mirror of
https://github.com/unisonweb/unison.git
synced 2024-10-05 06:07:21 +03:00
⅄ trunk → 22-12-14-tidy-up-hashing-package
This commit is contained in:
commit
68bc9e1561
@ -49,6 +49,11 @@ toReference = \case
|
||||
Ref termRef -> termRef
|
||||
Con typeRef _ -> typeRef
|
||||
|
||||
toTermReference :: Referent' termRef typeRef -> Maybe termRef
|
||||
toTermReference = \case
|
||||
Ref termRef -> Just termRef
|
||||
Con _ _ -> Nothing
|
||||
|
||||
type Id = Id' Hash Hash
|
||||
|
||||
data Id' hTm hTp
|
||||
|
@ -94,6 +94,10 @@ mapD2Monotonic f Relation3 {d1, d2, d3} =
|
||||
member :: (Ord a, Ord b, Ord c) => a -> b -> c -> Relation3 a b c -> Bool
|
||||
member a b c = R.member b c . lookupD1 a
|
||||
|
||||
memberD2 :: Ord b => b -> Relation3 a b c -> Bool
|
||||
memberD2 b =
|
||||
Map.member b . d2
|
||||
|
||||
lookupD1 :: (Ord a, Ord b, Ord c) => a -> Relation3 a b c -> Relation b c
|
||||
lookupD1 a = fromMaybe mempty . Map.lookup a . d1
|
||||
|
||||
|
@ -55,6 +55,12 @@ fromList xs = insertAll xs empty
|
||||
filter :: (Ord a, Ord b, Ord c, Ord d) => ((a, b, c, d) -> Bool) -> Relation4 a b c d -> Relation4 a b c d
|
||||
filter f = fromList . Prelude.filter f . toList
|
||||
|
||||
memberD13 :: (Ord a, Ord c) => a -> c -> Relation4 a b c d -> Bool
|
||||
memberD13 a c r4 =
|
||||
case Map.lookup a (d1 r4) of
|
||||
Nothing -> False
|
||||
Just r3 -> R3.memberD2 c r3
|
||||
|
||||
selectD3 ::
|
||||
(Ord a, Ord b, Ord c, Ord d) =>
|
||||
c ->
|
||||
|
@ -8,10 +8,15 @@ flags:
|
||||
optimized:
|
||||
manual: true
|
||||
default: true
|
||||
arraychecks:
|
||||
manual: true
|
||||
default: false
|
||||
|
||||
when:
|
||||
- condition: flag(optimized)
|
||||
ghc-options: -funbox-strict-fields -O2
|
||||
- condition: flag(arraychecks)
|
||||
cpp-options: -DARRAY_CHECK
|
||||
|
||||
dependencies:
|
||||
- ListLike
|
||||
|
@ -3,8 +3,10 @@ module U.Codebase.Branch.Diff
|
||||
NameChanges (..),
|
||||
DefinitionDiffs (..),
|
||||
Diff (..),
|
||||
NameBasedDiff (..),
|
||||
diffBranches,
|
||||
nameChanges,
|
||||
nameBasedDiff,
|
||||
)
|
||||
where
|
||||
|
||||
@ -20,10 +22,13 @@ import qualified U.Codebase.Branch.Type as Branch
|
||||
import qualified U.Codebase.Causal as Causal
|
||||
import U.Codebase.Reference (Reference)
|
||||
import U.Codebase.Referent (Referent)
|
||||
import qualified U.Codebase.Referent as Referent
|
||||
import Unison.Name (Name)
|
||||
import qualified Unison.Name as Name
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.Prelude
|
||||
import Unison.Util.Relation (Relation)
|
||||
import qualified Unison.Util.Relation as Relation
|
||||
|
||||
data Diff a = Diff
|
||||
{ adds :: Set a,
|
||||
@ -83,56 +88,70 @@ data NameChanges = NameChanges
|
||||
}
|
||||
|
||||
instance Semigroup NameChanges where
|
||||
(NameChanges a b c d) <> (NameChanges a2 b2 c2 d2) =
|
||||
NameChanges a b c d <> NameChanges a2 b2 c2 d2 =
|
||||
NameChanges (a <> a2) (b <> b2) (c <> c2) (d <> d2)
|
||||
|
||||
instance Monoid NameChanges where
|
||||
mempty = NameChanges mempty mempty mempty mempty
|
||||
|
||||
-- | A name-based diff for namespaces `N1` and `N2` is (for both terms and types) a relation between references, where
|
||||
-- `a R b` if:
|
||||
--
|
||||
-- 1. `a` has name `n` in `N1`, and `b` has the same name `n` in `N2`
|
||||
-- 2. `a` != `b`
|
||||
data NameBasedDiff = NameBasedDiff
|
||||
{ terms :: Relation Reference Reference,
|
||||
types :: Relation Reference Reference
|
||||
}
|
||||
deriving stock (Generic, Show)
|
||||
|
||||
instance Monoid NameBasedDiff where
|
||||
mempty = NameBasedDiff mempty mempty
|
||||
|
||||
instance Semigroup NameBasedDiff where
|
||||
NameBasedDiff terms0 types0 <> NameBasedDiff terms1 types1 =
|
||||
NameBasedDiff (terms0 <> terms1) (types0 <> types1)
|
||||
|
||||
-- | Diff two Branches, returning a tree containing all of the changes
|
||||
diffBranches :: forall m. Monad m => Branch m -> Branch m -> m TreeDiff
|
||||
diffBranches from to = do
|
||||
let termDiffs = diffMap (terms from) (terms to)
|
||||
let typeDiffs = diffMap (types from) (types to)
|
||||
let termDiffs = diffMap (Branch.terms from) (Branch.terms to)
|
||||
let typeDiffs = diffMap (Branch.types from) (Branch.types to)
|
||||
let defDiff = DefinitionDiffs {termDiffs, typeDiffs}
|
||||
childDiff <- do
|
||||
Align.align (children from) (children to)
|
||||
& wither
|
||||
( \case
|
||||
This ca -> do
|
||||
-- TODO: For the names index we really don't need to know which exact
|
||||
-- names were removed, we just need to delete from the index using a
|
||||
-- prefix query, this would be faster than crawling to get all the deletes.
|
||||
removedChildBranch <- Causal.value ca
|
||||
Just . unTreeDiff <$> diffBranches removedChildBranch Branch.empty
|
||||
That ca -> do
|
||||
newChildBranch <- Causal.value ca
|
||||
Just . unTreeDiff <$> diffBranches Branch.empty newChildBranch
|
||||
These fromC toC
|
||||
| Causal.valueHash fromC == Causal.valueHash toC -> do
|
||||
-- This child didn't change.
|
||||
pure Nothing
|
||||
| otherwise -> do
|
||||
fromChildBranch <- Causal.value fromC
|
||||
toChildBranch <- Causal.value toC
|
||||
diffBranches fromChildBranch toChildBranch >>= \case
|
||||
Lens.Empty -> pure Nothing
|
||||
TreeDiff cfr -> pure . Just $ cfr
|
||||
)
|
||||
& wither \case
|
||||
This ca -> do
|
||||
-- TODO: For the names index we really don't need to know which exact
|
||||
-- names were removed, we just need to delete from the index using a
|
||||
-- prefix query, this would be faster than crawling to get all the deletes.
|
||||
removedChildBranch <- Causal.value ca
|
||||
Just . unTreeDiff <$> diffBranches removedChildBranch Branch.empty
|
||||
That ca -> do
|
||||
newChildBranch <- Causal.value ca
|
||||
Just . unTreeDiff <$> diffBranches Branch.empty newChildBranch
|
||||
These fromC toC
|
||||
| Causal.valueHash fromC == Causal.valueHash toC -> do
|
||||
-- This child didn't change.
|
||||
pure Nothing
|
||||
| otherwise -> do
|
||||
fromChildBranch <- Causal.value fromC
|
||||
toChildBranch <- Causal.value toC
|
||||
diffBranches fromChildBranch toChildBranch >>= \case
|
||||
Lens.Empty -> pure Nothing
|
||||
TreeDiff cfr -> pure . Just $ cfr
|
||||
pure $ TreeDiff (defDiff :< childDiff)
|
||||
where
|
||||
diffMap :: forall ref. Ord ref => Map NameSegment (Map ref (m MdValues)) -> Map NameSegment (Map ref (m MdValues)) -> Map NameSegment (Diff ref)
|
||||
diffMap l r =
|
||||
Align.align l r
|
||||
& fmap
|
||||
( \case
|
||||
(This refs) -> (Diff {removals = Map.keysSet refs, adds = mempty})
|
||||
(That refs) -> (Diff {removals = mempty, adds = Map.keysSet refs})
|
||||
(These l' r') ->
|
||||
let lRefs = Map.keysSet l'
|
||||
rRefs = Map.keysSet r'
|
||||
in (Diff {removals = lRefs `Set.difference` rRefs, adds = rRefs `Set.difference` lRefs})
|
||||
)
|
||||
& fmap \case
|
||||
This refs -> Diff {removals = Map.keysSet refs, adds = mempty}
|
||||
That refs -> Diff {removals = mempty, adds = Map.keysSet refs}
|
||||
These l' r' ->
|
||||
let lRefs = Map.keysSet l'
|
||||
rRefs = Map.keysSet r'
|
||||
in Diff {removals = lRefs `Set.difference` rRefs, adds = rRefs `Set.difference` lRefs}
|
||||
|
||||
-- | Get a summary of all of the name adds and removals from a tree diff.
|
||||
--
|
||||
@ -144,22 +163,19 @@ nameChanges ::
|
||||
NameChanges
|
||||
nameChanges namePrefix (TreeDiff (DefinitionDiffs {termDiffs, typeDiffs} :< children)) =
|
||||
let (termNameAdds, termNameRemovals) =
|
||||
( termDiffs
|
||||
& ifoldMap \ns diff ->
|
||||
let name = appendName ns
|
||||
in (listifyNames name $ adds diff, listifyNames name $ removals diff)
|
||||
)
|
||||
termDiffs
|
||||
& ifoldMap \ns diff ->
|
||||
let name = appendName ns
|
||||
in (listifyNames name $ adds diff, listifyNames name $ removals diff)
|
||||
(typeNameAdds, typeNameRemovals) =
|
||||
( typeDiffs
|
||||
& ifoldMap \ns diff ->
|
||||
let name = appendName ns
|
||||
in (listifyNames name $ adds diff, listifyNames name $ removals diff)
|
||||
)
|
||||
typeDiffs
|
||||
& ifoldMap \ns diff ->
|
||||
let name = appendName ns
|
||||
in (listifyNames name $ adds diff, listifyNames name $ removals diff)
|
||||
childNameChanges =
|
||||
( children
|
||||
& ifoldMap \ns childTree ->
|
||||
nameChanges (Just $ appendName ns) (TreeDiff childTree)
|
||||
)
|
||||
children
|
||||
& ifoldMap \ns childTree ->
|
||||
nameChanges (Just $ appendName ns) (TreeDiff childTree)
|
||||
in NameChanges {termNameAdds, termNameRemovals, typeNameAdds, typeNameRemovals} <> childNameChanges
|
||||
where
|
||||
appendName :: NameSegment -> Name
|
||||
@ -172,3 +188,26 @@ nameChanges namePrefix (TreeDiff (DefinitionDiffs {termDiffs, typeDiffs} :< chil
|
||||
xs
|
||||
& Set.toList
|
||||
& fmap (name,)
|
||||
|
||||
-- | Get a 'NameBasedDiff' from a 'TreeDiff'.
|
||||
nameBasedDiff :: TreeDiff -> NameBasedDiff
|
||||
nameBasedDiff (TreeDiff defnDiffs) =
|
||||
defnDiffs & foldMap \DefinitionDiffs {termDiffs, typeDiffs} ->
|
||||
NameBasedDiff
|
||||
{ terms = foldMap nameBasedTermDiff termDiffs,
|
||||
types = foldMap nameBasedTypeDiff typeDiffs
|
||||
}
|
||||
where
|
||||
nameBasedTermDiff :: Diff Referent -> Relation Reference Reference
|
||||
nameBasedTermDiff Diff {adds, removals} =
|
||||
let termAdds = mapMaybe Referent.toTermReference (Set.toList adds)
|
||||
termRemovals = mapMaybe Referent.toTermReference (Set.toList removals)
|
||||
in ((,) <$> termRemovals <*> termAdds)
|
||||
& filter (\(r0, r1) -> r0 /= r1)
|
||||
& Relation.fromList
|
||||
|
||||
nameBasedTypeDiff :: Diff Reference -> Relation Reference Reference
|
||||
nameBasedTypeDiff Diff {adds, removals} =
|
||||
((,) <$> Set.toList removals <*> Set.toList adds)
|
||||
& filter (\(r0, r1) -> r0 /= r1)
|
||||
& Relation.fromList
|
||||
|
@ -7,7 +7,6 @@ import Unison.Reference (Reference)
|
||||
import qualified Unison.Util.List as List
|
||||
import Unison.Util.Relation (Relation)
|
||||
import qualified Unison.Util.Relation as R
|
||||
import qualified Unison.Util.Relation3 as R3
|
||||
import Unison.Util.Relation4 (Relation4)
|
||||
import qualified Unison.Util.Relation4 as R4
|
||||
import Unison.Util.Star3 (Star3)
|
||||
@ -44,8 +43,8 @@ hasMetadata :: Ord a => a -> Type -> Value -> Star a n -> Bool
|
||||
hasMetadata a t v = Set.member (t, v) . R.lookupDom a . Star3.d3
|
||||
|
||||
hasMetadataWithType' :: Ord a => a -> Type -> R4 a n -> Bool
|
||||
hasMetadataWithType' a t r =
|
||||
fromMaybe False $ Set.member t . R3.d2s <$> (Map.lookup a $ R4.d1 r)
|
||||
hasMetadataWithType' =
|
||||
R4.memberD13
|
||||
|
||||
hasMetadataWithType :: Ord a => a -> Type -> Star a n -> Bool
|
||||
hasMetadataWithType a t = Set.member t . R.lookupDom a . Star3.d2
|
||||
|
@ -97,9 +97,11 @@ watchDirectory dir allow = do
|
||||
if allow file
|
||||
then
|
||||
let handle :: IOException -> IO ()
|
||||
handle e = do
|
||||
liftIO $ putStrLn $ "‼ Got an exception while reading: " <> file
|
||||
liftIO $ print (e :: IOException)
|
||||
handle _e =
|
||||
-- Sometimes we notice a change and try to read a file while it's being written.
|
||||
-- This typically occurs when UCM is writing to the scratch file and can be
|
||||
-- ignored anyways.
|
||||
pure ()
|
||||
go :: IO (Maybe (FilePath, Text))
|
||||
go = liftIO $ do
|
||||
contents <- readUtf8 file
|
||||
|
@ -58,6 +58,8 @@ module Unison.Runtime.ANF
|
||||
ANFM,
|
||||
Branched (.., MatchDataCover),
|
||||
Func (..),
|
||||
SGEqv(..),
|
||||
equivocate,
|
||||
superNormalize,
|
||||
anfTerm,
|
||||
valueTermLinks,
|
||||
@ -66,6 +68,8 @@ module Unison.Runtime.ANF
|
||||
groupLinks,
|
||||
normalLinks,
|
||||
prettyGroup,
|
||||
prettySuperNormal,
|
||||
prettyANF,
|
||||
)
|
||||
where
|
||||
|
||||
@ -600,8 +604,9 @@ data ANormalF v e
|
||||
| AApp (Func v) [v]
|
||||
| AFrc v
|
||||
| AVar v
|
||||
deriving (Show)
|
||||
deriving (Show, Eq)
|
||||
|
||||
|
||||
-- Types representing components that will go into the runtime tag of
|
||||
-- a data type value. RTags correspond to references, while CTags
|
||||
-- correspond to constructors.
|
||||
@ -701,6 +706,109 @@ instance Bifoldable ANormalF where
|
||||
bifoldMap f _ (AFrc v) = f v
|
||||
bifoldMap f _ (AApp func args) = foldMap f func <> foldMap f args
|
||||
|
||||
instance ABTN.Align ANormalF where
|
||||
align f _ (AVar u) (AVar v) = Just $ AVar <$> f u v
|
||||
align _ _ (ALit l) (ALit r)
|
||||
| l == r = Just $ pure (ALit l)
|
||||
align _ g (ALet dl ccl bl el) (ALet dr ccr br er)
|
||||
| dl == dr, ccl == ccr =
|
||||
Just $ ALet dl ccl <$> g bl br <*> g el er
|
||||
align f g (AName hl asl el) (AName hr asr er)
|
||||
| length asl == length asr
|
||||
, Just hs <- alignEither f hl hr =
|
||||
Just $
|
||||
AName <$> hs
|
||||
<*> traverse (uncurry f) (zip asl asr)
|
||||
<*> g el er
|
||||
align f g (AMatch vl bsl) (AMatch vr bsr)
|
||||
| Just bss <- alignBranch g bsl bsr =
|
||||
Just $ AMatch <$> f vl vr <*> bss
|
||||
align f g (AHnd rl hl bl) (AHnd rr hr br)
|
||||
| rl == rr = Just $ AHnd rl <$> f hl hr <*> g bl br
|
||||
align _ g (AShift rl bl) (AShift rr br)
|
||||
| rl == rr = Just $ AShift rl <$> g bl br
|
||||
align f _ (AFrc u) (AFrc v) = Just $ AFrc <$> f u v
|
||||
align f _ (AApp hl asl) (AApp hr asr)
|
||||
| Just hs <- alignFunc f hl hr
|
||||
, length asl == length asr
|
||||
= Just $ AApp <$> hs <*> traverse (uncurry f) (zip asl asr)
|
||||
align _ _ _ _ = Nothing
|
||||
|
||||
alignEither ::
|
||||
Applicative f =>
|
||||
(l -> r -> f s) ->
|
||||
Either Reference l -> Either Reference r -> Maybe (f (Either Reference s))
|
||||
alignEither _ (Left rl) (Left rr) | rl == rr = Just . pure $ Left rl
|
||||
alignEither f (Right u) (Right v) = Just $ Right <$> f u v
|
||||
alignEither _ _ _ = Nothing
|
||||
|
||||
alignMaybe ::
|
||||
Applicative f =>
|
||||
(l -> r -> f s) ->
|
||||
Maybe l -> Maybe r -> Maybe (f (Maybe s))
|
||||
alignMaybe f (Just l) (Just r) = Just $ Just <$> f l r
|
||||
alignMaybe _ Nothing Nothing = Just (pure Nothing)
|
||||
alignMaybe _ _ _ = Nothing
|
||||
|
||||
alignFunc ::
|
||||
Applicative f =>
|
||||
(vl -> vr -> f vs) ->
|
||||
Func vl -> Func vr -> Maybe (f (Func vs))
|
||||
alignFunc f (FVar u) (FVar v) = Just $ FVar <$> f u v
|
||||
alignFunc _ (FComb rl) (FComb rr) | rl == rr = Just . pure $ FComb rl
|
||||
alignFunc f (FCont u) (FCont v) = Just $ FCont <$> f u v
|
||||
alignFunc _ (FCon rl tl) (FCon rr tr)
|
||||
| rl == rr, tl == tr = Just . pure $ FCon rl tl
|
||||
alignFunc _ (FReq rl tl) (FReq rr tr)
|
||||
| rl == rr, tl == tr = Just . pure $ FReq rl tl
|
||||
alignFunc _ (FPrim ol) (FPrim or)
|
||||
| ol == or = Just . pure $ FPrim ol
|
||||
alignFunc _ _ _ = Nothing
|
||||
|
||||
alignBranch ::
|
||||
Applicative f =>
|
||||
(el -> er -> f es) ->
|
||||
Branched el -> Branched er -> Maybe (f (Branched es))
|
||||
alignBranch _ MatchEmpty MatchEmpty = Just $ pure MatchEmpty
|
||||
alignBranch f (MatchIntegral bl dl) (MatchIntegral br dr)
|
||||
| keysSet bl == keysSet br
|
||||
, Just ds <- alignMaybe f dl dr
|
||||
= Just $ MatchIntegral
|
||||
<$> interverse f bl br
|
||||
<*> ds
|
||||
alignBranch f (MatchText bl dl) (MatchText br dr)
|
||||
| Map.keysSet bl == Map.keysSet br
|
||||
, Just ds <- alignMaybe f dl dr
|
||||
= Just $ MatchText
|
||||
<$> traverse id (Map.intersectionWith f bl br)
|
||||
<*> ds
|
||||
alignBranch f (MatchRequest bl pl) (MatchRequest br pr)
|
||||
| Map.keysSet bl == Map.keysSet br
|
||||
, all p (Map.keysSet bl)
|
||||
= Just $ MatchRequest
|
||||
<$> traverse id (Map.intersectionWith (interverse (alignCCs f)) bl br)
|
||||
<*> f pl pr
|
||||
where
|
||||
p r = keysSet hsl == keysSet hsr && all q (keys hsl)
|
||||
where
|
||||
hsl = bl Map.! r
|
||||
hsr = br Map.! r
|
||||
q t = fst (hsl ! t) == fst (hsr ! t)
|
||||
alignBranch f (MatchData rfl bl dl) (MatchData rfr br dr)
|
||||
| rfl == rfr
|
||||
, keysSet bl == keysSet br
|
||||
, all (\t -> fst (bl ! t) == fst (br ! t)) (keys bl)
|
||||
, Just ds <- alignMaybe f dl dr
|
||||
= Just $ MatchData rfl <$> interverse (alignCCs f) bl br <*> ds
|
||||
alignBranch f (MatchSum bl) (MatchSum br)
|
||||
| keysSet bl == keysSet br
|
||||
, all (\w -> fst (bl ! w) == fst (br ! w)) (keys bl)
|
||||
= Just $ MatchSum <$> interverse (alignCCs f) bl br
|
||||
alignBranch _ _ _ = Nothing
|
||||
|
||||
alignCCs :: Functor f => (l -> r -> f s) -> (a, l) -> (a, r) -> f (a, s)
|
||||
alignCCs f (ccs, l) (_, r) = (,) ccs <$> f l r
|
||||
|
||||
matchLit :: Term v a -> Maybe Lit
|
||||
matchLit (Int' i) = Just $ I i
|
||||
matchLit (Nat' n) = Just $ N n
|
||||
@ -927,7 +1035,7 @@ data Branched e
|
||||
| MatchEmpty
|
||||
| MatchData Reference (EnumMap CTag ([Mem], e)) (Maybe e)
|
||||
| MatchSum (EnumMap Word64 ([Mem], e))
|
||||
deriving (Show, Functor, Foldable, Traversable)
|
||||
deriving (Show, Eq, Functor, Foldable, Traversable)
|
||||
|
||||
-- Data cases expected to cover all constructors
|
||||
pattern MatchDataCover :: Reference -> EnumMap CTag ([Mem], e) -> Branched e
|
||||
@ -1038,7 +1146,7 @@ data Func v
|
||||
FReq !Reference !CTag
|
||||
| -- prim op
|
||||
FPrim (Either POp FOp)
|
||||
deriving (Show, Functor, Foldable, Traversable)
|
||||
deriving (Show, Eq, Functor, Foldable, Traversable)
|
||||
|
||||
data Lit
|
||||
= I Int64
|
||||
@ -1048,7 +1156,7 @@ data Lit
|
||||
| C Char
|
||||
| LM Referent
|
||||
| LY Reference
|
||||
deriving (Show)
|
||||
deriving (Show, Eq)
|
||||
|
||||
litRef :: Lit -> Reference
|
||||
litRef (I _) = Ty.intRef
|
||||
@ -1227,7 +1335,7 @@ type DNormal v = Directed () (ANormal v)
|
||||
|
||||
-- Should be a completely closed term
|
||||
data SuperNormal v = Lambda {conventions :: [Mem], bound :: ANormal v}
|
||||
deriving (Show)
|
||||
deriving (Show, Eq)
|
||||
|
||||
data SuperGroup v = Rec
|
||||
{ group :: [(v, SuperNormal v)],
|
||||
@ -1235,6 +1343,40 @@ data SuperGroup v = Rec
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
instance Var v => Eq (SuperGroup v) where
|
||||
g0 == g1 | Left _ <- equivocate g0 g1 = False | otherwise = True
|
||||
|
||||
-- Failure modes for SuperGroup alpha equivalence test
|
||||
data SGEqv v
|
||||
-- mismatch number of definitions in group
|
||||
= NumDefns (SuperGroup v) (SuperGroup v)
|
||||
-- mismatched SuperNormal calling conventions
|
||||
| DefnConventions (SuperNormal v) (SuperNormal v)
|
||||
-- mismatched subterms in corresponding definition
|
||||
| Subterms (ANormal v) (ANormal v)
|
||||
|
||||
-- Checks if two SuperGroups are equivalent up to renaming. The rest
|
||||
-- of the structure must match on the nose. If the two groups are not
|
||||
-- equivalent, an example of conflicting structure is returned.
|
||||
equivocate ::
|
||||
Var v =>
|
||||
SuperGroup v -> SuperGroup v -> Either (SGEqv v) ()
|
||||
equivocate g0@(Rec bs0 e0) g1@(Rec bs1 e1)
|
||||
| length bs0 == length bs1 =
|
||||
traverse_ eqvSN (zip ns0 ns1) *> eqvSN (e0, e1)
|
||||
| otherwise = Left $ NumDefns g0 g1
|
||||
where
|
||||
(vs0, ns0) = unzip bs0
|
||||
(vs1, ns1) = unzip bs1
|
||||
vm = Map.fromList (zip vs1 vs0)
|
||||
|
||||
promote (Left (l, r)) = Left $ Subterms l r
|
||||
promote (Right v) = Right v
|
||||
|
||||
eqvSN (Lambda ccs0 e0, Lambda ccs1 e1)
|
||||
| ccs0 == ccs1 = promote $ ABTN.alpha vm e0 e1
|
||||
eqvSN (n0, n1) = Left $ DefnConventions n0 n1
|
||||
|
||||
type ANFM v =
|
||||
ReaderT
|
||||
(Set v)
|
||||
|
378
parser-typechecker/src/Unison/Runtime/Array.hs
Normal file
378
parser-typechecker/src/Unison/Runtime/Array.hs
Normal file
@ -0,0 +1,378 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE StandaloneKindSignatures #-}
|
||||
|
||||
-- This module wraps the operations in the primitive package so that
|
||||
-- bounds checks can be toggled on during the build for debugging
|
||||
-- purposes. It exports the entire API for the three array types
|
||||
-- needed, and adds wrappers for the operations that are unchecked in
|
||||
-- the base library.
|
||||
--
|
||||
-- Checking is toggled using the `arraychecks` flag.
|
||||
module Unison.Runtime.Array
|
||||
( module EPA,
|
||||
readArray,
|
||||
writeArray,
|
||||
copyArray,
|
||||
copyMutableArray,
|
||||
cloneMutableArray,
|
||||
readByteArray,
|
||||
writeByteArray,
|
||||
indexByteArray,
|
||||
copyByteArray,
|
||||
copyMutableByteArray,
|
||||
moveByteArray,
|
||||
readPrimArray,
|
||||
writePrimArray,
|
||||
indexPrimArray,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad.Primitive
|
||||
import Data.Kind (Constraint)
|
||||
import Data.Primitive.Array as EPA hiding
|
||||
( cloneMutableArray,
|
||||
copyArray,
|
||||
copyMutableArray,
|
||||
readArray,
|
||||
writeArray,
|
||||
)
|
||||
import qualified Data.Primitive.Array as PA
|
||||
import Data.Primitive.ByteArray as EPA hiding
|
||||
( copyByteArray,
|
||||
copyMutableByteArray,
|
||||
indexByteArray,
|
||||
moveByteArray,
|
||||
readByteArray,
|
||||
writeByteArray,
|
||||
)
|
||||
import qualified Data.Primitive.ByteArray as PA
|
||||
import Data.Primitive.PrimArray as EPA hiding
|
||||
( indexPrimArray,
|
||||
readPrimArray,
|
||||
writePrimArray,
|
||||
)
|
||||
import qualified Data.Primitive.PrimArray as PA
|
||||
import Data.Primitive.Types
|
||||
|
||||
#ifdef ARRAY_CHECK
|
||||
import GHC.Stack
|
||||
|
||||
type CheckCtx :: Constraint
|
||||
type CheckCtx = HasCallStack
|
||||
|
||||
type MA = MutableArray
|
||||
type MBA = MutableByteArray
|
||||
type A = Array
|
||||
type BA = ByteArray
|
||||
|
||||
-- check index mutable array
|
||||
checkIMArray
|
||||
:: CheckCtx
|
||||
=> String
|
||||
-> (MA s a -> Int -> r)
|
||||
-> MA s a -> Int -> r
|
||||
checkIMArray name f arr i
|
||||
| i < 0 || sizeofMutableArray arr <= i
|
||||
= error $ name ++ " unsafe check out of bounds: " ++ show i
|
||||
| otherwise = f arr i
|
||||
{-# inline checkIMArray #-}
|
||||
|
||||
-- check copy array
|
||||
checkCArray
|
||||
:: CheckCtx
|
||||
=> String
|
||||
-> (MA s a -> Int -> A a -> Int -> Int -> r)
|
||||
-> MA s a -> Int -> A a -> Int -> Int -> r
|
||||
checkCArray name f dst d src s l
|
||||
| d < 0
|
||||
|| s < 0
|
||||
|| sizeofMutableArray dst < d + l
|
||||
|| sizeofArray src < s + l
|
||||
= error $ name ++ " unsafe check out of bounds: " ++ show (d, s, l)
|
||||
| otherwise = f dst d src s l
|
||||
{-# inline checkCArray #-}
|
||||
|
||||
-- check copy mutable array
|
||||
checkCMArray
|
||||
:: CheckCtx
|
||||
=> String
|
||||
-> (MA s a -> Int -> MA s a -> Int -> Int -> r)
|
||||
-> MA s a -> Int -> MA s a -> Int -> Int -> r
|
||||
checkCMArray name f dst d src s l
|
||||
| d < 0
|
||||
|| s < 0
|
||||
|| sizeofMutableArray dst < d + l
|
||||
|| sizeofMutableArray src < s + l
|
||||
= error $ name ++ " unsafe check out of bounds: " ++ show (d, s, l)
|
||||
| otherwise = f dst d src s l
|
||||
{-# inline checkCMArray #-}
|
||||
|
||||
-- check range mutable array
|
||||
checkRMArray
|
||||
:: CheckCtx
|
||||
=> String
|
||||
-> (MA s a -> Int -> Int -> r)
|
||||
-> MA s a -> Int -> Int -> r
|
||||
checkRMArray name f arr o l
|
||||
| o < 0 || sizeofMutableArray arr < o+l
|
||||
= error $ name ++ "unsafe check out of bounds: " ++ show (o, l)
|
||||
| otherwise = f arr o l
|
||||
{-# inline checkRMArray #-}
|
||||
|
||||
-- check index byte array
|
||||
checkIBArray
|
||||
:: CheckCtx
|
||||
=> Prim a
|
||||
=> String
|
||||
-> a
|
||||
-> (ByteArray -> Int -> r)
|
||||
-> ByteArray -> Int -> r
|
||||
checkIBArray name a f arr i
|
||||
| i < 0 || sizeofByteArray arr `quot` sizeOf a <= i
|
||||
= error $ name ++ " unsafe check out of bounds: " ++ show i
|
||||
| otherwise = f arr i
|
||||
{-# inline checkIBArray #-}
|
||||
|
||||
-- check index mutable byte array
|
||||
checkIMBArray
|
||||
:: CheckCtx
|
||||
=> Prim a
|
||||
=> String
|
||||
-> a
|
||||
-> (MutableByteArray s -> Int -> r)
|
||||
-> MutableByteArray s -> Int -> r
|
||||
checkIMBArray name a f arr i
|
||||
| i < 0 || sizeofMutableByteArray arr `quot` sizeOf a <= i
|
||||
= error $ name ++ " unsafe check out of bounds: " ++ show i
|
||||
| otherwise = f arr i
|
||||
{-# inline checkIMBArray #-}
|
||||
|
||||
-- check copy byte array
|
||||
checkCBArray
|
||||
:: CheckCtx
|
||||
=> String
|
||||
-> (MBA s -> Int -> BA -> Int -> Int -> r)
|
||||
-> MBA s -> Int -> BA -> Int -> Int -> r
|
||||
checkCBArray name f dst d src s l
|
||||
| d < 0
|
||||
|| s < 0
|
||||
|| sizeofMutableByteArray dst < d + l
|
||||
|| sizeofByteArray src < s + l
|
||||
= error $ name ++ " unsafe check out of bounds: " ++ show (d, s, l)
|
||||
| otherwise = f dst d src s l
|
||||
{-# inline checkCBArray #-}
|
||||
|
||||
-- check copy mutable byte array
|
||||
checkCMBArray
|
||||
:: CheckCtx
|
||||
=> String
|
||||
-> (MBA s -> Int -> MBA s -> Int -> Int -> r)
|
||||
-> MBA s -> Int -> MBA s -> Int -> Int -> r
|
||||
checkCMBArray name f dst d src s l
|
||||
| d < 0
|
||||
|| s < 0
|
||||
|| sizeofMutableByteArray dst < d + l
|
||||
|| sizeofMutableByteArray src < s + l
|
||||
= error $ name ++ " unsafe check out of bounds: " ++ show (d, s, l)
|
||||
| otherwise = f dst d src s l
|
||||
{-# inline checkCMBArray #-}
|
||||
|
||||
-- check index prim array
|
||||
checkIPArray
|
||||
:: CheckCtx
|
||||
=> Prim a
|
||||
=> String
|
||||
-> (PrimArray a -> Int -> r)
|
||||
-> PrimArray a -> Int -> r
|
||||
checkIPArray name f arr i
|
||||
| i < 0 || sizeofPrimArray arr <= i
|
||||
= error $ name ++ " unsafe check out of bounds: " ++ show i
|
||||
| otherwise = f arr i
|
||||
{-# inline checkIPArray #-}
|
||||
|
||||
-- check index mutable prim array
|
||||
checkIMPArray
|
||||
:: CheckCtx
|
||||
=> Prim a
|
||||
=> String
|
||||
-> (MutablePrimArray s a -> Int -> r)
|
||||
-> MutablePrimArray s a -> Int -> r
|
||||
checkIMPArray name f arr i
|
||||
| i < 0 || sizeofMutablePrimArray arr <= i
|
||||
= error $ name ++ " unsafe check out of bounds: " ++ show i
|
||||
| otherwise = f arr i
|
||||
{-# inline checkIMPArray #-}
|
||||
|
||||
#else
|
||||
type CheckCtx :: Constraint
|
||||
type CheckCtx = ()
|
||||
|
||||
checkIMArray, checkIMPArray, checkIPArray :: String -> r -> r
|
||||
checkCArray, checkCMArray, checkRMArray :: String -> r -> r
|
||||
checkIMArray _ = id
|
||||
checkIMPArray _ = id
|
||||
checkCArray _ = id
|
||||
checkCMArray _ = id
|
||||
checkRMArray _ = id
|
||||
checkIPArray _ = id
|
||||
|
||||
checkIBArray, checkIMBArray :: String -> a -> r -> r
|
||||
checkCBArray, checkCMBArray :: String -> r -> r
|
||||
checkIBArray _ _ = id
|
||||
checkIMBArray _ _ = id
|
||||
checkCBArray _ = id
|
||||
checkCMBArray _ = id
|
||||
#endif
|
||||
|
||||
readArray ::
|
||||
CheckCtx =>
|
||||
PrimMonad m =>
|
||||
MutableArray (PrimState m) a ->
|
||||
Int ->
|
||||
m a
|
||||
readArray = checkIMArray "readArray" PA.readArray
|
||||
{-# INLINE readArray #-}
|
||||
|
||||
writeArray ::
|
||||
CheckCtx =>
|
||||
PrimMonad m =>
|
||||
MutableArray (PrimState m) a ->
|
||||
Int ->
|
||||
a ->
|
||||
m ()
|
||||
writeArray = checkIMArray "writeArray" PA.writeArray
|
||||
{-# INLINE writeArray #-}
|
||||
|
||||
copyArray ::
|
||||
CheckCtx =>
|
||||
PrimMonad m =>
|
||||
MutableArray (PrimState m) a ->
|
||||
Int ->
|
||||
Array a ->
|
||||
Int ->
|
||||
Int ->
|
||||
m ()
|
||||
copyArray = checkCArray "copyArray" PA.copyArray
|
||||
{-# INLINE copyArray #-}
|
||||
|
||||
cloneMutableArray ::
|
||||
CheckCtx =>
|
||||
PrimMonad m =>
|
||||
MutableArray (PrimState m) a ->
|
||||
Int ->
|
||||
Int ->
|
||||
m (MutableArray (PrimState m) a)
|
||||
cloneMutableArray = checkRMArray "cloneMutableArray" PA.cloneMutableArray
|
||||
{-# INLINE cloneMutableArray #-}
|
||||
|
||||
copyMutableArray ::
|
||||
CheckCtx =>
|
||||
PrimMonad m =>
|
||||
MutableArray (PrimState m) a ->
|
||||
Int ->
|
||||
MutableArray (PrimState m) a ->
|
||||
Int ->
|
||||
Int ->
|
||||
m ()
|
||||
copyMutableArray = checkCMArray "copyMutableArray" PA.copyMutableArray
|
||||
{-# INLINE copyMutableArray #-}
|
||||
|
||||
readByteArray ::
|
||||
forall a m.
|
||||
CheckCtx =>
|
||||
PrimMonad m =>
|
||||
Prim a =>
|
||||
MutableByteArray (PrimState m) ->
|
||||
Int ->
|
||||
m a
|
||||
readByteArray = checkIMBArray @a "readByteArray" undefined PA.readByteArray
|
||||
{-# INLINE readByteArray #-}
|
||||
|
||||
writeByteArray ::
|
||||
forall a m.
|
||||
CheckCtx =>
|
||||
PrimMonad m =>
|
||||
Prim a =>
|
||||
MutableByteArray (PrimState m) ->
|
||||
Int ->
|
||||
a ->
|
||||
m ()
|
||||
writeByteArray = checkIMBArray @a "writeByteArray" undefined PA.writeByteArray
|
||||
{-# INLINE writeByteArray #-}
|
||||
|
||||
indexByteArray ::
|
||||
forall a.
|
||||
CheckCtx =>
|
||||
Prim a =>
|
||||
ByteArray ->
|
||||
Int ->
|
||||
a
|
||||
indexByteArray = checkIBArray @a "indexByteArray" undefined PA.indexByteArray
|
||||
{-# INLINE indexByteArray #-}
|
||||
|
||||
copyByteArray ::
|
||||
CheckCtx =>
|
||||
PrimMonad m =>
|
||||
MutableByteArray (PrimState m) ->
|
||||
Int ->
|
||||
ByteArray ->
|
||||
Int ->
|
||||
Int ->
|
||||
m ()
|
||||
copyByteArray = checkCBArray "copyByteArray" PA.copyByteArray
|
||||
{-# INLINE copyByteArray #-}
|
||||
|
||||
copyMutableByteArray ::
|
||||
CheckCtx =>
|
||||
PrimMonad m =>
|
||||
MutableByteArray (PrimState m) ->
|
||||
Int ->
|
||||
MutableByteArray (PrimState m) ->
|
||||
Int ->
|
||||
Int ->
|
||||
m ()
|
||||
copyMutableByteArray = checkCMBArray "copyMutableByteArray" PA.copyMutableByteArray
|
||||
{-# INLINE copyMutableByteArray #-}
|
||||
|
||||
moveByteArray ::
|
||||
CheckCtx =>
|
||||
PrimMonad m =>
|
||||
MutableByteArray (PrimState m) ->
|
||||
Int ->
|
||||
MutableByteArray (PrimState m) ->
|
||||
Int ->
|
||||
Int ->
|
||||
m ()
|
||||
moveByteArray = checkCMBArray "moveByteArray" PA.moveByteArray
|
||||
{-# INLINE moveByteArray #-}
|
||||
|
||||
readPrimArray ::
|
||||
CheckCtx =>
|
||||
PrimMonad m =>
|
||||
Prim a =>
|
||||
MutablePrimArray (PrimState m) a ->
|
||||
Int ->
|
||||
m a
|
||||
readPrimArray = checkIMPArray "readPrimArray" PA.readPrimArray
|
||||
{-# INLINE readPrimArray #-}
|
||||
|
||||
writePrimArray ::
|
||||
CheckCtx =>
|
||||
PrimMonad m =>
|
||||
Prim a =>
|
||||
MutablePrimArray (PrimState m) a ->
|
||||
Int ->
|
||||
a ->
|
||||
m ()
|
||||
writePrimArray = checkIMPArray "writePrimArray" PA.writePrimArray
|
||||
{-# INLINE writePrimArray #-}
|
||||
|
||||
indexPrimArray ::
|
||||
CheckCtx =>
|
||||
Prim a =>
|
||||
PrimArray a ->
|
||||
Int ->
|
||||
a
|
||||
indexPrimArray = checkIPArray "indexPrimArray" PA.indexPrimArray
|
||||
{-# INLINE indexPrimArray #-}
|
@ -51,7 +51,6 @@ import Data.IORef as SYS
|
||||
)
|
||||
import qualified Data.Map as Map
|
||||
import Data.PEM (PEM, pemContent, pemParseLBS)
|
||||
import qualified Data.Primitive as PA
|
||||
import Data.Set (insert)
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text
|
||||
@ -131,6 +130,7 @@ import Unison.Reference
|
||||
import Unison.Referent (pattern Ref)
|
||||
import Unison.Runtime.ANF as ANF
|
||||
import Unison.Runtime.ANF.Serialize as ANF
|
||||
import qualified Unison.Runtime.Array as PA
|
||||
import Unison.Runtime.Exception (die)
|
||||
import Unison.Runtime.Foreign
|
||||
( Foreign (Wrap),
|
||||
@ -1970,7 +1970,7 @@ declareForeign sand name op func0 = do
|
||||
| sanitize,
|
||||
Tracked <- sand,
|
||||
FF r w _ <- func0 =
|
||||
FF r w (bomb name)
|
||||
FF r w (bomb name)
|
||||
| otherwise = func0
|
||||
code = (name, (sand, uncurry Lambda (op w)))
|
||||
in (w + 1, code : codes, mapInsert w (name, func) funcs)
|
||||
|
@ -44,6 +44,68 @@ data Foreign where
|
||||
promote :: (a -> a -> r) -> b -> c -> r
|
||||
promote (~~) x y = unsafeCoerce x ~~ unsafeCoerce y
|
||||
|
||||
-- These functions are explicit aliases of the overloaded function.
|
||||
-- When the overloaded function is used in their place, it seems to
|
||||
-- cause issues with regard to `promote` above. Somehow, the
|
||||
-- unsafeCoerce can cause memory faults, even when the values are
|
||||
-- being coerced to appropriate types. Having an explicit, noinline
|
||||
-- alias seems to prevent the faults.
|
||||
txtEq :: Text -> Text -> Bool
|
||||
txtEq l r = l == r
|
||||
{-# NOINLINE txtEq #-}
|
||||
|
||||
txtCmp :: Text -> Text -> Ordering
|
||||
txtCmp l r = compare l r
|
||||
{-# NOINLINE txtCmp #-}
|
||||
|
||||
bytesEq :: Bytes -> Bytes -> Bool
|
||||
bytesEq l r = l == r
|
||||
{-# NOINLINE bytesEq #-}
|
||||
|
||||
bytesCmp :: Bytes -> Bytes -> Ordering
|
||||
bytesCmp l r = compare l r
|
||||
{-# NOINLINE bytesCmp #-}
|
||||
|
||||
mvarEq :: MVar () -> MVar () -> Bool
|
||||
mvarEq l r = l == r
|
||||
{-# NOINLINE mvarEq #-}
|
||||
|
||||
refEq :: IORef () -> IORef () -> Bool
|
||||
refEq l r = l == r
|
||||
{-# NOINLINE refEq #-}
|
||||
|
||||
tidEq :: ThreadId -> ThreadId -> Bool
|
||||
tidEq l r = l == r
|
||||
{-# NOINLINE tidEq #-}
|
||||
|
||||
tidCmp :: ThreadId -> ThreadId -> Ordering
|
||||
tidCmp l r = compare l r
|
||||
{-# NOINLINE tidCmp #-}
|
||||
|
||||
marrEq :: MutableArray () () -> MutableArray () () -> Bool
|
||||
marrEq l r = l == r
|
||||
{-# NOINLINE marrEq #-}
|
||||
|
||||
mbarrEq :: MutableByteArray () -> MutableByteArray () -> Bool
|
||||
mbarrEq l r = l == r
|
||||
{-# NOINLINE mbarrEq #-}
|
||||
|
||||
barrEq :: ByteArray -> ByteArray -> Bool
|
||||
barrEq l r = l == r
|
||||
{-# NOINLINE barrEq #-}
|
||||
|
||||
barrCmp :: ByteArray -> ByteArray -> Ordering
|
||||
barrCmp l r = compare l r
|
||||
{-# NOINLINE barrCmp #-}
|
||||
|
||||
cpatEq :: CPattern -> CPattern -> Bool
|
||||
cpatEq l r = l == r
|
||||
{-# NOINLINE cpatEq #-}
|
||||
|
||||
cpatCmp :: CPattern -> CPattern -> Ordering
|
||||
cpatCmp l r = compare l r
|
||||
{-# NOINLINE cpatCmp #-}
|
||||
|
||||
tylEq :: Reference -> Reference -> Bool
|
||||
tylEq r l = r == l
|
||||
{-# NOINLINE tylEq #-}
|
||||
@ -62,31 +124,31 @@ tmlCmp r l = compare r l
|
||||
|
||||
ref2eq :: Reference -> Maybe (a -> b -> Bool)
|
||||
ref2eq r
|
||||
| r == Ty.textRef = Just $ promote ((==) @Text)
|
||||
| r == Ty.textRef = Just $ promote txtEq
|
||||
| r == Ty.termLinkRef = Just $ promote tmlEq
|
||||
| r == Ty.typeLinkRef = Just $ promote tylEq
|
||||
| r == Ty.bytesRef = Just $ promote ((==) @Bytes)
|
||||
| r == Ty.bytesRef = Just $ promote bytesEq
|
||||
-- Note: MVar equality is just reference equality, so it shouldn't
|
||||
-- matter what type the MVar holds.
|
||||
| r == Ty.mvarRef = Just $ promote ((==) @(MVar ()))
|
||||
| r == Ty.mvarRef = Just $ promote mvarEq
|
||||
-- Ditto
|
||||
| r == Ty.refRef = Just $ promote ((==) @(IORef ()))
|
||||
| r == Ty.threadIdRef = Just $ promote ((==) @ThreadId)
|
||||
| r == Ty.marrayRef = Just $ promote ((==) @(MutableArray () ()))
|
||||
| r == Ty.mbytearrayRef = Just $ promote ((==) @(MutableByteArray ()))
|
||||
| r == Ty.ibytearrayRef = Just $ promote ((==) @ByteArray)
|
||||
| r == Ty.patternRef = Just $ promote ((==) @CPattern)
|
||||
| r == Ty.refRef = Just $ promote refEq
|
||||
| r == Ty.threadIdRef = Just $ promote tidEq
|
||||
| r == Ty.marrayRef = Just $ promote marrEq
|
||||
| r == Ty.mbytearrayRef = Just $ promote mbarrEq
|
||||
| r == Ty.ibytearrayRef = Just $ promote barrEq
|
||||
| r == Ty.patternRef = Just $ promote cpatEq
|
||||
| otherwise = Nothing
|
||||
|
||||
ref2cmp :: Reference -> Maybe (a -> b -> Ordering)
|
||||
ref2cmp r
|
||||
| r == Ty.textRef = Just $ promote (compare @Text)
|
||||
| r == Ty.textRef = Just $ promote txtCmp
|
||||
| r == Ty.termLinkRef = Just $ promote tmlCmp
|
||||
| r == Ty.typeLinkRef = Just $ promote tylCmp
|
||||
| r == Ty.bytesRef = Just $ promote (compare @Bytes)
|
||||
| r == Ty.threadIdRef = Just $ promote (compare @ThreadId)
|
||||
| r == Ty.ibytearrayRef = Just $ promote (compare @ByteArray)
|
||||
| r == Ty.patternRef = Just $ promote (compare @CPattern)
|
||||
| r == Ty.bytesRef = Just $ promote bytesCmp
|
||||
| r == Ty.threadIdRef = Just $ promote tidCmp
|
||||
| r == Ty.ibytearrayRef = Just $ promote barrCmp
|
||||
| r == Ty.patternRef = Just $ promote cpatCmp
|
||||
| otherwise = Nothing
|
||||
|
||||
instance Eq Foreign where
|
||||
|
@ -15,8 +15,6 @@ import Control.Exception
|
||||
import Data.Bits
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Ord (comparing)
|
||||
import qualified Data.Primitive.Array as PA
|
||||
import qualified Data.Primitive.PrimArray as PA
|
||||
import qualified Data.Sequence as Sq
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.Set as Set
|
||||
@ -40,6 +38,7 @@ import Unison.Runtime.ANF as ANF
|
||||
valueLinks,
|
||||
)
|
||||
import qualified Unison.Runtime.ANF as ANF
|
||||
import Unison.Runtime.Array as PA
|
||||
import Unison.Runtime.Builtin
|
||||
import Unison.Runtime.Exception
|
||||
import Unison.Runtime.Foreign
|
||||
|
@ -48,15 +48,13 @@ import Control.Monad (when)
|
||||
import Control.Monad.Primitive
|
||||
import Data.Foldable as F (for_)
|
||||
import qualified Data.Kind as Kind
|
||||
import Data.Primitive.Array
|
||||
import Data.Primitive.ByteArray
|
||||
import Data.Primitive.PrimArray
|
||||
import Data.Sequence (Seq)
|
||||
import Data.Word
|
||||
import GHC.Exts as L (IsList (..))
|
||||
import GHC.Stack (HasCallStack)
|
||||
import Unison.Reference (Reference)
|
||||
import Unison.Runtime.ANF as ANF (Mem (..))
|
||||
import Unison.Runtime.Array
|
||||
import Unison.Runtime.Foreign
|
||||
import Unison.Runtime.MCode
|
||||
import qualified Unison.Type as Ty
|
||||
@ -111,12 +109,13 @@ data Closure
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
traceK :: Reference -> K -> [(Reference, Int)]
|
||||
traceK begin = dedup (begin, 1) where
|
||||
dedup p (Mark _ _ _ _ k) = dedup p k
|
||||
dedup p@(cur,n) (Push _ _ _ _ (CIx r _ _) k)
|
||||
| cur == r = dedup (cur,1+n) k
|
||||
| otherwise = p : dedup (r,1) k
|
||||
dedup p _ = [p]
|
||||
traceK begin = dedup (begin, 1)
|
||||
where
|
||||
dedup p (Mark _ _ _ _ k) = dedup p k
|
||||
dedup p@(cur, n) (Push _ _ _ _ (CIx r _ _) k)
|
||||
| cur == r = dedup (cur, 1 + n) k
|
||||
| otherwise = p : dedup (r, 1) k
|
||||
dedup p _ = [p]
|
||||
|
||||
splitData :: Closure -> Maybe (Reference, Word64, [Int], [Closure])
|
||||
splitData (Enum r t) = Just (r, t, [], [])
|
||||
|
@ -1,4 +1,16 @@
|
||||
module Unison.Syntax.TermPrinter (emptyAc, pretty, prettyBlock, prettyBlock', pretty', prettyBinding, prettyBinding', pretty0, runPretty) where
|
||||
module Unison.Syntax.TermPrinter
|
||||
( emptyAc,
|
||||
pretty,
|
||||
prettyBlock,
|
||||
prettyBlock',
|
||||
pretty',
|
||||
prettyBinding,
|
||||
prettyBinding',
|
||||
prettyBindingWithoutTypeSignature,
|
||||
pretty0,
|
||||
runPretty,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Lens (unsnoc, (^.))
|
||||
import Control.Monad.State (evalState)
|
||||
@ -508,7 +520,7 @@ pretty0
|
||||
printBinding (v, binding) =
|
||||
if Var.isAction v
|
||||
then pretty0 (ac (-1) Normal im doc) binding
|
||||
else prettyBinding0 (ac (-1) Normal im doc) (HQ.unsafeFromVar v) binding
|
||||
else renderPrettyBinding <$> prettyBinding0 (ac (-1) Normal im doc) (HQ.unsafeFromVar v) binding
|
||||
letIntro = case sc of
|
||||
Block -> id
|
||||
Normal -> \x -> fmt S.ControlKeyword "let" `PP.hang` x
|
||||
@ -775,27 +787,63 @@ printCase im doc ms0 =
|
||||
<$> pretty0 (ac 2 Normal im doc) g
|
||||
printBody b = let (im', uses) = calcImports im b in goBody im' uses b
|
||||
|
||||
{- Render a binding, producing output of the form
|
||||
-- A pretty term binding, split into the type signature (possibly empty) and the term.
|
||||
data PrettyBinding = PrettyBinding
|
||||
{ typeSignature :: Maybe (Pretty SyntaxText),
|
||||
term :: Pretty SyntaxText
|
||||
}
|
||||
|
||||
foo : t -> u
|
||||
foo a = ...
|
||||
-- Render a pretty binding.
|
||||
renderPrettyBinding :: PrettyBinding -> Pretty SyntaxText
|
||||
renderPrettyBinding PrettyBinding {typeSignature, term} =
|
||||
case typeSignature of
|
||||
Nothing -> term
|
||||
Just ty -> PP.lines [ty, term]
|
||||
|
||||
The first line is only output if the term has a type annotation as the
|
||||
outermost constructor.
|
||||
-- Render a pretty binding without a type signature.
|
||||
renderPrettyBindingWithoutTypeSignature :: PrettyBinding -> Pretty SyntaxText
|
||||
renderPrettyBindingWithoutTypeSignature PrettyBinding {term} =
|
||||
term
|
||||
|
||||
Binary functions with symbolic names are output infix, as follows:
|
||||
|
||||
(+) : t -> t -> t
|
||||
a + b = ...
|
||||
|
||||
-}
|
||||
-- | Render a binding, producing output of the form
|
||||
--
|
||||
-- foo : t -> u
|
||||
-- foo a = ...
|
||||
--
|
||||
-- The first line is only output if the term has a type annotation as the
|
||||
-- outermost constructor.
|
||||
--
|
||||
-- Binary functions with symbolic names are output infix, as follows:
|
||||
--
|
||||
-- (+) : t -> t -> t
|
||||
-- a + b = ...
|
||||
prettyBinding ::
|
||||
Var v =>
|
||||
PrettyPrintEnv ->
|
||||
HQ.HashQualified Name ->
|
||||
Term2 v at ap v a ->
|
||||
Pretty SyntaxText
|
||||
prettyBinding ppe n = runPretty ppe . prettyBinding0 (ac (-1) Block Map.empty MaybeDoc) n
|
||||
prettyBinding =
|
||||
prettyBinding_ renderPrettyBinding
|
||||
|
||||
-- | Like 'prettyBinding', but elides the type signature (if any).
|
||||
prettyBindingWithoutTypeSignature ::
|
||||
Var v =>
|
||||
PrettyPrintEnv ->
|
||||
HQ.HashQualified Name ->
|
||||
Term2 v at ap v a ->
|
||||
Pretty SyntaxText
|
||||
prettyBindingWithoutTypeSignature =
|
||||
prettyBinding_ renderPrettyBindingWithoutTypeSignature
|
||||
|
||||
prettyBinding_ ::
|
||||
Var v =>
|
||||
(PrettyBinding -> Pretty SyntaxText) ->
|
||||
PrettyPrintEnv ->
|
||||
HQ.HashQualified Name ->
|
||||
Term2 v at ap v a ->
|
||||
Pretty SyntaxText
|
||||
prettyBinding_ go ppe n = runPretty ppe . fmap go . prettyBinding0 (ac (-1) Block Map.empty MaybeDoc) n
|
||||
|
||||
prettyBinding' ::
|
||||
Var v =>
|
||||
@ -812,7 +860,7 @@ prettyBinding0 ::
|
||||
AmbientContext ->
|
||||
HQ.HashQualified Name ->
|
||||
Term2 v at ap v a ->
|
||||
m (Pretty SyntaxText)
|
||||
m PrettyBinding
|
||||
prettyBinding0 a@AmbientContext {imports = im, docContext = doc} v term =
|
||||
go (symbolic && isBinary term) term
|
||||
where
|
||||
@ -831,26 +879,26 @@ prettyBinding0 a@AmbientContext {imports = im, docContext = doc} v term =
|
||||
_ -> id
|
||||
tp' <- TypePrinter.pretty0 im (-1) tp
|
||||
tm' <- avoidCapture (prettyBinding0 a v tm)
|
||||
pure $
|
||||
PP.lines
|
||||
[ PP.group
|
||||
( renderName v
|
||||
<> PP.hang
|
||||
(fmt S.TypeAscriptionColon " :")
|
||||
tp'
|
||||
),
|
||||
PP.group tm'
|
||||
]
|
||||
pure
|
||||
PrettyBinding
|
||||
{ typeSignature = Just (PP.group (renderName v <> PP.hang (fmt S.TypeAscriptionColon " :") tp')),
|
||||
term = PP.group (renderPrettyBinding tm')
|
||||
}
|
||||
(printAnnotate env -> LamsNamedMatch' vs branches) -> do
|
||||
branches' <- printCase im doc branches
|
||||
pure . PP.group $
|
||||
PP.group
|
||||
( defnLhs v vs <> fmt S.BindingEquals " =" <> " "
|
||||
<> fmt
|
||||
S.ControlKeyword
|
||||
"cases"
|
||||
)
|
||||
`PP.hang` branches'
|
||||
pure
|
||||
PrettyBinding
|
||||
{ typeSignature = Nothing,
|
||||
term =
|
||||
PP.group $
|
||||
PP.group
|
||||
( defnLhs v vs <> fmt S.BindingEquals " =" <> " "
|
||||
<> fmt
|
||||
S.ControlKeyword
|
||||
"cases"
|
||||
)
|
||||
`PP.hang` branches'
|
||||
}
|
||||
LamsNamedOrDelay' vs body -> do
|
||||
-- In the case where we're being called from inside `pretty0`, this
|
||||
-- call to printAnnotate is unfortunately repeating work we've already
|
||||
@ -862,10 +910,15 @@ prettyBinding0 a@AmbientContext {imports = im, docContext = doc} v term =
|
||||
let hang = case body' of
|
||||
Delay' (Lets' _ _) -> PP.softHang
|
||||
_ -> PP.hang
|
||||
pure . PP.group $
|
||||
PP.group (defnLhs v vs <> fmt S.BindingEquals " =")
|
||||
`hang` uses [prettyBody]
|
||||
t -> pure $ l "error: " <> l (show t)
|
||||
pure
|
||||
PrettyBinding
|
||||
{ typeSignature = Nothing,
|
||||
term =
|
||||
PP.group $
|
||||
PP.group (defnLhs v vs <> fmt S.BindingEquals " =")
|
||||
`hang` uses [prettyBody]
|
||||
}
|
||||
t -> error ("prettyBinding0: unexpected term: " ++ show t)
|
||||
where
|
||||
defnLhs v vs
|
||||
| infix' = case vs of
|
||||
|
@ -9,6 +9,7 @@ module Unison.Util.EnumContainers
|
||||
setSingleton,
|
||||
mapInsert,
|
||||
unionWith,
|
||||
intersectionWith,
|
||||
hasKey,
|
||||
keys,
|
||||
keysSet,
|
||||
@ -22,7 +23,9 @@ module Unison.Util.EnumContainers
|
||||
mapToList,
|
||||
(!),
|
||||
findMin,
|
||||
interverse,
|
||||
traverseSet_,
|
||||
traverseWithKey,
|
||||
setSize,
|
||||
)
|
||||
where
|
||||
@ -89,7 +92,6 @@ mapInsert :: EnumKey k => k -> a -> EnumMap k a -> EnumMap k a
|
||||
mapInsert e x (EM m) = EM $ IM.insert (keyToInt e) x m
|
||||
|
||||
unionWith ::
|
||||
EnumKey k =>
|
||||
EnumKey k =>
|
||||
(a -> a -> a) ->
|
||||
EnumMap k a ->
|
||||
@ -97,6 +99,13 @@ unionWith ::
|
||||
EnumMap k a
|
||||
unionWith f (EM l) (EM r) = EM $ IM.unionWith f l r
|
||||
|
||||
intersectionWith ::
|
||||
(a -> b -> c) ->
|
||||
EnumMap k a ->
|
||||
EnumMap k b ->
|
||||
EnumMap k c
|
||||
intersectionWith f (EM l) (EM r) = EM $ IM.intersectionWith f l r
|
||||
|
||||
keys :: EnumKey k => EnumMap k a -> [k]
|
||||
keys (EM m) = fmap intToKey . IM.keys $ m
|
||||
|
||||
@ -141,5 +150,22 @@ traverseSet_ ::
|
||||
traverseSet_ f (ES s) =
|
||||
IS.foldr (\i r -> f (intToKey i) *> r) (pure ()) s
|
||||
|
||||
interverse ::
|
||||
Applicative f =>
|
||||
(a -> b -> f c) ->
|
||||
EnumMap k a ->
|
||||
EnumMap k b ->
|
||||
f (EnumMap k c)
|
||||
interverse f (EM l) (EM r) =
|
||||
fmap EM . traverse id $ IM.intersectionWith f l r
|
||||
|
||||
traverseWithKey ::
|
||||
Applicative f =>
|
||||
EnumKey k =>
|
||||
(k -> a -> f b) ->
|
||||
EnumMap k a ->
|
||||
f (EnumMap k b)
|
||||
traverseWithKey f (EM m) = EM <$> IM.traverseWithKey (f . intToKey) m
|
||||
|
||||
setSize :: EnumSet k -> Int
|
||||
setSize (ES s) = IS.size s
|
||||
|
@ -17,6 +17,10 @@ source-repository head
|
||||
type: git
|
||||
location: https://github.com/unisonweb/unison
|
||||
|
||||
flag arraychecks
|
||||
manual: True
|
||||
default: False
|
||||
|
||||
flag optimized
|
||||
manual: True
|
||||
default: True
|
||||
@ -103,6 +107,7 @@ library
|
||||
Unison.Result
|
||||
Unison.Runtime.ANF
|
||||
Unison.Runtime.ANF.Serialize
|
||||
Unison.Runtime.Array
|
||||
Unison.Runtime.Builtin
|
||||
Unison.Runtime.Debug
|
||||
Unison.Runtime.Decompile
|
||||
@ -302,6 +307,8 @@ library
|
||||
, zlib
|
||||
if flag(optimized)
|
||||
ghc-options: -funbox-strict-fields -O2
|
||||
if flag(arraychecks)
|
||||
cpp-options: -DARRAY_CHECK
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite parser-typechecker-tests
|
||||
@ -490,4 +497,6 @@ test-suite parser-typechecker-tests
|
||||
, zlib
|
||||
if flag(optimized)
|
||||
ghc-options: -funbox-strict-fields -O2
|
||||
if flag(arraychecks)
|
||||
cpp-options: -DARRAY_CHECK
|
||||
default-language: Haskell2010
|
||||
|
@ -1,5 +1,4 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DefaultSignatures #-}
|
||||
|
||||
-- | The main CLI monad.
|
||||
module Unison.Cli.Monad
|
||||
@ -38,6 +37,7 @@ module Unison.Cli.Monad
|
||||
|
||||
-- * Running transactions
|
||||
runTransaction,
|
||||
runEitherTransaction,
|
||||
|
||||
-- * Misc types
|
||||
LoadSourceResult (..),
|
||||
@ -381,3 +381,8 @@ runTransaction :: Sqlite.Transaction a -> Cli a
|
||||
runTransaction action = do
|
||||
Env {codebase} <- ask
|
||||
liftIO (Codebase.runTransaction codebase action)
|
||||
|
||||
-- | Return early if a transaction returns Left.
|
||||
runEitherTransaction :: Sqlite.Transaction (Either Output a) -> Cli a
|
||||
runEitherTransaction action =
|
||||
runTransaction action & onLeftM returnEarly
|
||||
|
@ -13,7 +13,9 @@ module Unison.Cli.MonadUtils
|
||||
|
||||
-- ** Resolving branch identifiers
|
||||
resolveAbsBranchId,
|
||||
resolveAbsBranchIdV2,
|
||||
resolveBranchId,
|
||||
resolveBranchIdToAbsBranchId,
|
||||
resolveShortCausalHash,
|
||||
|
||||
-- ** Getting/setting branches
|
||||
@ -78,6 +80,7 @@ import Control.Monad.State
|
||||
import qualified Data.Configurator as Configurator
|
||||
import qualified Data.Configurator.Types as Configurator
|
||||
import qualified Data.Set as Set
|
||||
import qualified U.Codebase.Branch as V2 (Branch)
|
||||
import qualified U.Codebase.Branch as V2Branch
|
||||
import qualified U.Codebase.Causal as V2Causal
|
||||
import U.Codebase.HashTags (CausalHash (..))
|
||||
@ -101,6 +104,7 @@ import Unison.Parser.Ann (Ann (..))
|
||||
import Unison.Prelude
|
||||
import Unison.Reference (TypeReference)
|
||||
import Unison.Referent (Referent)
|
||||
import qualified Unison.Sqlite as Sqlite
|
||||
import Unison.Symbol (Symbol)
|
||||
import Unison.UnisonFile (TypecheckedUnisonFile)
|
||||
import qualified Unison.Util.Set as Set
|
||||
@ -144,32 +148,54 @@ resolveAbsBranchId = \case
|
||||
Left hash -> resolveShortCausalHash hash
|
||||
Right path -> getBranchAt path
|
||||
|
||||
-- | V2 version of 'resolveAbsBranchId2'.
|
||||
resolveAbsBranchIdV2 :: Input.AbsBranchId -> Sqlite.Transaction (Either Output.Output (V2.Branch Sqlite.Transaction))
|
||||
resolveAbsBranchIdV2 = \case
|
||||
Left shortHash -> do
|
||||
resolveShortCausalHashToCausalHash shortHash >>= \case
|
||||
Left output -> pure (Left output)
|
||||
Right hash -> succeed (Codebase.expectCausalBranchByCausalHash hash)
|
||||
Right path -> succeed (Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute path))
|
||||
where
|
||||
succeed getCausal = do
|
||||
causal <- getCausal
|
||||
branch <- V2Causal.value causal
|
||||
pure (Right branch)
|
||||
|
||||
-- | Resolve a @BranchId@ to the corresponding @Branch IO@, or fail if no such branch hash is found. (Non-existent
|
||||
-- branches by path are OK - the empty branch will be returned).
|
||||
resolveBranchId :: Input.BranchId -> Cli (Branch IO)
|
||||
resolveBranchId branchId = do
|
||||
absBranchId <- traverseOf _Right resolvePath' branchId
|
||||
absBranchId <- resolveBranchIdToAbsBranchId branchId
|
||||
resolveAbsBranchId absBranchId
|
||||
|
||||
-- | Resolve a @BranchId@ to an @AbsBranchId@.
|
||||
resolveBranchIdToAbsBranchId :: Input.BranchId -> Cli Input.AbsBranchId
|
||||
resolveBranchIdToAbsBranchId =
|
||||
traverseOf _Right resolvePath'
|
||||
|
||||
-- | Resolve a @ShortCausalHash@ to the corresponding @Branch IO@, or fail if no such branch hash is found.
|
||||
resolveShortCausalHash :: ShortCausalHash -> Cli (Branch IO)
|
||||
resolveShortCausalHash hash = do
|
||||
resolveShortCausalHash shortHash = do
|
||||
Cli.time "resolveShortCausalHash" do
|
||||
Cli.Env {codebase} <- ask
|
||||
(hashSet, len) <-
|
||||
Cli.runTransaction do
|
||||
hashSet <- Codebase.causalHashesByPrefix hash
|
||||
len <- Codebase.branchHashLength
|
||||
pure (hashSet, len)
|
||||
h <-
|
||||
Set.asSingleton hashSet & onNothing do
|
||||
Cli.returnEarly
|
||||
if Set.null hashSet
|
||||
then Output.NoBranchWithHash hash
|
||||
else Output.BranchHashAmbiguous hash (Set.map (SCH.fromHash len) hashSet)
|
||||
branch <- liftIO (Codebase.getBranchForHash codebase h)
|
||||
hash <- Cli.runEitherTransaction (resolveShortCausalHashToCausalHash shortHash)
|
||||
branch <- liftIO (Codebase.getBranchForHash codebase hash)
|
||||
pure (fromMaybe Branch.empty branch)
|
||||
|
||||
resolveShortCausalHashToCausalHash :: ShortCausalHash -> Sqlite.Transaction (Either Output.Output CausalHash)
|
||||
resolveShortCausalHashToCausalHash shortHash = do
|
||||
hashes <- Codebase.causalHashesByPrefix shortHash
|
||||
case Set.asSingleton hashes of
|
||||
Nothing ->
|
||||
fmap Left do
|
||||
if Set.null hashes
|
||||
then pure (Output.NoBranchWithHash shortHash)
|
||||
else do
|
||||
len <- Codebase.branchHashLength
|
||||
pure (Output.BranchHashAmbiguous shortHash (Set.map (SCH.fromHash len) hashes))
|
||||
Just hash -> pure (Right hash)
|
||||
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Getting/Setting branches
|
||||
|
||||
|
@ -12,6 +12,7 @@ import Control.Lens
|
||||
import Control.Monad.Reader (ask)
|
||||
import Control.Monad.State (StateT)
|
||||
import qualified Control.Monad.State as State
|
||||
import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
|
||||
import Control.Monad.Writer (WriterT (..))
|
||||
import Data.Bifunctor (first, second)
|
||||
import qualified Data.Foldable as Foldable
|
||||
@ -41,6 +42,7 @@ import qualified Text.Megaparsec as P
|
||||
import qualified U.Codebase.Branch.Diff as V2Branch
|
||||
import qualified U.Codebase.Causal as V2Causal
|
||||
import U.Codebase.HashTags (CausalHash (..))
|
||||
import qualified U.Codebase.Reference as V2 (Reference)
|
||||
import qualified U.Codebase.Reflog as Reflog
|
||||
import qualified U.Codebase.Sqlite.Operations as Ops
|
||||
import qualified U.Codebase.Sqlite.Queries as Queries
|
||||
@ -61,7 +63,6 @@ import Unison.Codebase.Branch (Branch (..), Branch0 (..))
|
||||
import qualified Unison.Codebase.Branch as Branch
|
||||
import qualified Unison.Codebase.Branch.Merge as Branch
|
||||
import qualified Unison.Codebase.Branch.Names as Branch
|
||||
import qualified Unison.Codebase.BranchDiff as BranchDiff (diff0)
|
||||
import qualified Unison.Codebase.BranchUtil as BranchUtil
|
||||
import qualified Unison.Codebase.Causal as Causal
|
||||
import Unison.Codebase.Editor.AuthorInfo (AuthorInfo (..))
|
||||
@ -115,6 +116,7 @@ import Unison.Codebase.PushBehavior (PushBehavior)
|
||||
import qualified Unison.Codebase.PushBehavior as PushBehavior
|
||||
import qualified Unison.Codebase.Runtime as Runtime
|
||||
import qualified Unison.Codebase.ShortCausalHash as SCH
|
||||
import qualified Unison.Codebase.SqliteCodebase.Conversions as Conversions
|
||||
import qualified Unison.Codebase.SyncMode as SyncMode
|
||||
import Unison.Codebase.TermEdit (TermEdit (..))
|
||||
import qualified Unison.Codebase.TermEdit as TermEdit
|
||||
@ -162,8 +164,6 @@ import qualified Unison.Reference as Reference
|
||||
import Unison.Referent (Referent)
|
||||
import qualified Unison.Referent as Referent
|
||||
import qualified Unison.Result as Result
|
||||
import Unison.Runtime.IOSource (isTest)
|
||||
import qualified Unison.Runtime.IOSource as DD
|
||||
import qualified Unison.Runtime.IOSource as IOSource
|
||||
import Unison.Server.Backend (ShallowListEntry (..))
|
||||
import qualified Unison.Server.Backend as Backend
|
||||
@ -269,7 +269,7 @@ loop e = do
|
||||
go (ann, kind, _hash, _uneval, eval, isHit) = (ann, kind, eval, isHit)
|
||||
when (not (null e')) do
|
||||
Cli.respond $ Evaluated text ppe bindings e'
|
||||
#latestTypecheckedFile .= (Just unisonFile)
|
||||
#latestTypecheckedFile .= Just unisonFile
|
||||
|
||||
case e of
|
||||
Left (IncomingRootBranch hashes) -> Cli.time "IncomingRootBranch" do
|
||||
@ -1186,41 +1186,7 @@ loop e = do
|
||||
ExecuteSchemeI main -> doRunAsScheme main
|
||||
GenSchemeLibsI -> doGenerateSchemeBoot True Nothing
|
||||
FetchSchemeCompilerI -> doFetchCompiler
|
||||
IOTestI main -> do
|
||||
Cli.Env {codebase, runtime} <- ask
|
||||
-- todo - allow this to run tests from scratch file, using addRunMain
|
||||
let testType = Runtime.ioTestType runtime
|
||||
parseNames <- (`NamesWithHistory.NamesWithHistory` mempty) <$> basicParseNames
|
||||
ppe <- suffixifiedPPE parseNames
|
||||
-- use suffixed names for resolving the argument to display
|
||||
let oks results =
|
||||
[ (r, msg)
|
||||
| (r, Term.List' ts) <- results,
|
||||
Term.App' (Term.Constructor' (ConstructorReference ref cid)) (Term.Text' msg) <- toList ts,
|
||||
cid == DD.okConstructorId && ref == DD.testResultRef
|
||||
]
|
||||
fails results =
|
||||
[ (r, msg)
|
||||
| (r, Term.List' ts) <- results,
|
||||
Term.App' (Term.Constructor' (ConstructorReference ref cid)) (Term.Text' msg) <- toList ts,
|
||||
cid == DD.failConstructorId && ref == DD.testResultRef
|
||||
]
|
||||
|
||||
results = NamesWithHistory.lookupHQTerm main parseNames
|
||||
ref <- do
|
||||
let noMain = Cli.returnEarly $ NoMainFunction (HQ.toString main) ppe [testType]
|
||||
case toList results of
|
||||
[Referent.Ref ref] -> do
|
||||
Cli.runTransaction (loadTypeOfTerm codebase (Referent.Ref ref)) >>= \case
|
||||
Just typ | Typechecker.isSubtype typ testType -> pure ref
|
||||
_ -> noMain
|
||||
_ -> noMain
|
||||
let a = ABT.annotation tm
|
||||
tm = DD.forceTerm a a (Term.ref a ref)
|
||||
-- Don't cache IO tests
|
||||
tm' <- evalUnisonTerm False ppe False tm
|
||||
Cli.respond $ TestResults Output.NewlyComputed ppe True True (oks [(ref, tm')]) (fails [(ref, tm')])
|
||||
|
||||
IOTestI main -> handleIOTest main
|
||||
-- UpdateBuiltinsI -> do
|
||||
-- stepAt updateBuiltins
|
||||
-- checkTodo
|
||||
@ -1410,8 +1376,8 @@ loop e = do
|
||||
([fromCH], [toCH]) -> pure (fromCH, toCH)
|
||||
output <-
|
||||
Cli.runTransaction do
|
||||
fromBranch <- (Codebase.expectCausalBranchByCausalHash fromCH) >>= V2Causal.value
|
||||
toBranch <- (Codebase.expectCausalBranchByCausalHash toCH) >>= V2Causal.value
|
||||
fromBranch <- Codebase.expectCausalBranchByCausalHash fromCH >>= V2Causal.value
|
||||
toBranch <- Codebase.expectCausalBranchByCausalHash toCH >>= V2Causal.value
|
||||
treeDiff <- V2Branch.diffBranches fromBranch toBranch
|
||||
let nameChanges = V2Branch.nameChanges Nothing treeDiff
|
||||
pure (DisplayDebugNameDiff nameChanges)
|
||||
@ -1804,58 +1770,34 @@ handleDiffNamespaceToPatch :: Text -> DiffNamespaceToPatchInput -> Cli ()
|
||||
handleDiffNamespaceToPatch description input = do
|
||||
Cli.Env {codebase} <- ask
|
||||
|
||||
branch1 <- Branch.head <$> Cli.resolveBranchId (input ^. #branchId1)
|
||||
branch2 <- Branch.head <$> Cli.resolveBranchId (input ^. #branchId2)
|
||||
branchDiff <- liftIO (BranchDiff.diff0 branch1 branch2)
|
||||
absBranchId1 <- Cli.resolveBranchIdToAbsBranchId (input ^. #branchId1)
|
||||
absBranchId2 <- Cli.resolveBranchIdToAbsBranchId (input ^. #branchId2)
|
||||
|
||||
-- Given {old referents} and {new referents}, create term edit patch entries as follows:
|
||||
--
|
||||
-- * If the {new referents} is a singleton set {new referent}, proceed. (Otherwise, the patch we might create would
|
||||
-- not be a function, which is a bogus/conflicted patch).
|
||||
-- * If the new referent is a term reference, not a data constructor, proceed. (Patches currently can't track
|
||||
-- updates to data constructors).
|
||||
-- * For each old term reference (again, throwing constructors away) in {old referents}, create a patch entry that
|
||||
-- maps the old reference to the new. The patch entry includes the typing relationship between the terms, so we
|
||||
-- look the references' types up in the codebase, too.
|
||||
let termNamespaceUpdateToTermEdits :: (Set Referent, Set Referent) -> Sqlite.Transaction (Set (Reference, TermEdit))
|
||||
termNamespaceUpdateToTermEdits (refs0, refs1) =
|
||||
case Set.asSingleton refs1 of
|
||||
Just (Referent.Ref ref1) ->
|
||||
Codebase.getTypeOfTerm codebase ref1 >>= \case
|
||||
Nothing -> pure Set.empty
|
||||
Just ty1 ->
|
||||
Monoid.foldMapM
|
||||
( \ref0 ->
|
||||
Codebase.getTypeOfTerm codebase ref0 <&> \case
|
||||
Nothing -> Set.empty
|
||||
Just ty0 -> Set.singleton (ref0, TermEdit.Replace ref1 (TermEdit.typing ty0 ty1))
|
||||
)
|
||||
(mapMaybe Referent.toTermReference (Set.toList refs0))
|
||||
_ -> pure Set.empty
|
||||
|
||||
-- The same idea as above, but for types: if there's one new reference in {new references}, then map each of the old
|
||||
-- references to it.
|
||||
let typeNamespaceUpdateToTypeEdits :: (Set Reference, Set Reference) -> Set (Reference, TypeEdit)
|
||||
typeNamespaceUpdateToTypeEdits (refs0, refs1) =
|
||||
case Set.asSingleton refs1 of
|
||||
Just ref1 -> Set.map (\ref0 -> (ref0, TypeEdit.Replace ref1)) refs0
|
||||
_ -> Set.empty
|
||||
|
||||
termUpdates <-
|
||||
Cli.runTransaction do
|
||||
(branchDiff ^. #termsDiff . #tallnamespaceUpdates)
|
||||
& Map.elems
|
||||
& Monoid.foldMapM termNamespaceUpdateToTermEdits
|
||||
let typeUpdates =
|
||||
(branchDiff ^. #typesDiff . #tallnamespaceUpdates)
|
||||
& Map.elems
|
||||
& foldMap typeNamespaceUpdateToTypeEdits
|
||||
|
||||
let patch =
|
||||
Patch
|
||||
{ _termEdits = Relation.fromSet termUpdates,
|
||||
_typeEdits = Relation.fromSet typeUpdates
|
||||
}
|
||||
patch <- do
|
||||
Cli.runEitherTransaction do
|
||||
runExceptT do
|
||||
branch1 <- ExceptT (Cli.resolveAbsBranchIdV2 absBranchId1)
|
||||
branch2 <- ExceptT (Cli.resolveAbsBranchIdV2 absBranchId2)
|
||||
lift do
|
||||
branchDiff <- V2Branch.nameBasedDiff <$> V2Branch.diffBranches branch1 branch2
|
||||
termEdits <-
|
||||
(branchDiff ^. #terms)
|
||||
& Relation.domain
|
||||
& Map.toList
|
||||
& traverse \(oldRef, newRefs) -> makeTermEdit codebase oldRef newRefs
|
||||
pure
|
||||
Patch
|
||||
{ _termEdits =
|
||||
termEdits
|
||||
& catMaybes
|
||||
& Relation.fromList,
|
||||
_typeEdits =
|
||||
(branchDiff ^. #types)
|
||||
& Relation.domain
|
||||
& Map.toList
|
||||
& mapMaybe (\(oldRef, newRefs) -> makeTypeEdit oldRef newRefs)
|
||||
& Relation.fromList
|
||||
}
|
||||
|
||||
-- Display the patch that we are about to create.
|
||||
ppe <- suffixifiedPPE =<< makePrintNamesFromLabeled' (Patch.labeledDependencies patch)
|
||||
@ -1868,6 +1810,88 @@ handleDiffNamespaceToPatch description input = do
|
||||
Cli.stepAtM
|
||||
description
|
||||
(Path.unabsolute patchPath, Branch.modifyPatches patchName (const patch))
|
||||
where
|
||||
-- Given {old reference} and {new references}, create term edit patch entries as follows:
|
||||
--
|
||||
-- * If the {new references} is a singleton set {new reference}, proceed. (Otherwise, the patch we might create
|
||||
-- would not be a function, which is a bogus/conflicted patch).
|
||||
-- * Look up {old reference} and {new reference} types in the codebase (which can technically fail, due to
|
||||
-- non-transactionality of this command, though we don't typically delete anything from SQLite), and create a
|
||||
-- patch entry that maps {old reference} to {new reference} with the typing relationship.
|
||||
makeTermEdit ::
|
||||
Codebase m Symbol Ann ->
|
||||
V2.Reference ->
|
||||
Set V2.Reference ->
|
||||
Sqlite.Transaction (Maybe (Reference, TermEdit))
|
||||
makeTermEdit codebase (Conversions.reference2to1 -> oldRef) newRefs =
|
||||
runMaybeT do
|
||||
newRef <- Conversions.reference2to1 <$> MaybeT (pure (Set.asSingleton newRefs))
|
||||
oldRefType <- MaybeT (Codebase.getTypeOfTerm codebase oldRef)
|
||||
newRefType <- MaybeT (Codebase.getTypeOfTerm codebase newRef)
|
||||
pure (oldRef, TermEdit.Replace newRef (TermEdit.typing oldRefType newRefType))
|
||||
|
||||
-- Same idea as 'makeTermEdit', but simpler, because there's nothing to look up in the database.
|
||||
makeTypeEdit :: V2.Reference -> Set V2.Reference -> Maybe (Reference, TypeEdit)
|
||||
makeTypeEdit (Conversions.reference2to1 -> oldRef) newRefs =
|
||||
Set.asSingleton newRefs <&> \newRef -> (oldRef, TypeEdit.Replace (Conversions.reference2to1 newRef))
|
||||
|
||||
handleIOTest :: HQ.HashQualified Name -> Cli ()
|
||||
handleIOTest main = do
|
||||
Cli.Env {codebase, runtime} <- ask
|
||||
|
||||
let testType = Runtime.ioTestType runtime
|
||||
parseNames <- (`NamesWithHistory.NamesWithHistory` mempty) <$> basicParseNames
|
||||
-- use suffixed names for resolving the argument to display
|
||||
ppe <- suffixifiedPPE parseNames
|
||||
let oks results =
|
||||
[ (r, msg)
|
||||
| (r, Term.List' ts) <- results,
|
||||
Term.App' (Term.Constructor' (ConstructorReference ref cid)) (Term.Text' msg) <- toList ts,
|
||||
cid == DD.okConstructorId && ref == DD.testResultRef
|
||||
]
|
||||
fails results =
|
||||
[ (r, msg)
|
||||
| (r, Term.List' ts) <- results,
|
||||
Term.App' (Term.Constructor' (ConstructorReference ref cid)) (Term.Text' msg) <- toList ts,
|
||||
cid == DD.failConstructorId && ref == DD.testResultRef
|
||||
]
|
||||
|
||||
matches <-
|
||||
Cli.label \returnMatches -> do
|
||||
-- First, look at the terms in the latest typechecked file for a name-match.
|
||||
whenJustM Cli.getLatestTypecheckedFile \typecheckedFile -> do
|
||||
whenJust (HQ.toName main) \mainName ->
|
||||
whenJust (Map.lookup (Name.toVar mainName) (UF.hashTermsId typecheckedFile)) \(ref, _wk, _term, typ) ->
|
||||
returnMatches [(Reference.fromId ref, typ)]
|
||||
|
||||
-- Then, if we get here (because nothing in the scratch file matched), look at the terms in the codebase.
|
||||
Cli.runTransaction do
|
||||
forMaybe (Set.toList (NamesWithHistory.lookupHQTerm main parseNames)) \ref0 ->
|
||||
runMaybeT do
|
||||
ref <- MaybeT (pure (Referent.toTermReference ref0))
|
||||
typ <- MaybeT (loadTypeOfTerm codebase (Referent.Ref ref))
|
||||
pure (ref, typ)
|
||||
|
||||
ref <-
|
||||
case matches of
|
||||
[] -> Cli.returnEarly (NoMainFunction (HQ.toString main) ppe [testType])
|
||||
[(ref, typ)] ->
|
||||
if Typechecker.isSubtype typ testType
|
||||
then pure ref
|
||||
else Cli.returnEarly (BadMainFunction "io.test" (HQ.toString main) typ ppe [testType])
|
||||
_ -> do
|
||||
hashLength <- Cli.runTransaction Codebase.hashLength
|
||||
let labeledDependencies =
|
||||
matches
|
||||
& map (\(ref, _typ) -> LD.termRef ref)
|
||||
& Set.fromList
|
||||
Cli.returnEarly (LabeledReferenceAmbiguous hashLength main labeledDependencies)
|
||||
|
||||
let a = ABT.annotation tm
|
||||
tm = DD.forceTerm a a (Term.ref a ref)
|
||||
-- Don't cache IO tests
|
||||
tm' <- evalUnisonTerm False ppe False tm
|
||||
Cli.respond $ TestResults Output.NewlyComputed ppe True True (oks [(ref, tm')]) (fails [(ref, tm')])
|
||||
|
||||
-- | Handle a @push@ command.
|
||||
handlePushRemoteBranch :: PushRemoteBranchInput -> Cli ()
|
||||
@ -1962,50 +1986,46 @@ handlePushToUnisonShare remote@WriteShareRemotePath {server, repo, path = remote
|
||||
let sharePath = Share.Path (repo Nel.:| pathToSegments remotePath)
|
||||
ensureAuthenticatedWithCodeserver codeserver
|
||||
|
||||
Cli.Env {authHTTPClient, codebase} <- ask
|
||||
|
||||
-- doesn't handle the case where a non-existent path is supplied
|
||||
localCausalHash <-
|
||||
Cli.runTransaction (Ops.loadCausalHashAtPath (pathToSegments (Path.unabsolute localPath))) & onNothingM do
|
||||
Cli.returnEarly (EmptyPush . Path.absoluteToPath' $ localPath)
|
||||
|
||||
let checkAndSetPush :: Maybe Hash32 -> IO (Either (Share.SyncError Share.CheckAndSetPushError) ())
|
||||
let checkAndSetPush :: Maybe Hash32 -> Cli ()
|
||||
checkAndSetPush remoteHash =
|
||||
withEntitiesUploadedProgressCallback \uploadedCallback ->
|
||||
if Just (Hash32.fromHash (unCausalHash localCausalHash)) == remoteHash
|
||||
then pure (Right ())
|
||||
else
|
||||
Share.checkAndSetPush
|
||||
authHTTPClient
|
||||
baseURL
|
||||
(Codebase.withConnectionIO codebase)
|
||||
sharePath
|
||||
remoteHash
|
||||
localCausalHash
|
||||
uploadedCallback
|
||||
when (Just (Hash32.fromHash (unCausalHash localCausalHash)) /= remoteHash) do
|
||||
let push =
|
||||
Cli.with withEntitiesUploadedProgressCallback \uploadedCallback -> do
|
||||
Share.checkAndSetPush
|
||||
baseURL
|
||||
sharePath
|
||||
remoteHash
|
||||
localCausalHash
|
||||
uploadedCallback
|
||||
push & onLeftM (pushError ShareErrorCheckAndSetPush)
|
||||
|
||||
case behavior of
|
||||
PushBehavior.ForcePush -> do
|
||||
maybeHashJwt <-
|
||||
Cli.ioE (Share.getCausalHashByPath authHTTPClient baseURL sharePath) \err ->
|
||||
Cli.returnEarly (Output.ShareError (ShareErrorGetCausalHashByPath err))
|
||||
Cli.ioE (checkAndSetPush (Share.hashJWTHash <$> maybeHashJwt)) (pushError ShareErrorCheckAndSetPush)
|
||||
Share.getCausalHashByPath baseURL sharePath & onLeftM \err0 ->
|
||||
(Cli.returnEarly . Output.ShareError) case err0 of
|
||||
Share.SyncError err -> ShareErrorGetCausalHashByPath err
|
||||
Share.TransportError err -> ShareErrorTransport err
|
||||
checkAndSetPush (Share.hashJWTHash <$> maybeHashJwt)
|
||||
Cli.respond (ViewOnShare remote)
|
||||
PushBehavior.RequireEmpty -> do
|
||||
Cli.ioE (checkAndSetPush Nothing) (pushError ShareErrorCheckAndSetPush)
|
||||
checkAndSetPush Nothing
|
||||
Cli.respond (ViewOnShare remote)
|
||||
PushBehavior.RequireNonEmpty -> do
|
||||
let push :: IO (Either (Share.SyncError Share.FastForwardPushError) ())
|
||||
push = do
|
||||
withEntitiesUploadedProgressCallback \uploadedCallback ->
|
||||
let push :: Cli (Either (Share.SyncError Share.FastForwardPushError) ())
|
||||
push =
|
||||
Cli.with withEntitiesUploadedProgressCallback \uploadedCallback ->
|
||||
Share.fastForwardPush
|
||||
authHTTPClient
|
||||
baseURL
|
||||
(Codebase.withConnectionIO codebase)
|
||||
sharePath
|
||||
localCausalHash
|
||||
uploadedCallback
|
||||
Cli.ioE push (pushError ShareErrorFastForwardPush)
|
||||
push & onLeftM (pushError ShareErrorFastForwardPush)
|
||||
Cli.respond (ViewOnShare remote)
|
||||
where
|
||||
pathToSegments :: Path -> [Text]
|
||||
@ -2076,8 +2096,24 @@ handleShowDefinition outputLoc showDefinitionScope inputQuery = do
|
||||
Cli.runTransaction (Backend.definitionsBySuffixes codebase nameSearch includeCycles query)
|
||||
outputPath <- getOutputPath
|
||||
when (not (null types && null terms)) do
|
||||
let ppe = PPED.biasTo (mapMaybe HQ.toName inputQuery) unbiasedPPE
|
||||
Cli.respond (DisplayDefinitions outputPath ppe types terms)
|
||||
-- We need an 'isTest' check in the output layer, so it can prepend "test>" to tests in a scratch file. Since we
|
||||
-- currently have the whole branch in memory, we just use that to make our predicate, but this could/should get this
|
||||
-- information from the database instead, once it's efficient to do so.
|
||||
isTest <- do
|
||||
branch <- Cli.getCurrentBranch0
|
||||
pure \ref ->
|
||||
branch
|
||||
& Branch.deepTermMetadata
|
||||
& Metadata.hasMetadataWithType' (Referent.fromTermReference ref) IOSource.isTestReference
|
||||
Cli.respond $
|
||||
DisplayDefinitions
|
||||
DisplayDefinitionsOutput
|
||||
{ isTest,
|
||||
outputFile = outputPath,
|
||||
prettyPrintEnv = PPED.biasTo (mapMaybe HQ.toName inputQuery) unbiasedPPE,
|
||||
terms,
|
||||
types
|
||||
}
|
||||
when (not (null misses)) (Cli.respond (SearchTermsNotFound misses))
|
||||
for_ outputPath \p -> do
|
||||
-- We set latestFile to be programmatically generated, if we
|
||||
@ -2113,7 +2149,7 @@ handleTest TestInput {includeLibNamespace, showFailures, showSuccesses} = do
|
||||
branch <- Cli.getCurrentBranch0
|
||||
branch
|
||||
& Branch.deepTermMetadata
|
||||
& R4.restrict34d12 isTest
|
||||
& R4.restrict34d12 IOSource.isTest
|
||||
& (if includeLibNamespace then id else R.filterRan (not . isInLibNamespace))
|
||||
& R.dom
|
||||
& pure
|
||||
@ -2251,21 +2287,13 @@ importRemoteShareBranch rrn@(ReadShareRemoteNamespace {server, repo, path}) = do
|
||||
-- Auto-login to share if pulling from a non-public path
|
||||
when (not $ RemoteRepo.isPublic rrn) $ ensureAuthenticatedWithCodeserver codeserver
|
||||
let shareFlavoredPath = Share.Path (repo Nel.:| coerce @[NameSegment] @[Text] (Path.toList path))
|
||||
Cli.Env {authHTTPClient, codebase} <- ask
|
||||
let pull :: IO (Either (Share.SyncError Share.PullError) CausalHash)
|
||||
pull =
|
||||
withEntitiesDownloadedProgressCallback \downloadedCallback ->
|
||||
Share.pull
|
||||
authHTTPClient
|
||||
baseURL
|
||||
(Codebase.withConnectionIO codebase)
|
||||
shareFlavoredPath
|
||||
downloadedCallback
|
||||
Cli.Env {codebase} <- ask
|
||||
causalHash <-
|
||||
Cli.ioE pull \err0 ->
|
||||
(Cli.returnEarly . Output.ShareError) case err0 of
|
||||
Share.SyncError err -> Output.ShareErrorPull err
|
||||
Share.TransportError err -> Output.ShareErrorTransport err
|
||||
Cli.with withEntitiesDownloadedProgressCallback \downloadedCallback ->
|
||||
Share.pull baseURL shareFlavoredPath downloadedCallback & onLeftM \err0 ->
|
||||
(Cli.returnEarly . Output.ShareError) case err0 of
|
||||
Share.SyncError err -> Output.ShareErrorPull err
|
||||
Share.TransportError err -> Output.ShareErrorTransport err
|
||||
liftIO (Codebase.getBranchForHash codebase causalHash) & onNothingM do
|
||||
error $ reportBug "E412939" "`pull` \"succeeded\", but I can't find the result in the codebase. (This is a bug.)"
|
||||
where
|
||||
@ -2687,7 +2715,7 @@ typecheckAndEval ppe tm = do
|
||||
| Typechecker.fitsScheme ty mty ->
|
||||
() <$ evalUnisonTerm False ppe False tm
|
||||
| otherwise ->
|
||||
Cli.returnEarly $ BadMainFunction rendered ty ppe [mty]
|
||||
Cli.returnEarly $ BadMainFunction "run" rendered ty ppe [mty]
|
||||
Result.Result notes Nothing -> do
|
||||
currentPath <- Cli.getCurrentPath
|
||||
let tes = [err | Result.TypeError err <- toList notes]
|
||||
@ -2960,7 +2988,7 @@ docsI srcLoc prettyPrintNames src =
|
||||
|
||||
codebaseByMetadata :: Cli ()
|
||||
codebaseByMetadata = do
|
||||
(ppe, out) <- getLinks srcLoc src (Left $ Set.fromList [DD.docRef, DD.doc2Ref])
|
||||
(ppe, out) <- getLinks srcLoc src (Left $ Set.fromList [DD.docRef, IOSource.doc2Ref])
|
||||
case out of
|
||||
[] -> codebaseByName
|
||||
[(_name, ref, _tm)] -> do
|
||||
@ -3122,7 +3150,7 @@ getTerm main =
|
||||
mainType <- Runtime.mainType <$> view #runtime
|
||||
basicPrettyPrintNames <- getBasicPrettyPrintNames
|
||||
ppe <- suffixifiedPPE (NamesWithHistory.NamesWithHistory basicPrettyPrintNames mempty)
|
||||
Cli.returnEarly $ BadMainFunction main ty ppe [mainType]
|
||||
Cli.returnEarly $ BadMainFunction "run" main ty ppe [mainType]
|
||||
GetTermSuccess x -> pure x
|
||||
|
||||
getTerm' :: String -> Cli GetTermResult
|
||||
|
@ -120,5 +120,5 @@ resolveMainRef main = do
|
||||
lookupTermRefWithType codebase main >>= \case
|
||||
[(rf, ty)]
|
||||
| Typechecker.fitsScheme ty mainType -> pure (rf, ppe)
|
||||
| otherwise -> Cli.returnEarly (BadMainFunction smain ty ppe [mainType])
|
||||
| otherwise -> Cli.returnEarly (BadMainFunction "main" smain ty ppe [mainType])
|
||||
_ -> Cli.returnEarly (NoMainFunction smain ppe [mainType])
|
||||
|
@ -53,7 +53,7 @@ import qualified Unison.Reference as Reference
|
||||
import Unison.Referent (Referent)
|
||||
import qualified Unison.Referent as Referent
|
||||
import qualified Unison.Result as Result
|
||||
import Unison.Runtime.IOSource (isTest)
|
||||
import qualified Unison.Runtime.IOSource as IOSource
|
||||
import qualified Unison.Sqlite as Sqlite
|
||||
import Unison.Symbol (Symbol)
|
||||
import qualified Unison.Syntax.Name as Name (toVar, unsafeFromVar)
|
||||
@ -589,7 +589,7 @@ doSlurpAdds slurp uf = Branch.batchUpdates (typeActions <> termActions)
|
||||
SC.terms slurp <> UF.constructorsForDecls (SC.types slurp) uf
|
||||
names = UF.typecheckedToNames uf
|
||||
tests = Set.fromList $ fst <$> UF.watchesOfKind WK.TestWatch (UF.discardTypes uf)
|
||||
(isTestType, isTestValue) = isTest
|
||||
(isTestType, isTestValue) = IOSource.isTest
|
||||
md v =
|
||||
if Set.member v tests
|
||||
then Metadata.singleton isTestType isTestValue
|
||||
|
@ -1,7 +1,6 @@
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
|
||||
module Unison.Codebase.Editor.Output
|
||||
( Output (..),
|
||||
DisplayDefinitionsOutput (..),
|
||||
NumberedOutput (..),
|
||||
NumberedArgs,
|
||||
ListDetailed,
|
||||
@ -54,7 +53,7 @@ import Unison.Parser.Ann (Ann)
|
||||
import Unison.Prelude
|
||||
import qualified Unison.PrettyPrintEnv as PPE
|
||||
import qualified Unison.PrettyPrintEnvDecl as PPE
|
||||
import Unison.Reference (Reference)
|
||||
import Unison.Reference (Reference, TermReference)
|
||||
import qualified Unison.Reference as Reference
|
||||
import Unison.Referent (Referent)
|
||||
import Unison.Server.Backend (ShallowListEntry (..))
|
||||
@ -121,8 +120,18 @@ data Output
|
||||
| SourceLoadFailed String
|
||||
| -- No main function, the [Type v Ann] are the allowed types
|
||||
NoMainFunction String PPE.PrettyPrintEnv [Type Symbol Ann]
|
||||
| -- Main function found, but has improper type
|
||||
BadMainFunction String (Type Symbol Ann) PPE.PrettyPrintEnv [Type Symbol Ann]
|
||||
| -- | Function found, but has improper type
|
||||
-- Note: the constructor name is misleading here; we weren't necessarily looking for a "main".
|
||||
BadMainFunction
|
||||
String
|
||||
-- ^ what we were trying to do (e.g. "run", "io.test")
|
||||
String
|
||||
-- ^ name of function
|
||||
(Type Symbol Ann)
|
||||
-- ^ bad type of function
|
||||
PPE.PrettyPrintEnv
|
||||
[Type Symbol Ann]
|
||||
-- ^ acceptable type(s) of function
|
||||
| BranchEmpty (Either ShortCausalHash Path')
|
||||
| BranchNotEmpty Path'
|
||||
| LoadPullRequest ReadRemoteNamespace ReadRemoteNamespace Path' Path' Path' Path'
|
||||
@ -203,11 +212,7 @@ data Output
|
||||
| Typechecked SourceName PPE.PrettyPrintEnv SlurpResult (UF.TypecheckedUnisonFile Symbol Ann)
|
||||
| DisplayRendered (Maybe FilePath) (P.Pretty P.ColorText)
|
||||
| -- "display" definitions, possibly to a FilePath on disk (e.g. editing)
|
||||
DisplayDefinitions
|
||||
(Maybe FilePath)
|
||||
PPE.PrettyPrintEnvDecl
|
||||
(Map Reference (DisplayObject () (Decl Symbol Ann)))
|
||||
(Map Reference (DisplayObject (Type Symbol Ann) (Term Symbol Ann)))
|
||||
DisplayDefinitions DisplayDefinitionsOutput
|
||||
| TestIncrementalOutputStart PPE.PrettyPrintEnv (Int, Int) Reference (Term Symbol Ann)
|
||||
| TestIncrementalOutputEnd PPE.PrettyPrintEnv (Int, Int) Reference (Term Symbol Ann)
|
||||
| TestResults
|
||||
@ -278,6 +283,14 @@ data Output
|
||||
| DisplayDebugNameDiff NameChanges
|
||||
| DisplayDebugCompletions [Completion.Completion]
|
||||
|
||||
data DisplayDefinitionsOutput = DisplayDefinitionsOutput
|
||||
{ isTest :: TermReference -> Bool,
|
||||
outputFile :: Maybe FilePath,
|
||||
prettyPrintEnv :: PPE.PrettyPrintEnvDecl,
|
||||
terms :: Map Reference (DisplayObject (Type Symbol Ann) (Term Symbol Ann)),
|
||||
types :: Map Reference (DisplayObject () (Decl Symbol Ann))
|
||||
}
|
||||
|
||||
data ShareError
|
||||
= ShareErrorCheckAndSetPush Sync.CheckAndSetPushError
|
||||
| ShareErrorFastForwardPush Sync.FastForwardPushError
|
||||
@ -369,7 +382,7 @@ isFailure o = case o of
|
||||
EvaluationFailure {} -> True
|
||||
Evaluated {} -> False
|
||||
Typechecked {} -> False
|
||||
DisplayDefinitions _ _ m1 m2 -> null m1 && null m2
|
||||
DisplayDefinitions DisplayDefinitionsOutput {terms, types} -> null terms && null types
|
||||
DisplayRendered {} -> False
|
||||
TestIncrementalOutputStart {} -> False
|
||||
TestIncrementalOutputEnd {} -> False
|
||||
|
@ -1537,19 +1537,20 @@ viewReflog =
|
||||
edit :: InputPattern
|
||||
edit =
|
||||
InputPattern
|
||||
"edit"
|
||||
[]
|
||||
I.Visible
|
||||
[(OnePlus, definitionQueryArg)]
|
||||
( P.lines
|
||||
[ "`edit foo` prepends the definition of `foo` to the top of the most "
|
||||
<> "recently saved file.",
|
||||
"`edit` without arguments invokes a search to select a definition for editing, which requires that `fzf` can be found within your PATH."
|
||||
]
|
||||
)
|
||||
( fmap (Input.ShowDefinitionI Input.LatestFileLocation Input.ShowDefinitionLocal)
|
||||
. traverse parseHashQualifiedName
|
||||
)
|
||||
{ patternName = "edit",
|
||||
aliases = [],
|
||||
visibility = I.Visible,
|
||||
argTypes = [(OnePlus, definitionQueryArg)],
|
||||
help =
|
||||
P.lines
|
||||
[ "`edit foo` prepends the definition of `foo` to the top of the most "
|
||||
<> "recently saved file.",
|
||||
"`edit` without arguments invokes a search to select a definition for editing, which requires that `fzf` can be found within your PATH."
|
||||
],
|
||||
parse =
|
||||
fmap (Input.ShowDefinitionI Input.LatestFileLocation Input.ShowDefinitionLocal)
|
||||
. traverse parseHashQualifiedName
|
||||
}
|
||||
|
||||
topicNameArg :: ArgumentType
|
||||
topicNameArg =
|
||||
@ -2084,20 +2085,20 @@ saveExecuteResult =
|
||||
ioTest :: InputPattern
|
||||
ioTest =
|
||||
InputPattern
|
||||
"io.test"
|
||||
["test.io"]
|
||||
I.Visible
|
||||
[(Required, exactDefinitionTermQueryArg)]
|
||||
( P.wrapColumn2
|
||||
[ ( "`io.test mytest`",
|
||||
"Runs `!mytest`, where `mytest` is a delayed test that can use the `IO` and `Exception` abilities. Note: `mytest` must already be added to the codebase."
|
||||
)
|
||||
]
|
||||
)
|
||||
( \case
|
||||
{ patternName = "io.test",
|
||||
aliases = ["test.io"],
|
||||
visibility = I.Visible,
|
||||
argTypes = [(Required, exactDefinitionTermQueryArg)],
|
||||
help =
|
||||
P.wrapColumn2
|
||||
[ ( "`io.test mytest`",
|
||||
"Runs `!mytest`, where `mytest` is a delayed test that can use the `IO` and `Exception` abilities."
|
||||
)
|
||||
],
|
||||
parse = \case
|
||||
[thing] -> fmap Input.IOTestI $ parseHashQualifiedName thing
|
||||
_ -> Left $ showPatternHelp ioTest
|
||||
)
|
||||
}
|
||||
|
||||
makeStandalone :: InputPattern
|
||||
makeStandalone =
|
||||
|
@ -111,7 +111,7 @@ import Unison.PrintError
|
||||
printNoteWithSource,
|
||||
renderCompilerBug,
|
||||
)
|
||||
import Unison.Reference (Reference)
|
||||
import Unison.Reference (Reference, TermReference)
|
||||
import qualified Unison.Reference as Reference
|
||||
import Unison.Referent (Referent)
|
||||
import qualified Unison.Referent as Referent
|
||||
@ -124,12 +124,14 @@ import qualified Unison.Share.Sync as Share
|
||||
import Unison.Share.Sync.Types (CodeserverTransportError (..))
|
||||
import qualified Unison.ShortHash as SH
|
||||
import qualified Unison.ShortHash as ShortHash
|
||||
import Unison.Symbol (Symbol)
|
||||
import qualified Unison.Sync.Types as Share
|
||||
import qualified Unison.Syntax.DeclPrinter as DeclPrinter
|
||||
import qualified Unison.Syntax.HashQualified as HQ (toString, toText, unsafeFromVar)
|
||||
import qualified Unison.Syntax.Name as Name (toString, toText)
|
||||
import Unison.Syntax.NamePrinter
|
||||
( prettyHashQualified,
|
||||
( SyntaxText,
|
||||
prettyHashQualified,
|
||||
prettyHashQualified',
|
||||
prettyLabeledDependency,
|
||||
prettyName,
|
||||
@ -657,8 +659,7 @@ notifyUser dir o = case o of
|
||||
[prettyReadRemoteNamespace baseNS, prettyPath' squashedPath]
|
||||
<> "to push the changes."
|
||||
]
|
||||
DisplayDefinitions outputLoc ppe types terms ->
|
||||
displayDefinitions outputLoc ppe types terms
|
||||
DisplayDefinitions output -> displayDefinitions output
|
||||
DisplayRendered outputLoc pp ->
|
||||
displayRendered outputLoc pp
|
||||
TestResults stats ppe _showSuccess _showFailures oks fails -> case stats of
|
||||
@ -798,14 +799,14 @@ notifyUser dir o = case o of
|
||||
"",
|
||||
P.indentN 2 $ P.lines [P.string main <> " : " <> TypePrinter.pretty ppe t | t <- ts]
|
||||
]
|
||||
BadMainFunction main ty ppe ts ->
|
||||
BadMainFunction what main ty ppe ts ->
|
||||
pure . P.callout "😶" $
|
||||
P.lines
|
||||
[ P.string "I found this function:",
|
||||
"",
|
||||
P.indentN 2 $ P.string main <> " : " <> TypePrinter.pretty ppe ty,
|
||||
"",
|
||||
P.wrap $ P.string "but in order for me to" <> P.backticked (P.string "run") <> "it needs be a subtype of:",
|
||||
P.wrap $ P.string "but in order for me to" <> P.backticked (P.string what) <> "it needs be a subtype of:",
|
||||
"",
|
||||
P.indentN 2 $ P.lines [P.string main <> " : " <> TypePrinter.pretty ppe t | t <- ts]
|
||||
]
|
||||
@ -1320,19 +1321,25 @@ notifyUser dir o = case o of
|
||||
"",
|
||||
err
|
||||
]
|
||||
NoConfiguredRemoteMapping pp p ->
|
||||
pure . P.fatalCallout . P.wrap $
|
||||
"I don't know where to "
|
||||
<> PushPull.fold "push to!" "pull from!" pp
|
||||
<> ( if Path.isRoot p
|
||||
then ""
|
||||
else
|
||||
"Add a line like `RemoteMapping." <> P.shown p
|
||||
<> " = namespace.path' to .unisonConfig. "
|
||||
)
|
||||
<> "Type `help "
|
||||
<> PushPull.fold "push" "pull" pp
|
||||
<> "` for more information."
|
||||
NoConfiguredRemoteMapping pp p -> do
|
||||
let (localPathExample, sharePathExample) =
|
||||
if Path.isRoot p
|
||||
then ("myproject", "myuser.public.myproject")
|
||||
else (Path.toText (Path.unabsolute p), "myuser.public." <> Path.toText (Path.unabsolute p))
|
||||
pure . P.fatalCallout $
|
||||
P.lines
|
||||
[ "I don't know where to " <> PushPull.fold "push to." "pull from." pp,
|
||||
"Add a `RemoteMapping` configuration to your .unisonConfig file. E.g.",
|
||||
"",
|
||||
"```",
|
||||
"RemoteMapping {",
|
||||
P.text (" " <> localPathExample <> " = \"" <> sharePathExample <> "\""),
|
||||
"}",
|
||||
"```",
|
||||
"",
|
||||
"Type `help " <> PushPull.fold "push" "pull" pp <> "` for more information."
|
||||
]
|
||||
|
||||
-- | ConfiguredGitUrlParseError PushPull Path' Text String
|
||||
ConfiguredRemoteMappingParseError pp p url err ->
|
||||
pure . P.fatalCallout . P.lines $
|
||||
@ -1722,9 +1729,9 @@ notifyUser dir o = case o of
|
||||
(Share.FastForwardPushErrorNoWritePermission sharePath) -> noWritePermission sharePath
|
||||
(Share.FastForwardPushErrorServerMissingDependencies hashes) -> missingDependencies hashes
|
||||
ShareErrorPull e -> case e of
|
||||
(Share.PullErrorGetCausalHashByPath err) -> handleGetCausalHashByPathError err
|
||||
(Share.PullErrorNoHistoryAtPath sharePath) ->
|
||||
Share.PullErrorNoHistoryAtPath sharePath ->
|
||||
P.wrap $ P.text "The server didn't find anything at" <> prettySharePath sharePath
|
||||
Share.PullErrorNoReadPermission sharePath -> noReadPermission sharePath
|
||||
ShareErrorGetCausalHashByPath err -> handleGetCausalHashByPathError err
|
||||
ShareErrorTransport te -> case te of
|
||||
DecodeFailure msg resp ->
|
||||
@ -2027,24 +2034,18 @@ displayRendered outputLoc pp =
|
||||
P.indentN 2 pp
|
||||
]
|
||||
|
||||
displayDefinitions ::
|
||||
Var v =>
|
||||
Ord a1 =>
|
||||
Maybe FilePath ->
|
||||
PPED.PrettyPrintEnvDecl ->
|
||||
Map Reference.Reference (DisplayObject () (DD.Decl v a1)) ->
|
||||
Map Reference.Reference (DisplayObject (Type v a1) (Term v a1)) ->
|
||||
IO Pretty
|
||||
displayDefinitions _outputLoc _ppe types terms
|
||||
| Map.null types && Map.null terms = pure $ P.callout "😶" "No results to display."
|
||||
displayDefinitions outputLoc ppe types terms =
|
||||
maybe displayOnly scratchAndDisplay outputLoc
|
||||
displayDefinitions :: DisplayDefinitionsOutput -> IO Pretty
|
||||
displayDefinitions DisplayDefinitionsOutput {isTest, outputFile, prettyPrintEnv = ppe, terms, types} =
|
||||
if Map.null types && Map.null terms
|
||||
then pure $ P.callout "😶" "No results to display."
|
||||
else maybe displayOnly scratchAndDisplay outputFile
|
||||
where
|
||||
displayOnly = pure code
|
||||
ppeDecl = PPED.unsuffixifiedPPE ppe
|
||||
displayOnly = pure (code (const False))
|
||||
scratchAndDisplay path = do
|
||||
path' <- canonicalizePath path
|
||||
prependToFile code path'
|
||||
pure (message code path')
|
||||
prependToFile (code isTest) path'
|
||||
pure (message (code (const False)) path')
|
||||
where
|
||||
prependToFile code path = do
|
||||
existingContents <- do
|
||||
@ -2071,47 +2072,63 @@ displayDefinitions outputLoc ppe types terms =
|
||||
"You can edit them there, then do" <> makeExample' IP.update
|
||||
<> "to replace the definitions currently in this namespace."
|
||||
]
|
||||
code =
|
||||
P.syntaxToColor $ P.sep "\n\n" (prettyTypes <> prettyTerms)
|
||||
|
||||
code :: (TermReference -> Bool) -> Pretty
|
||||
code isTest =
|
||||
P.syntaxToColor $ P.sep "\n\n" (prettyTypes <> prettyTerms isTest)
|
||||
|
||||
prettyTypes :: [P.Pretty SyntaxText]
|
||||
prettyTypes =
|
||||
types
|
||||
& Map.toList
|
||||
& map (\(ref, dt) -> (PPE.typeName ppeDecl ref, ref, dt))
|
||||
& List.sortBy (\(n0, _, _) (n1, _, _) -> Name.compareAlphabetical n0 n1)
|
||||
& map prettyType
|
||||
|
||||
prettyTerms :: (TermReference -> Bool) -> [P.Pretty SyntaxText]
|
||||
prettyTerms isTest =
|
||||
terms
|
||||
& Map.toList
|
||||
& map (\(ref, dt) -> (PPE.termName ppeDecl (Referent.Ref ref), ref, dt))
|
||||
& List.sortBy (\(n0, _, _) (n1, _, _) -> Name.compareAlphabetical n0 n1)
|
||||
& map (\t -> prettyTerm (isTest (t ^. _2)) t)
|
||||
|
||||
prettyTerm ::
|
||||
Bool ->
|
||||
(HQ.HashQualified Name, Reference, DisplayObject (Type Symbol Ann) (Term Symbol Ann)) ->
|
||||
P.Pretty SyntaxText
|
||||
prettyTerm isTest (n, r, dt) =
|
||||
case dt of
|
||||
MissingObject r -> missing n r
|
||||
BuiltinObject typ ->
|
||||
(if isJust outputFile then P.indent "-- " else id) $
|
||||
P.hang
|
||||
("builtin " <> prettyHashQualified n <> " :")
|
||||
(TypePrinter.prettySyntax (ppeBody n r) typ)
|
||||
UserObject tm ->
|
||||
if isTest
|
||||
then WK.TestWatch <> "> " <> TermPrinter.prettyBindingWithoutTypeSignature (ppeBody n r) n tm
|
||||
else TermPrinter.prettyBinding (ppeBody n r) n tm
|
||||
where
|
||||
ppeBody n r = PPE.biasTo (maybeToList $ HQ.toName n) $ PPE.declarationPPE ppe r
|
||||
ppeDecl = PPED.unsuffixifiedPPE ppe
|
||||
prettyTerms =
|
||||
terms
|
||||
& Map.toList
|
||||
& map (\(ref, dt) -> (PPE.termName ppeDecl (Referent.Ref ref), ref, dt))
|
||||
& List.sortBy (\(n0, _, _) (n1, _, _) -> Name.compareAlphabetical n0 n1)
|
||||
& map go
|
||||
prettyTypes =
|
||||
types
|
||||
& Map.toList
|
||||
& map (\(ref, dt) -> (PPE.typeName ppeDecl ref, ref, dt))
|
||||
& List.sortBy (\(n0, _, _) (n1, _, _) -> Name.compareAlphabetical n0 n1)
|
||||
& map go2
|
||||
go (n, r, dt) =
|
||||
case dt of
|
||||
MissingObject r -> missing n r
|
||||
BuiltinObject typ ->
|
||||
(if isJust outputLoc then P.indent "-- " else id) $
|
||||
P.hang
|
||||
("builtin " <> prettyHashQualified n <> " :")
|
||||
(TypePrinter.prettySyntax (ppeBody n r) typ)
|
||||
UserObject tm -> TermPrinter.prettyBinding (ppeBody n r) n tm
|
||||
go2 (n, r, dt) =
|
||||
case dt of
|
||||
MissingObject r -> missing n r
|
||||
BuiltinObject _ -> builtin n
|
||||
UserObject decl -> DeclPrinter.prettyDecl (PPED.biasTo (maybeToList $ HQ.toName n) $ PPE.declarationPPEDecl ppe r) r n decl
|
||||
builtin n = P.wrap $ "--" <> prettyHashQualified n <> " is built-in."
|
||||
missing n r =
|
||||
P.wrap
|
||||
( "-- The name " <> prettyHashQualified n <> " is assigned to the "
|
||||
<> "reference "
|
||||
<> fromString (show r ++ ",")
|
||||
<> "which is missing from the codebase."
|
||||
)
|
||||
<> P.newline
|
||||
<> tip "You might need to repair the codebase manually."
|
||||
|
||||
prettyType :: (HQ.HashQualified Name, Reference, DisplayObject () (DD.Decl Symbol Ann)) -> P.Pretty SyntaxText
|
||||
prettyType (n, r, dt) =
|
||||
case dt of
|
||||
MissingObject r -> missing n r
|
||||
BuiltinObject _ -> builtin n
|
||||
UserObject decl -> DeclPrinter.prettyDecl (PPED.biasTo (maybeToList $ HQ.toName n) $ PPE.declarationPPEDecl ppe r) r n decl
|
||||
|
||||
builtin n = P.wrap $ "--" <> prettyHashQualified n <> " is built-in."
|
||||
missing n r =
|
||||
P.wrap
|
||||
( "-- The name " <> prettyHashQualified n <> " is assigned to the "
|
||||
<> "reference "
|
||||
<> fromString (show r ++ ",")
|
||||
<> "which is missing from the codebase."
|
||||
)
|
||||
<> P.newline
|
||||
<> tip "You might need to repair the codebase manually."
|
||||
|
||||
displayTestResults ::
|
||||
Bool -> -- whether to show the tip
|
||||
|
@ -26,7 +26,7 @@ import Unison.Codebase.Runtime (Runtime)
|
||||
import qualified Unison.Debug as Debug
|
||||
import Unison.LSP.CancelRequest (cancelRequestHandler)
|
||||
import Unison.LSP.CodeAction (codeActionHandler)
|
||||
import Unison.LSP.Completion (completionHandler)
|
||||
import Unison.LSP.Completion (completionHandler, completionItemResolveHandler)
|
||||
import qualified Unison.LSP.Configuration as Config
|
||||
import qualified Unison.LSP.FileAnalysis as Analysis
|
||||
import Unison.LSP.FoldingRange (foldingRangeRequest)
|
||||
@ -137,6 +137,7 @@ lspRequestHandlers =
|
||||
& SMM.insert STextDocumentCodeAction (mkHandler codeActionHandler)
|
||||
& SMM.insert STextDocumentFoldingRange (mkHandler foldingRangeRequest)
|
||||
& SMM.insert STextDocumentCompletion (mkHandler completionHandler)
|
||||
& SMM.insert SCompletionItemResolve (mkHandler completionItemResolveHandler)
|
||||
where
|
||||
defaultTimeout = 10_000 -- 10s
|
||||
mkHandler ::
|
||||
|
@ -1,12 +1,15 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Unison.LSP.Completion where
|
||||
|
||||
import Control.Comonad.Cofree
|
||||
import Control.Lens hiding (List, (:<))
|
||||
import Control.Monad.Reader
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.Aeson.Types as Aeson
|
||||
import Data.Bifunctor (second)
|
||||
import Data.List.Extra (nubOrdOn)
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
@ -17,6 +20,10 @@ import Language.LSP.Types
|
||||
import Language.LSP.Types.Lens
|
||||
import Unison.Codebase.Path (Path)
|
||||
import qualified Unison.Codebase.Path as Path
|
||||
import qualified Unison.HashQualified as HQ
|
||||
import qualified Unison.HashQualified' as HQ'
|
||||
import Unison.LSP.FileAnalysis
|
||||
import qualified Unison.LSP.Queries as LSPQ
|
||||
import Unison.LSP.Types
|
||||
import qualified Unison.LSP.VFS as VFS
|
||||
import Unison.LabeledDependency (LabeledDependency)
|
||||
@ -29,20 +36,25 @@ import Unison.Names (Names (..))
|
||||
import Unison.Prelude
|
||||
import qualified Unison.PrettyPrintEnv as PPE
|
||||
import qualified Unison.PrettyPrintEnvDecl as PPED
|
||||
import qualified Unison.Reference as Reference
|
||||
import qualified Unison.Referent as Referent
|
||||
import qualified Unison.Syntax.Name as Name (toText)
|
||||
import qualified Unison.Syntax.DeclPrinter as DeclPrinter
|
||||
import qualified Unison.Syntax.HashQualified' as HQ' (toText)
|
||||
import qualified Unison.Syntax.Name as Name (fromText, toText)
|
||||
import qualified Unison.Syntax.TypePrinter as TypePrinter
|
||||
import qualified Unison.Util.Monoid as Monoid
|
||||
import qualified Unison.Util.Pretty as Pretty
|
||||
import qualified Unison.Util.Relation as Relation
|
||||
|
||||
completionHandler :: RequestMessage 'TextDocumentCompletion -> (Either ResponseError (ResponseResult 'TextDocumentCompletion) -> Lsp ()) -> Lsp ()
|
||||
completionHandler m respond =
|
||||
respond . maybe (Right $ InL mempty) (Right . InR) =<< runMaybeT do
|
||||
(range, prefix) <- MaybeT $ VFS.completionPrefix (m ^. params)
|
||||
let fileUri = (m ^. params . textDocument . uri)
|
||||
(range, prefix) <- VFS.completionPrefix (m ^. params)
|
||||
ppe <- PPED.suffixifiedPPE <$> lift globalPPED
|
||||
completions <- lift getCompletions
|
||||
codebaseCompletions <- lift getCodebaseCompletions
|
||||
Config {maxCompletions} <- lift getConfig
|
||||
let defMatches = matchCompletions completions prefix
|
||||
let defMatches = matchCompletions codebaseCompletions prefix
|
||||
let (isIncomplete, defCompletions) =
|
||||
defMatches
|
||||
& nubOrdOn (\(p, _name, ref) -> (p, ref))
|
||||
@ -55,7 +67,7 @@ completionHandler m respond =
|
||||
& mapMaybe \(path, fqn, dep) ->
|
||||
let biasedPPE = PPE.biasTo [fqn] ppe
|
||||
hqName = LD.fold (PPE.types biasedPPE) (PPE.terms biasedPPE) dep
|
||||
in hqName <&> \hqName -> mkDefCompletionItem range (Name.toText fqn) path (HQ'.toText hqName) dep
|
||||
in hqName <&> \hqName -> mkDefCompletionItem fileUri range (HQ'.toName hqName) fqn path (HQ'.toText hqName) dep
|
||||
pure . CompletionList isIncomplete . List $ defCompletionItems
|
||||
where
|
||||
-- Takes at most the specified number of completions, but also indicates with a boolean
|
||||
@ -65,8 +77,8 @@ completionHandler m respond =
|
||||
takeCompletions _ [] = (False, [])
|
||||
takeCompletions n (x : xs) = second (x :) $ takeCompletions (pred n) xs
|
||||
|
||||
mkDefCompletionItem :: Range -> Text -> Text -> Text -> LabeledDependency -> CompletionItem
|
||||
mkDefCompletionItem range fqn path suffixified dep =
|
||||
mkDefCompletionItem :: Uri -> Range -> Name -> Name -> Text -> Text -> LabeledDependency -> CompletionItem
|
||||
mkDefCompletionItem fileUri range relativeName fullyQualifiedName path suffixified dep =
|
||||
CompletionItem
|
||||
{ _label = lbl,
|
||||
_kind = case dep of
|
||||
@ -75,7 +87,7 @@ mkDefCompletionItem range fqn path suffixified dep =
|
||||
Referent.Con {} -> Just CiConstructor
|
||||
Referent.Ref {} -> Just CiValue,
|
||||
_tags = Nothing,
|
||||
_detail = Just fqn,
|
||||
_detail = Just (Name.toText fullyQualifiedName),
|
||||
_documentation = Nothing,
|
||||
_deprecated = Nothing,
|
||||
_preselect = Nothing,
|
||||
@ -88,7 +100,7 @@ mkDefCompletionItem range fqn path suffixified dep =
|
||||
_additionalTextEdits = Nothing,
|
||||
_commitCharacters = Nothing,
|
||||
_command = Nothing,
|
||||
_xdata = Nothing
|
||||
_xdata = Just $ Aeson.toJSON $ CompletionItemDetails {dep, relativeName, fullyQualifiedName, fileUri}
|
||||
}
|
||||
where
|
||||
-- We should generally show the longer of the path or suffixified name in the label,
|
||||
@ -240,3 +252,73 @@ matchCompletions (CompletionTree tree) txt =
|
||||
let childMatches = mkDefMatches rest <&> over _1 (Path.cons ns)
|
||||
let currentMatches = matches <&> \(name, dep) -> (Path.singleton ns, name, dep)
|
||||
currentMatches <> childMatches
|
||||
|
||||
-- | Called to resolve additional details for a completion item that the user is considering.
|
||||
completionItemResolveHandler :: RequestMessage 'CompletionItemResolve -> (Either ResponseError CompletionItem -> Lsp ()) -> Lsp ()
|
||||
completionItemResolveHandler message respond = do
|
||||
let completion :: CompletionItem
|
||||
completion = message ^. params
|
||||
respond . maybe (Right completion) Right =<< runMaybeT do
|
||||
case Aeson.fromJSON <$> (completion ^. xdata) of
|
||||
Just (Aeson.Success (CompletionItemDetails {dep, fullyQualifiedName, relativeName, fileUri})) -> do
|
||||
pped <- lift $ ppedForFile fileUri
|
||||
case dep of
|
||||
LD.TermReferent ref -> do
|
||||
typ <- LSPQ.getTypeOfReferent fileUri ref
|
||||
let renderedType = ": " <> (Text.pack $ TypePrinter.prettyStr (Just typeWidth) (PPED.suffixifiedPPE pped) typ)
|
||||
let doc = CompletionDocMarkup (toUnisonMarkup (Name.toText fullyQualifiedName))
|
||||
pure $ (completion {_detail = Just renderedType, _documentation = Just doc} :: CompletionItem)
|
||||
LD.TypeReference ref ->
|
||||
case ref of
|
||||
Reference.Builtin {} -> do
|
||||
let renderedBuiltin = ": <builtin>"
|
||||
let doc = CompletionDocMarkup (toUnisonMarkup (Name.toText fullyQualifiedName))
|
||||
pure $ (completion {_detail = Just renderedBuiltin, _documentation = Just doc} :: CompletionItem)
|
||||
Reference.DerivedId refId -> do
|
||||
decl <- LSPQ.getTypeDeclaration fileUri refId
|
||||
let renderedDecl = ": " <> (Text.pack . Pretty.toPlain typeWidth . Pretty.syntaxToColor $ DeclPrinter.prettyDecl pped ref (HQ.NameOnly relativeName) decl)
|
||||
let doc = CompletionDocMarkup (toUnisonMarkup (Name.toText fullyQualifiedName))
|
||||
pure $ (completion {_detail = Just renderedDecl, _documentation = Just doc} :: CompletionItem)
|
||||
_ -> empty
|
||||
where
|
||||
toUnisonMarkup txt = MarkupContent {_kind = MkMarkdown, _value = Text.unlines ["```unison", txt, "```"]}
|
||||
-- Completion windows can be very small, so this seems like a good default
|
||||
typeWidth = Pretty.Width 20
|
||||
|
||||
-- | Data which will be provided back to us in the completion resolve handler when the user considers this completion.
|
||||
data CompletionItemDetails = CompletionItemDetails
|
||||
{ dep :: LD.LabeledDependency,
|
||||
relativeName :: Name,
|
||||
fullyQualifiedName :: Name,
|
||||
fileUri :: Uri
|
||||
}
|
||||
|
||||
instance Aeson.ToJSON CompletionItemDetails where
|
||||
toJSON CompletionItemDetails {dep, relativeName, fullyQualifiedName, fileUri} =
|
||||
Aeson.object
|
||||
[ "relativeName" Aeson..= Name.toText relativeName,
|
||||
"fullyQualifiedName" Aeson..= Name.toText fullyQualifiedName,
|
||||
"fileUri" Aeson..= fileUri,
|
||||
"dep" Aeson..= ldJSON dep
|
||||
]
|
||||
where
|
||||
ldJSON :: LD.LabeledDependency -> Aeson.Value
|
||||
ldJSON = \case
|
||||
LD.TypeReference ref -> Aeson.object ["kind" Aeson..= ("type" :: Text), "ref" Aeson..= Reference.toText ref]
|
||||
LD.TermReferent ref -> Aeson.object ["kind" Aeson..= ("term" :: Text), "ref" Aeson..= Referent.toText ref]
|
||||
|
||||
instance Aeson.FromJSON CompletionItemDetails where
|
||||
parseJSON = Aeson.withObject "CompletionItemDetails" \obj -> do
|
||||
dep <- ((obj Aeson..: "dep") >>= ldParser)
|
||||
relativeName <- (obj Aeson..: "relativeName" >>= maybe (fail "Invalid name in CompletionItemDetails") pure . Name.fromText)
|
||||
fullyQualifiedName <- (obj Aeson..: "fullyQualifiedName" >>= maybe (fail "Invalid name in CompletionItemDetails") pure . Name.fromText)
|
||||
fileUri <- obj Aeson..: "fileUri"
|
||||
pure $ CompletionItemDetails {..}
|
||||
where
|
||||
ldParser :: Aeson.Value -> Aeson.Parser LD.LabeledDependency
|
||||
ldParser = Aeson.withObject "LabeledDependency" \obj -> do
|
||||
kind <- obj Aeson..: "kind"
|
||||
case kind of
|
||||
("type" :: Text) -> LD.TypeReference <$> (obj Aeson..: "ref" >>= either (const $ fail "Invalid Reference in LabeledDependency") pure . Reference.fromText)
|
||||
("term" :: Text) -> LD.TermReferent <$> (obj Aeson..: "ref" >>= maybe (fail "Invalid Referent in LabeledDependency") pure . Referent.fromText)
|
||||
_ -> fail "Invalid LabeledDependency kind"
|
||||
|
@ -34,6 +34,7 @@ import Unison.LSP.Diagnostics
|
||||
)
|
||||
import Unison.LSP.Orphans ()
|
||||
import Unison.LSP.Types
|
||||
import qualified Unison.LSP.Types as LSP
|
||||
import qualified Unison.LSP.VFS as VFS
|
||||
import qualified Unison.NamesWithHistory as NamesWithHistory
|
||||
import Unison.Parser.Ann (Ann)
|
||||
@ -47,10 +48,13 @@ import qualified Unison.PrintError as PrintError
|
||||
import Unison.Result (Note)
|
||||
import qualified Unison.Result as Result
|
||||
import Unison.Symbol (Symbol)
|
||||
import qualified Unison.Symbol as Symbol
|
||||
import qualified Unison.Syntax.HashQualified' as HQ' (toText)
|
||||
import qualified Unison.Syntax.Lexer as L
|
||||
import qualified Unison.Syntax.Parser as Parser
|
||||
import qualified Unison.Syntax.TypePrinter as TypePrinter
|
||||
import qualified Unison.Term as Term
|
||||
import Unison.Type (Type)
|
||||
import qualified Unison.Typechecker.Context as Context
|
||||
import qualified Unison.Typechecker.TypeError as TypeError
|
||||
import qualified Unison.UnisonFile as UF
|
||||
@ -58,16 +62,17 @@ import qualified Unison.UnisonFile.Names as UF
|
||||
import Unison.Util.Monoid (foldMapM)
|
||||
import qualified Unison.Util.Pretty as Pretty
|
||||
import qualified Unison.Var as Var
|
||||
import Unison.WatchKind (pattern TestWatch)
|
||||
import UnliftIO (atomically, modifyTVar', readTVar, readTVarIO, writeTVar)
|
||||
|
||||
-- | Lex, parse, and typecheck a file.
|
||||
checkFile :: HasUri d Uri => d -> Lsp (Maybe FileAnalysis)
|
||||
checkFile doc = runMaybeT $ do
|
||||
let fileUri = doc ^. uri
|
||||
(fileVersion, contents) <- MaybeT (VFS.getFileContents doc)
|
||||
(fileVersion, contents) <- VFS.getFileContents fileUri
|
||||
parseNames <- lift getParseNames
|
||||
let sourceName = getUri $ doc ^. uri
|
||||
let lexedSource@(srcText, _) = (contents, L.lexer (Text.unpack sourceName) (Text.unpack contents))
|
||||
let lexedSource@(srcText, _tokens) = (contents, L.lexer (Text.unpack sourceName) (Text.unpack contents))
|
||||
let ambientAbilities = []
|
||||
cb <- asks codebase
|
||||
let generateUniqueName = Parser.uniqueBase32Namegen <$> Random.getSystemDRG
|
||||
@ -77,8 +82,7 @@ checkFile doc = runMaybeT $ do
|
||||
Nothing -> (Nothing, Nothing)
|
||||
Just (Left uf) -> (Just uf, Nothing)
|
||||
Just (Right tf) -> (Just $ UF.discardTypes tf, Just tf)
|
||||
pped <- lift $ ppedForFileHelper parsedFile typecheckedFile
|
||||
(diagnostics, codeActions) <- lift $ analyseFile pped fileUri srcText notes
|
||||
(diagnostics, codeActions) <- lift $ analyseFile fileUri srcText notes
|
||||
let diagnosticRanges =
|
||||
diagnostics
|
||||
& fmap (\d -> (d ^. range, d))
|
||||
@ -87,9 +91,82 @@ checkFile doc = runMaybeT $ do
|
||||
codeActions
|
||||
& foldMap (\(RangedCodeAction {_codeActionRanges, _codeAction}) -> (,_codeAction) <$> _codeActionRanges)
|
||||
& toRangeMap
|
||||
let fileAnalysis = FileAnalysis {diagnostics = diagnosticRanges, codeActions = codeActionRanges, ..}
|
||||
let fileSummary = mkFileSummary parsedFile typecheckedFile
|
||||
let fileAnalysis = FileAnalysis {diagnostics = diagnosticRanges, codeActions = codeActionRanges, fileSummary, ..}
|
||||
pure $ fileAnalysis
|
||||
|
||||
-- | If a symbol is a 'User' symbol, return (Just sym), otherwise return Nothing.
|
||||
assertUserSym :: Symbol -> Maybe Symbol
|
||||
assertUserSym sym = case sym of
|
||||
Symbol.Symbol _ (Var.User {}) -> Just sym
|
||||
_ -> Nothing
|
||||
|
||||
-- | Summarize the information available to us from the current state of the file.
|
||||
-- See 'FileSummary' for more information.
|
||||
mkFileSummary :: Maybe (UF.UnisonFile Symbol Ann) -> Maybe (UF.TypecheckedUnisonFile Symbol Ann) -> Maybe FileSummary
|
||||
mkFileSummary parsed typechecked = case (parsed, typechecked) of
|
||||
(Nothing, Nothing) -> Nothing
|
||||
(_, Just tf@(UF.TypecheckedUnisonFileId {dataDeclarationsId', effectDeclarationsId', hashTermsId})) ->
|
||||
let (trms, testWatches, exprWatches) =
|
||||
hashTermsId & ifoldMap \sym (ref, wk, trm, typ) ->
|
||||
case wk of
|
||||
Nothing -> (Map.singleton sym (Just ref, trm, getUserTypeAnnotation sym <|> Just typ), mempty, mempty)
|
||||
Just TestWatch -> (mempty, [(assertUserSym sym, Just ref, trm, getUserTypeAnnotation sym <|> Just typ)], mempty)
|
||||
Just _ -> (mempty, mempty, [(assertUserSym sym, Just ref, trm, getUserTypeAnnotation sym <|> Just typ)])
|
||||
in Just $
|
||||
FileSummary
|
||||
{ dataDeclsBySymbol = dataDeclarationsId',
|
||||
dataDeclsByReference = declsRefMap dataDeclarationsId',
|
||||
effectDeclsBySymbol = effectDeclarationsId',
|
||||
effectDeclsByReference = declsRefMap effectDeclarationsId',
|
||||
termsBySymbol = trms,
|
||||
termsByReference = termsRefMap trms,
|
||||
testWatchSummary = testWatches,
|
||||
exprWatchSummary = exprWatches,
|
||||
fileNames = UF.typecheckedToNames tf
|
||||
}
|
||||
(Just uf@(UF.UnisonFileId {dataDeclarationsId, effectDeclarationsId, terms, watches}), _) ->
|
||||
let trms =
|
||||
terms & foldMap \(sym, trm) ->
|
||||
(Map.singleton sym (Nothing, trm, Nothing))
|
||||
(testWatches, exprWatches) =
|
||||
watches & ifoldMap \wk tms ->
|
||||
tms & foldMap \(v, trm) ->
|
||||
case wk of
|
||||
TestWatch -> ([(assertUserSym v, Nothing, trm, Nothing)], mempty)
|
||||
_ -> (mempty, [(assertUserSym v, Nothing, trm, Nothing)])
|
||||
in Just $
|
||||
FileSummary
|
||||
{ dataDeclsBySymbol = dataDeclarationsId,
|
||||
dataDeclsByReference = declsRefMap dataDeclarationsId,
|
||||
effectDeclsBySymbol = effectDeclarationsId,
|
||||
effectDeclsByReference = declsRefMap effectDeclarationsId,
|
||||
termsBySymbol = trms,
|
||||
termsByReference = termsRefMap trms,
|
||||
testWatchSummary = testWatches,
|
||||
exprWatchSummary = exprWatches,
|
||||
fileNames = UF.toNames uf
|
||||
}
|
||||
where
|
||||
declsRefMap :: (Ord v, Ord r) => Map v (r, a) -> Map r (Map v a)
|
||||
declsRefMap m =
|
||||
m & Map.toList
|
||||
& fmap (\(v, (r, a)) -> (r, Map.singleton v a))
|
||||
& Map.fromListWith (<>)
|
||||
termsRefMap :: (Ord v, Ord r) => Map v (r, a, b) -> Map r (Map v (a, b))
|
||||
termsRefMap m =
|
||||
m & Map.toList
|
||||
& fmap (\(v, (r, a, b)) -> (r, Map.singleton v (a, b)))
|
||||
& Map.fromListWith (<>)
|
||||
-- Gets the user provided type annotation for a term if there is one.
|
||||
-- This type sig will have Ann's within the file if it exists.
|
||||
getUserTypeAnnotation :: Symbol -> Maybe (Type Symbol Ann)
|
||||
getUserTypeAnnotation v = do
|
||||
UF.UnisonFileId {terms, watches} <- parsed
|
||||
trm <- Prelude.lookup v (terms <> fold watches)
|
||||
typ <- Term.getTypeAnnotation trm
|
||||
pure typ
|
||||
|
||||
fileAnalysisWorker :: Lsp ()
|
||||
fileAnalysisWorker = forever do
|
||||
dirtyFilesV <- asks dirtyFilesVar
|
||||
@ -111,9 +188,10 @@ fileAnalysisWorker = forever do
|
||||
for freshlyCheckedFiles \(FileAnalysis {fileUri, fileVersion, diagnostics}) -> do
|
||||
reportDiagnostics fileUri (Just fileVersion) $ fold diagnostics
|
||||
|
||||
analyseFile :: Foldable f => PPED.PrettyPrintEnvDecl -> Uri -> Text -> f (Note Symbol Ann) -> Lsp ([Diagnostic], [RangedCodeAction])
|
||||
analyseFile ppe fileUri srcText notes = do
|
||||
analyseNotes fileUri (PPED.suffixifiedPPE ppe) (Text.unpack srcText) notes
|
||||
analyseFile :: Foldable f => Uri -> Text -> f (Note Symbol Ann) -> Lsp ([Diagnostic], [RangedCodeAction])
|
||||
analyseFile fileUri srcText notes = do
|
||||
pped <- PPED.suffixifiedPPE <$> LSP.globalPPED
|
||||
analyseNotes fileUri pped (Text.unpack srcText) notes
|
||||
|
||||
analyseNotes :: Foldable f => Uri -> PrettyPrintEnv -> String -> f (Note Symbol Ann) -> Lsp ([Diagnostic], [RangedCodeAction])
|
||||
analyseNotes fileUri ppe src notes = do
|
||||
@ -271,6 +349,11 @@ getFileAnalysis uri = do
|
||||
checkedFiles <- readTVarIO checkedFilesV
|
||||
pure $ Map.lookup uri checkedFiles
|
||||
|
||||
getFileSummary :: Uri -> MaybeT Lsp FileSummary
|
||||
getFileSummary uri = do
|
||||
FileAnalysis {fileSummary} <- MaybeT $ getFileAnalysis uri
|
||||
MaybeT . pure $ fileSummary
|
||||
|
||||
-- TODO memoize per file
|
||||
ppedForFile :: Uri -> Lsp PPED.PrettyPrintEnvDecl
|
||||
ppedForFile fileUri = do
|
||||
|
@ -24,7 +24,7 @@ hoverHandler :: RequestMessage 'TextDocumentHover -> (Either ResponseError (Resp
|
||||
hoverHandler m respond =
|
||||
respond . Right =<< runMaybeT do
|
||||
let p = (m ^. params)
|
||||
txtIdentifier <- MaybeT $ identifierAtPosition p
|
||||
txtIdentifier <- identifierAtPosition p
|
||||
hqIdentifier <- MaybeT . pure $ HQ.fromText txtIdentifier
|
||||
cb <- asks codebase
|
||||
rt <- asks runtime
|
||||
|
@ -5,14 +5,23 @@ module Unison.LSP.Queries
|
||||
findSmallestEnclosingNode,
|
||||
findSmallestEnclosingType,
|
||||
refInDecl,
|
||||
getTypeOfReferent,
|
||||
getTypeDeclaration,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Lens
|
||||
import Control.Monad.Reader
|
||||
import Language.LSP.Types
|
||||
import qualified Unison.ABT as ABT
|
||||
import qualified Unison.Codebase as Codebase
|
||||
import Unison.ConstructorReference (GConstructorReference (..))
|
||||
import qualified Unison.ConstructorType as CT
|
||||
import Unison.DataDeclaration (Decl)
|
||||
import qualified Unison.DataDeclaration as DD
|
||||
import Unison.LSP.FileAnalysis
|
||||
import Unison.LSP.Orphans ()
|
||||
import Unison.LSP.Types
|
||||
import Unison.LabeledDependency
|
||||
import qualified Unison.LabeledDependency as LD
|
||||
import Unison.Lexer.Pos (Pos (..))
|
||||
@ -20,12 +29,52 @@ import Unison.Parser.Ann (Ann)
|
||||
import qualified Unison.Parser.Ann as Ann
|
||||
import Unison.Prelude
|
||||
import Unison.Reference (TypeReference)
|
||||
import qualified Unison.Reference as Reference
|
||||
import Unison.Referent (Referent)
|
||||
import qualified Unison.Referent as Referent
|
||||
import Unison.Symbol (Symbol)
|
||||
import Unison.Term (MatchCase (MatchCase), Term)
|
||||
import qualified Unison.Term as Term
|
||||
import Unison.Type (Type)
|
||||
import qualified Unison.Type as Type
|
||||
|
||||
-- | Gets the type of a reference from either the parsed file or the codebase.
|
||||
getTypeOfReferent :: Uri -> Referent -> MaybeT Lsp (Type Symbol Ann)
|
||||
getTypeOfReferent fileUri ref = do
|
||||
getFromFile <|> getFromCodebase
|
||||
where
|
||||
getFromFile = do
|
||||
FileSummary {termsByReference} <- getFileSummary fileUri
|
||||
case ref of
|
||||
Referent.Ref (Reference.Builtin {}) -> empty
|
||||
Referent.Ref (Reference.DerivedId termRefId) -> do
|
||||
MaybeT . pure $ (termsByReference ^? ix (Just termRefId) . folded . _2 . _Just)
|
||||
Referent.Con (ConstructorReference r0 cid) _type -> do
|
||||
case r0 of
|
||||
Reference.DerivedId r -> do
|
||||
decl <- getTypeDeclaration fileUri r
|
||||
MaybeT . pure $ DD.typeOfConstructor (either DD.toDataDecl id decl) cid
|
||||
Reference.Builtin _ -> empty
|
||||
getFromCodebase = do
|
||||
Env {codebase} <- ask
|
||||
MaybeT . liftIO $ Codebase.runTransaction codebase $ Codebase.getTypeOfReferent codebase ref
|
||||
|
||||
-- | Gets a decl from either the parsed file or the codebase.
|
||||
getTypeDeclaration :: Uri -> Reference.Id -> MaybeT Lsp (Decl Symbol Ann)
|
||||
getTypeDeclaration fileUri refId = do
|
||||
getFromFile <|> getFromCodebase
|
||||
where
|
||||
getFromFile :: MaybeT Lsp (Decl Symbol Ann)
|
||||
getFromFile = do
|
||||
FileSummary {dataDeclsByReference, effectDeclsByReference} <- getFileSummary fileUri
|
||||
let datas = dataDeclsByReference ^.. ix refId . folded
|
||||
let effects = effectDeclsByReference ^.. ix refId . folded
|
||||
MaybeT . pure . listToMaybe $ fmap Right datas <> fmap Left effects
|
||||
|
||||
getFromCodebase = do
|
||||
Env {codebase} <- ask
|
||||
MaybeT . liftIO $ Codebase.runTransaction codebase $ Codebase.getTypeDeclaration codebase refId
|
||||
|
||||
-- | Returns the reference a given term node refers to, if any.
|
||||
refInTerm :: (Term v a -> Maybe LabeledDependency)
|
||||
refInTerm term =
|
||||
|
@ -29,18 +29,23 @@ import Language.LSP.VFS
|
||||
import Unison.Codebase
|
||||
import qualified Unison.Codebase.Path as Path
|
||||
import Unison.Codebase.Runtime (Runtime)
|
||||
import qualified Unison.DataDeclaration as DD
|
||||
import Unison.LSP.Orphans ()
|
||||
import Unison.LabeledDependency (LabeledDependency)
|
||||
import Unison.Name (Name)
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.Names (Names)
|
||||
import Unison.NamesWithHistory (NamesWithHistory)
|
||||
import Unison.Parser.Ann
|
||||
import Unison.Prelude
|
||||
import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl)
|
||||
import qualified Unison.Reference as Reference
|
||||
import Unison.Result (Note)
|
||||
import qualified Unison.Server.Backend as Backend
|
||||
import Unison.Symbol
|
||||
import qualified Unison.Syntax.Lexer as Lexer
|
||||
import Unison.Term (Term)
|
||||
import Unison.Type (Type)
|
||||
import qualified Unison.UnisonFile as UF
|
||||
import UnliftIO
|
||||
|
||||
@ -109,14 +114,34 @@ data FileAnalysis = FileAnalysis
|
||||
typecheckedFile :: Maybe (UF.TypecheckedUnisonFile Symbol Ann),
|
||||
notes :: Seq (Note Symbol Ann),
|
||||
diagnostics :: IntervalMap Position [Diagnostic],
|
||||
codeActions :: IntervalMap Position [CodeAction]
|
||||
codeActions :: IntervalMap Position [CodeAction],
|
||||
fileSummary :: Maybe FileSummary
|
||||
}
|
||||
|
||||
-- | A file that parses might not always type-check, but often we just want to get as much
|
||||
-- information as we have available. This provides a type where we can summarize the
|
||||
-- information available in a Unison file.
|
||||
--
|
||||
-- If the file typechecked then all the Ref Ids and types will be filled in, otherwise
|
||||
-- they will be Nothing.
|
||||
data FileSummary = FileSummary
|
||||
{ dataDeclsBySymbol :: Map Symbol (Reference.Id, DD.DataDeclaration Symbol Ann),
|
||||
dataDeclsByReference :: Map Reference.Id (Map Symbol (DD.DataDeclaration Symbol Ann)),
|
||||
effectDeclsBySymbol :: Map Symbol (Reference.Id, DD.EffectDeclaration Symbol Ann),
|
||||
effectDeclsByReference :: Map Reference.Id (Map Symbol (DD.EffectDeclaration Symbol Ann)),
|
||||
termsBySymbol :: Map Symbol (Maybe Reference.Id, Term Symbol Ann, Maybe (Type Symbol Ann)),
|
||||
termsByReference :: Map (Maybe Reference.Id) (Map Symbol (Term Symbol Ann, Maybe (Type Symbol Ann))),
|
||||
testWatchSummary :: [(Maybe Symbol, Maybe Reference.Id, Term Symbol Ann, Maybe (Type Symbol Ann))],
|
||||
exprWatchSummary :: [(Maybe Symbol, Maybe Reference.Id, Term Symbol Ann, Maybe (Type Symbol Ann))],
|
||||
fileNames :: Names
|
||||
}
|
||||
deriving stock (Show)
|
||||
|
||||
getCurrentPath :: Lsp Path.Absolute
|
||||
getCurrentPath = asks currentPathCache >>= liftIO
|
||||
|
||||
getCompletions :: Lsp CompletionTree
|
||||
getCompletions = asks completionsVar >>= readTVarIO
|
||||
getCodebaseCompletions :: Lsp CompletionTree
|
||||
getCodebaseCompletions = asks completionsVar >>= readTVarIO
|
||||
|
||||
globalPPED :: Lsp PrettyPrintEnvDecl
|
||||
globalPPED = asks ppedCache >>= liftIO
|
||||
|
@ -33,14 +33,14 @@ usingVFS m = do
|
||||
vfsVar' <- asks vfsVar
|
||||
modifyMVar vfsVar' $ \vfs -> swap <$> runStateT m vfs
|
||||
|
||||
getVirtualFile :: (HasUri doc Uri) => doc -> Lsp (Maybe VirtualFile)
|
||||
getVirtualFile p = do
|
||||
getVirtualFile :: Uri -> MaybeT Lsp VirtualFile
|
||||
getVirtualFile fileUri = do
|
||||
vfs <- asks vfsVar >>= readMVar
|
||||
pure $ vfs ^. vfsMap . at (toNormalizedUri $ p ^. uri)
|
||||
MaybeT . pure $ vfs ^. vfsMap . at (toNormalizedUri $ fileUri)
|
||||
|
||||
getFileContents :: (HasUri doc Uri) => doc -> Lsp (Maybe (FileVersion, Text))
|
||||
getFileContents p = runMaybeT $ do
|
||||
vf <- MaybeT $ getVirtualFile p
|
||||
getFileContents :: Uri -> MaybeT Lsp (FileVersion, Text)
|
||||
getFileContents fileUri = do
|
||||
vf <- getVirtualFile fileUri
|
||||
pure (vf ^. lsp_version, Rope.toText $ vf ^. file_text)
|
||||
|
||||
vfsLogger :: Colog.LogAction (StateT VFS Lsp) (Colog.WithSeverity VfsLog)
|
||||
@ -62,14 +62,14 @@ markAllFilesDirty = do
|
||||
markFilesDirty $ Map.keys (vfs ^. vfsMap)
|
||||
|
||||
-- | Returns the name or symbol which the provided position is contained in.
|
||||
identifierAtPosition :: (HasPosition p Position, HasTextDocument p TextDocumentIdentifier) => p -> Lsp (Maybe Text)
|
||||
identifierAtPosition :: (HasPosition p Position, HasTextDocument p TextDocumentIdentifier) => p -> MaybeT Lsp Text
|
||||
identifierAtPosition p = do
|
||||
identifierSplitAtPosition p <&> fmap \(before, after) -> (before <> after)
|
||||
identifierSplitAtPosition p <&> \(before, after) -> (before <> after)
|
||||
|
||||
-- | Returns the prefix and suffix of the symbol which the provided position is contained in.
|
||||
identifierSplitAtPosition :: (HasPosition p Position, HasTextDocument p docId, HasUri docId Uri) => p -> Lsp (Maybe (Text, Text))
|
||||
identifierSplitAtPosition p = runMaybeT $ do
|
||||
vf <- MaybeT (getVirtualFile (p ^. textDocument))
|
||||
identifierSplitAtPosition :: (HasPosition p Position, HasTextDocument p docId, HasUri docId Uri) => p -> MaybeT Lsp (Text, Text)
|
||||
identifierSplitAtPosition p = do
|
||||
vf <- getVirtualFile (p ^. textDocument . uri)
|
||||
PosPrefixInfo {fullLine, cursorPos} <- MaybeT (VFS.getCompletionPrefix (p ^. position) vf)
|
||||
let (before, after) = Text.splitAt (cursorPos ^. character . to fromIntegral) fullLine
|
||||
pure $ (Text.takeWhileEnd isIdentifierChar before, Text.takeWhile isIdentifierChar after)
|
||||
@ -83,9 +83,9 @@ identifierSplitAtPosition p = runMaybeT $ do
|
||||
|
||||
-- | Returns the prefix of the symbol at the provided location, and the range that prefix
|
||||
-- spans.
|
||||
completionPrefix :: (HasPosition p Position, HasTextDocument p docId, HasUri docId Uri) => p -> Lsp (Maybe (Range, Text))
|
||||
completionPrefix p = runMaybeT $ do
|
||||
(before, _) <- MaybeT $ identifierSplitAtPosition p
|
||||
completionPrefix :: (HasPosition p Position, HasTextDocument p docId, HasUri docId Uri) => p -> MaybeT Lsp (Range, Text)
|
||||
completionPrefix p = do
|
||||
(before, _) <- identifierSplitAtPosition p
|
||||
let posLine = p ^. position . LSP.line
|
||||
let posChar = (p ^. position . LSP.character)
|
||||
let range = mkRange posLine (posChar - fromIntegral (Text.length before)) posLine posChar
|
||||
|
@ -2,9 +2,7 @@
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module Unison.Share.Sync
|
||||
( -- * High-level API
|
||||
|
||||
-- ** Get causal hash by path
|
||||
( -- ** Get causal hash by path
|
||||
getCausalHashByPath,
|
||||
GetCausalHashByPathError (..),
|
||||
|
||||
@ -22,6 +20,7 @@ where
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Reader (ask)
|
||||
import Control.Monad.Trans.Reader (ReaderT, runReaderT)
|
||||
import qualified Control.Monad.Trans.Reader as Reader
|
||||
import qualified Data.Foldable as Foldable (find)
|
||||
@ -51,6 +50,9 @@ import qualified U.Codebase.Sqlite.Queries as Q
|
||||
import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle)
|
||||
import Unison.Auth.HTTPClient (AuthenticatedHttpClient)
|
||||
import qualified Unison.Auth.HTTPClient as Auth
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import qualified Unison.Cli.Monad as Cli
|
||||
import qualified Unison.Codebase as Codebase
|
||||
import qualified Unison.Debug as Debug
|
||||
import Unison.Hash32 (Hash32)
|
||||
import Unison.Prelude
|
||||
@ -60,8 +62,6 @@ import qualified Unison.Sync.API as Share (API)
|
||||
import Unison.Sync.Common (causalHashToHash32, entityToTempEntity, expectEntity, hash32ToCausalHash)
|
||||
import qualified Unison.Sync.Types as Share
|
||||
import Unison.Util.Monoid (foldMapM)
|
||||
import qualified UnliftIO
|
||||
import UnliftIO.Exception (throwIO)
|
||||
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Pile of constants
|
||||
@ -83,12 +83,8 @@ maxSimultaneousPushWorkers = 5
|
||||
-- This flavor of push takes the expected state of the server, and the desired state we want to set; if our expectation
|
||||
-- is off, we won't proceed with the push.
|
||||
checkAndSetPush ::
|
||||
-- | The HTTP client to use for Unison Share requests.
|
||||
AuthenticatedHttpClient ->
|
||||
-- | The Unison Share URL.
|
||||
BaseUrl ->
|
||||
-- | SQLite-connection-making function, for writing entities we pull.
|
||||
(forall a. (Sqlite.Connection -> IO a) -> IO a) ->
|
||||
-- | The repo+path to push to.
|
||||
Share.Path ->
|
||||
-- | The hash that we expect this repo+path to be at on Unison Share. If not, we'll get back a hash mismatch error.
|
||||
@ -98,42 +94,54 @@ checkAndSetPush ::
|
||||
CausalHash ->
|
||||
-- | Callback that's given a number of entities we just uploaded.
|
||||
(Int -> IO ()) ->
|
||||
IO (Either (SyncError CheckAndSetPushError) ())
|
||||
checkAndSetPush httpClient unisonShareUrl connect path expectedHash causalHash uploadedCallback = catchSyncErrors do
|
||||
-- Maybe the server already has this causal; try just setting its remote path. Commonly, it will respond that it needs
|
||||
-- this causal (UpdatePathMissingDependencies).
|
||||
updatePath >>= \case
|
||||
Share.UpdatePathSuccess -> pure (Right ())
|
||||
Share.UpdatePathHashMismatch mismatch -> pure (Left (CheckAndSetPushErrorHashMismatch mismatch))
|
||||
Share.UpdatePathMissingDependencies (Share.NeedDependencies dependencies) -> do
|
||||
-- Upload the causal and all of its dependencies.
|
||||
uploadEntities httpClient unisonShareUrl connect (Share.pathRepoName path) dependencies uploadedCallback >>= \case
|
||||
False -> pure (Left (CheckAndSetPushErrorNoWritePermission path))
|
||||
True ->
|
||||
-- After uploading the causal and all of its dependencies, try setting the remote path again.
|
||||
updatePath <&> \case
|
||||
Share.UpdatePathSuccess -> Right ()
|
||||
-- Between the initial updatePath attempt and this one, someone else managed to update the path. That's ok;
|
||||
-- we still managed to upload our causal, but the push has indeed failed overall.
|
||||
Share.UpdatePathHashMismatch mismatch -> Left (CheckAndSetPushErrorHashMismatch mismatch)
|
||||
-- Unexpected, but possible: we thought we uploaded all we needed to, yet the server still won't accept our
|
||||
-- causal. Bug in the client because we didn't upload enough? Bug in the server because we weren't told to
|
||||
-- upload some dependency? Who knows.
|
||||
Share.UpdatePathMissingDependencies (Share.NeedDependencies dependencies) ->
|
||||
Left (CheckAndSetPushErrorServerMissingDependencies dependencies)
|
||||
Share.UpdatePathNoWritePermission _ -> Left (CheckAndSetPushErrorNoWritePermission path)
|
||||
Share.UpdatePathNoWritePermission _ -> pure (Left (CheckAndSetPushErrorNoWritePermission path))
|
||||
where
|
||||
updatePath :: IO Share.UpdatePathResponse
|
||||
updatePath =
|
||||
httpUpdatePath
|
||||
httpClient
|
||||
unisonShareUrl
|
||||
Share.UpdatePathRequest
|
||||
{ path,
|
||||
expectedHash,
|
||||
newHash = causalHashToHash32 causalHash
|
||||
}
|
||||
Cli (Either (SyncError CheckAndSetPushError) ())
|
||||
checkAndSetPush unisonShareUrl path expectedHash causalHash uploadedCallback = do
|
||||
Cli.Env {authHTTPClient} <- ask
|
||||
|
||||
Cli.label \done -> do
|
||||
let failed :: SyncError CheckAndSetPushError -> Cli void
|
||||
failed = done . Left
|
||||
|
||||
let updatePath :: Cli Share.UpdatePathResponse
|
||||
updatePath = do
|
||||
liftIO request & onLeftM \err -> failed (TransportError err)
|
||||
where
|
||||
request :: IO (Either CodeserverTransportError Share.UpdatePathResponse)
|
||||
request =
|
||||
httpUpdatePath
|
||||
authHTTPClient
|
||||
unisonShareUrl
|
||||
Share.UpdatePathRequest
|
||||
{ path,
|
||||
expectedHash,
|
||||
newHash = causalHashToHash32 causalHash
|
||||
}
|
||||
|
||||
-- Maybe the server already has this causal; try just setting its remote path. Commonly, it will respond that it
|
||||
-- needs this causal (UpdatePathMissingDependencies).
|
||||
updatePath >>= \case
|
||||
Share.UpdatePathSuccess -> pure (Right ())
|
||||
Share.UpdatePathHashMismatch mismatch -> pure (Left (SyncError (CheckAndSetPushErrorHashMismatch mismatch)))
|
||||
Share.UpdatePathMissingDependencies (Share.NeedDependencies dependencies) -> do
|
||||
-- Upload the causal and all of its dependencies.
|
||||
uploadEntities unisonShareUrl (Share.pathRepoName path) dependencies uploadedCallback & onLeftM \err ->
|
||||
failed $
|
||||
err <&> \case
|
||||
UploadEntitiesNoWritePermission -> CheckAndSetPushErrorNoWritePermission path
|
||||
|
||||
-- After uploading the causal and all of its dependencies, try setting the remote path again.
|
||||
updatePath >>= \case
|
||||
Share.UpdatePathSuccess -> pure (Right ())
|
||||
-- Between the initial updatePath attempt and this one, someone else managed to update the path. That's ok;
|
||||
-- we still managed to upload our causal, but the push has indeed failed overall.
|
||||
Share.UpdatePathHashMismatch mismatch -> failed (SyncError (CheckAndSetPushErrorHashMismatch mismatch))
|
||||
-- Unexpected, but possible: we thought we uploaded all we needed to, yet the server still won't accept our
|
||||
-- causal. Bug in the client because we didn't upload enough? Bug in the server because we weren't told to
|
||||
-- upload some dependency? Who knows.
|
||||
Share.UpdatePathMissingDependencies (Share.NeedDependencies dependencies) ->
|
||||
failed (SyncError (CheckAndSetPushErrorServerMissingDependencies dependencies))
|
||||
Share.UpdatePathNoWritePermission _ -> failed (SyncError (CheckAndSetPushErrorNoWritePermission path))
|
||||
Share.UpdatePathNoWritePermission _ -> failed (SyncError (CheckAndSetPushErrorNoWritePermission path))
|
||||
|
||||
-- | Perform a fast-forward push (initially of just a causal hash, but ultimately all of its dependencies that the
|
||||
-- server is missing, too) to Unison Share.
|
||||
@ -141,86 +149,105 @@ checkAndSetPush httpClient unisonShareUrl connect path expectedHash causalHash u
|
||||
-- This flavor of push provides the server with a chain of causal hashes leading from its current state to our desired
|
||||
-- state.
|
||||
fastForwardPush ::
|
||||
-- | The HTTP client to use for Unison Share requests.
|
||||
AuthenticatedHttpClient ->
|
||||
-- | The Unison Share URL.
|
||||
BaseUrl ->
|
||||
-- | SQLite-connection-making function, for writing entities we pull.
|
||||
(forall a. (Sqlite.Connection -> IO a) -> IO a) ->
|
||||
-- | The repo+path to push to.
|
||||
Share.Path ->
|
||||
-- | The hash of our local causal to push.
|
||||
CausalHash ->
|
||||
-- | Callback that's given a number of entities we just uploaded.
|
||||
(Int -> IO ()) ->
|
||||
IO (Either (SyncError FastForwardPushError) ())
|
||||
fastForwardPush httpClient unisonShareUrl connect path localHeadHash uploadedCallback = catchSyncErrors do
|
||||
getCausalHashByPath httpClient unisonShareUrl path >>= \case
|
||||
Left (GetCausalHashByPathErrorNoReadPermission _) -> pure (Left (FastForwardPushErrorNoReadPermission path))
|
||||
Right Nothing -> pure (Left (FastForwardPushErrorNoHistory path))
|
||||
Right (Just (Share.hashJWTHash -> remoteHeadHash)) -> do
|
||||
let doLoadCausalSpineBetween = do
|
||||
-- (Temporary?) optimization - perform the "is ancestor?" check within sqlite before reconstructing the
|
||||
-- actual path.
|
||||
let isBefore :: Sqlite.Transaction Bool
|
||||
isBefore = do
|
||||
maybeHashIds <-
|
||||
runMaybeT $
|
||||
(,)
|
||||
<$> MaybeT (Q.loadCausalHashIdByCausalHash (hash32ToCausalHash remoteHeadHash))
|
||||
<*> MaybeT (Q.loadCausalHashIdByCausalHash localHeadHash)
|
||||
case maybeHashIds of
|
||||
Nothing -> pure False
|
||||
Just (remoteHeadHashId, localHeadHashId) -> Q.before remoteHeadHashId localHeadHashId
|
||||
isBefore >>= \case
|
||||
False -> pure Nothing
|
||||
True -> loadCausalSpineBetween remoteHeadHash (causalHashToHash32 localHeadHash)
|
||||
(connect \conn -> Sqlite.runTransaction conn doLoadCausalSpineBetween) >>= \case
|
||||
Cli (Either (SyncError FastForwardPushError) ())
|
||||
fastForwardPush unisonShareUrl path localHeadHash uploadedCallback = do
|
||||
Cli.label \done -> do
|
||||
let succeeded :: Cli void
|
||||
succeeded =
|
||||
done (Right ())
|
||||
|
||||
let failed :: SyncError FastForwardPushError -> Cli void
|
||||
failed = done . Left
|
||||
|
||||
remoteHeadHash <-
|
||||
getCausalHashByPath unisonShareUrl path >>= \case
|
||||
Left (TransportError err) -> failed (TransportError err)
|
||||
Left (SyncError (GetCausalHashByPathErrorNoReadPermission _)) ->
|
||||
failed (SyncError (FastForwardPushErrorNoReadPermission path))
|
||||
Right Nothing -> failed (SyncError (FastForwardPushErrorNoHistory path))
|
||||
Right (Just remoteHeadHash) -> pure (Share.hashJWTHash remoteHeadHash)
|
||||
|
||||
let doLoadCausalSpineBetween = do
|
||||
-- (Temporary?) optimization - perform the "is ancestor?" check within sqlite before reconstructing the
|
||||
-- actual path.
|
||||
let isBefore :: Sqlite.Transaction Bool
|
||||
isBefore = do
|
||||
maybeHashIds <-
|
||||
runMaybeT $
|
||||
(,)
|
||||
<$> MaybeT (Q.loadCausalHashIdByCausalHash (hash32ToCausalHash remoteHeadHash))
|
||||
<*> MaybeT (Q.loadCausalHashIdByCausalHash localHeadHash)
|
||||
case maybeHashIds of
|
||||
Nothing -> pure False
|
||||
Just (remoteHeadHashId, localHeadHashId) -> Q.before remoteHeadHashId localHeadHashId
|
||||
isBefore >>= \case
|
||||
False -> pure Nothing
|
||||
True -> loadCausalSpineBetween remoteHeadHash (causalHashToHash32 localHeadHash)
|
||||
|
||||
let doUpload :: List.NonEmpty CausalHash -> Cli ()
|
||||
-- Maybe we could save round trips here by including the tail (or the head *and* the tail) as "extra hashes",
|
||||
-- but we don't have that API yet. So, we only upload the head causal entity (which we don't even know for sure
|
||||
-- the server doesn't have yet), and will (eventually) end up uploading the casuals in the tail that the server
|
||||
-- needs.
|
||||
doUpload (headHash :| _tailHashes) = do
|
||||
request & onLeftM \err ->
|
||||
failed $
|
||||
err <&> \case
|
||||
UploadEntitiesNoWritePermission -> (FastForwardPushErrorNoWritePermission path)
|
||||
where
|
||||
request =
|
||||
uploadEntities
|
||||
unisonShareUrl
|
||||
(Share.pathRepoName path)
|
||||
(NESet.singleton (causalHashToHash32 headHash))
|
||||
uploadedCallback
|
||||
|
||||
localInnerHashes <-
|
||||
Cli.runTransaction doLoadCausalSpineBetween >>= \case
|
||||
-- After getting the remote causal hash, we can tell from a local computation that this wouldn't be a
|
||||
-- fast-forward push, so we don't bother trying - just report the error now.
|
||||
Nothing -> pure (Left (FastForwardPushErrorNotFastForward path))
|
||||
Nothing -> failed (SyncError (FastForwardPushErrorNotFastForward path))
|
||||
-- The path from remote-to-local, excluding local, was empty. So, remote == local; there's nothing to push.
|
||||
Just [] -> pure (Right ())
|
||||
Just (_ : localInnerHashes0) -> do
|
||||
-- drop remote hash
|
||||
let localInnerHashes = map hash32ToCausalHash localInnerHashes0
|
||||
doUpload (localHeadHash :| localInnerHashes) >>= \case
|
||||
False -> pure (Left (FastForwardPushErrorNoWritePermission path))
|
||||
True -> do
|
||||
let doFastForwardPath =
|
||||
httpFastForwardPath
|
||||
httpClient
|
||||
unisonShareUrl
|
||||
Share.FastForwardPathRequest
|
||||
{ expectedHash = remoteHeadHash,
|
||||
hashes =
|
||||
causalHashToHash32 <$> List.NonEmpty.fromList (localInnerHashes ++ [localHeadHash]),
|
||||
path
|
||||
}
|
||||
doFastForwardPath <&> \case
|
||||
Share.FastForwardPathSuccess -> Right ()
|
||||
Share.FastForwardPathMissingDependencies (Share.NeedDependencies dependencies) ->
|
||||
Left (FastForwardPushErrorServerMissingDependencies dependencies)
|
||||
-- Weird: someone must have force-pushed no history here, or something. We observed a history at
|
||||
-- this path but moments ago!
|
||||
Share.FastForwardPathNoHistory -> Left (FastForwardPushErrorNoHistory path)
|
||||
Share.FastForwardPathNoWritePermission _ -> Left (FastForwardPushErrorNoWritePermission path)
|
||||
Share.FastForwardPathNotFastForward _ -> Left (FastForwardPushErrorNotFastForward path)
|
||||
Share.FastForwardPathInvalidParentage (Share.InvalidParentage parent child) ->
|
||||
Left (FastForwardPushInvalidParentage parent child)
|
||||
where
|
||||
doUpload :: List.NonEmpty CausalHash -> IO Bool
|
||||
-- Maybe we could save round trips here by including the tail (or the head *and* the tail) as "extra hashes", but we
|
||||
-- don't have that API yet. So, we only upload the head causal entity (which we don't even know for sure the server
|
||||
-- doesn't have yet), and will (eventually) end up uploading the casuals in the tail that the server needs.
|
||||
doUpload (headHash :| _tailHashes) =
|
||||
uploadEntities
|
||||
httpClient
|
||||
unisonShareUrl
|
||||
connect
|
||||
(Share.pathRepoName path)
|
||||
(NESet.singleton (causalHashToHash32 headHash))
|
||||
uploadedCallback
|
||||
Just [] -> succeeded
|
||||
-- drop remote hash
|
||||
Just (_ : localInnerHashes) -> pure (map hash32ToCausalHash localInnerHashes)
|
||||
|
||||
doUpload (localHeadHash :| localInnerHashes)
|
||||
|
||||
let doFastForwardPath :: Cli Share.FastForwardPathResponse
|
||||
doFastForwardPath = do
|
||||
Cli.Env {authHTTPClient} <- ask
|
||||
let request =
|
||||
httpFastForwardPath
|
||||
authHTTPClient
|
||||
unisonShareUrl
|
||||
Share.FastForwardPathRequest
|
||||
{ expectedHash = remoteHeadHash,
|
||||
hashes =
|
||||
causalHashToHash32 <$> List.NonEmpty.fromList (localInnerHashes ++ [localHeadHash]),
|
||||
path
|
||||
}
|
||||
liftIO request & onLeftM \err -> failed (TransportError err)
|
||||
|
||||
doFastForwardPath >>= \case
|
||||
Share.FastForwardPathSuccess -> succeeded
|
||||
Share.FastForwardPathMissingDependencies (Share.NeedDependencies dependencies) ->
|
||||
failed (SyncError (FastForwardPushErrorServerMissingDependencies dependencies))
|
||||
-- Weird: someone must have force-pushed no history here, or something. We observed a history at
|
||||
-- this path but moments ago!
|
||||
Share.FastForwardPathNoHistory -> failed (SyncError (FastForwardPushErrorNoHistory path))
|
||||
Share.FastForwardPathNoWritePermission _ -> failed (SyncError (FastForwardPushErrorNoWritePermission path))
|
||||
Share.FastForwardPathNotFastForward _ -> failed (SyncError (FastForwardPushErrorNotFastForward path))
|
||||
Share.FastForwardPathInvalidParentage (Share.InvalidParentage parent child) ->
|
||||
failed (SyncError (FastForwardPushInvalidParentage parent child))
|
||||
|
||||
-- Return a list (in oldest-to-newest order) of hashes along the causal spine that connects the given arguments,
|
||||
-- excluding the newest hash (second argument).
|
||||
@ -356,55 +383,82 @@ dagbfs goal children =
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Pull
|
||||
|
||||
data DownloadEntitiesError
|
||||
= DownloadEntitiesNoReadPermission
|
||||
|
||||
pull ::
|
||||
-- | The HTTP client to use for Unison Share requests.
|
||||
AuthenticatedHttpClient ->
|
||||
-- | The Unison Share URL.
|
||||
BaseUrl ->
|
||||
-- | SQLite-connection-making function, for writing entities we pull.
|
||||
(forall a. (Sqlite.Connection -> IO a) -> IO a) ->
|
||||
-- | The repo+path to pull from.
|
||||
Share.Path ->
|
||||
-- | Callback that's given a number of entities we just downloaded.
|
||||
(Int -> IO ()) ->
|
||||
IO (Either (SyncError PullError) CausalHash)
|
||||
pull httpClient unisonShareUrl connect repoPath downloadedCallback = catchSyncErrors do
|
||||
getCausalHashByPath httpClient unisonShareUrl repoPath >>= \case
|
||||
Left err -> pure (Left (PullErrorGetCausalHashByPath err))
|
||||
-- There's nothing at the remote path, so there's no causal to pull.
|
||||
Right Nothing -> pure (Left (PullErrorNoHistoryAtPath repoPath))
|
||||
Right (Just hashJwt) -> do
|
||||
let hash = Share.hashJWTHash hashJwt
|
||||
maybeTempEntities <-
|
||||
connect \conn ->
|
||||
Sqlite.runTransaction conn (Q.entityLocation hash) >>= \case
|
||||
Just Q.EntityInMainStorage -> pure Nothing
|
||||
Just Q.EntityInTempStorage -> pure (Just (NESet.singleton hash))
|
||||
Nothing -> do
|
||||
Share.DownloadEntitiesSuccess entities <-
|
||||
Cli (Either (SyncError PullError) CausalHash)
|
||||
pull unisonShareUrl repoPath downloadedCallback = do
|
||||
Cli.Env {authHTTPClient, codebase} <- ask
|
||||
|
||||
Cli.label \done -> do
|
||||
let failed :: SyncError PullError -> Cli void
|
||||
failed = done . Left
|
||||
|
||||
hashJwt <-
|
||||
getCausalHashByPath unisonShareUrl repoPath >>= \case
|
||||
Left err -> failed (getCausalHashByPathErrorToPullError <$> err)
|
||||
-- There's nothing at the remote path, so there's no causal to pull.
|
||||
Right Nothing -> failed (SyncError (PullErrorNoHistoryAtPath repoPath))
|
||||
Right (Just hashJwt) -> pure hashJwt
|
||||
|
||||
let hash = Share.hashJWTHash hashJwt
|
||||
|
||||
maybeTempEntities <-
|
||||
Cli.runTransaction (Q.entityLocation hash) >>= \case
|
||||
Just Q.EntityInMainStorage -> pure Nothing
|
||||
Just Q.EntityInTempStorage -> pure (Just (NESet.singleton hash))
|
||||
Nothing -> do
|
||||
let request =
|
||||
httpDownloadEntities
|
||||
httpClient
|
||||
authHTTPClient
|
||||
unisonShareUrl
|
||||
Share.DownloadEntitiesRequest {repoName, hashes = NESet.singleton hashJwt}
|
||||
tempEntities <- insertEntities conn entities
|
||||
downloadedCallback 1
|
||||
pure (NESet.nonEmptySet tempEntities)
|
||||
whenJust maybeTempEntities \tempEntities ->
|
||||
completeTempEntities
|
||||
httpClient
|
||||
unisonShareUrl
|
||||
connect
|
||||
repoName
|
||||
downloadedCallback
|
||||
tempEntities
|
||||
-- Since we may have just inserted and then deleted many temp entities, we attempt to recover some disk space by
|
||||
-- vacuuming after each pull. If the vacuum fails due to another open transaction on this connection, that's ok,
|
||||
-- we'll try vacuuming again next pull.
|
||||
_success <- connect Sqlite.vacuum
|
||||
pure (Right (hash32ToCausalHash hash))
|
||||
entities <-
|
||||
liftIO request >>= \case
|
||||
Left err -> failed (TransportError err)
|
||||
Right (Share.DownloadEntitiesNoReadPermission _) ->
|
||||
failed (SyncError (PullErrorNoReadPermission repoPath))
|
||||
Right (Share.DownloadEntitiesSuccess entities) -> pure entities
|
||||
tempEntities <- Cli.runTransaction (insertEntities entities)
|
||||
liftIO (downloadedCallback 1)
|
||||
pure (NESet.nonEmptySet tempEntities)
|
||||
|
||||
whenJust maybeTempEntities \tempEntities -> do
|
||||
let doCompleteTempEntities =
|
||||
completeTempEntities
|
||||
authHTTPClient
|
||||
unisonShareUrl
|
||||
( \action ->
|
||||
Codebase.withConnection codebase \conn ->
|
||||
action (Sqlite.runTransaction conn)
|
||||
)
|
||||
repoName
|
||||
downloadedCallback
|
||||
tempEntities
|
||||
liftIO doCompleteTempEntities & onLeftM \err ->
|
||||
failed $
|
||||
err <&> \case
|
||||
DownloadEntitiesNoReadPermission -> PullErrorNoReadPermission repoPath
|
||||
|
||||
-- Since we may have just inserted and then deleted many temp entities, we attempt to recover some disk space by
|
||||
-- vacuuming after each pull. If the vacuum fails due to another open transaction on this connection, that's ok,
|
||||
-- we'll try vacuuming again next pull.
|
||||
_success <- liftIO (Codebase.withConnection codebase Sqlite.vacuum)
|
||||
pure (Right (hash32ToCausalHash hash))
|
||||
where
|
||||
repoName = Share.pathRepoName repoPath
|
||||
|
||||
getCausalHashByPathErrorToPullError :: GetCausalHashByPathError -> PullError
|
||||
getCausalHashByPathErrorToPullError = \case
|
||||
GetCausalHashByPathErrorNoReadPermission path -> PullErrorNoReadPermission path
|
||||
|
||||
type WorkerCount =
|
||||
TVar Int
|
||||
|
||||
@ -423,20 +477,21 @@ recordNotWorking sem =
|
||||
-- What the dispatcher is to do
|
||||
data DispatcherJob
|
||||
= DispatcherForkWorker (NESet Share.HashJWT)
|
||||
| DispatcherReturnEarlyBecauseDownloaderFailed (SyncError DownloadEntitiesError)
|
||||
| DispatcherDone
|
||||
|
||||
-- | Finish downloading entities from Unison Share. Returns the total number of entities downloaded.
|
||||
-- | Finish downloading entities from Unison Share (or return the first failure to download something).
|
||||
--
|
||||
-- Precondition: the entities were *already* downloaded at some point in the past, and are now sitting in the
|
||||
-- `temp_entity` table, waiting for their dependencies to arrive so they can be flushed to main storage.
|
||||
completeTempEntities ::
|
||||
AuthenticatedHttpClient ->
|
||||
BaseUrl ->
|
||||
(forall a. (Sqlite.Connection -> IO a) -> IO a) ->
|
||||
(forall a. ((forall x. Sqlite.Transaction x -> IO x) -> IO a) -> IO a) ->
|
||||
Share.RepoName ->
|
||||
(Int -> IO ()) ->
|
||||
NESet Hash32 ->
|
||||
IO ()
|
||||
IO (Either (SyncError DownloadEntitiesError) ())
|
||||
completeTempEntities httpClient unisonShareUrl connect repoName downloadedCallback initialNewTempEntities = do
|
||||
-- The set of hashes we still need to download
|
||||
hashesVar <- newTVarIO Set.empty
|
||||
@ -453,34 +508,43 @@ completeTempEntities httpClient unisonShareUrl connect repoName downloadedCallba
|
||||
-- How many workers (downloader / inserter / elaborator) are currently doing stuff.
|
||||
workerCount <- newWorkerCount
|
||||
|
||||
-- The first download error seen by a downloader, if any.
|
||||
downloaderFailedVar <- newEmptyTMVarIO
|
||||
|
||||
-- Kick off the cycle of inserter->elaborator->dispatcher->downloader by giving the elaborator something to do
|
||||
atomically (writeTQueue newTempEntitiesQueue (Set.empty, Just initialNewTempEntities))
|
||||
|
||||
Ki.scoped \scope -> do
|
||||
Ki.fork_ scope (inserter entitiesQueue newTempEntitiesQueue workerCount)
|
||||
Ki.fork_ scope (elaborator hashesVar uninsertedHashesVar newTempEntitiesQueue workerCount)
|
||||
dispatcher hashesVar uninsertedHashesVar entitiesQueue newTempEntitiesQueue workerCount
|
||||
dispatcher hashesVar uninsertedHashesVar entitiesQueue newTempEntitiesQueue workerCount downloaderFailedVar
|
||||
where
|
||||
-- Dispatcher thread: "dequeue" from `hashesVar`, fork one-shot downloaders.
|
||||
--
|
||||
-- We stop when all of the following are true:
|
||||
-- We stop when either all of the following are true:
|
||||
--
|
||||
-- - There are no outstanding workers (downloaders, inserter, elaboraror)
|
||||
-- - The inserter thread doesn't have any outstanding work enqueued (in `entitiesQueue`)
|
||||
-- - The elaborator thread doesn't have any outstanding work enqueued (in `newTempEntitiesQueue`)
|
||||
--
|
||||
-- Or:
|
||||
--
|
||||
-- - Some downloader failed to download something
|
||||
dispatcher ::
|
||||
TVar (Set Share.HashJWT) ->
|
||||
TVar (Set Share.HashJWT) ->
|
||||
TQueue (NESet Share.HashJWT, NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT)) ->
|
||||
TQueue (Set Share.HashJWT, Maybe (NESet Hash32)) ->
|
||||
WorkerCount ->
|
||||
IO ()
|
||||
dispatcher hashesVar uninsertedHashesVar entitiesQueue newTempEntitiesQueue workerCount =
|
||||
TMVar (SyncError DownloadEntitiesError) ->
|
||||
IO (Either (SyncError DownloadEntitiesError) ())
|
||||
dispatcher hashesVar uninsertedHashesVar entitiesQueue newTempEntitiesQueue workerCount downloaderFailedVar =
|
||||
Ki.scoped \scope ->
|
||||
let loop :: IO ()
|
||||
let loop :: IO (Either (SyncError DownloadEntitiesError) ())
|
||||
loop =
|
||||
atomically (dispatchWorkMode <|> checkIfDoneMode) >>= \case
|
||||
DispatcherDone -> pure ()
|
||||
atomically (checkIfDownloaderFailedMode <|> dispatchWorkMode <|> checkIfDoneMode) >>= \case
|
||||
DispatcherDone -> pure (Right ())
|
||||
DispatcherReturnEarlyBecauseDownloaderFailed err -> pure (Left err)
|
||||
DispatcherForkWorker hashes -> do
|
||||
atomically do
|
||||
-- Limit number of simultaneous downloaders (plus 2, for inserter and elaborator)
|
||||
@ -491,10 +555,17 @@ completeTempEntities httpClient unisonShareUrl connect repoName downloadedCallba
|
||||
-- nothing more for the dispatcher to do, when in fact a downloader thread just hasn't made it as
|
||||
-- far as recording its own existence
|
||||
recordWorking workerCount
|
||||
_ <- Ki.fork @() scope (downloader entitiesQueue workerCount hashes)
|
||||
_ <-
|
||||
Ki.fork @() scope do
|
||||
downloader entitiesQueue workerCount hashes & onLeftM \err ->
|
||||
void (atomically (tryPutTMVar downloaderFailedVar err))
|
||||
loop
|
||||
in loop
|
||||
where
|
||||
checkIfDownloaderFailedMode :: STM DispatcherJob
|
||||
checkIfDownloaderFailedMode =
|
||||
DispatcherReturnEarlyBecauseDownloaderFailed <$> readTMVar downloaderFailedVar
|
||||
|
||||
dispatchWorkMode :: STM DispatcherJob
|
||||
dispatchWorkMode = do
|
||||
hashes <- readTVar hashesVar
|
||||
@ -513,22 +584,26 @@ completeTempEntities httpClient unisonShareUrl connect repoName downloadedCallba
|
||||
isEmptyTQueue newTempEntitiesQueue >>= check
|
||||
pure DispatcherDone
|
||||
|
||||
-- Downloader thread: download entities, enqueue to `entitiesQueue`
|
||||
-- Downloader thread: download entities, (if successful) enqueue to `entitiesQueue`
|
||||
downloader ::
|
||||
TQueue (NESet Share.HashJWT, NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT)) ->
|
||||
WorkerCount ->
|
||||
NESet Share.HashJWT ->
|
||||
IO ()
|
||||
IO (Either (SyncError DownloadEntitiesError) ())
|
||||
downloader entitiesQueue workerCount hashes = do
|
||||
Share.DownloadEntitiesSuccess entities <-
|
||||
httpDownloadEntities
|
||||
httpClient
|
||||
unisonShareUrl
|
||||
Share.DownloadEntitiesRequest {repoName, hashes}
|
||||
downloadedCallback (NESet.size hashes)
|
||||
atomically do
|
||||
writeTQueue entitiesQueue (hashes, entities)
|
||||
recordNotWorking workerCount
|
||||
httpDownloadEntities httpClient unisonShareUrl Share.DownloadEntitiesRequest {repoName, hashes} >>= \case
|
||||
Left err -> do
|
||||
atomically (recordNotWorking workerCount)
|
||||
pure (Left (TransportError err))
|
||||
Right (Share.DownloadEntitiesNoReadPermission _) -> do
|
||||
atomically (recordNotWorking workerCount)
|
||||
pure (Left (SyncError DownloadEntitiesNoReadPermission))
|
||||
Right (Share.DownloadEntitiesSuccess entities) -> do
|
||||
downloadedCallback (NESet.size hashes)
|
||||
atomically do
|
||||
writeTQueue entitiesQueue (hashes, entities)
|
||||
recordNotWorking workerCount
|
||||
pure (Right ())
|
||||
|
||||
-- Inserter thread: dequeue from `entitiesQueue`, insert entities, enqueue to `newTempEntitiesQueue`
|
||||
inserter ::
|
||||
@ -537,7 +612,7 @@ completeTempEntities httpClient unisonShareUrl connect repoName downloadedCallba
|
||||
WorkerCount ->
|
||||
IO Void
|
||||
inserter entitiesQueue newTempEntitiesQueue workerCount =
|
||||
connect \conn ->
|
||||
connect \runTransaction ->
|
||||
forever do
|
||||
(hashJwts, entities) <-
|
||||
atomically do
|
||||
@ -545,7 +620,7 @@ completeTempEntities httpClient unisonShareUrl connect repoName downloadedCallba
|
||||
recordWorking workerCount
|
||||
pure entities
|
||||
newTempEntities0 <-
|
||||
Sqlite.runTransaction conn do
|
||||
runTransaction do
|
||||
NEMap.toList entities & foldMapM \(hash, entity) ->
|
||||
upsertEntitySomewhere hash entity <&> \case
|
||||
Q.EntityInMainStorage -> Set.empty
|
||||
@ -562,7 +637,7 @@ completeTempEntities httpClient unisonShareUrl connect repoName downloadedCallba
|
||||
WorkerCount ->
|
||||
IO Void
|
||||
elaborator hashesVar uninsertedHashesVar newTempEntitiesQueue workerCount =
|
||||
connect \conn ->
|
||||
connect \runTransaction ->
|
||||
forever do
|
||||
maybeNewTempEntities <-
|
||||
atomically do
|
||||
@ -580,7 +655,7 @@ completeTempEntities httpClient unisonShareUrl connect repoName downloadedCallba
|
||||
recordWorking workerCount
|
||||
pure (Just newTempEntities)
|
||||
whenJust maybeNewTempEntities \newTempEntities -> do
|
||||
newElaboratedHashes <- Sqlite.runTransaction conn (elaborateHashes newTempEntities)
|
||||
newElaboratedHashes <- runTransaction (elaborateHashes newTempEntities)
|
||||
atomically do
|
||||
uninsertedHashes <- readTVar uninsertedHashesVar
|
||||
hashes0 <- readTVar hashesVar
|
||||
@ -589,85 +664,99 @@ completeTempEntities httpClient unisonShareUrl connect repoName downloadedCallba
|
||||
|
||||
-- | Insert entities into the database, and return the subset that went into temp storage (`temp_entitiy`) rather than
|
||||
-- of main storage (`object` / `causal`) due to missing dependencies.
|
||||
insertEntities :: Sqlite.Connection -> NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT) -> IO (Set Hash32)
|
||||
insertEntities conn entities =
|
||||
Sqlite.runTransaction conn do
|
||||
NEMap.toList entities & foldMapM \(hash, entity) ->
|
||||
upsertEntitySomewhere hash entity <&> \case
|
||||
Q.EntityInMainStorage -> Set.empty
|
||||
Q.EntityInTempStorage -> Set.singleton hash
|
||||
insertEntities :: NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT) -> Sqlite.Transaction (Set Hash32)
|
||||
insertEntities entities =
|
||||
NEMap.toList entities & foldMapM \(hash, entity) ->
|
||||
upsertEntitySomewhere hash entity <&> \case
|
||||
Q.EntityInMainStorage -> Set.empty
|
||||
Q.EntityInTempStorage -> Set.singleton hash
|
||||
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Get causal hash by path
|
||||
|
||||
-- | Get the causal hash of a path hosted on Unison Share.
|
||||
getCausalHashByPath ::
|
||||
-- | The HTTP client to use for Unison Share requests.
|
||||
AuthenticatedHttpClient ->
|
||||
-- | The Unison Share URL.
|
||||
BaseUrl ->
|
||||
Share.Path ->
|
||||
IO (Either GetCausalHashByPathError (Maybe Share.HashJWT))
|
||||
getCausalHashByPath httpClient unisonShareUrl repoPath =
|
||||
httpGetCausalHashByPath httpClient unisonShareUrl (Share.GetCausalHashByPathRequest repoPath) <&> \case
|
||||
Share.GetCausalHashByPathSuccess maybeHashJwt -> Right maybeHashJwt
|
||||
Share.GetCausalHashByPathNoReadPermission _ -> Left (GetCausalHashByPathErrorNoReadPermission repoPath)
|
||||
Cli (Either (SyncError GetCausalHashByPathError) (Maybe Share.HashJWT))
|
||||
getCausalHashByPath unisonShareUrl repoPath = do
|
||||
Cli.Env {authHTTPClient} <- ask
|
||||
liftIO (httpGetCausalHashByPath authHTTPClient unisonShareUrl (Share.GetCausalHashByPathRequest repoPath)) <&> \case
|
||||
Left err -> Left (TransportError err)
|
||||
Right (Share.GetCausalHashByPathSuccess maybeHashJwt) -> Right maybeHashJwt
|
||||
Right (Share.GetCausalHashByPathNoReadPermission _) ->
|
||||
Left (SyncError (GetCausalHashByPathErrorNoReadPermission repoPath))
|
||||
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Upload entities
|
||||
|
||||
data UploadDispatcherJob
|
||||
= UploadDispatcherReturnFailure
|
||||
= UploadDispatcherReturnFailure (SyncError UploadEntitiesError)
|
||||
| UploadDispatcherForkWorkerWhenAvailable (NESet Hash32)
|
||||
| UploadDispatcherForkWorker (NESet Hash32)
|
||||
| UploadDispatcherDone
|
||||
|
||||
data UploadEntitiesError
|
||||
= UploadEntitiesNoWritePermission
|
||||
|
||||
-- | Upload a set of entities to Unison Share. If the server responds that it cannot yet store any hash(es) due to
|
||||
-- missing dependencies, send those dependencies too, and on and on, until the server stops responding that it's missing
|
||||
-- anything.
|
||||
--
|
||||
-- Returns true on success, false on failure (because the user does not have write permission).
|
||||
uploadEntities ::
|
||||
AuthenticatedHttpClient ->
|
||||
BaseUrl ->
|
||||
(forall a. (Sqlite.Connection -> IO a) -> IO a) ->
|
||||
Share.RepoName ->
|
||||
NESet Hash32 ->
|
||||
(Int -> IO ()) ->
|
||||
IO Bool
|
||||
uploadEntities httpClient unisonShareUrl connect repoName hashes0 uploadedCallback = do
|
||||
hashesVar <- newTVarIO (NESet.toSet hashes0)
|
||||
-- Semantically, this is the set of hashes we've uploaded so far, but we do delete from it when it's safe to, so it
|
||||
-- doesn't grow unbounded. It's used to filter out hashes that would be duplicate uploads: the server, when responding
|
||||
-- to any particular upload request, may declare that it still needs some hashes that we're in the process of
|
||||
-- uploading from another thread.
|
||||
dedupeVar <- newTVarIO Set.empty
|
||||
nextWorkerIdVar <- newTVarIO 0
|
||||
workersVar <- newTVarIO Set.empty
|
||||
workerFailedVar <- newEmptyTMVarIO
|
||||
Cli (Either (SyncError UploadEntitiesError) ())
|
||||
uploadEntities unisonShareUrl repoName hashes0 uploadedCallback = do
|
||||
Cli.Env {authHTTPClient, codebase} <- ask
|
||||
|
||||
Ki.scoped \scope ->
|
||||
dispatcher scope hashesVar dedupeVar nextWorkerIdVar workersVar workerFailedVar
|
||||
liftIO do
|
||||
hashesVar <- newTVarIO (NESet.toSet hashes0)
|
||||
-- Semantically, this is the set of hashes we've uploaded so far, but we do delete from it when it's safe to, so it
|
||||
-- doesn't grow unbounded. It's used to filter out hashes that would be duplicate uploads: the server, when
|
||||
-- responding to any particular upload request, may declare that it still needs some hashes that we're in the
|
||||
-- process of uploading from another thread.
|
||||
dedupeVar <- newTVarIO Set.empty
|
||||
nextWorkerIdVar <- newTVarIO 0
|
||||
workersVar <- newTVarIO Set.empty
|
||||
workerFailedVar <- newEmptyTMVarIO
|
||||
|
||||
Ki.scoped \scope ->
|
||||
dispatcher
|
||||
scope
|
||||
authHTTPClient
|
||||
(Codebase.runTransaction codebase)
|
||||
hashesVar
|
||||
dedupeVar
|
||||
nextWorkerIdVar
|
||||
workersVar
|
||||
workerFailedVar
|
||||
where
|
||||
dispatcher ::
|
||||
Ki.Scope ->
|
||||
AuthenticatedHttpClient ->
|
||||
(forall a. Sqlite.Transaction a -> IO a) ->
|
||||
TVar (Set Hash32) ->
|
||||
TVar (Set Hash32) ->
|
||||
TVar Int ->
|
||||
TVar (Set Int) ->
|
||||
TMVar () ->
|
||||
IO Bool
|
||||
dispatcher scope hashesVar dedupeVar nextWorkerIdVar workersVar workerFailedVar = do
|
||||
TMVar (SyncError UploadEntitiesError) ->
|
||||
IO (Either (SyncError UploadEntitiesError) ())
|
||||
dispatcher scope httpClient runTransaction hashesVar dedupeVar nextWorkerIdVar workersVar workerFailedVar = do
|
||||
loop
|
||||
where
|
||||
loop :: IO Bool
|
||||
loop :: IO (Either (SyncError UploadEntitiesError) ())
|
||||
loop =
|
||||
doJob [checkForFailureMode, dispatchWorkMode, checkIfDoneMode]
|
||||
|
||||
doJob :: [STM UploadDispatcherJob] -> IO Bool
|
||||
doJob :: [STM UploadDispatcherJob] -> IO (Either (SyncError UploadEntitiesError) ())
|
||||
doJob jobs =
|
||||
atomically (asum jobs) >>= \case
|
||||
UploadDispatcherReturnFailure -> pure False
|
||||
UploadDispatcherReturnFailure err -> pure (Left err)
|
||||
UploadDispatcherForkWorkerWhenAvailable hashes -> doJob [forkWorkerMode hashes, checkForFailureMode]
|
||||
UploadDispatcherForkWorker hashes -> do
|
||||
workerId <-
|
||||
@ -678,14 +767,14 @@ uploadEntities httpClient unisonShareUrl connect repoName hashes0 uploadedCallba
|
||||
pure workerId
|
||||
_ <-
|
||||
Ki.fork @() scope do
|
||||
worker hashesVar dedupeVar workersVar workerFailedVar workerId hashes
|
||||
worker httpClient runTransaction hashesVar dedupeVar workersVar workerFailedVar workerId hashes
|
||||
loop
|
||||
UploadDispatcherDone -> pure True
|
||||
UploadDispatcherDone -> pure (Right ())
|
||||
|
||||
checkForFailureMode :: STM UploadDispatcherJob
|
||||
checkForFailureMode = do
|
||||
() <- readTMVar workerFailedVar
|
||||
pure UploadDispatcherReturnFailure
|
||||
err <- readTMVar workerFailedVar
|
||||
pure (UploadDispatcherReturnFailure err)
|
||||
|
||||
dispatchWorkMode :: STM UploadDispatcherJob
|
||||
dispatchWorkMode = do
|
||||
@ -708,25 +797,35 @@ uploadEntities httpClient unisonShareUrl connect repoName hashes0 uploadedCallba
|
||||
when (not (Set.null workers)) retry
|
||||
pure UploadDispatcherDone
|
||||
|
||||
worker :: TVar (Set Hash32) -> TVar (Set Hash32) -> TVar (Set Int) -> TMVar () -> Int -> NESet Hash32 -> IO ()
|
||||
worker hashesVar dedupeVar workersVar workerFailedVar workerId hashes = do
|
||||
worker ::
|
||||
AuthenticatedHttpClient ->
|
||||
(forall a. Sqlite.Transaction a -> IO a) ->
|
||||
TVar (Set Hash32) ->
|
||||
TVar (Set Hash32) ->
|
||||
TVar (Set Int) ->
|
||||
TMVar (SyncError UploadEntitiesError) ->
|
||||
Int ->
|
||||
NESet Hash32 ->
|
||||
IO ()
|
||||
worker httpClient runTransaction hashesVar dedupeVar workersVar workerFailedVar workerId hashes = do
|
||||
entities <-
|
||||
fmap NEMap.fromAscList do
|
||||
connect \conn ->
|
||||
Sqlite.runTransaction conn do
|
||||
for (NESet.toAscList hashes) \hash -> do
|
||||
entity <- expectEntity hash
|
||||
pure (hash, entity)
|
||||
runTransaction do
|
||||
for (NESet.toAscList hashes) \hash -> do
|
||||
entity <- expectEntity hash
|
||||
pure (hash, entity)
|
||||
|
||||
result <-
|
||||
httpUploadEntities httpClient unisonShareUrl Share.UploadEntitiesRequest {entities, repoName} <&> \case
|
||||
Share.UploadEntitiesNeedDependencies (Share.NeedDependencies moreHashes) -> Right (NESet.toSet moreHashes)
|
||||
Share.UploadEntitiesNoWritePermission _ -> Left ()
|
||||
Share.UploadEntitiesHashMismatchForEntity _ -> error "hash mismatch; fixme"
|
||||
Share.UploadEntitiesSuccess -> Right Set.empty
|
||||
Left err -> Left (TransportError err)
|
||||
Right (Share.UploadEntitiesNeedDependencies (Share.NeedDependencies moreHashes)) ->
|
||||
Right (NESet.toSet moreHashes)
|
||||
Right (Share.UploadEntitiesNoWritePermission _) -> Left (SyncError UploadEntitiesNoWritePermission)
|
||||
Right (Share.UploadEntitiesHashMismatchForEntity _) -> error "hash mismatch; fixme"
|
||||
Right Share.UploadEntitiesSuccess -> Right Set.empty
|
||||
|
||||
case result of
|
||||
Left () -> void (atomically (tryPutTMVar workerFailedVar ()))
|
||||
Left err -> void (atomically (tryPutTMVar workerFailedVar err))
|
||||
Right moreHashes -> do
|
||||
uploadedCallback (NESet.size hashes)
|
||||
maybeYoungestWorkerThatWasAlive <-
|
||||
@ -815,11 +914,31 @@ upsertEntitySomewhere hash entity =
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- HTTP calls
|
||||
|
||||
httpGetCausalHashByPath :: Auth.AuthenticatedHttpClient -> BaseUrl -> Share.GetCausalHashByPathRequest -> IO Share.GetCausalHashByPathResponse
|
||||
httpFastForwardPath :: Auth.AuthenticatedHttpClient -> BaseUrl -> Share.FastForwardPathRequest -> IO Share.FastForwardPathResponse
|
||||
httpUpdatePath :: Auth.AuthenticatedHttpClient -> BaseUrl -> Share.UpdatePathRequest -> IO Share.UpdatePathResponse
|
||||
httpDownloadEntities :: Auth.AuthenticatedHttpClient -> BaseUrl -> Share.DownloadEntitiesRequest -> IO Share.DownloadEntitiesResponse
|
||||
httpUploadEntities :: Auth.AuthenticatedHttpClient -> BaseUrl -> Share.UploadEntitiesRequest -> IO Share.UploadEntitiesResponse
|
||||
httpGetCausalHashByPath ::
|
||||
Auth.AuthenticatedHttpClient ->
|
||||
BaseUrl ->
|
||||
Share.GetCausalHashByPathRequest ->
|
||||
IO (Either CodeserverTransportError Share.GetCausalHashByPathResponse)
|
||||
httpFastForwardPath ::
|
||||
Auth.AuthenticatedHttpClient ->
|
||||
BaseUrl ->
|
||||
Share.FastForwardPathRequest ->
|
||||
IO (Either CodeserverTransportError Share.FastForwardPathResponse)
|
||||
httpUpdatePath ::
|
||||
Auth.AuthenticatedHttpClient ->
|
||||
BaseUrl ->
|
||||
Share.UpdatePathRequest ->
|
||||
IO (Either CodeserverTransportError Share.UpdatePathResponse)
|
||||
httpDownloadEntities ::
|
||||
Auth.AuthenticatedHttpClient ->
|
||||
BaseUrl ->
|
||||
Share.DownloadEntitiesRequest ->
|
||||
IO (Either CodeserverTransportError Share.DownloadEntitiesResponse)
|
||||
httpUploadEntities ::
|
||||
Auth.AuthenticatedHttpClient ->
|
||||
BaseUrl ->
|
||||
Share.UploadEntitiesRequest ->
|
||||
IO (Either CodeserverTransportError Share.UploadEntitiesResponse)
|
||||
( httpGetCausalHashByPath,
|
||||
httpFastForwardPath,
|
||||
httpUpdatePath,
|
||||
@ -843,14 +962,14 @@ httpUploadEntities :: Auth.AuthenticatedHttpClient -> BaseUrl -> Share.UploadEnt
|
||||
go httpUploadEntities
|
||||
)
|
||||
where
|
||||
hoist :: Servant.ClientM a -> ReaderT Servant.ClientEnv IO a
|
||||
hoist :: Servant.ClientM a -> ReaderT Servant.ClientEnv (ExceptT CodeserverTransportError IO) a
|
||||
hoist m = do
|
||||
clientEnv <- Reader.ask
|
||||
liftIO (Servant.runClientM m clientEnv) >>= \case
|
||||
Right a -> pure a
|
||||
Left err -> do
|
||||
Debug.debugLogM Debug.Sync (show err)
|
||||
throwIO case err of
|
||||
throwError case err of
|
||||
Servant.FailureResponse _req resp ->
|
||||
case HTTP.statusCode $ Servant.responseStatusCode resp of
|
||||
401 -> Unauthenticated (Servant.baseUrl clientEnv)
|
||||
@ -867,25 +986,18 @@ httpUploadEntities :: Auth.AuthenticatedHttpClient -> BaseUrl -> Share.UploadEnt
|
||||
Servant.ConnectionError _ -> UnreachableCodeserver (Servant.baseUrl clientEnv)
|
||||
|
||||
go ::
|
||||
(req -> ReaderT Servant.ClientEnv IO resp) ->
|
||||
(req -> ReaderT Servant.ClientEnv (ExceptT CodeserverTransportError IO) resp) ->
|
||||
Auth.AuthenticatedHttpClient ->
|
||||
BaseUrl ->
|
||||
req ->
|
||||
IO resp
|
||||
IO (Either CodeserverTransportError resp)
|
||||
go f (Auth.AuthenticatedHttpClient httpClient) unisonShareUrl req =
|
||||
runReaderT
|
||||
(f req)
|
||||
(Servant.mkClientEnv httpClient unisonShareUrl)
|
||||
{ Servant.makeClientRequest = \url request ->
|
||||
-- Disable client-side timeouts
|
||||
(Servant.defaultMakeClientRequest url request)
|
||||
{ Http.Client.responseTimeout = Http.Client.responseTimeoutNone
|
||||
}
|
||||
}
|
||||
|
||||
catchSyncErrors :: IO (Either e a) -> IO (Either (SyncError e) a)
|
||||
catchSyncErrors action =
|
||||
UnliftIO.try @_ @CodeserverTransportError action >>= \case
|
||||
Left te -> pure (Left . TransportError $ te)
|
||||
Right (Left e) -> pure . Left . SyncError $ e
|
||||
Right (Right a) -> pure $ Right a
|
||||
(Servant.mkClientEnv httpClient unisonShareUrl)
|
||||
{ Servant.makeClientRequest = \url request ->
|
||||
-- Disable client-side timeouts
|
||||
(Servant.defaultMakeClientRequest url request)
|
||||
{ Http.Client.responseTimeout = Http.Client.responseTimeoutNone
|
||||
}
|
||||
}
|
||||
& runReaderT (f req)
|
||||
& runExceptT
|
||||
|
@ -1,7 +1,13 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
|
||||
-- | Types used by the UCM client during sync.
|
||||
module Unison.Share.Sync.Types where
|
||||
module Unison.Share.Sync.Types
|
||||
( CheckAndSetPushError (..),
|
||||
CodeserverTransportError (..),
|
||||
FastForwardPushError (..),
|
||||
GetCausalHashByPathError (..),
|
||||
PullError (..),
|
||||
SyncError (..),
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Set.NonEmpty (NESet)
|
||||
import qualified Servant.Client as Servant
|
||||
@ -29,9 +35,8 @@ data FastForwardPushError
|
||||
|
||||
-- | An error occurred while pulling code from Unison Share.
|
||||
data PullError
|
||||
= -- | An error occurred while resolving a repo+path to a causal hash.
|
||||
PullErrorGetCausalHashByPath GetCausalHashByPathError
|
||||
| PullErrorNoHistoryAtPath Share.Path
|
||||
= PullErrorNoHistoryAtPath Share.Path
|
||||
| PullErrorNoReadPermission Share.Path
|
||||
deriving (Show)
|
||||
|
||||
-- | An error occurred when getting causal hash by path.
|
||||
@ -57,3 +62,4 @@ data CodeserverTransportError
|
||||
data SyncError e
|
||||
= TransportError CodeserverTransportError
|
||||
| SyncError e
|
||||
deriving stock (Functor)
|
||||
|
@ -12,6 +12,8 @@
|
||||
module Unison.ABT.Normalized
|
||||
( ABT (..),
|
||||
Term (.., TAbs, TTm, TAbss),
|
||||
Align (..),
|
||||
alpha,
|
||||
renames,
|
||||
rename,
|
||||
transform,
|
||||
@ -20,6 +22,7 @@ where
|
||||
|
||||
import Data.Bifoldable
|
||||
import Data.Bifunctor
|
||||
import Data.Foldable (toList)
|
||||
-- import Data.Bitraversable
|
||||
|
||||
import Data.Map.Strict (Map)
|
||||
@ -58,6 +61,22 @@ instance
|
||||
showsPrec p (Term _ e) =
|
||||
showParen (p >= 9) $ showString "Term " . showsPrec 10 e
|
||||
|
||||
instance
|
||||
(forall a b. Eq a => Eq b => Eq (f a b), Bifunctor f, Bifoldable f, Var v) =>
|
||||
Eq (ABT f v)
|
||||
where
|
||||
Abs v1 e1 == Abs v2 e2
|
||||
| v1 == v2 = e1 == e2
|
||||
| otherwise = e1 == rename v2 v1 e2
|
||||
Tm e1 == Tm e2 = e1 == e2
|
||||
_ == _ = False
|
||||
|
||||
instance
|
||||
(forall a b. Eq a => Eq b => Eq (f a b), Bifunctor f, Bifoldable f, Var v) =>
|
||||
Eq (Term f v)
|
||||
where
|
||||
Term _ abt1 == Term _ abt2 = abt1 == abt2
|
||||
|
||||
pattern TAbs :: Var v => v -> Term f v -> Term f v
|
||||
pattern TAbs u bd <-
|
||||
Term _ (Abs u bd)
|
||||
@ -72,6 +91,35 @@ pattern TTm bd <-
|
||||
|
||||
{-# COMPLETE TAbs, TTm #-}
|
||||
|
||||
class (Bifoldable f, Bifunctor f) => Align f where
|
||||
align ::
|
||||
Applicative g =>
|
||||
(vl -> vr -> g vs) ->
|
||||
(el -> er -> g es) ->
|
||||
f vl el ->
|
||||
f vr er ->
|
||||
Maybe (g (f vs es))
|
||||
|
||||
alphaErr ::
|
||||
Align f => Var v => Map v v -> Term f v -> Term f v -> Either (Term f v, Term f v) a
|
||||
alphaErr un tml tmr = Left (tml, renames count un tmr)
|
||||
where
|
||||
count = Map.fromListWith (+) . flip zip [1, 1 ..] $ toList un
|
||||
|
||||
-- Checks if two terms are equal up to a given variable renaming. The
|
||||
-- renaming should map variables in the right hand term to the
|
||||
-- equivalent variable in the left hand term.
|
||||
alpha :: Align f => Var v => Map v v -> Term f v -> Term f v -> Either (Term f v, Term f v) ()
|
||||
alpha un (TAbs u tml) (TAbs v tmr) =
|
||||
alpha (Map.insert v u (Map.filter (/= u) un)) tml tmr
|
||||
alpha un tml@(TTm bdl) tmr@(TTm bdr)
|
||||
| Just sub <- align av (alpha un) bdl bdr = () <$ sub
|
||||
where
|
||||
av u v
|
||||
| maybe False (== u) (Map.lookup v un) = pure ()
|
||||
| otherwise = alphaErr un tml tmr
|
||||
alpha un tml tmr = alphaErr un tml tmr
|
||||
|
||||
unabss :: Var v => Term f v -> ([v], Term f v)
|
||||
unabss (TAbs v (unabss -> (vs, bd))) = (v : vs, bd)
|
||||
unabss bd = ([], bd)
|
||||
|
@ -29,6 +29,7 @@ module Unison.Names
|
||||
prefix0,
|
||||
restrictReferences,
|
||||
refTermsNamed,
|
||||
refTermsHQNamed,
|
||||
termReferences,
|
||||
termReferents,
|
||||
typeReferences,
|
||||
@ -71,6 +72,7 @@ import qualified Unison.ShortHash as SH
|
||||
import Unison.Util.Relation (Relation)
|
||||
import qualified Unison.Util.Relation as R
|
||||
import qualified Unison.Util.Relation as Relation
|
||||
import qualified Unison.Util.Set as Set (mapMaybe)
|
||||
import Prelude hiding (filter, map)
|
||||
import qualified Prelude
|
||||
|
||||
@ -249,9 +251,23 @@ numHashChars = 3
|
||||
termsNamed :: Names -> Name -> Set Referent
|
||||
termsNamed = flip R.lookupDom . terms
|
||||
|
||||
-- | Get all terms with a specific name.
|
||||
refTermsNamed :: Names -> Name -> Set TermReference
|
||||
refTermsNamed names n =
|
||||
Set.fromList [r | Referent.Ref r <- toList $ termsNamed names n]
|
||||
Set.mapMaybe Referent.toTermReference (termsNamed names n)
|
||||
|
||||
-- | Get all terms with a specific hash-qualified name.
|
||||
refTermsHQNamed :: Names -> HQ.HashQualified Name -> Set TermReference
|
||||
refTermsHQNamed names = \case
|
||||
HQ.NameOnly name -> refTermsNamed names name
|
||||
HQ.HashOnly _hash -> Set.empty
|
||||
HQ.HashQualified name hash ->
|
||||
let f :: Referent -> Maybe TermReference
|
||||
f ref0 = do
|
||||
ref <- Referent.toTermReference ref0
|
||||
guard (Reference.isPrefixOf hash ref)
|
||||
Just ref
|
||||
in Set.mapMaybe f (termsNamed names name)
|
||||
|
||||
typesNamed :: Names -> Name -> Set TypeReference
|
||||
typesNamed = flip R.lookupDom . types
|
||||
|
@ -116,6 +116,11 @@ _TermLink = _Ctor @"TermLink"
|
||||
_TypeLink :: Prism' (F tv ta pa a) Reference
|
||||
_TypeLink = _Ctor @"TypeLink"
|
||||
|
||||
-- | Returns the top-level type annotation for a term if it has one.
|
||||
getTypeAnnotation :: Term v a -> Maybe (Type v a)
|
||||
getTypeAnnotation (ABT.Tm' (Ann _ t)) = Just t
|
||||
getTypeAnnotation _ = Nothing
|
||||
|
||||
type IsTop = Bool
|
||||
|
||||
-- | Like `Term v`, but with an annotation of type `a` at every level in the tree
|
||||
|
@ -1,7 +1,4 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
module Unison.WatchKind where
|
||||
|
||||
|
@ -701,7 +701,7 @@ makeNameSearch hashLength names =
|
||||
}
|
||||
|
||||
-- | Interpret a 'Search' as a function from name to search results.
|
||||
applySearch :: (Show r) => Search r -> HQ'.HashQualified Name -> [SR.SearchResult]
|
||||
applySearch :: Show r => Search r -> HQ'.HashQualified Name -> [SR.SearchResult]
|
||||
applySearch Search {lookupNames, lookupRelativeHQRefs', makeResult, matchesNamedRef} query = do
|
||||
-- a bunch of references will match a HQ ref.
|
||||
toList (lookupRelativeHQRefs' query) <&> \ref ->
|
||||
@ -778,9 +778,9 @@ hqNameQuery codebase NameSearch {typeSearch, termSearch} hqs = do
|
||||
}
|
||||
|
||||
-- TODO: Move this to its own module
|
||||
data DefinitionResults v = DefinitionResults
|
||||
{ termResults :: Map Reference (DisplayObject (Type v Ann) (Term v Ann)),
|
||||
typeResults :: Map Reference (DisplayObject () (DD.Decl v Ann)),
|
||||
data DefinitionResults = DefinitionResults
|
||||
{ termResults :: Map Reference (DisplayObject (Type Symbol Ann) (Term Symbol Ann)),
|
||||
typeResults :: Map Reference (DisplayObject () (DD.Decl Symbol Ann)),
|
||||
noResults :: [HQ.HashQualified Name]
|
||||
}
|
||||
|
||||
@ -1204,7 +1204,7 @@ definitionsBySuffixes ::
|
||||
NameSearch ->
|
||||
IncludeCycles ->
|
||||
[HQ.HashQualified Name] ->
|
||||
Sqlite.Transaction (DefinitionResults Symbol)
|
||||
Sqlite.Transaction DefinitionResults
|
||||
definitionsBySuffixes codebase nameSearch includeCycles query = do
|
||||
QueryResult misses results <- hqNameQuery codebase nameSearch query
|
||||
-- todo: remember to replace this with getting components directly,
|
||||
|
@ -1,10 +1,5 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
|
||||
module Unison.Server.Types where
|
||||
|
||||
|
5
unison-src/transcripts-using-base/all-base-hashes.md
Normal file
5
unison-src/transcripts-using-base/all-base-hashes.md
Normal file
@ -0,0 +1,5 @@
|
||||
This transcript is intended to make visible accidental changes to the hashing algorithm.
|
||||
|
||||
```ucm
|
||||
.> find.verbose
|
||||
```
|
2682
unison-src/transcripts-using-base/all-base-hashes.output.md
Normal file
2682
unison-src/transcripts-using-base/all-base-hashes.output.md
Normal file
File diff suppressed because it is too large
Load Diff
@ -39,6 +39,5 @@ A summary of the diff:
|
||||
* `one.a` -> `two.a` is a normal update.
|
||||
* Even though `one.b` is conflicted, both `one.b#hash1` and `one.b#hash2` get mapped to `two.b`.
|
||||
* Because `two.c` is conflicted, `one.c` doesn't end up on the left-hand side of the patch.
|
||||
* Oops, a similar case slipped by - `one.d` and `one.e` map to `two.d` and `two.e` respectively, but because `one.d` and
|
||||
`one.e` were aliases, we end up with a busted patch that isn't a function. This is a bug.
|
||||
* Because `one.d` and `one.e` are aliases, they don't end up on the left-hand side of the patch.
|
||||
* Neither `one.f` nor `two.g` end up in the patch because the names `f` and `g` are not common to both namespaces.
|
||||
|
@ -39,11 +39,9 @@ two.e = 6
|
||||
.> diff.namespace.to-patch one two thepatch
|
||||
|
||||
Edited Terms:
|
||||
1. one.b#cp6ri8mtg0 -> 6. two.b
|
||||
2. one.b#dcgdua2lj6 -> 7. two.b
|
||||
3. one.a -> 8. two.a
|
||||
4. one.d -> 9. two.d
|
||||
5. one.d -> 10. two.e
|
||||
1. one.b#cp6ri8mtg0 -> 4. two.b
|
||||
2. one.b#dcgdua2lj6 -> 5. two.b
|
||||
3. one.a -> 6. two.a
|
||||
|
||||
Tip: To remove entries from a patch, use
|
||||
delete.term-replacement or delete.type-replacement, as
|
||||
@ -55,6 +53,5 @@ A summary of the diff:
|
||||
* `one.a` -> `two.a` is a normal update.
|
||||
* Even though `one.b` is conflicted, both `one.b#hash1` and `one.b#hash2` get mapped to `two.b`.
|
||||
* Because `two.c` is conflicted, `one.c` doesn't end up on the left-hand side of the patch.
|
||||
* Oops, a similar case slipped by - `one.d` and `one.e` map to `two.d` and `two.e` respectively, but because `one.d` and
|
||||
`one.e` were aliases, we end up with a busted patch that isn't a function. This is a bug.
|
||||
* Because `one.d` and `one.e` are aliases, they don't end up on the left-hand side of the patch.
|
||||
* Neither `one.f` nor `two.g` end up in the patch because the names `f` and `g are not common to both namespaces.
|
||||
|
Loading…
Reference in New Issue
Block a user