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
header :: Doc
header = ppComment ["Generated by DB/Direct"]
languageOptions :: Doc
languageOptions = text "{-# LANGUAGE EmptyDataDecls, TypeSynonymInstances #-}"
contextStackPragma :: TInfo -> Doc
contextStackPragma ti
= text "{-# OPTIONS_GHC" <+> text flag <+> text "#-}"
where flag = "-fcontext-stack" ++ (show (40 + length (cols ti)))
imports :: Doc
imports = text "import Database.HaskellDB.DBLayout"
dbInfoToModuleFiles :: FilePath
-> String
-> DBInfo -> IO ()
dbInfoToModuleFiles d name =
createModules d name . specToHDB name . finalizeSpec
createModules :: FilePath
-> String
-> [(String,Doc)]
-> IO ()
createModules basedir dbname files
= do
let dir = withPrefix basedir (replace '.' '/' dbname)
createPath dir
mapM_ (\ (name,doc) -> writeFile (moduleNameToFile basedir name)
(render doc)) files
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]
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)
specToHDB :: String
-> DBInfo -> [(String,Doc)]
specToHDB name dbinfo = genDocs name (constructNonClashingDBInfo dbinfo)
genDocs :: String
-> DBInfo
-> [(String,Doc)]
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
tInfoToModule :: MakeIdentifiers
-> String
-> TInfo
-> (String,Doc)
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
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
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
ppColumns _ [] = text ""
ppColumns mi [c] = parens (ppColumnType mi c <+> text "RecNil")
ppColumns mi (c:cs) = parens (ppColumnType mi c $$ ppColumns mi cs)
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)
)))
ppColumnValue :: MakeIdentifiers -> CInfo -> Doc
ppColumnValue mi (CInfo ciName _)
= text "hdbMakeEntry" <+> text (toType mi ciName)
ppField :: MakeIdentifiers -> (String, String) -> Doc
ppField mi (name,typeof) =
ppComment [toType mi name ++ " Field"]
<> newline $$
text "data" <+> bname <+> equals <+> bname
<> 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)
columnNames :: TInfo -> [String]
columnNames table = map cname (cols table)
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)
columnNamesTypes :: TInfo -> [(String,String)]
columnNamesTypes table@(TInfo tname fields)
= zip (columnNames table) (columnTypes table)