Correctly parsing the example

2 files changed, 124 insertions, 48 deletions

diff --git a/src/SPL/Parse.hs b/src/SPL/Parse.hs
index 4331ccb..28230f8 100644
--- a/src/SPL/Parse.hs
+++ b/src/SPL/Parse.hs
@@ -10,29 +10,26 @@ import Data.Functor
 import Text.Parsec (sepBy, (<?>))
 import qualified Text.Parsec as P
 
-import SPL.Syntax hiding (TInt,TBool,TChar,TArrow)
+import SPL.Syntax hiding (TInt,TBool,TChar,TArrow,TVar)
 import qualified SPL.Syntax
 import SPL.Lex
 
 type Parser t = P.Parsec [Token] () t
 
-satisfy :: (Token -> Bool) -> Parser Token
-satisfy p = P.tokenPrim
-  show
-  (const . const)
-  (\t -> if p t then Just t else Nothing)
+parse :: [Token] -> Either P.ParseError Program
+parse = P.parse spl "Not a valid program" . filter (not . isCommentToken)
+
+check :: (Token -> Maybe a) -> Parser a
+check f = P.tokenPrim show (const . const) f
 
 token :: Token -> Parser Token
-token t = satisfy (== t) <?> show t
+token t = check (\u -> if t == u then Just t else Nothing)
 
-check :: (Token -> Maybe a) -> Parser a
-check f = P.tokenPrim
-  show
-  (const . const)
-  f
+choice :: [Parser a] -> Parser a
+choice = P.choice . map P.try
 
-parse :: [Token] -> Either P.ParseError Program
-parse = P.parse spl "Not a valid program" . filter (not . isCommentToken)
+trans :: Token -> a -> Parser a
+trans t x = token t $> x
 
 spl :: Parser Program
 spl = collect <$> (many toplevel <* P.eof)
@@ -41,19 +38,25 @@ spl = collect <$> (many toplevel <* P.eof)
     collect vfs = Program [f | Right f <- vfs] [v | Left v <- vfs]
 
 toplevel :: Parser (Either Variable Function)
-toplevel = Left <$> var <|> Right <$> fun
+toplevel = choice
+  [ Left  <$> var
+  , Right <$> fun
+  ]
 
 comment :: Parser String
-comment = toString <$> satisfy isCommentToken
-  where
-    toString (TSingleComment s) = s
-    toString (TBlockComment s)  = s
+comment = check $ \case
+  TSingleComment s -> Just s
+  TBlockComment s  -> Just s
+  _                -> Nothing
 
 parenthesised :: Parser a -> Parser a
-parenthesised p = token TParenOpen *> p <* token TParenClose
+parenthesised = P.between (token TParenOpen) (token TParenClose)
 
 braced :: Parser a -> Parser a
-braced p = token TBraceOpen *> p <* token TBraceClose
+braced = P.between (token TBraceOpen) (token TBraceClose)
+
+bracked :: Parser a -> Parser a
+bracked = P.between (token TBrackOpen) (token TBrackClose)
 
 var :: Parser Variable
 var = do
@@ -67,16 +70,18 @@ var = do
 fun :: Parser Function
 fun = do
   id <- ident
-  args <- parenthesised $ ident `sepBy` token TComma
-  ftype <- optional (token TColonColon *> funType)
+  args <- parenthesised (ident `sepBy` token TComma) <?> "arguments"
+  ftype <- optional (token TColonColon *> funType) <?> "optional function type"
   token TBraceOpen
-  vars <- many var
-  stmt <- statements
+  vars <- many (P.try var) <?> "local variables"
+  stmt <- statements <?> "function body"
   token TBraceClose
   return $ Function id ftype args vars stmt
 
 ident :: Parser Name
-ident = (\(TIdent id) -> id) <$> satisfy isIdentToken
+ident = check $ \case
+  TIdent id -> Just id
+  _         -> Nothing
 
 funType :: Parser Type
 funType = do
@@ -86,34 +91,102 @@ funType = do
   return $ SPL.Syntax.TArrow argtypes rettype
 
 plainType :: Parser Type
-plainType = -- TODO
-  token TIntType  $> SPL.Syntax.TInt  <|>
-  token TBoolType $> SPL.Syntax.TBool <|>
-  token TCharType $> SPL.Syntax.TChar
+plainType = choice
+  [ trans TIntType  SPL.Syntax.TInt
+  , trans TBoolType SPL.Syntax.TBool
+  , trans TCharType SPL.Syntax.TChar
+  , trans TVoidType SPL.Syntax.TVoid
+  , TList <$> bracked plainType
+  , parenthesised $ liftM2 TTuple plainType (token TComma *> plainType)
+  , SPL.Syntax.TVar <$> ident
+  ]
 
 expr :: Parser Expression
