Parse all statements

lib/Language/Elna/AST.hs

@@ -12,11 +12,12 @@ module Language.Elna.AST
 
 import Data.Int (Int32)
 import Data.List (intercalate)
-import Data.Word (Word8)
+import Data.Word (Word16)
 import Data.Text (Text)
 import qualified Data.Text as Text
 import Data.Char (chr)
 import Data.String (IsString(..))
+import Numeric (showHex)
 
 newtype Identifier = Identifier { unIdentifier :: Text }
     deriving Eq
@@ -43,14 +44,14 @@ instance Show TypeExpression
 data Literal
     = IntegerLiteral Int32
     | HexadecimalLiteral Int32
-    | CharacterLiteral Word8
+    | CharacterLiteral Word16
     | BooleanLiteral Bool
     deriving Eq
 
 instance Show Literal
   where
     show (IntegerLiteral integer) = show integer
-    show (HexadecimalLiteral integer) = show integer
+    show (HexadecimalLiteral integer) = '0' : 'x' : showHex integer ""
     show (CharacterLiteral character) =
         '\'' : chr (fromEnum character) : ['\'']
     show (BooleanLiteral boolean)
@@ -84,7 +85,7 @@ instance Show Expression
     show (ProductExpression lhs rhs) = concat [show lhs, " * ", show rhs]
     show (DivisionExpression lhs rhs) = concat [show lhs, " / ", show rhs]
     show (EqualExpression lhs rhs) = concat [show lhs, " = ", show rhs]
-    show (NonEqualExpression lhs rhs) = concat [show lhs, " /= ", show rhs]
+    show (NonEqualExpression lhs rhs) = concat [show lhs, " # ", show rhs]
     show (LessExpression lhs rhs) = concat [show lhs, " < ", show rhs]
     show (GreaterExpression lhs rhs) = concat [show lhs, " > ", show rhs]
     show (LessOrEqualExpression lhs rhs) = concat [show lhs, " <= ", show rhs]
@@ -105,17 +106,16 @@ instance Show Statement
   where
     show EmptyStatement = ";"
     show (AssignmentStatement lhs rhs) =
-        concat [show lhs, " := ", show rhs, show rhs, ";"]
+        concat [show lhs, " := ", show rhs, ";"]
     show (IfStatement condition if' else') = concat
         [ "if (", show condition, ") "
         , show if'
         , maybe "" ((<> " else ") . show) else'
-        , ";"
         ]
     show (WhileStatement expression statement) =
-        concat [ "while (", show expression, ") ", show statement, ";"]
+        concat ["while (", show expression, ") ", show statement, ";"]
-    show (CompoundStatement statements) = "begin "
+    show (CompoundStatement statements) =
-        <> intercalate "; " (show <$> statements) <> " end"
+        concat ["{\n", unlines (show <$> statements), " }"]
     show (CallStatement name parameters) = show name <> "("
         <> intercalate ", " (show <$> parameters) <> ")"
 
@@ -136,7 +136,7 @@ data VariableDeclaration =
 instance Show VariableDeclaration
   where
     show (VariableDeclaration identifier typeExpression) =
-        concat [" var ", show identifier, ": " <> show typeExpression, ";"]
+        concat ["var ", show identifier, ": " <> show typeExpression, ";"]
 
 data Declaration
     = TypeDefinition Identifier TypeExpression
@@ -146,11 +146,12 @@ data Declaration
 instance Show Declaration
   where
     show (TypeDefinition identifier typeExpression) =
-        concat ["type ", show identifier, " = ", show typeExpression]
+        concat ["type ", show identifier, " = ", show typeExpression, ";"]
     show (ProcedureDefinition procedureName parameters variables body)
-        = "proc " <> show procedureName <> showParameters parameters <> ";"
+        = "proc " <> show procedureName <> showParameters parameters <> " {\n"
-        <> unlines (show <$> variables)
+        <> unlines (("  " <>) . show <$> variables)
-        <> unlines (show <$> body) <> ";"
+        <> unlines (("  " <>) . show <$> body)
+        <> "}"
 
 newtype Program = Program [Declaration]
     deriving Eq

lib/Language/Elna/Parser.hs

@@ -19,8 +19,22 @@ import Language.Elna.AST
     , TypeExpression(..)
     , VariableDeclaration(..)
     )
