Bootstrap changes, gGeneric Form refined, Basic Term Sanity Checks

src/Common.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Common where
+-- Common Utility Functions
+
+import Language.Haskell.TH
+
+
+------------
+-- Tuples --
+------------
+
+fst3 :: (a,b,c) -> a
+fst3 (x,_,_) = x
+snd3 :: (a,b,c) -> b
+snd3 (_,y,_) = y
+trd3 :: (a,b,c) -> c
+trd3 (_,_,z) = z
+
+projNI :: Int -> Int -> ExpQ -- generic projection gives I-th element of N-tuple, i.e. snd3 = $(projNI 3 2)  --ghci -fth
+-- $(projN n m) :: (t1,..,tn) -> tm (for m<=n)
+projNI n i = lamE [pat] rhs
+  where pat = tupP (map varP xs)
+        rhs = varE (xs !! (i - 1))
+        xs  = [ mkName $ "x" ++ show j | j <- [1..n] ]

src/Handler/Term.hs

@@ -10,11 +10,10 @@ import Import
 import Handler.Utils
 import qualified Data.Text as T
 -- import Data.Maybe
-import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3)
+import Yesod.Form.Bootstrap3 
 -- import Text.Julius (RawJS (..))
 
 
-
 getShowTermsR :: Handler Html
 getShowTermsR = do
   terms <- runDB $ selectList [] [Desc TermStart]
@@ -66,9 +65,11 @@ getEditTermMaybeR :: Maybe Term -> Handler Html
 getEditTermMaybeR mbTerm= do 
     aid <- requireAuthId
     (formWidget, formEnctype) <- generateFormPost $ newTermForm mbTerm
+    let formtitle = "Semester editieren/anlegen" :: Text
+    let actionurl = EditTermR
     defaultLayout $ do
-        setTitle "Semester editieren/anlegen"        
+      setTitle [shamlet| #{formtitle} |]
-        $(widgetFile "editTerm")
+      $(widgetFile "generic_form")
         
         
 postEditTermR :: Handler Html
@@ -80,29 +81,48 @@ postEditTermR = do
           -- term <- runDB $ get $ TermKey termName 
           runDB $ repsert (TermKey $ termName res) res
           let tid = termToText $ termName res
-          let msg = "Semester " `T.append` tid `T.append` " wurde editiert!"        
+          let msg = "Semester " `T.append` tid `T.append` " erfolgreich editiert!"            
-          setMessage [shamlet| #{msg}|]
+          let okay  = termStart res `withinTerm` termName res
+          let order = termStart res <= termEnd res
+          setMessage [shamlet| #{msg} 
+                                $if not okay
+                                  <p .bg-warning>
+                                    Bezeichner des Semesters und Datum des Starts stimmen nicht überein!
+                                $if not order
+                                  <p .bg-danger>
+                                    Ende des Semesters liegt vor dem Start!
+                      |]
           redirect ShowTermsR
-       FormMissing -> defaultLayout $ do
+       FormMissing -> do
             setMessage "Keine Formulardaten erhalten."
-            $(widgetFile "editTerm")
+            let formtitle = "Semester editieren/anlegen" :: Text
-       FormFailure errorMsgs -> defaultLayout $ do
+            let actionurl = EditTermR  
-            setMessage [shamlet| <span .error>Fehler:
+            defaultLayout $ do 
-                            <ul>
+              setTitle [shamlet| #{formtitle} |]
-                                $forall errmsg <- errorMsgs
+              $(widgetFile "generic_form")
-                                    <li> #{errmsg} 
+            
-                        |]
+       FormFailure errorMsgs -> do
-            $(widgetFile "editTerm")
+            setMessage [shamlet|
-
+                <p .bg-danger>Fehler:
+                  <ul>
+                    $forall errmsg <- errorMsgs
+                      <li> #{errmsg} 
+              |]
+            let formtitle = "Semester editieren/anlegen" :: Text
+            let actionurl = EditTermR  
+            defaultLayout $ do 
+              setTitle [shamlet| #{formtitle} |]
+              $(widgetFile "generic_form")
             
 newTermForm :: Maybe Term -> Form Term
 newTermForm template = 
-    renderBootstrap3 BootstrapBasicForm $ Term
+    renderBootstrap3 bsHorizontalDefault $ Term
-      <$> areq termNewField (set "Semester")   (termName  <$> template)
+      <$> areq termNewField (bfs ("Semester" :: Text)) (termName  <$> template)
-      <*> areq dayField  (set "Erster Tag") (termStart <$> template)
+      <*> areq dayField  (bfs ("Erster Tag" :: Text)) (termStart <$> template)
       <*> areq dayField  (set "Letzer Tag") (termEnd   <$> template)
       <*> pure [] -- TODO: List of Day field required, must probably be done as its own form and then combined
       <*> areq checkBoxField (set "Aktiv") (termActive <$> template)
+      <*  bootstrapSubmit (bsSubmit "Semester bearbeiten")
   where set txt = FieldSettings
             { fsLabel = txt
             , fsTooltip = Nothing

src/Handler/Utils.hs

@@ -1,6 +1,10 @@
+{-# LANGUAGE TemplateHaskell #-}
+
 module Handler.Utils
   ( module Handler.Utils 
   ) where
 
 import Handler.Utils.DateTime as Handler.Utils
 import Handler.Utils.Term as Handler.Utils
+import Handler.Utils.Bootstrap3 as Handler.Utils
+

src/Handler/Utils/Bootstrap3.hs

@@ -0,0 +1,28 @@
+{-# 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/Term.hs

@@ -8,8 +8,10 @@ module Handler.Utils.Term where
 
 import Import
 import qualified Data.Text as T
+import Model.Types
 -- import Data.Maybe
 
+
 termExistsField :: Field (HandlerT UniWorX IO) TermIdentifier
 termExistsField = termField True
 

src/Import.hs

@@ -2,5 +2,6 @@ module Import
     ( module Import
     ) where
 
+import Common                as Import    
 import Foundation            as Import
 import Import.NoFoundation   as Import

src/Model/Types.hs

@@ -8,6 +8,8 @@ module Model.Types where
 
 import ClassyPrelude
 
+import Common
+
 import Database.Persist.TH
 import Database.Persist.Class
 import Database.Persist.Sql
@@ -104,3 +106,11 @@ termField :: Field (HandlerT UniWorX IO) TermIdentifier
 termField = checkMMap (return . termFromText) termToText textField
   -- TODO: this is too simple and inconvenient, use selector and year picker  
 -} 
+
+
+withinTerm :: Day -> TermIdentifier -> Bool
+time `withinTerm` term = timeYear `mod` 100 == termYear `mod` 100
+  where 
+    timeYear = fst3 $ toGregorian time      
+    termYear = year term 
+      

templates/generic_form.hamlet

@@ -0,0 +1,14 @@
+<div .container>
+    <div .bs-docs-section>
+        <div .row>
+            <div .col-lg-12>
+                <div .page-header>
+                    <h1 #forms>
+                      #{formtitle}
+
+        <div .row>
+            <div .col-lg-6>
+                <div .bs-callout bs-callout-info well>
+                    <form .form-horizontal method=post action=@{actionurl}#forms enctype=#{formEnctype}>
+                        ^{formWidget}
+