-----------------------------------------------------------
-- |
-- 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.BoundedString
import Database.HaskellDB.FieldType

import Database.HaskellDB
import Database.HaskellDB.PrimQuery
import Database.HaskellDB.DBSpec.DBInfo

import Database.HaskellDB.DBSpec.PPHelpers

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 an appropriate -fcontext-stackXX OPTIONS pragma at the top
--   of the generated file. Not currently in use since -fcontext-stackXX
--   is a static option, and thus can't be used in options pragmas.
contextStackPragma :: TInfo -> Doc
contextStackPragma ti
      = text "-- NOTE: use GHC flag" <+> text flag <+> text "with this module"
--    = text "{-# OPTIONS" <+> 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 = [tInfoToModule name t | t <- tbls dbinfo, hasName t]
    hasName TInfo{tname=name} = name /= ""
    tbnames = map fst rest
      
-- | Makes a module from a TInfo
tInfoToModule :: String -- ^ The name of our main module
	      -> TInfo 
	      -> (String,Doc) -- ^ Module name and module contents
tInfoToModule dbname tinfo@TInfo{tname=name,cols=col}
    = (modname,
       contextStackPragma tinfo $$
       header
       $$ text "module" <+> text modname <+> text "where"
       <> newline
       $$ imports
       <> newline
       $$ ppComment ["Table"]
       $$ ppTable tinfo       
       $$ ppComment ["Fields"]
       $$ if col == [] then empty -- no fields, don't do any weird shit
             else vcat (map ppField (columnNamesTypes tinfo)))
    where modname = dbname ++ "." ++ moduleName name

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

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

-- | Pretty prints the type field in a ColumnInfo	
ppColumnType :: CInfo -> Doc 
ppColumnType (CInfo ciName (ciType,ciAllowNull))
	=   text "RecCons" <+> 
	    ((text $ toType 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 :: CInfo -> Doc 
ppColumnValue (CInfo ciName _)
	=   text "hdbMakeEntry" <+> text (toType ciName)

-- | Pretty prints Field definitions
ppField :: (String,String) -> Doc
ppField (name,typeof) = 
    ppComment [toType 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 name)
	iname = text (identifier 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)