refactored utils

Author: zohl

.travis.yml

@@ -47,7 +47,7 @@ script:
   - cabal build
   - cabal test --show-details=always
   - cabal sdist
-  - cabal haddock | grep "100%" | wc -l | grep "5"
+  - cabal haddock | grep "100%" | wc -l | grep "6"
 
 branches:
   only:

default.nix

@@ -1,5 +1,5 @@
 { mkDerivation, attoparsec, base, bytestring, case-conversion
-, heredoc, hspec, HUnit, postgresql-simple, stdenv
+, data-default, heredoc, hspec, postgresql-simple, stdenv
 , template-haskell, text, time
 }:
 mkDerivation {
@@ -11,7 +11,7 @@ mkDerivation {
     template-haskell text time
   ];
   testHaskellDepends = [
-    attoparsec base bytestring case-conversion hspec HUnit
+    attoparsec base bytestring case-conversion data-default hspec
     postgresql-simple text
   ];
   description = "A FFI-like bindings for PostgreSQL stored functions";

examples/Common.hs

@@ -5,16 +5,21 @@ module Common (
   , bindOptions
   ) where
 
+import Data.Default (def)
 import Control.Exception.Base (bracket)
 import Database.PostgreSQL.Simple (Connection, ConnectInfo, connect, begin, rollback, close, execute_)
-import Database.PostgreSQL.Simple.Bind (Options(..), defaultOptions)
+import Database.PostgreSQL.Simple.Bind (PostgresBindOptions(..), PGFunction(..))
 import Database.PostgreSQL.Simple.Types (Query(..))
 import Text.CaseConversion (convertCase, WordCase(..))
 import qualified Data.ByteString.Char8 as BS
 
-bindOptions :: Options
-bindOptions = defaultOptions {
-    nameModifier = convertCase Snake Camel . ("sql_" ++)
+mkFunctionName :: PGFunction -> String
+mkFunctionName (PGFunction _schema name _args _result)
+  = convertCase Snake Camel . ("sql_" ++) $ name
+
+bindOptions :: PostgresBindOptions
+bindOptions = (def :: PostgresBindOptions) {
+    pboFunctionName = mkFunctionName
   }
 
 withDB :: ConnectInfo -> (Connection -> IO a) -> IO a

postgresql-simple-bind.cabal

@@ -25,6 +25,7 @@ library
   build-depends: base >= 4.7 && < 5.0
                , attoparsec >= 0.13.0 && < 0.14
                , bytestring >= 0.10.8 && < 0.11
+               , data-default
                , heredoc >= 0.2.0 && < 0.3
                , postgresql-simple >= 0.5.2 && < 0.6
                , template-haskell >= 2.11.0 && < 2.12
@@ -34,9 +35,10 @@ library
   hs-source-dirs: src
   exposed-modules:
      Database.PostgreSQL.Simple.Bind
-     Database.PostgreSQL.Simple.Bind.Types
-     Database.PostgreSQL.Simple.Bind.Util
+     Database.PostgreSQL.Simple.Bind.Common
      Database.PostgreSQL.Simple.Bind.Representation
+     Database.PostgreSQL.Simple.Bind.Types
+     Database.PostgreSQL.Simple.Bind.Utils
 
   other-modules:
      Database.PostgreSQL.Simple.Bind.Implementation
@@ -84,6 +86,7 @@ test-suite examples
                , attoparsec >= 0.13.0 && < 0.14
                , bytestring >= 0.10.8 && < 0.11
                , case-conversion
+               , data-default
                , hspec
                , postgresql-simple >= 0.5.2 && < 0.6
                , postgresql-simple-bind

src/Database/PostgreSQL/Simple/Bind.hs

@@ -17,12 +17,18 @@
 
 module Database.PostgreSQL.Simple.Bind (
     bindFunction
-  , Options(..)
-  , defaultOptions
+
+  , PostgresBindOptions(..)
   , PostgresType
+
+  , PGFunction(..)
+  , PGArgument(..)
+  , PGColumn(..)
+  , PGResult(..)
   ) where
 
 
 import Database.PostgreSQL.Simple.Bind.Implementation
-import Database.PostgreSQL.Simple.Bind.Util (Options (..), defaultOptions)
+import Database.PostgreSQL.Simple.Bind.Representation (PGFunction(..), PGArgument(..), PGColumn(..), PGResult(..))
+import Database.PostgreSQL.Simple.Bind.Common (PostgresBindOptions(..))
 

src/Database/PostgreSQL/Simple/Bind/Common.hs

@@ -0,0 +1,56 @@
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE EmptyDataDecls             #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE QuasiQuotes                #-}
+{-# LANGUAGE TemplateHaskell            #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE TypeOperators              #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE FlexibleInstances          #-}
+
+{-|
+  Module:      Database.PostgreSQL.Simple.Bind.Common
+  Copyright:   (c) 2016 Al Zohali
+  License:     GPL3
+  Maintainer:  Al Zohali <zohl@fmap.me>
+  Stability:   experimental
+
+  Common functions and types.
+-}
+
+
+module Database.PostgreSQL.Simple.Bind.Common (
+    unwrapRow
+  , unwrapColumn
+  , PostgresBindOptions(..)
+  ) where
+
+
+import Data.Default (Default, def)
+import Database.PostgreSQL.Simple (Only(..))
+import Database.PostgreSQL.Simple.Bind.Representation (PGFunction(..))
+
+
+-- | Options that specify how to construct the function binding.
+data PostgresBindOptions = PostgresBindOptions
+  { pboFunctionName :: PGFunction -> String
+    -- ^ Function that generates name of a binding
+  }
+
+instance Default PostgresBindOptions where
+  def = PostgresBindOptions
+    { pboFunctionName = \(PGFunction _schema name _args _result) -> name }
+
+-- | Remove 'Only' constructor.
+unwrapColumn :: [Only a] -> [a]
+unwrapColumn = map (\(Only x) -> x)
+
+-- | Remove list and 'Only' constructors.
+unwrapRow :: [Only a] -> a
+unwrapRow = head . unwrapColumn
+

src/Database/PostgreSQL/Simple/Bind/Implementation.hs

@@ -12,6 +12,7 @@
 {-# LANGUAGE TypeOperators              #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE RecordWildCards            #-}
 
 {-|
   Module:      Database.PostgreSQL.Simple.Bind.Implementation
@@ -31,7 +32,7 @@ import Data.List (intersperse)
 import Data.Text (Text)
 import Database.PostgreSQL.Simple
 import Database.PostgreSQL.Simple.Bind.Representation
-import Database.PostgreSQL.Simple.Bind.Util (unwrapRow, unwrapColumn, mkFunctionName, Options(..))
+import Database.PostgreSQL.Simple.Bind.Common (unwrapRow, unwrapColumn, PostgresBindOptions(..))
 import Database.PostgreSQL.Simple.FromField (FromField)
 import Database.PostgreSQL.Simple.ToField
 import Database.PostgreSQL.Simple.Types
@@ -45,7 +46,7 @@ type family PostgresType (a :: Symbol)
 
 
 -- | Function that constructs binding for PostgreSQL stored function by it's signature.
-bindFunction :: Options -> Text -> Q [Dec]
+bindFunction :: PostgresBindOptions -> Text -> Q [Dec]
 bindFunction opt = (mkFunction opt) . parsePGFunction
 
 
@@ -79,7 +80,7 @@ filterArguments = filter isActual
 
 
 
-mkFunction :: Options -> PGFunction -> Q [Dec]
+mkFunction :: PostgresBindOptions -> PGFunction -> Q [Dec]
 mkFunction opt f = sequence $ (($ f) . ($ opt)) <$> [mkFunctionT, mkFunctionE]
 
 postgresT :: String -> Type
@@ -121,8 +122,8 @@ mkArgsT cs = do
   return (names, context, clause)
 
 
-mkFunctionT :: Options -> PGFunction -> Q Dec
-mkFunctionT opt f@(PGFunction _schema _name args ret) = do
+mkFunctionT :: PostgresBindOptions -> PGFunction -> Q Dec
+mkFunctionT (PostgresBindOptions {..}) f@(PGFunction _schema _name args ret) = do
   (argNames, argContext, argClause) <- mkArgsT args
   (retNames, retContext, retClause) <- mkResultT ret
 
@@ -132,7 +133,7 @@ mkFunctionT opt f@(PGFunction _schema _name args ret) = do
   let chain x = AppT (AppT ArrowT x)
   let clause = foldr1 chain $ (ConT ''Connection):(argClause ++ [AppT (ConT ''IO) retClause])
 
-  return $ SigD (mkName (mkFunctionName opt f)) $ ForallT vars context clause
+  return $ SigD (mkName $ pboFunctionName f) $ ForallT vars context clause
 
 
 
@@ -162,14 +163,14 @@ unwrapE (PGSetOf _) q = (VarE 'fmap) `AppE` (VarE 'unwrapColumn) `AppE` q
 unwrapE (PGTable _) q = q
 
 
-mkFunctionE :: Options -> PGFunction -> Q Dec
-mkFunctionE opt f@(PGFunction _schema _name args ret) = do
+mkFunctionE :: PostgresBindOptions -> PGFunction -> Q Dec
+mkFunctionE (PostgresBindOptions {..}) f@(PGFunction _schema _name args ret) = do
   names <- sequence $ replicate (length args) (newName "x")
 
   connName <- newName "conn"
   argsName <- newName "args"
 
-  let funcName = mkName $ mkFunctionName opt f
+  let funcName = mkName $ pboFunctionName f
 
   let funcArgs = (VarP connName):(map VarP names)