    -----------------------------------------------------------
    -- |
    -- Module      :  DBSpecToDBDirect
    -- Copyright   :  HWT Group (c) 2004, haskelldb-users@lists.sourceforge.net
    -- License     :  BSD-style
    --
    -- Maintainer  :  haskelldb-users@lists.sourceforge.net
    -- Stability   :  experimental
    -- Portability :  non-portable
    --
    -- Converts a DBSpec-generated database to a set of
    -- (FilePath,Doc), that can be used to generate definition
    -- files usable in HaskellDB (the generation itself is done
    -- in DBDirect)
    --
    --
    -----------------------------------------------------------
    module Database.HaskellDB.DBSpec.DBSpecToDBDirect
        (specToHDB, dbInfoToModuleFiles)
        where

    import Database.HaskellDB.FieldType (toHaskellType, )

    import Database.HaskellDB.DBSpec.DBInfo
       (TInfo(TInfo), CInfo(CInfo), DBInfo,
        descr, cols, tname, cname, tbls, dbInfoToDoc, opts, makeIdent,
        finalizeSpec, constructNonClashingDBInfo, )

    import Database.HaskellDB.DBSpec.PPHelpers
       (MakeIdentifiers, moduleName, toType, identifier, checkChars,
        ppComment, newline, )

    import Control.Monad (unless)
    import Data.List (isPrefixOf)
    import System.Directory (createDirectory, doesDirectoryExist)
    import Text.PrettyPrint.HughesPJ

    -- | Common header for all files
    header :: Doc
    header = ppComment ["Generated by DB/Direct"]

    -- | Adds LANGUAGE pragrams to the top of generated files
    languageOptions :: Doc
    languageOptions = text "{-# LANGUAGE EmptyDataDecls, TypeSynonymInstances #-}"

    -- | Adds an appropriate -fcontext-stackXX OPTIONS pragma at the top
    --   of the generated file.
    contextStackPragma :: TInfo -> Doc
    contextStackPragma ti
        = text "{-# OPTIONS_GHC" <+> text flag <+> text "#-}"
      where flag = "-fcontext-stack" ++ (show (40 + length (cols ti)))

    -- | All imports generated files have dependencies on. Nowadays, this
    --   should only be Database.HaskellDB.DBLayout
    imports :: Doc
    imports = text "import Database.HaskellDB.DBLayout"

    -- | Create module files in the given directory for the given DBInfo
    dbInfoToModuleFiles :: FilePath -- ^ base directory
    		    -> String -- ^ top-level module name
    		    -> DBInfo -> IO ()
    dbInfoToModuleFiles d name =
        createModules d name . specToHDB name . finalizeSpec

    -- | Creates modules
    createModules :: FilePath -- ^ Base directory
    	      -> String   -- ^ Name of directory and top-level module for the database modules
    	      -> [(String,Doc)] -- ^ Module names and module contents
    	      -> IO ()
    createModules basedir dbname files
        = do
          let dir = withPrefix basedir (replace '.' '/' dbname)
          createPath dir
          mapM_ (\ (name,doc) -> writeFile (moduleNameToFile basedir name)
    	     (render doc)) files

    -- | Make a filename from a module name
    moduleNameToFile :: FilePath -> String -> FilePath
    moduleNameToFile base mod = withPrefix base f
        where f = replace '.' '/' mod ++ ".hs"

    withPrefix :: FilePath -> String -> FilePath
    withPrefix base f | null base = f
    		  | otherwise = base ++ "/" ++ f

    replace :: Eq a => a -> a -> [a] -> [a]
    replace x y zs = [if z == x then y else z | z <- zs]

    -- | Like createDirectory, but creates all the directories in
    --   the path.
    createPath :: FilePath -> IO ()
    createPath p | "/" `isPrefixOf` p = createPath' "/" (dropWhile (=='/') p)
    	     | otherwise = createPath' "" p
        where
        createPath' _ "" = return ()
        createPath' b p = do
    		      let (d,r) = break (=='/') p
    			  n = withPrefix b d
    		      createDirIfNotExists n
    		      createPath' n (dropWhile (=='/') r)

    createDirIfNotExists :: FilePath -> IO ()
    createDirIfNotExists p = do
    			 exists <- doesDirectoryExist p
    			 unless exists (createDirectory p)

    -- | Converts a database specification to a set of module names
    --   and module contents. The first element of the returned list
    --   is the top-level module.
    specToHDB :: String -- ^ Top level module name
    	  -> DBInfo -> [(String,Doc)]
    specToHDB name dbinfo = genDocs name (constructNonClashingDBInfo dbinfo)

    -- | Does the actual conversion work
    genDocs :: String -- ^ Top-level module name
    	-> DBInfo
    	-> [(String,Doc)] -- ^ list of module name, module contents pairs
    genDocs name dbinfo
        = (name,
           header
           $$ text "module" <+> text name <+> text "where"
           <> newline
           $$ imports
           <> newline
           $$ vcat (map (text . ("import qualified " ++)) tbnames)
           <> newline
           $$ dbInfoToDoc dbinfo)
            : rest
        where
        rest = map (tInfoToModule (makeIdent (opts dbinfo)) name) $
               filter hasName $ tbls dbinfo
        hasName TInfo{tname=name} = name /= ""
        tbnames = map fst rest

    -- | Makes a module from a TInfo
    tInfoToModule :: MakeIdentifiers
                  -> String -- ^ The name of our main module
    	      -> TInfo
    	      -> (String,Doc) -- ^ Module name and module contents
    tInfoToModule mi dbname tinfo@TInfo{tname=name,cols=col}
        = (modname,
           languageOptions $$
           contextStackPragma tinfo $$
           header
           $$ text "module" <+> text modname <+> text "where"
           <> newline
           $$ imports
           <> newline
           $$ ppComment ["Table type"]
           <> newline
           $$ ppTableType mi tinfo
           <> newline
           $$ ppComment ["Table"]
           $$ ppTable mi tinfo
           $$ ppComment ["Fields"]
           $$ if null col
                 then empty -- no fields, don't do anything weird
                 else vcat (map (ppField mi) (columnNamesTypes tinfo)))
        where modname = dbname ++ "." ++ moduleName mi name

    ppTableType :: MakeIdentifiers -> TInfo -> Doc
    ppTableType mi (TInfo { tname = tiName, cols = tiColumns }) =
        hang decl 4 types
      where
        decl = text "type" <+> text (toType mi tiName) <+> text "="
        types = ppColumns mi tiColumns

    -- | Pretty prints a TableInfo
    ppTable :: MakeIdentifiers -> TInfo -> Doc
    ppTable mi (TInfo tiName tiColumns) =
        hang (text (identifier mi tiName) <+> text "::" <+> text "Table") 4
    	 (text (toType mi tiName))
        $$
        text (identifier mi tiName) <+> text "=" <+>
        hang (text "baseTable" <+>
            doubleQuotes (text (checkChars tiName)) <+>
            text "$") 0
               (vcat $ punctuate (text " #") (map (ppColumnValue mi) tiColumns))
               <>  newline

    -- | Pretty prints a list of ColumnInfo
    ppColumns _  []      = text ""
    ppColumns mi [c]     = parens (ppColumnType mi c <+> text "RecNil")
    ppColumns mi (c:cs)  = parens (ppColumnType mi c $$ ppColumns mi cs)

    -- | Pretty prints the type field in a ColumnInfo
    ppColumnType :: MakeIdentifiers -> CInfo -> Doc
    ppColumnType mi (CInfo ciName (ciType,ciAllowNull))
    	=   text "RecCons" <+>
      	    ((text $ toType mi ciName) <+>
                 parens (text "Expr" <+>
                         (if (ciAllowNull)
    	              then parens (text "Maybe" <+> text (toHaskellType ciType))
    	              else text (toHaskellType ciType)
    	             )))

    -- | Pretty prints the value field in a ColumnInfo
    ppColumnValue :: MakeIdentifiers -> CInfo -> Doc
    ppColumnValue mi (CInfo ciName _)
    	=    text "hdbMakeEntry" <+> text (toType mi ciName)

    -- | Pretty prints Field definitions
    ppField :: MakeIdentifiers -> (String, String) -> Doc
    ppField mi (name,typeof) =
        ppComment [toType mi name ++ " Field"]
        <> newline $$
        text "data" <+> bname <+> equals <+> bname -- <+> text "deriving Show"
        <> newline $$
        hang (text "instance FieldTag" <+> bname <+> text "where") 4
             (text "fieldName _" <+> equals <+> doubleQuotes
    	         (text (checkChars name)))
        <> newline $$
        iname <+> text "::" <+> text "Attr" <+> bname <+> text typeof
        $$
        iname <+> equals <+> text "mkAttr" <+> bname
        <> newline
    	where
              bname = text (toType mi name)
    	  iname = text (identifier mi name)

    -- | Extracts all the column names from a TableInfo
    columnNames :: TInfo -> [String]
    columnNames table = map cname (cols table)

    -- | Extracts all the column types from a TableInfo
    columnTypes :: TInfo -> [String]
    columnTypes table =
        [if b then ("(Maybe " ++ t ++ ")") else t | (t,b) <- zippedlist]
        where
        zippedlist = zip typelist null_list
        typelist  = map (toHaskellType . fst . descr) (cols table)
        null_list = map (snd . descr) (cols table)

    -- | Combines the results of columnNames and columnTypes
    columnNamesTypes :: TInfo -> [(String,String)]
    columnNamesTypes table@(TInfo tname fields)
        = zip (columnNames table) (columnTypes table)