/
Parser.hs
187 lines (161 loc) · 6.54 KB
/
Parser.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE NoStarIsType #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module GHC.TypeLits.Printf.Internal.Parser where
import Data.Kind
import Data.Type.Bool
import Data.Type.Equality
import GHC.TypeLits
-- | A type synonym for a single-character symbol. Ideally this would just
-- be 'Char', but we don't have chars at the type level. So, if you see
-- 'SChar' in a type signature, it means that it's expected to be
-- a symbol/string with only one single character.
type SChar = Symbol
type Parser a = a -> Type
type family RunParser (p :: Parser a) (str :: [SChar]) :: Maybe (a, [SChar])
data Pure :: a -> Parser a
type instance RunParser (Pure x) str = 'Just '(x, str)
data Sym :: SChar -> Parser SChar
type instance RunParser (Sym c) (d ': cs) = If (c == d) ('Just '(c, cs)) 'Nothing
type instance RunParser (Sym c) '[] = 'Nothing
data NotSym :: SChar -> Parser SChar
type instance RunParser (NotSym c) (d ': cs) = If (c == d) 'Nothing ('Just '(d, cs))
type instance RunParser (NotSym c) '[] = 'Nothing
data AnySym :: Parser SChar
type instance RunParser AnySym (c ': cs) = 'Just '(c, cs)
type instance RunParser AnySym '[] = 'Nothing
data Alpha :: Parser SChar
type instance RunParser Alpha (c ': cs) = If (IsAlpha c) ('Just '(c, cs)) 'Nothing
type instance RunParser Alpha '[] = 'Nothing
data (<$) :: b -> Parser a -> Parser b
type family RepHelp (x :: b) (r :: Maybe (a, [SChar])) :: Maybe (b, [SChar]) where
RepHelp x 'Nothing = 'Nothing
RepHelp x ('Just '(y, s)) = 'Just '(x, s)
type instance RunParser (x <$ p) str = RepHelp x (RunParser p str)
data (<|>) :: Parser a -> Parser a -> Parser a
type family ChoiceMaybe (x :: Maybe a) (y :: Maybe a) :: Maybe a where
ChoiceMaybe ('Just x) y = 'Just x
ChoiceMaybe 'Nothing y = y
type instance RunParser (x <|> y) str = ChoiceMaybe (RunParser x str) (RunParser y str)
type Optional p = ('Just <$> p) <|> Pure 'Nothing
data (*>) :: Parser a -> Parser b -> Parser b
type family SeqHelp (p :: Parser b) (r :: Maybe (a, [SChar])) :: Maybe (b, [SChar]) where
SeqHelp p 'Nothing = 'Nothing
SeqHelp p ('Just '(x, str)) = RunParser p str
type instance RunParser (x *> y) str = SeqHelp y (RunParser x str)
-- | Parse a single digit
data Digit :: Parser Nat
type family DigitHelp (d :: Maybe Nat) (cs :: [SChar]) :: Maybe (Nat, [SChar]) where
DigitHelp 'Nothing cs = 'Nothing
DigitHelp ('Just d) cs = 'Just '(d, cs)
type instance RunParser Digit '[] = 'Nothing
type instance RunParser Digit (c ': cs) = DigitHelp (CharDigit c) cs
data (<$>) :: (a -> b) -> Parser a -> Parser b
type family MapConHelp (f :: a -> b) (r :: Maybe (a, [SChar])) :: Maybe (b, [SChar]) where
MapConHelp f 'Nothing = 'Nothing
MapConHelp f ('Just '(x, str)) = 'Just '(f x, str)
type instance RunParser (f <$> p) str = MapConHelp f (RunParser p str)
data (<*>) :: Parser (a -> b) -> Parser a -> Parser b
type family ApHelp (r :: Maybe (a -> b, [SChar])) (q :: Parser a) :: Maybe (b, [SChar]) where
ApHelp 'Nothing q = 'Nothing
ApHelp ('Just '(f, str)) q = RunParser (f <$> q) str
type instance RunParser (p <*> q) str = ApHelp (RunParser p str) q
data Many :: Parser a -> Parser [a]
type instance RunParser (Many p) str = RunParser (Some p <|> Pure '[]) str
data Some :: Parser a -> Parser [a]
type instance RunParser (Some p) str = RunParser ('(:) <$> p <*> Many p) str
-- | Parse a number
data Number :: Parser Nat
type family NumberHelp (xs :: Maybe ([Nat], [SChar])) :: Maybe (Nat, [SChar]) where
NumberHelp 'Nothing = 'Nothing
NumberHelp ('Just '(ns, str)) = 'Just '(FromDigits ns 0, str)
type instance RunParser Number str = NumberHelp (RunParser (Some Digit) str)
data Cat :: Parser [SChar] -> Parser Symbol
type family CatHelp (xs :: Maybe ([SChar], [SChar])) :: Maybe (Symbol, [SChar]) where
CatHelp 'Nothing = 'Nothing
CatHelp ('Just '(cs, str)) = 'Just '(CatChars cs, str)
type instance RunParser (Cat p) str = CatHelp (RunParser p str)
type family EvalHelp (r :: Maybe (a, [SChar])) :: Maybe a where
EvalHelp 'Nothing = 'Nothing
EvalHelp ('Just '(x, str)) = 'Just x
type EvalParser (p :: Parser a) str = EvalHelp (RunParser p str) :: Maybe a
type family EvalHelp_ (r :: Maybe (a, [SChar])) :: a where
EvalHelp_ ('Just '(x, str)) = x
EvalHelp_ 'Nothing = TypeError ('Text "Parse failed")
type EvalParser_ (p :: Parser a) str = EvalHelp_ (RunParser p str) :: a
type family CharDigit (c :: SChar) :: Maybe Nat where
CharDigit "0" = 'Just 0
CharDigit "1" = 'Just 1
CharDigit "2" = 'Just 2
CharDigit "3" = 'Just 3
CharDigit "4" = 'Just 4
CharDigit "5" = 'Just 5
CharDigit "6" = 'Just 6
CharDigit "7" = 'Just 7
CharDigit "8" = 'Just 8
CharDigit "9" = 'Just 9
CharDigit c = 'Nothing
type family FromDigits (xs :: [Nat]) (n :: Nat) :: Nat where
FromDigits '[] n = n
FromDigits (a ': bs) n = FromDigits bs (n * 10 + a)
type family CatChars (cs :: [SChar]) :: Symbol where
CatChars '[] = ""
CatChars (c ': cs) = AppendSymbol c (CatChars cs)
type family IsAlpha (c :: SChar) :: Bool where
IsAlpha "a" = 'True
IsAlpha "b" = 'True
IsAlpha "c" = 'True
IsAlpha "d" = 'True
IsAlpha "e" = 'True
IsAlpha "f" = 'True
IsAlpha "g" = 'True
IsAlpha "h" = 'True
IsAlpha "i" = 'True
IsAlpha "j" = 'True
IsAlpha "k" = 'True
IsAlpha "l" = 'True
IsAlpha "m" = 'True
IsAlpha "n" = 'True
IsAlpha "o" = 'True
IsAlpha "p" = 'True
IsAlpha "q" = 'True
IsAlpha "r" = 'True
IsAlpha "s" = 'True
IsAlpha "t" = 'True
IsAlpha "u" = 'True
IsAlpha "v" = 'True
IsAlpha "w" = 'True
IsAlpha "x" = 'True
IsAlpha "y" = 'True
IsAlpha "z" = 'True
IsAlpha "A" = 'True
IsAlpha "B" = 'True
IsAlpha "C" = 'True
IsAlpha "D" = 'True
IsAlpha "E" = 'True
IsAlpha "F" = 'True
IsAlpha "G" = 'True
IsAlpha "H" = 'True
IsAlpha "I" = 'True
IsAlpha "J" = 'True
IsAlpha "K" = 'True
IsAlpha "L" = 'True
IsAlpha "M" = 'True
IsAlpha "N" = 'True
IsAlpha "O" = 'True
IsAlpha "P" = 'True
IsAlpha "Q" = 'True
IsAlpha "R" = 'True
IsAlpha "S" = 'True
IsAlpha "T" = 'True
IsAlpha "U" = 'True
IsAlpha "V" = 'True
IsAlpha "W" = 'True
IsAlpha "X" = 'True
IsAlpha "Y" = 'True
IsAlpha "Z" = 'True
IsAlpha a = 'False