yeshql 1.0.0.1 → 2.0.0.0

raw patch · 5 files changed

+98/−24 lines, 5 filesdep +convertiblePVP ok

version bump matches the API change (PVP)

Dependencies added: convertible

API changes (from Hackage documentation)

Files

• src/Database/YeshQL.hs +23/−17
• src/Database/YeshQL/Parser.hs +11/−5
• src/Database/YeshQL/SqlRow/Class.hs +19/−0
• tests/Database/YeshQL/SimulationTests.hs +42/−1
• yeshql.cabal +3/−1

@@ -54,7 +54,7 @@     -- :name :: String     INSERT INTO users (name) VALUES (:name) RETURNING id     ;;;-    -- name:deleteUser :: Integer+    -- name:deleteUser :: rowcount Integer     -- :id :: Integer     DELETE FROM users WHERE id = :id     ;;;@@ -98,21 +98,19 @@ - A tuple, where all elements implement 'FromSql'; the function will return   the result set from a @SELECT@ query as a 'Maybe' of such tuples, or always   'Nothing' for other query types. For example, @:: (String, Int)@ produces-  a function whose type ends in @conn -> IO (Maybe (String, Int))@.-- A scalar, i.e., just a type name. The return value will be a 'Maybe'-  of scalars, containing the values from the first (or only) column in-  the result set. Note that, unlike Haskell, YeshQL does distinguish between-  @Type@ and @(Type)@: the former is a scalar type, while the latter is a-  one-tuple whose only element is of type @Type@. For example, @:: (Int)@-  produces a function whose type ends in @... -> conn -> IO (Maybe Int))@.-- A list of tuples, e.g. @[(String, Int)]@; the return value will be a list-  of such tuples.-- A list of scalars, e.g. @[Int]@. The return value will be a list of-  scalars, i.e., @... -> conn -> IO [Int]@.--Scalars can be written as "one-tuples", that is, @[Int]@ and @[(Int)]@ are-equivalent.+  a function whose type ends in @conn -> IO (Maybe (String, Int))@. Null-tuples+  are marshalled to '()', ignoring result sets; one-tuples (written as @(a)@)+  are marshalled to scalars.+- A naked type, i.e., just a type name, without parentheses. The type must+  implement 'FromSqlRow'; the return type will be a 'Maybe' of that type. E.g.,+  @(:: User)@ will produce a function signature ending in+  @conn -> IO (Maybe User)@.+- A list of tuples or naked types, written using square brackets (@[@ ... @]@),+  returning a list of mapped rows instead of a 'Maybe'. +Note that, unlike Haskell, YeshQL distinguishes @(Foo)@ from @Foo@: the former+takes the first column from a result row and maps it using 'FromSql', while the+latter takes the entire result row and maps it using 'FromSqlRow'.  @     -- :paramName :: Type@@ -190,7 +188,7 @@  @ [yesh1|-    -- name:getUser :: (Integer, String)+    -- name:getUser :: User     -- :userID :: Integer     -- Gets one user by the "id" column.     SELECT id, username FROM users WHERE id = :userID LIMIT 1 |]@@ -199,7 +197,7 @@ ...would produce the following three top-level definitions:  @-getUser :: IConnection conn => Integer -> conn -> [(Integer, String)]+getUser :: IConnection conn => Integer -> conn -> IO (Maybe User) getUser userID conn = ...  describeGetUser :: String@@ -242,6 +240,7 @@ import Data.Char (isAlpha, isAlphaNum)  import Database.YeshQL.Parser+import Database.YeshQL.SqlRow.Class  headMay :: [a] -> Maybe a headMay [] = Nothing@@ -450,6 +449,8 @@                         ReturnTuple Many [] -> tupleT 0                         ReturnTuple Many (x:[]) -> appT listT $ mkType x                         ReturnTuple Many xs -> appT listT $ foldl' appT (tupleT $ length xs) (map mkType xs)+                        ReturnRecord One x -> appT [t|Maybe|] $ mkType x+                        ReturnRecord Many x -> appT listT $ mkType x  mkType :: ParsedType -> Q Type mkType (MaybeType n) = [t|Maybe $(conT . mkName $ n)|]@@ -522,6 +523,7 @@                                     [(listP (map (varP . mkName) varNames))]                                     -- (fromSql a, fromSql b, fromSql c, ...)                                     (tupE $ (map (\n -> appE (varE 'fromSql) (varE . mkName $ n)) varNames)))|]+                    ReturnRecord _ x -> [|fromSqlRow|]         queryFunc = case pqReturnType query of                         ReturnRowCount _ ->                             [| \qstr params conn -> $convert <$> run conn qstr params |]@@ -529,6 +531,10 @@                             [| \qstr params conn -> $convert <$> quickQuery' conn qstr params |]                         ReturnTuple One _ ->                             [| \qstr params conn -> fmap headMay $ $convert <$> quickQuery' conn qstr params |]+                        ReturnRecord Many _ ->+                            [| \qstr params conn -> mapM $convert =<< quickQuery' conn qstr params |]+                        ReturnRecord One _ ->+                            [| \qstr params conn -> fmap headMay $ mapM $convert =<< quickQuery' conn qstr params |]         rawQueryFunc = [| \qstr conn -> runRaw conn qstr |]     if pqDDL query         then

