git.iko.soy/elk
on 267f708 help sign in
elk/src/Canonicalize.hs
478 lines 13 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 Access record field ->
370 Access <$> go record <*> Result.ok field
372 Update record fields ->
373 Update
374 <$> go record
375 <*> traverse (\(field,expr) -> (,) field <$> go expr) fields
377 Record fields ->
378 Record
379 <$> traverse (\(field,expr) -> (,) field <$> go expr) fields
381 Binop (Var.Raw op) leftExpr rightExpr ->
382 Binop
383 <$> Canon.variable region env op
384 <*> go leftExpr
385 <*> go rightExpr
387 Lambda arg body ->
388 let
389 env' =
390 Env.addPattern arg env
391 in
392 Lambda <$> canonicalizePattern env' arg <*> canonicalizeExpr env' body
394 App func arg ->
395 App <$> go func <*> go arg
397 If branches finally ->
398 If
399 <$> traverse go' branches
400 <*> go finally
401 where
402 go' (condition, branch) =
403 (,) <$> go condition <*> go branch
405 Let defs expr ->
406 Let <$> traverse rename' defs <*> canonicalizeExpr env' expr
407 where
408 env' =
409 foldr Env.addPattern env (map Valid.getPattern defs)
411 rename' (Valid.Def p body mtipe) =
412 Canonical.Def Canonical.dummyFacts
413 <$> canonicalizePattern env' p
414 <*> canonicalizeExpr env' body
415 <*> traverse (canonicalizeRegionType env') mtipe
417 Var (Var.Raw x) ->
418 Var <$> Canon.variable region env x
420 Data name exprs ->
421 Data name <$> traverse go exprs
423 ExplicitList exprs ->
424 ExplicitList <$> traverse go exprs
426 Case expr cases ->
427 Case <$> go expr <*> traverse branch cases
428 where
429 branch (ptrn, brnch) =
430 (,)
431 <$> canonicalizePattern env ptrn
432 <*> canonicalizeExpr (Env.addPattern ptrn env) brnch
434 Cmd moduleName ->
435 Result.ok (Cmd moduleName)
437 Sub moduleName ->
438 Result.ok (Sub moduleName)
440 OutgoingPort name tipe ->
441 OutgoingPort name <$> Canon.tipe env tipe
443 IncomingPort name tipe ->
444 IncomingPort name <$> Canon.tipe env tipe
446 Program _ _ ->
447 error "DANGER - Program AST nodes should not be in canonicalization."
449 SaveEnv moduleName effects ->
450 Result.ok (SaveEnv moduleName effects)
452 GLShader uid src tipe ->
453 Result.ok (GLShader uid src tipe)
456canonicalizePattern :: Env.Environment -> P.Raw -> CResult P.Canonical
457canonicalizePattern env (A.A region ptrn) =
458 A.A region <$>
459 case ptrn of
460 P.Var x ->
461 Result.ok (P.Var x)
463 P.Literal lit ->
464 Result.ok (P.Literal lit)
466 P.Record fields ->
467 Result.ok (P.Record fields)
469 P.Anything ->
470 Result.ok P.Anything
472 P.Alias x p ->
473 P.Alias x <$> canonicalizePattern env p
475 P.Data (Var.Raw name) patterns ->
476 P.Data
477 <$> Canon.pvar region env name (length patterns)
478 <*> traverse (canonicalizePattern env) patterns