module Text.Digestive.Types
( View (..)
, Environment (..)
, fromList
, FormState
, getFormId
, getFormRange
, getFormInput
, isFormInput
, Form (..)
, view
, (++>)
, (<++)
, mapView
, runForm
, eitherForm
, viewForm
) where
import Data.Monoid (Monoid (..))
import Control.Arrow (first)
import Control.Monad (liftM2, mplus)
import Control.Monad.Reader (ReaderT, ask, runReaderT)
import Control.Monad.State (StateT, get, put, evalStateT)
import Control.Monad.Trans (lift)
import Control.Applicative (Applicative (..))
import Text.Digestive.Result
newtype View e v = View
{ unView :: [(FormRange, e)] -> v
} deriving (Monoid)
instance Functor (View e) where
fmap f (View g) = View $ f . g
data Environment m i = Environment (FormId -> m (Maybe i))
| NoEnvironment
instance Monad m => Monoid (Environment m i) where
mempty = NoEnvironment
NoEnvironment `mappend` x = x
x `mappend` NoEnvironment = x
(Environment env1) `mappend` (Environment env2) = Environment $ \id' ->
liftM2 mplus (env1 id') (env2 id')
fromList :: Monad m => [(FormId, i)] -> Environment m i
fromList list = Environment $ return . flip lookup list
type FormState m i a = ReaderT (Environment m i) (StateT FormRange m) a
getFormId :: Monad m => FormState m i FormId
getFormId = do
FormRange x _ <- get
return x
getFormRange :: Monad m => FormState m i FormRange
getFormRange = get
getFormInput :: Monad m => FormState m i (Maybe i)
getFormInput = do
id' <- getFormId
env <- ask
case env of Environment f -> lift $ lift $ f id'
NoEnvironment -> return Nothing
isFormInput :: Monad m => FormState m i Bool
isFormInput = ask >>= \env -> return $ case env of
Environment _ -> True
NoEnvironment -> False
newtype Form m i e v a = Form {unForm :: FormState m i (View e v, Result e a)}
instance Monad m => Functor (Form m i e v) where
fmap f form = Form $ do
(view', result) <- unForm form
return (view', fmap f result)
instance (Monad m, Monoid v) => Applicative (Form m i e v) where
pure x = Form $ return (mempty, return x)
f1 <*> f2 = Form $ do
FormRange startF1 _ <- get
(v1, r1) <- unForm f1
FormRange _ endF1 <- get
put $ FormRange endF1 $ incrementFormId endF1
(v2, r2) <- unForm f2
FormRange _ endF2 <- get
put $ FormRange startF1 endF2
return (v1 `mappend` v2, r1 <*> r2)
view :: Monad m
=> v
-> Form m i e v ()
view view' = Form $ return (View (const view'), Ok ())
(++>) :: (Monad m, Monoid v)
=> Form m i e v ()
-> Form m i e v a
-> Form m i e v a
f1 ++> f2 = Form $ do
(v2, r) <- unForm f2
(v1, _) <- unForm f1
return (v1 `mappend` v2, r)
infixl 6 ++>
(<++) :: (Monad m, Monoid v)
=> Form m i e v a
-> Form m i e v ()
-> Form m i e v a
f1 <++ f2 = Form $ do
(v1, r) <- unForm f1
(v2, _) <- unForm f2
return (v1 `mappend` v2, r)
infixr 5 <++
mapView :: (Monad m, Functor m)
=> (v -> w)
-> Form m i e v a
-> Form m i e w a
mapView f = Form . fmap (first $ fmap f) . unForm
runForm :: Monad m
=> Form m i e v a
-> String
-> Environment m i
-> m (View e v, Result e a)
runForm form id' env = evalStateT (runReaderT (unForm form) env) $
FormRange f0 $ incrementFormId f0
where
f0 = FormId id' 0
eitherForm :: Monad m
=> Form m i e v a
-> String
-> Environment m i
-> m (Either v a)
eitherForm form id' env = do
(view', result) <- runForm form id' env
return $ case result of Error e -> Left $ unView view' e
Ok x -> Right x
viewForm :: Monad m
=> Form m i e v a
-> String
-> m v
viewForm form id' = do
(view', _) <- runForm form id' NoEnvironment
return $ unView view' []