Generic Join projections implemented

src/Database/Esqueleto/Utils.hs

@@ -55,6 +55,10 @@ all test = F.foldr (\needle acc -> acc E.&&. test needle) true
 
 $(sqlInTuples [2..16])
 
+-- | Example for usage of sqlIJproj
+-- queryFeaturesDegree :: (a `E.InnerJoin` b `E.InnerJoin` c) -> b
+-- queryFeaturesDegree  = $(sqlIJproj 3 2)
+
 
 -- | generic filter creation for dbTable
 --   Given a lens-like function, make filter for exact matches in a collection
@@ -66,7 +70,7 @@ mkExactFilter :: (PersistField a)
   -> E.SqlExpr (E.Value Bool)
 mkExactFilter lenslike row criterias
   | Set.null criterias = true
-  | otherwise = (lenslike row) `E.in_` E.valList (Set.toList criterias)
+  | otherwise = lenslike row `E.in_` E.valList (Set.toList criterias)
 
 -- | generic filter creation for dbTable
 --   Given a lens-like function, make filter searching for needles in String-like elements

src/Database/Esqueleto/Utils/TH.hs

@@ -1,6 +1,7 @@
 module Database.Esqueleto.Utils.TH
   ( SqlIn(..)
   , sqlInTuple, sqlInTuples
+  , sqlIJproj, sqlLOJproj
   ) where
 
 import ClassyPrelude
@@ -14,6 +15,8 @@ import Language.Haskell.TH
 
 import Data.List (foldr1, foldl)
 
+import Utils.TH
+
 class E.SqlSelect a r => SqlIn a r | a -> r, r -> a where
   sqlIn :: a -> [r] -> E.SqlExpr (E.Value Bool)
 
@@ -45,4 +48,11 @@ sqlInTuple arity = do
       ]
     ]
 
+-- | Generic projections for InnerJoin-tuples
+--   gives I-th element of N-tuple of left-associative InnerJoin-pairs,
+--   i.e. @$(projN n m) :: (t1 `E.InnerJoin` .. `E.InnerJoin` tn) -> tm@ (for m<=n)
+sqlIJproj :: Int -> Int -> ExpQ
+sqlIJproj = leftAssociativePairProjection 'E.InnerJoin
 
+sqlLOJproj :: Int -> Int -> ExpQ
+sqlLOJproj = leftAssociativePairProjection 'E.LeftOuterJoin

src/Handler/Course.hs

@@ -14,6 +14,7 @@ import Handler.Utils.Database
 import Handler.Utils.Table.Cells
 import Handler.Utils.Table.Columns
 import Database.Esqueleto.Utils
+import Database.Esqueleto.Utils.TH
 
 -- import Data.Time
 -- import qualified Data.Text as T
