climb 0.3.3 → 0.4.0
raw patch · 3 files changed
+89/−47 lines, 3 files
Files
- app/Main.hs +46/−25
- climb.cabal +9/−3
- src/Climb.hs +34/−19
app/Main.hs view
@@ -1,41 +1,62 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} module Main where import Climb-import Control.Monad.Catch (MonadThrow)-import Control.Monad.IO.Class (MonadIO)-import Control.Monad.IO.Unlift (MonadUnliftIO (..), wrappedWithRunInIO)-import Linenoise+import Control.Exception (Exception)+import Control.Monad.Catch (MonadCatch, MonadThrow (..))+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.IO.Unlift (MonadUnliftIO (..))+import Control.Monad.Reader (MonadReader (..), ReaderT (..), asks)+import qualified Data.Map.Strict as Map+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import Text.Read (readMaybe) -newtype Repl a = Repl { unRepl :: ReplT () () IO a }- deriving (Functor, Applicative, Monad, MonadIO, MonadThrow)+newtype BadGuessErr = BadGuessErr (Maybe Int)+ deriving stock (Eq, Show) -instance MonadUnliftIO Repl where- withRunInIO = wrappedWithRunInIO Repl unRepl+instance Exception BadGuessErr -runRepl :: Repl a -> IO a-runRepl r = fmap fst (runReplT (unRepl r) () ())+data ReplEnv = ReplEnv+ { reMagicNumber :: !Int+ } deriving stock (Eq, Show) -options :: OptionCommands Repl-options = mempty+newtype ReplM a = ReplM { unReplM :: ReaderT ReplEnv IO a }+ deriving newtype (Functor, Applicative, Monad, MonadReader ReplEnv, MonadIO, MonadUnliftIO, MonadThrow, MonadCatch) -exec :: Command Repl-exec = const (pure ReplContinue)+runReplM :: ReplM a -> ReplEnv -> IO a+runReplM = runReaderT . unReplM -completion :: Completion Repl-completion = const (pure [])+guessCommand :: Command ReplM+guessCommand input = do+ num <- asks reMagicNumber+ let mayGuess = readMaybe (T.unpack input)+ if readMaybe (T.unpack input) == Just num+ then ReplContinue <$ liftIO (putStrLn "You guessed it!")+ else throwM (BadGuessErr mayGuess) -replDef :: ReplDef Repl+options :: OptionCommands ReplM+options = Map.fromList [("guess", ("guess a number", guessCommand))]++exec :: Command ReplM+exec input = liftIO $ do+ putStr "You said: "+ TIO.putStrLn input+ pure ReplContinue++completion :: Completion ReplM+completion _ = pure []++replDef :: ReplDef ReplM replDef = ReplDef- { _rdOnInterrupt = ReplContinue- , _rdGreeting = "Hello, REPL!"- , _rdPrompt = "> "- , _rdOptionCommands = options- , _rdExecCommand = exec- , _rdCompletion = completion+ { rdOnInterrupt = ReplContinue+ , rdGreeting = "Hello, REPL!"+ , rdPrompt = "> "+ , rdOptionCommands = options+ , rdExecCommand = exec+ , rdCompletion = completion } main :: IO ()-main = runRepl (runReplDef replDef)+main = runReplM (runReplDef replDef) (ReplEnv 42)
climb.cabal view
@@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0.+-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack ----- hash: ef9b6c6a8b9065c4429bdbdaf4fb5f06470af3787a069de51b48eb6026c5631f+-- hash: 13958ca7b14089cca51ac048a8cea2d64d6e8e460fa1cddae5a3d4f5bd15ec68 name: climb-version: 0.3.3+version: 0.4.0 synopsis: Building blocks for a GHCi-like REPL with colon-commands description: Please see the README on GitHub at <https://github.com/ejconlon/climb#readme> category: User Interfaces@@ -33,6 +33,9 @@ Paths_climb hs-source-dirs: src+ default-extensions:+ DerivingStrategies+ GeneralizedNewtypeDeriving ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds build-depends: base >=4.12 && <5@@ -51,6 +54,9 @@ Paths_climb hs-source-dirs: app+ default-extensions:+ DerivingStrategies+ GeneralizedNewtypeDeriving ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.12 && <5
src/Climb.hs view
@@ -3,7 +3,7 @@ -- | Building blocks for a GHCI-like REPL with colon-commands. module Climb ( Command- , CommandExc (..)+ , CommandErr (..) , Completion , OptionCommands , ReplDef (..)@@ -14,9 +14,9 @@ , runReplDef ) where -import Control.Exception (Exception)+import Control.Exception (Exception (..), SomeAsyncException (..), SomeException) import Control.Monad (unless)-import Control.Monad.Catch (MonadThrow (..))+import Control.Monad.Catch (MonadCatch, MonadThrow (..), catchIf) import Control.Monad.Fix (fix) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.IO.Unlift (MonadUnliftIO)@@ -26,7 +26,6 @@ import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.IO as TIO-import Data.Typeable (Typeable) import Linenoise.Repl (ReplDirective (..), replM) -- | A 'Command' takes some input, performs some effect, and returns a directive (continue or quit).@@ -39,24 +38,24 @@ type Completion m = Text -> m [Text] -- | Sometimes things go wrong...-data CommandExc- = ExpectedNoInputError+data CommandErr+ = CommandErrExpectedNoInput -- ^ An option 'Command' got input when it expected None- | MissingCommandError !Text+ | CommandErrUnknownCommand !Text -- ^ An option 'Command' was not found by name.- deriving (Eq, Show, Typeable)+ deriving stock (Eq, Show) -instance Exception CommandExc+instance Exception CommandErr -- | Defines a REPL with commands, options, and completion. data ReplDef m = ReplDef- { _rdOnInterrupt :: !ReplDirective- , _rdGreeting :: !Text- , _rdPrompt :: !Text- , _rdOptionCommands :: !(OptionCommands m)- , _rdExecCommand :: !(Command m)- , _rdCompletion :: !(Completion m)+ { rdOnInterrupt :: !ReplDirective+ , rdGreeting :: !Text+ , rdPrompt :: !Text+ , rdOptionCommands :: !(OptionCommands m)+ , rdExecCommand :: !(Command m)+ , rdCompletion :: !(Completion m) } noOptionCommands :: OptionCommands m@@ -66,7 +65,7 @@ noCompletion = const (pure []) assertEmpty :: MonadThrow m => Text -> m ()-assertEmpty input = unless (Text.null input) (throwM ExpectedNoInputError)+assertEmpty input = unless (Text.null input) (throwM CommandErrExpectedNoInput) -- | Helps you define commands that expect no input. bareCommand :: MonadThrow m => m ReplDirective -> Command m@@ -93,15 +92,31 @@ Just (':', rest) -> do let (name, subInput) = Text.break (==' ') rest case Map.lookup name opts of- Nothing -> throwM (MissingCommandError name)+ Nothing -> throwM (CommandErrUnknownCommand name) Just (_, command) -> command (Text.drop 1 subInput) _ -> exec input +isUserErr :: SomeException -> Bool+isUserErr x =+ case fromException x of+ Just (SomeAsyncException _) -> False+ _ -> True++catchUserErr :: MonadCatch m => m a -> (SomeException -> m a) -> m a+catchUserErr = catchIf isUserErr++handleUserErr :: (MonadCatch m, MonadIO m) => Command m -> Command m+handleUserErr action input = catchUserErr (action input) $ \err -> do+ liftIO (TIO.putStr "Caught error: ")+ liftIO (print err)+ pure ReplContinue+ -- | Runs a REPL as defined.-runReplDef :: (MonadThrow m, MonadUnliftIO m) => ReplDef m -> m ()+runReplDef :: (MonadCatch m, MonadUnliftIO m) => ReplDef m -> m () runReplDef (ReplDef onInterrupt greeting prompt opts exec comp) = do let allOpts = fix (\c -> defaultOptions c <> opts) action = outerCommand allOpts exec+ handledAction = handleUserErr action liftIO (TIO.putStrLn greeting) liftIO (TIO.putStrLn "Enter `:quit` to exit or `:help` to see all commands.")- replM onInterrupt prompt action comp+ replM onInterrupt prompt handledAction comp