htoolkit-cvs

[<kr_...@us...>]

Update of /cvsroot/htoolkit/HSQL/MySQL
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv16963/MySQL

Added Files:
	MySQL.cabal Setup.lhs 
Log Message:
MySQL driver


--- NEW FILE: MySQL.cabal ---
name:		 hsql-mysql
version:	 1.5
license:	 BSD3
author:		 Krasimir Angelov <kr....@gm...>
category:	 Database
description: 	 MySQL driver for HSQL.
exposed-modules: Database.HSQL.MySQL
build-depends: 	 base, hsql
extensions:      ForeignFunctionInterface, CPP
include-dirs: Database/HSQL
--- NEW FILE: Setup.lhs ---
#!/usr/bin/runghc

\begin{code}
import Data.Maybe(fromMaybe)
import Distribution.PackageDescription
import Distribution.Setup
import Distribution.Simple
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Utils(rawSystemVerbose)
import System.Info
import System.Exit
import System.Directory
import System.Process(runInteractiveProcess, waitForProcess)
import System.IO(hClose, hGetContents, hPutStr, stderr)
import Control.Monad(when)
import Control.Exception(try)

main = defaultMainWithHooks defaultUserHooks{preConf=preConf, postConf=postConf}
  where
    preConf ::  [String] -> ConfigFlags -> IO HookedBuildInfo
    preConf args flags = do
      try (removeFile "MySQL.buildinfo")
      return emptyHookedBuildInfo
    postConf :: [String] -> ConfigFlags -> LocalBuildInfo -> IO ExitCode
    postConf args flags localbuildinfo = do
      mb_bi <- mysqlConfigBuildInfo (configVerbose flags)
      writeHookedBuildInfo "MySQL.buildinfo" (Just (fromMaybe emptyBuildInfo{extraLibs=["mysqlclient"]} mb_bi),[])
      return ExitSuccess
\end{code}

The following code is derived from Distribution.Simple.Configure
\begin{code}
findProgram
    :: String              -- ^ program name
    -> Maybe FilePath      -- ^ optional explicit path
    -> IO (Maybe FilePath)
findProgram name Nothing = do
  mb_path <- findExecutable name
  case mb_path of
    Nothing   -> message ("No " ++ name ++ " found")
    Just path -> message ("Using " ++ name ++ ": " ++ path)
  return mb_path
findProgram name (Just path) = do
  message ("Using " ++ name ++ ": " ++ path)
  return (Just path)

rawSystemGrabOutput :: Int -> FilePath -> [String] -> IO String
rawSystemGrabOutput verbose path args = do
  when (verbose > 0) $
        putStrLn (path ++ concatMap (' ':) args)
  (inp,out,err,pid) <- runInteractiveProcess path args Nothing Nothing
  exitCode <- waitForProcess pid
  if exitCode /= ExitSuccess
    then do errMsg <- hGetContents err
            hPutStr stderr errMsg
            exitWith exitCode
    else return ()
  hClose inp
  hClose err
  hGetContents out

message :: String -> IO ()
message s = putStrLn $ "configure: " ++ s
\end{code}

Populate BuildInfo using pkg-config tool.
\begin{code}
mysqlConfigBuildInfo :: Int -> IO (Maybe BuildInfo)
mysqlConfigBuildInfo verbose = do
  mb_mysql_config_path <- findProgram "mysql_config" Nothing
  case mb_mysql_config_path of
    Just mysql_config_path -> do
       message ("configuring mysqlclient library") 
       res <- rawSystemGrabOutput verbose mysql_config_path ["--libs"]
       let (lib_dirs,libs,ld_opts) = splitLibsFlags (words res)
       res <- rawSystemGrabOutput verbose mysql_config_path ["--cflags"]
       let (inc_dirs,cc_opts) = splitCFlags (words res)
       let bi = emptyBuildInfo{extraLibDirs=lib_dirs, extraLibs=libs, ldOptions=ld_opts, includeDirs=inc_dirs, ccOptions=cc_opts}
       return (Just bi)
    Nothing -> do
       message ("The package will be built using default settings for mysqlclient library")
       return Nothing
  where
    splitLibsFlags []         = ([],[],[])
    splitLibsFlags (arg:args) =
      case arg of
        ('-':'L':lib_dir) -> let (lib_dirs,libs,ld_opts) = splitLibsFlags args
                             in (lib_dir:lib_dirs,libs,ld_opts)
        ('-':'l':lib) ->     let (lib_dirs,libs,ld_opts) = splitLibsFlags args
                             in (lib_dirs,lib:libs,ld_opts)
        ld_opt ->            let (lib_dirs,libs,ld_opts) = splitLibsFlags args
                             in (lib_dirs,libs,ld_opt:ld_opts)

    splitCFlags []         = ([],[])
    splitCFlags (arg:args) =
      case arg of
        ('-':'I':inc_dir) -> let (inc_dirs,c_opts) = splitCFlags args
                             in (inc_dir:inc_dirs,c_opts)
        c_opt ->             let (inc_dirs,c_opts) = splitCFlags args
                             in (inc_dirs,c_opt:c_opts)

\end{code}