149 lines
5.0 KiB
Haskell
149 lines
5.0 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
|
|
module Handler.Utils.Form where
|
|
|
|
import Import
|
|
-- import Data.Time
|
|
import Data.Proxy
|
|
import qualified Data.Map as Map
|
|
import Handler.Utils.DateTime
|
|
import Data.String (IsString(..))
|
|
|
|
import qualified Data.Foldable as Foldable
|
|
|
|
-- import Yesod.Core
|
|
import qualified Data.Text as T
|
|
-- import Yesod.Form.Types
|
|
import Yesod.Form.Functions (parseHelper)
|
|
import Yesod.Form.Bootstrap3
|
|
|
|
import Web.PathPieces (showToPathPiece, readFromPathPiece)
|
|
import Text.Blaze (Markup)
|
|
----------------------------
|
|
-- Buttons (new version ) --
|
|
----------------------------
|
|
|
|
class (Enum a, Bounded a, Ord a, PathPiece a) => Button a where
|
|
label :: a -> Widget
|
|
label = toWidget . toPathPiece
|
|
|
|
buttonForm :: Button a => Markup -> MForm Handler (FormResult a, (a -> FieldView UniWorX))
|
|
buttonForm html = do
|
|
let
|
|
buttonValues = [minBound..maxBound]
|
|
buttonMap = Map.fromList $ zip buttonValues buttonValues
|
|
button b = Field parse view UrlEncoded
|
|
where
|
|
parse [] _ = return $ Right Nothing
|
|
parse [str] _
|
|
| str == toPathPiece b = return $ Right $ Just b
|
|
| otherwise = return $ Left "Wrong button value"
|
|
parse _ _ = return $ Left "Multiple button values"
|
|
|
|
view id name attrs _val _ = do
|
|
[whamlet|
|
|
#{html}
|
|
<button .btn .btn-default type=submit name=#{name} value=#{toPathPiece b} *{attrs} ##{id}>^{label b}
|
|
|]
|
|
|
|
buttonIdent <- newFormIdent
|
|
resultWidgetMap <- forM buttonMap $ \val -> mopt (button val) ("" { fsName = Just buttonIdent }) Nothing
|
|
|
|
let result = accResult $ fst <$> Map.elems resultWidgetMap
|
|
let viewF = (Map.!) (snd <$> resultWidgetMap)
|
|
|
|
return (result, viewF)
|
|
where
|
|
accResult :: Foldable f => f (FormResult (Maybe a)) -> FormResult a
|
|
accResult = Foldable.foldr accResult' FormMissing
|
|
|
|
accResult' :: FormResult (Maybe a) -> FormResult a -> FormResult a
|
|
accResult' (FormSuccess _) (FormSuccess _) = FormFailure ["Ambiguous parse"]
|
|
accResult' (FormSuccess (Just x)) _ = FormSuccess x
|
|
accResult' _ x = x
|
|
|
|
----------------------------
|
|
-- Buttons (old version ) --
|
|
----------------------------
|
|
|
|
formBtnSave :: (Text,Text,Text)
|
|
formBtnSave = ("save" ,"Speichern" ,"btn-primary")
|
|
|
|
formBtnAbort :: (Text,Text,Text)
|
|
formBtnAbort = ("abort" ,"Abbrechen" ,"btn-default")
|
|
|
|
formBtnDelete ::(Text,Text,Text)
|
|
formBtnDelete = ("delete","Löschen" ,"btn-warning")
|
|
|
|
formActionSave :: Maybe Text
|
|
formActionSave = Just $ fst3 formBtnSave
|
|
|
|
formActionAbort :: Maybe Text
|
|
formActionAbort = Just $ fst3 formBtnAbort
|
|
|
|
formActionDelete :: Maybe Text
|
|
formActionDelete = Just $ fst3 formBtnDelete
|
|
|
|
defaultFormActions :: [(Text,Text,Text)]
|
|
defaultFormActions = [ formBtnDelete
|
|
, formBtnAbort
|
|
, formBtnSave
|
|
]
|
|
|
|
-- Post-Buttons
|
|
-- postButtonForm :: MonadHandler m =>
|
|
-- Text -> Text.Blaze.Internal.Markup -> MForm m (FormResult (), WidgetT (HandlerSite m) IO ())
|
|
postButtonForm lblId = identifyForm lblId buttonF
|
|
where
|
|
buttonF = renderBootstrap3 BootstrapInlineForm $ pure () <* bootstrapSubmit bProps
|
|
bProps :: BootstrapSubmit Text
|
|
bProps = fromString $ unpack lblId
|
|
|
|
|
|
------------
|
|
-- Fields --
|
|
------------
|
|
|
|
natField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i
|
|
natField d = checkBool (>= 0) (T.append d " muss eine natürliche Zahl sein.") $ intField
|
|
|
|
posIntField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i
|
|
posIntField d = checkBool (>= 1) (T.append d " muss eine positive Zahl sein.") $ intField
|
|
|
|
minIntField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) FormMessage) => i -> Text -> Field m i
|
|
minIntField m d = checkBool (>= m) (T.concat [d," muss größer als ", T.pack $ show m, " sein."]) $ intField
|
|
|
|
|
|
schoolField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m SchoolId
|
|
schoolField = undefined -- TODO
|
|
|
|
utcTimeField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m UTCTime
|
|
-- StackOverflow: dayToUTC <$> (areq (jqueryDayField def {...}) settings Nothing)
|
|
utcTimeField = Field
|
|
{ fieldParse = parseHelper $ readTime
|
|
, fieldView = \theId name attrs val isReq ->
|
|
[whamlet|
|
|
$newline never
|
|
<input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required value="#{either id showTime val}">
|
|
|]
|
|
, fieldEnctype = UrlEncoded
|
|
}
|
|
where
|
|
fieldTimeFormat :: String
|
|
fieldTimeFormat = "%e.%m.%y %k:%M"
|
|
|
|
readTime :: Text -> Either FormMessage UTCTime
|
|
readTime t =
|
|
case parseTimeM True germanTimeLocale fieldTimeFormat (T.unpack t) of
|
|
(Just time) -> Right time
|
|
Nothing -> Left $ MsgInvalidEntry "Datum/Zeit Format: tt.mm.yy hh:mm"
|
|
|
|
showTime :: UTCTime -> Text
|
|
showTime = fromString . (formatTime germanTimeLocale fieldTimeFormat)
|