parse.icl

   1 implementation module parse
   2
   3 import Control.Applicative
   4 import Control.Monad
   5 import Data.Either
   6 import Data.GenEq
   7 import Data.Functor
   8 import Data.Func
   9 import Data.List
  10 import Data.Tuple
  11 import Text.GenPrint
  12 import StdEnv
  13
  14 import ast
  15
  16 cons x xs = [x:xs]
  17
  18 (<:>) infixl 0 :: a (m [a]) -> m [a] | Functor m
  19 (<:>) l r = cons l <$> r
  20
  21 :: Token = TTSemiColon | TTBrackOpen | TTBrackClose | TTBool Bool | TTInt Int | TTOp [Char] | TTIdent [Char]
  22
  23 derive gEq Token
  24 derive gPrint Token
  25
  26 instance toString Token where toString t = printToString t
  27
  28 lex :: ![Char] -> Either [String] [Token]
  29 lex [] = pure []
  30 lex ['//\n':ts] = lex ts
  31 lex ['//',t:ts] = lex ['/','/':ts]
  32 lex ['/**/':ts] = lex $ dropWhile ((<>)'\n') ts
  33 lex ['/*',t:ts] = lex ['/','*':ts]
  34 lex [';':ts] = TTSemiColon <:> lex ts
  35 lex [')':ts] = TTBrackClose <:> lex ts
  36 lex ['(':ts] = TTBrackOpen <:> lex ts
  37 lex ['True':ts] = TTBool True <:> lex ts
  38 lex ['False':ts] = TTBool False <:> lex ts
  39 lex ['-',t:ts]
  40         | isDigit t = lex [t:ts] >>= \v->case v of
  41                 [TTInt i:rest] = Right [TTInt (~i):rest]
  42                 x = pure x
  43 lex [t:ts]
  44         | isSpace t = lex ts
  45         | isDigit t
  46                 # (d, ts) = span isDigit [t:ts]
  47                 = TTInt (toInt (toString d)) <:> lex ts
  48         | isAlpha t
  49                 # (d, ts) = span isAlpha [t:ts]
  50                 = TTIdent d <:> lex ts
  51         | isOp t
  52                 # (d, ts) = span isOp [t:ts]
  53                 = TTOp d <:> lex ts
  54         = Left ["Unexpected: " +++ toString t +++ " ord: " +++ toString (toInt t)]
  55 where
  56         isOp c = isMember c ['!@#$%^&*=+/?-_|\\\'",<>.:']
  57
  58 :: Parser a = Parser ([Token] IfxInfo -> (Either [String] a, [Token], IfxInfo))
  59 :: IfxInfo :== [((Parser Expression) -> Parser Expression, Int)]
  60 runParser (Parser a) = a
  61 instance Functor Parser where fmap f a = liftM f a
  62 instance pure Parser where pure a = Parser \ts r->(Right a, ts, r)
  63 instance <*> Parser where (<*>) a b = ap a b
  64 instance <* Parser
  65 instance *> Parser
  66 instance Monad Parser where
  67         bind ma a2mb = Parser \t r->case runParser ma t r of
  68                 (Left e, ts, r) = (Left e, ts, r)
  69                 (Right a, ts, r) = runParser (a2mb a) ts r
  70 instance Alternative Parser where
  71         empty = Parser \ts r->(Left [], ts, r)
  72         (<|>) p1 p2 = Parser \ts r->case runParser p1 ts r of
  73                 (Left e, _, _) = runParser p2 ts r
  74                 a = a
  75
  76 pTop :: Parser Token
  77 pTop = Parser \ts r->case ts of
  78         [t:ts] = (Right t, ts, r)
  79         [] = (Left ["Fully consumed input"], ts, r)
  80
  81 pEof :: Parser ()
  82 pEof = Parser \ts r->case ts of
  83         [] = (Right (), [], r)
  84         _ = (Left ["Expected EOF but got ":map toString ts], ts, r)
  85
  86 (?) infixl 9 :: (Parser a) (a -> Bool) -> Parser a
  87 (?) p f = p >>= \v->if (f v) (pure v) empty
  88
  89 pToken :: (Token -> Parser Token)
  90 pToken = (?) pTop o (===)
  91
  92 pChainl :: (Parser (a a -> a)) (Parser a) -> Parser a
  93 pChainl op p = foldl (flip ($)) <$> p <*> many (flip <$> op <*> p)
  94
  95 pChainr :: (Parser (a a -> a)) (Parser a) -> Parser a
  96 pChainr op p = flip ($) <$> p <*> (flip <$> op <*> pChainr op p) <|> p
  97
  98 parse :: ![Token] -> Either [String] [Either TypeDef Function]
  99 parse ts = case runParser (many (Right <$> pFunction <|> Left <$> pTypeDef) <* pEof) ts [] of
 100         (Left e, _, _) = Left e
 101         (Right a, _, r) = sequence [reparse r a\\a<-a]
 102 where
 103         reparse r (Left e) = pure (Left e)
 104         reparse r (Right (id, args, body))
 105                 = Right <$> fst3 (runParser (Function id args <$> pExpression <* pEof) body r)
 106
 107         pTypeDef :: Parser TypeDef
 108         pTypeDef = TypeDef
 109                 <$  pToken (TTOp ['::'])
 110                 <*> pId
 111                 <*> many pId
 112                 <*  pToken (TTOp ['='])
 113                 <*> (cons <$> pCons <*> many (pToken (TTOp ['|']) *> pCons))
 114                 <*  pToken TTSemiColon
 115
 116         pCons = tuple <$> pId <*> many pType
 117
 118         pType =   TInt  <$ pTop ? (\t->t=:(TTIdent ['Int']))
 119               <|> TBool <$ pTop ? (\t->t=:(TTIdent ['Bool']))
 120               <|> TVar  <$> pId
 121               <|> pBrack (pChainr ((-->) <$ pToken (TTOp ['->'])) $ pChainl (pure TApp) pType)
 122
 123         pId = (\(TTIdent i)->i) <$> pTop ? (\t->t=:(TTIdent _))
 124         pOp = (\(TTOp i)->i) <$> pTop ? (\t->t=:(TTOp _))
 125         pInt = (\(TTInt i)->i) <$> pTop ? (\t->t=:(TTInt _))
 126         pBrack p = pToken TTBrackOpen *> p <* pToken TTBrackClose
 127
 128         pFunction :: Parser ([Char], [[Char]], [Token])
 129         pFunction
 130                 =   tuple3
 131                 <$> (pFunId <|> pId)
 132                 <*> many pId
 133                 <*  pToken (TTOp ['='])
 134                 <*> many (pTop ? ((=!=)TTSemiColon))
 135                 <*  pToken TTSemiColon
 136
 137         pFunId :: Parser [Char]
 138         pFunId = pOp
 139                 >>= \i->pChainr <$ pId ? ((==) ['ifxr']) <|> pChainl <$ pId ? ((==)['ifxl'])
 140                 >>= \p->pInt
 141                 >>= \s->addIfx i (p (App o App (Var i) <$ pOp ? ((==)i)), s)
 142
 143         addIfx a i = Parser \ts r->(Right a, ts, [i:r])
 144         getIfx = Parser \ts r->(Right r, ts, r)
 145
 146         pExpression :: Parser Expression
 147         pExpression = getIfx >>= \ifxs->flip (foldr ($))
 148                         (map fst $ sortBy (on (<) snd) ifxs)
 149                 $   pChainl (pure App)
 150                 $   Lambda <$ pToken (TTOp ['\\']) <*> pId <* pToken (TTOp ['.']) <*> pExpression
 151                 <|> pBrack (Var <$> pOp <|> pExpression)
 152                 <|> Lit o Int <$> pInt
 153                 <|> (\(TTBool i)->Lit (Bool i)) <$> pTop ? (\t->t=:(TTBool _))
 154                 <|> (\x->Var ['_':x]) <$ pToken (TTIdent ['code']) <*> pId
 155                 <|> Var <$> pId