Merge branch 'feat/custom-renderers'

src/Handler/Course.hs

@@ -97,8 +97,7 @@ getCourseShowR tid csh = do
     $(widgetFile "course")
       
 registerButton :: Bool -> Form ()
-registerButton registered =
+registerButton registered = renderAForm FormStandard $       
-    renderBootstrap3  bsHorizontalDefault $       
       pure () <*  bootstrapSubmit regMsg 
   where 
     msg    = if registered then "Abmelden" else "Anmelden"
@@ -267,7 +266,7 @@ newCourseForm template = identForm FIDcourse $ \html -> do
     --     courseId <- runMaybeT $ do
     --         cid <- cfCourseId template
     --         UUID.encrypt cidKey cid 
-    (result, widget) <- flip (renderBootstrap3 bsHorizontalDefault) html $ CourseForm
+    (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
       -- <$> pure cid -- $ join $ cfCourseId <$> template -- why doesnt this work?
       <$> aopt hiddenField "KursId"             (cfCourseId <$> template)
       <*> areq textField (fsb "Name")           (cfName     <$> template)

src/Handler/Sheet.hs

@@ -17,7 +17,6 @@ import Handler.Utils.Zip
 -- import Data.Time
 import qualified Data.Text as T
 -- import Data.Function ((&))
-import Yesod.Form.Bootstrap3
 -- 
 import Colonnade  -- hiding (fromMaybe)
 import Yesod.Colonnade
@@ -54,7 +53,7 @@ makeSheetForm :: CourseId -> Maybe SheetForm -> Form SheetForm
 makeSheetForm cid template = identForm FIDsheet $ \html -> do
     -- TODO: Yesod.Form.MassInput.inputList arbeitet Server-seitig :(
     -- Erstmal nur mit ZIP arbeiten
-    (result, widget) <- flip (renderBootstrap3 bsHorizontalDefault) html $ SheetForm
+    (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
       <$> areq textField    (fsb "Name")        (sfName <$> template)
       <*> aopt htmlField    (fsb "Hinweise für Teilnehmer")  (sfMarkingText <$> template)
       <*> sheetTypeAFormReq (fsb "Bewertung")   (sfType <$> template)

src/Handler/Submission.hs

@@ -13,7 +13,7 @@ module Handler.Submission where
 
 import Import hiding (joinPath)
 
-import Yesod.Form.Bootstrap3  
+-- import Yesod.Form.Bootstrap3  
 
 import Handler.Utils
 
@@ -72,10 +72,10 @@ submissionTable = do
 getSubmissionListR, postSubmissionListR :: Handler Html
 getSubmissionListR = postSubmissionListR
 postSubmissionListR = do
-  ((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderBootstrap3 BootstrapBasicForm $ (,)
+  ((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderAForm FormStandard $ (,)
-    <$> areq checkBoxField (bfs ("Dies sind Korrekturen" :: Text)) (Just False)
+    <$> areq checkBoxField "Dies sind Korrekturen" (Just False)
-    <*> fileAFormReq (bfs ("Archiv" :: Text))
+    <*> fileAFormReq "Archiv"
-    <*  bootstrapSubmit ("Mehrere Hochladen" :: BootstrapSubmit Text)
+    <*  submitButton
 
   runDB $ do
     case uploadResult of
@@ -211,10 +211,10 @@ getSubmissionR = postSubmissionR
 postSubmissionR cID = do
   submissionId <- decrypt cID
   
-  ((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderBootstrap3 BootstrapBasicForm $ (,)
+  ((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderAForm FormStandard $ (,)
-    <$> areq checkBoxField (bfs ("Dies ist eine Korrektur" :: Text)) (Just False)
+    <$> areq checkBoxField "Dies ist eine Korrektur" (Just False)
-    <*> fileAFormReq (bfs ("Datei" :: Text))
+    <*> fileAFormReq "Datei"
-    <*  bootstrapSubmit ("Upload" :: BootstrapSubmit Text)
+    <*  submitButton
 
   (submission, files) <- runDB $ do
     submission <- do

src/Handler/Term.hs

@@ -128,7 +128,7 @@ wdgtTermForm formWidget formEnctype = do
       
 newTermForm :: Maybe Term -> Form Term
 newTermForm template html = do
-    (result, widget) <- flip (renderBootstrap3 bsHorizontalDefault) html $ Term
+    (result, widget) <- flip (renderAForm FormStandard) html $ Term
       <$> areq termNewField (bfs ("Semester" :: Text)) (termName  <$> template)
       <*> areq dayField  (bfs ("Erster Tag" :: Text)) (termStart <$> template)
       <*> areq dayField  (bfs ("Letzer Tag" :: Text)) (termEnd   <$> template)

src/Handler/Utils.hs

@@ -11,7 +11,6 @@ import Import.NoFoundation
   
 import Handler.Utils.DateTime as Handler.Utils
 import Handler.Utils.Term as Handler.Utils
-import Handler.Utils.Bootstrap3 as Handler.Utils
 import Handler.Utils.Form as Handler.Utils
 import Handler.Utils.Table as Handler.Utils
 

src/Handler/Utils/Bootstrap3.hs

@@ -1,28 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-
-module Handler.Utils.Bootstrap3 where
-
-import Import
-import Data.String (IsString(..))
--- import Yesod.Core
--- import qualified Data.Text as T
--- import Yesod.Form.Types
--- import Yesod.Form.Functions
-import Yesod.Form.Bootstrap3 
-
-bsSubmit :: String -> BootstrapSubmit Text
-bsSubmit msg = 
-  BootstrapSubmit (fromString msg) " btn-default btn-primary " []
-  
-bsHorizontalDefault :: BootstrapFormLayout
-bsHorizontalDefault = 
-  BootstrapHorizontalForm 
-    { bflLabelOffset = ColSm 1
-    , bflLabelSize   = ColSm 4
-    , bflInputOffset = ColSm 1
-    , bflInputSize   = ColSm 6
-    }
-  

src/Handler/Utils/Form.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module Handler.Utils.Form where 
 
@@ -22,6 +23,8 @@ import qualified Data.Text as T
 import Yesod.Form.Functions (parseHelper)
 import Yesod.Form.Bootstrap3 
 
+import qualified Text.Blaze.Internal as Blaze (null)
+
 import Web.PathPieces (showToPathPiece, readFromPathPiece)
 
 ------------------------------------------------
@@ -35,6 +38,18 @@ data FormIdentifier = FIDcourse | FIDsheet
 identForm :: FormIdentifier -> Form a -> Form a  
 identForm fid = identifyForm (T.pack $ show fid)
 
+-------------------
+-- 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 "form")
+  return (res, widget)
 
 ----------------------------
 -- Buttons (new version ) --
@@ -70,6 +85,18 @@ instance Button StandardButton where
   cssClass BtnDelete = BCWarning
   cssClass BtnAbort  = BCDefault
   cssClass BtnSave   = BCPrimary
+
+data SubmitButton = BtnSubmit
+  deriving (Enum, Eq, Ord, Bounded, Read, Show)
+
+instance PathPiece SubmitButton where
+  toPathPiece   = showToPathPiece
+  fromPathPiece = readFromPathPiece
+
+instance Button SubmitButton where
+  label BtnSubmit = "Submit"
+
+  cssClass BtnSubmit = BCPrimary
   
 -- -- Looks like a button, but is just a link (e.g. for create course, etc.)  
 -- data LinkButton = LinkButton (Route UniWorX)
@@ -108,7 +135,10 @@ buttonField btn = Field {fieldParse, fieldView, fieldEnctype}
 combinedButtonField1 :: Button a => [a] -> AForm Handler [Maybe a]
 combinedButtonField1 btns = traverse b2f btns
   where
-    b2f b = aopt (buttonField b) "n/a" Nothing 
+    b2f b = aopt (buttonField b) "" Nothing 
+
+submitButton :: AForm Handler ()
+submitButton = void $ combinedButtonField1 [BtnSubmit]
 
     {-
 combinedButtonField :: Button a => [a] -> Form m -> Form (a,m)
@@ -200,7 +230,7 @@ defaultFormActions =  [ formBtnDelete
 postButtonForm :: Text -> Form ()
 postButtonForm lblId = identifyForm lblId buttonF
   where
-    buttonF = renderBootstrap3 BootstrapInlineForm $ pure () <* bootstrapSubmit bProps
+    buttonF = renderAForm FormStandard $ pure () <* bootstrapSubmit bProps
     bProps :: BootstrapSubmit Text
     bProps = fromString $ unpack lblId
     

templates/form.hamlet

@@ -0,0 +1,9 @@
+$newline never
+#{fragment}
+$case formLayout
+  $of FormStandard
+    $forall view <- views
+      <div :fvRequired view:.required :not $ fvRequired view:.optional :isJust $ fvErrors view:.has-error>
+        $if not (Blaze.null $ fvLabel view)
+          <label for=#{fvId view}>#{fvLabel view}
+        ^{fvInput view}