├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── flake.lock ├── flake.nix ├── src └── Data │ └── Symbol │ ├── Ascii.hs │ ├── Ascii │ └── Internal.hs │ ├── Examples │ └── Printf.hs │ └── Utils.hs └── symbols.cabal /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | TAGS 3 | dist* 4 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for symbols 2 | 3 | ## 0.3.0.0 4 | 5 | * Full ASCII range is supported (thanks @phadej) 6 | 7 | ## 0.2.0.0 8 | 9 | * added ToList, ToUpper, ToLower, ReadNat type families 10 | 11 | ## 0.1.0.0 12 | 13 | * First version. Released on an unsuspecting world. 14 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018, Csongor Kiss 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Csongor Kiss nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # symbols 2 | 3 | Manipulate type-level strings. 4 | 5 | Available on [Hackage](https://hackage.haskell.org/package/symbols) 6 | 7 | The implementation is described in [this blog post](https://kcsongor.github.io/symbol-parsing-haskell/). 8 | 9 | ## Contribute 10 | 11 | ### Nix 12 | 13 | You can use a [Nix flake](https://nixos.wiki/wiki/Flakes) from this repo to get several development tools. 14 | 15 | 1. [Enable flakes](https://nixos.wiki/wiki/Flakes#Enable_flakes). 16 | 17 | 2. Run `nix develop`. This command will make available `cabal`, `ghc`, and `haskell-language-server`. 18 | 19 | 3. Run `cabal build` to build the project. 20 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-utils": { 4 | "inputs": { 5 | "systems": "systems" 6 | }, 7 | "locked": { 8 | "lastModified": 1681202837, 9 | "narHash": "sha256-H+Rh19JDwRtpVPAWp64F+rlEtxUWBAQW28eAi3SRSzg=", 10 | "owner": "numtide", 11 | "repo": "flake-utils", 12 | "rev": "cfacdce06f30d2b68473a46042957675eebb3401", 13 | "type": "github" 14 | }, 15 | "original": { 16 | "owner": "numtide", 17 | "repo": "flake-utils", 18 | "rev": "cfacdce06f30d2b68473a46042957675eebb3401", 19 | "type": "github" 20 | } 21 | }, 22 | "nixpkgs": { 23 | "locked": { 24 | "lastModified": 1681184417, 25 | "narHash": "sha256-hEYKxuO9gQkeCdyhgvH/Jhs2bkAFyUBALCFiaT5IQE0=", 26 | "owner": "NixOS", 27 | "repo": "nixpkgs", 28 | "rev": "1fb781f4a148c19e9da1d35a4cbe15d0158afc4e", 29 | "type": "github" 30 | }, 31 | "original": { 32 | "owner": "NixOS", 33 | "repo": "nixpkgs", 34 | "rev": "1fb781f4a148c19e9da1d35a4cbe15d0158afc4e", 35 | "type": "github" 36 | } 37 | }, 38 | "root": { 39 | "inputs": { 40 | "flake-utils": "flake-utils", 41 | "nixpkgs": "nixpkgs" 42 | } 43 | }, 44 | "systems": { 45 | "locked": { 46 | "lastModified": 1681028828, 47 | "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 48 | "owner": "nix-systems", 49 | "repo": "default", 50 | "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 51 | "type": "github" 52 | }, 53 | "original": { 54 | "owner": "nix-systems", 55 | "repo": "default", 56 | "type": "github" 57 | } 58 | } 59 | }, 60 | "root": "root", 61 | "version": 7 62 | } 63 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | inputs = { 3 | flake-utils.url = "github:numtide/flake-utils/cfacdce06f30d2b68473a46042957675eebb3401"; 4 | nixpkgs.url = "github:NixOS/nixpkgs/1fb781f4a148c19e9da1d35a4cbe15d0158afc4e"; 5 | }; 6 | outputs = inputs: inputs.flake-utils.lib.eachDefaultSystem (system: 7 | let 8 | pkgs = inputs.nixpkgs.legacyPackages.${system}; 9 | 10 | packageName = "symbols"; 11 | override = { overrides = self: super: { "${packageName}" = self.callCabal2nix packageName ./. { }; }; }; 12 | ghcVersion = "ghc927"; 13 | hpkgs = pkgs.haskell.packages.${ghcVersion}; 14 | getHaskellPackagesDeps = someHaskellPackages: with pkgs.lib.lists; (subtractLists someHaskellPackages (concatLists (map (package: concatLists (__attrValues package.getCabalDeps)) someHaskellPackages))); 15 | ghcForPackages = hpkgs_: override_: localHaskellPackageNames: (hpkgs_.override override_).ghcWithPackages (ps: getHaskellPackagesDeps (map (x: ps.${x}) localHaskellPackageNames)); 16 | ghc = ghcForPackages hpkgs override [ packageName ]; 17 | 18 | tools = [ 19 | pkgs.cabal-install 20 | # ghc should go before haskell-language-server - https://github.com/NixOS/nixpkgs/issues/225895 21 | ghc 22 | hpkgs.haskell-language-server 23 | ]; 24 | 25 | devShells.default = pkgs.mkShell { 26 | buildInputs = tools; 27 | }; 28 | in 29 | { 30 | inherit devShells; 31 | }); 32 | } 33 | -------------------------------------------------------------------------------- /src/Data/Symbol/Ascii.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | {-# LANGUAGE TypeInType #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE DataKinds #-} 7 | {-# LANGUAGE CPP #-} 8 | 9 | #if __GLASGOW_HASKELL__ >= 806 10 | {-# LANGUAGE NoStarIsType #-} 11 | #endif 12 | 13 | module Data.Symbol.Ascii 14 | ( 15 | Head 16 | , ToList 17 | , ToUpper 18 | , ToLower 19 | , ReadNat 20 | ) where 21 | 22 | import GHC.TypeLits 23 | import Data.Symbol.Ascii.Internal (Head, ToList) 24 | 25 | -------------------------------------------------------------------------------- 26 | 27 | -- | Convert the symbol to uppercase 28 | type family ToUpper (sym :: Symbol) :: Symbol where 29 | ToUpper sym = ToUpper1 (ToList sym) 30 | 31 | type family ToUpper1 (sym :: [Symbol]) :: Symbol where 32 | ToUpper1 '[] = "" 33 | ToUpper1 (x ': xs) = AppendSymbol (ToUpperC x) (ToUpper1 xs) 34 | 35 | type family ToUpperC (sym :: Symbol) :: Symbol where 36 | ToUpperC "a" = "A" 37 | ToUpperC "b" = "B" 38 | ToUpperC "c" = "C" 39 | ToUpperC "d" = "D" 40 | ToUpperC "e" = "E" 41 | ToUpperC "f" = "F" 42 | ToUpperC "g" = "G" 43 | ToUpperC "h" = "H" 44 | ToUpperC "i" = "I" 45 | ToUpperC "j" = "J" 46 | ToUpperC "k" = "K" 47 | ToUpperC "l" = "L" 48 | ToUpperC "m" = "M" 49 | ToUpperC "n" = "N" 50 | ToUpperC "o" = "O" 51 | ToUpperC "p" = "P" 52 | ToUpperC "q" = "Q" 53 | ToUpperC "r" = "R" 54 | ToUpperC "s" = "S" 55 | ToUpperC "t" = "T" 56 | ToUpperC "u" = "U" 57 | ToUpperC "v" = "V" 58 | ToUpperC "w" = "W" 59 | ToUpperC "x" = "X" 60 | ToUpperC "y" = "Y" 61 | ToUpperC "z" = "Z" 62 | ToUpperC a = a 63 | -------------------------------------------------------------------------------- 64 | 65 | -- | Convert the symbol to lowercase 66 | type family ToLower (sym :: Symbol) :: Symbol where 67 | ToLower sym = ToLower1 (ToList sym) 68 | 69 | type family ToLower1 (sym :: [Symbol]) :: Symbol where 70 | ToLower1 '[] = "" 71 | ToLower1 (x ': xs) = AppendSymbol (ToLowerC x) (ToLower1 xs) 72 | 73 | type family ToLowerC (sym :: Symbol) :: Symbol where 74 | ToLowerC "A" = "a" 75 | ToLowerC "B" = "b" 76 | ToLowerC "C" = "c" 77 | ToLowerC "D" = "d" 78 | ToLowerC "E" = "e" 79 | ToLowerC "F" = "f" 80 | ToLowerC "G" = "g" 81 | ToLowerC "H" = "h" 82 | ToLowerC "I" = "i" 83 | ToLowerC "J" = "j" 84 | ToLowerC "K" = "k" 85 | ToLowerC "L" = "l" 86 | ToLowerC "M" = "m" 87 | ToLowerC "N" = "n" 88 | ToLowerC "O" = "o" 89 | ToLowerC "P" = "p" 90 | ToLowerC "Q" = "q" 91 | ToLowerC "R" = "r" 92 | ToLowerC "S" = "s" 93 | ToLowerC "T" = "t" 94 | ToLowerC "U" = "u" 95 | ToLowerC "V" = "v" 96 | ToLowerC "W" = "w" 97 | ToLowerC "X" = "x" 98 | ToLowerC "Y" = "y" 99 | ToLowerC "Z" = "z" 100 | ToLowerC a = a 101 | 102 | -------------------------------------------------------------------------------- 103 | -- | Parse a natural number 104 | type family ReadNat (sym :: Symbol) :: Nat where 105 | ReadNat sym = ReadNat1 sym (ToList sym) 106 | 107 | type family ReadNat1 (orig :: Symbol) (sym :: [Symbol]) :: Nat where 108 | ReadNat1 _ '[] = TypeError ('Text "Parse error: empty string") 109 | ReadNat1 orig xs = ReadNat2 orig xs 0 110 | 111 | type family ReadNat2 (orgin :: Symbol) (sym :: [Symbol]) (n :: Nat) :: Nat where 112 | ReadNat2 orig '[] acc = acc 113 | ReadNat2 orig (x ': xs) acc = ReadNat2 orig xs (10 * acc + ReadDigit orig x) 114 | 115 | type family ReadDigit (orig :: Symbol) (sym :: Symbol) :: Nat where 116 | ReadDigit _ "0" = 0 117 | ReadDigit _ "1" = 1 118 | ReadDigit _ "2" = 2 119 | ReadDigit _ "3" = 3 120 | ReadDigit _ "4" = 4 121 | ReadDigit _ "5" = 5 122 | ReadDigit _ "6" = 6 123 | ReadDigit _ "7" = 7 124 | ReadDigit _ "8" = 8 125 | ReadDigit _ "9" = 9 126 | ReadDigit orig other = 127 | TypeError ('Text "Parse error: " 128 | ':<>: ShowType other 129 | ':<>: 'Text " is not a valid digit in " 130 | ':<>: ShowType orig) 131 | -------------------------------------------------------------------------------- /src/Data/Symbol/Ascii/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | module Data.Symbol.Ascii.Internal where 8 | 9 | import Prelude hiding (head, lookup) 10 | 11 | import Data.Char (chr) 12 | import GHC.TypeLits (CmpSymbol, Symbol, AppendSymbol, ErrorMessage (..), TypeError) 13 | 14 | #ifdef MIN_VERSION_QuickCheck 15 | import Test.QuickCheck 16 | #endif 17 | 18 | -- $setup 19 | -- >>> :set -XDataKinds 20 | 21 | ------------------------------------------------------------------------------- 22 | -- term-level 23 | ------------------------------------------------------------------------------- 24 | 25 | type M = Either String 26 | 27 | head :: String -> M String 28 | head "" = Right "" 29 | head sym = head1 sym (compare sym "\128") 30 | 31 | head1 :: String -> Ordering -> M String 32 | head1 sym GT = Left $ "Starts with non-ASCII character " ++ sym 33 | head1 sym _ = lookup sym "" chars 34 | 35 | toList :: String -> M [String] 36 | toList sym = toList1 sym "" 37 | 38 | toList1 :: String -> String -> M [String] 39 | toList1 x pfx 40 | | x == pfx = Right [] 41 | | otherwise = toList2 x pfx (compare x (pfx ++ "\128")) 42 | 43 | toList2 :: String -> String -> Ordering -> M [String] 44 | toList2 x pfx LT = do 45 | h <- lookup x pfx chars 46 | t <- toList1 x (pfx ++ h) 47 | return (h : t) 48 | toList2 x pfx o = Left $ "Non-ASCII " ++ show (x, pfx, o) 49 | 50 | lookup :: String -> String -> Tree String -> M String 51 | lookup "" _ _ = Right "" 52 | lookup _ _ (Leaf x) = Right x 53 | lookup x "" (Node l c r) = lookup2 x "" c (compare x c) l r 54 | lookup x pfx (Node l c r) = lookup2 x pfx c (compare x (pfx ++ c)) l r 55 | 56 | lookup2 :: String -> String -> String -> Ordering -> Tree String -> Tree String -> M String 57 | lookup2 x pfx c o l r = case o of 58 | EQ -> Right c 59 | LT -> lookup x pfx l 60 | GT -> lookup x pfx r 61 | 62 | #ifdef MIN_VERSION_QuickCheck 63 | 64 | -- | >>> quickCheck head_prop 65 | -- +++ OK, passed 100 tests: 66 | -- ... 67 | head_prop :: ASCIIString -> Property 68 | head_prop (ASCIIString []) = label "empty" True 69 | head_prop (ASCIIString xs@(x : _)) = label "non-empty" $ head xs === Right [x] 70 | 71 | -- | >>> quickCheck headError_prop 72 | -- +++ OK, passed 100 tests: 73 | -- ... 74 | headError_prop :: String -> Property 75 | headError_prop [] = label "empty" True 76 | headError_prop xs@(x : _) 77 | | x < chr 128 = label "ascii" $ head xs === Right [x] 78 | | otherwise = label "non-ascii" $ case head xs of 79 | Left _ -> property True 80 | Right res -> counterexample (show res) False 81 | 82 | -- | >>> quickCheck toList_prop 83 | -- +++ OK, passed 100 tests. 84 | toList_prop :: ASCIIString -> Property 85 | toList_prop (ASCIIString s) = toList s === Right (map (:[]) s) 86 | 87 | -- | >>> quickCheck toListError_prop 88 | -- +++ OK, passed 100 tests; ... 89 | toListError_prop :: ASCIIString -> Char -> ASCIIString -> Property 90 | toListError_prop (ASCIIString xs) y (ASCIIString zs) = 91 | label (if ascii then "ascii" else "non-ascii") $ 92 | not ascii ==> case toList (xs ++ [y] ++ zs) of 93 | Left _ -> property True 94 | Right res -> counterexample (show res) False 95 | where 96 | ascii = y < chr 128 97 | 98 | #endif 99 | 100 | ------------------------------------------------------------------------------- 101 | -- type-level 102 | ------------------------------------------------------------------------------- 103 | 104 | -- | Compute the first character of a type-level symbol 105 | -- 106 | -- >>> :kind! Head "Example" 107 | -- Head "Example" :: Symbol 108 | -- = "E" 109 | -- 110 | -- >>> :kind! Head "" 111 | -- Head "" :: Symbol 112 | -- = "" 113 | -- 114 | -- 'Head' doesn't fail if the first character is ASCII, rest is irrelevant 115 | -- 116 | -- >>> :kind! Head "123±456" 117 | -- Head "123±456" :: Symbol 118 | -- = "1" 119 | -- 120 | -- 'Head' fails if the first character is non-ASCII 121 | -- 122 | -- >>> :kind! Head "±123" 123 | -- Head "±123" :: Symbol 124 | -- = (TypeError ...) 125 | -- 126 | type family Head (sym :: Symbol) :: Symbol where 127 | Head "" = "" 128 | Head sym = Head1 sym (CmpSymbol sym "\128") 129 | 130 | -- | Convert the symbol into a list of characters 131 | -- 132 | -- >>> :kind! ToList "ABC" 133 | -- ToList "ABC" :: [Symbol] 134 | -- = '["A", "B", "C"] 135 | -- 136 | -- 'ToList' works only for ASCII strings 137 | -- 138 | -- >>> :kind! ToList "123±456" 139 | -- ToList "123±456" :: [Symbol] 140 | -- = "1" : "2" : "3" : (TypeError ...) 141 | -- 142 | type family ToList (sym :: Symbol) :: [Symbol] where 143 | ToList sym = ToList1 sym "" 144 | 145 | ------------------------------------------------------------------------------- 146 | 147 | type family Head1 (x :: Symbol) (o :: Ordering) :: Symbol where 148 | Head1 x 'GT = TypeError ('Text "Starts with non-ASCII character " ':<>: ShowType x) 149 | Head1 x _ = Lookup x "" Chars 150 | 151 | type family ToList1 (x :: Symbol) (pfx :: Symbol) :: [Symbol] where 152 | ToList1 x x = '[] 153 | ToList1 x pfx = ToList2 x pfx (CmpSymbol x (AppendSymbol pfx "\128")) 154 | 155 | type family ToList2 (x :: Symbol) (pfx :: Symbol) (o :: Ordering) :: [Symbol] where 156 | ToList2 x pfx 'LT = Lookup x pfx Chars ': ToList1 x (AppendSymbol pfx (Lookup x pfx Chars)) 157 | ToList2 x _ _ = TypeError ('Text "Non-AScII character in " ':<>: ShowType x) 158 | 159 | type family Lookup (x :: Symbol) (pfx :: Symbol) (xs :: Tree Symbol) :: Symbol where 160 | Lookup "" _ _ = "" 161 | Lookup _ _ ('Leaf x) = x 162 | Lookup x "" ('Node l c r) = Lookup2 x "" c (CmpSymbol x c) l r 163 | Lookup x pfx ('Node l c r) = Lookup2 x pfx c (CmpSymbol x (AppendSymbol pfx c)) l r 164 | 165 | type family Lookup2 (x :: Symbol) (pfx :: Symbol) (c :: Symbol) (o :: Ordering) (l :: Tree Symbol) (r :: Tree Symbol) :: Symbol where 166 | Lookup2 _ _ c 'EQ _ _ = c 167 | Lookup2 x pfx c 'LT l _ = Lookup x pfx l 168 | Lookup2 x pfx _ 'GT _ r = Lookup x pfx r 169 | 170 | ------------------------------------------------------------------------------- 171 | -- Search Tree 172 | ------------------------------------------------------------------------------- 173 | 174 | -- | The search tree. Each leaf contains final element. 175 | data Tree a 176 | = Leaf a 177 | | Node (Tree a) a (Tree a) 178 | deriving (Show) 179 | 180 | chars :: Tree String 181 | chars = buildTree [ chr c | c <- [0..0x7f] ] where 182 | buildTree [] = error "panic! buildTree []" 183 | buildTree [c] = Leaf [c] 184 | buildTree pairs = Node (buildTree l) c (buildTree r) where 185 | n = length pairs 186 | (l, r) = splitAt (n `div` 2) pairs 187 | c = case r of 188 | [] -> error "panic! buildTree: r is empty" 189 | (c':_) -> [c'] 190 | 191 | -- To print this tree using pretty-show 192 | -- *Data.Symbol.Ascii.Internal Text.Show.Pretty Data.Maybe> valToDoc $ fromJust $ parseValue $ show chars 193 | -- 194 | type Chars = Node 195 | (Node 196 | (Node 197 | (Node 198 | (Node 199 | (Node 200 | (Node (Leaf "\NUL") "\SOH" (Leaf "\SOH")) 201 | "\STX" 202 | (Node (Leaf "\STX") "\ETX" (Leaf "\ETX"))) 203 | "\EOT" 204 | (Node 205 | (Node (Leaf "\EOT") "\ENQ" (Leaf "\ENQ")) 206 | "\ACK" 207 | (Node (Leaf "\ACK") "\a" (Leaf "\a")))) 208 | "\b" 209 | (Node 210 | (Node 211 | (Node (Leaf "\b") "\t" (Leaf "\t")) 212 | "\n" 213 | (Node (Leaf "\n") "\v" (Leaf "\v"))) 214 | "\f" 215 | (Node 216 | (Node (Leaf "\f") "\r" (Leaf "\r")) 217 | "\SO" 218 | (Node (Leaf "\SO") "\SI" (Leaf "\SI"))))) 219 | "\DLE" 220 | (Node 221 | (Node 222 | (Node 223 | (Node (Leaf "\DLE") "\DC1" (Leaf "\DC1")) 224 | "\DC2" 225 | (Node (Leaf "\DC2") "\DC3" (Leaf "\DC3"))) 226 | "\DC4" 227 | (Node 228 | (Node (Leaf "\DC4") "\NAK" (Leaf "\NAK")) 229 | "\SYN" 230 | (Node (Leaf "\SYN") "\ETB" (Leaf "\ETB")))) 231 | "\CAN" 232 | (Node 233 | (Node 234 | (Node (Leaf "\CAN") "\EM" (Leaf "\EM")) 235 | "\SUB" 236 | (Node (Leaf "\SUB") "\ESC" (Leaf "\ESC"))) 237 | "\FS" 238 | (Node 239 | (Node (Leaf "\FS") "\GS" (Leaf "\GS")) 240 | "\RS" 241 | (Node (Leaf "\RS") "\US" (Leaf "\US")))))) 242 | " " 243 | (Node 244 | (Node 245 | (Node 246 | (Node 247 | (Node (Leaf " ") "!" (Leaf "!")) 248 | "\"" 249 | (Node (Leaf "\"") "#" (Leaf "#"))) 250 | "$" 251 | (Node 252 | (Node (Leaf "$") "%" (Leaf "%")) 253 | "&" 254 | (Node (Leaf "&") "'" (Leaf "'")))) 255 | "(" 256 | (Node 257 | (Node 258 | (Node (Leaf "(") ")" (Leaf ")")) 259 | "*" 260 | (Node (Leaf "*") "+" (Leaf "+"))) 261 | "," 262 | (Node 263 | (Node (Leaf ",") "-" (Leaf "-")) 264 | "." 265 | (Node (Leaf ".") "/" (Leaf "/"))))) 266 | "0" 267 | (Node 268 | (Node 269 | (Node 270 | (Node (Leaf "0") "1" (Leaf "1")) 271 | "2" 272 | (Node (Leaf "2") "3" (Leaf "3"))) 273 | "4" 274 | (Node 275 | (Node (Leaf "4") "5" (Leaf "5")) 276 | "6" 277 | (Node (Leaf "6") "7" (Leaf "7")))) 278 | "8" 279 | (Node 280 | (Node 281 | (Node (Leaf "8") "9" (Leaf "9")) 282 | ":" 283 | (Node (Leaf ":") ";" (Leaf ";"))) 284 | "<" 285 | (Node 286 | (Node (Leaf "<") "=" (Leaf "=")) 287 | ">" 288 | (Node (Leaf ">") "?" (Leaf "?"))))))) 289 | "@" 290 | (Node 291 | (Node 292 | (Node 293 | (Node 294 | (Node 295 | (Node (Leaf "@") "A" (Leaf "A")) 296 | "B" 297 | (Node (Leaf "B") "C" (Leaf "C"))) 298 | "D" 299 | (Node 300 | (Node (Leaf "D") "E" (Leaf "E")) 301 | "F" 302 | (Node (Leaf "F") "G" (Leaf "G")))) 303 | "H" 304 | (Node 305 | (Node 306 | (Node (Leaf "H") "I" (Leaf "I")) 307 | "J" 308 | (Node (Leaf "J") "K" (Leaf "K"))) 309 | "L" 310 | (Node 311 | (Node (Leaf "L") "M" (Leaf "M")) 312 | "N" 313 | (Node (Leaf "N") "O" (Leaf "O"))))) 314 | "P" 315 | (Node 316 | (Node 317 | (Node 318 | (Node (Leaf "P") "Q" (Leaf "Q")) 319 | "R" 320 | (Node (Leaf "R") "S" (Leaf "S"))) 321 | "T" 322 | (Node 323 | (Node (Leaf "T") "U" (Leaf "U")) 324 | "V" 325 | (Node (Leaf "V") "W" (Leaf "W")))) 326 | "X" 327 | (Node 328 | (Node 329 | (Node (Leaf "X") "Y" (Leaf "Y")) 330 | "Z" 331 | (Node (Leaf "Z") "[" (Leaf "["))) 332 | "\\" 333 | (Node 334 | (Node (Leaf "\\") "]" (Leaf "]")) 335 | "^" 336 | (Node (Leaf "^") "_" (Leaf "_")))))) 337 | "`" 338 | (Node 339 | (Node 340 | (Node 341 | (Node 342 | (Node (Leaf "`") "a" (Leaf "a")) 343 | "b" 344 | (Node (Leaf "b") "c" (Leaf "c"))) 345 | "d" 346 | (Node 347 | (Node (Leaf "d") "e" (Leaf "e")) 348 | "f" 349 | (Node (Leaf "f") "g" (Leaf "g")))) 350 | "h" 351 | (Node 352 | (Node 353 | (Node (Leaf "h") "i" (Leaf "i")) 354 | "j" 355 | (Node (Leaf "j") "k" (Leaf "k"))) 356 | "l" 357 | (Node 358 | (Node (Leaf "l") "m" (Leaf "m")) 359 | "n" 360 | (Node (Leaf "n") "o" (Leaf "o"))))) 361 | "p" 362 | (Node 363 | (Node 364 | (Node 365 | (Node (Leaf "p") "q" (Leaf "q")) 366 | "r" 367 | (Node (Leaf "r") "s" (Leaf "s"))) 368 | "t" 369 | (Node 370 | (Node (Leaf "t") "u" (Leaf "u")) 371 | "v" 372 | (Node (Leaf "v") "w" (Leaf "w")))) 373 | "x" 374 | (Node 375 | (Node 376 | (Node (Leaf "x") "y" (Leaf "y")) 377 | "z" 378 | (Node (Leaf "z") "{" (Leaf "{"))) 379 | "|" 380 | (Node 381 | (Node (Leaf "|") "}" (Leaf "}")) 382 | "~" 383 | (Node (Leaf "~") "\DEL" (Leaf "\DEL"))))))) 384 | -------------------------------------------------------------------------------- /src/Data/Symbol/Examples/Printf.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE FunctionalDependencies #-} 5 | {-# LANGUAGE AllowAmbiguousTypes #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | {-# LANGUAGE DataKinds #-} 11 | 12 | module Data.Symbol.Examples.Printf where 13 | 14 | import Data.Symbol.Utils 15 | import GHC.TypeLits 16 | import Data.Proxy 17 | import Data.Monoid 18 | 19 | test :: String 20 | test = printf @"Wurble %d %d %s" 10 20 "foo" 21 | 22 | data Specifier 23 | = D 24 | | S 25 | | Lit Symbol 26 | 27 | class FormatF (format :: [Specifier]) fun | format -> fun where 28 | formatF :: String -> fun 29 | 30 | instance FormatF '[] String where 31 | formatF = id 32 | 33 | instance FormatF rest fun => FormatF (D ': rest) (Int -> fun) where 34 | formatF str i 35 | = formatF @rest (str Data.Monoid.<> show i) 36 | 37 | instance FormatF rest fun => FormatF (S ': rest) (String -> fun) where 38 | formatF str s 39 | = formatF @rest (str <> s) 40 | 41 | instance (FormatF rest fun, KnownSymbol l) => FormatF (Lit l ': rest) fun where 42 | formatF str 43 | = formatF @rest (str <> symbolVal (Proxy @l)) 44 | 45 | class PrintF (sym :: Symbol) fun where 46 | printf :: fun 47 | 48 | type family Parse (lst :: [Symbol]) :: [Specifier] where 49 | Parse '[] = '[Lit ""] 50 | Parse ("%" ': "d" ': xs) = D ': Parse xs 51 | Parse ("%" ': "s" ': xs) = S ': Parse xs 52 | Parse (x ': xs) = Parse2 x (Parse xs) 53 | 54 | type family Parse2 (c :: Symbol) (lst :: [Specifier]) :: [Specifier] where 55 | Parse2 c ('Lit s ': ss) = 'Lit (AppendSymbol c s) ': ss 56 | Parse2 c ss = 'Lit c ': ss 57 | 58 | instance (Listify sym lst, fmt ~ Parse lst, FormatF fmt fun) => PrintF (sym :: Symbol) fun where 59 | printf = formatF @fmt "" 60 | -------------------------------------------------------------------------------- /src/Data/Symbol/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# LANGUAGE PolyKinds #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE DataKinds #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE AllowAmbiguousTypes #-} 9 | 10 | module Data.Symbol.Utils 11 | ( Uncons (..) 12 | , Listify (..) 13 | ) where 14 | 15 | import Data.Symbol.Ascii 16 | 17 | import Data.Proxy 18 | import GHC.TypeLits 19 | 20 | class Uncons (sym :: Symbol) (h :: Symbol) (t :: Symbol) where 21 | uncons :: Proxy '(h, t) 22 | 23 | instance (h ~ Head sym, AppendSymbol h t ~ sym) => Uncons sym h t where 24 | uncons = Proxy 25 | 26 | class Listify (sym :: Symbol) (result :: [Symbol]) where 27 | listify :: Proxy result 28 | 29 | instance {-# OVERLAPPING #-} nil ~ '[] => Listify "" nil where 30 | listify = Proxy 31 | 32 | instance (Uncons sym h t, Listify t result, result' ~ (h ': result)) => Listify sym result' where 33 | listify = Proxy 34 | -------------------------------------------------------------------------------- /symbols.cabal: -------------------------------------------------------------------------------- 1 | name: symbols 2 | version: 0.3.0.0 3 | synopsis: Symbol manipulation 4 | description: Utilities for manipulating type-level strings natively. 5 | license: BSD3 6 | license-file: LICENSE 7 | author: Csongor Kiss 8 | maintainer: kiss.csongor.kiss@gmail.com 9 | copyright: (c) 2018-2019 Csongor Kiss 10 | category: Dependent Types 11 | build-type: Simple 12 | extra-source-files: CHANGELOG.md 13 | , README.md 14 | cabal-version: >=1.10 15 | 16 | source-repository head 17 | type: git 18 | location: https://github.com/kcsongor/symbols 19 | 20 | library 21 | exposed-modules: Data.Symbol.Ascii 22 | , Data.Symbol.Utils 23 | , Data.Symbol.Examples.Printf 24 | other-modules: Data.Symbol.Ascii.Internal 25 | build-depends: base >=4.10 && <5 26 | hs-source-dirs: src 27 | ghc-options: -Wall -Wno-unticked-promoted-constructors 28 | default-language: Haskell2010 29 | --------------------------------------------------------------------------------