├── stack.yaml ├── cabal.project ├── Setup.hs ├── opaleye-sqlite ├── cabal.project ├── Setup.hs ├── stack.yaml ├── Doc │ ├── Tutorial │ │ ├── Main.hs │ │ ├── TutorialAdvanced.lhs │ │ └── TutorialManipulation.lhs │ └── UPGRADING.md ├── README.md ├── src │ └── Opaleye │ │ ├── SQLite │ │ ├── QueryArr.hs │ │ ├── Internal │ │ │ ├── Tag.hs │ │ │ ├── Helpers.hs │ │ │ ├── HaskellDB │ │ │ │ ├── Sql │ │ │ │ │ └── Generate.hs │ │ │ │ ├── Sql.hs │ │ │ │ └── PrimQuery.hs │ │ │ ├── Optimize.hs │ │ │ ├── PGTypes.hs │ │ │ ├── Join.hs │ │ │ ├── Distinct.hs │ │ │ ├── Binary.hs │ │ │ ├── Column.hs │ │ │ ├── Order.hs │ │ │ ├── QueryArr.hs │ │ │ ├── Aggregate.hs │ │ │ ├── PrimQuery.hs │ │ │ ├── TableMaker.hs │ │ │ ├── Unpackspec.hs │ │ │ ├── Values.hs │ │ │ ├── Print.hs │ │ │ └── PackMap.hs │ │ ├── Distinct.hs │ │ ├── SqlTypes.hs │ │ ├── Values.hs │ │ ├── Binary.hs │ │ ├── Sql.hs │ │ ├── Table.hs │ │ ├── Column.hs │ │ ├── Constant.hs │ │ ├── Aggregate.hs │ │ ├── Join.hs │ │ ├── Operators.hs │ │ ├── Order.hs │ │ ├── RunQuery.hs │ │ └── PGTypes.hs │ │ └── SQLite.hs ├── LICENSE └── opaleye-sqlite.cabal ├── .gitignore ├── src ├── Opaleye │ ├── Inferrable.hs │ ├── TypeFamilies.hs │ ├── Lateral.hs │ ├── Select.hs │ ├── Internal │ │ ├── Tag.hs │ │ ├── Helpers.hs │ │ ├── Map.hs │ │ ├── HaskellDB │ │ │ ├── Sql │ │ │ │ └── Generate.hs │ │ │ └── Sql.hs │ │ ├── Lateral.hs │ │ ├── Rebind.hs │ │ ├── Locking.hs │ │ ├── JSONBuildObjectFields.hs │ │ ├── PGTypes.hs │ │ ├── Distinct.hs │ │ ├── Binary.hs │ │ ├── TypeFamilies.hs │ │ ├── RunQueryExternal.hs │ │ ├── Unpackspec.hs │ │ ├── Optimize.hs │ │ ├── Column.hs │ │ ├── Operators.hs │ │ └── Order.hs │ ├── Label.hs │ ├── Exists.hs │ ├── Values.hs │ ├── Column.hs │ ├── Distinct.hs │ ├── Sql.hs │ ├── Adaptors.hs │ ├── ToFields.hs │ ├── FunctionalJoin.hs │ ├── MaybeFields.hs │ ├── Window.hs │ ├── Field.hs │ ├── Table.hs │ └── Binary.hs └── Opaleye.hs ├── Doc ├── Tutorial │ ├── Main.hs │ └── TutorialAdvanced.lhs └── Design │ └── DESIGN.md ├── TODO.md ├── Test ├── TypeFamilies.hs ├── Opaleye │ └── Test │ │ └── TraverseA.hs ├── Connection.hs └── Wrapped.hs ├── .github └── workflows │ └── ci.yml └── LICENSE /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-16.29 2 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: opaleye.cabal 2 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /opaleye-sqlite/cabal.project: -------------------------------------------------------------------------------- 1 | packages: opaleye-sqlite.cabal 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .env 2 | .stack-work/ 3 | dist-newstyle/ 4 | dist/ 5 | -------------------------------------------------------------------------------- /opaleye-sqlite/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /opaleye-sqlite/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-16.29 2 | extra-deps: 3 | - direct-sqlite-2.3.26 4 | - sqlite-simple-0.4.18.0 5 | -------------------------------------------------------------------------------- /opaleye-sqlite/Doc/Tutorial/Main.hs: -------------------------------------------------------------------------------- 1 | import TutorialBasic () 2 | import TutorialManipulation () 3 | import TutorialAdvanced () 4 | import DefaultExplanation () 5 | 6 | main :: IO () 7 | main = return () 8 | -------------------------------------------------------------------------------- /src/Opaleye/Inferrable.hs: -------------------------------------------------------------------------------- 1 | module Opaleye.Inferrable 2 | ( Inferrable, 3 | inferrableDef, 4 | inferrable, 5 | runInferrable, 6 | ) 7 | where 8 | 9 | import Opaleye.Internal.Inferrable 10 | -------------------------------------------------------------------------------- /Doc/Tutorial/Main.hs: -------------------------------------------------------------------------------- 1 | import TutorialBasic () 2 | import TutorialBasicMonomorphic () 3 | import TutorialManipulation () 4 | import TutorialAdvanced () 5 | import DefaultExplanation () 6 | 7 | main :: IO () 8 | main = return () 9 | -------------------------------------------------------------------------------- /opaleye-sqlite/README.md: -------------------------------------------------------------------------------- 1 | # opaleye-sqlite is unmaintained 2 | 3 | `opaleye-sqlite` is unmaintained and probably unusable. If you'd like 4 | to try to resurrect it please [file an issue on 5 | GitHub](https://github.com/tomjaguarpaw/haskell-opaleye/issues/new). 6 | -------------------------------------------------------------------------------- /TODO.md: -------------------------------------------------------------------------------- 1 | ## Good starter projects for someone wanting to contribute to Opaleye 2 | 3 | ### Very easy 4 | 5 | * There may be some missing operators that just need to be written down 6 | 7 | ### Require a bit of work 8 | 9 | * Make the code generation neater 10 | * Escape hatch for embedding raw SQL 11 | -------------------------------------------------------------------------------- /opaleye-sqlite/src/Opaleye/SQLite/QueryArr.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | 3 | This modules defines the 'QueryArr' arrow, which is an arrow that represents 4 | selecting data from a database, and composing multiple queries together. 5 | 6 | -} 7 | module Opaleye.SQLite.QueryArr (QueryArr, Query) where 8 | 9 | import Opaleye.SQLite.Internal.QueryArr (QueryArr, Query) 10 | -------------------------------------------------------------------------------- /src/Opaleye/TypeFamilies.hs: -------------------------------------------------------------------------------- 1 | module Opaleye.TypeFamilies {-# DEPRECATED "No longer supported" #-} 2 | ( TF.TableRecordField 3 | , TF.RecordField 4 | , (TF.:<*>) 5 | , (TF.:<$>) 6 | , TF.Id 7 | , TF.Pure 8 | , TF.IMap 9 | , TF.F 10 | , TF.O 11 | , TF.H 12 | , TF.W 13 | , TF.N 14 | , TF.NN 15 | , TF.Opt 16 | , TF.Req 17 | , TF.Nulls 18 | ) where 19 | 20 | import Opaleye.Internal.TypeFamilies as TF 21 | -------------------------------------------------------------------------------- /opaleye-sqlite/src/Opaleye/SQLite/Internal/Tag.hs: -------------------------------------------------------------------------------- 1 | module Opaleye.SQLite.Internal.Tag where 2 | 3 | newtype Tag = UnsafeTag Int deriving (Read, Show) 4 | 5 | start :: Tag 6 | start = UnsafeTag 1 7 | 8 | next :: Tag -> Tag 9 | next = UnsafeTag . (+1) . unsafeUnTag 10 | 11 | unsafeUnTag :: Tag -> Int 12 | unsafeUnTag (UnsafeTag i) = i 13 | 14 | tagWith :: Tag -> String -> String 15 | tagWith t s = s ++ "_" ++ show (unsafeUnTag t) 16 | -------------------------------------------------------------------------------- /src/Opaleye/Lateral.hs: -------------------------------------------------------------------------------- 1 | -- | You will only need this module if you are using the arrow 2 | -- ('Opaleye.Select.SelectArr') interface to Opaleye. It is not 3 | -- needed when working only with 'Opaleye.Select.Select's and using 4 | -- the monadic (@do@ notation) interface. 5 | 6 | module Opaleye.Lateral 7 | ( lateral 8 | , viaLateral 9 | , laterally 10 | , bilaterally 11 | ) 12 | where 13 | 14 | import Opaleye.Internal.Lateral 15 | -------------------------------------------------------------------------------- /src/Opaleye/Select.hs: -------------------------------------------------------------------------------- 1 | -- | A 'Select' represents an SQL @SELECT@ statement. To run a 2 | -- 'Select' use the functions in "Opaleye.RunSelect". To create a 3 | -- 'Select' you probably want to start by querying one of your 4 | -- 'Opaleye.Table.Table's using 'Opaleye.Table.selectTable'. 5 | -- 'SelectArr' is a parametrised version of 'Select', i.e. it can be 6 | -- passed arguments. 7 | 8 | module Opaleye.Select (Select, SelectArr) where 9 | 10 | import Opaleye.Internal.QueryArr 11 | -------------------------------------------------------------------------------- /opaleye-sqlite/src/Opaleye/SQLite/Internal/Helpers.hs: -------------------------------------------------------------------------------- 1 | module Opaleye.SQLite.Internal.Helpers where 2 | 3 | infixr 8 .: 4 | 5 | (.:) :: (r -> z) -> (a -> b -> r) -> a -> b -> z 6 | (.:) f g x y = f (g x y) 7 | 8 | infixr 8 .:. 9 | 10 | (.:.) :: (r -> z) -> (a -> b -> c -> r) -> a -> b -> c -> z 11 | (.:.) f g a b c = f (g a b c) 12 | 13 | infixr 8 .:: 14 | 15 | (.::) :: (r -> z) -> (a -> b -> c -> d -> r) -> a -> b -> c -> d -> z 16 | (.::) f g a b c d = f (g a b c d) 17 | 18 | infixr 8 .::. 19 | 20 | (.::.) :: (r -> z) -> (a -> b -> c -> d -> e -> r) -> a -> b -> c -> d -> e -> z 21 | (.::.) f g a b c d e = f (g a b c d e) 22 | -------------------------------------------------------------------------------- /src/Opaleye/Internal/Tag.hs: -------------------------------------------------------------------------------- 1 | module Opaleye.Internal.Tag where 2 | 3 | import Control.Monad.Trans.State.Strict ( get, modify', State ) 4 | 5 | -- | Tag is for use as a source of unique IDs in QueryArr 6 | newtype Tag = UnsafeTag Int deriving (Read, Show) 7 | 8 | start :: Tag 9 | start = UnsafeTag 1 10 | 11 | next :: Tag -> Tag 12 | next = UnsafeTag . (+1) . unsafeUnTag 13 | 14 | unsafeUnTag :: Tag -> Int 15 | unsafeUnTag (UnsafeTag i) = i 16 | 17 | tagWith :: Tag -> String -> String 18 | tagWith t s = s ++ "_" ++ show (unsafeUnTag t) 19 | 20 | fresh :: State Tag Tag 21 | fresh = do 22 | t <- get 23 | modify' next 24 | pure t 25 | -------------------------------------------------------------------------------- /src/Opaleye/Internal/Helpers.hs: -------------------------------------------------------------------------------- 1 | module Opaleye.Internal.Helpers where 2 | 3 | infixr 8 .: 4 | 5 | (.:) :: (r -> z) -> (a -> b -> r) -> a -> b -> z 6 | (.:) f g x y = f (g x y) 7 | 8 | infixr 8 .:. 9 | 10 | (.:.) :: (r -> z) -> (a -> b -> c -> r) -> a -> b -> c -> z 11 | (.:.) f g a b c = f (g a b c) 12 | 13 | infixr 8 .:: 14 | 15 | (.::) :: (r -> z) -> (a -> b -> c -> d -> r) -> a -> b -> c -> d -> z 16 | (.::) f g a b c d = f (g a b c d) 17 | 18 | infixr 8 .::. 19 | 20 | (.::.) :: (r -> z) -> (a -> b -> c -> d -> e -> r) -> a -> b -> c -> d -> e -> z 21 | (.::.) f g a b c d e = f (g a b c d e) 22 | 23 | atSameType :: p a a -> p a a 24 | atSameType = id 25 | -------------------------------------------------------------------------------- /Test/TypeFamilies.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | 4 | module TypeFamilies where 5 | 6 | import Opaleye.Internal.TypeFamilies 7 | 8 | data (:~) a b where 9 | Eq :: (:~) a a 10 | 11 | -- If it compiles, it works 12 | tests :: () 13 | tests = () 14 | where _ = Eq :: a :~ (Pure :<$> Id :<| a :<| b) 15 | _ = Eq :: a :~ (Id :<| a) 16 | _ = Eq :: (a -> a) :~ (((->) :<$> Id :<*> Id) :<| a) 17 | _ = Eq :: (a -> b) 18 | :~ (((->) :<$> Pure a :<*> Pure b) :<| c) 19 | _ = Eq :: Maybe a :~ ((Maybe :<$> Pure a) :<| b) 20 | _ = Eq :: Maybe a :~ ((Maybe :<$> Id) :<| a) 21 | _ = Eq :: a :~ (Pure a :<| b) 22 | -------------------------------------------------------------------------------- /src/Opaleye/Label.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | 3 | module Opaleye.Label ( 4 | label', 5 | -- * Deprecated 6 | label 7 | ) where 8 | 9 | import qualified Opaleye.Internal.PrimQuery as PQ 10 | import qualified Opaleye.Internal.QueryArr as Q 11 | import qualified Opaleye.Select as S 12 | 13 | import Control.Arrow (returnA) 14 | 15 | -- | Add a commented label to the generated SQL. 16 | label' :: String -> S.Select () 17 | label' l = Q.selectArr f where 18 | f = pure (\() -> ((), PQ.aLabel l)) 19 | 20 | {-# DEPRECATED label "Will be removed in version 0.11. Use 'label\'' instead." #-} 21 | label :: String -> S.SelectArr a b -> S.SelectArr a b 22 | label l s = proc a -> do 23 | b <- s -< a 24 | label' l -< () 25 | returnA -< b 26 | -------------------------------------------------------------------------------- /src/Opaleye/Internal/Map.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | 3 | module Opaleye.Internal.Map where 4 | 5 | type family Map f x 6 | 7 | type instance Map f (a1, a2) 8 | = (Map f a1, Map f a2) 9 | type instance Map f (a1, a2, a3) 10 | = (Map f a1, Map f a2, Map f a3) 11 | type instance Map f (a1, a2, a3, a4) 12 | = (Map f a1, Map f a2, Map f a3, Map f a4) 13 | type instance Map f (a1, a2, a3, a4, a5) 14 | = (Map f a1, Map f a2, Map f a3, Map f a4, Map f a5) 15 | type instance Map f (a1, a2, a3, a4, a5, a6) 16 | = (Map f a1, Map f a2, Map f a3, Map f a4, Map f a5, Map f a6) 17 | type instance Map f (a1, a2, a3, a4, a5, a6, a7) 18 | = (Map f a1, Map f a2, Map f a3, Map f a4, Map f a5, Map f a6, 19 | Map f a7) 20 | type instance Map f (a1, a2, a3, a4, a5, a6, a7, a8) 21 | = (Map f a1, Map f a2, Map f a3, Map f a4, Map f a5, Map f a6, 22 | Map f a7, Map f a8) 23 | -------------------------------------------------------------------------------- /src/Opaleye/Exists.hs: -------------------------------------------------------------------------------- 1 | module Opaleye.Exists (exists) where 2 | 3 | import Opaleye.Field (Field) 4 | import Opaleye.Internal.Column (Field_(Column)) 5 | import Opaleye.Internal.QueryArr (productQueryArr, runSimpleSelect) 6 | import Opaleye.Internal.PackMap (run, extractAttr) 7 | import Opaleye.Internal.PrimQuery (PrimQuery' (Exists)) 8 | import Opaleye.Internal.Tag (fresh) 9 | import Opaleye.Select (Select) 10 | import Opaleye.SqlTypes (SqlBool) 11 | 12 | -- | True if any rows are returned by the given query, false otherwise. 13 | -- 14 | -- This operation is equivalent to Postgres's @EXISTS@ operator. 15 | exists :: Select a -> Select (Field SqlBool) 16 | exists q = productQueryArr $ do 17 | (_, query) <- runSimpleSelect q 18 | tag <- fresh 19 | let (result, [(binding, ())]) = run (extractAttr "exists" tag ()) 20 | pure (Column result, Exists binding query) 21 | -------------------------------------------------------------------------------- /opaleye-sqlite/src/Opaleye/SQLite/Distinct.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | module Opaleye.SQLite.Distinct (module Opaleye.SQLite.Distinct, distinctExplicit) 4 | where 5 | 6 | import Opaleye.SQLite.QueryArr (Query) 7 | import Opaleye.SQLite.Internal.Distinct (distinctExplicit, Distinctspec) 8 | 9 | import qualified Data.Profunctor.Product.Default as D 10 | 11 | -- | Remove duplicate items from the query result. 12 | -- 13 | -- Example type specialization: 14 | -- 15 | -- @ 16 | -- distinct :: Query (Column a, Column b) -> Query (Column a, Column b) 17 | -- @ 18 | -- 19 | -- Assuming the @makeAdaptorAndInstance@ splice has been run for the product type @Foo@: 20 | -- 21 | -- @ 22 | -- distinct :: Query (Foo (Column a) (Column b) (Column c)) -> Query (Foo (Column a) (Column b) (Column c)) 23 | -- @ 24 | distinct :: D.Default Distinctspec columns columns => 25 | Query columns -> Query columns 26 | distinct = distinctExplicit D.def 27 | -------------------------------------------------------------------------------- /src/Opaleye/Internal/HaskellDB/Sql/Generate.hs: -------------------------------------------------------------------------------- 1 | -- Copyright : Daan Leijen (c) 1999, daan@cs.uu.nl 2 | -- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net 3 | -- License : BSD-style 4 | 5 | module Opaleye.Internal.HaskellDB.Sql.Generate (SqlGenerator(..)) where 6 | 7 | import Opaleye.Internal.HaskellDB.PrimQuery 8 | import Opaleye.Internal.HaskellDB.Sql 9 | 10 | import qualified Data.List.NonEmpty as NEL 11 | 12 | data SqlGenerator = SqlGenerator 13 | { 14 | sqlUpdate :: SqlTable -> [PrimExpr] -> Assoc -> SqlUpdate, 15 | sqlDelete :: SqlTable -> [PrimExpr] -> SqlDelete, 16 | sqlInsert :: SqlTable -> [Attribute] -> NEL.NonEmpty [PrimExpr] -> Maybe OnConflict -> SqlInsert, 17 | sqlExpr :: PrimExpr -> SqlExpr, 18 | sqlLiteral :: Literal -> String, 19 | -- | Turn a string into a quoted string. Quote characters 20 | -- and any escaping are handled by this function. 21 | sqlQuote :: String -> String 22 | } 23 | -------------------------------------------------------------------------------- /src/Opaleye/Internal/Lateral.hs: -------------------------------------------------------------------------------- 1 | module Opaleye.Internal.Lateral 2 | ( lateral 3 | , viaLateral 4 | , laterally 5 | , bilaterally 6 | , bind 7 | , arrowApply 8 | ) 9 | where 10 | 11 | import Opaleye.Internal.QueryArr 12 | 13 | -- | Lifts operations like 'Opaleye.Aggregate.aggregate', 14 | -- 'Opaleye.Order.orderBy' and 'Opaleye.Order.limit', which are restricted to 15 | -- 'Select' normally, to operate on 'SelectArr's taking arbitrary inputs. 16 | laterally :: (Select a -> Select b) -> SelectArr i a -> SelectArr i b 17 | laterally f as = lateral (\i -> f (viaLateral as i)) 18 | 19 | 20 | -- | Lifts operations like 'Opaleye.Binary.union', 'Opaleye.Binary.intersect' 21 | -- and 'Opaleye.Binary.except', which are restricted to 'Select' normally, to 22 | -- operate on 'SelectArr's taking arbitrary inputs. 23 | bilaterally :: (Select a -> Select b -> Select c) 24 | -> SelectArr i a -> SelectArr i b -> SelectArr i c 25 | bilaterally f as bs = lateral (\i -> f (viaLateral as i) (viaLateral bs i)) 26 | -------------------------------------------------------------------------------- /opaleye-sqlite/src/Opaleye/SQLite/Internal/HaskellDB/Sql/Generate.hs: -------------------------------------------------------------------------------- 1 | -- Copyright : Daan Leijen (c) 1999, daan@cs.uu.nl 2 | -- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net 3 | -- License : BSD-style 4 | 5 | module Opaleye.SQLite.Internal.HaskellDB.Sql.Generate (SqlGenerator(..)) where 6 | 7 | import Opaleye.SQLite.Internal.HaskellDB.PrimQuery 8 | import Opaleye.SQLite.Internal.HaskellDB.Sql 9 | 10 | import qualified Data.List.NonEmpty as NEL 11 | 12 | data SqlGenerator = SqlGenerator 13 | { 14 | sqlUpdate :: TableName -> [PrimExpr] -> Assoc -> SqlUpdate, 15 | sqlDelete :: TableName -> [PrimExpr] -> SqlDelete, 16 | sqlInsert :: TableName -> [Attribute] -> NEL.NonEmpty [PrimExpr] -> SqlInsert, 17 | sqlExpr :: PrimExpr -> SqlExpr, 18 | sqlLiteral :: Literal -> String, 19 | -- | Turn a string into a quoted string. Quote characters 20 | -- and any escaping are handled by this function. 21 | sqlQuote :: String -> String 22 | } 23 | -------------------------------------------------------------------------------- /opaleye-sqlite/src/Opaleye/SQLite/SqlTypes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | 3 | module Opaleye.SQLite.SqlTypes (module Opaleye.SQLite.SqlTypes) where 4 | 5 | import Opaleye.SQLite.Internal.Column (Column) 6 | import qualified Opaleye.SQLite.PGTypes as PT 7 | 8 | import qualified Data.Text as SText 9 | import qualified Data.Text.Lazy as LText 10 | 11 | -- These probably don't correspond very well to SQLite types yet. 12 | -- Work in progress. 13 | type SqlBool = PT.PGBool 14 | type SqlDate = PT.PGDate 15 | type SqlReal = PT.PGFloat8 16 | type SqlText = PT.PGText 17 | type SqlInt = PT.PGInt4 18 | 19 | sqlString :: String -> Column SqlText 20 | sqlString = PT.pgString 21 | 22 | sqlStrictText :: SText.Text -> Column SqlText 23 | sqlStrictText = PT.pgStrictText 24 | 25 | sqlLazyText :: LText.Text -> Column SqlText 26 | sqlLazyText = PT.pgLazyText 27 | 28 | sqlInt :: Int -> Column SqlInt 29 | sqlInt = PT.pgInt4 30 | 31 | sqlReal :: Double -> Column SqlReal 32 | sqlReal = PT.pgDouble 33 | 34 | sqlBool :: Bool -> Column SqlBool 35 | sqlBool = PT.pgBool 36 | -------------------------------------------------------------------------------- /src/Opaleye/Internal/Rebind.hs: -------------------------------------------------------------------------------- 1 | module Opaleye.Internal.Rebind where 2 | 3 | import Data.Profunctor.Product.Default (Default, def) 4 | import Opaleye.Internal.Unpackspec (Unpackspec, runUnpackspec) 5 | import Opaleye.Internal.QueryArr (selectArr, SelectArr) 6 | import qualified Opaleye.Internal.PackMap as PM 7 | import qualified Opaleye.Internal.PrimQuery as PQ 8 | import qualified Opaleye.Internal.Tag as Tag 9 | 10 | rebind :: Default Unpackspec a a => SelectArr a a 11 | rebind = rebindExplicit def 12 | 13 | rebindExplicit :: Unpackspec a b -> SelectArr a b 14 | rebindExplicit = rebindExplicitPrefix "rebind" 15 | 16 | rebindExplicitPrefix :: String -> Unpackspec a b -> SelectArr a b 17 | rebindExplicitPrefix prefix u = selectArr $ do 18 | tag <- Tag.fresh 19 | pure $ \a -> 20 | let (b, bindings) = PM.run (runUnpackspec u (PM.extractAttr prefix tag) a) 21 | in (b, PQ.aRebind bindings) 22 | 23 | rebindExplicitPrefixNoStar :: String -> Unpackspec a b -> SelectArr a b 24 | rebindExplicitPrefixNoStar prefix u = selectArr $ do 25 | tag <- Tag.fresh 26 | pure $ \a -> 27 | let (b, bindings) = PM.run (runUnpackspec u (PM.extractAttr prefix tag) a) 28 | in (b, PQ.aRebindNoStar bindings) 29 | -------------------------------------------------------------------------------- /src/Opaleye/Internal/Locking.hs: -------------------------------------------------------------------------------- 1 | -- | Support for Postgres @SELECT@ locking clauses. 2 | -- 3 | -- This functionality is new. If you use it then please [open an 4 | -- issue on 5 | -- GitHub](https://github.com/tomjaguarpaw/haskell-opaleye/issues/new) 6 | -- and let us know how it went, whether that is well or badly. 7 | -- 8 | -- Not all Postgres locking clauses are supported. If you need 9 | -- another form of locking clause then please [open an issue on 10 | -- GitHub](https://github.com/tomjaguarpaw/haskell-opaleye/issues/new). 11 | 12 | module Opaleye.Internal.Locking where 13 | 14 | import qualified Opaleye.Internal.QueryArr as Q 15 | import qualified Opaleye.Internal.PrimQuery as PQ 16 | 17 | -- | Adds a @FOR UPDATE@ clause to the 'Q.Select'. 18 | -- 19 | -- Postgres has strong restrictions regarding the @SELECT@ clauses to 20 | -- which a @FOR UPDATE@ can be added. Opaleye makes no attempt to 21 | -- enforce those restrictions through its type system so it's very 22 | -- easy to create queries that fail at run time using this operation. 23 | forUpdate :: Q.Select a -> Q.Select a 24 | forUpdate s = Q.productQueryArr $ do 25 | (a, query) <- Q.runSimpleSelect s 26 | pure (a, PQ.ForUpdate query) 27 | -------------------------------------------------------------------------------- /opaleye-sqlite/src/Opaleye/SQLite/Values.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | module Opaleye.SQLite.Values where 4 | 5 | import qualified Opaleye.SQLite.Internal.QueryArr as Q 6 | import Opaleye.SQLite.QueryArr (Query) 7 | import Opaleye.SQLite.Internal.Values as V 8 | import qualified Opaleye.SQLite.Internal.Unpackspec as U 9 | 10 | import Data.Profunctor.Product.Default (Default, def) 11 | 12 | -- | Example type specialization: 13 | -- 14 | -- @ 15 | -- values :: [(Column a, Column b)] -> Query (Column a, Column b) 16 | -- @ 17 | -- 18 | -- Assuming the @makeAdaptorAndInstance@ splice has been run for the 19 | -- product type @Foo@: 20 | -- 21 | -- @ 22 | -- queryTable :: [Foo (Column a) (Column b) (Column c)] -> Query (Foo (Column a) (Column b) (Column c)) 23 | -- @ 24 | values :: (Default V.Valuesspec columns columns, 25 | Default U.Unpackspec columns columns) => 26 | [columns] -> Q.Query columns 27 | values = valuesExplicit def def 28 | 29 | valuesExplicit :: U.Unpackspec columns columns' 30 | -> V.Valuesspec columns columns' 31 | -> [columns] -> Query columns' 32 | valuesExplicit unpack valuesspec columns = 33 | Q.simpleQueryArr (V.valuesU unpack valuesspec columns) 34 | -------------------------------------------------------------------------------- /Test/Opaleye/Test/TraverseA.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | 4 | module Opaleye.Test.TraverseA where 5 | 6 | import Control.Arrow 7 | 8 | -- I first learned this from Alexis King at 9 | -- https://github.com/tomjaguarpaw/Arrows2/issues/3#issuecomment-561973678 10 | 11 | data Traversal a r b 12 | = Done b 13 | | Yield a !(r -> Traversal a r b) 14 | 15 | instance Functor (Traversal a r) where 16 | fmap f = \case 17 | Done x -> Done (f x) 18 | Yield v k -> Yield v (fmap f . k) 19 | 20 | instance Applicative (Traversal a r) where 21 | pure = Done 22 | tf <*> tx = case tf of 23 | Done f -> fmap f tx 24 | Yield v k -> Yield v ((<*> tx) . k) 25 | 26 | traversal :: Traversable t => t a -> Traversal a b (t b) 27 | traversal = traverse (flip Yield Done) 28 | 29 | traverseA :: (ArrowChoice arr, Traversable t) 30 | => arr (e, a) b -> arr (e, t a) (t b) 31 | traverseA f = second (arr traversal) >>> go where 32 | go = proc (e, as) -> case as of 33 | Done bs -> returnA -< bs 34 | Yield a k -> do 35 | b <- f -< (e, a) 36 | go -< (e, k b) 37 | 38 | traverseA1 :: (ArrowChoice arr, Traversable t) 39 | => arr a b -> arr (t a) (t b) 40 | traverseA1 f = arr (\x -> ((), x)) >>> traverseA (arr snd >>> f) 41 | -------------------------------------------------------------------------------- /opaleye-sqlite/src/Opaleye/SQLite.hs: -------------------------------------------------------------------------------- 1 | module Opaleye.SQLite ( module Opaleye.SQLite.Aggregate 2 | , module Opaleye.SQLite.Binary 3 | , module Opaleye.SQLite.Column 4 | , module Opaleye.SQLite.Constant 5 | , module Opaleye.SQLite.Distinct 6 | , module Opaleye.SQLite.Join 7 | , module Opaleye.SQLite.Manipulation 8 | , module Opaleye.SQLite.Operators 9 | , module Opaleye.SQLite.Order 10 | , module Opaleye.SQLite.PGTypes 11 | , module Opaleye.SQLite.QueryArr 12 | , module Opaleye.SQLite.RunQuery 13 | , module Opaleye.SQLite.Sql 14 | , module Opaleye.SQLite.Table 15 | , module Opaleye.SQLite.Values 16 | ) where 17 | 18 | import Opaleye.SQLite.Aggregate 19 | import Opaleye.SQLite.Binary 20 | import Opaleye.SQLite.Column 21 | import Opaleye.SQLite.Constant 22 | import Opaleye.SQLite.Distinct 23 | import Opaleye.SQLite.Join 24 | import Opaleye.SQLite.Manipulation 25 | import Opaleye.SQLite.Operators 26 | import Opaleye.SQLite.Order 27 | import Opaleye.SQLite.PGTypes 28 | import Opaleye.SQLite.QueryArr 29 | import Opaleye.SQLite.RunQuery 30 | import Opaleye.SQLite.Sql 31 | import Opaleye.SQLite.Table 32 | import Opaleye.SQLite.Values 33 | -------------------------------------------------------------------------------- /src/Opaleye/Values.hs: -------------------------------------------------------------------------------- 1 | module Opaleye.Values( 2 | values, 3 | -- * Explicit versions 4 | valuesExplicit, 5 | -- * Adaptors 6 | V.Valuesspec, 7 | V.valuesspecField, 8 | ) where 9 | 10 | import qualified Opaleye.Internal.Values as V 11 | import qualified Opaleye.Select as S 12 | 13 | import qualified Data.List.NonEmpty as NEL 14 | import Data.Profunctor.Product.Default (Default, def) 15 | 16 | -- | 'values' implements Postgres's @VALUES@ construct and allows you 17 | -- to create a @SELECT@ that consists of the given rows. 18 | -- 19 | -- Example type specialization: 20 | -- 21 | -- @ 22 | -- values :: [(Field a, Field b)] -> Select (Field a, Field b) 23 | -- @ 24 | -- 25 | -- Assuming the @makeAdaptorAndInstanceInferrable@ splice has been run for the 26 | -- product type @Foo@: 27 | -- 28 | -- @ 29 | -- values :: [Foo (Field a) (Field b) (Field c)] -> S.Select (Foo (Field a) (Field b) (Field c)) 30 | -- @ 31 | values :: Default V.Valuesspec fields fields 32 | => [fields] -> S.Select fields 33 | values = valuesExplicit def 34 | 35 | valuesExplicit :: V.Valuesspec fields fields' 36 | -> [fields] -> S.Select fields' 37 | valuesExplicit (V.ValuesspecSafe nullspec rowspec) fields = case NEL.nonEmpty fields of 38 | Nothing -> V.emptySelectExplicit nullspec 39 | Just rows -> V.nonEmptyValues rowspec rows 40 | -------------------------------------------------------------------------------- /opaleye-sqlite/src/Opaleye/SQLite/Internal/Optimize.hs: -------------------------------------------------------------------------------- 1 | module Opaleye.SQLite.Internal.Optimize where 2 | 3 | import Prelude hiding (product) 4 | 5 | import qualified Opaleye.SQLite.Internal.PrimQuery as PQ 6 | 7 | import qualified Data.List.NonEmpty as NEL 8 | 9 | optimize :: PQ.PrimQuery -> PQ.PrimQuery 10 | optimize = mergeProduct . removeUnit 11 | 12 | removeUnit :: PQ.PrimQuery -> PQ.PrimQuery 13 | removeUnit = PQ.foldPrimQuery (PQ.Unit, PQ.BaseTable, product, PQ.Aggregate, 14 | PQ.Order, PQ.Limit, PQ.Join, PQ.Values, 15 | PQ.Binary) 16 | where product pqs pes = PQ.Product pqs' pes 17 | where pqs' = case NEL.filter (not . PQ.isUnit) pqs of 18 | [] -> return PQ.Unit 19 | xs -> NEL.fromList xs 20 | 21 | mergeProduct :: PQ.PrimQuery -> PQ.PrimQuery 22 | mergeProduct = PQ.foldPrimQuery (PQ.Unit, PQ.BaseTable, product, PQ.Aggregate, 23 | PQ.Order, PQ.Limit, PQ.Join, PQ.Values, 24 | PQ.Binary) 25 | where product pqs pes = PQ.Product pqs' (pes ++ pes') 26 | where pqs' = pqs >>= queries 27 | queries (PQ.Product qs _) = qs 28 | queries q = return q 29 | pes' = NEL.toList pqs >>= conds 30 | conds (PQ.Product _ cs) = cs 31 | conds _ = [] 32 | -------------------------------------------------------------------------------- /opaleye-sqlite/src/Opaleye/SQLite/Internal/PGTypes.hs: -------------------------------------------------------------------------------- 1 | module Opaleye.SQLite.Internal.PGTypes where 2 | 3 | import Opaleye.SQLite.Internal.Column (Column(Column)) 4 | import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as HPQ 5 | 6 | import qualified Data.Text as SText 7 | import qualified Data.Text.Encoding as STextEncoding 8 | import qualified Data.Text.Lazy as LText 9 | import qualified Data.Text.Lazy.Encoding as LTextEncoding 10 | import qualified Data.ByteString as SByteString 11 | import qualified Data.ByteString.Lazy as LByteString 12 | import qualified Data.Time as Time 13 | import qualified Data.Time.Locale.Compat as Locale 14 | 15 | -- FIXME: SQLite requires temporal types to have the type "TEXT" which 16 | -- may cause problems elsewhere. 17 | unsafePgFormatTime :: Time.FormatTime t => HPQ.Name -> String -> t -> Column c 18 | unsafePgFormatTime _typeName formatString = castToType "TEXT" . format 19 | where format = Time.formatTime Locale.defaultTimeLocale formatString 20 | 21 | literalColumn :: HPQ.Literal -> Column a 22 | literalColumn = Column . HPQ.ConstExpr 23 | 24 | castToType :: HPQ.Name -> String -> Column c 25 | castToType typeName = 26 | Column . HPQ.CastExpr typeName . HPQ.ConstExpr . HPQ.OtherLit 27 | 28 | strictDecodeUtf8 :: SByteString.ByteString -> String 29 | strictDecodeUtf8 = SText.unpack . STextEncoding.decodeUtf8 30 | 31 | lazyDecodeUtf8 :: LByteString.ByteString -> String 32 | lazyDecodeUtf8 = LText.unpack . LTextEncoding.decodeUtf8 33 | -------------------------------------------------------------------------------- /opaleye-sqlite/src/Opaleye/SQLite/Internal/Join.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} 2 | 3 | module Opaleye.SQLite.Internal.Join where 4 | 5 | import qualified Opaleye.SQLite.Internal.Tag as T 6 | import qualified Opaleye.SQLite.Internal.PackMap as PM 7 | import Opaleye.SQLite.Internal.Column (Column, Nullable) 8 | import qualified Opaleye.SQLite.Column as C 9 | 10 | import Data.Profunctor (Profunctor, dimap) 11 | import Data.Profunctor.Product (ProductProfunctor, empty, (***!)) 12 | import qualified Data.Profunctor.Product.Default as D 13 | 14 | import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as HPQ 15 | 16 | newtype NullMaker a b = NullMaker (a -> b) 17 | 18 | toNullable :: NullMaker a b -> a -> b 19 | toNullable (NullMaker f) = f 20 | 21 | extractLeftJoinFields :: Int -> T.Tag -> HPQ.PrimExpr 22 | -> PM.PM [(HPQ.Symbol, HPQ.PrimExpr)] HPQ.PrimExpr 23 | extractLeftJoinFields n = PM.extractAttr ("result" ++ show n ++ "_") 24 | 25 | instance D.Default NullMaker (Column a) (Column (Nullable a)) where 26 | def = NullMaker C.unsafeCoerceColumn 27 | 28 | instance D.Default NullMaker (Column (Nullable a)) (Column (Nullable a)) where 29 | def = NullMaker C.unsafeCoerceColumn 30 | 31 | -- { Boilerplate instances 32 | 33 | instance Profunctor NullMaker where 34 | dimap f g (NullMaker h) = NullMaker (dimap f g h) 35 | 36 | instance ProductProfunctor NullMaker where 37 | empty = NullMaker empty 38 | NullMaker f ***! NullMaker f' = NullMaker (f ***! f') 39 | 40 | -- 41 | -------------------------------------------------------------------------------- /src/Opaleye/Column.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-duplicate-exports #-} 2 | -- | Functions for working directly with 'Column's. 3 | -- 4 | -- Please note that numeric 'Column' types are instances of 'Num', so 5 | -- you can use '*', '/', '+', '-' on them. 6 | 7 | module Opaleye.Column {-# DEPRECATED "Use \"Opaleye.Field\" instead. Will be removed in version 0.11." #-} 8 | (-- * 'Column' 9 | Column, 10 | -- * Working with @NULL@ 11 | Nullable, 12 | null, 13 | isNull, 14 | -- * Unsafe operations 15 | unsafeCast, 16 | unsafeCoerceColumn, 17 | unsafeCompositeField, 18 | -- * Entire module 19 | module Opaleye.Column) where 20 | 21 | import Opaleye.Internal.Column (Column, Nullable, unsafeCoerceColumn, 22 | unsafeCast, unsafeCompositeField) 23 | import qualified Opaleye.Field as F 24 | import qualified Opaleye.Internal.Column as C 25 | import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ 26 | import qualified Opaleye.Internal.PGTypesExternal as T 27 | import Prelude hiding (null) 28 | 29 | -- | A NULL of any type 30 | null :: Column (Nullable a) 31 | null = F.null 32 | 33 | -- | @TRUE@ if the value of the column is @NULL@, @FALSE@ otherwise. 34 | isNull :: Column (Nullable a) -> Column T.PGBool 35 | isNull = C.unOp HPQ.OpIsNull 36 | 37 | joinNullable :: Column (Nullable (Nullable a)) -> Column (Nullable a) 38 | joinNullable = unsafeCoerceColumn 39 | -------------------------------------------------------------------------------- /Doc/Design/DESIGN.md: -------------------------------------------------------------------------------- 1 | # The design of Opaleye 2 | 3 | *DRAFT!* 4 | 5 | ## Problems with SQL 6 | 7 | It's very heavyweight to abstract over anything in SQL. You can 8 | perhaps use temporary tables and views and you can perhaps use named 9 | fields as "let bindings" but it's all very clumsy. This means it's 10 | very hard to reuse code. 11 | 12 | It's awkward to generate composable SQL strings from another language 13 | because you end up needing things like unique names. 14 | 15 | Although you can generate SQL strings at runtime you can't know at 16 | compile time that your SQL is syntactically correct. 17 | 18 | Every subselect has to be given a name. Typically this is redundant. 19 | 20 | ### SQL language inconsistencies 21 | 22 | This orders by the second field 23 | 24 | SELECT * from table ORDER BY 2; 25 | 26 | whereas this orders by the value of 1 + 1, i.e. 2. 27 | 28 | SELECT * from table ORDER BY 1 + 1; 29 | 30 | ## `Select` and `Field` 31 | 32 | The most important types in Opaleye are `Select` and `Field`. A 33 | `Select` represents the result of running a database `SELECT`, i.e. a 34 | collection of rows with particular field types. The field types are 35 | specified in the type parameter to `Select` as a collection of 36 | `Field`s. Each `Field` also has a type parameter reflecting its SQL 37 | type. For example a `Select (Field PGInt4, Field PGText, Field 38 | PGBool)` is the type of a database `SELECT` which has three fields, of 39 | types `int4`, `text` and `bool`. 40 | 41 | A `Select` is a collection of rows and therefore if we have two of them 42 | we can form their Cartesian product. This corresponds exactly to 43 | Haskell's `Applicative` product on lists. 44 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: ci 2 | on: 3 | push: 4 | pull_request: 5 | schedule: 6 | - cron: '0 3 * * 6' # 3am Saturday 7 | workflow_dispatch: 8 | jobs: 9 | test: 10 | runs-on: ${{ matrix.os }} 11 | 12 | strategy: 13 | fail-fast: false 14 | matrix: 15 | os: [ubuntu-latest] 16 | ghc: ['9.12', '9.10', '9.8', '9.6', '9.4', '9.2', '9.0', '8.10', '8.8'] 17 | 18 | services: 19 | postgres: 20 | image: postgres:11 21 | env: 22 | POSTGRES_DB: postgres 23 | POSTGRES_PASSWORD: postgres 24 | POSTGRES_USER: postgres 25 | ports: 26 | - 5432:5432 27 | # Set health checks to wait until postgres has started 28 | options: >- 29 | --health-cmd pg_isready 30 | --health-interval 10s 31 | --health-timeout 5s 32 | --health-retries 5 33 | 34 | steps: 35 | - run: git config --global core.autocrlf false 36 | - uses: actions/checkout@v2 37 | - uses: haskell-actions/setup@v2.8 38 | id: setup-haskell 39 | with: 40 | ghc-version: ${{ matrix.ghc }} 41 | - run: cabal v2-freeze --enable-tests 42 | - uses: actions/cache@v4 43 | with: 44 | path: ${{ steps.setup-haskell.outputs.cabal-store }} 45 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} 46 | restore-keys: ${{ runner.os }}-${{ matrix.ghc }}- 47 | - uses: tomjaguarpaw/neil@tag-ac7e72e 48 | with: 49 | github-user: tomjaguarpaw 50 | branch: tag-2e76361 51 | env: 52 | POSTGRES_CONNSTRING: "user='postgres' dbname='postgres' password='postgres' host='localhost' port='5432'" 53 | -------------------------------------------------------------------------------- /Test/Connection.hs: -------------------------------------------------------------------------------- 1 | module Connection where 2 | 3 | import Control.Concurrent (threadDelay) 4 | import Control.Exception (tryJust) 5 | import Data.IORef (IORef, readIORef, writeIORef, newIORef) 6 | import Data.ByteString (ByteString) 7 | import qualified Database.PostgreSQL.Simple as PGS 8 | import GHC.IO.Exception (ioe_description) 9 | 10 | type Connection = (IORef PGS.Connection, ByteString) 11 | 12 | withConnection :: Connection -> (PGS.Connection -> IO r) -> IO (Either () r) 13 | withConnection (conn, connectString) k = do 14 | conn' <- readIORef conn 15 | 16 | er <- tryJust (\e -> if ioe_description e == "failed to fetch file descriptor" 17 | then Just e 18 | else Nothing) 19 | (k conn') 20 | 21 | case er of 22 | Right r -> pure (Right r) 23 | Left _ -> do 24 | PGS.close conn' 25 | -- If we reconnect immediately then the connection fails with 26 | -- "Exception: libpq: failed (FATAL: the database system is in 27 | -- recovery mode". We could try to handle that, but it's easier 28 | -- just to delay for ten seconds, which seems to be enough time 29 | -- for the database to recover. 30 | threadDelay (10 * 1000 * 1000) -- microseconds 31 | conn'new <- PGS.connectPostgreSQL connectString 32 | writeIORef conn conn'new 33 | return (Left ()) 34 | 35 | connectPostgreSQL :: ByteString -> IO Connection 36 | connectPostgreSQL connectString = do 37 | conn' <- PGS.connectPostgreSQL connectString 38 | conn <- newIORef conn' 39 | pure (conn, connectString) 40 | 41 | close :: Connection -> IO () 42 | close (conn, _) = do 43 | conn' <- readIORef conn 44 | PGS.close conn' 45 | -------------------------------------------------------------------------------- /src/Opaleye/Internal/JSONBuildObjectFields.hs: -------------------------------------------------------------------------------- 1 | module Opaleye.Internal.JSONBuildObjectFields 2 | ( JSONBuildObjectFields, 3 | jsonBuildObjectField, 4 | jsonBuildObject, 5 | ) 6 | where 7 | 8 | import Opaleye.Internal.Column (Field_(Column)) 9 | import Opaleye.Field (Field) 10 | import Opaleye.Internal.HaskellDB.PrimQuery (Literal (StringLit), PrimExpr (ConstExpr, FunExpr)) 11 | import Opaleye.Internal.PGTypesExternal (SqlJson) 12 | 13 | -- | Combine @JSONBuildObjectFields@ using @('<>')@ 14 | newtype JSONBuildObjectFields 15 | = JSONBuildObjectFields [(String, PrimExpr)] 16 | 17 | instance Semigroup JSONBuildObjectFields where 18 | (<>) 19 | (JSONBuildObjectFields a) 20 | (JSONBuildObjectFields b) = 21 | JSONBuildObjectFields $ a <> b 22 | 23 | instance Monoid JSONBuildObjectFields where 24 | mempty = JSONBuildObjectFields mempty 25 | mappend = (<>) 26 | 27 | -- | Given a label and a field, generates a pair for use with @jsonBuildObject@ 28 | jsonBuildObjectField :: String 29 | -- ^ Field name 30 | -> Field_ n a 31 | -- ^ Field value 32 | -> JSONBuildObjectFields 33 | jsonBuildObjectField f (Column v) = JSONBuildObjectFields [(f, v)] 34 | 35 | -- | Create an 'SqlJson' object from a collection of fields. 36 | -- 37 | -- Note: This is implemented as a variadic function in postgres, and as such, is limited to 50 arguments, or 25 key-value pairs. 38 | jsonBuildObject :: JSONBuildObjectFields -> Field SqlJson 39 | jsonBuildObject (JSONBuildObjectFields jbofs) = Column $ FunExpr "json_build_object" args 40 | where 41 | args = concatMap mapLabelsToPrimExpr jbofs 42 | mapLabelsToPrimExpr (label, expr) = [ConstExpr $ StringLit label, expr] 43 | -------------------------------------------------------------------------------- /opaleye-sqlite/src/Opaleye/SQLite/Internal/Distinct.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | 3 | module Opaleye.SQLite.Internal.Distinct where 4 | 5 | import Opaleye.SQLite.QueryArr (Query) 6 | import Opaleye.SQLite.Column (Column) 7 | import Opaleye.SQLite.Aggregate (Aggregator, groupBy, aggregate) 8 | 9 | import Control.Applicative (Applicative, pure, (<*>)) 10 | 11 | import qualified Data.Profunctor as P 12 | import qualified Data.Profunctor.Product as PP 13 | import Data.Profunctor.Product.Default (Default, def) 14 | 15 | -- We implement distinct simply by grouping by all columns. We could 16 | -- instead implement it as SQL's DISTINCT but implementing it in terms 17 | -- of something else that we already have is easier at this point. 18 | 19 | distinctExplicit :: Distinctspec columns columns' 20 | -> Query columns -> Query columns' 21 | distinctExplicit (Distinctspec agg) = aggregate agg 22 | 23 | newtype Distinctspec a b = Distinctspec (Aggregator a b) 24 | 25 | instance Default Distinctspec (Column a) (Column a) where 26 | def = Distinctspec groupBy 27 | 28 | -- { Boilerplate instances 29 | 30 | instance Functor (Distinctspec a) where 31 | fmap f (Distinctspec g) = Distinctspec (fmap f g) 32 | 33 | instance Applicative (Distinctspec a) where 34 | pure = Distinctspec . pure 35 | Distinctspec f <*> Distinctspec x = Distinctspec (f <*> x) 36 | 37 | instance P.Profunctor Distinctspec where 38 | dimap f g (Distinctspec q) = Distinctspec (P.dimap f g q) 39 | 40 | instance PP.ProductProfunctor Distinctspec where 41 | empty = PP.defaultEmpty 42 | (***!) = PP.defaultProfunctorProduct 43 | 44 | instance PP.SumProfunctor Distinctspec where 45 | Distinctspec x1 +++! Distinctspec x2 = Distinctspec (x1 PP.+++! x2) 46 | 47 | -- } 48 | -------------------------------------------------------------------------------- /src/Opaleye/Distinct.hs: -------------------------------------------------------------------------------- 1 | module Opaleye.Distinct (distinct, 2 | distinctOn, 3 | distinctOnBy, 4 | -- * Explicit versions 5 | distinctExplicit, 6 | -- * Adaptors 7 | Distinctspec, 8 | distinctspecField, 9 | distinctspecMaybeFields, 10 | -- * Deprecated 11 | distinctOnCorrect, 12 | distinctOnByCorrect, 13 | ) 14 | where 15 | 16 | import Opaleye.Select (Select) 17 | import Opaleye.Internal.Distinct 18 | import Opaleye.Order 19 | 20 | import qualified Data.Profunctor.Product.Default as D 21 | import Opaleye.Internal.Unpackspec (Unpackspec) 22 | 23 | -- | Remove duplicate rows from the 'Select'. 24 | -- 25 | -- Example type specialization: 26 | -- 27 | -- @ 28 | -- distinct :: Select (Field a, Field b) -> Select (Field a, Field b) 29 | -- @ 30 | -- 31 | -- Assuming the @makeAdaptorAndInstanceInferrable@ splice has been run for the product type @Foo@: 32 | -- 33 | -- @ 34 | -- distinct :: Select (Foo (Field a) (Field b) (Field c)) -> Select (Foo (Field a) (Field b) (Field c)) 35 | -- @ 36 | -- 37 | -- If you want to run 'distinct' on 'Select.SelectArr's you should 38 | -- apply 'Opaleye.Lateral.laterally' to it: 39 | -- 40 | -- @ 41 | -- 'Opaleye.Lateral.laterally' 'distinct' :: 'Data.Profunctor.Product.Default' 'Distinctspec' fields fields => 'Opaleye.Select.SelectArr' i fields -> 'Opaleye.Select.SelectArr' i fields 42 | -- @ 43 | distinct :: D.Default Distinctspec fields fields => 44 | D.Default Unpackspec fields fields => 45 | Select fields -> Select fields 46 | distinct = distinctExplicit D.def D.def 47 | -------------------------------------------------------------------------------- /opaleye-sqlite/src/Opaleye/SQLite/Binary.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-} 2 | 3 | module Opaleye.SQLite.Binary where 4 | 5 | import Opaleye.SQLite.QueryArr (Query) 6 | import qualified Opaleye.SQLite.Internal.QueryArr as Q 7 | import qualified Opaleye.SQLite.Internal.Binary as B 8 | import qualified Opaleye.SQLite.Internal.Tag as T 9 | import qualified Opaleye.SQLite.Internal.PrimQuery as PQ 10 | import qualified Opaleye.SQLite.Internal.PackMap as PM 11 | 12 | import Data.Profunctor.Product.Default (Default, def) 13 | 14 | -- | Example type specialization: 15 | -- 16 | -- @ 17 | -- unionAll :: Query (Column a, Column b) 18 | -- -> Query (Column a, Column b) 19 | -- -> Query (Column a, Column b) 20 | -- @ 21 | -- 22 | -- Assuming the @makeAdaptorAndInstance@ splice has been run for the product type @Foo@: 23 | -- 24 | -- @ 25 | -- unionAll :: Query (Foo (Column a) (Column b) (Column c)) 26 | -- -> Query (Foo (Column a) (Column b) (Column c)) 27 | -- -> Query (Foo (Column a) (Column b) (Column c)) 28 | -- @ 29 | unionAll :: Default B.Binaryspec columns columns => 30 | Query columns -> Query columns -> Query columns 31 | unionAll = unionAllExplicit def 32 | 33 | unionAllExplicit :: B.Binaryspec columns columns' 34 | -> Query columns -> Query columns -> Query columns' 35 | unionAllExplicit binaryspec q1 q2 = Q.simpleQueryArr q where 36 | q ((), startTag) = (newColumns, newPrimQuery, T.next endTag) 37 | where (columns1, primQuery1, midTag) = Q.runSimpleQueryArr q1 ((), startTag) 38 | (columns2, primQuery2, endTag) = Q.runSimpleQueryArr q2 ((), midTag) 39 | 40 | (newColumns, pes) = 41 | PM.run (B.runBinaryspec binaryspec (B.extractBinaryFields endTag) 42 | (columns1, columns2)) 43 | 44 | newPrimQuery = PQ.Binary PQ.UnionAll pes (primQuery1, primQuery2) 45 | -------------------------------------------------------------------------------- /src/Opaleye/Sql.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Opaleye.Sql ( 4 | -- * Showing SQL 5 | showSql, 6 | showSqlUnopt, 7 | -- * Explicit versions 8 | showSqlExplicit, 9 | showSqlUnoptExplicit, 10 | ) where 11 | 12 | import qualified Opaleye.Internal.Unpackspec as U 13 | import qualified Opaleye.Internal.Print as Pr 14 | import qualified Opaleye.Internal.Optimize as Op 15 | import Opaleye.Internal.Helpers ((.:), atSameType) 16 | import qualified Opaleye.Internal.QueryArr as Q 17 | 18 | import qualified Opaleye.Select as S 19 | 20 | import qualified Data.Profunctor.Product.Default as D 21 | 22 | -- | Show the SQL query string generated from the 'S.Select'. 23 | -- 24 | -- When 'Nothing' is returned it means that the 'S.Select' returns zero 25 | -- rows. 26 | -- 27 | -- Example type specialization: 28 | -- 29 | -- @ 30 | -- showSql :: Select (Field a, Field b) -> Maybe String 31 | -- @ 32 | -- 33 | -- Assuming the @makeAdaptorAndInstanceInferrable@ splice has been run for the 34 | -- product type @Foo@: 35 | -- 36 | -- @ 37 | -- showSql :: Select (Foo (Field a) (Field b) (Field c)) -> Maybe String 38 | -- @ 39 | showSql :: D.Default U.Unpackspec fields fields 40 | => S.Select fields 41 | -> Maybe String 42 | showSql = showSqlExplicit (atSameType D.def) 43 | 44 | -- | Show the unoptimized SQL query string generated from the 'S.Select'. 45 | showSqlUnopt :: D.Default U.Unpackspec fields fields 46 | => S.Select fields 47 | -> Maybe String 48 | showSqlUnopt = showSqlUnoptExplicit (atSameType D.def) 49 | 50 | showSqlExplicit :: U.Unpackspec fields b -> S.Select fields -> Maybe String 51 | showSqlExplicit = Pr.formatAndShowSQL 52 | . (\(x, y, z) -> (x, Op.optimize y, z)) 53 | .: Q.runQueryArrUnpack 54 | 55 | showSqlUnoptExplicit :: U.Unpackspec fields b -> S.Select fields -> Maybe String 56 | showSqlUnoptExplicit = Pr.formatAndShowSQL .: Q.runQueryArrUnpack 57 | -------------------------------------------------------------------------------- /src/Opaleye/Adaptors.hs: -------------------------------------------------------------------------------- 1 | -- We have the following groups. Groups could be merged into one. 2 | -- 3 | -- - p (Column a) (Column a) 4 | -- Not SumProfunctor 5 | -- Not SqlType a 6 | -- - Binaryspec 7 | -- - IfPP 8 | -- 9 | -- - p (Column a) (Column a) 10 | -- Not SumProfunctor 11 | -- Is SqlType a 12 | -- - Valuesspec 13 | -- 14 | -- - p (Column a) (Column a) 15 | -- Is SumProfunctor 16 | -- Not SqlType a 17 | -- - Distinctspec 18 | -- - Unpackspec 19 | -- 20 | -- - p (Column a) b 21 | -- - EqPP 22 | -- 23 | -- - p a (Column b) 24 | -- Is SqlType b 25 | -- - Nullspec 26 | 27 | module Opaleye.Adaptors 28 | ( 29 | -- * Binaryspec 30 | Binaryspec, 31 | binaryspecField, 32 | binaryspecMaybeFields, 33 | -- * Distinctspec 34 | Distinctspec, 35 | distinctspecField, 36 | distinctspecMaybeFields, 37 | -- * EqPP 38 | EqPP, 39 | eqPPField, 40 | eqPPMaybeFields, 41 | -- * IfPP 42 | IfPP, 43 | ifPPField, 44 | ifPPMaybeFields, 45 | -- * FromFields 46 | FromFields, 47 | fromFieldsMaybeFields, 48 | -- * Nullspec 49 | Nullspec, 50 | nullspecField, 51 | nullspecMaybeFields, 52 | nullspecList, 53 | nullspecEitherLeft, 54 | nullspecEitherRight, 55 | -- * ToFields 56 | ToFields, 57 | toFieldsMaybeFields, 58 | -- * Unpackspec 59 | Unpackspec, 60 | unpackspecField, 61 | unpackspecMaybeFields, 62 | -- * Updater 63 | Updater, 64 | -- * Valuesspec 65 | Valuesspec, 66 | valuesspecField, 67 | valuesspecMaybeFields, 68 | -- * WithNulls 69 | WithNulls, 70 | ) 71 | where 72 | 73 | import Opaleye.Internal.Unpackspec 74 | import Opaleye.Internal.Binary 75 | import Opaleye.Internal.Manipulation 76 | import Opaleye.Internal.Operators 77 | import Opaleye.Internal.MaybeFields 78 | 79 | import Opaleye.Binary 80 | import Opaleye.Distinct 81 | import Opaleye.ToFields 82 | import Opaleye.MaybeFields 83 | import Opaleye.RunSelect 84 | import Opaleye.Values 85 | -------------------------------------------------------------------------------- /opaleye-sqlite/src/Opaleye/SQLite/Sql.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-} 2 | 3 | module Opaleye.SQLite.Sql where 4 | 5 | import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as HPQ 6 | 7 | import qualified Opaleye.SQLite.Internal.Unpackspec as U 8 | import qualified Opaleye.SQLite.Internal.Sql as Sql 9 | import qualified Opaleye.SQLite.Internal.Print as Pr 10 | import qualified Opaleye.SQLite.Internal.PrimQuery as PQ 11 | import qualified Opaleye.SQLite.Internal.Optimize as Op 12 | import Opaleye.SQLite.Internal.Helpers ((.:)) 13 | import qualified Opaleye.SQLite.Internal.QueryArr as Q 14 | import qualified Opaleye.SQLite.Internal.Tag as T 15 | 16 | import qualified Data.Profunctor.Product.Default as D 17 | 18 | -- | Example type specialization: 19 | -- 20 | -- @ 21 | -- showSqlForPostgres :: Query (Column a, Column b) -> String 22 | -- @ 23 | -- 24 | -- Assuming the @makeAdaptorAndInstance@ splice has been run for the 25 | -- product type @Foo@: 26 | -- 27 | -- @ 28 | -- showSqlForPostgres :: Query (Foo (Column a) (Column b) (Column c)) -> String 29 | -- @ 30 | showSqlForPostgres :: forall columns . D.Default U.Unpackspec columns columns => 31 | Q.Query columns -> String 32 | showSqlForPostgres = showSqlForPostgresExplicit (D.def :: U.Unpackspec columns columns) 33 | 34 | showSqlForPostgresUnopt :: forall columns . D.Default U.Unpackspec columns columns => 35 | Q.Query columns -> String 36 | showSqlForPostgresUnopt = showSqlForPostgresUnoptExplicit (D.def :: U.Unpackspec columns columns) 37 | 38 | showSqlForPostgresExplicit :: U.Unpackspec columns b -> Q.Query columns -> String 39 | showSqlForPostgresExplicit = formatAndShowSQL 40 | . (\(x, y, z) -> (x, Op.optimize y, z)) 41 | .: Q.runQueryArrUnpack 42 | 43 | showSqlForPostgresUnoptExplicit :: U.Unpackspec columns b -> Q.Query columns -> String 44 | showSqlForPostgresUnoptExplicit = formatAndShowSQL .: Q.runQueryArrUnpack 45 | 46 | formatAndShowSQL :: ([HPQ.PrimExpr], PQ.PrimQuery, T.Tag) -> String 47 | formatAndShowSQL = show . Pr.ppSql . Sql.sql 48 | -------------------------------------------------------------------------------- /opaleye-sqlite/src/Opaleye/SQLite/Table.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | module Opaleye.SQLite.Table (module Opaleye.SQLite.Table, 4 | View, 5 | Writer, 6 | Table(Table), 7 | TableProperties) where 8 | 9 | import Opaleye.SQLite.Internal.Column (Column(Column)) 10 | import qualified Opaleye.SQLite.Internal.QueryArr as Q 11 | import qualified Opaleye.SQLite.Internal.Table as T 12 | import Opaleye.SQLite.Internal.Table (View(View), Table, Writer, 13 | TableProperties) 14 | import qualified Opaleye.SQLite.Internal.TableMaker as TM 15 | import qualified Opaleye.SQLite.Internal.Tag as Tag 16 | 17 | import qualified Data.Profunctor.Product.Default as D 18 | 19 | import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as HPQ 20 | 21 | -- | Example type specialization: 22 | -- 23 | -- @ 24 | -- queryTable :: Table w (Column a, Column b) -> Query (Column a, Column b) 25 | -- @ 26 | -- 27 | -- Assuming the @makeAdaptorAndInstance@ splice has been run for the 28 | -- product type @Foo@: 29 | -- 30 | -- @ 31 | -- queryTable :: Table w (Foo (Column a) (Column b) (Column c)) -> Query (Foo (Column a) (Column b) (Column c)) 32 | -- @ 33 | queryTable :: D.Default TM.ColumnMaker columns columns => 34 | Table a columns -> Q.Query columns 35 | queryTable = queryTableExplicit D.def 36 | 37 | queryTableExplicit :: TM.ColumnMaker tablecolumns columns -> 38 | Table a tablecolumns -> Q.Query columns 39 | queryTableExplicit cm table = Q.simpleQueryArr f where 40 | f ((), t0) = (retwires, primQ, Tag.next t0) where 41 | (retwires, primQ) = T.queryTable cm table t0 42 | 43 | required :: String -> TableProperties (Column a) (Column a) 44 | required columnName = T.TableProperties 45 | (T.required columnName) 46 | (View (Column (HPQ.BaseTableAttrExpr columnName))) 47 | 48 | optional :: String -> TableProperties (Maybe (Column a)) (Column a) 49 | optional columnName = T.TableProperties 50 | (T.optional columnName) 51 | (View (Column (HPQ.BaseTableAttrExpr columnName))) 52 | -------------------------------------------------------------------------------- /opaleye-sqlite/src/Opaleye/SQLite/Internal/HaskellDB/Sql.hs: -------------------------------------------------------------------------------- 1 | -- Copyright : Daan Leijen (c) 1999, daan@cs.uu.nl 2 | -- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net 3 | -- License : BSD-style 4 | 5 | module Opaleye.SQLite.Internal.HaskellDB.Sql where 6 | 7 | 8 | import qualified Data.List.NonEmpty as NEL 9 | 10 | ----------------------------------------------------------- 11 | -- * SQL data type 12 | ----------------------------------------------------------- 13 | 14 | newtype SqlTable = SqlTable String deriving Show 15 | 16 | newtype SqlColumn = SqlColumn String deriving Show 17 | 18 | -- | A valid SQL name for a parameter. 19 | type SqlName = String 20 | 21 | data SqlOrderNulls = SqlNullsFirst | SqlNullsLast 22 | deriving Show 23 | 24 | data SqlOrderDirection = SqlAsc | SqlDesc 25 | deriving Show 26 | 27 | data SqlOrder = SqlOrder { sqlOrderDirection :: SqlOrderDirection 28 | , sqlOrderNulls :: SqlOrderNulls } 29 | deriving Show 30 | 31 | -- | Expressions in SQL statements. 32 | data SqlExpr = ColumnSqlExpr SqlColumn 33 | | BinSqlExpr String SqlExpr SqlExpr 34 | | PrefixSqlExpr String SqlExpr 35 | | PostfixSqlExpr String SqlExpr 36 | | FunSqlExpr String [SqlExpr] 37 | | AggrFunSqlExpr String [SqlExpr] -- ^ Aggregate functions separate from normal functions. 38 | | ConstSqlExpr String 39 | | CaseSqlExpr [(SqlExpr,SqlExpr)] SqlExpr 40 | | ListSqlExpr [SqlExpr] 41 | | ParamSqlExpr (Maybe SqlName) SqlExpr 42 | | PlaceHolderSqlExpr 43 | | ParensSqlExpr SqlExpr 44 | | CastSqlExpr String SqlExpr 45 | | DefaultSqlExpr 46 | deriving Show 47 | 48 | -- | Data type for SQL UPDATE statements. 49 | data SqlUpdate = SqlUpdate SqlTable [(SqlColumn,SqlExpr)] [SqlExpr] 50 | 51 | -- | Data type for SQL DELETE statements. 52 | data SqlDelete = SqlDelete SqlTable [SqlExpr] 53 | 54 | --- | Data type for SQL INSERT statements. 55 | data SqlInsert = SqlInsert SqlTable [SqlColumn] (NEL.NonEmpty [SqlExpr]) 56 | -------------------------------------------------------------------------------- /opaleye-sqlite/src/Opaleye/SQLite/Column.hs: -------------------------------------------------------------------------------- 1 | module Opaleye.SQLite.Column (module Opaleye.SQLite.Column, 2 | Column, 3 | Nullable, 4 | unsafeCoerce, 5 | unsafeCoerceColumn) where 6 | 7 | import Opaleye.SQLite.Internal.Column (Column, Nullable, unsafeCoerce, unsafeCoerceColumn) 8 | import qualified Opaleye.SQLite.Internal.Column as C 9 | import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as HPQ 10 | import qualified Opaleye.SQLite.PGTypes as T 11 | import Prelude hiding (null) 12 | 13 | -- | A NULL of any type 14 | null :: Column (Nullable a) 15 | null = C.Column (HPQ.ConstExpr HPQ.NullLit) 16 | 17 | isNull :: Column (Nullable a) -> Column T.PGBool 18 | isNull = C.unOp HPQ.OpIsNull 19 | 20 | -- | If the @Column (Nullable a)@ is NULL then return the @Column b@ 21 | -- otherwise map the underlying @Column a@ using the provided 22 | -- function. 23 | -- 24 | -- The Opaleye equivalent of the 'Data.Maybe.maybe' function. 25 | matchNullable :: Column b -> (Column a -> Column b) -> Column (Nullable a) 26 | -> Column b 27 | matchNullable replacement f x = C.unsafeIfThenElse (isNull x) replacement 28 | (f (unsafeCoerceColumn x)) 29 | 30 | -- | If the @Column (Nullable a)@ is NULL then return the provided 31 | -- @Column a@ otherwise return the underlying @Column a@. 32 | -- 33 | -- The Opaleye equivalent of the 'Data.Maybe.fromMaybe' function 34 | fromNullable :: Column a -> Column (Nullable a) -> Column a 35 | fromNullable = flip matchNullable id 36 | 37 | -- | The Opaleye equivalent of 'Data.Maybe.Just' 38 | toNullable :: Column a -> Column (Nullable a) 39 | toNullable = unsafeCoerceColumn 40 | 41 | -- | If the argument is 'Data.Maybe.Nothing' return NULL otherwise return the 42 | -- provided value coerced to a nullable type. 43 | maybeToNullable :: Maybe (Column a) -> Column (Nullable a) 44 | maybeToNullable = maybe null toNullable 45 | 46 | -- | Cast a column to any other type. This is safe for some conversions such as uuid to text. 47 | unsafeCast :: String -> Column a -> Column b 48 | unsafeCast = C.unsafeCast 49 | -------------------------------------------------------------------------------- /src/Opaleye/Internal/PGTypes.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | module Opaleye.Internal.PGTypes where 6 | 7 | import Opaleye.Internal.Column (Field, Field_(Column)) 8 | import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ 9 | 10 | import Data.Proxy (Proxy(..)) 11 | import qualified Data.Text as SText 12 | import qualified Data.Text.Encoding as STextEncoding 13 | import qualified Data.Text.Lazy as LText 14 | import qualified Data.Text.Lazy.Encoding as LTextEncoding 15 | import qualified Data.ByteString as SByteString 16 | import qualified Data.ByteString.Lazy as LByteString 17 | import qualified Data.Time.Format.ISO8601.Compat as Time 18 | import Text.PrettyPrint.HughesPJ ((<>), doubleQuotes, render, text) 19 | import Prelude hiding ((<>)) 20 | 21 | unsafePgFormatTime :: Time.ISO8601 t => HPQ.Name -> t -> Field c 22 | unsafePgFormatTime typeName = castToType typeName . format 23 | where 24 | format = quote . Time.iso8601Show 25 | quote s = "'" ++ s ++ "'" 26 | 27 | literalColumn :: forall a. IsSqlType a => HPQ.Literal -> Field a 28 | literalColumn = Column . HPQ.CastExpr (showSqlType (Proxy :: Proxy a)) . HPQ.ConstExpr 29 | 30 | castToType :: HPQ.Name -> String -> Field_ n c 31 | castToType typeName = 32 | Column . HPQ.CastExpr typeName . HPQ.ConstExpr . HPQ.OtherLit 33 | 34 | strictDecodeUtf8 :: SByteString.ByteString -> String 35 | strictDecodeUtf8 = SText.unpack . STextEncoding.decodeUtf8 36 | 37 | lazyDecodeUtf8 :: LByteString.ByteString -> String 38 | lazyDecodeUtf8 = LText.unpack . LTextEncoding.decodeUtf8 39 | 40 | -- | Render the name of a type with a schema 41 | -- 42 | -- @ 43 | -- > putStrLn (sqlTypeWithSchema "my_schema" "my_type") 44 | -- "my_schema"."my_type" 45 | -- @ 46 | -- 47 | -- @ 48 | -- instance 'IsSqlType' SqlMyTypeWithSchema where 49 | -- 'showSqlType' = \\_ -> sqlTypeWithSchema "my_schema" "my_type" 50 | -- @ 51 | sqlTypeWithSchema :: String -> String -> String 52 | sqlTypeWithSchema schema type_ = 53 | render (doubleQuotes (text schema) 54 | <> text "." 55 | <> doubleQuotes (text type_)) 56 | 57 | class IsSqlType sqlType where 58 | showSqlType :: proxy sqlType -> String 59 | 60 | {-# MINIMAL showSqlType #-} 61 | -------------------------------------------------------------------------------- /src/Opaleye/ToFields.hs: -------------------------------------------------------------------------------- 1 | module Opaleye.ToFields (-- * Creating 'Field's from Haskell values 2 | toFields, 3 | toFieldsI, 4 | -- * Creating @ToFields@ 5 | C.toToFields, 6 | -- * Explicit versions 7 | toFieldsExplicit, 8 | -- * Adaptor 9 | C.ToFields, 10 | ) where 11 | 12 | import qualified Opaleye.Internal.Constant as C 13 | import Opaleye.Internal.Inferrable (Inferrable, runInferrable) 14 | 15 | import qualified Data.Profunctor.Product.Default as D 16 | 17 | toFieldsExplicit :: C.ToFields haskells fields -> haskells -> fields 18 | toFieldsExplicit = C.constantExplicit 19 | 20 | -- | 'toFields' provides a convenient typeclass wrapper around the 21 | -- 'Opaleye.Field.Field_' creation functions in "Opaleye.SqlTypes". Besides 22 | -- convenience it doesn't provide any additional functionality. 23 | -- 24 | -- It can be used with functions like 'Opaleye.Manipulation.runInsert' 25 | -- to insert custom Haskell types into the database. 26 | -- The following is an example of a function for inserting custom types. 27 | -- 28 | -- @ 29 | -- customInsert 30 | -- :: ( 'D.Default' 'ToFields' haskells fields ) 31 | -- => Connection 32 | -- -> 'Opaleye.Table' fields fields' 33 | -- -> [haskells] 34 | -- -> IO Int64 35 | -- customInsert conn table haskells = 'Opaleye.Manipulation.runInsert_' conn 'Opaleye.Manipulation.Insert' { 36 | -- iTable = table 37 | -- , iRows = map 'toFields' haskells 38 | -- , iReturning = rCount 39 | -- , iOnConflict = Nothing 40 | -- } 41 | -- @ 42 | -- 43 | -- In order to use this function with your custom types, you need to define an 44 | -- instance of 'D.Default' 'ToFields' for your custom types. 45 | toFields :: D.Default C.ToFields haskells fields => haskells -> fields 46 | toFields = C.toFields 47 | 48 | -- | Version of 'C.toFields' with better type inference 49 | toFieldsI :: (D.Default (Inferrable C.ToFields) haskells fields) 50 | => haskells 51 | -- ^ ͘ 52 | -> fields 53 | toFieldsI = toFieldsExplicit (runInferrable D.def) 54 | -------------------------------------------------------------------------------- /src/Opaleye/Internal/Distinct.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | 3 | module Opaleye.Internal.Distinct where 4 | 5 | import qualified Opaleye.Internal.MaybeFields as M 6 | import Opaleye.Select (Select) 7 | import Opaleye.Field (Field_) 8 | import Opaleye.Aggregate (Aggregator, groupBy, aggregateExplicit) 9 | 10 | import qualified Data.Profunctor as P 11 | import qualified Data.Profunctor.Product as PP 12 | import Data.Profunctor.Product.Default (Default, def) 13 | import Opaleye.Internal.Unpackspec (Unpackspec) 14 | 15 | -- We implement distinct simply by grouping by all columns. We could 16 | -- instead implement it as SQL's DISTINCT but implementing it in terms 17 | -- of something else that we already have is easier at this point. 18 | 19 | distinctExplicit :: Unpackspec fields fields 20 | -> Distinctspec fields fields' 21 | -> Select fields -> Select fields' 22 | distinctExplicit u (Distinctspec agg) = aggregateExplicit u agg 23 | 24 | newtype Distinctspec a b = Distinctspec (Aggregator a b) 25 | 26 | instance Default Distinctspec (Field_ n a) (Field_ n a) where 27 | def = Distinctspec groupBy 28 | 29 | distinctspecField :: Distinctspec (Field_ n a) (Field_ n a) 30 | distinctspecField = def 31 | 32 | distinctspecMaybeFields :: M.WithNulls Distinctspec a b 33 | -> Distinctspec (M.MaybeFields a) (M.MaybeFields b) 34 | distinctspecMaybeFields = M.unWithNulls def 35 | 36 | instance Default (M.WithNulls Distinctspec) a b 37 | => Default Distinctspec (M.MaybeFields a) (M.MaybeFields b) where 38 | def = distinctspecMaybeFields def 39 | 40 | -- { Boilerplate instances 41 | 42 | instance Functor (Distinctspec a) where 43 | fmap f (Distinctspec g) = Distinctspec (fmap f g) 44 | 45 | instance Applicative (Distinctspec a) where 46 | pure = Distinctspec . pure 47 | Distinctspec f <*> Distinctspec x = Distinctspec (f <*> x) 48 | 49 | instance P.Profunctor Distinctspec where 50 | dimap f g (Distinctspec q) = Distinctspec (P.dimap f g q) 51 | 52 | instance PP.ProductProfunctor Distinctspec where 53 | purePP = pure 54 | (****) = (<*>) 55 | 56 | instance PP.SumProfunctor Distinctspec where 57 | Distinctspec x1 +++! Distinctspec x2 = Distinctspec (x1 PP.+++! x2) 58 | 59 | -- } 60 | -------------------------------------------------------------------------------- /opaleye-sqlite/src/Opaleye/SQLite/Internal/Binary.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-} 2 | 3 | module Opaleye.SQLite.Internal.Binary where 4 | 5 | import Opaleye.SQLite.Internal.Column (Column(Column)) 6 | import qualified Opaleye.SQLite.Internal.Tag as T 7 | import qualified Opaleye.SQLite.Internal.PackMap as PM 8 | 9 | import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as HPQ 10 | 11 | import Data.Profunctor (Profunctor, dimap) 12 | import Data.Profunctor.Product (ProductProfunctor, empty, (***!)) 13 | import qualified Data.Profunctor.Product as PP 14 | import Data.Profunctor.Product.Default (Default, def) 15 | 16 | import Control.Applicative (Applicative, pure, (<*>)) 17 | import Control.Arrow ((***)) 18 | 19 | extractBinaryFields :: T.Tag -> (HPQ.PrimExpr, HPQ.PrimExpr) 20 | -> PM.PM [(HPQ.Symbol, (HPQ.PrimExpr, HPQ.PrimExpr))] 21 | HPQ.PrimExpr 22 | extractBinaryFields = PM.extractAttr "binary" 23 | 24 | newtype Binaryspec columns columns' = 25 | Binaryspec (PM.PackMap (HPQ.PrimExpr, HPQ.PrimExpr) HPQ.PrimExpr 26 | (columns, columns) columns') 27 | 28 | runBinaryspec :: Applicative f => Binaryspec columns columns' 29 | -> ((HPQ.PrimExpr, HPQ.PrimExpr) -> f HPQ.PrimExpr) 30 | -> (columns, columns) -> f columns' 31 | runBinaryspec (Binaryspec b) = PM.traversePM b 32 | 33 | binaryspecColumn :: Binaryspec (Column a) (Column a) 34 | binaryspecColumn = Binaryspec (PM.PackMap (\f (Column e, Column e') 35 | -> fmap Column (f (e, e')))) 36 | 37 | instance Default Binaryspec (Column a) (Column a) where 38 | def = binaryspecColumn 39 | 40 | -- { 41 | 42 | -- Boilerplate instance definitions. Theoretically, these are derivable. 43 | 44 | instance Functor (Binaryspec a) where 45 | fmap f (Binaryspec g) = Binaryspec (fmap f g) 46 | 47 | instance Applicative (Binaryspec a) where 48 | pure = Binaryspec . pure 49 | Binaryspec f <*> Binaryspec x = Binaryspec (f <*> x) 50 | 51 | instance Profunctor Binaryspec where 52 | dimap f g (Binaryspec b) = Binaryspec (dimap (f *** f) g b) 53 | 54 | instance ProductProfunctor Binaryspec where 55 | empty = PP.defaultEmpty 56 | (***!) = PP.defaultProfunctorProduct 57 | 58 | -- } 59 | -------------------------------------------------------------------------------- /opaleye-sqlite/src/Opaleye/SQLite/Constant.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} 2 | 3 | module Opaleye.SQLite.Constant where 4 | 5 | import Opaleye.SQLite.Column (Column) 6 | import qualified Opaleye.SQLite.Column as C 7 | import qualified Opaleye.SQLite.SqlTypes as T 8 | 9 | import qualified Data.Text as ST 10 | import qualified Data.Text.Lazy as LT 11 | 12 | import qualified Data.Profunctor.Product as PP 13 | import Data.Profunctor.Product (empty, (***!), (+++!)) 14 | import qualified Data.Profunctor.Product.Default as D 15 | import qualified Data.Profunctor as P 16 | 17 | import Control.Applicative (Applicative, pure, (<*>)) 18 | 19 | 20 | newtype Constant haskells columns = 21 | Constant { constantExplicit :: haskells -> columns } 22 | 23 | constant :: D.Default Constant haskells columns 24 | => haskells -> columns 25 | constant = constantExplicit D.def 26 | 27 | instance D.Default Constant haskell (Column sql) 28 | => D.Default Constant (Maybe haskell) (Column (C.Nullable sql)) where 29 | def = Constant (C.maybeToNullable . fmap f) 30 | where Constant f = D.def 31 | 32 | instance D.Default Constant Int (Column T.SqlInt) where 33 | def = Constant T.sqlInt 34 | 35 | instance D.Default Constant String (Column T.SqlText) where 36 | def = Constant T.sqlString 37 | 38 | instance D.Default Constant ST.Text (Column T.SqlText) where 39 | def = Constant T.sqlStrictText 40 | 41 | instance D.Default Constant LT.Text (Column T.SqlText) where 42 | def = Constant T.sqlLazyText 43 | 44 | instance D.Default Constant Double (Column T.SqlReal) where 45 | def = Constant T.sqlReal 46 | 47 | instance D.Default Constant Bool (Column T.SqlBool) where 48 | def = Constant T.sqlBool 49 | 50 | 51 | -- { Boilerplate instances 52 | 53 | instance Functor (Constant a) where 54 | fmap f (Constant g) = Constant (fmap f g) 55 | 56 | instance Applicative (Constant a) where 57 | pure = Constant . pure 58 | Constant f <*> Constant x = Constant (f <*> x) 59 | 60 | instance P.Profunctor Constant where 61 | dimap f g (Constant h) = Constant (P.dimap f g h) 62 | 63 | instance PP.ProductProfunctor Constant where 64 | empty = Constant empty 65 | Constant f ***! Constant g = Constant (f ***! g) 66 | 67 | instance PP.SumProfunctor Constant where 68 | Constant f +++! Constant g = Constant (f +++! g) 69 | 70 | -- } 71 | -------------------------------------------------------------------------------- /opaleye-sqlite/src/Opaleye/SQLite/Aggregate.hs: -------------------------------------------------------------------------------- 1 | -- | Perform aggregations on query results. 2 | module Opaleye.SQLite.Aggregate (module Opaleye.SQLite.Aggregate, Aggregator) where 3 | 4 | import qualified Opaleye.SQLite.Internal.Aggregate as A 5 | import Opaleye.SQLite.Internal.Aggregate (Aggregator) 6 | import qualified Opaleye.SQLite.Internal.Column as IC 7 | import Opaleye.SQLite.QueryArr (Query) 8 | import qualified Opaleye.SQLite.Internal.QueryArr as Q 9 | import qualified Opaleye.SQLite.Column as C 10 | import qualified Opaleye.SQLite.Order as Ord 11 | import qualified Opaleye.SQLite.PGTypes as T 12 | import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as HPQ 13 | 14 | -- This page of Postgres documentation tell us what aggregate 15 | -- functions are available 16 | -- 17 | -- http://www.postgresql.org/docs/9.3/static/functions-aggregate.html 18 | 19 | {-| 20 | Given a 'Query' producing rows of type @a@ and an 'Aggregator' accepting rows of 21 | type @a@, apply the aggregator to the results of the query. 22 | 23 | -} 24 | aggregate :: Aggregator a b -> Query a -> Query b 25 | aggregate agg q = Q.simpleQueryArr (A.aggregateU agg . Q.runSimpleQueryArr q) 26 | 27 | -- | Group the aggregation by equality on the input to 'groupBy'. 28 | groupBy :: Aggregator (C.Column a) (C.Column a) 29 | groupBy = A.makeAggr' Nothing 30 | 31 | -- | Sum all rows in a group. 32 | sum :: Aggregator (C.Column a) (C.Column a) 33 | sum = A.makeAggr HPQ.AggrSum 34 | 35 | -- | Count the number of non-null rows in a group. 36 | count :: Aggregator (C.Column a) (C.Column T.PGInt8) 37 | count = A.makeAggr HPQ.AggrCount 38 | 39 | -- | Average of a group 40 | avg :: Aggregator (C.Column T.PGFloat8) (C.Column T.PGFloat8) 41 | avg = A.makeAggr HPQ.AggrAvg 42 | 43 | -- | Maximum of a group 44 | max :: Ord.PGOrd a => Aggregator (C.Column a) (C.Column a) 45 | max = A.makeAggr HPQ.AggrMax 46 | 47 | -- | Maximum of a group 48 | min :: Ord.PGOrd a => Aggregator (C.Column a) (C.Column a) 49 | min = A.makeAggr HPQ.AggrMin 50 | 51 | boolOr :: Aggregator (C.Column T.PGBool) (C.Column T.PGBool) 52 | boolOr = A.makeAggr HPQ.AggrBoolOr 53 | 54 | boolAnd :: Aggregator (C.Column T.PGBool) (C.Column T.PGBool) 55 | boolAnd = A.makeAggr HPQ.AggrBoolAnd 56 | 57 | arrayAgg :: Aggregator (C.Column a) (C.Column (T.PGArray a)) 58 | arrayAgg = A.makeAggr HPQ.AggrArr 59 | 60 | stringAgg :: C.Column T.PGText -> Aggregator (C.Column T.PGText) (C.Column T.PGText) 61 | stringAgg = A.makeAggr' . Just . HPQ.AggrStringAggr . IC.unColumn 62 | -------------------------------------------------------------------------------- /src/Opaleye.hs: -------------------------------------------------------------------------------- 1 | -- {-# OPTIONS_HADDOCK ignore-exports #-} 2 | 3 | -- | An SQL-generating DSL targeting PostgreSQL. Allows Postgres 4 | -- queries to be written within Haskell in a typesafe and composable 5 | -- fashion. 6 | -- 7 | -- You might like to look at 8 | -- 9 | -- * 10 | -- 11 | -- * 12 | -- 13 | -- * 14 | -- 15 | -- * If you are confused about the @Default@ typeclass, then 16 | -- the 17 | 18 | module Opaleye ( module Opaleye.Adaptors 19 | , module Opaleye.Aggregate 20 | , module Opaleye.Binary 21 | , module Opaleye.Column 22 | , module Opaleye.Distinct 23 | , module Opaleye.Field 24 | , module Opaleye.FunctionalJoin 25 | , module Opaleye.Join 26 | , module Opaleye.Label 27 | , module Opaleye.Lateral 28 | , module Opaleye.Manipulation 29 | , module Opaleye.MaybeFields 30 | , module Opaleye.Operators 31 | , module Opaleye.Order 32 | , module Opaleye.RunSelect 33 | , module Opaleye.Sql 34 | , module Opaleye.Select 35 | , module Opaleye.SqlTypes 36 | , module Opaleye.Table 37 | , module Opaleye.ToFields 38 | , module Opaleye.Values 39 | , module Opaleye.With 40 | , module Opaleye.Window 41 | ) where 42 | 43 | import Opaleye.Adaptors 44 | import Opaleye.Aggregate 45 | import Opaleye.Binary 46 | import Opaleye.Column 47 | hiding (null, 48 | isNull) 49 | import Opaleye.Distinct 50 | import Opaleye.Field 51 | import Opaleye.FunctionalJoin 52 | import Opaleye.Join 53 | import Opaleye.Label 54 | import Opaleye.Lateral 55 | import Opaleye.Manipulation 56 | import Opaleye.MaybeFields 57 | import Opaleye.Operators 58 | import Opaleye.Order 59 | import Opaleye.RunSelect 60 | import Opaleye.Select 61 | import Opaleye.Sql 62 | import Opaleye.SqlTypes 63 | import Opaleye.Table 64 | import Opaleye.ToFields 65 | import Opaleye.Values 66 | import Opaleye.Window 67 | import Opaleye.With 68 | -------------------------------------------------------------------------------- /opaleye-sqlite/src/Opaleye/SQLite/Internal/Column.hs: -------------------------------------------------------------------------------- 1 | module Opaleye.SQLite.Internal.Column where 2 | 3 | import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as HPQ 4 | 5 | -- | The 'Num' and 'Fractional' instances for 'Column' 'a' are too 6 | -- general. For example, they allow you to add two 'Column' 7 | -- 'String's. This will be fixed in a subsequent release. 8 | newtype Column a = Column HPQ.PrimExpr deriving Show 9 | 10 | data Nullable a = Nullable 11 | 12 | unColumn :: Column a -> HPQ.PrimExpr 13 | unColumn (Column e) = e 14 | 15 | {-# DEPRECATED unsafeCoerce "Use unsafeCoerceColumn instead" #-} 16 | unsafeCoerce :: Column a -> Column b 17 | unsafeCoerce = unsafeCoerceColumn 18 | 19 | unsafeCoerceColumn :: Column a -> Column b 20 | unsafeCoerceColumn (Column e) = Column e 21 | 22 | binOp :: HPQ.BinOp -> Column a -> Column b -> Column c 23 | binOp op (Column e) (Column e') = Column (HPQ.BinExpr op e e') 24 | 25 | unOp :: HPQ.UnOp -> Column a -> Column b 26 | unOp op (Column e) = Column (HPQ.UnExpr op e) 27 | 28 | -- For import order reasons we can't make the return type PGBool 29 | unsafeCase_ :: [(Column pgBool, Column a)] -> Column a -> Column a 30 | unsafeCase_ alts (Column otherwise_) = Column (HPQ.CaseExpr (unColumns alts) otherwise_) 31 | where unColumns = map (\(Column e, Column e') -> (e, e')) 32 | 33 | unsafeIfThenElse :: Column pgBool -> Column a -> Column a -> Column a 34 | unsafeIfThenElse cond t f = unsafeCase_ [(cond, t)] f 35 | 36 | unsafeGt :: Column a -> Column a -> Column pgBool 37 | unsafeGt = binOp HPQ.OpGt 38 | 39 | unsafeEq :: Column a -> Column a -> Column pgBool 40 | unsafeEq = binOp HPQ.OpEq 41 | 42 | class PGNum a where 43 | pgFromInteger :: Integer -> Column a 44 | 45 | instance PGNum a => Num (Column a) where 46 | fromInteger = pgFromInteger 47 | (*) = binOp HPQ.OpMul 48 | (+) = binOp HPQ.OpPlus 49 | (-) = binOp HPQ.OpMinus 50 | 51 | abs = unOp HPQ.OpAbs 52 | negate = unOp HPQ.OpNegate 53 | 54 | -- We can't use Postgres's 'sign' function because it returns only a 55 | -- numeric or a double 56 | signum c = unsafeCase_ [(c `unsafeGt` 0, 1), (c `unsafeEq` 0, 0)] (-1) 57 | 58 | class PGFractional a where 59 | pgFromRational :: Rational -> Column a 60 | 61 | instance (PGNum a, PGFractional a) => Fractional (Column a) where 62 | fromRational = pgFromRational 63 | (/) = binOp HPQ.OpDiv 64 | 65 | unsafeCast :: String -> Column a -> Column b 66 | unsafeCast = mapColumn . HPQ.CastExpr 67 | where 68 | mapColumn :: (HPQ.PrimExpr -> HPQ.PrimExpr) -> Column c -> Column a 69 | mapColumn primExpr = Column . primExpr . unColumn 70 | -------------------------------------------------------------------------------- /opaleye-sqlite/src/Opaleye/SQLite/Internal/Order.hs: -------------------------------------------------------------------------------- 1 | module Opaleye.SQLite.Internal.Order where 2 | 3 | import qualified Opaleye.SQLite.Column as C 4 | import qualified Opaleye.SQLite.Internal.Column as IC 5 | import qualified Opaleye.SQLite.Internal.Tag as T 6 | import qualified Opaleye.SQLite.Internal.PrimQuery as PQ 7 | 8 | import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as HPQ 9 | import qualified Data.Functor.Contravariant as C 10 | import qualified Data.Functor.Contravariant.Divisible as Divisible 11 | import qualified Data.Profunctor as P 12 | import qualified Data.Monoid as M 13 | import qualified Data.Semigroup as S 14 | import qualified Data.Void as Void 15 | 16 | {-| 17 | An `Order` represents an expression to order on and a sort 18 | direction. Multiple `Order`s can be composed with 19 | `Data.Monoid.mappend`. If two rows are equal according to the first 20 | `Order`, the second is used, and so on. 21 | -} 22 | 23 | -- Like the (columns -> RowParser haskells) field of QueryRunner this 24 | -- type is "too big". We never actually look at the 'a' (in the 25 | -- QueryRunner case the 'colums') except to check the "structure". 26 | -- This is so we can support a SumProfunctor instance. 27 | newtype Order a = Order (a -> [(HPQ.OrderOp, HPQ.PrimExpr)]) 28 | 29 | instance C.Contravariant Order where 30 | contramap f (Order g) = Order (P.lmap f g) 31 | 32 | instance S.Semigroup (Order a) where 33 | Order o <> Order o' = Order (o `M.mappend` o') 34 | 35 | instance M.Monoid (Order a) where 36 | mempty = Order M.mempty 37 | 38 | instance Divisible.Divisible Order where 39 | divide f o o' = M.mappend (C.contramap (fst . f) o) 40 | (C.contramap (snd . f) o') 41 | conquer = M.mempty 42 | 43 | instance Divisible.Decidable Order where 44 | lose f = C.contramap f (Order Void.absurd) 45 | choose f (Order o) (Order o') = C.contramap f (Order (either o o')) 46 | 47 | order :: HPQ.OrderOp -> (a -> C.Column b) -> Order a 48 | order op f = Order (fmap (\column -> [(op, IC.unColumn column)]) f) 49 | 50 | orderByU :: Order a -> (a, PQ.PrimQuery, T.Tag) -> (a, PQ.PrimQuery, T.Tag) 51 | orderByU os (columns, primQ, t) = (columns, primQ', t) 52 | where primQ' = PQ.Order orderExprs primQ 53 | Order sos = os 54 | orderExprs = map (uncurry HPQ.OrderExpr) (sos columns) 55 | 56 | limit' :: Int -> (a, PQ.PrimQuery, T.Tag) -> (a, PQ.PrimQuery, T.Tag) 57 | limit' n (x, q, t) = (x, PQ.Limit (PQ.LimitOp n) q, t) 58 | 59 | offset' :: Int -> (a, PQ.PrimQuery, T.Tag) -> (a, PQ.PrimQuery, T.Tag) 60 | offset' n (x, q, t) = (x, PQ.Limit (PQ.OffsetOp n) q, t) 61 | -------------------------------------------------------------------------------- /opaleye-sqlite/src/Opaleye/SQLite/Internal/QueryArr.hs: -------------------------------------------------------------------------------- 1 | module Opaleye.SQLite.Internal.QueryArr where 2 | 3 | import Prelude hiding (id) 4 | 5 | import qualified Opaleye.SQLite.Internal.Unpackspec as U 6 | import qualified Opaleye.SQLite.Internal.Tag as Tag 7 | import Opaleye.SQLite.Internal.Tag (Tag) 8 | import qualified Opaleye.SQLite.Internal.PrimQuery as PQ 9 | 10 | import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as HPQ 11 | 12 | import qualified Control.Arrow as Arr 13 | import Control.Arrow ((&&&), (***), arr) 14 | import qualified Control.Category as C 15 | import Control.Category ((<<<), id) 16 | import Control.Applicative (Applicative, pure, (<*>)) 17 | import qualified Data.Profunctor as P 18 | import qualified Data.Profunctor.Product as PP 19 | 20 | newtype QueryArr a b = QueryArr ((a, PQ.PrimQuery, Tag) -> (b, PQ.PrimQuery, Tag)) 21 | type Query = QueryArr () 22 | 23 | simpleQueryArr :: ((a, Tag) -> (b, PQ.PrimQuery, Tag)) -> QueryArr a b 24 | simpleQueryArr f = QueryArr g 25 | where g (a0, primQuery, t0) = (a1, PQ.times primQuery primQuery', t1) 26 | where (a1, primQuery', t1) = f (a0, t0) 27 | 28 | runQueryArr :: QueryArr a b -> (a, PQ.PrimQuery, Tag) -> (b, PQ.PrimQuery, Tag) 29 | runQueryArr (QueryArr f) = f 30 | 31 | runSimpleQueryArr :: QueryArr a b -> (a, Tag) -> (b, PQ.PrimQuery, Tag) 32 | runSimpleQueryArr f (a, t) = runQueryArr f (a, PQ.Unit, t) 33 | 34 | runSimpleQueryArrStart :: QueryArr a b -> a -> (b, PQ.PrimQuery, Tag) 35 | runSimpleQueryArrStart q a = runSimpleQueryArr q (a, Tag.start) 36 | 37 | runQueryArrUnpack :: U.Unpackspec a b 38 | -> Query a -> ([HPQ.PrimExpr], PQ.PrimQuery, Tag) 39 | runQueryArrUnpack unpackspec q = (primExprs, primQ, endTag) 40 | where (columns, primQ, endTag) = runSimpleQueryArrStart q () 41 | primExprs = U.collectPEs unpackspec columns 42 | 43 | first3 :: (a1 -> b) -> (a1, a2, a3) -> (b, a2, a3) 44 | first3 f (a1, a2, a3) = (f a1, a2, a3) 45 | 46 | instance C.Category QueryArr where 47 | id = QueryArr id 48 | QueryArr f . QueryArr g = QueryArr (f . g) 49 | 50 | instance Arr.Arrow QueryArr where 51 | arr f = QueryArr (first3 f) 52 | first f = QueryArr g 53 | where g ((b, d), primQ, t0) = ((c, d), primQ', t1) 54 | where (c, primQ', t1) = runQueryArr f (b, primQ, t0) 55 | 56 | instance Functor (QueryArr a) where 57 | fmap f = (arr f <<<) 58 | 59 | instance Applicative (QueryArr a) where 60 | pure = arr . const 61 | f <*> g = arr (uncurry ($)) <<< (f &&& g) 62 | 63 | instance P.Profunctor QueryArr where 64 | dimap f g a = arr g <<< a <<< arr f 65 | 66 | instance PP.ProductProfunctor QueryArr where 67 | empty = id 68 | (***!) = (***) 69 | -------------------------------------------------------------------------------- /opaleye-sqlite/src/Opaleye/SQLite/Join.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} 2 | 3 | module Opaleye.SQLite.Join where 4 | 5 | import qualified Opaleye.SQLite.Internal.Unpackspec as U 6 | import qualified Opaleye.SQLite.Internal.Join as J 7 | import qualified Opaleye.SQLite.Internal.Tag as T 8 | import qualified Opaleye.SQLite.Internal.PrimQuery as PQ 9 | import Opaleye.SQLite.QueryArr (Query) 10 | import qualified Opaleye.SQLite.Internal.QueryArr as Q 11 | import Opaleye.SQLite.Internal.Column (Column(Column)) 12 | import qualified Opaleye.SQLite.PGTypes as T 13 | 14 | import qualified Data.Profunctor.Product.Default as D 15 | 16 | -- | @leftJoin@'s use of the 'D.Default' typeclass means that the 17 | -- compiler will have trouble inferring types. It is strongly 18 | -- recommended that you provide full type signatures when using 19 | -- @leftJoin@. 20 | -- 21 | -- Example specialization: 22 | -- 23 | -- @ 24 | -- leftJoin :: Query (Column a, Column b) 25 | -- -> Query (Column c, Column (Nullable d)) 26 | -- -> (((Column a, Column b), (Column c, Column (Nullable d))) -> Column 'Opaleye.PGTypes.PGBool') 27 | -- -> Query ((Column a, Column b), (Column (Nullable c), Column (Nullable d))) 28 | -- @ 29 | leftJoin :: (D.Default U.Unpackspec columnsA columnsA, 30 | D.Default U.Unpackspec columnsB columnsB, 31 | D.Default J.NullMaker columnsB nullableColumnsB) => 32 | Query columnsA -> Query columnsB 33 | -> ((columnsA, columnsB) -> Column T.PGBool) 34 | -> Query (columnsA, nullableColumnsB) 35 | leftJoin = leftJoinExplicit D.def D.def D.def 36 | 37 | -- We don't actually need the Unpackspecs any more, but I'm going to 38 | -- leave them here in case they're ever needed again. I don't want to 39 | -- have to break the API to add them back. 40 | leftJoinExplicit :: U.Unpackspec columnsA columnsA 41 | -> U.Unpackspec columnsB columnsB 42 | -> J.NullMaker columnsB nullableColumnsB 43 | -> Query columnsA -> Query columnsB 44 | -> ((columnsA, columnsB) -> Column T.PGBool) 45 | -> Query (columnsA, nullableColumnsB) 46 | leftJoinExplicit _ _ nullmaker qA qB cond = Q.simpleQueryArr q where 47 | q ((), startTag) = ((columnsA, nullableColumnsB), primQueryR, T.next endTag) 48 | where (columnsA, primQueryA, midTag) = Q.runSimpleQueryArr qA ((), startTag) 49 | (columnsB, primQueryB, endTag) = Q.runSimpleQueryArr qB ((), midTag) 50 | 51 | nullableColumnsB = J.toNullable nullmaker columnsB 52 | 53 | Column cond' = cond (columnsA, columnsB) 54 | primQueryR = PQ.Join PQ.LeftJoin cond' primQueryA primQueryB 55 | -------------------------------------------------------------------------------- /Doc/Tutorial/TutorialAdvanced.lhs: -------------------------------------------------------------------------------- 1 | > {-# LANGUAGE FlexibleContexts #-} 2 | > 3 | > module TutorialAdvanced where 4 | > 5 | > import Prelude hiding (sum) 6 | > 7 | > import Opaleye (Select, Field, Table, table, tableField, 8 | > selectTable, SqlText, SqlInt4, Aggregator, 9 | > aggregate) 10 | > import qualified Opaleye.Aggregate as A 11 | > import Opaleye.Aggregate () 12 | > 13 | > import qualified Opaleye.Sql as Sql 14 | > import qualified Opaleye.Internal.Unpackspec as U 15 | > 16 | > import Data.Profunctor.Product.Default (Default) 17 | > import Data.Profunctor (dimap) 18 | > import Data.Profunctor.Product ((***!), p2) 19 | 20 | 21 | Combining Aggregators 22 | ===================== 23 | 24 | Opaleye allows you to straightforwardly combine aggregators to create 25 | new aggregators in a way that is inconvenient to do directly in 26 | Postgres. 27 | 28 | We can define an aggregator to calculate the range of a group, that is 29 | the difference between its maximum and minimum. Although we can write 30 | this easily in SQL as `MAX(field) - MIN(field)`, Opaleye has the 31 | advantage of treating `range` as a first-class value able to be passed 32 | around between functions and manipulated at will. 33 | 34 | > range :: Aggregator (Field SqlInt4) (Field SqlInt4) 35 | > range = dimap (\x -> (x, x)) (uncurry (-)) (A.max ***! A.min) 36 | 37 | We can test it on a person table which contains rows containing 38 | people's names along with the age of their children. 39 | 40 | > personTable :: Table (Field SqlText, Field SqlInt4) 41 | > (Field SqlText, Field SqlInt4) 42 | > personTable = table "personTable" (p2 ( tableField "name" 43 | > , tableField "child_age" )) 44 | 45 | > rangeOfChildrensAges :: Select (Field SqlText, Field SqlInt4) 46 | > rangeOfChildrensAges = aggregate (p2 (A.groupBy, range)) (selectTable personTable) 47 | 48 | 49 | TutorialAdvanced> printSql rangeOfChildrensAges 50 | SELECT result0_2 as result1, 51 | (result1_2) - (result2_2) as result2 52 | FROM (SELECT * 53 | FROM (SELECT name0_1 as result0_2, 54 | MAX(child_age1_1) as result1_2, 55 | MIN(child_age1_1) as result2_2 56 | FROM (SELECT * 57 | FROM (SELECT name as name0_1, 58 | child_age as child_age1_1 59 | FROM personTable as T1) as T1) as T1 60 | GROUP BY name0_1) as T1) as T1 61 | 62 | 63 | Idealised SQL: 64 | 65 | SELECT name, 66 | MAX(child_age) - MIN(child_age) 67 | FROM personTable 68 | GROUP BY name 69 | 70 | 71 | Helper function 72 | =============== 73 | 74 | > printSql :: Default U.Unpackspec a a => Select a -> IO () 75 | > printSql = putStrLn . maybe "Empty select" id . Sql.showSql 76 | -------------------------------------------------------------------------------- /opaleye-sqlite/src/Opaleye/SQLite/Operators.hs: -------------------------------------------------------------------------------- 1 | module Opaleye.SQLite.Operators (module Opaleye.SQLite.Operators) where 2 | 3 | import qualified Data.Foldable as F 4 | 5 | import Opaleye.SQLite.Internal.Column (Column(Column), unsafeCase_, 6 | unsafeIfThenElse, unsafeGt, unsafeEq) 7 | import qualified Opaleye.SQLite.Internal.Column as C 8 | import Opaleye.SQLite.Internal.QueryArr (QueryArr(QueryArr)) 9 | import qualified Opaleye.SQLite.Internal.PrimQuery as PQ 10 | import qualified Opaleye.SQLite.Order as Ord 11 | import qualified Opaleye.SQLite.PGTypes as T 12 | 13 | import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as HPQ 14 | 15 | {-| Restrict query results to a particular condition. Corresponds to 16 | the guard method of the MonadPlus class. 17 | -} 18 | restrict :: QueryArr (Column T.PGBool) () 19 | restrict = QueryArr f where 20 | f (Column predicate, primQ, t0) = ((), PQ.restrict predicate primQ, t0) 21 | 22 | doubleOfInt :: Column T.PGInt4 -> Column T.PGFloat8 23 | doubleOfInt (Column e) = Column (HPQ.CastExpr "float8" e) 24 | 25 | infix 4 .== 26 | (.==) :: Column a -> Column a -> Column T.PGBool 27 | (.==) = unsafeEq 28 | 29 | infix 4 ./= 30 | (./=) :: Column a -> Column a -> Column T.PGBool 31 | (./=) = C.binOp HPQ.OpNotEq 32 | 33 | infix 4 .> 34 | (.>) :: Ord.PGOrd a => Column a -> Column a -> Column T.PGBool 35 | (.>) = unsafeGt 36 | 37 | infix 4 .< 38 | (.<) :: Ord.PGOrd a => Column a -> Column a -> Column T.PGBool 39 | (.<) = C.binOp HPQ.OpLt 40 | 41 | infix 4 .<= 42 | (.<=) :: Ord.PGOrd a => Column a -> Column a -> Column T.PGBool 43 | (.<=) = C.binOp HPQ.OpLtEq 44 | 45 | infix 4 .>= 46 | (.>=) :: Ord.PGOrd a => Column a -> Column a -> Column T.PGBool 47 | (.>=) = C.binOp HPQ.OpGtEq 48 | 49 | case_ :: [(Column T.PGBool, Column a)] -> Column a -> Column a 50 | case_ = unsafeCase_ 51 | 52 | ifThenElse :: Column T.PGBool -> Column a -> Column a -> Column a 53 | ifThenElse = unsafeIfThenElse 54 | 55 | infixr 3 .&& 56 | (.&&) :: Column T.PGBool -> Column T.PGBool -> Column T.PGBool 57 | (.&&) = C.binOp HPQ.OpAnd 58 | 59 | infixr 2 .|| 60 | (.||) :: Column T.PGBool -> Column T.PGBool -> Column T.PGBool 61 | (.||) = C.binOp HPQ.OpOr 62 | 63 | not :: Column T.PGBool -> Column T.PGBool 64 | not = C.unOp HPQ.OpNot 65 | 66 | (.++) :: Column T.PGText -> Column T.PGText -> Column T.PGText 67 | (.++) = C.binOp HPQ.OpCat 68 | 69 | lower :: Column T.PGText -> Column T.PGText 70 | lower = C.unOp HPQ.OpLower 71 | 72 | upper :: Column T.PGText -> Column T.PGText 73 | upper = C.unOp HPQ.OpUpper 74 | 75 | like :: Column T.PGText -> Column T.PGText -> Column T.PGBool 76 | like = C.binOp HPQ.OpLike 77 | 78 | ors :: F.Foldable f => f (Column T.PGBool) -> Column T.PGBool 79 | ors = F.foldl' (.||) (T.pgBool False) 80 | 81 | in_ :: (Functor f, F.Foldable f) => f (Column a) -> Column a -> Column T.PGBool 82 | in_ hs w = ors . fmap (w .==) $ hs 83 | -------------------------------------------------------------------------------- /src/Opaleye/FunctionalJoin.hs: -------------------------------------------------------------------------------- 1 | -- | Full outer joins. 2 | -- See "Opaleye.Join" for details on the best way to do other joins in 3 | -- Opaleye. 4 | 5 | module Opaleye.FunctionalJoin ( 6 | -- * Full outer join 7 | fullJoinF, 8 | ) where 9 | 10 | import qualified Data.Profunctor.Product.Default as D 11 | import qualified Data.Profunctor.Product as PP 12 | 13 | import qualified Opaleye.Field as C 14 | import qualified Opaleye.Field as F 15 | import qualified Opaleye.Internal.Join as IJ 16 | import qualified Opaleye.Internal.Operators as IO 17 | import qualified Opaleye.Internal.Unpackspec as IU 18 | import qualified Opaleye.Join as J 19 | import qualified Opaleye.Select as S 20 | import qualified Opaleye.SqlTypes as T 21 | import qualified Opaleye.Operators as O 22 | 23 | fullJoinF :: (D.Default IO.IfPP fieldsResult fieldsResult, 24 | D.Default IU.Unpackspec fieldsL fieldsL, 25 | D.Default IU.Unpackspec fieldsR fieldsR) 26 | => (fieldsL -> fieldsR -> fieldsResult) 27 | -- ^ Calculate result row from input rows for rows in the 28 | -- left and right query satisfying the join condition 29 | -> (fieldsL -> fieldsResult) 30 | -- ^ Calculate result row from left input row when there 31 | -- are /no/ rows in the right query satisfying the join 32 | -- condition 33 | -> (fieldsR -> fieldsResult) 34 | -- ^ Calculate result row from right input row when there 35 | -- are /no/ rows in the left query satisfying the join 36 | -- condition 37 | -> (fieldsL -> fieldsR -> F.Field T.SqlBool) 38 | -- ^ Condition on which to join 39 | -> S.Select fieldsL 40 | -- ^ Left query 41 | -> S.Select fieldsR 42 | -- ^ Right query 43 | -> S.Select fieldsResult 44 | fullJoinF f fL fR cond l r = fmap ret j 45 | where a1 = fmap (\x -> (x, T.sqlBool True)) 46 | j = J.fullJoinExplicit D.def 47 | D.def 48 | (PP.p2 (IJ.NullMaker id, nullmakerBool)) 49 | (PP.p2 (IJ.NullMaker id, nullmakerBool)) 50 | (a1 l) 51 | (a1 r) 52 | (\((l', _), (r', _)) -> cond l' r') 53 | 54 | ret ((lr, lc), (rr, rc)) = O.ifThenElseMany (C.isNull lc) 55 | (fR rr) 56 | (O.ifThenElseMany (C.isNull rc) 57 | (fL lr) 58 | (f lr rr)) 59 | 60 | nullmakerBool :: IJ.NullMaker (F.Field T.SqlBool) 61 | (F.FieldNullable T.SqlBool) 62 | nullmakerBool = D.def 63 | -------------------------------------------------------------------------------- /opaleye-sqlite/src/Opaleye/SQLite/Internal/Aggregate.hs: -------------------------------------------------------------------------------- 1 | module Opaleye.SQLite.Internal.Aggregate where 2 | 3 | import Control.Applicative (Applicative, pure, (<*>)) 4 | 5 | import qualified Data.Profunctor as P 6 | import qualified Data.Profunctor.Product as PP 7 | 8 | import qualified Opaleye.SQLite.Internal.PackMap as PM 9 | import qualified Opaleye.SQLite.Internal.PrimQuery as PQ 10 | import qualified Opaleye.SQLite.Internal.Tag as T 11 | import qualified Opaleye.SQLite.Internal.Column as C 12 | 13 | import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as HPQ 14 | 15 | {-| 16 | An 'Aggregator' takes a collection of rows of type @a@, groups 17 | them, and transforms each group into a single row of type @b@. This 18 | corresponds to aggregators using @GROUP BY@ in SQL. 19 | 20 | An 'Aggregator' corresponds closely to a 'Control.Foldl.Fold' from the 21 | @foldl@ package. Whereas an 'Aggregator' @a@ @b@ takes each group of 22 | type @a@ to a single row of type @b@, a 'Control.Foldl.Fold' @a@ @b@ 23 | takes a list of @a@ and returns a single row of type @b@. 24 | -} 25 | newtype Aggregator a b = Aggregator 26 | (PM.PackMap (Maybe HPQ.AggrOp, HPQ.PrimExpr) HPQ.PrimExpr 27 | a b) 28 | 29 | makeAggr' :: Maybe HPQ.AggrOp -> Aggregator (C.Column a) (C.Column b) 30 | makeAggr' m = Aggregator (PM.PackMap 31 | (\f (C.Column e) -> fmap C.Column (f (m, e)))) 32 | 33 | makeAggr :: HPQ.AggrOp -> Aggregator (C.Column a) (C.Column b) 34 | makeAggr = makeAggr' . Just 35 | 36 | runAggregator :: Applicative f => Aggregator a b 37 | -> ((Maybe HPQ.AggrOp, HPQ.PrimExpr) -> f HPQ.PrimExpr) -> a -> f b 38 | runAggregator (Aggregator a) = PM.traversePM a 39 | 40 | aggregateU :: Aggregator a b 41 | -> (a, PQ.PrimQuery, T.Tag) -> (b, PQ.PrimQuery, T.Tag) 42 | aggregateU agg (c0, primQ, t0) = (c1, primQ', T.next t0) 43 | where (c1, projPEs) = 44 | PM.run (runAggregator agg (extractAggregateFields t0) c0) 45 | 46 | primQ' = PQ.Aggregate projPEs primQ 47 | 48 | extractAggregateFields :: T.Tag -> (Maybe HPQ.AggrOp, HPQ.PrimExpr) 49 | -> PM.PM [(HPQ.Symbol, (Maybe HPQ.AggrOp, HPQ.PrimExpr))] HPQ.PrimExpr 50 | extractAggregateFields = PM.extractAttr "result" 51 | 52 | -- { Boilerplate instances 53 | 54 | instance Functor (Aggregator a) where 55 | fmap f (Aggregator g) = Aggregator (fmap f g) 56 | 57 | instance Applicative (Aggregator a) where 58 | pure = Aggregator . pure 59 | Aggregator f <*> Aggregator x = Aggregator (f <*> x) 60 | 61 | instance P.Profunctor Aggregator where 62 | dimap f g (Aggregator q) = Aggregator (P.dimap f g q) 63 | 64 | instance PP.ProductProfunctor Aggregator where 65 | empty = PP.defaultEmpty 66 | (***!) = PP.defaultProfunctorProduct 67 | 68 | instance PP.SumProfunctor Aggregator where 69 | Aggregator x1 +++! Aggregator x2 = Aggregator (x1 PP.+++! x2) 70 | 71 | -- } 72 | -------------------------------------------------------------------------------- /src/Opaleye/MaybeFields.hs: -------------------------------------------------------------------------------- 1 | -- | 'MaybeFields' is Opaleye's analogue to 'Data.Maybe.Maybe'. You 2 | -- probably won't want to create values of type 'MaybeFields' 3 | -- directly; instead they will appear as the result of 4 | -- left\/right\/outer join-like operations, such as 5 | -- 'Opaleye.Join.optionalRestrict' and 'Opaleye.Join.optional'. 6 | 7 | module Opaleye.MaybeFields ( 8 | -- * 'MaybeFields' type 9 | MaybeFields, 10 | -- * Creating a 'MaybeFields' 11 | nothingFields, 12 | nothingFieldsOfTypeOf, 13 | justFields, 14 | nullableToMaybeFields, 15 | -- * Using a 'MaybeFields' 16 | matchMaybe, 17 | fromMaybeFields, 18 | maybeFields, 19 | maybeFieldsToNullable, 20 | isJustAnd, 21 | -- * Creating a 'Select' which returns 'MaybeFields' 22 | Opaleye.Join.optional, 23 | Opaleye.MaybeFields.traverseMaybeFields, 24 | -- * Using a 'Select' which returns 'MaybeFields' 25 | catMaybeFields, 26 | maybeFieldsToSelect, 27 | -- * Adaptors 28 | Nullspec, 29 | nullspecField, 30 | nullspecMaybeFields, 31 | nullspecList, 32 | nullspecEitherLeft, 33 | nullspecEitherRight, 34 | binaryspecMaybeFields, 35 | distinctspecMaybeFields, 36 | fromFieldsMaybeFields, 37 | toFieldsMaybeFields, 38 | unpackspecMaybeFields, 39 | valuesspecMaybeFields, 40 | -- * Explicit versions 41 | nothingFieldsExplicit, 42 | fromMaybeFieldsExplicit, 43 | maybeFieldsExplicit, 44 | Opaleye.Join.optionalExplicit, 45 | traverseMaybeFieldsExplicit, 46 | ) where 47 | 48 | import Opaleye.Internal.Distinct 49 | import Opaleye.Internal.MaybeFields 50 | import Opaleye.Internal.Values 51 | import Opaleye.Join 52 | import Opaleye.Internal.Unpackspec 53 | import Opaleye.Select 54 | 55 | import Data.Profunctor.Product.Default 56 | 57 | -- | 'traverseMaybeFields' is analogous to Haskell's 58 | -- @'Data.Traversable.traverse' :: (a -> [b]) -> 'Data.Maybe.Maybe' a 59 | -- -> ['Data.Maybe.Maybe' b]@. In particular, 60 | -- 'Data.Traversable.traverse' has the following definition that 61 | -- generalises to 'traverseMaybeFields': 62 | -- 63 | -- * @traverse _ Nothing = pure Nothing@ 64 | -- * @traverse f (Just x) = fmap Just (f x)@ 65 | traverseMaybeFields :: (Default Unpackspec a a, Default Unpackspec b b) 66 | => SelectArr a b 67 | -- ^ 68 | -> SelectArr (MaybeFields a) (MaybeFields b) 69 | -- ^ ͘ 70 | traverseMaybeFields = Opaleye.Internal.MaybeFields.traverseMaybeFields 71 | 72 | -- The Unpackspecs are currently redundant, but I'm adding them in 73 | -- case they become necessary in the future. Then we can use them 74 | -- without breaking the API. 75 | traverseMaybeFieldsExplicit :: Unpackspec a a 76 | -> Unpackspec b b 77 | -> SelectArr a b 78 | -> SelectArr (MaybeFields a) (MaybeFields b) 79 | traverseMaybeFieldsExplicit _ _ = 80 | Opaleye.Internal.MaybeFields.traverseMaybeFields 81 | -------------------------------------------------------------------------------- /opaleye-sqlite/Doc/Tutorial/TutorialAdvanced.lhs: -------------------------------------------------------------------------------- 1 | > {-# LANGUAGE FlexibleContexts #-} 2 | > 3 | > module TutorialAdvanced where 4 | > 5 | > import Prelude hiding (sum) 6 | > 7 | > import Opaleye.SQLite.QueryArr (Query) 8 | > import Opaleye.SQLite.Column (Column) 9 | > import Opaleye.SQLite.Table (Table(Table), required, queryTable) 10 | > import Opaleye.SQLite.PGTypes (PGText, PGInt4) 11 | > import qualified Opaleye.SQLite.Aggregate as A 12 | > import Opaleye.SQLite.Aggregate (Aggregator, aggregate) 13 | > 14 | > import qualified Opaleye.SQLite.Sql as Sql 15 | > import qualified Opaleye.SQLite.Internal.Unpackspec as U 16 | > 17 | > import Data.Profunctor.Product.Default (Default) 18 | > import Data.Profunctor (dimap) 19 | > import Data.Profunctor.Product ((***!), p2) 20 | 21 | 22 | Combining Aggregators 23 | ===================== 24 | 25 | Opaleye allows you to straightforwardly combine aggregators to create 26 | new aggregators in a way that is inconvenient to do directly in 27 | Postgres. 28 | 29 | We can define an aggregator to calculate the range of a group, that is 30 | the difference between its maximum and minimum. Although we can write 31 | this easily in SQL as `MAX(column) - MIN(column)`, Opaleye has the 32 | advantage of treating `range` as a first-class value able to be passed 33 | around between functions and manipulated at will. 34 | 35 | > range :: Aggregator (Column PGInt4) (Column PGInt4) 36 | > range = dimap (\x -> (x, x)) (uncurry (-)) (A.max ***! A.min) 37 | 38 | We can test it on a person table which contains rows containing 39 | people's names along with the age of their children. 40 | 41 | > personTable :: Table (Column PGText, Column PGInt4) 42 | > (Column PGText, Column PGInt4) 43 | > personTable = Table "personTable" (p2 ( required "name" 44 | > , required "child_age" )) 45 | 46 | > rangeOfChildrensAges :: Query (Column PGText, Column PGInt4) 47 | > rangeOfChildrensAges = aggregate (p2 (A.groupBy, range)) (queryTable personTable) 48 | 49 | 50 | TutorialAdvanced> printSql rangeOfChildrensAges 51 | SELECT result0_2 as result1, 52 | (result1_2) - (result2_2) as result2 53 | FROM (SELECT * 54 | FROM (SELECT name0_1 as result0_2, 55 | MAX(child_age1_1) as result1_2, 56 | MIN(child_age1_1) as result2_2 57 | FROM (SELECT * 58 | FROM (SELECT name as name0_1, 59 | child_age as child_age1_1 60 | FROM personTable as T1) as T1) as T1 61 | GROUP BY name0_1) as T1) as T1 62 | 63 | 64 | Idealised SQL: 65 | 66 | SELECT name, 67 | MAX(child_age) - MIN(child_age) 68 | FROM personTable 69 | GROUP BY name 70 | 71 | 72 | Helper function 73 | =============== 74 | 75 | > printSql :: Default U.Unpackspec a a => Query a -> IO () 76 | > printSql = putStrLn . Sql.showSqlForPostgres 77 | -------------------------------------------------------------------------------- /src/Opaleye/Internal/Binary.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | 3 | module Opaleye.Internal.Binary where 4 | 5 | import Opaleye.Internal.Column (Field_(Column), unColumn) 6 | import qualified Opaleye.Internal.Tag as T 7 | import qualified Opaleye.Internal.PackMap as PM 8 | import qualified Opaleye.Internal.QueryArr as Q 9 | import qualified Opaleye.Internal.PrimQuery as PQ 10 | 11 | import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ 12 | 13 | import Data.Profunctor (Profunctor, dimap) 14 | import Data.Profunctor.Product (ProductProfunctor) 15 | import qualified Data.Profunctor.Product as PP 16 | import Data.Profunctor.Product.Default (Default, def) 17 | 18 | import Control.Arrow ((***)) 19 | 20 | extractBinaryFields :: T.Tag -> (HPQ.PrimExpr, HPQ.PrimExpr) 21 | -> PM.PM [(HPQ.Symbol, (HPQ.PrimExpr, HPQ.PrimExpr))] 22 | HPQ.PrimExpr 23 | extractBinaryFields = PM.extractAttr "binary" 24 | 25 | newtype Binaryspec fields fields' = 26 | Binaryspec (PM.PackMap (HPQ.PrimExpr, HPQ.PrimExpr) HPQ.PrimExpr 27 | (fields, fields) fields') 28 | 29 | runBinaryspec :: Applicative f => Binaryspec columns columns' 30 | -> ((HPQ.PrimExpr, HPQ.PrimExpr) -> f HPQ.PrimExpr) 31 | -> (columns, columns) -> f columns' 32 | runBinaryspec (Binaryspec b) = PM.traversePM b 33 | 34 | binaryspecColumn :: Binaryspec (Field_ n a) (Field_ n a) 35 | binaryspecColumn = dimap unColumn Column (Binaryspec (PM.PackMap id)) 36 | 37 | sameTypeBinOpHelper :: PQ.BinOp -> Binaryspec columns columns' 38 | -> Q.Query columns -> Q.Query columns -> Q.Query columns' 39 | sameTypeBinOpHelper binop binaryspec q1 q2 = Q.productQueryArr $ do 40 | (columns1, primQuery1) <- Q.runSimpleSelect q1 41 | (columns2, primQuery2) <- Q.runSimpleSelect q2 42 | 43 | endTag <- T.fresh 44 | 45 | let (newColumns, pes) = 46 | PM.run (runBinaryspec binaryspec (extractBinaryFields endTag) 47 | (columns1, columns2)) 48 | 49 | newPrimQuery = PQ.Binary binop 50 | ( PQ.Rebind False (map (fmap fst) pes) primQuery1 51 | , PQ.Rebind False (map (fmap snd) pes) primQuery2 52 | ) 53 | 54 | pure (newColumns, newPrimQuery) 55 | 56 | 57 | instance Default Binaryspec (Field_ n a) (Field_ n a) where 58 | def = binaryspecColumn 59 | 60 | -- { 61 | 62 | -- Boilerplate instance definitions. Theoretically, these are derivable. 63 | 64 | instance Functor (Binaryspec a) where 65 | fmap f (Binaryspec g) = Binaryspec (fmap f g) 66 | 67 | instance Applicative (Binaryspec a) where 68 | pure = Binaryspec . pure 69 | Binaryspec f <*> Binaryspec x = Binaryspec (f <*> x) 70 | 71 | instance Profunctor Binaryspec where 72 | dimap f g (Binaryspec b) = Binaryspec (dimap (f *** f) g b) 73 | 74 | instance ProductProfunctor Binaryspec where 75 | purePP = pure 76 | (****) = (<*>) 77 | 78 | -- } 79 | -------------------------------------------------------------------------------- /src/Opaleye/Internal/TypeFamilies.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE PolyKinds #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE TypeInType #-} 8 | 9 | -- TODO 10 | -- Updater -- easier -- this one's probably not needed 11 | -- NullMaker -- easier 12 | -- Constant -- harder 13 | -- QueryRunner -- harder 14 | 15 | module Opaleye.Internal.TypeFamilies where 16 | 17 | import Opaleye.Column (Column, Nullable) 18 | import qualified Opaleye.Field as F 19 | 20 | type family IMap f a 21 | 22 | data HT 23 | data OT 24 | data NullsT 25 | data WT 26 | 27 | -- | Used in 'RecordField' and 'TableRecordField' for a non-nullable 28 | -- field 29 | type NN = 'F.NonNullable 30 | -- | Used in 'RecordField' and 'TableRecordField' for a nullable field 31 | type N = 'F.Nullable 32 | 33 | data Optionality = OReq | OOpt 34 | 35 | -- | 'TableRecordField' for a required field 36 | type Req = 'OReq 37 | -- | 'TableRecordField' for an optional field 38 | type Opt = 'OOpt 39 | 40 | type family A (a :: Arr h k1 k2) (b :: k1) :: k2 41 | 42 | data Arr h k1 k2 where 43 | K :: k1 -> Arr h k2 k1 44 | S :: Arr h k1 (k2 -> k3) 45 | -> Arr h k1 k2 46 | -> Arr h k1 k3 47 | I :: Arr h k1 k1 48 | H :: h -> Arr h k2 k3 49 | 50 | type (:<*>) = 'S 51 | type Pure = 'K 52 | type (:<$>) f = (:<*>) (Pure f) 53 | type Id = 'I 54 | type (:<|) f x = A f x 55 | 56 | type instance A 'I a = a 57 | type instance A ('K k1) _ = k1 58 | type instance A ('S f x) a = (A f a) (A x a) 59 | 60 | data C a = C (a, a, F.Nullability) 61 | data TC a = TC ((a, a, F.Nullability), Optionality) 62 | 63 | type instance A ('H HT) ('C '(h, o, NN)) = h 64 | type instance A ('H HT) ('C '(h, o, N)) = Maybe h 65 | type instance A ('H OT) ('C '(h, o, NN)) = Column o 66 | type instance A ('H OT) ('C '(h, o, N)) = Column (Nullable o) 67 | type instance A ('H NullsT) ('C '(h, o, n)) = Column (Nullable o) 68 | 69 | type instance A ('H HT) ('TC '(t, b)) = A ('H HT) ('C t) 70 | type instance A ('H OT) ('TC '(t, b)) = A ('H OT) ('C t) 71 | type instance A ('H WT) ('TC '(t, Req)) = A ('H OT) ('C t) 72 | type instance A ('H WT) ('TC '(t, Opt)) = Maybe (A ('H OT) ('C t)) 73 | type instance A ('H NullsT) ('TC '(t, b)) = A ('H NullsT) ('C t) 74 | 75 | type RecordField f a b c = A f ('C '(a, b, c)) 76 | type TableRecordField f a b c d = A f ('TC '( '(a, b, c), d)) 77 | 78 | -- | Type families parameter for Haskell types ('String', 'Int', etc.) 79 | type H = 'H HT 80 | -- | Type families parameter for Opaleye types ('Opaleye.Field.Field' 81 | -- 'Opaleye.SqlString', 'Opaleye.Field.Field' 'Opaleye.SqlInt4', etc.) 82 | type O = 'H OT 83 | -- | Type families parameter for nulled Opaleye types 84 | -- ('Opaleye.Field.FieldNullable' 'Opaleye.SqlString', 85 | -- 'Opaleye.Field.FieldNullable' 'Opaleye.SqlInt4', etc.) 86 | type Nulls = 'H NullsT 87 | -- | Type families parameter for Opaleye write types (i.e. wrapped in 88 | -- 'Maybe' for optional types) 89 | type W = 'H WT 90 | type F = 'H 91 | -------------------------------------------------------------------------------- /src/Opaleye/Internal/RunQueryExternal.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | 3 | module Opaleye.Internal.RunQueryExternal 4 | (module Opaleye.Internal.RunQueryExternal, 5 | -- * Datatypes 6 | IRQ.Cursor, 7 | IRQ.FromFields, 8 | IRQ.FromField, 9 | ) where 10 | 11 | import qualified Database.PostgreSQL.Simple as PGS 12 | import qualified Database.PostgreSQL.Simple.Cursor as PGSC 13 | 14 | import qualified Opaleye.Select as S 15 | import Opaleye.Internal.RunQuery (prepareQuery) 16 | import qualified Opaleye.Internal.RunQuery as IRQ 17 | 18 | import qualified Data.Profunctor.Product.Default as D 19 | 20 | -- * Running 'S.Select's 21 | 22 | runQuery :: D.Default IRQ.FromFields fields haskells 23 | => PGS.Connection 24 | -> S.Select fields 25 | -> IO [haskells] 26 | runQuery = runQueryExplicit D.def 27 | 28 | runQueryFold 29 | :: D.Default IRQ.FromFields fields haskells 30 | => PGS.Connection 31 | -> S.Select fields 32 | -> b 33 | -> (b -> haskells -> IO b) 34 | -> IO b 35 | runQueryFold = runQueryFoldExplicit D.def 36 | 37 | -- * Explicit versions 38 | 39 | runQueryExplicit :: IRQ.FromFields fields haskells 40 | -> PGS.Connection 41 | -> S.Select fields 42 | -> IO [haskells] 43 | runQueryExplicit qr conn q = maybe (return []) (PGS.queryWith_ parser conn) sql 44 | where (sql, parser) = IRQ.prepareQuery qr q 45 | 46 | runQueryFoldExplicit 47 | :: IRQ.FromFields fields haskells 48 | -> PGS.Connection 49 | -> S.Select fields 50 | -> b 51 | -> (b -> haskells -> IO b) 52 | -> IO b 53 | runQueryFoldExplicit qr conn q z f = case sql of 54 | Nothing -> return z 55 | Just sql' -> PGS.foldWith_ parser conn sql' z f 56 | where (sql, parser) = prepareQuery qr q 57 | 58 | -- * Cursor interface 59 | 60 | declareCursor 61 | :: D.Default IRQ.FromFields fields haskells 62 | => PGS.Connection 63 | -> S.Select fields 64 | -> IO (IRQ.Cursor haskells) 65 | declareCursor = declareCursorExplicit D.def 66 | 67 | declareCursorExplicit 68 | :: IRQ.FromFields fields haskells 69 | -> PGS.Connection 70 | -> S.Select fields 71 | -> IO (IRQ.Cursor haskells) 72 | declareCursorExplicit qr conn q = 73 | case mbQuery of 74 | Nothing -> pure IRQ.EmptyCursor 75 | Just query -> IRQ.Cursor rowParser <$> PGSC.declareCursor conn query 76 | where 77 | (mbQuery, rowParser) = prepareQuery qr q 78 | 79 | closeCursor :: IRQ.Cursor fields -> IO () 80 | closeCursor IRQ.EmptyCursor = pure () 81 | closeCursor (IRQ.Cursor _ cursor) = PGSC.closeCursor cursor 82 | 83 | foldForward 84 | :: IRQ.Cursor haskells 85 | -> Int 86 | -> (a -> haskells -> IO a) 87 | -> a 88 | -> IO (Either a a) 89 | foldForward IRQ.EmptyCursor _chunkSize _f z = pure $ Left z 90 | foldForward (IRQ.Cursor rowParser cursor) chunkSize f z = 91 | PGSC.foldForwardWithParser cursor rowParser chunkSize f z 92 | -------------------------------------------------------------------------------- /opaleye-sqlite/src/Opaleye/SQLite/Internal/PrimQuery.hs: -------------------------------------------------------------------------------- 1 | module Opaleye.SQLite.Internal.PrimQuery where 2 | 3 | import Prelude hiding (product) 4 | 5 | import qualified Data.List.NonEmpty as NEL 6 | import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as HPQ 7 | import Opaleye.SQLite.Internal.HaskellDB.PrimQuery (Symbol) 8 | 9 | data LimitOp = LimitOp Int | OffsetOp Int | LimitOffsetOp Int Int 10 | deriving Show 11 | 12 | data BinOp = Except | Union | UnionAll deriving Show 13 | data JoinType = LeftJoin deriving Show 14 | 15 | -- In the future it may make sense to introduce this datatype 16 | -- type Bindings a = [(Symbol, a)] 17 | 18 | -- We use a 'NEL.NonEmpty' for Product because otherwise we'd have to check 19 | -- for emptiness explicitly in the SQL generation phase. 20 | data PrimQuery = Unit 21 | | BaseTable String [(Symbol, HPQ.PrimExpr)] 22 | | Product (NEL.NonEmpty PrimQuery) [HPQ.PrimExpr] 23 | | Aggregate [(Symbol, (Maybe HPQ.AggrOp, HPQ.PrimExpr))] PrimQuery 24 | | Order [HPQ.OrderExpr] PrimQuery 25 | | Limit LimitOp PrimQuery 26 | | Join JoinType HPQ.PrimExpr PrimQuery PrimQuery 27 | | Values [Symbol] [[HPQ.PrimExpr]] 28 | | Binary BinOp [(Symbol, (HPQ.PrimExpr, HPQ.PrimExpr))] (PrimQuery, PrimQuery) 29 | deriving Show 30 | 31 | type PrimQueryFold p = ( p 32 | , String -> [(Symbol, HPQ.PrimExpr)] -> p 33 | , NEL.NonEmpty p -> [HPQ.PrimExpr] -> p 34 | , [(Symbol, (Maybe HPQ.AggrOp, HPQ.PrimExpr))] -> p -> p 35 | , [HPQ.OrderExpr] -> p -> p 36 | , LimitOp -> p -> p 37 | , JoinType -> HPQ.PrimExpr -> p -> p -> p 38 | , [Symbol] -> [[HPQ.PrimExpr]] -> p 39 | , BinOp -> [(Symbol, (HPQ.PrimExpr, HPQ.PrimExpr))] -> (p, p) -> p 40 | ) 41 | 42 | foldPrimQuery :: PrimQueryFold p -> PrimQuery -> p 43 | foldPrimQuery (unit, baseTable, product, aggregate, order, limit, join, values, 44 | binary) = fix fold 45 | where fold self primQ = case primQ of 46 | Unit -> unit 47 | BaseTable n s -> baseTable n s 48 | Product pqs pes -> product (fmap self pqs) pes 49 | Aggregate aggrs pq -> aggregate aggrs (self pq) 50 | Order pes pq -> order pes (self pq) 51 | Limit op pq -> limit op (self pq) 52 | Join j cond q1 q2 -> join j cond (self q1) (self q2) 53 | Values ss pes -> values ss pes 54 | Binary binop pes (pq, pq') -> binary binop pes (self pq, self pq') 55 | fix f = let x = f x in x 56 | 57 | times :: PrimQuery -> PrimQuery -> PrimQuery 58 | times q q' = Product (q NEL.:| [q']) [] 59 | 60 | restrict :: HPQ.PrimExpr -> PrimQuery -> PrimQuery 61 | restrict cond primQ = Product (return primQ) [cond] 62 | 63 | isUnit :: PrimQuery -> Bool 64 | isUnit Unit = True 65 | isUnit _ = False 66 | -------------------------------------------------------------------------------- /opaleye-sqlite/src/Opaleye/SQLite/Order.hs: -------------------------------------------------------------------------------- 1 | module Opaleye.SQLite.Order (module Opaleye.SQLite.Order, O.Order) where 2 | 3 | import qualified Opaleye.SQLite.Column as C 4 | import Opaleye.SQLite.QueryArr (Query) 5 | import qualified Opaleye.SQLite.Internal.QueryArr as Q 6 | import qualified Opaleye.SQLite.Internal.Order as O 7 | import qualified Opaleye.SQLite.PGTypes as T 8 | 9 | import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as HPQ 10 | 11 | {-| Order the rows of a `Query` according to the `Order`. 12 | 13 | @ 14 | import Data.Monoid (\<\>) 15 | 16 | \-- Order by the first column ascending. When first columns are equal 17 | \-- order by second column descending. 18 | example :: 'Query' ('C.Column' 'T.PGInt4', 'C.Column' 'T.PGText') 19 | -> 'Query' ('C.Column' 'T.PGInt4', 'C.Column' 'T.PGText') 20 | example = 'orderBy' ('asc' fst \<\> 'desc' snd) 21 | @ 22 | 23 | -} 24 | orderBy :: O.Order a -> Query a -> Query a 25 | orderBy os q = 26 | Q.simpleQueryArr (O.orderByU os . Q.runSimpleQueryArr q) 27 | 28 | -- | Specify an ascending ordering by the given expression. 29 | -- (Any NULLs appear last) 30 | asc :: PGOrd b => (a -> C.Column b) -> O.Order a 31 | asc = O.order HPQ.OrderOp { HPQ.orderDirection = HPQ.OpAsc 32 | , HPQ.orderNulls = HPQ.NullsLast } 33 | 34 | -- | Specify an descending ordering by the given expression. 35 | -- (Any NULLs appear first) 36 | desc :: PGOrd b => (a -> C.Column b) -> O.Order a 37 | desc = O.order HPQ.OrderOp { HPQ.orderDirection = HPQ.OpDesc 38 | , HPQ.orderNulls = HPQ.NullsFirst } 39 | 40 | -- | Specify an ascending ordering by the given expression. 41 | -- (Any NULLs appear first) 42 | ascNullsFirst :: PGOrd b => (a -> C.Column b) -> O.Order a 43 | ascNullsFirst = O.order HPQ.OrderOp { HPQ.orderDirection = HPQ.OpAsc 44 | , HPQ.orderNulls = HPQ.NullsFirst } 45 | 46 | 47 | -- | Specify an descending ordering by the given expression. 48 | -- (Any NULLs appear last) 49 | descNullsLast :: PGOrd b => (a -> C.Column b) -> O.Order a 50 | descNullsLast = O.order HPQ.OrderOp { HPQ.orderDirection = HPQ.OpDesc 51 | , HPQ.orderNulls = HPQ.NullsLast } 52 | 53 | {- | 54 | Limit the results of the given query to the given maximum number of 55 | items. 56 | -} 57 | limit :: Int -> Query a -> Query a 58 | limit n a = Q.simpleQueryArr (O.limit' n . Q.runSimpleQueryArr a) 59 | 60 | {- | 61 | Offset the results of the given query by the given amount, skipping 62 | that many result rows. 63 | -} 64 | offset :: Int -> Query a -> Query a 65 | offset n a = Q.simpleQueryArr (O.offset' n . Q.runSimpleQueryArr a) 66 | 67 | -- | Typeclass for Postgres types which support ordering operations. 68 | class PGOrd a where 69 | 70 | instance PGOrd T.PGBool 71 | instance PGOrd T.PGDate 72 | instance PGOrd T.PGFloat8 73 | instance PGOrd T.PGFloat4 74 | instance PGOrd T.PGInt8 75 | instance PGOrd T.PGInt4 76 | instance PGOrd T.PGInt2 77 | instance PGOrd T.PGNumeric 78 | instance PGOrd T.PGText 79 | instance PGOrd T.PGTime 80 | instance PGOrd T.PGTimestamptz 81 | instance PGOrd T.PGTimestamp 82 | instance PGOrd T.PGCitext 83 | -------------------------------------------------------------------------------- /src/Opaleye/Internal/Unpackspec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | 3 | module Opaleye.Internal.Unpackspec where 4 | 5 | import qualified Opaleye.Internal.PackMap as PM 6 | import qualified Opaleye.Internal.Column as IC 7 | import qualified Opaleye.Field as F 8 | 9 | import Data.Profunctor (Profunctor, dimap) 10 | import Data.Profunctor.Product (ProductProfunctor) 11 | import qualified Data.Profunctor.Product as PP 12 | import qualified Data.Profunctor.Product.Default as D 13 | 14 | import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ 15 | 16 | newtype Unpackspec fields fields' = 17 | -- | An 'Unpackspec' @fields@ @fields'@ allows you to extract and 18 | -- modify a sequence of 'HPQ.PrimExpr's inside a value of type 19 | -- @fields@. 20 | -- 21 | -- For example, the 'Default' instance of type 'Unpackspec' @(Field 22 | -- a, Field b)@ @(Field a, Field b)@ allows you to manipulate or 23 | -- extract the two 'HPQ.PrimExpr's inside a @(Field a, Field b)@. The 24 | -- 'Default' instance of type @Foo (Field a) (Field b) (Field c)@ 25 | -- will allow you to manipulate or extract the three 'HPQ.PrimExpr's 26 | -- contained therein (for a user-defined product type @Foo@, assuming 27 | -- the @makeAdaptorAndInstanceInferrable@ splice from 28 | -- @Data.Profunctor.Product.TH@ has been run). 29 | -- 30 | -- Users should almost never need to create or manipulate 31 | -- `Unpackspec`s. Typically they will be created automatically by 32 | -- the 'D.Default' instance. If you really need to you can create 33 | -- 'Unpackspec's by hand using 'unpackspecField' and the 34 | -- 'Profunctor', 'ProductProfunctor' and 'SumProfunctor' operations. 35 | Unpackspec (PM.PackMap HPQ.PrimExpr HPQ.PrimExpr fields fields') 36 | 37 | -- | Target the single 'HPQ.PrimExpr' inside a 'F.Field n' 38 | unpackspecField :: Unpackspec (F.Field_ n a) (F.Field_ n a) 39 | unpackspecField = dimap IC.unColumn IC.Column (Unpackspec (PM.PackMap id)) 40 | 41 | -- | Modify all the targeted 'HPQ.PrimExpr's 42 | runUnpackspec :: Applicative f 43 | => Unpackspec columns b 44 | -> (HPQ.PrimExpr -> f HPQ.PrimExpr) 45 | -> columns -> f b 46 | runUnpackspec (Unpackspec f) = PM.traversePM f 47 | 48 | -- | Extract all the targeted 'HPQ.PrimExpr's 49 | collectPEs :: Unpackspec s t -> s -> [HPQ.PrimExpr] 50 | collectPEs unpackspec = fst . runUnpackspec unpackspec f 51 | where f pe = ([pe], pe) 52 | 53 | instance D.Default Unpackspec (F.Field_ n a) (F.Field_ n a) where 54 | def = unpackspecField 55 | 56 | -- { 57 | 58 | -- Boilerplate instance definitions. Theoretically, these are derivable. 59 | 60 | instance Functor (Unpackspec a) where 61 | fmap f (Unpackspec g) = Unpackspec (fmap f g) 62 | 63 | instance Applicative (Unpackspec a) where 64 | pure = Unpackspec . pure 65 | Unpackspec f <*> Unpackspec x = Unpackspec (f <*> x) 66 | 67 | instance Profunctor Unpackspec where 68 | dimap f g (Unpackspec q) = Unpackspec (dimap f g q) 69 | 70 | instance ProductProfunctor Unpackspec where 71 | purePP = pure 72 | (****) = (<*>) 73 | 74 | instance PP.SumProfunctor Unpackspec where 75 | Unpackspec x1 +++! Unpackspec x2 = Unpackspec (x1 PP.+++! x2) 76 | 77 | --} 78 | -------------------------------------------------------------------------------- /src/Opaleye/Internal/HaskellDB/Sql.hs: -------------------------------------------------------------------------------- 1 | -- Copyright : Daan Leijen (c) 1999, daan@cs.uu.nl 2 | -- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net 3 | -- License : BSD-style 4 | 5 | module Opaleye.Internal.HaskellDB.Sql where 6 | 7 | 8 | import qualified Data.List.NonEmpty as NEL 9 | 10 | ----------------------------------------------------------- 11 | -- * SQL data type 12 | ----------------------------------------------------------- 13 | 14 | data SqlTable = SqlTable 15 | { sqlTableSchemaName :: Maybe String 16 | , sqlTableName :: String 17 | } deriving Show 18 | 19 | newtype SqlColumn = SqlColumn String deriving Show 20 | 21 | -- | A valid SQL name for a parameter. 22 | type SqlName = String 23 | 24 | data SqlOrderNulls = SqlNullsFirst | SqlNullsLast 25 | deriving Show 26 | 27 | data SqlOrderDirection = SqlAsc | SqlDesc 28 | deriving Show 29 | 30 | data SqlOrder = SqlOrder { sqlOrderDirection :: SqlOrderDirection 31 | , sqlOrderNulls :: SqlOrderNulls } 32 | deriving Show 33 | 34 | 35 | data SqlPartition = SqlPartition 36 | { sqlPartitionBy :: Maybe (NEL.NonEmpty SqlExpr) 37 | , sqlOrderBy :: Maybe (NEL.NonEmpty (SqlExpr, SqlOrder)) 38 | } 39 | deriving Show 40 | 41 | data SqlRangeBound = Inclusive SqlExpr | Exclusive SqlExpr | PosInfinity | NegInfinity 42 | deriving Show 43 | 44 | data SqlDistinct = SqlDistinct | SqlNotDistinct 45 | deriving Show 46 | 47 | -- | Expressions in SQL statements. 48 | data SqlExpr = ColumnSqlExpr SqlColumn 49 | | CompositeSqlExpr SqlExpr String 50 | | BinSqlExpr String SqlExpr SqlExpr 51 | | SubscriptSqlExpr SqlExpr SqlExpr 52 | | PrefixSqlExpr String SqlExpr 53 | | PostfixSqlExpr String SqlExpr 54 | | FunSqlExpr String [SqlExpr] 55 | | AggrFunSqlExpr String [SqlExpr] [(SqlExpr, SqlOrder)] SqlDistinct [(SqlExpr, SqlOrder)] (Maybe SqlExpr) -- ^ Aggregate functions separate from normal functions. 56 | | WndwFunSqlExpr String [SqlExpr] SqlPartition 57 | | ConstSqlExpr String 58 | | CaseSqlExpr (NEL.NonEmpty (SqlExpr,SqlExpr)) SqlExpr 59 | | ListSqlExpr (NEL.NonEmpty SqlExpr) 60 | | ParamSqlExpr (Maybe SqlName) SqlExpr 61 | | PlaceHolderSqlExpr 62 | | ParensSqlExpr SqlExpr 63 | | CastSqlExpr String SqlExpr 64 | | DefaultSqlExpr 65 | | ArraySqlExpr [SqlExpr] 66 | | RangeSqlExpr String SqlRangeBound SqlRangeBound 67 | deriving Show 68 | 69 | -- | Data type for SQL UPDATE statements. 70 | data SqlUpdate = SqlUpdate SqlTable [(SqlColumn,SqlExpr)] [SqlExpr] 71 | 72 | -- | Data type for SQL DELETE statements. 73 | data SqlDelete = SqlDelete SqlTable [SqlExpr] 74 | 75 | {-# DEPRECATED DoNothing "Use 'doNothing' instead. @DoNothing@ will be removed in version 0.11" #-} 76 | -- It won't be removed, it will just be made internal 77 | data OnConflict = DoNothing 78 | -- ^ @ON CONFLICT DO NOTHING@ 79 | 80 | --- | Data type for SQL INSERT statements. 81 | data SqlInsert = SqlInsert SqlTable [SqlColumn] (NEL.NonEmpty [SqlExpr]) (Maybe OnConflict) 82 | -------------------------------------------------------------------------------- /opaleye-sqlite/src/Opaleye/SQLite/Internal/TableMaker.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} 2 | 3 | module Opaleye.SQLite.Internal.TableMaker where 4 | 5 | import qualified Opaleye.SQLite.Column as C 6 | import qualified Opaleye.SQLite.Internal.Column as IC 7 | import qualified Opaleye.SQLite.Internal.PackMap as PM 8 | 9 | import Data.Profunctor (Profunctor, dimap) 10 | import Data.Profunctor.Product (ProductProfunctor, empty, (***!)) 11 | import qualified Data.Profunctor.Product as PP 12 | import Data.Profunctor.Product.Default (Default, def) 13 | 14 | import Control.Applicative (Applicative, pure, (<*>)) 15 | 16 | import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as HPQ 17 | 18 | 19 | -- If we switch to a more lens-like approach to PackMap this should be 20 | -- the equivalent of a Setter 21 | newtype ViewColumnMaker strings columns = 22 | ViewColumnMaker (PM.PackMap () () strings columns) 23 | 24 | newtype ColumnMaker columns columns' = 25 | ColumnMaker (PM.PackMap HPQ.PrimExpr HPQ.PrimExpr columns columns') 26 | 27 | runViewColumnMaker :: ViewColumnMaker strings tablecolumns -> 28 | strings -> tablecolumns 29 | runViewColumnMaker (ViewColumnMaker f) = PM.overPM f id 30 | 31 | runColumnMaker :: Applicative f 32 | => ColumnMaker tablecolumns columns 33 | -> (HPQ.PrimExpr -> f HPQ.PrimExpr) 34 | -> tablecolumns -> f columns 35 | runColumnMaker (ColumnMaker f) = PM.traversePM f 36 | 37 | -- There's surely a way of simplifying this implementation 38 | tableColumn :: ViewColumnMaker String (C.Column a) 39 | tableColumn = ViewColumnMaker 40 | (PM.PackMap (\f s -> fmap (const (mkColumn s)) (f ()))) 41 | where mkColumn = IC.Column . HPQ.BaseTableAttrExpr 42 | 43 | column :: ColumnMaker (C.Column a) (C.Column a) 44 | column = ColumnMaker 45 | (PM.PackMap (\f (IC.Column s) 46 | -> fmap IC.Column (f s))) 47 | 48 | instance Default ViewColumnMaker String (C.Column a) where 49 | def = tableColumn 50 | 51 | instance Default ColumnMaker (C.Column a) (C.Column a) where 52 | def = column 53 | 54 | -- { 55 | 56 | -- Boilerplate instance definitions. Theoretically, these are derivable. 57 | 58 | instance Functor (ViewColumnMaker a) where 59 | fmap f (ViewColumnMaker g) = ViewColumnMaker (fmap f g) 60 | 61 | instance Applicative (ViewColumnMaker a) where 62 | pure = ViewColumnMaker . pure 63 | ViewColumnMaker f <*> ViewColumnMaker x = ViewColumnMaker (f <*> x) 64 | 65 | instance Profunctor ViewColumnMaker where 66 | dimap f g (ViewColumnMaker q) = ViewColumnMaker (dimap f g q) 67 | 68 | instance ProductProfunctor ViewColumnMaker where 69 | empty = PP.defaultEmpty 70 | (***!) = PP.defaultProfunctorProduct 71 | 72 | instance Functor (ColumnMaker a) where 73 | fmap f (ColumnMaker g) = ColumnMaker (fmap f g) 74 | 75 | instance Applicative (ColumnMaker a) where 76 | pure = ColumnMaker . pure 77 | ColumnMaker f <*> ColumnMaker x = ColumnMaker (f <*> x) 78 | 79 | instance Profunctor ColumnMaker where 80 | dimap f g (ColumnMaker q) = ColumnMaker (dimap f g q) 81 | 82 | instance ProductProfunctor ColumnMaker where 83 | empty = PP.defaultEmpty 84 | (***!) = PP.defaultProfunctorProduct 85 | 86 | --} 87 | -------------------------------------------------------------------------------- /opaleye-sqlite/src/Opaleye/SQLite/Internal/HaskellDB/PrimQuery.hs: -------------------------------------------------------------------------------- 1 | -- Copyright : Daan Leijen (c) 1999, daan@cs.uu.nl 2 | -- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net 3 | -- License : BSD-style 4 | 5 | module Opaleye.SQLite.Internal.HaskellDB.PrimQuery where 6 | 7 | import qualified Opaleye.SQLite.Internal.Tag as T 8 | import Data.ByteString (ByteString) 9 | 10 | type TableName = String 11 | type Attribute = String 12 | type Name = String 13 | type Scheme = [Attribute] 14 | type Assoc = [(Attribute,PrimExpr)] 15 | 16 | data Symbol = Symbol String T.Tag deriving (Read, Show) 17 | 18 | data PrimExpr = AttrExpr Symbol 19 | | BaseTableAttrExpr Attribute 20 | | BinExpr BinOp PrimExpr PrimExpr 21 | | UnExpr UnOp PrimExpr 22 | | AggrExpr AggrOp PrimExpr 23 | | ConstExpr Literal 24 | | CaseExpr [(PrimExpr,PrimExpr)] PrimExpr 25 | | ListExpr [PrimExpr] 26 | | ParamExpr (Maybe Name) PrimExpr 27 | | FunExpr Name [PrimExpr] 28 | | CastExpr Name PrimExpr -- ^ Cast an expression to a given type. 29 | | DefaultInsertExpr -- Indicate that we want to insert the 30 | -- default value into a column. 31 | -- TODO: I'm not sure this belongs 32 | -- here. Perhaps a special type is 33 | -- needed for insert expressions. 34 | deriving (Read,Show) 35 | 36 | data Literal = NullLit 37 | | DefaultLit -- ^ represents a default value 38 | | BoolLit Bool 39 | | StringLit String 40 | | ByteStringLit ByteString 41 | | IntegerLit Integer 42 | | DoubleLit Double 43 | | OtherLit String -- ^ used for hacking in custom SQL 44 | deriving (Read,Show) 45 | 46 | data BinOp = OpEq | OpLt | OpLtEq | OpGt | OpGtEq | OpNotEq 47 | | OpAnd | OpOr 48 | | OpLike | OpIn 49 | | OpOther String 50 | 51 | | OpCat 52 | | OpPlus | OpMinus | OpMul | OpDiv | OpMod 53 | | OpBitNot | OpBitAnd | OpBitOr | OpBitXor 54 | | OpAsg 55 | deriving (Show,Read) 56 | 57 | data UnOp = OpNot 58 | | OpIsNull 59 | | OpIsNotNull 60 | | OpLength 61 | | OpAbs 62 | | OpNegate 63 | | OpLower 64 | | OpUpper 65 | | UnOpOther String 66 | deriving (Show,Read) 67 | 68 | data AggrOp = AggrCount | AggrSum | AggrAvg | AggrMin | AggrMax 69 | | AggrStdDev | AggrStdDevP | AggrVar | AggrVarP 70 | | AggrBoolOr | AggrBoolAnd | AggrArr | AggrStringAggr PrimExpr 71 | | AggrOther String 72 | deriving (Show,Read) 73 | 74 | data OrderExpr = OrderExpr OrderOp PrimExpr 75 | deriving (Show) 76 | 77 | data OrderNulls = NullsFirst | NullsLast 78 | deriving Show 79 | 80 | data OrderDirection = OpAsc | OpDesc 81 | deriving Show 82 | 83 | data OrderOp = OrderOp { orderDirection :: OrderDirection 84 | , orderNulls :: OrderNulls } 85 | deriving (Show) 86 | -------------------------------------------------------------------------------- /opaleye-sqlite/src/Opaleye/SQLite/Internal/Unpackspec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} 2 | 3 | module Opaleye.SQLite.Internal.Unpackspec where 4 | 5 | import qualified Opaleye.SQLite.Internal.PackMap as PM 6 | import qualified Opaleye.SQLite.Internal.Column as IC 7 | import qualified Opaleye.SQLite.Column as C 8 | 9 | import Control.Applicative (Applicative, pure, (<*>)) 10 | import Data.Profunctor (Profunctor, dimap) 11 | import Data.Profunctor.Product (ProductProfunctor, empty, (***!)) 12 | import qualified Data.Profunctor.Product as PP 13 | import qualified Data.Profunctor.Product.Default as D 14 | 15 | import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as HPQ 16 | 17 | newtype Unpackspec columns columns' = 18 | -- | An 'Unpackspec' @columns@ @columns'@ allows you to extract and 19 | -- modify a sequence of 'HPQ.PrimExpr's inside a value of type 20 | -- @columns@. 21 | -- 22 | -- For example, the 'Default' instance of type 'Unpackspec' @(Column 23 | -- a, Column b)@ @(Column a, Column b)@ allows you to manipulate or 24 | -- extract the two 'HPQ.PrimExpr's inside a @(Column a, Column b)@. The 25 | -- 'Default' instance of type @Foo (Column a) (Column b) (Column c)@ 26 | -- will allow you to manipulate or extract the three 'HPQ.PrimExpr's 27 | -- contained therein (for a user-defined product type @Foo@, assuming 28 | -- the @makeAdaptorAndInstance@ splice from 29 | -- @Data.Profunctor.Product.TH@ has been run). 30 | -- 31 | -- You can create 'Unpackspec's by hand using 'unpackspecColumn' and 32 | -- the 'Profunctor', 'ProductProfunctor' and 'SumProfunctor' 33 | -- operations. However, in practice users should almost never need 34 | -- to create or manipulate them. Typically they will be created 35 | -- automatically by the 'D.Default' instance. 36 | Unpackspec (PM.PackMap HPQ.PrimExpr HPQ.PrimExpr columns columns') 37 | 38 | -- | Target the single 'HPQ.PrimExpr' inside a 'C.Column' 39 | unpackspecColumn :: Unpackspec (C.Column a) (C.Column a) 40 | unpackspecColumn = Unpackspec 41 | (PM.PackMap (\f (IC.Column pe) -> fmap IC.Column (f pe))) 42 | 43 | -- | Modify all the targeted 'HPQ.PrimExpr's 44 | runUnpackspec :: Applicative f 45 | => Unpackspec columns b 46 | -> (HPQ.PrimExpr -> f HPQ.PrimExpr) 47 | -> columns -> f b 48 | runUnpackspec (Unpackspec f) = PM.traversePM f 49 | 50 | -- | Extract all the targeted 'HPQ.PrimExpr's 51 | collectPEs :: Unpackspec s t -> s -> [HPQ.PrimExpr] 52 | collectPEs unpackspec = fst . runUnpackspec unpackspec f 53 | where f pe = ([pe], pe) 54 | 55 | instance D.Default Unpackspec (C.Column a) (C.Column a) where 56 | def = unpackspecColumn 57 | 58 | -- { 59 | 60 | -- Boilerplate instance definitions. Theoretically, these are derivable. 61 | 62 | instance Functor (Unpackspec a) where 63 | fmap f (Unpackspec g) = Unpackspec (fmap f g) 64 | 65 | instance Applicative (Unpackspec a) where 66 | pure = Unpackspec . pure 67 | Unpackspec f <*> Unpackspec x = Unpackspec (f <*> x) 68 | 69 | instance Profunctor Unpackspec where 70 | dimap f g (Unpackspec q) = Unpackspec (dimap f g q) 71 | 72 | instance ProductProfunctor Unpackspec where 73 | empty = PP.defaultEmpty 74 | (***!) = PP.defaultProfunctorProduct 75 | 76 | instance PP.SumProfunctor Unpackspec where 77 | Unpackspec x1 +++! Unpackspec x2 = Unpackspec (x1 PP.+++! x2) 78 | 79 | --} 80 | -------------------------------------------------------------------------------- /opaleye-sqlite/src/Opaleye/SQLite/RunQuery.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | module Opaleye.SQLite.RunQuery (module Opaleye.SQLite.RunQuery, 4 | QueryRunner, 5 | IRQ.QueryRunnerColumn, 6 | IRQ.fieldQueryRunnerColumn) where 7 | 8 | import qualified Database.SQLite.Simple as PGS 9 | import qualified Database.SQLite.Simple.FromRow as FR 10 | import qualified Data.String as String 11 | 12 | import Opaleye.SQLite.Column (Column) 13 | import qualified Opaleye.SQLite.Sql as S 14 | import Opaleye.SQLite.QueryArr (Query) 15 | import Opaleye.SQLite.Internal.RunQuery (QueryRunner(QueryRunner)) 16 | import qualified Opaleye.SQLite.Internal.RunQuery as IRQ 17 | import qualified Opaleye.SQLite.Internal.QueryArr as Q 18 | 19 | import qualified Data.Profunctor as P 20 | import qualified Data.Profunctor.Product.Default as D 21 | 22 | import Control.Applicative ((*>)) 23 | 24 | -- | @runQuery@'s use of the 'D.Default' typeclass means that the 25 | -- compiler will have trouble inferring types. It is strongly 26 | -- recommended that you provide full type signatures when using 27 | -- @runQuery@. 28 | -- 29 | -- Example type specialization: 30 | -- 31 | -- @ 32 | -- runQuery :: Query (Column 'Opaleye.PGTypes.PGInt4', Column 'Opaleye.PGTypes.PGText') -> IO [(Column Int, Column String)] 33 | -- @ 34 | -- 35 | -- Assuming the @makeAdaptorAndInstance@ splice has been run for the product type @Foo@: 36 | -- 37 | -- @ 38 | -- runQuery :: Query (Foo (Column 'Opaleye.PGTypes.PGInt4') (Column 'Opaleye.PGTypes.PGText') (Column 'Opaleye.PGTypes.PGBool') 39 | -- -> IO [(Foo (Column Int) (Column String) (Column Bool)] 40 | -- @ 41 | -- 42 | -- Opaleye types are converted to Haskell types based on instances of 43 | -- the 'Opaleye.Internal.RunQuery.QueryRunnerColumnDefault' typeclass. 44 | runQuery :: D.Default QueryRunner columns haskells 45 | => PGS.Connection 46 | -> Query columns 47 | -> IO [haskells] 48 | runQuery = runQueryExplicit D.def 49 | 50 | runQueryExplicit :: QueryRunner columns haskells 51 | -> PGS.Connection 52 | -> Query columns 53 | -> IO [haskells] 54 | runQueryExplicit (QueryRunner u rowParser nonZeroColumns) conn q = 55 | PGS.queryWith_ parser conn sql 56 | where sql :: PGS.Query 57 | sql = String.fromString (S.showSqlForPostgresExplicit u q) 58 | -- FIXME: We're doing work twice here 59 | (b, _, _) = Q.runSimpleQueryArrStart q () 60 | parser = if nonZeroColumns b 61 | then rowParser b 62 | else (FR.fromRow :: FR.RowParser (PGS.Only Int)) *> rowParser b 63 | -- If we are selecting zero columns then the SQL 64 | -- generator will have to put a dummy 0 into the 65 | -- SELECT statement, since we can't select zero 66 | -- columns. In that case we have to make sure we 67 | -- read a single Int. 68 | 69 | -- | Use 'queryRunnerColumn' to make an instance to allow you to run queries on 70 | -- your own datatypes. For example: 71 | -- 72 | -- @ 73 | -- newtype Foo = Foo Int 74 | -- instance Default QueryRunnerColumn Foo Foo where 75 | -- def = queryRunnerColumn ('Opaleye.Column.unsafeCoerce' :: Column Foo -> Column PGInt4) Foo def 76 | -- @ 77 | queryRunnerColumn :: (Column a' -> Column a) -> (b -> b') 78 | -> IRQ.QueryRunnerColumn a b -> IRQ.QueryRunnerColumn a' b' 79 | queryRunnerColumn colF haskellF qrc = IRQ.QueryRunnerColumn (P.lmap colF u) 80 | (fmapFP haskellF fp) 81 | where IRQ.QueryRunnerColumn u fp = qrc 82 | fmapFP = fmap . fmap 83 | -------------------------------------------------------------------------------- /Test/Wrapped.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE GADTs #-} 3 | 4 | module Wrapped where 5 | 6 | import Control.Arrow (arr, (<<<)) 7 | import qualified Control.Arrow as Arrow 8 | import qualified Control.Category 9 | import Control.Category (Category) 10 | import qualified Data.Functor.Contravariant as C 11 | import qualified Data.Functor.Contravariant.Divisible as D 12 | import qualified Data.Profunctor as P 13 | import qualified Data.Profunctor.Product as PP 14 | 15 | data WrappedSumProfunctor p a b where 16 | WrappedSumProfunctor :: p a b -> WrappedSumProfunctor p a b 17 | WrappedSumProfunctorId :: WrappedSumProfunctor p a a 18 | WrappedSumProfunctorArr :: (a -> b) -> WrappedSumProfunctor p a b 19 | WrappedSumProfunctorCompose :: WrappedSumProfunctor p b c 20 | -> WrappedSumProfunctor p a b 21 | -> WrappedSumProfunctor p a c 22 | WrappedSumProfunctorChoice :: 23 | WrappedSumProfunctor p a a' 24 | -> WrappedSumProfunctor p b b' 25 | -> WrappedSumProfunctor p (Either a b) (Either a' b') 26 | 27 | newtype WrappedDecidable f a b = 28 | WrappedDecidable { unWrappedDecidable :: f a } 29 | 30 | instance C.Contravariant f => P.Profunctor (WrappedDecidable f) where 31 | dimap f _ = WrappedDecidable . C.contramap f . unWrappedDecidable 32 | 33 | instance D.Decidable f => PP.SumProfunctor (WrappedDecidable f) where 34 | f1 +++! f2 = 35 | WrappedDecidable (D.choose id (unWrappedDecidable f1) 36 | (unWrappedDecidable f2)) 37 | 38 | constructor :: P.Profunctor p 39 | => (b -> c) -> p a b -> WrappedSumProfunctor p a c 40 | constructor c p = P.rmap c (WrappedSumProfunctor p) 41 | 42 | constructorDecidable :: D.Decidable f 43 | => f a 44 | -> WrappedSumProfunctor (WrappedDecidable f) a c 45 | constructorDecidable f = WrappedSumProfunctor (WrappedDecidable f) 46 | 47 | asSumProfunctor :: PP.SumProfunctor p 48 | => WrappedSumProfunctor p a b -> p a b 49 | asSumProfunctor w = case unWrappedSumProfunctorE w of 50 | Left p -> p 51 | Right _ -> error "unWrappedSumProfunctor was function" 52 | 53 | asDecidable :: D.Decidable f 54 | => WrappedSumProfunctor (WrappedDecidable f) a b -> f a 55 | asDecidable = unWrappedDecidable . asSumProfunctor 56 | 57 | unWrappedSumProfunctorE :: PP.SumProfunctor p 58 | => WrappedSumProfunctor p a b -> Either (p a b) (a -> b) 59 | unWrappedSumProfunctorE = \case 60 | WrappedSumProfunctor p -> Left p 61 | WrappedSumProfunctorId -> Right id 62 | WrappedSumProfunctorArr f -> Right f 63 | WrappedSumProfunctorCompose w1 w2 -> 64 | case (unWrappedSumProfunctorE w1, unWrappedSumProfunctorE w2) of 65 | (Left _, Left _) -> error "Composing two profunctors" 66 | (Right f, Left p) -> Left (P.rmap f p) 67 | (Left p, Right f) -> Left (P.lmap f p) 68 | (Right f1, Right f2) -> Right (f1 . f2) 69 | 70 | WrappedSumProfunctorChoice w1 w2 -> 71 | case (unWrappedSumProfunctorE w1, unWrappedSumProfunctorE w2) of 72 | (Left p1, Left p2) -> Left (p1 PP.+++! p2) 73 | _ -> error "WrappedSumProfunctorChoice" 74 | 75 | instance Category (WrappedSumProfunctor p) where 76 | id = WrappedSumProfunctorId 77 | (.) = WrappedSumProfunctorCompose 78 | 79 | instance Arrow.Arrow (WrappedSumProfunctor p) where 80 | arr = WrappedSumProfunctorArr 81 | first = error "WrappedSumProfunctor first" 82 | 83 | instance PP.SumProfunctor p => Arrow.ArrowChoice (WrappedSumProfunctor p) where 84 | (+++) = WrappedSumProfunctorChoice 85 | 86 | instance P.Profunctor p => P.Profunctor (WrappedSumProfunctor p) where 87 | dimap f g w = arr g <<< w <<< arr f 88 | -------------------------------------------------------------------------------- /src/Opaleye/Internal/Optimize.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | module Opaleye.Internal.Optimize where 4 | 5 | import Prelude hiding (product) 6 | 7 | import qualified Opaleye.Internal.PrimQuery as PQ 8 | import Opaleye.Internal.Helpers ((.:)) 9 | 10 | import qualified Data.List.NonEmpty as NEL 11 | 12 | import Control.Applicative (liftA2) 13 | import Control.Arrow (first) 14 | 15 | optimize :: PQ.PrimQuery' a -> PQ.PrimQuery' a 16 | optimize = PQ.foldPrimQuery (noSingletonProduct 17 | `PQ.composePrimQueryFold` mergeProduct 18 | `PQ.composePrimQueryFold` removeUnit) 19 | 20 | removeUnit :: PQ.PrimQueryFoldP a (PQ.PrimQuery' a) (PQ.PrimQuery' a) 21 | removeUnit = PQ.primQueryFoldDefault { PQ.product = product } 22 | where product pqs = PQ.Product pqs' 23 | where pqs' = case NEL.nonEmpty (NEL.filter (not . PQ.isUnit . snd) pqs) of 24 | Nothing -> return (pure PQ.Unit) 25 | Just xs -> xs 26 | 27 | mergeProduct :: PQ.PrimQueryFoldP a (PQ.PrimQuery' a) (PQ.PrimQuery' a) 28 | mergeProduct = PQ.primQueryFoldDefault { PQ.product = product } 29 | where product pqs pes = PQ.Product pqs' (pes ++ pes') 30 | where pqs' = pqs >>= queries 31 | queries (lat, PQ.Product qs _) = fmap (first (lat <>)) qs 32 | queries q = return q 33 | pes' = NEL.toList pqs >>= conds 34 | conds (_lat, PQ.Product _ cs) = cs 35 | conds _ = [] 36 | 37 | noSingletonProduct :: PQ.PrimQueryFoldP a (PQ.PrimQuery' a) (PQ.PrimQuery' a) 38 | noSingletonProduct = PQ.primQueryFoldDefault { PQ.product = product } 39 | where product pqs conds = case (NEL.uncons pqs, conds) of 40 | (((PQ.NonLateral, x), Nothing), []) -> x 41 | _ -> PQ.Product pqs conds 42 | 43 | removeEmpty :: PQ.PrimQuery' a -> Maybe (PQ.PrimQuery' b) 44 | removeEmpty = PQ.foldPrimQuery PQ.PrimQueryFold { 45 | PQ.unit = return PQ.Unit 46 | , PQ.empty = const Nothing 47 | , PQ.baseTable = return .: PQ.BaseTable 48 | , PQ.product = let sequenceOf l = traverseOf l id 49 | traverseOf = id 50 | _2 = traverse 51 | in 52 | \x y -> PQ.Product <$> sequenceOf (traverse._2) x 53 | <*> pure y 54 | , PQ.aggregate = fmap . PQ.Aggregate 55 | , PQ.window = fmap . PQ.Window 56 | , PQ.distinctOnOrderBy = \mDistinctOns -> fmap . PQ.DistinctOnOrderBy mDistinctOns 57 | , PQ.limit = fmap . PQ.Limit 58 | , PQ.join = \jt pe pq1 pq2 -> PQ.Join jt pe <$> sequence pq1 <*> sequence pq2 59 | , PQ.semijoin = liftA2 . PQ.Semijoin 60 | , PQ.exists = fmap . PQ.Exists 61 | , PQ.values = return .: PQ.Values 62 | , PQ.binary = \case 63 | -- Some unfortunate duplication here 64 | PQ.Except -> binary Just (const Nothing) PQ.Except 65 | PQ.Union -> binary Just Just PQ.Union 66 | PQ.Intersect -> binary (const Nothing) (const Nothing) PQ.Intersect 67 | 68 | PQ.ExceptAll -> binary Just (const Nothing) PQ.ExceptAll 69 | PQ.UnionAll -> binary Just Just PQ.UnionAll 70 | PQ.IntersectAll -> binary (const Nothing) (const Nothing) PQ.IntersectAll 71 | , PQ.label = fmap . PQ.Label 72 | , PQ.relExpr = return .: PQ.RelExpr 73 | , PQ.rebind = \b -> fmap . PQ.Rebind b 74 | , PQ.forUpdate = fmap PQ.ForUpdate 75 | , PQ.with = \recursive materialized name cols -> liftA2 (PQ.With recursive materialized name cols) 76 | } 77 | where -- If only the first argument is Just, do n1 on it 78 | -- If only the second argument is Just, do n2 on it 79 | binary n1 n2 jj = \case 80 | (Nothing, Nothing) -> Nothing 81 | (Nothing, Just pq2) -> n2 pq2 82 | (Just pq1, Nothing) -> n1 pq1 83 | (Just pq1, Just pq2) -> Just (PQ.Binary jj (pq1, pq2)) 84 | -------------------------------------------------------------------------------- /src/Opaleye/Window.hs: -------------------------------------------------------------------------------- 1 | -- | Support for [PostgreSQL window 2 | -- functions](https://www.postgresql.org/docs/current/tutorial-window.html) 3 | 4 | module Opaleye.Window 5 | ( 6 | -- * Run window functions on a @Select@ 7 | W.runWindows 8 | 9 | -- * Create @Windows@ 10 | , W.Windows 11 | , W.over 12 | 13 | -- * Create a @Window@ 14 | , W.Window 15 | , W.partitionBy 16 | 17 | -- * Create a @WindowFunction@ 18 | , W.WindowFunction 19 | 20 | -- * Window functions 21 | 22 | -- | You might like to also refer to [the Postgres 23 | -- documentation page that describes its window 24 | -- functions](https://www.postgresql.org/docs/devel/functions-window.html). 25 | 26 | , W.noWindowFunction 27 | , W.aggregatorWindowFunction 28 | , rowNumber 29 | , rank 30 | , denseRank 31 | , percentRank 32 | , cumeDist 33 | , ntile 34 | , lag 35 | , lead 36 | , firstValue 37 | , lastValue 38 | , nthValue 39 | ) where 40 | 41 | import qualified Opaleye.Internal.Column as IC 42 | import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ 43 | import qualified Opaleye.Internal.Window as W 44 | 45 | import qualified Opaleye.Field as F 46 | import qualified Opaleye.SqlTypes as T 47 | 48 | -- | [@row_number()@](https://www.postgresql.org/docs/current/functions-window.html) 49 | rowNumber :: W.WindowFunction a (F.Field T.SqlInt8) 50 | rowNumber = W.makeWndwAny HPQ.WndwRowNumber 51 | 52 | 53 | -- | [@rank()@](https://www.postgresql.org/docs/current/functions-window.html) 54 | rank :: W.WindowFunction a (F.Field T.SqlInt8) 55 | rank = W.makeWndwAny HPQ.WndwRank 56 | 57 | 58 | -- | [@dense_rank()@](https://www.postgresql.org/docs/current/functions-window.html) 59 | denseRank :: W.WindowFunction a (F.Field T.SqlInt8) 60 | denseRank = W.makeWndwAny HPQ.WndwDenseRank 61 | 62 | 63 | -- | [@percent_rank()@](https://www.postgresql.org/docs/current/functions-window.html) 64 | percentRank :: W.WindowFunction a (F.Field T.SqlFloat8) 65 | percentRank = W.makeWndwAny HPQ.WndwPercentRank 66 | 67 | 68 | -- | [@cume_dist()@](https://www.postgresql.org/docs/current/functions-window.html) 69 | cumeDist :: W.WindowFunction a (F.Field T.SqlFloat8) 70 | cumeDist = W.makeWndwAny HPQ.WndwCumeDist 71 | 72 | 73 | -- | [@ntile(num_buckets)@](https://www.postgresql.org/docs/current/functions-window.html) 74 | ntile :: F.Field T.SqlInt4 75 | -- ^ num_buckets 76 | -> W.WindowFunction a (F.Field T.SqlInt4) 77 | ntile (IC.Column buckets) = W.makeWndwAny $ HPQ.WndwNtile buckets 78 | 79 | 80 | -- | [@lag(value, offset, default)@](https://www.postgresql.org/docs/current/functions-window.html) 81 | lag :: F.Field T.SqlInt4 82 | -- ^ offset 83 | -> F.Field_ n a 84 | -- ^ default 85 | -> W.WindowFunction (F.Field_ n a) (F.Field_ n a) 86 | lag (IC.Column offset) (IC.Column def) = 87 | W.makeWndwField $ \a -> HPQ.WndwLag a offset def 88 | 89 | 90 | -- | [@lead(value, offset, default)@](https://www.postgresql.org/docs/current/functions-window.html) 91 | lead :: F.Field T.SqlInt4 92 | -- ^ offset 93 | -> F.Field_ n a 94 | -- ^ default 95 | -> W.WindowFunction (F.Field_ n a) (F.Field_ n a) 96 | lead (IC.Column offset) (IC.Column def) = 97 | W.makeWndwField $ \a -> HPQ.WndwLead a offset def 98 | 99 | 100 | -- | [@first_value(value)@](https://www.postgresql.org/docs/current/functions-window.html) 101 | firstValue :: W.WindowFunction (F.Field_ n a) (F.Field_ n a) 102 | firstValue = W.makeWndwField HPQ.WndwFirstValue 103 | 104 | 105 | -- | [@last_value(value)@](https://www.postgresql.org/docs/current/functions-window.html) 106 | lastValue :: W.WindowFunction (F.Field_ n a) (F.Field_ n a) 107 | lastValue = W.makeWndwField HPQ.WndwLastValue 108 | 109 | 110 | -- | [@nth_value(value, n)@](https://www.postgresql.org/docs/current/functions-window.html) 111 | nthValue :: F.Field T.SqlInt4 112 | -- ^ n 113 | -> W.WindowFunction (F.Field_ n a) (F.FieldNullable a) 114 | nthValue (IC.Column n) = W.makeWndwField $ \a -> HPQ.WndwNthValue a n 115 | -------------------------------------------------------------------------------- /opaleye-sqlite/src/Opaleye/SQLite/Internal/Values.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} 2 | 3 | module Opaleye.SQLite.Internal.Values where 4 | 5 | import qualified Opaleye.SQLite.PGTypes as T 6 | 7 | import Opaleye.SQLite.Internal.Column (Column(Column)) 8 | import qualified Opaleye.SQLite.Internal.Unpackspec as U 9 | import qualified Opaleye.SQLite.Internal.Tag as T 10 | import qualified Opaleye.SQLite.Internal.PrimQuery as PQ 11 | import qualified Opaleye.SQLite.Internal.PackMap as PM 12 | import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as HPQ 13 | 14 | import Data.Profunctor (Profunctor, dimap, rmap) 15 | import Data.Profunctor.Product (ProductProfunctor, empty, (***!)) 16 | import qualified Data.Profunctor.Product as PP 17 | import Data.Profunctor.Product.Default (Default, def) 18 | 19 | import Control.Applicative (Applicative, pure, (<*>)) 20 | 21 | -- There are two annoyances with creating SQL VALUES statements 22 | -- 23 | -- 1. SQL does not allow empty VALUES statements so if we want to 24 | -- create a VALUES statement from an empty list we have to fake it 25 | -- somehow. The current approach is to make a VALUES statement 26 | -- with a single row of NULLs and then restrict it with WHERE 27 | -- FALSE. 28 | 29 | -- 2. Postgres's type inference of constants is pretty poor so we will 30 | -- sometimes have to give explicit type signatures. The future 31 | -- ShowConstant class will have the same problem. NB We don't 32 | -- actually currently address this problem. 33 | 34 | valuesU :: U.Unpackspec columns columns' 35 | -> Valuesspec columns columns' 36 | -> [columns] 37 | -> ((), T.Tag) -> (columns', PQ.PrimQuery, T.Tag) 38 | valuesU unpack valuesspec rows ((), t) = (newColumns, primQ', T.next t) 39 | where runRow row = valuesRow 40 | where (_, valuesRow) = 41 | PM.run (U.runUnpackspec unpack extractValuesEntry row) 42 | 43 | (newColumns, valuesPEs_nulls) = 44 | PM.run (runValuesspec valuesspec (extractValuesField t)) 45 | 46 | valuesPEs = map fst valuesPEs_nulls 47 | nulls = map snd valuesPEs_nulls 48 | 49 | yieldNoRows :: PQ.PrimQuery -> PQ.PrimQuery 50 | yieldNoRows = PQ.restrict (HPQ.ConstExpr (HPQ.BoolLit False)) 51 | 52 | values' :: [[HPQ.PrimExpr]] 53 | (values', wrap) = if null rows 54 | then ([nulls], yieldNoRows) 55 | else (map runRow rows, id) 56 | 57 | primQ' = wrap (PQ.Values valuesPEs values') 58 | 59 | -- We don't actually use the return value of this. It might be better 60 | -- to come up with another Applicative instance for specifically doing 61 | -- what we need. 62 | extractValuesEntry :: HPQ.PrimExpr -> PM.PM [HPQ.PrimExpr] HPQ.PrimExpr 63 | extractValuesEntry pe = do 64 | PM.write pe 65 | return pe 66 | 67 | extractValuesField :: T.Tag -> HPQ.PrimExpr 68 | -> PM.PM [(HPQ.Symbol, HPQ.PrimExpr)] HPQ.PrimExpr 69 | extractValuesField = PM.extractAttr "values" 70 | 71 | newtype Valuesspec columns columns' = 72 | Valuesspec (PM.PackMap HPQ.PrimExpr HPQ.PrimExpr () columns') 73 | 74 | runValuesspec :: Applicative f => Valuesspec columns columns' 75 | -> (HPQ.PrimExpr -> f HPQ.PrimExpr) -> f columns' 76 | runValuesspec (Valuesspec v) f = PM.traversePM v f () 77 | 78 | instance Default Valuesspec (Column T.PGInt4) (Column T.PGInt4) where 79 | def = Valuesspec (PM.PackMap (\f () -> fmap Column (f (HPQ.ConstExpr HPQ.NullLit)))) 80 | 81 | -- { 82 | 83 | -- Boilerplate instance definitions. Theoretically, these are derivable. 84 | 85 | instance Functor (Valuesspec a) where 86 | fmap f (Valuesspec g) = Valuesspec (fmap f g) 87 | 88 | instance Applicative (Valuesspec a) where 89 | pure = Valuesspec . pure 90 | Valuesspec f <*> Valuesspec x = Valuesspec (f <*> x) 91 | 92 | instance Profunctor Valuesspec where 93 | dimap _ g (Valuesspec q) = Valuesspec (rmap g q) 94 | 95 | instance ProductProfunctor Valuesspec where 96 | empty = PP.defaultEmpty 97 | (***!) = PP.defaultProfunctorProduct 98 | 99 | -- } 100 | -------------------------------------------------------------------------------- /opaleye-sqlite/Doc/UPGRADING.md: -------------------------------------------------------------------------------- 1 | # Changes since version 0 2 | 3 | This document pertains to changes between various old pre-release 4 | versions of Opaleye and the first release to Hackage. It is 5 | irrelevant to you if you have only used Opaleye since its first 6 | Hackage release. 7 | 8 | ## Changes visible in the API 9 | 10 | ### `Wire` becomes `Column`. `ExprArr` is gone. 11 | 12 | The most important user-visible difference between Opaleye 0 and 13 | Opaleye 1 is that `Wire` is now called `Column`. This is not just a 14 | cosmetic change. `Column` contains an entire SQL expression rather 15 | than just a column reference. That is, it contains what used to be 16 | `ExprArr`. The benefit is that manipulating SQL expressions no longer 17 | needs the hassle of `ExprArr`. For example, numerical operations can 18 | be expressed succinctly 19 | 20 | calculation = proc () -> do 21 | (a, b, c) <- table -< () 22 | returnA -< a + ifThenElse (b .== c) (b * c) (a / 2) 23 | 24 | ### Namespace changes 25 | 26 | The namespace has changed from Karamaan.Opaleye to Opaleye. Many of 27 | the version 0 modules were very cluttered with deprecated names. They 28 | have been cleaned and tidied. 29 | 30 | ### Tables have type parameters for writing and reading 31 | 32 | Tables now have two type parameters. One indicates how to use it for 33 | writing, the other for reading. 34 | 35 | ### `Nullable` is no longer a synonym for `Maybe` 36 | 37 | `Nullable` is now a new type independent of `Maybe`. `runQuery` still 38 | converts it to `Maybe` but Opaleye-side code should use `Nullable` 39 | instead of `Maybe`. 40 | 41 | ### `ShowConstant` doesn't exist 42 | 43 | The `ShowConstant` typeclass for lifting Haskell values into Opaleye 44 | does not exist anymore. Instead there is a `PGTypes` module with 45 | individual functions for lifting values. If after due consideration 46 | it seems like the typeclass was needed after all it can be added back 47 | in. 48 | 49 | ## Internal changes 50 | 51 | ### SQL generation 52 | 53 | Opaleye 1 uses less of HaskellDB's SQL generator. HaskellDB's 54 | optimizer is extremely buggy and its SQL generator does not support 55 | `OUTER JOIN` or `VALUES`. It would have been more difficult to work 56 | around or patch HaskellDB than simply to write a new SQL generator for 57 | Opaleye, so we did the latter. 58 | 59 | ### `PackMap` 60 | 61 | Many or most of the product profunctors in use in Opaleye 0 have been 62 | unified as values of specific type called `PackMap` which seems very 63 | similar to a "traversal" from `Control.Lens`. This cuts down on a lot 64 | of boilerplate and allows unification of concepts and functionality. 65 | 66 | ## Converting from version 0 67 | 68 | Please note that although almost all of Opaleye 0's functionality is 69 | now present in Opaleye 1, we are still missing the implementation of 70 | many operators and instances. This is a very small amount of work and 71 | would be a good starter project. Patches for this are welcome. For 72 | example 73 | 74 | * `RunQuery` is fully implemented but most of the `QueryRunner` 75 | instances just need to be written down. 76 | * Support for numeric, boolean, etc. operators is fully 77 | implemented but many of them still need to be written down. 78 | * Support for binary set operations and `OUTER JOIN`s is fully 79 | implemented but the definitions of `UNION`, `INTERSECT`, 80 | `INTERSECT ALL`, `RIGHT JOIN`, `FULL OUTER JOIN` etc. still need 81 | to be written down. 82 | 83 | Opaleye 0 and Opaleye 1 can exist together in the same codebase 84 | because they have different package names and different module 85 | namespaces. However, I would recommend converting to Opaleye 1 and 86 | writing all new code with Opaleye 1 because it is easier to use. 87 | 88 | Converting from Opaleye 0 to Opaleye 1 might be smoother if you 89 | provide the following synonyms during the transition. 90 | 91 | type Wire = Column 92 | type ExprArr = (->) 93 | 94 | toQueryArrDef :: ExprArr a b -> QueryArr a b 95 | toQueryArrDef = arr 96 | 97 | Information about how well this works in practice would be gratefully 98 | received. 99 | 100 | You will probably find that many identifiers have changed, 101 | particularly fully qualified identifiers. Theoretically a transition 102 | package could be provided that maps from the old names to the new 103 | names, but I suspect this is likely to be more work than just changing 104 | all the old uses by hand. 105 | -------------------------------------------------------------------------------- /src/Opaleye/Internal/Column.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | 3 | {-# LANGUAGE ConstraintKinds #-} 4 | {-# LANGUAGE DataKinds #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | 7 | module Opaleye.Internal.Column where 8 | 9 | import Data.String 10 | 11 | import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ 12 | 13 | data Nullability = NonNullable | Nullable 14 | 15 | -- | A field of a @Select@, of type @sqlType@. For example a @Field 16 | -- SqlInt4@ is an @int4@ column and a @Field SqlText@ is a @text@ 17 | -- column. 18 | newtype Field_ (n :: Nullability) sqlType = Column HPQ.PrimExpr 19 | 20 | type Field = Field_ NonNullable 21 | type FieldNullable = Field_ 'Nullable 22 | 23 | -- | Only used within a 'Column', to indicate that it can be @NULL@. 24 | -- For example, a @'Column' ('Nullable' SqlText)@ can be @NULL@ but a 25 | -- 'Column' @SqlText@ cannot. 26 | data Nullable a = Nullable_ 27 | 28 | -- | Do not use. Use 'Field' instead. Will be removed in a later 29 | -- version. 30 | type family Column a where 31 | Column (Nullable a) = FieldNullable a 32 | Column a = Field a 33 | 34 | unColumn :: Field_ n a -> HPQ.PrimExpr 35 | unColumn (Column e) = e 36 | 37 | -- | Treat a 'Column' as though it were of a different type. If such 38 | -- a treatment is not valid then Postgres may fail with an error at 39 | -- SQL run time. 40 | unsafeCoerceColumn :: Field_ n a -> Field_ n' b 41 | unsafeCoerceColumn (Column e) = Column e 42 | 43 | -- | Cast a column to any other type. Implements Postgres's @::@ or 44 | -- @CAST( ... AS ... )@ operations. This is safe for some 45 | -- conversions, such as uuid to text. 46 | unsafeCast :: String -> Field_ n a -> Field_ n b 47 | unsafeCast = mapColumn . HPQ.CastExpr 48 | where 49 | mapColumn :: (HPQ.PrimExpr -> HPQ.PrimExpr) -> Field_ n c -> Field_ n' a 50 | mapColumn primExpr c = Column (primExpr (unColumn c)) 51 | 52 | unsafeCompositeField :: Field_ n a -> String -> Field_ n' b 53 | unsafeCompositeField (Column e) fieldName = 54 | Column (HPQ.CompositeExpr e fieldName) 55 | 56 | unsafeFromNullable :: Field_ n a 57 | -> Field_ n' a 58 | unsafeFromNullable (Column e) = Column e 59 | 60 | binOp :: HPQ.BinOp -> Field_ n a -> Field_ n' b -> Field_ n'' c 61 | binOp op (Column e) (Column e') = Column (HPQ.BinExpr op e e') 62 | 63 | unOp :: HPQ.UnOp -> Field_ n a -> Field_ n' b 64 | unOp op (Column e) = Column (HPQ.UnExpr op e) 65 | 66 | -- For import order reasons we can't make the argument type SqlBool 67 | unsafeCase_ :: [(Field_ n pgBool, Field_ n' a)] -> Field_ n' a -> Field_ n' a 68 | unsafeCase_ alts (Column otherwise_) = Column (HPQ.CaseExpr (unColumns alts) otherwise_) 69 | where unColumns = map (\(Column e, Column e') -> (e, e')) 70 | 71 | unsafeIfThenElse :: Field_ n' pgBool -> Field_ n a -> Field_ n a -> Field_ n a 72 | unsafeIfThenElse cond t f = unsafeCase_ [(cond, t)] f 73 | 74 | unsafeGt :: Field_ n a -> Field_ n a -> Field_ n' pgBool 75 | unsafeGt = binOp (HPQ.:>) 76 | 77 | unsafeEq :: Field_ n a -> Field_ n a -> Field_ n' pgBool 78 | unsafeEq = binOp (HPQ.:==) 79 | 80 | class SqlNum a where 81 | pgFromInteger :: Integer -> Field a 82 | pgFromInteger = sqlFromInteger 83 | 84 | sqlFromInteger :: Integer -> Field a 85 | 86 | type PGNum = SqlNum 87 | 88 | instance SqlNum a => Num (Field a) where 89 | fromInteger = pgFromInteger 90 | (*) = binOp (HPQ.:*) 91 | (+) = binOp (HPQ.:+) 92 | (-) = binOp (HPQ.:-) 93 | 94 | abs = unOp HPQ.OpAbs 95 | negate = unOp HPQ.OpNegate 96 | 97 | -- We can't use Postgres's 'sign' function because it returns only a 98 | -- numeric or a double 99 | signum c = unsafeCase_ [(c `unsafeGt` 0, 1), (c `unsafeEq` 0, 0)] (-1) 100 | 101 | class SqlFractional a where 102 | pgFromRational :: Rational -> Field a 103 | pgFromRational = sqlFromRational 104 | 105 | sqlFromRational :: Rational -> Field a 106 | 107 | type PGFractional = SqlFractional 108 | 109 | instance (SqlNum a, SqlFractional a) => Fractional (Field a) where 110 | fromRational = sqlFromRational 111 | (/) = binOp (HPQ.:/) 112 | 113 | -- | A dummy typeclass whose instances support integral operations. 114 | class SqlIntegral a 115 | 116 | type PGIntegral = SqlIntegral 117 | 118 | class SqlString a where 119 | pgFromString :: String -> Field a 120 | pgFromString = sqlFromString 121 | 122 | sqlFromString :: String -> Field a 123 | 124 | type PGString = SqlString 125 | 126 | instance SqlString a => IsString (Field a) where 127 | fromString = sqlFromString 128 | -------------------------------------------------------------------------------- /opaleye-sqlite/Doc/Tutorial/TutorialManipulation.lhs: -------------------------------------------------------------------------------- 1 | > module TutorialManipulation where 2 | > 3 | > import Prelude hiding (sum) 4 | > 5 | > import Opaleye.SQLite (Column, Table(Table), 6 | > required, optional, (.==), (.<), 7 | > arrangeDeleteSql, arrangeInsertSql, 8 | > arrangeUpdateSql, arrangeInsertReturningSql, 9 | > PGInt4, PGFloat8) 10 | > 11 | > import Data.Profunctor.Product (p3) 12 | > import Data.Profunctor.Product.Default (Default, def) 13 | > import qualified Opaleye.SQLite.Internal.Unpackspec as U 14 | 15 | 16 | Manipulation 17 | ============ 18 | 19 | Manipulation means changing the data in the database. This means SQL 20 | DELETE, INSERT and UPDATE. 21 | 22 | To demonstrate manipulation in Opaleye we will need a table to perform 23 | our manipulation on. It will have three columns: an integer-valued 24 | "id" column (assumed to be an auto-incrementing field) and two 25 | double-valued required fields. The `Table` type constructor has two 26 | type arguments. The first one is the type of writes to the table, and 27 | the second is the type of reads from the table. Notice that the "id" 28 | column was defined as optional (for writes) so in the type of writes 29 | it is wrapped in a Maybe. That means we don't necessarily need to 30 | specify it when writing to the table. The database will automatically 31 | fill in a value for us. 32 | 33 | > table :: Table (Maybe (Column PGInt4), Column PGFloat8, Column PGFloat8) 34 | > (Column PGInt4, Column PGFloat8, Column PGFloat8) 35 | > table = Table "tablename" (p3 (optional "id", required "x", required "y")) 36 | 37 | To perform a delete we provide an expression from our read type to 38 | `Column Bool`. All rows for which the expression is true are deleted. 39 | 40 | > delete :: String 41 | > delete = arrangeDeleteSql table (\(_, x, y) -> x .< y) 42 | 43 | ghci> putStrLn delete 44 | DELETE FROM tablename 45 | WHERE ((x) < (y)) 46 | 47 | 48 | To insert we provide a row with the write type. Optional columns can 49 | be omitted by providing `Nothing` instead. 50 | 51 | > insertNothing :: String 52 | > insertNothing = arrangeInsertSql table (Nothing, 2, 3) 53 | 54 | ghci> putStrLn insertNothing 55 | INSERT INTO tablename (x, 56 | y) 57 | VALUES (2.0, 58 | 3.0) 59 | 60 | 61 | If we really want to specify an optional column we can use `Just`. 62 | 63 | > insertJust :: String 64 | > insertJust = arrangeInsertSql table (Just 1, 2, 3) 65 | 66 | ghci> putStrLn insertJust 67 | INSERT INTO tablename (id, 68 | x, 69 | y) 70 | VALUES (1, 71 | 2.0, 72 | 3.0) 73 | 74 | 75 | An update takes an update function from the read type to the write 76 | type, and a condition given by a function from the read type to 77 | `Column Bool`. All rows that satisfy the condition are updated 78 | according to the update function. 79 | 80 | > update :: String 81 | > update = arrangeUpdateSql table (\(_, x, y) -> (Nothing, x + y, x - y)) 82 | > (\(id_, _, _) -> id_ .== 5) 83 | 84 | ghci> putStrLn update 85 | UPDATE tablename 86 | SET x = (x) + (y), 87 | y = (x) - (y) 88 | WHERE ((id) = 5) 89 | 90 | 91 | Sometimes when we insert a row with an automatically generated field 92 | we want the database to return the new field value to us so we can use 93 | it in future queries. SQL supports that via INSERT RETURNING and 94 | Opaleye supports it also. 95 | 96 | > insertReturning :: String 97 | > insertReturning = arrangeInsertReturningSql def' table (Nothing, 4, 5) 98 | > (\(id_, _, _) -> id_) 99 | > -- TODO: vv This is too messy 100 | > where def' :: U.Unpackspec (Column a) (Column a) 101 | > def' = def 102 | 103 | ghci> putStrLn insertReturning 104 | INSERT INTO tablename (x, 105 | y) 106 | VALUES (4.0, 107 | 5.0) 108 | RETURNING id 109 | 110 | 111 | Running the queries 112 | =================== 113 | 114 | This tutorial has only shown you how to generate the SQL string for 115 | manipulation queries. In practice you actually want to run them! To 116 | run them you should use `runInsert` instead of `arrangeInsertSql`, 117 | `runDelete` instead of `arrangeDeleteSql`, etc.. 118 | 119 | 120 | Comments 121 | ======== 122 | 123 | Opaleye does not currently support inserting more than one row at 124 | once, or SELECT-valued INSERT or UPDATE. 125 | -------------------------------------------------------------------------------- /src/Opaleye/Internal/Operators.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | 3 | {-# LANGUAGE ExistentialQuantification #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | module Opaleye.Internal.Operators where 7 | 8 | import Control.Applicative (liftA2) 9 | 10 | import Opaleye.Internal.Column (Field_(Column)) 11 | import qualified Opaleye.Internal.Column as C 12 | import qualified Opaleye.Internal.PackMap as PM 13 | import qualified Opaleye.Internal.PrimQuery as PQ 14 | import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ 15 | import qualified Opaleye.Internal.QueryArr as QA 16 | import qualified Opaleye.Internal.Tag as Tag 17 | import qualified Opaleye.Internal.PGTypesExternal as T 18 | import qualified Opaleye.Field as F 19 | import Opaleye.Field (Field) 20 | import qualified Opaleye.Select as S 21 | 22 | import Data.Profunctor (Profunctor, dimap) 23 | import Data.Profunctor.Product (ProductProfunctor, empty, (***!)) 24 | import qualified Data.Profunctor.Product.Default as D 25 | 26 | restrict :: S.SelectArr (F.Field T.SqlBool) () 27 | restrict = QA.selectArr f where 28 | -- A where clause can always refer to columns defined by the query 29 | -- it references so needs no special treatment on LATERAL. 30 | f = pure (\(Column predicate) -> ((), PQ.aRestrict predicate)) 31 | 32 | infix 4 .== 33 | (.==) :: forall columns. D.Default EqPP columns columns 34 | => columns -> columns -> Field T.PGBool 35 | (.==) = eqExplicit (D.def :: EqPP columns columns) 36 | 37 | infixr 2 .|| 38 | 39 | (.||) :: F.Field T.SqlBool -> F.Field T.SqlBool -> F.Field T.SqlBool 40 | (.||) = C.binOp HPQ.OpOr 41 | 42 | infixr 3 .&& 43 | 44 | -- | Boolean and 45 | (.&&) :: Field T.PGBool -> Field T.PGBool -> Field T.PGBool 46 | (.&&) = C.binOp HPQ.OpAnd 47 | 48 | not :: F.Field T.SqlBool -> F.Field T.SqlBool 49 | not = C.unOp HPQ.OpNot 50 | 51 | newtype EqPP a b = EqPP (a -> a -> Field T.PGBool) 52 | 53 | eqPPField :: EqPP (Field a) ignored 54 | eqPPField = EqPP C.unsafeEq 55 | 56 | eqExplicit :: EqPP columns a -> columns -> columns -> Field T.PGBool 57 | eqExplicit (EqPP f) = f 58 | 59 | instance D.Default EqPP (Field a) (Field a) where 60 | def = eqPPField 61 | 62 | 63 | newtype IfPP a b = IfPP (Field T.PGBool -> a -> a -> b) 64 | 65 | ifExplict :: IfPP columns columns' 66 | -> Field T.PGBool 67 | -> columns 68 | -> columns 69 | -> columns' 70 | ifExplict (IfPP f) = f 71 | 72 | ifPPField :: IfPP (Field_ n a) (Field_ n a) 73 | ifPPField = D.def 74 | 75 | instance D.Default IfPP (Field_ n a) (Field_ n a) where 76 | def = IfPP C.unsafeIfThenElse 77 | 78 | 79 | newtype RelExprPP a b = RelExprPP (Tag.Tag -> PM.PM [HPQ.Symbol] b) 80 | 81 | 82 | runRelExprPP :: RelExprPP a b -> Tag.Tag -> (b, [HPQ.Symbol]) 83 | runRelExprPP (RelExprPP m) = PM.run . m 84 | 85 | 86 | instance D.Default RelExprPP (Field_ n a) (Field_ n a) where 87 | def = relExprColumn 88 | 89 | 90 | relExprColumn :: RelExprPP (Field_ n a) (Field_ n a) 91 | relExprColumn = RelExprPP $ fmap Column . PM.extract "relExpr" 92 | 93 | 94 | relationValuedExprExplicit :: RelExprPP columns columns 95 | -> (a -> HPQ.PrimExpr) 96 | -> QA.QueryArr a columns 97 | relationValuedExprExplicit relExprPP pe = 98 | QA.productQueryArr' $ do 99 | (columns, symbols) <- runRelExprPP relExprPP <$> Tag.fresh 100 | pure $ \a -> (columns, PQ.RelExpr (pe a) symbols) 101 | 102 | 103 | relationValuedExpr :: D.Default RelExprPP columns columns 104 | => (a -> HPQ.PrimExpr) 105 | -> QA.QueryArr a columns 106 | relationValuedExpr = relationValuedExprExplicit D.def 107 | 108 | -- { Boilerplate instances 109 | 110 | instance Profunctor EqPP where 111 | dimap f _ (EqPP h) = EqPP (\a a' -> h (f a) (f a')) 112 | 113 | instance ProductProfunctor EqPP where 114 | empty = EqPP (\() () -> T.pgBool True) 115 | EqPP f ***! EqPP f' = EqPP (\a a' -> 116 | f (fst a) (fst a') .&& f' (snd a) (snd a')) 117 | 118 | instance Profunctor RelExprPP where 119 | dimap _ f (RelExprPP m) = RelExprPP (fmap (fmap f) m) 120 | 121 | instance ProductProfunctor RelExprPP where 122 | empty = RelExprPP (pure (pure ())) 123 | RelExprPP f ***! RelExprPP g = 124 | RelExprPP $ liftA2 (liftA2 (,)) f g 125 | 126 | instance Profunctor IfPP where 127 | dimap f g (IfPP h) = IfPP (\b a a' -> g (h b (f a) (f a'))) 128 | 129 | instance ProductProfunctor IfPP where 130 | empty = IfPP (\_ () () -> ()) 131 | IfPP f ***! IfPP f' = IfPP (\b a a1 -> 132 | (f b (fst a) (fst a1), f' b (snd a) (snd a1))) 133 | 134 | -- } 135 | -------------------------------------------------------------------------------- /src/Opaleye/Field.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | 4 | -- | Functions for working directly with 'Field_'s. 5 | -- 6 | -- Please note that numeric 'Field_' types are instances of 'Num', so 7 | -- you can use '*', '/', '+', '-' on them. To create 'Field_'s, see 8 | -- "Opaleye.ToFields" and "Opaleye.SqlTypes". 9 | -- 10 | -- 'Field_' used to be called t'C.Column' and for technical reasons 11 | -- there are still a few uses of the old name around. If you see 12 | -- @t'C.Column' SqlType@ then you can understand it as @'Field' 13 | -- SqlType@, and if you see @t'C.Column' ( t'C.Nullable' SqlType )@ then 14 | -- you can understand it as @'FieldNullable' SqlType@. 15 | -- 16 | -- t'C.Column' will be removed in version 0.11. 17 | -- 18 | -- (Due to Haddock formatting errors, this documentation previously 19 | -- incorrectly stated that @Field_@ would be removed. It won't be!) 20 | 21 | {-# LANGUAGE TypeFamilies #-} 22 | {-# LANGUAGE DataKinds #-} 23 | 24 | module Opaleye.Field ( 25 | Field_, 26 | Field, 27 | FieldNullable, 28 | Nullability(..), 29 | -- * Casting fields 30 | C.unsafeCast, 31 | unsafeCastSqlType, 32 | unsafeCoerceField, 33 | -- * Working with @NULL@ 34 | -- | Instead of working with @NULL@ you are recommended to use 35 | -- "Opaleye.MaybeFields" instead. 36 | Opaleye.Field.null, 37 | typedNull, 38 | untypedNull, 39 | isNull, 40 | matchNullable, 41 | fromNullable, 42 | toNullable, 43 | maybeToNullable, 44 | ) where 45 | 46 | import Prelude hiding (null) 47 | 48 | import Opaleye.Internal.Column 49 | (Field_(Column), FieldNullable, Field, Nullability(NonNullable, Nullable)) 50 | import qualified Opaleye.Internal.Column as C 51 | import qualified Opaleye.Internal.PGTypesExternal as T 52 | import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ 53 | 54 | import Data.Proxy (Proxy(Proxy)) 55 | 56 | -- FIXME Put Nullspec (or sqltype?) constraint on this 57 | 58 | -- | A @NULL@ of any type. This will change to become 'typedNull' in 59 | -- a future version. 60 | null :: FieldNullable a 61 | null = Column (HPQ.ConstExpr HPQ.NullLit) 62 | 63 | -- | Cast a column to any other type, as long as it has an instance of 64 | -- 'T.IsSqlType'. Should be used in preference to 'C.unsafeCast'. 65 | unsafeCastSqlType :: forall a b n. (T.IsSqlType b) => Field_ n a -> Field_ n b 66 | unsafeCastSqlType = C.unsafeCast (T.showSqlType @b Proxy) 67 | 68 | -- | Same as 'null', but with an explicit type @CAST@. This can help 69 | -- in situations when PostgreSQL can't figure out the type of a 70 | -- @NULL@. In a future major version this will replace @null@. 71 | typedNull :: T.IsSqlType a => FieldNullable a 72 | typedNull = unsafeCastSqlType null 73 | 74 | -- | A @NULL@ of any type with no @CAST@ supplied. Use this in 75 | -- preference to 'null' if you really don't want a type cast applied 76 | -- to your @NULL@. 77 | untypedNull :: FieldNullable a 78 | untypedNull = null 79 | 80 | -- | @TRUE@ if the value of the field is @NULL@, @FALSE@ otherwise. 81 | isNull :: FieldNullable a -> Field T.PGBool 82 | isNull = C.unOp HPQ.OpIsNull 83 | 84 | -- | If the @Field 'Nullable a@ is NULL then return the @Field 85 | -- 'NonNullable b@ otherwise map the underlying @Field 'Nullable a@ 86 | -- using the provided function. 87 | -- 88 | -- The Opaleye equivalent of 'Data.Maybe.maybe'. 89 | matchNullable :: Field b 90 | -- ^ 91 | -> (Field a -> Field b) 92 | -- ^ 93 | -> FieldNullable a 94 | -- ^ ͘ 95 | -> Field b 96 | matchNullable replacement f x = C.unsafeIfThenElse (isNull x) replacement 97 | (f (unsafeCoerceField x)) 98 | 99 | -- | If the @FieldNullable a@ is NULL then return the provided 100 | -- @Field a@ otherwise return the underlying @Field 101 | -- a@. 102 | -- 103 | -- The Opaleye equivalent of 'Data.Maybe.fromMaybe' and very similar 104 | -- to PostgreSQL's @COALESCE@. 105 | fromNullable :: Field a 106 | -- ^ 107 | -> FieldNullable a 108 | -- ^ ͘ 109 | -> Field a 110 | fromNullable = flip matchNullable id 111 | 112 | -- | Treat a field as though it were nullable. This is always safe. 113 | -- 114 | -- The Opaleye equivalent of 'Data.Maybe.Just'. 115 | toNullable :: Field a -> FieldNullable a 116 | toNullable = C.unsafeCoerceColumn 117 | 118 | -- | If the argument is 'Data.Maybe.Nothing' return NULL otherwise return the 119 | -- provided value coerced to a nullable type. 120 | maybeToNullable :: Maybe (Field a) 121 | -> FieldNullable a 122 | maybeToNullable = maybe null toNullable 123 | 124 | unsafeCoerceField :: Field_ n a -> Field_ n' b 125 | unsafeCoerceField = C.unsafeCoerceColumn 126 | -------------------------------------------------------------------------------- /opaleye-sqlite/src/Opaleye/SQLite/Internal/Print.hs: -------------------------------------------------------------------------------- 1 | module Opaleye.SQLite.Internal.Print where 2 | 3 | import Prelude hiding (product) 4 | 5 | import qualified Opaleye.SQLite.Internal.Sql as Sql 6 | import Opaleye.SQLite.Internal.Sql (Select(SelectFrom, Table, 7 | SelectJoin, 8 | SelectValues, 9 | SelectBinary), 10 | From, Join, Values, Binary) 11 | 12 | import qualified Opaleye.SQLite.Internal.HaskellDB.Sql as HSql 13 | import qualified Opaleye.SQLite.Internal.HaskellDB.Sql.Print as HPrint 14 | 15 | import Text.PrettyPrint.HughesPJ (Doc, ($$), (<+>), text, empty, 16 | parens) 17 | import qualified Data.List.NonEmpty as NEL 18 | 19 | type TableAlias = String 20 | 21 | ppSql :: Select -> Doc 22 | ppSql (SelectFrom s) = ppSelectFrom s 23 | ppSql (Table table) = HPrint.ppTable table 24 | ppSql (SelectJoin j) = ppSelectJoin j 25 | ppSql (SelectValues v) = ppSelectValues v 26 | ppSql (SelectBinary v) = ppSelectBinary v 27 | 28 | ppSelectFrom :: From -> Doc 29 | ppSelectFrom s = text "SELECT" 30 | <+> ppAttrs (Sql.attrs s) 31 | $$ ppTables (Sql.tables s) 32 | $$ HPrint.ppWhere (Sql.criteria s) 33 | $$ ppGroupBy (Sql.groupBy s) 34 | $$ HPrint.ppOrderBy (Sql.orderBy s) 35 | $$ ppLimit (Sql.limit s) 36 | $$ ppOffset (Sql.offset s) 37 | 38 | 39 | ppSelectJoin :: Join -> Doc 40 | ppSelectJoin j = text "SELECT *" 41 | $$ text "FROM" 42 | $$ ppTable (tableAlias 1 s1) 43 | $$ ppJoinType (Sql.jJoinType j) 44 | $$ ppTable (tableAlias 2 s2) 45 | $$ text "ON" 46 | $$ HPrint.ppSqlExpr (Sql.jCond j) 47 | where (s1, s2) = Sql.jTables j 48 | 49 | ppSelectValues :: Values -> Doc 50 | ppSelectValues v = text "SELECT" 51 | <+> ppAttrs (Sql.vAttrs v) 52 | $$ text "FROM" 53 | $$ ppValues (Sql.vValues v) 54 | 55 | ppSelectBinary :: Binary -> Doc 56 | ppSelectBinary b = ppSql (Sql.bSelect1 b) 57 | $$ ppBinOp (Sql.bOp b) 58 | $$ ppSql (Sql.bSelect2 b) 59 | 60 | ppJoinType :: Sql.JoinType -> Doc 61 | ppJoinType Sql.LeftJoin = text "LEFT OUTER JOIN" 62 | 63 | ppAttrs :: Sql.SelectAttrs -> Doc 64 | ppAttrs Sql.Star = text "*" 65 | ppAttrs (Sql.SelectAttrs xs) = (HPrint.commaV nameAs . NEL.toList) xs 66 | 67 | -- This is pretty much just nameAs from HaskellDB 68 | nameAs :: (HSql.SqlExpr, Maybe HSql.SqlColumn) -> Doc 69 | nameAs (expr, name) = HPrint.ppAs (maybe "" unColumn name) (HPrint.ppSqlExpr expr) 70 | where unColumn (HSql.SqlColumn s) = s 71 | 72 | ppTables :: [Select] -> Doc 73 | ppTables [] = empty 74 | ppTables ts = text "FROM" <+> HPrint.commaV ppTable (zipWith tableAlias [1..] ts) 75 | 76 | tableAlias :: Int -> Select -> (TableAlias, Select) 77 | tableAlias i select = ("T" ++ show i, select) 78 | 79 | -- TODO: duplication with ppSql 80 | ppTable :: (TableAlias, Select) -> Doc 81 | ppTable (alias, select) = case select of 82 | Table table -> HPrint.ppAs alias (HPrint.ppTable table) 83 | SelectFrom selectFrom -> HPrint.ppAs alias (parens (ppSelectFrom selectFrom)) 84 | SelectJoin slj -> HPrint.ppAs alias (parens (ppSelectJoin slj)) 85 | SelectValues slv -> HPrint.ppAs alias (parens (ppSelectValues slv)) 86 | SelectBinary slb -> HPrint.ppAs alias (parens (ppSelectBinary slb)) 87 | 88 | ppGroupBy :: Maybe (NEL.NonEmpty HSql.SqlExpr) -> Doc 89 | ppGroupBy Nothing = empty 90 | ppGroupBy (Just xs) = HPrint.ppGroupBy (NEL.toList xs) 91 | 92 | ppLimit :: Maybe Int -> Doc 93 | ppLimit Nothing = empty 94 | ppLimit (Just n) = text ("LIMIT " ++ show n) 95 | 96 | ppOffset :: Maybe Int -> Doc 97 | ppOffset Nothing = empty 98 | ppOffset (Just n) = text ("OFFSET " ++ show n) 99 | 100 | ppValues :: [[HSql.SqlExpr]] -> Doc 101 | ppValues v = HPrint.ppAs "V" (parens (text "VALUES" $$ HPrint.commaV ppValuesRow v)) 102 | 103 | ppValuesRow :: [HSql.SqlExpr] -> Doc 104 | ppValuesRow = parens . HPrint.commaH HPrint.ppSqlExpr 105 | 106 | ppBinOp :: Sql.BinOp -> Doc 107 | ppBinOp o = text $ case o of 108 | Sql.Union -> "UNION" 109 | Sql.UnionAll -> "UNION ALL" 110 | Sql.Except -> "EXCEPT" 111 | 112 | ppInsertReturning :: Sql.Returning HSql.SqlInsert -> Doc 113 | ppInsertReturning (Sql.Returning insert returnExprs) = 114 | HPrint.ppInsert insert 115 | $$ text "RETURNING" 116 | <+> HPrint.commaV HPrint.ppSqlExpr returnExprs 117 | 118 | ppUpdateReturning :: Sql.Returning HSql.SqlUpdate -> Doc 119 | ppUpdateReturning (Sql.Returning update returnExprs) = 120 | HPrint.ppUpdate update 121 | $$ text "RETURNING" 122 | <+> HPrint.commaV HPrint.ppSqlExpr returnExprs 123 | -------------------------------------------------------------------------------- /src/Opaleye/Table.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | 3 | Table fields can be required or optional and, independently, nullable or 4 | non-nullable. 5 | 6 | A required non-nullable @SqlInt4@ (for example) is defined with 7 | 'T.requiredTableField' and gives rise to a 8 | 9 | @ 10 | TableFields (Field SqlInt4) (Field SqlInt4) 11 | @ 12 | 13 | The leftmost argument is the type of writes. When you insert or 14 | update into this field you must give it a @Field SqlInt4@ (which you 15 | can define with @sqlInt4 :: Int -> Field SqlInt4@). 16 | 17 | A required nullable @SqlInt4@ is defined with 'T.requiredTableField' and gives rise 18 | to a 19 | 20 | @ 21 | TableFields (FieldNullable SqlInt4) (FieldNullable SqlInt4) 22 | @ 23 | 24 | When you insert or update into this field you must give it a 25 | @FieldNullable SqlInt4@, which you can define either with @sqlInt4@ and 26 | @toNullable :: Field a -> FieldNullable a@, or with @null :: 27 | FieldNullable a@. 28 | 29 | An optional non-nullable @SqlInt4@ is defined with 'T.optionalTableField' and gives 30 | rise to a 31 | 32 | @ 33 | TableFields (Maybe (Field SqlInt4)) (Field SqlInt4) 34 | @ 35 | 36 | Optional fields are those that can be omitted on writes, such as 37 | those that have @DEFAULT@s or those that are @SERIAL@. 38 | When you insert or update into this field you must give it a @Maybe 39 | (Field SqlInt4)@. If you provide @Nothing@ then the field will be 40 | omitted from the query and the default value will be used. Otherwise 41 | you have to provide a @Just@ containing a @Field SqlInt4@. 42 | 43 | An optional nullable @SqlInt4@ is defined with 'T.optionalTableField' and gives 44 | rise to a 45 | 46 | @ 47 | TableFields (Maybe (FieldNullable SqlInt4)) (FieldNullable SqlInt4) 48 | @ 49 | 50 | Optional fields are those that can be omitted on writes, such as 51 | those that have @DEFAULT@s or those that are @SERIAL@. 52 | When you insert or update into this field you must give it a @Maybe 53 | (FieldNullable SqlInt4)@. If you provide @Nothing@ then the default 54 | value will be used. Otherwise you have to provide a @Just@ containing 55 | a @FieldNullable SqlInt4@ (which can be null). 56 | 57 | -} 58 | 59 | module Opaleye.Table (-- * Defining tables 60 | table, 61 | tableWithSchema, 62 | T.Table, 63 | T.tableField, 64 | T.optionalTableField, 65 | T.requiredTableField, 66 | T.omitOnWriteTableField, 67 | T.InferrableTableField, 68 | -- * Selecting from tables 69 | selectTable, 70 | -- * Data types 71 | TableFields, 72 | -- * Explicit versions 73 | selectTableExplicit, 74 | -- * Deprecated versions 75 | T.readOnlyTableField, 76 | ) where 77 | 78 | import qualified Opaleye.Internal.QueryArr as Q 79 | import qualified Opaleye.Internal.Table as T 80 | import Opaleye.Internal.Table (Table, TableFields) 81 | 82 | import qualified Opaleye.Internal.Tag as Tag 83 | import qualified Opaleye.Internal.Unpackspec as U 84 | 85 | import qualified Opaleye.Select as S 86 | 87 | import qualified Data.Profunctor.Product.Default as D 88 | 89 | -- | Example type specialization: 90 | -- 91 | -- @ 92 | -- selectTable :: Table w (Field a, Field b) 93 | -- -> Select (Field a, Field b) 94 | -- @ 95 | -- 96 | -- Assuming the @makeAdaptorAndInstanceInferrable@ splice has been run for the 97 | -- product type @Foo@: 98 | -- 99 | -- @ 100 | -- selectTable :: Table w (Foo (Field a) (Field b) (Field c)) 101 | -- -> Select (Foo (Field a) (Field b) (Field c)) 102 | -- @ 103 | selectTable :: D.Default U.Unpackspec fields fields 104 | => Table a fields 105 | -- ^ ͘ 106 | -> S.Select fields 107 | selectTable = selectTableExplicit D.def 108 | 109 | -- | Define a table with an unqualified name. 110 | table :: String 111 | -- ^ Table name 112 | -> TableFields writeFields viewFields 113 | -> Table writeFields viewFields 114 | table = T.Table 115 | 116 | -- | Define a table with a qualified name. 117 | tableWithSchema :: String 118 | -- ^ Schema name 119 | -> String 120 | -- ^ Table name 121 | -> TableFields writeFields viewFields 122 | -> Table writeFields viewFields 123 | tableWithSchema = T.TableWithSchema 124 | 125 | -- * Explicit versions 126 | 127 | selectTableExplicit :: U.Unpackspec tablefields fields 128 | -- ^ 129 | -> Table a tablefields 130 | -- ^ ͘ 131 | -> S.Select fields 132 | selectTableExplicit cm table' = Q.productQueryArr $ do 133 | t0 <- Tag.fresh 134 | let (retwires, primQ) = T.queryTable cm table' t0 135 | pure (retwires, primQ) 136 | -------------------------------------------------------------------------------- /src/Opaleye/Binary.hs: -------------------------------------------------------------------------------- 1 | -- | Binary relational operations on 'S.Select's, that is, operations 2 | -- which take two 'S.Select's as arguments and return a single 'S.Select'. 3 | -- 4 | -- All the binary relational operations have the same type 5 | -- specializations. For example: 6 | -- 7 | -- @ 8 | -- unionAll :: S.Select (Field a, Field b) 9 | -- -> S.Select (Field a, Field b) 10 | -- -> S.Select (Field a, Field b) 11 | -- @ 12 | -- 13 | -- Assuming the @makeAdaptorAndInstanceInferrable@ splice has been run for the product type @Foo@: 14 | -- 15 | -- @ 16 | -- unionAll :: S.Select (Foo (Field a) (Field b) (Field c)) 17 | -- -> S.Select (Foo (Field a) (Field b) (Field c)) 18 | -- -> S.Select (Foo (Field a) (Field b) (Field c)) 19 | -- @ 20 | -- 21 | -- If you want to run a binary relational operator on 22 | -- 'Select.SelectArr's you should apply 'Opaleye.Lateral.bilaterally' 23 | -- to it, for example 24 | -- 25 | -- @ 26 | -- 'Opaleye.Lateral.bilaterally' 'union' 27 | -- :: 'Data.Profunctor.Product.Default' 'B.Binaryspec' fields fields 28 | -- => 'S.SelectArr' i fields -> 'S.SelectArr' i fields -> 'S.SelectArr' i fields 29 | -- @ 30 | -- 31 | -- `unionAll` is very close to being the @\<|\>@ operator of a 32 | -- @Control.Applicative.Alternative@ instance but it fails to work 33 | -- only because of the typeclass constraint it has. 34 | 35 | module Opaleye.Binary (-- * Binary operations 36 | unionAll, 37 | union, 38 | intersectAll, 39 | intersect, 40 | exceptAll, 41 | except, 42 | -- * Explicit versions 43 | unionAllExplicit, 44 | unionExplicit, 45 | intersectAllExplicit, 46 | intersectExplicit, 47 | exceptAllExplicit, 48 | exceptExplicit, 49 | -- * Adaptors 50 | binaryspecField, 51 | ) where 52 | 53 | import qualified Opaleye.Internal.Binary as B 54 | import qualified Opaleye.Internal.Column 55 | import qualified Opaleye.Internal.PrimQuery as PQ 56 | import qualified Opaleye.Select as S 57 | 58 | import Data.Profunctor.Product.Default (Default, def) 59 | 60 | unionAll :: Default B.Binaryspec fields fields => 61 | S.Select fields -> S.Select fields -> S.Select fields 62 | unionAll = unionAllExplicit def 63 | 64 | -- | The same as 'unionAll', except that it additionally removes any 65 | -- duplicate rows. 66 | union :: Default B.Binaryspec fields fields => 67 | S.Select fields -> S.Select fields -> S.Select fields 68 | union = unionExplicit def 69 | 70 | intersectAll :: Default B.Binaryspec fields fields => 71 | S.Select fields -> S.Select fields -> S.Select fields 72 | intersectAll = intersectAllExplicit def 73 | 74 | -- | The same as 'intersectAll', except that it additionally removes any 75 | -- duplicate rows. 76 | intersect :: Default B.Binaryspec fields fields => 77 | S.Select fields -> S.Select fields -> S.Select fields 78 | intersect = intersectExplicit def 79 | 80 | exceptAll :: Default B.Binaryspec fields fields => 81 | S.Select fields -> S.Select fields -> S.Select fields 82 | exceptAll = exceptAllExplicit def 83 | 84 | -- | The same as 'exceptAll', except that it additionally removes any 85 | -- duplicate rows. 86 | except :: Default B.Binaryspec fields fields => 87 | S.Select fields -> S.Select fields -> S.Select fields 88 | except = exceptExplicit def 89 | 90 | unionAllExplicit :: B.Binaryspec fields fields' 91 | -> S.Select fields -> S.Select fields -> S.Select fields' 92 | unionAllExplicit = B.sameTypeBinOpHelper PQ.UnionAll 93 | 94 | unionExplicit :: B.Binaryspec fields fields' 95 | -> S.Select fields -> S.Select fields -> S.Select fields' 96 | unionExplicit = B.sameTypeBinOpHelper PQ.Union 97 | 98 | intersectAllExplicit :: B.Binaryspec fields fields' 99 | -> S.Select fields -> S.Select fields -> S.Select fields' 100 | intersectAllExplicit = B.sameTypeBinOpHelper PQ.IntersectAll 101 | 102 | intersectExplicit :: B.Binaryspec fields fields' 103 | -> S.Select fields -> S.Select fields -> S.Select fields' 104 | intersectExplicit = B.sameTypeBinOpHelper PQ.Intersect 105 | 106 | exceptAllExplicit :: B.Binaryspec fields fields' 107 | -> S.Select fields -> S.Select fields -> S.Select fields' 108 | exceptAllExplicit = B.sameTypeBinOpHelper PQ.ExceptAll 109 | 110 | exceptExplicit :: B.Binaryspec fields fields' 111 | -> S.Select fields -> S.Select fields -> S.Select fields' 112 | exceptExplicit = B.sameTypeBinOpHelper PQ.Except 113 | 114 | binaryspecField :: (B.Binaryspec 115 | (Opaleye.Internal.Column.Field_ n a) 116 | (Opaleye.Internal.Column.Field_ n a)) 117 | binaryspecField = B.binaryspecColumn 118 | -------------------------------------------------------------------------------- /opaleye-sqlite/src/Opaleye/SQLite/PGTypes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | 3 | module Opaleye.SQLite.PGTypes (module Opaleye.SQLite.PGTypes) where 4 | 5 | import Opaleye.SQLite.Internal.Column (Column) 6 | import qualified Opaleye.SQLite.Internal.Column as C 7 | import qualified Opaleye.SQLite.Internal.PGTypes as IPT 8 | 9 | import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as HPQ 10 | import qualified Opaleye.SQLite.Internal.HaskellDB.Sql.Default as HSD (quote) 11 | 12 | import qualified Data.CaseInsensitive as CI 13 | import qualified Data.Text as SText 14 | import qualified Data.Text.Lazy as LText 15 | import qualified Data.ByteString as SByteString 16 | import qualified Data.ByteString.Lazy as LByteString 17 | import qualified Data.Time as Time 18 | import qualified Data.UUID as UUID 19 | 20 | import Data.Int (Int64) 21 | 22 | data PGBool 23 | data PGDate 24 | data PGFloat4 25 | data PGFloat8 26 | data PGInt8 27 | data PGInt4 28 | data PGInt2 29 | data PGNumeric 30 | data PGText 31 | data PGTime 32 | data PGTimestamp 33 | data PGTimestamptz 34 | data PGUuid 35 | data PGCitext 36 | data PGArray a 37 | data PGBytea 38 | data PGJson 39 | data PGJsonb 40 | 41 | instance C.PGNum PGFloat8 where 42 | pgFromInteger = pgDouble . fromInteger 43 | 44 | instance C.PGNum PGInt4 where 45 | pgFromInteger = pgInt4 . fromInteger 46 | 47 | instance C.PGNum PGInt8 where 48 | pgFromInteger = pgInt8 . fromInteger 49 | 50 | instance C.PGFractional PGFloat8 where 51 | pgFromRational = pgDouble . fromRational 52 | 53 | literalColumn :: HPQ.Literal -> Column a 54 | literalColumn = IPT.literalColumn 55 | {-# WARNING literalColumn 56 | "'literalColumn' has been moved to Opaleye.Internal.PGTypes" 57 | #-} 58 | 59 | pgString :: String -> Column PGText 60 | pgString = IPT.literalColumn . HPQ.StringLit 61 | 62 | pgLazyByteString :: LByteString.ByteString -> Column PGBytea 63 | pgLazyByteString = IPT.literalColumn . HPQ.ByteStringLit . LByteString.toStrict 64 | 65 | pgStrictByteString :: SByteString.ByteString -> Column PGBytea 66 | pgStrictByteString = IPT.literalColumn . HPQ.ByteStringLit 67 | 68 | pgStrictText :: SText.Text -> Column PGText 69 | pgStrictText = IPT.literalColumn . HPQ.StringLit . SText.unpack 70 | 71 | pgLazyText :: LText.Text -> Column PGText 72 | pgLazyText = IPT.literalColumn . HPQ.StringLit . LText.unpack 73 | 74 | pgInt4 :: Int -> Column PGInt4 75 | pgInt4 = IPT.literalColumn . HPQ.IntegerLit . fromIntegral 76 | 77 | pgInt8 :: Int64 -> Column PGInt8 78 | pgInt8 = IPT.literalColumn . HPQ.IntegerLit . fromIntegral 79 | 80 | -- SQLite needs to be told that numeric literals without decimal 81 | -- points are actual REAL 82 | pgDouble :: Double -> Column PGFloat8 83 | pgDouble = C.unsafeCast "REAL" . IPT.literalColumn . HPQ.DoubleLit 84 | 85 | pgBool :: Bool -> Column PGBool 86 | pgBool = IPT.literalColumn . HPQ.BoolLit 87 | 88 | pgUUID :: UUID.UUID -> Column PGUuid 89 | pgUUID = IPT.literalColumn . HPQ.StringLit . UUID.toString 90 | 91 | unsafePgFormatTime :: Time.FormatTime t => HPQ.Name -> String -> t -> Column c 92 | unsafePgFormatTime = IPT.unsafePgFormatTime 93 | {-# WARNING unsafePgFormatTime 94 | "'unsafePgFormatTime' has been moved to Opaleye.Internal.PGTypes" 95 | #-} 96 | 97 | pgDay :: Time.Day -> Column PGDate 98 | pgDay = IPT.unsafePgFormatTime "date" "'%F'" 99 | 100 | pgUTCTime :: Time.UTCTime -> Column PGTimestamptz 101 | pgUTCTime = IPT.unsafePgFormatTime "timestamptz" "'%FT%TZ'" 102 | 103 | pgLocalTime :: Time.LocalTime -> Column PGTimestamp 104 | pgLocalTime = IPT.unsafePgFormatTime "timestamp" "'%FT%T'" 105 | 106 | pgTimeOfDay :: Time.TimeOfDay -> Column PGTime 107 | pgTimeOfDay = IPT.unsafePgFormatTime "time" "'%T'" 108 | 109 | -- "We recommend not using the type time with time zone" 110 | -- http://www.postgresql.org/docs/8.3/static/datatype-datetime.html 111 | 112 | 113 | pgCiStrictText :: CI.CI SText.Text -> Column PGCitext 114 | pgCiStrictText = IPT.literalColumn . HPQ.StringLit . SText.unpack . CI.original 115 | 116 | pgCiLazyText :: CI.CI LText.Text -> Column PGCitext 117 | pgCiLazyText = IPT.literalColumn . HPQ.StringLit . LText.unpack . CI.original 118 | 119 | -- No CI String instance since postgresql-simple doesn't define FromField (CI String) 120 | 121 | -- The json data type was introduced in PostgreSQL version 9.2 122 | -- JSON values must be SQL string quoted 123 | pgJSON :: String -> Column PGJson 124 | pgJSON = IPT.castToType "json" . HSD.quote 125 | 126 | pgStrictJSON :: SByteString.ByteString -> Column PGJson 127 | pgStrictJSON = pgJSON . IPT.strictDecodeUtf8 128 | 129 | pgLazyJSON :: LByteString.ByteString -> Column PGJson 130 | pgLazyJSON = pgJSON . IPT.lazyDecodeUtf8 131 | 132 | -- The jsonb data type was introduced in PostgreSQL version 9.4 133 | -- JSONB values must be SQL string quoted 134 | -- 135 | -- TODO: We need to add literal JSON and JSONB types. 136 | pgJSONB :: String -> Column PGJsonb 137 | pgJSONB = IPT.castToType "jsonb" . HSD.quote 138 | 139 | pgStrictJSONB :: SByteString.ByteString -> Column PGJsonb 140 | pgStrictJSONB = pgJSONB . IPT.strictDecodeUtf8 141 | 142 | pgLazyJSONB :: LByteString.ByteString -> Column PGJsonb 143 | pgLazyJSONB = pgJSONB . IPT.lazyDecodeUtf8 144 | -------------------------------------------------------------------------------- /opaleye-sqlite/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014-2015 Purely Agile Limited 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 9 | * Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above 13 | copyright notice, this list of conditions and the following 14 | disclaimer in the documentation and/or other materials provided 15 | with the distribution. 16 | 17 | * Neither the names of the copyright holders nor the names of the 18 | contributors may be used to endorse or promote products derived 19 | from this software without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 24 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 25 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 26 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 27 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 28 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 29 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 30 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 31 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 32 | 33 | 34 | 35 | * Opaleye is based on code from Karamaan Group LLC under the following license 36 | 37 | 38 | Copyright (c) 2013, 2014, Karamaan Group LLC 39 | 40 | All rights reserved. 41 | 42 | Redistribution and use in source and binary forms, with or without 43 | modification, are permitted provided that the following conditions are met: 44 | 45 | 1. Redistributions of source code must retain the above copyright notice, 46 | this list of conditions and the following disclaimer. 47 | 48 | 2. Redistributions in binary form must reproduce the above copyright notice, 49 | this list of conditions and the following disclaimer in the documentation 50 | and/or other materials provided with the distribution. 51 | 52 | 3. Neither the name of Karamaan Group LLC nor the names of its contributors 53 | may be used to endorse or promote products derived from this software 54 | without specific prior written permission. 55 | 56 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 57 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 58 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 59 | ARE DISCLAIMED. IN NO EVENT SHALL KARAMAAN GROUP LLC OR ITS AFFILIATES BE 60 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 61 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 62 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 63 | INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 64 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 65 | ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 66 | POSSIBILITY OF SUCH DAMAGE. 67 | 68 | 69 | 70 | * Opaleye contains code from the HaskellDB project under the following license 71 | 72 | 73 | Copyright (c) 1999 Daan Leijen, daan@cs.uu.nl 74 | Copyright (c) 2003-2004 The HaskellDB development team 75 | All rights reserved. 76 | 77 | Redistribution and use in source and binary forms, with or without 78 | modification, are permitted provided that the following conditions are 79 | met: 80 | 81 | * Redistributions of source code must retain the above copyright 82 | notice, this list of conditions and the following disclaimer. 83 | 84 | * Redistributions in binary form must reproduce the above 85 | copyright notice, this list of conditions and the following 86 | disclaimer in the documentation and/or other materials provided 87 | with the distribution. 88 | 89 | * Neither the names of the copyright holders nor the names of the 90 | contributors may be used to endorse or promote products derived 91 | from this software without specific prior written permission. 92 | 93 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 94 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 95 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 96 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 97 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 98 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 99 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 100 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 101 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 102 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 103 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 104 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014-2018 Purely Agile Limited; 2019-2025 Tom Ellis 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 9 | * Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above 13 | copyright notice, this list of conditions and the following 14 | disclaimer in the documentation and/or other materials provided 15 | with the distribution. 16 | 17 | * Neither the names of the copyright holders nor the names of the 18 | contributors may be used to endorse or promote products derived 19 | from this software without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 24 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 25 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 26 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 27 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 28 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 29 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 30 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 31 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 32 | 33 | 34 | 35 | * Opaleye is based on code from Karamaan Group LLC under the following license 36 | 37 | 38 | Copyright (c) 2013, 2014, Karamaan Group LLC 39 | 40 | All rights reserved. 41 | 42 | Redistribution and use in source and binary forms, with or without 43 | modification, are permitted provided that the following conditions are met: 44 | 45 | 1. Redistributions of source code must retain the above copyright notice, 46 | this list of conditions and the following disclaimer. 47 | 48 | 2. Redistributions in binary form must reproduce the above copyright notice, 49 | this list of conditions and the following disclaimer in the documentation 50 | and/or other materials provided with the distribution. 51 | 52 | 3. Neither the name of Karamaan Group LLC nor the names of its contributors 53 | may be used to endorse or promote products derived from this software 54 | without specific prior written permission. 55 | 56 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 57 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 58 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 59 | ARE DISCLAIMED. IN NO EVENT SHALL KARAMAAN GROUP LLC OR ITS AFFILIATES BE 60 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 61 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 62 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 63 | INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 64 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 65 | ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 66 | POSSIBILITY OF SUCH DAMAGE. 67 | 68 | 69 | 70 | * Opaleye contains code from the HaskellDB project under the following license 71 | 72 | 73 | Copyright (c) 1999 Daan Leijen, daan@cs.uu.nl 74 | Copyright (c) 2003-2004 The HaskellDB development team 75 | All rights reserved. 76 | 77 | Redistribution and use in source and binary forms, with or without 78 | modification, are permitted provided that the following conditions are 79 | met: 80 | 81 | * Redistributions of source code must retain the above copyright 82 | notice, this list of conditions and the following disclaimer. 83 | 84 | * Redistributions in binary form must reproduce the above 85 | copyright notice, this list of conditions and the following 86 | disclaimer in the documentation and/or other materials provided 87 | with the distribution. 88 | 89 | * Neither the names of the copyright holders nor the names of the 90 | contributors may be used to endorse or promote products derived 91 | from this software without specific prior written permission. 92 | 93 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 94 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 95 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 96 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 97 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 98 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 99 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 100 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 101 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 102 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 103 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 104 | -------------------------------------------------------------------------------- /opaleye-sqlite/opaleye-sqlite.cabal: -------------------------------------------------------------------------------- 1 | name: opaleye-sqlite 2 | copyright: Copyright (c) 2014-2015 Purely Agile Limited 3 | version: 0.0.1.1 4 | synopsis: An SQL-generating DSL targeting SQLite 5 | description: An SQL-generating DSL targeting SQLite. Allows 6 | SQLite queries to be written within Haskell in a 7 | typesafe and composable fashion. 8 | 9 | This package is old and unmaintained. It may work, or 10 | it may not. If you are interested in reviving it 11 | please file an issue on the GitHub repository. 12 | homepage: https://github.com/tomjaguarpaw/haskell-opaleye 13 | bug-reports: https://github.com/tomjaguarpaw/haskell-opaleye/issues 14 | license: BSD3 15 | license-file: LICENSE 16 | author: Purely Agile 17 | maintainer: Purely Agile 18 | category: Database 19 | build-type: Simple 20 | cabal-version: 1.18 21 | extra-doc-files: Doc/*.md 22 | tested-with: GHC==7.10.1, GHC==7.8.4, GHC==7.6.3 23 | 24 | source-repository head 25 | type: git 26 | location: https://github.com/tomjaguarpaw/haskell-opaleye.git 27 | 28 | library 29 | default-language: Haskell2010 30 | hs-source-dirs: src 31 | build-depends: 32 | base >= 4 && < 5 33 | , base16-bytestring >= 0.1.1.6 && < 0.2 34 | , case-insensitive >= 1.2 && < 1.3 35 | , bytestring >= 0.10 && < 0.11 36 | , contravariant >= 1.2 && < 1.6 37 | , direct-sqlite >= 2.3.13 && < 2.4 38 | , pretty >= 1.1.1.0 && < 1.2 39 | , product-profunctors >= 0.6.2 && < 0.12 40 | , profunctors >= 4.0 && < 5.6 41 | , semigroups >= 0.13 && < 0.20 42 | , sqlite-simple 43 | , text >= 0.11 && < 1.3 44 | , transformers >= 0.3 && < 0.6 45 | , time >= 1.4 && < 1.10 46 | , time-locale-compat >= 0.1 && < 0.2 47 | , uuid >= 1.3 && < 1.4 48 | , void >= 0.4 && < 0.8 49 | exposed-modules: Opaleye.SQLite, 50 | Opaleye.SQLite.Aggregate, 51 | Opaleye.SQLite.Binary, 52 | Opaleye.SQLite.Column, 53 | Opaleye.SQLite.Constant, 54 | Opaleye.SQLite.Distinct, 55 | Opaleye.SQLite.Join, 56 | Opaleye.SQLite.Manipulation, 57 | Opaleye.SQLite.Operators, 58 | Opaleye.SQLite.Order, 59 | Opaleye.SQLite.PGTypes, 60 | Opaleye.SQLite.QueryArr, 61 | Opaleye.SQLite.RunQuery, 62 | Opaleye.SQLite.Sql, 63 | Opaleye.SQLite.SqlTypes, 64 | Opaleye.SQLite.Table, 65 | Opaleye.SQLite.Values, 66 | Opaleye.SQLite.Internal.Aggregate, 67 | Opaleye.SQLite.Internal.Binary, 68 | Opaleye.SQLite.Internal.Column, 69 | Opaleye.SQLite.Internal.Distinct, 70 | Opaleye.SQLite.Internal.Helpers, 71 | Opaleye.SQLite.Internal.Join, 72 | Opaleye.SQLite.Internal.Order, 73 | Opaleye.SQLite.Internal.Optimize, 74 | Opaleye.SQLite.Internal.PackMap, 75 | Opaleye.SQLite.Internal.PGTypes, 76 | Opaleye.SQLite.Internal.PrimQuery, 77 | Opaleye.SQLite.Internal.Print, 78 | Opaleye.SQLite.Internal.QueryArr, 79 | Opaleye.SQLite.Internal.RunQuery, 80 | Opaleye.SQLite.Internal.Sql, 81 | Opaleye.SQLite.Internal.Table, 82 | Opaleye.SQLite.Internal.TableMaker, 83 | Opaleye.SQLite.Internal.Tag, 84 | Opaleye.SQLite.Internal.Unpackspec, 85 | Opaleye.SQLite.Internal.Values 86 | Opaleye.SQLite.Internal.HaskellDB.PrimQuery, 87 | Opaleye.SQLite.Internal.HaskellDB.Sql, 88 | Opaleye.SQLite.Internal.HaskellDB.Sql.Default, 89 | Opaleye.SQLite.Internal.HaskellDB.Sql.Generate, 90 | Opaleye.SQLite.Internal.HaskellDB.Sql.Print 91 | ghc-options: -Wall 92 | 93 | test-suite test 94 | default-language: Haskell2010 95 | type: exitcode-stdio-1.0 96 | main-is: Test.hs 97 | other-modules: QuickCheck 98 | hs-source-dirs: Test 99 | build-depends: 100 | base >= 4 && < 5, 101 | containers, 102 | contravariant, 103 | profunctors, 104 | product-profunctors, 105 | QuickCheck, 106 | semigroups, 107 | sqlite-simple, 108 | opaleye-sqlite 109 | ghc-options: -Wall 110 | 111 | test-suite tutorial 112 | default-language: Haskell2010 113 | type: exitcode-stdio-1.0 114 | main-is: Main.hs 115 | other-modules: TutorialAdvanced, 116 | TutorialBasic, 117 | TutorialManipulation, 118 | DefaultExplanation 119 | hs-source-dirs: Doc/Tutorial 120 | build-depends: 121 | base >= 4 && < 5, 122 | profunctors, 123 | product-profunctors >= 0.6, 124 | sqlite-simple, 125 | time, 126 | opaleye-sqlite 127 | ghc-options: -Wall 128 | -------------------------------------------------------------------------------- /src/Opaleye/Internal/Order.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | 3 | module Opaleye.Internal.Order where 4 | 5 | import Data.Function (on) 6 | import qualified Data.Functor.Contravariant as C 7 | import qualified Data.Functor.Contravariant.Divisible as Divisible 8 | import qualified Data.List.NonEmpty as NL 9 | import qualified Data.Monoid as M 10 | import qualified Data.Profunctor as P 11 | import qualified Data.Semigroup as S 12 | import qualified Data.Void as Void 13 | import qualified Opaleye.Field as F 14 | import qualified Opaleye.Internal.Column as IC 15 | import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ 16 | import qualified Opaleye.Internal.PrimQuery as PQ 17 | import qualified Opaleye.Internal.Unpackspec as U 18 | 19 | {-| 20 | An `Order` @a@ represents a sort order and direction for the elements 21 | of the type @a@. Multiple `Order`s can be composed with 22 | `Data.Monoid.mappend` or @(\<\>)@ from "Data.Monoid". If two rows are 23 | equal according to the first `Order` in the @mappend@, the second is 24 | used, and so on. 25 | -} 26 | 27 | -- Like the (columns -> RowParser haskells) field of FromFields this 28 | -- type is "too big". We never actually look at the 'a' (in the 29 | -- FromFields case the 'columns') except to check the "structure". 30 | -- This is so we can support a SumProfunctor instance. 31 | newtype Order a = Order (a -> [(HPQ.OrderOp, HPQ.PrimExpr)]) 32 | 33 | instance C.Contravariant Order where 34 | contramap f (Order g) = Order (P.lmap f g) 35 | 36 | instance S.Semigroup (Order a) where 37 | Order o <> Order o' = Order (o S.<> o') 38 | 39 | instance M.Monoid (Order a) where 40 | mempty = Order M.mempty 41 | mappend = (S.<>) 42 | 43 | instance Divisible.Divisible Order where 44 | divide f o o' = M.mappend (C.contramap (fst . f) o) 45 | (C.contramap (snd . f) o') 46 | conquer = M.mempty 47 | 48 | instance Divisible.Decidable Order where 49 | lose f = C.contramap f (Order Void.absurd) 50 | choose f (Order o) (Order o') = C.contramap f (Order (either o o')) 51 | 52 | order :: HPQ.OrderOp -> (a -> F.Field_ n b) -> Order a 53 | order op f = Order (fmap (\column -> [(op, IC.unColumn column)]) f) 54 | 55 | orderByU :: Order a -> (a, PQ.PrimQuery) -> (a, PQ.PrimQuery) 56 | orderByU os (columns, primQ) = (columns, primQ') 57 | where primQ' = PQ.DistinctOnOrderBy Nothing oExprs primQ 58 | oExprs = orderExprs columns os 59 | 60 | orderExprs :: a -> Order a -> [HPQ.OrderExpr] 61 | orderExprs x (Order os) = map (uncurry HPQ.OrderExpr) (os x) 62 | 63 | limit' :: HPQ.PrimExpr -> (a, PQ.PrimQuery) -> (a, PQ.PrimQuery) 64 | limit' n (x, q) = (x, PQ.Limit (PQ.LimitOp n) q) 65 | 66 | offset' :: HPQ.PrimExpr -> (a, PQ.PrimQuery) -> (a, PQ.PrimQuery) 67 | offset' n (x, q) = (x, PQ.Limit (PQ.OffsetOp n) q) 68 | 69 | distinctOn :: U.Unpackspec b b -> (a -> b) 70 | -> (a, PQ.PrimQuery) -> (a, PQ.PrimQuery) 71 | distinctOn ups proj = distinctOnBy ups proj M.mempty 72 | 73 | distinctOnBy :: U.Unpackspec b b -> (a -> b) -> Order a 74 | -> (a, PQ.PrimQuery) -> (a, PQ.PrimQuery) 75 | distinctOnBy ups proj ord (cols, pq) = (cols, pqOut) 76 | where pqOut = case NL.nonEmpty (U.collectPEs ups (proj cols)) of 77 | Just xs -> PQ.DistinctOnOrderBy (Just xs) oexprs pq 78 | Nothing -> PQ.Limit (PQ.LimitOp one) (PQ.DistinctOnOrderBy Nothing oexprs pq) 79 | oexprs = orderExprs cols ord 80 | one = HPQ.ConstExpr (HPQ.IntegerLit 1) 81 | 82 | -- | Order the results of a given query exactly, as determined by the given list 83 | -- of input fields. Note that this list does not have to contain an entry for 84 | -- every result in your query: you may exactly order only a subset of results, 85 | -- if you wish. Rows that are not ordered according to the input list are 86 | -- returned /after/ the ordered results, in the usual order the database would 87 | -- return them (e.g. sorted by primary key). Exactly-ordered results always come 88 | -- first in a result set. Entries in the input list that are /not/ present in 89 | -- result of a query are ignored. 90 | exact :: [IC.Field_ n b] -> (a -> IC.Field_ n b) -> Order a 91 | exact xs k = maybe M.mempty go (NL.nonEmpty xs) where 92 | -- Create an equality AST node, between two columns, essentially 93 | -- stating "(column = value)" syntactically. 94 | mkEq = HPQ.BinExpr (HPQ.:=) `on` IC.unColumn 95 | 96 | -- The AST operation: ORDER BY (equalities...) DESC NULLS FIRST 97 | -- NOTA BENE: DESC is mandatory (otherwise the result is reversed, as you are 98 | -- "descending" down the list of equalities from the front, rather than 99 | -- "ascending" from the end of the list.) NULLS FIRST strictly isn't needed; 100 | -- but HPQ.OrderOp currently mandates a value for both the direction 101 | -- (OrderDirection) and the rules for null (OrderNulls) values, in the 102 | -- OrderOp constructor. 103 | astOp = HPQ.OrderOp HPQ.OpDesc HPQ.NullsFirst 104 | 105 | -- Final result: ORDER BY (equalities...) DESC NULLS FIRST, with a given 106 | -- list of equality operations, created via 'mkEq' 107 | go givenOrder = Order $ flip fmap k $ \col -> 108 | [(astOp, HPQ.ListExpr $ NL.map (mkEq col) givenOrder)] 109 | -------------------------------------------------------------------------------- /opaleye-sqlite/src/Opaleye/SQLite/Internal/PackMap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Rank2Types #-} 2 | 3 | module Opaleye.SQLite.Internal.PackMap where 4 | 5 | import qualified Opaleye.SQLite.Internal.Tag as T 6 | 7 | import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as HPQ 8 | 9 | import Control.Applicative (Applicative, pure, (<*>), liftA2) 10 | import qualified Control.Monad.Trans.State as State 11 | import Data.Profunctor (Profunctor, dimap) 12 | import Data.Profunctor.Product (ProductProfunctor, empty, (***!)) 13 | import qualified Data.Profunctor.Product as PP 14 | import qualified Data.Functor.Identity as I 15 | 16 | -- This is rather like a Control.Lens.Traversal with the type 17 | -- parameters switched but I'm not sure if it should be required to 18 | -- obey the same laws. 19 | -- 20 | -- TODO: We could attempt to generalise this to 21 | -- 22 | -- data LensLike f a b s t = LensLike ((a -> f b) -> s -> f t) 23 | -- 24 | -- i.e. a wrapped, argument-flipped Control.Lens.LensLike 25 | -- 26 | -- This would allow us to do the Profunctor and ProductProfunctor 27 | -- instances (requiring just Functor f and Applicative f respectively) 28 | -- and share them between many different restrictions of f. For 29 | -- example, TableColumnMaker is like a Setter so we would restrict f 30 | -- to the Distributive case. 31 | 32 | -- | A 'PackMap' @a@ @b@ @s@ @t@ encodes how an @s@ contains an 33 | -- updatable sequence of @a@ inside it. Each @a@ in the sequence can 34 | -- be updated to a @b@ (and the @s@ changes to a @t@ to reflect this 35 | -- change of type). 36 | -- 37 | -- 'PackMap' is just like a @Traversal@ from the lens package. 38 | -- 'PackMap' has a different order of arguments to @Traversal@ because 39 | -- it typically needs to be made a 'Profunctor' (and indeed 40 | -- 'ProductProfunctor') in @s@ and @t@. It is unclear at this point 41 | -- whether we want the same @Traversal@ laws to hold or not. Our use 42 | -- cases may be much more general. 43 | data PackMap a b s t = PackMap (forall f. Applicative f => 44 | (a -> f b) -> s -> f t) 45 | 46 | -- | Replaces the targeted occurrences of @a@ in @s@ with @b@ (changing 47 | -- the @s@ to a @t@ in the process). This can be done via an 48 | -- 'Applicative' action. 49 | -- 50 | -- 'traversePM' is just like @traverse@ from the @lens@ package. 51 | -- 'traversePM' used to be called @packmap@. 52 | traversePM :: Applicative f => PackMap a b s t -> (a -> f b) -> s -> f t 53 | traversePM (PackMap f) = f 54 | 55 | -- | Modify the targeted occurrences of @a@ in @s@ with @b@ (changing 56 | -- the @s@ to a @t@ in the process). 57 | -- 58 | -- 'overPM' is just like @over@ from the @lens@ package. 59 | overPM :: PackMap a b s t -> (a -> b) -> s -> t 60 | overPM p f = I.runIdentity . traversePM p (I.Identity . f) 61 | 62 | 63 | -- { 64 | 65 | -- | A helpful monad for writing columns in the AST 66 | type PM a = State.State (a, Int) 67 | 68 | new :: PM a String 69 | new = do 70 | (a, i) <- State.get 71 | State.put (a, i + 1) 72 | return (show i) 73 | 74 | write :: a -> PM [a] () 75 | write a = do 76 | (as, i) <- State.get 77 | State.put (as ++ [a], i) 78 | 79 | run :: PM [a] r -> (r, [a]) 80 | run m = (r, as) 81 | where (r, (as, _)) = State.runState m ([], 0) 82 | 83 | -- } 84 | 85 | 86 | -- { General functions for writing columns in the AST 87 | 88 | -- | Make a fresh name for an input value (the variable @primExpr@ 89 | -- type is typically actually a 'HPQ.PrimExpr') based on the supplied 90 | -- function and the unique 'T.Tag' that is used as part of our 91 | -- @QueryArr@. 92 | -- 93 | -- Add the fresh name and the input value it refers to the list in 94 | -- the state parameter. 95 | extractAttrPE :: (primExpr -> String -> String) -> T.Tag -> primExpr 96 | -> PM [(HPQ.Symbol, primExpr)] HPQ.PrimExpr 97 | extractAttrPE mkName t pe = do 98 | i <- new 99 | let s = HPQ.Symbol (mkName pe i) t 100 | write (s, pe) 101 | return (HPQ.AttrExpr s) 102 | 103 | -- | As 'extractAttrPE' but ignores the 'primExpr' when making the 104 | -- fresh column name and just uses the supplied 'String' and 'T.Tag'. 105 | extractAttr :: String -> T.Tag -> primExpr 106 | -> PM [(HPQ.Symbol, primExpr)] HPQ.PrimExpr 107 | extractAttr s = extractAttrPE (const (s ++)) 108 | 109 | -- } 110 | 111 | eitherFunction :: Functor f 112 | => (a -> f b) 113 | -> (a' -> f b') 114 | -> Either a a' 115 | -> f (Either b b') 116 | eitherFunction f g = fmap (either (fmap Left) (fmap Right)) (f PP.+++! g) 117 | 118 | -- { 119 | 120 | -- Boilerplate instance definitions. There's no choice here apart 121 | -- from the order in which the applicative is applied. 122 | 123 | instance Functor (PackMap a b s) where 124 | fmap f (PackMap g) = PackMap ((fmap . fmap . fmap) f g) 125 | 126 | instance Applicative (PackMap a b s) where 127 | pure x = PackMap (pure (pure (pure x))) 128 | PackMap f <*> PackMap x = PackMap (liftA2 (liftA2 (<*>)) f x) 129 | 130 | instance Profunctor (PackMap a b) where 131 | dimap f g (PackMap q) = PackMap (fmap (dimap f (fmap g)) q) 132 | 133 | instance ProductProfunctor (PackMap a b) where 134 | empty = PP.defaultEmpty 135 | (***!) = PP.defaultProfunctorProduct 136 | 137 | instance PP.SumProfunctor (PackMap a b) where 138 | f +++! g = (PackMap (\x -> eitherFunction (f' x) (g' x))) 139 | where PackMap f' = f 140 | PackMap g' = g 141 | 142 | -- } 143 | --------------------------------------------------------------------------------