1 {-# LANGUAGE TypeFamilies #-} 2 module 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 HTTP.Form 21 import 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) 91 -}