Add Intermediate monad stack for the code generation

3 files changed, 181 insertions, 86 deletions

diff --git a/TODO b/TODO
index e1bdc64..e676d1d 100644
--- a/TODO
+++ b/TODO
@@ -1,4 +1,5 @@
 # Intermediate code generation
 
-Execute the generation in a state monad and generate unique labels and
-temporary variable names.
+- Put symbol table in the reader monad and it to the stack
+  or use the state monad for everything.
+- Add errors handling to the monad stack.
diff --git a/elna.cabal b/elna.cabal
index e82cffc..9f07012 100644
--- a/elna.cabal
+++ b/elna.cabal
@@ -21,6 +21,7 @@ common warnings
         text ^>= 2.0
     ghc-options: -Wall
     default-extensions:
+        DataKinds,
         ExplicitForAll,
         LambdaCase,
         OverloadedStrings,
diff --git a/lib/Language/Elna/Intermediate.hs b/lib/Language/Elna/Intermediate.hs
index c2445ae..0cda806 100644
--- a/lib/Language/Elna/Intermediate.hs
+++ b/lib/Language/Elna/Intermediate.hs
@@ -6,6 +6,7 @@ module Language.Elna.Intermediate
     , intermediate
     ) where
 
+import Control.Monad.Trans.State (State, runState, gets, modify')
 import Data.Bifunctor (Bifunctor(..))
 import Data.Int (Int32)
 import Data.HashMap.Strict (HashMap)
@@ -18,6 +19,11 @@ import qualified Language.Elna.AST as AST
 import Language.Elna.Types (Type(..))
 import Language.Elna.SymbolTable (SymbolTable, Info(..))
 import qualified Language.Elna.SymbolTable as SymbolTable
+import Data.Foldable (Foldable(..), foldrM)
+import GHC.Records (HasField(..))
+import qualified Data.Text.Lazy.Builder.Int as Text.Builder
+import qualified Data.Text.Lazy.Builder as Text.Builder
+import qualified Data.Text.Lazy as Text.Lazy
 
 data Operand
     = VariableOperand Variable
@@ -30,6 +36,39 @@ newtype Label = Label Text
 data Variable = Variable Text | TempVariable
     deriving (Eq, Show)
 
+newtype Generator = Generator
+    { labelCounter :: Int32
+    } deriving (Eq, Show)
+
+instance Semigroup Generator
+  where
+    lhs <> rhs = Generator
+        { labelCounter = getField @"labelCounter" lhs + getField @"labelCounter" rhs
+        }
+
+instance Monoid Generator
+  where
+    mempty = Generator
+        { labelCounter = 0
+        }
+
+newtype Intermediate a = Intermediate
+    { runIntermediate :: State Generator a
+    }
+
+instance Functor Intermediate
+  where
+    fmap f (Intermediate x) = Intermediate $ f <$> x
+
+instance Applicative Intermediate
+  where
+    pure = Intermediate . pure
+    (Intermediate f) <*> (Intermediate x) = Intermediate $ f <*> x
+
+instance Monad Intermediate
+  where
+    (Intermediate x) >>= f = Intermediate $ x >>= (runIntermediate . f)
+
 data Quadruple
     = StartQuadruple
     | GoToQuadruple Label
@@ -53,24 +92,49 @@ data Quadruple
     | StopQuadruple
     deriving (Eq, Show)
 
+createLabel :: Intermediate Label
+createLabel = do
+    currentCounter <- Intermediate $ gets labelCounter
+    Intermediate $ modify' modifier
+    pure
+        $ Label
+        $ Text.Lazy.toStrict
+        $ Text.Builder.toLazyText
+        $ Text.Builder.decimal currentCounter
+  where
+    modifier generator = generator
+        { labelCounter = getField @"labelCounter" generator + 1
+        }
+
 intermediate :: SymbolTable -> AST.Program -> HashMap AST.Identifier (Vector Quadruple)
-intermediate globalTable (AST.Program declarations) =
-    foldr go HashMap.empty declarations
+intermediate globalTable
+    = fst
+    . flip runState mempty
+    . runIntermediate
+    . program globalTable
+
+program
+    :: SymbolTable
+    -> AST.Program
+    -> Intermediate (HashMap AST.Identifier (Vector Quadruple))
+program globalTable (AST.Program declarations) =
+    foldrM go HashMap.empty declarations
   where
-    go (AST.TypeDefinition _ _) accumulator = accumulator
-    go (AST.ProcedureDefinition procedureName _ _ statements) accumulator =
-        let translatedStatements
-                = Vector.cons StartQuadruple
-                $ flip Vector.snoc StopQuadruple
-                $ foldMap (statement globalTable) statements
-         in HashMap.insert procedureName translatedStatements accumulator
-
-statement :: SymbolTable -> AST.Statement -> Vector Quadruple
-statement _ AST.EmptyStatement = mempty
-statement localTable (AST.AssignmentStatement variableAccess' assignee) =
-    let (rhsOperand, rhsStatements) = expression localTable assignee
-        variableType' = variableType variableAccess' localTable
-        lhsStatements = case variableAccess localTable variableAccess' Nothing variableType' mempty of
+    go (AST.TypeDefinition _ _) accumulator = pure accumulator
+    go (AST.ProcedureDefinition procedureName _ _ statements) accumulator = do
+        translatedStatements <- Vector.cons StartQuadruple
+            . flip Vector.snoc StopQuadruple
+            . fold
+            <$> traverse (statement globalTable) statements
+        pure $ HashMap.insert procedureName translatedStatements accumulator
+
+statement :: SymbolTable -> AST.Statement -> Intermediate (Vector Quadruple)
+statement _ AST.EmptyStatement = pure mempty
+statement localTable (AST.AssignmentStatement variableAccess' assignee) = do
+    (rhsOperand, rhsStatements) <- expression localTable assignee
+    let variableType' = variableType variableAccess' localTable
+    accessResult <- variableAccess localTable variableAccess' Nothing variableType' mempty
+    pure $ rhsStatements <> case accessResult of
             (AST.Identifier identifier, Just accumulatedIndex, accumulatedStatements) ->
                 Vector.snoc accumulatedStatements
                     $ ArrayAssignQuadruple rhsOperand accumulatedIndex
@@ -79,66 +143,85 @@ statement localTable (AST.AssignmentStatement variableAccess' assignee) =
                 Vector.snoc accumulatedStatements
                     $ AssignQuadruple rhsOperand
                     $ Variable identifier
-     in rhsStatements <> lhsStatements
-statement localTable (AST.IfStatement ifCondition ifStatement elseStatement) =
-    let (conditionStatements, jumpConstructor) = condition localTable ifCondition
-        ifStatements = statement localTable ifStatement
-        ifLabel = Label "L1"
-        endLabel = Label "L2"
-     in conditionStatements <> case statement localTable <$> elseStatement of
+statement localTable (AST.IfStatement ifCondition ifStatement elseStatement) = do
+    (conditionStatements, jumpConstructor) <- condition localTable ifCondition
+    ifLabel <- createLabel
+    endLabel <- createLabel
+    ifStatements <- statement localTable ifStatement
+    possibleElseStatements <- traverse (statement localTable) elseStatement
+    pure $ conditionStatements <> case possibleElseStatements of
         Just elseStatements -> Vector.cons (jumpConstructor ifLabel) elseStatements
             <> Vector.fromList [GoToQuadruple endLabel, LabelQuadruple ifLabel]
             <> Vector.snoc ifStatements (LabelQuadruple endLabel)
         Nothing -> Vector.fromList [jumpConstructor ifLabel, GoToQuadruple endLabel, LabelQuadruple ifLabel]
             <> Vector.snoc ifStatements (LabelQuadruple endLabel)
-statement localTable (AST.WhileStatement whileCondition whileStatement) =
-    let (conditionStatements, jumpConstructor) = condition localTable whileCondition
-        whileStatements = statement localTable whileStatement
-        startLabel = Label "L3"
-        endLabel = Label "L4"
-        conditionLabel = Label "L5"
-     in Vector.fromList [LabelQuadruple conditionLabel]
+statement localTable (AST.WhileStatement whileCondition whileStatement) = do
+    (conditionStatements, jumpConstructor) <- condition localTable whileCondition
+    startLabel <- createLabel
+    endLabel <- createLabel
+    conditionLabel <- createLabel
+    whileStatements <- statement localTable whileStatement
+    pure $ Vector.fromList [LabelQuadruple conditionLabel]
         <> conditionStatements
         <> Vector.fromList [jumpConstructor startLabel, GoToQuadruple endLabel, LabelQuadruple startLabel]
         <> whileStatements
         <> Vector.fromList [GoToQuadruple conditionLabel, LabelQuadruple endLabel]
-statement localTable (AST.CallStatement (AST.Identifier callName) arguments) =
+statement localTable (AST.CallStatement (AST.Identifier callName) arguments) = do
+    visitedArguments <- traverse (expression localTable) arguments
     let (parameterStatements, argumentStatements)
             = bimap (Vector.fromList . fmap ParameterQuadruple) Vector.concat
-            $ unzip
-            $ expression localTable <$> arguments
-     in Vector.snoc (argumentStatements <> parameterStatements)
+            $ unzip visitedArguments
+     in pure
+        $ Vector.snoc (argumentStatements <> parameterStatements)
         $ CallQuadruple (Variable callName)
         $ fromIntegral
         $ Vector.length argumentStatements
 statement localTable (AST.CompoundStatement statements) =
-    foldMap (statement localTable) statements
-
-condition :: SymbolTable -> AST.Condition -> (Vector Quadruple, Label -> Quadruple)
-condition localTable (AST.EqualCondition lhs rhs) =
-    let (lhsOperand, lhsStatements) = expression localTable lhs
-        (rhsOperand, rhsStatements) = expression localTable rhs
-     in (lhsStatements <> rhsStatements, EqualQuadruple lhsOperand rhsOperand)
-condition localTable (AST.NonEqualCondition lhs rhs) =
-    let (lhsOperand, lhsStatements) = expression localTable lhs
-        (rhsOperand, rhsStatements) = expression localTable rhs
-     in (lhsStatements <> rhsStatements, NonEqualQuadruple lhsOperand rhsOperand)
-condition localTable (AST.LessCondition lhs rhs) =
-    let (lhsOperand, lhsStatements) = expression localTable lhs
-        (rhsOperand, rhsStatements) = expression localTable rhs
-     in (lhsStatements <> rhsStatements, LessQuadruple lhsOperand rhsOperand)
-condition localTable (AST.GreaterCondition lhs rhs) =
-    let (lhsOperand, lhsStatements) = expression localTable lhs
-        (rhsOperand, rhsStatements) = expression localTable rhs
-     in (lhsStatements <> rhsStatements, GreaterQuadruple lhsOperand rhsOperand)
-condition localTable (AST.LessOrEqualCondition lhs rhs) =
-    let (lhsOperand, lhsStatements) = expression localTable lhs
-        (rhsOperand, rhsStatements) = expression localTable rhs
-     in (lhsStatements <> rhsStatements, LessOrEqualQuadruple lhsOperand rhsOperand)
-condition localTable (AST.GreaterOrEqualCondition lhs rhs) =
-    let (lhsOperand, lhsStatements) = expression localTable lhs
-        (rhsOperand, rhsStatements) = expression localTable rhs
-     in (lhsStatements <> rhsStatements, GreaterOrEqualQuadruple lhsOperand rhsOperand)
+    fold <$> traverse (statement localTable) statements
+
+condition
+    :: SymbolTable
+    -> AST.Condition
+    -> Intermediate (Vector Quadruple, Label -> Quadruple)
+condition localTable (AST.EqualCondition lhs rhs) = do
+    (lhsOperand, lhsStatements) <- expression localTable lhs
+    (rhsOperand, rhsStatements) <- expression localTable rhs
+    pure
+        ( lhsStatements <> rhsStatements
+        , EqualQuadruple lhsOperand rhsOperand
+        )
+condition localTable (AST.NonEqualCondition lhs rhs) = do
+    (lhsOperand, lhsStatements) <- expression localTable lhs
+    (rhsOperand, rhsStatements) <- expression localTable rhs
+    pure
+        ( lhsStatements <> rhsStatements
+        , NonEqualQuadruple lhsOperand rhsOperand
+        )
+condition localTable (AST.LessCondition lhs rhs) = do
+    (lhsOperand, lhsStatements) <- expression localTable lhs
+    (rhsOperand, rhsStatements) <- expression localTable rhs
+    pure (lhsStatements <> rhsStatements, LessQuadruple lhsOperand rhsOperand)
+condition localTable (AST.GreaterCondition lhs rhs) = do
+    (lhsOperand, lhsStatements) <- expression localTable lhs
+    (rhsOperand, rhsStatements) <- expression localTable rhs
+    pure
+        ( lhsStatements <> rhsStatements
+        , GreaterQuadruple lhsOperand rhsOperand
+        )
+condition localTable (AST.LessOrEqualCondition lhs rhs) = do
+    (lhsOperand, lhsStatements) <- expression localTable lhs
+    (rhsOperand, rhsStatements) <- expression localTable rhs
+    pure
+        ( lhsStatements <> rhsStatements
+        , LessOrEqualQuadruple lhsOperand rhsOperand
+        )
+condition localTable (AST.GreaterOrEqualCondition lhs rhs) = do
+    (lhsOperand, lhsStatements) <- expression localTable lhs
+    (rhsOperand, rhsStatements) <- expression localTable rhs
+    pure
+        ( lhsStatements <> rhsStatements
+        , GreaterOrEqualQuadruple lhsOperand rhsOperand
+        )
 
 variableAccess
     :: SymbolTable
@@ -146,15 +229,15 @@ variableAccess
     -> Maybe Operand
     -> Type
     -> Vector Quadruple
-    -> (AST.Identifier, Maybe Operand, Vector Quadruple)
+    -> Intermediate (AST.Identifier, Maybe Operand, Vector Quadruple)
 variableAccess _ (AST.VariableAccess identifier) accumulatedIndex _ accumulatedStatements =
-    (identifier, accumulatedIndex, accumulatedStatements)
-variableAccess localTable (AST.ArrayAccess access1 index1) Nothing (ArrayType _ baseType) _ =
-    let (indexPlace, statements) = expression localTable index1
-     in variableAccess localTable access1 (Just indexPlace) baseType statements
-variableAccess localTable (AST.ArrayAccess arrayAccess' arrayIndex) (Just baseIndex) (ArrayType arraySize baseType) statements =
-    let (indexPlace, statements') = expression localTable arrayIndex
-        resultVariable = TempVariable
+    pure (identifier, accumulatedIndex, accumulatedStatements)
+variableAccess localTable (AST.ArrayAccess access1 index1) Nothing (ArrayType _ baseType) _ = do
+    (indexPlace, statements) <- expression localTable index1
+    variableAccess localTable access1 (Just indexPlace) baseType statements
+variableAccess localTable (AST.ArrayAccess arrayAccess' arrayIndex) (Just baseIndex) (ArrayType arraySize baseType) statements = do
+    (indexPlace, statements') <- expression localTable arrayIndex
+    let resultVariable = TempVariable
         resultOperand = VariableOperand resultVariable
         indexCalculation = Vector.fromList
             [ ProductQuadruple (IntOperand $ fromIntegral arraySize) baseIndex resultVariable
@@ -171,23 +254,30 @@ variableType (AST.VariableAccess identifier) symbolTable
 variableType (AST.ArrayAccess arrayAccess' _) symbolTable =
     variableType arrayAccess' symbolTable
 
-expression :: SymbolTable -> AST.Expression -> (Operand, Vector Quadruple)
+expression :: SymbolTable -> AST.Expression -> Intermediate (Operand, Vector Quadruple)
 expression localTable = \case
-    (AST.VariableExpression variableExpression) ->
+    (AST.VariableExpression variableExpression) -> do
         let variableType' = variableType variableExpression localTable
-         in case variableAccess localTable variableExpression Nothing variableType' mempty of
+        variableAccess' <- variableAccess localTable variableExpression Nothing variableType' mempty
+        case variableAccess' of
             (AST.Identifier identifier, Nothing, statements) ->
-                (VariableOperand (Variable identifier), statements)
+                pure (VariableOperand (Variable identifier), statements)
             (AST.Identifier identifier, Just operand, statements) ->
                 let arrayAddress = TempVariable
                     arrayStatement = ArrayQuadruple (Variable identifier) operand arrayAddress
-                 in (VariableOperand arrayAddress, Vector.snoc statements arrayStatement)
-    (AST.LiteralExpression literal') -> (literal literal', mempty)
-    (AST.NegationExpression negation) ->
-        let (operand, statements) = expression localTable negation
-            tempVariable = TempVariable
+                 in pure
+                    ( VariableOperand arrayAddress
+                    , Vector.snoc statements arrayStatement
+                    )
+    (AST.LiteralExpression literal') -> pure (literal literal', mempty)
+    (AST.NegationExpression negation) -> do
+        (operand, statements) <- expression localTable negation
+        let tempVariable = TempVariable
             negationQuadruple = NegationQuadruple operand tempVariable
-         in (VariableOperand tempVariable, Vector.snoc statements negationQuadruple)
+         in pure
+            ( VariableOperand tempVariable
+            , Vector.snoc statements negationQuadruple
+            )
     (AST.SumExpression lhs rhs) -> binaryExpression AddQuadruple lhs rhs
     (AST.SubtractionExpression lhs rhs) ->
         binaryExpression SubtractionQuadruple lhs rhs
@@ -196,12 +286,15 @@ expression localTable = \case
     (AST.DivisionExpression lhs rhs) ->
         binaryExpression DivisionQuadruple lhs rhs
   where
-    binaryExpression f lhs rhs = 
-        let (lhsOperand, lhsStatements) = expression localTable lhs
-            (rhsOperand, rhsStatements) = expression localTable rhs
-            tempVariable = TempVariable
+    binaryExpression f lhs rhs = do
+        (lhsOperand, lhsStatements) <- expression localTable lhs
+        (rhsOperand, rhsStatements) <- expression localTable rhs
+        let tempVariable = TempVariable
             newQuadruple = f lhsOperand rhsOperand tempVariable
-         in (VariableOperand tempVariable, Vector.snoc (lhsStatements <> rhsStatements) newQuadruple)
+         in pure
+            ( VariableOperand tempVariable
+            , Vector.snoc (lhsStatements <> rhsStatements) newQuadruple
+            )
 
 literal :: AST.Literal -> Operand
 literal (AST.IntegerLiteral integer) = IntOperand integer