mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-11 10:35:57 +03:00
move some code around
This commit is contained in:
parent
f853a8bd45
commit
fc2fcf6037
@ -150,15 +150,18 @@ default-extensions:
|
||||
- ApplicativeDo
|
||||
- BangPatterns
|
||||
- BlockArguments
|
||||
- DeriveAnyClass
|
||||
- DeriveFunctor
|
||||
- DeriveFoldable
|
||||
- DeriveTraversable
|
||||
- DeriveGeneric
|
||||
- DerivingStrategies
|
||||
- DerivingVia
|
||||
- DoAndIfThenElse
|
||||
- DuplicateRecordFields
|
||||
- FlexibleContexts
|
||||
- FlexibleInstances
|
||||
- GADTs
|
||||
- GeneralizedNewtypeDeriving
|
||||
- LambdaCase
|
||||
- MultiParamTypeClasses
|
||||
|
@ -54,17 +54,15 @@ import qualified Data.Configurator.Types as Configurator
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import qualified Data.List.NonEmpty as Nel
|
||||
import qualified Data.Map as Map
|
||||
import Unison.Auth.CredentialManager (CredentialManager)
|
||||
import Unison.Auth.HTTPClient (AuthenticatedHttpClient)
|
||||
import Unison.Codebase (Codebase)
|
||||
import Unison.Codebase.Branch (Branch)
|
||||
import Unison.Codebase.Editor.Input (Input)
|
||||
import Unison.Codebase.Editor.Output
|
||||
import Unison.Codebase.Editor.UCMVersion (UCMVersion)
|
||||
import qualified Unison.Codebase.Path as Path
|
||||
import Unison.Codebase.Runtime (Runtime)
|
||||
import qualified Unison.Codebase.Runtime as Runtime
|
||||
import qualified Unison.Lexer as L
|
||||
import Unison.Monad.Cli hiding (with)
|
||||
import Unison.Names (Names)
|
||||
import qualified Unison.Parser as Parser
|
||||
import Unison.Parser.Ann (Ann)
|
||||
@ -82,17 +80,10 @@ import qualified Unison.WatchKind as WK
|
||||
|
||||
type AmbientAbilities v = [Type v Ann]
|
||||
|
||||
type SourceName = Text
|
||||
|
||||
type Source = Text
|
||||
|
||||
type LexedSource = (Text, [L.Token L.Lexeme])
|
||||
|
||||
data LoadSourceResult
|
||||
= InvalidSourceNameError
|
||||
| LoadError
|
||||
| LoadSuccess Text
|
||||
|
||||
type TypecheckingResult v =
|
||||
Result
|
||||
(Seq (Note v Ann))
|
||||
@ -163,25 +154,6 @@ data LoopState = LoopState
|
||||
|
||||
type SkipNextUpdate = Bool
|
||||
|
||||
data Env = Env
|
||||
{ authHTTPClient :: AuthenticatedHttpClient,
|
||||
codebase :: Codebase IO Symbol Ann,
|
||||
config :: Configurator.Config,
|
||||
credentialManager :: CredentialManager,
|
||||
-- | Generate a unique name.
|
||||
generateUniqueName :: IO Parser.UniqueName,
|
||||
-- | How to load source code.
|
||||
loadSource :: SourceName -> IO LoadSourceResult,
|
||||
-- | What to do with output for the user.
|
||||
notify :: Output -> IO (),
|
||||
-- | What to do with numbered output for the user.
|
||||
notifyNumbered :: NumberedOutput -> IO NumberedArgs,
|
||||
runtime :: Runtime Symbol,
|
||||
sandboxedRuntime :: Runtime Symbol,
|
||||
serverBaseUrl :: Maybe Server.BaseUrl,
|
||||
ucmVersion :: UCMVersion
|
||||
}
|
||||
|
||||
newtype Action a = Action {unAction :: Free Command a}
|
||||
deriving newtype
|
||||
( Functor,
|
||||
|
@ -1,99 +1,16 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
|
||||
module Unison.Codebase.Editor.HandleCommand
|
||||
( commandLine,
|
||||
)
|
||||
where
|
||||
|
||||
module Unison.Codebase.Editor.HandleCommand where
|
||||
|
||||
import Control.Monad.Reader (MonadReader (ask, local), ReaderT (ReaderT))
|
||||
import Control.Monad.Trans.Cont
|
||||
import Control.Monad.Reader (MonadReader (ask, local))
|
||||
import Unison.Codebase.Editor.Command (Action (..), Command (..), Env, LoopState)
|
||||
import Unison.Codebase.Editor.Input (Event, Input)
|
||||
import Unison.Monad.Cli (Cli (..), ReturnType (..), abortStep, haltRepl, scopeWith, with, withCliToIO')
|
||||
import Unison.Prelude
|
||||
import qualified Unison.Util.Free as Free
|
||||
import qualified UnliftIO
|
||||
|
||||
data ReturnType a
|
||||
= Success a
|
||||
| HaltStep
|
||||
| HaltRepl
|
||||
|
||||
data Bailing
|
||||
= HaltingStep
|
||||
| HaltingRepl
|
||||
deriving stock (Show)
|
||||
deriving anyclass (Exception)
|
||||
|
||||
newtype Cli r a = Cli {unCli :: (a -> Env -> IO (ReturnType r)) -> Env -> IO (ReturnType r)}
|
||||
deriving
|
||||
( Functor,
|
||||
Applicative,
|
||||
Monad,
|
||||
MonadIO,
|
||||
MonadReader Env
|
||||
)
|
||||
via ContT (ReturnType r) (ReaderT Env IO)
|
||||
|
||||
-- | 'withCliToIO' generalized to accept other monads that we can turn
|
||||
-- into 'Cli' (e.g. Action)
|
||||
withCliToIO' :: forall r a. ((forall m x. (m x -> Cli x x) -> m x -> IO x) -> IO a) -> Cli r a
|
||||
withCliToIO' run = Cli \k env -> do
|
||||
ea <- try $
|
||||
run $ \toCli someMonad ->
|
||||
let Cli ma = toCli someMonad
|
||||
in ma (\a _ -> pure (Success a)) env >>= \case
|
||||
HaltStep -> UnliftIO.throwIO HaltingStep
|
||||
HaltRepl -> UnliftIO.throwIO HaltingRepl
|
||||
Success a -> pure a
|
||||
case ea of
|
||||
Left HaltingStep -> pure HaltStep
|
||||
Left HaltingRepl -> pure HaltRepl
|
||||
Right a -> k a env
|
||||
|
||||
-- | Provide a way to run 'Cli' to IO. Note that this also delimits
|
||||
-- the scope of and 'succeedWith' or 'with' calls.
|
||||
withCliToIO :: ((forall x. Cli x x -> IO x) -> IO a) -> Cli r a
|
||||
withCliToIO k = withCliToIO' \k' -> k (k' id)
|
||||
|
||||
short :: ReturnType r -> Cli r a
|
||||
short r = Cli \_k _env -> pure r
|
||||
|
||||
-- | Short-circuit success. Returns 'r' to the nearest enclosing
|
||||
-- 'scopeWith'
|
||||
succeedWith :: r -> Cli r a
|
||||
succeedWith = short . Success
|
||||
|
||||
-- | Short-circuit success
|
||||
abortStep :: Cli r a
|
||||
abortStep = short HaltStep
|
||||
|
||||
-- | Halt the repl
|
||||
haltRepl :: Cli r a
|
||||
haltRepl = short HaltRepl
|
||||
|
||||
-- | Wrap a continuation with 'Cli'. Provides a nicer syntax to
|
||||
-- resource acquiring functions.
|
||||
--
|
||||
-- @
|
||||
-- resource <- with (bracket acquire close)
|
||||
-- @
|
||||
--
|
||||
-- Delimit the scope of acquired resources with 'scopeWith'.
|
||||
with :: (forall x. (a -> IO x) -> IO x) -> Cli r a
|
||||
with resourceK = Cli \k env -> resourceK (\resource -> k resource env)
|
||||
|
||||
-- | Delimit the scope of 'with' calls
|
||||
scopeWith :: Cli x x -> Cli r x
|
||||
scopeWith (Cli ma) = Cli \k env -> do
|
||||
ma (\x _ -> pure (Success x)) env >>= \case
|
||||
Success x -> k x env
|
||||
HaltStep -> pure HaltStep
|
||||
HaltRepl -> pure HaltRepl
|
||||
|
||||
commandLine ::
|
||||
Env ->
|
||||
LoopState ->
|
||||
|
123
unison-cli/src/Unison/Monad/Cli.hs
Normal file
123
unison-cli/src/Unison/Monad/Cli.hs
Normal file
@ -0,0 +1,123 @@
|
||||
-- | The main CLI monad.
|
||||
--
|
||||
-- TODO export list, docs
|
||||
module Unison.Monad.Cli where
|
||||
|
||||
import Control.Monad.Reader (MonadReader (..), ReaderT (ReaderT))
|
||||
import Control.Monad.Trans.Cont
|
||||
import qualified Data.Configurator.Types as Configurator
|
||||
import Unison.Auth.CredentialManager (CredentialManager)
|
||||
import Unison.Auth.HTTPClient (AuthenticatedHttpClient)
|
||||
import Unison.Codebase (Codebase)
|
||||
import Unison.Codebase.Editor.Output (Output, NumberedOutput, NumberedArgs)
|
||||
import Unison.Codebase.Editor.UCMVersion (UCMVersion)
|
||||
import Unison.Codebase.Runtime (Runtime)
|
||||
import qualified Unison.Parser as Parser
|
||||
import Unison.Parser.Ann (Ann)
|
||||
import Unison.Prelude
|
||||
import qualified Unison.Server.CodebaseServer as Server
|
||||
import Unison.Symbol (Symbol)
|
||||
import qualified UnliftIO
|
||||
|
||||
data ReturnType a
|
||||
= Success a
|
||||
| HaltStep
|
||||
| HaltRepl
|
||||
|
||||
data Bailing
|
||||
= HaltingStep
|
||||
| HaltingRepl
|
||||
deriving stock (Show)
|
||||
deriving anyclass (Exception)
|
||||
|
||||
newtype Cli r a = Cli {unCli :: (a -> Env -> IO (ReturnType r)) -> Env -> IO (ReturnType r)}
|
||||
deriving
|
||||
( Functor,
|
||||
Applicative,
|
||||
Monad,
|
||||
MonadIO,
|
||||
MonadReader Env
|
||||
)
|
||||
via ContT (ReturnType r) (ReaderT Env IO)
|
||||
|
||||
data Env = Env
|
||||
{ authHTTPClient :: AuthenticatedHttpClient,
|
||||
codebase :: Codebase IO Symbol Ann,
|
||||
config :: Configurator.Config,
|
||||
credentialManager :: CredentialManager,
|
||||
-- | Generate a unique name.
|
||||
generateUniqueName :: IO Parser.UniqueName,
|
||||
-- | How to load source code.
|
||||
loadSource :: SourceName -> IO LoadSourceResult,
|
||||
-- | What to do with output for the user.
|
||||
notify :: Output -> IO (),
|
||||
-- | What to do with numbered output for the user.
|
||||
notifyNumbered :: NumberedOutput -> IO NumberedArgs,
|
||||
runtime :: Runtime Symbol,
|
||||
sandboxedRuntime :: Runtime Symbol,
|
||||
serverBaseUrl :: Maybe Server.BaseUrl,
|
||||
ucmVersion :: UCMVersion
|
||||
}
|
||||
|
||||
type SourceName = Text
|
||||
|
||||
data LoadSourceResult
|
||||
= InvalidSourceNameError
|
||||
| LoadError
|
||||
| LoadSuccess Text
|
||||
|
||||
-- | 'withCliToIO' generalized to accept other monads that we can turn
|
||||
-- into 'Cli' (e.g. Action)
|
||||
withCliToIO' :: forall r a. ((forall m x. (m x -> Cli x x) -> m x -> IO x) -> IO a) -> Cli r a
|
||||
withCliToIO' run = Cli \k env -> do
|
||||
ea <- try $
|
||||
run $ \toCli someMonad ->
|
||||
let Cli ma = toCli someMonad
|
||||
in ma (\a _ -> pure (Success a)) env >>= \case
|
||||
HaltStep -> UnliftIO.throwIO HaltingStep
|
||||
HaltRepl -> UnliftIO.throwIO HaltingRepl
|
||||
Success a -> pure a
|
||||
case ea of
|
||||
Left HaltingStep -> pure HaltStep
|
||||
Left HaltingRepl -> pure HaltRepl
|
||||
Right a -> k a env
|
||||
|
||||
-- | Provide a way to run 'Cli' to IO. Note that this also delimits
|
||||
-- the scope of and 'succeedWith' or 'with' calls.
|
||||
withCliToIO :: ((forall x. Cli x x -> IO x) -> IO a) -> Cli r a
|
||||
withCliToIO k = withCliToIO' \k' -> k (k' id)
|
||||
|
||||
short :: ReturnType r -> Cli r a
|
||||
short r = Cli \_k _env -> pure r
|
||||
|
||||
-- | Short-circuit success. Returns 'r' to the nearest enclosing
|
||||
-- 'scopeWith'
|
||||
succeedWith :: r -> Cli r a
|
||||
succeedWith = short . Success
|
||||
|
||||
-- | Short-circuit success
|
||||
abortStep :: Cli r a
|
||||
abortStep = short HaltStep
|
||||
|
||||
-- | Halt the repl
|
||||
haltRepl :: Cli r a
|
||||
haltRepl = short HaltRepl
|
||||
|
||||
-- | Wrap a continuation with 'Cli'. Provides a nicer syntax to
|
||||
-- resource acquiring functions.
|
||||
--
|
||||
-- @
|
||||
-- resource <- with (bracket acquire close)
|
||||
-- @
|
||||
--
|
||||
-- Delimit the scope of acquired resources with 'scopeWith'.
|
||||
with :: (forall x. (a -> IO x) -> IO x) -> Cli r a
|
||||
with resourceK = Cli \k env -> resourceK (\resource -> k resource env)
|
||||
|
||||
-- | Delimit the scope of 'with' calls
|
||||
scopeWith :: Cli x x -> Cli r x
|
||||
scopeWith (Cli ma) = Cli \k env -> do
|
||||
ma (\x _ -> pure (Success x)) env >>= \case
|
||||
Success x -> k x env
|
||||
HaltStep -> pure HaltStep
|
||||
HaltRepl -> pure HaltRepl
|
@ -1,6 +1,6 @@
|
||||
cabal-version: 1.12
|
||||
|
||||
-- This file has been generated from package.yaml by hpack version 0.34.6.
|
||||
-- This file has been generated from package.yaml by hpack version 0.34.4.
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
|
||||
@ -60,6 +60,7 @@ library
|
||||
Unison.CommandLine.Main
|
||||
Unison.CommandLine.OutputMessages
|
||||
Unison.CommandLine.Welcome
|
||||
Unison.Monad.Cli
|
||||
Unison.Share.Codeserver
|
||||
Unison.Share.Sync
|
||||
Unison.Share.Sync.Types
|
||||
@ -70,15 +71,18 @@ library
|
||||
ApplicativeDo
|
||||
BangPatterns
|
||||
BlockArguments
|
||||
DeriveAnyClass
|
||||
DeriveFunctor
|
||||
DeriveFoldable
|
||||
DeriveTraversable
|
||||
DeriveGeneric
|
||||
DerivingStrategies
|
||||
DerivingVia
|
||||
DoAndIfThenElse
|
||||
DuplicateRecordFields
|
||||
FlexibleContexts
|
||||
FlexibleInstances
|
||||
GADTs
|
||||
GeneralizedNewtypeDeriving
|
||||
LambdaCase
|
||||
MultiParamTypeClasses
|
||||
@ -171,15 +175,18 @@ executable cli-integration-tests
|
||||
ApplicativeDo
|
||||
BangPatterns
|
||||
BlockArguments
|
||||
DeriveAnyClass
|
||||
DeriveFunctor
|
||||
DeriveFoldable
|
||||
DeriveTraversable
|
||||
DeriveGeneric
|
||||
DerivingStrategies
|
||||
DerivingVia
|
||||
DoAndIfThenElse
|
||||
DuplicateRecordFields
|
||||
FlexibleContexts
|
||||
FlexibleInstances
|
||||
GADTs
|
||||
GeneralizedNewtypeDeriving
|
||||
LambdaCase
|
||||
MultiParamTypeClasses
|
||||
@ -273,15 +280,18 @@ executable transcripts
|
||||
ApplicativeDo
|
||||
BangPatterns
|
||||
BlockArguments
|
||||
DeriveAnyClass
|
||||
DeriveFunctor
|
||||
DeriveFoldable
|
||||
DeriveTraversable
|
||||
DeriveGeneric
|
||||
DerivingStrategies
|
||||
DerivingVia
|
||||
DoAndIfThenElse
|
||||
DuplicateRecordFields
|
||||
FlexibleContexts
|
||||
FlexibleInstances
|
||||
GADTs
|
||||
GeneralizedNewtypeDeriving
|
||||
LambdaCase
|
||||
MultiParamTypeClasses
|
||||
@ -378,15 +388,18 @@ executable unison
|
||||
ApplicativeDo
|
||||
BangPatterns
|
||||
BlockArguments
|
||||
DeriveAnyClass
|
||||
DeriveFunctor
|
||||
DeriveFoldable
|
||||
DeriveTraversable
|
||||
DeriveGeneric
|
||||
DerivingStrategies
|
||||
DerivingVia
|
||||
DoAndIfThenElse
|
||||
DuplicateRecordFields
|
||||
FlexibleContexts
|
||||
FlexibleInstances
|
||||
GADTs
|
||||
GeneralizedNewtypeDeriving
|
||||
LambdaCase
|
||||
MultiParamTypeClasses
|
||||
@ -488,15 +501,18 @@ test-suite cli-tests
|
||||
ApplicativeDo
|
||||
BangPatterns
|
||||
BlockArguments
|
||||
DeriveAnyClass
|
||||
DeriveFunctor
|
||||
DeriveFoldable
|
||||
DeriveTraversable
|
||||
DeriveGeneric
|
||||
DerivingStrategies
|
||||
DerivingVia
|
||||
DoAndIfThenElse
|
||||
DuplicateRecordFields
|
||||
FlexibleContexts
|
||||
FlexibleInstances
|
||||
GADTs
|
||||
GeneralizedNewtypeDeriving
|
||||
LambdaCase
|
||||
MultiParamTypeClasses
|
||||
|
Loading…
Reference in New Issue
Block a user