{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DoAndIfThenElse #-}
-- 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.Named 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 -> Either err a)
-> (FormId -> a -> view)
-> a
-> String
-> Form m input err view a
input fromInput toView initialValue name =
Form $ do
let i = FormIdCustom name
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))]
)
-- | used for elements like @\@ which are not always present in the form submission data.
inputMaybe
:: (Monad m, FormError err)
=> (input -> Either err a)
-> (FormId -> a -> view)
-> a
-> String
-> Form m input err view (Maybe a)
inputMaybe fromInput toView initialValue name =
Form $ do
let i = FormIdCustom name
v <- getFormInput' i
case v of
Default -> pure
( View $ const $ toView i initialValue
, pure $
Ok
( Proved
{ pos = unitRange i
, unProved = Just initialValue
}
)
)
Found x -> case fromInput x of
Right a -> pure
( View $ const $ toView i 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)
=> (FormId -> a -> view)
-> a
-> String
-> Form m input err view ()
inputNoData toView a name =
Form $ do
let i = FormIdCustom name
pure
( View $ const $ toView i a
, pure $
Ok
( Proved
{ pos = unitRange i
, unProved = ()
}
)
)
-- | used for @\@
inputFile
:: forall m input err view. (Monad m, FormInput input, FormError err, ErrorInputType err ~ input)
=> (FormId -> view)
-> String
-> Form m input err view (FileType input)
inputFile toView name =
Form $ do
let i = FormIdCustom name
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, ErrorInputType err ~ input) => input -> Either err (FileType input)
getInputFile' = getInputFile
-- | used for groups of checkboxes, @\