1 {-# LANGUAGE OverloadedStrings, TypeFamilies #-}
    2 module Databrary.HTTP.Form.View
    3   ( FormViewT
    4   , runFormView
    5   , blankFormView
    6   , (.:>)
    7   , withSubFormsViews
    8   , formViewErrors
    9   , allFormViewErrors
   10   ) where
   11 
   12 import Control.Arrow (first, second)
   13 import Control.Monad (ap, join, liftM)
   14 import Control.Monad.Reader (MonadReader(..))
   15 import Control.Monad.State (MonadState(..))
   16 import Control.Monad.Trans.Class (MonadTrans(..))
   17 import Control.Monad.Trans.Control (MonadTransControl(..))
   18 import qualified Data.Text as T
   19 
   20 import Databrary.HTTP.Form
   21 import Databrary.HTTP.Form.Errors
   22 
   23 newtype FormViewT f m a = FormViewT { runFormViewT :: Form f -> FormErrors -> m (a, FormErrors) }
   24 
   25 lpt :: e -> a -> (a, e)
   26 lpt e a = (a, e)
   27 
   28 instance MonadTrans (FormViewT f) where
   29   lift m = FormViewT $ \_ e ->
   30     liftM (lpt e) m
   31 
   32 instance MonadTransControl (FormViewT f) where
   33   type StT (FormViewT f) a = (a, FormErrors)
   34   liftWith f = FormViewT $ \d e ->
   35     liftM (lpt e) $ f $ \t -> runFormViewT t d e
   36   restoreT m = FormViewT $ \_ _ -> m
   37 
   38 instance Functor m => Functor (FormViewT f m) where
   39   fmap f (FormViewT v) = FormViewT $ \d ->
   40     fmap (first f) . v d
   41 
   42 instance (Applicative m, Monad m) => Applicative (FormViewT f m) where
   43   pure a = FormViewT $ \_ e -> pure (a, e)
   44   (<*>) = ap
   45 
   46 instance Monad m => Monad (FormViewT f m) where
   47   return a = FormViewT $ \_ e -> return (a, e)
   48   FormViewT x >>= f = FormViewT $ \d e -> do
   49     (rx, ex) <- x d e
   50     runFormViewT (f rx) d ex
   51   fail e = FormViewT $ \_ _ -> fail e
   52 
   53 instance Monad m => MonadReader (Form f) (FormViewT f m) where
   54   ask = FormViewT $ \d -> return . (,) d
   55   reader f = FormViewT $ \d -> return . (,) (f d)
   56   local f (FormViewT a) = FormViewT $ a . f
   57 
   58 instance Monad m => MonadState FormErrors (FormViewT f m) where
   59   get = FormViewT $ \_ -> return . join (,)
   60   put e = FormViewT $ \_ _ -> return ((), e)
   61   state f = FormViewT $ \_ -> return . f
   62 
   63 runFormView :: Monad m => FormViewT f m a -> FormData f -> FormErrors -> m a
   64 runFormView (FormViewT f) d = fmap fst . f (initForm d)
   65 
   66 blankFormView :: Monad m => FormViewT f m a -> m a
   67 blankFormView f = runFormView f mempty mempty
   68 
   69 withSubFormView :: Monad m => FormKey -> FormViewT f m a -> FormViewT f m a
   70 withSubFormView k (FormViewT a) = FormViewT $ \d e ->
   71   second (setSubFormErrors e k) <$> a (subForm k d) (subFormErrors k e)
   72 
   73 withSubFormsViews :: Monad m => [a] -> (Maybe a -> FormViewT f m ()) -> FormViewT f m ()
   74 withSubFormsViews l f = msfv 0 l =<< reader subForms where
   75   msfv _ [] [] = return ()
   76   msfv i xl sl = withSubFormView (FormIndex i) (f x) >> msfv (succ i) xr sr where
   77     (x, xr) = uncons xl
   78     (_, sr) = uncons sl
   79   uncons (x:r) = (Just x, r)
   80   uncons r = (Nothing, r)
   81 
   82 infixr 2 .:>
   83 (.:>) :: Monad m => T.Text -> FormViewT f m a -> FormViewT f m a
   84 (.:>) = withSubFormView . FormField
   85 
   86 formViewErrors :: Monad m => FormViewT f m [FormErrorMessage]
   87 formViewErrors = state $ \e -> (formErrors e, e{ formErrors = [] })
   88 
   89 allFormViewErrors :: Monad m => FormViewT f m [(FormPath, FormErrorMessage)]
   90 allFormViewErrors = state $ \e -> (allFormErrors e, mempty)