module Handler.Utils.Form
  ( module Handler.Utils.Form
  , module Utils.Form
  , MonadWriter(..)
  ) where

import Utils.Form

import Handler.Utils.Form.Types

import Handler.Utils.DateTime

import Import hiding (cons)
import qualified Data.Char as Char

import qualified Data.CaseInsensitive as CI

import qualified Data.Foldable as Foldable

-- import Yesod.Core
import qualified Data.Text as T
-- import Yesod.Form.Types
import Yesod.Form.Functions (parseHelper)
import Yesod.Form.Bootstrap3

import Handler.Utils.Zip
import qualified Data.Conduit.List as C

import qualified Database.Esqueleto as E

import Data.Set (Set)
import qualified Data.Set as Set

import Data.Map (Map, (!))
import qualified Data.Map as Map

import Control.Monad.Trans.Writer (execWriterT, WriterT)
import Control.Monad.Except (runExceptT)
import Control.Monad.Writer.Class

import Data.Scientific (Scientific)
import Data.Ratio
import Text.Read (readMaybe)

import Utils.Lens

import Data.Aeson (eitherDecodeStrict')
import Data.Aeson.Text (encodeToLazyText)

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

data BtnDelete = BtnDelete
  deriving (Enum, Eq, Ord, Bounded, Read, Show)

instance Universe BtnDelete
instance Finite BtnDelete

nullaryPathPiece ''BtnDelete $ camelToPathPiece' 1

instance Button UniWorX BtnDelete where
  label BtnDelete = [whamlet|_{MsgBtnDelete}|]

  cssClass BtnDelete = BCDanger

data RegisterButton = BtnRegister  | BtnDeregister
  deriving (Enum, Eq, Ord, Bounded, Read, Show)

instance Universe RegisterButton
instance Finite RegisterButton

nullaryPathPiece ''RegisterButton $ camelToPathPiece' 1

instance Button UniWorX RegisterButton where
  label BtnRegister   = [whamlet|_{MsgBtnRegister}|]
  label BtnDeregister = [whamlet|_{MsgBtnDeregister}|]

  cssClass BtnRegister   = BCPrimary
  cssClass BtnDeregister = BCDanger

data AdminHijackUserButton = BtnHijack
  deriving (Enum, Eq, Ord, Bounded, Read, Show)

instance Universe AdminHijackUserButton
instance Finite AdminHijackUserButton

nullaryPathPiece ''AdminHijackUserButton $ camelToPathPiece' 1

instance Button UniWorX AdminHijackUserButton where
  label BtnHijack = [whamlet|_{MsgBtnHijack}|]

  cssClass BtnHijack = BCDefault

data BtnSubmitDelete = BtnSubmit' | BtnDelete'
  deriving (Enum, Eq, Ord, Bounded, Read, Show)

instance Universe BtnSubmitDelete
instance Finite BtnSubmitDelete

instance Button UniWorX BtnSubmitDelete where
  label BtnSubmit' = [whamlet|_{MsgBtnSubmit}|]
  label BtnDelete' = [whamlet|_{MsgBtnDelete}|]

  cssClass BtnSubmit' = BCPrimary
  cssClass BtnDelete' = BCDanger

  btnValidate _ BtnSubmit' = True
  btnValidate _ BtnDelete' = False

nullaryPathPiece ''BtnSubmitDelete $ camelToPathPiece' 1 . dropSuffix "'"


-- -- Looks like a button, but is just a link (e.g. for create course, etc.)
-- data LinkButton = LinkButton (Route UniWorX)
--   deriving (Enum, Eq, Ord, Bounded, Read, Show)
--
-- instance PathPiece LinkButton where
--     LinkButton route = ???

linkButton :: Widget -> ButtonCssClass UniWorX -> Route UniWorX -> Widget -- Alternative: Handler.Utils.simpleLink
linkButton lbl cls url = [whamlet| <a href=@{url} .btn .#{bcc2txt cls} role=button>^{lbl} |]
--   [whamlet|
--     <form method=post action=@{url}>
--       <input type="hidden" name="_formid" value="identify-linkButton">
--       <button .btn .#{bcc2txt cls} type=submit value="Link to @{url}">^{lbl}
--   |]
  --  <input .btn .#{bcc2txt cls} type="submit" value=^{lbl}>


-- buttonForm :: Button a => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, (WidgetT UniWorX IO ()))
buttonForm :: (Button UniWorX a, Show a) => Form a
buttonForm csrf = do
    buttonIdent <- newFormIdent
    let button b = mopt (buttonField b) ("n/a"{ fsName = Just buttonIdent }) Nothing
    (results, btnViews) <- unzip <$> mapM button [minBound..maxBound]
    let widget =
          [whamlet|
            #{csrf}
            $forall bView <- btnViews
              ^{fvInput bView}
          |]
    return (accResult results,widget)
  where
    accResult :: Foldable f => f (FormResult (Maybe a)) -> FormResult a
    accResult = Foldable.foldr accResult' FormMissing

    accResult' :: FormResult (Maybe a) -> FormResult a -> FormResult a
    -- Find the single FormSuccess Just _; Expected behaviour: all buttons deliver FormFailure, except for one.
    accResult' (FormSuccess (Just _)) (FormSuccess _) = FormFailure ["Ambiguous button parse"]
    accResult' (FormSuccess (Just x)) _ = FormSuccess x
    accResult' _ x@(FormSuccess _) = x --Safe: most buttons deliver FormFailure, one delivers FormSuccess
    accResult' (FormSuccess Nothing) x = x
    accResult' FormMissing _ = FormMissing
    accResult' (FormFailure errs) _ = FormFailure errs



------------
-- Fields --
------------

-- ciField moved to Utils.Form

routeField :: ( Monad m
              , HandlerSite m ~ UniWorX
              ) => Field m (Route UniWorX)
routeField = checkMMap (return . maybe (Left MsgInvalidRoute) Right . fromPathPiece) toPathPiece textField

natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i
natFieldI msg = checkBool (>= 0) msg intField

natField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i
natField d = checkBool (>= 0) (T.append  d " muss eine natürliche Zahl sein.") intField

natIntField ::(Monad m, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m Integer
natIntField = natField

posIntField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i
posIntField d = checkBool (>= 1) (T.append  d " muss eine positive Zahl sein.") intField

minIntField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) FormMessage) => i -> Text -> Field m i
minIntField m d = checkBool (>= m) (T.concat [d," muss größer als ", T.pack $ show m, " sein."]) intField

