1 files changed, 270 insertions, 0 deletions
diff --git a/lib/Language/Elna/Glue.hs b/lib/Language/Elna/Glue.hs
new file mode 100644
index 0000000..2313b2b
--- /dev/null
+++ b/lib/Language/Elna/Glue.hs
@@ -0,0 +1,270 @@
+module Language.Elna.Glue
+    ( glue
+    ) where
+
+import Control.Monad.Trans.State (State, get, modify', runState)
+import Data.Bifunctor (Bifunctor(..))
+import Data.Foldable (Foldable(..))
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+import Data.Maybe (catMaybes)
+import Data.Vector (Vector)
+import qualified Data.Vector as Vector
+import Data.Word (Word32)
+import qualified Language.Elna.Frontend.AST as AST
+import Language.Elna.Backend.Intermediate (Operand(..), Quadruple(..), Variable(..))
+import Language.Elna.Frontend.SymbolTable (SymbolTable{-, Info(..) -})
+
+newtype Glue a = Glue
+    { runGlue :: State Word32 a }
+
+instance Functor Glue
+  where
+    fmap f (Glue x) = Glue $ f <$> x
+
+instance Applicative Glue
+  where
+    pure = Glue . pure
+    (Glue f) <*> (Glue x) = Glue $ f <*> x
+
+instance Monad Glue
+  where
+    (Glue x) >>= f = Glue $ x >>= (runGlue . f)
+
+glue :: SymbolTable -> AST.Program -> HashMap AST.Identifier (Vector (Quadruple Variable))
+glue globalTable
+    = fst
+    . flip runState 0
+    . runGlue
+    . program globalTable
+
+program
+    :: SymbolTable
+    -> AST.Program
+    -> Glue (HashMap AST.Identifier (Vector (Quadruple Variable)))
+program globalTable (AST.Program declarations) = HashMap.fromList . catMaybes
+    <$> traverse (declaration globalTable) declarations
+
+declaration
+    :: SymbolTable
+    -> AST.Declaration
+    -> Glue (Maybe (AST.Identifier, Vector (Quadruple Variable)))
+declaration globalTable (AST.ProcedureDeclaration procedureName _ _ statements)
+    = Just
+    . (procedureName,)
+    . Vector.cons StartQuadruple
+    . flip Vector.snoc StopQuadruple
+    . fold
+    <$> traverse (statement globalTable) statements
+-- declaration (AST.TypeDefinition _ _) accumulator = pure accumulator
+
+statement :: SymbolTable -> AST.Statement -> Glue (Vector (Quadruple Variable))
+statement _ AST.EmptyStatement = pure mempty
+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 visitedArguments
+     in pure
+        $ Vector.snoc (argumentStatements <> parameterStatements)
+        $ CallQuadruple callName
+        $ fromIntegral
+        $ Vector.length argumentStatements
+{- 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
+                    $ Variable identifier
+            (AST.Identifier identifier, Nothing, accumulatedStatements) ->
+                Vector.snoc accumulatedStatements
+                    $ AssignQuadruple rhsOperand
+                    $ Variable identifier
+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) = 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.CompoundStatement statements) =
+    fold <$> traverse (statement localTable) statements -}
+
+createTemporary :: Glue Variable
+createTemporary = do
+    currentCounter <- Glue get
+    Glue $ modify' (+ 1)
+    pure $ TempVariable currentCounter
+
+{-
+import Language.Elna.Types (Type(..))
+import qualified Language.Elna.SymbolTable as SymbolTable
+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
+
+newtype Label = Label Text
+    deriving Eq
+
+instance Show Label
+  where
+    show (Label label) = '.' : Text.unpack label
+
+createLabel :: Glue Label
+createLabel = do
+    currentCounter <- Glue $ gets labelCounter
+    Glue $ modify' modifier
+    pure
+        $ Label
+        $ Text.Lazy.toStrict
+        $ Text.Builder.toLazyText
+        $ Text.Builder.decimal currentCounter
+  where
+    modifier generator = generator
+        { labelCounter = getField @"labelCounter" generator + 1
+        }
+
+condition
+    :: SymbolTable
+    -> AST.Condition
+    -> Glue (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
+    -> AST.VariableAccess
+    -> Maybe Operand
+    -> Type
+    -> Vector Quadruple
+    -> Glue (AST.Identifier, Maybe Operand, Vector Quadruple)
+variableAccess _ (AST.VariableAccess identifier) accumulatedIndex _ accumulatedStatements =
+    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
+    resultVariable <- createTemporary
+    let resultOperand = VariableOperand resultVariable
+        indexCalculation = Vector.fromList
+            [ ProductQuadruple (IntOperand $ fromIntegral arraySize) baseIndex resultVariable
+            , AddQuadruple indexPlace resultOperand resultVariable
+            ]
+     in variableAccess localTable arrayAccess' (Just resultOperand) baseType
+        $ statements <> indexCalculation <> statements'
+variableAccess _ _ _ _ _ = error "Array access operator doesn't match the type."
+
+variableType :: AST.VariableAccess -> SymbolTable -> Type
+variableType (AST.VariableAccess identifier) symbolTable
+    | Just (TypeInfo type') <- SymbolTable.lookup identifier symbolTable = type'
+    | otherwise = error "Undefined type."
+variableType (AST.ArrayAccess arrayAccess' _) symbolTable =
+    variableType arrayAccess' symbolTable
+-}
+expression :: SymbolTable -> AST.Expression -> Glue (Operand Variable, Vector (Quadruple Variable))
+expression localTable = \case
+    (AST.LiteralExpression literal') -> pure (literal literal', mempty)
+    (AST.SumExpression lhs rhs) -> binaryExpression AddQuadruple lhs rhs
+    (AST.SubtractionExpression lhs rhs) ->
+        binaryExpression SubtractionQuadruple lhs rhs
+    (AST.NegationExpression negation) -> do
+        (operand, statements) <- expression localTable negation
+        tempVariable <- createTemporary
+        let negationQuadruple = NegationQuadruple operand tempVariable
+        pure
+            ( VariableOperand tempVariable
+            , Vector.snoc statements negationQuadruple
+            )
+{-    (AST.VariableExpression variableExpression) -> do
+        let variableType' = variableType variableExpression localTable
+        variableAccess' <- variableAccess localTable variableExpression Nothing variableType' mempty
+        case variableAccess' of
+            (AST.Identifier identifier, Nothing, statements) ->
+                pure (VariableOperand (Variable identifier), statements)
+            (AST.Identifier identifier, Just operand, statements) -> do
+                arrayAddress <- createTemporary
+                let arrayStatement = ArrayQuadruple (Variable identifier) operand arrayAddress
+                pure
+                    ( VariableOperand arrayAddress
+                    , Vector.snoc statements arrayStatement
+                    )
+    (AST.ProductExpression lhs rhs) ->
+        binaryExpression ProductQuadruple lhs rhs
+    (AST.DivisionExpression lhs rhs) ->
+        binaryExpression DivisionQuadruple lhs rhs -}
+  where
+    binaryExpression f lhs rhs = do
+        (lhsOperand, lhsStatements) <- expression localTable lhs
+        (rhsOperand, rhsStatements) <- expression localTable rhs
+        tempVariable <- createTemporary
+        let newQuadruple = f lhsOperand rhsOperand tempVariable
+        pure
+            ( VariableOperand tempVariable
+            , Vector.snoc (lhsStatements <> rhsStatements) newQuadruple
+            )
+
+literal :: AST.Literal -> Operand Variable
+literal (AST.IntegerLiteral integer) = IntOperand integer
+{-literal (AST.HexadecimalLiteral integer) = IntOperand integer
+literal (AST.CharacterLiteral character) = IntOperand $ fromIntegral character
+literal (AST.BooleanLiteral boolean)
+    | boolean = IntOperand 1
+    | otherwise = IntOperand 0 -}