mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-20 06:47:15 +03:00
implement Actions2.searchBranch'
This commit is contained in:
parent
14f0090c13
commit
4696d0a490
1
.gitignore
vendored
1
.gitignore
vendored
@ -23,6 +23,7 @@ target
|
||||
htags
|
||||
scala-tags
|
||||
haskell-tags
|
||||
out
|
||||
|
||||
# Stack
|
||||
.stack-work
|
||||
|
@ -6,6 +6,7 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
module Unison.Codebase.Branch2 where
|
||||
|
||||
@ -14,12 +15,16 @@ module Unison.Codebase.Branch2 where
|
||||
import Prelude hiding (head,read,subtract)
|
||||
|
||||
import Control.Lens hiding ( children )
|
||||
import qualified Control.Monad as Monad
|
||||
--import Control.Monad.Extra ( whenM )
|
||||
-- import Data.GUID (genText)
|
||||
--import Data.List ( intercalate )
|
||||
import qualified Data.Map as Map
|
||||
import Data.Map ( Map )
|
||||
import qualified Data.Set as Set
|
||||
import Data.Set ( Set )
|
||||
import Data.Text ( Text )
|
||||
import Data.Tuple (swap)
|
||||
--import qualified Data.Text as Text
|
||||
import Data.Foldable ( for_ )
|
||||
import qualified Unison.Codebase.Causal2 as Causal
|
||||
@ -28,6 +33,8 @@ import Unison.Codebase.Causal2 ( Causal
|
||||
, pattern RawCons
|
||||
, pattern RawMerge
|
||||
)
|
||||
import Unison.Codebase.SearchResult (SearchResult)
|
||||
import qualified Unison.Codebase.SearchResult as SR
|
||||
import Unison.Codebase.TermEdit ( TermEdit )
|
||||
import Unison.Codebase.TypeEdit ( TypeEdit )
|
||||
import Unison.Codebase.Path ( NameSegment
|
||||
@ -37,17 +44,30 @@ import qualified Unison.Codebase.Path as Path
|
||||
--import Unison.Hash ( Hash )
|
||||
import Unison.Hashable ( Hashable )
|
||||
import qualified Unison.Hashable as H
|
||||
import qualified Unison.HashQualified as HQ
|
||||
|
||||
import Unison.Name ( Name )
|
||||
import Unison.Names2 ( Names0 )
|
||||
import Unison.Reference ( Reference )
|
||||
import Unison.Referent ( Referent )
|
||||
import Unison.Referent ( Referent(Con,Ref) )
|
||||
import qualified Unison.Util.Relation as R
|
||||
import Unison.Util.Relation ( Relation )
|
||||
import qualified Unison.Util.List as List
|
||||
|
||||
|
||||
-- type EditGuid = Text
|
||||
|
||||
newtype Branch m = Branch { _history :: Causal m Raw (Branch0 m) }
|
||||
deriving (Eq, Ord)
|
||||
|
||||
data BranchEntry = TermEntry Referent | TypeEntry Reference deriving (Eq,Ord,Show)
|
||||
|
||||
branchEntryReference :: BranchEntry -> Reference
|
||||
branchEntryReference = \case
|
||||
TermEntry (Con r _i) -> r
|
||||
TermEntry (Ref r) -> r
|
||||
TypeEntry r -> r
|
||||
|
||||
head :: Branch m -> Branch0 m
|
||||
head (Branch c) = Causal.head c
|
||||
|
||||
@ -59,6 +79,7 @@ type Hash = Causal.RawHash Raw
|
||||
data Branch0 m = Branch0
|
||||
{ _terms :: Relation NameSegment Referent
|
||||
, _types :: Relation NameSegment Reference
|
||||
-- , _edits :: Relation NameSegment Edits
|
||||
-- Q: How will we handle merges and conflicts for `children`?
|
||||
-- Should this be a relation?
|
||||
-- What is the UX to resolve conflicts?
|
||||
@ -91,6 +112,24 @@ instance Eq (Branch0 m) where
|
||||
|
||||
data ForkFailure = SrcNotFound | DestExists
|
||||
|
||||
fold :: Monad m => (a -> Name -> BranchEntry -> a) -> a -> Branch m -> m a
|
||||
fold f = foldM (\a n b -> pure (f a n b))
|
||||
|
||||
foldM :: forall m a. Monad m
|
||||
=> (a -> Name -> BranchEntry -> m a) -> a -> Branch m -> m a
|
||||
foldM f a (head -> b) = go Path.empty b a where
|
||||
doTerm p a (seg, r) = f a (Path.toName (p `Path.snoc` seg)) (TermEntry r)
|
||||
doType p a (seg, r) = f a (Path.toName (p `Path.snoc` seg)) (TypeEntry r)
|
||||
doChild p a (seg, (_hash, head -> b)) = go (p `Path.snoc` seg) b a
|
||||
go :: Path -> Branch0 m -> a -> m a
|
||||
go p b a = do
|
||||
a1 <- Monad.foldM (doTerm p) a (R.toList . view terms $ b)
|
||||
a2 <- Monad.foldM (doType p) a1 (R.toList . view types $ b)
|
||||
Monad.foldM (doChild p) a2 (Map.toList . view children $ b)
|
||||
|
||||
allEntries :: Monad m => Branch m -> m [(Name, BranchEntry)]
|
||||
allEntries = fmap reverse . fold (\l n e -> (n, e) : l) []
|
||||
|
||||
-- Question: How does Deserialize throw a not-found error?
|
||||
-- Question: What is the previous question?
|
||||
read
|
||||
|
@ -42,7 +42,7 @@ import Data.Set ( Set )
|
||||
import qualified Unison.ABT as ABT
|
||||
import Unison.Codebase.Branch2 ( Branch
|
||||
, Branch0
|
||||
, Edits
|
||||
, Edits, BranchEntry
|
||||
)
|
||||
import qualified Unison.Codebase.Branch2 as Branch
|
||||
import Unison.Codebase.Editor2 ( Command(..)
|
||||
@ -84,6 +84,8 @@ import qualified Unison.Util.Find as Find
|
||||
import Unison.Util.Free ( Free )
|
||||
import qualified Unison.Util.Free as Free
|
||||
import qualified Unison.Util.Relation as Relation
|
||||
import qualified Unison.Util.Relation as R
|
||||
import Unison.Util.Relation ( Relation )
|
||||
import Unison.Var ( Var )
|
||||
|
||||
type F m i v = Free (Command m i v)
|
||||
@ -414,18 +416,37 @@ searchBranch (Branch.head -> b) queries = \case
|
||||
[] -> Nothing
|
||||
(m, _) : _ -> Just m
|
||||
|
||||
collectHashQualified :: Monad m => Branch m -> m (Set HashQualified)
|
||||
collectHashQualified (Branch.head -> b) = search mempty b where
|
||||
search :: Path -> Branch0 m -> m (Set HashQualified)
|
||||
search path b = error "todo"
|
||||
|
||||
|
||||
searchBranch' :: forall m score. (Ord score)
|
||||
=> Branch0 m
|
||||
-> (Name -> Name -> Maybe score)
|
||||
-> [HashQualified]
|
||||
-> m [SearchResult]
|
||||
searchBranch' = error "todo"
|
||||
where
|
||||
wrangle :: [(Name, BranchEntry)] -> [SearchResult]
|
||||
wrangle entries = go <$> entries where
|
||||
go (n, e) = case e of
|
||||
Branch.TypeEntry r ->
|
||||
SR.typeResult (hq e n) r (Set.map (hq e) (Relation.lookupRan e typeR))
|
||||
Branch.TermEntry r ->
|
||||
SR.termResult (hq e n) r (Set.map (hq e) (Relation.lookupRan e termR))
|
||||
-- basically splitting the names up into separate type/term namespaces,
|
||||
-- so we can tell if the names are conflicted and need to be hash-qualified
|
||||
typeR, termR :: Relation Name BranchEntry
|
||||
typeR = Relation.fromList [ (n,e) | (n, e@Branch.TypeEntry{}) <- entries ]
|
||||
termR = Relation.fromList [ (n,e) | (n, e@Branch.TermEntry{}) <- entries ]
|
||||
isQualifiedType, isQualifiedTerm :: Name -> Bool
|
||||
isQualifiedType n = Relation.manyDom n typeR
|
||||
isQualifiedTerm n = Relation.manyDom n termR
|
||||
hq :: BranchEntry -> Name -> HQ.HashQualified
|
||||
hq e n = case e of
|
||||
Branch.TypeEntry r -> if isQualifiedType n
|
||||
then HQ.take 3 $ HQ.fromNamedReference n r else HQ.fromName n
|
||||
Branch.TermEntry r -> if isQualifiedTerm n
|
||||
then HQ.take 3 $ HQ.fromNamedReferent n r else HQ.fromName n
|
||||
hashLength = 3
|
||||
|
||||
|
||||
|
||||
|
||||
-- withBranch :: BranchName -> (Branch -> Action m i v ()) -> Action m i v ()
|
||||
|
@ -53,6 +53,9 @@ asDirectory p = case toList p of
|
||||
fromName :: Name -> Path
|
||||
fromName = fromList . fmap NameSegment . Text.splitOn "." . Name.toText
|
||||
|
||||
toName :: Path -> Name
|
||||
toName = Name.unsafeFromText . asIdentifier
|
||||
|
||||
-- Returns the nearest common ancestor, along with the
|
||||
-- two inputs relativized to that ancestor.
|
||||
relativeToAncestor :: Path -> Path -> (Path, Path, Path)
|
||||
|
@ -12,8 +12,9 @@ multimap kvs =
|
||||
where
|
||||
step m (k,v) = Map.insertWith (++) k [v] m
|
||||
|
||||
-- prefers earlier copies
|
||||
uniqueBy :: (Foldable f, Ord b) => (a -> b) -> f a -> [a]
|
||||
-- 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 f as = wrangle' (toList as) Set.empty where
|
||||
wrangle' [] _ = []
|
||||
wrangle' (a:as) seen =
|
||||
@ -21,6 +22,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
|
||||
|
||||
-- prefers later copies
|
||||
uniqueBy' :: (Foldable f, Ord b) => (a -> b) -> f a -> [a]
|
||||
|
@ -26,7 +26,7 @@ import qualified Data.Map as Map
|
||||
--
|
||||
-- 3. If you subtract, take care when handling the set of values.
|
||||
--
|
||||
-- As a multi-map, each key is asscoated with a Set of values v.
|
||||
-- As a multi-map, each key is associated with a Set of values v.
|
||||
--
|
||||
-- We do not allow the associations with the 'empty' Set.
|
||||
--
|
||||
@ -200,7 +200,12 @@ member x y r = case lookupDom' x r of
|
||||
notMember :: (Ord a, Ord b) => a -> b -> Relation a b -> Bool
|
||||
notMember x y r = not $ member x y r
|
||||
|
||||
-- | True if a value appears more than one time in the relation.
|
||||
manyDom :: Ord a => a -> Relation a b -> Bool
|
||||
manyDom a = (>1) . S.size . lookupDom a
|
||||
|
||||
manyRan :: Ord b => b -> Relation a b -> Bool
|
||||
manyRan b = (>1) . S.size . lookupRan b
|
||||
|
||||
-- | Returns the domain in the relation, as a Set, in its entirety.
|
||||
dom :: Relation a b -> Set a
|
||||
|
Loading…
Reference in New Issue
Block a user