elna/lib/Language/Elna/Glue.hs

module Language.Elna.Glue
    ( glue
    ) where

import Control.Monad.Trans.State (State, gets, modify', runState)
import Data.Bifunctor (Bifunctor(..))
import Data.Foldable (Foldable(..), traverse_)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Maybe (catMaybes)
import Data.Vector (Vector)
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
import qualified Data.Vector as Vector
import Data.Word (Word32)
import qualified Language.Elna.Frontend.AST as AST
import Language.Elna.Frontend.Types (Type(..))
import Language.Elna.Backend.Intermediate
    ( Label(..)
    , Operand(..)
    , Quadruple(..)
    , Variable(..)
    )
import Language.Elna.Frontend.SymbolTable (Info(..), SymbolTable)
import qualified Language.Elna.Frontend.SymbolTable as SymbolTable
import GHC.Records (HasField(..))
import Language.Elna.Frontend.AST (Identifier(..))

data Paste = Paste
    { temporaryCounter :: Word32
    , labelCounter :: Word32
    , localMap :: HashMap Identifier Variable
    }

newtype Glue a = Glue
    { runGlue :: State Paste 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 Identifier (Vector (Quadruple Variable))
glue globalTable
    = fst
    . flip runState emptyPaste
    . runGlue
    . program globalTable
  where
    emptyPaste = Paste
        { temporaryCounter = 0
        , labelCounter = 0
        , localMap = mempty
        }

program :: SymbolTable -> AST.Program -> Glue (HashMap 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 parameters variableDeclarations statements)
    = Glue (modify' resetTemporaryCounter)
    >> traverseWithIndex registerVariable variableDeclarations
    >> traverseWithIndex registerParameter (reverse parameters)
    >> nameQuadruplesTuple <$> traverse (statement globalTable) statements
  where
    traverseWithIndex f = traverse_ (uncurry f) . zip [0..]
    registerParameter index (AST.Parameter identifier _ _) =
        Glue $ modify' $ modifier identifier $ ParameterVariable index
    registerVariable index (AST.VariableDeclaration identifier _) =
        Glue $ modify' $ modifier identifier $ LocalVariable index
    modifier identifier currentCounter generator = generator
        { localMap = HashMap.insert identifier currentCounter
            $ getField @"localMap" generator
        }
    nameQuadruplesTuple quadrupleList = Just
        ( procedureName
        , Vector.cons StartQuadruple
            $ flip Vector.snoc StopQuadruple
            $ fold quadrupleList
        )
    resetTemporaryCounter paste = paste
        { temporaryCounter = 0
        , localMap = mempty
        }
declaration _ (AST.TypeDefinition _ _) = pure Nothing

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
        $ length arguments
statement localTable (AST.CompoundStatement statements) =
    fold <$> traverse (statement localTable) statements
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.AssignmentStatement variableAccess' assignee) = do
    (rhsOperand, rhsStatements) <- expression localTable assignee
    let variableType' = variableType variableAccess' localTable
    accessResult <- variableAccess localTable variableAccess' Nothing variableType' mempty
    lhsStatements <- case accessResult of
            {-(AST.Identifier identifier, Just accumulatedIndex, accumulatedStatements) ->
                Vector.snoc accumulatedStatements
                    $ ArrayAssignQuadruple rhsOperand accumulatedIndex
                    $ LocalVariable identifier -}
            (identifier, _Nothing, accumulatedStatements)
                -> Vector.snoc accumulatedStatements
                . AssignQuadruple rhsOperand
                <$> lookupLocal identifier
    pure $ rhsStatements <> lhsStatements
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]

createTemporary :: Glue Variable
createTemporary = do
    currentCounter <- Glue $ gets $ getField @"temporaryCounter"
    Glue $ modify' modifier
    pure $ TempVariable currentCounter
  where
    modifier generator = generator
        { temporaryCounter = getField @"temporaryCounter" generator + 1
        }

lookupLocal :: Identifier -> Glue Variable
lookupLocal identifier =
    fmap (HashMap.! identifier) $ Glue $ gets $ getField @"localMap"

createLabel :: Glue Label
createLabel = do
    currentCounter <- Glue $ gets $ getField @"labelCounter"
    Glue $ modify' modifier
    pure $ Label
        $ Text.Lazy.toStrict
        $ Text.Builder.toLazyText
        $ ".L" <> Text.Builder.decimal currentCounter
  where
    modifier generator = generator
        { labelCounter = getField @"labelCounter" generator + 1
        }

condition
    :: SymbolTable
    -> AST.Condition
    -> Glue (Vector (Quadruple Variable), Label -> Quadruple Variable)
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 Variable)
    -> Type
    -> Vector (Quadruple Variable)
    -> Glue (AST.Identifier, Maybe (Operand Variable), Vector (Quadruple Variable))
variableAccess _ (AST.VariableAccess identifier) accumulatedIndex _ accumulatedStatements =
    pure (identifier, accumulatedIndex, accumulatedStatements)
variableAccess localTable accessKind accumulatedIndex arrayType statements
    | (AST.ArrayAccess access1 index1) <- accessKind
    , (ArrayType arraySize baseType) <- arrayType = do
        (indexPlace, statements') <- expression localTable index1
        case accumulatedIndex  of
            Just baseIndex -> do
                resultVariable <- createTemporary
                let resultOperand = VariableOperand resultVariable
                    indexCalculation = Vector.fromList
                        [ ProductQuadruple (IntOperand $ fromIntegral arraySize) baseIndex resultVariable
                        , AddQuadruple indexPlace resultOperand resultVariable
                        ]
                 in variableAccess localTable access1 (Just resultOperand) baseType
                    $ statements <> indexCalculation <> statements'
            Nothing ->
                variableAccess localTable access1 (Just indexPlace) baseType 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.ProductExpression lhs rhs) ->
        binaryExpression ProductQuadruple lhs rhs
    (AST.DivisionExpression lhs rhs) ->
        binaryExpression DivisionQuadruple lhs rhs
    (AST.VariableExpression variableExpression) -> do
        let variableType' = variableType variableExpression localTable
        variableAccess' <- variableAccess localTable variableExpression Nothing variableType' mempty
        case variableAccess' of
            (identifier, _Nothing, statements)
                -> (, statements) . VariableOperand 
                <$> lookupLocal identifier
            {-(AST.Identifier identifier, Just operand, statements) -> do
                arrayAddress <- createTemporary
                let arrayStatement = ArrayQuadruple (Variable identifier) operand arrayAddress
                pure
                    ( VariableOperand arrayAddress
                    , Vector.snoc statements arrayStatement
                    ) -}
  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.DecimalLiteral integer) = IntOperand integer
literal (AST.HexadecimalLiteral integer) = IntOperand integer
literal (AST.CharacterLiteral character) = IntOperand $ fromIntegral character