hasql-generic (empty) → 0.1.0.4
raw patch · 5 files changed
+590/−0 lines, 5 filesdep +aesondep +basedep +binary-parsersetup-changed
Dependencies added: aeson, base, binary-parser, bytestring, containers, contravariant, generics-sop, hasql, postgresql-binary, scientific, text, time, uuid, vector
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- hasql-generic.cabal +38/−0
- src/Hasql/Generic/HasParams.hs +258/−0
- src/Hasql/Generic/HasRow.hs +262/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Chris Kahn (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hasql-generic.cabal view
@@ -0,0 +1,38 @@+name: hasql-generic+version: 0.1.0.4+synopsis: Generic encoder and decoder deriving for Hasql+description: Please see README.md+homepage: https://github.com/chris-kahn/hasql-generic#readme+license: BSD3+license-file: LICENSE+author: Chris Kahn+maintainer: chris@kahn.pro+copyright: 2016 Chris Kahn+category: Web+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Hasql.Generic.HasRow+ , Hasql.Generic.HasParams+ build-depends: base >= 4.7 && < 5+ , aeson >= 0.11 && < 1.1+ , binary-parser >= 0.5 && < 0.6+ , bytestring >= 0.10 && < 0.11+ , containers >= 0.5 && < 0.6+ , contravariant >= 1.4 && < 1.5+ , generics-sop >= 0.2 && < 0.3+ , hasql >= 0.19 && < 0.20+ , postgresql-binary >= 0.9 && < 0.10+ , scientific >= 0.3 && < 0.4+ , text >= 1.2 && < 1.3+ , time >= 1.6 && < 1.8+ , uuid >= 1.3 && < 1.4+ , vector >= 0.11 && < 0.12+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/chris-kahn/hasql-generic
+ src/Hasql/Generic/HasParams.hs view
@@ -0,0 +1,258 @@+--------------------------------------------------------------------------------+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+module Hasql.Generic.HasParams+ ( HasParams+ , HasEField+ , HasEValue+ , mkParams+ , mkEField+ , mkEValue+ , gParams+ , gEEnumValue+ ) where++--------------------------------------------------------------------------------+import qualified Data.Aeson.Types as JSON+import Data.ByteString (ByteString)+import Data.Foldable (foldl')+import Data.Functor.Contravariant+import Data.Int (Int16, Int32, Int64)+import qualified Data.Map as Map+import Data.Scientific (Scientific)+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Time (Day, DiffTime, LocalTime,+ TimeOfDay, TimeZone, UTCTime)+import Data.UUID (UUID)+import Data.Vector (Vector)+import qualified Data.Vector as Vector+import Data.Word (Word16, Word32, Word64)+import Generics.SOP+import qualified GHC.Generics as GHC+import Hasql.Encoders++--------------------------------------------------------------------------------+-- |+-- A type that can be encoded into database parameters, using Hasql's `Params` encoder.+--+-- Your data type needs to derive GHC `GHC.Generics.Generic`, and using this derive+-- an instance of SOP `Generics.SOP.Generic`. From here you can derive an instance+-- of `HasParams`. This gives you access to a value `mkParams`, which you can use+-- to get a value of type `Hasql.Encoders.Params`.+--+-- @+-- {-\# DeriveGeneric #-}+--+-- import Data.Text (Text)+-- import Data.UUID (UUID)+-- import qualified GHC.Generics as GHC+-- import Generics.SOP+-- import Hasql.Query (statement)+-- import Hasql.Session (Session, query)+-- import qualified Hasql.Decoders as HD+-- import qualified Hasql.Encoders as HE+--+-- data Person = Person+-- { personId :: UUID+-- , personName :: Text+-- , personAge :: Int+-- } deriving (GHC.Generic)+--+-- instance Generic Person+-- instance HasParams Person+--+-- \-- Search for a 'Person' with a matching UUID+-- createPerson :: Person -> Session ()+-- createPerson person =+-- query person preparedStatement+-- where+-- preparedStatement = statement sql encoder decoder True+-- sql = "INSERT INTO people (id, name, age) VALUES ($1, $2, $3)"+-- encoder = mkParams+-- decoder = HD.unit+-- @+class HasParams a where+ mkParams :: Params a+ default mkParams :: (Generic a, Code a ~ '[ xs ], All HasEField xs) => Params a+ mkParams = gParams++--------------------------------------------------------------------------------+-- | A type representing a value encoder lifted into a composable params encoder.+-- Fields with `HasEValue` instances will be automatically lifted into some+-- common wrappers, including vectors, lists, and maybe.+class HasEField a where+ mkEField :: Params a++--------------------------------------------------------------------------------+-- | A type representing a encoder of an individual value. Instances should be+-- defined manually for each type.+class HasEValue a where+ mkEValue :: Value a++--------------------------------------------------------------------------------+-- | Generate a 'Params a' generically+gParams :: (Generic a, Code a ~ '[ xs ], All HasEField xs) => Params a+gParams =+ contramap (unZ . unSOP . from)+ (mconcat $ hcollapse+ (hcmap (Proxy :: Proxy HasEField)+ (\ (Fn p) -> K (contramap (unI . p . K) mkEField))+ projections+ )+ )++--------------------------------------------------------------------------------+class (a ~ b) => Equal a b+instance (a ~ b) => Equal a b++--------------------------------------------------------------------------------+-- | Derive a 'HasEValue' for enumeration types+gEEnumValue :: (Generic a, All (Equal '[]) (Code a)) => NP (K Text) (Code a) -> Value a+gEEnumValue names = enum $ hcollapse . hzipWith const names . unSOP . from++--------------------------------------------------------------------------------+-- Instances for common data types++instance HasEValue Bool where+ {-# INLINE mkEValue #-}+ mkEValue = bool++instance HasEValue Int16 where+ {-# INLINE mkEValue #-}+ mkEValue = int2++instance HasEValue Int32 where+ {-# INLINE mkEValue #-}+ mkEValue = int4++instance HasEValue Int64 where+ {-# INLINE mkEValue #-}+ mkEValue = int8++instance HasEValue Float where+ {-# INLINE mkEValue #-}+ mkEValue = float4++instance HasEValue Double where+ {-# INLINE mkEValue #-}+ mkEValue = float8++instance HasEValue Scientific where+ {-# INLINE mkEValue #-}+ mkEValue = numeric++instance HasEValue Char where+ {-# INLINE mkEValue #-}+ mkEValue = char++instance HasEValue Text where+ {-# INLINE mkEValue #-}+ mkEValue = text++instance HasEValue ByteString where+ {-# INLINE mkEValue #-}+ mkEValue = bytea++instance HasEValue Day where+ {-# INLINE mkEValue #-}+ mkEValue = date++instance HasEValue LocalTime where+ {-# INLINE mkEValue #-}+ mkEValue = timestamp++instance HasEValue UTCTime where+ {-# INLINE mkEValue #-}+ mkEValue = timestamptz++instance HasEValue TimeOfDay where+ {-# INLINE mkEValue #-}+ mkEValue = time++instance HasEValue (TimeOfDay, TimeZone) where+ {-# INLINE mkEValue #-}+ mkEValue = timetz++instance HasEValue DiffTime where+ {-# INLINE mkEValue #-}+ mkEValue = interval++instance HasEValue UUID where+ {-# INLINE mkEValue #-}+ mkEValue = uuid++instance HasEValue JSON.Value where+ {-# INLINE mkEValue #-}+ mkEValue = jsonb+++--------------------------------------------------------------------------------+instance HasEValue a => HasEField [Maybe a] where+ {-# INLINE mkEField #-}+ mkEField = value $ array (arrayDimension foldl' (arrayNullableValue mkEValue))++instance HasEValue a => HasEField [a] where+ {-# INLINE mkEField #-}+ mkEField = value $ array (arrayDimension foldl' (arrayValue mkEValue))++instance HasEValue a => HasEField (Vector (Maybe a)) where+ {-# INLINE mkEField #-}+ mkEField = value $ array (arrayDimension Vector.foldl' (arrayNullableValue mkEValue))++instance HasEValue a => HasEField (Vector a) where+ {-# INLINE mkEField #-}+ mkEField = value $ array (arrayDimension Vector.foldl' (arrayValue mkEValue))++instance HasEValue a => HasEField (Maybe a) where+ {-# INLINE mkEField #-}+ mkEField = nullableValue mkEValue++instance HasEValue a => HasEField a where+ {-# INLINE mkEField #-}+ mkEField = value mkEValue+++--------------------------------------------------------------------------------+instance HasEField Int where+ {-# INLINE mkEField #-}+ mkEField = contramap fromIntegral (value int8)++instance HasEField (Maybe Int) where+ {-# INLINE mkEField #-}+ mkEField = contramap (fmap fromIntegral) (nullableValue int8)++instance HasEField Word16 where+ {-# INLINE mkEField #-}+ mkEField = contramap fromIntegral (value int2)++instance HasEField Word32 where+ {-# INLINE mkEField #-}+ mkEField = contramap fromIntegral (value int4)++instance HasEField Word64 where+ {-# INLINE mkEField #-}+ mkEField = contramap fromIntegral (value int8)++instance HasEField (Maybe Word16) where+ {-# INLINE mkEField #-}+ mkEField = contramap (fmap fromIntegral) (nullableValue int2)++instance HasEField (Maybe Word32) where+ {-# INLINE mkEField #-}+ mkEField = contramap (fmap fromIntegral) (nullableValue int4)++instance HasEField (Maybe Word64) where+ {-# INLINE mkEField #-}+ mkEField = contramap (fmap fromIntegral) (nullableValue int8)
+ src/Hasql/Generic/HasRow.hs view
@@ -0,0 +1,262 @@+--------------------------------------------------------------------------------+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+module Hasql.Generic.HasRow+ ( HasRow+ , HasDField+ , HasDValue+ , mkRow+ , mkDField+ , mkDValue+ , gRow+ , gDEnumValue+ ) where++--------------------------------------------------------------------------------+import BinaryParser+import Control.Monad (replicateM)+import qualified Data.Aeson.Types as JSON+import Data.ByteString (ByteString)+import Data.Functor.Contravariant+import Data.Int (Int16, Int32, Int64)+import qualified Data.Map as Map+import Data.Scientific (Scientific)+import Data.Text+import Data.Time (Day, DiffTime, LocalTime,+ TimeOfDay, TimeZone, UTCTime)+import Data.UUID (UUID)+import Data.Vector (Vector)+import qualified Data.Vector as Vector+import Data.Word (Word16, Word32, Word64)+import Generics.SOP+import qualified GHC.Generics as GHC+import Hasql.Decoders+import qualified PostgreSQL.Binary.Decoder as Decoder++--------------------------------------------------------------------------------+-- |+-- A type that can be decoded from a database row, using Hasql's `Row` decoder.+--+-- Your data type needs to derive GHC `GHC.Generics.Generic`, and using this derive+-- an instance of SOP `Generics.SOP.Generic`. From here you can derive an instance+-- of `HasRow`. This gives you access to a value `mkRow`, which you can use+-- to get a value of type `Hasql.Decoders.Row`.+--+-- @+-- {-\# DeriveGeneric #-}+--+-- import Data.Text (Text)+-- import Data.UUID (UUID)+-- import qualified GHC.Generics as GHC+-- import Generics.SOP+-- import Hasql.Query (statement)+-- import Hasql.Session (Session, query)+-- import qualified Hasql.Decoders as HD+-- import qualified Hasql.Encoders as HE+--+-- data Person = Person+-- { personId :: UUID+-- , personName :: Text+-- , personAge :: Int+-- } deriving (GHC.Generic)+--+-- instance Generic Person+-- instance HasRow Person+--+-- \-- Search for a 'Person' with a matching UUID+-- findPerson :: UUID -> Session (Maybe Person)+-- findPerson pid =+-- query pid preparedStatement+-- where+-- preparedStatement = statement sql encoder decoder True+-- sql = "SELECT id, name, age FROM people WHERE id=$1"+-- encoder = HE.value HE.uuid+-- decoder = HD.maybeRow mkRow+-- @+class HasRow a where+ mkRow :: Row a+ default mkRow :: (Generic a, Code a ~ '[ xs ], All HasDField xs) => Row a+ mkRow = gRow++--------------------------------------------------------------------------------+-- | A type representing a value decoder lifted into a compasable `Row`. Instances+-- are defined that will lift `HasDValue` types into the common wrappers like+-- vectors, lists, and maybe.+class HasDField a where+ mkDField :: Row a++--------------------------------------------------------------------------------+-- | A type representing an individual value decoder. These should be defined+-- manually for each type.+class HasDValue a where+ mkDValue :: Value a++--------------------------------------------------------------------------------+-- | Generate a `Row` generically+gRow :: (Generic a, Code a ~ '[ xs ], All HasDField xs) => Row a+gRow =+ to . SOP . Z <$> hsequence (hcpure (Proxy :: Proxy HasDField) mkDField)++--------------------------------------------------------------------------------+class (a ~ b) => Equal a b+instance (a ~ b) => Equal a b++--------------------------------------------------------------------------------+-- | Derive a 'HasDField' for enumeration types+gDEnumValue :: (Generic a, All (Equal '[]) (Code a)) => NP (K Text) (Code a) -> Value a+gDEnumValue names = enum $ \n -> Map.lookup n table+ where+ table =+ Map.fromList+ (hcollapse+ (hczipWith (Proxy :: Proxy (Equal '[]))+ (\ (K n) (Fn c) -> K (n, to (SOP (unK (c Nil)))))+ names injections+ )+ )+++--------------------------------------------------------------------------------+-- Instances for common data types++instance HasDValue Bool where+ {-# INLINE mkDValue #-}+ mkDValue = bool++instance HasDValue Int16 where+ {-# INLINE mkDValue #-}+ mkDValue = int2++instance HasDValue Int32 where+ {-# INLINE mkDValue #-}+ mkDValue = int4++instance HasDValue Int64 where+ {-# INLINE mkDValue #-}+ mkDValue = int8++instance HasDValue Word16 where+ {-# INLINE mkDValue #-}+ mkDValue = word2++instance HasDValue Word32 where+ {-# INLINE mkDValue #-}+ mkDValue = word4++instance HasDValue Word64 where+ {-# INLINE mkDValue #-}+ mkDValue = word8++instance HasDValue Float where+ {-# INLINE mkDValue #-}+ mkDValue = float4++instance HasDValue Double where+ {-# INLINE mkDValue #-}+ mkDValue = float8++instance HasDValue Scientific where+ {-# INLINE mkDValue #-}+ mkDValue = numeric++instance HasDValue Char where+ {-# INLINE mkDValue #-}+ mkDValue = char++instance HasDValue Text where+ {-# INLINE mkDValue #-}+ mkDValue = text++instance HasDValue ByteString where+ {-# INLINE mkDValue #-}+ mkDValue = bytea++instance HasDValue Day where+ {-# INLINE mkDValue #-}+ mkDValue = date++instance HasDValue LocalTime where+ {-# INLINE mkDValue #-}+ mkDValue = timestamp++instance HasDValue UTCTime where+ {-# INLINE mkDValue #-}+ mkDValue = timestamptz++instance HasDValue TimeOfDay where+ {-# INLINE mkDValue #-}+ mkDValue = time++instance HasDValue (TimeOfDay, TimeZone) where+ {-# INLINE mkDValue #-}+ mkDValue = timetz++instance HasDValue DiffTime where+ {-# INLINE mkDValue #-}+ mkDValue = interval++instance HasDValue UUID where+ {-# INLINE mkDValue #-}+ mkDValue = uuid++instance HasDValue JSON.Value where+ {-# INLINE mkDValue #-}+ mkDValue = jsonb+++--------------------------------------------------------------------------------+instance HasDValue a => HasDField [Maybe a] where+ {-# INLINE mkDField #-}+ mkDField = value $ array (arrayDimension replicateM (arrayNullableValue mkDValue))++instance HasDValue a => HasDField [a] where+ {-# INLINE mkDField #-}+ mkDField = value $ array (arrayDimension replicateM (arrayValue mkDValue))++instance HasDValue a => HasDField (Vector (Maybe a)) where+ {-# INLINE mkDField #-}+ mkDField = value $ array (arrayDimension Vector.replicateM (arrayNullableValue mkDValue))++instance HasDValue a => HasDField (Vector a) where+ {-# INLINE mkDField #-}+ mkDField = value $ array (arrayDimension Vector.replicateM (arrayValue mkDValue))++instance HasDValue a => HasDField (Maybe a) where+ {-# INLINE mkDField #-}+ mkDField = nullableValue mkDValue++instance HasDValue a => HasDField a where+ {-# INLINE mkDField #-}+ mkDField = value mkDValue+++--------------------------------------------------------------------------------+instance HasDField Int where+ {-# INLINE mkDField #-}+ mkDField = fmap fromIntegral (value int8)++instance HasDField (Maybe Int) where+ {-# INLINE mkDField #-}+ mkDField = fmap (fmap fromIntegral) (nullableValue int8)++--------------------------------------------------------------------------------+word2 :: Value Word16+word2 = custom $ \b -> BinaryParser.run Decoder.int++--------------------------------------------------------------------------------+word4 :: Value Word32+word4 = custom $ \b -> BinaryParser.run Decoder.int++--------------------------------------------------------------------------------+word8 :: Value Word64+word8 = custom $ \b -> BinaryParser.run Decoder.int