fradrive/src/Utils/Form.hs

{-# OPTIONS_GHC -fno-warn-deprecations #-}

module Utils.Form where

import ClassyPrelude.Yesod hiding (addMessage, cons, Proxy(..), identifyForm)
import Yesod.Core.Instances ()
import Settings

import Utils.Parameters

import Text.Blaze (Markup)
import qualified Text.Blaze.Internal as Blaze (null)
import qualified Data.Text as T

import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Data.Universe

import Data.Map.Lazy ((!))
import qualified Data.Map.Lazy as Map
import qualified Data.Set as Set

import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Reader.Class (MonadReader(..))
import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Trans.RWS (mapRWST)
import Control.Monad.Trans.Except (ExceptT, runExceptT)

import Data.List ((!!))

import Control.Lens

import Web.PathPieces

import Data.UUID

import Utils
-- import Utils.Message
-- import Utils.PathPiece
-- import Utils.Route

import Data.Proxy




--------------------
-- Field Settings --
--------------------

fsl ::  Text -> FieldSettings site
fsl lbl
  = FieldSettings { fsLabel    = SomeMessage lbl
                  , fsTooltip  = Nothing
                  , fsId       = Nothing
                  , fsName     = Nothing
                  , fsAttrs    = []
                  }

fslI :: RenderMessage site msg => msg -> FieldSettings site
fslI lbl
  = FieldSettings { fsLabel    = SomeMessage lbl
                  , fsTooltip  = Nothing
                  , fsId       = Nothing
                  , fsName     = Nothing
                  , fsAttrs    = []
                  }

fslp ::  Text -> Text -> FieldSettings site
fslp lbl placeholder
  = FieldSettings { fsLabel    = SomeMessage lbl
                  , fsTooltip  = Nothing
                  , fsId       = Nothing
                  , fsName     = Nothing
                  , fsAttrs    = [("placeholder", placeholder)]
                  }

fslpI :: RenderMessage site msg => msg -> Text -> FieldSettings site
fslpI lbl placeholder
  = FieldSettings { fsLabel    = SomeMessage lbl
                  , fsTooltip  = Nothing
                  , fsId       = Nothing
                  , fsName     = Nothing
                  , fsAttrs    = [("placeholder", placeholder)]
                  }


-- NOTE: see Utils.insertAttrs for inserting/merging generic [[(Text,Text)] attributes

addAttr :: Text -> Text -> FieldSettings site -> FieldSettings site
addAttr attr valu fs = fs { fsAttrs = insertAttr attr valu $ fsAttrs fs }

addAttrs :: Text -> [Text] -> FieldSettings site -> FieldSettings site
addAttrs attr valus fs = fs { fsAttrs = insertAttr attr valu $ fsAttrs fs }
  where
    valu = T.intercalate " " valus

addPlaceholder :: Text -> FieldSettings site -> FieldSettings site
addPlaceholder placeholder fs = fs { fsAttrs = (placeholderAttr, placeholder) : filter ((/= placeholderAttr) . fst) (fsAttrs fs) }
  where
    placeholderAttr = "placeholder"

addClass :: Text -> FieldSettings site -> FieldSettings site
addClass = addAttr "class"

addClasses :: [Text] -> FieldSettings site -> FieldSettings site
addClasses = addAttrs "class"

addName :: PathPiece p => p -> FieldSettings site -> FieldSettings site
addName nm fs = fs { fsName = Just $ toPathPiece nm }

addId :: PathPiece p => p -> FieldSettings site -> FieldSettings site
addId fid fs = fs { fsId = Just $ toPathPiece fid }

addNameClass :: Text -> Text -> FieldSettings site -> FieldSettings site
addNameClass gName gClass fs = fs { fsName = Just gName, fsAttrs = ("class",gClass) : fsAttrs fs }

addIdClass :: Text -> Text -> FieldSettings site -> FieldSettings site
addIdClass gId gClass fs = fs { fsId = Just gId, fsAttrs = ("class",gClass) : fsAttrs fs }


setClass :: FieldSettings site -> Text -> FieldSettings site -- deprecated
setClass fs c = fs { fsAttrs = ("class",c) : fsAttrs fs }

setNameClass :: FieldSettings site -> Text -> Text -> FieldSettings site -- deprecated
setNameClass fs gName gClass = fs { fsName = Just gName
                                  , fsAttrs = ("class",gClass) : fsAttrs fs
                                  }

setTooltip :: RenderMessage site msg => msg -> FieldSettings site -> FieldSettings site
setTooltip msg fs = fs { fsTooltip = Just $ SomeMessage msg }

addDatalist :: (PathPiece (Element vals), MonoFoldable vals, Monad m) => WidgetT (HandlerSite m) IO vals -> Field m a -> Field m a
addDatalist mValues field = field
  { fieldView = \fId fName fAttrs fRes fReq -> do
      listId <- newIdent
      values <- map toPathPiece . otoList <$> mValues
      fieldView field fId fName (("list", listId) : fAttrs) fRes fReq
      [whamlet|
        $newline never
        <datalist ##{listId}>
          $forall value <- values
            <option value=#{value}>
      |]
  }

noValidate :: FieldSettings site -> FieldSettings site
noValidate = addAttr "formnovalidate" ""

inputDisabled :: FieldSettings site -> FieldSettings site
inputDisabled = addAttr "disabled" ""

inputReadonly :: FieldSettings site -> FieldSettings site
inputReadonly = addAttr "readonly" ""

addAutosubmit :: FieldSettings site -> FieldSettings site
addAutosubmit = addAttr "uw-auto-submit-input" ""

------------------------------------------------
-- Unique Form Identifiers to avoid accidents --
------------------------------------------------

data FormIdentifier
  = FIDcourse
  | FIDcourseRegister
  | FIDsheet
  | FIDmaterial
  | FIDsubmission
  | FIDsettings
  | FIDcorrectors
  | FIDcorrectorTable
  | FIDcorrection
  | FIDcorrectionsUpload
  | FIDcorrectionUpload
  | FIDSystemMessageAdd
  | FIDSystemMessageTable
  | FIDSystemMessageModify
  | FIDSystemMessageModifyTranslation UUID
  | FIDSystemMessageAddTranslation
  | FIDDBTableFilter
  | FIDDBTablePagesize
  | FIDDBTable
  | FIDDelete
  | FIDCourseRegister
  | FIDuserRights
  | FIDcUserNote
  | FIDcRegField
  | FIDcRegButton
  | FIDAdminDemo
  | FIDUserDelete
  | FIDCommunication
  deriving (Eq, Ord, Read, Show)

instance PathPiece FormIdentifier where
  fromPathPiece = readFromPathPiece
  toPathPiece = showToPathPiece


identifyForm' :: (Monad m, PathPiece ident, Eq ident)
              => Lens' x (FormResult a)
              -> ident -- ^ Form identification
              -> (Html -> MForm m (x, widget))
              -> (Html -> MForm m (x, widget))
identifyForm' resLens identVal form fragment = do
    -- Create hidden <input>.
    let fragment' =
          [shamlet|
            <input .form-identifier type=hidden name=#{toPathPiece PostFormIdentifier} value=#{toPathPiece identVal}>
            #{fragment}
          |]

    -- Check if we got its value back.
    hasIdent <- (== Just identVal) <$> lookupGlobalPostParamForm PostFormIdentifier

    -- Run the form proper (with our hidden <input>).  If the
    -- data is missing, then do not provide any params to the
    -- form, which will turn its result into FormMissing.  Also,
    -- doing this avoids having lots of fields with red errors.
    let eraseParams | not hasIdent = local (\(_, h, l) -> (Nothing, h, l))
                    | otherwise    = id
    fmap (over (_1 . resLens) $ bool (const FormMissing) id hasIdent) . eraseParams $ form fragment'

identifyForm :: (Monad m, PathPiece ident, Eq ident) => ident -> (Html -> MForm m (FormResult a, widget)) -> (Html -> MForm m (FormResult a, widget))
identifyForm = identifyForm' id


{- Hinweise zur Erinnerung:
  - identForm primär, wenn es mehr als ein Formular pro Handler gibt
  - nur einmal pro makeForm reicht
-}

----------------------------
-- Buttons (new version ) --
----------------------------

data family ButtonClass site :: *

class (PathPiece a, PathPiece (ButtonClass site), RenderMessage site ButtonMessage) => Button site a where
  btnLabel :: a -> WidgetT site IO ()

  default btnLabel :: RenderMessage site a => a -> WidgetT site IO ()
  btnLabel = toWidget <=< ap getMessageRender . return

  btnValidate :: forall p. p site -> a -> Bool
  btnValidate _ _ = True

  btnClasses :: a -> [ButtonClass site]
  btnClasses _ = []

data ButtonMessage = MsgAmbiguousButtons
                   | MsgWrongButtonValue
                   | MsgMultipleButtonValues
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)

-- | Default button for submitting. Required in Foundation for Login, other Buttons defined in Handler.Utils.Form
data ButtonSubmit = BtnSubmit
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)

