diff --git a/System/Console/Wizard.hs b/System/Console/Wizard.hs --- a/System/Console/Wizard.hs +++ b/System/Console/Wizard.hs @@ -1,17 +1,29 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, Trustworthy, MultiParamTypeClasses, FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts, TypeOperators, Trustworthy #-} +-- Necessary for MonadIO instance. +{-# LANGUAGE UndecidableInstances #-} module System.Console.Wizard ( -- * Wizards -- $intro Wizard (..) , PromptString (..) + , run + , (:<:) + , (:+:) -- * Primitives -- $primitives + , Line , line + , LinePrewritten , linePrewritten + , Password , password - , character + , Character + , character + , Output , output + , OutputLn , outputLn + , ArbitraryIO -- * Modifiers -- $modifiers , retry @@ -30,104 +42,95 @@ ) where import System.Console.Wizard.Internal + import Control.Applicative import Control.Monad.Trans.Maybe +import Control.Monad.Trans +import Control.Monad.Free import Control.Monad.Reader -import Control.Monad.Prompt import Data.Maybe - --- | A @Wizard a@ is a conversation with the user that will result in a data type @a@, or may fail. --- A 'Wizard' is made up of one or more \"primitives\" (see below), composed using the 'Applicative', --- 'Monad' and 'Alternative' instances. The 'Alternative' instance is, as you might expect, a maybe-style cascade. --- If the first wizard fails, the next one is tried. --- --- The 'Wizard' constructor is exported here for use when developing backends, but it is better for end-users to --- simply pretend that 'Wizard' is an opaque data type. Don't depend on this unless you have no other choice. --- --- 'Wizard's are, internally, just a maybe transformer over a prompt monad for each primitive action. -newtype Wizard backend a = Wizard (MaybeT (RecPrompt (WizardAction backend)) a) - deriving (Monad, Functor, Applicative, Alternative, MonadPlus) -instance MonadPrompt (WizardAction s (RecPrompt (WizardAction s))) (Wizard s) where - prompt = Wizard . lift . prompt - - +import Data.Monoid -- $primitives -- /Primitives/ are the basic building blocks for @wizards@. Use these functions to produce wizards that -- ask for input from the user, or output information. --- | Read one line of input from the user. -line :: PromptString -> Wizard b String -line str = prompt $ Line str +-- | Output a string. Does not fail. +output :: (Output :<: b) => String -> Wizard b () +output s = Wizard $ lift $ inject (Output s (Pure ())) +-- | Output a string followed by a newline. Does not fail. +outputLn :: (OutputLn :<: b) => String -> Wizard b () +outputLn s = Wizard $ lift $ inject (OutputLn s (Pure ())) + +-- | Read one line of input from the user. Cannot fail (but may throw exceptions, depending on the backend). +line :: (Line :<: b) => PromptString -> Wizard b String +line s = Wizard $ lift $ inject (Line s Pure) + +-- | Read a single character only from input. Cannot fail (but may throw exceptions, depending on the backend). +character :: (Character :<: b) + => PromptString + -> Wizard b Char +character p = Wizard $ lift $ inject (Character p Pure) + + +instance (ArbitraryIO :<: b) => MonadIO (Wizard b) where + liftIO v = Wizard $ lift $ inject (ArbitraryIO v Pure) -- | Read one line of input, with some default text already present, before and/or after the editing cursor. --- Backends are not required to display this default text, or position the cursor anywhere, it is merely --- a suggestion. -linePrewritten :: PromptString +--- Cannot fail (but may throw exceptions, depending on the backend). +linePrewritten :: (LinePrewritten :<: b) + => PromptString -> String -- ^ Text to the left of the cursor -> String -- ^ Text to the right of the cursor -> Wizard b String -linePrewritten p s1 s2 = prompt $ LinePreset p s1 s2 +linePrewritten p s1 s2 = Wizard $ lift $ inject (LinePrewritten p s1 s2 Pure) -- | Read one line of password input, with an optional mask character. --- The exact masking behavior of the password may vary from backend to backend. The masking character --- does not have to be honoured. -password :: PromptString +--- Cannot fail (but may throw exceptions, depending on the backend). +password :: (Password :<: b) + => PromptString -> Maybe Char -- ^ Mask character, if any. -> Wizard b String -password str m = prompt $ Password str m - --- | Read a single character only from input. -character :: PromptString -> Wizard b Char -character = prompt . Character - --- | Output a string, if the backend used supports output. -output :: String -> Wizard b () -output = prompt . Output - --- | Output a string followed by a newline, if the backend used supports such output. -outputLn :: String -> Wizard b () -outputLn = prompt . OutputLn +password p mc = Wizard $ lift $ inject (Password p mc Pure) -- $modifiers -- /Modifiers/ change the behaviour of existing wizards. -- | Retry produces a wizard that will retry the entire conversation again if it fails. --- Conceptually, it could thought of as @retry x = x \<|\> retry x@, however it also prints --- a user-friendly error message in the event of failure. -retry :: Wizard b a -> Wizard b a -retry = retryMsg "Invalid input. Please try again." +-- It is simply @retry x = x \<|\> retry x@. +retry :: Functor b => Wizard b a -> Wizard b a +retry x = x <|> retry x --- | Same as 'retry', except the error message can be specified. -retryMsg :: String -> Wizard b a -> Wizard b a +-- | Same as 'retry', except an error message can be specified. +retryMsg :: (OutputLn :<: b) => String -> Wizard b a -> Wizard b a retryMsg msg x = x <|> (outputLn msg >> retryMsg msg x) -- | @x \`defaultTo\` y@ will return @y@ if @x@ fails, e.g @parseRead line \`defaultTo\` 0@. -defaultTo :: Wizard b a -> a -> Wizard b a +defaultTo :: Functor b => Wizard b a -> a -> Wizard b a defaultTo wz d = wz <|> pure d -- | Like 'fmap', except the function may be partial ('Nothing' causes the wizard to fail). -parser :: (a -> Maybe c) -> Wizard b a -> Wizard b c +parser :: Functor b => (a -> Maybe c) -> Wizard b a -> Wizard b c parser f a = a >>= liftMaybe . f --- | @validator p w@ causes a wizard to fail if the output value does not satisfy the predicate @p@. -validator :: (a -> Bool) -> Wizard b a -> Wizard b a +-- | @validator p@ causes a wizard to fail if the output value does not satisfy the predicate @p@. +validator :: Functor b => (a -> Bool) -> Wizard b a -> Wizard b a validator = parser . ensure -- | Simply @validator (not . null)@, makes a wizard fail if it gets an empty string. -nonEmpty :: Wizard b [a] -> Wizard b [a] +nonEmpty :: Functor b => Wizard b [a] -> Wizard b [a] nonEmpty = validator (not . null) -- | Makes a wizard fail if it gets an ordered quantity outside of the given range. -inRange :: (Ord a) => (a,a) -> Wizard b a -> Wizard b a +inRange :: (Ord a, Functor b) => (a,a) -> Wizard b a -> Wizard b a inRange (b,t) = validator (\x -> b <= x && x <= t) -- | Simply @parser readP@. Attaches a simple @read@ parser to a 'Wizard'. -parseRead :: (Read a) => Wizard b String -> Wizard b a +parseRead :: (Read a, Functor b) => Wizard b String -> Wizard b a parseRead = parser (readP) -- | Translate a maybe value into wizard success/failure. -liftMaybe :: Maybe a -> Wizard b a +liftMaybe :: Functor b => Maybe a -> Wizard b a liftMaybe (Just v) = pure v liftMaybe (Nothing) = mzero diff --git a/System/Console/Wizard/BasicIO.hs b/System/Console/Wizard/BasicIO.hs --- a/System/Console/Wizard/BasicIO.hs +++ b/System/Console/Wizard/BasicIO.hs @@ -1,34 +1,37 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, GADTs, KindSignatures #-} -module System.Console.Wizard.BasicIO +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeOperators, GeneralizedNewtypeDeriving, Trustworthy #-} +module System.Console.Wizard.BasicIO ( BasicIO - , runBasicIO + , basicIO ) where import System.Console.Wizard -import System.Console.Wizard.Internal +import System.Console.Wizard.Internal import Control.Monad.Trans -import Control.Monad.Prompt import Control.Monad.Trans.Maybe -import Control.Applicative((<$>)) -import Data.Typeable - --- | A very simple standard IO backend for @wizards@, supporting input and output. --- Default text and password masks are ignored. --- A more full-featured back-end is based on Haskeline. --- Arbitrary IO actions can be performed in wizards via a 'MonadIO' instance. -data BasicIO (m :: * -> *) r = ArbitraryIO (IO r) +instance Run IO Output where runAlgebra (Output s w) = putStr s >> w +instance Run IO OutputLn where runAlgebra (OutputLn s w) = putStrLn s >> w +instance Run IO Line where runAlgebra (Line s w) = getLine >>= w +instance Run IO Character where runAlgebra (Character s w) = getChar >>= w +instance Run IO ArbitraryIO where runAlgebra (ArbitraryIO iov f) = iov >>= f --- | Runs a Wizard action in the BasicIO backend. -runBasicIO :: Wizard BasicIO a -> IO (Maybe a) -runBasicIO (Wizard (MaybeT c)) = runRecPromptM f c - where f :: WizardAction BasicIO (RecPrompt (WizardAction BasicIO) ) c -> IO c - f (Line s) = getLine - f (Character s) = getChar - f (Password s m) = getLine - f (LinePreset s f b) = getLine - f (Output s) = putStr s - f (OutputLn s) = putStrLn s - f (Backend (ArbitraryIO a)) = a +-- | The 'BasicIO' backend supports only simple input and output. +-- Support for 'Password' and 'LinePrewritten' features can be added with +-- a shim from 'System.Console.Wizard.Shim'. +newtype BasicIO a = BasicIO (( Output + :+: OutputLn + :+: Line + :+: Character + :+: ArbitraryIO) a) + deriving ( (:<:) Output + , (:<:) OutputLn + , (:<:) Line + , (:<:) Character + , (:<:) ArbitraryIO + , Functor + , Run IO + ) -instance MonadIO (Wizard BasicIO) where - liftIO = prompt . Backend . ArbitraryIO +-- | A simple identity function, used to restrict types if the type inferred by GHC is too general. +-- You could achieve the same effect with a type signature, but this is slightly less typing. +basicIO :: Wizard BasicIO a -> Wizard BasicIO a +basicIO = id diff --git a/System/Console/Wizard/Haskeline.hs b/System/Console/Wizard/Haskeline.hs --- a/System/Console/Wizard/Haskeline.hs +++ b/System/Console/Wizard/Haskeline.hs @@ -1,50 +1,66 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, GADTs #-} +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, TypeOperators, GeneralizedNewtypeDeriving, Trustworthy #-} module System.Console.Wizard.Haskeline - ( Haskeline - , UnexpectedEOF (..) - , runHaskeline + ( UnexpectedEOF (..) + , Haskeline + , haskeline , withSettings + , WithSettings(..) ) where import System.Console.Wizard import System.Console.Wizard.Internal import System.Console.Haskeline import Control.Monad.Trans -import Control.Monad.Prompt import Control.Monad.Trans.Maybe import Control.Exception import Data.Typeable --- | A Haskeline backend for @wizards@, supporting input, output, default text, and password input. --- In addition, Haskeline settings can be modified for a single wizard, and arbitrary IO can be --- performed using the 'MonadIO' instance. -data Haskeline m r = SetSettings (Settings IO) (m r) - | ArbitraryIO (IO r) -- | The Haskeline back-end will throw this exception if EOF is encountered -- when it is not expected. Specifically, when actions such as 'getInputLine' return 'Nothing'. data UnexpectedEOF = UnexpectedEOF deriving (Show, Typeable) instance Exception UnexpectedEOF --- | Runs a Wizard action in the Haskeline backend. -runHaskeline :: Wizard Haskeline a -> InputT IO (Maybe a) -runHaskeline (Wizard c) = runRecPromptM f $ runMaybeT c - where f :: WizardAction Haskeline (RecPrompt (WizardAction Haskeline) ) a -> InputT IO a - f (Line s) = getInputLine s >>= maybeToException UnexpectedEOF - f (Character s) = getInputChar s >>= maybeToException UnexpectedEOF - f (Password s m) = getPassword m s >>= maybeToException UnexpectedEOF - f (LinePreset s f b) = getInputLineWithInitial s (f,b) >>= maybeToException UnexpectedEOF - f (Output s) = outputStr s - f (OutputLn s) = outputStrLn s - f (Backend (SetSettings s v)) = liftIO $ runInputT s (runRecPromptM f v) - f (Backend (ArbitraryIO a)) = liftIO $ a +-- | Haskeline supports all the following features completely. +newtype Haskeline a = Haskeline (( Output + :+: OutputLn + :+: Line + :+: Character + :+: LinePrewritten + :+: Password + :+: ArbitraryIO + :+: WithSettings) a) + deriving ( (:<:) Output + , (:<:) OutputLn + , (:<:) Line + , (:<:) Character + , (:<:) LinePrewritten + , (:<:) Password + , (:<:) ArbitraryIO + , (:<:) WithSettings + , Functor + , Run (InputT IO) + ) -- | Modifies a wizard so that it will run with different Haskeline 'Settings' to the top level input monad. -withSettings :: Settings IO -> Wizard Haskeline a -> Wizard Haskeline a -withSettings sets (Wizard (MaybeT v)) = Wizard $ MaybeT $ prompt $ Backend $ SetSettings sets $ v +withSettings :: (WithSettings :<: b) => Settings IO -> Wizard b a -> Wizard b a +withSettings sets (Wizard (MaybeT v)) = Wizard $ MaybeT $ inject (WithSettings sets v) -instance MonadIO (Wizard Haskeline) where - liftIO = prompt . Backend . ArbitraryIO +data WithSettings w = WithSettings (Settings IO) w deriving (Functor) -maybeToException :: (Monad m, Exception e) => e -> Maybe a -> m a -maybeToException e (Just v) = return v -maybeToException e (Nothing) = throw e +instance Run (InputT IO) Output where runAlgebra (Output s w) = outputStr s >> w +instance Run (InputT IO) OutputLn where runAlgebra (OutputLn s w) = outputStrLn s >> w +instance Run (InputT IO) Line where runAlgebra (Line s w) = getInputLine s >>= mEof w +instance Run (InputT IO) Character where runAlgebra (Character s w) = getInputChar s >>= mEof w +instance Run (InputT IO) LinePrewritten where runAlgebra (LinePrewritten p s1 s2 w) = getInputLineWithInitial p (s1,s2) >>= mEof w +instance Run (InputT IO) Password where runAlgebra (Password p mc w) = getPassword mc p >>= mEof w +instance Run (InputT IO) ArbitraryIO where runAlgebra (ArbitraryIO iov f) = liftIO iov >>= f +instance Run (InputT IO) WithSettings where runAlgebra (WithSettings sets w) = liftIO (runInputT sets w) + +mEof = maybe (throw UnexpectedEOF) + + +-- | A simple identity function, used to restrict types if the type inferred by GHC is too general. +-- You could achieve the same effect with a type signature, but this is slightly less typing. +haskeline :: Wizard Haskeline a -> Wizard Haskeline a +haskeline = id + diff --git a/System/Console/Wizard/Internal.hs b/System/Console/Wizard/Internal.hs --- a/System/Console/Wizard/Internal.hs +++ b/System/Console/Wizard/Internal.hs @@ -1,85 +1,172 @@ -{-# LANGUAGE GADTs, KindSignatures #-} -module System.Console.Wizard.Internal ( WizardAction (..) +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, DeriveFunctor, FlexibleContexts, TypeOperators, GeneralizedNewtypeDeriving, Trustworthy, ExistentialQuantification, EmptyDataDecls #-} +module System.Console.Wizard.Internal ( Wizard (..) , PromptString (..) + , (:+:) (..) + , (:<:) + , inject + , Run (..) + , run + -- $functors + , Output (..) + , OutputLn (..) + , Line (..) + , LinePrewritten (..) + , Password (..) + , Character (..) + , ArbitraryIO (..) -- $backend ) where +import Control.Monad.Free +import Control.Monad.Trans.Maybe +import Control.Applicative -type PromptString = String +-- | A string for a prompt +type PromptString = String --- | Internally, a 'Wizard' is essentially a prompt monad with a 'WizardAction'. A constructor exists for each primitive action, as well --- as a special \"escape hatch\" constructor ('Backend') used for writing backend-specific primitives and modifiers. --- Each back-end has a corresponding data type, used as a type parameter for 'Wizard'. This data type is usually opaque, but internally --- specifies additional primitive actions that are specific to the back-end. --- 'WizardAction' is parameterised by this data type (for use in the 'Backend' constructor), the prompt monad itself (so that modifiers --- can be made as well as primitives) and the return type of the action. -data WizardAction :: ((* -> *) -> * -> *) -> (* -> *) -> * -> * where - Line :: PromptString -> WizardAction b m String - LinePreset :: PromptString -> String -> String -> WizardAction b m String - Password :: PromptString -> Maybe Char -> WizardAction b m String - Character :: PromptString -> WizardAction b m Char - Output :: String -> WizardAction b m () - OutputLn :: String -> WizardAction b m () - Backend :: b m a -> WizardAction b m a +-- | A @Wizard b a@ is a conversation with the user via back-end @b@ that will result in a data type @a@, or may fail. +-- A 'Wizard' is made up of one or more \"primitives\" (see below), composed using the 'Applicative', +-- 'Monad' and 'Alternative' instances. The 'Alternative' instance is, as you might expect, a maybe-style cascade. +-- If the first wizard fails, the next one is tried. `mzero` can be used to induce failure directly. +-- +-- The 'Wizard' constructor is exported here for use when developing backends, but it is better for end-users to +-- simply pretend that 'Wizard' is an opaque data type. Don't depend on this unless you have no other choice. +-- +-- 'Wizard's are, internally, just a maybe transformer over a free monad built from some coproduct of functors, +-- each of which is a primitive action. +newtype Wizard backend a = Wizard (MaybeT (Free backend) a) + deriving (Monad, Functor, Applicative, Alternative, MonadPlus) + +-- | Coproduct of two functors +data (f :+: g) w = Inl (f w) | Inr (g w) deriving Functor + +-- | Subsumption of two functors. You shouldn't define any of your own instances of this when writing back-ends, rely only on GeneralizedNewtypeDeriving. +class (Functor sub, Functor sup) => sub :<: sup where + inj :: sub a -> sup a + +instance Functor f => f :<: f where inj = id +instance (Functor f, Functor g) => f :<: (f :+: g) where inj = Inl +instance (Functor f, Functor g, Functor h, f :<: g) => f :<: (h :+: g) where inj = Inr . inj + +-- | Injection function for free monads, see \"Data Types a la Carte\" from Walter Swierstra, @http:\/\/www.cs.ru.nl\/~W.Swierstra\/Publications\/DataTypesALaCarte.pdf@ +inject :: (g :<: f ) => g (Free f a) -> Free f a +inject = Impure . inj + +-- | A class for implementing actions on a backend. E.g Run IO Output provides an interpreter for the Output action in the IO monad. +class Run a b where + runAlgebra :: b (a v) -> a v + +instance (Run b f, Run b g) => Run b (f :+: g) where + runAlgebra (Inl r) = runAlgebra r + runAlgebra (Inr r) = runAlgebra r + +infixr 9 :+: + +-- $functors +-- Each of the following functors is a primitive action. A back-end provides interpreters for these actions using the 'Run' class, + +data Output w = Output String w deriving Functor +data OutputLn w = OutputLn String w deriving Functor +data Line w = Line PromptString (String -> w) deriving Functor +data Character w = Character PromptString (Char -> w) deriving Functor +data LinePrewritten w = LinePrewritten PromptString String String (String -> w) deriving Functor +data Password w = Password PromptString (Maybe Char) (String -> w) deriving Functor +data ArbitraryIO w = forall a. ArbitraryIO (IO a) (a -> w) +instance Functor (ArbitraryIO) where + fmap f (ArbitraryIO iov f') = ArbitraryIO iov (fmap f f') + + + +run' :: (Functor f, Monad b, Run b f) => Free f a -> b a +run' = foldFree return runAlgebra + +-- | Run a wizard using some back-end. +run :: (Functor f, Monad b, Run b f) => Wizard f a -> b (Maybe a) +run (Wizard c) = run' (runMaybeT c) + + -- $backend -- A short tutorial on writing backends. -- -- Backends consist of two main components: -- --- 1. A back-end data type (the type parameter to 'Wizard'), which includes constructors --- for any primitive actions or modifiers that are specific to the back-end. +-- 1. A monad, @M@, in which the primitive actions are interpreted. 'Run' instances specify an interpreter for each supported +-- action, e.g @Run M Output@ will specify an interpreter for the 'Output' primitive action in the monad M. -- --- 2. An interpreter function, of type @Wizard DataType a -> B (Maybe a)@ for some type @B@ (depending on the backend). --- Typically this function will provide semantics for each 'WizardAction' using 'runRecPromptM' or similar. --- --- The 'Backend' constructor can be used to add back-end specific primitives and modifiers. +-- 2. A newtype, e.g @Backend a@, which is a functor, usually implemented by wrapping a coproduct of all supported features. +-- '(:<:)' instances, the 'Functor' instance, and the 'Run' instance are provided by generalized newtype deriving. -- --- As an example, suppose I am writing a back-end to @IO@, like "System.Console.Wizard.BasicIO". --- One additional primitive action that I might want to include is the ability to run arbitrary @IO@ actions while a wizard is running. --- So, my backend data type will be: +-- As an example, suppose I am writing a back-end to @IO@, like "System.Console.Wizard.BasicIO". I want to support basic input and output, +-- and arbitrary IO, so I declare instances for 'Run' for the 'IO' monad: -- --- @ --- data MyBackend (m :: * -> *) r = ArbitraryIO (IO r) -- kind signature to avoid defaulting to * --- @ +-- @ +-- instance Run IO Output where runAlgebra (Output s w) = putStr s >> w +-- instance Run IO OutputLn where runAlgebra (OutputLn s w) = putStrLn s >> w +-- instance Run IO Line where runAlgebra (Line s w) = getLine >>= w +-- instance Run IO Character where runAlgebra (Character s w) = getChar >>= w +-- instance Run IO ArbitraryIO where runAlgebra (ArbitraryIO iov f) = iov >>= f +-- @ +-- +-- And then I would define the newtype for the backend, which we can call @MyIOBackend@: +-- +-- @ +-- newtype MyIOBackend a = MyIOBackend ((Output :+: OutputLn :+: Line :+: Character :+: ArbitraryIO) a) +-- deriving ( Functor, Run IO +-- , (:<:) Output +-- , (:<:) OutputLn +-- , (:<:) Line +-- , (:<:) Character +-- , (:<:) ArbitraryIO +-- ) +-- @ +-- +-- A useful convenience is to provide a simple identity function to serve as a type coercion: +-- +-- @ +-- myIOBackend :: Wizard MyIOBackend a -> Wizard MyIOBackend a +-- myIOBackend = id +-- @ -- --- And my interpreter function will be: +-- One additional primitive action that I might want to include is the ability to clear the screen at a certain point. +-- So, we define a new data type for the action: -- --- @ --- runWizardMyBackend :: Wizard MyBackend a -> IO a --- runWizardMyBackend (Wizard (MaybeT c)) = runRecPromptM f c --- where f :: WizardAction MyBackend (RecPrompt (WizardAction MyBackend)) a -> IO a --- f (Output s) = putStr s --- f (... ) = ... --- f (Backend (ArbitraryIO io)) = io --- @ +-- @ +-- data ClearScreen w = ClearScreen w deriving Functor -- via -XDeriveFunctor +-- @ -- --- And then the action can be easily defined: +-- And a \"smart\" constructor for use by the user: -- --- @ --- runIO :: IO a -> Wizard MyBackend a --- runIO = prompt . Backend . ArbitraryIO --- @ +-- @ +-- clearScreen :: (ClearScreen :\<: b) => Wizard b () +-- clearScreen = Wizard $ lift $ inject (ClearScreen (Pure ())) +-- @ -- --- I might also want to include a /modifier/, which say, colours any output text green. Assuming I have a function --- @ --- withGreenText :: IO a -> IO a --- @ --- which causes any output produced by the input action to be coloured green, we can use the 'Backend' constructor to transform --- this into a wizard modifier. +-- (These smart constructors all follow a similar pattern. See the source of "System.Console.Wizard" for more examples) +-- +-- And then we define an interpreter for it: -- --- @ ---data MyBackend m r = ArbitraryIO (IO r) --- | GreenText (m r) +-- @ +-- instance Run IO ArbitraryIO where runAlgebra (ClearScreen f) = clearTheScreen >> f +-- @ -- ---runWizardMyBackend :: Wizard MyBackend ---runWizardMyBackend (Wizard (MaybeT c)) = runRecPromptM f c --- where f :: WizardAction MyBackend (RecPrompt (WizardAction MyBackend)) a -> IO a --- f (Output s) = putStr s --- f (... ) = ... --- f (Backend (ArbitraryIO io)) = io --- f (Backend (GreenText a)) = withGreenText $ runRecPromptM f a +-- Now, we can use this as-is simply by directly extending our back-end: -- ---greenText :: Wizard MyBackend a -> Wizard MyBackend a ---greenText (Wizard (MaybeT a)) = prompt (Backend (GreenText a)) --- @ +-- @ +-- foo :: Wizard (ClearScreen :+: MyIOBackend) +-- foo = clearScreen >> output \"Hello World!\" +-- @ -- +-- Or, we could modify @MyIOBackend@ to include the extension directly. +-- +-- +-- For custom actions that /return/ output, the definition looks slightly different. Here is the definition of Line: +-- +-- @ +-- data Line w = Line (PromptString) (String -> w) deriving Functor -- via -XDeriveFunctor +-- @ -- +-- And the smart constructor looks like this: +-- +-- @ +-- line :: (Line :\<: b) => PromptString -> Wizard b String +-- line s = Wizard $ lift $ inject (Line s Pure) +-- @ diff --git a/System/Console/Wizard/Pure.hs b/System/Console/Wizard/Pure.hs new file mode 100644 --- /dev/null +++ b/System/Console/Wizard/Pure.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, FlexibleInstances, TypeOperators, DoAndIfThenElse, GeneralizedNewtypeDeriving, Trustworthy #-} +module System.Console.Wizard.Pure + ( Pure + , UnexpectedEOI (..) + , runPure + , PureState (..) + ) where + +import System.Console.Wizard +import System.Console.Wizard.Internal +import Control.Monad.Trans +import Control.Monad.State.Lazy +import Control.Monad.Trans.Maybe +import Control.Applicative((<$>)) +import Data.Typeable +import Data.Sequence(Seq, (|>), (><), fromList, empty) +import Control.Monad +import Control.Exception +import Control.Arrow +import Data.Foldable(toList) + +-- | Thrown if the wizard ever unexpectedly runs out of input. +data UnexpectedEOI = UnexpectedEOI deriving (Show, Typeable) +instance Exception UnexpectedEOI + +-- | The pure backend is actually just a simple state monad, with the following state. +type PureState = ([String], Seq Char) + +-- | Run a wizard in the Pure backend +runPure :: Wizard Pure a -> String -> (Maybe a, String) +runPure wz input = let (a,(_,o)) = runState (run wz) (lines input, empty) + in (a, toList o) + +getPureLine :: State PureState String +getPureLine = do crashIfNull + x <- head . fst <$> get + modify (first tail) + return x + +crashIfNull :: State PureState () +crashIfNull = do (x, y ) <- get + when (null x) $ throw UnexpectedEOI + +getPureChar :: State PureState Char +getPureChar = do crashIfNull + x <- null . head . fst <$> get + if x then do + modify (first tail) + return '\n' + else do + r <- head . head . fst <$> get + modify (first (\ (x : r) -> tail x : r)) + return r + +outputPure :: String -> State PureState () +outputPure s = modify (second (>< fromList s)) + >> modify (\s -> s `seq` s) + +outputLnPure :: String -> State PureState () +outputLnPure s = modify (second $ (|> '\n') . (>< fromList s)) + >> modify (\s -> s `seq` s) + + +instance Run (State PureState) Output where runAlgebra (Output s w) = outputPure s >> w +instance Run (State PureState) OutputLn where runAlgebra (OutputLn s w) = outputLnPure s >> w +instance Run (State PureState) Line where runAlgebra (Line s w) = getPureLine >>= w +instance Run (State PureState) Character where runAlgebra (Character s w) = getPureChar >>= w + +-- | The 'Pure' backend supports only simple input and output. +-- Support for 'Password' and 'LinePrewritten' features can be added with +-- a shim from "System.Console.Wizard.Shim". +newtype Pure a = Pure ((Output :+: OutputLn :+: Line :+: Character) a) + deriving ( (:<:) Output + , (:<:) OutputLn + , (:<:) Line + , (:<:) Character + , Functor + , Run (State PureState) + ) + diff --git a/wizards.cabal b/wizards.cabal --- a/wizards.cabal +++ b/wizards.cabal @@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented. -Version: 0.1 +Version: 1.0 -- A short (one-line) description of the package. Synopsis: High level, generic library for interrogative user interfaces @@ -36,10 +36,11 @@ Everything from interactive system scripts, to installation wizards, to full-blown shells can be implemented with the support of @wizards@. . - It is developed transparently on top of a Prompt monad, which separates out the semantics of the program from any - particular interface. A variety of backends exist, including "System.Console.Wizard.Haskeline" and - "System.Console.Wizard.BasicIO". It is also possible to write your own backends. While both built-in backends - operate on a console, there is no reason why @wizards@ cannot also be used for making GUI wizard interfaces. + It is developed transparently on top of a free monad, which separates out the semantics of the program from any + particular interface. A variety of backends exist, including console-based "System.Console.Wizard.Haskeline" and + "System.Console.Wizard.BasicIO", and the pure "System.Console.Wizard.Pure". It is also possible to write your + own backends, or extend existing back-ends with new features. While both built-in IO backends operate on a + console, there is no reason why @wizards@ cannot also be used for making GUI wizard interfaces. . . See the github page for examples on usage: @@ -69,7 +70,7 @@ source-repository this type: git location: git://github.com/liamoc/wizards.git - tag: 0.1 + tag: 1.0 Library @@ -78,10 +79,11 @@ System.Console.Wizard.Internal System.Console.Wizard.Haskeline System.Console.Wizard.BasicIO - + System.Console.Wizard.Pure + Extensions: OverlappingInstances -- Packages needed in order to build this package. - Build-depends: base == 4.*, haskeline == 0.6.*, mtl == 2.0.*, transformers == 0.2.*, MonadPrompt == 1.0.* + Build-depends: base == 4.*, haskeline == 0.6.*, mtl == 2.0.*, transformers == 0.2.*, control-monad-free ==0.5.*, containers == 0.4.* -- Modules not exported by this package. -- Other-modules: