{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# 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.State.Class (MonadState(..))
import Control.Monad.Trans.RWS (RWST, execRWST, mapRWST)
import Control.Monad.Trans.Except (ExceptT, runExceptT)
import Control.Monad.Fix (MonadFix)
import Control.Monad.Morph (MFunctor(..))

import Data.List ((!!))

import Control.Lens

import Web.PathPieces

import Data.UUID

import Data.Ratio ((%))
import Data.Fixed
import Data.Scientific

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

import Data.Proxy

import Text.HTML.SanitizeXSS (sanitizeBalance)
import Text.Blaze (preEscapedText)
import Text.Blaze.Html.Renderer.Pretty (renderHtml)




--------------------
-- 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
  | FIDAssignSubmissions
  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


-- | generate a form that only shows a finite amount of buttons
buttonForm :: (Button site a, Finite a) => Html -> MForm (HandlerT site IO) (FormResult a, WidgetT site IO ())
buttonForm = buttonForm' universeF

-- | like `buttonForm`, but for a given list of buttons, i.e. a subset or for buttons outside the Finite typeclass
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}
    |])

-- | buttons-only form complete with widget-generation and evaluation; return type determines buttons shown.
runButtonForm ::(PathPiece ident, Eq ident, RenderMessage site FormMessage,
                Button site ButtonSubmit, Button site a, Finite a)
  => ident -> HandlerT site IO (WidgetT site IO (), Maybe a)
runButtonForm fid = do
  currentRoute <- getCurrentRoute
  ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid buttonForm
  let btnForm = wrapForm btnWdgt def  { formAction = SomeRoute <$> currentRoute
                                      , formEncoding = btnEnctype
                                      , formSubmit = FormNoSubmit
                                      }
  res <- formResultMaybe btnResult (return . Just)
  return (btnForm, res)

-- | like `runButtonForm` but showing only a given list of buttons, especially for buttons that are not in the Finite typeclass.
runButtonForm' ::(PathPiece ident, Eq ident, RenderMessage site FormMessage,
                Button site ButtonSubmit, Button site a)
  => [a] -> ident -> HandlerT site IO (WidgetT site IO (), Maybe a)
runButtonForm' btns fid = do
  currentRoute <- getCurrentRoute
  ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid $ buttonForm' btns
  let btnForm = wrapForm btnWdgt def  { formAction = SomeRoute <$> currentRoute
                                      , formEncoding = btnEnctype
                                      , formSubmit = FormNoSubmit
                                      }
  res <- formResultMaybe btnResult (return . Just)
  return (btnForm, res)


-------------------
-- 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

fractionalField :: forall m a.
                   ( RealFrac a
                   , Monad m
                   , RenderMessage (HandlerSite m) FormMessage
                   ) => Field m a
