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 Data.Tuple
  13 import StdEnv
  14
  15 import ast
  16
  17 (<:>) infixl 0 :: a (m [a]) -> m [a] | Functor m
  18 (<:>) l r = (\xs->[l:xs]) <$> r
  19
  20 :: Token = TTEq | TTSemiColon | TTLambda | TTDot | TTBrackOpen | TTBrackClose | TTBool Bool | TTInt Int | TTIdent [Char]
  21 derive gEq Token
  22 lex :: [Char] -> Either [String] [Token]
  23 lex [] = pure []
  24 lex [';':ts] = TTSemiColon <:> lex ts
  25 lex [')':ts] = TTBrackClose <:> lex ts
  26 lex ['(':ts] = TTBrackOpen <:> lex ts
  27 lex ['True':ts] = TTBool True <:> lex ts
  28 lex ['False':ts] = TTBool False <:> 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         | isIdent t
  39                 # (i, ts) = span isIdent [t:ts]
  40                 | i =: ['='] = TTEq <:> lex ts
  41                 | i =: ['.'] = TTDot <:> lex ts
  42                 | i =: ['\\'] = TTLambda <:> lex ts
  43                 = TTIdent i <:> lex ts
  44         = Left ["Unexpected: " +++ toString t +++ " ord: " +++ toString (toInt t)]
  45 where
  46         isIdent c = isAlpha c || isMember c ['!@#$%^&*=+/?-_|\\\'",<>.:']
  47
  48 :: Parser a :== StateT ParseState (Either [String]) a
  49 :: ParseState =
  50         { tokens :: [Token]
  51         , ifxs :: [((Parser Expression) -> Parser Expression, Int)]
  52         }
  53 instance zero ParseState where zero = {tokens=[],ifxs=[]}
  54
  55 pTop :: Parser Token
  56 pTop = getState >>= \s->case s.tokens of
  57         [t:ts] = put {s & tokens=ts} >>| pure t
  58         [] = liftT (Left ["Fully consumed input"])
  59
  60 pEof :: Parser ()
  61 pEof = getState >>= \s->case s.tokens of
  62         [] = pure ()
  63         [t:ts] = liftT (Left ["Expected EOF"])
  64
  65 pSatisfy :: (Token -> Bool) -> Parser Token
  66 pSatisfy f = pTop >>= \t->if (f t) (pure t) empty
  67
  68 pToken :: (Token -> Parser Token)
  69 pToken = pSatisfy o (===)
  70
  71 pChainl :: (Parser (a a -> a)) (Parser a) -> Parser a
  72 pChainl op p = foldl (flip ($)) <$> p <*> many (flip <$> op <*> p)
  73
  74 pChainr :: (Parser (a a -> a)) (Parser a) -> Parser a
  75 pChainr op p = flip ($) <$> p <*> (flip <$> op <*> pChainr op p) <|> p
  76
  77 parse :: [Token] -> Either [String] AST
  78 parse ts = case runStateT (AST <$> pAST <* pEof) {zero & tokens=ts} of
  79         Right (a, _) = Right a
  80         Left e = Left e
  81 where
  82         pAST :: Parser [Function]
  83         pAST = many pFunction >>= mapM \(id, args, body)->Function id args <$
  84                 modify (\t->{t&tokens=body}) <*> pExpression <* pEof
  85
  86         pId = (\(TTIdent i)->i) <$> pSatisfy (\t->t=:(TTIdent _))
  87         pCId a = pId >>= \b->if (a == b) (pure a) empty
  88
  89         pFunction :: Parser ([Char], [[Char]], [Token])
  90         pFunction
  91                 =   tuple3
  92                 <$> (pFunId <|> pId)
  93                 <*> many pId
  94                 <*  pToken TTEq
  95                 <*> many (pSatisfy ((=!=)TTSemiColon))
  96                 <*  pToken TTSemiColon
  97
  98         pFunId :: Parser [Char]
  99         pFunId = pId
 100                 >>= \i->pChainr <$ pCId ['ifxr'] <|> pChainl <$ pCId ['ifxl']
 101                 >>= \p->(\(TTInt i)->i) <$> pSatisfy (\t->t=:(TTInt _))
 102                 >>= \s->modify (\t->{t & ifxs=[(p (App o App (Var i) <$ pCId i), s):t.ifxs]})
 103                 >>| pure i
 104
 105         pExpression :: Parser Expression
 106         pExpression = getState >>= \{ifxs}->flip (foldr ($))
 107                         [pChainl (pure App):map fst $ sortBy (on (<) snd) ifxs]
 108                 $   Lambda <$ pToken TTLambda <*> pId <* pToken TTDot <*> pExpression
 109                 <|> pToken TTBrackOpen *> pExpression <* pToken TTBrackClose
 110                 <|> Lit o Int <$> (\(TTInt i)->i) <$> pSatisfy (\t->t=:(TTInt _))
 111                 <|> (\(TTBool i)->Lit (Bool i)) <$> pSatisfy (\t->t=:(TTBool _))
 112                 <|> Var <$> pId