diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index f3594d523..4e3e85e22 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/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 diff --git a/src/Database/Esqueleto/Utils/TH.hs b/src/Database/Esqueleto/Utils/TH.hs index 7ae382959..5596f31ee 100644 --- a/src/Database/Esqueleto/Utils/TH.hs +++ b/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) @@ -33,7 +36,7 @@ sqlInTuple arity = do let matchE = lam1E (tupP $ map (\vV -> conP 'E.Value [varP vV]) vVs) (foldr1 (\e1 e2 -> [e|$(e1) E.&&. $(e2)|]) . map (\(varE -> vE, varE -> xE) -> [e|E.val $(vE) E.==. $(xE)|]) $ zip vVs xVs) tupTy f = foldl (\typ v -> typ `appT` f (varT v)) (tupleT arity) tyVars - + instanceD (cxt $ map (\v -> [t|PersistField $(varT v)|]) tyVars) [t|SqlIn $(tupTy $ \v -> [t|E.SqlExpr (E.Value $(v))|]) $(tupTy $ \v -> [t|E.Value $(v)|])|] [ funD 'sqlIn [ clause [tupP $ map varP xVs, varP xsV] @@ -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 diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index abb9e27e7..a9f30a8ce 100644 --- a/src/Handler/Course.hs +++ b/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' ((_user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note `E.LeftOuterJoin` (features `E.InnerJoin` _degree `E.InnerJoin` _terms) ) - = features E.?. StudyFeaturesSemester +-- 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) ) +-- = 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)) - -- TODO + , ("course-user-degree", SortColumn $ queryUserFeatures >>> queryFeaturesDegree >>> \degree -> degree E.?. StudyDegreeShorthand) + , ("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) - -- TODO + , ("course-user-degree", error "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 diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 7b384d0db..507ba10bf 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/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-name"] -- new way, untested, working with single sorter + 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 -- | 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 ) - where - queryName = compose queryUser (E.^. UserSurname) +fltrUserSurname queryUser = ( "user-surname", FilterColumn $ mkContainsFilter $ 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 ) - where - queryName = compose queryUser (E.^. UserDisplayName) +fltrUserDisplayName queryUser = ( "user-display-name", FilterColumn $ mkContainsFilter $ 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)) diff --git a/src/Utils.hs b/src/Utils.hs index 33027639a..cd735a6c0 100644 --- a/src/Utils.hs +++ b/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 (.) diff --git a/src/Utils/TH.hs b/src/Utils/TH.hs index ea1e73b3c..b12d90359 100644 --- a/src/Utils/TH.hs +++ b/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 - where pat = tupP (map varP xs) - rhs = varE (xs !! (i - 1)) - xs = [ mkName $ "x" ++ show j | j <- [1..n] ] +projNI n i = do + x <- newName "x" + let rhs = varE x + 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 --