Check argument list length

3 files changed, 86 insertions, 64 deletions

diff --git a/TODO b/TODO
index 1cca7c0..ec3d028 100644
--- a/TODO
+++ b/TODO
@@ -10,17 +10,8 @@
 - Don't ignore relocations where the symbol is not defined in the symbol table.
   Report an error about an undefined symbol.
 
-# Name analysis
-
-- Format error messages.
-- Return non-zero error code on errors.
-
 # Register allocation
 
-- Each temporary variales gets a tn register where n is the variable index. If
+- Each temporary variable gets a tn register where n is the variable index. If
   there more variables the allocation will fail with out of bounds runtime
   error. Implement spill over.
-
-# Other
-
-- Type analysis.
diff --git a/lib/Language/Elna/Frontend/TypeAnalysis.hs b/lib/Language/Elna/Frontend/TypeAnalysis.hs
index 7d0b050..2ddbd1c 100644
--- a/lib/Language/Elna/Frontend/TypeAnalysis.hs
+++ b/lib/Language/Elna/Frontend/TypeAnalysis.hs
@@ -3,42 +3,61 @@ module Language.Elna.Frontend.TypeAnalysis
     , -- Error(..)
     ) where
 
+import Control.Monad (unless)
+import Control.Monad.Trans.Class (MonadTrans(..))
+import Control.Monad.Trans.Except (Except, runExcept, throwE)
+import Control.Monad.Trans.Reader (ReaderT, runReaderT, withReaderT, ask)
+import Data.Foldable (traverse_)
+import qualified Data.Vector as Vector
 import qualified Language.Elna.Frontend.AST as AST
-import Language.Elna.Frontend.SymbolTable ({-Info(..), ParameterInfo(..), -}SymbolTable)
+import Language.Elna.Frontend.SymbolTable (Info(..), {-ParameterInfo(..), -}SymbolTable)
+import qualified Language.Elna.Frontend.SymbolTable as SymbolTable
+import Language.Elna.Frontend.Types (Type(..), booleanType, intType)
+import Language.Elna.Location (Identifier(..))
 
-typeAnalysis :: SymbolTable -> AST.Program -> () -- Maybe Error
-typeAnalysis _globalTable = const () {- either Just (const Nothing)
+typeAnalysis :: SymbolTable -> AST.Program -> Maybe Error
+typeAnalysis globalTable = either Just (const Nothing)
     . runExcept
     . flip runReaderT globalTable
     . runTypeAnalysis
-    . program -}
+    . program
 
 {-
 import Control.Applicative (Alternative(..))
-import Control.Monad.Trans.Except (Except, runExcept, throwE)
-import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT, withReaderT, ask)
-import qualified Data.Vector as Vector
-import Language.Elna.Location (Identifier(..))
-import qualified Language.Elna.SymbolTable as SymbolTable
-import Language.Elna.Types (Type(..), booleanType, intType)
-import Control.Monad.Trans.Class (MonadTrans(..))
-import Control.Monad (unless, when)
-import Data.Foldable (traverse_)
-
+-}
 data Error
-    = ArithmeticExpressionError Type
-    | ComparisonExpressionError Type Type
-    | UnexpectedVariableInfoError Info
-    | UnexpectedProcedureInfoError Info
+    = UnexpectedProcedureInfoError Info
     | UndefinedSymbolError Identifier
+    | ParameterCountMismatchError Int Int
+    | UnexpectedVariableInfoError Info
+    | ArithmeticExpressionError Type
+    | ComparisonExpressionError Type Type
     | InvalidConditionTypeError Type