-- | Form `Field` for any `Fractional` number
--
-- Use more specific `Field`s (i.e. `fixedPrecField`) whenever they exist
fractionalField = Field{..}
  where
    scientific' :: Iso' a Scientific
    scientific' = iso (fromRational . toRational) (fromRational . toRational)
    
    fieldEnctype = UrlEncoded
    fieldView theId name attrs (fmap $ view scientific' -> val) isReq
      = [whamlet|
          $newline never
          <input id=#{theId} name=#{name} *{attrs} type=number :isReq:required value=#{either id (pack . formatScientific Fixed Nothing) val}>
        |]
    fieldParse = parseHelper $ \t ->
      maybe (Left $ MsgInvalidNumber t) (Right . review scientific') (readMay t :: Maybe Scientific)

fixedPrecField :: forall m p.
                  ( Monad m
                  , RenderMessage (HandlerSite m) FormMessage
                  , HasResolution p
                  ) => Field m (Fixed p)
fixedPrecField = Field{..}
  where
    resolution' :: Integer
    resolution' = resolution $ Proxy @p

    step = showFixed True (fromRational $ 1 % resolution' :: Fixed p)
    
    fieldEnctype = UrlEncoded
    fieldView theId name attrs val isReq
      = [whamlet|
          $newline never
          <input id=#{theId} name=#{name} *{attrs} type=number step=#{step} :isReq:required value=#{either id (pack . showFixed True) val}>
        |]
    fieldParse = parseHelper $ \t -> do
      sci <- maybe (Left $ MsgInvalidNumber t) Right (readMay t :: Maybe Scientific)
      return . fromRational $ round (sci * fromIntegral resolution') % resolution'

rationalField :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage) => Field m Rational
rationalField = fractionalField

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

htmlFieldSmall :: forall m. (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m Html
htmlFieldSmall = checkMMap sanitize (pack . renderHtml) textField
  where
    sanitize :: Text -> m (Either FormMessage Html)
    sanitize = return . Right . preEscapedText . sanitizeBalance

-----------
-- 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"

-- | special id to identify form messages, see 'aformMessage' and 'formMessage'
--   currently only treated by form generation through 'renderAForm'
idFormMessageNoinput :: Text
idFormMessageNoinput = "form-message-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)
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 }


-- | Similar to aformSection, generates a form having just a view widget, but no input.
--   Currently only correctly rendered by 'renderAForm' and mforms using 'widget/form.hamlet'
--   Usage:
--   @
--      (,) <$  formMessage (Message Info html1)
--          <*> areq intField "int here" Nothing
--          <*  formSection (Message Warning html2)
--          <*> areq doubleField "double there " Nothing
--          <*  submitButton
--   @

aformMessage :: (MonadHandler m) => Message -> AForm m ()
aformMessage = formToAForm . fmap (second pure) . formMessage

wformMessage :: (MonadHandler m) => Message -> WForm m ()
wformMessage = void . aFormToWForm . aformMessage

formMessage :: (MonadHandler m) => Message -> MForm m (FormResult (), FieldView site)
formMessage Message{..} = do
    return (FormSuccess (), FieldView
      { fvLabel    = mempty
      , fvTooltip  = Nothing
      , fvId       = idFormMessageNoinput
      , fvErrors   = Nothing
      , fvRequired = False
      , fvInput    = [whamlet|<div .notification .notification-#{toPathPiece messageStatus}>#{messageContent}|]
      })

---------------------
-- 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'

-- | Turn form errors into alerts, but otherwise do nothing at all
formFailure2Alerts :: MonadHandler m => FormResult a -> m ()
formFailure2Alerts = flip formResult $ const $ return ()

-- | 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 = fmap formResult' . runInputGetResult
runInputPostMaybe = fmap formResult' . runInputPostResult
runInputMaybe form = runMaybeT $ MaybeT (runInputPostMaybe form) <|> MaybeT (runInputGetMaybe form)

runInputResult :: MonadHandler m => FormInput m a -> m (FormResult a)
runInputResult form = do
  postRes <- runInputPostResult form
  getRes  <- runInputGetResult form
  return $ case (postRes, getRes) of
    (FormSuccess a, _) -> FormSuccess a
    (_, FormSuccess b) -> FormSuccess b
    (postRes', _)      -> postRes'

runInput :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage) => FormInput m a -> m a
runInput = runInputResult >=> \case
  FormFailure errs -> invalidArgs errs
  FormMissing      -> invalidArgsI [MsgValueRequired]
  FormSuccess a    -> return a

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

newtype FormValidator r m a = FormValidator { unFormValidator :: RWST () [SomeMessage (HandlerSite m)] r m a }

deriving newtype instance Functor m => Functor (FormValidator r m)
deriving newtype instance Monad m => Applicative (FormValidator r m)
deriving newtype instance Monad m => Monad (FormValidator r m)
deriving newtype instance Monad m => MonadState r (FormValidator r m)
deriving newtype instance MonadFix m => MonadFix (FormValidator r m)
instance MonadTrans (FormValidator r) where
  lift = FormValidator . lift

validateForm :: MonadHandler m
             => FormValidator a m ()
             -> (Markup -> MForm m (FormResult a, xml))
             -> (Markup -> MForm m (FormResult a, xml))
validateForm valF form csrf = do
  (res, xml) <- form csrf
  res' <- for res $ lift . execRWST (unFormValidator valF) ()
  (, xml) <$> case res' of
    FormSuccess (x, []  ) -> return $ FormSuccess x
    FormSuccess (_, msgs) -> formFailure msgs
    FormMissing           -> return FormMissing
    FormFailure errs      -> return $ FormFailure errs

validateFormDB :: ( MonadHandler m
                  , YesodPersist (HandlerSite m)
                  )
               => FormValidator a (YesodDB (HandlerSite m)) ()
               -> (Markup -> MForm m (FormResult a, xml))
               -> (Markup -> MForm m (FormResult a, xml))
validateFormDB (FormValidator valF) = validateForm . FormValidator $ hoist (liftHandlerT . runDB) valF

tellValidationError :: ( MonadHandler m
                       , RenderMessage (HandlerSite m) msg
                       )
                    => msg -> FormValidator r m ()
tellValidationError = FormValidator . tell . pure . SomeMessage

guardValidation :: ( MonadHandler m
                   , RenderMessage (HandlerSite m) msg
                   )
                => msg -> Bool -> FormValidator r m ()
guardValidation _   False = return ()
guardValidation msg True  = tellValidationError msg

guardValidationM :: ( MonadHandler m
                    , RenderMessage (HandlerSite m) msg
                    )
                 => msg -> m Bool -> FormValidator r m ()
guardValidationM = (. lift) . (=<<) . guardValidation

-----------------------
-- 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 $ over _2 pure <$> mforced field settings val

mpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
      => Field m a -> FieldSettings site -> Maybe a -> MForm m (FormResult a, FieldView site)
-- ^ Pseudo required
--
-- `FieldView` has `fvRequired` set to `True` and @FormSuccess Nothing@ is cast to `FormFailure`.
-- Otherwise acts exactly like `mopt`.
mpreq f fs mx = do
  mr <- getMessageRender
  (res, fv) <- mopt f fs (Just <$> mx)
  let fv' = fv { fvRequired = True }
  return $ case res of
    FormSuccess (Just res')
      -> (FormSuccess res', fv')
    FormSuccess Nothing
      -> (FormFailure [mr MsgValueRequired], fv' { fvErrors = Just . toHtml $ mr MsgValueRequired })
    FormFailure errs
      -> (FormFailure errs, fv')
    FormMissing
      -> (FormMissing, fv')

apreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
      => Field m a -> FieldSettings site -> Maybe a -> AForm m a
apreq f fs mx = formToAForm $ over _2 pure <$> mpreq f fs 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 $ mpreq f fs mx