{-# 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
    , Output 
    , output
    , OutputLn
    , outputLn
    , ArbitraryIO
      -- * Modifiers
      -- $modifiers
    , retry
    , retryMsg
    , defaultTo
    , parser
    , validator
      -- * Convenience
    , nonEmpty
    , inRange
    , parseRead    
      -- * Utility
    , liftMaybe
    , ensure
    , readP
    ) 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 Data.Maybe
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.

-- | Output a string. Does not fail.
output :: (Output :<: b) => String -> Wizard b ()
output :: forall (b :: * -> *). (Output :<: b) => String -> Wizard b ()
output String
s = MaybeT (Free b) () -> Wizard b ()
forall (backend :: * -> *) a.
MaybeT (Free backend) a -> Wizard backend a
Wizard (MaybeT (Free b) () -> Wizard b ())
-> MaybeT (Free b) () -> Wizard b ()
forall a b. (a -> b) -> a -> b
$ Free b () -> MaybeT (Free b) ()
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Free b () -> MaybeT (Free b) ())
-> Free b () -> MaybeT (Free b) ()
forall a b. (a -> b) -> a -> b
$ Output (Free b ()) -> Free b ()
forall (g :: * -> *) (f :: * -> *) a.
(g :<: f) =>
g (Free f a) -> Free f a
inject (String -> Free b () -> Output (Free b ())
forall w. String -> w -> Output w
Output String
s (() -> Free b ()
forall (f :: * -> *) a. a -> Free f a
Pure ()))

-- | Output a string followed by a newline. Does not fail.
outputLn :: (OutputLn :<: b) => String -> Wizard b ()
outputLn :: forall (b :: * -> *). (OutputLn :<: b) => String -> Wizard b ()
outputLn String
s = MaybeT (Free b) () -> Wizard b ()
forall (backend :: * -> *) a.
MaybeT (Free backend) a -> Wizard backend a
Wizard (MaybeT (Free b) () -> Wizard b ())
-> MaybeT (Free b) () -> Wizard b ()
forall a b. (a -> b) -> a -> b
$ Free b () -> MaybeT (Free b) ()
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Free b () -> MaybeT (Free b) ())
-> Free b () -> MaybeT (Free b) ()
forall a b. (a -> b) -> a -> b
$ OutputLn (Free b ()) -> Free b ()
forall (g :: * -> *) (f :: * -> *) a.
(g :<: f) =>
g (Free f a) -> Free f a
inject (String -> Free b () -> OutputLn (Free b ())
forall w. String -> w -> OutputLn w
OutputLn String
s (() -> Free b ()
forall (f :: * -> *) a. a -> Free f a
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 :: forall (b :: * -> *). (Line :<: b) => String -> Wizard b String
line String
s = MaybeT (Free b) String -> Wizard b String
forall (backend :: * -> *) a.
MaybeT (Free backend) a -> Wizard backend a
Wizard (MaybeT (Free b) String -> Wizard b String)
-> MaybeT (Free b) String -> Wizard b String
forall a b. (a -> b) -> a -> b
$ Free b String -> MaybeT (Free b) String
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Free b String -> MaybeT (Free b) String)
-> Free b String -> MaybeT (Free b) String
forall a b. (a -> b) -> a -> b
$ Line (Free b String) -> Free b String
forall (g :: * -> *) (f :: * -> *) a.
(g :<: f) =>
g (Free f a) -> Free f a
inject (String -> (String -> Free b String) -> Line (Free b String)
forall w. String -> (String -> w) -> Line w
Line String
s String -> Free b String
forall (f :: * -> *) a. a -> Free f a
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 :: forall (b :: * -> *). (Character :<: b) => String -> Wizard b Char
character String
p = MaybeT (Free b) Char -> Wizard b Char
forall (backend :: * -> *) a.
MaybeT (Free backend) a -> Wizard backend a
Wizard (MaybeT (Free b) Char -> Wizard b Char)
-> MaybeT (Free b) Char -> Wizard b Char
forall a b. (a -> b) -> a -> b
$ Free b Char -> MaybeT (Free b) Char
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Free b Char -> MaybeT (Free b) Char)
-> Free b Char -> MaybeT (Free b) Char
forall a b. (a -> b) -> a -> b
$ Character (Free b Char) -> Free b Char
forall (g :: * -> *) (f :: * -> *) a.
(g :<: f) =>
g (Free f a) -> Free f a
inject (String -> (Char -> Free b Char) -> Character (Free b Char)
forall w. String -> (Char -> w) -> Character w
Character String
p Char -> Free b Char
forall (f :: * -> *) a. a -> Free f a
Pure)


instance (ArbitraryIO :<: b) => MonadIO (Wizard b) where
    liftIO :: forall a. IO a -> Wizard b a
liftIO IO a
v = MaybeT (Free b) a -> Wizard b a
forall (backend :: * -> *) a.
MaybeT (Free backend) a -> Wizard backend a
Wizard (MaybeT (Free b) a -> Wizard b a)
-> MaybeT (Free b) a -> Wizard b a
forall a b. (a -> b) -> a -> b
$ Free b a -> MaybeT (Free b) a
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Free b a -> MaybeT (Free b) a) -> Free b a -> MaybeT (Free b) a
forall a b. (a -> b) -> a -> b
$ ArbitraryIO (Free b a) -> Free b a
forall (g :: * -> *) (f :: * -> *) a.
(g :<: f) =>
g (Free f a) -> Free f a
inject (IO a -> (a -> Free b a) -> ArbitraryIO (Free b a)
forall w a. IO a -> (a -> w) -> ArbitraryIO w
ArbitraryIO IO a
v a -> Free b a
forall (f :: * -> *) a. a -> Free f a
Pure)  
-- | Read one line of input, with some default text already present, before and/or after the editing cursor.
---  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 :: forall (b :: * -> *).
(LinePrewritten :<: b) =>
String -> String -> String -> Wizard b String
linePrewritten String
p String
s1 String
s2 = MaybeT (Free b) String -> Wizard b String
forall (backend :: * -> *) a.
MaybeT (Free backend) a -> Wizard backend a
Wizard (MaybeT (Free b) String -> Wizard b String)
-> MaybeT (Free b) String -> Wizard b String
forall a b. (a -> b) -> a -> b
$ Free b String -> MaybeT (Free b) String
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Free b String -> MaybeT (Free b) String)
-> Free b String -> MaybeT (Free b) String
forall a b. (a -> b) -> a -> b
$ LinePrewritten (Free b String) -> Free b String
forall (g :: * -> *) (f :: * -> *) a.
(g :<: f) =>
g (Free f a) -> Free f a
inject (String
-> String
-> String
-> (String -> Free b String)
-> LinePrewritten (Free b String)
forall w.
String -> String -> String -> (String -> w) -> LinePrewritten w
LinePrewritten String
p String
s1 String
s2 String -> Free b String
forall (f :: * -> *) a. a -> Free f a
Pure)

