Cleanup Theme declaration

.gitignore

@@ -29,3 +29,4 @@ uniworx.nix
 src/Handler/Assist.bak
 src/Handler/Course.SnapCustom.hs
 *.orig
+.stack-work-*

ghci.sh

@@ -5,4 +5,15 @@ export DETAILED_LOGGING=true
 export LOG_ALL=true
 export DUMMY_LOGIN=true
 
-exec -- stack ghci --flag uniworx:dev --flag uniworx:library-only
+move-back() {
+    mv -v .stack-work .stack-work-ghci
+    [[ -d .stack-work-run ]] && mv -v .stack-work-run .stack-work
+}
+
+if [[ -d .stack-work-ghci ]]; then
+    [[ -d .stack-work ]] && mv -v .stack-work .stack-work-run
+    mv -v .stack-work-ghci .stack-work
+    trap move-back EXIT
+fi
+
+stack ghci --flag uniworx:dev --flag uniworx:library-only

package.yaml

@@ -88,6 +88,8 @@ dependencies:
 - Glob
 - ldap-client
 - connection
+- universe
+- universe-base
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.

src/Foundation.hs

@@ -515,6 +515,7 @@ instance Yesod UniWorX where
 
     defaultLayout widget = do
         master <- getYesod
+        let AppSettings { appUserDefaults = UserDefaultConf{..}, .. } = appSettings master
         mmsgs  <- getMessages
 
         mcurrentRoute <- getCurrentRoute
@@ -534,10 +535,10 @@ instance Yesod UniWorX where
         isAuth <- isJust <$> maybeAuthId
 
         -- Lookup Favourites & Theme if possible -- TODO: cache this info in a cookie?!
-        (favourites',show -> currentTheme) <- do
+        (favourites', currentTheme) <- do
             muid <- maybeAuthPair
             case muid of
-                Nothing         -> return ([],Default)
+                Nothing         -> return ([],userDefaultTheme)
                 (Just (uid,user)) -> do
                     favs <- runDB $ E.select . E.from $ \(course `E.InnerJoin` courseFavourite) -> do
                         E.on (course E.^. CourseId E.==. courseFavourite E.^. CourseFavouriteCourse)

src/Handler/Profile.hs

@@ -30,12 +30,12 @@ data SettingsForm = SettingsForm
 
 makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
 makeSettingForm template = identForm FIDsettings $ \html -> do
-    let themeList = [(display t,t) | t <- allThemes]
+    let themeList = [Option (display t) t (toPathPiece t) | t <- universeF]
     (result, widget) <- flip (renderAForm FormStandard) html $ SettingsForm
       <$> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here
             (fslpI MsgFavoriten "Anzahl Favoriten") (stgMaxFavourties <$> template)
-      <*> areq (selectFieldList themeList)
-            (fslpI  MsgTheme "theme-select"       ) (stgTheme         <$> template) -- TODO: pass theme-select as id-attribute or similar.
+      <*> areq (selectField . return $ mkOptionList themeList)
+            (fslI  MsgTheme) { fsId = Just "theme-select" } (stgTheme         <$> template)
       <*> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) (stgDateTime <$> template)
       <*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) (stgDate <$> template)
       <*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) (stgTime <$> template)

src/Import/NoFoundation.hs

@@ -21,3 +21,5 @@ import Data.UUID              as Import (UUID)
 import Text.Lucius            as Import
 
 import Text.Shakespeare.Text  as Import hiding (text, stext)
+
+import Data.Universe          as Import

src/Model/Types.hs

@@ -16,12 +16,15 @@ import ClassyPrelude
 import Utils
 import Control.Lens
 
-import Data.Map (Map)
-import qualified Data.Map as Map
 import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.Fixed
 import Data.Monoid (Sum(..))
+import Data.Maybe (fromJust)
+import Data.Universe
+import Data.Universe.Helpers
+
+import Text.Read (readMaybe)
 
 import Database.Persist.TH
 import Database.Persist.Class
