DBSpecToDBDirect.hs

-----------------------------------------------------------
-- |
-- 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 an appropriate -fcontext-stackXX OPTIONS pragma at the top
--   of the generated file.
contextStackPragma :: TInfo -> Doc
contextStackPragma ti
    = text "{-# OPTIONS_GHC" <+> text flag <+> text "#-}" $$
      text "-- NOTE: use GHC flag" <+> text flag <+> text "with this module if GHC < 6.8.1"
  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,
       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) <> newline)
    $$
    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 :: MakeIdentifiers -> [CInfo] -> Doc
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)