-- | Read one line of password input, with an optional mask character.
---  Cannot fail (but may throw exceptions, depending on the backend).
password :: (Password :<: b)
         => PromptString
         -> Maybe Char -- ^ Mask character, if any.
         -> Wizard b String
password :: forall (b :: * -> *).
(Password :<: b) =>
String -> Maybe Char -> Wizard b String
password String
p Maybe Char
mc = MaybeT (Free b) String -> Wizard b String
forall (backend :: * -> *) a.
MaybeT (Free backend) a -> Wizard backend a
Wizard (MaybeT (Free b) String -> Wizard b String)
-> MaybeT (Free b) String -> Wizard b String
forall a b. (a -> b) -> a -> b
$ Free b String -> MaybeT (Free b) String
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Free b String -> MaybeT (Free b) String)
-> Free b String -> MaybeT (Free b) String
forall a b. (a -> b) -> a -> b
$ Password (Free b String) -> Free b String
forall (g :: * -> *) (f :: * -> *) a.
(g :<: f) =>
g (Free f a) -> Free f a
inject (String
-> Maybe Char
-> (String -> Free b String)
-> Password (Free b String)
forall w. String -> Maybe Char -> (String -> w) -> Password w
Password String
p Maybe Char
mc String -> Free b String
forall (f :: * -> *) a. a -> Free f a
Pure)

-- $modifiers
-- /Modifiers/ change the behaviour of existing wizards.

-- | Retry produces a wizard that will retry the entire conversation again if it fails.
-- It is simply @retry x = x \<|\> retry x@.
retry :: Functor b => Wizard b a -> Wizard b a
retry :: forall (b :: * -> *) a. Functor b => Wizard b a -> Wizard b a
retry Wizard b a
x = Wizard b a
x Wizard b a -> Wizard b a -> Wizard b a
forall a. Wizard b a -> Wizard b a -> Wizard b a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Wizard b a -> Wizard b a
forall (b :: * -> *) a. Functor b => Wizard b a -> Wizard b a
retry Wizard b a
x

-- | Same as 'retry', except an error message can be specified.
retryMsg :: (OutputLn :<: b) => String -> Wizard b a -> Wizard b a
retryMsg :: forall (b :: * -> *) a.
(OutputLn :<: b) =>
String -> Wizard b a -> Wizard b a
retryMsg String
msg Wizard b a
x = Wizard b a
x Wizard b a -> Wizard b a -> Wizard b a
forall a. Wizard b a -> Wizard b a -> Wizard b a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (String -> Wizard b ()
forall (b :: * -> *). (OutputLn :<: b) => String -> Wizard b ()
outputLn String
msg Wizard b () -> Wizard b a -> Wizard b a
forall a b. Wizard b a -> Wizard b b -> Wizard b b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Wizard b a -> Wizard b a
forall (b :: * -> *) a.
(OutputLn :<: b) =>
String -> Wizard b a -> Wizard b a
retryMsg String
msg Wizard b a
x)
                    
