Initial implementation

.gitignore

@@ -23,6 +23,7 @@ cabal.project.local
 .HTF/
 # Stack
 .stack-work/
+stack.yaml.lock
 
 ### IDE/support
 # Vim

.travis.yml

@@ -14,9 +14,9 @@ cache:
 
 matrix:
   include:
-  - ghc: 8.6.4
-  
-  - ghc: 8.6.4
+  - ghc: 8.6.5
+
+  - ghc: 8.6.5
     env: STACK_YAML="$TRAVIS_BUILD_DIR/stack.yaml"
 
 install:

postgresql-simple-named.cabal

@@ -1,8 +1,22 @@
-cabal-version:       2.0
+cabal-version:       2.4
 name:                postgresql-simple-named
 version:             0.0.0.0
 synopsis:            Implementation of named parameters for `postgresql-simple` library
-description:         Implementation of named parameters for `postgresql-simple` library
+description:
+    Implementation of named parameters for `postgresql-simple` library.
+    .
+    Here is an exaple of how it could be used in your code:
+    .
+    > queryNamed [sql|
+    >     SELECT *
+    >     FROM table
+    >     WHERE foo = ?foo
+    >       AND bar = ?bar
+    >       AND baz = ?foo
+    > |] [ "foo" =? "fooBar"
+    >    , "bar" =? "barVar"
+    >    ]
+
 homepage:            https://github.com/Holmusk/postgresql-simple-named
 bug-reports:         https://github.com/Holmusk/postgresql-simple-named/issues
 license:             MPL-2.0
@@ -14,19 +28,14 @@ category:            Database
 build-type:          Simple
 extra-doc-files:     README.md
                    , CHANGELOG.md
-tested-with:         GHC == 8.6.4
+tested-with:         GHC == 8.6.5
 
 source-repository head
   type:                git
   location:            https://github.com/Holmusk/postgresql-simple-named.git
 
-library
-  hs-source-dirs:      src
-  exposed-modules:     PostgresqlSimpleNamed
-
-
+common common-options
   build-depends:       base ^>= 4.12.0.0
-
 
   ghc-options:         -Wall
                        -Wincomplete-uni-patterns
@@ -53,39 +62,21 @@ library
                        TypeApplications
                        ViewPatterns
 
+library
+  import:              common-options
+  hs-source-dirs:      src
+  exposed-modules:     PgNamed
+  build-depends:       bytestring ^>= 0.10.8
+                     , mtl ^>= 2.2
+                     , postgresql-simple ^>= 0.6.2
+                     , text ^>= 1.2
+
 test-suite postgresql-simple-named-test
+  import:              common-options
   type:                exitcode-stdio-1.0
   hs-source-dirs:      test
   main-is:             Spec.hs
 
-  build-depends:       base ^>= 4.12.0.0
-                     , postgresql-simple-named
-
-
-  ghc-options:         -Wall
-                       -threaded
-                       -rtsopts
-                       -with-rtsopts=-N
-                       -Wincomplete-uni-patterns
-                       -Wincomplete-record-updates
-                       -Wcompat
-                       -Widentities
-                       -Wredundant-constraints
-                       -fhide-source-paths
-                       -Wmissing-export-lists
-                       -Wpartial-fields
+  build-depends:       postgresql-simple-named
 
-  default-language:    Haskell2010
-  default-extensions:  ConstraintKinds
-                       DeriveGeneric
-                       GeneralizedNewtypeDeriving
-                       InstanceSigs
-                       KindSignatures
-                       LambdaCase
-                       OverloadedStrings
-                       RecordWildCards
-                       ScopedTypeVariables
-                       StandaloneDeriving
-                       TupleSections
-                       TypeApplications
-                       ViewPatterns
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N

src/PgNamed.hs

