diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for symbols +## 0.3.0.0 + +* Full ASCII range is supported (thanks @phadej) + ## 0.2.0.0 * added ToList, ToUpper, ToLower, ReadNat type families diff --git a/src/Data/Symbol/Ascii.hs b/src/Data/Symbol/Ascii.hs --- a/src/Data/Symbol/Ascii.hs +++ b/src/Data/Symbol/Ascii.hs @@ -20,39 +20,7 @@ ) where import GHC.TypeLits - --- | Compute the first character of a type-level symbol -type family Head (sym :: Symbol) :: Symbol where - Head "" = "" - Head sym = Lookup sym "" Chars - --- | Convert the symbol into a list of characters -type family ToList (sym :: Symbol) :: [Symbol] where - ToList sym = ToList1 sym Chars "" - --------------------------------------------------------------------------------- -data Tree a - = Leaf - | Node (Tree a) a (Tree a) - deriving Show - -type LookupTable = Tree (Symbol, Symbol) - -type family ToList1 (sym :: Symbol) (table :: LookupTable) (prefix :: Symbol) :: [Symbol] where - ToList1 sym table sym = '[] - ToList1 sym table prefix = Lookup sym prefix table ': ToList1 sym table (AppendSymbol prefix (Lookup sym prefix table)) - -type family Lookup (x :: Symbol) (prefix :: Symbol) (xs :: LookupTable) :: Symbol where - Lookup "" _ _ = "" - Lookup x "" (Node l '(cl, cr) r) = Lookup2 (CmpSymbol cl x) (CmpSymbol cr x) x "" cl l r - Lookup x prefix (Node l '(cl, cr) r) = Lookup2 (CmpSymbol (AppendSymbol prefix cl) x) (CmpSymbol (AppendSymbol prefix cr) x) x prefix cl l r - -type family Lookup2 ol or x prefix cl l r :: Symbol where - Lookup2 EQ _ _ _ cl _ _ = cl - Lookup2 LT GT _ _ cl _ r = cl - Lookup2 LT _ _ _ cl _ Leaf = cl -- for the last character (~) - Lookup2 LT _ x prefix _ _ r = Lookup x prefix r - Lookup2 GT _ x prefix _ l _ = Lookup x prefix l +import Data.Symbol.Ascii.Internal (Head, ToList) -------------------------------------------------------------------------------- @@ -160,105 +128,3 @@ ':<>: ShowType other ':<>: 'Text " is not a valid digit in " ':<>: ShowType orig) - --------------------------------------------------------------------------------- - --- | The search tree: each node contains two consecutive characters of --- the printable ASCII charset, and we're looking for the node where --- the first element is LT and the second element is GT than our --- symbol -type Chars - = 'Node - ('Node - ('Node - ('Node - ('Node - ('Node ('Node 'Leaf '(" ", "!") 'Leaf) '("!", "\"") 'Leaf) - '("\"", "#") - ('Node ('Node 'Leaf '("#", "$") 'Leaf) '("$", "%") 'Leaf)) - '("%", "&") - ('Node - ('Node ('Node 'Leaf '("&", "'") 'Leaf) '("'", "(") 'Leaf) - '("(", ")") - ('Node ('Node 'Leaf '(")", "*") 'Leaf) '("*", "+") 'Leaf))) - '("+", ",") - ('Node - ('Node - ('Node ('Node 'Leaf '(",", "-") 'Leaf) '("-", ".") 'Leaf) - '(".", "/") - ('Node ('Node 'Leaf '("/", "0") 'Leaf) '("0", "1") 'Leaf)) - '("1", "2") - ('Node - ('Node ('Node 'Leaf '("2", "3") 'Leaf) '("3", "4") 'Leaf) - '("4", "5") - ('Node ('Node 'Leaf '("5", "6") 'Leaf) '("6", "7") 'Leaf)))) - '("7", "8") - ('Node - ('Node - ('Node - ('Node ('Node 'Leaf '("8", "9") 'Leaf) '("9", ":") 'Leaf) - '(":", ";") - ('Node ('Node 'Leaf '(";", "<") 'Leaf) '("<", "=") 'Leaf)) - '("=", ">") - ('Node - ('Node ('Node 'Leaf '(">", "?") 'Leaf) '("?", "@") 'Leaf) - '("@", "A") - ('Node ('Node 'Leaf '("A", "B") 'Leaf) '("B", "C") 'Leaf))) - '("C", "D") - ('Node - ('Node - ('Node ('Node 'Leaf '("D", "E") 'Leaf) '("E", "F") 'Leaf) - '("F", "G") - ('Node ('Node 'Leaf '("G", "H") 'Leaf) '("H", "I") 'Leaf)) - '("I", "J") - ('Node - ('Node ('Node 'Leaf '("J", "K") 'Leaf) '("K", "L") 'Leaf) - '("L", "M") - ('Node ('Node 'Leaf '("M", "N") 'Leaf) '("N", "O") 'Leaf))))) - '("O", "P") - ('Node - ('Node - ('Node - ('Node - ('Node ('Node 'Leaf '("P", "Q") 'Leaf) '("Q", "R") 'Leaf) - '("R", "S") - ('Node ('Node 'Leaf '("S", "T") 'Leaf) '("T", "U") 'Leaf)) - '("U", "V") - ('Node - ('Node ('Node 'Leaf '("V", "W") 'Leaf) '("W", "X") 'Leaf) - '("X", "Y") - ('Node ('Node 'Leaf '("Y", "Z") 'Leaf) '("Z", "[") 'Leaf))) - '("[", "\\") - ('Node - ('Node - ('Node ('Node 'Leaf '("\\", "]") 'Leaf) '("]", "^") 'Leaf) - '("^", "_") - ('Node ('Node 'Leaf '("_", "`") 'Leaf) '("`", "a") 'Leaf)) - '("a", "b") - ('Node - ('Node ('Node 'Leaf '("b", "c") 'Leaf) '("c", "d") 'Leaf) - '("d", "e") - ('Node ('Node 'Leaf '("e", "f") 'Leaf) '("f", "g") 'Leaf)))) - '("g", "h") - ('Node - ('Node - ('Node - ('Node ('Node 'Leaf '("h", "i") 'Leaf) '("i", "j") 'Leaf) - '("j", "k") - ('Node ('Node 'Leaf '("k", "l") 'Leaf) '("l", "m") 'Leaf)) - '("m", "n") - ('Node - ('Node ('Node 'Leaf '("n", "o") 'Leaf) '("o", "p") 'Leaf) - '("p", "q") - ('Node ('Node 'Leaf '("q", "r") 'Leaf) '("r", "s") 'Leaf))) - '("s", "t") - ('Node - ('Node - ('Node ('Node 'Leaf '("t", "u") 'Leaf) '("u", "v") 'Leaf) - '("v", "w") - ('Node ('Node 'Leaf '("w", "x") 'Leaf) '("x", "y") 'Leaf)) - '("y", "z") - ('Node - ('Node ('Node 'Leaf '("z", "{") 'Leaf) '("{", "|") 'Leaf) - '("|", "}") - ('Node ('Node 'Leaf '("}", "~") 'Leaf) '("~", "~") 'Leaf))))) diff --git a/src/Data/Symbol/Ascii/Internal.hs b/src/Data/Symbol/Ascii/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Symbol/Ascii/Internal.hs @@ -0,0 +1,383 @@ +{-# 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"))))))) diff --git a/src/Data/Symbol/Examples/Printf.hs b/src/Data/Symbol/Examples/Printf.hs --- a/src/Data/Symbol/Examples/Printf.hs +++ b/src/Data/Symbol/Examples/Printf.hs @@ -14,6 +14,7 @@ import Data.Symbol.Utils import GHC.TypeLits import Data.Proxy +import Data.Monoid test :: String test = printf @"Wurble %d %d %s" 10 20 "foo" @@ -31,7 +32,7 @@ instance FormatF rest fun => FormatF (D ': rest) (Int -> fun) where formatF str i - = formatF @rest (str <> show i) + = formatF @rest (str Data.Monoid.<> show i) instance FormatF rest fun => FormatF (S ': rest) (String -> fun) where formatF str s diff --git a/symbols.cabal b/symbols.cabal --- a/symbols.cabal +++ b/symbols.cabal @@ -1,12 +1,12 @@ name: symbols -version: 0.2.0.3 +version: 0.3.0.0 synopsis: Symbol manipulation description: Utilities for manipulating type-level strings natively. license: BSD3 license-file: LICENSE author: Csongor Kiss maintainer: kiss.csongor.kiss@gmail.com --- copyright: +copyright: (c) 2018-2019 Csongor Kiss category: Dependent Types build-type: Simple extra-source-files: CHANGELOG.md @@ -21,8 +21,8 @@ exposed-modules: Data.Symbol.Ascii , Data.Symbol.Utils , Data.Symbol.Examples.Printf - -- other-modules: - -- other-extensions: - build-depends: base >=4.10 && <= 5.0 + other-modules: Data.Symbol.Ascii.Internal + build-depends: base >=4.10 && <5 hs-source-dirs: src + ghc-options: -Wall -Wno-unticked-promoted-constructors default-language: Haskell2010