composite-opaleye (empty) → 0.1.0.0

raw patch · 7 files changed

+359/−0 lines, 7 filesdep +Framesdep +basedep +basic-preludesetup-changed

Dependencies added: Frames, base, basic-prelude, bytestring, composite-base, lens, opaleye, postgresql-simple, product-profunctors, profunctors, template-haskell, text, vinyl

Files

• Setup.hs +2/−0
• composite-opaleye.cabal +43/−0
• src/Composite/Opaleye.hs +7/−0
• src/Composite/Opaleye/ProductProfunctors.hs +60/−0
• src/Composite/Opaleye/RecordTable.hs +67/−0
• src/Composite/Opaleye/TH.hs +169/−0
• src/Composite/Opaleye/Util.hs +11/−0

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,43 @@+-- This file has been generated from package.yaml by hpack version 0.15.0.+--+-- see: https://github.com/sol/hpack++name:           composite-opaleye+version:        0.1.0.0+synopsis:       Opaleye SQL for Frames records+description:    Integration between Frames records and Opaleye SQL, allowing records to be stored, retrieved, and queried from PostgreSQL.+category:       Records+homepage:       https://github.com/ConferHealth/composite#readme+author:         Confer Health, Inc.+maintainer:     oss@confer.care+copyright:      2017 Confer Health, Inc.+license:        BSD3+build-type:     Simple+cabal-version:  >= 1.10++library+  hs-source-dirs:+      src+  default-extensions: DataKinds FlexibleContexts FlexibleInstances LambdaCase MultiParamTypeClasses NoImplicitPrelude OverloadedStrings PolyKinds ScopedTypeVariables StrictData TemplateHaskell TypeFamilies TypeOperators ViewPatterns+  ghc-options: -Wall -O2+  build-depends:+      base >= 4.7 && < 5+    , Frames+    , basic-prelude+    , bytestring+    , composite-base+    , lens+    , opaleye+    , postgresql-simple+    , product-profunctors+    , profunctors+    , template-haskell+    , text+    , vinyl+  exposed-modules:+      Composite.Opaleye+      Composite.Opaleye.ProductProfunctors+      Composite.Opaleye.RecordTable+      Composite.Opaleye.TH+      Composite.Opaleye.Util+  default-language: Haskell2010

@@ -0,0 +1,7 @@+module Composite.Opaleye+  ( module Composite.Opaleye.ProductProfunctors+  , module Composite.Opaleye.RecordTable+  ) where++import Composite.Opaleye.ProductProfunctors+import Composite.Opaleye.RecordTable

