minimizeOrdered function

parser-typechecker/src/Unison/Codecs.hs

@@ -25,7 +25,6 @@ import           Unison.Reference (Reference, pattern Builtin, pattern Derived)
 import qualified Unison.Referent as Referent
 import qualified Unison.ConstructorType as ConstructorType 
 import           Unison.Term
-import qualified Unison.Typechecker.Components as Components
 import           Unison.UnisonFile (UnisonFile(..))
 import qualified Unison.UnisonFile as UF
 import           Unison.Var (Var)
@@ -337,19 +336,6 @@ serializeFile uf@(UnisonFile dataDecls effectDecls _ _) tm = do
   serializeFoldable (uncurry serializeConstructorArities) effectDecls'
   -- NB: we rewrite the term to minimize away let rec cycles, as let rec
   -- blocks aren't allowed to have effects
-  pos <- serializeTerm
-    (ABT.rebuildUp'
-      ( either
-          (\e ->
-            error
-              (  "The Unison file is malformed. It has duplicate bindings "
-              ++ show (void <$> e)
-              )
-          )
-          id
-      . Components.minimize'
-      )
-      body
-    )
+  pos <- serializeTerm body
   putWord8 0
   putBackref pos

parser-typechecker/src/Unison/Runtime/ANF.hs

@@ -21,7 +21,7 @@ import qualified Data.Text as Text
 import qualified Unison.ABT as ABT
 import qualified Unison.Term as Term
 import qualified Unison.Var as Var
-import Unison.Typechecker.Components (minimize')
+import Unison.Typechecker.Components (minimizeOrdered')
 -- import Debug.Trace
 -- import qualified Unison.TermPrinter as TP
 -- import qualified Unison.Util.Pretty as P
@@ -93,7 +93,7 @@ isLeaf (TypeLink' _) = True
 isLeaf _ = False
 
 minimizeCyclesOrCrash :: Var v => AnnotatedTerm v a -> AnnotatedTerm v a
-minimizeCyclesOrCrash t = case minimize' t of
+minimizeCyclesOrCrash t = case minimizeOrdered' t of
   Right t -> t
   Left e -> error $ "tried to minimize let rec with duplicate definitions: "
                  ++ show (fst <$> toList e)

parser-typechecker/src/Unison/TermParser.hs

@@ -570,7 +570,7 @@ block' isTop s openBlock closeBlock = do
       = let
           startAnnotation = (fst . fst . head $ toBindings bs)
           endAnnotation   = (fst . fst . last $ toBindings bs)
-          finish tm = case Components.minimize' tm of
+          finish tm = case Components.minimizeOrdered' tm of
             Left dups -> customFailure $ DuplicateTermNames (toList dups)  
             Right tm -> pure tm
         in

parser-typechecker/src/Unison/Typechecker/Components.hs

@@ -1,4 +1,4 @@
-module Unison.Typechecker.Components (minimize, minimize') where
+module Unison.Typechecker.Components (minimize, minimize',minimizeOrdered,minimizeUnordered,minimizeOrdered',minimizeUnordered',ordered,unordered) where
 
 import Unison.Prelude
 
@@ -16,6 +16,24 @@ import           Unison.Term (AnnotatedTerm')
 import qualified Unison.Term as Term
 import           Unison.Var (Var)
 
+type Components vt v a = [(v,AnnotatedTerm' vt v a)] -> [[(v,AnnotatedTerm' vt v a)]]
+
+unordered :: Var v => [(v,AnnotatedTerm' vt v a)] -> [[(v,AnnotatedTerm' vt v a)]]
+unordered = ABT.components 
+
+ordered :: Var v => [(v,AnnotatedTerm' vt v a)] -> [[(v,AnnotatedTerm' vt v a)]]
+ordered = ABT.orderedComponents 
+
+minimizeOrdered, minimizeUnordered :: 
+   Var v => AnnotatedTerm' vt v a -> Either (NonEmpty (v, [a])) (Maybe (AnnotatedTerm' vt v a))
+minimizeOrdered = minimize ordered
+minimizeUnordered = minimize unordered
+
+minimizeOrdered', minimizeUnordered' :: 
+   Var v => AnnotatedTerm' vt v a -> Either (NonEmpty (v, [a])) (AnnotatedTerm' vt v a)
+minimizeOrdered' = minimize' ordered
+minimizeUnordered' = minimize' unordered
+
 -- | Algorithm for minimizing cycles of a `let rec`. This can
 -- improve generalization during typechecking and may also be more
 -- efficient for execution.
@@ -32,9 +50,10 @@ import           Unison.Var (Var)
 -- Fails on the left if there are duplicate definitions.
 minimize
   :: Var v