-import Text.Megaparsec (Parsec, (<?>), optional, between, sepBy, choice)
+import Text.Megaparsec
-import Text.Megaparsec.Char (alphaNumChar, char, letterChar, space1, asciiChar)
+    ( Parsec
+    , (<?>)
+    , optional
+    , between
+    , sepBy
+    , choice
+    , MonadParsec(..)
+    )
+import Text.Megaparsec.Char
+    ( alphaNumChar
+    , char
+    , letterChar
+    , space1
+    , string
+    )
 import qualified Text.Megaparsec.Char.Lexer as Lexer
 import Control.Applicative (Alternative(..))
 import Data.Maybe (isJust)
@@ -91,33 +105,32 @@ parameterP = paramCons
   where
     paramCons ref name typeName = Parameter name typeName (isJust ref)
 
-parametersP :: Parser [Parameter]
+commaP :: Parser ()
-parametersP = parensP $ sepBy parameterP (symbol ",")
+commaP = void $ symbol ","
 
 literalP :: Parser Literal
 literalP
-    = HexadecimalLiteral <$> Lexer.hexadecimal
+    = HexadecimalLiteral <$> (string "0x" *> lexeme Lexer.hexadecimal)
-    <|> IntegerLiteral <$> Lexer.decimal
+    <|> IntegerLiteral <$> lexeme Lexer.decimal
-    <|> CharacterLiteral <$> charP
+    <|> CharacterLiteral <$> lexeme charP
     <|> BooleanLiteral <$> (symbol "true" $> True)
     <|> BooleanLiteral <$> (symbol "false" $> False)
   where
-    -- TODO: Escape characters.
     charP = fromIntegral . fromEnum
-        <$> between (char '\'') (char '\'') asciiChar
+        <$> between (char '\'') (char '\'') Lexer.charLiteral
 
 termP :: Parser Expression
 termP = choice
     [ parensP expressionP
-    , VariableExpression <$> identifierP
     , LiteralExpression <$> literalP
+    , VariableExpression <$> identifierP
     ]
 
 operatorTable :: [[Operator Parser Expression]]
 operatorTable =
