From 71f5b230d337a1e795a420d80b0a6d57c7981cf8 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 7 Oct 2022 18:36:53 -0600 Subject: [PATCH] Add current branch, current names, and current PPED cache --- unison-cli/src/Unison/Cli/Monad.hs | 72 +++++++++++++++---- unison-cli/src/Unison/Cli/MonadUtils.hs | 29 +++++--- .../src/Unison/Codebase/TranscriptParser.hs | 11 ++- unison-cli/src/Unison/CommandLine/Main.hs | 3 +- unison-cli/src/Unison/LSP/Types.hs | 10 +-- 5 files changed, 95 insertions(+), 30 deletions(-) diff --git a/unison-cli/src/Unison/Cli/Monad.hs b/unison-cli/src/Unison/Cli/Monad.hs index dbdb90f6ec..0b1495318f 100644 --- a/unison-cli/src/Unison/Cli/Monad.hs +++ b/unison-cli/src/Unison/Cli/Monad.hs @@ -14,6 +14,7 @@ module Unison.Cli.Monad -- * Immutable state LoopState (..), loopState0, + modifyLoopStateRootBranch, -- * Lifting IO actions ioE, @@ -43,7 +44,8 @@ module Unison.Cli.Monad ) where -import Control.Lens (lens, (.=)) +import Control.Concurrent.Extra (once) +import Control.Lens (lens, (.=), (^.)) import Control.Monad.Reader (MonadReader (..), ReaderT (ReaderT)) import Control.Monad.State.Strict (MonadState, StateT (StateT)) import Control.Monad.Trans.Cont @@ -62,14 +64,20 @@ import Unison.Auth.CredentialManager (CredentialManager) import Unison.Auth.HTTPClient (AuthenticatedHttpClient) import Unison.Codebase (Codebase) import Unison.Codebase.Branch (Branch) +import qualified Unison.Codebase.Branch as Branch +import qualified Unison.Codebase.Branch.Names as Branch import Unison.Codebase.Editor.Input (Input) import Unison.Codebase.Editor.Output (NumberedArgs, NumberedOutput, Output) import Unison.Codebase.Editor.UCMVersion (UCMVersion) import qualified Unison.Codebase.Path as Path import Unison.Codebase.Runtime (Runtime) import qualified Unison.Debug as Debug +import Unison.Names (Names) +import qualified Unison.NamesWithHistory as NamesWithHistory import Unison.Parser.Ann (Ann) import Unison.Prelude +import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl) +import qualified Unison.PrettyPrintEnvDecl.Names as PPED import qualified Unison.Server.CodebaseServer as Server import Unison.Symbol (Symbol) import qualified Unison.Syntax.Parser as Parser @@ -151,6 +159,11 @@ data LoopState = LoopState lastSavedRootHash :: V2Branch.CausalHash, -- the current position in the namespace currentPathStack :: List.NonEmpty Path.Absolute, + currentBranch :: IO (Branch IO), + currentNames :: IO Names, + currentPPED :: IO PrettyPrintEnvDecl, + -- Hash length to use when generating ppes + hashLength :: Int, -- TBD -- , _activeEdits :: Set Branch.EditGuid @@ -185,19 +198,52 @@ instance loopState {currentPathStack = path List.NonEmpty.:| paths} ) +modifyLoopStateRootBranch :: (Branch IO -> Branch IO) -> (LoopState -> IO (LoopState, Branch IO)) +modifyLoopStateRootBranch f ls = do + let rootVar = root ls + newRoot <- atomically do + root <- takeTMVar rootVar + let newRoot = f root + putTMVar rootVar $! newRoot + pure newRoot + ls' <- updateDerivedValues ls + pure (ls', newRoot) + +updateDerivedValues :: LoopState -> IO LoopState +updateDerivedValues ls = do + let currentPath = ls ^. #currentPath + currentBranch <- once do + atomically do + rootBranch <- readTMVar (root ls) + pure $ Branch.getAt' (Path.unabsolute currentPath) rootBranch + let currentNames = Branch.toNames . Branch.head <$> currentBranch + let currentPPED = PPED.fromNamesDecl (hashLength ls) . NamesWithHistory.fromCurrentNames <$> currentNames + pure $ ls {currentBranch = currentBranch, currentNames = currentNames, currentPPED = currentPPED} + -- | Create an initial loop state given a root branch and the current path. -loopState0 :: V2Branch.CausalHash -> TMVar (Branch IO) -> Path.Absolute -> LoopState -loopState0 lastSavedRootHash b p = do - LoopState - { root = b, - lastSavedRootHash = lastSavedRootHash, - currentPathStack = pure p, - latestFile = Nothing, - latestTypecheckedFile = Nothing, - lastInput = Nothing, - numberedArgs = [], - lastRunResult = Nothing - } +loopState0 :: Int -> V2Branch.CausalHash -> TMVar (Branch IO) -> Path.Absolute -> IO LoopState +loopState0 hashLength lastSavedRootHash b p = do + currentBranch <- once do + atomically do + rootBranch <- readTMVar b + pure $ Branch.getAt' (Path.unabsolute p) rootBranch + let currentNames = Branch.toNames . Branch.head <$> currentBranch + let currentPPED = PPED.fromNamesDecl hashLength . NamesWithHistory.fromCurrentNames <$> currentNames + pure $ + LoopState + { root = b, + lastSavedRootHash = lastSavedRootHash, + currentPathStack = pure p, + currentBranch, + currentNames, + currentPPED, + hashLength, + latestFile = Nothing, + latestTypecheckedFile = Nothing, + lastInput = Nothing, + numberedArgs = [], + lastRunResult = Nothing + } -- | Run a @Cli@ action down to @IO@. runCli :: Env -> LoopState -> Cli a a -> IO (ReturnType a, LoopState) diff --git a/unison-cli/src/Unison/Cli/MonadUtils.hs b/unison-cli/src/Unison/Cli/MonadUtils.hs index 5425c8c020..eb5f82eb27 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -22,6 +22,8 @@ module Unison.Cli.MonadUtils getRootBranch0, getCurrentBranch, getCurrentBranch0, + getCurrentNames, + getCurrentPPED, getBranchAt, getBranch0At, getLastSavedRootHash, @@ -79,7 +81,7 @@ import qualified Data.Configurator.Types as Configurator import qualified Data.Set as Set import qualified U.Codebase.Branch as V2Branch import qualified U.Codebase.Causal as V2Causal -import Unison.Cli.Monad (Cli) +import Unison.Cli.Monad (Cli, LoopState) import qualified Unison.Cli.Monad as Cli import qualified Unison.Codebase as Codebase import Unison.Codebase.Branch (Branch (..), Branch0 (..)) @@ -97,8 +99,10 @@ import qualified Unison.Codebase.ShortBranchHash as SBH import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv import qualified Unison.HashQualified' as HQ' import Unison.NameSegment (NameSegment) +import Unison.Names (Names) import Unison.Parser.Ann (Ann (..)) import Unison.Prelude +import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl) import Unison.Reference (TypeReference) import Unison.Referent (Referent) import Unison.Symbol (Symbol) @@ -182,18 +186,25 @@ setRootBranch b = do -- | Get the root branch. modifyRootBranch :: (Branch IO -> Branch IO) -> Cli r (Branch IO) modifyRootBranch f = do - rootVar <- use #root - atomically do - root <- takeTMVar rootVar - let newRoot = f root - putTMVar rootVar $! newRoot - pure newRoot + ls <- get + (ls', b) <- liftIO $ Cli.modifyLoopStateRootBranch f ls + put ls' + pure b -- | Get the current branch. getCurrentBranch :: Cli r (Branch IO) getCurrentBranch = do - path <- getCurrentPath - getBranchAt path + use #currentBranch >>= liftIO + +-- | Get the names for the current branch. +getCurrentNames :: (MonadState LoopState m, MonadIO m) => m Names +getCurrentNames = do + use #currentNames >>= liftIO + +-- | Get the names for the current branch. +getCurrentPPED :: (MonadState LoopState m, MonadIO m) => m PrettyPrintEnvDecl +getCurrentPPED = do + use #currentPPED >>= liftIO -- | Get the current branch0. getCurrentBranch0 :: Cli r (Branch0 IO) diff --git a/unison-cli/src/Unison/Codebase/TranscriptParser.hs b/unison-cli/src/Unison/Codebase/TranscriptParser.hs index ecd2ea5537..9ea1518350 100644 --- a/unison-cli/src/Unison/Codebase/TranscriptParser.hs +++ b/unison-cli/src/Unison/Codebase/TranscriptParser.hs @@ -235,9 +235,14 @@ run dir stanzas codebase runtime sbRuntime config ucmVersion baseURL = UnliftIO. ] initialRootCausalHash <- Codebase.getRootCausalHash codebase rootVar <- newEmptyTMVarIO + currentBranchVar <- newEmptyTMVarIO + currentPPEDVar <- newEmptyTMVarIO void $ Ki.fork scope do root <- Codebase.getRootBranch codebase - atomically $ putTMVar rootVar root + atomically $ do + putTMVar rootVar root + putTMVar currentBranchVar root + putTMVar currentPPEDVar root mayShareAccessToken <- fmap Text.pack <$> lookupEnv accessTokenEnvVarKey credMan <- AuthN.newCredentialManager let tokenProvider :: AuthN.TokenProvider @@ -485,7 +490,9 @@ run dir stanzas codebase runtime sbRuntime config ucmVersion baseURL = UnliftIO. texts <- readIORef out pure $ Text.concat (Text.pack <$> toList (texts :: Seq String)) - loop (Cli.loopState0 initialRootCausalHash rootVar initialPath) + hashLen <- Codebase.hashLength codebase + initState <- liftIO (Cli.loopState0 hashLen initialRootCausalHash rootVar initialPath) + loop initState transcriptFailure :: IORef (Seq String) -> Text -> IO b transcriptFailure out msg = do diff --git a/unison-cli/src/Unison/CommandLine/Main.hs b/unison-cli/src/Unison/CommandLine/Main.hs index 23bb5d1e80..3e6c9931b5 100644 --- a/unison-cli/src/Unison/CommandLine/Main.hs +++ b/unison-cli/src/Unison/CommandLine/Main.hs @@ -117,7 +117,8 @@ main dir welcome initialPath (config, cancelConfig) initialInputs runtime sbRunt -- This might be overly aggressive, maybe we should just evaluate the top level but avoid -- recursive "deep*" things. void $ UnliftIO.evaluate root - let initialState = Cli.loopState0 initialRootCausalHash rootVar initialPath + hashLen <- Codebase.hashLength codebase + initialState <- liftIO (Cli.loopState0 hashLen initialRootCausalHash rootVar initialPath) Ki.fork_ scope $ do let loop lastRoot = do -- This doesn't necessarily notify on _every_ update, but the LSP only needs the diff --git a/unison-cli/src/Unison/LSP/Types.hs b/unison-cli/src/Unison/LSP/Types.hs index 28e2238540..69016e6953 100644 --- a/unison-cli/src/Unison/LSP/Types.hs +++ b/unison-cli/src/Unison/LSP/Types.hs @@ -77,11 +77,11 @@ data FileAnalysis = FileAnalysis { fileUri :: !Uri, fileVersion :: !FileVersion, lexedSource :: LexedSource, - parsedFile :: ~Maybe (UF.UnisonFile Symbol Ann), - typecheckedFile :: ~Maybe (UF.TypecheckedUnisonFile Symbol Ann), - notes :: ~Seq (Note Symbol Ann), - diagnostics :: ~IntervalMap Position [Diagnostic], - codeActions :: ~IntervalMap Position [CodeAction] + parsedFile :: Maybe (UF.UnisonFile Symbol Ann), + typecheckedFile :: Maybe (UF.TypecheckedUnisonFile Symbol Ann), + notes :: Seq (Note Symbol Ann), + diagnostics :: IntervalMap Position [Diagnostic], + codeActions :: IntervalMap Position [CodeAction] } deriving (Show)