-  => AnnotatedTerm' vt v a
+  => Components vt v a
+  -> AnnotatedTerm' vt v a
   -> Either (NonEmpty (v, [a])) (Maybe (AnnotatedTerm' vt v a))
-minimize (Term.LetRecNamedAnnotatedTop' isTop ann bs e) =
+minimize components (Term.LetRecNamedAnnotatedTop' isTop ann bs e) =
   let bindings = first snd <$> bs
       group    = map (fst . head &&& map (ABT.annotation . snd)) . groupBy ((==) `on` fst) . sortBy
         (compare `on` fst)
@@ -43,7 +62,7 @@ minimize (Term.LetRecNamedAnnotatedTop' isTop ann bs e) =
   in  if not $ null dupes
         then Left $ Nel.fromList dupes
         else
-          let cs0            = ABT.components bindings
+          let cs0            = components bindings
               -- within a cycle, we put the lambdas first, so
               -- unguarded definitions can refer to these lambdas, example:
               --
@@ -75,8 +94,8 @@ minimize (Term.LetRecNamedAnnotatedTop' isTop ann bs e) =
             -- sure to preserve it, whereas the annotations at intermediate Abs
             -- nodes aren't necessarily meaningful
               Right . Just . ABT.annotate ann . foldr mklet e $ cs
-minimize _ = Right Nothing
+minimize _ _ = Right Nothing
 
 minimize'
-  :: Var v => AnnotatedTerm' vt v a -> Either (NonEmpty (v,[a])) (AnnotatedTerm' vt v a)
-minimize' term = fromMaybe term <$> minimize term
+  :: Var v => Components vt v a -> AnnotatedTerm' vt v a -> Either (NonEmpty (v,[a])) (AnnotatedTerm' vt v a)
+minimize' cs term = fromMaybe term <$> minimize cs term

parser-typechecker/src/Unison/Typechecker/Context.hs

@@ -79,7 +79,7 @@ import           Unison.Referent                ( Referent )
 import           Unison.Term                    ( AnnotatedTerm' )
 import qualified Unison.Term                   as Term
 import qualified Unison.Type                   as Type
-import           Unison.Typechecker.Components  ( minimize' )
+import           Unison.Typechecker.Components  ( minimizeOrdered' )
 import qualified Unison.Typechecker.TypeLookup as TL
 import qualified Unison.TypeVar                as TypeVar
 import           Unison.Var                     ( Var )
@@ -803,7 +803,7 @@ noteTopLevelType e binding typ = case binding of
 synthesize :: forall v loc . (Var v, Ord loc) => Term v loc -> M v loc (Type v loc)
 synthesize e | debugEnabled && traceShow ("synthesize"::String, e) False = undefined
 synthesize e = scope (InSynthesize e) $
-  case minimize' e of
+  case minimizeOrdered' e of
     Left es -> failWith (DuplicateDefinitions es)
     Right e -> do
       Type.Effect'' es t <- go e
@@ -1291,7 +1291,7 @@ check e t | debugEnabled && traceShow ("check" :: String, e, t) False = undefine
 check e0 t0 = scope (InCheck e0 t0) $ do
   ctx <- getContext
   let Type.Effect'' es t = t0
-  let e                  = minimize' e0
+  let e                  = minimizeOrdered' e0
   case e of
     Left e -> failWith $ DuplicateDefinitions e
     Right e ->

parser-typechecker/src/Unison/UnisonFile.hs

@@ -36,6 +36,7 @@ import qualified Unison.Typechecker.TypeLookup as TL
 import Unison.Names3 (Names0)
 import qualified Unison.LabeledDependency as LD
 import Unison.LabeledDependency (LabeledDependency)
+import qualified Unison.Typechecker.Components as Components
 
 data UnisonFile v a = UnisonFile {
   dataDeclarations   :: Map v (Reference, DataDeclaration' v a),

unison-core/src/Unison/ABT.hs

@@ -558,6 +558,24 @@ instance (Foldable f, Functor f, Ord1 f, Var v) => Ord (Term f v a) where
 components :: Var v => [(v, Term f v a)] -> [[(v, Term f v a)]]
 components = Components.components freeVars
 
+-- Converts to strongly connected components, preserving order of the input.
+-- Satisfies `join (orderedComponents vs) == vs`. Algorithm works by 
+-- repeatedly collecting smallest cycle of definitions from remainder of list. 
+orderedComponents :: Var v => [(v, Term f v a)] -> [[(v, Term f v a)]]
+orderedComponents tms = go [] Set.empty tms 
+  where
+  go [] _ [] = []
+  go [] deps (hd:rem) = go [hd] (deps <> freeVars (snd hd)) rem
+  go cur deps rem = case findIndex isDep rem of
+    Nothing -> reverse cur : let (hd,tl) = splitAt 1 rem
+                             in go hd (depsFor hd) tl
+    Just i  -> go (reverse newMembers ++ cur) deps' (drop (i+1) rem) 
+               where deps' = deps <> depsFor newMembers
+                     newMembers = take (i+1) rem
+    where
+    depsFor = foldMap (freeVars . snd)
+    isDep (v, _) = Set.member v deps
+
 -- Hash a strongly connected component and sort its definitions into a canonical order.
 hashComponent ::
   (Functor f, Hashable1 f, Foldable f, Eq v, Show v, Var v, Ord h, Accumulate h)