-    [ [Postfix (ArrayExpression <$> bracketsP expressionP)]
+    [ [Postfix (flip ArrayExpression <$> bracketsP expressionP)]
     , unaryOperator
-    , factoryOperator
+    , factorOperator
     , termOperator
     , comparisonOperator
     ]
@@ -126,7 +139,7 @@ operatorTable =
         [ prefix "-" NegationExpression
         , prefix "+" id
         ]
-    factoryOperator =
+    factorOperator =
         [ binary "*" ProductExpression
         , binary "/" DivisionExpression
         ]
@@ -151,17 +164,39 @@ expressionP = makeExprParser termP operatorTable
 statementP :: Parser Statement
 statementP
     = EmptyStatement <$ semicolonP
-    <|> AssignmentStatement <$> expressionP <* symbol ":=" <*> expressionP
     <|> CompoundStatement <$> blockP (many statementP)
-    <?> "statement" -- TODO: further statements
+    <|> try assignmentP
+    <|> try ifElseP
+    <|> try whileP
+    <|> try callP
+    <?> "statement"
+  where
+    ifElseP = IfStatement
+        <$> (symbol "if" *> parensP expressionP)
+        <*> statementP
+        <*> optional (symbol "else" *> statementP)
+    whileP = WhileStatement
+        <$> (symbol "while" *> parensP expressionP)
+        <*> statementP
+    callP = CallStatement
+        <$> identifierP
+        <*> parensP (sepBy expressionP commaP)
+        <* semicolonP
+    assignmentP = AssignmentStatement
+        <$> expressionP
+        <* symbol ":="
+        <*> expressionP
+        <* semicolonP
 
 procedureDefinitionP :: Parser Declaration
-procedureDefinitionP = ProcedureDefinition
+procedureDefinitionP = procedureCons
     <$> (procedureP *> identifierP)
-    <*> parametersP
+    <*> parensP (sepBy parameterP commaP)
-    <*> blockP (many variableDeclarationP)
+    <*> blockP ((,) <$> many variableDeclarationP <*> many statementP)
-    <*> pure mempty -- TODO
     <?> "procedure definition"
+  where
+    procedureCons procedureName parameters (variables, body) =
+        ProcedureDefinition procedureName parameters variables body
 
 declarationP :: Parser Declaration
 declarationP = typeDefinitionP <|> procedureDefinitionP

tests/Language/Elna/ParserSpec.hs

@@ -2,14 +2,18 @@ module Language.Elna.ParserSpec
     ( spec
     ) where
 
-import Test.Hspec (Spec, describe, it, pendingWith, xit)
+import Test.Hspec (Spec, describe, it)
 import Test.Hspec.Megaparsec (shouldParse, shouldSucceedOn, parseSatisfies)
 import Language.Elna.Parser (programP)
 import Text.Megaparsec (parse)
 import Language.Elna.AST
     ( Declaration(..)
+    , Expression(..)
+    , Literal(..)
+    , Statement(..)
     , Parameter(..)
     , Program(..)
+    , VariableDeclaration(..)
     , TypeExpression(..)
     )
 
@@ -54,5 +58,85 @@ spec =
                 actual = parse programP "" given
              in actual `parseSatisfies` expected
 
-        it "parses procedure body statements" $
+        it "parses negation" $
-            pendingWith "Not implemented"
+            let given = "proc main(x: integer) { var y: integer; y := -x; }"
+                parameters = pure $ Parameter "x" (NamedType "integer") False
+                variables = pure
+                    $ VariableDeclaration "y"
+                    $ NamedType "integer"
+                body = pure
+                    $ AssignmentStatement (VariableExpression "y")
+                    $ NegationExpression
+                    $ VariableExpression "x"
+                expected = Program
+                    [ProcedureDefinition "main" parameters variables body]
+                actual = parse programP "" given
+             in actual `shouldParse` expected
+
+        it "parses comparison with lower precedence than other binary operators" $
+            let given = "proc main() { var x: boolean; x := 1 + 2 = 3 * 4; }"
+                variables = pure
+                    $ VariableDeclaration "x"
+                    $ NamedType "boolean"
+                lhs = SumExpression (LiteralExpression (IntegerLiteral 1))
+                    $ LiteralExpression (IntegerLiteral 2)
+                rhs = ProductExpression (LiteralExpression (IntegerLiteral 3))
+                    $ LiteralExpression (IntegerLiteral 4)
+                body = pure
+                    $ AssignmentStatement (VariableExpression "x")
+                    $ EqualExpression lhs rhs
+                expected = Program
+                    [ProcedureDefinition "main" [] variables body]
+                actual = parse programP "" given
+             in actual `shouldParse` expected
+
+        it "parses hexadecimals" $
+            let given = "proc main() { var x: integer; x := 0x10; }"
+                variables = pure
+                    $ VariableDeclaration "x"
+                    $ NamedType "integer"
+                body = pure
+                    $ AssignmentStatement (VariableExpression "x")
+                    $ LiteralExpression (HexadecimalLiteral 16)
+                expected = Program
+                    [ProcedureDefinition "main" [] variables body]
+                actual = parse programP "" given
+             in actual `shouldParse` expected
+
+        it "parses procedure calls" $
+            let given = "proc main() { f('c'); }"
+                body = pure
+                    $ CallStatement "f" [LiteralExpression (CharacterLiteral 99)]
+                expected = Program
+                    [ProcedureDefinition "main" [] [] body]
+                actual = parse programP "" given
+             in actual `shouldParse` expected
+
+        it "parses an if statement" $
+            let given = "proc main() { if (true) ; }"
+                body = pure
+                    $ IfStatement (LiteralExpression $ BooleanLiteral True) EmptyStatement Nothing
+                expected = Program
+                    [ProcedureDefinition "main" [] [] body]
+                actual = parse programP "" given
+             in actual `shouldParse` expected
+
+        it "associates else with the nearst if statement" $
+            let given = "proc main() { if (true) if (false) ; else ; }"
+                if' = IfStatement (LiteralExpression $ BooleanLiteral False) EmptyStatement
+                    $ Just EmptyStatement
+                body = pure
+                    $ IfStatement (LiteralExpression $ BooleanLiteral True) if' Nothing
+                expected = Program
+                    [ProcedureDefinition "main" [] [] body]
+                actual = parse programP "" given
+             in actual `shouldParse` expected
+
+        it "parses a while statement" $
+            let given = "proc main() { while (true) ; }"
+                body = pure
+                    $ WhileStatement (LiteralExpression $ BooleanLiteral True) EmptyStatement
+                expected = Program
+                    [ProcedureDefinition "main" [] [] body]
+                actual = parse programP "" given
+             in actual `shouldParse` expected