module Database.HaskellDB.DBSpec.DBInfo
(DBInfo(..),TInfo(..),CInfo(..),DBOptions(..),makeDBSpec,
makeTInfo,makeCInfo,ppDBInfo,ppTInfo,ppCInfo,ppDBOptions,
dbInfoToDoc,finalizeSpec,constructNonClashingDBInfo)
where
import qualified Database.HaskellDB.DBSpec.PPHelpers as PP
import Database.HaskellDB.FieldType (FieldDesc, FieldType(BStrT, StringT), )
import Data.Char (toLower, isAlpha)
import Text.PrettyPrint.HughesPJ
data DBInfo = DBInfo {dbname :: String
,opts :: DBOptions
,tbls :: [TInfo]
}
deriving (Show)
data TInfo = TInfo {tname :: String
,cols :: [CInfo]
}
deriving (Eq,Show)
data CInfo = CInfo {cname :: String
,descr :: FieldDesc
}
deriving (Eq,Show)
data DBOptions = DBOptions
{useBString :: Bool
,makeIdent :: PP.MakeIdentifiers
}
instance Show DBOptions where
showsPrec p opts =
showString "DBOptions {useBString = " .
shows (useBString opts) .
showString "}"
dbInfoToDoc :: DBInfo -> Doc
dbInfoToDoc dbi@(DBInfo {dbname = n
, opts = opt})
= fixedName <+> text ":: DBInfo"
$$ fixedName <+> equals <+> ppDBInfo dbi
where fixedName = text . PP.identifier (makeIdent opt) $ n
ppDBInfo :: DBInfo -> Doc
ppDBInfo (DBInfo {dbname=n, opts=o, tbls = t})
= text "DBInfo" <+>
braces (vcat (punctuate comma (
text "dbname =" <+> doubleQuotes (text n) :
text "opts =" <+> ppDBOptions o :
text "tbls =" <+>
brackets (vcat (punctuate comma (map ppTInfo t))) : [])))
ppTInfo :: TInfo -> Doc
ppTInfo (TInfo {tname=n,cols=c})
= text "TInfo" <+>
braces (vcat (punctuate comma (
text "tname =" <+> doubleQuotes (text n) :
text "cols =" <+>
brackets (vcat (punctuate comma (map ppCInfo c))) : [])))
ppCInfo :: CInfo -> Doc
ppCInfo (CInfo {cname=n,descr=(val,null)})
= text "CInfo" <+>
braces (vcat (punctuate comma (
text "cname =" <+> doubleQuotes (text n) :
text "descr =" <+>
parens (text (show val) <> comma <+> text (show null)) : [])))
ppDBOptions :: DBOptions -> Doc
ppDBOptions (DBOptions {useBString = b})
= text "DBOptions" <+>
braces (text "useBString =" <+> text (show b))
finalizeSpec :: DBInfo -> DBInfo
finalizeSpec dbi = if (useBString (opts dbi)) then
dbi else stripBStr dbi
stripBStr :: DBInfo -> DBInfo
stripBStr dbi = fixTables dbi
where
fixTables dbi = dbi{tbls=map fixCols (tbls dbi)}
fixCols tbl = tbl{cols=map oneCol (cols tbl)}
oneCol col = col{descr = fixDescr (descr col)}
fixDescr col = case fst col of
BStrT _ -> (StringT,snd col)
_ -> col
makeDBSpec :: String
-> DBOptions
-> [TInfo]
-> DBInfo
makeDBSpec name opt tinfos
= DBInfo {dbname = name, opts = opt, tbls = tinfos}
makeTInfo :: String
-> [CInfo]
-> TInfo
makeTInfo name cinfs
= TInfo {tname = name, cols = cinfs}
makeCInfo :: String
-> FieldDesc
-> CInfo
makeCInfo name fdef
= CInfo {cname = name, descr = fdef}
constructNonClashingDBInfo :: DBInfo -> DBInfo
constructNonClashingDBInfo dbinfo =
let db' = makeDBNameUnique dbinfo
in if equalObjectNames db' (makeDBNameUnique db')
then db'
else constructNonClashingDBInfo db'
equalObjectNames :: DBInfo -> DBInfo -> Bool
equalObjectNames db1 db2 =
dbname db1 == dbname db2 &&
tbls db1 == tbls db2
makeTblNamesUnique :: [TInfo] -> [TInfo]
makeTblNamesUnique [] = []
makeTblNamesUnique (t:[]) = t:[]
makeTblNamesUnique (t:tt:ts)
| compNames (tname t) (tname tt)
= t: (makeTblNamesUnique ((tblNewName tt) : ts))
| True = t : makeTblNamesUnique (tt:ts)
where
tblNewName tinfo@TInfo{tname=n} = tinfo{tname=newName (Left n)}
makeFieldNamesUnique :: [CInfo] -> [CInfo]
makeFieldNamesUnique [] = []
makeFieldNamesUnique (f:[]) = f:[]
makeFieldNamesUnique (f:ff:fs)
| compNames (cname f) (cname ff)
= f: (makeFieldNamesUnique ((fNewName ff) :fs))
| True = f : makeFieldNamesUnique (ff:fs)
where
fNewName cinfo@CInfo{cname=n} = cinfo{cname=newName (Right n)}
makeDBNameUnique :: DBInfo -> DBInfo
makeDBNameUnique dbinfo
= dbinfo{tbls=map (makeTblNameUnique (dbname dbinfo)) (tbls dbinfo)}
makeTblNameUnique :: String -> TInfo -> TInfo
makeTblNameUnique s tinfo
| compNames s (tname tinfo) =
tinfo{cols=map (makeFieldNameUnique s)
(cols tinfo{tname=newName (Left (tname tinfo))})}
| True = tinfo{cols=map (makeFieldNameUnique s) (cols tinfo)}
makeFieldNameUnique :: String -> CInfo -> CInfo
makeFieldNameUnique s cinfo
| compNames s (cname cinfo) = cinfo{cname=newName (Right (cname cinfo))}
| True = cinfo
newName :: Either String String
-> String
newName (Left t) = t ++ "T"
newName (Right n) = n ++ "F"
compNames :: String -> String -> Bool
compNames s1 s2 = map toLower s1 == map toLower s2