elna/lib/Language/Elna/Intermediate.hs

module Language.Elna.Intermediate
    ( Label(..)
    , Operand(..)
    , Quadruple(..)
    , Variable(..)
    , intermediate
    ) where

import Data.Int (Int32)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text)
import Data.Word (Word32)
import Data.Vector (Vector)
import qualified Data.Vector as Vector
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

data Operand
    = VariableOperand Variable
    | IntOperand Int32
    deriving (Eq, Show)

newtype Label = Label Text
    deriving (Eq, Show)

data Variable = Variable Text | TempVariable
    deriving (Eq, Show)

data Quadruple
    = StartQuadruple
    | GoToQuadruple Label
    | AssignQuadruple Operand Variable
    | ArrayQuadruple Variable Operand Variable
    | ArrayAssignQuadruple Operand Word32 Variable
    | AddQuadruple Operand Operand Variable
    | SubtractionQuadruple Operand Operand Variable
    | ProductQuadruple Operand Operand Variable
    | DivisionQuadruple Operand Operand Variable
    | NegationQuadruple Operand Variable
    | EqualQuadruple Operand Operand Label
    | NonEqualQuadruple Operand Operand Label
    | LessQuadruple Operand Operand Label
    | GreaterQuadruple Operand Operand Label
    | LessOrEqualQuadruple Operand Operand Label
    | GreaterOrEqualQuadruple Operand Operand Label
    | LabelQuadruple Label
    | ParameterQuadruple Operand
    | CallQuadruple Variable Word32
    | StopQuadruple
    deriving (Eq, Show)

intermediate :: SymbolTable -> AST.Program -> HashMap AST.Identifier (Vector Quadruple)
intermediate globalTable (AST.Program declarations) =
    foldr 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 globalTable (AST.CompoundStatement statements) =
    foldMap (statement globalTable) statements

variableAccess
    :: SymbolTable
    -> AST.VariableAccess
    -> Maybe Operand
    -> Type
    -> Vector Quadruple
    -> (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
        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 -> (Operand, Vector Quadruple)
expression localTable = \case
    (AST.VariableExpression variableExpression) ->
        let variableType' = variableType variableExpression localTable
         in case variableAccess localTable variableExpression Nothing variableType' mempty of
            (AST.Identifier identifier, Nothing, statements) ->
                (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
            negationQuadruple = NegationQuadruple operand tempVariable
         in (VariableOperand tempVariable, Vector.snoc statements negationQuadruple)
    (AST.SumExpression lhs rhs) -> binaryExpression AddQuadruple lhs rhs
    (AST.SubtractionExpression lhs rhs) ->
        binaryExpression SubtractionQuadruple lhs rhs
    (AST.ProductExpression lhs rhs) ->
        binaryExpression ProductQuadruple lhs rhs
    (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
            newQuadruple = f lhsOperand rhsOperand tempVariable
         in (VariableOperand tempVariable, Vector.snoc (lhsStatements <> rhsStatements) newQuadruple)

literal :: AST.Literal -> Operand
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