fix file delete bug and lens bug

parser-typechecker/src/Unison/Codebase/Branch2.hs

@@ -74,6 +74,69 @@ import qualified Unison.Util.List              as List
 newtype Branch m = Branch { _history :: Causal m Raw (Branch0 m) }
   deriving (Eq, Ord)
 
+type Hash = Causal.RawHash Raw
+type EditHash = Hash.Hash
+
+data Branch0 m = Branch0
+  { _terms :: Relation NameSegment Referent
+  , _types :: Relation NameSegment Reference
+  , _children:: Map NameSegment (Hash, Branch m) --todo: can we get rid of this hash
+  , _edits :: Map NameSegment (EditHash, m Patch)
+  , toNamesSeg :: Names.NamesSeg
+  , toNames0 :: Names.Names0
+  , deepReferents :: Set Referent
+  , deepTypeReferences :: Set Reference
+  }
+
+-- The raw Branch
+data Raw = Raw
+  { _termsR :: Relation NameSegment Referent
+  , _typesR :: Relation NameSegment Reference
+  , _childrenR :: Map NameSegment Hash
+  , _editsR :: Map NameSegment EditHash
+  }
+
+makeLenses ''Branch
+makeLensesFor [("_edits", "edits")] ''Branch0
+makeLenses ''Raw
+
+terms :: Lens' (Branch0 m) (Relation NameSegment Referent)
+terms = lens _terms (\Branch0{..} x -> branch0 x _types _children _edits)
+types :: Lens' (Branch0 m) (Relation NameSegment Reference)
+types = lens _types (\Branch0{..} x -> branch0 _terms x _children _edits)
+children :: Lens' (Branch0 m) (Map NameSegment (Hash, Branch m))
+children = lens _children (\Branch0{..} x -> branch0 _terms _types x _edits)
+
+-- creates a Branch0 from the primary fields and derives the others.
+branch0 :: Relation NameSegment Referent
+        -> Relation NameSegment Reference
+        -> Map NameSegment (Hash, Branch m)
+        -> Map NameSegment (EditHash, m Patch)
+        -> Branch0 m
+branch0 terms types children edits =
+  Branch0 terms types children edits namesSeg names0 deepRefts deepTypeRefs
+  where
+  namesSeg = toNamesSegImpl terms types
+  names0 = foldMap toNames0Impl (Map.toList (fmap snd children))
+            <> Names (R.mapDom nameSegToName terms)
+                     (R.mapDom nameSegToName types)
+  deepRefts = foldMap deepReferents childrenBranch0
+  deepTypeRefs = foldMap deepTypeReferences childrenBranch0
+  childrenBranch0 = fmap (head . snd) . Foldable.toList $ children
+
+  toNames0Impl :: (NameSegment, Branch m) -> Names0
+  toNames0Impl (nameSegToName -> n, head -> b0) =
+    Names.prefix0 n (toNames0 b0)
+  toNamesSegImpl :: Relation NameSegment Referent
+                 -> Relation NameSegment Reference
+                 -> Names' (HQ.HashQualified' NameSegment)
+  toNamesSegImpl terms types = Names terms' types' where
+    terms' = R.map (\(n, r) -> (Names.hqTermName names n r, r)) terms
+    types' = R.map (\(n, r) -> (Names.hqTypeName names n r, r)) types
+    names :: Names' NameSegment
+    names = Names terms types
+  nameSegToName = Name . NameSegment.toText
+
 head :: Branch m -> Branch0 m
 head (Branch c) = Causal.head c
 
@@ -118,22 +181,8 @@ unionWithM f m1 m2 = Monad.foldM go m1 $ Map.toList m2 where
     Just a1 -> do a <- f a1 a2; pure $ Map.insert k a m1
     Nothing -> pure $ Map.insert k a2 m1
 
-type Hash = Causal.RawHash Raw
-type EditHash = Hash.Hash
-
 pattern Hash h = Causal.RawHash h
 
-data Branch0 m = Branch0
-  { _terms :: Relation NameSegment Referent
-  , _types :: Relation NameSegment Reference
-  , _children :: Map NameSegment (Hash, Branch m) --todo: can we get rid of this hash
-  , _edits :: Map NameSegment (EditHash, m Patch)
-  , toNamesSeg :: Names.NamesSeg
-  , toNames0 :: Names.Names0
-  , deepReferents :: Set Referent
-  , deepTypeReferences :: Set Reference
-  }
-
 printDebugPaths :: Branch m -> String
 printDebugPaths = unlines . map show . Set.toList . debugPaths
 