-expr = literal -- TODO
+expr =
+  rightAssoc (trans TPipePipe Or)  $
+  rightAssoc (trans TAmpAmp   And) $
+  rightAssoc (trans TEqEq     Eq
+          <|> trans TExclamEq Ne
+          <|> trans TLtEq     Le
+          <|> trans TGtEq     Ge
+          <|> trans TLt       Lt
+          <|> trans TGt       Gt) $
+  rightAssoc (trans TColon    Cons) $
+  leftAssoc  (trans TPlus     Add
+          <|> trans TMinus    Sub) $
+  leftAssoc  (trans TAsterisk Mul
+          <|> trans TSlash    Div) $
+  leftAssoc  (trans TPercent  Mod) $
+  fields $
+  simpleExpr
   where
+    rightAssoc :: Parser Op2 -> Parser Expression -> Parser Expression
+    rightAssoc op e = do
+      e1 <- e
+      rest <- optional (liftM2 (,) op (rightAssoc op e))
+      return $ case rest of
+        Nothing      -> e1
+        Just (op,e2) -> Op2 e1 op e2
+
+    leftAssoc :: Parser Op2 -> Parser Expression -> Parser Expression
+    leftAssoc op e = do
+      e1 <- e
+      rest <- many (liftM2 (,) op e)
+      foldM (\e1 (op,e2) -> pure $ Op2 e1 op e2) e1 rest
+
+    fields :: Parser Expression -> Parser Expression
+    fields p = liftM2 (foldl Field) p (many field)
+
+    simpleExpr = choice
+      [ liftM2 Op1 (trans TExclam Not <|> trans TMinus Neg) simpleExpr
+      , literal
+      , tuple
+      , funcall
+      , var
+      , parenthesised expr
+      ]
+
     literal :: Parser Expression
-    literal = fmap Literal $ check $ \case
+    literal = fmap Literal $ nil <|> (check $ \case
       TInt i  -> Just (LInt i)
       TBool b -> Just (LBool b)
-      _       -> Nothing
+      TChar c -> Just (LChar c)
+      _       -> Nothing)
+      where nil = pure LNil <* token TBrackOpen <* token TBrackClose
+
+    tuple = parenthesised (liftM2 Tuple expr (token TComma *> expr))
+
+    funcall = liftM2 FunCall ident (parenthesised $ expr `sepBy` token TComma)
+
+    var = Var <$> ident
 
 statements :: Parser Statement
 statements = foldr1 Seq <$> some statement <|> pure Nop
 
+-- NOTE: we here assume that if/while blocks need not be braced, as in the
+-- example function `abs`. The alternative is using `braced statements`.
 statement :: Parser Statement
-statement =
-  liftM3 If
-    (token TIf *> parenthesised expr)
-    (braced statements)
-    (optional (token TElse *> braced statements)) <|>
-  liftM2 While
-    (token TWhile *> parenthesised expr)
-    (braced statements) <|>
-  liftM2 Assign
-    ident
-    (token TEquals *> expr <* token TSemicolon) <|>
-  Eval <$> (expr <* token TSemicolon) <|>
-  Return <$> (token TReturn *> optional expr <* token TSemicolon)
+statement = choice
+  [ liftM3 If
+      (token TIf *> parenthesised expr)
+      statement
+      (optional (token TElse *> statement))
+  , liftM2 While
+      (token TWhile *> parenthesised expr)
+      statement
+  , Eval <$> (expr <* token TSemicolon)
+  , liftM3 Assign
+      ident
+      (many field)
+      (token TEquals *> expr <* token TSemicolon)
+  , Return <$> (token TReturn *> optional expr <* token TSemicolon)
+  , braced statements
+  ]
+
+field :: Parser Field
+field = token TDot *> check (\case
+  TIdent "hd"  -> Just Hd
+  TIdent "tl"  -> Just Tl
+  TIdent "fst" -> Just Fst
+  TIdent "snd" -> Just Snd
+  _            -> Nothing)
diff --git a/src/SPL/Syntax.hs b/src/SPL/Syntax.hs
index e40d47c..f52b866 100644
--- a/src/SPL/Syntax.hs
+++ b/src/SPL/Syntax.hs
@@ -30,15 +30,17 @@ data Type
   = TInt
   | TBool
   | TChar
+  | TVoid
   | TList Type
   | TTuple Type Type
   | TArrow [Type] Type
+  | TVar Name
   deriving (Show)
 
 data Statement
   = If Expression Statement (Maybe Statement)
   | While Expression Statement
-  | Assign Name Expression
+  | Assign Name [Field] Expression
   | Eval Expression
   | Return (Maybe Expression)
   | Seq Statement Statement
@@ -46,7 +48,8 @@ data Statement
   deriving (Show)
 
 data Expression
-  = Field Name Field
+  = Var Name
+  | Field Expression Field
   | Op2 Expression Op2 Expression
   | Op1 Op1 Expression
   | Literal Literal