WIP

parser-typechecker/src/Unison/UnisonFile/Type.hs

@@ -16,6 +16,9 @@ import Unison.Term (Term)
 import qualified Unison.Term as Term
 import Unison.Type (Type)
 import Unison.WatchKind (WatchKind)
+import Unison.Hash (Hash)
+import qualified Unison.Referent as Referent
+import qualified Unison.LabeledDependency as LD
 
 data UnisonFile v a = UnisonFileId {
   dataDeclarationsId   :: Map v (Reference.Id, DataDeclaration v a),
@@ -42,6 +45,17 @@ data TypecheckedUnisonFile v a =
     hashTermsId           :: Map v (Reference.Id, Maybe WatchKind, Term v a, Type v a)
   } deriving Show
 
+-- Produce a mapping which includes all component hashes and the variables contained
+-- within them.
+-- This includes all kinds of definitions: types, terms, abilities, constructors
+componentMap :: TypecheckedUnisonFile v ann -> Map Hash (Set v)
+componentMap _uf = undefined
+  -- TODO: watch components?
+
+-- Produce a mapping which includes all variables their reference.
+referencesMap :: TypecheckedUnisonFile v ann -> Map v LD.LabeledDependency
+referencesMap _uf = undefined
+
 {-# COMPLETE TypecheckedUnisonFile #-}
 pattern TypecheckedUnisonFile ds es tlcs wcs hts <-
   TypecheckedUnisonFileId (fmap (first Reference.DerivedId) -> ds)

unison-cli/src/Unison/Codebase/Editor/HandleInput.hs

@@ -55,8 +55,9 @@ import qualified Unison.Codebase.Editor.Propagate as Propagate
 import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRemotePath, WriteRepo, printNamespace, writePathToRead, writeToRead)
 import Unison.Codebase.Editor.SlurpComponent (SlurpComponent (..))
 import qualified Unison.Codebase.Editor.SlurpComponent as SC
+import qualified Unison.Codebase.Editor.Slurp as Slurp
 import Unison.Codebase.Editor.SlurpResult (SlurpResult (..))
-import qualified Unison.Codebase.Editor.SlurpResult as Slurp
+-- import qualified Unison.Codebase.Editor.SlurpResult as Slurp
 import qualified Unison.Codebase.Editor.TodoOutput as TO
 import qualified Unison.Codebase.Editor.UriParser as UriParser
 import qualified Unison.Codebase.MainTerm as MainTerm
@@ -152,6 +153,7 @@ import Data.Set.NonEmpty (NESet)
 import Unison.Symbol (Symbol)
 import qualified Unison.Codebase.Editor.Input as Input
 import Debug.Pretty.Simple
+import qualified Unison.Codebase.Editor.SlurpResult as OldSlurp
 
 defaultPatchNameSegment :: NameSegment
 defaultPatchNameSegment = "patch"
@@ -260,11 +262,12 @@ loop = do
       loadUnisonFile sourceName text = do
         let lexed = L.lexer (Text.unpack sourceName) (Text.unpack text)
         withFile [] sourceName (text, lexed) $ \unisonFile -> do
-          sr <- toSlurpResult currentPath' unisonFile <$> slurpResultNames
+          sr <- Slurp.analyzeTypecheckedUnisonFile unisonFile <$> currentPathNames
+          -- sr <- toSlurpResult currentPath' unisonFile <$> slurpResultNames
           names <- displayNames unisonFile
           pped <- prettyPrintEnvDecl names
           let ppe = PPE.suffixifiedPPE pped
-          eval . Notify $ Typechecked sourceName ppe sr unisonFile
+          eval . Notify $ Typechecked sourceName ppe (undefined $ Slurp.toSlurpPrintout sr) unisonFile
           unlessError' EvaluationFailure do
             (bindings, e) <- ExceptT . eval . Evaluate ppe $ unisonFile
             lift do
@@ -1256,11 +1259,11 @@ loop = do
                 Nothing -> respond NoUnisonFile
                 Just uf -> do
                   sr <-
-                    Slurp.disallowUpdates
+                    OldSlurp.disallowUpdates
                       . applySelection hqs uf
                       . toSlurpResult currentPath' uf
                       <$> slurpResultNames
