Convenience for new exercise sheets implemented.

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)
     }

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

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
+withFragment :: Monad m => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ())
-                ) => 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,
+{- We do not want DisplayAble for every Show-Class:
-   for example, UTCTime values were shown without proper rendering!
+   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!
--- The easy way out of UndecidableInstances (TypeFamilies would have been proper, but are much more complicated)
+instance {-# OVERLAPPABLE #-} Show a => DisplayAble a where -- The easy way out of UndecidableInstances (TypeFamilies would have been proper, but are much more complicated)
-instance {-# OVERLAPPABLE #-} Show a => DisplayAble a where
   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 --
 ------------

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

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 items thisWord [] = reverse thisWord : items
-    helper hadChange words [] (c:cs) = helper True words [c] cs
+    helper _hadChange items [] (c:cs) = helper True items [c] cs
-    helper hadChange words ws@(w:ws') (c:cs)
+    helper  hadChange items ws@(w:ws') (c:cs)
       | sameCategory w c
-      , null ws'         = helper False words (c:ws) cs
+      , null ws'         = helper False items (c:ws) cs
-      | sameCategory w c = helper hadChange words (c:ws) cs
+      | sameCategory w c = helper hadChange items (c:ws) cs
-      | null ws'         = helper True words (c:ws) cs
+      | null ws'         = helper True items (c:ws) cs
-      | not hadChange    = helper True (reverse ws':words) [c,w] cs
+      | not hadChange    = helper True (reverse ws':items) [c,w] cs
-      | otherwise        = helper True (reverse ws:words) [c] cs
+      | otherwise        = helper True (reverse ws :items) [c] cs
 
     sameCategory = (==) `on` Char.generalCategory