-----------------------------------------------------------
-- |
-- Module      :  Database.HaskellDB.DBDirect
-- Copyright   :  Daan Leijen (c) 1999, daan@cs.uu.nl
--                HWT Group (c) 2003,
--                Bjorn Bringert (c) 2005-2006, bjorn@bringert.net
-- License     :  BSD-style
--
-- Maintainer  :  haskelldb-users@lists.sourceforge.net
-- Stability   :  experimental
-- Portability :  portable
--
-- DBDirect generates a Haskell module from a database.
-- It first reads the system catalog of the database into
-- a 'Catalog' data type. After that it pretty prints that
-- data structure in an appropiate Haskell module which
-- can be used to perform queries on the database.
--
-----------------------------------------------------------

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 () -- Monad instance for Either
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

-- | Shows usage information
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)