    {-# LANGUAGE OverloadedStrings, ScopedTypeVariables, TypeFamilies #-}
    module Text.Reform.Blaze.Common where

    import Data.Monoid (mconcat, mempty, (<>))
    import Data.Text.Lazy (Text)
    import Text.Reform.Backend
    import Text.Reform.Core
    import Text.Reform.Generalized as G
    import Text.Reform.Result (FormId, Result(Ok), unitRange)
    import Text.Blaze.Html (Html, (!), toValue)
    import qualified Text.Blaze.Html5  as H
    import Text.Blaze.Html5.Attributes (type_, name, value)
    import qualified Text.Blaze.Html5.Attributes as A

    instance H.ToValue FormId where
        toValue fid = toValue (show fid)

    inputText :: (Monad m, FormError error, H.ToValue text) =>
                 (input -> Either error text)
              -> text
              -> Form m input error Html () text
    inputText getInput initialValue = G.input getInput inputField initialValue
        where
          inputField i a = H.input ! type_ "text" ! A.id (toValue i) ! name (toValue i) ! value (toValue a)

    inputPassword :: (Monad m, FormError error, H.ToValue text) =>
                 (input -> Either error text)
              -> text
              -> Form m input error Html () text
    inputPassword getInput initialValue = G.input getInput inputField initialValue
        where
          inputField i a = H.input ! type_ "password" ! A.id (toValue i) ! name (toValue i) ! value (toValue a)

    inputSubmit :: (Monad m, FormError error, H.ToValue text) =>
                 (input -> Either error text)
              -> text
              -> Form m input error Html () (Maybe text)
    inputSubmit getInput initialValue = G.inputMaybe getInput inputField initialValue
        where
          inputField i a = H.input ! type_ "submit" ! A.id (toValue i) ! name (toValue i) ! value (toValue a)

    inputReset :: (Monad m, FormError error, H.ToValue text) =>
                  text
               -> Form m input error Html () ()
    inputReset lbl = G.inputNoData inputField lbl
        where
          inputField i a = H.input ! type_ "submit" ! A.id (toValue i) ! name (toValue i) ! value (toValue a)

    inputHidden :: (Monad m, FormError error, H.ToValue text) =>
                 (input -> Either error text)
              -> text
              -> Form m input error Html () text
    inputHidden getInput initialValue = G.input getInput inputField initialValue
        where
          inputField i a = H.input ! type_ "hidden" ! A.id (toValue i) ! name (toValue i) ! value (toValue a)

    inputButton :: (Monad m, FormError error, H.ToValue text) =>
                 text
              -> Form m input error Html () ()
    inputButton label = G.inputNoData inputField label
        where
          inputField i a = H.input ! type_ "button" ! A.id (toValue i) ! name (toValue i) ! value (toValue a)

    textarea :: (Monad m, FormError error, H.ToMarkup text) =>
                (input -> Either error text)
             -> Int    -- ^ cols
             -> Int    -- ^ rows
             -> text   -- ^ initial text
             -> Form m input error Html () text
    textarea getInput cols rows initialValue = G.input getInput textareaView initialValue
        where
          textareaView i txt =
              H.textarea ! A.rows (toValue rows)
                         ! A.cols (toValue cols)
                         ! A.id   (toValue i)
                         ! A.name (toValue i) $
                   H.toHtml txt

    -- | Create an @\<input type=\"file\"\>@ element
    --
    -- This control may succeed even if the user does not actually select a file to upload. In that case the uploaded name will likely be \"\" and the file contents will be empty as well.
    inputFile :: (Monad m, FormError error, FormInput input, ErrorInputType error ~ input) =>
                 Form m input error Html () (FileType input)
    inputFile = G.inputFile fileView
        where
          fileView i = H.input ! type_ "file" ! A.id (toValue i) ! name (toValue i)

    -- | Create a @\<button type=\"submit\"\>@ element
    buttonSubmit :: (Monad m, FormError error, H.ToValue text, H.ToMarkup children) =>
                    (input -> Either error text)
                 -> text
                 -> children
                 -> Form m input error Html () (Maybe text)
    buttonSubmit getInput text c = G.inputMaybe getInput inputField text
        where
          inputField i a = H.button ! type_ "submit" ! A.id (toValue i) ! name (toValue i) ! value (toValue a) $ H.toHtml c

    -- | create a  @\<button type=\"reset\"\>\<\/button\>@ element
    --
    -- This element does not add any data to the form data set.
    buttonReset :: (Monad m, FormError error, H.ToMarkup children) =>
                   children
                 -> Form m input error Html () ()
    buttonReset c = G.inputNoData inputField Nothing
        where
          inputField i a = H.button ! type_ "reset" ! A.id (toValue i) ! name (toValue i) $ H.toHtml c

    -- | create a  @\<button type=\"button\"\>\<\/button\>@ element
    --
    -- This element does not add any data to the form data set.
    button :: (Monad m, FormError error, H.ToMarkup children) =>
              children
           -> Form m input error Html () ()
    button c = G.inputNoData inputField Nothing
        where
          inputField i a = H.button ! type_ "button" ! A.id (toValue i) ! name (toValue i) $ H.toHtml c

    -- | create a @\<label\>@ element.
    --
    -- Use this with <++ or ++> to ensure that the @for@ attribute references the correct @id@.
    --
    -- > label "some input field: " ++> inputText ""
    label :: (Monad m, H.ToMarkup children) =>
             children
          -> Form m input error Html () ()
    label c = G.label mkLabel
        where
          mkLabel i = H.label ! A.for (toValue i) $ H.toHtml c

    -- | Create a single @\<input type=\"checkbox\"\>@ element
    --
    -- returns a 'Bool' indicating if it was checked or not.
    --
    -- see also 'inputCheckboxes'
    -- FIXME: Should this built on something in Generalized?
    inputCheckbox :: forall x error input m. (Monad m, FormInput input, FormError error, ErrorInputType error ~ input) =>
                       Bool  -- ^ initially checked
                    -> Form m input error Html () Bool
    inputCheckbox initiallyChecked =
        Form $
          do i <- getFormId
             v <- getFormInput' i
             case v of
               Default   -> mkCheckbox i initiallyChecked
               Missing   -> mkCheckbox i False -- checkboxes only appear in the submitted data when checked
               (Found input) ->
                   case getInputString input of
                     (Right _) -> mkCheckbox i True
                     (Left  (e :: error) ) -> mkCheckbox i False
        where
          mkCheckbox i checked =
              let checkbox  = H.input ! type_ "checkbox" ! A.id (toValue i) ! name (toValue i) ! value (toValue i)
                  checkbox' = if checked then checkbox ! A.checked "checked" else checkbox
              in
              return ( View $ const $  checkbox'
                     , return $ Ok (Proved { proofs   = ()
                                           , pos      = unitRange i
                                           , unProved = if checked then True else False
                                           })
                     )

    -- | Create a group of @\<input type=\"checkbox\"\>@ elements
    --
    inputCheckboxes :: (Functor m, Monad m, FormError error, ErrorInputType error ~ input, FormInput input, H.ToMarkup lbl) =>
                      [(a, lbl)]  -- ^ value, label, initially checked
                    -> (a -> Bool) -- ^ function which indicates if a value should be checked initially
                    -> Form m input error Html () [a]
    inputCheckboxes choices isChecked =
        G.inputMulti choices mkCheckboxes isChecked
        where
          mkCheckboxes nm choices' = mconcat $ concatMap (mkCheckbox nm) choices'
          mkCheckbox nm (i, val, lbl, checked) =
              [ ((if checked then (! A.checked "checked") else id) $
                         H.input ! type_ "checkbox" ! A.id (toValue i) ! name (toValue nm) ! value (toValue val))
                      ,  H.label ! A.for (toValue i) $ H.toHtml lbl
                      ]

    -- | Create a group of @\<input type=\"radio\"\>@ elements
    inputRadio :: (Functor m, Monad m, FormError error, ErrorInputType error ~ input, FormInput input, H.ToMarkup lbl) =>
                  [(a, lbl)]  -- ^ value, label, initially checked
               -> (a -> Bool) -- ^ isDefault
               -> Form m input error Html () a
    inputRadio choices isDefault =
        G.inputChoice isDefault choices mkRadios
        where
          mkRadios nm choices' = mconcat $ concatMap (mkRadio nm) choices'
          mkRadio nm (i, val, lbl, checked) =
              [ ((if checked then (! A.checked "checked") else id) $
                 H.input ! type_ "radio" ! A.id (toValue i) ! name (toValue nm) ! value (toValue val))
              ,  H.label ! A.for (toValue i) $ H.toHtml lbl
              ,  H.br
              ]

    -- | create @\<select\>\<\/select\>@ element plus its @\<option\>\<\/option\>@ children.
    --
    -- see also: 'selectMultiple'
    select :: (Functor m, Monad m, FormError error, ErrorInputType error ~ input, FormInput input, H.ToMarkup lbl) =>
                  [(a, lbl)]  -- ^ value, label
               -> (a -> Bool) -- ^ isDefault, must match *exactly one* element in the list of choices
               -> Form m input error Html () a
    select choices isDefault  =
        G.inputChoice isDefault choices mkSelect
        where
          mkSelect nm choices' =
              H.select ! name (toValue nm) $
               mconcat $ map mkOption choices'

          mkOption (_, val, lbl, selected) =
              (if selected then (! A.selected "selected") else id)
                 H.option ! value (toValue val) $ H.toHtml lbl

    -- | create @\<select multiple=\"multiple\"\>\<\/select\>@ element plus its @\<option\>\<\/option\>@ children.
    --
    -- This creates a @\<select\>@ element which allows more than one item to be selected.
    selectMultiple :: (Functor m, Monad m, FormError error, ErrorInputType error ~ input, FormInput input, H.ToMarkup lbl) =>
                      [(a, lbl)]  -- ^ value, label, initially checked
                   -> (a -> Bool)  -- ^ isSelected initially
                   -> Form m input error Html () [a]
    selectMultiple choices isSelected =
        G.inputMulti choices mkSelect isSelected
        where
          mkSelect nm choices' =
              H.select ! name (toValue nm) ! A.multiple "multiple" $
               mconcat $ map mkOption choices'

          mkOption (_, val, lbl, selected) =
            (if selected then (! A.selected "selected") else id)
                 H.option ! value (toValue val) $ H.toHtml lbl

    {-
    inputMultiSelectOptGroup :: (Functor m, XMLGenerator x, EmbedAsChild x groupLbl, EmbedAsChild x lbl, EmbedAsAttr x (Attr String FormId), FormError error, ErrorInputType error ~ input, FormInput input, Monad m) =>
                       [(groupLbl, [(a, lbl, Bool)])]  -- ^ value, label, initially checked
                    -> Form m input error Html () [a]
    inputMultiSelectOptGroup choices =
        G.inputMulti choices mkSelect
        where
          mkSelect nm choices' =
              [<select name=nm multiple="multiple">
                <% mapM mkOptGroup choices' %>
               </select>
              ]
          mkOptGroup (grpLabel, options) =
              <optgroup label=grpLabel>
               <% mapM mkOption options %>
              </optgroup>
          mkOption (_, val, lbl, selected) =
              <option value=val (if selected then ["selected" := "selected"] else [])>
               <% lbl %>
              </option>
    -}

    -- | create a @\<ul\>@ which contains all the errors related to the 'Form'.
    --
    -- The @<\ul\>@ will have the attribute @class=\"reform-error-list\"@.
    errorList :: (Monad m, H.ToMarkup error) =>
                 Form m input error Html () ()
    errorList = G.errors mkErrors
        where
          mkErrors []   = mempty
          mkErrors errs =
              H.ul ! A.class_ "reform-error-list" $
                 mconcat $ map mkError errs
          mkError e     = H.li $ H.toHtml e

    -- | create a @\<ul\>@ which contains all the errors related to the 'Form'.
    --
    -- Includes errors from child forms.
    --
    -- The @<\ul\>@ will have the attribute @class=\"reform-error-list\"@.
    childErrorList :: (Monad m, H.ToMarkup error) =>
                 Form m input error Html () ()
    childErrorList = G.childErrors mkErrors
        where
          mkErrors []   = mempty
          mkErrors errs =
              H.ul ! A.class_ "reform-error-list" $
                 mconcat $ map mkError errs
          mkError e     = H.li $ H.toHtml e

    -- | create a @\<br\>@ tag.
    br :: (Monad m) => Form m input error Html () ()
    br = view H.br

    -- | wrap a @\<fieldset class=\"reform\"\>@ around a 'Form'
    --
    fieldset :: (Monad m, Functor m) =>
                Form m input error Html proof a
             -> Form m input error Html proof a
    fieldset frm = mapView (H.fieldset ! A.class_ "reform") frm

    -- | wrap an @\<ol class=\"reform\"\>@ around a 'Form'
    ol :: (Monad m, Functor m) =>
          Form m input error Html proof a
       -> Form m input error Html proof a
    ol frm = mapView (H.ol ! A.class_ "reform") frm

    -- | wrap a @\<ul class=\"reform\"\>@ around a 'Form'
    ul :: (Monad m, Functor m) =>
          Form m input error Html proof a
       -> Form m input error Html proof a
    ul frm = mapView (H.ul ! A.class_ "reform") frm

    -- | wrap a @\<li class=\"reform\"\>@ around a 'Form'
    li :: (Monad m, Functor m) =>
          Form m input error Html proof a
       -> Form m input error Html proof a
    li frm = mapView (H.li ! A.class_ "reform") frm

    -- | create @\<form action=action method=\"POST\" enctype=\"multipart/form-data\"\>@
    form :: (H.ToValue action) =>
            action                  -- ^ action url
         -> [(Text, Text)]       -- ^ hidden fields to add to form
         -> Html -- ^ children
         -> Html
    form action hidden children =
        H.form ! A.action (toValue action) ! A.method "POST" ! A.enctype "multipart/form-data" $
             ((mconcat $ map mkHidden hidden) <> children)
          where
            mkHidden (nm, val) =
                H.input ! type_ "hidden" ! name (toValue nm) ! value (toValue val)

    -- | add an attribute to the 'Html' for a form element.
    setAttr :: (Monad m, Functor m) =>
               Form m input error Html proof a
             -> H.Attribute
             -> Form m input error Html proof a
    setAttr form attr = mapView (\e -> e ! attr) form