From 28c7afe69cc1bd458fcc47c29b6fe0fbc556ccd6 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 6 Aug 2018 22:16:33 +0200 Subject: [PATCH] Cleanup Theme declaration --- .gitignore | 1 + ghci.sh | 13 +++- package.yaml | 2 + src/Foundation.hs | 5 +- src/Handler/Profile.hs | 6 +- src/Import/NoFoundation.hs | 2 + src/Model/Types.hs | 87 ++++++++++++++----------- src/Utils.hs | 19 +----- src/Utils/Common.hs | 2 +- src/Utils/PathPiece.hs | 51 +++++++++++++++ start.sh | 13 +++- templates/default-layout-wrapper.hamlet | 2 +- templates/profile.julius | 6 +- 13 files changed, 142 insertions(+), 67 deletions(-) create mode 100644 src/Utils/PathPiece.hs diff --git a/.gitignore b/.gitignore index 9abd44d27..30a4364e2 100644 --- a/.gitignore +++ b/.gitignore @@ -29,3 +29,4 @@ uniworx.nix src/Handler/Assist.bak src/Handler/Course.SnapCustom.hs *.orig +.stack-work-* diff --git a/ghci.sh b/ghci.sh index 64adc58eb..5139c7c72 100755 --- a/ghci.sh +++ b/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 diff --git a/package.yaml b/package.yaml index 74bb7bf3c..60cff14a5 100644 --- a/package.yaml +++ b/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. diff --git a/src/Foundation.hs b/src/Foundation.hs index a28faf0ed..7aed4d78c 100644 --- a/src/Foundation.hs +++ b/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) diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 1d340adba..f869efc37 100644 --- a/src/Handler/Profile.hs +++ b/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) diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 665c509b5..5f0353d8b 100644 --- a/src/Import/NoFoundation.hs +++ b/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 diff --git a/src/Model/Types.hs b/src/Model/Types.hs index c836cedc7..64e4efe2c 100644 --- a/src/Model/Types.hs +++ b/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 diff --git a/src/Utils.hs b/src/Utils.hs index a95255a7e..ee0ffee23 100644 --- a/src/Utils.hs +++ b/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 diff --git a/src/Utils/Common.hs b/src/Utils/Common.hs index 8583ccf86..0bb828291 100644 --- a/src/Utils/Common.hs +++ b/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" diff --git a/src/Utils/PathPiece.hs b/src/Utils/PathPiece.hs new file mode 100644 index 000000000..a56358638 --- /dev/null +++ b/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 diff --git a/start.sh b/start.sh index b73e8bc05..da7e422d4 100755 --- a/start.sh +++ b/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 diff --git a/templates/default-layout-wrapper.hamlet b/templates/default-layout-wrapper.hamlet index ceb3c44b4..3eba4f9f1 100644 --- a/templates/default-layout-wrapper.hamlet +++ b/templates/default-layout-wrapper.hamlet @@ -39,7 +39,7 @@ $newline never } - +