diff --git a/hasql.cabal b/hasql.cabal --- a/hasql.cabal +++ b/hasql.cabal @@ -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 @@ . * . . - * . + * . . - * . + * . . 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 diff --git a/library/Hasql.hs b/library/Hasql.hs --- a/library/Hasql.hs +++ b/library/Hasql.hs @@ -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) |] + diff --git a/library/Hasql/QParser.hs b/library/Hasql/QParser.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/QParser.hs @@ -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 + diff --git a/library/Hasql/QQ.hs b/library/Hasql/QQ.hs deleted file mode 100644 --- a/library/Hasql/QQ.hs +++ /dev/null @@ -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 - diff --git a/library/Hasql/QQ/Parser.hs b/library/Hasql/QQ/Parser.hs deleted file mode 100644 --- a/library/Hasql/QQ/Parser.hs +++ /dev/null @@ -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 - diff --git a/library/Hasql/RowParser.hs b/library/Hasql/RowParser.hs --- a/library/Hasql/RowParser.hs +++ b/library/Hasql/RowParser.hs @@ -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] + diff --git a/library/Hasql/TH.hs b/library/Hasql/TH.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/TH.hs @@ -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