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"
class Language a where
objectdef :: a -> ObjectDef
relsDefdIn :: a -> [Declaration]
udefrules :: a -> [Rule]
invariants :: a -> [Rule]
invariants x = [r |r<-udefrules x, not (isSignal r)] ++ multrules x ++ identityRules x
multrules :: a -> [Rule]
multrules x = [rulefromProp p d |d<-relsDefdIn x, p<-multiplicities d]
identityRules :: a -> [Rule]
identityRules x = concatMap rulesFromIdentity (identities x)
identities :: a -> [IdentityDef]
viewDefs :: a -> [ViewDef]
gens :: a -> [A_Gen]
patterns :: a -> [Pattern]
class ProcessStructure a where
processes :: a -> [Process]
roles :: a -> [String]
interfaces :: a -> [Interface]
objDefs :: a -> [ObjectDef]
processRules :: a -> [Rule]
maintains :: a -> [(String,Rule)]
mayEdit :: a -> [(String,Declaration)]
workFromProcessRules :: [A_Gen] -> [Population] -> a -> [(Rule,Paire)]
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)) ]
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
, rrmean = AMeaning
[ A_Markup English ReST (string2Blocks ReST meaningEN)
, A_Markup Dutch ReST (string2Blocks ReST meaningNL)
]
, rrmsg = []
, rrviol = Nothing
, rrtyp = sign expression
, rrdcl = Nothing
, r_env = ""
, r_usr = Identity
, isSignal = False
, 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
uniteRels :: [Declaration] -> [Declaration]
uniteRels [] = []
uniteRels ds = [ d | cl<-eqClass (==) ds
, let d=(head cl){ decprps = (foldr1 uni.map decprps) cl
, decprps_calc = Nothing
}]
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
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
mayEdit = prcRRels
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
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]
udefrules r = [r | r_usr r == UserDefined ]
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 = []
, ptdcs = relsDefdIn r
, ptups = []
, ptrruls = []
, ptrrels = []
, ptids = []
, ptvds = []
, ptxps = []
}
]