module Handler.Utils.Form
  ( module Handler.Utils.Form
  , module Utils.Form
  ) 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 Web.PathPieces (showToPathPiece, readFromPathPiece)

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.Writer.Class

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

import Utils.Lens

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

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

instance PathPiece BtnDelete where    -- for displaying the button only, not really for paths
  toPathPiece   = showToPathPiece
  fromPathPiece = readFromPathPiece

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

  cssClass BtnDelete = BCDanger
  cssClass BtnAbort  = BCDefault

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

instance PathPiece RegisterButton where
  toPathPiece   = showToPathPiece
  fromPathPiece = readFromPathPiece

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 PathPiece AdminHijackUserButton where
  toPathPiece   = showToPathPiece
  fromPathPiece = readFromPathPiece

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

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' = Bonus' | Normal' | Informational' | NotGraded'
  deriving (Eq, Ord, Read, Show, Enum, Bounded)

instance Universe SheetType'
instance Finite SheetType'

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


data SheetGroup' = Arbitrary' | RegisteredGroups' | NoGroups'
  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
      [ ( Bonus' , Bonus  <$> gradingReq )
      , ( Normal', Normal <$> 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


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

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 => FormResult a -> (a -> m ()) -> m ()
formResultModal res handler = do
  formResult res handler
  whenM (hasCustomHeader HeaderIsModal) $ do
    messages <- mapM (\(cl, co) -> maybe (throwM $ UnknownMessageClass cl) (return . flip Message co) $ fromPathPiece cl) =<< getMessages
    sendResponse $ toJSON messages