@@ -0,0 +1,60 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Composite.Opaleye.ProductProfunctors where++import BasicPrelude+import Data.Profunctor (dimap)+import Data.Profunctor.Product (ProductProfunctor, (***!))+import qualified Data.Profunctor.Product as PP+import Data.Profunctor.Product.Default (Default(def))+import Data.Vinyl.Core (Rec((:&), RNil))+import Data.Vinyl.Functor (Identity(Identity))+-- FIXME would nice to be generic to all vinyl records but then the types get really really hairy trying to assert Unwrapped r ~ p a b, project out a, and so on+import Frames ((:->)(Col))++-- |Type class implementing traversal of a record, yanking individual product profunctors @Record [p a b]@+-- (though with distinct @a@ and @b@ at each position) up to @p (Record as) (Record bs)@.+--+-- This is similar to the @pN@ functions on tuples provided by the @product-profunctors@ library.+class ProductProfunctor p => PRec p rs where+  -- |Record fields @rs@ with the profunctor removed yielding the contravariant parameter. E.g. @PRecContra p '[p a b] ~ '[a]@+  type PRecContra p rs :: [*]+  -- |Record fields @rs@ with the profunctor removed yielding the covariant parameter. E.g. @PRecContra p '[p a b] ~ '[a]@+  type PRecCo     p rs :: [*]++  -- |Traverse the record, transposing the profunctors @p@ within to the outside like 'traverse' does for Applicative effects.+  --+  -- Roughly equivalent to @Record '[p a b, p c d, …] -> p (Record '[a, c, …]) (Record '[b, d, …])@+  pRec :: Rec Identity rs -> p (Rec Identity (PRecContra p rs)) (Rec Identity (PRecCo p rs))++instance ProductProfunctor p => PRec p '[] where+  type PRecContra p '[] = '[]+  type PRecCo     p '[] = '[]++  pRec RNil = dimap (const ()) (const RNil) PP.empty++instance (ProductProfunctor p, PRec p rs) => PRec p (s :-> p a b ': rs) where+  type PRecContra p (s :-> p a b ': rs) = (s :-> a ': PRecContra p rs)+  type PRecCo     p (s :-> p a b ': rs) = (s :-> b ': PRecCo     p rs)++  pRec (Identity (Col p) :& rs) =+    dimap (\ (Identity (Col a) :& aRs) -> (a, aRs))+          (\ (b, bRs) -> (Identity (Col b) :& bRs))+          (p ***! pRec rs)++instance ProductProfunctor p => Default p (Rec Identity '[]) (Rec Identity '[]) where+  def = dimap (const ()) (const RNil) PP.empty++instance forall p s a b rsContra rsCo. (ProductProfunctor p, Default p a b, Default p (Rec Identity rsContra) (Rec Identity rsCo))+      => Default p (Rec Identity (s :-> a ': rsContra)) (Rec Identity (s :-> b ': rsCo)) where+  def =+    dimap (\ (Identity (Col a) :& aRs) -> (a, aRs))+          (\ (b, bRs) -> (Identity (Col b) :& bRs))+          (step ***! recur)+    where+      step :: p a b+      step = def+      recur :: p (Rec Identity rsContra) (Rec Identity rsCo)+      recur = def+++

@@ -0,0 +1,67 @@+module Composite.Opaleye.RecordTable where++import BasicPrelude+import Composite.Base (NamedField(fieldName))+import Control.Lens (Wrapped(type Unwrapped, _Wrapped'), from, view)+import Data.Profunctor (dimap)+import Data.Profunctor.Product ((***!))+import qualified Data.Profunctor.Product as PP+import Data.Proxy (Proxy(Proxy))+import Data.Text (unpack)+import Data.Vinyl.Core (Rec((:&), RNil))+import Data.Vinyl.Functor (Identity(Identity))+import Opaleye (Column, TableProperties, required, optional)++-- |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++-- |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, using 'NamedField' to reflect the field names.+--+-- 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:+--+-- > pReq (optional "id" &: required "name" &: Nil)+--+--+-- Alternately, use 'Composite.Opaleye.ProductProfunctors.pReq' 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 r reads w writes.+    ( NamedField w, NamedField r+    , DefaultRecTableField (Unwrapped w) (Unwrapped r)+    , DefaultRecTable writes reads+    ) => DefaultRecTable (w ': writes) (r ': reads) where+  defaultRecTable =+    dimap (\ (Identity (view _Wrapped' -> w) :& writeRs) -> (w, writeRs))+          (\ (r, readRs) -> (Identity (view (from _Wrapped') r) :& readRs))+          (step  ***! recur)+    where+      step :: TableProperties (Unwrapped w) (Unwrapped r)+      step = defaultRecTableField . unpack $ fieldName (Proxy :: Proxy r)+      recur :: TableProperties (Rec Identity writes) (Rec Identity reads)+      recur = defaultRecTable+

@@ -0,0 +1,169 @@+module Composite.Opaleye.TH where++import BasicPrelude hiding (lift)+import Composite.Opaleye.Util (constantColumnUsing)+import Control.Lens ((<&>))+import qualified Data.ByteString.Char8 as BSC8+import Data.Profunctor.Product.Default (Default, def)+import Data.Traversable (for)+import Database.PostgreSQL.Simple (ResultError(ConversionFailed, Incompatible, UnexpectedNull))+import Database.PostgreSQL.Simple.FromField (FromField, fromField, typename, returnError)+import Language.Haskell.TH+  ( Q, Name, mkName, nameBase, newName, pprint, reify+  , Info(TyConI), Dec(DataD), Con(NormalC)+  , conT+  , dataD, instanceD+  , lamE, varE, caseE, conE+  , conP, varP, wildP, litP, stringL+  , caseE, match+  , funD, clause+  , normalB, normalGE, guardedB+  , cxt+  )+import Language.Haskell.TH.Syntax (lift)+import Opaleye+  ( Column, Constant, QueryRunnerColumnDefault, PGText, fieldQueryRunnerColumn, queryRunnerColumnDefault+  )++-- |Derive the various instances required to make a Haskell enumeration map to a PostgreSQL @enum@ type.+--+-- In @deriveOpaleyeEnum ''HaskellType "sqltype" hsConToSqlValue@, @''HaskellType@ is the sum type (data declaration) to make instances for, @"sqltype"@ is+-- the PostgreSQL type name, and @hsConToSqlValue@ is a function to map names of constructors to SQL values.+--+-- The function @hsConToSqlValue@ is of the type @String -> Maybe String@ in order to make using 'stripPrefix' convenient. The function is applied to each+-- constructor name and for @Just value@ that value is used, otherwise for @Nothing@ the constructor name is used.+--+-- For example, given the Haskell type:+--+-- @+--     data MyEnum = MyFoo | MyBar+-- @+--+-- And PostgreSQL type:+--+-- @+--     CREATE TYPE myenum AS ENUM('foo', 'bar');+-- @+--+-- The splice:+--+-- @+--     deriveOpaleyeEnum ''MyEnum "myenum" ('stripPrefix' "my" . 'map' 'toLower')+-- @+--+-- Will create @PGMyEnum@ and instances required to use @MyEnum@ / @Column MyEnum@ in Opaleye.+--+-- The Haskell generated by this splice for the example is something like:+--+-- @+--     data PGMyEnum+--+--     instance 'FromField' MyEnum where+--       'fromField' f mbs = do+--         tname <- 'typename' f+--         case mbs of+--           _ | tname /= "myenum" -> 'returnError' 'Incompatible' f ""+--           Just "foo" -> pure MyFoo+--           Just "bar" -> pure MyBar+--           Just other -> 'returnError' 'ConversionFailed' f ("Unexpected myenum value: " <> 'BSC8.unpack' other)+--           Nothing    -> 'returnError' 'UnexpectedNull' f ""+--+--     instance 'QueryRunnerColumnDefault' PGMyEnum MyEnum where+--       queryRunnerColumnDefault = 'fieldQueryRunnerColumn'+--+--     instance 'Default' 'Constant' MyEnum ('Column' PGMyEnum) where+--       def = 'constantColumnUsing' (def :: 'Constant' String ('Column' 'PGText')) $ \ case+--         MyFoo -> "foo"+--         MyBar -> "bar"+-- @+deriveOpaleyeEnum :: Name -> String -> (String -> Maybe String) -> Q [Dec]+deriveOpaleyeEnum hsName sqlName hsConToSqlValue = do+  let sqlTypeName = mkName $ "PG" ++ nameBase hsName+      sqlType = conT sqlTypeName+      hsType = conT hsName++  rawCons <- reify hsName >>= \ case+    TyConI (DataD _cxt _name _tvVarBndrs _maybeKind cons _derivingCxt) ->+      pure cons+    other ->+      fail $ "expected " <> show hsName <> " to name a data declaration, not:\n" <> pprint other++  nullaryCons <- for rawCons $ \ case+    NormalC conName [] ->+      pure conName+    other ->+      fail $ "expected every constructor of " <> show hsName <> " to be a regular nullary constructor, not:\n" <> pprint other++  let conPairs = nullaryCons <&> \ conName ->+        (conName, fromMaybe (nameBase conName) (hsConToSqlValue (nameBase conName)))++  sqlTypeDecl <- dataD (cxt []) sqlTypeName [] Nothing [] (cxt [])++  fromFieldInst <- instanceD (cxt []) [t| FromField $hsType |] . (:[]) $ do+    field <- newName "field"+    mbs   <- newName "mbs"+    tname <- newName "tname"+    other <- newName "other"++    let bodyCase = caseE (varE mbs) $+          [ match+              wildP+              (guardedB [ normalGE [| $(varE tname) /= $(lift sqlName) |]+                                   [| returnError Incompatible $(varE field) "" |] ])+              []+          ] +++          (+            conPairs <&> \ (conName, value) ->+              match+                [p| Just $(litP $ stringL value) |]+                (normalB [| pure $(conE conName) |])+                []+          ) +++          [ match +              [p| Just $(varP other) |]+              (normalB [| returnError ConversionFailed $(varE field) ("Unexpected " <> $(lift sqlName) <> " value: " <> BSC8.unpack $(varE other)) |])+              []+          , match+              [p| Nothing |]+              (normalB [| returnError UnexpectedNull $(varE field) "" |])+              []+          ]++    funD 'fromField+      [ clause+          [varP field, varP mbs]+          (normalB [|+            do+              $(varP tname) <- typename $(varE field)+              $bodyCase+            |])+          []+      ]++  queryRunnerColumnDefaultInst <- instanceD (cxt []) [t| QueryRunnerColumnDefault $sqlType $hsType |] . (:[]) $+    funD 'queryRunnerColumnDefault+      [ clause+          []+          (normalB [| fieldQueryRunnerColumn |])+          []+      ]++  defaultInst <- instanceD (cxt []) [t| Default Constant $hsType (Column $sqlType) |] . (:[]) $ do+    s <- newName "s"+    let body = lamE [varP s] $+          caseE (varE s) $+            conPairs <&> \ (conName, value) ->+              match+                (conP conName [])+                (normalB $ lift value)+                []++    funD 'def+      [ clause+          []+          (normalB [| constantColumnUsing (def :: Constant String (Column PGText)) $body |])+          []+      ]++  pure [sqlTypeDecl, fromFieldInst, queryRunnerColumnDefaultInst, defaultInst]+

@@ -0,0 +1,11 @@+module Composite.Opaleye.Util where++import Data.Profunctor (dimap)+import Opaleye (Column, Constant, unsafeCoerceColumn)++-- |Coerce one type of 'Column' 'Constant' profunctor to another using by just asserting the changed type on the column side and using the given function+-- on the Haskell side. Useful when the PG value representation is the same but the Haskell type changes, e.g. for enums.+constantColumnUsing :: Constant haskell (Column pgType)+                    -> (haskell' -> haskell)+                    -> Constant haskell' (Column pgType')+constantColumnUsing oldConstant f = dimap f unsafeCoerceColumn oldConstant