@@ -1,4 +1,5 @@
11{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
23module Canonicalize.Expression
34 ( canonicalize
45 , FreeLocals
@@ -9,8 +10,11 @@ module Canonicalize.Expression
910 where
1011
1112
13+import Control.Monad (foldM)
1214import qualified Data.Graph as Graph
15+import qualified Data.List as List
1316import qualified Data.Map.Strict as Map
17+import qualified Data.Text as Text
1418
1519import qualified AST.Canonical as Can
1620import qualified AST.Source as Src
@@ -287,77 +291,66 @@ toBinop (Env.Binop op home name annotation _ _) left right =
287291canonicalizeLet :: R.Region -> Env.Env -> [Valid.Def] -> Valid.Expr -> Result FreeLocals [W.Warning] Can.Expr
288292canonicalizeLet letRegion env defs body =
289293 directUsage $
290− do let keyedDefs = zip defs [ 0 .. length defs ]
291− let names = foldr addBindings Dups.none keyedDefs
292− nameDict <- Dups.detect (Error.DuplicatePattern Error.DPLetBinding) names
294+ do bindings <-
295+ Dups.detect (Error.DuplicatePattern Error.DPLetBinding) $
296+ List.foldl' addBindings Dups.none defs
293297
294− let bindings = Map.map A.toRegion nameDict
295− let defKeys = Map.map A.toValue nameDict
296− newEnv <- Env.addLocals bindings env
298+ newEnv <- Env.addLocals bindings env
297299
298− ((nodes, cbody), freeLocals) <-
299300 verifyBindings W.Def bindings $
300− (,)
301− <$> traverse (defToNode defKeys newEnv) keyedDefs
302− <*> canonicalize newEnv body
303−
304− letExpr <-
305− detectCycles letRegion (Graph.stronglyConnComp nodes) cbody
306−
307− return (letExpr, freeLocals)
301+ do nodes <- foldM (addDefNodes newEnv) [] defs
302+ cbody <- canonicalize newEnv body
303+ detectCycles letRegion (Graph.stronglyConnComp nodes) cbody
308304
309305
310306
311307-- ADD BINDINGS
312308
313309
314−type Bindings =
315− Dups.Dict (A.Located Int)
316−
317−
318−addBindings :: (Valid.Def, Int) -> Bindings -> Bindings
319−addBindings (def, key) bindings =
310+addBindings :: Dups.Dict R.Region -> Valid.Def -> Dups.Dict R.Region
311+addBindings bindings def =
320312 case def of
321− Valid.Define defRegion (A.At region name) _ _ _ ->
322− Dups.insert name region (A.At defRegion key) bindings
313+ Valid.Define _ (A.At region name) _ _ _ ->
314+ Dups.insert name region region bindings
323315
324− Valid.Destruct defRegion pattern _ ->
325− addBindingsHelp (A.At defRegion key) pattern bindings
316+ Valid.Destruct _ pattern _ ->
317+ addBindingsHelp bindings pattern
326318
327319
328−addBindingsHelp :: A.Located Int -> Src.Pattern -> Bindings -> Bindings
329−addBindingsHelp key (A.At region pattern) bindings =
320+addBindingsHelp :: Dups.Dict R.Region -> Src.Pattern -> Dups.Dict R.Region
321+addBindingsHelp bindings (A.At region pattern) =
330322 case pattern of
331323 Src.PAnything ->
332324 bindings
333325
334326 Src.PVar name ->
335− Dups.insert name region key bindings
327+ Dups.insert name region region bindings
336328
337329 Src.PRecord fields ->
338330 let
339− addField (A.At fieldRegion name) dict =
340− Dups.insert name fieldRegion key dict
331+ addField dict (A.At fieldRegion name) =
332+ Dups.insert name fieldRegion fieldRegion dict
341333 in
342− foldr addField bindings fields
334+ List.foldl' addField bindings fields
343335
344336 Src.PUnit ->
345337 bindings
346338
347339 Src.PTuple a b cs ->
348− foldr (addBindingsHelp key) bindings (a:b:cs)
340+ List.foldl' addBindingsHelp bindings (a:b:cs)
349341
350342 Src.PCtor _ _ _ patterns ->
351− foldr (addBindingsHelp key) bindings patterns
343+ List.foldl' addBindingsHelp bindings patterns
352344
353345 Src.PList patterns ->
354− foldr (addBindingsHelp key) bindings patterns
346+ List.foldl' addBindingsHelp bindings patterns
355347
356− Src.PCons first rest ->
357− addBindingsHelp key rest (addBindingsHelp key first bindings)
348+ Src.PCons hd tl ->
349+ addBindingsHelp (addBindingsHelp bindings hd) tl
358350
359− Src.PAlias ptrn (A.At reg name) ->
360− addBindingsHelp key ptrn (Dups.insert name reg key bindings)
351+ Src.PAlias aliasPattern (A.At nameRegion name) ->
352+ Dups.insert name nameRegion nameRegion $
353+ addBindingsHelp bindings aliasPattern
361354
362355 Src.PChr _ ->
363356 bindings
@@ -374,72 +367,75 @@ addBindingsHelp key (A.At region pattern) bindings =
374367
375368
376369type Node =
377− (Binding, Int, [Int])
370+ (Binding, N.Name, [N.Name])
378371
379372
380373data Binding
381− = Define R.Region Can.Def
382− | Destruct R.Region Can.Pattern Can.Expr
374+ = Define Can.Def
375+ | Edge (A.Located N.Name)
376+ | Destruct Can.Pattern Can.Expr
383377
384378
385−defToNode :: Map.Map N.Name Int -> Env.Env -> (Valid.Def, Int) -> Result FreeLocals [W.Warning] Node
386−defToNode defKeys env (def, key) =
379+addDefNodes :: Env.Env -> [Node] -> Valid.Def -> Result FreeLocals [W.Warning] [Node]
380+addDefNodes env nodes def =
387381 case def of
388− Valid.Define region aname@(A.At _ name) srcArgs body Nothing ->
389− do (args, argBindings) <-
390− Pattern.verify (Error.DPFuncArgs name) $
391− traverse (Pattern.canonicalize env) srcArgs
382+ Valid.Define _ aname@(A.At _ name) srcArgs body maybeType ->
383+ case maybeType of
384+ Nothing ->
385+ do (args, argBindings) <-
386+ Pattern.verify (Error.DPFuncArgs name) $
387+ traverse (Pattern.canonicalize env) srcArgs
392388
393− newEnv <-
394− Env.addLocals argBindings env
389+ newEnv <-
390+ Env.addLocals argBindings env
395391
396− (cbody, freeLocals) <-
397− verifyBindings W.Pattern argBindings (canonicalize newEnv body)
392+ (cbody, freeLocals) <-
393+ verifyBindings W.Pattern argBindings (canonicalize newEnv body)
398394
399− logLetLocals args freeLocals
400− ( Define region (Can.Def aname args cbody)
401− , key
402− , Map.elems (Map.intersection defKeys freeLocals)
403− )
395+ let cdef = Can.Def aname args cbody
396+ let node = ( Define cdef, name, Map.keys freeLocals )
397+ logLetLocals args freeLocals (node:nodes)
404398
405− Valid.Destruct region pattern body ->
399+ Just tipe ->
400+ do (Can.Forall freeVars ctipe) <- Type.toAnnotation env tipe
401+ ((args, resultType), argBindings) <-
402+ Pattern.verify (Error.DPFuncArgs name) $
403+ gatherTypedArgs env name srcArgs ctipe Index.first []
404+
405+ newEnv <-
406+ Env.addLocals argBindings env
407+
408+ (cbody, freeLocals) <-
409+ verifyBindings W.Pattern argBindings (canonicalize newEnv body)
410+
411+ let cdef = Can.TypedDef aname freeVars args cbody resultType
412+ let node = ( Define cdef, name, Map.keys freeLocals )
413+ logLetLocals args freeLocals (node:nodes)
414+
415+ Valid.Destruct _ pattern body ->
406416 do (cpattern, _bindings) <-
407417 Pattern.verify Error.DPDestruct $
408418 Pattern.canonicalize env pattern
409419
410− Result.Result $ \freeLocals warnings bad good ->
420+ Result.Result $ \fs ws bad good ->
411421 case canonicalize env body of
412422 Result.Result k ->
413− k Map.empty warnings
414− (\_ ws es -> bad freeLocals ws es)
415− (\newFreeLocals warnings1 cbody ->
423+ k Map.empty ws
424+ (\freeLocals warnings errors ->
425+ bad (Map.unionWith combineUses freeLocals fs) warnings errors
426+ )
427+ (\freeLocals warnings cbody ->
428+ let
429+ names = getPatternNames [] pattern
430+ name = Text.intercalate "$" (map A.toValue names)
431+ node = ( Destruct cpattern cbody, name, Map.keys freeLocals )
432+ in
416433 good
417− (Map.unionWith combineUses freeLocals newFreeLocals)
418− warnings1
419− ( Destruct region cpattern cbody
420− , key
421− , Map.elems (Map.intersection defKeys freeLocals)
422− )
434+ (Map.unionWith combineUses fs freeLocals)
435+ warnings
436+ (List.foldl' (addEdge [name]) (node:nodes) names)
423437 )
424438
425− Valid.Define region aname@(A.At _ name) srcArgs body (Just tipe) ->
426− do (Can.Forall freeVars ctipe) <- Type.toAnnotation env tipe
427− ((args, resultType), argBindings) <-
428− Pattern.verify (Error.DPFuncArgs name) $
429− gatherTypedArgs env name srcArgs ctipe Index.first []
430−
431− newEnv <-
432− Env.addLocals argBindings env
433−
434− (cbody, freeLocals) <-
435− verifyBindings W.Pattern argBindings (canonicalize newEnv body)
436−
437− logLetLocals args freeLocals
438− ( Define region (Can.TypedDef aname freeVars args cbody resultType)
439− , key
440− , Map.elems (Map.intersection defKeys freeLocals)
441− )
442−
443439
444440logLetLocals :: [arg] -> FreeLocals -> value -> Result FreeLocals w value
445441logLetLocals args letLocals value =
@@ -454,6 +450,28 @@ logLetLocals args letLocals value =
454450 value
455451
456452
453+addEdge :: [N.Name] -> [Node] -> A.Located N.Name -> [Node]
454+addEdge edges nodes aname@(A.At _ name) =
455+ (Edge aname, name, edges) : nodes
456+
457+
458+getPatternNames :: [A.Located N.Name] -> Src.Pattern -> [A.Located N.Name]
459+getPatternNames names (A.At region pattern) =
460+ case pattern of
461+ Src.PAnything -> names
462+ Src.PVar name -> A.At region name : names
463+ Src.PRecord fields -> fields ++ names
464+ Src.PAlias ptrn name -> getPatternNames (name : names) ptrn
465+ Src.PUnit -> names
466+ Src.PTuple a b cs -> List.foldl' getPatternNames (getPatternNames (getPatternNames names a) b) cs
467+ Src.PCtor _ _ _ args -> List.foldl' getPatternNames names args
468+ Src.PList patterns -> List.foldl' getPatternNames names patterns
469+ Src.PCons hd tl -> getPatternNames (getPatternNames names hd) tl
470+ Src.PChr _ -> names
471+ Src.PStr _ -> names
472+ Src.PInt _ -> names
473+
474+
457475
458476-- GATHER TYPED ARGS
459477
@@ -495,54 +513,76 @@ detectCycles letRegion sccs body =
495513 Result.ok body
496514
497515 scc : subSccs ->
498− A.At letRegion <$>
499516 case scc of
500517 Graph.AcyclicSCC binding ->
501518 case binding of
502− Define _ def ->
503− Can.Let def
504− <$> detectCycles letRegion subSccs body
519+ Define def ->
520+ A.At letRegion . Can.Let def <$> detectCycles letRegion subSccs body
521+
522+ Edge _ ->
523+ detectCycles letRegion subSccs body
505524
506− Destruct _ pattern expr ->
507− Can.LetDestruct pattern expr
508− <$> detectCycles letRegion subSccs body
525+ Destruct pattern expr ->
526+ A.At letRegion . Can.LetDestruct pattern expr <$> detectCycles letRegion subSccs body
509527
510528 Graph.CyclicSCC bindings ->
511− case traverse requireFunction bindings of
512− Just defs ->
513− Can.LetRec defs
514− <$> detectCycles letRegion subSccs body
529+ A.At letRegion <$>
530+ (Can.LetRec
531+ <$> checkCycle bindings []
532+ <*> detectCycles letRegion subSccs body
533+ )
515534
516− Nothing ->
517− Result.throw (Error.RecursiveLet letRegion (map toCycleNodes bindings))
518535
536+checkCycle :: [Binding] -> [Can.Def] -> Result i w [Can.Def]
537+checkCycle bindings defs =
538+ case bindings of
539+ [] ->
540+ Result.ok defs
519541
520−requireFunction :: Binding -> Maybe Can.Def
521−requireFunction binding =
522− case binding of
523− Define _ def@(Can.Def _ (_:_) _) ->
524− Just def
542+ binding : otherBindings ->
543+ case binding of
544+ Define def@(Can.Def name args _) ->
545+ if null args then
546+ Result.throw (Error.RecursiveLet name (toNames otherBindings defs))
547+ else
548+ checkCycle otherBindings (def:defs)
525549
526− Define _ def@(Can.TypedDef _ _ (_:_) _ _) ->
527− Just def
550+ Define def@(Can.TypedDef name _ args _ _) ->
551+ if null args then
552+ Result.throw (Error.RecursiveLet name (toNames otherBindings defs))
553+ else
554+ checkCycle otherBindings (def:defs)
528555
529− _ ->
530− Nothing
556+ Edge name ->
557+ Result.throw (Error.RecursiveLet name (toNames otherBindings defs))
531558
559+ Destruct _ _ ->
560+ -- a Destruct cannot appear in a cycle without any Edge values
561+ -- so we just keep going until we get to the edges
562+ checkCycle otherBindings defs
532563
533−toCycleNodes :: Binding -> Error.CycleNode
534−toCycleNodes binding =
535− case binding of
536− Define _ def ->
537− case def of
538− Can.Def name args _ ->
539− if null args then Error.CycleValue name else Error.CycleFunc name
540564
541− Can.TypedDef name _ args _ _ ->
542− if null args then Error.CycleValue name else Error.CycleFunc name
565+toNames :: [Binding] -> [Can.Def] -> [N.Name]
566+toNames bindings revDefs =
567+ case bindings of
568+ [] ->
569+ reverse (map getDefName revDefs)
570+
571+ binding : otherBindings ->
572+ case binding of
573+ Define def -> getDefName def : toNames otherBindings revDefs
574+ Edge (A.At _ name) -> name : toNames otherBindings revDefs
575+ Destruct _ _ -> toNames otherBindings revDefs
576+
577+
578+getDefName :: Can.Def -> N.Name
579+getDefName def =
580+ case def of
581+ Can.Def (A.At _ name) _ _ ->
582+ name
543583
544− Destruct _ pattern _ ->
545− Error.CyclePattern pattern
584+ Can.TypedDef (A.At _ name) _ _ _ _ ->
585+ name
546586
547587
548588