diff --git a/src/Database/Esqueleto/Utils/TH.hs b/src/Database/Esqueleto/Utils/TH.hs index b3eb51643..6623220a6 100644 --- a/src/Database/Esqueleto/Utils/TH.hs +++ b/src/Database/Esqueleto/Utils/TH.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -26,6 +26,9 @@ import Data.List (foldr1, foldl) import Utils.TH import Control.Lens.Iso (Iso', iso) +{-# ANN module ("HLint: ignore Redundant bracket"::String) #-} + + class E.SqlSelect a r => SqlIn a r | a -> r, r -> a where sqlIn :: a -> [r] -> E.SqlExpr (E.Value Bool) @@ -125,10 +128,6 @@ sqlMIXproj = leftAssociativeProjection . map decodeJoin decodeJoin 'C' = 'E.CrossJoin decodeJoin c = error $ "Database.Esqueleto.Utils.TH.sqlMIXproj: received unknown SQL join kind \"" ++ c:"\"" -- always raised at compile time, so this is ok --- Alternative using `refiy`, but impractical due to TH staging restrictions --- and currently confuses type and expression constructors somehow +-- Alternative using `reify`; works, but may require `$(return [])` between type definition and call to workaround ghc staging problems sqlMIXproj' :: Name -> Int -> ExpQ -sqlMIXproj' t i = do - ns <- extractConstructorNames t - -- ns' <- maybeMapM (lookupValueName . nameBase) ns -- failed attempt change type-constructor names to identical expression-constructors - leftAssociativeProjection (reverse ns) i +sqlMIXproj' t i = extractConstructorNames t >>= flip leftAssociativeProjection i diff --git a/src/Utils/TH.hs b/src/Utils/TH.hs index c8b14d704..83e560af5 100644 --- a/src/Utils/TH.hs +++ b/src/Utils/TH.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -55,11 +55,11 @@ leftAssociativePairProjection constructor n i = do | w==i = conP constructor [wildP, varP x] | otherwise = conP constructor [pat x (pred w), wildP] --- | Generic projections N-tuples that are actually left-associative pairs with differing constructors +-- | Generic projections n-tuples that are actually left-associative pairs with differing constructors -- i.e. @$(leftAssociativePairProjection [c1,c2,..,cn] m :: (..(t1 `c1` t2) `c2` .. `cn` t(n+1) -> tm@ (for m<=n+1) leftAssociativeProjection :: [Name] -> Int -> ExpQ leftAssociativeProjection constructors@(length -> n) (pred -> i) - | n < i = error $ "leftAssciativeProjection not given enough constructors: " <> show constructors + | n < i = error $ "Util.TH.leftAssociativeProjection not given enough constructors: " <> show constructors | otherwise = do x <- newName "x" lamE [pat x n] (varE x) @@ -69,39 +69,32 @@ leftAssociativeProjection constructors@(length -> n) (pred -> i) | w==i = conP (constructors !! v) [wildP, varP x] | otherwise = conP (constructors !! v) [pat x v, wildP] --- Extract constructor names from a type definition of left-associative pair-constructors --- PROBLEM: returns the wrong names: E.g. for `data LeftOuterJoinTC a b = a `LeftOuterJoinEC` b we get `LeftOuterJoinTC`, but we need `LeftOuterJoinEC` +-- Extract constructor names from a type definition of left-associative pair-constructors (i.e. Esqueleto-Joins in a table-expression type) extractConstructorNames :: Name -> Q [Name] extractConstructorNames td = do - TyConI (TySynD _ [] ty) <- reify td - concatMapM getDataConstructors (go ty) + TyConI (TySynD _ [] ty) <- reify td -- executed at compile time, so failure is acceptable + reverse . concat <$> mapM getDataConstructors (go ty) where go :: Type -> [Name] go (AppT (AppT (ConT name) rest) _) = name : go rest go _ = [] - -- At this point we have the Type-Constructors, but we actually need the Data-Constructors. - -- We might possibly use something like the following: - + -- At this point we have the Type-Constructors, but we actually need the Data-Constructors: getDataConstructors :: Name -> Q [Name] getDataConstructors conName = do info <- reify conName case info of - TyConI (DataD _ _ _ _ constr _) -> return $ concatMap getConNames constr - TyConI (NewtypeD _ _ _ _ constr _) -> return $ getConNames constr + TyConI (DataD _ _ _ _ constr _) -> return $ concatMap getConNames constr + TyConI (NewtypeD _ _ _ _ constr _) -> return $ getConNames constr _ -> return [] getConNames :: Con -> [Name] - getConNames (NormalC name _) = [name] - getConNames (RecC name _) = [name] + getConNames (NormalC name _) = [name] + getConNames (RecC name _) = [name] getConNames (InfixC _ name _) = [name] getConNames (ForallC _ _ con) = getConNames con getConNames _ = [] - concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] - concatMapM f xs = concat <$> mapM f xs - - {- Example: @@ -149,8 +142,6 @@ with (ConT Database.Persist.Class.PersistEntity.Entity) (ConT Model.QualificationUserBlock) ) ) ) ) ) - - -}