module Database.HaskellDB.DBDirect (dbdirect) where
import Database.HaskellDB (Database, )
import Database.HaskellDB.DriverAPI (DriverInterface, connect, requiredOptions, )
import Database.HaskellDB.DBSpec (dbToDBSpec, dbname)
import Database.HaskellDB.DBSpec.DBSpecToDBDirect (dbInfoToModuleFiles, )
import qualified Database.HaskellDB.DBSpec.PPHelpers as PP
import System.Console.GetOpt (getOpt, ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, )
import System.Environment (getArgs, getProgName, )
import System.Exit (exitFailure, )
import System.IO (hPutStrLn, stderr, )
import Control.Monad.Error ()
import Control.Monad (when, )
import Data.List (intersperse, )
createModules :: String -> String -> Bool -> PP.MakeIdentifiers -> Database -> IO ()
createModules m dbName useBStrT mkIdent db =
do
putStrLn "Getting database info..."
spec <- dbToDBSpec useBStrT mkIdent m db
putStrLn "Writing modules..."
dbInfoToModuleFiles "." m (spec {dbname = dbName})
data Flags =
Flags {
optHelp :: Bool,
optBoundedStrings :: Bool,
optIdentifierStyle :: PP.MakeIdentifiers
}
options :: [OptDescr (Flags -> Either String Flags)]
options =
Option ['h'] ["help"]
(NoArg (\flags -> Right $ flags{optHelp = True}))
"show options" :
Option ['b'] ["bounded-strings"]
(NoArg (\flags -> Right $ flags{optBoundedStrings = True}))
"use bounded string types" :
Option [] ["identifier-style"]
(ReqArg (\str flags ->
case str of
"preserve" -> Right $ flags{optIdentifierStyle = PP.mkIdentPreserving}
"camel-case" -> Right $ flags{optIdentifierStyle = PP.mkIdentCamelCase}
_ -> Left $ "unknown identifier style: " ++ str)
"type")
"<type> is one of [preserve, camel-case]" :
[]
parseOptions ::
[Flags -> Either String Flags] -> Either String Flags
parseOptions =
foldr (=<<)
(Right $
Flags {optHelp = False,
optBoundedStrings = False,
optIdentifierStyle = PP.mkIdentPreserving})
exitWithError :: String -> IO a
exitWithError msg =
hPutStrLn stderr msg >>
hPutStrLn stderr "Try --help option to get detailed info." >>
exitFailure
dbdirect :: DriverInterface -> IO ()
dbdirect driver =
do putStrLn "DB/Direct: Daan Leijen (c) 1999, HWT (c) 2003-2004,"
putStrLn " Bjorn Bringert (c) 2005-2007, Henning Thielemann (c) 2008"
putStrLn ""
argv <- getArgs
let (opts, modAndDrvOpts, errors) = getOpt RequireOrder options argv
when (not (null errors))
(ioError . userError . concat $ errors)
flags <-
case parseOptions opts of
Left errMsg -> exitWithError errMsg
Right flags -> return flags
when (optHelp flags)
(showHelp driver >> exitFailure)
case modAndDrvOpts of
[] -> exitWithError "Missing module and driver options"
[_] -> exitWithError "Missing driver options"
[moduleName,dbname,drvOpts] ->
do putStrLn "Connecting to database..."
connect driver
(splitOptions drvOpts)
(createModules moduleName dbname
(optBoundedStrings flags)
(optIdentifierStyle flags))
putStrLn "Done!"
(_:_:restArgs) ->
exitWithError ("Unnecessary arguments: " ++ show restArgs)
splitOptions :: String -> [(String,String)]
splitOptions = map (split2 '=') . split ','
split :: Char -> String -> [String]
split _ [] = []
split g xs = y : split g ys
where (y,ys) = split2 g xs
split2 :: Char -> String -> (String,String)
split2 g xs = (ys, drop 1 zs)
where (ys,zs) = break (==g) xs
showHelp :: DriverInterface -> IO ()
showHelp driver =
do p <- getProgName
let header =
"Usage: " ++ p ++ " [dbdirect-options] <module> <db-name> <driver-options>\n"
footer = unlines $
"" :
"NOTE: You will probably have to specify the db name in both <driver-options> and <db-name>. This is because the driver options are specific to each database." :
"" :
"module: Module name without an extension" :
("driver-options: " ++
(concat . intersperse "," .
map (\(name,descr) -> name++"=<"++descr++">") .
requiredOptions) driver) :
[]
hPutStrLn stderr $ (usageInfo header options ++ footer)