src/parse.icl

   1 implementation module parse
   2
   3 import StdString
   4 import StdTuple
   5 import StdList
   6 from StdFunc import const
   7 import Data.Either
   8 import Data.Functor
   9 import Data.Maybe
  10 import Control.Monad
  11 import Control.Applicative
  12 import Data.Func
  13 from Data.List import intercalate, replicate
  14 from Text import class Text(concat), instance Text String
  15
  16 import yard
  17 import lex
  18
  19 parser :: LexerOutput -> ParserOutput
  20 parser (Left e) = Left $ toString $ LexError e
  21 parser (Right r) = case runParser parseProgram r of
  22         (Right p, _) = Right p
  23         (Left e, _) = Left $ toString e
  24
  25 parseProgram :: Parser Token AST
  26 parseProgram = many parseVarDecl
  27         >>= \vd->some parseFunDecl
  28         >>= \fd->pure $ AST vd fd
  29
  30 parseFunDecl :: Parser Token FunDecl
  31 parseFunDecl = parseIdent <* satTok BraceOpenToken
  32         >>= \ident->parseSepList CommaToken parseIdent <* satTok BraceCloseToken
  33         >>= \args->parseFunType <* satTok CBraceOpenToken
  34         >>= \funtype->many parseVarDecl
  35         >>= \vardecls->many parseStmt
  36         <* satTok CBraceCloseToken
  37         >>= \stmts->pure $ FunDecl ident args funtype vardecls stmts
  38
  39 parseStmt :: Parser Token Stmt
  40 parseStmt = parseIfStmt <|>
  41         parseWhileStmt <|>
  42         (parseAssStmt <* satTok SColonToken) <|>
  43         (parseReturnStmt <* satTok SColonToken) <|>
  44         (parseFunCall <* satTok SColonToken >>= \fc->pure $ FunStmt fc)
  45         where
  46                 parseReturnStmt :: Parser Token Stmt
  47                 parseReturnStmt = satTok ReturnToken
  48                         *> optional parseExpr >>= \me->pure $ ReturnStmt me
  49
  50                 parseAssStmt :: Parser Token Stmt
  51                 parseAssStmt = parseVarDef <* satTok AssignmentToken
  52                         >>= \var-> parseExpr >>= \expr->pure $ AssStmt var expr
  53
  54                 parseIfStmt :: Parser Token Stmt
  55                 parseIfStmt = satTok IfToken
  56                         *> parseBBraces parseExpr
  57                         >>= \pred->parseBCBraces (many parseStmt)
  58                         >>= \thens->optional (
  59                                 satTok ElseToken *> parseBCBraces (many parseStmt)
  60                         )>>= \elses->pure $ IfStmt pred thens (fromMaybe [] elses)
  61
  62                 parseWhileStmt :: Parser Token Stmt
  63                 parseWhileStmt = satTok WhileToken *> parseBBraces parseExpr
  64                         >>= \pred->parseBCBraces (many parseStmt)
  65                         >>= \body->pure $ WhileStmt pred body
  66
  67 parseBBraces :: (Parser Token a) -> Parser Token a
  68 parseBBraces p = satTok BraceOpenToken *> p <* satTok BraceCloseToken
  69
  70 parseBCBraces :: (Parser Token a) -> Parser Token a
  71 parseBCBraces p = satTok CBraceOpenToken *> p <* satTok CBraceCloseToken
  72
  73 parseFunType :: Parser Token FunType
  74 parseFunType = satTok DoubleColonToken *>
  75         (parseInOutType <|> (parseVoidOrType >>= \t->pure $ FunType [] t))
  76         where
  77                 parseInOutType :: Parser Token FunType
  78                 parseInOutType = some parseType <* satTok ArrowToken
  79                         >>= \intypes-> parseVoidOrType
  80                         >>= \outtypes->pure $ FunType intypes outtypes
  81
  82                 parseVoidOrType :: Parser Token (Maybe Type)
  83                 parseVoidOrType = (satTok VoidToken *> pure Nothing) <|>
  84                         (parseType >>= \type->pure $ Just type)
  85
  86 parseVarDecl :: Parser Token VarDecl
  87 parseVarDecl =
  88         (parseType <|> trans1 VarToken VarType )
  89         >>= \t->parseIdent <* satTok AssignmentToken
  90         >>= \i->parseExpr <* satTok SColonToken
  91         >>= \e->pure $ VarDecl i t e
  92
  93 parseType :: Parser Token Type
  94 parseType =
  95         trans1 IntTypeToken IntType <|>
  96         trans1 CharTypeToken CharType <|>
  97         trans1 BoolTypeToken BoolType <|>
  98         (satTok SquareOpenToken *> parseType <* satTok SquareCloseToken
  99                 >>= \t.pure $ ListType t) <|>
 100         (satTok BraceOpenToken *> parseType <* satTok CommaToken
 101                 >>= \t1->parseType <* satTok BraceCloseToken
 102                 >>= \t2->pure $ TupleType t1 t2) <|>
 103         (parseIdent >>= \e.pure $ IdType e) <|>
 104         empty
 105
 106 parseExpr :: Parser Token Expr
 107 parseExpr = //Operators in order of binding strength
 108         parseOpR (trans1 ColonToken BiCons) $
 109         parseOpR (trans1 PipesToken BiOr) $
 110         parseOpR (trans1 AmpersandsToken BiAnd) $
 111         parseOpR (trans1 EqualsToken BiEquals <|>
 112                         trans1 LesserToken BiLesser <|>
 113                         trans1 BiggerToken BiGreater <|>
 114                         trans1 LesserEqToken BiLesserEq <|>
 115                         trans1 GreaterEqToken BiGreaterEq <|>
 116                         trans1 NotEqualToken BiUnEqual) $
 117         parseOpL (trans1 PlusToken BiPlus <|>
 118                         trans1 DashToken BiMinus) $
 119         parseOpL (trans1 StarToken BiTimes <|>
 120                         trans1 SlashToken BiDivide <|>
 121                         trans1 PercentToken BiMod) $ parseBasicExpr
 122         where
 123                 parseOpR :: (Parser Token Op2) (Parser Token Expr) -> Parser Token Expr
 124                 parseOpR ops prev = prev >>= \e1->optional (
 125                                 ops >>= \op->parseOpR ops prev >>= \e->pure (op, e)
 126                         ) >>= \moe->pure $ maybe e1 (\(op,e2)->Op2Expr e1 op e2) moe
 127
 128                 parseOpL :: (Parser Token Op2) (Parser Token Expr) -> Parser Token Expr
 129                 parseOpL ops prev = prev >>= \e1->many (
 130                                 ops >>= \op->prev >>= \e->pure (op, e)
 131                         ) >>= \moe->foldM (\e->(\(op,e2)->pure $ Op2Expr e op e2)) e1 moe
 132
 133                 parseBasicExpr :: Parser Token Expr
 134                 parseBasicExpr =
 135                         (satTok BraceOpenToken *> parseExpr <* satTok CommaToken
 136                                 >>= \e1->parseExpr <* satTok BraceCloseToken
 137                                 >>= \e2->pure $ TupleExpr e1 e2) <|>
 138                         (parseFunCall >>= \fc->pure $ FunExpr fc) <|>
 139                         parseBBraces parseExpr <|>
 140                         trans1 EmptyListToken EmptyListExpr <|>
 141                         trans2 TrueToken (const $ BoolExpr True) <|>
 142                         trans2 FalseToken (const $ BoolExpr False) <|>
 143                         trans2 (NumberToken zero) (\(NumberToken i)->IntExpr i) <|>
 144                         trans2 (CharToken zero) (\(CharToken c)->CharExpr c) <|>
 145                         (parseOp1 >>= \o->parseExpr >>= \e.pure $ Op1Expr o e) <|>
 146                         (parseVarDef >>= \ve->pure $ VarExpr ve)
 147
 148 parseFunCall :: Parser Token FunCall
 149 parseFunCall = parseIdent <* satTok BraceOpenToken
 150         >>= \i->parseSepList CommaToken parseExpr
 151         <* satTok BraceCloseToken >>= \es->pure $ FunCall i es
 152
 153 parseVarDef :: Parser Token VarDef
 154 parseVarDef = parseIdent
 155         >>= \i-> many (satTok DotToken *> (
 156                 (parseIdent >>= (\i.if (i == "hd") (pure FieldHd) empty)) <|>
 157                 (parseIdent >>= \i.if (i == "tl") (pure FieldTl) empty) <|>
 158                 (parseIdent >>= \i.if (i == "fst") (pure FieldFst) empty) <|>
 159                 (parseIdent >>= \i.if (i == "snd") (pure FieldSnd) empty))
 160         ) >>= \f->pure $ VarDef i f
 161
 162 parseOp1 :: Parser Token Op1
 163 parseOp1 = trans1 DashToken UnMinus <|>
 164         trans1 ExclamationToken UnNegation
 165
 166 trans2 :: TokenValue (TokenValue -> a) -> Parser Token a
 167 trans2 t f = satTok t >>= \(_, r).pure (f r)
 168
 169 trans1 :: TokenValue a -> Parser Token a
 170 trans1 t r = trans2 t $ const r
 171
 172 satTok :: TokenValue -> Parser Token Token
 173 satTok t = satisfy ((===) t)
 174
 175 parseSepList :: TokenValue (Parser Token a) -> Parser Token [a]
 176 parseSepList sep p =
 177         (some (p <* satTok sep) >>= \es->p >>= \e.pure $ reverse [e:es]) <|>
 178         (p >>= \e->pure [e]) <|> pure []
 179
 180 parseIdent :: Parser Token String
 181 parseIdent = trans2 (IdentToken []) (\(IdentToken e).toString e)
 182
 183 instance toString AST where
 184         toString (AST v f) = concat (
 185                 ["\n":printersperse "\n" v] ++
 186                 ["\n":printersperse "\n" f])
 187
 188 class print a :: a -> [String]
 189
 190 printersperse :: String [a] -> [String] | print a
 191 printersperse i j = intercalate [i] (map print j)
 192
 193 instance print FunDecl where
 194         print (FunDecl i as t vs ss) =
 195                 ["\n", i, " (":printersperse "," as] ++
 196                 [") :: ":print t] ++
 197                 ["{\n\t":printersperse "\n\t" vs] ++
 198                 ["\n":printStatements ss 1] ++ ["\n}"]
 199
 200 printStatements :: [Stmt] Int -> [String]
 201 printStatements [] i = []
 202 printStatements [s:ss] i = (case s of
 203         (IfStmt b thens elses) = indent i ["if (":print b] ++ ["){\n"] ++
 204                 printStatements thens (i+1) ++
 205                 indent i ["} else {\n":printStatements elses (i+1)] ++
 206                 indent i ["}\n"]
 207         (WhileStmt b dos) = indent i ["while (":print b] ++
 208                 ["){\n":printStatements dos (i+1)] ++ indent i ["}\n"]
 209         (AssStmt vardef val) =
 210                 indent i $ print vardef ++ ["=":print val] ++ [";\n"]
 211         (FunStmt fc) = indent i $ print fc ++ [";\n"]
 212         (ReturnStmt me) = indent i ["return ":maybe [""] print me] ++ [";\n"]
 213         ) ++ printStatements ss i
 214
 215 indent :: Int [String] -> [String]
 216 indent i rest = replicate i "\t" ++ rest
 217
 218 instance print FunType where
 219         print (FunType at rt) = printersperse " " at ++
 220                 [if (isEmpty at) "" "->":maybe ["Void"] print rt]
 221
 222 instance print VarDecl where
 223         print (VarDecl i t e) = print t ++ [" ":i:"=":print e] ++ [";"]
 224
 225 instance print Type where
 226         print (TupleType t1 t2) = ["(":print t1] ++ [",":print t2] ++ [")"]
 227         print (ListType t) = ["[":print t] ++ ["]"]
 228         print (IdType s) = print s
 229         print IntType = print "Int"
 230         print BoolType = print "Bool"
 231         print CharType = print "Char"
 232         print VarType = print "var"
 233
 234 instance print String where
 235         print s = [s]
 236
 237 instance print FieldSelector where
 238         print FieldHd = print "hd"
 239         print FieldTl = print "tl"
 240         print FieldSnd = print "snd"
 241         print FieldFst = print "fst"
 242
 243 instance print VarDef where
 244         print (VarDef i fs) = printersperse "." [i:flatten $ map print fs]
 245
 246 instance print FunCall where
 247         print (FunCall i args) = [i,"(":printersperse "," args] ++ [")"]
 248
 249 instance print Expr where
 250         print (VarExpr vd) = print vd
 251         print (Op2Expr e1 o e2) = ["(":print e1] ++ [" ",case o of
 252                 BiPlus = "+"; BiMinus = "-"; BiTimes = "*"; BiDivide = "/"
 253                 BiMod = "%"; BiEquals = "="; BiLesser = "<"; BiGreater = ">"
 254                 BiLesserEq = "<="; BiGreaterEq = ">="; BiUnEqual = "!=";
 255                 BiAnd = "&&"; BiOr = "||"; BiCons = ":"
 256                 ," ":print e2] ++ [")"]
 257         print (Op1Expr o e) = ["(",case o of
 258                 UnNegation = "!"; UnMinus = "-"
 259                 :print e] ++ [")"]
 260         print (IntExpr i) = [toString i]
 261         print (CharExpr c) = ["\'", case c of
 262                 '\b' = "\\b"; '\f' = "\\f"; '\n' = "\\n"
 263                 '\r' = "\\r"; '\t' = "\\t"; '\v' = "\\v"
 264                 c = if (c == toChar 7) "\\a" (toString c)
 265                 ,"\'"]
 266         print (BoolExpr b) = [toString b]
 267         print (FunExpr fc) = print fc
 268         print EmptyListExpr = ["[]"]
 269         print (TupleExpr e1 e2) = ["(":print e1] ++ [",":print e2] ++ [")"]