parse.icl

   1 implementation module parse
   2
   3 import Control.Applicative
   4 import Control.Monad
   5 import Data.Either
   6 import Data.Functor
   7 import Data.Func
   8 import StdEnv
   9 import Text.Parsers.Simple.ParserCombinators => qualified parse
  10
  11 import ast
  12
  13 (<:>) infixl 0 :: a (m [a]) -> m [a] | Functor m
  14 (<:>) l r = (\xs->[l:xs]) <$> r
  15
  16 :: Token = TTEq | TTSemiColon | TTLambda | TTDot | TTBrackOpen | TTBrackClose | TTBool Bool | TTChar Char | TTInt Int | TTIdent [Char]
  17
  18 lex :: [Char] -> Either [String] [Token]
  19 lex [] = pure []
  20 lex ['=':ts] = TTEq <:> lex ts
  21 lex [';':ts] = TTSemiColon <:> lex ts
  22 lex ['\\':ts] = TTLambda <:> lex ts
  23 lex ['.':ts] = TTDot <:> lex ts
  24 lex [')':ts] = TTBrackClose <:> lex ts
  25 lex ['(':ts] = TTBrackOpen <:> lex ts
  26 lex ['True':ts] = TTBool True <:> lex ts
  27 lex ['False':ts] = TTBool False <:> lex ts
  28 lex ['\'',c,'\'':ts] = TTChar c <:> lex ts
  29 lex ['-',t:ts]
  30         | isDigit t = lex [t:ts] >>= \v->case v of
  31                 [TTInt i:rest] = Right [TTInt (~i):rest]
  32                 x = pure x
  33 lex [t:ts]
  34         | isSpace t = lex ts
  35         | isDigit t
  36                 # (i, ts) = span isDigit [t:ts]
  37                 = TTInt (toInt (toString i)) <:> lex ts
  38         | isAlpha t
  39                 # (i, ts) = span isAlpha [t:ts]
  40                 = TTIdent i <:> lex ts
  41         = Left ["Unexpected: " +++ toString t +++ " ord: " +++ toString (toInt t)]
  42
  43 parse :: ([Token] -> Either [String] AST)
  44 parse = 'Text.Parsers.Simple.ParserCombinators'.parse (AST <$> many pFunction)
  45 where
  46         pId = (\(TTIdent i)->i) <$> pSatisfy (\t->t=:(TTIdent _))
  47
  48         pFunction :: Parser Token Function
  49         pFunction
  50                 =   Function
  51                 <$> pId
  52                 <*> many pId
  53                 <*  pSatisfy (\t->t=:TTEq)
  54                 <*> pExpression
  55                 <*  pSatisfy (\t->t=:TTSemiColon)
  56
  57         pExpression :: Parser Token Expression
  58         pExpression = flip pChainl1 (pure App) $
  59                      (Lambda <$ pSatisfy (\t->t=:TTLambda) <*> pId <* pSatisfy (\t->t=:TTDot) <*> pExpression)
  60                 <<|> (pSatisfy (\t->t=:TTBrackOpen) *> pExpression <* pSatisfy (\t->t=:TTBrackClose))
  61                 <<|> ((\(TTInt i)->Lit (Int i)) <$> pSatisfy (\t->t=:(TTInt _)))
  62                 <<|> ((\(TTChar i)->Lit (Char i)) <$> pSatisfy (\t->t=:(TTChar _)))
  63                 <<|> ((\(TTBool i)->Lit (Bool i)) <$> pSatisfy (\t->t=:(TTBool _)))
  64                 <<|> (Var <$> pId)