pointsField :: (Monad m, HandlerSite m ~ UniWorX) => Field m Points --TODO allow fractions
pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..}
  where
    fieldEnctype = UrlEncoded
    fieldView theId name attrs val isReq
      = [whamlet|
          $newline never
          <input id=#{theId} name=#{name} *{attrs} type=number step="0.01" :isReq:required value=#{either id tshow val}>
        |]
    fieldParse = parseHelper $ \t -> do
      sci <- maybe (Left $ MsgInvalidNumber t) Right (readMaybe $ unpack t :: Maybe Scientific)
      return . fromRational $ round (sci * 100) % 100

pointsFieldMax :: (Monad m, HandlerSite m ~ UniWorX) => Maybe Points -> Field m Points --TODO allow fractions
pointsFieldMax Nothing = pointsField
pointsFieldMax (Just maxp) = checkBool (<= maxp) (MsgPointsTooHigh maxp) pointsField

termsActiveField :: Field Handler TermId
termsActiveField = selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName

termsAllowedField :: Field Handler TermId
termsAllowedField = selectField $ do
  mayEditTerm <- isAuthorized TermEditR True
  let termFilter | Authorized <- mayEditTerm = []
                 | otherwise = [TermActive ==. True]
  optionsPersistKey termFilter [Desc TermStart] termName

termsSetField :: [TermId] -> Field Handler TermId
termsSetField tids = selectField $ optionsPersistKey [TermName <-. (unTermKey <$> tids)] [Desc TermStart] termName
-- termsSetField tids = selectFieldList [(unTermKey t, t)| t <- tids ]

termsActiveOrSetField :: [TermId] -> Field Handler TermId
termsActiveOrSetField tids = selectField $ optionsPersistKey ([TermActive ==.True] ||. [TermName <-. terms]) [Desc TermStart] termName
  where terms = map unTermKey tids