instance Universe ButtonSubmit
instance Finite ButtonSubmit

nullaryPathPiece ''ButtonSubmit $ camelToPathPiece' 1

buttonField :: forall a m.
             ( Button (HandlerSite m) a
             , MonadHandler m
             ) => a -> Field m a
-- | Already validates that the correct button press was received (result only neccessary for combinedButtonField)
buttonField btn = Field{..}
  where
    fieldEnctype = UrlEncoded

    fieldView :: FieldViewFunc m a
    fieldView fid name attrs _val _ = let
      validate = btnValidate (Proxy @(HandlerSite m)) btn
      classes :: [ButtonClass (HandlerSite m)]
      classes = btnClasses btn
      in [whamlet|
        $newline never
        <button class=#{unwords $ map toPathPiece classes} type=submit name=#{name} value=#{toPathPiece btn} *{attrs} ##{fid} :not validate:formnovalidate>^{btnLabel btn}
      |]

    fieldParse []    [] = return $ Right Nothing
    fieldParse [str] []
      | str == toPathPiece btn = return . Right $ Just btn
      | otherwise  = return . Left $ SomeMessage MsgWrongButtonValue
    fieldParse _ _ = return . Left $ SomeMessage MsgMultipleButtonValues

combinedButtonField :: forall a m.
                     ( Button (HandlerSite m) a
                     , MonadHandler m
                     ) => [a] -> FieldSettings (HandlerSite m) -> AForm m [Maybe a]
