diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for symbols -## 0.1.0.0 -- YYYY-mm-dd +## 0.2.0.0 + +* added ToList, ToUpper, ToLower, ReadNat type families + +## 0.1.0.0 * First version. Released on an unsuspecting world. 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeInType #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE KindSignatures #-} @@ -7,6 +8,10 @@ module Data.Symbol.Ascii ( Head + , ToList + , ToUpper + , ToLower + , ReadNat ) where import GHC.TypeLits @@ -14,8 +19,13 @@ -- | Compute the first character of a type-level symbol type family Head (sym :: Symbol) :: Symbol where Head "" = "" - Head sym = Lookup sym Chars + 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) @@ -23,16 +33,121 @@ type LookupTable = Tree (Symbol, Symbol) -type family Lookup (x :: Symbol) (xs :: LookupTable) :: Symbol where - Lookup "" _ = "" - Lookup x (Node l '(cl, cr) r) = Lookup2 (CmpSymbol cl x) (CmpSymbol cr x) x cl l r +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 Lookup2 ol or x 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 _ _ r = Lookup x r - Lookup2 GT _ x _ l _ = Lookup x l +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 + +-------------------------------------------------------------------------------- + +-- | Convert the symbol to uppercase +type family ToUpper (sym :: Symbol) :: Symbol where + ToUpper sym = ToUpper1 (ToList sym) + +type family ToUpper1 (sym :: [Symbol]) :: Symbol where + ToUpper1 '[] = "" + ToUpper1 (x ': xs) = AppendSymbol (ToUpperC x) (ToUpper1 xs) + +type family ToUpperC (sym :: Symbol) :: Symbol where + ToUpperC "a" = "A" + ToUpperC "b" = "B" + ToUpperC "c" = "C" + ToUpperC "d" = "D" + ToUpperC "e" = "E" + ToUpperC "f" = "F" + ToUpperC "g" = "G" + ToUpperC "h" = "H" + ToUpperC "i" = "I" + ToUpperC "j" = "J" + ToUpperC "k" = "K" + ToUpperC "l" = "L" + ToUpperC "m" = "M" + ToUpperC "n" = "N" + ToUpperC "o" = "O" + ToUpperC "p" = "P" + ToUpperC "q" = "Q" + ToUpperC "r" = "R" + ToUpperC "s" = "S" + ToUpperC "t" = "T" + ToUpperC "u" = "U" + ToUpperC "v" = "V" + ToUpperC "w" = "W" + ToUpperC "x" = "X" + ToUpperC "y" = "Y" + ToUpperC "z" = "Z" + ToUpperC a = a +-------------------------------------------------------------------------------- + +-- | Convert the symbol to lowercase +type family ToLower (sym :: Symbol) :: Symbol where + ToLower sym = ToLower1 (ToList sym) + +type family ToLower1 (sym :: [Symbol]) :: Symbol where + ToLower1 '[] = "" + ToLower1 (x ': xs) = AppendSymbol (ToLowerC x) (ToLower1 xs) + +type family ToLowerC (sym :: Symbol) :: Symbol where + ToLowerC "A" = "a" + ToLowerC "B" = "b" + ToLowerC "C" = "c" + ToLowerC "D" = "d" + ToLowerC "E" = "e" + ToLowerC "F" = "f" + ToLowerC "G" = "g" + ToLowerC "H" = "h" + ToLowerC "I" = "i" + ToLowerC "J" = "j" + ToLowerC "K" = "k" + ToLowerC "L" = "l" + ToLowerC "M" = "m" + ToLowerC "N" = "n" + ToLowerC "O" = "o" + ToLowerC "P" = "p" + ToLowerC "Q" = "q" + ToLowerC "R" = "r" + ToLowerC "S" = "s" + ToLowerC "T" = "t" + ToLowerC "U" = "u" + ToLowerC "V" = "v" + ToLowerC "W" = "w" + ToLowerC "X" = "x" + ToLowerC "Y" = "y" + ToLowerC "Z" = "z" + ToLowerC a = a + +-------------------------------------------------------------------------------- +-- | Parse a natural number +type family ReadNat (sym :: Symbol) :: Nat where + ReadNat sym = ReadNat1 (ToList sym) 0 + +type family ReadNat1 (sym :: [Symbol]) (n :: Nat) :: Nat where + ReadNat1 '[] acc = acc + ReadNat1 (x ': xs) acc = ReadNat1 xs (acc * 10 + ReadDigit x) + +type family ReadDigit (sym :: Symbol) :: Nat where + ReadDigit "0" = 0 + ReadDigit "1" = 1 + ReadDigit "2" = 2 + ReadDigit "3" = 3 + ReadDigit "4" = 4 + ReadDigit "5" = 5 + ReadDigit "6" = 6 + ReadDigit "7" = 7 + ReadDigit "8" = 8 + ReadDigit "9" = 9 + +-------------------------------------------------------------------------------- -- | The search tree: each node contains two consecutive characters of -- the printable ASCII charset, and we're looking for the node where diff --git a/symbols.cabal b/symbols.cabal --- a/symbols.cabal +++ b/symbols.cabal @@ -1,8 +1,5 @@ --- Initial symbols.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - name: symbols -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Symbol manipulation description: Utilities for manipulating type-level strings natively. license: BSD3 @@ -15,6 +12,10 @@ extra-source-files: CHANGELOG.md , README.md cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/kcsongor/symbols library exposed-modules: Data.Symbol.Ascii