fradrive-old/src/Utils/Form.hs

{-# LANGUAGE NoImplicitPrelude
           , TemplateHaskell
           , ViewPatterns
           , OverloadedStrings
           , QuasiQuotes
           , TemplateHaskell
           , MultiParamTypeClasses
           , TypeFamilies
           , FlexibleContexts
           , NamedFieldPuns
           , ScopedTypeVariables
#-}

module Utils.Form where

import ClassyPrelude.Yesod
import Settings

import qualified Text.Blaze.Internal as Blaze (null)
import qualified Data.Text as T
import qualified Data.Char as Char

import Web.PathPieces

-------------------
-- Form Renderer --
-------------------

-- | Use this type to pass information to the form template
data FormLayout = FormStandard

renderAForm :: Monad m => FormLayout -> FormRender m a
renderAForm formLayout aform fragment = do
  (res, (($ []) -> views)) <- aFormToForm aform
  let widget = $(widgetFile "widgets/form")
  return (res, widget)

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

addAttr :: Text -> Text -> FieldSettings site -> FieldSettings site
addAttr attr valu fs = fs { fsAttrs=newAttrs (fsAttrs fs) }
  where
    newAttrs :: [(Text,Text)] -> [(Text,Text)]
    newAttrs [] = [(attr,valu)]
    newAttrs (p@(a,v):t)
      | attr==a   = (a,T.append valu $ cons ' ' v):t
      | otherwise = p:(newAttrs t)

addAttrs :: Text -> [Text] -> FieldSettings site -> FieldSettings site
addAttrs attr valus fs = fs { fsAttrs=newAttrs (fsAttrs fs) }
  where
    newAttrs :: [(Text,Text)] -> [(Text,Text)]
    newAttrs [] = [(attr,T.intercalate " " valus)]
    newAttrs (p@(a,v):t)
      | attr==a   = (a,T.intercalate " " (v:valus)):t
      | otherwise = p:(newAttrs t)

addClass :: Text -> FieldSettings site -> FieldSettings site
addClass = addAttr "class"

addClasses :: [Text] -> FieldSettings site -> FieldSettings site
addClasses = addAttrs "class"

addName :: Text -> FieldSettings site -> FieldSettings site
addName nm fs = fs { fsName = Just nm }

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 }

------------------------------------------------
-- Unique Form Identifiers to avoid accidents --
------------------------------------------------

data FormIdentifier = FIDcourse | FIDsheet | FIDsubmission | FIDsettings | FIDcorrectors | FIDcorrectorTable | FIDcorrection | FIDcorrectionsUpload | FIDcorrectionUpload
  deriving (Enum, Eq, Ord, Bounded, Read, Show)

instance PathPiece FormIdentifier where
  fromPathPiece = readFromPathPiece
  toPathPiece = showToPathPiece


identForm :: (Monad m, PathPiece ident)
          => ident -- ^ Form identification
          -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
          -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
identForm = identifyForm . toPathPiece

{- 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 ButtonCssClass site :: *

bcc2txt :: Show (ButtonCssClass site) => ButtonCssClass site -> Text -- a Hack; maybe define Read/Show manually
bcc2txt bcc = T.pack $ "btn-" ++ (Char.toLower <$> (drop 2 $ show bcc))

class (Enum a, Bounded a, Ord a, PathPiece a) => Button site a where
  label :: a -> WidgetT site IO ()
  label = toWidget . toPathPiece

  cssClass :: a -> ButtonCssClass site

data SubmitButton = BtnSubmit
  deriving (Enum, Eq, Ord, Bounded, Read, Show)

instance PathPiece SubmitButton where
  toPathPiece   = showToPathPiece
  fromPathPiece = readFromPathPiece

buttonField :: forall site a. (Button site a, Show (ButtonCssClass site)) => a -> Field (HandlerT site IO) a -- already validates that the correct button press was received (result only neccessary for combinedButtonField)
buttonField btn = Field {fieldParse, fieldView, fieldEnctype}
  where
    fieldEnctype = UrlEncoded

    fieldView fid name attrs _val _ = let
      cssClass' :: ButtonCssClass site
      cssClass' = cssClass btn
      in [whamlet|
        <button .btn .#{bcc2txt cssClass'} type=submit name=#{name} value=#{toPathPiece btn} *{attrs} ##{fid}>^{label btn}
      |]

    fieldParse []    _ = return $ Right Nothing
    fieldParse [str] _
      | str == toPathPiece btn = return $ Right $ Just btn
      | otherwise  = return $ Left "Wrong button value"
    fieldParse _ _ = return $ Left "Multiple button values"

combinedButtonField :: (Button site a, Show (ButtonCssClass site)) => [a] -> AForm (HandlerT site IO) [Maybe a]
combinedButtonField btns = traverse b2f btns
  where
    b2f b = aopt (buttonField b) "" Nothing

submitButton :: (Button site SubmitButton, Show (ButtonCssClass site)) => AForm (HandlerT site IO) ()
submitButton = void $ combinedButtonField [BtnSubmit]