combinedButtonField bs FieldSettings{..} = formToAForm $ do
  mr <- getMessageRender
  fvId <- maybe newFormIdent return fsId
  name <- maybe newFormIdent return fsName
  (ress, fvs) <- fmap unzip . for bs $ \b -> mopt (buttonField b) ("" { fsId = Just $ fvId <> "__" <> toPathPiece b
                                                                      , fsName = Just $ name <> "__" <> toPathPiece b
                                                                      , fsAttrs
                                                                      }) Nothing
  return ( sequenceA ress
         , pure FieldView
             { fvLabel = toHtml $ mr fsLabel
             , fvTooltip = fmap (toHtml . mr) fsTooltip
             , fvId
             , fvInput = foldMap fvInput fvs
             , fvErrors = bool Nothing (Just $ foldMap (fromMaybe mempty . fvErrors) fvs) $ any (isJust . fvErrors) fvs
             , fvRequired = False
             }
         )

combinedButtonFieldF :: forall m a.
                      ( Button (HandlerSite m) a
                      , Finite a
                      , MonadHandler m
                      ) => FieldSettings (HandlerSite m) -> AForm m [Maybe a]
combinedButtonFieldF = combinedButtonField (universeF :: [a])

-- | Ensures that only a single button press is accepted at once
disambiguateButtons :: forall m a.
                     ( MonadHandler m
                     , RenderMessage (HandlerSite m) ButtonMessage
                     ) => AForm m [Maybe a] -> AForm m a
