Profile prepared for Theme selection (incomplete, but compiles)

src/Handler/Profile.hs

@@ -17,6 +17,26 @@ import Handler.Utils
 import qualified Database.Esqueleto as E
 import           Database.Esqueleto      ((^.))
 
+
+
+data SettingsForm = SettingsForm
+      { stgMaxFavourties :: Int
+      , stgTheme         :: Theme
+      }
+
+makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
+makeSettingForm template = identForm FIDsettings $ \html -> do
+    let themeList = [(display t,t) | t <- allThemes]
+    flip (renderAForm FormStandard) html $ SettingsForm
+      <$> areq (natField "Favoriten") -- TODO: natFieldI not working here
+            (fslpI MsgFavoriten "12") (stgMaxFavourties <$> template)
+      <*> areq (selectFieldList themeList)
+            (fslI  MsgTheme         ) (stgTheme         <$> template)
+      <*  submitButton
+    -- no validation required here
+
+
+
 getProfileR :: Handler Html
 getProfileR = do
     (uid, User{..}) <- requireAuthPair

src/Handler/Utils/Form.hs

@@ -48,7 +48,7 @@ import Control.Monad.Writer.Class
 -- Unique Form Identifiers to avoid accidents --
 ------------------------------------------------
 
-data FormIdentifier = FIDcourse | FIDsheet | FIDsubmission
+data FormIdentifier = FIDcourse | FIDsheet | FIDsubmission | FIDsettings
   deriving (Enum, Eq, Ord, Bounded, Read, Show)
 
 
@@ -226,6 +226,10 @@ buttonForm csrf = do
 -- Fields --
 ------------
 
+
+natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => FormMessage -> Field m i
+natFieldI msg = checkBool (>= 0) msg intField
+
 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
 
@@ -393,6 +397,15 @@ fsl lbl =
                 , fsAttrs    = []
   }
 
+fslI :: RenderMessage UniWorX msg => msg -> FieldSettings UniWorX
+fslI lbl =
+  FieldSettings { fsLabel    = (SomeMessage lbl)
+                , fsTooltip  = Nothing
+                , fsId       = Nothing
+                , fsName     = Nothing
+                , fsAttrs    = []
+  }
+
 fslp ::  Text -> Text -> FieldSettings UniWorX
 fslp lbl placeholder =
   FieldSettings { fsLabel    = (SomeMessage lbl)

src/Model/Types.hs

@@ -209,7 +209,7 @@ derivePersistField "StudyFieldType"
 data Theme       --Simply add Themes to this type only. CamelCase will be converted to "-lower"
   = Default
   | NeutralBlue
-  | AberdeenReds
+  | AberdeenRedso
   | MintGreen
   | SkyLove
   deriving (Eq,Ord,Bounded,Enum)