{-# OPTIONS_GHC -Wall #-}
module DatabaseDesign.Ampersand.Fspec.GenerateUML (generateUML) where
import DatabaseDesign.Ampersand.Basics
import DatabaseDesign.Ampersand.Misc
import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree (explMarkup,aMarkup2String,Rule,Declaration,Purpose(..))
import DatabaseDesign.Ampersand.Fspec.Graphic.ClassDiagram
import DatabaseDesign.Ampersand.Fspec
import Data.Map (Map)
import Data.List
import qualified Data.Map as Map
import Control.Monad.State.Lazy (State, gets, evalState, modify)
fatal :: Int -> String -> a
fatal = fatalMsg "Fspec.GenerateUML"
-- TODO: escape
-- TODO: names of model, package, assoc (empty?), etc.
generateUML :: Fspc -> Options -> String
generateUML fSpec flags = showUML (fSpec2UML fSpec flags)
showUML :: UML -> String
showUML uml = unlines $ evalState uml $ UMLState 0 Map.empty [] []
fSpec2UML :: Fspc -> Options -> UML
fSpec2UML fSpec flags =
do { packageId0 <- mkUnlabeledId "TopPackage"
; packageId1 <- mkUnlabeledId "PackageClasses"
; packageId2 <- mkUnlabeledId "PackageReqs"
; diagramId <- mkUnlabeledId "Diagram"
; _ <- mapM (mkLabeledId "Datatype") datatypeNames
; _ <- mapM (mkLabeledId "Class") classNames
; datatypesUML <- mapM genUMLDatatype datatypeNames
; classesUML <- mapM genUMLClass (classes classDiag)
; assocsUML <- mapM genUMLAssociation (assocs classDiag)
; requirementsUML <- mapM genUMLRequirement (requirements flags fSpec)
; diagramElements <- genDiagramElements
; customProfileElements <- genCustomProfileElements
; customReqElements <- genCustomReqElements fSpec flags packageId2
; return $ [ ""
, ""
, ""
-- WHY is the exporter not something like `Ampersand` (in the string below)?
-- BECAUSE then for some reason the importer doesn't show the properties of the requirements.
, " "
, " "
, " " ] ++
[ " " ] ++
concat datatypesUML ++
concat classesUML ++
concat assocsUML ++
[ " " ] ++
[ " " ] ++
concat requirementsUML ++
[ " " ] ++
[ " " ] ++
customProfileElements ++
[ " "
, " "
, " "] ++
[ " "]++
[ " "]++
[ " "]++
[ " "]++
[ " "]++
[ " "]++
[ " "]++
[ " "]++
customReqElements ++
[ " "
, " "
, " "
, " "
, " "
, " " ] ++
diagramElements ++
[ " "
, " "
, " "
, " "
, "" ]
}
where classDiag = cdAnalysis fSpec flags
contextName = cdName classDiag
allConcs = ooCpts classDiag
classNames = map name (classes classDiag)
datatypeNames = map name allConcs >- classNames
genUMLRequirement :: Req -> UML
genUMLRequirement req =
do { reqLId <- mkUnlabeledId "Req"
; addReqToState (reqLId, req)
; return $ [ " " ]
}
genUMLDatatype :: String -> UML
genUMLDatatype nm =
do { datatypeId <- refLabeledId nm
; addToDiagram datatypeId
; return [ " " ]
}
genUMLClass :: Class -> UML
genUMLClass cl =
do { classId <- refLabeledId (clName cl)
; addToDiagram classId
; attributesUML <- mapM genUMAttribute (clAtts cl)
; return $ [ " "] ++
concat attributesUML ++
[ " "]
}
genUMAttribute :: CdAttribute -> UML
genUMAttribute (OOAttr nm attrType optional) =
do { attrId <- mkUnlabeledId "Attr"
; lIntId <- mkUnlabeledId "Int"
; uIntId <- mkUnlabeledId "Int"
; classId <- refLabeledId attrType
; return [ " "
, " "
, " "
, " "
, " "]
}
genUMLAssociation :: Association -> UML
genUMLAssociation ass =
do { assocId <- mkUnlabeledId "Assoc"
; lMemberAndOwnedEnd <- genMemberAndOwnedEnd (asslhm ass) assocId (assSrc ass)
; rMemberAndOwnedEnd <- genMemberAndOwnedEnd (assrhm ass) assocId (assTgt ass)
; return $
[ " "
] ++
lMemberAndOwnedEnd ++
rMemberAndOwnedEnd ++
[ " "
]
}
where genMemberAndOwnedEnd (Mult minVal maxVal) assocId type' =
do { endId <- mkUnlabeledId "MemberEnd"
; typeId <- refLabeledId (case type' of
Left c -> name c
Right s -> s
)
; lIntId <- mkUnlabeledId "Int"
; uIntId <- mkUnlabeledId "Int"
; return
[ " "
, " "
, " "
, " "
, case maxVal of
MaxOne -> " "
MaxMany -> " "
, " "
]
}
genDiagramElements :: UML
genDiagramElements =
do { elementIds <- gets diagramEltIds
; return [ " " | elementId <- elementIds ]
}
genCustomProfileElements :: UML
genCustomProfileElements =
do { reqVals <- gets reqValues
; return [reqUML req | req <- reverse reqVals]
}
where
reqUML :: ReqValue2 -> String
reqUML (xmiId, req) = intercalate "\n"
( [" "]++
[tagUML xmiId count puprtxt reftxt | (count, (puprtxt, reftxt)) <- zip [0::Int ..] [(aMarkup2String (explMarkup p), intercalate ";" (explRefIds p)) | p <- reqPurposes req]]
)
tagUML xmiId nr value reftxt = intercalate "\n"
[ " "
, " "
]
where keyMeaning = "Meaning"++show nr
keyRef = "Reference"++show nr
genCustomReqElements :: Fspc -> Options -> String -> UML
genCustomReqElements fSpec _ parentPackageId =
do { reqVals <- gets reqValues
; return [reqUML req | req <- reverse reqVals]
}
where
reqUML :: ReqValue2 -> String
reqUML (xmiId, req) = intercalate "\n"
([ " "
, " "
, " "
, " "]++
[ " " | (nr ,p) <- zip ("" : map show [1::Int ..]) ([aMarkup2String (explMarkup p) | p <- reqPurposes req]) ]++
[ " "
, " "
])
-- Requirements
data Req = Req { reqId :: String
-- , reqRef :: String
, reqOrig :: Either Rule Declaration
, reqPurposes :: [Purpose]
}
instance Meaning Req where
meaning l r = case reqOrig r of
Right rul -> meaning l rul
Left dcl -> meaning l dcl
requirements :: Options -> Fspc -> [Req]
requirements _ fSpec
= [decl2req d | d <- vrels fSpec]
++[rule2req r | r <- vrules fSpec]
where
decl2req d = Req { reqId = name d
, reqOrig = Right d
, reqPurposes = purposesDefinedIn fSpec (fsLang fSpec) d
}
rule2req r = Req { reqId = name r
, reqOrig = Left r
, reqPurposes = purposesDefinedIn fSpec (fsLang fSpec) r
}
-- State and Monad
data UMLState = UMLState { idCounter :: Int
, labelIdMap :: Map String String
, diagramEltIds :: [String]
, reqValues :: [ReqValue2]
}
type StateUML a = State UMLState a
type UML = StateUML [String]
type ReqValue2 = ( String -- the xmi-id
, Req
)
addToDiagram :: String -> StateUML ()
addToDiagram elementId =
modify $ \state' -> state' { diagramEltIds = elementId : diagramEltIds state'}
addReqToState :: ReqValue2 -> StateUML ()
addReqToState reqVal =
modify $ \state' -> state' { reqValues = reqVal : reqValues state'}
mkUnlabeledId :: String -> StateUML String
mkUnlabeledId tag =
do { idC <- gets idCounter
; modify $ \state' -> state' { idCounter = idCounter state' + 1}
; let unlabeledId = tag++"ID_"++show idC
; return unlabeledId
}
refLabeledId :: String -> StateUML String
refLabeledId label =
do { lidMap <- gets labelIdMap
; case Map.lookup label lidMap of
Just lid -> return lid
Nothing -> fatal 147 $ "Requesting non-existent label "++label
}
mkLabeledId :: String -> String -> StateUML ()
mkLabeledId tag label =
do { let classId = tag++"ID_"++label
; modify $ \state' -> state' { labelIdMap = Map.insert label classId (labelIdMap state') }
}