haskell/esqueleto
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Allow any parenthesization of JOINs.

Browse Source
This commit is contained in:
Felipe Lessa 2012-09-05 15:55:59 -03:00
parent 1e19d8625b
commit 7bb68cc233
3 changed files with 51 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
src/Database/Esqueleto/Internal/Language.hs
View File

@ -48,11 +48,10 @@ class (Functor query, Applicative query, Monad query) =>
=> query (expr (PreprocessedFrom (expr (Maybe (Entity a)))))
-- | (Internal) Do a @JOIN@.
fromJoin
:: ( PersistEntity a
, PersistEntityBackend a ~ backend
, IsJoinKind join )
=> expr (PreprocessedFrom b)
-> query (expr (PreprocessedFrom (join (expr (Entity a)) b)))
:: IsJoinKind join
=> expr (PreprocessedFrom a)
-> expr (PreprocessedFrom b)
-> query (expr (PreprocessedFrom (join a b)))
-- | (Internal) Finish a @JOIN@.
fromFinish
:: expr (PreprocessedFrom a)
@ -286,28 +285,28 @@ instance ( Esqueleto query expr backend
from_ = fromPreprocess >>= fromFinish
instance ( Esqueleto query expr backend
, FromPreprocess query expr backend (InnerJoin (expr (Entity val)) b)
) => From query expr backend (InnerJoin (expr (Entity val)) b) where
, FromPreprocess query expr backend (InnerJoin a b)
) => From query expr backend (InnerJoin a b) where
from_ = fromPreprocess >>= fromFinish
instance ( Esqueleto query expr backend
, FromPreprocess query expr backend (CrossJoin (expr (Entity val)) b)
) => From query expr backend (CrossJoin (expr (Entity val)) b) where
, FromPreprocess query expr backend (CrossJoin a b)
) => From query expr backend (CrossJoin a b) where
from_ = fromPreprocess >>= fromFinish
instance ( Esqueleto query expr backend
, FromPreprocess query expr backend (LeftOuterJoin (expr (Entity val)) b)
) => From query expr backend (LeftOuterJoin (expr (Entity val)) b) where
, FromPreprocess query expr backend (LeftOuterJoin a b)
) => From query expr backend (LeftOuterJoin a b) where
from_ = fromPreprocess >>= fromFinish
instance ( Esqueleto query expr backend
, FromPreprocess query expr backend (RightOuterJoin (expr (Entity val)) b)
) => From query expr backend (RightOuterJoin (expr (Entity val)) b) where
, FromPreprocess query expr backend (RightOuterJoin a b)
) => From query expr backend (RightOuterJoin a b) where
from_ = fromPreprocess >>= fromFinish
instance ( Esqueleto query expr backend
, FromPreprocess query expr backend (FullOuterJoin (expr (Entity val)) b)
) => From query expr backend (FullOuterJoin (expr (Entity val)) b) where
, FromPreprocess query expr backend (FullOuterJoin a b)
) => From query expr backend (FullOuterJoin a b) where
from_ = fromPreprocess >>= fromFinish
instance ( From query expr backend a
@ -386,9 +385,11 @@ instance ( Esqueleto query expr backend
fromPreprocess = fromStartMaybe
instance ( Esqueleto query expr backend
, PersistEntity val
, PersistEntityBackend val ~ backend
, IsJoinKind join
, FromPreprocess query expr backend a
, FromPreprocess query expr backend b
) => FromPreprocess query expr backend (join (expr (Entity val)) b) where
fromPreprocess = fromPreprocess >>= fromJoin
, IsJoinKind join
) => FromPreprocess query expr backend (join a b) where
fromPreprocess = do
a <- fromPreprocess
b <- fromPreprocess
fromJoin a b

29
src/Database/Esqueleto/Internal/Sql.hs
View File

@ -64,7 +64,7 @@ instance Monoid SideData where
-- | A part of a @FROM@ clause.
data FromClause =
FromStart Ident EntityDef
| FromJoin Ident EntityDef JoinKind FromClause (Maybe (SqlExpr (Single Bool)))
| FromJoin FromClause JoinKind FromClause (Maybe (SqlExpr (Single Bool)))
| OnClause (SqlExpr (Single Bool))
@ -79,8 +79,8 @@ collectOnClauses = go []
go acc (f:fs) = go (f:acc) fs
go acc [] = return $ reverse acc
findMatching (FromJoin i e k f Nothing : acc) expr =
return (FromJoin i e k f (Just expr) : acc)
findMatching (FromJoin l k r Nothing : acc) expr =
return (FromJoin l k r (Just expr) : acc)
findMatching (f : acc) expr = (f:) <$> findMatching acc expr
findMatching [] expr = Left expr
@ -142,16 +142,15 @@ instance Esqueleto SqlQuery SqlExpr SqlPersist where
maybelize (EPreprocessedFrom ret from_) = EPreprocessedFrom (EMaybe ret) from_
maybelize _ = error "Esqueleto/Sql/fromStartMaybe: never here (see GHC #6124)"
fromJoin (EPreprocessedFrom rhsRet rhsFrom) = Q $ do
lhsIdent <- S.supply
let lhsRet = EEntity lhsIdent
ret = smartJoin lhsRet rhsRet
from_ = FromJoin lhsIdent (entityDef $ getVal lhsRet) -- LHS
(reifyJoinKind ret) -- JOIN
rhsFrom -- RHS
Nothing -- ON
fromJoin (EPreprocessedFrom lhsRet lhsFrom)
(EPreprocessedFrom rhsRet rhsFrom) = Q $ do
let ret = smartJoin lhsRet rhsRet
from_ = FromJoin lhsFrom -- LHS
(reifyJoinKind ret) -- JOIN
rhsFrom -- RHS
Nothing -- ON
return (EPreprocessedFrom ret from_)
fromJoin _ = error "Esqueleto/Sql/fromJoin: never here (see GHC #6124)"
fromJoin _ _ = error "Esqueleto/Sql/fromJoin: never here (see GHC #6124)"
fromFinish (EPreprocessedFrom ret from_) = Q $ do
W.tell mempty { sdFromClause = [from_] }
@ -299,10 +298,10 @@ makeFrom esc fs = ret
Right fs' -> first ("\nFROM " <>) $ uncommas' (map mk fs')
mk (FromStart (I i) def) = base i def
mk (FromJoin (I i) def kind rest monClause) =
mconcat [ base i def
mk (FromJoin lhs kind rhs monClause) =
mconcat [ mk lhs
, (fromKind kind, mempty)
, mk rest
, mk rhs
, maybe mempty makeOnClause monClause ]
mk (OnClause _) = error "Esqueleto/Sql/makeFrom: never here (is collectOnClauses working?)"

16
test/Test.hs
View File

@ -127,6 +127,22 @@ main = do
, (p3e, Just b31e)
, (p2e, Nothing) ]
it "typechecks (A LEFT OUTER JOIN (B LEFT OUTER JOIN C))" $
let _ = run $
select $
from $ \(a `LeftOuterJoin` (b `LeftOuterJoin` c)) ->
let _ = [a, b, c] :: [ SqlExpr (Entity Person) ]
in return a
in return () :: IO ()
it "typechecks ((A LEFT OUTER JOIN B) LEFT OUTER JOIN C)" $
let _ = run $
select $
from $ \((a `LeftOuterJoin` b) `LeftOuterJoin` c) ->
let _ = [a, b, c] :: [ SqlExpr (Entity Person) ]
in return a
in return () :: IO ()
it "throws an error for using on without joins" $
run (do
p1e <- insert' p1