Convenience for new exercise sheets implemented.
This commit is contained in:
SJost
parent
c684692cc2
commit
eed3cf51ae
@ -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)
|
||||
}
|
||||
|
||||
@ -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
|
||||
|
||||
62
src/Utils.hs
62
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 --
|
||||
------------
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user