move some code around

unison-cli/package.yaml

@@ -150,15 +150,18 @@ default-extensions:
   - ApplicativeDo
   - BangPatterns
   - BlockArguments
+  - DeriveAnyClass
   - DeriveFunctor
   - DeriveFoldable
   - DeriveTraversable
   - DeriveGeneric
   - DerivingStrategies
+  - DerivingVia
   - DoAndIfThenElse
   - DuplicateRecordFields
   - FlexibleContexts
   - FlexibleInstances
+  - GADTs
   - GeneralizedNewtypeDeriving
   - LambdaCase
   - MultiParamTypeClasses

unison-cli/src/Unison/Codebase/Editor/Command.hs

@@ -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,

unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs

@@ -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 ->

unison-cli/src/Unison/Monad/Cli.hs

@@ -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

unison-cli/unison-cli.cabal

@@ -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