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

import Utils.Form

import Handler.Utils.Form.Types
import Handler.Utils.Templates

import Handler.Utils.DateTime
import qualified Data.Time as Time

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

import Data.CaseInsensitive (CI)
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 qualified Database.Esqueleto.Internal.Sql 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 Data.Maybe (fromJust)

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

$(return [])

instance PathPiece BtnSubmitDelete where
  toPathPiece = $(nullaryToPathPiece ''BtnSubmitDelete [ T.intercalate "-" . drop 1 . splitCamel ])
  fromPathPiece = finiteFromPathPiece


-- -- 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 = do
          [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

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


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 = selectFieldList
  [ (MsgUploadModeNone    , NoUpload      )
  , (MsgUploadModeNoUnpack, Upload   False)
  , (MsgUploadModeUnpack  , Upload   True )
  ]

submissionModeField :: Field Handler SheetSubmissionMode
submissionModeField = selectFieldList
  [ (MsgSheetNoSubmission, NoSubmissions)
  , (MsgSheetCorrectorSubmissions, CorrectorSubmissions)
  , (MsgSheetUserSubmissions, UserSubmissions)
  ]

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

instance Universe SheetType'
instance Finite SheetType'

$(return [])

instance PathPiece SheetType' where
  toPathPiece = $(nullaryToPathPiece ''SheetType' [intercalate "-" . splitCamel , fromJust . stripSuffix "'"])
  fromPathPiece = finiteFromPathPiece

instance RenderMessage UniWorX SheetType' where
  renderMessage f ls = \case
    Bonus' -> render MsgSheetTypeBonus
    Normal' -> render MsgSheetTypeNormal
    Pass' -> render MsgSheetTypePass
    NotGraded' -> render MsgSheetTypeNotGraded
    where
      render = renderMessage f ls

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

instance Universe SheetGroup'
instance Finite SheetGroup'

$(return [])

instance PathPiece SheetGroup' where
  toPathPiece = $(nullaryToPathPiece ''SheetGroup' [intercalate "-" . splitCamel , fromJust . stripSuffix "'"])
  fromPathPiece = finiteFromPathPiece

instance RenderMessage UniWorX SheetGroup' where
  renderMessage f ls = \case
    Arbitrary' -> render MsgSheetGroupArbitrary
    RegisteredGroups' -> render MsgSheetGroupRegisteredGroups
    NoGroups' -> render MsgSheetGroupNoGroups
    where
      render = renderMessage f ls

sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType
sheetTypeAFormReq FieldSettings{..} template = formToAForm $ do
  let
    selOptions = Map.fromList
      [ ( Bonus', Bonus <$> maxPointsReq )
      , ( Normal', Normal <$> maxPointsReq )
      , ( Pass', Pass
          <$> maxPointsReq
          <*> apreq pointsField (fslpI MsgSheetTypePassingPoints "Punkte" & noValidate) (preview _passingPoints =<< template)
        )
      , ( NotGraded', pure NotGraded )
      ]
  (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
    maxPointsReq = apreq pointsField (fslpI MsgSheetTypeMaxPoints "Punkte" & noValidate) (preview _maxPoints =<< template)
    
    classify' :: SheetType -> SheetType'
    classify' = \case
      Bonus _ -> Bonus'
      Normal _ -> Normal'
      Pass _ _ -> Pass'
      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 time _))     -> Right time
        (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


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

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

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
  fmap (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
  fmap (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
      }
    ])