symbols-0.3.0.0: src/Data/Symbol/Ascii/Internal.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Symbol.Ascii.Internal where
import Prelude hiding (head, lookup)
import Data.Char (chr)
import GHC.TypeLits (CmpSymbol, Symbol, AppendSymbol, ErrorMessage (..), TypeError)
#ifdef MIN_VERSION_QuickCheck
import Test.QuickCheck
#endif
-- $setup
-- >>> :set -XDataKinds
-------------------------------------------------------------------------------
-- term-level
-------------------------------------------------------------------------------
type M = Either String
head :: String -> M String
head "" = Right ""
head sym = head1 sym (compare sym "\128")
head1 :: String -> Ordering -> M String
head1 sym GT = Left $ "Starts with non-ASCII character " ++ sym
head1 sym _ = lookup sym "" chars
toList :: String -> M [String]
toList sym = toList1 sym ""
toList1 :: String -> String -> M [String]
toList1 x pfx
| x == pfx = Right []
| otherwise = toList2 x pfx (compare x (pfx ++ "\128"))
toList2 :: String -> String -> Ordering -> M [String]
toList2 x pfx LT = do
h <- lookup x pfx chars
t <- toList1 x (pfx ++ h)
return (h : t)
toList2 x pfx o = Left $ "Non-ASCII " ++ show (x, pfx, o)
lookup :: String -> String -> Tree String -> M String
lookup "" _ _ = Right ""
lookup _ _ (Leaf x) = Right x
lookup x "" (Node l c r) = lookup2 x "" c (compare x c) l r
lookup x pfx (Node l c r) = lookup2 x pfx c (compare x (pfx ++ c)) l r
lookup2 :: String -> String -> String -> Ordering -> Tree String -> Tree String -> M String
lookup2 x pfx c o l r = case o of
EQ -> Right c
LT -> lookup x pfx l
GT -> lookup x pfx r
#ifdef MIN_VERSION_QuickCheck
-- | >>> quickCheck head_prop
-- +++ OK, passed 100 tests:
-- ...
head_prop :: ASCIIString -> Property
head_prop (ASCIIString []) = label "empty" True
head_prop (ASCIIString xs@(x : _)) = label "non-empty" $ head xs === Right [x]
-- | >>> quickCheck headError_prop
-- +++ OK, passed 100 tests:
-- ...
headError_prop :: String -> Property
headError_prop [] = label "empty" True
headError_prop xs@(x : _)
| x < chr 128 = label "ascii" $ head xs === Right [x]
| otherwise = label "non-ascii" $ case head xs of
Left _ -> property True
Right res -> counterexample (show res) False
-- | >>> quickCheck toList_prop
-- +++ OK, passed 100 tests.
toList_prop :: ASCIIString -> Property
toList_prop (ASCIIString s) = toList s === Right (map (:[]) s)
-- | >>> quickCheck toListError_prop
-- +++ OK, passed 100 tests; ...
toListError_prop :: ASCIIString -> Char -> ASCIIString -> Property
toListError_prop (ASCIIString xs) y (ASCIIString zs) =
label (if ascii then "ascii" else "non-ascii") $
not ascii ==> case toList (xs ++ [y] ++ zs) of
Left _ -> property True
Right res -> counterexample (show res) False
where
ascii = y < chr 128
#endif
-------------------------------------------------------------------------------
-- type-level
-------------------------------------------------------------------------------
-- | Compute the first character of a type-level symbol
--
-- >>> :kind! Head "Example"
-- Head "Example" :: Symbol
-- = "E"
--
-- >>> :kind! Head ""
-- Head "" :: Symbol
-- = ""
--
-- 'Head' doesn't fail if the first character is ASCII, rest is irrelevant
--
-- >>> :kind! Head "123±456"
-- Head "123±456" :: Symbol
-- = "1"
--
-- 'Head' fails if the first character is non-ASCII
--
-- >>> :kind! Head "±123"
-- Head "±123" :: Symbol
-- = (TypeError ...)
--
type family Head (sym :: Symbol) :: Symbol where
Head "" = ""
Head sym = Head1 sym (CmpSymbol sym "\128")
-- | Convert the symbol into a list of characters
--
-- >>> :kind! ToList "ABC"
-- ToList "ABC" :: [Symbol]
-- = '["A", "B", "C"]
--
-- 'ToList' works only for ASCII strings
--
-- >>> :kind! ToList "123±456"
-- ToList "123±456" :: [Symbol]
-- = "1" : "2" : "3" : (TypeError ...)
--
type family ToList (sym :: Symbol) :: [Symbol] where
ToList sym = ToList1 sym ""
-------------------------------------------------------------------------------
type family Head1 (x :: Symbol) (o :: Ordering) :: Symbol where
Head1 x 'GT = TypeError ('Text "Starts with non-ASCII character " ':<>: ShowType x)
Head1 x _ = Lookup x "" Chars
type family ToList1 (x :: Symbol) (pfx :: Symbol) :: [Symbol] where
ToList1 x x = '[]
ToList1 x pfx = ToList2 x pfx (CmpSymbol x (AppendSymbol pfx "\128"))
type family ToList2 (x :: Symbol) (pfx :: Symbol) (o :: Ordering) :: [Symbol] where
ToList2 x pfx 'LT = Lookup x pfx Chars ': ToList1 x (AppendSymbol pfx (Lookup x pfx Chars))
ToList2 x _ _ = TypeError ('Text "Non-AScII character in " ':<>: ShowType x)
type family Lookup (x :: Symbol) (pfx :: Symbol) (xs :: Tree Symbol) :: Symbol where
Lookup "" _ _ = ""
Lookup _ _ ('Leaf x) = x
Lookup x "" ('Node l c r) = Lookup2 x "" c (CmpSymbol x c) l r
Lookup x pfx ('Node l c r) = Lookup2 x pfx c (CmpSymbol x (AppendSymbol pfx c)) l r
type family Lookup2 (x :: Symbol) (pfx :: Symbol) (c :: Symbol) (o :: Ordering) (l :: Tree Symbol) (r :: Tree Symbol) :: Symbol where
Lookup2 _ _ c 'EQ _ _ = c
Lookup2 x pfx c 'LT l _ = Lookup x pfx l
Lookup2 x pfx _ 'GT _ r = Lookup x pfx r
-------------------------------------------------------------------------------
-- Search Tree
-------------------------------------------------------------------------------
-- | The search tree. Each leaf contains final element.
data Tree a
= Leaf a
| Node (Tree a) a (Tree a)
deriving (Show)
chars :: Tree String
chars = buildTree [ chr c | c <- [0..0x7f] ] where
buildTree [] = error "panic! buildTree []"
buildTree [c] = Leaf [c]
buildTree pairs = Node (buildTree l) c (buildTree r) where
n = length pairs
(l, r) = splitAt (n `div` 2) pairs
c = case r of
[] -> error "panic! buildTree: r is empty"
(c':_) -> [c']
-- To print this tree using pretty-show
-- *Data.Symbol.Ascii.Internal Text.Show.Pretty Data.Maybe> valToDoc $ fromJust $ parseValue $ show chars
--
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")))))))