Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX

src/Handler/Sheet.hs

@@ -85,17 +85,19 @@ data SheetForm = SheetForm
       -- Keine SheetId im Formular!
       }
 
+getFtIdMap :: Key Sheet -> DB (SheetFileType -> Set FileId)
+getFtIdMap sId = do
+  allfIds <- E.select . E.from $ \(sheetFile `E.InnerJoin` file) -> do
+      E.on     $ sheetFile E.^. SheetFileFile  E.==. file E.^. FileId
+      E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sId
+      return    (sheetFile E.^. SheetFileType, file E.^. FileId)
+  return $ partitionFileType [(t,i)|(E.Value t, E.Value i) <- allfIds]
 
 makeSheetForm :: Maybe SheetId -> Maybe SheetForm -> Form SheetForm
 makeSheetForm msId template = identForm FIDsheet $ \html -> do
-    -- TODO: SJ to refactor this; extract Code from getSEditR to joint code piece
-    let oldFileIds fType
-          | Just sId <- msId = fmap setFromList . fmap (map E.unValue) . runDB . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
-              E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile
-              E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sId
-                   E.&&. sheetFile E.^. SheetFileType    E.==. E.val fType
-              return (file E.^. FileId)
-          | otherwise = return Set.empty
+    oldFileIds <- (return.) <$> case msId of
+      Nothing    -> return $ partitionFileType mempty
+      (Just sId) -> liftHandlerT $ runDB $ getFtIdMap sId
     mr <- getMsgRenderer
     ctime <- liftIO $ getCurrentTime
     (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
@@ -316,13 +318,8 @@ getSEditR :: TermId -> Text -> Text -> Handler Html
 getSEditR tid csh shn = do
   (sheetEnt, sheetFileIds) <- runDB $ do
     ent <- fetchSheet tid csh shn
-    allfIds <- E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
-      E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile
-      E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val (entityKey ent)
-      return (sheetFile E.^. SheetFileType, file E.^. FileId)
-    let ftIds :: SheetFileType -> Set FileId
-        ftIds ft = Set.fromList $ mapMaybe (\(E.Value t, E.Value i) -> i <$ guard (ft==t)) allfIds
-    return (ent, ftIds)
+    fti <- getFtIdMap $ entityKey ent
+    return (ent, fti)
   let sid = entityKey sheetEnt
   let oldSheet@(Sheet {..}) = entityVal sheetEnt
   let template = Just $ SheetForm

src/Model/Types.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -15,6 +16,8 @@ import Utils
 
 import Data.Map (Map)
 import qualified Data.Map as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
 import Data.Fixed
 
 import Database.Persist.TH
@@ -95,6 +98,23 @@ instance DisplayAble SheetFileType where -- deprecated, see RenderMessage instan
   display SheetSolution = "Musterlösung"
   display SheetMarking  = "Korrekturhinweise"
 
+-- partitionFileType' :: Ord a => [(SheetFileType,a)] -> Map SheetFileType (Set a)
+-- partitionFileType' = groupMap
+
+partitionFileType :: Ord a => [(SheetFileType,a)] -> SheetFileType -> Set a
+partitionFileType fts =
+    let (se,sh,ss,sm) = foldl' switchft (Set.empty,Set.empty,Set.empty,Set.empty) fts
+    in \case  SheetExercise -> se
+              SheetHint     -> sh
+              SheetSolution -> ss
+              SheetMarking  -> sm
+  where
+    switchft :: Ord a => (Set a, Set a, Set a, Set a) -> (SheetFileType,a) -> (Set a, Set a, Set a, Set a)
+    switchft (se,sh,ss,sm) (SheetExercise,x) = (Set.insert x se, sh, ss, sm)
+    switchft (se,sh,ss,sm) (SheetHint    ,x) = (se, Set.insert x sh, ss, sm)
+    switchft (se,sh,ss,sm) (SheetSolution,x) = (se, sh, Set.insert x ss, sm)
+    switchft (se,sh,ss,sm) (SheetMarking ,x) = (se, sh, ss, Set.insert x sm)
+
 data SubmissionFileType = SubmissionOriginal | SubmissionCorrected
   deriving (Show, Read, Eq, Ord, Enum, Bounded)
 

src/Utils.hs

@@ -23,8 +23,10 @@ import Utils.DateTime as Utils
 
 import Text.Blaze (Markup, ToMarkup)
 
--- import Data.Map (Map)
--- import qualified Data.Map as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Map (Map)
+import qualified Data.Map as Map
 -- import qualified Data.List as List
 
 import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
@@ -154,6 +156,17 @@ trd3 (_,_,z) = z
 -- Maps --
 ----------
 
+infixl 5 !!!
+
+
+(!!!) :: (Ord k, Monoid v) => Map k v -> k -> v
+(!!!) m k = (fromMaybe mempty) $ Map.lookup k m
+
+groupMap :: (Ord k, Ord v) => [(k,v)] -> Map k (Set v)
+groupMap l = Map.fromListWith mappend $ [(k, Set.singleton v) | (k,v) <- l]
+
+partMap :: (Ord k, Monoid v) => [(k,v)] -> Map k v
+partMap = Map.fromListWith mappend
 
 -----------
 -- Maybe --