-- termActiveOld :: Field Handler TermIdentifier
-- termActiveOld = convertField unTermKey TermKey $ selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName

termNewField :: Field Handler TermIdentifier
termNewField = checkMMap (return.termFromText) termToText textField

schoolField :: Field Handler SchoolId
schoolField = selectField $ optionsPersistKey [] [Asc SchoolName] schoolName

schoolFieldEnt :: Field Handler (Entity School)
schoolFieldEnt = selectField $ optionsPersist [] [Asc SchoolName] schoolName

schoolFieldFor :: [SchoolId] -> Field Handler SchoolId
schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolShorthand <-. map unSchoolKey userSchools] [Asc SchoolName] schoolName

uploadModeField :: Field Handler UploadMode
uploadModeField = selectField optionsFinite

submissionModeField :: Field Handler SheetSubmissionMode
submissionModeField = selectField optionsFinite

pseudonymWordField :: Field Handler PseudonymWord
pseudonymWordField = checkMMap doCheck CI.original $ textField & addDatalist (return $ map CI.original pseudonymWordlist)
  where
    doCheck (CI.mk -> w)
      | Just w' <- find (== w) pseudonymWordlist
      = return $ Right w'
      | otherwise
      = return . Left $ MsgUnknownPseudonymWord (CI.original w)

zipFileField :: Bool -- ^ Unpack zips?
             -> Field Handler (Source Handler File)
zipFileField doUnpack = Field{..}
  where
    fieldEnctype = Multipart
    fieldParse _ files
      | [f] <- files = return . Right . Just $ bool (yieldM . acceptFile) sourceFiles doUnpack f
      | null files   = return $ Right Nothing
      | otherwise    = return . Left $ SomeMessage MsgOnlyUploadOneFile
    fieldView fieldId fieldName attrs _ req =
      [whamlet|
        $newline never
        <input type=file ##{fieldId} *{attrs} name=#{fieldName} :req:required>
      |]

