Wizard.hs

{-# 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 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.
---  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 = Wizard $ lift $ inject (LinePrewritten p s1 s2 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 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.
-- 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 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 :: 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 :: Functor b => (a -> Maybe c) -> Wizard b a -> Wizard b c
parser f a = a >>= liftMaybe . 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 = parser . 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 = validator (not . 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 (b,t) = validator (\x -> b <= x && x <= t)

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

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

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

-- | A read-based parser for the 'parser' modifier.
readP :: Read a => String -> Maybe a
readP = fmap fst . listToMaybe . reads