git.iko.soy/elk
on master help sign in
cosmetic: modernize whitespace
c4f6f6aEvan Czaplicki
src/Canonicalize/Setup.hs+173−148
compare with master
unifiedsplit
@@ -24,6 +24,7 @@ import qualified Canonicalize.Result as Result
24import qualified Canonicalize.Type as Canonicalize
24import qualified Canonicalize.Type as Canonicalize
25
25
26
26
27+
27environment
28environment
28 :: Map.Map ModuleName.Raw ModuleName.Canonical
29 :: Map.Map ModuleName.Raw ModuleName.Canonical
29 -> Module.Interfaces
30 -> Module.Interfaces
@@ -43,12 +44,14 @@ environment importDict interfaces (Module.Module name _ _ _ (defaults, imports)
43 patches =
44 patches =
44 (++) (Env.builtinPatches ++ declPatches) <$> importPatchesResult
45 (++) (Env.builtinPatches ++ declPatches) <$> importPatchesResult
45 in
46 in
46− (Env.fromPatches name <$> patches)
47+ (Env.fromPatches name <$> patches)
47− `Result.andThen` addTypeAliases name typeAliasNodes
48+ `Result.andThen` addTypeAliases name typeAliasNodes
49+
48
50
49
51
50-- PATCHES FOR IMPORTS
52-- PATCHES FOR IMPORTS
51
53
54+
52importPatches
55importPatches
53 :: Map.Map ModuleName.Raw ModuleName.Canonical
56 :: Map.Map ModuleName.Raw ModuleName.Canonical
54 -> Module.Interfaces
57 -> Module.Interfaces
@@ -63,68 +66,76 @@ importPatches importDict allInterfaces (A.A region (rawImportName, method)) =
63 in
66 in
64 case maybeInterface of
67 case maybeInterface of
65 Nothing ->
68 Nothing ->
66− if ModuleName.isNative rawImportName then
69+ if ModuleName.isNative rawImportName then
67− Result.ok []
70+ Result.ok []
68−
71+
69− else
72+ else
70− allInterfaces
73+ allInterfaces
71− |> Map.keys
74+ |> Map.keys
72− |> map ModuleName._module
75+ |> map ModuleName._module
73− |> Error.nearbyNames ModuleName.toString rawImportName
76+ |> Error.nearbyNames ModuleName.toString rawImportName
74− |> Error.moduleNotFound rawImportName
77+ |> Error.moduleNotFound rawImportName
75− |> A.A region
78+ |> A.A region
76− |> Result.err
79+ |> Result.err
77
80
78 Just (importName, interface) ->
81 Just (importName, interface) ->
82+ let
79− let (Module.ImportMethod maybeAlias listing) =
83+ (Module.ImportMethod maybeAlias listing) =
80− method
84+ method
81
85
82− (Var.Listing exposedValues open) =
86+ (Var.Listing exposedValues open) =
83− listing
87+ listing
84
88
85− qualifier =
89+ qualifier =
86− maybe (ModuleName.toString rawImportName) id maybeAlias
90+ maybe (ModuleName.toString rawImportName) id maybeAlias
87
91
88− qualifiedPatches =
92+ qualifiedPatches =
89− interfacePatches importName (qualifier ++ ".") interface
93+ interfacePatches importName (qualifier ++ ".") interface
90
94
91− unqualifiedPatches =
95+ unqualifiedPatches =
92− if open
96+ if open then
93− then Result.ok (interfacePatches importName "" interface)
97+ Result.ok (interfacePatches importName "" interface)
98+
99+ else
94− else concat <$> Trav.traverse (valueToPatches region importName interface) exposedValues
100+ concat <$> Trav.traverse (valueToPatches region importName interface) exposedValues
95− in
101+ in
96− (++) qualifiedPatches <$> unqualifiedPatches
102+ (++) qualifiedPatches <$> unqualifiedPatches
97
103
98
104
99interfacePatches :: ModuleName.Canonical -> String -> Module.Interface -> [Env.Patch]
105interfacePatches :: ModuleName.Canonical -> String -> Module.Interface -> [Env.Patch]
100interfacePatches moduleName prefix interface =
106interfacePatches moduleName prefix interface =
107+ let
101− let genericPatch mkPatch name value =
108+ genericPatch mkPatch name value =
102− mkPatch (prefix ++ name) value
109+ mkPatch (prefix ++ name) value
103
110
104− patch mkPatch name =
111+ patch mkPatch name =
105− genericPatch mkPatch name (Var.fromModule moduleName name)
112+ genericPatch mkPatch name (Var.fromModule moduleName name)
106
113
107− aliasPatch (name, (tvars, tipe)) =
114+ aliasPatch (name, (tvars, tipe)) =
108− genericPatch Env.Alias name
115+ genericPatch
116+ Env.Alias
117+ name
109− (Var.fromModule moduleName name, tvars, tipe)
118+ (Var.fromModule moduleName name, tvars, tipe)
110
119
111− patternPatch (name, args) =
120+ patternPatch (name, args) =
112− genericPatch Env.Pattern name
121+ genericPatch
122+ Env.Pattern
123+ name
113− (Var.fromModule moduleName name, length args)
124+ (Var.fromModule moduleName name, length args)
114
125
115− ctors =
126+ ctors =
116− concatMap snd (Map.elems (Module.iAdts interface))
127+ concatMap snd (Map.elems (Module.iAdts interface))
117
128
118− ctorNames =
129+ ctorNames =
119− map fst ctors
130+ map fst ctors
120− in
131+ in
121− concat
132+ concat
122− [ map (patch Env.Value) (Map.keys (Module.iTypes interface))
133+ [ map (patch Env.Value) (Map.keys (Module.iTypes interface))
123− , map (patch Env.Value) ctorNames
134+ , map (patch Env.Value) ctorNames
124− , map (patch Env.Union) (Map.keys (Module.iAdts interface))
135+ , map (patch Env.Union) (Map.keys (Module.iAdts interface))
125− , map aliasPatch (Map.toList (Module.iAliases interface))
136+ , map aliasPatch (Map.toList (Module.iAliases interface))
126− , map patternPatch ctors
137+ , map patternPatch ctors
127− ]
138+ ]
128
139
129
140
130-- PATCHES FOR INDIVIDUAL VALUES
141-- PATCHES FOR INDIVIDUAL VALUES
@@ -136,84 +147,88 @@ valueToPatches
136 -> Var.Value
147 -> Var.Value
137 -> Result.ResultErr [Env.Patch]
148 -> Result.ResultErr [Env.Patch]
138valueToPatches region moduleName interface value =
149valueToPatches region moduleName interface value =
150+ let
139− let patch mkPatch x =
151+ patch mkPatch x =
140− mkPatch x (Var.fromModule moduleName x)
152+ mkPatch x (Var.fromModule moduleName x)
141−
153+
142− patternPatch (x, numArgs) =
154+ patternPatch (x, numArgs) =
143− Env.Pattern x (Var.fromModule moduleName x, numArgs)
155+ Env.Pattern x (Var.fromModule moduleName x, numArgs)
144−
156+
145− notFound getNames x =
157+ notFound getNames x =
146− Module.iExports interface
158+ Module.iExports interface
147− |> getNames
159+ |> getNames
148− |> Error.nearbyNames id x
160+ |> Error.nearbyNames id x
149− |> Error.valueNotFound (ModuleName._module moduleName) x
161+ |> Error.valueNotFound (ModuleName._module moduleName) x
150− |> A.A region
162+ |> A.A region
151− |> Result.err
163+ |> Result.err
152 in
164 in
153 case value of
165 case value of
154 Var.Value x ->
166 Var.Value x ->
155− if Map.notMember x (Module.iTypes interface) then
167+ if Map.notMember x (Module.iTypes interface) then
156− notFound Var.getValues x
168+ notFound Var.getValues x
157
169
158− else
170+ else
159− Result.ok [patch Env.Value x]
171+ Result.ok [patch Env.Value x]
160
172
161 Var.Alias x ->
173 Var.Alias x ->
162− case Map.lookup x (Module.iAliases interface) of
174+ case Map.lookup x (Module.iAliases interface) of
163− Just (tvars, t) ->
175+ Just (tvars, t) ->
164− let alias =
176+ let alias =
165− Env.Alias x (Var.fromModule moduleName x, tvars, t)
177+ Env.Alias x (Var.fromModule moduleName x, tvars, t)
166− in
178+ in
167− Result.ok $
179+ Result.ok $
168− if Map.member x (Module.iTypes interface)
180+ if Map.member x (Module.iTypes interface)
169− then [alias, patch Env.Value x]
181+ then [alias, patch Env.Value x]
170− else [alias]
182+ else [alias]
171−
183+
172− Nothing ->
184+ Nothing ->
173− case Map.lookup x (Module.iAdts interface) of
185+ case Map.lookup x (Module.iAdts interface) of
174− Just (_,_) ->
186+ Just (_,_) ->
175− Result.ok [patch Env.Union x]
187+ Result.ok [patch Env.Union x]
176−
188+
177− Nothing ->
189+ Nothing ->
178− let getNames values =
190+ let getNames values =
179− Var.getAliases values
191+ Var.getAliases values
180− ++ map fst (Var.getUnions values)
192+ ++ map fst (Var.getUnions values)
181− in
193+ in
182− notFound getNames x
194+ notFound getNames x
183
195
184 Var.Union givenName (Var.Listing givenCtorNames open) ->
196 Var.Union givenName (Var.Listing givenCtorNames open) ->
185− case Map.lookup givenName (Module.iAdts interface) of
197+ case Map.lookup givenName (Module.iAdts interface) of
186− Nothing ->
198+ Nothing ->
187− notFound (map fst . Var.getUnions) givenName
199+ notFound (map fst . Var.getUnions) givenName
188−
200+
189− Just (_tvars, realCtors) ->
201+ Just (_tvars, realCtors) ->
190− patches <$>
202+ patches <$>
191− if open
203+ if open
192− then Result.ok realCtorList
204+ then Result.ok realCtorList
193− else Trav.traverse ctorExists givenCtorNames
205+ else Trav.traverse ctorExists givenCtorNames
194− where
206+ where
195− realCtorList =
207+ realCtorList =
196− map (second length) realCtors
208+ map (second length) realCtors
197−
209+
198− realCtorDict =
210+ realCtorDict =
199− Map.fromList realCtorList
211+ Map.fromList realCtorList
200−
212+
201− ctorExists givenCtorName =
213+ ctorExists givenCtorName =
202− case Map.lookup givenCtorName realCtorDict of
214+ case Map.lookup givenCtorName realCtorDict of
203− Just numArgs ->
215+ Just numArgs ->
204− Result.ok (givenCtorName, numArgs)
216+ Result.ok (givenCtorName, numArgs)
205− Nothing ->
217+ Nothing ->
206− notFound (const (map fst realCtors)) givenCtorName
218+ notFound (const (map fst realCtors)) givenCtorName
207−
219+
208− patches ctors =
220+ patches ctors =
209− patch Env.Union givenName
221+ patch Env.Union givenName
210− : map (patch Env.Value . fst) ctors
222+ : map (patch Env.Value . fst) ctors
211− ++ map patternPatch ctors
223+ ++ map patternPatch ctors
224+
212
225
213
226
214-- PATCHES FOR TYPE ALIASES
227-- PATCHES FOR TYPE ALIASES
215
228
229+
230+type Node =
216−type Node = ((R.Region, String, [String], Type.Raw), String, [String])
231+ ( (R.Region, String, [String], Type.Raw), String, [String] )
217
232
218
233
219node :: R.Region -> String -> [String] -> Type.Raw -> Node
234node :: R.Region -> String -> [String] -> Type.Raw -> Node
@@ -221,21 +236,21 @@ node region name tvars alias =
221 ((region, name, tvars, alias), name, edges alias)
236 ((region, name, tvars, alias), name, edges alias)
222 where
237 where
223 edges (A.A _ tipe) =
238 edges (A.A _ tipe) =
224− case tipe of
239+ case tipe of
225− Type.RLambda t1 t2 ->
240+ Type.RLambda t1 t2 ->
226− edges t1 ++ edges t2
241+ edges t1 ++ edges t2
227
242
228− Type.RVar _ ->
243+ Type.RVar _ ->
229− []
244+ []
230
245
231− Type.RType (Var.Raw x) ->
246+ Type.RType (Var.Raw x) ->
232− [x]
247+ [x]
233
248
234− Type.RApp t ts ->
249+ Type.RApp t ts ->
235− edges t ++ concatMap edges ts
250+ edges t ++ concatMap edges ts
236
251
237− Type.RRecord fs ext ->
252+ Type.RRecord fs ext ->
238− maybe [] edges ext ++ concatMap (edges . snd) fs
253+ maybe [] edges ext ++ concatMap (edges . snd) fs
239
254
240
255
241addTypeAliases
256addTypeAliases
@@ -244,10 +259,10 @@ addTypeAliases
244 -> Env.Environment
259 -> Env.Environment
245 -> Result.ResultErr Env.Environment
260 -> Result.ResultErr Env.Environment
246addTypeAliases moduleName typeAliasNodes initialEnv =
261addTypeAliases moduleName typeAliasNodes initialEnv =
247− Result.foldl
262+ Result.foldl
248− (addTypeAlias moduleName)
263+ (addTypeAlias moduleName)
249− initialEnv
264+ initialEnv
250− (Graph.stronglyConnComp typeAliasNodes)
265+ (Graph.stronglyConnComp typeAliasNodes)
251
266
252
267
253addTypeAlias
268addTypeAlias
@@ -267,26 +282,29 @@ addTypeAlias moduleName scc env =
267 env { Env._aliases = Env.insert name value (Env._aliases env) }
282 env { Env._aliases = Env.insert name value (Env._aliases env) }
268
283
269 Graph.CyclicSCC [] ->
284 Graph.CyclicSCC [] ->
270− Result.ok env
285+ Result.ok env
271
286
272 Graph.CyclicSCC [(region, name, tvars, alias)] ->
287 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)))
274
289
275 Graph.CyclicSCC aliases@((region, _, _, _) : _) ->
290 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+
277
293
278
294
279-- DECLARATIONS TO PATCHES
295-- DECLARATIONS TO PATCHES
280
296
297+
281declarationsToPatches
298declarationsToPatches
282 :: ModuleName.Canonical
299 :: ModuleName.Canonical
283 -> [D.ValidDecl]
300 -> [D.ValidDecl]
284 -> ([Node], [Env.Patch])
301 -> ([Node], [Env.Patch])
285declarationsToPatches moduleName decls =
302declarationsToPatches moduleName decls =
303+ let
286− let (maybeNodes, patchLists) =
304+ (maybeNodes, patchLists) =
287− unzip (map (declToPatches moduleName) decls)
305+ unzip (map (declToPatches moduleName) decls)
288 in
306 in
289− (Maybe.catMaybes maybeNodes, concat patchLists)
307+ (Maybe.catMaybes maybeNodes, concat patchLists)
290
308
291
309
292-- When canonicalizing, it is important that:
310-- When canonicalizing, it is important that:
@@ -299,14 +317,15 @@ declToPatches
299 -> D.ValidDecl
317 -> D.ValidDecl
300 -> (Maybe Node, [Env.Patch])
318 -> (Maybe Node, [Env.Patch])
301declToPatches moduleName (A.A (region,_) decl) =
319declToPatches moduleName (A.A (region,_) decl) =
320+ let
302− let topLevel mkPatch x =
321+ topLevel mkPatch x =
303− mkPatch x (Var.topLevel moduleName x )
322+ mkPatch x (Var.topLevel moduleName x )
304
323
305− namespaced mkPatch x =
324+ namespaced mkPatch x =
306− mkPatch x (Var.fromModule moduleName x)
325+ mkPatch x (Var.fromModule moduleName x)
307
326
308− patternPatch (name, args) =
327+ patternPatch (name, args) =
309− Env.Pattern name (Var.fromModule moduleName name, length args)
328+ Env.Pattern name (Var.fromModule moduleName name, length args)
310 in
329 in
311 case decl of
330 case decl of
312 D.Definition (Valid.Definition pattern _ _) ->
331 D.Definition (Valid.Definition pattern _ _) ->
@@ -381,8 +400,11 @@ restrictToPublicApi interface =
381get :: Map.Map String a -> String -> Maybe (String, a)
400get :: Map.Map String a -> String -> Maybe (String, a)
382get dict key =
401get dict key =
383 case Map.lookup key dict of
402 case Map.lookup key dict of
384− Nothing -> Nothing
403+ Nothing ->
404+ Nothing
405+
406+ Just value ->
385− Just value -> Just (key, value)
407+ Just (key, value)
386
408
387
409
388trimUnions
410trimUnions
@@ -391,9 +413,12 @@ trimUnions
391 -> Maybe (String, Module.AdtInfo String)
413 -> Maybe (String, Module.AdtInfo String)
392trimUnions interface (name, Var.Listing exportedCtors _) =
414trimUnions interface (name, Var.Listing exportedCtors _) =
393 case Map.lookup name (Module.iAdts interface) of
415 case Map.lookup name (Module.iAdts interface) of
394− Nothing -> Nothing
416+ Nothing ->
417+ Nothing
418+
395 Just (tvars, ctors) ->
419 Just (tvars, ctors) ->
420+ let
396− let isExported (ctor, _) =
421+ isExported (ctor, _) =
397− ctor `elem` exportedCtors
422+ ctor `elem` exportedCtors
398 in
423 in
399− Just (name, (tvars, filter isExported ctors))
424+ Just (name, (tvars, filter isExported ctors))
src/Optimize.hs+12
@@ -166,8 +166,10 @@ patternToDefs home rootName pattern =
166 map toDef (patternToSubstitutions rootExpr pattern)
166 map toDef (patternToSubstitutions rootExpr pattern)
167
167
168
168
169+
169-- TURN A PATTERN INTO A BUNCH OF SUBSTITUTIONS
170-- TURN A PATTERN INTO A BUNCH OF SUBSTITUTIONS
170
171
172+
171patternToSubstitutions :: Opt.Expr -> P.CanonicalPattern -> [(String, Opt.Expr)]
173patternToSubstitutions :: Opt.Expr -> P.CanonicalPattern -> [(String, Opt.Expr)]
172patternToSubstitutions expr (A.A _ pattern) =
174patternToSubstitutions expr (A.A _ pattern) =
173 case pattern of
175 case pattern of
@@ -190,8 +192,10 @@ patternToSubstitutions expr (A.A _ pattern) =
190 concat (zipWith (patternToSubstitutions . Opt.DataAccess expr) [0..] patterns)
192 concat (zipWith (patternToSubstitutions . Opt.DataAccess expr) [0..] patterns)
191
193
192
194
195+
193-- OPTIMIZE EXPRESSIONS
196-- OPTIMIZE EXPRESSIONS
194
197
198+
195type Context = Maybe (String, Int, [String])
199type Context = Maybe (String, Int, [String])
196
200
197
201
@@ -322,8 +326,10 @@ mapSnd func (x, a) =
322 (,) x <$> func a
326 (,) x <$> func a
323
327
324
328
329+
325-- OPTIMIZE CASE BRANCHES
330-- OPTIMIZE CASE BRANCHES
326
331
332+
327optimizeBranch
333optimizeBranch
328 :: Context
334 :: Context
329 -> R.Region
335 -> R.Region
@@ -362,8 +368,10 @@ tagCrashBranch region pattern@(A.A pr _) expr =
362 return (pattern, expr)
368 return (pattern, expr)
363
369
364
370
371+
365-- DETECT TAIL CALL
372-- DETECT TAIL CALL
366
373
374+
367isTailCall :: Context -> Can.Expr -> Int -> Maybe (String, [String])
375isTailCall :: Context -> Can.Expr -> Int -> Maybe (String, [String])
368isTailCall context (A.A _ function) arity =
376isTailCall context (A.A _ function) arity =
369 case (context, function) of
377 case (context, function) of
@@ -379,11 +387,13 @@ isTailCall context (A.A _ function) arity =
379 Nothing
387 Nothing
380
388
381
389
390+
382-- DEPATTERN
391-- DEPATTERN
383-- given a pattern and an expression, push the actual pattern matching into the
392-- given a pattern and an expression, push the actual pattern matching into the
384-- expression as a case-expression if necessary. The pattern compiler will work
393-- expression as a case-expression if necessary. The pattern compiler will work
385-- it out from there
394-- it out from there
386
395
396+
387depattern :: P.CanonicalPattern -> Can.Expr -> Env.Optimizer (String, Can.Expr)
397depattern :: P.CanonicalPattern -> Can.Expr -> Env.Optimizer (String, Can.Expr)
388depattern canPattern@(A.A _ pattern) expr =
398depattern canPattern@(A.A _ pattern) expr =
389 let
399 let
@@ -424,8 +434,10 @@ depattern canPattern@(A.A _ pattern) expr =
424 caseify
434 caseify
425
435
426
436
437+
427-- OPTIMIZE BINOPS
438-- OPTIMIZE BINOPS
428
439
440+
429optimizeBinop
441optimizeBinop
430 :: Context
442 :: Context
431 -> R.Region
443 -> R.Region