yeshql 2.0.0.0 → 2.1.0.0

raw patch · 3 files changed

+66/−18 lines, 3 filesdep +syb-with-classPVP ok

version bump matches the API change (PVP)

Dependencies added: syb-with-class

API changes (from Hackage documentation)

Files

• src/Database/YeshQL/SqlRow/TH.hs +51/−0
• tests/Database/YeshQL/SimulationTests.hs +12/−17
• yeshql.cabal +3/−1

@@ -0,0 +1,51 @@+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE DeriveGeneric #-}+{-#LANGUAGE TemplateHaskell #-}+{-#LANGUAGE QuasiQuotes #-}+{-#LANGUAGE LambdaCase #-}+module Database.YeshQL.SqlRow.TH+where++import Database.YeshQL.SqlRow.Class+import Database.HDBC (fromSql, toSql)+import Language.Haskell.TH+import Language.Haskell.TH.Quote+import Data.Generics.SYB.WithClass.Derive (typeInfo)++makeSqlRow :: Name -> Q [Dec]+makeSqlRow entityName = do+    (TyConI d) <- reify entityName+    (typeName, _, constructors) <- typeInfo d++    (constructorName, fieldNames, fieldTypes) <-+        case constructors of+            [(constructorName, _, Just fieldNames, fieldTypes)] ->+                return (constructorName, fieldNames, fieldTypes)+            _ -> fail "Unsuitable type for deriving SqlRow"++    [d|+        instance ToSqlRow $(conT typeName) where+            toSqlRow entity =+                $(listE $ map (toSqlRowField 'entity) fieldNames)++        instance FromSqlRow $(conT typeName) where+            fromSqlRow = \case+                $(listP $ map fromSqlPatternItem fieldNames) ->+                    return $+                        $(foldl1 appE $+                            conE constructorName : map fromSqlPatternArg fieldNames)+                _ -> fail $ "Invalid SQL for " ++ $(litE . stringL . nameBase $ typeName) |]+    where+        toSqlRowField :: Name -> Name -> ExpQ+        toSqlRowField entityName fieldName =+            appE [|toSql|] $ appE (varE fieldName) (varE entityName)++        fromSqlPatternItem :: Name -> PatQ+        fromSqlPatternItem fieldName =+            varP (mkName $ "sql_" ++ nameBase fieldName)++        fromSqlPatternArg :: Name -> ExpQ+        fromSqlPatternArg fieldName =+            appE+                (varE (mkName "fromSql"))+                (varE (mkName $ "sql_" ++ nameBase fieldName))

@@ -1,6 +1,7 @@ {-#LANGUAGE QuasiQuotes #-} {-#LANGUAGE RankNTypes #-} {-#LANGUAGE LambdaCase #-}+{-#LANGUAGE TemplateHaskell #-} module Database.YeshQL.SimulationTests ( tests )@@ -12,10 +13,20 @@ import Database.HDBC.Mock import Database.YeshQL import Database.YeshQL.SqlRow.Class+import Database.YeshQL.SqlRow.TH import System.IO import Data.Char import Data.List (dropWhile, dropWhileEnd) +data User =+    User+        { userID :: Int+        , userName :: String+        }+        deriving (Show, Eq)++makeSqlRow ''User+ tests =     [ testSimpleSelect     , testParametrizedSelect@@ -65,23 +76,6 @@                 }             ] -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|@@ -104,6 +98,7 @@                 , chatRowsAffected = 0                 }             ]+ testSingleInsert :: TestTree testSingleInsert = testCase "Single INSERT" $ chatTest chatScript $ \conn -> do     actual <- [yesh|

@@ -1,5 +1,5 @@ name: yeshql-version: 2.0.0.0+version: 2.1.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@@ -17,6 +17,7 @@ library     exposed-modules: Database.YeshQL                    , Database.YeshQL.SqlRow.Class+                   , Database.YeshQL.SqlRow.TH     other-modules: Database.YeshQL.Parser     -- other-extensions:     build-depends: base >=4.6 && <5.0@@ -24,6 +25,7 @@                  , containers >= 0.5 && < 1.0                  , filepath                  , parsec >= 3.0 && <4.0+                 , syb-with-class >= 0.6.1.7 && <1                  , template-haskell                  , convertible >= 1.1.1.0 && <2     hs-source-dirs: src