blob: 49b791557e14dfc3f06ae235c7a39572742e1c41 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
|
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
|
