hesql 0.6 → 0.7
raw patch · 7 files changed
+123/−44 lines, 7 files
Files
- HESQL.hs +24/−16
- HESQL/Options.hs +53/−0
- HESQL/Parser.hs +16/−12
- HESQL/Syntax.hs +3/−3
- HESQL/Translator.hs +23/−10
- Makefile +1/−0
- hesql.cabal +3/−3
HESQL.hs view
@@ -6,28 +6,36 @@ import Language.Haskell.Pretty import HESQL.Parser (hesqlModule) import HESQL.Translator-import Control.Monad(when)+import Control.Monad(when, forM_) import Text.Parsec.String (parseFromFile) import System.Exit +import HESQL.Options+import Paths_hesql ( version )+import Data.Version (showVersion)++outputFile :: FilePath -> FilePath outputFile file = replaceExtension file ".hs" +main :: IO () main = do- putStrLn "hesql 0.0"- [file, db] <- getArgs- when (outputFile file == file) $- error (file ++ "has a wrong extension")- inp <- readFile file- mod <- parseFromFile hesqlModule file- case mod of- Left err -> do- print err- exitWith $ ExitFailure 1- Right mod' -> do- outp <- generateCode file db mod'- writeFile (outputFile file) $- prettyPrint $- outp + putStrLn $ "hesql " ++ showVersion version+ argv <- getArgs+ case getOpts argv of+ Left msg -> putStrLn msg+ Right (opts, files) -> do+ forM_ files $ \ file -> do+ when (outputFile file == file) $+ error (file ++ "has a wrong extension")+ modl <- parseFromFile hesqlModule file+ case modl of+ Left err -> do+ print err+ exitWith $ ExitFailure 1+ Right modl' -> do+ outp <- generateCode file opts modl'+ writeFile (outputFile file) $+ prettyPrint outp
+ HESQL/Options.hs view
@@ -0,0 +1,53 @@+module HESQL.Options where++import System.Console.GetOpt+++data Options = Options+ { optDBLastArg :: Bool+ , optHelp :: Bool+ , optCatalogFile :: Maybe FilePath+ , optDatabase :: Maybe String+ } deriving Show++defaultOptions :: Options+defaultOptions = + Options + {+ optDBLastArg = False+ , optCatalogFile = Nothing+ , optDatabase = Nothing+ , optHelp = False+ }+++options :: [OptDescr (Options -> Options)]+options = + [ Option ['l'] ["lastarg"]+ (NoArg (\opts -> opts { optDBLastArg = True }))+ "db is last argument in all generated functions"+ , Option ['c'] ["catalog"]+ ((ReqArg (\ c opts -> opts { optCatalogFile = Just c })) "FILE")+ "validate against catalog file (TODO)" + , Option ['d'] ["database"]+ ((ReqArg (\ db opts -> opts { optDatabase = Just db })) "DATABASE")+ "validate against online database (TODO)" + , Option ['h'] ["help"]+ (NoArg (\opts -> opts { optHelp = True }))+ "show usage"+ ]++getOpts :: [String] -> Either String (Options, [String])+getOpts argv = + case getOpt Permute options argv of+ (o, n, []) + | null n -> usage []+ | otherwise -> + let opts = foldl (flip id) defaultOptions o in+ if optHelp opts + then usage []+ else Right (opts, n)+ (_, _, errs) -> usage errs+ where header = "Usage: hesql [OPTION...] file ..."+ usage errs = Left (concat errs ++ usageInfo header options)+
HESQL/Parser.hs view
@@ -4,11 +4,9 @@ import Text.Parsec.String import Text.Parsec import Text.Parsec.Language (haskellDef)-import Text.Parsec.Expr+ import qualified Text.Parsec.Token as P import Data.List (intercalate)-import Database.HDBC-import Control.Monad (forM_) import Database.HsSqlPpp.Parsing.Parser @@ -17,28 +15,32 @@ hesqlModule = do whiteSpace modName <- moduleHeader- decls <- decls+ decls' <- decls whiteSpace eof- return $ HesqlModule modName decls+ return $ HesqlModule modName decls' +decls :: Parser [HesqlDecls] decls = many decl +decl :: Parser HesqlDecls decl = do fn <- funName p <- many parameter whiteSpace char '=' whiteSpace- queryOpt <- queryOpt+ queryOpt' <- queryOpt stmtStr <- sqlStatement whiteSpace stmt <- case parseSql stmtStr of Right [stmt] -> return stmt+ Right _ -> error "unexpected number of statements" Left e -> error $ show e -- TODO proper error message, handle other Right cases- return $ HesqlDecls fn p queryOpt stmt+ return $ HesqlDecls fn p queryOpt' stmt +queryOpt :: Parser QueryOpt queryOpt = (reserved "maybe" >> return MaybeQuery) <|> (reserved "lazy" >> return LazyQuery) <|> @@ -50,6 +52,7 @@ r <- sqlStatement' return $ s ++ r +sqlStatement' :: Parser String sqlStatement' = do r <- sqlQuoted "\"" <|> sqlQuoted "'" <|> sqlTerminator if (r == ";") @@ -61,29 +64,30 @@ - +sqlQuoted :: String -> Parser String sqlQuoted s = do l <- between (string s) (string s) $ many qchars return $ s ++ concat l ++ s where qchars = many1 (noneOf ('\\':s)) <|> do - c <- char '\\' + char '\\' q <- anyChar return ['\\', q] +sqlTerminator :: Parser String sqlTerminator = string ";" -+funName :: Parser String funName = identifier parameter = identifier -modName = sepBy1 identifier (char '.')+moduleName = sepBy1 identifier (char '.') moduleHeader = do reserved "module"- m <- modName+ m <- moduleName reserved "where" return $ intercalate "." m
HESQL/Syntax.hs view
@@ -1,8 +1,5 @@ module HESQL.Syntax where -import Database.HDBC (SqlValue(..))-import Data.List (intercalate)- import Database.HsSqlPpp.Ast.Ast type ModuleName = String@@ -24,7 +21,10 @@ data QueryOpt = LazyQuery | StrictQuery | MaybeQuery deriving Show +isSelect :: Statement -> Bool isSelect (SelectStatement _ _) = True isSelect _ = False +selectColumnLength :: Statement -> Int selectColumnLength (SelectStatement _ (Select _ _ (SelectList _ l _) _ _ _ _ _ _ _)) = length l+selectColumnLength _ = error "selectColumnLength"
HESQL/Translator.hs view
@@ -1,10 +1,11 @@ module HESQL.Translator (generateCode) where import Language.Haskell.Syntax-import Database.HDBC.PostgreSQL+--import Database.HDBC.PostgreSQL import HESQL.Syntax -import HESQL.Verifier+--import HESQL.Verifier+import HESQL.Options import System.FilePath @@ -13,33 +14,43 @@ import Data.List (elemIndex) +stmtRec :: HsName stmtRec = HsIdent "Stmts"++funarg :: String -> HsPat funarg = HsPVar . HsIdent++funargs :: [String] -> [HsPat] funargs = map funarg +srcloc :: SrcLoc srcloc = SrcLoc "<dummy>" 1 1 +hsSimpleFun :: String -> [String]+ -> HsRhs -> [HsDecl]+ -> HsDecl hsSimpleFun name vars body wheres = HsFunBind [HsMatch srcloc (HsIdent name) (funargs vars) body wheres] -generateCode :: FilePath -> String -> HesqlModule -> IO HsModule-generateCode fn db (HesqlModule modName decls) = do- conn <- connectPostgreSQL db- mapM_ (verifySql conn . declSQL) decls'+generateCode :: FilePath -> Options -> HesqlModule -> IO HsModule+generateCode fn opts (HesqlModule modName decls) = do+ -- conn <- connectPostgreSQL db+ -- mapM_ (verifySql conn . declSQL) decls' return $ HsModule srcloc (Module modName) Nothing imports hsDecls where imports = [HsImportDecl srcloc (Module "Database.HDBC") False Nothing Nothing]- hsDecls = [dataType, initFun decls'] ++ map declFun decls'+ hsDecls = [dataType, initFun decls'] ++ map (declFun opts) decls' dataType = HsDataDecl srcloc [] stmtRec [] [HsRecDecl srcloc stmtRec recFields] [] mkRecField decl = ([HsIdent $ stmtRecName decl], HsBangedTy (HsTyCon $ UnQual $ HsIdent"Statement")) recFields = map mkRecField decls decls' = map updateDeclSql decls -+updateDeclSql :: HesqlDecls -> HesqlDecls updateDeclSql decl = decl { declSQL = substituteVarsSql (declVars decl) (declSQL decl) } + hsapp fun = HsApp (HsVar $ UnQual $ HsSymbol fun) hsapps fun exps = foldl HsApp (HsVar $ UnQual $ HsSymbol fun) exps hsvar v = HsVar $ UnQual $ HsSymbol v@@ -60,8 +71,8 @@ (HsVar $ UnQual $ HsIdent $ declName decl) -declFun decl = -- TODO declLOC- hsSimpleFun (declName decl) ("h":declVars decl) body (stmtDef : maybeTupleFun)+declFun opts decl = -- TODO declLOC+ hsSimpleFun (declName decl) params body (stmtDef : maybeTupleFun) where body = HsUnGuardedRhs $ HsDo (bindAndExecute:result) bindAndExecute = HsQualifier $ hsapps "execute" [stmt, valList] selectFlag = isSelect $ declSQL decl@@ -77,6 +88,8 @@ stmtDef = HsPatBind srcloc (HsPVar $ HsIdent "stmt") (HsUnGuardedRhs $ HsApp (HsVar $ UnQual $ HsIdent $ stmtRecName decl) (hsvar "h")) []+ params | optDBLastArg opts = declVars decl++["h"]+ | otherwise = "h":declVars decl resultStmt decl stmt = HsQualifier $ hsapps "fmap" [HsParen (hsapp "fmap" (hsvar "toTuple")), HsParen (hsapp (fetchFun opt) stmt)] where opt = declOpt decl
Makefile view
@@ -2,6 +2,7 @@ ./Setup build clean: Setup+ rm -f .configured ./Setup clean .configured: hesql.cabal Setup
hesql.cabal view
@@ -1,5 +1,5 @@ Name: hesql-Version: 0.6+Version: 0.7 Author: Christoph Bauer <ich@christoph-bauer.net> Maintainer: Christoph Bauer <ich@christoph-bauer.net> Cabal-Version: >= 1.2@@ -16,6 +16,6 @@ Build-depends: base >= 4 && < 5, HDBC, HDBC-postgresql, haskell-src, filepath, parsec, hssqlppp >= 0.0.10 Extensions: FlexibleContexts- Ghc-Options: -funbox-strict-fields + Ghc-Options: -funbox-strict-fields -Wall Other-Modules: HESQL.Parser, HESQL.Translator, HESQL.Syntax,- HESQL.Verifier+ HESQL.Verifier, HESQL.Options