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
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
|
module Language.Elna.NameAnalysis
( Error(..)
, nameAnalysis
) where
import Control.Monad.Trans.Except (Except, runExcept, throwE)
import Control.Monad.Trans.Reader
( ReaderT(..)
, ask
, asks
, runReaderT
, withReaderT
)
import Data.Functor ((<&>))
import qualified Language.Elna.AST as AST
import Language.Elna.Location (Identifier(..))
import Language.Elna.SymbolTable
( Info(..)
, ParameterInfo(..)
, SymbolTable
, builtInSymbolTable
)
import qualified Language.Elna.SymbolTable as SymbolTable
import Language.Elna.Types (Type(..))
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad (foldM, unless)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Foldable (traverse_)
import qualified Data.Vector as Vector
data Error
= UndefinedTypeError Identifier
| UnexpectedTypeInfoError Info
| IdentifierAlreadyDefinedError Identifier
| UndefinedSymbolError Identifier
| UnexpectedArrayByValue Identifier
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 = NameAnalysis . pure
(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 builtInSymbolTable
. 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)
= withSymbolTable globalTable (dataType typeExpression)
>>= flip (enter identifier) globalTable . TypeInfo
declaration globalTable (AST.ProcedureDefinition identifier parameters variables body) = do
parametersInfo <- mapM parameter parameters
variableInfo <- mapM variableDeclaration variables
newTable <- either (identifierAlreadyDefinedError . NonEmpty.head) pure
$ SymbolTable.fromList
$ fmap parameterToVariableInfo parametersInfo
<> variableInfo
traverse_ (statement globalTable) body
let procedureInfo = ProcedureInfo newTable
$ Vector.fromList parametersInfo
enter identifier procedureInfo globalTable
statement :: SymbolTable -> AST.Statement -> NameAnalysis ()
statement _ AST.EmptyStatement = pure ()
statement globalTable (AST.AssignmentStatement lvalue rvalue)
= expression globalTable lvalue
>> expression globalTable rvalue
statement globalTable (AST.IfStatement condition ifStatement elseStatement)
= expression globalTable condition
>> statement globalTable ifStatement
>> maybe (pure ()) (statement globalTable) elseStatement
statement globalTable (AST.WhileStatement condition loop)
= expression globalTable condition
>> statement globalTable loop
statement globalTable (AST.CompoundStatement statements) =
traverse_ (statement globalTable) statements
statement globalTable (AST.CallStatement name arguments)
= checkSymbol name globalTable
>> traverse_ (expression globalTable) arguments
checkSymbol :: Identifier -> SymbolTable -> NameAnalysis ()
checkSymbol identifier globalTable =
let undefinedSymbolError = NameAnalysis
$ lift
$ throwE
$ UndefinedSymbolError identifier
isDefined = SymbolTable.member identifier globalTable
in NameAnalysis (asks (SymbolTable.member identifier))
>>= (flip unless undefinedSymbolError . (isDefined ||))
expression :: SymbolTable -> AST.Expression -> NameAnalysis ()
expression globalTable (AST.VariableExpression identifier) =
checkSymbol identifier globalTable
expression _ (AST.LiteralExpression _) = pure ()
expression globalTable (AST.NegationExpression negation) =
expression globalTable negation
expression globalTable (AST.SumExpression lhs rhs)
= expression globalTable lhs
>> expression globalTable rhs
expression globalTable (AST.SubtractionExpression lhs rhs)
= expression globalTable lhs
>> expression globalTable rhs
expression globalTable (AST.ProductExpression lhs rhs)
= expression globalTable lhs
>> expression globalTable rhs
expression globalTable (AST.DivisionExpression lhs rhs)
= expression globalTable lhs
>> expression globalTable rhs
expression globalTable (AST.EqualExpression lhs rhs)
= expression globalTable lhs
>> expression globalTable rhs
expression globalTable (AST.NonEqualExpression lhs rhs)
= expression globalTable lhs
>> expression globalTable rhs
expression globalTable (AST.LessExpression lhs rhs)
= expression globalTable lhs
>> expression globalTable rhs
expression globalTable (AST.GreaterExpression lhs rhs)
= expression globalTable lhs
>> expression globalTable rhs
expression globalTable (AST.LessOrEqualExpression lhs rhs)
= expression globalTable lhs
>> expression globalTable rhs
expression globalTable (AST.GreaterOrEqualExpression lhs rhs)
= expression globalTable lhs
>> expression globalTable rhs
expression globalTable (AST.ArrayExpression arrayExpression indexExpression)
= expression globalTable arrayExpression
>> expression globalTable indexExpression
enter :: Identifier -> Info -> SymbolTable -> NameAnalysis SymbolTable
enter identifier info table
= maybe (identifierAlreadyDefinedError identifier) pure
$ SymbolTable.enter identifier info table
identifierAlreadyDefinedError :: Identifier -> NameAnalysis a
identifierAlreadyDefinedError = NameAnalysis
. lift
. throwE
. IdentifierAlreadyDefinedError
variableDeclaration :: AST.VariableDeclaration -> NameAnalysis (Identifier, Info)
variableDeclaration (AST.VariableDeclaration identifier typeExpression)
= (identifier,) . VariableInfo False
<$> dataType typeExpression
parameter :: AST.Parameter -> NameAnalysis ParameterInfo
parameter (AST.Parameter identifier typeExpression isReferenceParameter') = do
parameterType <- dataType typeExpression
case parameterType of
ArrayType _ _
| not isReferenceParameter' -> NameAnalysis
$ lift $ throwE $ UnexpectedArrayByValue identifier
_ ->
let parameterInfo = ParameterInfo
{ name = identifier
, type' = parameterType
, isReferenceParameter = isReferenceParameter'
}
in pure parameterInfo
parameterToVariableInfo :: ParameterInfo -> (Identifier, Info)
parameterToVariableInfo ParameterInfo{..} =
( name
, VariableInfo isReferenceParameter type'
)
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
|