-                  let adds = Slurp.adds sr
+                  let adds = OldSlurp.adds sr
                   stepAtNoSync Branch.CompressHistory (Path.unabsolute currentPath', doSlurpAdds adds uf)
                   eval . AddDefsToCodebase . filterBySlurpResult sr $ uf
                   ppe <- prettyPrintEnvDecl =<< displayNames uf
@@ -1270,7 +1273,7 @@ loop = do
             PreviewAddI hqs -> case (latestFile', uf) of
               (Just (sourceName, _), Just uf) -> do
                 sr <-
-                  Slurp.disallowUpdates
+                  OldSlurp.disallowUpdates
                     . applySelection hqs uf
                     . toSlurpResult currentPath' uf
                     <$> slurpResultNames
@@ -1820,50 +1823,49 @@ handleUpdate input maybePatchPath hqs = do
       let patchPath = fromMaybe defaultPatchPath maybePatchPath
       slurpCheckNames <- slurpResultNames
       let currentPathNames = slurpCheckNames
-      let sr :: SlurpResult v
-          sr =
-            applySelection hqs uf
-              . toSlurpResult currentPath' uf
-              $ slurpCheckNames
-          addsAndUpdates :: SlurpComponent v
-          addsAndUpdates = Slurp.updates sr <> Slurp.adds sr
+      let sr = Slurp.analyzeTypecheckedUnisonFile uf currentPathNames
+      -- let sr :: SlurpResult v
+      --     sr =
+      --       applySelection hqs uf
+      --         . toSlurpResult currentPath' uf
+      --         $ slurpCheckNames
           fileNames :: Names
           fileNames = UF.typecheckedToNames uf
           -- todo: display some error if typeEdits or termEdits itself contains a loop
-          typeEdits :: Map Name (Reference, Reference)
-          typeEdits = Map.fromList $ map f (toList $ SC.types (updates sr))
-            where
-              f v = case ( toList (Names.typesNamed slurpCheckNames n),
-                           toList (Names.typesNamed fileNames n)
-                         ) of
-                ([old], [new]) -> (n, (old, new))
-                _ ->
-                  error $
-                    "Expected unique matches for "
-                      ++ Var.nameStr v
-                      ++ " but got: "
-                      ++ show otherwise
-                where
-                  n = Name.unsafeFromVar v
+          -- typeEdits :: Map Name (Reference, Reference)
+          -- typeEdits = Map.fromList $ map f (toList $ SC.types (updates sr))
+          --   where
+          --     f v = case ( toList (Names.typesNamed slurpCheckNames n),
+          --                  toList (Names.typesNamed fileNames n)
+          --                ) of
+          --       ([old], [new]) -> (n, (old, new))
+          --       _ ->
+          --         error $
+          --           "Expected unique matches for "
+          --             ++ Var.nameStr v
+          --             ++ " but got: "
+          --             ++ show otherwise
+          --       where
+          --         n = Name.unsafeFromVar v
           hashTerms :: Map Reference (Type v Ann)
           hashTerms = Map.fromList (toList hashTerms0)
             where
               hashTerms0 = (\(r, _wk, _tm, typ) -> (r, typ)) <$> UF.hashTerms uf
-          termEdits :: Map Name (Reference, Reference)
-          termEdits = Map.fromList $ map g (toList $ SC.terms (updates sr))
-            where
-              g v = case ( toList (Names.refTermsNamed slurpCheckNames n),
-                           toList (Names.refTermsNamed fileNames n)
-                         ) of
-                ([old], [new]) -> (n, (old, new))
-                _ ->
-                  error $
-                    "Expected unique matches for "
-                      ++ Var.nameStr v
-                      ++ " but got: "
-                      ++ show otherwise
-                where
-                  n = Name.unsafeFromVar v
+          -- termEdits :: Map Name (Reference, Reference)
+          -- termEdits = Map.fromList $ map g (toList $ SC.terms (updates sr))
+          --   where
+          --     g v = case ( toList (Names.refTermsNamed slurpCheckNames n),
+          --                  toList (Names.refTermsNamed fileNames n)
+          --                ) of
+          --       ([old], [new]) -> (n, (old, new))
+          --       _ ->
+          --         error $
+          --           "Expected unique matches for "
+          --             ++ Var.nameStr v
+          --             ++ " but got: "
+          --             ++ show otherwise
+          --       where
+          --         n = Name.unsafeFromVar v
           termDeprecations :: [(Name, Referent)]
           termDeprecations =
             [ (n, r)
@@ -1920,19 +1922,28 @@ handleUpdate input maybePatchPath hqs = do
           updatePatches :: Branch0 m -> m (Branch0 m)
           updatePatches = Branch.modifyPatches seg updatePatch
 
-      when (Slurp.isNonempty sr) $ do
-        -- take a look at the `updates` from the SlurpResult
-        -- and make a patch diff to record a replacement from the old to new references
-        stepManyAtMNoSync Branch.CompressHistory
-          [ ( Path.unabsolute currentPath',
-              pure . doSlurpUpdates typeEdits termEdits termDeprecations
-            ),
-            ( Path.unabsolute currentPath',
-              pure . doSlurpAdds addsAndUpdates uf
-            ),
-            (Path.unabsolute p, updatePatches)
-          ]
-        eval . AddDefsToCodebase . filterBySlurpResult sr $ uf
+      case Slurp.slurpOp Update (undefined hqs) sr of
+        Left errs -> undefined
+        Right (adds, updates) ->
+          -- when nonEmpty
+          -- doSlurpUpdates updates
+          -- doSlurpAdds adds
+          undefined adds updates
+
+          -- take a look at the `updates` from the SlurpResult
+          -- and make a patch diff to record a replacement from the old to new references
+          -- stepManyAtMNoSync Branch.CompressHistory
+          --   [ ( Path.unabsolute currentPath',
+          --       pure . doSlurpUpdates typeEdits termEdits termDeprecations
+          --     ),
+          --     ( Path.unabsolute currentPath',
+          --       pure . doSlurpAdds addsAndUpdates uf
+          --     ),
+          --     (Path.unabsolute p, updatePatches)
+          --   ]
+          -- eval . AddDefsToCodebase . filterBySlurpResult sr $ uf
+
+      -- when (Slurp.isNonempty sr) $ do
       ppe <- prettyPrintEnvDecl =<< displayNames uf
       respond $ SlurpOutput input (PPE.suffixifiedPPE ppe) sr
       -- propagatePatch prints TodoOutput
@@ -2784,7 +2795,7 @@ toSlurpResult ::
   Names ->
   SlurpResult v
 toSlurpResult curPath uf existingNames = pTraceShowId $
-  Slurp.subtractComponent (conflicts <> ctorCollisions) $
+  OldSlurp.subtractComponent (conflicts <> ctorCollisions) $
     SlurpResult
       uf
       mempty
@@ -2890,13 +2901,13 @@ toSlurpResult curPath uf existingNames = pTraceShowId $
       R.Relation Name Referent ->
       R.Relation Name Referent ->
       Set v ->
-      Map v Slurp.Aliases
+      Map v OldSlurp.Aliases
     buildAliases existingNames namesFromFile duplicates =
       Map.fromList
         [ ( var n,
             if null aliasesOfOld
-              then Slurp.AddAliases aliasesOfNew
-              else Slurp.UpdateAliases aliasesOfOld aliasesOfNew
+              then OldSlurp.AddAliases aliasesOfNew
+              else OldSlurp.UpdateAliases aliasesOfOld aliasesOfNew
           )
           | (n, r@Referent.Ref {}) <- R.toList namesFromFile,
             -- All the refs whose names include `n`, and are not `r`
@@ -2911,14 +2922,14 @@ toSlurpResult curPath uf existingNames = pTraceShowId $
             Set.notMember (var n) duplicates
         ]
 
-    termAliases :: Map v Slurp.Aliases
+    termAliases :: Map v OldSlurp.Aliases
     termAliases =
       buildAliases
         (Names.terms existingNames)
         (Names.terms fileNames)
         (SC.terms dups)
 
-    typeAliases :: Map v Slurp.Aliases
+    typeAliases :: Map v OldSlurp.Aliases
     typeAliases =
       buildAliases
         (R.mapRan Referent.Ref $ Names.types existingNames)
@@ -3070,7 +3081,7 @@ doSlurpAdds slurp uf = Branch.batchUpdates (typeActions <> termActions)
     typeActions = map doType . toList $ SC.types slurp
     termActions =
       map doTerm . toList $
-        SC.terms slurp <> Slurp.constructorsFor (SC.types slurp) uf
+        SC.terms slurp <> OldSlurp.constructorsFor (SC.types slurp) uf
     names = UF.typecheckedToNames uf
     tests = Set.fromList $ fst <$> UF.watchesOfKind WK.TestWatch (UF.discardTypes uf)
     (isTestType, isTestValue) = isTest

unison-cli/src/Unison/Codebase/Editor/Slurp.hs

@@ -2,32 +2,54 @@
 
 module Unison.Codebase.Editor.Slurp where
 
+import qualified Data.Foldable as Foldable
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Unison.ABT as ABT
+import qualified Unison.DataDeclaration as DD
 import Unison.Hash (Hash)
-import qualified Unison.HashQualified' as HQ'
+import qualified Unison.LabeledDependency as LD
 import Unison.Name (Name)
+import qualified Unison.Name as Name
 import Unison.Names (Names)
+import qualified Unison.Names as Names
 import Unison.Parser.Ann (Ann)
 import Unison.Prelude
+import qualified Unison.Reference as Ref
+import Unison.Referent (Referent)
+import qualified Unison.Referent as Referent
 import qualified Unison.UnisonFile as UF
 import qualified Unison.UnisonFile.Names as UF
+import qualified Unison.UnisonFile.Type as UF
 import Unison.Var (Var)
 
-data SlurpStatus = New | Updated | Duplicate | Alias
+data SlurpStatus = New | Updated | Duplicate
 
 data SlurpOp = Add | Update
 
-data SlurpErr
+data TypeOrTermVar v = TypeVar v | TermVar v
+
+untypedVar :: TypeOrTermVar v -> v
+untypedVar = \case
+  TypeVar v -> v
+  TermVar v -> v
+
+data SlurpPrintout v = SlurpPrintout
+  { notOk :: Map v (SlurpErr v),
+    ok :: Map v SlurpStatus
+  }
+
+data SlurpErr v
   = TermCtorCollision
   | CtorTermCollision
-  | RequiresUpdate
+  | RequiresUpdateOf v
 
 data SlurpComponent v = SlurpComponent {types :: Set v, terms :: Set v}
   deriving (Eq, Ord, Show)
 
-data DefinitionNotes v = DefinitionNotes
-  { status :: SlurpStatus,
-    errs :: Set SlurpErr
-  }
+data DefinitionNotes v
+  = DefStatus SlurpStatus
+  | DefErr (Set (SlurpErr v))
 
 data ComponentNotes v = ComponentNotes
   { deps :: Set ComponentHash,
@@ -46,6 +68,9 @@ data Components v = Components
     typeComponents :: Map Hash (Set v)
   }
 
+toSlurpPrintout :: SlurpResult v -> SlurpPrintout v
+toSlurpPrintout = undefined
+
 collectComponents :: UF.TypecheckedUnisonFile v Ann -> Components v
 collectComponents _uf = Components {termComponents, typeComponents}
   where
@@ -60,11 +85,112 @@ analyzeTypecheckedUnisonFile ::
   Var v =>
   UF.TypecheckedUnisonFile v Ann ->
   Names ->
+  Maybe (Set v) ->
   SlurpResult v
-analyzeTypecheckedUnisonFile uf _codebaseNames = undefined
+analyzeTypecheckedUnisonFile uf unalteredCodebaseNames _defsToConsider =
+  SlurpResult _varToComponents _componentNotes'
   where
     fileNames :: Names
     fileNames = UF.typecheckedToNames uf
+    componentMapping :: Map ComponentHash (Set v)
+    componentMapping = UF.componentMap uf
+    -- codebaseNames with deprecated constructors removed.
 
-slurpOp :: SlurpOp -> Maybe (Set v) -> SlurpResult v -> Either (Set SlurpErr) (SlurpComponent v)
+    allDefinitions :: Set v
+    allDefinitions = fold componentMapping
+
+    componentNotes' :: Map ComponentHash (Map v (DefinitionNotes v))
+    componentNotes' = undefined
+
+    definitionStatus :: TypeOrTermVar v -> DefinitionNotes v
+    definitionStatus tv =
+      let v = untypedVar tv
+          existingTypesAtName = Names.typesNamed codebaseNames (Name.unsafeFromVar v)
+          existingTermsAtName = Names.termsNamed codebaseNames (Name.unsafeFromVar v)
+          existingTermsMatchingReference = Names.termsNamed codebaseNames (Name.unsafeFromVar v)
+          varRef = varReferences Map.! v
+       in case tv of
+            TermVar {} ->
+              case Set.toList existingTermsAtName of
+                [] -> DefStatus New
+                [r] | LD.referent r == varRef -> DefStatus Duplicate
+                [Referent.Con {}] | LD.ConReference {} <- varRef -> DefErr TermCtorCollision
+                [Referent.Ref {}] | LD.ConReference {} <- varRef -> DefErr CtorTermCollision
+                -- This allows us to resolve conflicts with an update.
+                _ -> DefStatus Updated
+            -- [r] -> DefStatus Updated
+            -- _ -> DefStatus Conflicted
+            TypeVar {} -> _
+    varReferences :: Map v LD.LabeledDependency
+    varReferences = UF.referencesMap uf
+
+    -- Get the set of all DIRECT definitions in the file which a definition depends on.
+    varDeps :: v -> Set v
+    varDeps v = do
+      let varComponentHash = varToComponentHash Map.! v
+          componentPeers = componentMapping Map.! varComponentHash
+          directDeps = case UF.hashTermsId uf Map.!? v of
+            Nothing -> mempty
+            Just (_, _, term, _) -> ABT.freeVars term
+       in Set.delete v (componentPeers <> directDeps)
+
+    transitiveVarDeps :: Set v -> v -> Set v
+    transitiveVarDeps resolved v =
+      let directDeps = varDeps v
+       in Foldable.foldl' transitiveVarDeps (Set.insert v resolved) directDeps
+      where
+        go resolved nextV =
+          if Set.member nextV resolved
+            then resolved
+            else resolved <> transitiveVarDeps resolved nextV
+
+    varToComponentHash :: Map v ComponentHash
+    varToComponentHash = Map.fromList $ do
+      -- List monad
+      (hash, vars) <- Map.toList componentMapping
+      v <- Set.toList vars
+      pure (v, hash)
+
+    codebaseNames :: Names
+    codebaseNames =
+      -- TODO: make faster
+      -- TODO: how does defsToConsider affect deprecations?
+      Names.filter (`Set.notMember` deprecatedConstructors) unalteredCodebaseNames
+    constructorNamesInFile :: Set Name
+    constructorNamesInFile =
+      Map.elems (UF.dataDeclarationsId' uf)
+        <> (fmap . fmap) DD.toDataDecl (Map.elems (UF.effectDeclarationsId' uf))
+          & fmap snd
+          & concatMap
+            ( \decl ->
+                DD.constructors' decl <&> \(_ann, v, _typ) ->
+                  Name.unsafeFromVar v
+            )
+          & Set.fromList
+
+    deprecatedConstructors :: Set Name
+    deprecatedConstructors =
+      let allRefIds =
+            fmap fst (Map.elems (UF.dataDeclarationsId' uf))
+              <> fmap fst (Map.elems (UF.effectDeclarationsId' uf))
+          existingConstructorsFromEditedTypes = Set.fromList $ do
+            -- List Monad
+            refId <- allRefIds
+            (name, _ref) <- Names.constructorsForType (Ref.DerivedId refId) unalteredCodebaseNames
+            pure name
+       in -- Compute any constructors which were deleted
+          existingConstructorsFromEditedTypes `Set.difference` constructorNamesInFile
+
+-- [ (n, r)
+--   | (oldTypeRef, _) <- Map.elems typeEdits,
+--     (n, r) <- Names.constructorsForType oldTypeRef codebaseNames
+-- ]
+
+slurpOp ::
+  SlurpOp ->
+  SlurpResult v ->
+  Either
+    (Set (SlurpErr v))
+    -- adds,           updates
+    (SlurpComponent v, SlurpComponent v)
 slurpOp = undefined