-- | @x \`defaultTo\` y@ will return @y@ if @x@ fails, e.g @parseRead line \`defaultTo\` 0@.
defaultTo :: Functor b => Wizard b a -> a -> Wizard b a
defaultTo :: forall (b :: * -> *) a. Functor b => Wizard b a -> a -> Wizard b a
defaultTo Wizard b a
wz a
d = Wizard b a
wz Wizard b a -> Wizard b a -> Wizard b a
forall a. Wizard b a -> Wizard b a -> Wizard b a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> a -> Wizard b a
forall a. a -> Wizard b a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
d

-- | Like 'fmap', except the function may be partial ('Nothing' causes the wizard to fail).
parser :: Functor b => (a -> Maybe c) -> Wizard b a -> Wizard b c
parser :: forall (b :: * -> *) a c.
Functor b =>
(a -> Maybe c) -> Wizard b a -> Wizard b c
parser a -> Maybe c
f Wizard b a
a = Wizard b a
a Wizard b a -> (a -> Wizard b c) -> Wizard b c
forall a b. Wizard b a -> (a -> Wizard b b) -> Wizard b b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe c -> Wizard b c
forall (b :: * -> *) a. Functor b => Maybe a -> Wizard b a
liftMaybe (Maybe c -> Wizard b c) -> (a -> Maybe c) -> a -> Wizard b c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe c
f

-- | @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 :: forall (b :: * -> *) a.
Functor b =>
(a -> Bool) -> Wizard b a -> Wizard b a
validator = (a -> Maybe a) -> Wizard b a -> Wizard b a
forall (b :: * -> *) a c.
Functor b =>
(a -> Maybe c) -> Wizard b a -> Wizard b c
parser ((a -> Maybe a) -> Wizard b a -> Wizard b a)
-> ((a -> Bool) -> a -> Maybe a)
-> (a -> Bool)
-> Wizard b a
-> Wizard b a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Bool) -> a -> Maybe a
forall a. (a -> Bool) -> a -> Maybe a
ensure

-- | Simply @validator (not . null)@, makes a wizard fail if it gets an empty string.
nonEmpty :: Functor b => Wizard b [a] -> Wizard b [a]
nonEmpty :: forall (b :: * -> *) a. Functor b => Wizard b [a] -> Wizard b [a]
nonEmpty = ([a] -> Bool) -> Wizard b [a] -> Wizard b [a]
forall (b :: * -> *) a.
Functor b =>
(a -> Bool) -> Wizard b a -> Wizard b a
validator (Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null)

-- | Makes a wizard fail if it gets an ordered quantity outside of the given range.
inRange :: (Ord a, Functor b) => (a,a) -> Wizard b a -> Wizard b a
inRange :: forall a (b :: * -> *).
(Ord a, Functor b) =>
(a, a) -> Wizard b a -> Wizard b a
inRange (a
b,a
t) = (a -> Bool) -> Wizard b a -> Wizard b a
forall (b :: * -> *) a.
Functor b =>
(a -> Bool) -> Wizard b a -> Wizard b a
validator (\a
x -> a
b a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
x Bool -> Bool -> Bool
&& a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
t)

-- | Simply @parser readP@. Attaches a simple @read@ parser to a 'Wizard'.
parseRead :: (Read a, Functor b) => Wizard b String -> Wizard b a
parseRead :: forall a (b :: * -> *).
(Read a, Functor b) =>
Wizard b String -> Wizard b a
parseRead = (String -> Maybe a) -> Wizard b String -> Wizard b a
forall (b :: * -> *) a c.
Functor b =>
(a -> Maybe c) -> Wizard b a -> Wizard b c
parser (String -> Maybe a
forall a. Read a => String -> Maybe a
readP)

-- | Translate a maybe value into wizard success/failure.	
liftMaybe :: Functor b => Maybe a -> Wizard b a
liftMaybe :: forall (b :: * -> *) a. Functor b => Maybe a -> Wizard b a
liftMaybe (Just a
v) = a -> Wizard b a
forall a. a -> Wizard b a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v
liftMaybe (Maybe a
Nothing) = Wizard b a
forall a. Wizard b a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

-- | Ensures that a maybe value satisfies a given predicate.
ensure :: (a -> Bool) -> a -> Maybe a
ensure :: forall a. (a -> Bool) -> a -> Maybe a
ensure a -> Bool
p a
v | a -> Bool
p a
v       = a -> Maybe a
forall a. a -> Maybe a
Just a
v
           | Bool
otherwise = Maybe a
forall a. Maybe a
Nothing

-- | A read-based parser for the 'parser' modifier.
readP :: Read a => String -> Maybe a
readP :: forall a. Read a => String -> Maybe a
readP = ((a, String) -> a) -> Maybe (a, String) -> Maybe a
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, String) -> a
forall a b. (a, b) -> a
fst (Maybe (a, String) -> Maybe a)
-> (String -> Maybe (a, String)) -> String -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(a, String)] -> Maybe (a, String)
forall a. [a] -> Maybe a
listToMaybe ([(a, String)] -> Maybe (a, String))
-> (String -> [(a, String)]) -> String -> Maybe (a, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [(a, String)]
forall a. Read a => ReadS a
reads