disambiguateButtons = traverseAForm $ \case
  (catMaybes -> [bRes]) -> return $ FormSuccess bRes
  (catMaybes -> []    ) -> return FormMissing
  _other                -> formFailure [MsgAmbiguousButtons]

combinedButtonField_ :: forall a m.
                      ( Button (HandlerSite m) a
                      , MonadHandler m
                      ) => [a] -> FieldSettings (HandlerSite m) -> AForm m ()
combinedButtonField_ = (void .) . combinedButtonField

combinedButtonFieldF_ :: forall m a p.
                       ( Button (HandlerSite m) a
                       , MonadHandler m
                       , Finite a
                       ) => p a -> FieldSettings (HandlerSite m) -> AForm m ()
combinedButtonFieldF_ _ = void . combinedButtonFieldF @m @a

-- | Submit-Button as AForm, also see submitButtonView below
submitButton :: (Button (HandlerSite m) ButtonSubmit, MonadHandler m) => AForm m ()
submitButton = combinedButtonFieldF_ (Proxy @ButtonSubmit) ""

-- | just Html for a Submit-Button
submitButtonView :: forall site . Button site ButtonSubmit => WidgetT site IO ()
submitButtonView = buttonView BtnSubmit

buttonView :: forall site button. Button site button => button -> WidgetT site IO ()
buttonView btn = do
  let bField :: Field (HandlerT site IO) button
      bField = buttonField btn
  btnId <- newIdent
  fieldView bField btnId "" mempty (Right btn) False



buttonForm :: (Button site a, Finite a) => Html -> MForm (HandlerT site IO) (FormResult a, WidgetT site IO ())
buttonForm = buttonForm' universeF

buttonForm' :: Button site a => [a] -> Html -> MForm (HandlerT site IO) (FormResult a, WidgetT site IO ())
buttonForm' btns csrf = do
  (res, ($ []) -> fViews) <- aFormToForm . disambiguateButtons $ combinedButtonField btns ""
  return (res, [whamlet|
      $newline never
      #{csrf}
      $forall bView <- fViews
        ^{fvInput bView}
    |])

-------------------
-- Custom Fields --
-------------------

-- | empty field that has no view and always succeeds, useful for form sections having only a label
noinputField :: Monad m => Field m ()
noinputField = Field  { fieldEnctype = UrlEncoded
                      , fieldParse = const $ const $ return $ Right $ Just ()
                      , fieldView  = \_theId _name _attrs _val _isReq -> mempty
                      }

ciField :: ( Textual t
           , CI.FoldCase t
           , Monad m
           , RenderMessage (HandlerSite m) FormMessage
           ) => Field m (CI t)
ciField = convertField (CI.mk . fromList . unpack) (pack . toList . CI.original) textField

pathPieceField :: ( PathPiece a
                  , Monad m
                  , RenderMessage (HandlerSite m) FormMessage
                  ) => Field m a
pathPieceField = checkMMap (\t -> return . maybe (Left $ MsgInvalidEntry t) Right $ fromPathPiece t) toPathPiece textField

reorderField :: ( MonadHandler m
                , HandlerSite m ~ site
                , Eq a
                , Show a
                ) => HandlerT site IO (OptionList a) -> Field m [a]
-- ^ Allow the user to enter a /permutation/ of the given options (every option must occur exactly once in the result)
reorderField optList = Field{..}
  where
    fieldEnctype = UrlEncoded
    fieldParse [] _ = return $ Right Nothing
    fieldParse optlist _ = do
      OptionList{..} <- liftHandlerT optList
      let
        olNum = fromIntegral $ length olOptions
        selOptions = Map.fromList $ do
          i <- [1..olNum]
          (readMay -> Just (n :: Word), '.' : extVal) <- break (== '.') . unpack <$> optlist
          guard $ i == n
          Just val <- return . olReadExternal $ pack extVal
          return (i, val)
      return $ if
        | Map.keysSet selOptions == Set.fromList [1..olNum]
          -> Right . Just $ map (selOptions !) [1..fromIntegral olNum]
        | otherwise
          -> Left "Not a valid permutation"
    fieldView theId name attrs val isReq = do
      OptionList{..} <- liftHandlerT optList
      let
        isSel n = (==) (either (const $ map optionInternalValue olOptions) id val !! pred n) . optionInternalValue
        nums = map (id &&& withNum theId) [1..length olOptions]
        withNum t n = tshow n <> "." <> t
      $(widgetFile "widgets/permutation/permutation")