@@ -28,6 +28,7 @@  data ParsedReturnType = ReturnRowCount ParsedType                       | ReturnTuple OneOrMany [ParsedType]+                      | ReturnRecord OneOrMany ParsedType                       deriving (Show)  data ParsedQuery =@@ -201,21 +202,26 @@     whitespaceP     ReturnRowCount <$> typeP +setNumerus :: OneOrMany -> ParsedReturnType -> ParsedReturnType+setNumerus _ (ReturnRowCount t) = ReturnRowCount t+setNumerus numerus (ReturnTuple _ x) = ReturnTuple numerus x+setNumerus numerus (ReturnRecord _ x) = ReturnRecord numerus x+ returnTypeMultiP :: Parsec String () ParsedReturnType returnTypeMultiP =-    ReturnTuple Many <$> between+    setNumerus Many <$> between         (char '[' >> whitespaceP)         (char ']' >> whitespaceP)         returnTypeRowP  returnTypeSingleP :: Parsec String () ParsedReturnType returnTypeSingleP =-    ReturnTuple One <$> returnTypeRowP+    setNumerus One <$> returnTypeRowP -returnTypeRowP :: Parsec String () [ParsedType]+returnTypeRowP :: Parsec String () ParsedReturnType returnTypeRowP =-    returnTypeTupleP <|> -    fmap (:[]) typeP+    fmap (ReturnTuple One) returnTypeTupleP <|> +    fmap (ReturnRecord One) typeP  returnTypeTupleP :: Parsec String () [ParsedType] returnTypeTupleP =

@@ -0,0 +1,19 @@+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE DeriveGeneric #-}+{-#LANGUAGE LambdaCase #-}+{-#LANGUAGE TemplateHaskell #-}+{-#LANGUAGE MultiParamTypeClasses #-}+{-#LANGUAGE FlexibleContexts #-}+module Database.YeshQL.SqlRow.Class+where++import Database.HDBC+import Data.Convertible (Convertible)++class ToSqlRow a where+    toSqlRow :: a -> [SqlValue]++class FromSqlRow a where+    fromSqlRow :: Monad m => [SqlValue] -> m a++class (ToSqlRow a, FromSqlRow a) => SqlRow a where

@@ -1,5 +1,6 @@ {-#LANGUAGE QuasiQuotes #-} {-#LANGUAGE RankNTypes #-}+{-#LANGUAGE LambdaCase #-} module Database.YeshQL.SimulationTests ( tests )@@ -10,6 +11,7 @@ import Database.HDBC import Database.HDBC.Mock import Database.YeshQL+import Database.YeshQL.SqlRow.Class import System.IO import Data.Char import Data.List (dropWhile, dropWhileEnd)@@ -63,6 +65,45 @@                 }             ] +data User =+    User+        { userID :: Int+        , userName :: String+        }+        deriving (Show, Eq)++instance FromSqlRow User where+    fromSqlRow = \case+        [ sqlID, sqlName ] ->+            return $ User (fromSql sqlID) (fromSql sqlName)+        _ -> fail "Not a user"++instance ToSqlRow User where+    toSqlRow (User id name) =+        [ toSql id, toSql name ]++testRecordReturn :: TestTree+testRecordReturn = testCase "Return record from SELECT" $ chatTest chatScript $ \conn -> do+    actual <- [yesh|+        -- name:getUserByName :: User+        -- :username :: String+        SELECT id, username FROM users+        WHERE username = :username LIMIT 1|]+        "billy"+        conn+    let expected :: Maybe User+        expected = Just $ User 1 "billy"+    assertEqual "" expected actual+    where+        chatScript =+            [ ChatStep+                { chatQuery = sameThrough trim "SELECT id, username FROM users WHERE username = ? LIMIT 1"+                , chatParams = [exactly (toSql "billy")]+                , chatResultSet = [[toSql (1 :: Int), toSql "billy"]]+                , chatColumnNames = ["username"]+                , chatRowsAffected = 0+                }+            ] testSingleInsert :: TestTree testSingleInsert = testCase "Single INSERT" $ chatTest chatScript $ \conn -> do     actual <- [yesh|@@ -111,7 +152,7 @@             ]  [yesh|-    -- name:findUser :: Int+    -- name:findUser :: (Int)     -- :username :: String     SELECT id FROM users WHERE username = :username     ;;;

@@ -1,5 +1,5 @@ name: yeshql-version: 1.0.0.1+version: 2.0.0.0 synopsis: YesQL-style SQL database abstraction description: Use quasi-quotations to write SQL in SQL, while at the same time              adding type annotations to turn them into well-typed Haskell@@ -16,6 +16,7 @@  library     exposed-modules: Database.YeshQL+                   , Database.YeshQL.SqlRow.Class     other-modules: Database.YeshQL.Parser     -- other-extensions:     build-depends: base >=4.6 && <5.0@@ -24,6 +25,7 @@                  , filepath                  , parsec >= 3.0 && <4.0                  , template-haskell+                 , convertible >= 1.1.1.0 && <2     hs-source-dirs: src     default-language: Haskell2010 test-suite tests