git.iko.soy/elk
on 17618de help sign in
elk/src/Canonicalize.hs
481 lines 14 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Canonicalize (module') where
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.Foldable as T
10import AST.Expression.General (Expr'(..))
11import Elm.Utils ((|>))
13import qualified AST.Declaration as D
14import qualified AST.Expression.Valid as Valid
15import qualified AST.Expression.Canonical as Canonical
16import qualified AST.Module as Module
17import qualified AST.Module.Name as ModuleName
18import qualified AST.Pattern as P
19import qualified AST.Type as Type
20import qualified AST.Variable as Var
21import qualified Canonicalize.Body as Body
22import qualified Canonicalize.Effects as Effects
23import qualified Canonicalize.Environment as Env
24import qualified Canonicalize.Setup as Setup
25import qualified Canonicalize.Type as Canon
26import qualified Canonicalize.Variable as Canon
27import qualified Docs.Centralize as Docs
28import qualified Reporting.Annotation as A
29import qualified Reporting.Error as Error
30import qualified Reporting.Error.Canonicalize as CError
31import qualified Reporting.Error.Helpers as ErrorHelp
32import qualified Reporting.Region as Region
33import qualified Reporting.Render.Type as RenderType
34import qualified Reporting.Result as Result
35import qualified Reporting.Warning as Warning
39type Result a =
40 Result.Result (Result.One RenderType.Localizer) Warning.Warning Error.Error a
43-- MODULES
46module'
47 :: [ModuleName.Canonical]
48 -> Module.Interfaces
49 -> Module.Valid
50 -> Result Module.Canonical
51module' allCanonicalImports interfaces modul =
52 let
53 (Module.Valid docs exports imports decls effects) =
54 Module.info modul
56 importDict =
57 allCanonicalImports
58 |> map (\cName -> (ModuleName._module cName, cName))
59 |> Map.fromList
61 (Result.Result uses warnings rawResults) =
62 do env <- Setup.environment importDict interfaces modul
64 (,,,) env
65 <$> resolveExports (Effects.toValues effects ++ declsToValues decls) exports
66 <*> canonicalizeDecls env decls
67 <*> Effects.canonicalize env effects
68 in
69 case rawResults of
70 Result.Err errors ->
71 Result.mapError Error.Canonicalize $
72 Result.Result Result.None warnings (Result.Err errors)
74 Result.Ok (env, canonicalExports, canonicalDecls, canonicalEffects) ->
75 let
76 (D.Decls _ unions aliases infixes) =
77 canonicalDecls
79 centralizedDocs =
80 A.map (fmap (Docs.centralize canonicalDecls)) docs
82 typeToPair (A.A _ (D.Type name args body)) =
83 ( name, (args, body) )
85 program =
86 Body.flatten (Module.name modul) canonicalDecls canonicalEffects
87 in
88 do canonicalImports <- filterImports uses imports
89 Result.accumulate (Result.One (Env.toDealiaser env)) $
90 modul {
91 Module.info =
92 Module.Info
93 { Module.docs = centralizedDocs
94 , Module.exports = canonicalExports
95 , Module.imports = canonicalImports
96 , Module.program = program
97 , Module.types = Map.empty
98 , Module.fixities = infixes
99 , Module.aliases = Map.fromList (map typeToPair aliases)
100 , Module.unions = Map.fromList (map typeToPair unions)
101 , Module.effects = canonicalEffects
102 }
103 }
107-- IMPORTS
110filterImports
111 :: Set.Set ModuleName.Raw
112 -> ([Module.DefaultImport], [Module.UserImport])
113 -> Result [ModuleName.Raw]
114filterImports uses (defaults, imports) =
115 let
116 checkImport (A.A region (name, _method)) =
117 if Set.member name uses then
118 return (Just name)
120 else
121 Result.warn region (Warning.UnusedImport name) Nothing
122 in
123 do reducedImports <-
124 Maybe.catMaybes <$> traverse checkImport imports
126 return $
127 Set.toList (Set.fromList (map fst defaults ++ reducedImports))
131-------- CANONICALIZATION --------
134type CResult a =
135 Canon.Result a
139-- EXPORTS
142resolveExports :: [Var.Value] -> Var.Listing (A.Located Var.Value) -> CResult [Var.Value]
143resolveExports fullList (Var.Listing partialList open) =
144 if open then
145 Result.ok fullList
147 else
148 let
149 (allValues, allAliases, allAdts) =
150 maybeUnzip3 (map splitValue fullList)
152 (values, aliases, adts) =
153 maybeUnzip3 (map splitLocatedValue partialList)
155 adtTypes =
156 map fst allAdts
157 in
158 (\xs ys zs _ -> xs ++ ys ++ zs)
159 <$> traverse (getValueExport allValues (Set.fromList allValues)) values
160 <*> (concat <$> traverse (getAliasExport allValues allAliases adtTypes) aliases)
161 <*> traverse (getAdtExport allAdts adtTypes) adts
162 <*> allUnique partialList
165getValueExport :: [String] -> Set.Set String -> A.Located String -> CResult Var.Value
166getValueExport allValues allValuesSet (A.A region name) =
167 if Set.member name allValuesSet then
168 Result.ok (Var.Value name)
169 else
170 manyNotFound region [name] allValues
173getAliasExport :: [String] -> [String] -> [String] -> A.Located String -> CResult [Var.Value]
174getAliasExport allValues allAliases adtTypes (A.A region alias) =
175 if alias `elem` allAliases then
177 Result.ok $ (:) (Var.Alias alias) $
178 if alias `elem` allValues then [Var.Value alias] else []
180 else if List.elem alias adtTypes then
182 Result.ok [Var.Union alias (Var.Listing [] False)]
184 else
186 manyNotFound region [alias] (allAliases ++ adtTypes)
189getAdtExport
190 :: [(String, Var.Listing String)]
191 -> [String]
192 -> A.Located (String, Var.Listing String)
193 -> CResult Var.Value
194getAdtExport allAdts adtTypes (A.A region (name, Var.Listing ctors open)) =
195 case List.lookup name allAdts of
196 Nothing ->
197 manyNotFound region [name] adtTypes
199 Just (Var.Listing allCtors _) ->
200 if open then
201 Result.ok (Var.Union name (Var.Listing allCtors False))
202 else
203 case filter (`notElem` allCtors) ctors of
204 [] ->
205 Result.ok (Var.Union name (Var.Listing ctors False))
206 unfoundCtors ->
207 manyNotFound region unfoundCtors allCtors
210manyNotFound :: Region.Region -> [String] -> [String] -> CResult a
211manyNotFound region nameList possibilities =
212 Result.throwMany (map (notFound region possibilities) nameList)
215notFound :: Region.Region -> [String] -> String -> A.Located CError.Error
216notFound region possibilities name =
217 A.A region $ CError.Export name $
218 ErrorHelp.nearbyNames id name possibilities
221allUnique :: [A.Located Var.Value] -> CResult ()
222allUnique statedExports =
223 let
224 valueToString value =
225 case value of
226 Var.Value name -> name
227 Var.Alias name -> name
228 Var.Union name _ -> name
230 locations =
231 Map.fromListWith (++) (map (\(A.A region value) -> (value, [region])) statedExports)
233 isUnique value allRegions =
234 case allRegions of
235 region : _ : _ ->
236 Result.throw region (CError.DuplicateExport (valueToString value))
238 _ ->
239 Result.ok ()
240 in
241 T.sequenceA_ (Map.mapWithKey isUnique locations)
245-- CONVERSIONS
248declsToValues :: D.Valid -> [Var.Value]
249declsToValues (D.Decls defs unions aliases _) =
250 let
251 fromDef (A.A _ def) =
252 map Var.Value (P.boundVarList (Valid.getPattern def))
254 fromUnion (A.A _ (D.Type name _ ctors)) =
255 Var.Union name (Var.Listing (map fst ctors) False)
257 fromAlias (A.A _ (D.Type name _ tipe)) =
258 case tipe of
259 A.A _ (Type.RRecord _ Nothing) ->
260 [ Var.Alias name, Var.Value name ]
262 _ ->
263 [ Var.Alias name ]
264 in
265 concat
266 [ map fromUnion unions
267 , concatMap fromAlias aliases
268 , concatMap fromDef defs
269 ]
273-- GROUPING VALUES
276maybeUnzip3 :: [(Maybe a, Maybe b, Maybe c)] -> ([a],[b],[c])
277maybeUnzip3 tuples =
278 let (as, bs, cs) = unzip3 tuples
279 in
280 (Maybe.catMaybes as, Maybe.catMaybes bs, Maybe.catMaybes cs)
283splitValue
284 :: Var.Value
285 -> ( Maybe String, Maybe String, Maybe (String, Var.Listing String) )
286splitValue value =
287 case value of
288 Var.Value name ->
289 (Just name, Nothing, Nothing)
291 Var.Alias name ->
292 (Nothing, Just name, Nothing)
294 Var.Union name listing ->
295 (Nothing, Nothing, Just (name, listing))
298splitLocatedValue
299 :: A.Located Var.Value
300 ->
301 ( Maybe (A.Located String)
302 , Maybe (A.Located String)
303 , Maybe (A.Located (String, Var.Listing String))
304 )
305splitLocatedValue (A.A region value) =
306 case value of
307 Var.Value name ->
308 (Just (A.A region name), Nothing, Nothing)
310 Var.Alias name ->
311 (Nothing, Just (A.A region name), Nothing)
313 Var.Union name listing ->
314 (Nothing, Nothing, Just (A.A region (name, listing)))
318-- DECLARATIONS
321canonicalizeDecls :: Env.Environment -> D.Valid -> CResult D.Canonical
322canonicalizeDecls env (D.Decls defs unions aliases infixes) =
323 let
324 annTraverse canEntry entries =
325 traverse (\(A.A ann entry) -> A.A ann <$> canEntry entry) entries
327 canonicalizeDef (Valid.Def pat expr typ) =
328 Canonical.Def Canonical.dummyFacts
329 <$> canonicalizePattern env pat
330 <*> canonicalizeExpr env expr
331 <*> traverse (canonicalizeRegionType env) typ
333 canonicalizeArgs (ctor, args) =
334 (,) ctor <$> traverse (Canon.tipe env) args
336 canonicalizeUnion (D.Type name tvars ctors) =
337 D.Type name tvars <$> traverse canonicalizeArgs ctors
339 canonicalizeAlias (D.Type name tvars alias) =
340 D.Type name tvars <$> Canon.tipe env alias
341 in
342 D.Decls
343 <$> annTraverse canonicalizeDef defs
344 <*> annTraverse canonicalizeUnion unions
345 <*> annTraverse canonicalizeAlias aliases
346 <*> pure infixes
349canonicalizeRegionType
350 :: Env.Environment
351 -> Type.Raw
352 -> CResult (A.Located Type.Canonical)
353canonicalizeRegionType env typ@(A.A region _) =
354 A.A region <$> Canon.tipe env typ
357canonicalizeExpr
358 :: Env.Environment
359 -> Valid.Expr
360 -> CResult Canonical.Expr
361canonicalizeExpr env (A.A region validExpr) =
362 let go = canonicalizeExpr env
363 in
364 A.A region <$>
365 case validExpr of
366 Literal lit ->
367 Result.ok (Literal lit)
369 Range lowExpr highExpr ->
370 Range <$> go lowExpr <*> go highExpr
372 Access record field ->
373 Access <$> go record <*> Result.ok field
375 Update record fields ->
376 Update
377 <$> go record
378 <*> traverse (\(field,expr) -> (,) field <$> go expr) fields
380 Record fields ->
381 Record
382 <$> traverse (\(field,expr) -> (,) field <$> go expr) fields
384 Binop (Var.Raw op) leftExpr rightExpr ->
385 Binop
386 <$> Canon.variable region env op
387 <*> go leftExpr
388 <*> go rightExpr
390 Lambda arg body ->
391 let
392 env' =
393 Env.addPattern arg env
394 in
395 Lambda <$> canonicalizePattern env' arg <*> canonicalizeExpr env' body
397 App func arg ->
398 App <$> go func <*> go arg
400 If branches finally ->
401 If
402 <$> traverse go' branches
403 <*> go finally
404 where
405 go' (condition, branch) =
406 (,) <$> go condition <*> go branch
408 Let defs expr ->
409 Let <$> traverse rename' defs <*> canonicalizeExpr env' expr
410 where
411 env' =
412 foldr Env.addPattern env (map Valid.getPattern defs)
414 rename' (Valid.Def p body mtipe) =
415 Canonical.Def Canonical.dummyFacts
416 <$> canonicalizePattern env' p
417 <*> canonicalizeExpr env' body
418 <*> traverse (canonicalizeRegionType env') mtipe
420 Var (Var.Raw x) ->
421 Var <$> Canon.variable region env x
423 Data name exprs ->
424 Data name <$> traverse go exprs
426 ExplicitList exprs ->
427 ExplicitList <$> traverse go exprs
429 Case expr cases ->
430 Case <$> go expr <*> traverse branch cases
431 where
432 branch (ptrn, brnch) =
433 (,)
434 <$> canonicalizePattern env ptrn
435 <*> canonicalizeExpr (Env.addPattern ptrn env) brnch
437 Cmd moduleName ->
438 Result.ok (Cmd moduleName)
440 Sub moduleName ->
441 Result.ok (Sub moduleName)
443 OutgoingPort name tipe ->
444 OutgoingPort name <$> Canon.tipe env tipe
446 IncomingPort name tipe ->
447 IncomingPort name <$> Canon.tipe env tipe
449 Program _ _ ->
450 error "DANGER - Program AST nodes should not be in canonicalization."
452 SaveEnv moduleName effects ->
453 Result.ok (SaveEnv moduleName effects)
455 GLShader uid src tipe ->
456 Result.ok (GLShader uid src tipe)
459canonicalizePattern :: Env.Environment -> P.Raw -> CResult P.Canonical
460canonicalizePattern env (A.A region ptrn) =
461 A.A region <$>
462 case ptrn of
463 P.Var x ->
464 Result.ok (P.Var x)
466 P.Literal lit ->
467 Result.ok (P.Literal lit)
469 P.Record fields ->
470 Result.ok (P.Record fields)
472 P.Anything ->
473 Result.ok P.Anything
475 P.Alias x p ->
476 P.Alias x <$> canonicalizePattern env p
478 P.Data (Var.Raw name) patterns ->
479 P.Data
480 <$> Canon.pvar region env name (length patterns)
481 <*> traverse (canonicalizePattern env) patterns