From f718be86da2b88dc8f18d094ef50996bee3f2e4d Mon Sep 17 00:00:00 2001 From: Felipe Lessa Date: Thu, 6 Sep 2012 01:40:52 -0300 Subject: [PATCH] Instead of using rawSql's Single, use a new data type Value. 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. --- src/Database/Esqueleto.hs | 5 +- src/Database/Esqueleto/Internal/Language.hs | 69 ++++++++++++--------- src/Database/Esqueleto/Internal/Sql.hs | 50 +++++---------- test/Test.hs | 18 +++--- 4 files changed, 66 insertions(+), 76 deletions(-) diff --git a/src/Database/Esqueleto.hs b/src/Database/Esqueleto.hs index 1cb488e..e7cc4ed 100644 --- a/src/Database/Esqueleto.hs +++ b/src/Database/Esqueleto.hs @@ -25,6 +25,7 @@ module Database.Esqueleto , (+.), (-.), (/.), (*.) , set, (=.), (+=.), (-=.), (*=.), (/=.) ) , from + , Value(..) , OrderBy -- ** Joins , InnerJoin(..) @@ -191,8 +192,8 @@ import qualified Database.Persist.Store -- @ -- -- Since @age@ is an optional @Person@ field, we use 'just' lift --- @val 18 :: SqlExpr (Single Int)@ into @just (val 18) :: --- SqlExpr (Single (Just Int))@. +-- @val 18 :: SqlExpr (Value Int)@ into @just (val 18) :: +-- SqlExpr (Value (Just Int))@. -- -- Implicit joins are represented by tuples. For example, to get -- the list of all blog posts and their authors, we could write: diff --git a/src/Database/Esqueleto/Internal/Language.hs b/src/Database/Esqueleto/Internal/Language.hs index 85d8052..722d1e7 100644 --- a/src/Database/Esqueleto/Internal/Language.hs +++ b/src/Database/Esqueleto/Internal/Language.hs @@ -10,6 +10,7 @@ module Database.Esqueleto.Internal.Language ( Esqueleto(..) , from + , Value(..) , InnerJoin(..) , CrossJoin(..) , LeftOuterJoin(..) @@ -67,7 +68,7 @@ class (Functor query, Applicative query, Monad query) => -> query a -- | @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@ -- 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 -- broken: @query1@'s 'on' would refer to @query2@'s -- 'LeftOuterJoin'. - on :: expr (Single Bool) -> query () + on :: expr (Value Bool) -> query () -- | @ORDER BY@ clause. See also 'asc' and 'desc'. orderBy :: [expr OrderBy] -> query () -- | 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. - desc :: PersistField a => expr (Single a) -> expr OrderBy + desc :: PersistField a => expr (Value a) -> expr OrderBy -- | 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. - 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. (^.) :: (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. (?.) :: (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. - val :: PersistField typ => typ -> expr (Single typ) + val :: PersistField typ => typ -> expr (Value typ) -- | @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 -- of type @Maybe typ@. It should hold that @val . Just === -- just . val@. - just :: expr (Single typ) -> expr (Single (Maybe typ)) + just :: expr (Value typ) -> expr (Value (Maybe typ)) -- | @NULL@ value. - nothing :: expr (Single (Maybe typ)) + nothing :: expr (Value (Maybe typ)) -- | @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 (Single typ) -> expr (Single typ) -> expr (Single Bool) - (>.) :: PersistField typ => expr (Single typ) -> expr (Single typ) -> expr (Single Bool) - (<=.) :: PersistField typ => expr (Single typ) -> expr (Single typ) -> expr (Single Bool) - (<.) :: PersistField typ => expr (Single typ) -> expr (Single typ) -> expr (Single 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 (Value typ) -> expr (Value typ) -> expr (Value Bool) + (>.) :: PersistField typ => expr (Value typ) -> expr (Value typ) -> expr (Value Bool) + (<=.) :: PersistField typ => expr (Value typ) -> expr (Value typ) -> expr (Value Bool) + (<.) :: PersistField typ => expr (Value typ) -> expr (Value typ) -> expr (Value Bool) + (!=.) :: PersistField typ => expr (Value typ) -> expr (Value typ) -> expr (Value Bool) - (&&.) :: expr (Single Bool) -> expr (Single Bool) -> expr (Single Bool) - (||.) :: expr (Single Bool) -> expr (Single Bool) -> expr (Single Bool) + (&&.) :: expr (Value Bool) -> expr (Value Bool) -> expr (Value Bool) + (||.) :: expr (Value Bool) -> expr (Value Bool) -> expr (Value Bool) - (+.) :: PersistField a => expr (Single a) -> expr (Single a) -> expr (Single a) - (-.) :: PersistField a => expr (Single a) -> expr (Single a) -> expr (Single a) - (/.) :: PersistField a => expr (Single a) -> expr (Single a) -> expr (Single 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 (Value a) -> expr (Value a) -> expr (Value a) + (/.) :: PersistField a => expr (Value a) -> expr (Value a) -> expr (Value a) + (*.) :: PersistField a => expr (Value a) -> expr (Value a) -> expr (Value a) -- | @SET@ clause used on @UPDATE@s. Note that while it's not -- a type error to use this function on a @SELECT@, it will -- most certainly result in a runtime error. 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 a) => EntityField val a -> expr (Single 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 (Single a) -> expr (Update val) - (/=.) :: (PersistEntity val, PersistField a) => EntityField val a -> expr (Single a) -> expr (Update val) + (=.) :: (PersistEntity val, PersistField typ) => EntityField val typ -> expr (Value typ) -> expr (Update val) + (+=.) :: (PersistEntity val, PersistField a) => EntityField val a -> expr (Value 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 (Value a) -> expr (Update val) + (/=.) :: (PersistEntity val, PersistField a) => EntityField val a -> expr (Value a) -> expr (Update val) -- Fixity declarations @@ -198,6 +199,12 @@ infixr 3 &&., =., +=., -=., *=., /=. 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 InnerJoin a b = a `InnerJoin` b diff --git a/src/Database/Esqueleto/Internal/Sql.hs b/src/Database/Esqueleto/Internal/Sql.hs index ebc056a..5aa4992 100644 --- a/src/Database/Esqueleto/Internal/Sql.hs +++ b/src/Database/Esqueleto/Internal/Sql.hs @@ -86,18 +86,18 @@ instance Monoid SideData where -- | A part of a @FROM@ clause. data FromClause = FromStart Ident EntityDef - | FromJoin FromClause JoinKind FromClause (Maybe (SqlExpr (Single Bool))) - | OnClause (SqlExpr (Single Bool)) + | FromJoin FromClause JoinKind FromClause (Maybe (SqlExpr (Value Bool))) + | OnClause (SqlExpr (Value Bool)) -- | 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 -- unmatched 'OnClause's data on error. Returns a list without -- 'OnClauses' on success. -collectOnClauses :: [FromClause] -> Either (SqlExpr (Single Bool)) [FromClause] +collectOnClauses :: [FromClause] -> Either (SqlExpr (Value Bool)) [FromClause] collectOnClauses = go [] where go [] (f@(FromStart _ _):fs) = fmap (f:) (go [] fs) -- fast path @@ -123,7 +123,7 @@ collectOnClauses = go [] -- | A complete @WHERE@ clause. -data WhereClause = Where (SqlExpr (Single Bool)) +data WhereClause = Where (SqlExpr (Value Bool)) | NoWhere instance Monoid WhereClause where @@ -186,9 +186,9 @@ useIdent esc (I ident) = esc (DBName ident) data SqlExpr a where EEntity :: Ident -> SqlExpr (Entity val) EMaybe :: SqlExpr a -> SqlExpr (Maybe a) - ERaw :: NeedParens -> (Escape -> (TLB.Builder, [PersistValue])) -> SqlExpr (Single a) - EOrderBy :: OrderByType -> SqlExpr (Single a) -> SqlExpr OrderBy - ESet :: (SqlExpr (Entity val) -> SqlExpr (Single ())) -> SqlExpr (Update val) + ERaw :: NeedParens -> (Escape -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value a) + EOrderBy :: OrderByType -> SqlExpr (Value a) -> SqlExpr OrderBy + ESet :: (SqlExpr (Entity val) -> SqlExpr (Value ())) -> SqlExpr (Update val) EPreprocessedFrom :: a -> FromClause -> SqlExpr (PreprocessedFrom a) data NeedParens = Parens | Never @@ -219,7 +219,6 @@ instance Esqueleto SqlQuery SqlExpr SqlPersist where maybelize :: SqlExpr (PreprocessedFrom (SqlExpr (Entity a))) -> SqlExpr (PreprocessedFrom (SqlExpr (Maybe (Entity a)))) maybelize (EPreprocessedFrom ret from_) = EPreprocessedFrom (EMaybe ret) from_ - maybelize _ = error "Esqueleto/Sql/fromStartMaybe: never here (see GHC #6124)" fromJoin (EPreprocessedFrom lhsRet lhsFrom) (EPreprocessedFrom rhsRet rhsFrom) = Q $ do @@ -229,12 +228,10 @@ instance Esqueleto SqlQuery SqlExpr SqlPersist where rhsFrom -- RHS Nothing -- ON return (EPreprocessedFrom ret from_) - fromJoin _ _ = error "Esqueleto/Sql/fromJoin: never here (see GHC #6124)" fromFinish (EPreprocessedFrom ret from_) = Q $ do W.tell mempty { sdFromClause = [from_] } return ret - fromFinish _ = error "Esqueleto/Sql/fromFinish: never here (see GHC #6124)" where_ expr = Q $ W.tell mempty { sdWhereClause = Where expr } @@ -249,27 +246,21 @@ instance Esqueleto SqlQuery SqlExpr SqlPersist where EEntity ident ^. field = ERaw Never $ \esc -> (useIdent esc ident <> ("." <> fieldName esc field), []) - _ ^. _ = error "Esqueleto/Sql/(^.): never here (see GHC #6124)" EMaybe r ?. field = maybelize (r ^. field) 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 _ = error "Esqueleto/Sql/(?.): never here 1 (see GHC #6124)" - _ ?. _ = error "Esqueleto/Sql/(?.): never here 2 (see GHC #6124)" val = ERaw Never . const . (,) "?" . return . toPersistValue 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 _ = error "Esqueleto/Sql/just: never here (see GHC #6124)" nothing = ERaw Never $ \_ -> ("NULL", mempty) countRows = ERaw Never $ \_ -> ("COUNT(*)", mempty) not_ (ERaw p f) = ERaw Never $ \esc -> let (b, vals) = f esc in ("NOT " <> parensM p b, vals) - not_ _ = error "Esqueleto/Sql/not_: never here (see GHC #6124)" (==.) = binop " = " (>=.) = binop " >= " @@ -287,7 +278,6 @@ instance Esqueleto SqlQuery SqlExpr SqlPersist where set ent upds = Q $ W.tell mempty { sdSetClause = map apply upds } where 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 (\ent -> ent ^. field +. expr) @@ -302,25 +292,24 @@ fieldName esc = esc . fieldDB . persistFieldDef setAux :: (PersistEntity val, PersistField typ) => EntityField val typ - -> (SqlExpr (Entity val) -> SqlExpr (Single typ)) + -> (SqlExpr (Entity val) -> SqlExpr (Value typ)) -> SqlExpr (Update val) setAux field mkVal = ESet $ \ent -> binop " = " name (mkVal ent) 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) fromDBName :: Connection -> DBName -> TLB.Builder 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 where f esc = let (b1, vals1) = f1 esc (b2, vals2) = f2 esc in ( parensM p1 b1 <> op <> parensM p2 b2 , 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 " 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) = OnClauseWithoutMatchingJoinException $ TL.unpack $ TLB.toLazyText $ fst (f esc) - mkExc _ = OnClauseWithoutMatchingJoinException "???" makeSet :: Escape -> [SetClause] -> (TLB.Builder, [PersistValue]) @@ -544,13 +532,11 @@ makeSet _ [] = mempty makeSet esc os = first ("\nSET " <>) $ uncommas' (map mk os) where mk (SetClause (ERaw _ f)) = f esc - mk _ = error "Esqueleto/Sql/makeSet: never here (see GHC #6124)" makeWhere :: Escape -> WhereClause -> (TLB.Builder, [PersistValue]) makeWhere _ NoWhere = mempty 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]) @@ -558,7 +544,6 @@ makeOrderBy _ [] = mempty makeOrderBy esc os = first ("\nORDER BY " <>) $ uncommas' (map mk os) where mk (EOrderBy t (ERaw _ f)) = first (<> orderByType t) (f esc) - mk _ = error "Esqueleto/Sql/makeOrderBy: never here (see GHC #6124)" orderByType ASC = " ASC" orderByType DESC = " DESC" @@ -608,7 +593,6 @@ instance PersistEntity a => SqlSelect (SqlExpr (Entity a)) (Entity a) where name = useIdent escape ident <> "." ret = let ed = entityDef $ getEntityVal expr in (process ed, mempty) - sqlSelectCols _ _ = error "Esqueleto/Sql/sqlSelectCols[Entity]: never here (see GHC #6124)" sqlSelectColCount = (+1) . length . entityFields . entityDef . getEntityVal sqlSelectProcessRow (idCol:ent) = Entity <$> fromPersistValue idCol @@ -620,7 +604,6 @@ getEntityVal = error "Esqueleto/Sql/getEntityVal" instance PersistEntity a => SqlSelect (SqlExpr (Maybe (Entity a))) (Maybe (Entity a)) where sqlSelectCols escape (EMaybe ent) = sqlSelectCols escape ent - sqlSelectCols _ _ = error "Esqueleto/Sql/sqlSelectCols[Maybe Entity]: never here (see GHC #6124)" sqlSelectColCount = sqlSelectColCount . fromEMaybe where 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 | 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 in (parensM p b, vals) - sqlSelectCols _ _ = error "Esqueleto/Sql/sqlSelectCols[Single]: never here (see GHC #6124)" sqlSelectColCount = const 1 - sqlSelectProcessRow [pv] = Single <$> fromPersistValue pv - sqlSelectProcessRow _ = Left "SqlSelect (Single a): wrong number of columns." + sqlSelectProcessRow [pv] = Value <$> fromPersistValue pv + sqlSelectProcessRow _ = Left "SqlSelect (Value a): wrong number of columns." instance ( SqlSelect a ra , SqlSelect b rb diff --git a/test/Test.hs b/test/Test.hs index 687640e..454d6f8 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -59,12 +59,12 @@ main = do it "works for a single value" $ run $ do ret <- select $ return $ val (3 :: Int) - liftIO $ ret `shouldBe` [ Single 3 ] + liftIO $ ret `shouldBe` [ Value 3 ] it "works for a single NULL value" $ run $ do ret <- select $ return $ nothing - liftIO $ ret `shouldBe` [ Single (Nothing :: Maybe Int) ] + liftIO $ ret `shouldBe` [ Value (Nothing :: Maybe Int) ] describe "select/from" $ do it "works for a simple example" $ @@ -102,8 +102,8 @@ main = do ret <- select $ from $ \p -> return (p ^. PersonId, p ^. PersonName) - liftIO $ ret `shouldBe` [ (Single p1k, Single (personName p1)) - , (Single p2k, Single (personName p2)) ] + liftIO $ ret `shouldBe` [ (Value p1k, Value (personName p1)) + , (Value p2k, Value (personName p2)) ] it "works for a simple projection with a simple implicit self-join" $ run $ do @@ -112,10 +112,10 @@ main = do ret <- select $ from $ \(pa, pb) -> return (pa ^. PersonName, pb ^. PersonName) - liftIO $ ret `shouldBe` [ (Single (personName p1), Single (personName p1)) - , (Single (personName p1), Single (personName p2)) - , (Single (personName p2), Single (personName p1)) - , (Single (personName p2), Single (personName p2)) ] + liftIO $ ret `shouldBe` [ (Value (personName p1), Value (personName p1)) + , (Value (personName p1), Value (personName p2)) + , (Value (personName p2), Value (personName p1)) + , (Value (personName p2), Value (personName p2)) ] describe "select/JOIN" $ do it "works with a LEFT OUTER JOIN" $ @@ -342,7 +342,7 @@ main = do let title = b ^. BlogPostTitle orderBy [asc title] return title - liftIO $ ret `shouldBe` [ Single t1, Single t2, Single t3 ] + liftIO $ ret `shouldBe` [ Value t1, Value t2, Value t3 ] describe "delete" $ it "works on a simple example" $