From eed3cf51aea4f3823adcfc9868d90441350db054 Mon Sep 17 00:00:00 2001 From: SJost Date: Tue, 18 Sep 2018 10:45:44 +0200 Subject: [PATCH] Convenience for new exercise sheets implemented. --- src/Foundation.hs | 2 +- src/Handler/Sheet.hs | 27 +++++++++++++++++- src/Utils.hs | 62 ++++++++++++++++++++++++++++++------------ src/Utils/DateTime.hs | 7 +++++ src/Utils/PathPiece.hs | 16 +++++------ 5 files changed, 87 insertions(+), 27 deletions(-) diff --git a/src/Foundation.hs b/src/Foundation.hs index ab3649634..e5a4dc284 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -145,7 +145,7 @@ pattern CSubmissionR tid ssh csh shn cid ptn -- Menus and Favourites data MenuItem = MenuItem { menuItemLabel :: Text - , menuItemIcon :: Maybe Text + , menuItemIcon :: Maybe Text , menuItemRoute :: Route UniWorX , menuItemAccessCallback' :: Handler Bool -- Check whether action is shown in ADDITION to authorization (which is always checked) } diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 8ea156247..5432fe202 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -349,7 +349,32 @@ getSFileR tid ssh csh shn typ title = do getSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getSheetNewR tid ssh csh = do - let template = Nothing -- TODO: provide convenience by interpolating name/nr/dates+7days + lastSheets <- runDB $ E.select . E.from $ \(course `E.InnerJoin` sheet) -> do + E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.orderBy [E.desc (sheet E.^. SheetActiveFrom)] + E.limit 1 + return sheet + let template = case lastSheets of + ((Entity {entityVal=Sheet{..}}):_) -> Just $ SheetForm + { sfName = stepTextCounterCI sheetName + , sfDescription = sheetDescription + , sfType = sheetType + , sfGrouping = sheetGrouping + , sfMarkingText = sheetMarkingText + , sfVisibleFrom = addOneWeek <$> sheetVisibleFrom + , sfActiveFrom = addOneWeek sheetActiveFrom + , sfActiveTo = addOneWeek sheetActiveTo + , sfSheetF = Nothing + , sfHintFrom = addOneWeek <$> sheetHintFrom + , sfHintF = Nothing + , sfSolutionFrom = addOneWeek <$> sheetSolutionFrom + , sfSolutionF = Nothing + , sfMarkingF = Nothing + } + _other -> Nothing let action newSheet = -- More specific error message for new sheet could go here, if insertUnique returns Nothing insertUnique $ newSheet handleSheetEdit tid ssh csh Nothing template action diff --git a/src/Utils.hs b/src/Utils.hs index 1d1b1bcde..65227a604 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -3,7 +3,7 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} {-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-} {-# LANGUAGE QuasiQuotes, TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} @@ -16,7 +16,7 @@ module Utils import ClassyPrelude.Yesod -- import Data.Double.Conversion.Text -- faster implementation for textPercent? -import Data.Foldable as Fold +import Data.Foldable as Fold hiding (length) import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI @@ -28,7 +28,8 @@ import Utils.PathPiece as Utils import Text.Blaze (Markup, ToMarkup) -import Data.Text (dropWhileEnd) +import Data.Char (isDigit) +import Data.Text (dropWhileEnd, takeWhileEnd, justifyRight) import Numeric (showFFloat) import Control.Lens @@ -50,6 +51,8 @@ import Instances.TH.Lift () import Text.Shakespeare.Text (st) + + ----------- -- Yesod -- ----------- @@ -85,6 +88,7 @@ unsupportedAuthPredicate = do |] + --------------------- -- Text and String -- --------------------- @@ -100,6 +104,9 @@ tickmarkT = tickmark text2Html :: Text -> Html text2Html = toHtml -- prevents ambiguous types +liftCI :: (Text -> Text) -> (CI Text) -> (CI Text) +liftCI f ci = CI.mk $ f $ CI.original ci + toWgt :: (ToMarkup a, MonadBaseControl IO m, MonadThrow m, MonadIO m) => a -> WidgetT site m () toWgt = toWidget . toHtml @@ -121,15 +128,14 @@ display2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m, DisplayAble a -> WidgetT site m () display2widget = text2widget . display -withFragment :: ( Monad m - ) => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ()) +withFragment :: Monad m => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ()) withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >> widget) --- Convert anything to Text, and I don't care how +-- Types that can be converted to Text for direct displayed to User! (Show for debugging, Display for Production) class DisplayAble a where display :: a -> Text - -- Default definitions for type belonging to Show (allows empty instanc declarations) + -- Default definitions for types belonging to Show (allows empty instance declarations) default display :: Show a => a -> Text display = pack . show @@ -139,10 +145,6 @@ instance DisplayAble Text where instance DisplayAble String where display = pack -instance DisplayAble a => DisplayAble (Maybe a) where - display Nothing = "" - display (Just x) = display x - instance DisplayAble Int instance DisplayAble Int64 instance DisplayAble Integer @@ -156,19 +158,21 @@ instance DisplayAble Rational where rat2float :: Rational -> Double rat2float = fromRational +instance DisplayAble a => DisplayAble (Maybe a) where + display Nothing = "" + display (Just x) = display x + instance DisplayAble a => DisplayAble (E.Value a) where display = display . E.unValue instance DisplayAble a => DisplayAble (CI a) where display = display . CI.original -{- We do not want DisplayAble for every Show-Class, we want to check that it looks good and explicitely add Instances only, - for example, UTCTime values were shown without proper rendering! - --- The easy way out of UndecidableInstances (TypeFamilies would have been proper, but are much more complicated) -instance {-# OVERLAPPABLE #-} Show a => DisplayAble a where +{- We do not want DisplayAble for every Show-Class: + We want to explicitly verify that the resulting text can be displayed to the User! + For example: UTCTime values were shown without proper format rendering! +instance {-# OVERLAPPABLE #-} Show a => DisplayAble a where -- The easy way out of UndecidableInstances (TypeFamilies would have been proper, but are much more complicated) display = pack . show - -} textPercent :: Double -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead? @@ -180,6 +184,22 @@ textPercent x = lz <> (pack $ show rx) <> "%" rx = fromIntegral (round' $ 1000.0*x) / 10.0 lz = if rx < 10.0 then "0" else "" +stepTextCounterCI :: CI Text -> CI Text -- find and increment rightmost-number, preserving leading zeroes +stepTextCounterCI = liftCI stepTextCounter + +stepTextCounter :: Text -> Text -- find and increment rightmost-number, preserving leading zeroes +stepTextCounter text + | (Just i) <- readMay number = + let iplus1 = tshow (succ i :: Int) + zeroip = justifyRight (length number) '0' iplus1 + in prefix <> zeroip <> suffix + | otherwise = text + where -- no splitWhile nor findEnd in Data.Text + suffix = takeWhileEnd (not . isDigit) text + number = takeWhileEnd isDigit $ dropWhileEnd (not . isDigit) text + prefix = dropWhileEnd isDigit $ dropWhileEnd (not . isDigit) text + + ------------ -- Tuples -- @@ -197,6 +217,7 @@ trd3 (_,_,z) = z -- snd3 = $(projNI 3 2) + ----------- -- Lists -- ----------- @@ -229,6 +250,8 @@ mergeAttrs = mergeAttrs' `on` sort mergeAttrs' [] xs2 = xs2 mergeAttrs' xs1 [] = xs1 + + ---------- -- Maps -- ---------- @@ -248,6 +271,8 @@ partMap = Map.fromListWith mappend invertMap :: (Ord k, Ord v) => Map k v -> Map v (Set k) invertMap = groupMap . map swap . Map.toList + + ----------- -- Maybe -- ----------- @@ -296,6 +321,8 @@ instance Ord a => Ord (NTop (Maybe a)) where compare _ (NTop Nothing) = LT compare (NTop (Just x)) (NTop (Just y)) = compare x y + + --------------- -- Exception -- --------------- @@ -325,6 +352,7 @@ catchIfMExceptT :: (MonadCatch m, Exception e) => (e -> m e') -> (e -> Bool) -> catchIfMExceptT err p act = catchIf p (lift act) (throwE <=< lift . err) + ------------ -- Monads -- ------------ diff --git a/src/Utils/DateTime.hs b/src/Utils/DateTime.hs index cb9135120..ee33ccc72 100644 --- a/src/Utils/DateTime.hs +++ b/src/Utils/DateTime.hs @@ -10,6 +10,7 @@ module Utils.DateTime ( timeLocaleMap , TimeLocale(..) , currentYear + , addOneWeek , module Data.Time.Zones , module Data.Time.Zones.TH ) where @@ -18,6 +19,7 @@ import ClassyPrelude.Yesod hiding (lift) import System.Locale.Read import Data.Time (TimeZone(..), TimeLocale(..)) +import Data.Time.Clock (addUTCTime,nominalDay) import Data.Time.Zones (TZ) import Data.Time.Zones.TH (includeSystemTZ) @@ -28,6 +30,11 @@ import Instances.TH.Lift () deriving instance Lift TimeZone deriving instance Lift TimeLocale + +addOneWeek :: UTCTime -> UTCTime +addOneWeek = addUTCTime (7 * nominalDay) --better use nominalWeek + + -- $(timeLocaleMap _) :: [Lang] -> TimeLocale timeLocaleMap :: [(Lang, String)] -- ^ Languages and matching locales, first is taken as default -> ExpQ diff --git a/src/Utils/PathPiece.hs b/src/Utils/PathPiece.hs index a56358638..13f79cff9 100644 --- a/src/Utils/PathPiece.hs +++ b/src/Utils/PathPiece.hs @@ -38,14 +38,14 @@ nullaryToPathPiece nullaryType manglers = do 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) + helper _hadChange items thisWord [] = reverse thisWord : items + helper _hadChange items [] (c:cs) = helper True items [c] cs + helper hadChange items 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 + , null ws' = helper False items (c:ws) cs + | sameCategory w c = helper hadChange items (c:ws) cs + | null ws' = helper True items (c:ws) cs + | not hadChange = helper True (reverse ws':items) [c,w] cs + | otherwise = helper True (reverse ws :items) [c] cs sameCategory = (==) `on` Char.generalCategory