66 lines
2.3 KiB
Haskell
66 lines
2.3 KiB
Haskell
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
|