unisonweb/unison
1
0
Fork 0
mirror of https://github.com/unisonweb/unison.git synced 2024-11-13 09:55:35 +03:00
Code Issues Projects Releases Wiki Activity

⅄ trunk → topic/rehash-codebase

Browse Source
This commit is contained in:
Mitchell Rosen 2021-11-19 14:59:35 -05:00
commit 6052820089
42 changed files with 1167 additions and 555 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.github/workflows/ci.yaml vendored
View File

@ -60,8 +60,8 @@ jobs:
# recent branch cache.
# Then it will save a new cache at this commit sha, which should be used by
# the next build on this branch.
key: stack-work-2_${{matrix.os}}-${{github.sha}}
restore-keys: stack-work-2_${{matrix.os}}
key: stack-work-3_${{matrix.os}}-${{github.sha}}
restore-keys: stack-work-3_${{matrix.os}}
# Install stack by downloading the binary from GitHub. The installation process is different for Linux and macOS,
# so this is split into two steps, only one of which will run on any particular build.

1
.gitignore vendored
View File

@ -13,3 +13,4 @@ dist-newstyle
# GHC
*.hie
*.prof

5
lib/unison-util-relation/src/Unison/Util/Relation3.hs
View File

@ -39,6 +39,11 @@ d13 :: Relation3 a b c -> Relation a c
d13 Relation3 {d1, d3} =
R.unsafeFromMultimaps (Map.map R.ran d1) (Map.map R.dom d3)
-- | Project out a relation that only includes the 2nd and 3rd dimensions.
d23 :: Relation3 a b c -> Relation b c
d23 Relation3 {d2, d3} =
R.unsafeFromMultimaps (Map.map R.ran d2) (Map.map R.ran d3)
filter :: (Ord a, Ord b, Ord c)
=> ((a,b,c) -> Bool) -> Relation3 a b c -> Relation3 a b c
filter f = fromList . Prelude.filter f . toList

13
lib/unison-util-relation/src/Unison/Util/Relation4.hs
View File

@ -58,6 +58,10 @@ selectD34 c d r =
(Map.lookup c (d3 r))
]
keys :: Relation4 a b c d -> (Set a, Set b, Set c, Set d)
keys Relation4{d1, d2, d3, d4} =
(Map.keysSet d1, Map.keysSet d2, Map.keysSet d3, Map.keysSet d4)
d1set :: Ord a => Relation4 a b c d -> Set a
d1set = Map.keysSet . d1
@ -76,6 +80,15 @@ d124 Relation4 {d1, d2, d4} =
d3 = Map.map R3.d12 d4
}
-- | Project out a relation that only includes the 2nd, 3rd, and 4th dimensions.
d234 :: (Ord a, Ord b, Ord c, Ord d) => Relation4 a b c d -> Relation3 b c d
d234 Relation4 {d2, d3, d4} =
Relation3
{ d1 = Map.map R3.d23 d2,
d2 = Map.map R3.d23 d3,
d3 = Map.map R3.d23 d4
}
-- todo: make me faster
d12s :: (Ord a, Ord b) => Relation4 a b c d -> [(a,b)]
d12s = nubOrd . fmap (\(a, (b, _)) -> (a,b)) . toNestedList

326
parser-typechecker/src/Unison/Codebase.hs
View File

