diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Marcin Tolysz + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Marcin Tolysz nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +mysql-simple-typed +================== +more: https://github.com/tolysz/typedquery diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/mysql-simple-typed.cabal b/mysql-simple-typed.cabal new file mode 100644 --- /dev/null +++ b/mysql-simple-typed.cabal @@ -0,0 +1,38 @@ +-- Initial mysql-simple-typed.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: mysql-simple-typed +version: 0.1.0.0 +synopsis: Typed extension to mysql simple +description: Simplifies simple +homepage: https://github.com/tolysz/mysql-simple-typed +license: BSD3 +license-file: LICENSE +author: Marcin Tolysz +maintainer: tolysz@gmail.com +-- copyright: +category: Database +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + exposed-modules: Database.MySQL.Simple.DBmore + Database.MySQL.Simple.DBmoreTH + Database.MySQL.Simple.TypedQuery + -- other-modules: + -- other-extensions: + build-depends: base >=4.7 && <4.8 + , mysql + , mysql-simple + , typedquery + , template-haskell + , haskell-src-meta +-- , parsec +-- , aeson +-- , bytestring +-- , text +-- , transformers + , utf8-string + hs-source-dirs: src + default-language: Haskell2010 diff --git a/src/Database/MySQL/Simple/DBmore.hs b/src/Database/MySQL/Simple/DBmore.hs new file mode 100644 --- /dev/null +++ b/src/Database/MySQL/Simple/DBmore.hs @@ -0,0 +1,72 @@ +{-# Language TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Database.MySQL.Simple.DBmore where + +import Database.MySQL.Simple.DBmoreTH + +qp 11 +qp 12 +qp 13 +qp 14 +qp 15 +qp 16 +qp 17 +qp 18 +qp 19 +qp 20 +qp 21 +qp 22 +qp 23 +qp 24 +qp 25 + +qr 11 +qr 12 +qr 13 +qr 14 +qr 15 +qr 16 +qr 17 +qr 18 +qr 19 +qr 20 +qr 21 +qr 22 +qr 23 +qr 24 +qr 25 +qr 26 +qr 27 +qr 28 +qr 29 +qr 30 +qr 31 +qr 32 +qr 33 +qr 34 +qr 35 +qr 36 +qr 37 +qr 38 +qr 39 +qr 40 +qr 41 +qr 42 +qr 43 +qr 44 +qr 45 +qr 46 +qr 47 +qr 48 +qr 49 +qr 50 +qr 51 +qr 52 +qr 53 +qr 54 +qr 55 +qr 56 +qr 57 +qr 58 +qr 59 diff --git a/src/Database/MySQL/Simple/DBmoreTH.hs b/src/Database/MySQL/Simple/DBmoreTH.hs new file mode 100644 --- /dev/null +++ b/src/Database/MySQL/Simple/DBmoreTH.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE TupleSections + , OverloadedStrings + , ScopedTypeVariables + , NoMonomorphismRestriction + , BangPatterns + , TemplateHaskell + , LambdaCase + #-} +module Database.MySQL.Simple.DBmoreTH +( qp +, qr +) +where + +import Database.MySQL.Base () +import Database.MySQL.Simple.QueryParams +import Database.MySQL.Simple.Param +import Database.MySQL.Simple.Result +import Database.MySQL.Simple.QueryResults + + +import Language.Haskell.TH.Syntax +import Control.Monad + +import Language.Haskell.Meta.Parse() + +import Prelude (map, (!!), (<), (-), (.) ,($), head, otherwise, zipWith3, Int, toInteger) + +-- maybe add case 0 + 1 and make it being generated + +qp :: Int -> Q [Dec] +qp k = do + ns <- replicateM k (newName "a") + let pre = map (\x -> ClassP (''Param) [VarT x]) ns + return [ InstanceD pre (loop k ns) [fun ns] ] + where + loop 0 ns = AppT (TupleT k) (VarT (head ns)) + loop i ns | i < k = AppT (loop (i-1) ns ) (VarT (ns !! i)) + | otherwise = AppT (ConT ''QueryParams) (loop (i-1) ns ) + fun ns = FunD ('renderParams) [ Clause [TupP (map VarP ns)] (NormalB $ ListE $ map (AppE (VarE 'render) . VarE) ns ) [] ] + +qr :: Int -> Q [Dec] +qr k = do + nsa <- replicateM k (newName "a") + nsv <- replicateM k (newName "v") + nsf <- replicateM k (newName "f") + fs <- newName "fs" + vs <- newName "vs" + + let pre = map (\x -> ClassP (''Result) [VarT x]) nsa + return [ InstanceD pre (loop k nsa) [fun nsa nsf nsv fs vs] ] + where + loop 0 ns = AppT (TupleT k) (VarT (head ns)) + loop i ns | i < k = AppT (loop (i-1) ns ) (VarT (ns !! i)) + | otherwise = AppT (ConT ''QueryResults) (loop (i-1) ns ) + fun nsa nsf nsv fs vs= FunD ('convertResults) + [ Clause [ListP (map VarP nsf), ListP (map VarP nsv)] + (NormalB $ TupE $ map VarE nsa ) + (zipWith3 (\a f v -> ValD (BangP (VarP a)) (NormalB (AppE (AppE (VarE 'convert) (VarE f)) (VarE v))) [] ) nsa nsf nsv) + , Clause [VarP fs,VarP vs] (NormalB (AppE (AppE (AppE (VarE 'convertError) (VarE fs)) (VarE vs)) (LitE $ IntegerL $ toInteger k))) [] + ] diff --git a/src/Database/MySQL/Simple/TypedQuery.hs b/src/Database/MySQL/Simple/TypedQuery.hs new file mode 100644 --- /dev/null +++ b/src/Database/MySQL/Simple/TypedQuery.hs @@ -0,0 +1,39 @@ +{-# Language TemplateHaskell #-} + +module Database.MySQL.Simple.TypedQuery +( genJsonQuery +, genTypedQuery +, TQ.genUncurry +, TQ.TypedQuery(..) +, S.Query +) +where + +import qualified Database.MySQL.Base as S (Connection) +import qualified Database.MySQL.Simple.Types as S (fromQuery) +import qualified Database.MySQL.Simple as S (query, query_, execute, execute_, Only(..), In(..), connect, Query) +import Database.MySQL.Simple.DBmore() +import qualified Database.TypedQuery.Types as TQ +import Language.Haskell.TH.Syntax (Q, Exp, Lift(..)) +import Data.ByteString.UTF8 (toString) +import Prelude ( (.)) + + +-- Move this somewhere +instance Lift S.Query where + lift = lift . toString . S.fromQuery + +instance TQ.RunDB S.Query where + rdquery _ = 'S.query + rdquery_ _ = 'S.query_ + rdexecute_ _ = 'S.execute_ + rdexecute _ = 'S.execute + rdin _ = 'S.In + rdonly _ = 'S.Only + rdconn _ = ''S.Connection + +genJsonQuery :: TQ.TypedQuery S.Query -> Q Exp +genJsonQuery = TQ.genJsonQuery + +genTypedQuery :: TQ.TypedQuery S.Query -> Q Exp +genTypedQuery = TQ.genTypedQuery