1 implementation module parse
4 import qualified _SystemStrictLists as SS
8 import Control.Applicative
10 import Control.Monad.State
22 derive consName Token, Value
24 :: Expression | DelayedParse [Token]
27 = IntToken Int | BoolToken Bool | CharToken Char | IdentToken String
28 | InfixrToken | InfixlToken | SemiColonToken | OpenBraceToken
29 | CloseBraceToken | EqualsToken
31 lex :: [Char] -> [Token]
35 lex` ['\n':cs] = lex` cs
38 lex` [';':cs] = [SemiColonToken:lex` cs]
40 | not (isIdent c) = [EqualsToken:lex` [c:cs]]
41 lex` ['(':cs] = [OpenBraceToken:lex` cs]
42 lex` [')':cs] = [CloseBraceToken:lex` cs]
43 lex` ['\'',c,'\'':cs] = [CharToken c:lex` cs]
44 lex` ['T','r','u','e':cs] = [BoolToken True:lex` cs]
45 lex` ['F','a','l','s','e':cs] = [BoolToken True:lex` cs]
46 lex` ['i','n','f','i','x','r':cs] = [InfixrToken:lex` cs]
47 lex` ['i','n','f','i','x','l':cs] = [InfixlToken:lex` cs]
51 [IntToken i:ts] = [IntToken (~i):ts]
55 # (i, cs) = span isDigit [c:cs]
56 = [IntToken $ toInt $ toString i:lex` cs]
58 # (i, cs) = span (\c->isIdent c || isDigit c) cs
59 = [IdentToken $ toString [c:i]:lex` cs]
61 isIdent c = isAlpha c || isMember c ['!@#$%^&*\|+?/_-\'<>.:~`=']
67 :: Infix = Infix String Fixity Int
68 instance < Infix where (<) (Infix _ _ s) (Infix _ _ t) = s < t
69 :: Fixity = InfixL | InfixR
71 :: Parser a :== StateT ParseState (Either [String]) a
73 instance zero ParseState where zero = {tokens=[],infixers=[]}
75 (<?>) infixl 1 :: a (StateT b (Either (c a)) d) -> StateT b (Either (c a)) d | Semigroup (c a) & Applicative c
76 (<?>) err p = StateT $ first (flip mappend (pure err)) o runStateT p
79 top = getState >>= \st=:{tokens}->case tokens of
80 [t:ts] = put {st & tokens=ts} >>| pure t
83 parseIf :: (a -> Bool) (Parser a) -> Parser a
84 parseIf pred p = p >>= \a->if (pred a) (pure a) empty
86 token t :== parseIf ((=+?=)t) top
88 (until) infix 5 :: (Parser a) (Parser b) -> Parser ([a], b)
89 (until) p grd = (tuple [] <$> grd) <|> (appFst o 'SS'._cons <$> p <*> p until grd)
91 parse :: [Token] ParseState -> Either [String] AST
92 parse ts st = runStateT parseAST {st & tokens=ts} >>= uncurry parse2
94 parse2 :: AST ParseState -> Either [String] AST
95 parse2 (AST fs) ps = AST <$> mapM pfun fs
97 pfun :: Function -> Either [String] Function
98 pfun (Function s a (DelayedParse ts)) =
99 Function s a <$> evalStateT parseExpr {ps & tokens=ts}
104 parseExpr :: Parser Expression
105 parseExpr = gets (\s->sort s.infixers)
106 >>= flip seq parseBasic o cons parseApp o reverse o map op2parser
108 op2parser (Infix sym dir str) = if (dir =: InfixL) parseLOP parseROP
109 (\l op->Apply $ Apply op l) (Variable <$> parseIf ((==)sym) parseIdent)
111 parseApp = parseLOP (const o Apply) (pure ())
113 parseLOP :: (a b a -> a) (c b) (c a) -> c a | Alternative c
114 parseLOP comb ops prev = foldl (uncurry o comb)
115 <$> prev <*> many (tuple <$> ops <*> prev)
117 parseROP :: (a b a -> a) (c b) (c a) -> c a | Monad c & Alternative c
118 parseROP comb ops prev = prev >>= \e1->
119 comb e1 <$> ops <*> parseROP comb ops prev <|> pure e1
122 = (token OpenBraceToken *> parseExpr <* token CloseBraceToken)
123 <|> Literal <$> Int <$> parseInt
124 <|> (gets (\s->[i\\Infix i _ _<-s.infixers])
125 >>= \ifs->Variable <$> parseIf (not o flip elem ifs) parseIdent)
127 parseAST :: Parser AST
128 parseAST = AST <$> many parseFunction
130 parseFunction :: Parser Function
131 parseFunction = Function
132 <$> (parseIdent >>= \ident->(parseFixity ident <|> pure ()) >>| pure ident)
134 <*> (DelayedParse o fst <$> (token EqualsToken *> top until token SemiColonToken))
136 parseFixity :: String -> Parser ()
137 parseFixity ident = Infix ident
138 <$> (token InfixrToken *> pure InfixR <|> token InfixlToken *> pure InfixL)
140 >>= \f->modify \s->{s & infixers=[f:s.infixers]}
142 parseIdent :: Parser String
143 parseIdent = (\(IdentToken s)->s) <$> token (IdentToken "")
145 parseInt :: Parser Int
146 parseInt = (\(IntToken i)->i) <$> token (IntToken 0)
148 Start = toString <$> parse (lex ['+ infixr 6 a b = 0; * infixr 7 a b = 0; ap = a + b * c + d;']) zero