hssqlppp-th (empty) → 0.6.0
raw patch · 7 files changed
+626/−0 lines, 7 filesdep +basedep +hssqlpppdep +sybsetup-changed
Dependencies added: base, hssqlppp, syb, tasty, tasty-hunit, template-haskell, text
Files
- LICENSE +31/−0
- README +16/−0
- Setup.lhs +4/−0
- hssqlppp-th.cabal +58/−0
- src/Database/HsSqlPpp/Quote.lhs +356/−0
- tests/Database/HsSqlPpp/Tests/QuasiQuoteTests.lhs +155/−0
- tests/TestsTh.lhs +6/−0
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright Jake Wheat 2010-2014++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 Jake Wheat 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.+
+ README view
@@ -0,0 +1,16 @@+A parser, pretty printer, and type checker for SQL written in+Haskell. Mainly targets the PostgreSQL dialect of SQL and PL/pgSQL+syntax.++Pre alpha: works well and is stable for a subset of SQL, but there are+lots of unfinished areas and the api is likely to change a lot from+release to release at this time.++Website, with some docs and examples:+http://jakewheat.github.com/hssqlppp/latest++Hackage: http://hackage.haskell.org/package/hssqlppp++Repository: https://github.com/JakeWheat/hssqlppp++Contact: jakewheatmail@gmail.com
+ Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ hssqlppp-th.cabal view
@@ -0,0 +1,58 @@+Name: hssqlppp-th+Version: 0.6.0+Synopsis: hssqlppp extras which need template-haskell+License: BSD3+License-file: LICENSE+Author: Jake Wheat+Maintainer: jakewheatmail@gmail.com+Build-Type: Simple+Cabal-Version: >=1.10+copyright: Copyright 2009-2014 Jake Wheat+stability: pre-alpha+homepage: http://jakewheat.github.com/hssqlppp/+bug-reports: https://github.com/JakeWheat/hssqlppp/issues+category: Database,Language+Description:+ hssqlppp extras which need template-haskell+ .+ Documentation, examples on the homepage:+ <http://jakewheat.github.com/hssqlppp/>.+ .+ Changes here: <https://github.com/JakeWheat/hssqlppp/blob/master/CHANGES>++extra-source-files: README+ LICENSE++source-repository head+ type: git+ location: https://github.com/JakeWheat/hssqlppp.git++Library+ Build-Depends: base >= 4 && < 5,+ template-haskell,+ hssqlppp == 0.6.0,+ syb >= 0.1.0.2 && < 0.7,+ text >= 0.11.1.13 && < 1.3++ hs-source-dirs: src+ Exposed-modules: Database.HsSqlPpp.Quote+ default-language: Haskell2010+ ghc-options: -Wall++Test-Suite TestsTh+ type: exitcode-stdio-1.0+ main-is: TestsTh.lhs+ hs-source-dirs: src,tests+ Build-Depends: base >= 4 && < 5,+ syb >= 0.1.0.2 && < 0.7,+ template-haskell,+ tasty >= 0.10 && < 0.12,+ tasty-hunit >= 0.9 && < 0.10,++ text >= 0.11.1.13 && < 1.3,+ hssqlppp == 0.6.0++ Other-Modules: Database.HsSqlPpp.Tests.QuasiQuoteTests+ Database.HsSqlPpp.Quote+ default-language: Haskell2010+ ghc-options: -Wall
+ src/Database/HsSqlPpp/Quote.lhs view
@@ -0,0 +1,356 @@+> {- | A quasiquoter for SQL. Antiquoting is a bit inconsistent.+>+> Example:+>+> >+> > {-# LANGUAGE QuasiQuotes #-}+> > import Database.HsSqlPpp.Ast+> > import Database.HsSqlPpp.Quote+> > import Database.HsSqlPpp.Annotation+> >+> > test :: Statement+> > test = [$sqlStmt|+> >+> > create table $n(tablename) (+> > $m(varname) $n(typename)+> > );+> >+> > |]+> > where+> > tablename = [sqlName| my_table |]+> > varname = [sqlNameComponent| my_field |]+> > typename = [sqlName| text |]+> >+>+> See <http://jakewheat.github.com/hssqlppp/QuasiQuoteTests.html>+> for more simple examples+>+> The splices are:+>+> * $e(scalarexpression)+>+> * $s(string)+>+> * $t(triggerevent)+>+> * $s(statement)+>+> * $n(name)+>+> * $m(namecomponent)+>+> You can use $m() in a name context, and $n() or $m() in a scalar+> expression context. You can only use a single variable name in a+> splice atm.+> -}++, and+<http://jakewheat.github.com/hssqlppp/source/examples/Database/HsSqlPpp/Examples/Extensions/>+for some example files which use quasiquotation to do ast+transformations which implement syntax extensions to sql+these files need fixing up before ready for public consumption+++improvements to qq:+quasi quotes and antiquotes for?:+tablerefs+select lists+multiple statements++use haskell syntax inside antiquotes++>+> {-# LANGUAGE ScopedTypeVariables #-}+>+> module Database.HsSqlPpp.Quote+> (sqlStmts,sqlStmt,pgsqlStmts,pgsqlStmt,sqlExpr,sqlName,sqlNameComponent) where++> import Language.Haskell.TH.Quote+> import Language.Haskell.TH+> import Data.Generics+> import Data.List+>+> import qualified Database.HsSqlPpp.Parse as P+> import Database.HsSqlPpp.Annotation+> import Database.HsSqlPpp.Syntax hiding (Name)+> import qualified Database.HsSqlPpp.Syntax as A+> --import qualified Data.Text as T+> import qualified Data.Text.Lazy as L+> --import Data.Data++> import Data.Text ()++> -- Control.Monad.Identity+> --import Text.Parsec++public api: the quasiquote functions++> -- | quotes Statements+> sqlStmts :: QuasiQuoter+> sqlStmts = makeQQ $ parseStatements P.defaultParseFlags+>+> -- | quotes a single Statement+> sqlStmt :: QuasiQuoter+> sqlStmt = makeQQ parseOneStatement+>+> -- | quotes plpgsql Statements+> pgsqlStmts :: QuasiQuoter+> pgsqlStmts = makeQQ $ parsePlpgsql P.defaultParseFlags+>+> -- | quotes a plpgsql Statement+> pgsqlStmt :: QuasiQuoter+> pgsqlStmt = makeQQ parseOnePlpgsql++> -- | quotes a ScalarExpr+> sqlExpr :: QuasiQuoter+> sqlExpr = makeQQ $ parseScalarExpr P.defaultParseFlags+> {-QuasiQuoter {quoteExp = prs}+> where+> prs :: String -> Q Exp+> prs s = either (fail . show) return (pse s)+> >>= dataToExpQ (const Nothing)-}++> --pse :: String -> Either P.ParseErrorExtra ScalarExpr+> --pse = parseScalarExpr P.defaultParseFlags "" Nothing++ghc -Wall -threaded -rtsopts -isrc:src-extra/catalogReader:src-extra/chaos:src-extra/devel-util:src-extra/docutil:src-extra/examples:src-extra/extensions:src-extra/h7c:src-extra/tests:src-extra/chaos/extensions:src-extra/utils temp.lhs++> -- | quotes a Name+> sqlName :: QuasiQuoter+> sqlName = makeQQ $ parseName P.defaultParseFlags++> -- | quotes a Name+> sqlNameComponent :: QuasiQuoter+> sqlNameComponent = makeQQ $ parseNameComponent P.defaultParseFlags+++boilerplate utils to hook everything together++> type Parser e a = (String+> -> Maybe (Int,Int)+> -> String+> -> Either e a)+>+> makeQQ :: (Show e, Data a) =>+> Parser e a -> QuasiQuoter+> makeQQ p = QuasiQuoter {quoteExp = parseExprExp p+> ,quotePat = parseExprPat p+> ,quoteType = error "quasi-quoter doesn't work for types"+> ,quoteDec = error "quasi-quoter doesn't work for declarations"}++hack for the text issue:++create parallel ast with text replaced with strings automatically+create conversion function to convert tree with text to tree with+strings automatically+pass this tree into dataToExpQ+then get the result, and convert the Exp type back to using text+not sure what needs to be done about which package the Exp refers to+maybe it will work?++> parseExprExp :: (Show e, Data a) =>+> Parser e a -> String -> Q Exp+> parseExprExp p s = parseSql' p s+> >>= dataToExpQ (const Nothing+> `extQ` antiExpE+> `extQ` antiStrE+> `extQ` antiTriggerEventE+> `extQ` antiStatementE+> `extQ` antiNameE+> `extQ` antiNameComponentE)++> parseExprPat :: (Show e, Data a) =>+> Parser e a -> String -> Q Pat+> parseExprPat p s = parseSql' p s+> >>= dataToPatQ (const Nothing+> `extQ` antiExpP+> `extQ` antiStrP+> `extQ` antiTriggerEventP+> `extQ` antiStatementP+> `extQ` antiNameP+> `extQ` antiNameComponentP+> `extQ` annotToWildCard)+>++wrapper for all the different parsers which sets the source location+and converts left to fail++todo: error messages not coming out nicely from ghc when doing+fail.show.++> parseSql' :: (Data a, Show e) => Parser e a -> String -> Q a+> parseSql' p s = do+> Loc fn _ _ (l,c) _ <- location+> either (fail . show) return (p fn (Just (l,c)) s)++wrappers - the Parser module doesn't expose methods which parse+exactly one statement++> parseOnePlpgsql :: Parser String Statement+> parseOnePlpgsql f sp s =+> case parsePlpgsql P.defaultParseFlags f sp s of+> Right [st] -> Right st+> Right _ -> Left "got multiple statements"+> Left e -> Left $ show e+>+> parseOneStatement :: Parser String Statement+> parseOneStatement f sp s =+> case parseStatements P.defaultParseFlags f sp s of+> Right [st] -> Right st+> Right _ -> Left "got multiple statements"+> Left e -> Left $ show e++hack: replace the annotations in asts produced by parsing with+wildcards, if you don't do this then pattern matches generally don't+work since the source position annotations from the parser don't match+up. The source position annotations are still available so that e.g. a+function can pattern match against a statement then get the source+position from the matched statements.++> annotToWildCard :: Annotation -> Maybe PatQ+> annotToWildCard _ = Just $ return WildP++= individual antinode lookup functions++> antiExpE :: ScalarExpr -> Maybe ExpQ+> antiExpE v = fmap varE (antiExp v)+>+> antiExpP :: ScalarExpr -> Maybe PatQ+> antiExpP v = fmap varP $ antiExp v+>+> antiExp :: ScalarExpr -> Maybe Name+> antiExp (AntiScalarExpr v) = Just $ mkName v+> antiExp _ = Nothing+++> antiNameE :: A.Name -> Maybe ExpQ+> antiNameE v = fmap varE (antiName v)+>+> antiNameP :: A.Name -> Maybe PatQ+> antiNameP v = fmap varP $ antiName v+>+> antiName :: A.Name -> Maybe Name+> antiName (AntiName v) = Just $ mkName v+> antiName _ = Nothing++> antiNameComponentE :: NameComponent -> Maybe ExpQ+> antiNameComponentE v = fmap varE (antiNameComponent v)+>+> antiNameComponentP :: NameComponent -> Maybe PatQ+> antiNameComponentP v = fmap varP $ antiNameComponent v+>+> antiNameComponent :: NameComponent -> Maybe Name+> antiNameComponent (AntiNameComponent v) = Just $ mkName v+> antiNameComponent _ = Nothing++++> antiStatementE :: Statement -> Maybe ExpQ+> antiStatementE v = fmap varE (antiStatement v)+>+> antiStatementP :: Statement -> Maybe PatQ+> antiStatementP v = fmap varP $ antiStatement v+>+> antiStatement :: Statement -> Maybe Name+> antiStatement (AntiStatement v) = Just $ mkName v+> antiStatement _ = Nothing++++antistatements not working ...+trying to replace a single antistatement node with multiple statement+nodes and my generics skills aren't up to the task.+++> {-antiStatementE :: [Statement] -> Maybe ExpQ+> antiStatementE (AntiStatement v : tl) =+> Just (listE (vref : conArgs))+> where+> conArgs = gmapQ (dataToExpQ (const Nothing+> `extQ` antiExpE+> -- `extQ` antiStrE+> `extQ` antiTriggerEventE+> `extQ` antiStatementE+> `extQ` antiNameE+> `extQ` antiNameComponentE)) tl+> vref :: ExpQ+> vref = varE $ mkName v+> antiStatementE _ = Nothing-}+++> antiStrE :: String -> Maybe ExpQ+> antiStrE v = fmap varE $ antiStr v++> antiStrP :: String -> Maybe PatQ+> antiStrP v = fmap varP $ antiStr v++> antiStr :: String -> Maybe Name+> antiStr v =+> fmap mkName $ getSpliceName v+> where+> getSpliceName s+> | isPrefixOf "$s(" s && last s == ')' =+> Just $ drop 3 $ init s+> | otherwise = Nothing++>+> antiTriggerEventE :: TriggerEvent -> Maybe ExpQ+> antiTriggerEventE (AntiTriggerEvent v) = Just $ varE $ mkName v+> antiTriggerEventE _ = Nothing++> antiTriggerEventP :: TriggerEvent -> Maybe PatQ+> antiTriggerEventP (AntiTriggerEvent v) = Just $ varP $ mkName v+> antiTriggerEventP _ = Nothing+++what needs to be done to support _ in pattern quasiquotes? -> I think+it's just adding a wildcard ctor to the appropriate ast types using+makeantinodes, and adding in lexing and parsing support - actually+using wildcards is now working with the annotation approach above++also, how to use haskell syntax in splices++----------------------------------++> parseStatements :: P.ParseFlags -- ^ parse options+> -> FilePath -- ^ filename to use in errors+> -> Maybe (Int,Int) -- ^ set the line number and column number+> -- of the first char in the source (used in annotation)+> -> String -- ^ a string containing the sql to parse+> -> Either P.ParseErrorExtra [Statement]+> parseStatements p f s src = P.parseStatements p f s (L.pack src)++> {-parseQueryExpr :: P.ParseFlags -- ^ parse options+> -> FilePath -- ^ filename to use in errors+> -> Maybe (Int,Int) -- ^ set the line number and column number+> -> String -- ^ a string containing the sql to parse+> -> Either P.ParseErrorExtra QueryExpr+> parseQueryExpr p f s src = P.parseQueryExpr p f s (L.pack src)-}++> parseScalarExpr :: P.ParseFlags -- ^ parse options+> -> FilePath -- ^ filename to use in errors+> -> Maybe (Int,Int) -- ^ set the line number and column number+> -> String -- ^ a string containing the sql to parse+> -> Either P.ParseErrorExtra ScalarExpr+> parseScalarExpr p f s src = P.parseScalarExpr p f s (L.pack src)++> parseName :: P.ParseFlags+> -> FilePath+> -> Maybe (Int,Int)+> -> String+> -> Either P.ParseErrorExtra A.Name+> parseName p f s src = P.parseName p f s (L.pack src)++> parseNameComponent :: P.ParseFlags+> -> FilePath+> -> Maybe (Int,Int)+> -> String+> -> Either P.ParseErrorExtra NameComponent+> parseNameComponent p f s src = P.parseNameComponent p f s (L.pack src)++> parsePlpgsql :: P.ParseFlags -- ^ parse options+> -> FilePath -- ^ filename to use in errors+> -> Maybe (Int,Int) -- ^ set the line number and column number+> -> String+> -> Either P.ParseErrorExtra [Statement]+> parsePlpgsql p f s src = P.parseProcSQL p f s (L.pack src)
+ tests/Database/HsSqlPpp/Tests/QuasiQuoteTests.lhs view
@@ -0,0 +1,155 @@++Tests mainly for antiquotation, plus examples of where antiquotes work.++> {-# LANGUAGE QuasiQuotes,ScopedTypeVariables #-}+>+> module Database.HsSqlPpp.Tests.QuasiQuoteTests (quasiQuoteTests, quasiQuoteTestData, Item(..)) where+>+> import qualified Test.Tasty as T+> import qualified Test.Tasty.HUnit as H++> import Data.Data+>+> import Database.HsSqlPpp.Syntax+> import Database.HsSqlPpp.Annotation+> import Database.HsSqlPpp.Pretty+> import Database.HsSqlPpp.Quote+> import Database.HsSqlPpp.Utility+> --import Database.HsSqlPpp.Tests.TestUtils+> import qualified Data.Text.Lazy as L+>+> data Item = Expr ScalarExpr ScalarExpr+> | Stmts [Statement] [Statement]+> | PgSqlStmts [Statement] [Statement]+> | Stmt Statement Statement+> | PgSqlStmt Statement Statement+> | Group String [Item]++> quasiQuoteTests :: T.TestTree+> quasiQuoteTests = itemToTft quasiQuoteTestData+>+> quasiQuoteTestData :: Item+> quasiQuoteTestData =+> Group "quasiQuoteTests" [++> let tableName = [sqlName| my_table |]+> varname = [sqlNameComponent| my_field |]+> typename = [sqlName| text |]+> in Stmt [sqlStmt|+>+> create table $n(tableName) (+> $m(varname) $n(typename)+> );+>+> |]+> [sqlStmt|+> create table my_table (+> my_field text+> );+> |]+++> ,let fnname = [sqlName| my_function |]+> tablename = [sqlName| my_table |]+> typename = [sqlName| int |]+> in Stmt [sqlStmt|+>+> create function $n(fnname)() returns $n(typename) as $a$+> select * from $n(tablename);+> $a$ language sql stable;+>+> |]+> [sqlStmt|+> create function my_function() returns int as $a$+> select * from my_table;+> $a$ language sql stable;+> |]+++> ,let fnname = [sqlName|my_function|]+> in Stmt [sqlStmt| drop function $n(fnname)();|]+> [sqlStmt| drop function my_function();|]+>+> ,let expr = StringLit ea "testing"+> in PgSqlStmt [pgsqlStmt| return $e(expr); |]+> [pgsqlStmt| return 'testing'; |]++> ,let expr = [sqlExpr| 3 + 4 |]+> in PgSqlStmt [pgsqlStmt| return $e(expr); |]+> [pgsqlStmt| return 3 + 4; |]+>++> ,let triggername = [sqlNameComponent|my_trigger|]+> tablename = [sqlName|my_table|]+> opname = [sqlName|my_function|]+> in Stmt [sqlStmt|+> create trigger $m(triggername)+> after insert or update or delete on $n(tablename)+> for each statement+> execute procedure $n(opname)();+> |]+> [sqlStmt|+> create trigger my_trigger+> after insert or update or delete on my_table+> for each statement+> execute procedure my_function();+> |]++> ,let tablename = [sqlName|lotsastuff|]+> in Expr [sqlExpr|(select count(*) from $n(tablename))|]+> [sqlExpr|(select count(*) from lotsastuff)|]+>+> ,let trigname = [sqlNameComponent|tbl_trig1|]+> tablename = [sqlName|tbl|]+> tevent = TUpdate+> fn = [sqlName|checkit|]+> in Stmt [sqlStmt|+> create trigger $m(trigname)+> after $t(tevent) on $n(tablename)+> for each row+> execute procedure $n(fn)();+> |] [sqlStmt|+> create trigger tbl_trig1+> after update on tbl+> for each row+> execute procedure checkit();+> |]+> ,let x = [sqlName| fnname |]+> in Expr [sqlExpr| $n(x)('a') |]+> [sqlExpr| fnname('a') |]+> ,let x = StringLit ea "splicedstring"+> in Expr [sqlExpr| $e(x) |]+> [sqlExpr| 'splicedstring' |]+> ,let x = [sqlName|splicedIdentifier|]+> in Expr [sqlExpr| $n(x) |]+> [sqlExpr| splicedIdentifier |]+> ,let errMsg = "string splice"+> in PgSqlStmt [pgsqlStmt| raise exception $s(errMsg); |]+> [pgsqlStmt| raise exception 'string splice'; |]++>++--------------------------------------------------------------------------------++expressions++> ]+++================================================================================++Unit test helpers++> itemToTft :: Item -> T.TestTree+> itemToTft (Expr a b) = H.testCase (L.unpack $ prettyScalarExpr defaultPrettyFlags b) $ stripEqual a b+> itemToTft (PgSqlStmt a b) = H.testCase (L.unpack $ prettyStatements defaultPrettyFlags [b]) $ stripEqual a b+> itemToTft (Stmt a b) = H.testCase (L.unpack $ prettyStatements defaultPrettyFlags [b]) $ stripEqual a b+> itemToTft (PgSqlStmts a b) = H.testCase (L.unpack $ prettyStatements defaultPrettyFlags b) $ stripEqual a b+> itemToTft (Stmts a b) = H.testCase (L.unpack $ prettyStatements defaultPrettyFlags b) $ stripEqual a b+> itemToTft (Group s is) = T.testGroup s $ map itemToTft is+> stripEqual :: (Data a, Eq a, Show a) =>+> a -> a -> H.Assertion+> stripEqual a b = H.assertEqual "" (resetAnnotations a) (resetAnnotations b)++> ea :: Annotation+> ea = emptyAnnotation
+ tests/TestsTh.lhs view
@@ -0,0 +1,6 @@++> import Test.Tasty+> import Database.HsSqlPpp.Tests.QuasiQuoteTests++> main :: IO ()+> main = defaultMain quasiQuoteTests