diff --git a/composite-opaleye.cabal b/composite-opaleye.cabal --- a/composite-opaleye.cabal +++ b/composite-opaleye.cabal @@ -3,15 +3,13 @@ -- This file has been generated from package.yaml by hpack version 0.34.5. -- -- see: https://github.com/sol/hpack --- --- hash: 03ab7de21f52bc22bd073870d37886f0591c8fa2ee7a704f32d4e385ecbcc622 name: composite-opaleye -version: 0.8.0.0 +version: 0.8.1.0 synopsis: Opaleye SQL for Vinyl records description: Integration between Vinyl records and Opaleye SQL, allowing records to be stored, retrieved, and queried from PostgreSQL. category: Records -homepage: https://github.com/ConferOpenSource/composite#readme +homepage: https://github.com/composite-hs/composite#readme author: Confer Health, Inc. maintainer: oss@vitalbio.com copyright: 2017 Confer Health, Inc., 2020-2021 Vital Biosciences @@ -55,6 +53,7 @@ , postgresql-simple >=0.5.3.0 && <0.7 , product-profunctors >=0.8.0.3 && <0.12 , profunctors >=5.2.1 && <5.7 + , split >=0.2.3 && <0.3 , template-haskell >=2.11.1.0 && <2.19 , text >=1.2.2.2 && <1.3 , vinyl >=0.5.3 && <0.15 @@ -96,6 +95,7 @@ , postgresql-simple >=0.5.3.0 && <0.7 , product-profunctors >=0.8.0.3 && <0.12 , profunctors >=5.2.1 && <5.7 + , split >=0.2.3 && <0.3 , template-haskell >=2.11.1.0 && <2.19 , text >=1.2.2.2 && <1.3 , vinyl >=0.5.3 && <0.15 diff --git a/src/Composite/Opaleye/RecordTable.hs b/src/Composite/Opaleye/RecordTable.hs --- a/src/Composite/Opaleye/RecordTable.hs +++ b/src/Composite/Opaleye/RecordTable.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module Composite.Opaleye.RecordTable where import Composite.Record ((:->)(Val), Rec((:&), RNil)) @@ -7,9 +8,15 @@ import qualified Data.Profunctor.Product as PP import Data.Proxy (Proxy(Proxy)) import GHC.TypeLits (KnownSymbol, symbolVal) +#if MIN_VERSION_opaleye(0,8,0) import Opaleye (Field, requiredTableField, optionalTableField) import Opaleye.Internal.Table (TableFields) +#else +import Opaleye (Column, required, optional) +import Opaleye.Internal.Table (TableProperties) +#endif +#if MIN_VERSION_opaleye(0,8,0) -- |Helper typeclass which picks which of 'requiredTableField' or 'optionalTableField' to use for a pair of write column type and read column type. -- -- @DefaultRecTableField (Maybe (Field a)) (Field a)@ uses 'optionalTableField'. @@ -22,9 +29,24 @@ instance DefaultRecTableField (Field a) (Field a) where defaultRecTableField = requiredTableField +#else +-- |Helper typeclass which picks which of 'required' or 'optional' to use for a pair of write column type and read column type. +-- +-- @DefaultRecTableField (Maybe (Column a)) (Column a)@ uses 'optional'. +-- @DefaultRecTableField (Column a) (Column a)@ uses 'required'. +class DefaultRecTableField write read where + defaultRecTableField :: String -> TableProperties write read +instance DefaultRecTableField (Maybe (Column a)) (Column a) where + defaultRecTableField = optional + +instance DefaultRecTableField (Column a) (Column a) where + defaultRecTableField = required +#endif + +#if MIN_VERSION_opaleye(0,8,0) -- |Type class for producing a default 'TableFields' schema for some expected record types. 'requiredTableField' and 'optionalTableField' are chosen automatically and the --- column is named after the record fields, using 'NamedField' to reflect the field names. +-- column is named after the record fields. -- -- For example, given: -- @@ -62,3 +84,44 @@ step = defaultRecTableField $ symbolVal (Proxy :: Proxy s) recur :: TableFields (Rec Identity writes) (Rec Identity reads) recur = defaultRecTable +#else +-- |Type class for producing a default 'TableProperties' schema for some expected record types. 'required' and 'optional' are chosen automatically and the +-- column is named after the record fields. +-- +-- For example, given: +-- +-- > type WriteRec = Record '["id" :-> Maybe (Column PGInt8), "name" :-> Column PGText] +-- > type ReadRec = Record '["id" :-> Column PGInt8 , "name" :-> Column PGText] +-- +-- This: +-- +-- > defaultRecTable :: TableProperties WriteRec ReadRec +-- +-- Is equivalent to: +-- +-- > pRec (optional "id" &: required "name" &: Nil) +-- +-- +-- Alternately, use 'Composite.Opaleye.ProductProfunctors.pRec' and the usual Opaleye 'required' and 'optional'. +class DefaultRecTable write read where + defaultRecTable :: TableProperties (Rec Identity write) (Rec Identity read) + +instance DefaultRecTable '[] '[] where + defaultRecTable = dimap (const ()) (const RNil) PP.empty + +instance + forall s r reads w writes. + ( KnownSymbol s + , DefaultRecTableField w r + , DefaultRecTable writes reads + ) => DefaultRecTable (s :-> w ': writes) (s :-> r ': reads) where + defaultRecTable = + dimap (\ (Identity (Val w) :& writeRs) -> (w, writeRs)) + (\ (r, readRs) -> (Identity (Val r) :& readRs)) + (step ***! recur) + where + step :: TableProperties w r + step = defaultRecTableField $ symbolVal (Proxy :: Proxy s) + recur :: TableProperties (Rec Identity writes) (Rec Identity reads) + recur = defaultRecTable +#endif diff --git a/src/Composite/Opaleye/TH.hs b/src/Composite/Opaleye/TH.hs --- a/src/Composite/Opaleye/TH.hs +++ b/src/Composite/Opaleye/TH.hs @@ -3,6 +3,7 @@ import Control.Lens ((<&>)) import qualified Data.ByteString.Char8 as BSC8 +import Data.List.Split (splitOn) import Data.Maybe (fromMaybe) import Data.Profunctor.Product.Default (Default, def) import Data.Traversable (for) @@ -27,6 +28,11 @@ import Opaleye.Internal.PGTypes (IsSqlType, showSqlType, literalColumn) import Opaleye.Internal.HaskellDB.PrimQuery (Literal(StringLit)) +getLastComponent :: String -> String +getLastComponent str = case reverse (splitOn "." str) of + x:_ -> x + [] -> str + -- |Derive the various instances required to make a Haskell enumeration map to a PostgreSQL @enum@ type. -- -- In @deriveOpaleyeEnum ''HaskellType "schema.sqltype" hsConToSqlValue@, @''HaskellType@ is the sum type (data declaration) to make instances for, @@ -67,7 +73,7 @@ -- 'fromField' f mbs = do -- tname <- 'typename' f -- case mbs of --- _ | tname /= "myenum" -> 'returnError' 'Incompatible' f "" +-- _ | 'getLastComponent' ('BSC8.unpack' tname) /= "myenum" -> 'returnError' 'Incompatible' f "" -- Just "foo" -> pure MyFoo -- Just "bar" -> pure MyBar -- Just other -> 'returnError' 'ConversionFailed' f ("Unexpected myschema.myenum value: " <> 'BSC8.unpack' other) @@ -87,6 +93,7 @@ let sqlTypeName = mkName $ "PG" ++ nameBase hsName sqlType = conT sqlTypeName hsType = conT hsName + unqualSqlName = getLastComponent sqlName rawCons <- reify hsName >>= \ case TyConI (DataD _cxt _name _tvVarBndrs _maybeKind cons _derivingCxt) -> @@ -133,7 +140,7 @@ let bodyCase = caseE (varE mbs) $ [ match wildP - (guardedB [ normalGE [| $(varE tname) /= $(lift sqlName) |] + (guardedB [ normalGE [| getLastComponent (BSC8.unpack $(varE tname)) /= $(lift unqualSqlName) |] [| returnError Incompatible $(varE field) "" |] ]) [] ] ++