hasql 0.1.4 → 0.1.5

raw patch · 7 files changed

+158/−146 lines, 7 filesdep ~hasql-postgresdep ~mtl-preludedep ~safePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: hasql-postgres, mtl-prelude, safe

API changes (from Hackage documentation)

Files

• hasql.cabal +11/−11
• library/Hasql.hs +56/−8
• library/Hasql/QParser.hs +38/−0
• library/Hasql/QQ.hs +0/−47
• library/Hasql/QQ/Parser.hs +0/−38
• library/Hasql/RowParser.hs +29/−42
• library/Hasql/TH.hs +24/−0

@@ -1,12 +1,12 @@ name:   hasql version:-  0.1.4+  0.1.5 synopsis:   A minimalistic general high level API for relational databases description:   A robust and concise yet powerful API for communication with arbitrary-  relational databases. +  relational databases using SQL.   .   Features:   .@@ -42,9 +42,9 @@   .   * <http://nikita-volkov.github.io/hasql-benchmarks/ Benchmarks analysis>.   .-  * <http://hackage.haskell.org/package/hasql-0.1.3/src/demo/Main.hs A basic tutorial-demo>.+  * <http://hackage.haskell.org/package/hasql-0.1.3/src/demo/Main.hs Basic tutorial-demo>.   .-  * <http://hackage.haskell.org/package/hasql-postgres A PostgreSQL backend>.+  * <http://hackage.haskell.org/package/hasql-postgres PostgreSQL backend>.   . category:   Database@@ -86,9 +86,9 @@     Haskell2010   other-modules:     Hasql.Prelude-    Hasql.QQ-    Hasql.QQ.Parser+    Hasql.QParser     Hasql.RowParser+    Hasql.TH   exposed-modules:     Hasql   build-depends:@@ -114,16 +114,16 @@     -- general:     monad-control == 0.3.*,     transformers-base == 0.4.*,-    safe >= 0.3.8 && < 0.4,+    safe == 0.3.*,     mmorph == 1.0.*,-    mtl-prelude == 2.*,+    mtl-prelude < 3,     base-prelude >= 0.1.3 && < 0.2,     base >= 4.5 && < 4.8   -- Well, it's not a benchmark actually, --- but there's no better way to specify an executable, --- which is not intended for distribution, in Cabal.+-- but in Cabal there's no better way to specify an executable, +-- which is not intended for distribution. benchmark demo   type:      exitcode-stdio-1.0@@ -139,7 +139,7 @@   default-language:     Haskell2010   build-depends:-    hasql-postgres == 0.1.*,+    hasql-postgres == 0.3.*,     hasql == 0.1.*,     transformers,     base >= 4.5 && < 4.8