@@ -701,24 +702,31 @@ _rowUserSemester = _userTableFeatures . _1 . _Just . _studyFeaturesSemester
 queryUser :: UserTableExpr -> E.SqlExpr (Entity User)
 queryUser ((user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note `E.LeftOuterJoin` _studyFeatures) = user
 
+-- No longer needed:
 -- queryUserName :: UserTableExpr -> E.SqlExpr (E.Value Text)
 -- queryUserName ((user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note `E.LeftOuterJoin` _studyFeatures) = user E.^. UserDisplayName
 
 -- queryUserDisplayName :: UserTableExpr -> E.SqlExpr (E.Value Text)
 -- queryUserDisplayName ((user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note `E.LeftOuterJoin` _studyFeatures) = user E.^. UserDisplayName
 
+queryUserNote ::  UserTableExpr -> E.SqlExpr (Maybe (Entity CourseUserNote))
+queryUserNote ((_user `E.InnerJoin` _participant) `E.LeftOuterJoin` note `E.LeftOuterJoin` _studyFeatures) = note
+
 queryUserFeatures :: UserTableExpr -> (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin`E.SqlExpr (Maybe (Entity StudyTerms)))
 queryUserFeatures ((_user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note `E.LeftOuterJoin` studyFeatures) = studyFeatures
 
+queryFeaturesDegree ::  (a `E.InnerJoin` b `E.InnerJoin` c) -> b
+queryFeaturesDegree = $(sqlIJproj 3 2)
+
 queryUserSemester :: UserTableExpr -> E.SqlExpr (E.Value (Maybe Int)) -- (E.Value (Maybe Int))
 queryUserSemester = aux . queryUserFeatures
   where aux (features `E.InnerJoin` _degree `E.InnerJoin` _terms)
           = features E.?. StudyFeaturesSemester
 
 -- Deprecated in favour of newer implementation
-queryUserSemester' :: UserTableExpr -> E.SqlExpr (E.Value (Maybe Int)) -- (E.Value (Maybe Int))
+-- queryUserSemester :: UserTableExpr -> E.SqlExpr (E.Value (Maybe Int)) -- (E.Value (Maybe Int))
-queryUserSemester' ((_user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note `E.LeftOuterJoin` (features `E.InnerJoin` _degree `E.InnerJoin` _terms) )
+-- queryUserSemester ((_user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note `E.LeftOuterJoin` (features `E.InnerJoin` _degree `E.InnerJoin` _terms) )
-    = features E.?. StudyFeaturesSemester
+--   = features E.?. StudyFeaturesSemester
 
 colUserComment :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c)
 colUserComment tid ssh csh =
@@ -759,19 +767,28 @@ makeCourseUserTable cid colChoices psValidator =
       dbtProj      = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms))
       dbtColonnade = colChoices
       dbtSorting   = Map.fromList
-        [ sortUserNameLink    queryUser
+        [ sortUserNameLink    queryUser -- slower sorting through clicking name column header
+        , sortUserSurname     queryUser -- needed for initial sorting
         , sortUserDisplayName queryUser -- needed for initial sorting
         , sortUserEmail       queryUser
         , sortUserMatriclenr  queryUser
-        , ( "course-user-semesternr", SortColumn queryUserSemester) -- $ -- preview (_userTableFeatures . _1 . _Just . _studyFeaturesSemester))
+        , ("course-user-degree", SortColumn $ queryUserFeatures >>> queryFeaturesDegree >>> \degree -> degree E.?. StudyDegreeShorthand)
-        -- TODO
+        , ("course-user-field" , error "TODO") -- TODO
+        , ("course-user-semesternr", SortColumn queryUserSemester) -- $ -- preview (_userTableFeatures . _1 . _Just . _studyFeaturesSemester))
+        , ("course-user-note"      , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
+              E.sub_select . E.from $ \edit -> do
+                E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
+                return . E.max_ $ edit E.^. CourseUserNoteEditTime
+          )
         ]
       dbtFilter    = Map.fromList
         [ fltrUserNameLink    queryUser
         , fltrUserEmail       queryUser
         , fltrUserMatriclenr  queryUser
-        , ( "course-user-semesternr", FilterColumn $ mkExactFilter queryUserSemester)
+        , ("course-user-degree", error "TODO") -- TODO
-        -- TODO
+        , ("course-user-field" , error "TODO") -- TODO
+        , ("course-user-semesternr", FilterColumn $ mkExactFilter queryUserSemester)
+        , ("course-user-note", error "TODO") -- TODO
         ]
       dbtFilterUI  = mempty -- TODO
       dbtParams    = def

src/Handler/Utils/Table/Columns.hs

@@ -59,15 +59,15 @@ sortUserNameLink :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColu
 sortUserNameLink = sortUserName
 
 sortUserSurname :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
-sortUserSurname queryUser = ("user-surname", SortColumn $ compose queryUser (E.^. UserSurname))
+sortUserSurname queryUser = ("user-surname", SortColumn $ queryUser >>> (E.^. UserSurname))
 
 sortUserDisplayName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
-sortUserDisplayName queryUser = ("user-display-name", SortColumn $ compose queryUser (E.^. UserDisplayName))
+sortUserDisplayName queryUser = ("user-display-name", SortColumn $ queryUser >>> (E.^. UserDisplayName))
 
 defaultSortingByName :: PSValidator m x -> PSValidator m x
 defaultSortingByName =
-  -- defaultSorting [SortAscBy "user-surname", SortAscBy "user-display-name"] -- old way, requiring two exta sorters
+  defaultSorting [SortAscBy "user-surname", SortAscBy "user-display-name"] -- old way, requiring two exta sorters
-  defaultSorting [SortAscBy "user-name"] -- new way, untested, working with single sorter
+  -- defaultSorting [SortAscBy "user-name"] -- new way, untested, working with single sorter
 
 -- | Alias for sortUserName for consistency
 fltrUserNameLink :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) => (a -> E.SqlExpr (Entity User)) -> (d, FilterColumn t)
@@ -78,28 +78,24 @@ fltrUserName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), I
   -> (d, FilterColumn t)
 fltrUserName queryUser = ( "user-name", FilterColumn $ mkContainsFilter queryName )
   where
-    queryName = compose queryUser (E.^. UserDisplayName)
+    queryName = queryUser >>> (E.^. UserDisplayName)
 
 fltrUserNameExact :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
   => (a -> E.SqlExpr (Entity User))
   -> (d, FilterColumn t)
 fltrUserNameExact queryUser = ( "user-name", FilterColumn $ mkExactFilter queryName )
   where
-    queryName = compose queryUser (E.^. UserDisplayName)
+    queryName = queryUser >>> (E.^. UserDisplayName)
 
 fltrUserSurname :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
   => (a -> E.SqlExpr (Entity User))
   -> (d, FilterColumn t)
-fltrUserSurname queryUser = ( "user-surname", FilterColumn $ mkContainsFilter queryName )
+fltrUserSurname queryUser = ( "user-surname", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserSurname))
-  where
-    queryName = compose queryUser (E.^. UserSurname)
 
 fltrUserDisplayName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
   => (a -> E.SqlExpr (Entity User))
   -> (d, FilterColumn t)
-fltrUserDisplayName queryUser = ( "user-display-name", FilterColumn $ mkContainsFilter queryName )
+fltrUserDisplayName queryUser = ( "user-display-name", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserDisplayName))
-  where
-    queryName = compose queryUser (E.^. UserDisplayName)
 
 
 
@@ -109,12 +105,12 @@ colUserMatriclenr ::  (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell
 colUserMatriclenr = sortable (Just "user-matriclenumber") (i18nCell MsgMatrikelNr) cellHasMatrikelnummer
 
 sortUserMatriclenr :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t)
-sortUserMatriclenr queryUser = ( "user-matriclenumber", SortColumn $ compose queryUser (E.^. UserMatrikelnummer))
+sortUserMatriclenr queryUser = ( "user-matriclenumber", SortColumn $ queryUser >>> (E.^. UserMatrikelnummer))
 
 fltrUserMatriclenr :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
   => (a -> E.SqlExpr (Entity User))
   -> (d, FilterColumn t)
-fltrUserMatriclenr queryUser = ( "user-matriclenumber", FilterColumn $ mkContainsFilter $ compose queryUser (E.^. UserMatrikelnummer))
+fltrUserMatriclenr queryUser = ( "user-matriclenumber", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserMatrikelnummer))
 
 
 
@@ -124,11 +120,11 @@ colUserEmail ::  (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
 colUserEmail = sortable (Just "user-email") (i18nCell MsgEMail) cellHasEMail
 
 sortUserEmail :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t)
-sortUserEmail queryUser = ( "user-email", SortColumn $ compose queryUser (E.^. UserEmail))
+sortUserEmail queryUser = ( "user-email", SortColumn $ queryUser >>> (E.^. UserEmail))
 
 fltrUserEmail :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
   => (a -> E.SqlExpr (Entity User))
   -> (d, FilterColumn t)
-fltrUserEmail queryUser = ( "user-email", FilterColumn $ mkContainsFilter $ compose queryUser (E.^. UserEmail))
+fltrUserEmail queryUser = ( "user-email", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserEmail))
 
 

src/Utils.hs

@@ -24,8 +24,6 @@ import Utils.DateTime as Utils
 import Utils.PathPiece as Utils
 import Utils.Message as Utils
 import Utils.Lang as Utils
-import Control.Lens as Utils (none)
-
 
 import Text.Blaze (Markup, ToMarkup)
 
@@ -33,13 +31,16 @@ import Data.Char (isDigit, isSpace)
 import Data.Text (dropWhileEnd, takeWhileEnd, justifyRight)
 import Numeric (showFFloat)
 
-import Control.Lens
 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.Lens
+import Control.Lens as Utils (none)
+
+import Control.Arrow as Utils ((>>>))
 import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
 import Control.Monad.Except (MonadError(..))
 import Control.Monad.Trans.Maybe (MaybeT(..))
@@ -344,7 +345,10 @@ invertMap = groupMap . map swap . Map.toList
 -- Functions --
 ---------------
 
--- | Just @flip (.)@ for convenient formatting in some rare cases
+-- curryN, uncurryN see Utils.TH
+
+-- | Just @flip (.)@ for convenient formatting in some cases,
+--   Deprecated in favor of Control.Arrow.(>>>)
 compose :: (a -> b) -> (b -> c) -> (a -> c)
 compose = flip (.)
 

src/Utils/TH.hs

@@ -20,10 +20,25 @@ import Data.List ((!!), foldl)
 -- Alternatively uses lenses: "^. _3" projects the 3rd component of an n-tuple for any n >=3, requires import Control.Lens
 projNI :: Int -> Int -> ExpQ -- generic projection gives I-th element of N-tuple, i.e. snd3 = $(projNI 3 2)  --ghci -fth
 -- $(projN n m) :: (t1,..,tn) -> tm (for m<=n)
-projNI n i = lamE [pat] rhs
+projNI n i = do
-  where pat = tupP (map varP xs)
+  x <- newName "x"
-        rhs = varE (xs !! (i - 1))
+  let rhs = varE x
-        xs  = [ mkName $ "x" ++ show j | j <- [1..n] ]
+  let pat = tupP $ replicate (pred i) wildP ++ varP x : replicate (n-i) wildP
+  lamE [pat] rhs
+
+
+-- | Generic projections N-tuples that are actually left-associative pairs
+--   i.e. @$(leftAssociativePairProjection c n m :: (..(t1 `c` t2) `c` .. `c` tn) -> tm@ (for m<=n)
+leftAssociativePairProjection :: Name -> Int -> Int -> ExpQ
+leftAssociativePairProjection constructor n i = do
+    x <- newName "x"
+    lamE [pat x n] (varE x)
+  where
+    pat x 1       = varP x
+    pat x w
+      | w==i      = conP constructor [wildP, varP x]
+      | otherwise = conP constructor [pat x (pred w), wildP]
+
 
 ---------------
 -- Functions --