optionsFinite :: ( MonadHandler m
                 , Finite a
                 , RenderMessage site a
                 , HandlerSite m ~ site
                 , PathPiece a
                 )
              => m (OptionList a)
optionsFinite = do
  mr <- getMessageRender
  let
    mkOption a = Option
      { optionDisplay       = mr a
      , optionInternalValue = a
      , optionExternalValue = toPathPiece a
      }
  return . mkOptionList $ mkOption <$> universeF

rationalField :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage) => Field m Rational
rationalField = convertField toRational fromRational doubleField

data SecretJSONFieldException = SecretJSONFieldDecryptFailure
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance Exception SecretJSONFieldException

secretJsonField :: ( ToJSON a, FromJSON a
                   , MonadHandler m
                   , MonadSecretBox (ExceptT EncodedSecretBoxException m)
                   , MonadSecretBox (WidgetT (HandlerSite m) IO)
                   , RenderMessage (HandlerSite m) FormMessage
                   , RenderMessage (HandlerSite m) SecretJSONFieldException
                   )
                => Field m a
secretJsonField = Field{..}
  where
    fieldParse [v] [] = bimap (\_ -> SomeMessage SecretJSONFieldDecryptFailure) Just <$> runExceptT (encodedSecretBoxOpen v)
    fieldParse [] [] = return $ Right Nothing
    fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired
    fieldView theId name attrs val _isReq = do
      val' <- traverse (encodedSecretBox SecretBoxShort) val
      [whamlet|
        <input id=#{theId} name=#{name} *{attrs} type=hidden value=#{either id id val'}>
      |]
    fieldEnctype = UrlEncoded

-----------
-- Forms --
-----------

data FormSubmitType = FormNoSubmit | FormSubmit | FormDualSubmit | FormAutoSubmit
    deriving (Eq, Ord, Enum, Bounded, Read, Show, Typeable, Generic)

instance Universe FormSubmitType
instance Finite FormSubmitType

data FormSettings site = forall p. PathPiece p => FormSettings
      { formMethod     :: StdMethod
      , formAction     :: Maybe (SomeRoute site)
      , formEncoding   :: Enctype
      , formAttrs      :: [(Text, Text)]
      , formSubmit     :: FormSubmitType
      , formAnchor     :: Maybe p
      } deriving (Typeable)

instance Default (FormSettings site) where
  def = FormSettings
    { formMethod   = POST
    , formAction   = Nothing
    , formEncoding = UrlEncoded
    , formAttrs    = []
    , formSubmit   = FormSubmit
    , formAnchor   = Nothing :: Maybe Text
    }

wrapForm :: Button site ButtonSubmit => WidgetT site IO () -> FormSettings site -> WidgetT site IO ()
wrapForm = wrapForm' BtnSubmit

wrapForm' :: Button site button => button -> WidgetT site IO () -> FormSettings site -> WidgetT site IO ()
wrapForm' btn formWidget FormSettings{..} = do
  formId <- maybe newIdent (return . toPathPiece) formAnchor
  formActionUrl <- traverse toTextUrl formAction
  $(widgetFile "widgets/form/form")


-------------------
-- Form Renderer --
-------------------

-- | Use this type to pass information to the form template
data FormLayout = FormStandard | FormDBTableFilter | FormDBTablePagesize

renderAForm :: Monad m => FormLayout -> FormRender m a
renderAForm formLayout aform fragment = do
  (res, ($ []) -> fieldViews) <- aFormToForm aform
  let widget = $(widgetFile "widgets/aform/aform")
  return (res, widget)

