{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -Werror=incomplete-patterns #-}
module Fcf.Data.Text.Internal where
import Data.Char (chr)
import qualified GHC.TypeLits as TL
import qualified Fcf.Data.List as L
import Fcf.Data.Bitree
import qualified Fcf.Alg.Symbol as S
import Fcf
type LookupTable = Tree (TL.Symbol, TL.Symbol)
type family Head2 (sym :: TL.Symbol) :: TL.Symbol where
Head2 "" = ""
Head2 sym = Head1 sym (TL.CmpSymbol sym "\128")
type family ToList (sym :: TL.Symbol) :: [TL.Symbol] where
ToList sym = ToList1 sym ""
data ToSymbol2 :: [TL.Symbol] -> Exp TL.Symbol
type instance Eval (ToSymbol2 lst) = Eval (Foldr S.Append "" lst)
data HeadA :: TL.Symbol -> Exp TL.Symbol
type instance Eval (HeadA sym) = Head1 sym (TL.CmpSymbol sym "\128")
data ToListA :: TL.Symbol -> Exp [TL.Symbol]
type instance Eval (ToListA sym) = ToList1 sym ""
data Uncons :: TL.Symbol -> Exp (Maybe TL.Symbol)
type instance Eval (Uncons sym) = Eval (Map ToSymbol2 =<< L.Tail =<< ToListA sym)
type family Head1 (x :: TL.Symbol) (o :: Ordering) :: TL.Symbol where
Head1 x 'GT = TL.TypeError ('TL.Text "Starts with non-ASCII character " 'TL.:<>: 'TL.ShowType x)
Head1 x _ = LookupA x "" Chars
type family ToList1 (x :: TL.Symbol) (pfx :: TL.Symbol) :: [TL.Symbol] where
ToList1 x x = '[]
ToList1 x pfx = ToList2 x pfx (TL.CmpSymbol x (TL.AppendSymbol pfx "\128"))
type family ToList2 (x :: TL.Symbol) (pfx :: TL.Symbol) (o :: Ordering) :: [TL.Symbol] where
ToList2 x pfx 'LT = LookupA x pfx Chars ': ToList1 x (TL.AppendSymbol pfx (LookupA x pfx Chars))
ToList2 x _ _ = TL.TypeError ('TL.Text "Non-AScII character in " 'TL.:<>: 'TL.ShowType x)
type family LookupA (x :: TL.Symbol) (pfx :: TL.Symbol) (xs :: Tree TL.Symbol) :: TL.Symbol where
LookupA "" _ _ = ""
LookupA _ _ ('Leaf x) = x
LookupA x "" ('Node l c r) = Lookup2 x "" c (TL.CmpSymbol x c) l r
LookupA x pfx ('Node l c r) = Lookup2 x pfx c (TL.CmpSymbol x (TL.AppendSymbol pfx c)) l r
type family Lookup2 (x :: TL.Symbol) (pfx :: TL.Symbol) (c :: TL.Symbol) (o :: Ordering) (l :: Tree TL.Symbol) (r :: Tree TL.Symbol) :: TL.Symbol where
Lookup2 _ _ c 'EQ _ _ = c
Lookup2 x pfx c 'LT l _ = LookupA x pfx l
Lookup2 x pfx _ 'GT _ r = LookupA x pfx r
chars :: Tree String
chars :: Tree String
chars = String -> Tree String
forall a. [a] -> Tree [a]
buildTree [ Int -> Char
chr Int
c | Int
c <- [Int
0..Int
0x7f] ] where
buildTree :: [a] -> Tree [a]
buildTree [] = String -> Tree [a]
forall a. HasCallStack => String -> a
error String
"panic! buildTree []"
buildTree [a
c] = [a] -> Tree [a]
forall a. a -> Tree a
Leaf [a
c]
buildTree [a]
pairs = Tree [a] -> [a] -> Tree [a] -> Tree [a]
forall a. Tree a -> a -> Tree a -> Tree a
Node ([a] -> Tree [a]
buildTree [a]
l) [a]
c ([a] -> Tree [a]
buildTree [a]
r) where
n :: Int
n = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
pairs
([a]
l, [a]
r) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) [a]
pairs
c :: [a]
c = case [a]
r of
[] -> String -> [a]
forall a. HasCallStack => String -> a
error String
"panic! buildTree: r is empty"
(a
c':[a]
_) -> [a
c']
type Chars = 'Node
('Node
('Node
('Node
('Node
('Node
('Node ('Leaf "\NUL") "\SOH" ('Leaf "\SOH"))
"\STX"
('Node ('Leaf "\STX") "\ETX" ('Leaf "\ETX")))
"\EOT"
('Node
('Node ('Leaf "\EOT") "\ENQ" ('Leaf "\ENQ"))
"\ACK"
('Node ('Leaf "\ACK") "\a" ('Leaf "\a"))))
"\b"
('Node
('Node
('Node ('Leaf "\b") "\t" ('Leaf "\t"))
"\n"
('Node ('Leaf "\n") "\v" ('Leaf "\v")))
"\f"
('Node
('Node ('Leaf "\f") "\r" ('Leaf "\r"))
"\SO"
('Node ('Leaf "\SO") "\SI" ('Leaf "\SI")))))
"\DLE"
('Node
('Node
('Node
('Node ('Leaf "\DLE") "\DC1" ('Leaf "\DC1"))
"\DC2"
('Node ('Leaf "\DC2") "\DC3" ('Leaf "\DC3")))
"\DC4"
('Node
('Node ('Leaf "\DC4") "\NAK" ('Leaf "\NAK"))
"\SYN"
('Node ('Leaf "\SYN") "\ETB" ('Leaf "\ETB"))))
"\CAN"
('Node
('Node
('Node ('Leaf "\CAN") "\EM" ('Leaf "\EM"))
"\SUB"
('Node ('Leaf "\SUB") "\ESC" ('Leaf "\ESC")))
"\FS"
('Node
('Node ('Leaf "\FS") "\GS" ('Leaf "\GS"))
"\RS"
('Node ('Leaf "\RS") "\US" ('Leaf "\US"))))))
" "
('Node
('Node
('Node
('Node
('Node ('Leaf " ") "!" ('Leaf "!"))
"\""
('Node ('Leaf "\"") "#" ('Leaf "#")))
"$"
('Node
('Node ('Leaf "$") "%" ('Leaf "%"))
"&"
('Node ('Leaf "&") "'" ('Leaf "'"))))
"("
('Node
('Node
('Node ('Leaf "(") ")" ('Leaf ")"))
"*"
('Node ('Leaf "*") "+" ('Leaf "+")))
","
('Node
('Node ('Leaf ",") "-" ('Leaf "-"))
"."
('Node ('Leaf ".") "/" ('Leaf "/")))))
"0"
('Node
('Node
('Node
('Node ('Leaf "0") "1" ('Leaf "1"))
"2"
('Node ('Leaf "2") "3" ('Leaf "3")))
"4"
('Node
('Node ('Leaf "4") "5" ('Leaf "5"))
"6"
('Node ('Leaf "6") "7" ('Leaf "7"))))
"8"
('Node
('Node
('Node ('Leaf "8") "9" ('Leaf "9"))
":"
('Node ('Leaf ":") ";" ('Leaf ";")))
"<"
('Node
('Node ('Leaf "<") "=" ('Leaf "="))
">"
('Node ('Leaf ">") "?" ('Leaf "?")))))))
"@"
('Node
('Node
('Node
('Node
('Node
('Node ('Leaf "@") "A" ('Leaf "A"))
"B"
('Node ('Leaf "B") "C" ('Leaf "C")))
"D"
('Node
('Node ('Leaf "D") "E" ('Leaf "E"))
"F"
('Node ('Leaf "F") "G" ('Leaf "G"))))
"H"
('Node
('Node
('Node ('Leaf "H") "I" ('Leaf "I"))
"J"
('Node ('Leaf "J") "K" ('Leaf "K")))
"L"
('Node
('Node ('Leaf "L") "M" ('Leaf "M"))
"N"
('Node ('Leaf "N") "O" ('Leaf "O")))))
"P"
('Node
('Node
('Node
('Node ('Leaf "P") "Q" ('Leaf "Q"))
"R"
('Node ('Leaf "R") "S" ('Leaf "S")))
"T"
('Node
('Node ('Leaf "T") "U" ('Leaf "U"))
"V"
('Node ('Leaf "V") "W" ('Leaf "W"))))
"X"
('Node
('Node
('Node ('Leaf "X") "Y" ('Leaf "Y"))
"Z"
('Node ('Leaf "Z") "[" ('Leaf "[")))
"\\"
('Node
('Node ('Leaf "\\") "]" ('Leaf "]"))
"^"
('Node ('Leaf "^") "_" ('Leaf "_"))))))
"`"
('Node
('Node
('Node
('Node
('Node ('Leaf "`") "a" ('Leaf "a"))
"b"
('Node ('Leaf "b") "c" ('Leaf "c")))
"d"
('Node
('Node ('Leaf "d") "e" ('Leaf "e"))
"f"
('Node ('Leaf "f") "g" ('Leaf "g"))))
"h"
('Node
('Node
('Node ('Leaf "h") "i" ('Leaf "i"))
"j"
('Node ('Leaf "j") "k" ('Leaf "k")))
"l"
('Node
('Node ('Leaf "l") "m" ('Leaf "m"))
"n"
('Node ('Leaf "n") "o" ('Leaf "o")))))
"p"
('Node
('Node
('Node
('Node ('Leaf "p") "q" ('Leaf "q"))
"r"
('Node ('Leaf "r") "s" ('Leaf "s")))
"t"
('Node
('Node ('Leaf "t") "u" ('Leaf "u"))
"v"
('Node ('Leaf "v") "w" ('Leaf "w"))))
"x"
('Node
('Node
('Node ('Leaf "x") "y" ('Leaf "y"))
"z"
('Node ('Leaf "z") "{" ('Leaf "{")))
"|"
('Node
('Node ('Leaf "|") "}" ('Leaf "}"))
"~"
('Node ('Leaf "~") "\DEL" ('Leaf "\DEL")))))))