{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- This module provides helper functions for HTML input elements. These helper functions are not specific to any particular web framework or html library.
module Ditto.Generalized.Internal where
import Control.Applicative ((<$>))
import Control.Monad (foldM)
import Control.Monad.Trans (lift)
import Data.Bifunctor
import Numeric (readDec)
import Ditto.Backend
import Ditto.Core
import Ditto.Result
import qualified Data.IntSet as IS
-- | used for constructing elements like @\@, which pure a single input value.
input
:: (Monad m, FormError err input)
=> FormState m input FormId
-> (input -> Either err a)
-> (FormId -> a -> view)
-> a
-> Form m input err view a
input i' fromInput toView initialValue =
Form $ do
i <- i'
v <- getFormInput' i
case v of
Default ->
pure
( View $ const $ toView i initialValue
, pure $
Ok
( Proved
{ pos = unitRange i
, unProved = initialValue
}
)
)
Found x -> case fromInput x of
Right a -> pure
( View $ const $ toView i a
, pure $
Ok
( Proved
{ pos = unitRange i
, unProved = a
}
)
)
Left err -> pure
( View $ const $ toView i initialValue
, pure $ Error [(unitRange i, err)]
)
Missing -> pure
( View $ const $ toView i initialValue
, pure $ Error [(unitRange i, commonFormError (InputMissing i))]
)
inputMaybeReq
:: (Monad m, FormError err input)
=> FormState m input FormId
-> (input -> Either err a)
-> (FormId -> Maybe a -> view)
-> Maybe a
-> Form m input err view a
inputMaybeReq i' fromInput toView initialValue =
Form $ do
i <- i'
v <- getFormInput' i
case v of
Default ->
pure
( View $ const $ toView i initialValue
, case initialValue of
Just x -> pure $
Ok ( Proved
{ pos = unitRange i
, unProved = x
}
)
Nothing -> pure $ Error [(unitRange i, commonFormError MissingDefaultValue)]
)
Found x -> case fromInput x of
Right a -> pure
( View $ const $ toView i (Just a)
, pure $
Ok
( Proved
{ pos = unitRange i
, unProved = a
}
)
)
Left err -> pure
( View $ const $ toView i initialValue
, pure $ Error [(unitRange i, err)]
)
Missing -> pure
( View $ const $ toView i initialValue
, pure $ Error [(unitRange i, commonFormError (InputMissing i))]
)
-- | used for elements like @\@ which are not always present in the form submission data.
inputMaybe
:: (Monad m, FormError err input)
=> FormState m input FormId
-> (input -> Either err a)
-> (FormId -> Maybe a -> view)
-> Maybe a
-> Form m input err view (Maybe a)
inputMaybe i' fromInput toView initialValue =
Form $ do
i <- i'
v <- getFormInput' i
case v of
Default -> pure
( View $ const $ toView i initialValue
, pure $
Ok
( Proved
{ pos = unitRange i
, unProved = initialValue
}
)
)
Found x -> case fromInput x of
Right a -> pure
( View $ const $ toView i (Just a)
, pure $
Ok
( Proved
{ pos = unitRange i
, unProved = (Just a)
}
)
)
Left err -> pure
( View $ const $ toView i initialValue
, pure $ Error [(unitRange i, err)]
)
Missing -> pure
( View $ const $ toView i initialValue
, pure $
Ok
( Proved
{ pos = unitRange i
, unProved = Nothing
}
)
)
-- | used for elements like @\@ which take a value, but are never present in the form data set.
inputNoData
:: (Monad m)
=> FormState m input FormId
-> (FormId -> view)
-> Form m input err view ()
inputNoData i' toView =
Form $ do
i <- i'
pure
( View $ const $ toView i
, pure $
Ok
( Proved
{ pos = unitRange i
, unProved = ()
}
)
)
-- | used for @\@
inputFile
:: forall m input err view. (Monad m, FormInput input, FormError err input)
=> FormState m input FormId
-> (FormId -> view)
-> Form m input err view (FileType input)
inputFile i' toView =
Form $ do
i <- i'
v <- getFormInput' i
case v of
Default ->
pure
( View $ const $ toView i
, pure $ Error [(unitRange i, commonFormError (InputMissing i))]
)
Found x -> case getInputFile' x of
Right a -> pure
( View $ const $ toView i
, pure $
Ok
( Proved
{ pos = unitRange i
, unProved = a
}
)
)
Left err -> pure
( View $ const $ toView i
, pure $ Error [(unitRange i, err)]
)
Missing ->
pure
( View $ const $ toView i
, pure $ Error [(unitRange i, commonFormError (InputMissing i))]
)
where
-- just here for the type-signature to make the type-checker happy
getInputFile' :: (FormError err input) => input -> Either err (FileType input)
getInputFile' = getInputFile
-- | used for groups of checkboxes, @\