263 lines
9.0 KiB
Haskell
263 lines
9.0 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude
|
|
, TemplateHaskell
|
|
, ViewPatterns
|
|
, OverloadedStrings
|
|
, QuasiQuotes
|
|
, TemplateHaskell
|
|
, MultiParamTypeClasses
|
|
, TypeFamilies
|
|
, FlexibleContexts
|
|
, NamedFieldPuns
|
|
, ScopedTypeVariables
|
|
, MultiWayIf
|
|
, RecordWildCards
|
|
#-}
|
|
|
|
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 Data.CaseInsensitive (CI)
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import Data.Map.Lazy ((!))
|
|
import qualified Data.Map.Lazy as Map
|
|
import qualified Data.Set as Set
|
|
|
|
import Data.List ((!!))
|
|
|
|
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 }
|
|
|
|
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" ""
|
|
|
|
------------------------------------------------
|
|
-- 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]
|
|
|
|
-------------------
|
|
-- Custom Fields --
|
|
-------------------
|
|
|
|
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
|
|
|
|
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")
|