diff --git a/parser-typechecker/src/Unison/Codebase/Branch2.hs b/parser-typechecker/src/Unison/Codebase/Branch2.hs index 000aaee52..de03edffa 100644 --- a/parser-typechecker/src/Unison/Codebase/Branch2.hs +++ b/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 diff --git a/parser-typechecker/src/Unison/Codebase/Causal2.hs b/parser-typechecker/src/Unison/Codebase/Causal2.hs index d8c42add9..528ea0b82 100644 --- a/parser-typechecker/src/Unison/Codebase/Causal2.hs +++ b/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 diff --git a/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs b/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs index 0546ed0fb..a16a74373 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs +++ b/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 diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase2.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase2.hs index 26d06369c..0b03c5d6b 100644 --- a/parser-typechecker/src/Unison/Codebase/FileCodebase2.hs +++ b/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) "" diff --git a/parser-typechecker/src/Unison/Util/List.hs b/parser-typechecker/src/Unison/Util/List.hs index 1481df914..fdc9d8550 100644 --- a/parser-typechecker/src/Unison/Util/List.hs +++ b/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]