@@ -32,15 +35,14 @@ import Web.HttpApiData
 import Data.Text (Text)
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
-
-import Text.Read (readMaybe,readsPrec)
+import qualified Data.Text.Lens as Text
 
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
 
 import Yesod.Core.Dispatch (PathPiece(..))
 import Data.Aeson (FromJSON(..), ToJSON(..), withText, Value(..))
-import Data.Aeson.TH (deriveJSON, defaultOptions)
+import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..))
 
 import GHC.Generics (Generic)
 import Generics.Deriving.Monoid (gmemptydefault, gmappenddefault)
@@ -107,19 +109,19 @@ data SheetGroup
 deriveJSON defaultOptions ''SheetGroup
 derivePersistFieldJSON "SheetGroup"
 
-enumFromPathPiece :: (PathPiece a, Enum a, Bounded a) => Text -> Maybe a
-enumFromPathPiece t = lookup (CI.mk t) [(CI.mk $ toPathPiece ty,ty) | ty <- [minBound..maxBound]]
-
 data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking
   deriving (Show, Read, Eq, Ord, Enum, Bounded)
 derivePersistField "SheetFileType"
 
+instance Universe SheetFileType where universe = universeDef
+instance Finite SheetFileType
+
 instance PathPiece SheetFileType where
   toPathPiece SheetExercise = "file"
   toPathPiece SheetHint     = "hint"
   toPathPiece SheetSolution = "solution"
   toPathPiece SheetMarking  = "marking"