@@ -22,7 +22,7 @@   Backend.IsolationLevel(..),    -- * Statement Quasi-Quoter-  QQ.q,+  q,    -- * Statement Execution   unit,@@ -47,10 +47,13 @@ import Hasql.RowParser (RowParser) import qualified Hasql.Backend as Backend import qualified Hasql.RowParser as RowParser-import qualified Hasql.QQ as QQ+import qualified Hasql.QParser as QParser import qualified ListT import qualified Data.Pool as Pool import qualified Data.Vector as Vector+import qualified Language.Haskell.TH as TH+import qualified Language.Haskell.TH.Quote as TH+import qualified Hasql.TH as THUtil   -- * Session@@ -66,7 +69,7 @@ -- Given backend settings, session settings, and a session monad transformer, -- execute it in the inner monad. session :: -  Backend.Backend b => MonadBaseControl IO m =>+  (Backend.Backend b, MonadBaseControl IO m) =>   b -> SessionSettings -> Session b m r -> m r session backend (SessionSettings size timeout) reader =   join $ liftM restoreM $ liftBaseWith $ \runInIO ->@@ -180,7 +183,7 @@ -- | -- Execute a transaction in a session. tx :: -  Backend.Backend b => MonadBase IO m =>+  (Backend.Backend b, MonadBase IO m) =>   Mode -> (forall s. Tx b s r) -> Session b m r tx m t =   ReaderT $ \p -> liftBase $ Pool.withResource p $ \c -> runTx c m t@@ -245,7 +248,7 @@ -- | -- Execute a statement and count the amount of affected rows. -- Useful for resolving how many rows were updated or deleted.-count :: Backend b => Backend.Mapping b Word64 => Backend.Statement b -> Tx b s Word64+count :: (Backend b, Backend.Mapping b Word64) => Backend.Statement b -> Tx b s Word64 count s =   Tx $ ReaderT $ Backend.executeAndCountEffects s @@ -254,14 +257,14 @@ -- which produces a single result row:  -- a @SELECT@  -- or an @INSERT@, which produces a generated value (e.g., an auto-incremented id).-single :: Backend b => RowParser b r => Backend.Statement b -> Tx b s (Maybe r)+single :: (Backend b, RowParser b r) => Backend.Statement b -> Tx b s (Maybe r) single s =   headMay <$> list s  -- | -- Execute a @SELECT@ statement, -- and produce a list of results.-list :: Backend b => RowParser b r => Backend.Statement b -> Tx b s [r]+list :: (Backend b, RowParser b r) => Backend.Statement b -> Tx b s [r] list s =   Tx $ ReaderT $ \c -> do     m <- Backend.executeAndGetMatrix s c@@ -275,10 +278,55 @@ -- at a cost of a small overhead. -- Note that in most databases cursors require establishing a database transaction, -- so a 'NotInTransaction' error will be raised if you run it improperly.-stream :: Backend b => RowParser b r => Backend.Statement b -> TxListT s (Tx b s) r+stream :: (Backend b, RowParser b r) => Backend.Statement b -> TxListT s (Tx b s) r stream s =   do     s <- lift $ Tx $ ReaderT $ \c -> Backend.executeAndStream s c     TxListT $ hoist (Tx . lift) $ do       row <- s       either (lift . throwIO . UnparsableRow) return $ RowParser.parseRow row+++-- * Statements quasi-quotation+-------------------------++-- |+-- Produces a lambda-expression, +-- which takes as many parameters as there are placeholders in the quoted text+-- and results in a 'Backend.Statement'. +-- +-- E.g.:+-- +-- >selectFive :: 'Backend.Statement' c+-- >selectFive = [q|SELECT (? + ?)|] 2 3+-- +q :: TH.QuasiQuoter+q = +  TH.QuasiQuoter+    (parseExp)+    (const $ fail "Pattern context is not supported")+    (const $ fail "Type context is not supported")+    (const $ fail "Declaration context is not supported")+  where+    parseExp s =+      do+        n <- either (fail . showString "Parsing failure: ") return (QParser.parse (fromString s))+        return $ statementF s n+    statementF s n =+      TH.LamE+        (map TH.VarP argNames)+        (TH.AppE +          (TH.AppE +            (TH.ConE '(,))+            (statementE))+          (argsE))+      where+        argNames = +          map (TH.mkName . ('_' :) . show) [1 .. n]+        statementE = +          TH.LitE (TH.StringL s)+        argsE = +          TH.ListE $ flip map argNames $ \x ->+            THUtil.purify+            [| Backend.renderValue $(TH.varE x) |]+        

@@ -0,0 +1,38 @@+module Hasql.QParser where++import Hasql.Prelude hiding (takeWhile)+import Data.Attoparsec.Text hiding (Result)+import qualified Data.Text as Text+++-- |+-- The amount of placeholders.+type Result =+  (Word)++parse :: Text -> Either String Result+parse = +  parseOnly countPlaceholders+  where+    countPlaceholders =+      count <|> pure 0+      where+        count =+          do+            many $ void stringLit <|> void (notChar '?')+            char '?'+            fmap succ countPlaceholders++stringLit :: Parser Text+stringLit =+  do+    quote <- +      char '"' <|> char '\''+    text <- +      fmap mconcat $ many $ +        string "\\\\" <|> +        string (fromString ['\\', quote]) <|> +        (Text.singleton <$> notChar quote)+    char quote+    return text+

@@ -1,47 +0,0 @@-module Hasql.QQ where--import Hasql.Prelude-import Language.Haskell.TH-import Language.Haskell.TH.Quote-import qualified Hasql.QQ.Parser as Parser-import qualified Hasql.Backend as Backend----- |--- Produces a lambda-expression, --- which takes as many parameters as there are placeholders in the quoted text--- and results in an expression of type 'Backend.Statement'. --- --- E.g.:--- --- >selectFive :: Statement b--- >selectFive = [q|SELECT (? + ?)|] 2 3--- -q :: QuasiQuoter-q = -  QuasiQuoter-    parseExp-    (const $ fail "Pattern context is not supported")-    (const $ fail "Type context is not supported")-    (const $ fail "Declaration context is not supported")---parseExp :: String -> Q Exp-parseExp s =-  do-    n <- either (fail . showString "Parsing failure: ") return (Parser.parse (fromString s))-    return $ statementF s n---- |--- An expression of a function with an arbitrary arity, --- which produces a "Backend.Statement".-statementF :: String -> Word -> Exp-statementF s n =-  LamE pats exp-  where-    vars = map (mkName . ('_' :) . show) [1 .. n]-    pats = map VarP vars-    exp  = AppE (AppE (ConE '(,)) (LitE (StringL s))) (ListE exps)-      where-        exps = map (AppE (VarE 'Backend.renderValue) . VarE) vars-

@@ -1,38 +0,0 @@-module Hasql.QQ.Parser where--import Hasql.Prelude hiding (takeWhile)-import Data.Attoparsec.Text hiding (Result)-import qualified Data.Text as Text----- |--- The amount of placeholders.-type Result =-  (Word)--parse :: Text -> Either String Result-parse = -  parseOnly countPlaceholders-  where-    countPlaceholders =-      count <|> pure 0-      where-        count =-          do-            many $ void stringLit <|> void (notChar '?')-            char '?'-            fmap succ countPlaceholders--stringLit :: Parser Text-stringLit =-  do-    quote <- -      char '"' <|> char '\''-    text <- -      fmap mconcat $ many $ -        string "\\\\" <|> -        string (fromString ['\\', quote]) <|> -        (Text.singleton <$> notChar quote)-    char quote-    return text-

@@ -4,6 +4,7 @@ import Language.Haskell.TH import qualified Hasql.Backend as Backend import qualified Data.Vector as Vector+import qualified Hasql.TH as THUtil   class RowParser b r where@@ -20,45 +21,31 @@     Identity <$> Backend.parseResult (Vector.unsafeHead row)  -- Generate tuple instaces using Template Haskell:-let-  inst :: Int -> Dec-  inst arity =-    InstanceD constraints head [parseRowDec]-    where-      varNames =-        [1 .. arity] >>= \i -> return (mkName ('v' : show i))-      varTypes =-        map VarT varNames-      backendType =-        VarT (mkName "b")-      constraints =-        map (\t -> ClassP ''Backend.Mapping [backendType, t]) varTypes-      head =-        AppT (AppT (ConT ''RowParser) backendType) (foldl AppT (TupleT arity) varTypes)-      parseRowDec =-        FunD 'parseRow [Clause [VarP n] (NormalB e) []]-        where-          n = mkName "row"-          e =-            foldQueue queue-            where-              lookups = do-                i <- [0 .. pred arity]-                return $ purify $-                  [|-                    Backend.parseResult $ -                    (Vector.unsafeIndex) $(varE n) $(litE (IntegerL $ fromIntegral i)) -                  |]-              queue =-                (ConE (tupleDataName arity) :) $-                (VarE '(<$>) :) $-                intersperse (VarE '(<*>)) $-                lookups-              foldQueue =-                \case-                  e : o : t -> UInfixE e o (foldQueue t)-                  e : [] -> e-                  _ -> $bug "Unexpected queue size"-      purify = unsafePerformIO . runQ-  in -    mapM (return . inst) [2 .. 24]+return $ flip map [2 .. 24] $ \arity ->+  let +    varNames =+      [1 .. arity] >>= \i -> return (mkName ('v' : show i))+    varTypes =+      map VarT varNames+    connectionType =+      VarT (mkName "b")+    constraints =+      map (\t -> ClassP ''Backend.Mapping [connectionType, t]) varTypes+    head =+      AppT (AppT (ConT ''RowParser) connectionType) (foldl AppT (TupleT arity) varTypes)+    parseRowDec =+      FunD 'parseRow [Clause [VarP rowVarName] (NormalB e) []]+      where+        rowVarName = mkName "row"+        e =+          THUtil.applicativeE (ConE (tupleDataName arity)) lookups+          where+            lookups = do+              i <- [0 .. pred arity]+              return $ THUtil.purify $+                [|+                  Backend.parseResult+                    (Vector.unsafeIndex $(varE rowVarName) $(litE (IntegerL $ fromIntegral i)) )+                |]+    in InstanceD constraints head [parseRowDec]+

@@ -0,0 +1,24 @@+-- |+-- TH utils.+module Hasql.TH where++import Hasql.Prelude+import Language.Haskell.TH+++applicativeE :: Exp -> [Exp] -> Exp+applicativeE head =+  \case+    [] -> error "Empty expressions list"+    exps ->+      reduce $ +        head : VarE '(<$>) : intersperse (VarE '(<*>)) exps+      where+        reduce =+          \case+            e : o : t -> UInfixE e o (reduce t)+            e : [] -> e+            _ -> $bug $ "Unexpected queue size. Exps: " <> show exps++purify :: Q a -> a+purify = unsafePerformIO . runQ