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