Generic Join projections implemented
This commit is contained in:
SJost
parent
e5d693e707
commit
529c226ad6
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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))
|
||||
|
||||
|
||||
|
||||
12
src/Utils.hs
12
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 (.)
|
||||
|
||||
|
||||
@ -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 --
|
||||
|
||||
Loading…
Reference in New Issue
Block a user