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

Instead of using rawSql's Single, use a new data type Value.

Browse Source 
First of all, Value is a nicer name than Single.

However the main reason is to avoid error calls and to get better
feedback about the code from GHC.  Because of the GHC bug #6124,
we had many calls to 'error' just to avoid spurious warnings.  By
using data (instead of newtype) for Value we're able to avoid
them.  This commit removes *19* error calls from Sql.hs that GHC
is now able to prove that are unreachable.
This commit is contained in:
Felipe Lessa 2012-09-06 01:40:52 -03:00
parent cc72ee9811
commit f718be86da
4 changed files with 66 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
src/Database/Esqueleto.hs
View File

@ -25,6 +25,7 @@ module Database.Esqueleto
, (+.), (-.), (/.), (*.) , (+.), (-.), (/.), (*.)
, set, (=.), (+=.), (-=.), (*=.), (/=.) ) , set, (=.), (+=.), (-=.), (*=.), (/=.) )
, from , from
, Value(..)
, OrderBy , OrderBy
-- ** Joins -- ** Joins
, InnerJoin(..) , InnerJoin(..)
@ -191,8 +192,8 @@ import qualified Database.Persist.Store
-- @ -- @
-- --
-- Since @age@ is an optional @Person@ field, we use 'just' lift -- Since @age@ is an optional @Person@ field, we use 'just' lift
-- @val 18 :: SqlExpr (Single Int)@ into @just (val 18) :: -- @val 18 :: SqlExpr (Value Int)@ into @just (val 18) ::
-- SqlExpr (Single (Just Int))@. -- SqlExpr (Value (Just Int))@.
-- --
-- Implicit joins are represented by tuples. For example, to get -- Implicit joins are represented by tuples. For example, to get
-- the list of all blog posts and their authors, we could write: -- the list of all blog posts and their authors, we could write:

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