multiFileField :: Handler (Set FileId) -> Field Handler (Source Handler (Either FileId File))
multiFileField permittedFiles' = Field{..}
  where
    fieldEnctype = Multipart
    fieldParse vals files = return . Right . Just $ do
      pVals <- lift permittedFiles'
      let
        decrypt' :: CryptoUUIDFile -> Handler (Maybe FileId)
        decrypt' = fmap (either (\(_ :: CryptoIDError) -> Nothing) Just) . try . decrypt
      yieldMany vals
        .| C.filter (/= unpackZips)
        .| C.map fromPathPiece .| C.catMaybes
        .| C.mapMaybeM decrypt'
        .| C.filter (`elem` pVals)
        .| C.map Left
      let
        handleFile :: FileInfo -> Source Handler File
        handleFile
          | doUnpack  = sourceFiles
          | otherwise = yieldM . acceptFile
      mapM_ handleFile files .| C.map Right
      where
        doUnpack = unpackZips `elem` vals
    fieldView fieldId fieldName _attrs val req = do
      pVals <- handlerToWidget permittedFiles'
      sentVals <- for val $ \src -> handlerToWidget . sourceToList $ src .| takeLefts
      let
        toFUI (E.Value fuiId', E.Value fuiTitle) = do
          fuiId <- encrypt fuiId'
          fuiHtmlId <- newIdent
          let fuiChecked
                | Right sentVals' <- sentVals = fuiId' `elem` sentVals'
                | otherwise = True
          return FileUploadInfo{..}
      fileInfos <- mapM toFUI <=< handlerToWidget . runDB . E.select . E.from $ \file -> do
          E.where_ $ file E.^. FileId `E.in_` E.valList (setToList pVals)
          E.orderBy [E.asc $ file E.^. FileTitle]
          return (file E.^. FileId, file E.^. FileTitle)
      $(widgetFile "multiFileField")
    unpackZips :: Text
    unpackZips = "unpack-zip"
    takeLefts :: Monad m => ConduitM (Either b a) b m ()
    takeLefts = awaitForever $ \case
      Right _ -> return ()
      Left  r -> yield r


data SheetGrading' = Points' | PassPoints' | PassBinary'
  deriving (Eq, Ord, Read, Show, Enum, Bounded)

instance Universe SheetGrading'
instance Finite SheetGrading'

nullaryPathPiece ''SheetGrading' (camelToPathPiece . dropSuffix "'")
embedRenderMessage ''UniWorX ''SheetGrading' ("SheetGrading" <>)


data SheetType' = NotGraded' | Normal' | Bonus' | Informational'
  deriving (Eq, Ord, Read, Show, Enum, Bounded)

instance Universe SheetType'
instance Finite SheetType'

nullaryPathPiece ''SheetType' (camelToPathPiece . dropSuffix "'")
embedRenderMessage ''UniWorX ''SheetType' ("SheetType" <>)


data SheetGroup' = NoGroups' | Arbitrary' | RegisteredGroups'
  deriving (Eq, Ord, Read, Show, Enum, Bounded)

instance Universe SheetGroup'
instance Finite SheetGroup'

nullaryPathPiece ''SheetGroup' (camelToPathPiece . dropSuffix "'")
embedRenderMessage ''UniWorX ''SheetGroup' (("SheetGroup" <>) . dropSuffix "'")

sheetGradingAFormReq :: FieldSettings UniWorX -> Maybe SheetGrading -> AForm Handler SheetGrading
sheetGradingAFormReq fs template = multiActionA fs selOptions (classify' <$> template)
  where
    selOptions = Map.fromList
      [ ( Points',     Points     <$> maxPointsReq )
      , ( PassPoints', PassPoints <$> maxPointsReq <*> passPointsReq )
      , ( PassBinary', pure PassBinary)
      ]
    classify' :: SheetGrading -> SheetGrading'
    classify' = \case
      Points     {} -> Points'
      PassPoints {} -> PassPoints'
      PassBinary {} -> PassBinary'

    maxPointsReq  = apreq pointsField (fslI MsgSheetGradingMaxPoints)     (template >>= preview _maxPoints)
    passPointsReq = apreq pointsField (fslI MsgSheetGradingPassingPoints) (template >>= preview _passingPoints)


sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType
sheetTypeAFormReq fs template = multiActionA fs selOptions (classify' <$> template)
  where
    selOptions = Map.fromList
      [ ( Normal', Normal <$> gradingReq )
      , ( Bonus' , Bonus  <$> gradingReq )
      , ( Informational', Informational <$> gradingReq  )
      , ( NotGraded', pure NotGraded )
      ]
    gradingReq = sheetGradingAFormReq (fslI MsgSheetGrading
        & setTooltip MsgSheetGradingInfo) (template >>= preview _grading)

    classify' :: SheetType -> SheetType'
    classify' = \case
      Bonus  {} -> Bonus'
      Normal {} -> Normal'
      Informational {} -> Informational'
      NotGraded -> NotGraded'

sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler SheetGroup
sheetGroupAFormReq FieldSettings{..} template = formToAForm $ do
  let
    selOptions = Map.fromList
      [ ( Arbitrary', Arbitrary
          <$> apreq (natField "Gruppengröße") (fslI MsgSheetGroupMaxGroupsize & noValidate) (preview _maxParticipants =<< template)
        )
      , ( RegisteredGroups', pure RegisteredGroups )
      , ( NoGroups', pure NoGroups )
      ]
  (res, selView) <- multiAction selOptions (classify' <$> template)

  fvId <- maybe newIdent return fsId
  MsgRenderer mr <- getMsgRenderer

  return (res,
    [ FieldView
      { fvLabel = toHtml $ mr fsLabel
      , fvTooltip = toHtml . mr <$> fsTooltip
      , fvId
      , fvInput = selView
      , fvErrors = case res of
          FormFailure [e] -> Just $ toHtml e
          _ -> Nothing
      , fvRequired = True
      }
    ])

  where
    classify' :: SheetGroup -> SheetGroup'
    classify' = \case
      Arbitrary _ -> Arbitrary'
      RegisteredGroups -> RegisteredGroups'
      NoGroups -> NoGroups'


{-
dayTimeField :: FieldSettings UniWorX -> Maybe UTCTime -> Form Handler UTCTime
dayTimeField fs mutc = do
    let (mbDay,mbTime) = case mutcs of
          Nothing    -> return (Nothing,Nothing)
          (Just utc) ->

    (dayResult, dayView) <- mreq dayField fs

    (result, view) <- (,) <$> dayField <*> timeField
  where
    (mbDay,mbTime)
      | (Just utc) <- mutc =
          let lt = utcToLocalTime ??? utcs
          in  (Just $ localDay lt, Just $ localTimeOfDay lt)
      | otherwise = (Nothing,Nothing)
-}


utcTimeField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m UTCTime
-- StackOverflow: dayToUTC <$> (areq (jqueryDayField def {...}) settings Nothing)
-- Browser returns LocalTime
utcTimeField = Field
    { fieldParse = parseHelperGen readTime
    , fieldView = \theId name attrs val isReq -> do
        val' <- either id id <$> traverse (formatTime' fieldTimeFormat) val
        [whamlet|
          $newline never
          <input id="#{theId}" name="#{name}" *{attrs} type="datetime-local" :isReq:required value="#{val'}">
        |]
    , fieldEnctype = UrlEncoded
    }
  where
    fieldTimeFormat :: String
    --fieldTimeFormat = "%e.%m.%y %k:%M"
    fieldTimeFormat = "%Y-%m-%dT%H:%M"

    -- `defaultTimeLocale` is okay here, since `fieldTimeFormat` does not contain any
    readTime :: Text -> Either UniWorXMessage UTCTime
    readTime t =
      case localTimeToUTC <$> parseTimeM True defaultTimeLocale fieldTimeFormat (T.unpack t) of
        Just LTUUnique{_ltuResult} -> Right _ltuResult
        Just LTUNone{}             -> Left MsgIllDefinedUTCTime
        Just LTUAmbiguous{}        -> Left MsgAmbiguousUTCTime
        Nothing                    -> Left MsgInvalidDateTimeFormat

langField :: Bool -- ^ Only allow values from `appLanguages`
          -> Field (HandlerT UniWorX IO) Lang
langField False = checkBool (all ((&&) <$> not . null <*> T.all Char.isAlpha) . T.splitOn "-") MsgInvalidLangFormat $ textField & addDatalist (return $ toList appLanguages)
langField True = selectField . optionsPairs . map (MsgLanguage &&& id) $ toList appLanguages

jsonField :: ( ToJSON a, FromJSON a
             , MonadHandler m
             , RenderMessage (HandlerSite m) UniWorXMessage
             , RenderMessage (HandlerSite m) FormMessage
             )
          => Bool {-^ Hidden? -}
          -> Field m a
jsonField hide = Field{..}
  where
    inputType :: Text
    inputType
      | hide      = "hidden"
      | otherwise = "text"
    fieldParse [v] [] = return . bimap (SomeMessage . MsgJSONFieldDecodeFailure) Just . eitherDecodeStrict' $ encodeUtf8 v
    fieldParse [] [] = return $ Right Nothing
    fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired
    fieldView theId name attrs val isReq = liftWidgetT [whamlet|
      <input id=#{theId} name=#{name} *{attrs} type=#{inputType} :isReq:required value=#{either fromStrict encodeToLazyText val}>
    |]
    fieldEnctype = UrlEncoded

secretJsonField :: ( ToJSON a, FromJSON a
                   , MonadHandler m
                   , HandlerSite m ~ UniWorX
                   )
                => Field m a
secretJsonField = Field{..}
  where
    fieldParse [v] [] = bimap (\_ -> SomeMessage MsgSecretJSONFieldDecryptFailure) 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


funcForm :: forall k v m.
            ( Finite k, Ord k
            , MonadHandler m
            , HandlerSite m ~ UniWorX
            )
         => (k -> AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (k -> v)
funcForm mkForm FieldSettings{fsName = _, fsAttrs = _, ..} isRequired = formToAForm $ funcFieldView =<< renderAForm FormStandard funcForm' mempty
  where
    funcForm' :: AForm m (k -> v)
    funcForm' = fmap (!) . sequenceA . Map.fromSet mkForm $ Set.fromList universeF
    funcFieldView :: (FormResult (k -> v), Widget) -> MForm m (FormResult (k -> v), [FieldView UniWorX])
    funcFieldView (res, fvInput) = do
      mr <- getMessageRender
      let fvLabel = toHtml $ mr fsLabel
          fvTooltip = fmap (toHtml . mr) fsTooltip
          fvRequired = isRequired
          fvErrors
            | FormFailure (err:_) <- res = Just $ toHtml err
            | otherwise = Nothing
      fvId <- maybe newIdent return fsId
      return (res, pure FieldView{..})
    -- areq nsField (fslI MsgNotificationSettings) (stgNotficationSettings <$> template)




fsm :: RenderMessage UniWorX msg => msg -> FieldSettings UniWorX -- DEPRECATED
fsm = bfs -- TODO: get rid of Bootstrap

fsb :: Text -> FieldSettings site -- DEPRECATED
fsb = bfs -- Just to avoid annoying Ambiguous Type Errors

fsUniq :: (Text -> Text) -> Text -> FieldSettings site
fsUniq mkUnique seed = "" { fsName = Just $ mkUnique seed }


optionsPersistCryptoId :: forall site backend a msg.
                          ( YesodPersist site
                          , PersistQueryRead backend
                          , HasCryptoUUID (Key a) (HandlerT site IO)
                          , RenderMessage site msg
                          , YesodPersistBackend site ~ backend
                          , PersistRecordBackend a backend
                          )
                       => [Filter a]
                       -> [SelectOpt a]
                       -> (a -> msg)
                       -> HandlerT site IO (OptionList (Entity a))
optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do
  mr <- getMessageRender
  pairs <- runDB $ selectList filts ords
  cPairs <- forM pairs $ \e@(Entity key _) -> (,) <$> encrypt key <*> pure e
  return $ map (\(cId, e@(Entity _key value)) -> Option
                 { optionDisplay = mr (toDisplay value)
                 , optionInternalValue = e
                 , optionExternalValue = toPathPiece (cId :: CryptoID UUID (Key a))
                 }) cPairs

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)

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)

multiAction :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
            => Map action (AForm (HandlerT UniWorX IO) a)
            -> Maybe action
            -> MForm (HandlerT UniWorX IO) (FormResult a, Widget)
multiAction acts defAction = do
  mr <- getMessageRender
  let
    options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece
  (actionRes, actionView) <- mreq (selectField $ return options) "" defAction
  results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts
  let mToWidget (_, []) = return Nothing
      mToWidget aForm = Just . snd <$> renderAForm FormStandard (formToAForm $ return aForm) mempty
  widgets <- mapM mToWidget results
  let actionWidgets = Map.foldrWithKey accWidget [] widgets
      accWidget _act Nothing = id
      accWidget act (Just w) = cons $(widgetFile "widgets/multiAction")
      actionResults = Map.map fst results
  return ((actionResults Map.!) =<< actionRes, $(widgetFile "widgets/multiActionCollect"))

multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
            => FieldSettings UniWorX
            -> Map action (AForm (HandlerT UniWorX IO) a)
            -> Maybe action
            -> AForm (HandlerT UniWorX IO) a
multiActionA FieldSettings{..} acts defAction = formToAForm $ do
  (res, selView) <- multiAction acts defAction

  fvId <- maybe newIdent return fsId
  MsgRenderer mr <- getMsgRenderer

  return (res,
    [ FieldView
      { fvLabel = toHtml $ mr fsLabel
      , fvTooltip = toHtml . mr <$> fsTooltip
      , fvId
      , fvInput = selView
      , fvErrors = case res of
          FormFailure [e] -> Just $ toHtml e
          _ -> Nothing
      , fvRequired = True
      }
    ])

formResultModal :: (MonadHandler m, RedirectUrl (HandlerSite m) route) => FormResult a -> route -> (a -> WriterT [Message] m ()) -> m ()
formResultModal res finalDest handler = maybeT_ $ do
  messages <- case res of
    FormMissing -> mzero
    FormFailure errs -> mapM_ (addMessage Error . toHtml) errs >> mzero
    FormSuccess val -> lift . execWriterT $ handler val

  isModal <- hasCustomHeader HeaderIsModal
  if
    | isModal   -> sendResponse $ toJSON messages
    | otherwise -> do
        forM_ messages $ \Message{..} -> addMessage messageClass messageContent
        redirect finalDest