-  fromPathPiece = enumFromPathPiece
+  fromPathPiece = finiteFromPathPiece
 
 -- $(deriveSimpleWith ''DisplayAble 'display (drop 17) ''SheetFileType)
 instance DisplayAble SheetFileType where -- deprecated, see RenderMessage instance in Foundation
@@ -148,6 +150,9 @@ partitionFileType fts =
 data SubmissionFileType = SubmissionOriginal | SubmissionCorrected
   deriving (Show, Read, Eq, Ord, Enum, Bounded)
 
+instance Universe SubmissionFileType where universe = universeDef
+instance Finite SubmissionFileType
+
 submissionFileTypeIsUpdate :: SubmissionFileType -> Bool
 submissionFileTypeIsUpdate SubmissionOriginal  = False
 submissionFileTypeIsUpdate SubmissionCorrected = True
@@ -159,7 +164,7 @@ isUpdateSubmissionFileType True  = SubmissionCorrected
 instance PathPiece SubmissionFileType where
   toPathPiece SubmissionOriginal  = "original"
   toPathPiece SubmissionCorrected = "corrected"
-  fromPathPiece = enumFromPathPiece
+  fromPathPiece = finiteFromPathPiece
 
 instance DisplayAble SubmissionFileType where
   display SubmissionOriginal  = "Abgabe"
@@ -319,38 +324,43 @@ data StudyFieldType = FieldPrimary | FieldSecondary
   deriving (Eq, Ord, Enum, Show, Read, Bounded)
 derivePersistField "StudyFieldType"
 
+data Theme
+  = ThemeDefault
+  | ThemeLavender
+  | ThemeNeutralBlue
+  | ThemeAberdeenReds
+  | ThemeMossGreen
+  | ThemeSkyLove
+  deriving (Eq, Ord, Bounded, Enum, Show, Read)
 
--- Skins / Themes
-data Theme       --Simply add Themes to this type only. CamelCase will be converted to "-lower"
-  = Default
-  | Lavender
-  | NeutralBlue
-  | AberdeenReds -- e.g. turned into "theme--aberdeen-reds"
-  | MossGreen
-  | SkyLove
-  deriving (Eq,Ord,Bounded,Enum)
+deriveJSON defaultOptions
+  { constructorTagModifier = fromJust . stripPrefix "Theme"
+  } ''Theme
 
-$(deriveJSON defaultOptions ''Theme)
-$(deriveShowWith uncamel ''Theme)                             -- show    for internal use in css/js
-$(deriveSimpleWith ''DisplayAble 'display camelSpace ''Theme) -- display to display at user
+instance Universe Theme where universe = universeDef
+instance Finite Theme
 
-allThemes :: [Theme]
-allThemes = [minBound..maxBound]
+instance PathPiece Theme where
+  toPathPiece = $(nullaryToPathPiece ''Theme [Text.intercalate "-" . map Text.toLower . unsafeTail . splitCamel])
+  fromPathPiece = finiteFromPathPiece
 
-readTheme :: Map String Theme
-readTheme = Map.fromList [ (show t,t) | t <- allThemes ]
+$(deriveSimpleWith ''DisplayAble 'display (over Text.packed $ Text.intercalate " " . unsafeTail . splitCamel) ''Theme) -- describe theme to user
+  
+-- derivePersistFieldJSON "Theme" -- Preferred Version
+-- Backwards-compatibility until database versioning is implemented (#120):
+instance PersistField Theme where
+  toPersistValue = PersistText . ("theme--" <>) . toPathPiece
+  fromPersistValue (PersistText t) = do
+    pp <- case Text.stripPrefix "theme--" t of
+      Just pp -> return pp
+      Nothing -> Left "Expected 'theme--'-Prefix"
+    case fromPathPiece pp of
+      Just th -> return th
+      Nothing -> Left "Could not parse PathPiece"
+  fromPersistValue x = Left $ "Expected PersistText, received: " <> tshow x
 
-instance Read Theme where -- generic Read-Instance for Show/Bounded
-  readsPrec _ s
-    | (Just t) <- (Map.lookup s readTheme) = [(t,"")]
-    | otherwise = [(Default,"")] -- read shall always succeed
-
-{-
-instance Default Theme where
-  def = Default
--}
-
-derivePersistField "Theme"
+instance PersistFieldSql Theme where
+  sqlType _ = SqlString
 
 
 newtype ZIPArchiveName obj = ZIPArchiveName { unZIPArchiveName :: obj }
@@ -380,6 +390,9 @@ instance PersistField (CI String) where
 instance PersistFieldSql (CI Text) where
   sqlType _ = SqlOther "citext"
 
+instance PersistFieldSql (CI String) where
+  sqlType _ = SqlOther "citext"
+
 instance ToJSON a => ToJSON (CI a) where
   toJSON = toJSON . CI.original
 

src/Utils.hs

@@ -25,6 +25,7 @@ import qualified Data.CaseInsensitive as CI
 import Utils.DB as Utils
 import Utils.Common as Utils
 import Utils.DateTime as Utils
+import Utils.PathPiece as Utils
 
 import Text.Blaze (Markup, ToMarkup)
 
@@ -109,24 +110,6 @@ withFragment :: ( Monad m
 withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >> widget)
 
 
-uncamel :: String -> String -- "Model.Theme.CamelCaseThing" -> "camel-case-thing"
-uncamel = ("theme-" ++) . reverse . foldl helper []
-  where
-    helper _   '.' = []
-    helper acc  c
-      | Char.isSpace c = acc
-      | Char.isUpper c = Char.toLower c : '-' : acc
-      | otherwise      = c : acc
-
-camelSpace :: String -> String -- "Model.Theme.CamelCaseThing" -> "Camel Case Thing"
-camelSpace = reverse . foldl helper []
-  where
-    helper _   '.' = []
-    helper acc  c
-      | Char.isSpace c = acc
-      | Char.isUpper c = c : ' ' : acc
-      | otherwise      = c : acc
-
 -- Convert anything to Text, and I don't care how
 class DisplayAble a where
   display :: a -> Text

src/Utils/Common.hs

@@ -73,7 +73,7 @@ deriveSimpleWith cls fun strOp ty = do
     genClause :: Con -> Q Clause
     genClause (NormalC name []) =
       let pats = [ConP name []]
-          body = NormalB $ LitE $ StringL $ strOp $ show $ name
+          body = NormalB $ LitE $ StringL $ strOp $ nameBase name
       in return $ Clause pats body []
     genClause _ = fail "deriveShowTheme: constructors not allowed to have arguments"
 

src/Utils/PathPiece.hs

@@ -0,0 +1,51 @@
+{-# LANGUAGE NoImplicitPrelude
+  #-}
+
+module Utils.PathPiece
+  ( finiteFromPathPiece
+  , nullaryToPathPiece
+  , splitCamel
+  ) where
+
+import ClassyPrelude.Yesod
+
+import Language.Haskell.TH
+import qualified Language.Haskell.TH.Syntax as TH (Lift(..))
+import Data.Universe
+
+import qualified Data.Text as Text
+import qualified Data.Char as Char
+
+import Data.Monoid (Endo(..))
+
+finiteFromPathPiece :: (PathPiece a, Finite a) => Text -> Maybe a
+finiteFromPathPiece text = case filter (\c -> toPathPiece c == text) universeF of
+  [x] -> Just x
+  _xs -> Nothing
+
+nullaryToPathPiece :: Name -> [Text -> Text] -> ExpQ
+nullaryToPathPiece nullaryType manglers = do
+  TyConI (DataD _ _ _ _ constructors _) <- reify nullaryType
+  helperName <- newName "helper"
+  let
+    toClause (NormalC cName []) = clause [conP cName []] (normalB . TH.lift . mangle $ nameBase cName) []
+    toClause con = fail $ "Unsupported constructor: " ++ show con
+    helperDec = funD helperName $ map toClause constructors
+  letE [helperDec] $ varE helperName
+  where
+    mangle = appEndo (foldMap Endo manglers) . Text.pack
+  
+splitCamel :: Text -> [Text]
+splitCamel = map Text.pack . reverse . helper (error "hasChange undefined at start of string") [] "" . Text.unpack
+  where
+    helper hadChange words thisWord [] = reverse thisWord : words
+    helper hadChange words [] (c:cs) = helper True words [c] cs
+    helper hadChange words ws@(w:ws') (c:cs)
+      | sameCategory w c
+      , null ws'         = helper False words (c:ws) cs
+      | sameCategory w c = helper hadChange words (c:ws) cs
+      | null ws'         = helper True words (c:ws) cs
+      | not hadChange    = helper True (reverse ws':words) [c,w] cs
+      | otherwise        = helper True (reverse ws:words) [c] cs
+
+    sameCategory = (==) `on` Char.generalCategory

start.sh

@@ -7,4 +7,15 @@ export DUMMY_LOGIN=true
 export ALLOW_DEPRECATED=true
 export PWFILE=users.yml
 
-exec -- stack exec -- yesod devel
+move-back() {
+    mv -v .stack-work .stack-work-run
+    [[ -d .stack-work-ghci ]] && mv -v .stack-work-ghci .stack-work
+}
+
+if [[ -d .stack-work-run ]]; then
+    [[ -d .stack-work ]] && mv -v .stack-work .stack-work-ghci
+    mv -v .stack-work-run .stack-work
+    trap move-back EXIT
+fi
+
+stack exec -- yesod devel

templates/default-layout-wrapper.hamlet

@@ -39,7 +39,7 @@ $newline never
       }
 
 
-  <body .no-js .#{currentTheme} :isAuth:.logged-in>
+  <body .no-js .theme--#{toPathPiece currentTheme} :isAuth:.logged-in>
     <!-- removes no-js class from body if client supports javascript -->
     <script>
       document.body.classList.remove('no-js');

templates/profile.julius

@@ -1,6 +1,6 @@
 document.addEventListener('DOMContentLoaded', function () {
 
-  var themeSelector = document.querySelector('[placeholder="theme-select"]');
+  var themeSelector = document.querySelector('#theme-select');
   themeSelector.addEventListener('change', function() {
     // get rid of old themes on body
     var options = Array.from(themeSelector.options)
@@ -8,10 +8,10 @@ document.addEventListener('DOMContentLoaded', function () {
       document.body.classList.remove(optionToTheme(option));
     });
     // add newly selected theme
-    document.body.classList.add(optionToTheme(themeSelector.options[themeSelector.value - 1]));
+    document.body.classList.add(optionToTheme(themeSelector.selectedOptions[0]));
   });
 
   function optionToTheme(option) {
-    return optionValue = 'theme--' + option.innerText.toLowerCase().trim().replace(/\s/g, '-');
+    return optionValue = 'theme--' + option.value;
   }
 });