@ -10,6 +10,7 @@
module Database.Esqueleto.Internal.Language module Database.Esqueleto.Internal.Language
( Esqueleto(..) ( Esqueleto(..)
, from , from
, Value(..)
, InnerJoin(..) , InnerJoin(..)
, CrossJoin(..) , CrossJoin(..)
, LeftOuterJoin(..) , LeftOuterJoin(..)
@ -67,7 +68,7 @@ class (Functor query, Applicative query, Monad query) =>
-> query a -> query a
-- | @WHERE@ clause: restrict the query's result. -- | @WHERE@ clause: restrict the query's result.
where_ :: expr (Single Bool) -> query () where_ :: expr (Value Bool) -> query ()
-- | @ON@ clause: restrict the a @JOIN@'s result. The @ON@ -- | @ON@ clause: restrict the a @JOIN@'s result. The @ON@
-- clause will be applied to the /last/ @JOIN@ that does not -- clause will be applied to the /last/ @JOIN@ that does not
@ -118,75 +119,75 @@ class (Functor query, Applicative query, Monad query) =>
-- If the order was *not* reversed, then @test2@ would be -- If the order was *not* reversed, then @test2@ would be
-- broken: @query1@'s 'on' would refer to @query2@'s -- broken: @query1@'s 'on' would refer to @query2@'s
-- 'LeftOuterJoin'. -- 'LeftOuterJoin'.
on :: expr (Single Bool) -> query () on :: expr (Value Bool) -> query ()
-- | @ORDER BY@ clause. See also 'asc' and 'desc'. -- | @ORDER BY@ clause. See also 'asc' and 'desc'.
orderBy :: [expr OrderBy] -> query () orderBy :: [expr OrderBy] -> query ()
-- | Ascending order of this field or expression. -- | Ascending order of this field or expression.
asc :: PersistField a => expr (Single a) -> expr OrderBy asc :: PersistField a => expr (Value a) -> expr OrderBy
-- | Descending order of this field or expression. -- | Descending order of this field or expression.
desc :: PersistField a => expr (Single a) -> expr OrderBy desc :: PersistField a => expr (Value a) -> expr OrderBy
-- | Execute a subquery @SELECT@ in an expression. -- | Execute a subquery @SELECT@ in an expression.
sub_select :: PersistField a => query (expr (Single a)) -> expr (Single a) sub_select :: PersistField a => query (expr (Value a)) -> expr (Value a)
-- | Execute a subquery @SELECT_DISTINCT@ in an expression. -- | Execute a subquery @SELECT_DISTINCT@ in an expression.
sub_selectDistinct :: PersistField a => query (expr (Single a)) -> expr (Single a) sub_selectDistinct :: PersistField a => query (expr (Value a)) -> expr (Value a)
-- | Project a field of an entity. -- | Project a field of an entity.
(^.) :: (PersistEntity val, PersistField typ) => (^.) :: (PersistEntity val, PersistField typ) =>
expr (Entity val) -> EntityField val typ -> expr (Single typ) expr (Entity val) -> EntityField val typ -> expr (Value typ)
-- | Project a field of an entity that may be null. -- | Project a field of an entity that may be null.
(?.) :: (PersistEntity val, PersistField typ) => (?.) :: (PersistEntity val, PersistField typ) =>
expr (Maybe (Entity val)) -> EntityField val typ -> expr (Single (Maybe typ)) expr (Maybe (Entity val)) -> EntityField val typ -> expr (Value (Maybe typ))
-- | Lift a constant value from Haskell-land to the query. -- | Lift a constant value from Haskell-land to the query.
val :: PersistField typ => typ -> expr (Single typ) val :: PersistField typ => typ -> expr (Value typ)
-- | @IS NULL@ comparison. -- | @IS NULL@ comparison.
isNothing :: PersistField typ => expr (Single (Maybe typ)) -> expr (Single Bool) isNothing :: PersistField typ => expr (Value (Maybe typ)) -> expr (Value Bool)
-- | Analog to 'Just', promotes a value of type @typ@ into one -- | Analog to 'Just', promotes a value of type @typ@ into one
-- of type @Maybe typ@. It should hold that @val . Just === -- of type @Maybe typ@. It should hold that @val . Just ===
-- just . val@. -- just . val@.
just :: expr (Single typ) -> expr (Single (Maybe typ)) just :: expr (Value typ) -> expr (Value (Maybe typ))
-- | @NULL@ value. -- | @NULL@ value.
nothing :: expr (Single (Maybe typ)) nothing :: expr (Value (Maybe typ))
-- | @COUNT(*)@ value. -- | @COUNT(*)@ value.
countRows :: Num a => expr (Single a) countRows :: Num a => expr (Value a)
not_ :: expr (Single Bool) -> expr (Single Bool) not_ :: expr (Value Bool) -> expr (Value Bool)
(==.) :: PersistField typ => expr (Single typ) -> expr (Single typ) -> expr (Single Bool) (==.) :: PersistField typ => expr (Value typ) -> expr (Value typ) -> expr (Value Bool)
(>=.) :: PersistField typ => expr (Single typ) -> expr (Single typ) -> expr (Single Bool) (>=.) :: PersistField typ => expr (Value typ) -> expr (Value typ) -> expr (Value Bool)
(>.) :: PersistField typ => expr (Single typ) -> expr (Single typ) -> expr (Single Bool) (>.) :: PersistField typ => expr (Value typ) -> expr (Value typ) -> expr (Value Bool)
(<=.) :: PersistField typ => expr (Single typ) -> expr (Single typ) -> expr (Single Bool) (<=.) :: PersistField typ => expr (Value typ) -> expr (Value typ) -> expr (Value Bool)
(<.) :: PersistField typ => expr (Single typ) -> expr (Single typ) -> expr (Single Bool) (<.) :: PersistField typ => expr (Value typ) -> expr (Value typ) -> expr (Value Bool)
(!=.) :: PersistField typ => expr (Single typ) -> expr (Single typ) -> expr (Single Bool) (!=.) :: PersistField typ => expr (Value typ) -> expr (Value typ) -> expr (Value Bool)
(&&.) :: expr (Single Bool) -> expr (Single Bool) -> expr (Single Bool) (&&.) :: expr (Value Bool) -> expr (Value Bool) -> expr (Value Bool)
(||.) :: expr (Single Bool) -> expr (Single Bool) -> expr (Single Bool) (||.) :: expr (Value Bool) -> expr (Value Bool) -> expr (Value Bool)
(+.) :: PersistField a => expr (Single a) -> expr (Single a) -> expr (Single a) (+.) :: PersistField a => expr (Value a) -> expr (Value a) -> expr (Value a)
(-.) :: PersistField a => expr (Single a) -> expr (Single a) -> expr (Single a) (-.) :: PersistField a => expr (Value a) -> expr (Value a) -> expr (Value a)
(/.) :: PersistField a => expr (Single a) -> expr (Single a) -> expr (Single a) (/.) :: PersistField a => expr (Value a) -> expr (Value a) -> expr (Value a)
(*.) :: PersistField a => expr (Single a) -> expr (Single a) -> expr (Single a) (*.) :: PersistField a => expr (Value a) -> expr (Value a) -> expr (Value a)
-- | @SET@ clause used on @UPDATE@s. Note that while it's not -- | @SET@ clause used on @UPDATE@s. Note that while it's not
-- a type error to use this function on a @SELECT@, it will -- a type error to use this function on a @SELECT@, it will
-- most certainly result in a runtime error. -- most certainly result in a runtime error.
set :: PersistEntity val => expr (Entity val) -> [expr (Update val)] -> query () set :: PersistEntity val => expr (Entity val) -> [expr (Update val)] -> query ()
(=.) :: (PersistEntity val, PersistField typ) => EntityField val typ -> expr (Single typ) -> expr (Update val) (=.) :: (PersistEntity val, PersistField typ) => EntityField val typ -> expr (Value typ) -> expr (Update val)
(+=.) :: (PersistEntity val, PersistField a) => EntityField val a -> expr (Single a) -> expr (Update val) (+=.) :: (PersistEntity val, PersistField a) => EntityField val a -> expr (Value a) -> expr (Update val)
(-=.) :: (PersistEntity val, PersistField a) => EntityField val a -> expr (Single a) -> expr (Update val) (-=.) :: (PersistEntity val, PersistField a) => EntityField val a -> expr (Value a) -> expr (Update val)
(*=.) :: (PersistEntity val, PersistField a) => EntityField val a -> expr (Single a) -> expr (Update val) (*=.) :: (PersistEntity val, PersistField a) => EntityField val a -> expr (Value a) -> expr (Update val)
(/=.) :: (PersistEntity val, PersistField a) => EntityField val a -> expr (Single a) -> expr (Update val) (/=.) :: (PersistEntity val, PersistField a) => EntityField val a -> expr (Value a) -> expr (Update val)
-- Fixity declarations -- Fixity declarations
@ -198,6 +199,12 @@ infixr 3 &&., =., +=., -=., *=., /=.
infixr 2 ||., `InnerJoin`, `CrossJoin`, `LeftOuterJoin`, `RightOuterJoin`, `FullOuterJoin` infixr 2 ||., `InnerJoin`, `CrossJoin`, `LeftOuterJoin`, `RightOuterJoin`, `FullOuterJoin`
-- | A single value (as opposed to a whole entity). You may use
-- @('^.')@ or @('?.')@ to get a 'Value' from an 'Entity'.
data Value a = Value a deriving (Eq, Ord, Show, Typeable)
-- Note: because of GHC bug #6124 we use @data@ instead of @newtype@.
-- | Data type that represents an @INNER JOIN@ (see 'LeftOuterJoin' for an example). -- | Data type that represents an @INNER JOIN@ (see 'LeftOuterJoin' for an example).
data InnerJoin a b = a `InnerJoin` b data InnerJoin a b = a `InnerJoin` b

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

@ -86,18 +86,18 @@ instance Monoid SideData where
-- | A part of a @FROM@ clause. -- | A part of a @FROM@ clause.
data FromClause = data FromClause =
FromStart Ident EntityDef FromStart Ident EntityDef
| FromJoin FromClause JoinKind FromClause (Maybe (SqlExpr (Single Bool))) | FromJoin FromClause JoinKind FromClause (Maybe (SqlExpr (Value Bool)))
| OnClause (SqlExpr (Single Bool)) | OnClause (SqlExpr (Value Bool))
-- | A part of a @SET@ clause. -- | A part of a @SET@ clause.
newtype SetClause = SetClause (SqlExpr (Single ())) newtype SetClause = SetClause (SqlExpr (Value ()))
-- | Collect 'OnClause's on 'FromJoin's. Returns the first -- | Collect 'OnClause's on 'FromJoin's. Returns the first
-- unmatched 'OnClause's data on error. Returns a list without -- unmatched 'OnClause's data on error. Returns a list without
-- 'OnClauses' on success. -- 'OnClauses' on success.
collectOnClauses :: [FromClause] -> Either (SqlExpr (Single Bool)) [FromClause] collectOnClauses :: [FromClause] -> Either (SqlExpr (Value Bool)) [FromClause]
collectOnClauses = go [] collectOnClauses = go []
where where
go [] (f@(FromStart _ _):fs) = fmap (f:) (go [] fs) -- fast path go [] (f@(FromStart _ _):fs) = fmap (f:) (go [] fs) -- fast path
@ -123,7 +123,7 @@ collectOnClauses = go []
-- | A complete @WHERE@ clause. -- | A complete @WHERE@ clause.
data WhereClause = Where (SqlExpr (Single Bool)) data WhereClause = Where (SqlExpr (Value Bool))
| NoWhere | NoWhere
instance Monoid WhereClause where instance Monoid WhereClause where
@ -186,9 +186,9 @@ useIdent esc (I ident) = esc (DBName ident)
data SqlExpr a where data SqlExpr a where
EEntity :: Ident -> SqlExpr (Entity val) EEntity :: Ident -> SqlExpr (Entity val)
EMaybe :: SqlExpr a -> SqlExpr (Maybe a) EMaybe :: SqlExpr a -> SqlExpr (Maybe a)
ERaw :: NeedParens -> (Escape -> (TLB.Builder, [PersistValue])) -> SqlExpr (Single a) ERaw :: NeedParens -> (Escape -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value a)
EOrderBy :: OrderByType -> SqlExpr (Single a) -> SqlExpr OrderBy EOrderBy :: OrderByType -> SqlExpr (Value a) -> SqlExpr OrderBy
ESet :: (SqlExpr (Entity val) -> SqlExpr (Single ())) -> SqlExpr (Update val) ESet :: (SqlExpr (Entity val) -> SqlExpr (Value ())) -> SqlExpr (Update val)
EPreprocessedFrom :: a -> FromClause -> SqlExpr (PreprocessedFrom a) EPreprocessedFrom :: a -> FromClause -> SqlExpr (PreprocessedFrom a)
data NeedParens = Parens | Never data NeedParens = Parens | Never
@ -219,7 +219,6 @@ instance Esqueleto SqlQuery SqlExpr SqlPersist where
maybelize :: SqlExpr (PreprocessedFrom (SqlExpr (Entity a))) maybelize :: SqlExpr (PreprocessedFrom (SqlExpr (Entity a)))
-> SqlExpr (PreprocessedFrom (SqlExpr (Maybe (Entity a)))) -> SqlExpr (PreprocessedFrom (SqlExpr (Maybe (Entity a))))
maybelize (EPreprocessedFrom ret from_) = EPreprocessedFrom (EMaybe ret) from_ maybelize (EPreprocessedFrom ret from_) = EPreprocessedFrom (EMaybe ret) from_
maybelize _ = error "Esqueleto/Sql/fromStartMaybe: never here (see GHC #6124)"
fromJoin (EPreprocessedFrom lhsRet lhsFrom) fromJoin (EPreprocessedFrom lhsRet lhsFrom)
(EPreprocessedFrom rhsRet rhsFrom) = Q $ do (EPreprocessedFrom rhsRet rhsFrom) = Q $ do
@ -229,12 +228,10 @@ instance Esqueleto SqlQuery SqlExpr SqlPersist where
rhsFrom -- RHS rhsFrom -- RHS
Nothing -- ON Nothing -- ON
return (EPreprocessedFrom ret from_) return (EPreprocessedFrom ret from_)
fromJoin _ _ = error "Esqueleto/Sql/fromJoin: never here (see GHC #6124)"
fromFinish (EPreprocessedFrom ret from_) = Q $ do fromFinish (EPreprocessedFrom ret from_) = Q $ do
W.tell mempty { sdFromClause = [from_] } W.tell mempty { sdFromClause = [from_] }
return ret return ret
fromFinish _ = error "Esqueleto/Sql/fromFinish: never here (see GHC #6124)"
where_ expr = Q $ W.tell mempty { sdWhereClause = Where expr } where_ expr = Q $ W.tell mempty { sdWhereClause = Where expr }
@ -249,27 +246,21 @@ instance Esqueleto SqlQuery SqlExpr SqlPersist where
EEntity ident ^. field = EEntity ident ^. field =
ERaw Never $ \esc -> (useIdent esc ident <> ("." <> fieldName esc field), []) ERaw Never $ \esc -> (useIdent esc ident <> ("." <> fieldName esc field), [])
_ ^. _ = error "Esqueleto/Sql/(^.): never here (see GHC #6124)"
EMaybe r ?. field = maybelize (r ^. field) EMaybe r ?. field = maybelize (r ^. field)
where where
maybelize :: SqlExpr (Single a) -> SqlExpr (Single (Maybe a)) maybelize :: SqlExpr (Value a) -> SqlExpr (Value (Maybe a))
maybelize (ERaw p f) = ERaw p f maybelize (ERaw p f) = ERaw p f
maybelize _ = error "Esqueleto/Sql/(?.): never here 1 (see GHC #6124)"
_ ?. _ = error "Esqueleto/Sql/(?.): never here 2 (see GHC #6124)"
val = ERaw Never . const . (,) "?" . return . toPersistValue val = ERaw Never . const . (,) "?" . return . toPersistValue
isNothing (ERaw p f) = ERaw Never $ first ((<> " IS NULL") . parensM p) . f isNothing (ERaw p f) = ERaw Never $ first ((<> " IS NULL") . parensM p) . f
isNothing _ = error "Esqueleto/Sql/isNothing: never here (see GHC #6124)"
just (ERaw p f) = ERaw p f just (ERaw p f) = ERaw p f
just _ = error "Esqueleto/Sql/just: never here (see GHC #6124)"
nothing = ERaw Never $ \_ -> ("NULL", mempty) nothing = ERaw Never $ \_ -> ("NULL", mempty)
countRows = ERaw Never $ \_ -> ("COUNT(*)", mempty) countRows = ERaw Never $ \_ -> ("COUNT(*)", mempty)
not_ (ERaw p f) = ERaw Never $ \esc -> let (b, vals) = f esc not_ (ERaw p f) = ERaw Never $ \esc -> let (b, vals) = f esc
in ("NOT " <> parensM p b, vals) in ("NOT " <> parensM p b, vals)
not_ _ = error "Esqueleto/Sql/not_: never here (see GHC #6124)"
(==.) = binop " = " (==.) = binop " = "
(>=.) = binop " >= " (>=.) = binop " >= "
@ -287,7 +278,6 @@ instance Esqueleto SqlQuery SqlExpr SqlPersist where
set ent upds = Q $ W.tell mempty { sdSetClause = map apply upds } set ent upds = Q $ W.tell mempty { sdSetClause = map apply upds }
where where
apply (ESet f) = SetClause (f ent) apply (ESet f) = SetClause (f ent)
apply _ = error "Esqueleto/Sql/set/apply: never here (see GHC #6124)"
field =. expr = setAux field (const expr) field =. expr = setAux field (const expr)
field +=. expr = setAux field (\ent -> ent ^. field +. expr) field +=. expr = setAux field (\ent -> ent ^. field +. expr)
@ -302,25 +292,24 @@ fieldName esc = esc . fieldDB . persistFieldDef
setAux :: (PersistEntity val, PersistField typ) setAux :: (PersistEntity val, PersistField typ)
=> EntityField val typ => EntityField val typ
-> (SqlExpr (Entity val) -> SqlExpr (Single typ)) -> (SqlExpr (Entity val) -> SqlExpr (Value typ))
-> SqlExpr (Update val) -> SqlExpr (Update val)
setAux field mkVal = ESet $ \ent -> binop " = " name (mkVal ent) setAux field mkVal = ESet $ \ent -> binop " = " name (mkVal ent)
where name = ERaw Never $ \esc -> (fieldName esc field, mempty) where name = ERaw Never $ \esc -> (fieldName esc field, mempty)
sub :: PersistField a => Mode -> SqlQuery (SqlExpr (Single a)) -> SqlExpr (Single a) sub :: PersistField a => Mode -> SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a)
sub mode query = ERaw Parens $ \esc -> first parens (toRawSql mode esc query) sub mode query = ERaw Parens $ \esc -> first parens (toRawSql mode esc query)
fromDBName :: Connection -> DBName -> TLB.Builder fromDBName :: Connection -> DBName -> TLB.Builder
fromDBName conn = TLB.fromText . escapeName conn fromDBName conn = TLB.fromText . escapeName conn
binop :: TLB.Builder -> SqlExpr (Single a) -> SqlExpr (Single b) -> SqlExpr (Single c) binop :: TLB.Builder -> SqlExpr (Value a) -> SqlExpr (Value b) -> SqlExpr (Value c)
binop op (ERaw p1 f1) (ERaw p2 f2) = ERaw Parens f binop op (ERaw p1 f1) (ERaw p2 f2) = ERaw Parens f
where where
f esc = let (b1, vals1) = f1 esc f esc = let (b1, vals1) = f1 esc
(b2, vals2) = f2 esc (b2, vals2) = f2 esc
in ( parensM p1 b1 <> op <> parensM p2 b2 in ( parensM p1 b1 <> op <> parensM p2 b2
, vals1 <> vals2 ) , vals1 <> vals2 )
binop _ _ _ = error "Esqueleto/Sql/binop: never here (see GHC #6124)"
---------------------------------------------------------------------- ----------------------------------------------------------------------
@ -531,12 +520,11 @@ makeFrom esc mode fs = ret
fromKind FullOuterJoinKind = " FULL OUTER JOIN " fromKind FullOuterJoinKind = " FULL OUTER JOIN "
makeOnClause (ERaw _ f) = first (" ON " <>) (f esc) makeOnClause (ERaw _ f) = first (" ON " <>) (f esc)
makeOnClause _ = error "Esqueleto/Sql/makeFrom/makeOnClause: never here (see GHC #6124)"
mkExc :: SqlExpr (Value Bool) -> OnClauseWithoutMatchingJoinException
mkExc (ERaw _ f) = mkExc (ERaw _ f) =
OnClauseWithoutMatchingJoinException $ OnClauseWithoutMatchingJoinException $
TL.unpack $ TLB.toLazyText $ fst (f esc) TL.unpack $ TLB.toLazyText $ fst (f esc)
mkExc _ = OnClauseWithoutMatchingJoinException "???"
makeSet :: Escape -> [SetClause] -> (TLB.Builder, [PersistValue]) makeSet :: Escape -> [SetClause] -> (TLB.Builder, [PersistValue])
@ -544,13 +532,11 @@ makeSet _ [] = mempty
makeSet esc os = first ("\nSET " <>) $ uncommas' (map mk os) makeSet esc os = first ("\nSET " <>) $ uncommas' (map mk os)
where where
mk (SetClause (ERaw _ f)) = f esc mk (SetClause (ERaw _ f)) = f esc
mk _ = error "Esqueleto/Sql/makeSet: never here (see GHC #6124)"
makeWhere :: Escape -> WhereClause -> (TLB.Builder, [PersistValue]) makeWhere :: Escape -> WhereClause -> (TLB.Builder, [PersistValue])
makeWhere _ NoWhere = mempty makeWhere _ NoWhere = mempty
makeWhere esc (Where (ERaw _ f)) = first ("\nWHERE " <>) (f esc) makeWhere esc (Where (ERaw _ f)) = first ("\nWHERE " <>) (f esc)
makeWhere _ _ = error "Esqueleto/Sql/makeWhere: never here (see GHC #6124)"
makeOrderBy :: Escape -> [OrderByClause] -> (TLB.Builder, [PersistValue]) makeOrderBy :: Escape -> [OrderByClause] -> (TLB.Builder, [PersistValue])
@ -558,7 +544,6 @@ makeOrderBy _ [] = mempty
makeOrderBy esc os = first ("\nORDER BY " <>) $ uncommas' (map mk os) makeOrderBy esc os = first ("\nORDER BY " <>) $ uncommas' (map mk os)
where where
mk (EOrderBy t (ERaw _ f)) = first (<> orderByType t) (f esc) mk (EOrderBy t (ERaw _ f)) = first (<> orderByType t) (f esc)
mk _ = error "Esqueleto/Sql/makeOrderBy: never here (see GHC #6124)"
orderByType ASC = " ASC" orderByType ASC = " ASC"
orderByType DESC = " DESC" orderByType DESC = " DESC"
@ -608,7 +593,6 @@ instance PersistEntity a => SqlSelect (SqlExpr (Entity a)) (Entity a) where
name = useIdent escape ident <> "." name = useIdent escape ident <> "."
ret = let ed = entityDef $ getEntityVal expr ret = let ed = entityDef $ getEntityVal expr
in (process ed, mempty) in (process ed, mempty)
sqlSelectCols _ _ = error "Esqueleto/Sql/sqlSelectCols[Entity]: never here (see GHC #6124)"
sqlSelectColCount = (+1) . length . entityFields . entityDef . getEntityVal sqlSelectColCount = (+1) . length . entityFields . entityDef . getEntityVal
sqlSelectProcessRow (idCol:ent) = sqlSelectProcessRow (idCol:ent) =
Entity <$> fromPersistValue idCol Entity <$> fromPersistValue idCol
@ -620,7 +604,6 @@ getEntityVal = error "Esqueleto/Sql/getEntityVal"
instance PersistEntity a => SqlSelect (SqlExpr (Maybe (Entity a))) (Maybe (Entity a)) where instance PersistEntity a => SqlSelect (SqlExpr (Maybe (Entity a))) (Maybe (Entity a)) where
sqlSelectCols escape (EMaybe ent) = sqlSelectCols escape ent sqlSelectCols escape (EMaybe ent) = sqlSelectCols escape ent
sqlSelectCols _ _ = error "Esqueleto/Sql/sqlSelectCols[Maybe Entity]: never here (see GHC #6124)"
sqlSelectColCount = sqlSelectColCount . fromEMaybe sqlSelectColCount = sqlSelectColCount . fromEMaybe
where where
fromEMaybe :: SqlExpr (Maybe e) -> SqlExpr e fromEMaybe :: SqlExpr (Maybe e) -> SqlExpr e
@ -629,13 +612,12 @@ instance PersistEntity a => SqlSelect (SqlExpr (Maybe (Entity a))) (Maybe (Entit
| all (== PersistNull) cols = return Nothing | all (== PersistNull) cols = return Nothing
| otherwise = Just <$> sqlSelectProcessRow cols | otherwise = Just <$> sqlSelectProcessRow cols
instance PersistField a => SqlSelect (SqlExpr (Single a)) (Single a) where instance PersistField a => SqlSelect (SqlExpr (Value a)) (Value a) where
sqlSelectCols esc (ERaw p f) = let (b, vals) = f esc sqlSelectCols esc (ERaw p f) = let (b, vals) = f esc
in (parensM p b, vals) in (parensM p b, vals)
sqlSelectCols _ _ = error "Esqueleto/Sql/sqlSelectCols[Single]: never here (see GHC #6124)"
sqlSelectColCount = const 1 sqlSelectColCount = const 1
sqlSelectProcessRow [pv] = Single <$> fromPersistValue pv sqlSelectProcessRow [pv] = Value <$> fromPersistValue pv
sqlSelectProcessRow _ = Left "SqlSelect (Single a): wrong number of columns." sqlSelectProcessRow _ = Left "SqlSelect (Value a): wrong number of columns."
instance ( SqlSelect a ra instance ( SqlSelect a ra
, SqlSelect b rb , SqlSelect b rb

18
test/Test.hs
View File

@ -59,12 +59,12 @@ main = do
it "works for a single value" $ it "works for a single value" $
run $ do run $ do
ret <- select $ return $ val (3 :: Int) ret <- select $ return $ val (3 :: Int)
liftIO $ ret `shouldBe` [ Single 3 ] liftIO $ ret `shouldBe` [ Value 3 ]
it "works for a single NULL value" $ it "works for a single NULL value" $
run $ do run $ do
ret <- select $ return $ nothing ret <- select $ return $ nothing
liftIO $ ret `shouldBe` [ Single (Nothing :: Maybe Int) ] liftIO $ ret `shouldBe` [ Value (Nothing :: Maybe Int) ]
describe "select/from" $ do describe "select/from" $ do
it "works for a simple example" $ it "works for a simple example" $
@ -102,8 +102,8 @@ main = do
ret <- select $ ret <- select $
from $ \p -> from $ \p ->
return (p ^. PersonId, p ^. PersonName) return (p ^. PersonId, p ^. PersonName)
liftIO $ ret `shouldBe` [ (Single p1k, Single (personName p1)) liftIO $ ret `shouldBe` [ (Value p1k, Value (personName p1))
, (Single p2k, Single (personName p2)) ] , (Value p2k, Value (personName p2)) ]
it "works for a simple projection with a simple implicit self-join" $ it "works for a simple projection with a simple implicit self-join" $
run $ do run $ do
@ -112,10 +112,10 @@ main = do
ret <- select $ ret <- select $
from $ \(pa, pb) -> from $ \(pa, pb) ->
return (pa ^. PersonName, pb ^. PersonName) return (pa ^. PersonName, pb ^. PersonName)
liftIO $ ret `shouldBe` [ (Single (personName p1), Single (personName p1)) liftIO $ ret `shouldBe` [ (Value (personName p1), Value (personName p1))
, (Single (personName p1), Single (personName p2)) , (Value (personName p1), Value (personName p2))
, (Single (personName p2), Single (personName p1)) , (Value (personName p2), Value (personName p1))
, (Single (personName p2), Single (personName p2)) ] , (Value (personName p2), Value (personName p2)) ]
describe "select/JOIN" $ do describe "select/JOIN" $ do
it "works with a LEFT OUTER JOIN" $ it "works with a LEFT OUTER JOIN" $
@ -342,7 +342,7 @@ main = do
let title = b ^. BlogPostTitle let title = b ^. BlogPostTitle
orderBy [asc title] orderBy [asc title]
return title return title
liftIO $ ret `shouldBe` [ Single t1, Single t2, Single t3 ] liftIO $ ret `shouldBe` [ Value t1, Value t2, Value t3 ]
describe "delete" $ describe "delete" $
it "works on a simple example" $ it "works on a simple example" $