diff --git a/README.md b/README.md deleted file mode 100644 --- a/README.md +++ /dev/null @@ -1,4 +0,0 @@ -# `opaleye-sqlite` - -A preliminary version of Opaleye for SQLite. There may be many rough -edges! diff --git a/Test/QuickCheck.hs b/Test/QuickCheck.hs --- a/Test/QuickCheck.hs +++ b/Test/QuickCheck.hs @@ -35,8 +35,11 @@ type Columns = [Either (O.Column O.PGInt4) (O.Column O.PGBool)] type Haskells = [Either Int Bool] +columnsOfHaskells :: Haskells -> Columns +columnsOfHaskells = O.constantExplicit eitherPP + newtype ArbitraryQuery = ArbitraryQuery (O.Query Columns) -newtype ArbitraryColumns = ArbitraryColumns { unArbitraryColumns :: Columns } +newtype ArbitraryColumns = ArbitraryColumns { unArbitraryColumns :: Haskells } deriving Show newtype ArbitraryPositiveInt = ArbitraryPositiveInt Int deriving Show @@ -62,7 +65,7 @@ arbitraryQuery :: Int -> TQ.Gen ArbitraryQuery arbitraryQuery size | size == 0 = (pure . ArbitraryQuery . pure) [] | otherwise = TQ.oneof [ - (ArbitraryQuery . pure . unArbitraryColumns) + (ArbitraryQuery . pure . columnsOfHaskells . unArbitraryColumns) <$> TQ.arbitrary , return (ArbitraryQuery (fmap (\(x,y) -> [Left x, Left y]) (O.queryTable table1))) , do @@ -107,7 +110,7 @@ instance TQ.Arbitrary ArbitraryColumns where arbitrary = do l <- TQ.listOf (TQ.oneof (map (return . Left) [-1, 0, 1] - ++ map (return . Right) [O.pgBool False, O.pgBool True])) + ++ map (return . Right) [False, True])) return (ArbitraryColumns l) instance TQ.Arbitrary ArbitraryPositiveInt where @@ -221,6 +224,11 @@ -- { The tests +columns :: PGS.Connection -> ArbitraryColumns -> IO Bool +columns conn (ArbitraryColumns c) = + compareNoSort conn (denotation' (pure (columnsOfHaskells c))) + (pure c) + fmap' :: PGS.Connection -> ArbitraryGarble -> ArbitraryQuery -> IO Bool fmap' conn f (ArbitraryQuery q) = do compareNoSort conn (denotation' (fmap (unArbitraryGarble f) q)) @@ -262,29 +270,34 @@ run :: PGS.Connection -> IO () run conn = do - let propFmap = (fmap . fmap) TQ.ioProperty (fmap' conn) - propApply = (fmap . fmap) TQ.ioProperty (apply conn) - propLimit = (fmap . fmap) TQ.ioProperty (limit conn) --- propOffset = (fmap . fmap) TQ.ioProperty (offset conn) - propOrder = (fmap . fmap) TQ.ioProperty (order conn) - propDistinct = fmap TQ.ioProperty (distinct conn) - propRestrict = fmap TQ.ioProperty (restrict conn) + let prop1 p = fmap TQ.ioProperty (p conn) + prop2 p = (fmap . fmap) TQ.ioProperty (p conn) + test1 :: (Show a, TQ.Arbitrary a, TQ.Testable prop) + => (PGS.Connection -> a -> IO prop) -> IO () + test1 = t . prop1 + + test2 :: (Show a1, Show a2, TQ.Arbitrary a1, TQ.Arbitrary a2, + TQ.Testable prop) + => (PGS.Connection -> a1 -> a2 -> IO prop) -> IO () + test2 = t . prop2 + -- 5 seems to be the max size of test cases before SQLite's stack overflows. -- I'd rather increase the stack size -- http://www.sqlite.org/limits.html#max_expr_depth -- but I don't know how to do that from Haskell. -- Increasing the number of trials to compensate. - let t p = errorIfNotSuccess =<< TQ.quickCheckWithResult (TQ.stdArgs { TQ.maxSuccess = 10000 + t p = errorIfNotSuccess =<< TQ.quickCheckWithResult (TQ.stdArgs { TQ.maxSuccess = 10000 , TQ.maxSize = 5 }) p - t propFmap - t propApply - t propLimit --- t propOffset - t propOrder - t propDistinct - t propRestrict + test1 columns + test2 fmap' + test2 apply + test2 limit +-- test2 offset + test2 order + test1 distinct + test1 restrict -- } diff --git a/opaleye-sqlite.cabal b/opaleye-sqlite.cabal --- a/opaleye-sqlite.cabal +++ b/opaleye-sqlite.cabal @@ -1,6 +1,6 @@ name: opaleye-sqlite copyright: Copyright (c) 2014-2015 Purely Agile Limited -version: 0.0.0.1 +version: 0.0.1.0 synopsis: An SQL-generating DSL targeting SQLite description: An SQL-generating DSL targeting SQLite. Allows SQLite queries to be written within Haskell in a @@ -14,8 +14,7 @@ category: Database build-type: Simple cabal-version: >= 1.8 -extra-doc-files: *.md, - Doc/*.md +extra-doc-files: Doc/*.md tested-with: GHC==7.10.1, GHC==7.8.4, GHC==7.6.3 source-repository head @@ -46,6 +45,7 @@ Opaleye.SQLite.Aggregate, Opaleye.SQLite.Binary, Opaleye.SQLite.Column, + Opaleye.SQLite.Constant, Opaleye.SQLite.Distinct, Opaleye.SQLite.Join, Opaleye.SQLite.Manipulation, diff --git a/src/Opaleye/SQLite.hs b/src/Opaleye/SQLite.hs --- a/src/Opaleye/SQLite.hs +++ b/src/Opaleye/SQLite.hs @@ -1,6 +1,7 @@ module Opaleye.SQLite ( module Opaleye.SQLite.Aggregate , module Opaleye.SQLite.Binary , module Opaleye.SQLite.Column + , module Opaleye.SQLite.Constant , module Opaleye.SQLite.Distinct , module Opaleye.SQLite.Join , module Opaleye.SQLite.Manipulation @@ -17,6 +18,7 @@ import Opaleye.SQLite.Aggregate import Opaleye.SQLite.Binary import Opaleye.SQLite.Column +import Opaleye.SQLite.Constant import Opaleye.SQLite.Distinct import Opaleye.SQLite.Join import Opaleye.SQLite.Manipulation diff --git a/src/Opaleye/SQLite/Constant.hs b/src/Opaleye/SQLite/Constant.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SQLite/Constant.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} + +module Opaleye.SQLite.Constant where + +import Opaleye.SQLite.Column (Column) +import qualified Opaleye.SQLite.Column as C +import qualified Opaleye.SQLite.SqlTypes as T + +import qualified Data.Text as ST +import qualified Data.Text.Lazy as LT + +import qualified Data.Profunctor.Product as PP +import Data.Profunctor.Product (empty, (***!), (+++!)) +import qualified Data.Profunctor.Product.Default as D +import qualified Data.Profunctor as P + +import Control.Applicative (Applicative, pure, (<*>)) + + +newtype Constant haskells columns = + Constant { constantExplicit :: haskells -> columns } + +constant :: D.Default Constant haskells columns + => haskells -> columns +constant = constantExplicit D.def + +instance D.Default Constant haskell (Column sql) + => D.Default Constant (Maybe haskell) (Column (C.Nullable sql)) where + def = Constant (C.maybeToNullable . fmap f) + where Constant f = D.def + +instance D.Default Constant Int (Column T.SqlInt) where + def = Constant T.sqlInt + +instance D.Default Constant String (Column T.SqlText) where + def = Constant T.sqlString + +instance D.Default Constant ST.Text (Column T.SqlText) where + def = Constant T.sqlStrictText + +instance D.Default Constant LT.Text (Column T.SqlText) where + def = Constant T.sqlLazyText + +instance D.Default Constant Double (Column T.SqlReal) where + def = Constant T.sqlReal + +instance D.Default Constant Bool (Column T.SqlBool) where + def = Constant T.sqlBool + + +-- { Boilerplate instances + +instance Functor (Constant a) where + fmap f (Constant g) = Constant (fmap f g) + +instance Applicative (Constant a) where + pure = Constant . pure + Constant f <*> Constant x = Constant (f <*> x) + +instance P.Profunctor Constant where + dimap f g (Constant h) = Constant (P.dimap f g h) + +instance PP.ProductProfunctor Constant where + empty = Constant empty + Constant f ***! Constant g = Constant (f ***! g) + +instance PP.SumProfunctor Constant where + Constant f +++! Constant g = Constant (f +++! g) + +-- } diff --git a/src/Opaleye/SQLite/Internal/HaskellDB/Sql/Print.hs b/src/Opaleye/SQLite/Internal/HaskellDB/Sql/Print.hs --- a/src/Opaleye/SQLite/Internal/HaskellDB/Sql/Print.hs +++ b/src/Opaleye/SQLite/Internal/HaskellDB/Sql/Print.hs @@ -3,6 +3,7 @@ -- License : BSD-style module Opaleye.SQLite.Internal.HaskellDB.Sql.Print ( + deliteral, ppUpdate, ppDelete, ppInsert, @@ -27,6 +28,11 @@ empty, equals, hcat, hsep, parens, punctuate, text, vcat) +-- Silliness to avoid "ORDER BY 1" etc. meaning order by the first column +-- Any identity function will do +deliteral :: SqlExpr -> SqlExpr +deliteral c@(ColumnSqlExpr (SqlColumn _)) = c +deliteral expr = FunSqlExpr "COALESCE" [expr, expr] ppWhere :: [SqlExpr] -> Doc ppWhere [] = empty @@ -38,14 +44,7 @@ ppGroupBy es = text "GROUP BY" <+> ppGroupAttrs es where ppGroupAttrs :: [SqlExpr] -> Doc - ppGroupAttrs cs = commaV nameOrExpr cs - nameOrExpr :: SqlExpr -> Doc - nameOrExpr (ColumnSqlExpr (SqlColumn col)) = text col - -- Silliness to avoid "ORDER BY 1" etc. meaning order by the first column - -- Any identity function will do - -- nameOrExpr expr = parens (ppSqlExpr expr) - -- SQLite requires COALESCE to have at least two arguments. - nameOrExpr expr = text "COALESCE" <+> parens (commaH ppSqlExpr [expr, expr]) + ppGroupAttrs cs = commaV (ppSqlExpr . deliteral) cs ppOrderBy :: [(SqlExpr,SqlOrder)] -> Doc ppOrderBy [] = empty @@ -54,8 +53,7 @@ -- Silliness to avoid "ORDER BY 1" etc. meaning order by the first column -- Any identity function will do -- ppOrd (e,o) = ppSqlExpr e <+> ppSqlDirection o <+> ppSqlNulls o - ppOrd (e,o) = text "COALESCE" - <+> parens (commaH ppSqlExpr [e, e]) + ppOrd (e,o) = ppSqlExpr (deliteral e) <+> ppSqlDirection o <+> ppSqlNulls o @@ -66,7 +64,7 @@ -- FIXME: We haven't implemented NULL ordering properly ppSqlNulls :: Sql.SqlOrder -> Doc -ppSqlNulls x = empty +ppSqlNulls _ = empty --ppSqlNulls x = text $ case Sql.sqlOrderNulls x of -- Sql.SqlNullsFirst -> "NULLS FIRST" -- Sql.SqlNullsLast -> "NULLS LAST" diff --git a/src/Opaleye/SQLite/Internal/PGTypes.hs b/src/Opaleye/SQLite/Internal/PGTypes.hs --- a/src/Opaleye/SQLite/Internal/PGTypes.hs +++ b/src/Opaleye/SQLite/Internal/PGTypes.hs @@ -15,7 +15,7 @@ -- FIXME: SQLite requires temporal types to have the type "TEXT" which -- may cause problems elsewhere. unsafePgFormatTime :: Time.FormatTime t => HPQ.Name -> String -> t -> Column c -unsafePgFormatTime typeName formatString = castToType "TEXT" . format +unsafePgFormatTime _typeName formatString = castToType "TEXT" . format where format = Time.formatTime Locale.defaultTimeLocale formatString literalColumn :: HPQ.Literal -> Column a diff --git a/src/Opaleye/SQLite/Internal/Sql.hs b/src/Opaleye/SQLite/Internal/Sql.hs --- a/src/Opaleye/SQLite/Internal/Sql.hs +++ b/src/Opaleye/SQLite/Internal/Sql.hs @@ -8,6 +8,7 @@ import Opaleye.SQLite.Internal.HaskellDB.PrimQuery (Symbol(Symbol)) import qualified Opaleye.SQLite.Internal.HaskellDB.Sql as HSql import qualified Opaleye.SQLite.Internal.HaskellDB.Sql.Default as SD +import qualified Opaleye.SQLite.Internal.HaskellDB.Sql.Print as SP import qualified Opaleye.SQLite.Internal.HaskellDB.Sql.Generate as SG import qualified Opaleye.SQLite.Internal.Tag as T @@ -101,8 +102,7 @@ --- constant. handleEmpty :: [HSql.SqlExpr] -> NEL.NonEmpty HSql.SqlExpr handleEmpty = - M.fromMaybe (return (HSql.FunSqlExpr "COALESCE" [HSql.ConstSqlExpr "0" - ,HSql.ConstSqlExpr "0"])) + M.fromMaybe (return (SP.deliteral (HSql.ConstSqlExpr "0"))) . NEL.nonEmpty groupBy' :: [(symbol, (Maybe aggrOp, HPQ.PrimExpr))] diff --git a/src/Opaleye/SQLite/SqlTypes.hs b/src/Opaleye/SQLite/SqlTypes.hs --- a/src/Opaleye/SQLite/SqlTypes.hs +++ b/src/Opaleye/SQLite/SqlTypes.hs @@ -4,13 +4,9 @@ import Opaleye.SQLite.Internal.Column (Column) import qualified Opaleye.SQLite.PGTypes as PT -import qualified Opaleye.SQLite.Internal.PGTypes as IPT -import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as HPQ - import qualified Data.Text as SText import qualified Data.Text.Lazy as LText -import qualified Data.Time as Time -- These probably don't correspond very well to SQLite types yet. -- Work in progress.