1+ module Analyser.Analyser where
2+
3+ import Analyser.Util
4+ ( Def (Argument , Function , Variable ),
5+ GDefs ,
6+ LDefs ,
7+ getTypeFromArr ,
8+ getTypeFromExpr ,
9+ rFoldl ,
10+ tfst ,
11+ tsnd ,
12+ tthd ,
13+ )
14+ import Data.Bifunctor (second )
15+ import Data.Either.Combinators (fromLeft' , fromRight , fromRight' , isLeft , maybeToRight )
16+ import Data.HashMap.Strict as H (HashMap , empty , findWithDefault , fromList , insert , lookup , union )
17+ import Data.Maybe (fromJust , fromMaybe , isJust )
18+ import Data.Text as T (Text , empty , pack , toLower , unpack )
19+ import Debug.Trace (trace )
20+ import Parser.Ast
21+ ( Expr (Array , FunctionCall , FunctionDef , Nil , Root , Variable , VariableDef ),
22+ VDataType (Function , Inferred , NilType ),
23+ )
24+
25+ {-
26+ semCheckExprs should be used to fold over a list of expressions,
27+ with the final result being (globalDefs, localDefs, inferredTree)
28+
29+ globalDefs here is a hashmap - (DefName, Expr), simple enough
30+ localDefs is a hashmap - (scopeName, hashmap (DefName, Expr))
31+
32+ so if you have two functions called a and b, and you defined a
33+ variable age=20 in a and name="udit" in b, you'll have localDefs as
34+ [
35+ [ "a", [ ("age", IntLiteral 20) ] ]
36+ [ "b", [ ("name", StringLiteral "udit") ] ]
37+ ]
38+
39+ inferredTree is the expr array you passed it with all Inferred
40+ in it's tree replaced with actual types inferred from context
41+
42+ semCheckExprs calls inferType for every expr in the expr array you give it
43+ initially, which in turn in most cases calls getTypeFromExpr
44+
45+ I use semCheckExprs for AST Root (just array of all expr in program)
46+ and function bodies here, but it can be used anywhere you want to
47+ infer types and analyse a set of expressions
48+ -}
49+ type Accumulator = (GDefs , LDefs , [Either Text Expr ])
50+
51+ {-
52+ Cases where a type-check is necessary:
53+ * variable definition when the type is explicitly defined
54+ * function definition when the return type is explicitly defined
55+ * function call (whether all arguments confirm to needed types)
56+ * array generation (whether all arguments confirm to needed type)
57+
58+ note that if the type of an array is explicitly defined, every
59+ element in the array must have the same type, and in case the
60+ type is _not_ explicitly defined, every element in the array
61+ must have the same type as the first element in the array
62+ -}
63+ makeDtArr :: Accumulator -> [Expr ] -> Either Text [VDataType ]
64+ makeDtArr acc = mapM (`getTypeFromExpr` tfst acc)
65+
66+ checkArgs :: [VDataType ] -> Either Text [VDataType ] -> Text -> Maybe Text
67+ checkArgs expArgs vdtArgs fnName = do
68+ case vdtArgs of
69+ Left -> Just txt
70+ Right -> snd $
71+ rFoldl (zip expArgs vdts) (0 , Nothing ) $ \ acc curr ->
72+ ( fst acc + 1 ,
73+ if uncurry (==) curr
74+ then Nothing
75+ else
76+ Just $
77+ " Expected argument of type '"
78+ <> (toLower . T. pack . show ) (fst curr)
79+ <> " ' but got '"
80+ <> (toLower . T. pack . show ) (snd curr)
81+ <> " ' in argument "
82+ <> T. pack (show (fst acc + 1 ))
83+ <> T. pack " of call to function "
84+ <> T. pack (show fnName)
85+ )
86+
87+ semCheckExprs :: (Accumulator -> Expr -> Accumulator )
88+ semCheckExprs acc curr = do
89+ let makeLeft r = (H. empty, H. empty, [Left
90+ if not (null (tthd acc)) && isLeft (last (tthd acc))
91+ then (H. empty, H. empty, [last (tthd acc)])
92+ else case inferType curr (tfst acc) of
93+ Left -> (tfst acc, tsnd acc, tthd acc <> [Left
94+ -- if it's a def, add to a1 or a2, else just add expr to a3
95+ Right -> case infExpr of
96+ Array exprs -> do
97+ -- since inferType evaluated to Right, this exists
98+ let at = getTypeFromArr $ fromRight' $ getTypeFromExpr infExpr (tfst acc)
99+ let mapped = mapM (`getTypeFromExpr` tfst acc) exprs
100+ case mapped of
101+ Left -> makeLeft txt
102+ Right -> do
103+ let res = rFoldl exprs (0 , Nothing ) $ \ acc' curr -> do
104+ let et = getTypeFromExpr curr (tfst acc)
105+ let ni = fst acc' + 1
106+ if isJust (snd acc')
107+ then (ni, snd acc')
108+ else case et of
109+ Left -> (ni, Just txt)
110+ Right ->
111+ if avdt == at
112+ then (ni, Nothing )
113+ else
114+ ( ni,
115+ Just $
116+ " Expected type '"
117+ <> (toLower . T. pack . show ) at
118+ <> " ' but got '"
119+ <> (toLower . T. pack . show ) avdt
120+ <> " ' in index "
121+ <> T. pack (show (fst acc'))
122+ <> " of array literal"
123+ )
124+ maybe (tfst acc, tsnd acc, tthd acc <> [Right snd res)
125+ FunctionCall name args -> do
126+ -- since inferType evaluated to Right, this exists
127+ let def = fromJust $ H. lookup name (tfst acc)
128+ -- (def arg-1 arg-2 ...)
129+ case def of
130+ Analyser.Util. Variable-> case v of
131+ Parser.Ast. Function->
132+ maybe
133+ (tfst acc, tsnd acc, tthd acc <> [Right
134+ makeLeft
135+ (checkArgs expArgs (makeDtArr acc args) name)
136+ x -> makeLeft $ " Variable of type '" <> pack (show x) <> " ' is not callable"
137+ Analyser.Util. Function->
138+ maybe
139+ (tfst acc, tsnd acc, tthd acc <> [Right
140+ makeLeft
141+ (checkArgs (map snd expArgs) (makeDtArr acc args) name)
142+ Analyser.Util. Argument-> undefined -- TODO
143+ VariableDef name vtype expr -> case H. lookup name (tfst acc) of
144+ Nothing -> do
145+ let res =
146+ ( insert name (Analyser.Util. Variable
147+ tsnd acc,
148+ tthd acc <> [Right
149+ )
150+ if vtype /= Inferred
151+ then do
152+ let atype = getTypeFromExpr expr (tfst acc)
153+ case atype of
154+ Left -> makeLeft txt
155+ Right ->
156+ if vdt == vtype
157+ then res
158+ else
159+ makeLeft $
160+ " Cannot assign value of type "
161+ <> T. pack (show vdt)
162+ <> " to variable of type "
163+ <> T. pack (show vtype)
164+ else res
165+ Just _ -> (H. empty, H. empty, [Left $ " Redefinition of variable " <> name])
166+ FunctionDef name vtype args body frgn -> case H. lookup name (tfst acc) of
167+ Just _ -> (H. empty, H. empty, [Left $ " Redefinition of function " <> name])
168+ Nothing -> do
169+ let result =
170+ foldl
171+ semCheckExprs
172+ (tfst acc `union` H. fromList (map (second Argument ) args), H. empty, [] )
173+ body
174+ let r =
175+ getTypeFromExpr
176+ (if null body then Nil else last body)
177+ (tfst result `union` tfst acc)
178+ let inferred = vtype == Inferred
179+ case r of
180+ Left -> makeLeft txt
181+ Right -> do
182+ let res =
183+ ( insert name (Analyser.Util. Functionif inferred then fromRight' r else vtype) args body frgn) (tfst acc),
184+ insert name (tfst result) (tsnd acc),
185+ tthd acc
186+ <> [ sequence (tthd result) >>= \ v ->
187+ r
188+ >>= \ ct -> Right $ FunctionDef name ct args v frgn
189+ ]
190+ )
191+ if not inferred
192+ then
193+ if vtype == dvdt
194+ then res
195+ else
196+ makeLeft $
197+ " Expected function '"
198+ <> name
199+ <> " ' to return "
200+ <> (toLower . T. pack . show ) vtype
201+ <> " , instead got "
202+ <> (toLower . T. pack . show ) dvdt
203+ else res
204+ _ -> (tfst acc, tsnd acc, tthd acc <> [Right
205+
206+ inferType :: Expr -> GDefs -> Either Text Expr
207+ inferType (Root x) gd = error " fold with semCheckExprs for this"
208+ -- handle variable definition inside variable definition
209+ inferType (VariableDef name x VariableDef {}) _ =
210+ Left " Cannot define a variable inside a variable"
211+ -- infer types for proper variable definitions
212+ inferType (VariableDef name Inferred y) gd =
213+ getTypeFromExpr y gd >>= \ t -> Right $ VariableDef name t y
214+ -- infer function call types
215+ inferType (FunctionCall name args) gd =
216+ getTypeFromExpr (FunctionCall name args) gd >>= \ t ->
217+ Right $ FunctionCall name args
218+ -- send back nodes that don't need type inference
219+ inferType x _ = Right
220+
221+ analyseAst :: Expr -> GDefs -> (Either Text Expr , GDefs , LDefs )
222+ analyseAst (Root x) gd = do
223+ let t = foldl semCheckExprs (gd, H. empty, [] ) x
224+ (sequence (tthd t) >>= \ v -> Right Root v), tfst t, tsnd t)
225+ analyseAst _ _ = undefined
226+
227+ analyseAst' :: Expr -> Either Text Expr
228+ analyseAst' (Root x) = do
229+ let t = foldl semCheckExprs (H. empty, H. empty, [] ) x
230+ sequence (tthd t) >>= \ v -> Right Root v)
231+ analyseAst' _ = undefined
0 commit comments