@@ -24,6 +24,7 @@ import qualified Canonicalize.Result as Result
2424import qualified Canonicalize.Type as Canonicalize
2525
2626
27+
2728environment
2829 :: Map.Map ModuleName.Raw ModuleName.Canonical
2930 -> Module.Interfaces
@@ -43,12 +44,14 @@ environment importDict interfaces (Module.Module name _ _ _ (defaults, imports)
4344 patches =
4445 (++) (Env.builtinPatches ++ declPatches) <$> importPatchesResult
4546 in
46− (Env.fromPatches name <$> patches)
47− `Result.andThen` addTypeAliases name typeAliasNodes
47+ (Env.fromPatches name <$> patches)
48+ `Result.andThen` addTypeAliases name typeAliasNodes
49+
4850
4951
5052-- PATCHES FOR IMPORTS
5153
54+
5255importPatches
5356 :: Map.Map ModuleName.Raw ModuleName.Canonical
5457 -> Module.Interfaces
@@ -63,68 +66,76 @@ importPatches importDict allInterfaces (A.A region (rawImportName, method)) =
6366 in
6467 case maybeInterface of
6568 Nothing ->
66− if ModuleName.isNative rawImportName then
67− Result.ok []
68−
69− else
70− allInterfaces
71− |> Map.keys
72− |> map ModuleName._module
73− |> Error.nearbyNames ModuleName.toString rawImportName
74− |> Error.moduleNotFound rawImportName
75− |> A.A region
76− |> Result.err
69+ if ModuleName.isNative rawImportName then
70+ Result.ok []
71+
72+ else
73+ allInterfaces
74+ |> Map.keys
75+ |> map ModuleName._module
76+ |> Error.nearbyNames ModuleName.toString rawImportName
77+ |> Error.moduleNotFound rawImportName
78+ |> A.A region
79+ |> Result.err
7780
7881 Just (importName, interface) ->
79− let (Module.ImportMethod maybeAlias listing) =
80− method
82+ let
83+ (Module.ImportMethod maybeAlias listing) =
84+ method
8185
82− (Var.Listing exposedValues open) =
83− listing
86+ (Var.Listing exposedValues open) =
87+ listing
8488
85− qualifier =
86− maybe (ModuleName.toString rawImportName) id maybeAlias
89+ qualifier =
90+ maybe (ModuleName.toString rawImportName) id maybeAlias
8791
88− qualifiedPatches =
89− interfacePatches importName (qualifier ++ ".") interface
92+ qualifiedPatches =
93+ interfacePatches importName (qualifier ++ ".") interface
9094
91− unqualifiedPatches =
92− if open
93− then Result.ok (interfacePatches importName "" interface)
94− else concat <$> Trav.traverse (valueToPatches region importName interface) exposedValues
95− in
96− (++) qualifiedPatches <$> unqualifiedPatches
95+ unqualifiedPatches =
96+ if open then
97+ Result.ok (interfacePatches importName "" interface)
98+
99+ else
100+ concat <$> Trav.traverse (valueToPatches region importName interface) exposedValues
101+ in
102+ (++) qualifiedPatches <$> unqualifiedPatches
97103
98104
99105interfacePatches :: ModuleName.Canonical -> String -> Module.Interface -> [Env.Patch]
100106interfacePatches moduleName prefix interface =
101− let genericPatch mkPatch name value =
102− mkPatch (prefix ++ name) value
107+ let
108+ genericPatch mkPatch name value =
109+ mkPatch (prefix ++ name) value
103110
104− patch mkPatch name =
105− genericPatch mkPatch name (Var.fromModule moduleName name)
111+ patch mkPatch name =
112+ genericPatch mkPatch name (Var.fromModule moduleName name)
106113
107− aliasPatch (name, (tvars, tipe)) =
108− genericPatch Env.Alias name
109− (Var.fromModule moduleName name, tvars, tipe)
114+ aliasPatch (name, (tvars, tipe)) =
115+ genericPatch
116+ Env.Alias
117+ name
118+ (Var.fromModule moduleName name, tvars, tipe)
110119
111− patternPatch (name, args) =
112− genericPatch Env.Pattern name
113− (Var.fromModule moduleName name, length args)
120+ patternPatch (name, args) =
121+ genericPatch
122+ Env.Pattern
123+ name
124+ (Var.fromModule moduleName name, length args)
114125
115− ctors =
116− concatMap snd (Map.elems (Module.iAdts interface))
126+ ctors =
127+ concatMap snd (Map.elems (Module.iAdts interface))
117128
118− ctorNames =
119− map fst ctors
120− in
121− concat
122− [ map (patch Env.Value) (Map.keys (Module.iTypes interface))
123− , map (patch Env.Value) ctorNames
124− , map (patch Env.Union) (Map.keys (Module.iAdts interface))
125− , map aliasPatch (Map.toList (Module.iAliases interface))
126− , map patternPatch ctors
127− ]
129+ ctorNames =
130+ map fst ctors
131+ in
132+ concat
133+ [ map (patch Env.Value) (Map.keys (Module.iTypes interface))
134+ , map (patch Env.Value) ctorNames
135+ , map (patch Env.Union) (Map.keys (Module.iAdts interface))
136+ , map aliasPatch (Map.toList (Module.iAliases interface))
137+ , map patternPatch ctors
138+ ]
128139
129140
130141-- PATCHES FOR INDIVIDUAL VALUES
@@ -136,84 +147,88 @@ valueToPatches
136147 -> Var.Value
137148 -> Result.ResultErr [Env.Patch]
138149valueToPatches region moduleName interface value =
139− let patch mkPatch x =
140− mkPatch x (Var.fromModule moduleName x)
141−
142− patternPatch (x, numArgs) =
143− Env.Pattern x (Var.fromModule moduleName x, numArgs)
144−
145− notFound getNames x =
146− Module.iExports interface
147− |> getNames
148− |> Error.nearbyNames id x
149− |> Error.valueNotFound (ModuleName._module moduleName) x
150− |> A.A region
151− |> Result.err
150+ let
151+ patch mkPatch x =
152+ mkPatch x (Var.fromModule moduleName x)
153+
154+ patternPatch (x, numArgs) =
155+ Env.Pattern x (Var.fromModule moduleName x, numArgs)
156+
157+ notFound getNames x =
158+ Module.iExports interface
159+ |> getNames
160+ |> Error.nearbyNames id x
161+ |> Error.valueNotFound (ModuleName._module moduleName) x
162+ |> A.A region
163+ |> Result.err
152164 in
153165 case value of
154166 Var.Value x ->
155− if Map.notMember x (Module.iTypes interface) then
156− notFound Var.getValues x
167+ if Map.notMember x (Module.iTypes interface) then
168+ notFound Var.getValues x
157169
158− else
159− Result.ok [patch Env.Value x]
170+ else
171+ Result.ok [patch Env.Value x]
160172
161173 Var.Alias x ->
162− case Map.lookup x (Module.iAliases interface) of
163− Just (tvars, t) ->
164− let alias =
165− Env.Alias x (Var.fromModule moduleName x, tvars, t)
166− in
167− Result.ok $
168− if Map.member x (Module.iTypes interface)
169− then [alias, patch Env.Value x]
170− else [alias]
171−
172− Nothing ->
173− case Map.lookup x (Module.iAdts interface) of
174− Just (_,_) ->
175− Result.ok [patch Env.Union x]
176−
177− Nothing ->
178− let getNames values =
179− Var.getAliases values
180− ++ map fst (Var.getUnions values)
181− in
182− notFound getNames x
174+ case Map.lookup x (Module.iAliases interface) of
175+ Just (tvars, t) ->
176+ let alias =
177+ Env.Alias x (Var.fromModule moduleName x, tvars, t)
178+ in
179+ Result.ok $
180+ if Map.member x (Module.iTypes interface)
181+ then [alias, patch Env.Value x]
182+ else [alias]
183+
184+ Nothing ->
185+ case Map.lookup x (Module.iAdts interface) of
186+ Just (_,_) ->
187+ Result.ok [patch Env.Union x]
188+
189+ Nothing ->
190+ let getNames values =
191+ Var.getAliases values
192+ ++ map fst (Var.getUnions values)
193+ in
194+ notFound getNames x
183195
184196 Var.Union givenName (Var.Listing givenCtorNames open) ->
185− case Map.lookup givenName (Module.iAdts interface) of
186− Nothing ->
187− notFound (map fst . Var.getUnions) givenName
188−
189− Just (_tvars, realCtors) ->
190− patches <$>
191− if open
192− then Result.ok realCtorList
193− else Trav.traverse ctorExists givenCtorNames
194− where
195− realCtorList =
196− map (second length) realCtors
197−
198− realCtorDict =
199− Map.fromList realCtorList
200−
201− ctorExists givenCtorName =
202− case Map.lookup givenCtorName realCtorDict of
203− Just numArgs ->
204− Result.ok (givenCtorName, numArgs)
205− Nothing ->
206− notFound (const (map fst realCtors)) givenCtorName
207−
208− patches ctors =
209− patch Env.Union givenName
210− : map (patch Env.Value . fst) ctors
211− ++ map patternPatch ctors
197+ case Map.lookup givenName (Module.iAdts interface) of
198+ Nothing ->
199+ notFound (map fst . Var.getUnions) givenName
200+
201+ Just (_tvars, realCtors) ->
202+ patches <$>
203+ if open
204+ then Result.ok realCtorList
205+ else Trav.traverse ctorExists givenCtorNames
206+ where
207+ realCtorList =
208+ map (second length) realCtors
209+
210+ realCtorDict =
211+ Map.fromList realCtorList
212+
213+ ctorExists givenCtorName =
214+ case Map.lookup givenCtorName realCtorDict of
215+ Just numArgs ->
216+ Result.ok (givenCtorName, numArgs)
217+ Nothing ->
218+ notFound (const (map fst realCtors)) givenCtorName
219+
220+ patches ctors =
221+ patch Env.Union givenName
222+ : map (patch Env.Value . fst) ctors
223+ ++ map patternPatch ctors
224+
212225
213226
214227-- PATCHES FOR TYPE ALIASES
215228
216−type Node = ((R.Region, String, [String], Type.Raw), String, [String])
229+
230+type Node =
231+ ( (R.Region, String, [String], Type.Raw), String, [String] )
217232
218233
219234node :: R.Region -> String -> [String] -> Type.Raw -> Node
@@ -221,21 +236,21 @@ node region name tvars alias =
221236 ((region, name, tvars, alias), name, edges alias)
222237 where
223238 edges (A.A _ tipe) =
224− case tipe of
225− Type.RLambda t1 t2 ->
226− edges t1 ++ edges t2
239+ case tipe of
240+ Type.RLambda t1 t2 ->
241+ edges t1 ++ edges t2
227242
228− Type.RVar _ ->
229− []
243+ Type.RVar _ ->
244+ []
230245
231− Type.RType (Var.Raw x) ->
232− [x]
246+ Type.RType (Var.Raw x) ->
247+ [x]
233248
234− Type.RApp t ts ->
235− edges t ++ concatMap edges ts
249+ Type.RApp t ts ->
250+ edges t ++ concatMap edges ts
236251
237− Type.RRecord fs ext ->
238− maybe [] edges ext ++ concatMap (edges . snd) fs
252+ Type.RRecord fs ext ->
253+ maybe [] edges ext ++ concatMap (edges . snd) fs
239254
240255
241256addTypeAliases
@@ -244,10 +259,10 @@ addTypeAliases
244259 -> Env.Environment
245260 -> Result.ResultErr Env.Environment
246261addTypeAliases moduleName typeAliasNodes initialEnv =
247− Result.foldl
248− (addTypeAlias moduleName)
249− initialEnv
250− (Graph.stronglyConnComp typeAliasNodes)
262+ Result.foldl
263+ (addTypeAlias moduleName)
264+ initialEnv
265+ (Graph.stronglyConnComp typeAliasNodes)
251266
252267
253268addTypeAlias
@@ -267,26 +282,29 @@ addTypeAlias moduleName scc env =
267282 env { Env._aliases = Env.insert name value (Env._aliases env) }
268283
269284 Graph.CyclicSCC [] ->
270− Result.ok env
285+ Result.ok env
271286
272287 Graph.CyclicSCC [(region, name, tvars, alias)] ->
273− Result.err (A.A region (Error.Alias (Error.SelfRecursive name tvars alias)))
288+ Result.err (A.A region (Error.Alias (Error.SelfRecursive name tvars alias)))
274289
275290 Graph.CyclicSCC aliases@((region, _, _, _) : _) ->
276− Result.err (A.A region (Error.Alias (Error.MutuallyRecursive aliases)))
291+ Result.err (A.A region (Error.Alias (Error.MutuallyRecursive aliases)))
292+
277293
278294
279295-- DECLARATIONS TO PATCHES
280296
297+
281298declarationsToPatches
282299 :: ModuleName.Canonical
283300 -> [D.ValidDecl]
284301 -> ([Node], [Env.Patch])
285302declarationsToPatches moduleName decls =
286− let (maybeNodes, patchLists) =
287− unzip (map (declToPatches moduleName) decls)
303+ let
304+ (maybeNodes, patchLists) =
305+ unzip (map (declToPatches moduleName) decls)
288306 in
289− (Maybe.catMaybes maybeNodes, concat patchLists)
307+ (Maybe.catMaybes maybeNodes, concat patchLists)
290308
291309
292310-- When canonicalizing, it is important that:
@@ -299,14 +317,15 @@ declToPatches
299317 -> D.ValidDecl
300318 -> (Maybe Node, [Env.Patch])
301319declToPatches moduleName (A.A (region,_) decl) =
302− let topLevel mkPatch x =
303− mkPatch x (Var.topLevel moduleName x )
320+ let
321+ topLevel mkPatch x =
322+ mkPatch x (Var.topLevel moduleName x )
304323
305− namespaced mkPatch x =
306− mkPatch x (Var.fromModule moduleName x)
324+ namespaced mkPatch x =
325+ mkPatch x (Var.fromModule moduleName x)
307326
308− patternPatch (name, args) =
309− Env.Pattern name (Var.fromModule moduleName name, length args)
327+ patternPatch (name, args) =
328+ Env.Pattern name (Var.fromModule moduleName name, length args)
310329 in
311330 case decl of
312331 D.Definition (Valid.Definition pattern _ _) ->
@@ -381,8 +400,11 @@ restrictToPublicApi interface =
381400get :: Map.Map String a -> String -> Maybe (String, a)
382401get dict key =
383402 case Map.lookup key dict of
384− Nothing -> Nothing
385− Just value -> Just (key, value)
403+ Nothing ->
404+ Nothing
405+
406+ Just value ->
407+ Just (key, value)
386408
387409
388410trimUnions
@@ -391,9 +413,12 @@ trimUnions
391413 -> Maybe (String, Module.AdtInfo String)
392414trimUnions interface (name, Var.Listing exportedCtors _) =
393415 case Map.lookup name (Module.iAdts interface) of
394− Nothing -> Nothing
416+ Nothing ->
417+ Nothing
418+
395419 Just (tvars, ctors) ->
396− let isExported (ctor, _) =
397− ctor `elem` exportedCtors
420+ let
421+ isExported (ctor, _) =
422+ ctor `elem` exportedCtors
398423 in
399− Just (name, (tvars, filter isExported ctors))
424+ Just (name, (tvars, filter isExported ctors))