elna/lib/Language/Elna/NameAnalysis.hs

module Language.Elna.NameAnalysis
    ( Error(..)
    , nameAnalysis
    ) where

import Control.Monad.Trans.Except (ExceptT(..), runExceptT, throwE)
import Control.Monad.Trans.Reader (Reader, ask, runReader)
import Data.Functor ((<&>))
import qualified Language.Elna.AST as AST
import Language.Elna.Location (Identifier(..))
import Language.Elna.SymbolTable (Info(..), SymbolTable, symbolTable)
import qualified Language.Elna.SymbolTable as SymbolTable
import Language.Elna.Types (Type(..))
import Control.Monad.Trans.Class (MonadTrans(..))

data Error
    = UndefinedTypeError Identifier
    | UnexpectedTypeInfoError Info
    deriving (Eq, Show)

newtype NameAnalysis a = NameAnalysis
    { runNameAnalysis :: ExceptT Error (Reader SymbolTable) a
    }

instance Functor NameAnalysis
  where
    fmap f (NameAnalysis x) = NameAnalysis $ f <$> x

instance Applicative NameAnalysis
  where
    pure x = NameAnalysis $ pure x
    (NameAnalysis f) <*> (NameAnalysis x) = NameAnalysis $ f <*> x

instance Monad NameAnalysis
  where
    (NameAnalysis x) >>= f = NameAnalysis $ x >>= (runNameAnalysis . f)

nameAnalysis :: AST.Program -> Either Error SymbolTable
nameAnalysis = flip runReader symbolTable
    . runExceptT
    . runNameAnalysis
    . program

program :: AST.Program -> NameAnalysis SymbolTable
program (AST.Program declarations) = do
    globalDeclarations <- traverse declaration declarations
    NameAnalysis $ lift ask

declaration :: AST.Declaration -> NameAnalysis (Identifier, Info)
declaration (AST.TypeDefinition identifier typeExpression) =
    (identifier,) . TypeInfo <$> dataType typeExpression
declaration (AST.ProcedureDefinition identifier _parameters _variables _body) = do
    environmentSymbolTable <- NameAnalysis $ lift ask
    pure (identifier, ProcedureInfo environmentSymbolTable mempty)

dataType :: AST.TypeExpression -> NameAnalysis Type
dataType (AST.NamedType baseType) = do
    environmentSymbolTable <- NameAnalysis $ lift ask
    case SymbolTable.lookup baseType environmentSymbolTable of
        Just baseInfo
            | TypeInfo baseType' <- baseInfo -> pure baseType'
            | otherwise -> NameAnalysis $ throwE $ UnexpectedTypeInfoError baseInfo
        _ -> NameAnalysis $ throwE $ UndefinedTypeError baseType
dataType (AST.ArrayType arraySize baseType) =
    dataType baseType <&> ArrayType arraySize