@@ -1,478 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Canonicalize (module') where
3−
4−import Prelude hiding (last)
5−import qualified Data.Foldable as T
6−import Data.List.NonEmpty (NonEmpty((:|)))
7−import qualified Data.List as List
8−import qualified Data.Map as Map
9−import qualified Data.Maybe as Maybe
10−import qualified Data.Set as Set
11−import Data.Text (Text)
12−
13−import qualified AST.Declaration as D
14−import qualified AST.Effects as Effects
15−import qualified AST.Exposing as Exposing
16−import qualified AST.Expression.Source as Src
17−import qualified AST.Expression.Canonical as C
18−import qualified AST.Module as Module
19−import qualified AST.Module.Name as ModuleName
20−import qualified AST.Pattern as P
21−import qualified AST.Type as Type
22−import qualified AST.Variable as Var
23−import qualified Canonicalize.Binops as Binops
24−import qualified Canonicalize.Body as Body
25−import qualified Canonicalize.Effects as Effects
26−import qualified Canonicalize.Environment as Env
27−import qualified Canonicalize.Setup as Setup
28−import qualified Canonicalize.Type as Canon
29−import qualified Canonicalize.Variable as Canon
30−import qualified Docs.Centralize as Docs
31−import qualified Reporting.Annotation as A
32−import qualified Reporting.Error as Error
33−import qualified Reporting.Error.Canonicalize as CError
34−import qualified Reporting.Helpers as Help
35−import qualified Reporting.Region as Region
36−import qualified Reporting.Render.Type as RenderType
37−import qualified Reporting.Result as Result
38−import qualified Reporting.Warning as Warning
39−
40−
41−
42−type Result a =
43− Result.Result (Result.One RenderType.Localizer) Warning.Warning Error.Error a
44−
45−
46−-- MODULES
47−
48−
49−module'
50− :: Map.Map ModuleName.Raw ModuleName.Canonical
51− -> Module.Interfaces
52− -> Module.Valid
53− -> Result Module.Canonical
54−module' importDict interfaces modul =
55− let
56− (Module.Valid docs exports imports decls effects) =
57− Module.info modul
58−
59− (Result.Result uses warnings rawResults) =
60− do env <- Setup.environment importDict interfaces modul
61−
62− (,,,) env
63− <$> resolveExports (getInternalApi effects decls) exports
64− <*> canonicalizeDecls env decls
65− <*> Effects.canonicalize env effects
66− in
67− case rawResults of
68− Result.Err errors ->
69− Result.mapError Error.Canonicalize $
70− Result.Result Result.None warnings (Result.Err errors)
71−
72− Result.Ok (env, canonicalExports, canonicalDecls, canonicalEffects) ->
73− let
74− (D.Decls _ unions aliases infixes) =
75− canonicalDecls
76−
77− centralizedDocs =
78− A.map (fmap (Docs.centralize canonicalDecls)) docs
79−
80− typeToPair (A.A _ (D.Type name args body)) =
81− ( name, (args, body) )
82−
83− getProgram =
84− Body.flatten (Module.name modul) canonicalDecls canonicalEffects
85− in
86− do program <- Result.mapError Error.Canonicalize getProgram
87− canonicalImports <- filterImports uses imports
88− Result.accumulate (Result.One (Env.toLocalizer env)) $
89− modul {
90− Module.info =
91− Module.Info
92− { Module.docs = centralizedDocs
93− , Module.exports = canonicalExports
94− , Module.imports = canonicalImports
95− , Module.program = program
96− , Module.types = Map.empty
97− , Module.fixities = infixes
98− , Module.aliases = Map.fromList (map typeToPair aliases)
99− , Module.unions = Map.fromList (map typeToPair unions)
100− , Module.effects = canonicalEffects
101− }
102− }
103−
104−
105−
106−-- IMPORTS
107−
108−
109−filterImports
110− :: Set.Set ModuleName.Raw
111− -> ([Module.DefaultImport], [Module.UserImport])
112− -> Result [ModuleName.Raw]
113−filterImports uses (defaults, imports) =
114− let
115− checkImport (A.A region (A.A _ name, _method)) =
116− if Set.member name uses then
117− return (Just name)
118−
119− else
120− Result.warn region (Warning.UnusedImport name) Nothing
121− in
122− do reducedImports <-
123− Maybe.catMaybes <$> traverse checkImport imports
124−
125− return $
126− Set.toList (Set.fromList (map fst defaults ++ reducedImports))
127−
128−
129−
130−-------- CANONICALIZATION --------
131−
132−
133−type CResult a =
134− Canon.Result a
135−
136−
137−
138−-- EXPORTS
139−
140−
141−resolveExports :: Exposing.Canonical -> Exposing.Raw -> CResult Exposing.Canonical
142−resolveExports internalApi@(Exposing.Canonical values aliases unions) rawExposing =
143− case rawExposing of
144− Exposing.Open ->
145− Result.ok internalApi
146−
147− Exposing.Explicit entries ->
148− let
149− valueSet = Set.fromList values
150− aliasSet = Set.fromList aliases
151− unionMap = Map.fromList unions
152− in
153− case List.foldl' (resolveEntry valueSet aliasSet unionMap) (Exposing.nothing, []) entries of
154− (exposing, []) ->
155− do checkForDups entries
156− Result.ok exposing
157−
158− (_, errors) ->
159− Result.throwMany errors
160−
161−
162−resolveEntry
163− :: Set.Set Text
164− -> Set.Set Text
165− -> Map.Map Text [Text]
166− -> (Exposing.Canonical, [A.Located CError.Error])
167− -> A.Located Exposing.Entry
168− -> (Exposing.Canonical, [A.Located CError.Error])
169−resolveEntry vSet aSet uSet (exposing@(Exposing.Canonical values aliases unions), errors) (A.A region entry) =
170− case entry of
171− Exposing.Lower name ->
172− if Set.member name vSet then
173− ( Exposing.Canonical (name:values) aliases unions
174− , errors
175− )
176−
177− else
178− ( exposing
179− , notFound region (Set.toList vSet) name : errors
180− )
181−
182− Exposing.Upper name Nothing ->
183− if Set.member name aSet then
184− ( Exposing.Canonical
185− (if Set.member name vSet then name:values else values)
186− (name:aliases)
187− unions
188− , errors
189− )
190−
191− else if Map.member name uSet then
192− ( Exposing.Canonical values aliases ((name, []) : unions)
193− , errors
194− )
195−
196− else
197− ( exposing
198− , notFound region (Set.toList aSet ++ Map.keys uSet) name : errors
199− )
200−
201− Exposing.Upper name (Just exposedCtors) ->
202− case Map.lookup name uSet of
203− Nothing ->
204− ( exposing
205− , notFound region (Map.keys uSet) name : errors
206− )
207−
208− Just allCtors ->
209− case exposedCtors of
210− Exposing.Open ->
211− ( Exposing.Canonical values aliases ((name, allCtors) : unions)
212− , errors
213− )
214−
215− Exposing.Explicit ctors ->
216− let
217− isNotKnown (A.A _ ctor) =
218− ctor `notElem` allCtors
219−
220− notKnown (A.A ctorRegion ctor) =
221− notFound ctorRegion allCtors ctor
222− in
223− case filter isNotKnown ctors of
224− [] ->
225− ( Exposing.Canonical values aliases ((name, map A.drop ctors) : unions)
226− , errors
227− )
228−
229− unfoundCtors ->
230− ( exposing
231− , map notKnown unfoundCtors ++ errors
232− )
233−
234−
235−notFound :: Region.Region -> [Text] -> Text -> A.Located CError.Error
236−notFound region possibilities badName =
237− A.A region $ CError.Export badName $
238− Help.nearbyNames id badName possibilities
239−
240−
241−checkForDups :: [A.Located Exposing.Entry] -> CResult ()
242−checkForDups entries =
243− let
244− locations =
245− A.listToDict Exposing.getName entries
246−
247− isUnique name (region :| duplicates) =
248− case duplicates of
249− [] ->
250− Result.ok ()
251−
252− _ ->
253− Result.throw region (CError.DuplicateExport name)
254− in
255− T.sequenceA_ (Map.mapWithKey isUnique locations)
256−
257−
258−
259−-- ALL POSSIBLE EXPOSED VALUES
260−
261−
262−getInternalApi :: Effects.Raw -> D.Valid -> Exposing.Canonical
263−getInternalApi effects (D.Decls defs unions aliases _) =
264− let
265− values =
266− Effects.toExposedValues effects
267− ++ concatMap getAliasValues aliases
268− ++ concatMap getDefValues defs
269− in
270− Exposing.Canonical values (map getAlias aliases) (map getUnion unions)
271−
272−
273−getDefValues :: A.Commented Src.ValidDef -> [Text]
274−getDefValues (A.A _ def) =
275− P.boundVarList (Src.getPattern def)
276−
277−
278−getAliasValues :: A.Commented (D.Alias Type.Raw) -> [Text]
279−getAliasValues (A.A _ (D.Type name _ tipe)) =
280− case tipe of
281− A.A _ (Type.RRecord _ Nothing) ->
282− [ name ]
283−
284− _ ->
285− []
286−
287−
288−getAlias :: A.Commented (D.Alias Type.Raw) -> Text
289−getAlias (A.A _ (D.Type name _ _)) =
290− name
291−
292−
293−getUnion :: A.Commented (D.Union Type.Raw) -> (Text, [Text])
294−getUnion (A.A _ (D.Type name _ ctors)) =
295− (name, map fst ctors)
296−
297−
298−
299−-- DECLARATIONS
300−
301−
302−canonicalizeDecls :: Env.Env -> D.Valid -> CResult D.Canonical
303−canonicalizeDecls env (D.Decls defs unions aliases infixes) =
304− let
305− annTraverse canEntry entries =
306− traverse (\(A.A ann entry) -> A.A ann <$> canEntry entry) entries
307−
308− canonicalizeDef (Src.Def region pat expr typ) =
309− C.Def region
310− <$> canonicalizePattern env pat
311− <*> canonicalizeExpr env expr
312− <*> traverse (canonicalizeRegionType env) typ
313−
314− canonicalizeArgs (ctor, args) =
315− (,) ctor <$> traverse (Canon.tipe env) args
316−
317− canonicalizeUnion (D.Type name tvars ctors) =
318− D.Type name tvars <$> traverse canonicalizeArgs ctors
319−
320− canonicalizeAlias (D.Type name tvars alias) =
321− D.Type name tvars <$> Canon.tipe env alias
322− in
323− D.Decls
324− <$> annTraverse canonicalizeDef defs
325− <*> annTraverse canonicalizeUnion unions
326− <*> annTraverse canonicalizeAlias aliases
327− <*> pure infixes
328−
329−
330−canonicalizeRegionType :: Env.Env -> Type.Raw -> CResult (A.Located Type.Canonical)
331−canonicalizeRegionType env typ@(A.A region _) =
332− A.A region <$> Canon.tipe env typ
333−
334−
335−
336−-- EXPRESSIONS
337−
338−
339−canonicalizeExpr :: Env.Env -> Src.ValidExpr -> CResult C.Expr
340−canonicalizeExpr env (A.A region validExpr) =
341− let go = canonicalizeExpr env
342− in
343− A.A region <$>
344− case validExpr of
345− Src.Literal lit ->
346− Result.ok (C.Literal lit)
347−
348− Src.Access record field ->
349− C.Access <$> go record <*> Result.ok field
350−
351− Src.Update record fields ->
352− C.Update <$> go record <*> traverse (canonicalizeFields env) fields
353−
354− Src.Record fields ->
355− C.Record <$> traverse (canonicalizeFields env) fields
356−
357− Src.Binop ops last ->
358− canonicalizeBinop region env ops last
359−
360− Src.Lambda arg body ->
361− let
362− env' =
363− Env.addPattern arg env
364− in
365− C.Lambda
366− <$> canonicalizePattern env' arg
367− <*> canonicalizeExpr env' body
368−
369− Src.App func arg ->
370− C.App <$> go func <*> go arg
371−
372− Src.If branches finally ->
373− C.If
374− <$> traverse go' branches
375− <*> go finally
376− where
377− go' (condition, branch) =
378− (,) <$> go condition <*> go branch
379−
380− Src.Let defs expr ->
381− C.Let <$> traverse rename' defs <*> canonicalizeExpr env' expr
382− where
383− env' =
384− foldr Env.addPattern env (map Src.getPattern defs)
385−
386− rename' (Src.Def defRegion p body mtipe) =
387− C.Def defRegion
388− <$> canonicalizePattern env' p
389− <*> canonicalizeExpr env' body
390− <*> traverse (canonicalizeRegionType env') mtipe
391−
392− Src.Var (Var.Raw x) ->
393− C.Var <$> Canon.variable region env x
394−
395− Src.Ctor name exprs ->
396− C.Ctor
397− <$> Canon.variable region env name
398− <*> traverse go exprs
399−
400− Src.List exprs ->
401− C.List <$> traverse go exprs
402−
403− Src.Case expr cases ->
404− C.Case <$> go expr <*> traverse branch cases
405− where
406− branch (ptrn, brnch) =
407− (,)
408− <$> canonicalizePattern env ptrn
409− <*> canonicalizeExpr (Env.addPattern ptrn env) brnch
410−
411− Src.GLShader uid src tipe ->
412− Result.ok (C.GLShader uid src tipe)
413−
414−
415−canonicalizeFields
416− :: Env.Env
417− -> (A.Located Text, Src.ValidExpr)
418− -> CResult (Text, C.Expr)
419−canonicalizeFields env (A.A _ key, expr) =
420− (\value -> (key, value)) <$> canonicalizeExpr env expr
421−
422−
423−
424−-- PATTERNS
425−
426−
427−canonicalizePattern :: Env.Env -> P.Raw -> CResult P.Canonical
428−canonicalizePattern env (A.A region ptrn) =
429− A.A region <$>
430− case ptrn of
431− P.Var x ->
432− Result.ok (P.Var x)
433−
434− P.Literal lit ->
435− Result.ok (P.Literal lit)
436−
437− P.Record fields ->
438− Result.ok (P.Record fields)
439−
440− P.Anything ->
441− Result.ok P.Anything
442−
443− P.Alias x p ->
444− P.Alias x <$> canonicalizePattern env p
445−
446− P.Ctor (Var.Raw name) patterns ->
447− P.Ctor
448− <$> Canon.pvar region env name (length patterns)
449− <*> traverse (canonicalizePattern env) patterns
450−
451−
452−
453−-- BINOPS
454−
455−
456−canonicalizeBinop
457− :: Region.Region
458− -> Env.Env
459− -> [(Src.ValidExpr, A.Located Text)]
460− -> Src.ValidExpr
461− -> CResult C.Expr'
462−canonicalizeBinop region env srcOps srcLast =
463− let
464− opsResult =
465− traverse (binopHelp env) srcOps
466−
467− lastResult =
468− canonicalizeExpr env srcLast
469− in
470− do (expr, ops) <- (,) <$> opsResult <*> lastResult
471− A.drop <$> Binops.flatten region expr ops
472−
473−
474−binopHelp :: Env.Env -> (Src.ValidExpr, A.Located Text) -> CResult (C.Expr, Binops.Op)
475−binopHelp env (expr, op) =
476− (,)
477− <$> canonicalizeExpr env expr
478− <*> Binops.canonicalize env op