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 Text.GenPrint
  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 | TTOp [Char] | TTIdent [Char]
  21
  22 derive gEq Token
  23 derive gPrint Token
  24
  25 instance toString Token where toString t = printToString t
  26
  27 lex :: [Char] -> Either [String] [Token]
  28 lex [] = pure []
  29 lex ['//\n':ts] = lex ts
  30 lex ['//',t:ts] = lex ['/','/':ts]
  31 lex ['/**/':ts] = lex $ dropWhile ((<>)'\n') ts
  32 lex ['/*',t:ts] = lex ['/','*':ts]
  33 lex [';':ts] = TTSemiColon <:> lex ts
  34 lex [')':ts] = TTBrackClose <:> lex ts
  35 lex ['(':ts] = TTBrackOpen <:> lex ts
  36 lex ['True':ts] = TTBool True <:> lex ts
  37 lex ['False':ts] = TTBool False <:> lex ts
  38 lex ['-',t:ts]
  39         | isDigit t = lex [t:ts] >>= \v->case v of
  40                 [TTInt i:rest] = Right [TTInt (~i):rest]
  41                 x = pure x
  42 lex [t:ts]
  43         | isSpace t = lex ts
  44         | isDigit t
  45                 # (i, ts) = span isDigit [t:ts]
  46                 = TTInt (toInt (toString i)) <:> lex ts
  47         | isAlpha t
  48                 # (i, ts) = span isAlpha [t:ts]
  49                 = TTIdent i <:> lex ts
  50         | isOp t
  51                 # (i, ts) = span isOp [t:ts]
  52                 | i =: ['='] = TTEq <:> lex ts
  53                 | i =: ['.'] = TTDot <:> lex ts
  54                 | i =: ['\\'] = TTLambda <:> lex ts
  55                 = TTOp i <:> lex ts
  56         = Left ["Unexpected: " +++ toString t +++ " ord: " +++ toString (toInt t)]
  57 where
  58         isOp c = isMember c ['!@#$%^&*=+/?-_|\\\'",<>.:']
  59
  60 :: Parser a :== StateT ParseState (Either [String]) a
  61 :: ParseState =
  62         { tokens :: [Token]
  63         , ifxs   :: [((Parser Expression) -> Parser Expression, Int)]
  64         }
  65
  66 pTop :: Parser Token
  67 pTop = getState >>= \s->case s.tokens of
  68         [t:ts] = put {s & tokens=ts} >>| pure t
  69         [] = liftT (Left ["Fully consumed input"])
  70
  71 pEof :: Parser ()
  72 pEof = getState >>= \s->case s.tokens of
  73         [] = pure ()
  74         [t:ts] = liftT (Left ["Expected EOF but got ":map toString [t:ts]])
  75
  76 (?) infixl 9 :: (Parser a) (a -> Bool) -> Parser a
  77 (?) p f = p >>= \v->if (f v) (pure v) empty
  78
  79 pToken :: (Token -> Parser Token)
  80 pToken = (?) pTop o (===)
  81
  82 pChainl :: (Parser (a a -> a)) (Parser a) -> Parser a
  83 pChainl op p = foldl (flip ($)) <$> p <*> many (flip <$> op <*> p)
  84
  85 pChainr :: (Parser (a a -> a)) (Parser a) -> Parser a
  86 pChainr op p = flip ($) <$> p <*> (flip <$> op <*> pChainr op p) <|> p
  87
  88 parse :: [Token] -> Either [String] [Function]
  89 parse ts = fst <$> runStateT (reverse <$> pAST <* pEof) {tokens=ts, ifxs=[]}
  90 where
  91         pAST :: Parser [Function]
  92         pAST = many pFunction >>= mapM \(id, args, body)->Function id args <$
  93                 modify (\t->{t & tokens=body}) <*> pExpression <* pEof
  94
  95         pId = (\(TTIdent i)->i) <$> pTop ? (\t->t=:(TTIdent _))
  96         pOp = (\(TTOp i)->i) <$> pTop ? (\t->t=:(TTOp _))
  97
  98         pFunction :: Parser ([Char], [[Char]], [Token])
  99         pFunction
 100                 =   (\x y z->(x, y, z))
 101                 <$> (pFunId <|> pId)
 102                 <*> many pId
 103                 <*  pToken TTEq
 104                 <*> many (pTop ? ((=!=)TTSemiColon))
 105                 <*  pToken TTSemiColon
 106
 107         pFunId :: Parser [Char]
 108         pFunId = pOp
 109                 >>= \i->pChainr <$ pId ? ((==) ['ifxr']) <|> pChainl <$ pId ? ((==)['ifxl'])
 110                 >>= \p->(\(TTInt i)->i) <$> pTop ? (\t->t=:(TTInt _))
 111                 >>= \s->modify (\t->{t & ifxs=[(p (App o App (Var i) <$ pOp ? ((==)i)), s):t.ifxs]})
 112                 >>| pure i
 113
 114         pExpression :: Parser Expression
 115         pExpression = getState >>= \{ifxs}->flip (foldr ($))
 116                         (map fst $ sortBy (on (<) snd) ifxs)
 117                 $   pChainl (pure App)
 118                 $   Lambda <$ pToken TTLambda <*> pId <* pToken TTDot <*> pExpression
 119                 <|> Var <$ pToken TTBrackOpen <*> pOp <* pToken TTBrackClose
 120                 <|> pToken TTBrackOpen *> pExpression <* pToken TTBrackClose
 121                 <|> (\(TTInt i)->Lit (Int i)) <$> pTop ? (\t->t=:(TTInt _))
 122                 <|> (\(TTBool i)->Lit (Bool i)) <$> pTop ? (\t->t=:(TTBool _))
 123                 <|> (\x->Var ['_':x]) <$ pId ? ((==)['code']) <*> pId
 124                 <|> Var <$> pId