@@ -0,0 +1,153 @@
+{-# LANGUAGE DerivingStrategies        #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts          #-}
+
+{- | Introduces named parameters for @postgresql-simple@ library.
+It uses @?@ question mark symbol as the indicator of the named parameter which
+is replaced with the standard syntax with question marks. Check out the example
+of usage:
+
+@
+queryNamed [sql|
+    SELECT *
+    FROM users
+    WHERE foo = ?foo
+      AND bar = ?bar
+      AND baz = ?foo
+|] [ "foo" =? "fooBar"
+   , "bar" =? "barVar"
+   ]
+@
+-}
+
+module PgNamed
+       ( NamedParam (..)
+       , Name (..)
+
+       , extractNames
+       , namesToRow
+       , (=?)
+       ) where
+
+import Control.Monad.Except (MonadError (throwError))
+import Data.Bifunctor (bimap)
+import Data.ByteString (ByteString)
+import Data.Char (isAlphaNum)
+import Data.List (lookup)
+import Data.List.NonEmpty (NonEmpty (..))
+import Data.Text (Text)
+import Data.Text.Encoding (decodeUtf8)
+import GHC.Exts (IsString)
+
+import qualified Data.ByteString.Char8 as BS
+import qualified Database.PostgreSQL.Simple as PG
+import qualified Database.PostgreSQL.Simple.ToField as PG
+import qualified Database.PostgreSQL.Simple.Types as PG
+
+-- | Wrapper over name of the argument.
+newtype Name = Name
+    { unName :: Text
+    } deriving newtype (Show, Eq, Ord, IsString)
+
+-- | Data type to represent each named parameter.
+data NamedParam = NamedParam
+    { namedParamName  :: !Name
+    , namedParamParam :: !PG.Action
+    } deriving (Show)
+
+-- | @PostgreSQL@ error type for named parameters.
+data PgNamedError
+    -- | Named parameter is not specified.
+    = PgNamedParam Name
+    -- | Query has no names inside but was called with named functions,
+    | PgNoNames PG.Query
+    -- | Query contains an empty name.
+    | PgEmptyName PG.Query
+
+
+-- | Type alias for monads that can throw errors of the 'PgNamedError' type.
+type WithError = MonadError PgNamedError
+
+instance Show PgNamedError where
+    show e = "PostgreSQL named parameter error: " ++ case e of
+        PgNamedParam n -> "Named parameter '" ++ show n ++ "' is not specified"
+        PgNoNames (PG.Query q) ->
+            "Query has no names but was called with named functions: " ++ BS.unpack q
+        PgEmptyName (PG.Query q) ->
+            "Query contains an empty name: " ++ BS.unpack q
+
+-- | Checks whether the 'Name' is in the list and returns its parameter.
+lookupName :: Name -> [NamedParam] -> Maybe PG.Action
+lookupName n = lookup n . map (\NamedParam{..} -> (namedParamName, namedParamParam))
+
+{- | This function takes query with named parameters specified like this:
+
+@
+SELECT name, user FROM users WHERE id = ?id
+@
+
+and returns either the error or query with all all names replaced by
+questiosn marks @?@ with list of the names in the order of their appearance.
+
+For example:
+
+>>> extractNames "SELECT * FROM users WHERE foo = ?foo AND bar = ?bar AND baz = ?foo"
+Right ("SELECT * FROM users WHERE foo = ? AND bar = ? AND baz = ?","foo" :| ["bar","foo"])
+-}
+extractNames
+    :: PG.Query
+    -> Either PgNamedError (PG.Query, NonEmpty Name)
+extractNames qr = go (PG.fromQuery qr) >>= \case
+    (_, [])         -> Left $ PgNoNames qr
+    (q, name:names) -> Right (PG.Query q, name :| names)
+  where
+    go :: ByteString -> Either PgNamedError (ByteString, [Name])
+    go str
+        | BS.null str = Right ("", [])
+        | otherwise   = let (before, after) = BS.break (== '?') str in
+            case BS.uncons after of
+                Nothing -> Right (before, [])
+                Just ('?', nameStart) ->
+                    let (name, remainingQuery) = BS.span isNameChar nameStart
+                    in if BS.null name
+                           then Left $ PgEmptyName qr
+                           else fmap (bimap ((before <> "?") <>) (Name (decodeUtf8 name) :))
+                                     (go remainingQuery)
+                Just _ -> error "'break (== '?')' doesn't return string started with the question mark"
+
+    isNameChar :: Char -> Bool
+    isNameChar c = isAlphaNum c || c == '_'
+
+
+-- | Returns the list of values to use in query by given list of 'Name's.
+namesToRow
+    :: forall m . WithError m
+    => NonEmpty Name  -- ^ List of the names used in query
+    -> [NamedParam]   -- ^ List of the named parameters
+    -> m (NonEmpty PG.Action)
+namesToRow names params = traverse magicLookup names
+  where
+    magicLookup :: Name -> m PG.Action
+    magicLookup n = case lookupName n params of
+        Just x  -> pure x
+        Nothing -> throwError $ PgNamedParam n
+
+{- | Operator to create 'NamedParam's.
+
+>>> "foo" =? (1 :: Int)
+NamedParam {namedParamName = "foo", namedParamParam = 1}
+
+So it can be used in creating the list of the named arguments:
+
+@
+queryNamed [sql|
+  SELECT * FROM users WHERE foo = ?foo AND bar = ?bar AND baz = ?foo"
+|] [ "foo" =? "fooBar"
+   , "bar" =? "barVar"
+   ]
+@
+-}
+infix 7 =?
+(=?) :: (PG.ToField a) => Name -> a -> NamedParam
+n =? a = NamedParam n $ PG.toField a
+{-# INLINE (=?) #-}

stack.yaml

@@ -1,4 +1 @@
-resolver: lts-13.16
-
-ghc-options:
-  "$locals": -fhide-source-paths
+resolver: lts-13.27