git.iko.soy/elk
on 9b0c310 help sign in
elk/src/Canonicalize.hs
403 lines 12 kB history raw
1module Canonicalize (module') where
3import Control.Applicative ((<$>),(<*>))
4import qualified Data.List as List
5import qualified Data.Map as Map
6import qualified Data.Maybe as Maybe
7import qualified Data.Set as Set
8import qualified Data.Traversable as T
10import AST.Expression.General (Expr'(..), dummyLet)
11import AST.Module (CanonicalBody(..))
13import qualified AST.Declaration as D
14import qualified AST.Expression.General as E
15import qualified AST.Expression.Valid as Valid
16import qualified AST.Expression.Canonical as Canonical
17import qualified AST.Module as Module
18import qualified AST.Pattern as P
19import qualified AST.Type as Type
20import qualified AST.Variable as Var
21import qualified Reporting.Annotation as A
22import qualified Reporting.Error as Error
23import qualified Reporting.Error.Canonicalize as CError
24import qualified Reporting.Result as R
25import qualified Reporting.Warning as Warning
26import qualified Canonicalize.Declaration as Decls
27import qualified Canonicalize.Environment as Env
28import qualified Canonicalize.Port as Port
29import qualified Canonicalize.Result as Result
30import qualified Canonicalize.Setup as Setup
31import qualified Canonicalize.Sort as Sort
32import qualified Canonicalize.Type as Canonicalize
33import qualified Canonicalize.Variable as Canonicalize
36-- MODULES
38module'
39 :: Module.Interfaces
40 -> Module.ValidModule
41 -> R.Result Warning.Warning Error.Error Module.CanonicalModule
42module' interfaces modul@(Module.Module _ _ _ (_, imports) _) =
43 let (Result.Result uses rawResults) =
44 moduleHelp interfaces modul
46 unusedImportWarnings =
47 Maybe.mapMaybe (warnUnusedImport uses) imports
48 in
49 R.addWarnings unusedImportWarnings $
50 case rawResults of
51 Result.Ok canonicalModule ->
52 return canonicalModule
54 Result.Err msgs ->
55 R.throwMany (map (A.map Error.Canonicalize) msgs)
58moduleHelp
59 :: Module.Interfaces
60 -> Module.ValidModule
61 -> Result.ResultErr Module.CanonicalModule
62moduleHelp interfaces modul@(Module.Module _ _ exports (defaults, imports) decls) =
63 canonicalModule
64 <$> canonicalDeclsResult
65 <*> resolveExports locals exports
66 where
67 canonicalModule canonicalDecls canonicalExports =
68 modul
69 { Module.exports = canonicalExports
70 , Module.imports = map fst defaults ++ map (fst . A.drop) imports
71 , Module.body = body canonicalDecls
72 }
74 locals :: [Var.Value]
75 locals =
76 concatMap declToValue decls
78 canonicalDeclsResult =
79 Setup.environment interfaces modul
80 `Result.andThen` \env -> T.traverse (declaration env) decls
82 body :: [D.CanonicalDecl] -> Module.CanonicalBody
83 body decls =
84 let nakedDecls = map A.drop decls
85 in
86 Module.CanonicalBody
87 { program =
88 let expr = Decls.toExpr (Module.names modul) decls
89 in
90 Sort.definitions (dummyLet expr)
92 , types =
93 Map.empty
95 , datatypes =
96 Map.fromList [ (name,(vars,ctors)) | D.Datatype name vars ctors <- nakedDecls ]
98 , fixities =
99 [ (assoc,level,op) | D.Fixity assoc level op <- nakedDecls ]
101 , aliases =
102 Map.fromList [ (name,(tvs,alias)) | D.TypeAlias name tvs alias <- nakedDecls ]
104 , ports =
105 [ E.portName impl | D.Port (D.CanonicalPort impl) <- nakedDecls ]
106 }
109-- IMPORTS / EXPORTS
111warnUnusedImport
112 :: Set.Set Module.Name
113 -> Module.UserImport
114 -> Maybe (A.Located Warning.Warning)
115warnUnusedImport uses (A.A region (name, _method)) =
116 if Set.member name uses
117 then Nothing
118 else Just (A.A region (Warning.UnusedImport name))
121resolveExports
122 :: [Var.Value]
123 -> Var.Listing Var.Value
124 -> Result.ResultErr [Var.Value]
125resolveExports fullList (Var.Listing partialList open) =
126 if open
127 then Result.ok fullList
128 else
129 (\xs ys zs -> xs ++ ys ++ zs)
130 <$> getValueExports
131 <*> (concat <$> T.traverse getAliasExport aliases)
132 <*> T.traverse getAdtExport adts
133 where
134 (allValues, allAliases, allAdts) =
135 splitValues fullList
137 (values, aliases, adts) =
138 splitValues partialList
140 getValueExports =
141 case Set.toList (Set.difference values' allValues') of
142 [] -> Result.ok (map Var.Value values)
143 xs -> manyNotFound xs allValues
144 where
145 allValues' = Set.fromList allValues
146 values' = Set.fromList values
148 getAliasExport alias
149 | alias `elem` allAliases =
150 let recordConstructor =
151 if alias `elem` allValues then [Var.Value alias] else []
152 in
153 Result.ok (Var.Alias alias : recordConstructor)
155 | otherwise =
156 case List.find (\(name, _ctors) -> name == alias) allAdts of
157 Nothing -> manyNotFound [alias] allAliases
158 Just (name, _ctor) ->
159 Result.ok [Var.Union name (Var.Listing [] False)]
161 getAdtExport (name, Var.Listing ctors open) =
162 case lookup name allAdts of
163 Nothing -> manyNotFound [name] (map fst allAdts)
164 Just (Var.Listing allCtors _)
165 | open ->
166 Result.ok (Var.Union name (Var.Listing allCtors False))
167 | otherwise ->
168 case filter (`notElem` allCtors) ctors of
169 [] -> Result.ok (Var.Union name (Var.Listing ctors False))
170 unfoundCtors -> manyNotFound unfoundCtors allCtors
172 manyNotFound nameList possibilities =
173 Result.errors (map (notFound possibilities) nameList)
175 notFound possibilities name =
176 A.A undefined $ CError.Export name $
177 CError.nearbyNames id name possibilities
180splitValues
181 :: [Var.Value]
182 -> ([String], [String], [(String, Var.Listing String)])
183splitValues mixedValues =
184 case mixedValues of
185 [] -> ([], [], [])
186 x:xs ->
187 let (values, aliases, adts) = splitValues xs in
188 case x of
189 Var.Value name ->
190 (name : values, aliases, adts)
192 Var.Alias name ->
193 (values, name : aliases, adts)
195 Var.Union name listing ->
196 (values, aliases, (name, listing) : adts)
199-- DECLARATIONS
201declToValue :: D.ValidDecl -> [Var.Value]
202declToValue (A.A _ decl) =
203 case decl of
204 D.Definition (Valid.Definition pattern _ _) ->
205 map Var.Value (P.boundVarList pattern)
207 D.Datatype name _tvs ctors ->
208 [ Var.Union name (Var.Listing (map fst ctors) False) ]
210 D.TypeAlias name _ tipe ->
211 case tipe of
212 A.A _ (Type.RRecord _ _) ->
213 [ Var.Alias name, Var.Value name ]
214 _ -> [ Var.Alias name ]
216 _ -> []
219declaration
220 :: Env.Environment
221 -> D.ValidDecl
222 -> Result.ResultErr D.CanonicalDecl
223declaration env (A.A region decl) =
224 let canonicalize kind _context _pattern env v =
225 kind env v
226 in
227 A.A region <$>
228 case decl of
229 D.Definition (Valid.Definition p e t) ->
230 D.Definition <$> (
231 Canonical.Definition
232 <$> canonicalize pattern "definition" p env p
233 <*> expression env e
234 <*> T.traverse (canonicalize Canonicalize.tipe "definition" p env) t
235 )
237 D.Datatype name tvars ctors ->
238 D.Datatype name tvars <$> T.traverse canonicalize' ctors
239 where
240 canonicalize' (ctor,args) =
241 (,) ctor <$> T.traverse (canonicalize Canonicalize.tipe "datatype" name env) args
243 D.TypeAlias name tvars expanded ->
244 D.TypeAlias name tvars
245 <$> canonicalize Canonicalize.tipe "type alias" name env expanded
247 D.Port validPort ->
248 Result.addModule ["Native","Port"] $
249 Result.addModule ["Native","Json"] $
250 case validPort of
251 D.In name tipe ->
252 canonicalize Canonicalize.tipe "port" name env tipe
253 `Result.andThen` \canonicalType ->
254 D.Port <$> Port.check name Nothing canonicalType
256 D.Out name expr tipe ->
257 let exprTypeResult =
258 (,)
259 <$> expression env expr
260 <*> canonicalize Canonicalize.tipe "port" name env tipe
261 in
262 exprTypeResult
263 `Result.andThen` \(expr', tipe') ->
264 D.Port <$> Port.check name (Just expr') tipe'
266 D.Fixity assoc prec op ->
267 Result.ok (D.Fixity assoc prec op)
270expression
271 :: Env.Environment
272 -> Valid.Expr
273 -> Result.ResultErr Canonical.Expr
274expression env (A.A region validExpr) =
275 let go = expression env
276 in
277 A.A region <$>
278 case validExpr of
279 Literal lit ->
280 Result.ok (Literal lit)
282 Range lowExpr highExpr ->
283 Range <$> go lowExpr <*> go highExpr
285 Access record field ->
286 Access <$> go record <*> Result.ok field
288 Remove record field ->
289 flip Remove field <$> go record
291 Insert record field expr ->
292 flip Insert field <$> go record <*> go expr
294 Modify record fields ->
295 Modify
296 <$> go record
297 <*> T.traverse (\(field,expr) -> (,) field <$> go expr) fields
299 Record fields ->
300 Record
301 <$> T.traverse (\(field,expr) -> (,) field <$> go expr) fields
303 Binop (Var.Raw op) leftExpr rightExpr ->
304 Binop
305 <$> Canonicalize.variable region env op
306 <*> go leftExpr
307 <*> go rightExpr
309 Lambda arg body ->
310 let env' = Env.addPattern arg env
311 in
312 Lambda <$> pattern env' arg <*> expression env' body
314 App func arg ->
315 App <$> go func <*> go arg
317 MultiIf branches ->
318 MultiIf <$> T.traverse go' branches
319 where
320 go' (condition, branch) =
321 (,) <$> go condition <*> go branch
323 Let defs body ->
324 Let <$> T.traverse rename' defs <*> expression env' body
325 where
326 env' =
327 foldr Env.addPattern env $ map (\(Valid.Definition p _ _) -> p) defs
329 rename' (Valid.Definition p body mtipe) =
330 Canonical.Definition
331 <$> pattern env' p
332 <*> expression env' body
333 <*> T.traverse (Canonicalize.tipe env') mtipe
335 Var (Var.Raw x) ->
336 Var <$> Canonicalize.variable region env x
338 Data name exprs ->
339 Data name <$> T.traverse go exprs
341 ExplicitList exprs ->
342 ExplicitList <$> T.traverse go exprs
344 Case expr cases ->
345 Case <$> go expr <*> T.traverse branch cases
346 where
347 branch (ptrn, brnch) =
348 (,) <$> pattern env ptrn
349 <*> expression (Env.addPattern ptrn env) brnch
351 Port impl ->
352 let portType pt =
353 case pt of
354 Type.Normal t ->
355 Type.Normal
356 <$> Canonicalize.tipe env t
358 Type.Signal root arg ->
359 Type.Signal
360 <$> Canonicalize.tipe env root
361 <*> Canonicalize.tipe env arg
362 in
363 Port <$>
364 case impl of
365 E.In name tipe ->
366 E.In name <$> portType tipe
368 E.Out name expr tipe ->
369 E.Out name <$> go expr <*> portType tipe
371 E.Task name expr tipe ->
372 E.Task name <$> go expr <*> portType tipe
374 GLShader uid src tipe ->
375 Result.ok (GLShader uid src tipe)
378pattern
379 :: Env.Environment
380 -> P.RawPattern
381 -> Result.ResultErr P.CanonicalPattern
382pattern env (A.A region ptrn) =
383 A.A region <$>
384 case ptrn of
385 P.Var x ->
386 Result.ok (P.Var x)
388 P.Literal lit ->
389 Result.ok (P.Literal lit)
391 P.Record fields ->
392 Result.ok (P.Record fields)
394 P.Anything ->
395 Result.ok P.Anything
397 P.Alias x p ->
398 P.Alias x <$> pattern env p
400 P.Data (Var.Raw name) patterns ->
401 P.Data
402 <$> Canonicalize.pvar region env name (length patterns)
403 <*> T.traverse (pattern env) patterns