@ -1,38 +1,94 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE ViewPatterns #-}
module Unison.Codebase
( Codebase (..),
CodebasePath,
GetRootBranchError (..),
getBranchForHash,
getCodebaseDir,
isBlank,
SyncToDir,
addDefsToCodebase,
installUcmDependencies,
getTypeOfTerm,
getTypeOfReferent,
lca,
lookupWatchCache,
toCodeLookup,
typeLookupForDependencies,
importRemoteBranch,
viewRemoteBranch,
termsOfType,
termsMentioningType,
dependents,
dependentsOfComponent,
isTerm,
isType,
componentReferencesForReference,
( Codebase,
-- * Unsafe variants
-- * Terms
getTerm,
unsafeGetTerm,
unsafeGetTermWithType,
unsafeGetTypeDeclaration,
getTermComponentWithTypes,
getTypeOfTerm,
unsafeGetTypeOfTermById,
isTerm,
putTerm,
-- ** Referents (sorta-termlike)
getTypeOfReferent,
-- ** Search
termsOfType,
termsMentioningType,
termReferencesByPrefix,
termReferentsByPrefix,
-- * Type declarations
getTypeDeclaration,
unsafeGetTypeDeclaration,
getDeclComponent,
putTypeDeclaration,
typeReferencesByPrefix,
isType,
-- * Branches
branchExists,
getBranchForHash,
putBranch,
branchHashesByPrefix,
lca,
beforeImpl,
-- * Root branch
getRootBranch,
GetRootBranchError (..),
isBlank,
putRootBranch,
rootBranchUpdates,
-- * Patches
patchExists,
getPatch,
putPatch,
-- * Watches
getWatch,
lookupWatchCache,
watches,
putWatch,
clearWatches,
-- * Reflog
getReflog,
appendReflog,
-- * Unambiguous hash length
hashLength,
branchHashLength,
-- * Dependents
dependents,
dependentsOfComponent,
-- * Sync
-- ** Local sync
syncFromDirectory,
syncToDirectory,
-- ** Remote sync
viewRemoteBranch,
importRemoteBranch,
pushGitRootBranch,
-- * Codebase path
getCodebaseDir,
CodebasePath,
SyncToDir,
-- * Misc (organize these better)
addDefsToCodebase,
componentReferencesForReference,
installUcmDependencies,
toCodeLookup,
typeLookupForDependencies,
unsafeGetComponentLength,
)
where
@ -76,36 +132,39 @@ import qualified Unison.UnisonFile as UF
import qualified Unison.Util.Relation as Rel
import Unison.Var (Var)
import qualified Unison.WatchKind as WK
-- Attempt to find the Branch in the current codebase cache and root up to 3 levels deep
-- If not found, attempt to find it in the Codebase (sqlite)
-- | Get a branch from the codebase.
getBranchForHash :: Monad m => Codebase m v a -> Branch.Hash -> m (Maybe (Branch m))
getBranchForHash codebase h =
let
nestedChildrenForDepth depth b =
if depth == 0 then []
else
b : (Map.elems (Branch._children (Branch.head b)) >>= nestedChildrenForDepth (depth - 1))
-- Attempt to find the Branch in the current codebase cache and root up to 3 levels deep
-- If not found, attempt to find it in the Codebase (sqlite)
let nestedChildrenForDepth depth b =
if depth == 0
then []
else b : (Map.elems (Branch._children (Branch.head b)) >>= nestedChildrenForDepth (depth - 1))
headHashEq = (h ==) . Branch.headHash
headHashEq = (h ==) . Branch.headHash
find rb = List.find headHashEq (nestedChildrenForDepth 3 rb)
in do
rootBranch <- hush <$> getRootBranch codebase
case rootBranch of
Just rb -> maybe (getBranchForHashImpl codebase h) (pure . Just) (find rb)
Nothing -> getBranchForHashImpl codebase h
find rb = List.find headHashEq (nestedChildrenForDepth 3 rb)
in do
rootBranch <- hush <$> getRootBranch codebase
case rootBranch of
Just rb -> maybe (getBranchForHashImpl codebase h) (pure . Just) (find rb)
Nothing -> getBranchForHashImpl codebase h
-- | Get the lowest common ancestor of two branches, i.e. the most recent branch that is an ancestor of both branches.
lca :: Monad m => Codebase m v a -> Branch m -> Branch m -> m (Maybe (Branch m))
lca code b1@(Branch.headHash -> h1) b2@(Branch.headHash -> h2) = case lcaImpl code of
Nothing -> Branch.lca b1 b2
Just lca -> do
eb1 <- branchExists code h1
eb2 <- branchExists code h2
if eb1 && eb2 then do
lca h1 h2 >>= \case
Just h -> getBranchForHash code h
Nothing -> pure Nothing -- no common ancestor
else Branch.lca b1 b2
if eb1 && eb2
then do
lca h1 h2 >>= \case
Just h -> getBranchForHash code h
Nothing -> pure Nothing -- no common ancestor
else Branch.lca b1 b2
debug :: Bool
debug = False
@ -113,19 +172,26 @@ debug = False
-- | Write all of UCM's dependencies (builtins types and an empty namespace) into the codebase
installUcmDependencies :: forall m. Monad m => Codebase m Symbol Parser.Ann -> m ()
installUcmDependencies c = do
let uf = (UF.typecheckedUnisonFile (Map.fromList Builtin.builtinDataDecls)
(Map.fromList Builtin.builtinEffectDecls)
[Builtin.builtinTermsSrc Parser.Intrinsic]
mempty)
let uf =
( UF.typecheckedUnisonFile
(Map.fromList Builtin.builtinDataDecls)
(Map.fromList Builtin.builtinEffectDecls)
[Builtin.builtinTermsSrc Parser.Intrinsic]
mempty
)
addDefsToCodebase c uf
-- Feel free to refactor this to use some other type than TypecheckedUnisonFile
-- if it makes sense to later.
addDefsToCodebase :: forall m v a. (Monad m, Var v, Show a)
=> Codebase m v a -> UF.TypecheckedUnisonFile v a -> m ()
addDefsToCodebase ::
forall m v a.
(Monad m, Var v, Show a) =>
Codebase m v a ->
UF.TypecheckedUnisonFile v a ->
m ()
addDefsToCodebase c uf = do
traverse_ (goType Right) (UF.dataDeclarationsId' uf)
traverse_ (goType Left) (UF.effectDeclarationsId' uf)
traverse_ (goType Left) (UF.effectDeclarationsId' uf)
-- put terms
traverse_ goTerm (UF.hashTermsId uf)
where
@ -147,11 +213,18 @@ getTypeOfConstructor codebase (Reference.DerivedId r) cid = do
getTypeOfConstructor _ r cid =
error $ "Don't know how to getTypeOfConstructor " ++ show r ++ " " ++ show cid
lookupWatchCache :: (Monad m) => Codebase m v a -> Reference -> m (Maybe (Term v a))
lookupWatchCache codebase (Reference.DerivedId h) = do
-- | Like 'getWatch', but first looks up the given reference as a regular watch, then as a test watch.
--
-- @
-- lookupWatchCache codebase ref =
-- runMaybeT do
-- MaybeT (getWatch codebase RegularWatch ref)
-- <|> MaybeT (getWatch codebase TestWatch ref))
-- @
lookupWatchCache :: (Monad m) => Codebase m v a -> Reference.Id -> m (Maybe (Term v a))
lookupWatchCache codebase h = do
m1 <- getWatch codebase WK.RegularWatch h
maybe (getWatch codebase WK.TestWatch h) (pure . Just) m1
lookupWatchCache _ Reference.Builtin{} = pure Nothing
typeLookupForDependencies
:: (Monad m, Var v, BuiltinAnnotation a)
@ -159,35 +232,49 @@ typeLookupForDependencies
typeLookupForDependencies codebase s = do
when debug $ traceM $ "typeLookupForDependencies " ++ show s
foldM go mempty s
where
go tl ref@(Reference.DerivedId id) = fmap (tl <>) $
getTypeOfTerm codebase ref >>= \case
Just typ -> pure $ TypeLookup (Map.singleton ref typ) mempty mempty
Nothing -> getTypeDeclaration codebase id >>= \case
Just (Left ed) ->
pure $ TypeLookup mempty mempty (Map.singleton ref ed)
Just (Right dd) ->
pure $ TypeLookup mempty (Map.singleton ref dd) mempty
Nothing -> pure mempty
go tl Reference.Builtin{} = pure tl -- codebase isn't consulted for builtins
where
go tl ref@(Reference.DerivedId id) =
fmap (tl <>) $
getTypeOfTerm codebase ref >>= \case
Just typ -> pure $ TypeLookup (Map.singleton ref typ) mempty mempty
Nothing ->
getTypeDeclaration codebase id >>= \case
Just (Left ed) ->
pure $ TypeLookup mempty mempty (Map.singleton ref ed)
Just (Right dd) ->
pure $ TypeLookup mempty (Map.singleton ref dd) mempty
Nothing -> pure mempty
go tl Reference.Builtin {} = pure tl -- codebase isn't consulted for builtins
toCodeLookup :: Codebase m v a -> CL.CodeLookup v m a
toCodeLookup c = CL.CodeLookup (getTerm c) (getTypeDeclaration c)
getTypeOfTerm :: (Applicative m, Var v, BuiltinAnnotation a) =>
Codebase m v a -> Reference -> m (Maybe (Type v a))
-- | Get the type of a term.
--
-- Note that it is possible to call 'putTerm', then 'getTypeOfTerm', and receive @Nothing@, per the semantics of
-- 'putTerm'.
getTypeOfTerm ::
(Applicative m, Var v, BuiltinAnnotation a) =>
Codebase m v a ->
Reference ->
m (Maybe (Type v a))
getTypeOfTerm _c r | debug && trace ("Codebase.getTypeOfTerm " ++ show r) False = undefined
getTypeOfTerm c r = case r of
Reference.DerivedId h -> getTypeOfTermImpl c h
r@Reference.Builtin{} ->
pure $ fmap (const builtinAnnotation)
r@Reference.Builtin {} ->
pure $
fmap (const builtinAnnotation)
<$> Map.lookup r Builtin.termRefTypes
getTypeOfReferent :: (BuiltinAnnotation a, Var v, Monad m)
=> Codebase m v a -> Referent.Referent -> m (Maybe (Type v a))
getTypeOfReferent c (Referent.Ref r) = getTypeOfTerm c r
getTypeOfReferent c (Referent.Con r cid _) =
getTypeOfConstructor c r cid
-- | Get the type of a referent.
getTypeOfReferent ::
(BuiltinAnnotation a, Var v, Monad m) =>
Codebase m v a ->
Referent.Referent ->
m (Maybe (Type v a))
getTypeOfReferent c = \case
Referent.Ref r -> getTypeOfTerm c r
Referent.Con r cid _ -> getTypeOfConstructor c r cid
componentReferencesForReference :: Monad m => Codebase m v a -> Reference -> m (Set Reference)
componentReferencesForReference c = \case
@ -195,13 +282,13 @@ componentReferencesForReference c = \case
Reference.Derived h _i ->
Set.mapMonotonic Reference.DerivedId . Reference.componentFromLength h <$> unsafeGetComponentLength c h
-- | The dependents of a builtin type includes the set of builtin terms which
-- mention that type.
-- | Get the set of terms, type declarations, and builtin types that depend on the given term, type declaration, or
-- builtin type.
dependents :: Functor m => Codebase m v a -> Reference -> m (Set Reference)
dependents c r
= Set.union (Builtin.builtinTypeDependents r)
dependents c r =
Set.union (Builtin.builtinTypeDependents r)
. Set.map Reference.DerivedId
<$> dependentsImpl c r
<$> dependentsImpl c r
dependentsOfComponent :: Functor f => Codebase f v a -> Hash -> f (Set Reference)
dependentsOfComponent c h =
@ -209,30 +296,40 @@ dependentsOfComponent c h =
. Set.map Reference.DerivedId
<$> dependentsOfComponentImpl c h
-- | Get the set of terms-or-constructors that have the given type.
termsOfType :: (Var v, Functor m) => Codebase m v a -> Type v a -> m (Set Referent.Referent)
termsOfType c ty =
termsOfType c ty = termsOfTypeByReference c $ Hashing.typeToReference ty
-- | Get all terms which match the exact type the provided reference points to.
termsOfTypeByReference :: (Var v, Functor m) => Codebase m v a -> Reference -> m (Set Referent.Referent)
termsOfTypeByReference c r =
Set.union (Rel.lookupDom r Builtin.builtinTermsByType)
. Set.map (fmap Reference.DerivedId)
<$> termsOfTypeImpl c r
where r = Hashing.typeToReference ty
-- | Get the set of terms-or-constructors mention the given type anywhere in their signature.
termsMentioningType :: (Var v, Functor m) => Codebase m v a -> Type v a -> m (Set Referent.Referent)
termsMentioningType c ty =
Set.union (Rel.lookupDom r Builtin.builtinTermsByTypeMention)
. Set.map (fmap Reference.DerivedId)
<$> termsMentioningTypeImpl c r
where r = Hashing.typeToReference ty
where
r = Hashing.typeToReference ty
-- todo: could have a way to look this up just by checking for a file rather than loading it
isTerm :: (Applicative m, Var v, BuiltinAnnotation a)
=> Codebase m v a -> Reference -> m Bool
-- | Check whether a reference is a term.
isTerm ::
(Applicative m, Var v, BuiltinAnnotation a) =>
Codebase m v a ->
Reference ->
m Bool
isTerm code = fmap isJust . getTypeOfTerm code
isType :: Applicative m => Codebase m v a -> Reference -> m Bool
isType c r = case r of
Reference.Builtin{} -> pure $ Builtin.isBuiltinType r
Reference.Builtin {} -> pure $ Builtin.isBuiltinType r
Reference.DerivedId r -> isJust <$> getTypeDeclaration c r
-- | Return whether the root branch is empty.
isBlank :: Applicative m => Codebase m v a -> m Bool
isBlank codebase = do
root <- fromMaybe Branch.empty . rightMay <$> getRootBranch codebase
@ -258,8 +355,8 @@ importRemoteBranch codebase ns mode = runExceptT do
ExceptT
let h = Branch.headHash branch
err = Left . GitCodebaseError $ GitError.CouldntLoadSyncedBranch ns h
in time "load fresh local branch after sync" $
(getBranchForHash codebase h <&> maybe err Right) <* cleanup
in time "load fresh local branch after sync" $
(getBranchForHash codebase h <&> maybe err Right) <* cleanup
-- | Pull a git branch and view it from the cache, without syncing into the
-- local codebase.
@ -272,33 +369,34 @@ viewRemoteBranch codebase ns = runExceptT do
(cleanup, branch, _) <- ExceptT $ viewRemoteBranch' codebase ns
pure (cleanup, branch)
unsafeGetTerm :: (HasCallStack, Monad m) => Codebase m v a -> Reference.Id -> m (Term v a)
unsafeGetTerm codebase rid =
getTerm codebase rid >>= \case
Nothing -> error (reportBug "E520818" ("term " ++ show rid ++ " not found"))
Just term -> pure term
unsafeGetTypeDeclaration :: (HasCallStack, Monad m) => Codebase m v a -> Reference.Id -> m (Decl v a)
unsafeGetTypeDeclaration codebase rid =
getTypeDeclaration codebase rid >>= \case
Nothing -> error (reportBug "E129043" ("type decl " ++ show rid ++ " not found"))
Just decl -> pure decl
unsafeGetTypeOfTermById :: (HasCallStack, Monad m) => Codebase m v a -> Reference.Id -> m (Type v a)
unsafeGetTypeOfTermById codebase rid =
getTypeOfTermImpl codebase rid >>= \case
Nothing -> error (reportBug "E377910" ("type of term " ++ show rid ++ " not found"))
Just ty -> pure ty
unsafeGetComponentLength :: (HasCallStack, Monad m) => Codebase m v a -> Hash -> m Reference.CycleSize
unsafeGetComponentLength codebase h =
getComponentLength codebase h >>= \case
Nothing -> error (reportBug "E713350" ("component with hash " ++ show h ++ " not found"))
Just size -> pure size
-- | Get a term with its type.
--
-- Precondition: the term exists in the codebase.
-- | Like 'getTerm', for when the term is known to exist in the codebase.
unsafeGetTerm :: (HasCallStack, Monad m) => Codebase m v a -> Reference.Id -> m (Term v a)
unsafeGetTerm codebase rid =
getTerm codebase rid >>= \case
Nothing -> error (reportBug "E520818" ("term " ++ show rid ++ " not found"))
Just term -> pure term
-- | Like 'getTypeDeclaration', for when the type declaration is known to exist in the codebase.
unsafeGetTypeDeclaration :: (HasCallStack, Monad m) => Codebase m v a -> Reference.Id -> m (Decl v a)
unsafeGetTypeDeclaration codebase rid =
getTypeDeclaration codebase rid >>= \case
Nothing -> error (reportBug "E129043" ("type decl " ++ show rid ++ " not found"))
Just decl -> pure decl
-- | Like 'getTypeOfTerm', but for when the term is known to exist in the codebase.
unsafeGetTypeOfTermById :: (HasCallStack, Monad m) => Codebase m v a -> Reference.Id -> m (Type v a)
unsafeGetTypeOfTermById codebase rid =
getTypeOfTermImpl codebase rid >>= \case
Nothing -> error (reportBug "E377910" ("type of term " ++ show rid ++ " not found"))
Just ty -> pure ty
-- | Like 'unsafeGetTerm', but returns the type of the term, too.
unsafeGetTermWithType :: (HasCallStack, Monad m) => Codebase m v a -> Reference.Id -> m (Term v a, Type v a)
unsafeGetTermWithType codebase rid = do
term <- unsafeGetTerm codebase rid

2
parser-typechecker/src/Unison/Codebase/CodeLookup.hs
View File

@ -65,4 +65,4 @@ transitiveDependencies code seen0 rid = if Set.member rid seen0
(getIds $ DD.dependencies (DD.toDataDecl ed))
Just (Right dd) -> foldM (transitiveDependencies code)
seen
(getIds $ DD.dependencies dd)
(getIds $ DD.dependencies dd)

26
parser-typechecker/src/Unison/Codebase/Editor/Git.hs
View File

@ -18,8 +18,8 @@ import UnliftIO.Directory (XdgDirectory (XdgCache), doesDirectoryExist, findExec
import UnliftIO.IO (hFlush, stdout)
import qualified Data.ByteString.Base16 as ByteString
import qualified Data.Char as Char
import Control.Exception.Safe (catchIO, MonadCatch)
import Unison.Codebase.GitError (GitProtocolError)
import UnliftIO (handleIO)
-- https://superuser.com/questions/358855/what-characters-are-safe-in-cross-platform-file-names-for-linux-windows-and-os
@ -56,7 +56,7 @@ withStatus str ma = do
-- | Given a remote git repo url, and branch/commit hash (currently
-- not allowed): checks for git, clones or updates a cached copy of the repo
pullBranch :: (MonadIO m, MonadCatch m, MonadError GitProtocolError m) => ReadRepo -> m CodebasePath
pullBranch :: (MonadIO m, MonadError GitProtocolError m) => ReadRepo -> m CodebasePath
pullBranch repo@(ReadGitRepo uri) = do
checkForGit
localPath <- tempGitDir uri
@ -83,7 +83,7 @@ pullBranch repo@(ReadGitRepo uri) = do
unless isGitDir . throwError $ GitError.UnrecognizableCheckoutDir repo localPath
-- | Do a `git pull` on a cached repo.
checkoutExisting :: (MonadIO m, MonadCatch m, MonadError GitProtocolError m)
checkoutExisting :: (MonadIO m, MonadError GitProtocolError m)
=> FilePath
-> Maybe Text
-> m ()
@ -94,15 +94,17 @@ pullBranch repo@(ReadGitRepo uri) = do
-- be too, so this impl. just wipes the cached copy and starts from scratch.
goFromScratch
-- Otherwise proceed!
(catchIO
(withStatus ("Updating cached copy of " ++ Text.unpack uri ++ " ...") $ do
-- Fetch only the latest commit, we don't need history.
gitIn localPath (["fetch", "origin", remoteRef, "--quiet"] ++ ["--depth", "1"])
-- Reset our branch to point at the latest code from the remote.
gitIn localPath ["reset", "--hard", "--quiet", "FETCH_HEAD"]
-- Wipe out any unwanted files which might be sitting around, but aren't in the commit.
gitIn localPath ["clean", "-d", "--force", "--quiet"])
(const $ goFromScratch))
do
succeeded <- liftIO . handleIO (const $ pure False) $ do
withStatus ("Updating cached copy of " ++ Text.unpack uri ++ " ...") $ do
-- Fetch only the latest commit, we don't need history.
gitIn localPath (["fetch", "origin", remoteRef, "--quiet"] ++ ["--depth", "1"])
-- Reset our branch to point at the latest code from the remote.
gitIn localPath ["reset", "--hard", "--quiet", "FETCH_HEAD"]
-- Wipe out any unwanted files which might be sitting around, but aren't in the commit.
gitIn localPath ["clean", "-d", "--force", "--quiet"]
pure True
when (not succeeded) $ goFromScratch
where
remoteRef :: Text

21
parser-typechecker/src/Unison/Codebase/Runtime.hs
View File

@ -47,14 +47,14 @@ data Runtime v = Runtime
type IsCacheHit = Bool
noCache :: Reference -> IO (Maybe (Term v))
noCache :: Reference.Id -> IO (Maybe (Term v))
noCache _ = pure Nothing
type WatchResults v a = (Either Error
-- Bindings:
( [(v, Term v)]
-- Map watchName (loc, hash, expression, value, isHit)
, Map v (a, WatchKind, Reference, Term v, Term v, IsCacheHit)
, Map v (a, WatchKind, Reference.Id, Term v, Term v, IsCacheHit)
))
-- Evaluates the watch expressions in the file, returning a `Map` of their
@ -70,14 +70,14 @@ evaluateWatches
. Var v
=> CL.CodeLookup v IO a
-> PPE.PrettyPrintEnv
-> (Reference -> IO (Maybe (Term v)))
-> (Reference.Id -> IO (Maybe (Term v)))
-> Runtime v
-> TypecheckedUnisonFile v a
-> IO (WatchResults v a)
evaluateWatches code ppe evaluationCache rt tuf = do
-- 1. compute hashes for everything in the file
let m :: Map v (Reference, Term.Term v a)
m = fmap (\(id, _wk, tm, _tp) -> (Reference.DerivedId id, tm)) (UF.hashTermsId tuf)
let m :: Map v (Reference.Id, Term.Term v a)
m = fmap (\(id, _wk, tm, _tp) -> (id, tm)) (UF.hashTermsId tuf)
watches :: Set v = Map.keysSet watchKinds
watchKinds :: Map v WatchKind
watchKinds =
@ -91,7 +91,7 @@ evaluateWatches code ppe evaluationCache rt tuf = do
Nothing -> pure (v, (r, ABT.annotation t, unann t, False))
Just t' -> pure (v, (r, ABT.annotation t, t', True))
-- 3. create a big ol' let rec whose body is a big tuple of all watches
let rv :: Map Reference v
let rv :: Map Reference.Id v
rv = Map.fromList [ (r, v) | (v, (r, _)) <- Map.toList m ]
bindings :: [(v, Term v)]
bindings = [ (v, unref rv b) | (v, (_, _, b, _)) <- Map.toList m' ]
@ -117,10 +117,10 @@ evaluateWatches code ppe evaluationCache rt tuf = do
pure $ Right (bindings, watchMap)
Left e -> pure (Left e)
where
-- unref :: Map Reference v -> Term.Term v a -> Term.Term v a
-- unref :: Map Reference.Id v -> Term.Term v a -> Term.Term v a
unref rv t = ABT.visitPure go t
where
go t@(Term.Ref' r@(Reference.DerivedId _)) = case Map.lookup r rv of
go t@(Term.Ref' (Reference.DerivedId r)) = case Map.lookup r rv of
Nothing -> Nothing
Just v -> Just (Term.var (ABT.annotation t) v)
go _ = Nothing
@ -128,14 +128,13 @@ evaluateWatches code ppe evaluationCache rt tuf = do
evaluateTerm'
:: (Var v, Monoid a)
=> CL.CodeLookup v IO a
-> (Reference -> IO (Maybe (Term v)))
-> (Reference.Id -> IO (Maybe (Term v)))
-> PPE.PrettyPrintEnv
-> Runtime v
-> Term.Term v a
-> IO (Either Error (Term v))
evaluateTerm' codeLookup cache ppe rt tm = do
let ref = Reference.DerivedId (Hashing.hashClosedTerm tm)
result <- cache ref
result <- cache (Hashing.hashClosedTerm tm)
case result of
Just r -> pure (Right r)
Nothing -> do

191
parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs
View File

@ -8,14 +8,10 @@
module Unison.Codebase.SqliteCodebase
( Unison.Codebase.SqliteCodebase.init,
unsafeGetConnection,
shutdownConnection,
)
where
import qualified Control.Concurrent
import qualified Control.Exception
import Control.Exception.Safe (MonadCatch)
import Control.Monad (filterM, unless, when, (>=>))
import Control.Monad.Except (ExceptT (ExceptT), MonadError (throwError), runExceptT, withExceptT)
import qualified Control.Monad.Except as Except
@ -115,6 +111,8 @@ import qualified Unison.WatchKind as UF
import UnliftIO (MonadIO, catchIO, finally, try, liftIO, MonadUnliftIO)
import UnliftIO.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist)
import UnliftIO.STM
import UnliftIO.Exception (bracket)
import Control.Monad.Trans.Except (mapExceptT)
debug, debugProcessBranches, debugCommitFailedTransaction :: Bool
debug = False
@ -131,11 +129,11 @@ backupCodebasePath now =
v2dir :: FilePath -> FilePath
v2dir root = root </> ".unison" </> "v2"
init :: HasCallStack => (MonadUnliftIO m, MonadCatch m) => Codebase.Init m Symbol Ann
init :: HasCallStack => (MonadUnliftIO m) => Codebase.Init m Symbol Ann
init = Codebase.Init getCodebaseOrError createCodebaseOrError v2dir
createCodebaseOrError ::
(MonadUnliftIO m, MonadCatch m) =>
(MonadUnliftIO m) =>
Codebase.DebugName ->
CodebasePath ->
m (Either Codebase1.CreateCodebaseError (m (), Codebase m Symbol Ann))
@ -155,7 +153,7 @@ data CreateCodebaseError
deriving (Show)
createCodebaseOrError' ::
(MonadUnliftIO m, MonadCatch m) =>
(MonadUnliftIO m) =>
Codebase.DebugName ->
CodebasePath ->
m (Either CreateCodebaseError (m (), Codebase m Symbol Ann))
@ -166,19 +164,21 @@ createCodebaseOrError' debugName path = do
do
createDirectoryIfMissing True (path </> FilePath.takeDirectory codebasePath)
liftIO $
Control.Exception.bracket
(unsafeGetConnection (debugName ++ ".createSchema") path)
shutdownConnection
(runReaderT do
Q.createSchema
runExceptT (void . Ops.saveRootBranch $ Cv.causalbranch1to2 Branch.empty) >>= \case
Left e -> error $ show e
Right () -> pure ()
)
withConnection (debugName ++ ".createSchema") path $
( runReaderT do
Q.createSchema
runExceptT (void . Ops.saveRootBranch $ Cv.causalbranch1to2 Branch.empty) >>= \case
Left e -> error $ show e
Right () -> pure ()
)
fmap (Either.mapLeft CreateCodebaseUnknownSchemaVersion) (sqliteCodebase debugName path Local)
openOrCreateCodebaseConnection :: MonadIO m => Codebase.DebugName -> FilePath -> m Connection
openOrCreateCodebaseConnection ::
MonadIO m =>
Codebase.DebugName ->
FilePath ->
m (IO (), Connection)
openOrCreateCodebaseConnection debugName path = do
unlessM
(doesFileExist $ path </> codebasePath)
@ -186,7 +186,12 @@ openOrCreateCodebaseConnection debugName path = do
unsafeGetConnection debugName path
-- get the codebase in dir
getCodebaseOrError :: forall m. (MonadUnliftIO m, MonadCatch m) => Codebase.DebugName -> CodebasePath -> m (Either Codebase1.Pretty (m (), Codebase m Symbol Ann))
getCodebaseOrError ::
forall m.
(MonadUnliftIO m) =>
Codebase.DebugName ->
CodebasePath ->
m (Either Codebase1.Pretty (m (), Codebase m Symbol Ann))
getCodebaseOrError debugName dir = do
prettyDir <- liftIO $ P.string <$> canonicalizePath dir
let prettyError v = P.wrap $ "I don't know how to handle " <> P.shown v <> "in" <> P.backticked' prettyDir "."
@ -201,10 +206,7 @@ initSchemaIfNotExist path = liftIO do
unlessM (doesDirectoryExist $ path </> FilePath.takeDirectory codebasePath) $
createDirectoryIfMissing True (path </> FilePath.takeDirectory codebasePath)
unlessM (doesFileExist $ path </> codebasePath) $
Control.Exception.bracket
(unsafeGetConnection "initSchemaIfNotExist" path)
shutdownConnection
(runReaderT Q.createSchema)
withConnection "initSchemaIfNotExist" path $ runReaderT Q.createSchema
-- checks if a db exists at `path` with the minimum schema
codebaseExists :: MonadIO m => CodebasePath -> m Bool
@ -263,18 +265,42 @@ type TermBufferEntry = BufferEntry (Term Symbol Ann, Type Symbol Ann)
type DeclBufferEntry = BufferEntry (Decl Symbol Ann)
unsafeGetConnection :: MonadIO m => Codebase.DebugName -> CodebasePath -> m Connection
-- | Create a new sqlite connection to the database at the given path.
-- the caller is responsible for calling the returned cleanup method once finished with the
-- connection.
-- The connection may not be used after it has been cleaned up.
-- Prefer using 'withConnection' if you can, as it guarantees the connection will be properly
-- closed for you.
unsafeGetConnection ::
MonadIO m =>
Codebase.DebugName ->
CodebasePath ->
m (IO (), Connection)
unsafeGetConnection name root = do
let path = root </> codebasePath
Monad.when debug $ traceM $ "unsafeGetconnection " ++ name ++ " " ++ root ++ " -> " ++ path
(Connection name path -> conn) <- liftIO $ Sqlite.open path
runReaderT Q.setFlags conn
pure conn
pure (shutdownConnection conn, conn)
where
shutdownConnection :: MonadIO m => Connection -> m ()
shutdownConnection conn = do
Monad.when debug $ traceM $ "shutdown connection " ++ show conn
liftIO $ Sqlite.close (Connection.underlying conn)
shutdownConnection :: MonadIO m => Connection -> m ()
shutdownConnection conn = do
Monad.when debug $ traceM $ "shutdown connection " ++ show conn
liftIO $ Sqlite.close (Connection.underlying conn)
-- | Run an action with a connection to the codebase, closing the connection on completion or
-- failure.
withConnection ::
MonadUnliftIO m =>
Codebase.DebugName ->
CodebasePath ->
(Connection -> m a) ->
m a
withConnection name root act = do
bracket
(unsafeGetConnection name root)
(\(closeConn, _) -> liftIO closeConn)
(\(_, conn) -> act conn)
-- | Whether a codebase is local or remote.
data LocalOrRemote
@ -283,7 +309,7 @@ data LocalOrRemote
sqliteCodebase ::
forall m.
(MonadUnliftIO m, MonadCatch m) =>
MonadUnliftIO m =>
Codebase.DebugName ->
CodebasePath ->
-- | When local, back up the existing codebase before migrating, in case there's a catastrophic bug in the migration.
@ -291,7 +317,7 @@ sqliteCodebase ::
m (Either SchemaVersion (m (), Codebase m Symbol Ann))
sqliteCodebase debugName root localOrRemote = do
Monad.when debug $ traceM $ "sqliteCodebase " ++ debugName ++ " " ++ root
conn <- unsafeGetConnection debugName root
(closeConn, conn) <- unsafeGetConnection debugName root
termCache <- Cache.semispaceCache 8192 -- pure Cache.nullCache -- to disable
typeOfTermCache <- Cache.semispaceCache 8192
declCache <- Cache.semispaceCache 1024
@ -647,18 +673,18 @@ sqliteCodebase debugName root localOrRemote = do
Set.map Cv.referenceid2to1
<$> Ops.dependentsOfComponent (Cv.hash1to2 h)
syncFromDirectory :: MonadIO m => Codebase1.CodebasePath -> SyncMode -> Branch m -> m ()
syncFromDirectory srcRoot _syncMode b =
flip State.evalStateT emptySyncProgressState $ do
srcConn <- unsafeGetConnection (debugName ++ ".sync.src") srcRoot
syncInternal syncProgress srcConn conn $ Branch.transform lift b
syncFromDirectory :: MonadUnliftIO m => Codebase1.CodebasePath -> SyncMode -> Branch m -> m ()
syncFromDirectory srcRoot _syncMode b = do
withConnection (debugName ++ ".sync.src") srcRoot $ \srcConn -> do
flip State.evalStateT emptySyncProgressState $ do
syncInternal syncProgress srcConn conn $ Branch.transform lift b
syncToDirectory :: MonadIO m => Codebase1.CodebasePath -> SyncMode -> Branch m -> m ()
syncToDirectory :: MonadUnliftIO m => Codebase1.CodebasePath -> SyncMode -> Branch m -> m ()
syncToDirectory destRoot _syncMode b =
flip State.evalStateT emptySyncProgressState $ do
initSchemaIfNotExist destRoot
destConn <- unsafeGetConnection (debugName ++ ".sync.dest") destRoot
syncInternal syncProgress conn destConn $ Branch.transform lift b
withConnection (debugName ++ ".sync.dest") destRoot $ \destConn ->
flip State.evalStateT emptySyncProgressState $ do
initSchemaIfNotExist destRoot
syncInternal syncProgress conn destConn $ Branch.transform lift b
watches :: MonadIO m => UF.WatchKind -> m [Reference.Id]
watches w =
@ -773,18 +799,15 @@ sqliteCodebase debugName root localOrRemote = do
pure $ Set.map (Causal.RawHash . Cv.hash2to1 . unCausalHash) cs
sqlLca :: MonadIO m => Branch.Hash -> Branch.Hash -> m (Maybe Branch.Hash)
sqlLca h1 h2 = liftIO $ Control.Exception.bracket open close \(c1, c2) ->
runDB conn
. (fmap . fmap) Cv.causalHash2to1
$ Ops.lca (Cv.causalHash1to2 h1) (Cv.causalHash1to2 h2) c1 c2
where
open = (,) <$> unsafeGetConnection (debugName ++ ".lca.left") root
<*> unsafeGetConnection (debugName ++ ".lca.left") root
close (c1, c2) = shutdownConnection c1 *> shutdownConnection c2
sqlLca h1 h2 =
liftIO $ withConnection (debugName ++ ".lca.left") root $ \c1 -> do
withConnection (debugName ++ ".lca.right") root $ \c2 -> do
runDB conn
. (fmap . fmap) Cv.causalHash2to1
$ Ops.lca (Cv.causalHash1to2 h1) (Cv.causalHash1to2 h2) c1 c2
let finalizer :: MonadIO m => m ()
finalizer = do
shutdownConnection conn
liftIO $ closeConn
decls <- readTVarIO declBuffer
terms <- readTVarIO termBuffer
let printBuffer header b =
@ -798,7 +821,7 @@ sqliteCodebase debugName root localOrRemote = do
pure $
( finalizer,
let
code = Codebase1.Codebase
code = C.Codebase
(Cache.applyDefined termCache getTerm)
(Cache.applyDefined typeOfTermCache getTypeOfTermImpl)
(Cache.applyDefined declCache getTypeDeclaration)
@ -856,7 +879,7 @@ sqliteCodebase debugName root localOrRemote = do
migrateSchema12 conn codebase
-- it's ok to pass codebase along; whatever it cached during the migration won't break anything
pure (Right (cleanup, codebase))
v -> shutdownConnection conn $> Left v
v -> liftIO closeConn $> Left v
-- well one or the other. :zany_face: the thinking being that they wouldn't hash-collide
termExists', declExists' :: MonadIO m => Hash -> ReaderT Connection (ExceptT Ops.Error m) Bool
@ -1076,7 +1099,7 @@ syncProgress = Sync.Progress need done warn allDone
viewRemoteBranch' ::
forall m.
(MonadUnliftIO m, MonadCatch m) =>
(MonadUnliftIO m) =>
ReadRemoteNamespace ->
m (Either C.GitError (m (), Branch m, CodebasePath))
viewRemoteBranch' (repo, sbh, path) = runExceptT @C.GitError do
@ -1120,7 +1143,7 @@ viewRemoteBranch' (repo, sbh, path) = runExceptT @C.GitError do
-- Given a branch that is "after" the existing root of a given git repo,
-- stage and push the branch (as the new root) + dependencies to the repo.
pushGitRootBranch ::
(MonadIO m, MonadCatch m) =>
(MonadUnliftIO m) =>
Connection ->
Branch m ->
WriteRepo ->
@ -1136,40 +1159,38 @@ pushGitRootBranch srcConn branch repo = runExceptT @C.GitError do
-- set up the cache dir
remotePath <- time "Git fetch" $ withExceptT C.GitProtocolError $ pullBranch (writeToRead repo)
destConn <- openOrCreateCodebaseConnection "push.dest" remotePath
(closeDestConn, destConn) <- openOrCreateCodebaseConnection "push.dest" remotePath
mapExceptT (`finally` liftIO closeDestConn) $ do
flip runReaderT destConn $ Q.savepoint "push"
lift . flip State.execStateT emptySyncProgressState $
syncInternal syncProgress srcConn destConn (Branch.transform lift branch)
flip runReaderT destConn do
let newRootHash = Branch.headHash branch
-- the call to runDB "handles" the possible DB error by bombing
(fmap . fmap) Cv.branchHash2to1 (runDB destConn Ops.loadMaybeRootCausalHash) >>= \case
Nothing -> do
setRepoRoot newRootHash
Q.release "push"
Just oldRootHash -> do
before oldRootHash newRootHash >>= \case
Nothing ->
error $
"I couldn't find the hash " ++ show newRootHash
++ " that I just synced to the cached copy of "
++ repoString
++ " in "
++ show remotePath
++ "."
Just False -> do
Q.rollbackRelease "push"
throwError . C.GitProtocolError $ GitError.PushDestinationHasNewStuff repo
flip runReaderT destConn $ Q.savepoint "push"
lift . flip State.execStateT emptySyncProgressState $
syncInternal syncProgress srcConn destConn (Branch.transform lift branch)
flip runReaderT destConn do
let newRootHash = Branch.headHash branch
-- the call to runDB "handles" the possible DB error by bombing
(fmap . fmap) Cv.branchHash2to1 (runDB destConn Ops.loadMaybeRootCausalHash) >>= \case
Nothing -> do
setRepoRoot newRootHash
Q.release "push"
Just oldRootHash -> do
before oldRootHash newRootHash >>= \case
Nothing ->
error $
"I couldn't find the hash " ++ show newRootHash
++ " that I just synced to the cached copy of "
++ repoString
++ " in "
++ show remotePath
++ "."
Just False -> do
Q.rollbackRelease "push"
throwError . C.GitProtocolError $ GitError.PushDestinationHasNewStuff repo
Just True -> do
setRepoRoot newRootHash
Q.release "push"
Q.setJournalMode JournalMode.DELETE
Just True -> do
setRepoRoot newRootHash
Q.release "push"
Q.setJournalMode JournalMode.DELETE
liftIO do
shutdownConnection destConn
void $ push remotePath repo
where
repoString = Text.unpack $ printWriteRepo repo

2
parser-typechecker/src/Unison/Codebase/SqliteCodebase/MigrateSchema12.hs
View File

@ -55,7 +55,7 @@ import qualified U.Codebase.WatchKind as WK
import U.Util.Monoid (foldMapM)
import qualified U.Util.Set as Set
import qualified Unison.ABT as ABT
import Unison.Codebase (Codebase (Codebase))
import Unison.Codebase.Type (Codebase (Codebase))
import qualified Unison.Codebase as Codebase
import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv
import qualified Unison.Codebase.SqliteCodebase.MigrateSchema12.DbHelpers as Hashing

76
parser-typechecker/src/Unison/Codebase/Type.hs
View File

@ -31,54 +31,108 @@ type SyncToDir m =
m ()
-- | Abstract interface to a user's codebase.
--
-- One implementation is 'Unison.Codebase.FileCodebase' which uses the filesystem.
data Codebase m v a = Codebase
{ getTerm :: Reference.Id -> m (Maybe (Term v a)),
{ -- | Get a user-defined term from the codebase.
--
-- Note that it is possible to call 'putTerm', then 'getTerm', and receive @Nothing@, per the semantics of
-- 'putTerm'.
getTerm :: Reference.Id -> m (Maybe (Term v a)),
-- | Get the type of a user-defined term.
--
-- Note that it is possible to call 'putTerm', then 'getTypeOfTermImpl', and receive @Nothing@, per the semantics of
-- 'putTerm'.
getTypeOfTermImpl :: Reference.Id -> m (Maybe (Type v a)),
-- | Get a type declaration.
--
-- Note that it is possible to call 'putTypeDeclaration', then 'getTypeDeclaration', and receive @Nothing@, per the
-- semantics of 'putTypeDeclaration'.
getTypeDeclaration :: Reference.Id -> m (Maybe (Decl v a)),
-- | Enqueue the put of a user-defined term (with its type) into the codebase, if it doesn't already exist. The
-- implementation may choose to delay the put until all of the term's (and its type's) references are stored as
-- well.
putTerm :: Reference.Id -> Term v a -> Type v a -> m (),
-- | Enqueue the put of a type declaration into the codebase, if it doesn't already exist. The implementation may
-- choose to delay the put until all of the type declaration's references are stored as well.
putTypeDeclaration :: Reference.Id -> Decl v a -> m (),
-- getTermComponent :: Hash -> m (Maybe [Term v a]),
getTermComponentWithTypes :: Hash -> m (Maybe [(Term v a, Type v a)]),
getDeclComponent :: Hash -> m (Maybe [Decl v a]),
getComponentLength :: Hash -> m (Maybe Reference.CycleSize),
-- | Get the root branch.
getRootBranch :: m (Either GetRootBranchError (Branch m)),
-- | Like 'putBranch', but also adjusts the root branch pointer afterwards.
putRootBranch :: Branch m -> m (),
rootBranchUpdates :: m (IO (), IO (Set Branch.Hash)),
getBranchForHashImpl :: Branch.Hash -> m (Maybe (Branch m)),
-- | Put a branch into the codebase, which includes its children, its patches, and the branch itself, if they don't
-- already exist.
--
-- The terms and type declarations that a branch references must already exist in the codebase.
putBranch :: Branch m -> m (),
-- | Check whether the given branch exists in the codebase.
branchExists :: Branch.Hash -> m Bool,
-- | Get a patch from the codebase.
getPatch :: Branch.EditHash -> m (Maybe Patch),
-- | Put a patch into the codebase.
--
-- Note that 'putBranch' may also put patches.
putPatch :: Branch.EditHash -> Patch -> m (),
-- | Check whether the given patch exists in the codebase.
patchExists :: Branch.EditHash -> m Bool,
-- | Get the set of user-defined terms and type declarations that depend on the given term, type declaration, or
-- builtin type.
dependentsImpl :: Reference -> m (Set Reference.Id),
dependentsOfComponentImpl :: Hash -> m (Set Reference.Id),
-- This copies all the dependencies of `b` from the specified Codebase into this one
-- | Copy a branch and all of its dependencies from the given codebase into this one.
syncFromDirectory :: CodebasePath -> SyncMode -> Branch m -> m (),
-- This copies all the dependencies of `b` from this Codebase
-- | Copy a branch and all of its dependencies from this codebase into the given codebase.
syncToDirectory :: CodebasePath -> SyncMode -> Branch m -> m (),
viewRemoteBranch' :: ReadRemoteNamespace -> m (Either GitError (m (), Branch m, CodebasePath)),
-- | Push the given branch to the given repo, and set it as the root branch.
pushGitRootBranch :: Branch m -> WriteRepo -> SyncMode -> m (Either GitError ()),
-- Watch expressions are part of the codebase, the `Reference.Id` is
-- the hash of the source of the watch expression, and the `Term v a`
-- is the evaluated result of the expression, decompiled to a term.
-- | @watches k@ returns all of the references @r@ that were previously put by a @putWatch k r t@. @t@ can be
-- retrieved by @getWatch k r@.
watches :: WK.WatchKind -> m [Reference.Id],
-- | @getWatch k r@ returns watch result @t@ that was previously put by @putWatch k r t@.
getWatch :: WK.WatchKind -> Reference.Id -> m (Maybe (Term v a)),
-- | @putWatch k r t@ puts a watch of kind @k@, with hash-of-expression @r@ and decompiled result @t@ into the
-- codebase.
--
-- For example, in the watch expression below, @k@ is 'WK.Regular', @r@ is the hash of @x@, and @t@ is @7@.
--
-- @
-- > x = 3 + 4
-- ⧩
-- 7
-- @
putWatch :: WK.WatchKind -> Reference.Id -> Term v a -> m (),
-- | Delete all watches that were put by 'putWatch'.
clearWatches :: m (),
-- | Get the entire reflog.
getReflog :: m [Reflog.Entry Branch.Hash],
-- | @appendReflog reason before after@ appends a reflog entry.
--
-- FIXME: this could have type
--
-- @
-- appendReflog :: Reflog.Entry (Branch m) -> m ()
-- @
appendReflog :: Text -> Branch m -> Branch m -> m (),
-- list of terms of the given type
-- | Get the set of user-defined terms-or-constructors that have the given type.
termsOfTypeImpl :: Reference -> m (Set Referent.Id),
-- list of terms that mention the given type anywhere in their signature
-- | Get the set of user-defined terms-or-constructors mention the given type anywhere in their signature.
termsMentioningTypeImpl :: Reference -> m (Set Referent.Id),
-- number of base58 characters needed to distinguish any two references in the codebase
-- | The number of base32 characters needed to distinguish any two references in the codebase.
hashLength :: m Int,
-- | Get the set of user-defined terms whose hash matches the given prefix.
termReferencesByPrefix :: ShortHash -> m (Set Reference.Id),
-- | Get the set of type declarations whose hash matches the given prefix.
typeReferencesByPrefix :: ShortHash -> m (Set Reference.Id),
-- | Get the set of user-defined terms-or-constructors whose hash matches the given prefix.
termReferentsByPrefix :: ShortHash -> m (Set Referent.Id),
-- | The number of base32 characters needed to distinguish any two branch in the codebase.
branchHashLength :: m Int,
-- | Get the set of branches whose hash matches the given prefix.
branchHashesByPrefix :: ShortBranchHash -> m (Set Branch.Hash),
-- returns `Nothing` to not implemented, fallback to in-memory
-- also `Nothing` if no LCA

1
parser-typechecker/src/Unison/CodebasePath.hs
View File

@ -7,6 +7,7 @@ where
import Control.Monad.IO.Class (MonadIO)
import UnliftIO.Directory (getHomeDirectory)
-- | A directory that contains a codebase.
type CodebasePath = FilePath
getCodebaseDir :: MonadIO m => Maybe CodebasePath -> m CodebasePath

2
parser-typechecker/src/Unison/Runtime/Foreign.hs
View File

@ -50,6 +50,7 @@ ref2eq r
| r == Ty.mvarRef = Just $ promote ((==) @(MVar ()))
-- Ditto
| r == Ty.refRef = Just $ promote ((==) @(IORef ()))
| r == Ty.threadIdRef = Just $ promote ((==) @ThreadId)
| otherwise = Nothing
ref2cmp :: Reference -> Maybe (a -> b -> Ordering)
@ -58,6 +59,7 @@ ref2cmp r
| r == Ty.termLinkRef = Just $ promote (compare @Referent)
| r == Ty.typeLinkRef = Just $ promote (compare @Reference)
| r == Ty.bytesRef = Just $ promote (compare @Bytes)
| r == Ty.threadIdRef = Just $ promote (compare @ThreadId)
| otherwise = Nothing
instance Eq Foreign where

18
parser-typechecker/src/Unison/Runtime/Pattern.hs
View File

@ -153,13 +153,13 @@ extractVars = catMaybes . fmap extractVar
-- convenient to yield a list here.
decomposePattern
:: Var v
=> Reference -> Int -> Int -> P.Pattern v
=> Maybe Reference -> Int -> Int -> P.Pattern v
-> [[P.Pattern v]]
decomposePattern rf0 t _ (P.Boolean _ b)
decomposePattern (Just rf0) t _ (P.Boolean _ b)
| rf0 == Rf.booleanRef
, t == if b then 1 else 0
= [[]]
decomposePattern rf0 t nfields p@(P.Constructor _ rf u ps)
decomposePattern (Just rf0) t nfields p@(P.Constructor _ rf u ps)
| t == fromIntegral u
, rf0 == rf
= if length ps == nfields
@ -168,7 +168,7 @@ decomposePattern rf0 t nfields p@(P.Constructor _ rf u ps)
where
err = "decomposePattern: wrong number of constructor fields: "
++ show (nfields, p)
decomposePattern rf0 t nfields p@(P.EffectBind _ rf u ps pk)
decomposePattern (Just rf0) t nfields p@(P.EffectBind _ rf u ps pk)
| t == fromIntegral u
, rf0 == rf
= if length ps + 1 == nfields
@ -311,7 +311,7 @@ decomposeSeqP _ _ _ = Overlap
splitRow
:: Var v
=> v
-> Reference
-> Maybe Reference
-> Int
-> Int
-> PatternRow v
@ -467,7 +467,7 @@ splitMatrixSeq avoid v (PM rs)
splitMatrix
:: Var v
=> v
-> Reference
-> Maybe Reference
-> NCons
-> PatternMatrix v
-> [(Int, [(v,PType)], PatternMatrix v)]
@ -604,17 +604,17 @@ compile spec ctx m@(PM (r:rs))
Right cons ->
match () (var () v)
$ buildCase spec rf False cons ctx
<$> splitMatrix v rf (numberCons cons) m
<$> splitMatrix v (Just rf) (numberCons cons) m
Left err -> internalBug err
| PReq rfs <- ty
= match () (var () v) $
[ buildCasePure spec ctx tup
| tup <- splitMatrix v undefined [(-1,1)] m
| tup <- splitMatrix v Nothing [(-1,1)] m
] ++
[ buildCase spec rf True cons ctx tup
| rf <- Set.toList rfs
, Right cons <- [lookupAbil rf spec]
, tup <- splitMatrix v rf (numberCons cons) m
, tup <- splitMatrix v (Just rf) (numberCons cons) m
]
| Unknown <- ty
= internalBug "unknown pattern compilation type"

6
parser-typechecker/src/Unison/Server/Doc.hs
View File

@ -161,7 +161,7 @@ renderDoc pped terms typeOf eval types tm = eval tm >>= \case
goSignatures rs = runMaybeT (traverse (MaybeT . typeOf) rs) >>= \case
Nothing -> pure ["🆘 codebase is missing type signature for these definitions"]
Just types -> pure . fmap P.group $
TypePrinter.prettySignatures''
TypePrinter.prettySignaturesST
(PPE.suffixifiedPPE pped)
[ (r, PPE.termName (PPE.suffixifiedPPE pped) r, ty) | (r,ty) <- zip rs types]
@ -266,8 +266,8 @@ renderDoc pped terms typeOf eval types tm = eval tm >>= \case
Just tm -> do
typ <- fromMaybe (Type.builtin() "unknown") <$> typeOf (Referent.Ref ref)
let name = PPE.termName ppe (Referent.Ref ref)
let folded = formatPretty . P.lines
$ TypePrinter.prettySignatures'' ppe [(Referent.Ref ref, name, typ)]
let folded = formatPretty . P.lines
$ TypePrinter.prettySignaturesST ppe [(Referent.Ref ref, name, typ)]
let full tm@(Term.Ann' _ _) _ =
formatPretty (TermPrinter.prettyBinding ppe name tm)
full tm typ =

54
parser-typechecker/src/Unison/Server/Doc/AsHtml.hs
View File

@ -94,11 +94,11 @@ foldedToHtml attrs isFolded =
IsFolded isFolded summary details ->
let attrsWithOpen =
if isFolded
then open_ "open" : attrs
else attrs
then attrs
else open_ "open" : attrs
in details_ attrsWithOpen $ do
summary_ [class_ "folded-content"] $ sequence_ summary
div_ [class_ "folded-content"] $ sequence_ details
summary_ [class_ "folded-content folded-summary"] $ sequence_ summary
div_ [class_ "folded-content folded-details"] $ sequence_ details
foldedToHtmlSource :: Bool -> EmbeddedSource -> Html ()
foldedToHtmlSource isFolded source =
@ -185,9 +185,30 @@ toHtml docNamesByRef document =
toHtml_ sectionLevel
sectionContentToHtml renderer doc_ =
-- Block elements can't be children for <p> elements
case doc_ of
Paragraph _ ->
p_ [] $ renderer doc_
Paragraph [CodeBlock {}] -> renderer doc_
Paragraph [Blockquote _] -> renderer doc_
Paragraph [Blankline] -> renderer doc_
Paragraph [SectionBreak] -> renderer doc_
Paragraph [Callout {} ] -> renderer doc_
Paragraph [Table _] -> renderer doc_
Paragraph [Folded {} ] -> renderer doc_
Paragraph [BulletedList _] -> renderer doc_
Paragraph [NumberedList {}] -> renderer doc_
-- Paragraph [Section _ _] -> renderer doc_
Paragraph [Image {} ] -> renderer doc_
Paragraph [Special (Source _)] -> renderer doc_
Paragraph [Special (FoldedSource _)] -> renderer doc_
Paragraph [Special (ExampleBlock _)] -> renderer doc_
Paragraph [Special (Signature _)] -> renderer doc_
Paragraph [Special Eval {}] ->renderer doc_
Paragraph [Special (Embed _)] -> renderer doc_
Paragraph [UntitledSection ds] -> mapM_ (sectionContentToHtml renderer) ds
Paragraph [Column _] -> renderer doc_
Paragraph _ -> p_ [] $ renderer doc_
_ ->
renderer doc_
in case doc of
@ -196,7 +217,7 @@ toHtml docNamesByRef document =
Code code ->
span_ [class_ "rich source inline-code"] $ inlineCode [] (currentSectionLevelToHtml code)
CodeBlock lang code ->
div_ [class_ "rich source code", class_ $ textToClass lang] $ codeBlock [] (currentSectionLevelToHtml code)
div_ [class_ $ "rich source code " <> textToClass lang] $ codeBlock [] (currentSectionLevelToHtml code)
Bold d ->
strong_ [] $ currentSectionLevelToHtml d
Italic d ->
@ -206,7 +227,7 @@ toHtml docNamesByRef document =
Style cssclass_ d ->
span_ [class_ $ textToClass cssclass_] $ currentSectionLevelToHtml d
Anchor id' d ->
a_ [id_ id', target_ id'] $ currentSectionLevelToHtml d
a_ [id_ id', href_ $ "#" <> id'] $ currentSectionLevelToHtml d
Blockquote d ->
blockquote_ [] $ currentSectionLevelToHtml d
Blankline ->
@ -249,7 +270,12 @@ toHtml docNamesByRef document =
IsFolded
isFolded
[currentSectionLevelToHtml summary]
[currentSectionLevelToHtml details]
-- We include the summary in the details slot to make it
-- symmetric with code folding, which currently always
-- includes the type signature in the details portion
[ div_ [] $ currentSectionLevelToHtml summary,
currentSectionLevelToHtml details
]
Paragraph docs ->
case docs of
[d] ->
@ -271,7 +297,11 @@ toHtml docNamesByRef document =
NamedLink label href ->
case normalizeHref docNamesByRef href of
Href h ->
a_ [class_ "named-link", href_ h, rel_ "noopener", target_ "_blank"] $ currentSectionLevelToHtml label
-- Fragments (starting with a #) are links internal to the page
if Text.isPrefixOf "#" h then
a_ [class_ "named-link", href_ h ] $ currentSectionLevelToHtml label
else
a_ [class_ "named-link", href_ h, rel_ "noopener", target_ "_blank"] $ currentSectionLevelToHtml label
DocLinkHref name ->
let href = "/" <> Text.replace "." "/" (Name.toText name) <> ".html"
in a_ [class_ "named-link doc-link", href_ href] $ currentSectionLevelToHtml label
@ -314,14 +344,14 @@ toHtml docNamesByRef document =
Link syntax ->
inlineCode ["rich", "source"] $ Syntax.toHtml syntax
Signature signatures ->
div_
codeBlock
[class_ "rich source signatures"]
( mapM_
(div_ [class_ "signature"] . Syntax.toHtml)
signatures
)
SignatureInline sig ->
span_ [class_ "rich source signature-inline"] $ Syntax.toHtml sig
inlineCode ["rich", "source", "signature-inline"] $ Syntax.toHtml sig
Eval source result ->
div_ [class_ "source rich eval"] $
codeBlock [] $

52
parser-typechecker/src/Unison/TypePrinter.hs
View File

@ -1,7 +1,20 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
module Unison.TypePrinter where
module Unison.TypePrinter
(
pretty
, pretty0
, prettyRaw
, prettyStr
, prettySyntax
, prettySignaturesST
, prettySignaturesCT
, prettySignaturesCTCollapsed
, prettySignaturesAlt
, prettySignaturesAlt'
) where
import Unison.Prelude
@ -31,10 +44,10 @@ pretty ppe = PP.syntaxToColor . prettySyntax ppe
prettySyntax :: forall v a . (Var v) => PrettyPrintEnv -> Type v a -> Pretty SyntaxText
prettySyntax ppe = pretty0 ppe mempty (-1)
pretty' :: Var v => Maybe Width -> PrettyPrintEnv -> Type v a -> String
pretty' (Just width) n t =
prettyStr :: Var v => Maybe Width -> PrettyPrintEnv -> Type v a -> String
prettyStr (Just width) n t =
toPlain $ PP.render width $ PP.syntaxToColor $ pretty0 n Map.empty (-1) t
pretty' Nothing n t =
prettyStr Nothing n t =
toPlain $ PP.render maxBound $ PP.syntaxToColor $ pretty0 n Map.empty (-1) t
{- Explanation of precedence handling
@ -147,24 +160,33 @@ fmt :: S.Element r -> Pretty (S.SyntaxText' r) -> Pretty (S.SyntaxText' r)
fmt = PP.withSyntax
-- todo: provide sample output in comment
prettySignatures'
prettySignaturesCT
:: Var v => PrettyPrintEnv
-> [(Referent, HashQualified Name, Type v a)]
-> [Pretty ColorText]
prettySignatures' env ts = map PP.syntaxToColor $ prettySignatures'' env ts
prettySignaturesCT env ts = map PP.syntaxToColor $ prettySignaturesST env ts
prettySignatures''
prettySignaturesCTCollapsed
:: Var v
=> PrettyPrintEnv
-> [(Referent, HashQualified Name, Type v a)]
-> Pretty ColorText
prettySignaturesCTCollapsed env ts = PP.lines $
PP.group <$> prettySignaturesCT env ts
prettySignaturesST
:: Var v => PrettyPrintEnv
-> [(Referent, HashQualified Name, Type v a)]
-> [Pretty SyntaxText]
prettySignatures'' env ts =
prettySignaturesST env ts =
PP.align [ (name r hq, sig typ) | (r, hq, typ) <- ts ]
where
name r hq =
name r hq =
styleHashQualified'' (fmt $ S.TermReference r) hq
sig typ =
sig typ =
(fmt S.TypeAscriptionColon ": " <> pretty0 env Map.empty (-1) typ)
`PP.orElse`
`PP.orElse`
(fmt S.TypeAscriptionColon ": " <> PP.indentNAfterNewline 2 (pretty0 env Map.empty (-1) typ))
-- todo: provide sample output in comment; different from prettySignatures'
@ -185,14 +207,6 @@ prettySignaturesAlt' env ts = map PP.syntaxToColor $ PP.align
-- prettySignatures'' :: Var v => PrettyPrintEnv -> [(Name, Type v a)] -> [Pretty ColorText]
-- prettySignatures'' env ts = prettySignatures' env (first HQ.fromName <$> ts)
prettySignatures
:: Var v
=> PrettyPrintEnv
-> [(Referent, HashQualified Name, Type v a)]
-> Pretty ColorText
prettySignatures env ts = PP.lines $
PP.group <$> prettySignatures' env ts
prettySignaturesAlt
:: Var v
=> PrettyPrintEnv

8
parser-typechecker/src/Unison/Typechecker/Context.hs
View File

@ -2718,9 +2718,9 @@ instance (Var v) => Show (Element v loc) where
show (Var v) = case v of
TypeVar.Universal x -> "@" <> show x
e -> show e
show (Solved _ v t) = "'"++Text.unpack (Var.name v)++" = "++TP.pretty' Nothing mempty (Type.getPolytype t)
show (Solved _ v t) = "'"++Text.unpack (Var.name v)++" = "++TP.prettyStr Nothing mempty (Type.getPolytype t)
show (Ann v t) = Text.unpack (Var.name v) ++ " : " ++
TP.pretty' Nothing mempty t
TP.prettyStr Nothing mempty t
show (Marker v) = "|"++Text.unpack (Var.name v)++"|"
instance (Ord loc, Var v) => Show (Context v loc) where
@ -2729,8 +2729,8 @@ instance (Ord loc, Var v) => Show (Context v loc) where
showElem _ctx (Var v) = case v of
TypeVar.Universal x -> "@" <> show x
e -> show e
showElem ctx (Solved _ v (Type.Monotype t)) = "'"++Text.unpack (Var.name v)++" = "++ TP.pretty' Nothing mempty (apply ctx t)
showElem ctx (Ann v t) = Text.unpack (Var.name v) ++ " : " ++ TP.pretty' Nothing mempty (apply ctx t)
showElem ctx (Solved _ v (Type.Monotype t)) = "'"++Text.unpack (Var.name v)++" = "++ TP.prettyStr Nothing mempty (apply ctx t)
showElem ctx (Ann v t) = Text.unpack (Var.name v) ++ " : " ++ TP.prettyStr Nothing mempty (apply ctx t)
showElem _ (Marker v) = "|"++Text.unpack (Var.name v)++"|"
-- MEnv v loc -> (Seq (ErrorNote v loc), (a, Env v loc))

2
parser-typechecker/src/Unison/Util/Pretty.hs
View File

@ -556,7 +556,7 @@ column2Header left right = column2sep " " . ((fmap CT.hiBlack left, fmap CT.hiB
column2sep
:: (LL.ListLike s Char, IsString s) => Pretty s -> [(Pretty s, Pretty s)] -> Pretty s
column2sep sep rows = lines . (group <$>) . align $ [(a, sep <> b) | (a, b) <- rows]
column2sep sep rows = lines . (group <$>) . align $ [(a, indent sep b) | (a, b) <- rows]
column2M
:: (Applicative m, LL.ListLike s Char, IsString s)

3
unison-cli/package.yaml
View File

@ -25,6 +25,7 @@ dependencies:
- lens
- megaparsec >= 5.0.0 && < 7.0.0
- mtl
- transformers
- open-browser
- random >= 1.2.0
- regex-tdfa
@ -97,6 +98,8 @@ default-extensions:
- BangPatterns
- BlockArguments
- DeriveFunctor
- DeriveFoldable
- DeriveTraversable
- DeriveGeneric
- DerivingStrategies
- DoAndIfThenElse

114
unison-cli/src/Unison/Codebase/Editor/Command.hs
View File

@ -239,7 +239,7 @@ data Command
-- IsDerivedTerm :: H.Hash -> Command m i v Bool
-- IsDerivedType :: H.Hash -> Command m i v Bool
-- Get the immediate (not transitive) dependents of the given reference
-- | Get the immediate (not transitive) dependents of the given reference
-- This might include historical definitions not in any current path; these
-- should be filtered by the caller of this command if that's not desired.
GetDependents :: Reference -> Command m i v (Set Reference)
@ -272,7 +272,7 @@ type UseCache = Bool
type EvalResult v =
( [(v, Term v ())]
, Map v (Ann, WK.WatchKind, Reference, Term v (), Term v (), Runtime.IsCacheHit)
, Map v (Ann, WK.WatchKind, Reference.Id, Term v (), Term v (), Runtime.IsCacheHit)
)
lookupEvalResult :: Ord v => v -> EvalResult v -> Maybe (Term v ())
@ -280,58 +280,58 @@ lookupEvalResult v (_, m) = view _5 <$> Map.lookup v m
commandName :: Command m i v a -> String
commandName = \case
Eval{} -> "Eval"
UI -> "UI"
DocsToHtml{} -> "DocsToHtml"
ConfigLookup{} -> "ConfigLookup"
Input -> "Input"
Notify{} -> "Notify"
NotifyNumbered{} -> "NotifyNumbered"
AddDefsToCodebase{} -> "AddDefsToCodebase"
CodebaseHashLength -> "CodebaseHashLength"
TypeReferencesByShortHash{} -> "TypeReferencesByShortHash"
TermReferencesByShortHash{} -> "TermReferencesByShortHash"
TermReferentsByShortHash{} -> "TermReferentsByShortHash"
BranchHashLength -> "BranchHashLength"
BranchHashesByPrefix{} -> "BranchHashesByPrefix"
ParseType{} -> "ParseType"
LoadSource{} -> "LoadSource"
Typecheck{} -> "Typecheck"
TypecheckFile{} -> "TypecheckFile"
Evaluate{} -> "Evaluate"
Evaluate1{} -> "Evaluate1"
PutWatch{} -> "PutWatch"
LoadWatches{} -> "LoadWatches"
LoadLocalRootBranch -> "LoadLocalRootBranch"
LoadLocalBranch{} -> "LoadLocalBranch"
Merge{} -> "Merge"
ViewRemoteBranch{} -> "ViewRemoteBranch"
ImportRemoteBranch{} -> "ImportRemoteBranch"
SyncLocalRootBranch{} -> "SyncLocalRootBranch"
SyncRemoteRootBranch{} -> "SyncRemoteRootBranch"
AppendToReflog{} -> "AppendToReflog"
LoadReflog -> "LoadReflog"
LoadTerm{} -> "LoadTerm"
LoadTermComponentWithTypes{} -> "LoadTermComponentWithTypes"
LoadType{} -> "LoadType"
LoadTypeOfTerm{} -> "LoadTypeOfTerm"
LoadDeclComponent{} -> "LoadDeclComponent"
PutTerm{} -> "PutTerm"
PutDecl{} -> "PutDecl"
IsTerm{} -> "IsTerm"
IsType{} -> "IsType"
GetDependents{} -> "GetDependents"
GetDependentsOfComponent{} -> "GetDependentsOfComponent"
GetTermsOfType{} -> "GetTermsOfType"
GetTermsMentioningType{} -> "GetTermsMentioningType"
Execute{} -> "Execute"
CreateAuthorInfo{} -> "CreateAuthorInfo"
RuntimeMain -> "RuntimeMain"
RuntimeTest -> "RuntimeTest"
HQNameQuery{} -> "HQNameQuery"
LoadSearchResults{} -> "LoadSearchResults"
GetDefinitionsBySuffixes{} -> "GetDefinitionsBySuffixes"
FindShallow{} -> "FindShallow"
ClearWatchCache{} -> "ClearWatchCache"
MakeStandalone{} -> "MakeStandalone"
FuzzySelect{} -> "FuzzySelect"
Eval {} -> "Eval"
UI -> "UI"
DocsToHtml {} -> "DocsToHtml"
ConfigLookup {} -> "ConfigLookup"
Input -> "Input"
Notify {} -> "Notify"
NotifyNumbered {} -> "NotifyNumbered"
AddDefsToCodebase {} -> "AddDefsToCodebase"
CodebaseHashLength -> "CodebaseHashLength"
TypeReferencesByShortHash {} -> "TypeReferencesByShortHash"
TermReferencesByShortHash {} -> "TermReferencesByShortHash"
TermReferentsByShortHash {} -> "TermReferentsByShortHash"
BranchHashLength -> "BranchHashLength"
BranchHashesByPrefix {} -> "BranchHashesByPrefix"
ParseType {} -> "ParseType"
LoadSource {} -> "LoadSource"
Typecheck {} -> "Typecheck"
TypecheckFile {} -> "TypecheckFile"
Evaluate {} -> "Evaluate"
Evaluate1 {} -> "Evaluate1"
PutWatch {} -> "PutWatch"
LoadWatches {} -> "LoadWatches"
LoadLocalRootBranch -> "LoadLocalRootBranch"
LoadLocalBranch {} -> "LoadLocalBranch"
Merge {} -> "Merge"
ViewRemoteBranch {} -> "ViewRemoteBranch"
ImportRemoteBranch {} -> "ImportRemoteBranch"
SyncLocalRootBranch {} -> "SyncLocalRootBranch"
SyncRemoteRootBranch {} -> "SyncRemoteRootBranch"
AppendToReflog {} -> "AppendToReflog"
LoadReflog -> "LoadReflog"
LoadTerm {} -> "LoadTerm"
LoadTermComponentWithTypes {} -> "LoadTermComponentWithTypes"
LoadType {} -> "LoadType"
LoadTypeOfTerm {} -> "LoadTypeOfTerm"
LoadDeclComponent {} -> "LoadDeclComponent"
PutTerm {} -> "PutTerm"
PutDecl {} -> "PutDecl"
IsTerm {} -> "IsTerm"
IsType {} -> "IsType"
GetDependents {} -> "GetDependents"
GetDependentsOfComponent {} -> "GetDependentsOfComponent"
GetTermsOfType {} -> "GetTermsOfType"
GetTermsMentioningType {} -> "GetTermsMentioningType"
Execute {} -> "Execute"
CreateAuthorInfo {} -> "CreateAuthorInfo"
RuntimeMain -> "RuntimeMain"
RuntimeTest -> "RuntimeTest"
HQNameQuery {} -> "HQNameQuery"
LoadSearchResults {} -> "LoadSearchResults"
GetDefinitionsBySuffixes {} -> "GetDefinitionsBySuffixes"
FindShallow {} -> "FindShallow"
ClearWatchCache {} -> "ClearWatchCache"
MakeStandalone {} -> "MakeStandalone"
FuzzySelect {} -> "FuzzySelect"

17
unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs
View File

@ -202,11 +202,10 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour
ClearWatchCache -> lift $ Codebase.clearWatches codebase
FuzzySelect opts display choices -> liftIO $ Fuzzy.fuzzySelect opts display choices
watchCache (Reference.DerivedId h) = do
m1 <- Codebase.getWatch codebase WK.RegularWatch h
m2 <- maybe (Codebase.getWatch codebase WK.TestWatch h) (pure . Just) m1
pure $ Term.amap (const ()) <$> m2
watchCache Reference.Builtin{} = pure Nothing
watchCache :: Reference.Id -> IO (Maybe (Term v ()))
watchCache h = do
maybeTerm <- Codebase.lookupWatchCache codebase h
pure (Term.amap (const ()) <$> maybeTerm)
eval1 :: PPE.PrettyPrintEnv -> UseCache -> Term v Ann -> _
eval1 ppe useCache tm = do
@ -228,11 +227,9 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour
Right rs@(_,map) -> do
forM_ (Map.elems map) $ \(_loc, kind, hash, _src, value, isHit) ->
if isHit then pure ()
else case hash of
Reference.DerivedId h -> do
let value' = Term.amap (const Ann.External) value
Codebase.putWatch codebase kind h value'
Reference.Builtin{} -> pure ()
else do
let value' = Term.amap (const Ann.External) value
Codebase.putWatch codebase kind hash value'
pure $ Right rs
-- doTodo :: Monad m => Codebase m v a -> Branch0 -> m (TodoOutput v a)

327
unison-cli/src/Unison/Codebase/Editor/HandleInput.hs
View File

@ -2,9 +2,6 @@
module Unison.Codebase.Editor.HandleInput
( loop,
loopState0,
LoopState (..),
currentPath,
parseSearchType,
)
where
@ -22,7 +19,6 @@ import Data.Either.Extra (eitherToMaybe)
import qualified Data.Foldable as Foldable
import qualified Data.List as List
import Data.List.Extra (nubOrd)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as Nel
import qualified Data.Map as Map
import Data.Sequence (Seq (..))
@ -128,8 +124,6 @@ import Unison.UnisonFile (TypecheckedUnisonFile)
import qualified Unison.UnisonFile as UF
import qualified Unison.UnisonFile.Names as UF
import qualified Unison.Util.Find as Find
import Unison.Util.Free (Free)
import qualified Unison.Util.Free as Free
import Unison.Util.List (uniqueBy)
import Unison.Util.Monoid (intercalateMap)
import qualified Unison.Util.Monoid as Monoid
@ -142,48 +136,9 @@ import Unison.Util.TransitiveClosure (transitiveClosure)
import Unison.Var (Var)
import qualified Unison.Var as Var
import qualified Unison.WatchKind as WK
type F m i v = Free (Command m i v)
-- type (Action m i v) a
type Action m i v = MaybeT (StateT (LoopState m v) (F m i v))
data LoopState m v = LoopState
{ _root :: Branch m,
_lastSavedRoot :: Branch m,
-- the current position in the namespace
_currentPathStack :: NonEmpty Path.Absolute,
-- TBD
-- , _activeEdits :: Set Branch.EditGuid
-- The file name last modified, and whether to skip the next file
-- change event for that path (we skip file changes if the file has
-- just been modified programmatically)
_latestFile :: Maybe (FilePath, SkipNextUpdate),
_latestTypecheckedFile :: Maybe (UF.TypecheckedUnisonFile v Ann),
-- The previous user input. Used to request confirmation of
-- questionable user commands.
_lastInput :: Maybe Input,
-- A 1-indexed list of strings that can be referenced by index at the
-- CLI prompt. e.g. Given ["Foo.bat", "Foo.cat"],
-- `rename 2 Foo.foo` will rename `Foo.cat` to `Foo.foo`.
_numberedArgs :: NumberedArgs
}
type SkipNextUpdate = Bool
type InputDescription = Text
makeLenses ''LoopState
-- replacing the old read/write scalar Lens with "peek" Getter for the NonEmpty
currentPath :: Getter (LoopState m v) Path.Absolute
currentPath = currentPathStack . to Nel.head
loopState0 :: Branch m -> Path.Absolute -> LoopState m v
loopState0 b p = LoopState b b (pure p) Nothing Nothing Nothing []
type Action' m v = Action m (Either Event Input) v
import qualified Unison.Codebase.Editor.HandleInput.LoopState as LoopState
import Unison.Codebase.Editor.HandleInput.LoopState (Action, Action', eval)
import qualified Unison.Codebase.Editor.HandleInput.NamespaceDependencies as NamespaceDependencies
defaultPatchNameSegment :: NameSegment
defaultPatchNameSegment = "patch"
@ -191,12 +146,19 @@ defaultPatchNameSegment = "patch"
prettyPrintEnvDecl :: NamesWithHistory -> Action' m v PPE.PrettyPrintEnvDecl
prettyPrintEnvDecl ns = eval CodebaseHashLength <&> (`PPE.fromNamesDecl` ns)
-- | Get a pretty print env decl for the current names at the current path.
currentPrettyPrintEnvDecl :: Action' m v PPE.PrettyPrintEnvDecl
currentPrettyPrintEnvDecl = do
root' <- use LoopState.root
currentPath' <- Path.unabsolute <$> use LoopState.currentPath
prettyPrintEnvDecl (Backend.getCurrentPrettyNames (Backend.AllNames currentPath') root')
loop :: forall m v. (Monad m, Var v) => Action m (Either Event Input) v ()
loop = do
uf <- use latestTypecheckedFile
root' <- use root
currentPath' <- use currentPath
latestFile' <- use latestFile
uf <- use LoopState.latestTypecheckedFile
root' <- use LoopState.root
currentPath' <- use LoopState.currentPath
latestFile' <- use LoopState.latestFile
currentBranch' <- getAt currentPath'
e <- eval Input
hqLength <- eval CodebaseHashLength
@ -264,8 +226,8 @@ loop = do
_ -> Nothing
hqs = Set.fromList . mapMaybe (getHQ . L.payload) $ tokens
let parseNames = Backend.getCurrentParseNames (Backend.AllNames currentPath'') root'
latestFile .= Just (Text.unpack sourceName, False)
latestTypecheckedFile .= Nothing
LoopState.latestFile .= Just (Text.unpack sourceName, False)
LoopState.latestTypecheckedFile .= Nothing
Result notes r <- eval $ Typecheck ambient parseNames sourceName lexed
case r of
-- Parsing failed
@ -299,7 +261,7 @@ loop = do
go (ann, kind, _hash, _uneval, eval, isHit) = (ann, kind, eval, isHit)
unless (null e') $
eval . Notify $ Evaluated text ppe bindings e'
latestTypecheckedFile .= Just unisonFile
LoopState.latestTypecheckedFile .= Just unisonFile
case e of
Left (IncomingRootBranch hashes) ->
@ -310,7 +272,7 @@ loop = do
Left (UnisonFileChanged sourceName text) ->
-- We skip this update if it was programmatically generated
if maybe False snd latestFile'
then modifying latestFile (fmap (const False) <$>)
then modifying LoopState.latestFile (fmap (const False) <$>)
else loadUnisonFile sourceName text
Right input ->
let ifConfirmed = ifM (confirmedCommand input)
@ -372,7 +334,7 @@ loop = do
branchExistsSplit = branchExists . Path.unsplit'
typeExists dest = respond . TypeAlreadyExists dest
termExists dest = respond . TermAlreadyExists dest
inputDescription :: InputDescription
inputDescription :: LoopState.InputDescription
inputDescription = case input of
ForkLocalBranchI src dest -> "fork " <> hp' src <> " " <> p' dest
MergeLocalBranchI src dest mode -> case mode of
@ -451,6 +413,7 @@ loop = do
ListEditsI {} -> wat
ListDependenciesI {} -> wat
ListDependentsI {} -> wat
NamespaceDependenciesI{} -> wat
HistoryI {} -> wat
TestI {} -> wat
LinksI {} -> wat
@ -491,7 +454,7 @@ loop = do
stepManyAtNoSync =
Unison.Codebase.Editor.HandleInput.stepManyAtNoSync
updateRoot = flip Unison.Codebase.Editor.HandleInput.updateRoot inputDescription
syncRoot = use root >>= updateRoot
syncRoot = use LoopState.root >>= updateRoot
updateAtM = Unison.Codebase.Editor.HandleInput.updateAtM inputDescription
unlessGitError = unlessError' Output.GitError
importRemoteBranch ns mode = ExceptT . eval $ ImportRemoteBranch ns mode
@ -574,12 +537,12 @@ loop = do
runExceptT (for mdValues \val -> ExceptT (getMetadataFromName val)) >>= \case
Left output -> respond output
Right metadata -> do
before <- Branch.head <$> use root
before <- Branch.head <$> use LoopState.root
traverse_ go metadata
if silent
then respond DefaultMetadataNotification
else do
after <- Branch.head <$> use root
after <- Branch.head <$> use LoopState.root
(ppe, outputDiff) <- diffHelper before after
if OBranchDiff.isEmpty outputDiff
then respond NoOp
@ -593,7 +556,7 @@ loop = do
where
go :: (Metadata.Type, Metadata.Value) -> Action m (Either Event Input) v ()
go (mdType, mdValue) = do
newRoot <- use root
newRoot <- use LoopState.root
let r0 = Branch.head newRoot
getTerms p = BranchUtil.getTerm (resolveSplit' p) r0
getTypes p = BranchUtil.getType (resolveSplit' p) r0
@ -637,7 +600,7 @@ loop = do
let makeDeleteTermNames = fmap (BranchUtil.makeDeleteTermName resolvedPath) . toList $ tms
let makeDeleteTypeNames = fmap (BranchUtil.makeDeleteTypeName resolvedPath) . toList $ tys
stepManyAt (makeDeleteTermNames ++ makeDeleteTypeNames)
root'' <- use root
root'' <- use LoopState.root
diffHelper (Branch.head root') (Branch.head root'')
>>= respondNumbered . uncurry ShowDiffAfterDeleteDefinitions
else handleFailedDelete failed failedDependents
@ -646,7 +609,7 @@ loop = do
respond $ PrintMessage pretty
ShowReflogI -> do
entries <- convertEntries Nothing [] <$> eval LoadReflog
numberedArgs .= fmap (('#' :) . SBH.toString . Output.hash) entries
LoopState.numberedArgs .= fmap (('#' :) . SBH.toString . Output.hash) entries
respond $ ShowReflog entries
where
-- reverses & formats entries, adds synthetic entries when there is a
@ -778,9 +741,9 @@ loop = do
(snoc desta "merged")
else respond . BranchNotEmpty . Path.Path' . Left $ currentPath'
-- move the root to a sub-branch
-- move the LoopState.root to a sub-branch
MoveBranchI Nothing dest -> do
b <- use root
b <- use LoopState.root
stepManyAt
[ (Path.empty, const Branch.empty0),
BranchUtil.makeSetBranch (resolveSplit' dest) b
@ -866,17 +829,17 @@ loop = do
Nothing -> pure ()
Just path' -> do
let path = resolveToAbsolute path'
currentPathStack %= Nel.cons path
LoopState.currentPathStack %= Nel.cons path
branch' <- getAt path
when (Branch.isEmpty branch') (respond $ CreatedNewBranch path)
UpI ->
use currentPath >>= \p -> case Path.unsnoc (Path.unabsolute p) of
use LoopState.currentPath >>= \p -> case Path.unsnoc (Path.unabsolute p) of
Nothing -> pure ()
Just (path, _) -> currentPathStack %= Nel.cons (Path.Absolute path)
Just (path, _) -> LoopState.currentPathStack %= Nel.cons (Path.Absolute path)
PopBranchI ->
use (currentPathStack . to Nel.uncons) >>= \case
use (LoopState.currentPathStack . to Nel.uncons) >>= \case
(_, Nothing) -> respond StartOfCurrentPathHistory
(_, Just t) -> currentPathStack .= t
(_, Just t) -> LoopState.currentPathStack .= t
HistoryI resultsCap diffCap from -> case from of
Left hash -> unlessError do
b <- resolveShortBranchHash hash
@ -1044,7 +1007,7 @@ loop = do
LinksI src mdTypeStr -> unlessError do
(ppe, out) <- getLinks (show input) src (Right mdTypeStr)
lift do
numberedArgs .= fmap (HQ.toString . view _1) out
LoopState.numberedArgs .= fmap (HQ.toString . view _1) out
respond $ ListOfLinks ppe out
DocsI srcs -> do
srcs' <- case srcs of
@ -1130,7 +1093,7 @@ loop = do
(seg, _) <- Map.toList (Branch._edits b)
]
respond $ ListOfPatches $ Set.fromList patches
numberedArgs .= fmap Name.toString patches
LoopState.numberedArgs .= fmap Name.toString patches
FindShallowI pathArg -> do
let pathArgAbs = resolveToAbsolute pathArg
ppe =
@ -1143,7 +1106,7 @@ loop = do
Left e -> handleBackendError e
Right entries -> do
-- caching the result as an absolute path, for easier jumping around
numberedArgs .= fmap entryToHQString entries
LoopState.numberedArgs .= fmap entryToHQString entries
respond $ ListShallow ppe entries
where
entryToHQString :: ShallowListEntry v Ann -> String
@ -1194,7 +1157,7 @@ loop = do
let srs = searchBranchScored ns fuzzyNameDistance qs
pure $ uniqueBy SR.toReferent srs
lift do
numberedArgs .= fmap searchResultToHQString results
LoopState.numberedArgs .= fmap searchResultToHQString results
results' <- loadSearchResults results
ppe <-
suffixifiedPPE
@ -1672,7 +1635,6 @@ loop = do
let srcb = BranchUtil.fromNames names0
_ <- updateAtM (currentPath' `snoc` "builtin") $ \destb ->
eval $ Merge Branch.RegularMerge srcb destb
success
ListEditsI maybePath -> do
let (p, seg) =
@ -1694,23 +1656,7 @@ loop = do
let printDiffPath = if Verbosity.isSilent verbosity then Nothing else Just path
lift $ mergeBranchAndPropagateDefaultPatch Branch.RegularMerge inputDescription msg b printDiffPath destAbs
PushRemoteBranchI mayRepo path pushBehavior syncMode -> handlePushRemoteBranch mayRepo path pushBehavior syncMode
ListDependentsI hq ->
-- todo: add flag to handle transitive efficiently
resolveHQToLabeledDependencies hq >>= \lds ->
if null lds
then respond $ LabeledReferenceNotFound hq
else for_ lds $ \ld -> do
dependents <-
let tp r = eval $ GetDependents r
tm (Referent.Ref r) = eval $ GetDependents r
tm (Referent.Con r _i _ct) = eval $ GetDependents r
in LD.fold tp tm ld
(missing, names0) <- eval . Eval $ Branch.findHistoricalRefs' dependents root'
let types = R.toList $ Names.types names0
let terms = fmap (second Referent.toReference) $ R.toList $ Names.terms names0
let names = types <> terms
numberedArgs .= fmap (Text.unpack . Reference.toText) ((fmap snd names) <> toList missing)
respond $ ListDependents hqLength ld names missing
ListDependentsI hq -> handleDependents hq
ListDependenciesI hq ->
-- todo: add flag to handle transitive efficiently
resolveHQToLabeledDependencies hq >>= \lds ->
@ -1739,9 +1685,17 @@ loop = do
let types = R.toList $ Names.types names0
let terms = fmap (second Referent.toReference) $ R.toList $ Names.terms names0
let names = types <> terms
numberedArgs .= fmap (Text.unpack . Reference.toText) ((fmap snd names) <> toList missing)
LoopState.numberedArgs .= fmap (Text.unpack . Reference.toText) ((fmap snd names) <> toList missing)
respond $ ListDependencies hqLength ld names missing
DebugNumberedArgsI -> use numberedArgs >>= respond . DumpNumberedArgs
NamespaceDependenciesI namespacePath' -> do
let path = maybe currentPath' resolveToAbsolute namespacePath'
case (Branch.getAt (Path.unabsolute path) root') of
Nothing -> respond $ BranchEmpty (Right (Path.absoluteToPath' path))
Just b -> do
externalDependencies <- NamespaceDependencies.namespaceDependencies (Branch.head b)
ppe <- PPE.unsuffixifiedPPE <$> currentPrettyPrintEnvDecl
respond $ ListNamespaceDependencies ppe path externalDependencies
DebugNumberedArgsI -> use LoopState.numberedArgs >>= respond . DumpNumberedArgs
DebugTypecheckedUnisonFileI -> case uf of
Nothing -> respond NoUnisonFile
Just uf ->
@ -1828,9 +1782,45 @@ loop = do
pure . join $ toList xs
case e of
Right input -> lastInput .= Just input
Right input -> LoopState.lastInput .= Just input
_ -> pure ()
handleDependents :: Monad m => HQ.HashQualified Name -> Action' m v ()
handleDependents hq = do
hqLength <- eval CodebaseHashLength
-- todo: add flag to handle transitive efficiently
resolveHQToLabeledDependencies hq >>= \lds ->
if null lds
then respond $ LabeledReferenceNotFound hq
else for_ lds \ld -> do
-- The full set of dependent references, any number of which may not have names in the current namespace.
dependents <-
let tp r = eval $ GetDependents r
tm (Referent.Ref r) = eval $ GetDependents r
tm (Referent.Con r _i _ct) = eval $ GetDependents r
in LD.fold tp tm ld
-- Use an unsuffixified PPE here, so we display full names (relative to the current path), rather than the shortest possible
-- unambiguous name.
ppe <- PPE.unsuffixifiedPPE <$> currentPrettyPrintEnvDecl
let results :: [(Reference, Maybe Name)]
results =
-- Currently we only retain dependents that are named in the current namespace (hence `mapMaybe`). In the future, we could
-- take a flag to control whether we want to show all dependents
mapMaybe f (Set.toList dependents)
where
f :: Reference -> Maybe (Reference, Maybe Name)
f reference =
asum
[ g <$> PPE.terms ppe (Referent.Ref reference),
g <$> PPE.types ppe reference
]
where
g :: HQ'.HashQualified Name -> (Reference, Maybe Name)
g hqName =
(reference, Just (HQ'.toName hqName))
LoopState.numberedArgs .= map (Text.unpack . Reference.toText . fst) results
respond (ListDependents hqLength ld results)
handlePushRemoteBranch ::
forall m v.
Applicative m =>
@ -1845,7 +1835,7 @@ handlePushRemoteBranch ::
Action' m v ()
handlePushRemoteBranch mayRepo path pushBehavior syncMode = do
srcb <- do
currentPath' <- use currentPath
currentPath' <- use LoopState.currentPath
getAt (Path.resolve currentPath' path)
unlessError do
(repo, remotePath) <- maybe (resolveConfiguredGitUrl Push path) pure mayRepo
@ -1887,8 +1877,8 @@ handleShowDefinition outputLoc inputQuery = do
branch <- fuzzyBranch
fuzzySelectTermsAndTypes branch
else pure inputQuery
currentPath' <- Path.unabsolute <$> use currentPath
root' <- use root
currentPath' <- Path.unabsolute <$> use LoopState.currentPath
root' <- use LoopState.root
hqLength <- eval CodebaseHashLength
Backend.DefinitionResults terms types misses <-
eval (GetDefinitionsBySuffixes (Just currentPath') root' includeCycles query)
@ -1901,19 +1891,19 @@ handleShowDefinition outputLoc inputQuery = do
-- We set latestFile to be programmatically generated, if we
-- are viewing these definitions to a file - this will skip the
-- next update for that file (which will happen immediately)
latestFile .= ((,True) <$> outputPath)
LoopState.latestFile .= ((,True) <$> outputPath)
where
-- `view`: fuzzy find globally; `edit`: fuzzy find local to current branch
fuzzyBranch :: Action' m v (Branch0 m)
fuzzyBranch =
case outputLoc of
ConsoleLocation {} -> Branch.head <$> use root
ConsoleLocation {} -> Branch.head <$> use LoopState.root
-- fuzzy finding for 'edit's are local to the current branch
LatestFileLocation {} -> currentBranch0
FileLocation {} -> currentBranch0
where
currentBranch0 = do
currentPath' <- use currentPath
currentPath' <- use LoopState.currentPath
currentBranch <- getAt currentPath'
pure (Branch.head currentBranch)
-- `view`: don't include cycles; `edit`: include cycles
@ -1930,7 +1920,7 @@ handleShowDefinition outputLoc inputQuery = do
ConsoleLocation -> pure Nothing
FileLocation path -> pure (Just path)
LatestFileLocation ->
use latestFile <&> \case
use LoopState.latestFile <&> \case
Nothing -> Just "scratch.u"
Just (path, _) -> Just path
@ -1942,7 +1932,7 @@ resolveConfiguredGitUrl ::
Path' ->
ExceptT (Output v) (Action' m v) WriteRemotePath
resolveConfiguredGitUrl pushPull destPath' = ExceptT do
currentPath' <- use currentPath
currentPath' <- use LoopState.currentPath
let destPath = Path.resolve currentPath' destPath'
let configKey = gitUrlKey destPath
(eval . ConfigLookup) configKey >>= \case
@ -1995,9 +1985,9 @@ resolveHQToLabeledDependencies = \case
doDisplay :: Var v => OutputLocation -> NamesWithHistory -> Term v () -> Action' m v ()
doDisplay outputLoc names tm = do
ppe <- prettyPrintEnvDecl names
tf <- use latestTypecheckedFile
tf <- use LoopState.latestTypecheckedFile
let (tms, typs) = maybe mempty UF.indexByReference tf
latestFile' <- use latestFile
latestFile' <- use LoopState.latestFile
let loc = case outputLoc of
ConsoleLocation -> Nothing
FileLocation path -> Just path
@ -2054,8 +2044,8 @@ getLinks' ::
[(HQ.HashQualified Name, Reference, Maybe (Type v Ann))]
)
getLinks' src selection0 = do
root0 <- Branch.head <$> use root
currentPath' <- use currentPath
root0 <- Branch.head <$> use LoopState.root
currentPath' <- use LoopState.currentPath
let resolveSplit' = Path.fromAbsoluteSplit . Path.toAbsoluteSplit currentPath'
p = resolveSplit' src -- ex: the (parent,hqsegment) of `List.map` - `List`
-- all metadata (type+value) associated with name `src`
@ -2092,7 +2082,7 @@ propagatePatchNoSync ::
Path.Absolute ->
Action' m v Bool
propagatePatchNoSync patch scopePath = do
r <- use root
r <- use LoopState.root
let nroot = Branch.toNames (Branch.head r)
stepAtMNoSync'
( Path.unabsolute scopePath,
@ -2102,12 +2092,12 @@ propagatePatchNoSync patch scopePath = do
-- Returns True if the operation changed the namespace, False otherwise.
propagatePatch ::
(Monad m, Var v) =>
InputDescription ->
LoopState.InputDescription ->
Patch ->
Path.Absolute ->
Action' m v Bool
propagatePatch inputDescription patch scopePath = do
r <- use root
r <- use LoopState.root
let nroot = Branch.toNames (Branch.head r)
stepAtM'
(inputDescription <> " (applying patch)")
@ -2139,7 +2129,7 @@ showTodoOutput getPpe patch names0 = do
if TO.noConflicts todo && TO.noEdits todo
then respond NoConflictsOrEdits
else do
numberedArgs
LoopState.numberedArgs
.= ( Text.unpack . Reference.toText . view _2
<$> fst (TO.todoFrontierDependents todo)
)
@ -2178,12 +2168,9 @@ checkTodo patch names0 = do
-- we don't want the frontier in the result
pure $ tdeps `Set.difference` rs
eval :: Command m i v a -> Action m i v a
eval = lift . lift . Free.eval
confirmedCommand :: Input -> Action m i v Bool
confirmedCommand i = do
i0 <- use lastInput
i0 <- use LoopState.lastInput
pure $ Just i == i0
listBranch :: Branch0 m -> [SearchResult]
@ -2306,7 +2293,7 @@ respondNumbered :: NumberedOutput v -> Action m i v ()
respondNumbered output = do
args <- eval $ NotifyNumbered output
unless (null args) $
numberedArgs .= toList args
LoopState.numberedArgs .= toList args
unlessError :: ExceptT (Output v) (Action' m v) () -> Action' m v ()
unlessError ma = runExceptT ma >>= either respond pure
@ -2319,7 +2306,7 @@ unlessError' f ma = unlessError $ withExceptT f ma
mergeBranchAndPropagateDefaultPatch ::
(Monad m, Var v) =>
Branch.MergeMode ->
InputDescription ->
LoopState.InputDescription ->
Maybe (Output v) ->
Branch m ->
Maybe Path.Path' ->
@ -2334,7 +2321,7 @@ mergeBranchAndPropagateDefaultPatch mode inputDescription unchangedMessage srcb
mergeBranch ::
(Monad m, Var v) =>
Branch.MergeMode ->
InputDescription ->
LoopState.InputDescription ->
Branch m ->
Maybe Path.Path' ->
Path.Absolute ->
@ -2350,7 +2337,7 @@ mergeBranchAndPropagateDefaultPatch mode inputDescription unchangedMessage srcb
loadPropagateDiffDefaultPatch ::
(Monad m, Var v) =>
InputDescription ->
LoopState.InputDescription ->
Maybe Path.Path' ->
Path.Absolute ->
Action' m v ()
@ -2390,16 +2377,16 @@ getMetadataFromName name = do
where
getPPE :: Action m (Either Event Input) v PPE.PrettyPrintEnv
getPPE = do
currentPath' <- use currentPath
currentPath' <- use LoopState.currentPath
sbhLength <- eval BranchHashLength
Backend.basicSuffixifiedNames sbhLength <$> use root <*> pure (Backend.AllNames $ Path.unabsolute currentPath')
Backend.basicSuffixifiedNames sbhLength <$> use LoopState.root <*> pure (Backend.AllNames $ Path.unabsolute currentPath')
-- | Get the set of terms related to a hash-qualified name.
getHQTerms :: HQ.HashQualified Name -> Action' m v (Set Referent)
getHQTerms = \case
HQ.NameOnly n -> do
root0 <- Branch.head <$> use root
currentPath' <- use currentPath
root0 <- Branch.head <$> use LoopState.root
currentPath' <- use LoopState.currentPath
-- absolute-ify the name, then lookup in deepTerms of root
let path =
n
@ -2415,18 +2402,18 @@ getHQTerms = \case
getAt :: Functor m => Path.Absolute -> Action m i v (Branch m)
getAt (Path.Absolute p) =
use root <&> fromMaybe Branch.empty . Branch.getAt p
use LoopState.root <&> fromMaybe Branch.empty . Branch.getAt p
-- Update a branch at the given path, returning `True` if
-- an update occurred and false otherwise
updateAtM ::
Applicative m =>
InputDescription ->
LoopState.InputDescription ->
Path.Absolute ->
(Branch m -> Action m i v (Branch m)) ->
Action m i v Bool
updateAtM reason (Path.Absolute p) f = do
b <- use lastSavedRoot
b <- use LoopState.lastSavedRoot
b' <- Branch.modifyAtM p f b
updateRoot b' reason
pure $ b /= b'
@ -2434,7 +2421,7 @@ updateAtM reason (Path.Absolute p) f = do
stepAt ::
forall m i v.
Monad m =>
InputDescription ->
LoopState.InputDescription ->
(Path, Branch0 m -> Branch0 m) ->
Action m i v ()
stepAt cause = stepManyAt @m @[] cause . pure
@ -2449,7 +2436,7 @@ stepAtNoSync = stepManyAtNoSync @m @[] . pure
stepAtM ::
forall m i v.
Monad m =>
InputDescription ->
LoopState.InputDescription ->
(Path, Branch0 m -> m (Branch0 m)) ->
Action m i v ()
stepAtM cause = stepManyAtM @m @[] cause . pure
@ -2457,7 +2444,7 @@ stepAtM cause = stepManyAtM @m @[] cause . pure
stepAtM' ::
forall m i v.
Monad m =>
InputDescription ->
LoopState.InputDescription ->
(Path, Branch0 m -> Action m i v (Branch0 m)) ->
Action m i v Bool
stepAtM' cause = stepManyAtM' @m @[] cause . pure
@ -2471,32 +2458,32 @@ stepAtMNoSync' = stepManyAtMNoSync' @m @[] . pure
stepManyAt ::
(Monad m, Foldable f) =>
InputDescription ->
LoopState.InputDescription ->
f (Path, Branch0 m -> Branch0 m) ->
Action m i v ()
stepManyAt reason actions = do
stepManyAtNoSync actions
b <- use root
b <- use LoopState.root
updateRoot b reason
-- Like stepManyAt, but doesn't update the root
-- Like stepManyAt, but doesn't update the LoopState.root
stepManyAtNoSync ::
(Monad m, Foldable f) =>
f (Path, Branch0 m -> Branch0 m) ->
Action m i v ()
stepManyAtNoSync actions = do
b <- use root
b <- use LoopState.root
let new = Branch.stepManyAt actions b
root .= new
LoopState.root .= new
stepManyAtM ::
(Monad m, Foldable f) =>
InputDescription ->
LoopState.InputDescription ->
f (Path, Branch0 m -> m (Branch0 m)) ->
Action m i v ()
stepManyAtM reason actions = do
stepManyAtMNoSync actions
b <- use root
b <- use LoopState.root
updateRoot b reason
stepManyAtMNoSync ::
@ -2504,17 +2491,17 @@ stepManyAtMNoSync ::
f (Path, Branch0 m -> m (Branch0 m)) ->
Action m i v ()
stepManyAtMNoSync actions = do
b <- use root
b <- use LoopState.root
b' <- eval . Eval $ Branch.stepManyAtM actions b
root .= b'
LoopState.root .= b'
stepManyAtM' ::
(Monad m, Foldable f) =>
InputDescription ->
LoopState.InputDescription ->
f (Path, Branch0 m -> Action m i v (Branch0 m)) ->
Action m i v Bool
stepManyAtM' reason actions = do
b <- use root
b <- use LoopState.root
b' <- Branch.stepManyAtM actions b
updateRoot b' reason
pure (b /= b')
@ -2524,19 +2511,19 @@ stepManyAtMNoSync' ::
f (Path, Branch0 m -> Action m i v (Branch0 m)) ->
Action m i v Bool
stepManyAtMNoSync' actions = do
b <- use root
b <- use LoopState.root
b' <- Branch.stepManyAtM actions b
root .= b'
LoopState.root .= b'
pure (b /= b')
updateRoot :: Branch m -> InputDescription -> Action m i v ()
updateRoot :: Branch m -> LoopState.InputDescription -> Action m i v ()
updateRoot new reason = do
old <- use lastSavedRoot
old <- use LoopState.lastSavedRoot
when (old /= new) $ do
root .= new
LoopState.root .= new
eval $ SyncLocalRootBranch new
eval $ AppendToReflog reason old new
lastSavedRoot .= new
LoopState.lastSavedRoot .= new
-- cata for 0, 1, or more elements of a Foldable
-- tries to match as lazily as possible
@ -2616,7 +2603,7 @@ toSlurpResult ::
UF.TypecheckedUnisonFile v Ann ->
Names ->
SlurpResult v
toSlurpResult currentPath uf existingNames =
toSlurpResult curPath uf existingNames =
Slurp.subtractComponent (conflicts <> ctorCollisions) $
SlurpResult
uf
@ -2735,10 +2722,10 @@ toSlurpResult currentPath uf existingNames =
-- All the refs whose names include `n`, and are not `r`
let refs = Set.delete r $ R.lookupDom n existingNames
aliasesOfNew =
Set.map (Path.unprefixName currentPath) . Set.delete n $
Set.map (Path.unprefixName curPath) . Set.delete n $
R.lookupRan r existingNames
aliasesOfOld =
Set.map (Path.unprefixName currentPath) . Set.delete n . R.dom $
Set.map (Path.unprefixName curPath) . Set.delete n . R.dom $
R.restrictRan existingNames refs,
not (null aliasesOfNew && null aliasesOfOld),
Set.notMember (var n) duplicates
@ -2778,7 +2765,7 @@ displayI ::
HQ.HashQualified Name ->
Action m (Either Event Input) v ()
displayI prettyPrintNames outputLoc hq = do
uf <- use latestTypecheckedFile >>= addWatch (HQ.toString hq)
uf <- use LoopState.latestTypecheckedFile >>= addWatch (HQ.toString hq)
case uf of
Nothing -> do
let parseNames = (`NamesWithHistory.NamesWithHistory` mempty) prettyPrintNames
@ -2830,7 +2817,7 @@ docsI srcLoc prettyPrintNames src = do
dotDoc = hq <&> \n -> Name.joinDot n "doc"
fileByName = do
ns <- maybe mempty UF.typecheckedToNames <$> use latestTypecheckedFile
ns <- maybe mempty UF.typecheckedToNames <$> use LoopState.latestTypecheckedFile
fnames <- pure $ NamesWithHistory.NamesWithHistory ns mempty
case NamesWithHistory.lookupHQTerm dotDoc fnames of
s | Set.size s == 1 -> do
@ -2853,7 +2840,7 @@ docsI srcLoc prettyPrintNames src = do
Left e -> respond (EvaluationFailure e)
Right tm -> doDisplay ConsoleLocation names (Term.unannotate tm)
out -> do
numberedArgs .= fmap (HQ.toString . view _1) out
LoopState.numberedArgs .= fmap (HQ.toString . view _1) out
respond $ ListOfLinks ppe out
codebaseByName = do
@ -3001,7 +2988,7 @@ loadDisplayInfo refs = do
-- are converted to names relative to current path. all other names are
-- converted to absolute names. For example:
--
-- e.g. if currentPath = .foo.bar
-- e.g. if LoopState.currentPath = .foo.bar
-- then name foo.bar.baz becomes baz
-- name cat.dog becomes .cat.dog
fixupNamesRelative :: Path.Absolute -> Names -> Names
@ -3018,12 +3005,12 @@ makeHistoricalParsingNames ::
makeHistoricalParsingNames lexedHQs = do
rawHistoricalNames <- findHistoricalHQs lexedHQs
basicNames <- basicParseNames
currentPath <- use currentPath
curPath <- use LoopState.currentPath
pure $
NamesWithHistory
basicNames
( Names.makeAbsolute rawHistoricalNames
<> fixupNamesRelative currentPath rawHistoricalNames
<> fixupNamesRelative curPath rawHistoricalNames
)
loadTypeDisplayObject ::
@ -3092,15 +3079,15 @@ makeShadowedPrintNamesFromLabeled deps shadowing =
makePrintNamesFromLabeled' ::
Monad m => Set LabeledDependency -> Action' m v NamesWithHistory
makePrintNamesFromLabeled' deps = do
root <- use root
currentPath <- use currentPath
root' <- use LoopState.root
curPath <- use LoopState.currentPath
(_missing, rawHistoricalNames) <-
eval . Eval $
Branch.findHistoricalRefs
deps
root
root'
basicNames <- basicPrettyPrintNamesA
pure $ NamesWithHistory basicNames (fixupNamesRelative currentPath rawHistoricalNames)
pure $ NamesWithHistory basicNames (fixupNamesRelative curPath rawHistoricalNames)
getTermsIncludingHistorical ::
Monad m => Path.HQSplit -> Branch0 m -> Action' m v (Set Referent)
@ -3120,25 +3107,25 @@ getTermsIncludingHistorical (p, hq) b = case Set.toList refs of
-- I'd enforce it with finer-grained types if we had them.
findHistoricalHQs :: Monad m => Set (HQ.HashQualified Name) -> Action' m v Names
findHistoricalHQs lexedHQs0 = do
root <- use root
currentPath <- use currentPath
root' <- use LoopState.root
curPath <- use LoopState.currentPath
let -- omg this nightmare name-to-path parsing code is littered everywhere.
-- We need to refactor so that the absolute-ness of a name isn't represented
-- by magical text combinations.
-- Anyway, this function takes a name, tries to determine whether it is
-- relative or absolute, and tries to return the corresponding name that is
-- /relative/ to the root.
-- /relative/ to the LoopState.root.
preprocess n = case Name.toString n of
-- some absolute name that isn't just "."
'.' : t@(_ : _) -> Name.unsafeFromString t
-- something in current path
_ ->
if Path.isRoot currentPath
if Path.isRoot curPath
then n
else Name.joinDot (Path.toName . Path.unabsolute $ currentPath) n
else Name.joinDot (Path.toName . Path.unabsolute $ curPath) n
lexedHQs = Set.map (fmap preprocess) . Set.filter HQ.hasHash $ lexedHQs0
(_missing, rawHistoricalNames) <- eval . Eval $ Branch.findHistoricalHQs lexedHQs root
(_missing, rawHistoricalNames) <- eval . Eval $ Branch.findHistoricalHQs lexedHQs root'
pure rawHistoricalNames
basicPrettyPrintNamesA :: Functor m => Action' m v Names
@ -3148,13 +3135,13 @@ makeShadowedPrintNamesFromHQ :: Monad m => Set (HQ.HashQualified Name) -> Names
makeShadowedPrintNamesFromHQ lexedHQs shadowing = do
rawHistoricalNames <- findHistoricalHQs lexedHQs
basicNames <- basicPrettyPrintNamesA
currentPath <- use currentPath
curPath <- use LoopState.currentPath
-- The basic names go into "current", but are shadowed by "shadowing".
-- They go again into "historical" as a hack that makes them available HQ-ed.
pure $
NamesWithHistory.shadowing
shadowing
(NamesWithHistory basicNames (fixupNamesRelative currentPath rawHistoricalNames))
(NamesWithHistory basicNames (fixupNamesRelative curPath rawHistoricalNames))
basicParseNames, slurpResultNames :: Functor m => Action' m v Names
basicParseNames = fst <$> basicNames'
@ -3163,15 +3150,15 @@ slurpResultNames = currentPathNames
currentPathNames :: Functor m => Action' m v Names
currentPathNames = do
currentPath' <- use currentPath
currentPath' <- use LoopState.currentPath
currentBranch' <- getAt currentPath'
pure $ Branch.toNames (Branch.head currentBranch')
-- implementation detail of basicParseNames and basicPrettyPrintNames
basicNames' :: Functor m => Action' m v (Names, Names)
basicNames' = do
root' <- use root
currentPath' <- use currentPath
root' <- use LoopState.root
currentPath' <- use LoopState.currentPath
pure $ Backend.basicNames' root' (Backend.AllNames $ Path.unabsolute currentPath')
data AddRunMainResult v

66
unison-cli/src/Unison/Codebase/Editor/HandleInput/LoopState.hs Normal file
View File

@ -0,0 +1,66 @@
{-# LANGUAGE TemplateHaskell #-}
module Unison.Codebase.Editor.HandleInput.LoopState where
import Control.Lens
import Control.Monad.State (StateT)
import Data.Configurator ()
import Data.List.NonEmpty (NonEmpty)
import Unison.Codebase.Branch
( Branch (..),
)
import Unison.Codebase.Editor.Input
import qualified Unison.Codebase.Path as Path
import Unison.Parser.Ann (Ann (..))
import Unison.Prelude
import qualified Unison.UnisonFile as UF
import Unison.Util.Free (Free)
import Unison.Codebase.Editor.Command
import qualified Data.List.NonEmpty as Nel
import qualified Unison.Util.Free as Free
type F m i v = Free (Command m i v)
-- type (Action m i v) a
type Action m i v = MaybeT (StateT (LoopState m v) (F m i v))
type NumberedArgs = [String]
data LoopState m v = LoopState
{ _root :: Branch m,
_lastSavedRoot :: Branch m,
-- the current position in the namespace
_currentPathStack :: NonEmpty Path.Absolute,
-- TBD
-- , _activeEdits :: Set Branch.EditGuid
-- The file name last modified, and whether to skip the next file
-- change event for that path (we skip file changes if the file has
-- just been modified programmatically)
_latestFile :: Maybe (FilePath, SkipNextUpdate),
_latestTypecheckedFile :: Maybe (UF.TypecheckedUnisonFile v Ann),
-- The previous user input. Used to request confirmation of
-- questionable user commands.
_lastInput :: Maybe Input,
-- A 1-indexed list of strings that can be referenced by index at the
-- CLI prompt. e.g. Given ["Foo.bat", "Foo.cat"],
-- `rename 2 Foo.foo` will rename `Foo.cat` to `Foo.foo`.
_numberedArgs :: NumberedArgs
}
type Action' m v = Action m (Either Event Input) v
type SkipNextUpdate = Bool
type InputDescription = Text
makeLenses ''LoopState
-- replacing the old read/write scalar Lens with "peek" Getter for the NonEmpty
currentPath :: Getter (LoopState m v) Path.Absolute
currentPath = currentPathStack . to Nel.head
loopState0 :: Branch m -> Path.Absolute -> LoopState m v
loopState0 b p = LoopState b b (pure p) Nothing Nothing Nothing []
eval :: Command m i v a -> Action m i v a
eval = lift . lift . Free.eval

93
unison-cli/src/Unison/Codebase/Editor/HandleInput/NamespaceDependencies.hs Normal file
View File

@ -0,0 +1,93 @@
module Unison.Codebase.Editor.HandleInput.NamespaceDependencies
( namespaceDependencies,
)
where
import Control.Monad.Trans.Maybe
import qualified Data.Map as Map
import qualified Data.Set as Set
import Unison.Codebase.Branch (Branch0)
import qualified Unison.Codebase.Branch as Branch
import Unison.Codebase.Editor.Command
import Unison.Codebase.Editor.HandleInput.LoopState (Action, eval)
import qualified Unison.DataDeclaration as DD
import Unison.LabeledDependency (LabeledDependency)
import qualified Unison.LabeledDependency as LD
import Unison.Name (Name)
import Unison.Prelude
import Unison.Reference (Reference)
import qualified Unison.Reference as Reference
import Unison.Referent (Referent)
import qualified Unison.Referent as Referent
import qualified Unison.Term as Term
import qualified Unison.Util.Relation as Relation
import qualified Unison.Util.Relation3 as Relation3
import qualified Unison.Util.Relation4 as Relation4
-- | Check the dependencies of all types, terms, and metadata in the current namespace,
-- returns a map of dependencies which do not have a name within the current namespace,
-- alongside the names of all of that thing's dependents.
--
-- This is non-transitive, i.e. only the first layer of external dependencies is returned.
--
-- So if my namespace depends on .base.Bag.map; which depends on base.Map.mapKeys, only
-- .base.Bag.map is returned unless some other definition inside my namespace depends
-- on base.Map.mapKeys directly.
--
-- Returns a Set of names rather than using the PPE since we already have the correct names in
-- scope on this branch, and also want to list ALL names of dependents, including aliases.
namespaceDependencies :: forall m i v. Ord v => Branch0 m -> Action m i v (Map LabeledDependency (Set Name))
namespaceDependencies branch = do
typeDeps <- for (Map.toList currentBranchTypeRefs) $ \(typeRef, names) -> fmap (fromMaybe Map.empty) . runMaybeT $ do
refId <- MaybeT . pure $ Reference.toId typeRef
decl <- MaybeT $ eval (LoadType refId)
let typeDeps = Set.map LD.typeRef $ DD.dependencies (DD.asDataDecl decl)
pure $ foldMap (`Map.singleton` names) typeDeps
termDeps <- for (Map.toList currentBranchTermRefs) $ \(termRef, names) -> fmap (fromMaybe Map.empty) . runMaybeT $ do
refId <- MaybeT . pure $ Referent.toReferenceId termRef
term <- MaybeT $ eval (LoadTerm refId)
let termDeps = Term.labeledDependencies term
pure $ foldMap (`Map.singleton` names) termDeps
let dependenciesToDependents :: Map LabeledDependency (Set Name)
dependenciesToDependents =
Map.unionsWith (<>) (metadata : typeDeps ++ termDeps)
let onlyExternalDeps :: Map LabeledDependency (Set Name)
onlyExternalDeps =
Map.filterWithKey
( \x _ ->
LD.fold
(`Map.notMember` currentBranchTypeRefs)
(`Map.notMember` currentBranchTermRefs)
x
)
dependenciesToDependents
pure onlyExternalDeps
where
currentBranchTermRefs :: Map Referent (Set Name)
currentBranchTermRefs = Relation.domain (Branch.deepTerms branch)
currentBranchTypeRefs :: Map Reference (Set Name)
currentBranchTypeRefs = Relation.domain (Branch.deepTypes branch)
-- Since metadata is only linked by reference, not by name,
-- it's possible that the metadata itself is external to the branch.
metadata :: Map LabeledDependency (Set Name)
metadata =
let typeMetadataRefs :: Map LabeledDependency (Set Name)
typeMetadataRefs =
(Branch.deepTypeMetadata branch)
& Relation4.d234 -- Select only the type and value portions of the metadata
& \rel ->
let types = Map.mapKeys LD.typeRef $ Relation.range (Relation3.d12 rel)
terms = Map.mapKeys LD.termRef $ Relation.range (Relation3.d13 rel)
in Map.unionWith (<>) types terms
termMetadataRefs :: Map LabeledDependency (Set Name)
termMetadataRefs =
(Branch.deepTermMetadata branch)
& Relation4.d234 -- Select only the type and value portions of the metadata
& \rel ->
let types = Map.mapKeys LD.typeRef $ Relation.range (Relation3.d12 rel)
terms = Map.mapKeys LD.termRef $ Relation.range (Relation3.d13 rel)
in Map.unionWith (<>) types terms
in Map.unionWith (<>) typeMetadataRefs termMetadataRefs

3
unison-cli/src/Unison/Codebase/Editor/Input.hs
View File

@ -145,6 +145,9 @@ data Input
| MergeIOBuiltinsI
| ListDependenciesI (HQ.HashQualified Name)
| ListDependentsI (HQ.HashQualified Name)
-- | List all external dependencies of a given namespace, or the current namespace if
-- no path is provided.
| NamespaceDependenciesI (Maybe Path')
| DebugNumberedArgsI
| DebugTypecheckedUnisonFileI
| DebugDumpNamespacesI

9
unison-cli/src/Unison/Codebase/Editor/Output.hs
View File

@ -210,7 +210,13 @@ data Output v
| NotImplemented
| NoBranchWithHash ShortBranchHash
| ListDependencies Int LabeledDependency [(Name, Reference)] (Set Reference)
| ListDependents Int LabeledDependency [(Name, Reference)] (Set Reference)
| -- | List dependents of a type or term.
ListDependents Int LabeledDependency [(Reference, Maybe Name)]
| -- | List all direct dependencies which don't have any names in the current branch
ListNamespaceDependencies
PPE.PrettyPrintEnv -- PPE containing names for everything from the root namespace.
Path.Absolute -- The namespace we're checking dependencies for.
(Map LabeledDependency (Set Name)) -- Mapping of external dependencies to their local dependents.
| DumpNumberedArgs NumberedArgs
| DumpBitBooster Branch.Hash (Map Branch.Hash [Branch.Hash])
| DumpUnisonFileHashes Int [(Name, Reference.Id)] [(Name, Reference.Id)] [(Name, Reference.Id)]
@ -340,6 +346,7 @@ isFailure o = case o of
NoOp -> False
ListDependencies {} -> False
ListDependents {} -> False
ListNamespaceDependencies {} -> False
TermMissingType {} -> True
DumpUnisonFileHashes _ x y z -> x == mempty && y == mempty && z == mempty
NamespaceEmpty _ -> False

11
unison-cli/src/Unison/Codebase/TranscriptParser.hs
View File

@ -48,7 +48,7 @@ import qualified Text.Megaparsec as P
import qualified Unison.Codebase as Codebase
import qualified Unison.Codebase.Branch as Branch
import qualified Unison.Codebase.Editor.HandleCommand as HandleCommand
import qualified Unison.Codebase.Editor.HandleInput as HandleInput
import qualified Unison.Codebase.Editor.HandleInput.LoopState as LoopState
import qualified Unison.Codebase.Path as Path
import qualified Unison.Codebase.Path.Parse as Path
import qualified Unison.Codebase.Runtime as Runtime
@ -58,6 +58,7 @@ import qualified Unison.Util.TQueue as Q
import qualified Unison.Codebase.Editor.Output as Output
import Control.Lens (view)
import Control.Error (rightMay)
import qualified Unison.Codebase.Editor.HandleInput as HandleInput
-- | Render transcript errors at a width of 65 chars.
terminalWidth :: P.Width
@ -305,7 +306,7 @@ run version dir configFile stanzas codebase = do
"Run `" <> Text.pack executable <> " --codebase " <> Text.pack dir <> "` " <> "to do more work with it."]
loop state = do
writeIORef pathRef (view HandleInput.currentPath state)
writeIORef pathRef (view LoopState.currentPath state)
let free = runStateT (runMaybeT HandleInput.loop) state
rng i = pure $ Random.drgNewSeed (Random.seedFromInteger (fromIntegral i))
(o, state') <- HandleCommand.commandLine config awaitInput
@ -323,11 +324,11 @@ run version dir configFile stanzas codebase = do
texts <- readIORef out
pure $ Text.concat (Text.pack <$> toList (texts :: Seq String))
Just () -> do
writeIORef numberedArgsRef (HandleInput._numberedArgs state')
writeIORef rootBranchRef (HandleInput._root state')
writeIORef numberedArgsRef (LoopState._numberedArgs state')
writeIORef rootBranchRef (LoopState._root state')
loop state'
(`finally` cleanup)
$ loop (HandleInput.loopState0 root initialPath)
$ loop (LoopState.loopState0 root initialPath)
transcriptFailure :: IORef (Seq String) -> Text -> IO b
transcriptFailure out msg = do

4
unison-cli/src/Unison/CommandLine/DisplayValues.hs
View File

@ -232,7 +232,7 @@ displayPretty pped terms typeOf eval types tm = go tm
goSignature r = typeOf r >>= \case
Nothing -> pure $ termName (PPE.suffixifiedPPE pped) r
Just typ -> pure . P.group $
TypePrinter.prettySignatures
TypePrinter.prettySignaturesCTCollapsed
(PPE.suffixifiedPPE pped)
[(r, PPE.termName (PPE.suffixifiedPPE pped) r, typ)]
@ -293,7 +293,7 @@ displayDoc pped terms typeOf evaluated types = go
prettySignature r = typeOf r >>= \case
Nothing -> pure $ termName (PPE.unsuffixifiedPPE pped) r
Just typ -> pure . P.group $
TypePrinter.prettySignatures
TypePrinter.prettySignaturesCTCollapsed
(PPE.suffixifiedPPE pped)
[(r, PPE.termName (PPE.unsuffixifiedPPE pped) r, typ)]
prettyEval terms r = case r of

14
unison-cli/src/Unison/CommandLine/InputPatterns.hs
View File

@ -1610,7 +1610,7 @@ dependents =
"dependents"
[]
[]
"List the dependents of the specified definition."
"List the named dependents of the specified definition."
( \case
[thing] -> fmap Input.ListDependentsI $ parseHashQualifiedName thing
_ -> Left (I.help dependents)
@ -1626,6 +1626,17 @@ dependencies =
_ -> Left (I.help dependencies)
)
namespaceDependencies :: InputPattern
namespaceDependencies = InputPattern "namespace.dependencies" [] [(Optional, namespaceArg)]
"List the external dependencies of the specified namespace."
(\case
[p] -> first fromString $ do
p <- Path.parsePath' p
pure $ Input.NamespaceDependenciesI (Just p)
[] -> pure (Input.NamespaceDependenciesI Nothing)
_ -> Left (I.help namespaceDependencies)
)
debugNumberedArgs :: InputPattern
debugNumberedArgs =
InputPattern
@ -1860,6 +1871,7 @@ validInputs =
mergeIOBuiltins,
dependents,
dependencies,
namespaceDependencies,
debugNumberedArgs,
debugFileHashes,
debugDumpNamespace,

15
unison-cli/src/Unison/CommandLine/Main.hs
View File

@ -2,7 +2,7 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}
module Unison.CommandLine.Main
module Unison.CommandLine.Main
( main
) where
@ -19,7 +19,6 @@ import Unison.Codebase.Branch (Branch)
import qualified Unison.Codebase.Branch as Branch
import Unison.Codebase.Editor.Input (Input (..), Event)
import qualified Unison.Server.CodebaseServer as Server
import qualified Unison.Codebase.Editor.HandleInput as HandleInput
import qualified Unison.Codebase.Editor.HandleCommand as HandleCommand
import Unison.Codebase.Editor.Command (LoadSourceResult(..))
import Unison.Codebase (Codebase)
@ -48,6 +47,8 @@ import Control.Error (rightMay)
import UnliftIO (catchSyncOrAsync, throwIO, withException)
import System.IO (hPutStrLn, stderr)
import Unison.Codebase.Editor.Output (Output)
import qualified Unison.Codebase.Editor.HandleInput.LoopState as LoopState
import qualified Unison.Codebase.Editor.HandleInput as HandleInput
getUserInput
:: forall m v a
@ -180,9 +181,9 @@ main dir welcome initialPath (config, cancelConfig) initialInputs runtime codeba
writeIORef pageOutput True
pure x) `catchSyncOrAsync` interruptHandler
let loop :: HandleInput.LoopState IO Symbol -> IO ()
let loop :: LoopState.LoopState IO Symbol -> IO ()
loop state = do
writeIORef pathRef (view HandleInput.currentPath state)
writeIORef pathRef (view LoopState.currentPath state)
let free = runStateT (runMaybeT HandleInput.loop) state
(o, state') <- HandleCommand.commandLine config awaitInput
(writeIORef rootRef)
@ -198,10 +199,10 @@ main dir welcome initialPath (config, cancelConfig) initialInputs runtime codeba
case o of
Nothing -> pure ()
Just () -> do
writeIORef numberedArgsRef (HandleInput._numberedArgs state')
writeIORef numberedArgsRef (LoopState._numberedArgs state')
loop state'
-- Run the main program loop, always run cleanup,
-- Run the main program loop, always run cleanup,
-- If an exception occurred, print it before exiting.
(loop (HandleInput.loopState0 root initialPath)
(loop (LoopState.loopState0 root initialPath)
`withException` \e -> hPutStrLn stderr ("Exception: " <> show (e :: SomeException)))
`finally` cleanup

60
unison-cli/src/Unison/CommandLine/OutputMessages.hs
View File

@ -11,6 +11,7 @@ import Control.Lens
import qualified Control.Monad.State.Strict as State
import Data.Bifunctor (first, second)
import Data.List (sort, stripPrefix)
import qualified Data.List as List
import Data.List.Extra (notNull, nubOrd, nubOrdOn)
import qualified Data.Map as Map
import qualified Data.Sequence as Seq
@ -1310,24 +1311,28 @@ notifyUser dir o = case o of
"",
"Paste that output into http://bit-booster.com/graph.html"
]
ListDependents hqLength ld names missing ->
ListDependents hqLength ld results ->
pure $
if names == mempty && missing == mempty
then c (prettyLabeledDependency hqLength ld) <> " doesn't have any dependents."
if null results
then prettyLd <> " doesn't have any named dependents."
else
"Dependents of " <> c (prettyLabeledDependency hqLength ld) <> ":\n\n"
<> (P.indentN 2 (P.numberedColumn2Header num pairs))
P.lines
[ "Dependents of " <> prettyLd <> ":",
"",
P.indentN 2 (P.numberedColumn2Header num pairs)
]
where
prettyLd = P.syntaxToColor (prettyLabeledDependency hqLength ld)
num n = P.hiBlack $ P.shown n <> "."
header = (P.hiBlack "Reference", P.hiBlack "Name")
pairs =
header :
( fmap (first c . second c) $
[(p $ Reference.toShortHash r, prettyName n) | (n, r) <- names]
++ [(p $ Reference.toShortHash r, "(no name available)") | r <- toList missing]
pairs = header : map pair results
pair :: (Reference, Maybe Name) -> (Pretty, Pretty)
pair (reference, maybeName) =
( prettyShortHash (SH.take hqLength (Reference.toShortHash reference)),
case maybeName of
Nothing -> ""
Just name -> prettyName name
)
p = prettyShortHash . SH.take hqLength
c = P.syntaxToColor
-- this definition is identical to the previous one, apart from the word
-- "Dependencies", but undecided about whether or how to refactor
ListDependencies hqLength ld names missing ->
@ -1348,6 +1353,28 @@ notifyUser dir o = case o of
)
p = prettyShortHash . SH.take hqLength
c = P.syntaxToColor
ListNamespaceDependencies _ppe _path Empty -> pure $ "This namespace has no external dependencies."
ListNamespaceDependencies ppe path' externalDependencies -> do
let spacer = ("", "")
pure . P.column2Header (P.hiBlack "External dependency") ("Dependents in " <> prettyAbsolute path') $
List.intersperse spacer (externalDepsTable externalDependencies)
where
externalDepsTable :: Map LabeledDependency (Set Name) -> [(P.Pretty P.ColorText, P.Pretty P.ColorText)]
externalDepsTable = ifoldMap $ \ld dependents ->
[(prettyLD ld, prettyDependents dependents)]
prettyLD :: LabeledDependency -> P.Pretty P.ColorText
prettyLD =
P.syntaxToColor
. prettyHashQualified
. LD.fold
(PPE.typeName ppe)
(PPE.termName ppe)
prettyDependents :: Set Name -> P.Pretty P.ColorText
prettyDependents refs =
refs
& Set.toList
& fmap prettyName
& P.lines
DumpUnisonFileHashes hqLength datas effects terms ->
pure . P.syntaxToColor . P.lines $
( effects <&> \(n, r) ->
@ -1412,6 +1439,9 @@ prettyPath' p' =
prettyRelative :: Path.Relative -> Pretty
prettyRelative = P.blue . P.shown
prettyAbsolute :: Path.Absolute -> Pretty
prettyAbsolute = P.blue . P.shown
prettySBH :: IsString s => ShortBranchHash -> P.Pretty s
prettySBH hash = P.group $ "#" <> P.text (SBH.toText hash)
@ -1631,7 +1661,7 @@ unsafePrettyTermResultSig' ::
Pretty
unsafePrettyTermResultSig' ppe = \case
SR'.TermResult' name (Just typ) r _aliases ->
head (TypePrinter.prettySignatures' ppe [(r, name, typ)])
head (TypePrinter.prettySignaturesCT ppe [(r, name, typ)])
_ -> error "Don't pass Nothing"
-- produces:
@ -1818,13 +1848,13 @@ todoOutput ppe todo =
),
P.indentN 2 . P.lines $
( (prettyDeclPair ppeu <$> toList frontierTypes)
++ TypePrinter.prettySignatures' ppes (goodTerms frontierTerms)
++ TypePrinter.prettySignaturesCT ppes (goodTerms frontierTerms)
),
P.wrap "I recommend working on them in the following order:",
P.numberedList $
let unscore (_score, a, b) = (a, b)
in (prettyDeclPair ppeu . unscore <$> toList dirtyTypes)
++ TypePrinter.prettySignatures'
++ TypePrinter.prettySignaturesCT
ppes
(goodTerms $ unscore <$> dirtyTerms),
formatMissingStuff corruptTerms corruptTypes

17
unison-cli/unison-cli.cabal
View File

@ -27,6 +27,8 @@ library
Unison.Codebase.Editor.Command
Unison.Codebase.Editor.HandleCommand
Unison.Codebase.Editor.HandleInput
Unison.Codebase.Editor.HandleInput.LoopState
Unison.Codebase.Editor.HandleInput.NamespaceDependencies
Unison.Codebase.Editor.Input
Unison.Codebase.Editor.Output
Unison.Codebase.Editor.Output.BranchDiff
@ -56,6 +58,8 @@ library
BangPatterns
BlockArguments
DeriveFunctor
DeriveFoldable
DeriveTraversable
DeriveGeneric
DerivingStrategies
DoAndIfThenElse
@ -94,6 +98,7 @@ library
, regex-tdfa
, stm
, text
, transformers
, unison-codebase-sqlite
, unison-core1
, unison-parser-typechecker
@ -117,6 +122,8 @@ executable integration-tests
BangPatterns
BlockArguments
DeriveFunctor
DeriveFoldable
DeriveTraversable
DeriveGeneric
DerivingStrategies
DoAndIfThenElse
@ -159,6 +166,7 @@ executable integration-tests
, stm
, text
, time
, transformers
, unison-codebase-sqlite
, unison-core1
, unison-parser-typechecker
@ -181,6 +189,8 @@ executable transcripts
BangPatterns
BlockArguments
DeriveFunctor
DeriveFoldable
DeriveTraversable
DeriveGeneric
DerivingStrategies
DoAndIfThenElse
@ -224,6 +234,7 @@ executable transcripts
, shellmet
, stm
, text
, transformers
, unison-codebase-sqlite
, unison-core1
, unison-parser-typechecker
@ -250,6 +261,8 @@ executable unison
BangPatterns
BlockArguments
DeriveFunctor
DeriveFoldable
DeriveTraversable
DeriveGeneric
DerivingStrategies
DoAndIfThenElse
@ -292,6 +305,7 @@ executable unison
, template-haskell
, temporary
, text
, transformers
, unison-cli
, unison-codebase-sqlite
, unison-core1
@ -325,6 +339,8 @@ test-suite tests
BangPatterns
BlockArguments
DeriveFunctor
DeriveFoldable
DeriveTraversable
DeriveGeneric
DerivingStrategies
DoAndIfThenElse
@ -367,6 +383,7 @@ test-suite tests
, stm
, temporary
, text
, transformers
, unison-cli
, unison-codebase-sqlite
, unison-core1

4
unison-core/src/Unison/Reference.hs
View File

@ -29,6 +29,7 @@ module Unison.Reference
showSuffix,
toHash,
toId,
fromId,
toText,
unsafeId,
toShortHash,
@ -151,6 +152,9 @@ toId :: Reference -> Maybe Id
toId (DerivedId id) = Just id
toId Builtin{} = Nothing
fromId :: Id -> Reference
fromId = DerivedId
toHash :: Reference -> Maybe H.Hash
toHash r = idToHash <$> toId r

14
unison-core/src/Unison/Referent.hs
View File

@ -10,6 +10,9 @@ module Unison.Referent
pattern ConId,
fold,
toReference,
toReferenceId,
fromTermReference,
fromTermReferenceId,
fromText,
-- * Lenses
@ -35,6 +38,7 @@ import qualified Unison.Reference as R
import Unison.Referent' (Referent' (..), toReference', reference_)
import Unison.ShortHash (ShortHash)
import qualified Unison.ShortHash as SH
import qualified Unison.Reference as Reference
-- | Specifies a term.
--
@ -94,6 +98,16 @@ toString = Text.unpack . toText
toReference :: Referent -> Reference
toReference = toReference'
toReferenceId :: Referent -> Maybe Reference.Id
toReferenceId = Reference.toId . toReference
-- | Inject a Term Reference into a Referent
fromTermReference :: Reference -> Referent
fromTermReference r = Ref r
fromTermReferenceId :: Reference.Id -> Referent
fromTermReferenceId = fromTermReference . Reference.fromId
isPrefixOf :: ShortHash -> Referent -> Bool
isPrefixOf sh r = SH.isPrefixOf sh (toShortHash r)

5
unison-core/src/Unison/ShortHash.hs
View File

@ -8,7 +8,10 @@ import Unison.Prelude
import qualified Data.Text as Text
-- Arya created this type to be able to query the Codebase for anonymous definitions. The parsing functions can't fail, because they only try to pull apart the syntactic elements "#" and ".". They don't necessarily produce a meaningful reference; you'll figure that out during base58 decoding. We don't attempt base58 decoding here because the base58 prefix doesn't correspond to anything useful. We'll just compare strings against the codebase or namespace later.
-- Arya created this type to be able to query the Codebase for anonymous definitions. The parsing functions can't fail,
-- because they only try to pull apart the syntactic elements "#" and ".". They don't necessarily produce a meaningful
-- reference; you'll figure that out during base32 decoding. We don't attempt base32 decoding here because the base32
-- prefix doesn't correspond to anything useful. We'll just compare strings against the codebase or namespace later.
-- None of the punctuation is stored here.
data ShortHash
= Builtin Text

12
unison-core/src/Unison/WatchKind.hs
View File

@ -7,5 +7,17 @@ module Unison.WatchKind where
type WatchKind = String
-- | A non-test watch, such as
-- @
-- > 3 + 4
-- @
pattern RegularWatch = ""
-- | A named test watch, such as
--
-- @
-- test> x = expect (1 == 1)
-- @
--
-- Note: currently test watches don't need to be named by the user, but that "feature" will be removed soon.
pattern TestWatch = "test"

26
unison-src/transcripts-using-base/namespace-dependencies.md Normal file
View File

@ -0,0 +1,26 @@
# namespace.dependencies command
```ucm:hide
.> builtins.merge
```
```unison:hide
myMetadata = "just some text"
```
```ucm:hide
.metadata> add
```
```unison:hide
dependsOnNat = 1
dependsOnInt = -1
dependsOnIntAndNat = Nat.drop 1 10
hasMetadata = 3
```
```ucm
.dependencies> add
.dependencies> link .metadata.myMetadata hasMetadata
.dependencies> namespace.dependencies
```

48
unison-src/transcripts-using-base/namespace-dependencies.output.md Normal file
View File

@ -0,0 +1,48 @@
# namespace.dependencies command
```unison
myMetadata = "just some text"
```
```unison
dependsOnNat = 1
dependsOnInt = -1
dependsOnIntAndNat = Nat.drop 1 10
hasMetadata = 3
```
```ucm
☝️ The namespace .dependencies is empty.
.dependencies> add
⍟ I've added these definitions:
dependsOnInt : Int
dependsOnIntAndNat : Nat
dependsOnNat : Nat
hasMetadata : Nat
.dependencies> link .metadata.myMetadata hasMetadata
Updates:
1. dependencies.hasMetadata : Nat
+ 2. myMetadata : Text
.dependencies> namespace.dependencies
External dependency Dependents in .dependencies
.builtin.Int dependsOnInt
.builtin.Nat dependsOnIntAndNat
dependsOnNat
hasMetadata
.builtin.Text hasMetadata
.builtin.Nat.drop dependsOnIntAndNat
.metadata.myMetadata hasMetadata
```

2
unison-src/transcripts/dependents-dependencies-debugfile.output.md
View File

@ -47,7 +47,7 @@ But wait, there's more. I can check the dependencies and dependents of a defini
.> dependents q
#l5pndeifuh doesn't have any dependents.
#l5pndeifuh doesn't have any named dependents.
.> dependencies q

20
unison-src/transcripts/universal-cmp.md Normal file
View File

@ -0,0 +1,20 @@
File for test cases making sure that universal equality/comparison
cases exist for built-in types. Just making sure they don't crash.
```ucm:hide
.> builtins.mergeio
```
```unison
threadEyeDeez _ =
t1 = forkComp '()
t2 = forkComp '()
t1 == t2
t1 < t2
()
```
```ucm
.> run threadEyeDeez
```

28
unison-src/transcripts/universal-cmp.output.md Normal file
View File

@ -0,0 +1,28 @@
File for test cases making sure that universal equality/comparison
cases exist for built-in types. Just making sure they don't crash.
```unison
threadEyeDeez _ =
t1 = forkComp '()
t2 = forkComp '()
t1 == t2
t1 < t2
()
```
```ucm
I found and typechecked these definitions in scratch.u. If you
do an `add` or `update`, here's how your codebase would
change:
⍟ These new definitions are ok to `add`:
threadEyeDeez : ∀ _. _ ->{IO} ()
```
```ucm
.> run threadEyeDeez
```