diff --git a/HESQL.hs b/HESQL.hs --- a/HESQL.hs +++ b/HESQL.hs @@ -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 diff --git a/HESQL/Options.hs b/HESQL/Options.hs new file mode 100644 --- /dev/null +++ b/HESQL/Options.hs @@ -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) + diff --git a/HESQL/Parser.hs b/HESQL/Parser.hs --- a/HESQL/Parser.hs +++ b/HESQL/Parser.hs @@ -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 diff --git a/HESQL/Syntax.hs b/HESQL/Syntax.hs --- a/HESQL/Syntax.hs +++ b/HESQL/Syntax.hs @@ -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" diff --git a/HESQL/Translator.hs b/HESQL/Translator.hs --- a/HESQL/Translator.hs +++ b/HESQL/Translator.hs @@ -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 "" 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 diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -2,6 +2,7 @@ ./Setup build clean: Setup + rm -f .configured ./Setup clean .configured: hesql.cabal Setup diff --git a/hesql.cabal b/hesql.cabal --- a/hesql.cabal +++ b/hesql.cabal @@ -1,5 +1,5 @@ Name: hesql -Version: 0.6 +Version: 0.7 Author: Christoph Bauer Maintainer: Christoph Bauer 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