{-# 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 (Int -> UnexpectedEOI -> ShowS
[UnexpectedEOI] -> ShowS
UnexpectedEOI -> String
(Int -> UnexpectedEOI -> ShowS)
-> (UnexpectedEOI -> String)
-> ([UnexpectedEOI] -> ShowS)
-> Show UnexpectedEOI
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnexpectedEOI] -> ShowS
$cshowList :: [UnexpectedEOI] -> ShowS
show :: UnexpectedEOI -> String
$cshow :: UnexpectedEOI -> String
showsPrec :: Int -> UnexpectedEOI -> ShowS
$cshowsPrec :: Int -> UnexpectedEOI -> ShowS
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 :: Wizard Pure a -> String -> (Maybe a, String)
runPure Wizard Pure a
wz String
input = let (Maybe a
a,([String]
_,Seq Char
o)) = State ([String], Seq Char) (Maybe a)
-> ([String], Seq Char) -> (Maybe a, ([String], Seq Char))
forall s a. State s a -> s -> (a, s)
runState (Wizard Pure a -> State ([String], Seq Char) (Maybe a)
forall (f :: * -> *) (b :: * -> *) a.
(Functor f, Monad b, Run b f) =>
Wizard f a -> b (Maybe a)
run Wizard Pure a
wz) (String -> [String]
lines String
input, Seq Char
forall a. Seq a
empty) 
                       in (Maybe a
a, Seq Char -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Char
o)

getPureLine :: State PureState String
getPureLine :: State ([String], Seq Char) String
getPureLine = do State ([String], Seq Char) ()
crashIfNull
                 String
x <- [String] -> String
forall a. [a] -> a
head ([String] -> String)
-> (([String], Seq Char) -> [String])
-> ([String], Seq Char)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String], Seq Char) -> [String]
forall a b. (a, b) -> a
fst (([String], Seq Char) -> String)
-> StateT ([String], Seq Char) Identity ([String], Seq Char)
-> State ([String], Seq Char) String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT ([String], Seq Char) Identity ([String], Seq Char)
forall s (m :: * -> *). MonadState s m => m s
get
                 (([String], Seq Char) -> ([String], Seq Char))
-> State ([String], Seq Char) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (([String] -> [String])
-> ([String], Seq Char) -> ([String], Seq Char)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first [String] -> [String]
forall a. [a] -> [a]
tail)
                 String -> State ([String], Seq Char) String
forall (m :: * -> *) a. Monad m => a -> m a
return String
x

crashIfNull :: State PureState ()
crashIfNull :: State ([String], Seq Char) ()
crashIfNull = do ([String]
x, Seq Char
y ) <- StateT ([String], Seq Char) Identity ([String], Seq Char)
forall s (m :: * -> *). MonadState s m => m s
get
                 Bool
-> State ([String], Seq Char) () -> State ([String], Seq Char) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
x) (State ([String], Seq Char) () -> State ([String], Seq Char) ())
-> State ([String], Seq Char) () -> State ([String], Seq Char) ()
forall a b. (a -> b) -> a -> b
$ UnexpectedEOI -> State ([String], Seq Char) ()
forall a e. Exception e => e -> a
throw UnexpectedEOI
UnexpectedEOI

getPureChar :: State PureState Char
getPureChar :: State ([String], Seq Char) Char
getPureChar = do State ([String], Seq Char) ()
crashIfNull
                 Bool
x <- String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool)
-> (([String], Seq Char) -> String) -> ([String], Seq Char) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall a. [a] -> a
head ([String] -> String)
-> (([String], Seq Char) -> [String])
-> ([String], Seq Char)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String], Seq Char) -> [String]
forall a b. (a, b) -> a
fst (([String], Seq Char) -> Bool)
-> StateT ([String], Seq Char) Identity ([String], Seq Char)
-> StateT ([String], Seq Char) Identity Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT ([String], Seq Char) Identity ([String], Seq Char)
forall s (m :: * -> *). MonadState s m => m s
get
                 if Bool
x then do 
                    (([String], Seq Char) -> ([String], Seq Char))
-> State ([String], Seq Char) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (([String] -> [String])
-> ([String], Seq Char) -> ([String], Seq Char)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first [String] -> [String]
forall a. [a] -> [a]
tail)
                    Char -> State ([String], Seq Char) Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\n'
                 else do
                    Char
r <- String -> Char
forall a. [a] -> a
head (String -> Char)
-> (([String], Seq Char) -> String) -> ([String], Seq Char) -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall a. [a] -> a
head ([String] -> String)
-> (([String], Seq Char) -> [String])
-> ([String], Seq Char)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String], Seq Char) -> [String]
forall a b. (a, b) -> a
fst (([String], Seq Char) -> Char)
-> StateT ([String], Seq Char) Identity ([String], Seq Char)
-> State ([String], Seq Char) Char
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT ([String], Seq Char) Identity ([String], Seq Char)
forall s (m :: * -> *). MonadState s m => m s
get
                    (([String], Seq Char) -> ([String], Seq Char))
