ampersand-3.1.0: src/Database/Design/Ampersand/Graphic/Fspec2ClassDiagrams.hs
module Database.Design.Ampersand.Graphic.Fspec2ClassDiagrams (
clAnalysis, cdAnalysis, tdAnalysis
)
where
import Data.List
import Database.Design.Ampersand.ADL1
import Database.Design.Ampersand.Classes
import Database.Design.Ampersand.Basics
import Database.Design.Ampersand.FSpec
import Database.Design.Ampersand.FSpec.FSpec(getConceptTableFor)
import Data.Maybe
import Data.Either
import Database.Design.Ampersand.Graphic.ClassDiagram
fatal :: Int -> String -> a
fatal = fatalMsg "Fspec2ClassDiagrams"
-- | This function makes the classification diagram.
-- It focuses on generalizations and specializations.
clAnalysis :: FSpec -> ClassDiag
clAnalysis fSpec =
OOclassdiagram { cdName = "classification_"++name fSpec
, classes = [ OOClass { clName = name c
, clcpt = Just c
, clAtts = attrs c
, clMths = []
} | c<-cpts]
, assocs = []
, aggrs = []
, geners = map OOGener (gensInScope fSpec)
, ooCpts = concs fSpec
}
where
cpts = concs (gensInScope fSpec)
attrs c = [ OOAttr (fldname fld) (if isPropty fld then "Bool" else (name.target.fldexpr) fld) (fldnull fld)
| plug<-lookup' c, fld<-tail (plugFields plug), not (inKernel fld), source (fldexpr fld)==c]
where inKernel fld = null([Uni,Inj,Sur]>-multiplicities (fldexpr fld)) && not (isPropty fld)
lookup' c = [plug |InternalPlug plug@TblSQL{}<-plugInfos fSpec , (c',_)<-cLkpTbl plug, c'==c]
isPropty fld = null([Sym,Asy]>-multiplicities (fldexpr fld))
-- | This function, cdAnalysis, generates a conceptual data model.
-- It creates a class diagram in which generalizations and specializations remain distinct entity types.
-- This yields more classes than plugs2classdiagram does, as plugs contain their specialized concepts.
-- Properties and identities are not shown.
cdAnalysis :: FSpec -> ClassDiag
cdAnalysis fSpec =
OOclassdiagram { cdName = "logical_"++name fSpec
, classes =
[ OOClass{ clName = name root
, clcpt = Just root
, clAtts = map ooAttr ooClass
, clMths = []
}
| ooClass <- ooClasses, let root=source (head ooClass)]
, assocs = lefts assocsAndAggrs
, aggrs = rights assocsAndAggrs
, geners = map OOGener (gensInScope fSpec)
, ooCpts = roots
}
where
ooAttr :: Expression -> CdAttribute
ooAttr r = OOAttr { attNm = (name . head . relsMentionedIn) r
, attTyp = if isPropty r then "Bool" else (name.target) r
, attOptional = (not.isTot) r
}
isPropty r = null([Sym,Asy]>-multiplicities r)
topLevelDcls = vrels fSpec \\
(concatMap relsDefdIn (vpatterns fSpec))
allDcls = topLevelDcls `uni`
[ d -- restricted to those themes that must be printed.
| d@Sgn{} <- nub . concat $
[relsDefdIn p ++ relsMentionedIn p | p <- pattsInScope fSpec ]
]
assocsAndAggrs = [ decl2assocOrAggr d
| d <- allDcls
, not.isPropty $ d
{- SJ 20150416: the following restriction prevents printing attribute-relations to empty boxes.
-}
, d `notElem` attribDcls ||
( source d `elem` nodeConcepts && target d `elem` nodeConcepts && source d/= target d )
] where family c = [c] ++ specializationsOf fSpec c ++ generalizationsOf fSpec c
nodeConcepts = concatMap family roots
-- Aggregates are disabled for now, as the conditions we use to regard a relation as an aggregate still seem to be too weak
-- decl2assocOrAggr :: Declaration -> Either Association Aggregation
--decl2assocOrAggr d | isUni d && isTot d = Right $ OOAggr {aggDel = Close, aggChild = source d, aggParent = target d}
--decl2assocOrAggr d | isInj d && isSur d = Right $ OOAggr {aggDel = Close, aggChild = target d, aggParent = source d}
decl2assocOrAggr d | otherwise = Left $
OOAssoc { assSrc = name $ source d
, assSrcPort = name d
, asslhm = mults . flp $ EDcD d
, asslhr = ""
, assTgt = name $ target d
, assrhm = mults d
, assrhr = name d
, assmdcl = Just d
}
attribDcls = [ d | d <- allDcls, Aut `notElem` multiplicities d, isUni d || isInj d ]
attribs = [ if isInj d then flp (EDcD d) else EDcD d | d<-attribDcls ]
ooClasses = eqCl source attribs -- an equivalence class wrt source yields the attributes that constitute an OO-class.
roots = map (source.head) ooClasses
-- | This function generates a technical data model.
-- It is based on the plugs that are calculated.
tdAnalysis :: FSpec -> ClassDiag
tdAnalysis fSpec =
OOclassdiagram {cdName = "technical_"++name fSpec
,classes = allClasses
,assocs = allAssocs
,aggrs = []
,geners = []
,ooCpts = roots
}
where
allClasses =
[ OOClass{ clName = sqlname table
, clcpt = primKey table
, clAtts = case table of
TblSQL{fields=attribs, cLkpTbl=kernelLookupTbl, mLkpTbl=t} ->
let kernelFlds = map snd $ kernelLookupTbl -- extract kernel fields from kernel lookup table
in map (ooAttr kernelFlds . lookInFor t . fldexpr) attribs
BinSQL{columns=(a,b)} ->
[ OOAttr { attNm = fldname a
, attTyp = (name.target.fldexpr) a
, attOptional = False
}
, OOAttr { attNm = fldname b
, attTyp = (name.target.fldexpr) b
, attOptional = False
}
]
_ -> fatal 166 "Unexpected type of table!"
, clMths = []
}
| table <- tables
, length (plugFields table) > 1
]
lookInFor [] _ = fatal 191 "Expression not found!"
lookInFor ((expr,_,t):xs) a
| expr == a = t
| otherwise = lookInFor xs a
tables = [ pSql | InternalPlug pSql <- plugInfos fSpec, not (isScalar pSql)]
where isScalar ScalarSQL{} = True
isScalar _ = False
roots :: [A_Concept]
roots = (catMaybes.map primKey) tables
primKey :: PlugSQL -> Maybe A_Concept
primKey TblSQL{fields=(f:_)} = Just (source (fldexpr f))
primKey _ = Nothing
ooAttr :: [SqlField] -> SqlField -> CdAttribute
ooAttr kernelFlds f =
OOAttr { attNm = fldname f
, attTyp = if null([Sym,Asy]>-multiplicities (fldexpr f)) && (f `notElem` kernelFlds)
then "Bool"
else (name.target.fldexpr) f
, attOptional = fldnull f
}
allAssocs = filter isAssocBetweenClasses $ concatMap relsOf tables
where
isAssocBetweenClasses a = let allClassNames = map clName allClasses in assSrc a `elem` allClassNames && assTgt a `elem` allClassNames
kernelConcepts = map fst (concatMap cLkpTbl tables)
relsOf t =
case t of
TblSQL{} -> map (mkRel t) (catMaybes (map relOf (fields t)))
BinSQL{columns=(a,b)} ->
[ OOAssoc { assSrc = sqlname t
, assSrcPort = fldname a
, asslhm = Mult MinZero MaxMany
, asslhr = ""
, assTgt = getConceptTableFor fSpec . target . fldexpr $ a
, assrhm = Mult MinOne MaxOne
, assrhr = ""
, assmdcl = Nothing
}
, OOAssoc { assSrc = sqlname t
, assSrcPort = fldname b
, asslhm = Mult MinZero MaxMany
, asslhr = ""
, assTgt = getConceptTableFor fSpec . target . fldexpr $ b
, assrhm = Mult MinOne MaxOne
, assrhr = ""
, assmdcl = Nothing
}
]
_ -> fatal 195 "Unexpected type of table"
relOf f =
let expr = fldexpr f in
case expr of
EDcI{} -> Nothing
EDcD d -> if target d `elem` kernelConcepts then Just (expr,f) else Nothing
EFlp (EDcD d) -> if source d `elem` kernelConcepts then Just (expr,f) else Nothing
_ -> fatal 200 ("Unexpected expression: "++show expr)
mkRel :: PlugSQL -> (Expression,SqlField) -> Database.Design.Ampersand.Graphic.ClassDiagram.Association
mkRel t (expr,f) =
OOAssoc { assSrc = sqlname t
, assSrcPort = fldname f
, asslhm = (mults.flp) expr
, asslhr = fldname f
, assTgt = getConceptTableFor fSpec (target expr)
, assrhm = mults expr
, assrhr = case [name d | d@Sgn{}<-relsMentionedIn expr] of h:_ -> h ; _ -> fatal 229 "no relations used in expr"
, assmdcl = Nothing
}
----
mults :: Relational r => r -> Multiplicities
mults r = let minVal = if isTot r then MinOne else MinZero
maxVal = if isUni r then MaxOne else MaxMany
in Mult minVal maxVal