elna/lib/Language/Elna/NameAnalysis.hs

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

import Control.Monad.Trans.Except (Except, runExcept, throwE)
import Control.Monad.Trans.Reader (ReaderT(..), ask, runReaderT, withReaderT)
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(..))
import Control.Monad (foldM)

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

newtype NameAnalysis a = NameAnalysis
    { runNameAnalysis :: ReaderT SymbolTable (Except Error) 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 = runExcept
    . flip runReaderT symbolTable
    . runNameAnalysis
    . program

program :: AST.Program -> NameAnalysis SymbolTable
program (AST.Program declarations)
    = NameAnalysis ask
    >>= flip (foldM declaration) declarations

declaration :: SymbolTable -> AST.Declaration -> NameAnalysis SymbolTable
declaration globalTable (AST.TypeDefinition identifier typeExpression)
    = flip (SymbolTable.enter identifier) globalTable . TypeInfo
    <$> withSymbolTable globalTable (dataType typeExpression)
declaration globalTable (AST.ProcedureDefinition identifier _parameters _variables _body) =
    let localTable = SymbolTable.empty
     in pure $ SymbolTable.enter identifier (ProcedureInfo localTable mempty) globalTable

withSymbolTable :: forall a. SymbolTable -> NameAnalysis a -> NameAnalysis a
withSymbolTable symbolTable' = NameAnalysis
    . withReaderT (const symbolTable')
    . runNameAnalysis

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