-> State ([String], Seq Char) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (([String] -> [String])
-> ([String], Seq Char) -> ([String], Seq Char)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (\ (String
x : [String]
r) -> ShowS
forall a. [a] -> [a]
tail String
x String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
r))
                    Char -> State ([String], Seq Char) Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
r
                    
outputPure :: String -> State PureState ()                    
outputPure :: String -> State ([String], Seq Char) ()
outputPure String
s = (([String], Seq Char) -> ([String], Seq Char))
-> State ([String], Seq Char) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Seq Char -> Seq Char)
-> ([String], Seq Char) -> ([String], Seq Char)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Seq Char -> Seq Char -> Seq Char
forall a. Seq a -> Seq a -> Seq a
>< String -> Seq Char
forall a. [a] -> Seq a
fromList String
s))
            State ([String], Seq Char) ()
-> State ([String], Seq Char) () -> State ([String], Seq Char) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (([String], Seq Char) -> ([String], Seq Char))
-> State ([String], Seq Char) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\([String], Seq Char)
s -> ([String], Seq Char)
s ([String], Seq Char)
-> ([String], Seq Char) -> ([String], Seq Char)
`seq` ([String], Seq Char)
s)

outputLnPure :: String -> State PureState ()                    
outputLnPure :: String -> State ([String], Seq Char) ()
outputLnPure String
s = (([String], Seq Char) -> ([String], Seq Char))
-> State ([String], Seq Char) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Seq Char -> Seq Char)
-> ([String], Seq Char) -> ([String], Seq Char)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((Seq Char -> Seq Char)
 -> ([String], Seq Char) -> ([String], Seq Char))
-> (Seq Char -> Seq Char)
-> ([String], Seq Char)
-> ([String], Seq Char)
forall a b. (a -> b) -> a -> b
$ (Seq Char -> Char -> Seq Char
forall a. Seq a -> a -> Seq a
|> Char
'\n') (Seq Char -> Seq Char)
-> (Seq Char -> Seq Char) -> Seq Char -> Seq Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Seq Char -> Seq Char -> Seq Char
forall a. Seq a -> Seq a -> Seq a
>< String -> Seq Char
forall a. [a] -> Seq a
fromList String
s))
              State ([String], Seq Char) ()
-> State ([String], Seq Char) () -> State ([String], Seq Char) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (([String], Seq Char) -> ([String], Seq Char))
-> State ([String], Seq Char) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\([String], Seq Char)
s -> ([String], Seq Char)
s ([String], Seq Char)
-> ([String], Seq Char) -> ([String], Seq Char)
`seq` ([String], Seq Char)
s)


instance Run (State PureState) Output    where runAlgebra :: Output (State ([String], Seq Char) v)
-> State ([String], Seq Char) v
runAlgebra (Output String
s State ([String], Seq Char) v
w)        = String -> State ([String], Seq Char) ()
outputPure String
s   State ([String], Seq Char) ()
-> State ([String], Seq Char) v -> State ([String], Seq Char) v
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> State ([String], Seq Char) v
w
instance Run (State PureState) OutputLn  where runAlgebra :: OutputLn (State ([String], Seq Char) v)
-> State ([String], Seq Char) v
runAlgebra (OutputLn String
s State ([String], Seq Char) v
w)      = String -> State ([String], Seq Char) ()
outputLnPure String
s State ([String], Seq Char) ()
-> State ([String], Seq Char) v -> State ([String], Seq Char) v
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> State ([String], Seq Char) v
w
instance Run (State PureState) Line      where runAlgebra :: Line (State ([String], Seq Char) v) -> State ([String], Seq Char) v
runAlgebra (Line String
s String -> State ([String], Seq Char) v
w)          = State ([String], Seq Char) String
getPureLine    State ([String], Seq Char) String
-> (String -> State ([String], Seq Char) v)
-> State ([String], Seq Char) v
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> State ([String], Seq Char) v
w
instance Run (State PureState) Character where runAlgebra :: Character (State ([String], Seq Char) v)
-> State ([String], Seq Char) v
runAlgebra (Character String
s Char -> State ([String], Seq Char) v
w)     = State ([String], Seq Char) Char
getPureChar    State ([String], Seq Char) Char
-> (Char -> State ([String], Seq Char) v)
-> State ([String], Seq Char) v
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Char -> State ([String], Seq Char) v
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
                        , a -> Pure b -> Pure a
(a -> b) -> Pure a -> Pure b
(forall a b. (a -> b) -> Pure a -> Pure b)
-> (forall a b. a -> Pure b -> Pure a) -> Functor Pure
forall a b. a -> Pure b -> Pure a
forall a b. (a -> b) -> Pure a -> Pure b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Pure b -> Pure a
$c<$ :: forall a b. a -> Pure b -> Pure a
fmap :: (a -> b) -> Pure a -> Pure b
$cfmap :: forall a b. (a -> b) -> Pure a -> Pure b
Functor
                        , Run (State PureState)
                        )