@@ -145,18 +194,6 @@ debugPaths b = go Path.empty b where
 data Target = TargetType | TargetTerm | TargetBranch
   deriving (Eq, Ord, Show)
 
--- The raw Branch
-data Raw = Raw
-  { _termsR :: Relation NameSegment Referent
-  , _typesR :: Relation NameSegment Reference
-  , _childrenR :: Map NameSegment Hash
-  , _editsR :: Map NameSegment EditHash
-  }
-
-makeLenses ''Raw
-makeLenses ''Branch0
-makeLenses ''Branch
-
 instance Eq (Branch0 m) where
   a == b = view terms a == view terms b
     && view types a == view types b
@@ -180,13 +217,6 @@ toNames b = Names hqTerms hqTypes where
   hqTypes = R.fromList [ (Names.hqTypeName names0 n r, r)
                        | (n, r) <- R.toList (Names.types names0) ]
 
---toNames0' :: Branch0 m -> Names0
---toNames0' b = fold go mempty b where
---  go names name (TermEntry r) = names <> Names.fromTerms [(name, r)]
---  go names name (TypeEntry r) = names <> Names.fromTypes [(name, r)]
-
--- asSearchResults :: Branch m -> [SearchResult]
-
 -- Question: How does Deserialize throw a not-found error?
 -- Question: What is the previous question?
 read
@@ -201,37 +231,14 @@ read deserializeRaw deserializeEdits h = Branch <$> Causal.read d h
   fromRaw :: Raw -> m (Branch0 m)
   fromRaw Raw {..} = do
     children <- traverse go _childrenR
-    let namesSeg = toNamesSegImpl _termsR _typesR
-        childrenBranch0 = fmap (head . snd) . Foldable.toList $ children
-        deepReferents' = foldMap deepReferents childrenBranch0
-        names0 = foldMap toNames0Impl (Map.toList (fmap snd children))
-             <> Names (R.mapDom nameSegToName _termsR)
-                      (R.mapDom nameSegToName _typesR)
-        deepTypeReferences' = foldMap deepTypeReferences childrenBranch0
     edits <- for _editsR $ \hash -> (hash,) . pure <$> deserializeEdits hash
-    pure $ Branch0 _termsR _typesR children edits
-                    namesSeg
-                    names0
-                    deepReferents'
-                    deepTypeReferences'
+    pure $ branch0 _termsR _typesR children edits
   go h = (h, ) <$> read deserializeRaw deserializeEdits h
   d :: Causal.Deserialize m Raw (Branch0 m)
   d h = deserializeRaw h >>= \case
     RawOne raw      -> RawOne <$> fromRaw raw
     RawCons  raw h  -> flip RawCons h <$> fromRaw raw
     RawMerge raw hs -> flip RawMerge hs <$> fromRaw raw
-  toNames0Impl :: (NameSegment, Branch m) -> Names0
-  toNames0Impl (nameSegToName -> n, head -> b0) =
-    Names.prefix0 n (toNames0 b0)
-  toNamesSegImpl :: Relation NameSegment Referent
-                 -> Relation NameSegment Reference
-                 -> Names' (HQ.HashQualified' NameSegment)
-  toNamesSegImpl terms types = Names terms' types' where
-    terms' = R.map (\(n, r) -> (Names.hqTermName names n r, r)) terms
-    types' = R.map (\(n, r) -> (Names.hqTypeName names n r, r)) types
-    names :: Names' NameSegment
-    names = Names terms types
-  nameSegToName = Name . NameSegment.toText
 
 
 -- serialize a `Branch m` indexed by the hash of its corresponding Raw

parser-typechecker/src/Unison/Codebase/Causal2.hs

@@ -45,7 +45,10 @@ import           Util                           ( bind2 )
 -}
 
 newtype RawHash a = RawHash { unRawHash :: Hash }
-  deriving (Eq, Ord, Show)
+  deriving (Eq, Ord)
+
+instance Show (RawHash a) where
+  show = show . unRawHash
 
 -- h is the type of the pure data structure that will be hashed and used as
 -- an index; e.g. h = Branch00, e = Branch0 m

parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs

@@ -169,35 +169,10 @@ loop = do
       getHQTerms :: Path.HQSplit' -> Set Referent
       getHQTerms p = BranchUtil.getTerm (resolvePath' p) root0
       getHQ'Terms = getHQTerms . fmap HQ'.toHQ
-      -- These don't quite make sense, because a HQ'Split' includes a name.
-      -- A regular HQSplit' may be missing a name, and then it .. well
-      -- even then, a NameSegment probably isn't going to cut it.
-      -- getNamedHQTypes :: Path.HQ'Split' -> Set (NameSegment, Reference)
-      -- getNamedHQTypes p = BranchUtil.getNamedType (resolvePath' p) root0
-      -- getNamedHQTerms :: Path.HQ'Split' -> Set (NameSegment, Referent)
-      -- getNamedHQTerms p = BranchUtil.getNamedTerm (resolvePath' p) root0
       getTypes :: Path.Split' -> Set Reference
       getTypes = getHQTypes . fmap HQ.NameOnly
       getTerms :: Path.Split' -> Set Referent
       getTerms = getHQTerms . fmap HQ.NameOnly
-
-      -- unsnocPath' :: Path' -> (Absolute, NameSegment)
-      -- unsnocPath' = fromJust
-      --           . fmap (first Absolute)
-      --           . (\(Absolute p) -> Path.unsnoc p)
-      --           . Path.toAbsolutePath currentPath'
-
-      -- todo: don't need to use this version, because the NamesSeg and deepReferentes are built into the Branch0 now.
-      -- loadHqSrc ::
-      --   Path.HQSplit' -> _ (Branch m, NamesSeg, Names0, Absolute, HQSegment)
-      -- loadHqSrc hq = do
-      --   let (p, seg) = toAbsoluteSplit hq
-      --   b <- getAt p
-      --   pure ( b
-      --        , Branch.toNamesSeg (Branch.head b)
-      --        , Branch.toNames0 (Branch.head b)
-      --        , p, seg)
-
   let -- names' = Branch.toNames (Branch.head currentBranch')
       names0' = Branch.toNames0 root0
   e           <- eval Input
@@ -441,7 +416,8 @@ loop = do
           .   ListOfDefinitions names0' True
       -- ls with arguments
       SearchByNameI ("-l" : (fmap HQ.fromString -> qs)) -> do
-        let results = searchBranchScored currentBranch' fuzzyNameDistance qs
+        let results = uniqueBy SR.toReferent
+                    $ searchBranchScored currentBranch' fuzzyNameDistance qs
         numberedArgs .= fmap searchResultToHQString results
         eval (LoadSearchResults results)
           >>= respond

parser-typechecker/src/Unison/Codebase/FileCodebase2.hs

@@ -214,7 +214,7 @@ updateCausalHead :: MonadIO m => FilePath -> Causal n h e -> m ()
 updateCausalHead headDir c = do
   let (RawHash h) = Causal.currentHash c
   -- delete existing heads
-  liftIO $ listDirectory headDir >>= traverse_ removeFile
+  liftIO $ listDirectory headDir >>= traverse_ (removeFile . (headDir </>))
   -- write new head
   liftIO $ writeFile (headDir </> Hash.base58s h) ""
 

parser-typechecker/src/Unison/Util/List.hs

@@ -18,7 +18,7 @@ groupBy f vs = reverse <$> foldl' step Map.empty vs
 
 -- returns the subset of `f a` which maps to unique `b`s.
 -- prefers earlier copies, if many `a` map to some `b`.
-uniqueBy, nubOrdBy :: (Foldable f, Ord b) => (a -> b) -> f a -> [a]
+uniqueBy, nubOrdOn :: (Foldable f, Ord b) => (a -> b) -> f a -> [a]
 uniqueBy f as = wrangle' (toList as) Set.empty where
   wrangle' [] _ = []
   wrangle' (a:as) seen =
@@ -26,7 +26,7 @@ uniqueBy f as = wrangle' (toList as) Set.empty where
     then wrangle' as seen
     else a : wrangle' as (Set.insert b seen)
     where b = f a
-nubOrdBy = uniqueBy
+nubOrdOn = uniqueBy
 
 -- prefers later copies
 uniqueBy' :: (Foldable f, Ord b) => (a -> b) -> f a -> [a]