{-# LANGUAGE DeriveFunctor , FlexibleInstances , FunctionalDependencies , GeneralizedNewtypeDeriving , NamedFieldPuns , OverloadedStrings , RankNTypes , ScopedTypeVariables , StandaloneDeriving , TypeFamilies , LiberalTypeSynonyms , TypeSynonymInstances , UndecidableInstances , DataKinds , KindSignatures #-} -- | The core module for @ditto@. -- -- This module provides the @Form@ type and helper functions -- for constructing typesafe forms inside arbitrary "views" / web frameworks. -- @ditto@ is meant to be a generalized formlet library used to write -- formlet libraries specific to a web / gui framework module Ditto.Core ( -- * Form types -- | The representation of formlets FormState , Form(..) -- * Environment -- | The interface to a given web framework , Environment(..) , NoEnvironment(..) , WithEnvironment(..) , noEnvironment -- * Utility functions , (@$) , catchFormError , catchFormErrorM , eitherForm , getFormId , getFormInput , getFormInput' , getFormRange , getNamedFormId , incrementFormId , isInRange , mapFormMonad , mapResult , mapView , mkOk , retainChildErrors , retainErrors , runForm , runForm_ , successDecode , unitRange , view , viewForm , pureRes , liftForm ) where import Control.Applicative import Control.Monad.Reader import Control.Monad.State.Lazy import Data.Bifunctor import Data.Text (Text) import Ditto.Types import Ditto.Backend import Torsor ------------------------------------------------------------------------------ -- Form types ------------------------------------------------------------------------------ -- | The Form's state is just the range of identifiers so far type FormState m = StateT FormRange m -- | @ditto@'s representation of a formlet data Form m input err view a = Form { formDecodeInput :: input -> m (Either err a) -- ^ Decode the value from the input , formInitialValue :: m a -- ^ The initial value , formFormlet :: FormState m (View err view, Result err (Proved a)) -- ^ A @FormState@ which produced a @View@ and a @Result@ } deriving (Functor) instance (Monad m, Monoid view) => Applicative (Form m input err view) where pure x = Form (successDecode x) (pure x) $ do i <- getFormId pure ( mempty , Ok $ Proved { pos = FormRange i i , unProved = x } ) (Form df ivF frmF) <*> (Form da ivA frmA) = Form ( \inp -> do f <- df inp x <- da inp pure (f <*> x) ) (ivF <*> ivA) ( do ((view1, fok), (view2, aok)) <- bracketState $ do res1 <- frmF incrementFormRange res2 <- frmA pure (res1, res2) case (fok, aok) of (Error errs1, Error errs2) -> pure (view1 <> view2, Error $ errs1 ++ errs2) (Error errs1, _) -> pure (view1 <> view2, Error errs1) (_, Error errs2) -> pure (view1 <> view2, Error errs2) (Ok (Proved (FormRange x _) f), Ok (Proved (FormRange _ y) a)) -> pure ( view1 <> view2 , Ok $ Proved { pos = FormRange x y , unProved = f a } ) ) f1 *> f2 = Form (formDecodeInput f2) (formInitialValue f2) $ do -- Evaluate the form that matters first, so we have a correct range set (v2, r) <- formFormlet f2 (v1, _) <- formFormlet f1 pure (v1 <> v2, r) f1 <* f2 = Form (formDecodeInput f1) (formInitialValue f1) $ do -- Evaluate the form that matters first, so we have a correct range set (v1, r) <- formFormlet f1 (v2, _) <- formFormlet f2 pure (v1 <> v2, r) instance (Environment m input, Monoid view, FormError input err) => Monad (Form m input err view) where form >>= f = let mres = fmap snd $ runForm "" form in Form (\input -> do res <- mres case res of Error {} -> do iv <- formInitialValue form formDecodeInput (f iv) input Ok (Proved _ x) -> formDecodeInput (f x) input ) (do res <- mres case res of Error {} -> do iv <- formInitialValue form formInitialValue $ f iv Ok (Proved _ x) -> formInitialValue (f x) ) (do (View viewF0, res0) <- formFormlet form case res0 of Error errs0 -> do iv <- lift $ formInitialValue form (View viewF, res) <- formFormlet $ f iv let errs = case res of Error es -> es Ok {} -> [] pure (View $ const $ viewF0 errs0 <> viewF errs, Error (errs0 <> errs)) Ok (Proved _ x) -> fmap (first (\(View v) -> View $ \e -> viewF0 [] <> v e)) $ formFormlet (f x) ) return = pure (>>) = (*>) -- way more efficient than the default instance (Monad m, Monoid view, Semigroup a) => Semigroup (Form m input err view a) where (<>) = liftA2 (<>) instance (Monad m, Monoid view, Monoid a) => Monoid (Form m input err view a) where mempty = pure mempty instance Functor m => Bifunctor (Form m input err) where first = mapView second = fmap errorInitialValue :: String errorInitialValue = "ditto: Ditto.Core.errorInitialValue was evaluated" instance (Monad m, Monoid view, FormError input err, Environment m input) => Alternative (Form m input err view) where empty = Form failDecodeMDF (error errorInitialValue) (pure (mempty, Error [])) formA <|> formB = do efA <- formEither formA case efA of Right{} -> formA Left{} -> formB ------------------------------------------------------------------------------ -- Environment ------------------------------------------------------------------------------ -- | The environment typeclass: the interface between ditto and a given framework class Monad m => Environment m input | m -> input where environment :: FormId -> m (Value input) -- | Run the form, but always return the initial value newtype NoEnvironment input m a = NoEnvironment { getNoEnvironment :: m a } deriving (Monad, Functor, Applicative) instance Monad m => Environment (NoEnvironment input m) input where environment = noEnvironment -- | @environment@ which will always return the initial value noEnvironment :: Applicative m => FormId -> m (Value input) noEnvironment = const (pure Default) -- | Run the form, but with a given @environment@ function newtype WithEnvironment input m a = WithEnvironment { getWithEnvironment :: ReaderT (FormId -> m (Value input)) m a } deriving (Monad, Functor, Applicative) deriving instance Monad m => MonadReader (FormId -> m (Value input)) (WithEnvironment input m) instance MonadTrans (WithEnvironment input) where lift = WithEnvironment . lift instance Monad m => Environment (WithEnvironment input m) input where environment fid = do f <- ask lift $ f fid ------------------------------------------------------------------------------ -- Utility functions ------------------------------------------------------------------------------ failDecodeMDF :: forall m input err a. (Applicative m, FormError input err) => input -> m (Either err a) failDecodeMDF = const $ pure $ Left err where mdf :: CommonFormError input mdf = MissingDefaultValue err :: err err = commonFormError mdf -- | Always succeed decoding successDecode :: Applicative m => a -> (input -> m (Either err a)) successDecode = const . pure . Right -- | Common operations on @Form@s -- | Change the view of a form using a simple function -- -- This is useful for wrapping a form inside of a \