{-# 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 = forall (backend :: * -> *) a.
MaybeT (Free backend) a -> Wizard backend a
Wizard forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (g :: * -> *) (f :: * -> *) a.
(g :<: f) =>
g (Free f a) -> Free f a
inject (forall w. String -> w -> Output w
Output String
s (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 = forall (backend :: * -> *) a.
MaybeT (Free backend) a -> Wizard backend a
Wizard forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (g :: * -> *) (f :: * -> *) a.
(g :<: f) =>
g (Free f a) -> Free f a
inject (forall w. String -> w -> OutputLn w
OutputLn String
s (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 = forall (backend :: * -> *) a.
MaybeT (Free backend) a -> Wizard backend a
Wizard forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (g :: * -> *) (f :: * -> *) a.
(g :<: f) =>
g (Free f a) -> Free f a
inject (forall w. String -> (String -> w) -> Line w
Line String
s 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 = forall (backend :: * -> *) a.
MaybeT (Free backend) a -> Wizard backend a
Wizard forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (g :: * -> *) (f :: * -> *) a.
(g :<: f) =>
g (Free f a) -> Free f a
inject (forall w. String -> (Char -> w) -> Character w
Character String
p 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 = forall (backend :: * -> *) a.
MaybeT (Free backend) a -> Wizard backend a
Wizard forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (g :: * -> *) (f :: * -> *) a.
(g :<: f) =>
g (Free f a) -> Free f a
inject (forall w a. IO a -> (a -> w) -> ArbitraryIO w
ArbitraryIO IO a
v 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 = forall (backend :: * -> *) a.
MaybeT (Free backend) a -> Wizard backend a
Wizard forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (g :: * -> *) (f :: * -> *) a.
(g :<: f) =>
g (Free f a) -> Free f a
inject (forall w.
String -> String -> String -> (String -> w) -> LinePrewritten w
LinePrewritten String
p String
s1 String
s2 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 = forall (backend :: * -> *) a.
MaybeT (Free backend) a -> Wizard backend a
Wizard forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (g :: * -> *) (f :: * -> *) a.
(g :<: f) =>
g (Free f a) -> Free f a
inject (forall w. String -> Maybe Char -> (String -> w) -> Password w
Password String
p Maybe Char
mc 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 forall (f :: * -> *) a. Alternative f => f a -> f a -> f 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 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (forall (b :: * -> *). (OutputLn :<: b) => String -> Wizard b ()
outputLn String
msg forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 forall (f :: * -> *) a. Alternative f => f a -> f a -> f 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (b :: * -> *) a. Functor b => Maybe a -> Wizard b a
liftMaybe 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 = forall (b :: * -> *) a c.
Functor b =>
(a -> Maybe c) -> Wizard b a -> Wizard b c
parser forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (b :: * -> *) a.
Functor b =>
(a -> Bool) -> Wizard b a -> Wizard b a
validator (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) = forall (b :: * -> *) a.
Functor b =>
(a -> Bool) -> Wizard b a -> Wizard b a
validator (\a
x -> a
b forall a. Ord a => a -> a -> Bool
<= a
x Bool -> Bool -> Bool
&& a
x 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 = forall (b :: * -> *) a c.
Functor b =>
(a -> Maybe c) -> Wizard b a -> Wizard b c
parser (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) = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v
liftMaybe (Maybe a
Nothing) = 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       = forall a. a -> Maybe a
Just a
v
           | Bool
otherwise = 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => ReadS a
reads