blob: abbfb93de10910e92e3f7d7b1e0e8fb76efe6da0 (
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
|
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
|
