{-# OPTIONS_GHC -Wall #-} module DatabaseDesign.Ampersand.Classes.ViewPoint (Language(..),ProcessStructure(..)) where import DatabaseDesign.Ampersand.Core.ParseTree import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree import Prelude hiding (Ord(..)) import DatabaseDesign.Ampersand.ADL1.Rule (rulefromProp, ruleviolations) import DatabaseDesign.Ampersand.Classes.Relational (Relational(multiplicities)) import DatabaseDesign.Ampersand.Basics import DatabaseDesign.Ampersand.Misc.Explain import Data.List fatal :: Int -> String -> a fatal = fatalMsg "Classes.ViewPoint" -- Language exists because there are many data structures that behave like an ontology, such as Pattern, P_Context, and Rule. -- These data structures are accessed by means of a common set of functions (e.g. rules, relations, etc.) class Language a where objectdef :: a -> ObjectDef -- ^ The objectdef that characterizes this viewpoint relsDefdIn :: a -> [Declaration] -- ^ all relations that are declared in the scope of this viewpoint. -- These are user defined relations and all generated relarations, -- i.e. one relation for each GEN and one for each signal rule. -- Don't confuse relsDefdIn with relsUsedIn, which gives the relations that are -- used in a.) udefrules :: a -> [Rule] -- ^ all user defined rules that are maintained within this viewpoint, -- which are not multiplicity- and not identity rules. invariants :: a -> [Rule] -- ^ all rules that are not maintained by users will be maintained by the computer. -- That includes multiplicity rules and identity rules, but excludes rules that are assigned to a role. -- ^ all relations used in rules must have a valid declaration in the same viewpoint. invariants x = [r |r<-udefrules x, not (isSignal r)] ++ multrules x ++ identityRules x multrules :: a -> [Rule] -- ^ all multiplicityrules that are maintained within this viewpoint. multrules x = [rulefromProp p d |d<-relsDefdIn x, p<-multiplicities d] identityRules :: a -> [Rule] -- all identity rules that are maintained within this viewpoint. identityRules x = concatMap rulesFromIdentity (identities x) identities :: a -> [IdentityDef] -- ^ all keys that are defined in a viewDefs :: a -> [ViewDef] -- ^ all views that are defined in a gens :: a -> [A_Gen] -- ^ all generalizations that are valid within this viewpoint patterns :: a -> [Pattern] -- ^ all patterns that are used in this viewpoint class ProcessStructure a where processes :: a -> [Process] -- ^ all roles that are used in this ProcessStructure roles :: a -> [String] -- ^ all roles that are used in this ProcessStructure interfaces :: a -> [Interface] -- ^ all interfaces that are used in this ProcessStructure objDefs :: a -> [ObjectDef] processRules :: a -> [Rule] -- ^ all process rules that are visible within this viewpoint -- ^ all relations used in rules must have a valid declaration in the same viewpoint. maintains :: a -> [(String,Rule)] -- ^ the string represents a Role mayEdit :: a -> [(String,Declaration)] -- ^ the string represents a Role workFromProcessRules :: [A_Gen] -> [Population] -> a -> [(Rule,Paire)] --the violations of rules and multrules of this viewpoint workFromProcessRules gens' udp x = [(r,viol) |r<-processRules x, viol<-ruleviolations gens' udp r] rulesFromIdentity :: IdentityDef -> [Rule] rulesFromIdentity identity = [ if null (identityAts identity) then fatal 81 ("Moving into foldr1 with empty list (identityAts identity).") else mkKeyRule ( foldr1 (./\.) [ expr .:. flp expr | IdentityExp att <- identityAts identity, let expr=objctx att ] .|-. EDcI (idCpt identity)) ] {- diamond e1 e2 = (flp e1 .\. e2) ./\. (e1 ./. flp e2) -} where ruleName = "identity_" ++ name identity meaningEN = "Identity rule" ++ ", following from identity "++name identity meaningNL = "Identiteitsregel" ++ ", volgend uit identiteit "++name identity mkKeyRule expression = Ru { rrnm = ruleName , rrexp = expression , rrfps = origin identity -- position in source file , rrmean = AMeaning [ A_Markup English ReST (string2Blocks ReST meaningEN) , A_Markup Dutch ReST (string2Blocks ReST meaningNL) ] , rrmsg = [] , rrviol = Nothing , rrtyp = sign expression , rrdcl = Nothing -- This rule was not generated from a property of some declaration. , r_env = "" -- For traceability: The name of the pattern. Unknown at this position but it may be changed by the environment. , r_usr = Identity -- This rule was not specified as a rule in the Ampersand script, but has been generated by a computer , isSignal = False -- This is not a signal rule , srrel = Sgn { decnm = ruleName , decsgn = sign expression , decprps = [] , decprps_calc = Nothing -- [] , decprL = "" , decprM = "" , decprR = "" , decMean = AMeaning [ A_Markup English ReST (string2Blocks ReST meaningEN) , A_Markup Dutch ReST (string2Blocks ReST meaningNL) ] , decfpos = origin identity , deciss = False , decusr = False , decpat = "" , decplug = False } } instance ProcessStructure a => ProcessStructure [a] where processes = concatMap processes roles = concatMap roles interfaces = concatMap interfaces objDefs = concatMap objDefs processRules = concatMap processRules maintains = concatMap maintains mayEdit = concatMap mayEdit instance Language A_Context where objectdef context = Obj { objnm = name context , objpos = Origin "Object generated by objectdef (Language A_Context)" , objctx = EDcI ONE , objmsub = Just . Box ONE $ map (objectdef) (ctxpats context) , objstrs = [] } relsDefdIn context = uniteRels (concatMap relsDefdIn (patterns context) ++ concatMap relsDefdIn (processes context) ++ ctxds context) where -- relations with the same name, but different properties (decprps,pragma,decpopu,etc.) may exist and need to be united -- decpopu, decprps and decprps_calc are united, all others are taken from the head. uniteRels :: [Declaration] -> [Declaration] uniteRels [] = [] uniteRels ds = [ d | cl<-eqClass (==) ds , let d=(head cl){ decprps = (foldr1 uni.map decprps) cl , decprps_calc = Nothing -- Calculation is only done in ADL2Fspc. -- was:(foldr1 uni.map decprps_calc) cl }] udefrules context = concatMap udefrules (ctxpats context) ++ concatMap udefrules (ctxprocs context) ++ ctxrs context identities context = concatMap identities (ctxpats context) ++ concatMap identities (ctxprocs context) ++ ctxks context viewDefs context = concatMap viewDefs (ctxpats context) ++ concatMap viewDefs (ctxprocs context) ++ ctxvs context gens context = concatMap gens (ctxpats context) ++ concatMap gens (ctxprocs context) ++ ctxgs context patterns = ctxpats instance ProcessStructure A_Context where processes = ctxprocs roles context = nub ([r | proc<-ctxprocs context, r <- roles proc]++ [r | interface<-ctxifcs context, r <- ifcRoles interface]) interfaces = ctxifcs objDefs context = [ifcObj s | s<-ctxifcs context] processRules context = [r |r<-udefrules context, (not.null) [role | (role, rul) <-maintains context, name r == name rul ] ] maintains context = maintains (ctxprocs context) mayEdit context = mayEdit (ctxprocs context) instance Language Process where objectdef prc = Obj { objnm = name prc , objpos = origin prc , objctx = EDcI ONE , objmsub = Nothing , objstrs = [] } relsDefdIn proc = prcDcls proc udefrules = prcRules -- all user defined rules in this process -- invariants proc = [r | r<-prcRules proc, not (isSignal r) ] identities = prcIds viewDefs = prcVds gens = prcGens patterns _ = [] instance ProcessStructure Process where processes proc = [proc] roles proc = nub ( [r | (r,_) <- prcRRuls proc]++ [r | (r,_) <- prcRRels proc] ) interfaces _ = [] objDefs _ = [] processRules proc = [r |r<-prcRules proc, isSignal r] maintains = prcRRuls -- says which roles maintain which rules. mayEdit = prcRRels -- says which roles may change the population of which relation. instance Language Pattern where objectdef pat = Obj { objnm = name pat , objpos = origin pat , objctx = EDcI ONE , objmsub = Nothing , objstrs = [] } relsDefdIn pat = ptdcs pat udefrules = ptrls -- all user defined rules in this pattern -- invariants pat = [r |r<-ptrls pat, not (isSignal r)] identities = ptids viewDefs = ptvds gens = ptgns patterns pat = [pat] instance Language Rule where objectdef rule = Obj { objnm = name rule , objpos = origin rule , objctx = EDcI ONE , objmsub = Nothing , objstrs = [] } relsDefdIn r = [srrel r | isSignal r] -- a process rule "declares" a new relation to store violations in. That relation is "stored" in that rule. Therefore it counts as a declaration. udefrules r = [r | r_usr r == UserDefined ] -- invariants r = [r | not (isSignal r)] identities _ = [] viewDefs _ = [] gens _ = [] patterns r = [A_Pat{ ptnm = "Pattern for rule "++name r , ptpos = Origin "Nameless pattern generated by patterns (Language (Rule(Relation Concept))) " , ptend = Origin "Nameless pattern generated by patterns (Language (Rule(Relation Concept))) " , ptrls = [r] , ptgns = [] -- A rule defines no Gens. , ptdcs = relsDefdIn r , ptups = [] , ptrruls = [] , ptrrels = [] , ptids = [] , ptvds = [] , ptxps = [] } ]