content: -----------------------------------------------------------
  -- |
  -- 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 Prelude hiding ((<>))
  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)
  