renderWForm :: MonadHandler m => FormLayout -> WForm m (FormResult a) -> -- Form a   -- (Synonym unavailable here)
  (Markup -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
renderWForm formLayout = renderAForm formLayout . wFormToAForm


-- | special id to identify form section headers, see 'aformSection' and 'formSection'
--   currently only treated by form generation through 'renderAForm'
idFormSectionNoinput :: Text
idFormSectionNoinput = "form-section-noinput"

-- | Generates a form having just a form-section-header and no input title.
--   Currently only correctly rendered by 'renderAForm' and mforms using 'widget/form.hamlet'
--   Usage:
--   @
--      (,) <$  formSection MsgInt
--          <*> areq intField "int here" Nothing
--          <*  formSection MsgDouble
--          <*> areq doubleField "double there " Nothing
--          <*  submitButton
--   @
--   If tooltips or other attributes are required, see 'formSection\'' instead.
aformSection :: (MonadHandler m, site ~ HandlerSite m, RenderMessage site msg) => msg -> AForm m ()
aformSection = formToAForm . fmap (second pure) . formSection

wformSection :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => msg -> WForm m ()
wformSection = void . aFormToWForm . aformSection

formSection :: (MonadHandler m, site ~ HandlerSite m, RenderMessage site msg) => msg -> MForm m (FormResult (), FieldView site) -- TODO: WIP, delete
formSection formSectionTitle = do
    mr <- getMessageRender
    return (FormSuccess (), FieldView
      { fvLabel    = toHtml $ mr formSectionTitle
      , fvTooltip  = Nothing
      , fvId       = idFormSectionNoinput
      , fvErrors   = Nothing
      , fvRequired = False
      , fvInput    = mempty
      })



-------------------
-- Special Forms --
-------------------

-- | Alternative implementation for 'aformSection' in a more standard that
--  allows tooltips and arbitrary attributs. Section header must be given through `fsLabel`
aformSection' :: (MonadHandler m, site ~ HandlerSite m, RenderMessage site FormMessage) => FieldSettings site -> AForm m ()
aformSection' = formToAForm . fmap (second pure) . formSection'

-- | Alternative implementation for 'formSection' in a more standard that
--  allows tooltips and arbitrary attributs. Section header must be given through `fsLabel`
formSection' :: (MonadHandler m, site ~ HandlerSite m, RenderMessage site FormMessage) =>
   FieldSettings site  -> MForm m (FormResult (), FieldView site) -- TODO: WIP, delete
formSection' formSectionTitleSettings = mreq noinputField sectionSettings Nothing
  where
    sectionSettings = formSectionTitleSettings { fsId = Just idFormSectionNoinput }



---------------------
-- Form evaluation --
---------------------

traverseAForm :: forall m a b. Monad m => (a -> m (FormResult b)) -> (AForm m a -> AForm m b)
traverseAForm adj (AForm f) = AForm $ \mr env ints -> do
  ret@(res, _, _, _) <- f mr env ints
  case res of
    FormFailure errs
      -> return $ ret & _1 .~ FormFailure errs
    FormMissing
      -> return $ ret & _1 .~ FormMissing
    FormSuccess a -> do
      a' <- adj a
      return $ ret & _1 .~ a'

formFailure :: forall msg m a.
             ( MonadHandler m
             , RenderMessage (HandlerSite m) msg
             ) => [msg] -> m (FormResult a)
formFailure errs' = do
  mr <- getMessageRender
  return . FormFailure $ map mr errs'

-- | Turns errors into alerts, ignores missing forms and applies processing function
formResult :: MonadHandler m => FormResult a -> (a -> m ()) -> m ()
formResult res f = void . formResultMaybe res $ \x -> Nothing <$ f x

formResultMaybe :: MonadHandler m => FormResult a -> (a -> m (Maybe b)) -> m (Maybe b)
formResultMaybe (FormFailure errs) _ = Nothing <$ forM_ errs (addMessage Error . toHtml)
formResultMaybe  FormMissing       _ = return Nothing
formResultMaybe (FormSuccess res)  f = f res

formResult' :: FormResult a -> Maybe a
formResult'  FormMissing    = Nothing
formResult' (FormFailure _) = Nothing
formResult' (FormSuccess x) = Just x

runInputGetMaybe, runInputPostMaybe, runInputMaybe :: MonadHandler m => FormInput m a -> m (Maybe a)
runInputGetMaybe form = do
  res <- runInputGetResult form
  return $ case res of
    FormSuccess suc -> Just suc
    _other -> Nothing
runInputPostMaybe form = do
  res <- runInputPostResult form
  return $ case res of
    FormSuccess suc -> Just suc
    _other -> Nothing
runInputMaybe form = runMaybeT $ MaybeT (runInputPostMaybe form) <|> MaybeT (runInputGetMaybe form)

hoistAForm :: HandlerSite m ~ HandlerSite n => (forall a. m a -> n a) -> AForm m b -> AForm n b
hoistAForm f (AForm g) = AForm (\x y z ->f $ g x y z)

hoistField :: HandlerSite m ~ HandlerSite n => (forall a. m a -> n a) -> Field m b -> Field n b
hoistField f Field{..} = Field
  { fieldParse = \x y -> f $ fieldParse x y
  , fieldView
  , fieldEnctype
  }

prismAForm :: Monad m => Prism' s a -> Maybe s ->  (Maybe a -> AForm m a) -> AForm m s
-- ^ @Monad m => Prism' s a -> (Maybe a -> AForm m a) -> (Maybe s -> AForm m s)@
prismAForm p outer form = review p <$> form inner
  where
    inner = outer >>= preview p

-----------------------
-- Form Manipulation --
-----------------------

aFormToWForm :: MonadHandler m => AForm m a -> WForm m (FormResult a)
aFormToWForm = mapRWST mFormToWForm' . over (mapped . _2) ($ []) . aFormToForm
  where
    mFormToWForm' f = do
      ((a, vs), ints, enctype) <- lift f
      writer ((a, ints, enctype), vs)

infixl 4 `fmapAForm`
  
fmapAForm :: Functor m => (FormResult a -> FormResult b) -> (AForm m a -> AForm m b)
fmapAForm f (AForm act) = AForm $ \app env ints -> over _1 f <$> act app env ints

---------------------------------------------
-- Special variants of @mopt@, @mreq@, ... --
---------------------------------------------

mforced :: (site ~ HandlerSite m, MonadHandler m)
        => Field m a -> FieldSettings site -> a -> MForm m (FormResult a, FieldView site)
mforced Field{..} FieldSettings{..} val = do
  tell fieldEnctype
  name <- maybe newFormIdent return fsName
  theId <- lift $ maybe newIdent return fsId
  mr <- getMessageRender
  let fsAttrs' = fsAttrs <> [("disabled", "")]
  return ( FormSuccess val
         , FieldView
           { fvLabel = toHtml $ mr fsLabel
           , fvTooltip = toHtml <$> fmap mr fsTooltip
           , fvId = theId
           , fvInput = fieldView theId name fsAttrs' (Right val) False
           , fvErrors = Nothing
           , fvRequired = False
           }
         )

aforced :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
        => Field m a -> FieldSettings site -> a -> AForm m a
aforced field settings val = formToAForm $ second pure <$> mforced field settings val

apreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
      => Field m a -> FieldSettings site -> Maybe a -> AForm m a
-- ^ Pseudo required
apreq f fs mx = formToAForm $ do
  mr <- getMessageRender
  over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (pure . (\fv -> fv { fvRequired = True } )) <$> mopt f fs (Just <$> mx)

mpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
      => Field m a -> FieldSettings site -> Maybe a -> MForm m (FormResult a, FieldView site)
mpreq f fs mx = do
  mr <- getMessageRender
  over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (\fv -> fv { fvRequired = True } ) <$> mopt f fs (Just <$> mx)

wpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
      => Field m a -> FieldSettings site -> Maybe a -> WForm m (FormResult a)
wpreq f fs mx = mFormToWForm $ do
  mr <- getMessageRender
  over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (\fv -> fv { fvRequired = True } ) <$> mopt f fs (Just <$> mx)