-    | InvalidAssignmentError Type
+{-    | InvalidAssignmentError Type
     | ExpectedLvalueError AST.Expression
-    | ParameterCountMismatchError Int Int
     | ArgumentTypeMismatchError Type Type
     | ArrayIndexError Type
-    | ArrayAccessError Type
-    deriving (Eq, Show)
+    | ArrayAccessError Type -}
+    deriving Eq
+
+instance Show Error
+  where
+    show (UnexpectedProcedureInfoError info) =
+        "Expected to encounter a procedure, got: " <> show info
+    show (UndefinedSymbolError identifier) =
+        concat ["Symbol \"", show identifier, "\" is not defined"]
+    show (ParameterCountMismatchError parameterCount argumentCount)
+        = "The function was expected to receive " <> show argumentCount
+        <> " arguments, but got " <> show parameterCount
+    show (UnexpectedVariableInfoError info) =
+        "Expected to encounter a variable, got: " <> show info
+    show (ArithmeticExpressionError got) =
+        "Expected an arithmetic expression to be an integer, got: " <> show got
+    show (ComparisonExpressionError lhs rhs)
+        = "Expected an arithmetic expression to be an integer, got \""
+        <> show lhs <> "\" and \"" <> show rhs <> "\""
+    show (InvalidConditionTypeError got) =
+        "Expected a condition to be a boolean, got: " <> show got
 
 newtype TypeAnalysis a = TypeAnalysis
     { runTypeAnalysis :: ReaderT SymbolTable (Except Error) a
@@ -61,7 +80,7 @@ program :: AST.Program -> TypeAnalysis ()
 program (AST.Program declarations) = traverse_ declaration declarations
 
 declaration :: AST.Declaration -> TypeAnalysis ()
-declaration (AST.ProcedureDefinition procedureName _ _ body) = do
+declaration (AST.ProcedureDeclaration procedureName _ _ body) = do
     globalTable <- TypeAnalysis ask
     case SymbolTable.lookup procedureName globalTable of
         Just (ProcedureInfo localTable _) -> TypeAnalysis
@@ -72,29 +91,29 @@ declaration (AST.ProcedureDefinition procedureName _ _ body) = do
             $ UnexpectedProcedureInfoError anotherInfo
         Nothing -> TypeAnalysis $ lift $ throwE
             $ UndefinedSymbolError procedureName
-declaration _ = pure ()
+declaration (AST.TypeDefinition _ _) = pure ()
 
 statement :: SymbolTable -> AST.Statement -> TypeAnalysis ()
 statement globalTable = \case
     AST.EmptyStatement -> pure ()
-    AST.AssignmentStatement lhs rhs -> do
+    {- AST.AssignmentStatement lhs rhs -> do
         lhsType <- variableAccess globalTable lhs
         rhsType <- expression globalTable rhs
         unless (lhsType == intType)
             $ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError lhsType
         unless (rhsType == intType)
             $ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError rhsType
+    AST.WhileStatement whileCondition whileStatement -> do
+        conditionType <- condition globalTable whileCondition
+        unless (conditionType == booleanType)
+            $ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError conditionType
+        statement globalTable whileStatement -}
     AST.IfStatement ifCondition ifStatement elseStatement -> do
         conditionType <- condition globalTable ifCondition
         unless (conditionType == booleanType)
             $ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError conditionType
         statement globalTable ifStatement
         maybe (pure ()) (statement globalTable) elseStatement
-    AST.WhileStatement whileCondition whileStatement -> do
-        conditionType <- condition globalTable whileCondition
-        unless (conditionType == booleanType)
-            $ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError conditionType
-        statement globalTable whileStatement
     AST.CompoundStatement statements -> traverse_ (statement globalTable) statements
     AST.CallStatement procedureName arguments ->
         case SymbolTable.lookup procedureName globalTable of
@@ -110,7 +129,7 @@ statement globalTable = \case
             Nothing -> TypeAnalysis $ lift $ throwE
                 $ UndefinedSymbolError procedureName
   where
-    checkArgument ParameterInfo{..} argument = do
+    checkArgument SymbolTable.ParameterInfo{} _argument = pure () {-
         argumentType <- expression globalTable argument
         unless (argumentType == type')
             $ TypeAnalysis $ lift $ throwE $ ArgumentTypeMismatchError type' argumentType
@@ -137,11 +156,11 @@ variableAccess globalTable (AST.ArrayAccess arrayExpression indexExpression) = d
             ArrayType _ baseType -> pure baseType
             nonArrayType -> TypeAnalysis $ lift $ throwE
                 $ ArrayAccessError nonArrayType
-
+-}
 expression :: SymbolTable -> AST.Expression -> TypeAnalysis Type
 expression globalTable = \case
-    AST.VariableExpression variableExpression -> do
-        variableAccess globalTable variableExpression
+    {- AST.VariableExpression variableExpression -> do
+        variableAccess globalTable variableExpression -}
     AST.LiteralExpression literal' -> literal literal'
     AST.NegationExpression negation -> do
         operandType <- expression globalTable negation
@@ -179,8 +198,6 @@ condition globalTable = \case
         else TypeAnalysis $ lift $ throwE $ ComparisonExpressionError lhsType rhsType
 
 literal :: AST.Literal -> TypeAnalysis Type
-literal (AST.IntegerLiteral _) = pure intType
+literal (AST.DecimalLiteral _) = pure intType
 literal (AST.HexadecimalLiteral _) = pure intType
 literal (AST.CharacterLiteral _) = pure intType
-literal (AST.BooleanLiteral _) = pure booleanType
--}
diff --git a/src/Main.hs b/src/Main.hs
index 2e02955..81e5976 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -15,25 +15,39 @@ import Data.Maybe (fromMaybe)
 import System.FilePath (replaceExtension, takeFileName)
 import Text.Megaparsec (runParser, errorBundlePretty)
 import qualified Data.Text.IO as Text
+import System.Exit (ExitCode(..), exitWith)
+import Control.Exception (IOException, catch)
+
+-- * Error codes
+--
+-- 1 - Command line parsing failed and other errors.
+-- 2 - The input could not be read.
+-- 3 - Parse error.
+-- 4 - Name analysis error.
+-- 5 - Type error.
 
 main :: IO ()
-main  = execParser commandLine >>= withCommandLine
+main = execParser commandLine >>= withCommandLine
   where
     withCommandLine CommandLine{..} =
-        let defaultOutput = flip fromMaybe output
-                $ replaceExtension (takeFileName input) "o"
-         in Text.readFile input
-            >>= withParsedInput defaultOutput
+        let defaultOutputName = replaceExtension (takeFileName input) "o"
+            outputName = fromMaybe defaultOutputName output
+         in catch (Text.readFile input) (printAndExit 2 :: IOException -> IO a)
+            >>= withParsedInput outputName
             . runParser programP input
-    withParsedInput output (Right program) =
-        either print (withSymbolTable output program)
-            $ nameAnalysis program
-    withParsedInput _ (Left errorBundle) = putStrLn
-        $ errorBundlePretty errorBundle
-    withSymbolTable output program symbolTable =
-        let _ = typeAnalysis symbolTable program
-            instructions = generateRiscV
-                $ allocate riscVConfiguration
-                $ glue symbolTable program
-         in elfObject output
-            $ riscv32Elf instructions
+    withParsedInput output (Right program)
+        = either (printAndExit 4) (withSymbolTable output program)
+        $ nameAnalysis program
+    withParsedInput _ (Left errorBundle)
+        = putStrLn (errorBundlePretty errorBundle)
+        >> exitWith (ExitFailure 3)
+    withSymbolTable output program symbolTable
+        | Just typeError <- typeAnalysis symbolTable program =
+            printAndExit 5 typeError
+        | otherwise =
+            let instructions = generateRiscV
+                    $ allocate riscVConfiguration
+                    $ glue symbolTable program
+             in elfObject output $ riscv32Elf instructions
+    printAndExit :: Show b => forall a. Int -> b -> IO a
+    printAndExit failureCode e = print e >> exitWith (ExitFailure failureCode)