postgresql-simple-sop (empty) → 0.1.0.0

raw patch · 4 files changed

+143/−0 lines, 4 filesdep +basedep +generics-sopdep +postgresql-simplesetup-changed

Dependencies added: base, generics-sop, postgresql-simple

Files

• LICENSE +22/−0
• Setup.hs +2/−0
• postgresql-simple-sop.cabal +18/−0
• src/Database/PostgreSQL/Simple/SOP.hs +101/−0

@@ -0,0 +1,22 @@+The MIT License (MIT)++Copyright (c) 2014 OpenBrain Ltd++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.+

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

@@ -0,0 +1,18 @@+name:                postgresql-simple-sop+version:             0.1.0.0+synopsis:            Generic functions for postgresql-simple+homepage:            https://github.com/openbrainsrc/postgresql-simple-sop+license:             MIT+license-file:        LICENSE+author:              Tom Nielsen+maintainer:          tomn@openbrain.org+build-type:          Simple+cabal-version:       >=1.8++library+  exposed-modules:     Database.PostgreSQL.Simple.SOP+  hs-source-dirs:      src+  ghc-options:         -Wall -fno-warn-unused-do-bind -fno-warn-orphans -fwarn-incomplete-patterns+  build-depends:       base >= 4.6 && < 5+                     , postgresql-simple+                     , generics-sop

@@ -0,0 +1,101 @@+{-# LANGUAGE DefaultSignatures, OverloadedStrings, ScopedTypeVariables, DeriveGeneric, FlexibleInstances, ConstraintKinds, DataKinds, GADTs #-}++{- |++Generic functions to make working with postgresql-simple easier.++Original implmentation of gfromRow and gtoRow by+<https://ocharles.org.uk/blog/posts/2014-08-07-postgresql-simple-generic-sop.html Ollie Charles>.++Intended usage:++@+import qualified GHC.Generics as GHC+import Generics.SOP++data Person = Person { name:: String, age:: Int } deriving (GHC.Generic)++instance Generic Person+instance HasDatatypeInfo Person++instance FromRow Person where fromRow = gfromRow+instance ToRow Person where toRow = gtoRow+@++-}++module Database.PostgreSQL.Simple.SOP (gfromRow, gtoRow, gselectFrom, ginsertInto) where++import Generics.SOP+import Control.Applicative+import Data.Monoid ((<>))+import Data.List (intercalate)+import Data.String (fromString)++import Database.PostgreSQL.Simple+import Database.PostgreSQL.Simple.FromRow+import Database.PostgreSQL.Simple.FromField+import Database.PostgreSQL.Simple.ToField++--++-- |Generic fromRow+gfromRow+  :: (All FromField xs, Code a ~ '[xs], SingI xs, Generic a)+  => RowParser a+gfromRow = to . SOP . Z <$> hsequence (hcpure fromFieldp field)+  where fromFieldp = Proxy :: Proxy FromField++-- |Generic toRow+gtoRow :: (Generic a, Code a ~ '[xs], All ToField xs, SingI xs) => a -> [Action]+gtoRow a =+  case from a of+    SOP (Z xs) -> hcollapse (hcliftA toFieldP (K . toField . unI) xs)++  where toFieldP = Proxy :: Proxy ToField++fNms :: NP ConstructorInfo a -> [String]+fNms ((Record _ fs) :* _) = fNmsRec fs++fNmsRec :: NP FieldInfo a -> [String]+fNmsRec Nil = []+fNmsRec (FieldInfo nm :* rest) = nm : fNmsRec rest++--++class HasFieldNames a where+  fieldNames :: Proxy a -> [String]++  default fieldNames :: (Generic a, HasDatatypeInfo a) => Proxy a -> [String]+  fieldNames p = case datatypeInfo p of+    ADT     _ _ cs -> fNms cs+    Newtype _ _ c -> fNms $ c :* Nil++{-|Generic select++@+gselectFrom conn \"persons where name = ?\" theName+@++-}+gselectFrom :: forall r q. (ToRow q, FromRow r, Generic r, HasFieldNames r) => Connection -> Query -> q -> IO [r]+gselectFrom conn q1 args = query conn ("select (" <> (fromString $ intercalate "," $ fieldNames $ (Proxy :: Proxy r) ) <> ") from " <> q1) args++{-|Generic insert++@+let thePerson = Person \"Tom\" 37+ginsertInto conn \"persons\" thePerson+@++This is not going to work if you use auto-incrementing primary keys and the primary key is part of the Haskell record.+-}+ginsertInto :: forall r. (ToRow r, Generic r, HasFieldNames r) => Connection -> Query -> r -> IO ()+ginsertInto conn tbl val = do+  let fnms = fieldNames $ (Proxy :: Proxy r)+  _ <- execute conn ("INSERT INTO " <> tbl <> " (" <>+                     (fromString $ intercalate "," fnms ) <>+                     ") VALUES (" <>+                     (fromString $ intercalate "," $ map (const "?") fnms) <> ")")+               val+  return ()