{-# language OverloadedStrings #-}
{-# language TypeOperators #-}

{- | Functions for creating and composing forms.
-}

module FlexTask.FormUtil
  (
  -- * Functions for Rendered
    ($$>)
  , addCss
  , addJs
  , addCssAndJs
  , applyToWidget
  -- * Convenience functions for Yesod FieldSettings
  , addAttribute
  , addAttributes
  , addCssClass
  , addNameAndCssClass
  , readOnly
  -- * Convenience for internationalization
  , universalLabel
  , showToUniversalLabel
  -- * functions for custom forms
  , newFlexId
  , newFlexName
  , repeatFlexName
  -- * debugging
  , printWidget
  ) where


import Data.Containers.ListUtils       (nubOrd)
import Data.List.Extra                 (isInfixOf, isPrefixOf, trimEnd, splitOn)
import Data.String                     (fromString)
import Data.Text                       (Text, pack)
import Data.Tuple.Extra                (second)
import Text.Cassius                    (Css)
import Text.Julius                     (Javascript)
import Yesod
import Yesod.Core.Types                (RY)

import qualified Control.Monad.Trans.RWS as RWS   (get)
import qualified Data.Map                as M     (lookup)
import qualified Data.Text               as T     (replace)

import FlexTask.ConvertForm            (getFormData)
import FlexTask.YesodConfig (
  FlexForm(..),
  Handler,
  Rendered,
  Rendered',
  Widget,
  )



{- $setup
>>> :set -XOverloadedStrings
>>> :set -XQuasiQuotes
>>> :set -XTypeApplications
>>> import FlexTask.Generic.Form
>>> let myForm = formify (Nothing @Int) [[single "input"]]
>>> let myOtherForm = formify (Nothing @String) [[single "input2"]]
-}


{- |
Compose two forms sequentially.
The result contains all fields from both input forms.
This is used to compose `FlexTask.Generic.Form.formify` generated forms with custom ones.

Note that forms generated by `FlexTask.Generic.Form.formify` will always be wrapped in an outer \<div\> tag.
This means composing such a form with something else results in a line break.
You may circumvent this via CSS rules on the 'flex-form-div' class.

=== __Example__

>>> printWidget "de" $ myForm $$> myOtherForm
<div class="flex-form-div form-group">
...
    <label for="flexident1">
      ...
    </label>
...
</div>
<div class="flex-form-div form-group">
...
    <label for="flexident2">
      ...
    </label>
...
</div>
-}
infixr 0 $$>
($$>)
  :: (Monad w, Monad m)
  => Rendered' m (w a)
  -> Rendered' m (w b)
  -> Rendered' m (w b)
Rendered' m (w a)
f1 $$> :: forall (w :: * -> *) (m :: * -> *) a b.
(Monad w, Monad m) =>
Rendered' m (w a) -> Rendered' m (w b) -> Rendered' m (w b)
$$> Rendered' m (w b)
f2 = do
    res1 <- Rendered' m (w a)
m (RWST
     (Maybe (Env, FileEnv), FlexForm, [Lang])
     Enctype
     Ints
     Handler
     ([[Lang]], w a))
f1
    res2 <- f2
    pure $ do
      (names1,wid1) <- res1
      (names2,wid2) <- res2
      pure (nubOrd $ names1 ++ names2, wid1 >> wid2)


{- |
Apply some function to the embedded `Widget` of a `Rendered` value.
This can be used to alter the form HTML after using `FlexTask.Generic.Form.formify`,
e.g. if some custom text is to be included with the element.

==== __Example__

>>> printWidget "de" $ applyToWidget ([whamlet| <h1>Insert me at once!|] >>) myForm
<h1>
  Insert me at once!
</h1>
<div class="flex-form-div form-group">
...
</div>
-}
applyToWidget :: Functor m => (w -> w') -> Rendered' m w -> Rendered' m w'
applyToWidget :: forall (m :: * -> *) w w'.
Functor m =>
(w -> w') -> Rendered' m w -> Rendered' m w'
applyToWidget w -> w'
f Rendered' m w
form = (([[Lang]], w) -> ([[Lang]], w'))
-> RWST
     (Maybe (Env, FileEnv), FlexForm, [Lang])
     Enctype
     Ints
     Handler
     ([[Lang]], w)
-> RWST
     (Maybe (Env, FileEnv), FlexForm, [Lang])
     Enctype
     Ints
     Handler
     ([[Lang]], w')
forall a b.
(a -> b)
-> RWST
     (Maybe (Env, FileEnv), FlexForm, [Lang]) Enctype Ints Handler a
-> RWST
     (Maybe (Env, FileEnv), FlexForm, [Lang]) Enctype Ints Handler b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((w -> w') -> ([[Lang]], w) -> ([[Lang]], w')
forall b b' a. (b -> b') -> (a, b) -> (a, b')
second w -> w'
f) (RWST
   (Maybe (Env, FileEnv), FlexForm, [Lang])
   Enctype
   Ints
   Handler
   ([[Lang]], w)
 -> RWST
      (Maybe (Env, FileEnv), FlexForm, [Lang])
      Enctype
      Ints
      Handler
      ([[Lang]], w'))
-> m (RWST
        (Maybe (Env, FileEnv), FlexForm, [Lang])
        Enctype
        Ints
        Handler
        ([[Lang]], w))
-> m (RWST
        (Maybe (Env, FileEnv), FlexForm, [Lang])
        Enctype
        Ints
        Handler
        ([[Lang]], w'))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rendered' m w
m (RWST
     (Maybe (Env, FileEnv), FlexForm, [Lang])
     Enctype
     Ints
     Handler
     ([[Lang]], w))
form


addContent
  :: (ToWidget FlexForm (render -> a), Functor m)
  => (render -> a)
  -> Rendered' m Widget
  -> Rendered' m Widget
addContent :: forall render a (m :: * -> *).
(ToWidget FlexForm (render -> a), Functor m) =>
(render -> a) -> Rendered' m Widget -> Rendered' m Widget
addContent render -> a
content = (Widget -> Widget) -> Rendered' m Widget -> Rendered' m Widget
forall (m :: * -> *) w w'.
Functor m =>
(w -> w') -> Rendered' m w -> Rendered' m w'
applyToWidget (Widget -> Widget -> Widget
forall a b.
WidgetFor FlexForm a
-> WidgetFor FlexForm b -> WidgetFor FlexForm a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (render -> a) -> Widget
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
forall (m :: * -> *).
(MonadWidget m, HandlerSite m ~ FlexForm) =>
(render -> a) -> m ()
toWidget render -> a
content)


{- |
Add CSS to a form.
Use with `Yesod` Cassius or Lucius Shakespeare quasi quoters.
The content will be inserted in a \<style\> tag at the top of the document.

==== __Example__

>>> printWidget "en" $ addCss [lucius| myClass {margin: 2px}|] myForm
<style>
  myClass{margin:2px}
</style>
<div class="flex-form-div form-group">
...
</div>
-}
addCss
  :: (render ~ RY FlexForm, Functor m)
  => (render -> Css)      -- ^ CSS template
  -> Rendered' m Widget -- ^ Form to add to
  -> Rendered' m Widget
addCss :: forall render (m :: * -> *).
(render ~ RY FlexForm, Functor m) =>
(render -> Css) -> Rendered' m Widget -> Rendered' m Widget
addCss = (render -> Css) -> Rendered' m Widget -> Rendered' m Widget
forall render a (m :: * -> *).
(ToWidget FlexForm (render -> a), Functor m) =>
(render -> a) -> Rendered' m Widget -> Rendered' m Widget
addContent


{- |
Add JavaScript to a form.
Use with `Yesod` Julius Shakespeare quasi quoters.
The content will be inserted in a \<script\> tag at the bottom of the document.

==== __Example__

>>> printWidget "de" $ addJs [julius|myFunc(){ console.log("Hi"); }|] myForm
<div class="flex-form-div form-group">
...
</div>
<script>
  myFunc(){ console.log("Hi"); }
</script>
-}
addJs
  :: (render ~ RY FlexForm, Functor m)
  => (render -> Javascript) -- ^ Javascript template
  -> Rendered' m Widget -- ^ Form to add to
  -> Rendered' m Widget
addJs :: forall render (m :: * -> *).
(render ~ RY FlexForm, Functor m) =>
(render -> Javascript) -> Rendered' m Widget -> Rendered' m Widget
addJs = (render -> Javascript) -> Rendered' m Widget -> Rendered' m Widget
forall render a (m :: * -> *).
(ToWidget FlexForm (render -> a), Functor m) =>
(render -> a) -> Rendered' m Widget -> Rendered' m Widget
addContent


{- |
Like `addCss` and `addJs`, but for including CSS and JavaScript in one step.
-}
addCssAndJs
  :: (render ~ RY FlexForm, Functor m)
  => (render -> Css)        -- ^ CSS template
  -> (render -> Javascript) -- ^ Javascript template
  -> Rendered' m Widget -- ^ Form to add to
  -> Rendered' m Widget
addCssAndJs :: forall render (m :: * -> *).
(render ~ RY FlexForm, Functor m) =>
(render -> Css)
-> (render -> Javascript)
-> Rendered' m Widget
-> Rendered' m Widget
addCssAndJs render -> Css
css render -> Javascript
js = (Widget -> Widget) -> Rendered' m Widget -> Rendered' m Widget
forall (m :: * -> *) w w'.
Functor m =>
(w -> w') -> Rendered' m w -> Rendered' m w'
applyToWidget ((Widget -> Widget -> Widget
forall a b.
WidgetFor FlexForm a
-> WidgetFor FlexForm b -> WidgetFor FlexForm a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (render -> Css) -> Widget
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
forall (m :: * -> *).
(MonadWidget m, HandlerSite m ~ FlexForm) =>
(render -> Css) -> m ()
toWidget render -> Css
css) (Widget -> Widget) -> (Widget -> Widget) -> Widget -> Widget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Widget -> Widget -> Widget
forall a b.
WidgetFor FlexForm a
-> WidgetFor FlexForm b -> WidgetFor FlexForm a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (render -> Javascript) -> Widget
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
forall (m :: * -> *).
(MonadWidget m, HandlerSite m ~ FlexForm) =>
(render -> Javascript) -> m ()
toWidget render -> Javascript
js))


{- |
Directly create a Yesod FieldSettings with this name and CSS Class.

Using the `IsString` instance of `FieldSettings a` only sets the label.
The name is then auto generated.
Useful when writing a custom form to group multiple inputs.

==== __Example__

>>> addNameAndCssClass "testSettings" "nav" :: FieldSettings FlexForm
FieldSettings {..., fsName = Just "testSettings", fsAttrs = [("class","nav")]}
-}
addNameAndCssClass :: Text -> Text -> FieldSettings app
addNameAndCssClass :: forall app. Lang -> Lang -> FieldSettings app
addNameAndCssClass Lang
name Lang
cssClass = FieldSettings app
forall {master}. FieldSettings master
addFieldAttrs
  where
    fSettings :: FieldSettings site
fSettings = Lang -> FieldSettings site
forall site msg.
RenderMessage site msg =>
msg -> FieldSettings site
fieldSettingsLabel Lang
name
    addFieldAttrs :: FieldSettings master
addFieldAttrs = FieldSettings master
forall {master}. FieldSettings master
fSettings {
      fsName = Just name,
      fsAttrs = addClass cssClass $ fsAttrs fSettings
      }


{- |
Add an attribute-value pair to the given FieldSettings.

==== __Example__

>>> addAttribute ("type","hidden") "testSettings" :: FieldSettings FlexForm
FieldSettings {fsLabel = (German: "testSettings", English: "testSettings"), ..., fsAttrs = [("type","hidden")]}
-}
addAttribute :: (Text,Text) -> FieldSettings app -> FieldSettings app
addAttribute :: forall app. (Lang, Lang) -> FieldSettings app -> FieldSettings app
addAttribute (Lang, Lang)
attribute FieldSettings app
fs =  FieldSettings app
fs { fsAttrs = attribute : fsAttrs fs}


-- | Add a list of attribute-value pairs to the given FieldSettings.
addAttributes :: [(Text,Text)] -> FieldSettings app -> FieldSettings app
addAttributes :: forall app.
[(Lang, Lang)] -> FieldSettings app -> FieldSettings app
addAttributes [(Lang, Lang)]
as FieldSettings app
fs =  FieldSettings app
fs { fsAttrs = as ++ fsAttrs fs}


{- |
Add a CSS class to the given FieldSettings.

==== __Example__

>>> addCssClass "nav" "testSettings" :: FieldSettings FlexForm
FieldSettings {fsLabel = (German: "testSettings", English: "testSettings"), ..., fsAttrs = [("class","nav")]}
-}
addCssClass :: Text -> FieldSettings app -> FieldSettings app
addCssClass :: forall app. Lang -> FieldSettings app -> FieldSettings app
addCssClass Lang
c FieldSettings app
fs = FieldSettings app
fs { fsAttrs = addClass c $ fsAttrs fs}


-- | Turn FieldSettings into a read-only input field.
readOnly :: FieldSettings app -> FieldSettings app
readOnly :: forall app. FieldSettings app -> FieldSettings app
readOnly = [(Lang, Lang)] -> FieldSettings app -> FieldSettings app
forall app.
[(Lang, Lang)] -> FieldSettings app -> FieldSettings app
addAttributes [(Lang
"readonly",Lang
""),(Lang
"style",Lang
"background-color: #EEEEEE")]


{- |
Turn a String into a label for all languages.

==== __Example__

>>> universalLabel "index"
(German: "index", English: "index")
-}
universalLabel :: String -> SomeMessage FlexForm
universalLabel :: String -> SomeMessage FlexForm
universalLabel = String -> SomeMessage FlexForm
forall a. IsString a => String -> a
fromString


{- |
Turn the Show instance of a value into a label for all languages.

==== __Example__

>>> showToUniversalLabel (1 :: Int)
(German: "1", English: "1")
-}
showToUniversalLabel :: Show a => a -> SomeMessage FlexForm
showToUniversalLabel :: forall a. Show a => a -> SomeMessage FlexForm
showToUniversalLabel = String -> SomeMessage FlexForm
universalLabel (String -> SomeMessage FlexForm)
-> (a -> String) -> a -> SomeMessage FlexForm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show


{- |
Get a unique identifier for an html element.
The format is "flexident[number]"
-}
newFlexId :: MForm Handler Text
newFlexId :: MForm Handler Lang
newFlexId = HasCallStack => Lang -> Lang -> Lang -> Lang
Lang -> Lang -> Lang -> Lang
T.replace Lang
"h" Lang
"flex" (Lang -> Lang)
-> RWST
     (Maybe (Env, FileEnv), FlexForm, [Lang]) Enctype Ints Handler Lang
-> RWST
     (Maybe (Env, FileEnv), FlexForm, [Lang]) Enctype Ints Handler Lang
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST
  (Maybe (Env, FileEnv), FlexForm, [Lang]) Enctype Ints Handler Lang
forall (m :: * -> *). MonadHandler m => m Lang
newIdent


-- | repeat the last received name.
repeatFlexName :: MForm Handler Text
repeatFlexName :: MForm Handler Lang
repeatFlexName = do
  i <- RWST
  (Maybe (Env, FileEnv), FlexForm, [Lang]) Enctype Ints Handler Ints
forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m s
RWS.get
  pure $ pack $ "flex" ++ show i


{- |
Get a unique name for an html element.
The format is "flex[number]"
-}
newFlexName :: MForm Handler Text
newFlexName :: MForm Handler Lang
newFlexName = HasCallStack => Lang -> Lang -> Lang -> Lang
Lang -> Lang -> Lang -> Lang
T.replace Lang
"f" Lang
"flex" (Lang -> Lang)
-> RWST
     (Maybe (Env, FileEnv), FlexForm, [Lang]) Enctype Ints Handler Lang
-> RWST
     (Maybe (Env, FileEnv), FlexForm, [Lang]) Enctype Ints Handler Lang
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MForm Handler Lang
RWST
  (Maybe (Env, FileEnv), FlexForm, [Lang]) Enctype Ints Handler Lang
forall (m :: * -> *). Monad m => MForm m Lang
newFormIdent


{- |
Pretty prints the given embedded Widget's HTML code in the console.
Applies the specified language for internationalization.
Used for debugging.

=== __Example__

>>> printWidget "en" $ formify (Nothing @Int) [[single "Number Please"]]
<div class="flex-form-div form-group">
  <input type="hidden" name="_hasdata">
  <span class="required flex-form-span">
    <label for="flexident1">
      Number Please
    </label>
    <input id="flexident1" name="flex1" type="number" step="1" required="" value="">
  </span>
</div>
-}
printWidget :: Lang -> Rendered Widget -> IO ()
printWidget :: Lang -> Rendered Widget -> IO ()
printWidget Lang
lang Rendered Widget
render  = do
  (_, dict) <- Rendered Widget -> IO ([[Lang]], HtmlDict)
getFormData Rendered Widget
render
  putStrLn $ maybe "Form not available in this language."
    (trimEnd . unlines . addIndent 0 . intoLines)
    $ M.lookup lang dict
  where
    intoLines :: String -> [String]
intoLines String
s =
      let opening :: [String]
opening = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"<" String -> String -> String
forall a. [a] -> [a] -> [a]
++) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop Int
1 (String -> String -> [String]
forall a. (HasCallStack, Eq a) => [a] -> [a] -> [[a]]
splitOn String
"<" String
s)
          closing :: [String]
closing = (String -> [String]) -> [String] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/=String
"") ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> [String]
forall a. (HasCallStack, Eq a) => [a] -> [a] -> [[a]]
splitOn String
">") [String]
opening
      in  (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\String
x -> if String
"<" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
x then String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">" else String
x) [String]
closing

    addIndent :: Int -> [String] -> [String]
addIndent Int
_ [] = []
    addIndent Int
i (String
s:[String]
ss)
      | String
"</" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
s
      = (Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
2) Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Int -> [String] -> [String]
addIndent (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
2) [String]
ss
      | String
">" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
s Bool -> Bool -> Bool
&& Bool -> Bool
not ((String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
s) [String]
noClose)
      = (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
i Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Int -> [String] -> [String]
addIndent (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2) [String]
ss
      | Bool
otherwise
      = (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
i Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Int -> [String] -> [String]
addIndent Int
i [String]
ss

    noClose :: [String]
noClose =
      [ String
"area"
      , String
"base"
      , String
"br"
      , String
"col"
      , String
"embed"
      , String
"hr"
      , String
"img"
      , String
"input"
      , String
"link"
      , String
"meta"
      , String
"param"
      , String
"source"
      , String
"track"
      , String
"wbr"
      ]