git.iko.soy/elk
on 54dfb21 help sign in
elk/src/Canonicalize.hs
517 lines 15 kB history raw
1module Canonicalize (module') where
3import qualified Data.List as List
4import qualified Data.Map as Map
5import qualified Data.Maybe as Maybe
6import qualified Data.Set as Set
7import qualified Data.Traversable as T
8import qualified Data.Foldable as T
10import AST.Expression.General (Expr'(..), dummyLet)
11import AST.Module (Body(..))
12import Elm.Utils ((|>))
14import qualified AST.Declaration as D
15import qualified AST.Expression.General as E
16import qualified AST.Expression.Valid as Valid
17import qualified AST.Expression.Canonical as Canonical
18import qualified AST.Module as Module
19import qualified AST.Module.Name as ModuleName
20import qualified AST.Pattern as P
21import qualified AST.Type as Type
22import qualified AST.Variable as Var
23import qualified Docs.AST as Docs
24import qualified Docs.Centralize as Docs
25import qualified Reporting.Annotation as A
26import qualified Reporting.Error as Error
27import qualified Reporting.Error.Canonicalize as CError
28import qualified Reporting.Error.Helpers as ErrorHelp
29import qualified Reporting.Region as Region
30import qualified Reporting.Result as R
31import qualified Reporting.Warning as Warning
32import qualified Canonicalize.Declaration as Decls
33import qualified Canonicalize.Environment as Env
34import qualified Canonicalize.Port as Port
35import qualified Canonicalize.Result as Result
36import qualified Canonicalize.Setup as Setup
37import qualified Canonicalize.Sort as Sort
38import qualified Canonicalize.Type as Canonicalize
39import qualified Canonicalize.Variable as Canonicalize
42-- MODULES
44module'
45 :: [ModuleName.Canonical]
46 -> Module.Interfaces
47 -> Module.ValidModule
48 -> R.Result Warning.Warning Error.Error Module.CanonicalModule
49module' canonicalImports interfaces modul =
50 let
51 importDict =
52 canonicalImports
53 |> map (\cName -> (ModuleName._module cName, cName))
54 |> Map.fromList
56 (Result.Result uses rawResults) =
57 moduleHelp importDict interfaces modul
58 in
59 case rawResults of
60 Result.Ok (env, almostCanonicalModule) ->
61 R.addDealiaser (Env.toDealiaser env) $
62 filterImports uses almostCanonicalModule
64 Result.Err msgs ->
65 R.throwMany (map (A.map Error.Canonicalize) msgs)
68type AlmostCanonicalModule =
69 Module.Module
70 Docs.Centralized
71 ([Module.DefaultImport], [Module.UserImport])
72 [Var.Value]
73 (Module.Body Canonical.Expr)
76moduleHelp
77 :: Map.Map ModuleName.Raw ModuleName.Canonical
78 -> Module.Interfaces
79 -> Module.ValidModule
80 -> Result.ResultErr (Env.Environment, AlmostCanonicalModule)
81moduleHelp importDict interfaces modul@(Module.Module _ _ comment exports _ decls) =
82 canonicalModule
83 <$> canonicalDeclsResult
84 <*> resolveExports locals exports
85 where
86 canonicalModule (env, canonicalDecls) canonicalExports =
87 (,) env $
88 modul
89 { Module.docs = A.map (fmap (Docs.centralize canonicalDecls)) comment
90 , Module.exports = canonicalExports
91 , Module.body = body canonicalDecls
92 }
94 locals :: [Var.Value]
95 locals =
96 concatMap declToValue decls
98 canonicalDeclsResult =
99 Setup.environment importDict interfaces modul
100 `Result.andThen` \env -> (,) env <$> T.traverse (declaration env) decls
102 body :: [D.CanonicalDecl] -> Module.Body Canonical.Expr
103 body decls =
104 let nakedDecls = map A.drop decls
105 in
106 Module.Body
107 { program =
108 let expr = Decls.toExpr (Module.name modul) decls
109 in
110 Sort.definitions (dummyLet expr)
112 , types =
113 Map.empty
115 , datatypes =
116 Map.fromList [ (name,(vars,ctors)) | D.Datatype name vars ctors <- nakedDecls ]
118 , fixities =
119 [ (assoc,level,op) | D.Fixity assoc level op <- nakedDecls ]
121 , aliases =
122 Map.fromList [ (name,(tvs,alias)) | D.TypeAlias name tvs alias <- nakedDecls ]
124 , ports =
125 [ E.portName impl | D.Port (D.CanonicalPort impl) <- nakedDecls ]
126 }
129-- IMPORTS
131filterImports
132 :: Set.Set ModuleName.Raw
133 -> AlmostCanonicalModule
134 -> R.Result Warning.Warning e Module.CanonicalModule
135filterImports uses modul@(Module.Module _ _ _ _ (defaults, imports) _) =
136 do reducedImports <-
137 Maybe.catMaybes <$> T.traverse checkImport imports
139 return $ modul
140 { Module.imports =
141 Set.toList (Set.fromList (map fst defaults ++ reducedImports))
142 }
143 where
144 checkImport (A.A region (name, _method)) =
145 if Set.member name uses then
146 return (Just name)
147 else
148 do R.warn region (Warning.UnusedImport name)
149 return Nothing
152-- EXPORTS
154resolveExports
155 :: [Var.Value]
156 -> Var.Listing (A.Located Var.Value)
157 -> Result.ResultErr [Var.Value]
158resolveExports fullList (Var.Listing partialList open) =
159 if open then
160 Result.ok fullList
161 else
162 let
163 (allValues, allAliases, allAdts) =
164 maybeUnzip3 (map splitValue fullList)
166 (values, aliases, adts) =
167 maybeUnzip3 (map splitLocatedValue partialList)
169 adtTypes =
170 map fst allAdts
171 in
172 (\xs ys zs _ -> xs ++ ys ++ zs)
173 <$> T.traverse (getValueExport allValues (Set.fromList allValues)) values
174 <*> (concat <$> T.traverse (getAliasExport allValues allAliases adtTypes) aliases)
175 <*> T.traverse (getAdtExport allAdts adtTypes) adts
176 <*> allUnique partialList
179getValueExport
180 :: [String]
181 -> Set.Set String
182 -> A.Located String
183 -> Result.ResultErr Var.Value
184getValueExport allValues allValuesSet (A.A region name) =
185 if Set.member name allValuesSet then
186 Result.ok (Var.Value name)
187 else
188 manyNotFound region [name] allValues
191getAliasExport
192 :: [String]
193 -> [String]
194 -> [String]
195 -> A.Located String
196 -> Result.ResultErr [Var.Value]
197getAliasExport allValues allAliases adtTypes (A.A region alias) =
198 if alias `elem` allAliases then
200 Result.ok $ (:) (Var.Alias alias) $
201 if alias `elem` allValues then [Var.Value alias] else []
203 else if List.elem alias adtTypes then
205 Result.ok [Var.Union alias (Var.Listing [] False)]
207 else
209 manyNotFound region [alias] (allAliases ++ adtTypes)
212getAdtExport
213 :: [(String, Var.Listing String)]
214 -> [String]
215 -> A.Located (String, Var.Listing String)
216 -> Result.ResultErr Var.Value
217getAdtExport allAdts adtTypes (A.A region (name, Var.Listing ctors open)) =
218 case List.lookup name allAdts of
219 Nothing ->
220 manyNotFound region [name] adtTypes
222 Just (Var.Listing allCtors _) ->
223 if open then
224 Result.ok (Var.Union name (Var.Listing allCtors False))
225 else
226 case filter (`notElem` allCtors) ctors of
227 [] ->
228 Result.ok (Var.Union name (Var.Listing ctors False))
229 unfoundCtors ->
230 manyNotFound region unfoundCtors allCtors
233manyNotFound :: Region.Region -> [String] -> [String] -> Result.ResultErr a
234manyNotFound region nameList possibilities =
235 Result.errors (map (notFound region possibilities) nameList)
238notFound :: Region.Region -> [String] -> String -> A.Located CError.Error
239notFound region possibilities name =
240 A.A region $ CError.Export name $
241 ErrorHelp.nearbyNames id name possibilities
244allUnique :: [A.Located Var.Value] -> Result.ResultErr ()
245allUnique statedExports =
246 let
247 valueToString value =
248 case value of
249 Var.Value name -> name
250 Var.Alias name -> name
251 Var.Union name _ -> name
253 locations =
254 Map.fromListWith (++) (map (\(A.A region value) -> (value, [region])) statedExports)
256 isUnique value allRegions =
257 case allRegions of
258 region : _ : _ ->
259 Result.err (A.A region (CError.DuplicateExport (valueToString value)))
261 _ ->
262 Result.ok ()
263 in
264 T.traverse_ id (Map.mapWithKey isUnique locations)
267-- GROUPING VALUES
269maybeUnzip3 :: [(Maybe a, Maybe b, Maybe c)] -> ([a],[b],[c])
270maybeUnzip3 tuples =
271 let (as, bs, cs) = unzip3 tuples
272 in
273 (Maybe.catMaybes as, Maybe.catMaybes bs, Maybe.catMaybes cs)
276splitValue
277 :: Var.Value
278 -> ( Maybe String, Maybe String, Maybe (String, Var.Listing String) )
279splitValue value =
280 case value of
281 Var.Value name ->
282 (Just name, Nothing, Nothing)
284 Var.Alias name ->
285 (Nothing, Just name, Nothing)
287 Var.Union name listing ->
288 (Nothing, Nothing, Just (name, listing))
291splitLocatedValue
292 :: A.Located Var.Value
293 ->
294 ( Maybe (A.Located String)
295 , Maybe (A.Located String)
296 , Maybe (A.Located (String, Var.Listing String))
297 )
298splitLocatedValue (A.A region value) =
299 case value of
300 Var.Value name ->
301 (Just (A.A region name), Nothing, Nothing)
303 Var.Alias name ->
304 (Nothing, Just (A.A region name), Nothing)
306 Var.Union name listing ->
307 (Nothing, Nothing, Just (A.A region (name, listing)))
310-- DECLARATIONS
312declToValue :: D.ValidDecl -> [Var.Value]
313declToValue (A.A _ decl) =
314 case decl of
315 D.Definition (Valid.Definition pattern _ _) ->
316 map Var.Value (P.boundVarList pattern)
318 D.Datatype name _tvs ctors ->
319 [ Var.Union name (Var.Listing (map fst ctors) False) ]
321 D.TypeAlias name _ tipe ->
322 case tipe of
323 A.A _ (Type.RRecord _ Nothing) ->
324 [ Var.Alias name, Var.Value name ]
326 _ ->
327 [ Var.Alias name ]
329 _ -> []
332declaration
333 :: Env.Environment
334 -> D.ValidDecl
335 -> Result.ResultErr D.CanonicalDecl
336declaration env (A.A ann@(region,_) decl) =
337 A.A ann <$>
338 case decl of
339 D.Definition (Valid.Definition pat expr typ) ->
340 D.Definition <$> (
341 Canonical.Definition Canonical.dummyFacts
342 <$> pattern env pat
343 <*> expression env expr
344 <*> T.traverse (regionType env) typ
345 )
347 D.Datatype name tvars ctors ->
348 D.Datatype name tvars <$> T.traverse canonicalize' ctors
349 where
350 canonicalize' (ctor,args) =
351 (,) ctor <$> T.traverse (Canonicalize.tipe env) args
353 D.TypeAlias name tvars expanded ->
354 D.TypeAlias name tvars
355 <$> Canonicalize.tipe env expanded
357 D.Port validPort ->
358 Result.addModule ["Native","Port"] $
359 Result.addModule ["Native","Json"] $
360 case validPort of
361 D.In name tipe ->
362 Canonicalize.tipe env tipe
363 `Result.andThen` \canonicalType ->
364 D.Port <$> Port.check region name Nothing canonicalType
366 D.Out name expr tipe ->
367 let exprTypeResult =
368 (,)
369 <$> expression env expr
370 <*> Canonicalize.tipe env tipe
371 in
372 exprTypeResult
373 `Result.andThen` \(expr', tipe') ->
374 D.Port <$> Port.check region name (Just expr') tipe'
376 D.Fixity assoc prec op ->
377 Result.ok (D.Fixity assoc prec op)
380regionType
381 :: Env.Environment
382 -> Type.Raw
383 -> Result.ResultErr (A.Located Type.Canonical)
384regionType env typ@(A.A region _) =
385 A.A region <$> Canonicalize.tipe env typ
388expression
389 :: Env.Environment
390 -> Valid.Expr
391 -> Result.ResultErr Canonical.Expr
392expression env (A.A region validExpr) =
393 let go = expression env
394 in
395 A.A region <$>
396 case validExpr of
397 Literal lit ->
398 Result.ok (Literal lit)
400 Range lowExpr highExpr ->
401 Range <$> go lowExpr <*> go highExpr
403 Access record field ->
404 Access <$> go record <*> Result.ok field
406 Update record fields ->
407 Update
408 <$> go record
409 <*> T.traverse (\(field,expr) -> (,) field <$> go expr) fields
411 Record fields ->
412 Record
413 <$> T.traverse (\(field,expr) -> (,) field <$> go expr) fields
415 Binop (Var.Raw op) leftExpr rightExpr ->
416 Binop
417 <$> Canonicalize.variable region env op
418 <*> go leftExpr
419 <*> go rightExpr
421 Lambda arg body ->
422 let env' = Env.addPattern arg env
423 in
424 Lambda <$> pattern env' arg <*> expression env' body
426 App func arg ->
427 App <$> go func <*> go arg
429 If branches finally ->
430 If
431 <$> T.traverse go' branches
432 <*> go finally
433 where
434 go' (condition, branch) =
435 (,) <$> go condition <*> go branch
437 Let defs body ->
438 Let <$> T.traverse rename' defs <*> expression env' body
439 where
440 env' =
441 foldr Env.addPattern env $ map (\(Valid.Definition p _ _) -> p) defs
443 rename' (Valid.Definition p body mtipe) =
444 Canonical.Definition Canonical.dummyFacts
445 <$> pattern env' p
446 <*> expression env' body
447 <*> T.traverse (regionType env') mtipe
449 Var (Var.Raw x) ->
450 Var <$> Canonicalize.variable region env x
452 Data name exprs ->
453 Data name <$> T.traverse go exprs
455 ExplicitList exprs ->
456 ExplicitList <$> T.traverse go exprs
458 Case expr cases ->
459 Case <$> go expr <*> T.traverse branch cases
460 where
461 branch (ptrn, brnch) =
462 (,) <$> pattern env ptrn
463 <*> expression (Env.addPattern ptrn env) brnch
465 Port impl ->
466 let portType pt =
467 case pt of
468 Type.Normal t ->
469 Type.Normal
470 <$> Canonicalize.tipe env t
472 Type.Signal root arg ->
473 Type.Signal
474 <$> Canonicalize.tipe env root
475 <*> Canonicalize.tipe env arg
476 in
477 Port <$>
478 case impl of
479 E.In name tipe ->
480 E.In name <$> portType tipe
482 E.Out name expr tipe ->
483 E.Out name <$> go expr <*> portType tipe
485 E.Task name expr tipe ->
486 E.Task name <$> go expr <*> portType tipe
488 GLShader uid src tipe ->
489 Result.ok (GLShader uid src tipe)
492pattern
493 :: Env.Environment
494 -> P.RawPattern
495 -> Result.ResultErr P.CanonicalPattern
496pattern env (A.A region ptrn) =
497 A.A region <$>
498 case ptrn of
499 P.Var x ->
500 Result.ok (P.Var x)
502 P.Literal lit ->
503 Result.ok (P.Literal lit)
505 P.Record fields ->
506 Result.ok (P.Record fields)
508 P.Anything ->
509 Result.ok P.Anything
511 P.Alias x p ->
512 P.Alias x <$> pattern env p
514 P.Data (Var.Raw name) patterns ->
515 P.Data
516 <$> Canonicalize.pvar region env name (length patterns)
517 <*> T.traverse (pattern env) patterns