parse.icl

   1 implementation module parse
   2
   3 import Control.Applicative
   4 import Control.Monad
   5 import Control.Monad.State
   6 import Control.Monad.Trans
   7 import Data.Either
   8 import Data.GenEq
   9 import Data.Functor
  10 import Data.Func
  11 import Data.List
  12 import StdEnv
  13
  14 import ast
  15
  16 (<:>) infixl 0 :: a (m [a]) -> m [a] | Functor m
  17 (<:>) l r = (\xs->[l:xs]) <$> r
  18
  19 :: Token = TTEq | TTSemiColon | TTLambda | TTDot | TTBrackOpen | TTBrackClose | TTBool Bool | TTInt Int | TTIdent [Char]
  20 derive gEq Token
  21 lex :: [Char] -> Either [String] [Token]
  22 lex [] = pure []
  23 lex ['=':ts] = TTEq <:> lex ts
  24 lex [';':ts] = TTSemiColon <:> lex ts
  25 lex ['\\':ts] = TTLambda <:> lex ts
  26 lex ['.':ts] = TTDot <:> lex ts
  27 lex [')':ts] = TTBrackClose <:> lex ts
  28 lex ['(':ts] = TTBrackOpen <:> lex ts
  29 lex ['True':ts] = TTBool True <:> lex ts
  30 lex ['False':ts] = TTBool False <:> lex ts
  31 lex ['-',t:ts]
  32         | isDigit t = lex [t:ts] >>= \v->case v of
  33                 [TTInt i:rest] = Right [TTInt (~i):rest]
  34                 x = pure x
  35 lex [t:ts]
  36         | isSpace t = lex ts
  37         | isDigit t
  38                 # (i, ts) = span isDigit [t:ts]
  39                 = TTInt (toInt (toString i)) <:> lex ts
  40         | isIdent t
  41                 # (i, ts) = span isIdent [t:ts]
  42                 = TTIdent i <:> lex ts
  43         = Left ["Unexpected: " +++ toString t +++ " ord: " +++ toString (toInt t)]
  44 where
  45         isIdent c = isAlpha c || isMember c ['!@#$%^&*=+/?-_|\\\'",<>.:']
  46
  47 :: Parser a :== StateT ParseState (Either [String]) a
  48 :: ParseState =
  49         { tokens :: [Token]
  50         , infixs :: [(Bool, [Char], Int)]
  51         }
  52 instance zero ParseState where zero = {tokens=[],infixs=[]}
  53
  54 pTop :: Parser Token
  55 pTop = getState >>= \s->case s.tokens of
  56         [t:ts] = put {s & tokens=ts} >>| pure t
  57         [] = liftT (Left ["Fully consumed input"])
  58
  59 pSatisfy :: (Token -> Bool) -> Parser Token
  60 pSatisfy f = pTop >>= \t->if (f t) (pure t) empty
  61
  62 pToken :: (Token -> Parser Token)
  63 pToken = pSatisfy o (===)
  64
  65 pChainl :: (Parser (a a -> a)) (Parser a) -> Parser a
  66 pChainl op p = foldl (flip ($)) <$> p <*> many (flip <$> op <*> p)
  67
  68 pChainr :: (Parser (a a -> a)) (Parser a) -> Parser a
  69 pChainr op p = flip ($) <$> p <*> (flip <$> op <*> pChainr op p) <|> p
  70
  71 parse :: [Token] -> Either [String] AST
  72 parse ts = case runStateT pAST {zero & tokens=ts} of
  73         Right (a, {tokens=[]}) = Right a
  74         Right (a, _) = Left ["No complete parse result"]
  75         Left e = Left e
  76 where
  77         pAST :: Parser AST
  78         pAST = AST <$> many pFunction
  79
  80         pId = (\(TTIdent i)->i) <$> pSatisfy (\t->t=:(TTIdent _))
  81         pOp t` = pId >>= \t->if (t == t`) (pure t) empty
  82
  83         pFunction :: Parser Function
  84         pFunction
  85                 =   Function
  86                 <$> pId
  87                 <*> many pId
  88                 <*  pToken TTEq
  89                 <*> pExpression
  90                 <*  pToken TTSemiColon
  91
  92         pExpression :: Parser Expression
  93         pExpression = getState >>= \{infixs}->foldr ($) pBasic
  94                 [ pChainl (pure App)
  95                 : [ if ifxr pChainr pChainl $ App o App (Var op) <$ pOp op
  96                   \\(ifxr, op, _)<-infixs]]
  97
  98         pBasic :: Parser Expression
  99         pBasic
 100                 =   Lambda <$ pToken TTLambda <*> pId <* pToken TTDot <*> pExpression
 101                 <|> pToken TTBrackOpen *> pExpression <* pToken TTBrackClose
 102                 <|> (\(TTInt i)->Lit (Int i)) <$> pSatisfy (\t->t=:(TTInt _))
 103                 <|> (\(TTInt i)->Lit (Int i)) <$> pSatisfy (\t->t=:(TTInt _))
 104                 <|> (\(TTBool i)->Lit (Bool i)) <$> pSatisfy (\t->t=:(TTBool _))
 105                 <|> Var <$> pId