module DatabaseDesign.Ampersand.Classes.ConceptStructure (ConceptStructure(..), prim2rel)
where
import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
import DatabaseDesign.Ampersand.Core.ParseTree (ConceptDef(..))
import DatabaseDesign.Ampersand.Basics
import Data.List
import Data.Maybe
import DatabaseDesign.Ampersand.ADL1.Expression
import Prelude hiding (Ordering(..))
fatal :: Int -> String -> a
fatal = fatalMsg "Classes.ConceptStructure"
class ConceptStructure a where
concs :: a -> [A_Concept]
relsUsedIn :: a -> [Declaration]
relsUsedIn a = [ d | d@Sgn{}<-relsMentionedIn a]++[Isn c | c<-concs a]
relsMentionedIn :: a -> [Declaration]
relsMentionedIn = nub . map prim2rel . primsMentionedIn
primsMentionedIn :: a -> [Expression]
primsMentionedIn = nub . concatMap primitives . expressionsIn
expressionsIn :: a -> [Expression]
mp1Exprs :: a -> [Expression]
mp1Exprs = filter isMp1.primsMentionedIn
mp1Pops :: a -> [Population]
mp1Pops struc
= [ PCptPopu{ popcpt = cpt (head cl), popas = map atm cl } | cl<-eqCl cpt (mp1Exprs struc)]
where cpt (EMp1 _ c) = c
cpt _ = fatal 31 "cpt error"
atm (EMp1 a _) = a
atm _ = fatal 31 "atm error"
prim2rel :: Expression -> Declaration
prim2rel e
= case e of
EDcD d@Sgn{} -> d
EDcD{} -> fatal 23 "invalid declaration in EDcD{}"
EDcI c -> Isn c
EDcV sgn -> Vs sgn
EMp1 _ c -> Isn c
_ -> fatal 40 $ "only primitive expressions should be found here.\nHere we see: " ++ show e
instance (ConceptStructure a,ConceptStructure b) => ConceptStructure (a, b) where
concs (a,b) = concs a `uni` concs b
expressionsIn (a,b) = expressionsIn a `uni` expressionsIn b
instance ConceptStructure a => ConceptStructure (Maybe a) where
concs ma = maybe [] concs ma
expressionsIn ma = maybe [] expressionsIn ma
instance ConceptStructure a => ConceptStructure [a] where
concs = nub . concatMap concs
expressionsIn = foldr ((uni) . expressionsIn) []
instance ConceptStructure A_Context where
concs ctx = foldr uni []
[ (concs.ctxpats) ctx
, (concs.ctxprocs) ctx
, (concs.ctxrs) ctx
, (concs.ctxds) ctx
, (concs.ctxpopus) ctx
, (concs.ctxcds) ctx
, (concs.ctxks) ctx
, (concs.ctxvs) ctx
, (concs.ctxgs) ctx
, (concs.ctxifcs) ctx
, (concs.ctxps) ctx
, (concs.ctxsql) ctx
, (concs.ctxphp) ctx
]
expressionsIn ctx = foldr uni []
[ (expressionsIn.ctxpats) ctx
, (expressionsIn.ctxprocs) ctx
, (expressionsIn.ctxifcs) ctx
, (expressionsIn.ctxrs) ctx
, (expressionsIn.ctxks) ctx
, (expressionsIn.ctxvs) ctx
, (expressionsIn.ctxsql) ctx
, (expressionsIn.ctxphp) ctx
]
instance ConceptStructure IdentityDef where
concs identity = [idCpt identity] `uni` concs [objDef | IdentityExp objDef <- identityAts identity]
expressionsIn identity = expressionsIn [objDef | IdentityExp objDef <- identityAts identity]
instance ConceptStructure ViewDef where
concs vd = [vdcpt vd] `uni` concs [objDef | ViewExp objDef <- vdats vd]
expressionsIn vd = expressionsIn [objDef | ViewExp objDef <- vdats vd]
instance ConceptStructure Expression where
concs (EDcI c ) = [c]
concs (EEps i sgn) = nub (i:concs sgn)
concs (EDcV sgn) = concs sgn
concs (EMp1 _ c ) = [c]
concs e = foldrMapExpression uni concs [] e
expressionsIn e = [e]
instance ConceptStructure A_Concept where
concs c = [c]
expressionsIn _ = []
instance ConceptStructure ConceptDef where
concs cd = [PlainConcept (cdcpt cd)]
expressionsIn _ = []
instance ConceptStructure Sign where
concs (Sign s t) = nub [s,t]
expressionsIn _ = []
instance ConceptStructure ObjectDef where
concs obj = [target (objctx obj)] `uni` concs (objmsub obj)
expressionsIn obj = foldr (uni) []
[ (expressionsIn.objctx) obj
, (expressionsIn.objmsub) obj
]
instance ConceptStructure SubInterface where
concs (Box _ objs) = concs objs
concs (InterfaceRef _) = []
expressionsIn (Box _ objs) = expressionsIn objs
expressionsIn (InterfaceRef _) = []
instance ConceptStructure Pattern where
concs pat = foldr uni []
[ (concs.ptrls) pat
, (concs.ptgns) pat
, (concs.ptdcs) pat
, (concs.ptups) pat
, (concs.ptids) pat
, (concs.ptxps) pat
]
expressionsIn p = foldr (uni) []
[ (expressionsIn.ptrls) p
, (expressionsIn.ptids) p
, (expressionsIn.ptvds) p
]
instance ConceptStructure Process where
concs prc = foldr uni []
[ (concs.prcRules) prc
, (concs.prcGens) prc
, (concs.prcDcls) prc
, (concs.prcUps) prc
, (concs.prcIds) prc
, (concs.prcVds) prc
, (concs.prcXps) prc
]
expressionsIn p = foldr (uni) []
[ (expressionsIn.prcRules) p
, (expressionsIn.prcIds) p
, (expressionsIn.prcVds) p
]
instance ConceptStructure Interface where
concs ifc = concs (ifcObj ifc)
expressionsIn ifc = foldr (uni) []
[ (expressionsIn.ifcObj) ifc
, (expressionsIn.ifcParams) ifc
]
instance ConceptStructure Declaration where
concs d = concs (sign d)
expressionsIn _ = fatal 148 "expressionsIn not allowed on Declaration"
instance ConceptStructure Rule where
concs r = concs (rrexp r) `uni` concs (rrviol r)
expressionsIn r = foldr (uni) []
[ (expressionsIn.rrexp ) r
, (expressionsIn.rrviol) r
]
instance ConceptStructure (PairView Expression) where
concs (PairView ps) = concs ps
expressionsIn (PairView ps) = expressionsIn ps
instance ConceptStructure Population where
concs pop@PRelPopu{} = concs (popdcl pop)
concs pop@PCptPopu{} = concs (popcpt pop)
expressionsIn _ = []
instance ConceptStructure Purpose where
concs pop@Expl{} = concs (explObj pop)
expressionsIn _ = []
instance ConceptStructure ExplObj where
concs (ExplConceptDef cd) = concs cd
concs (ExplDeclaration d) = concs d
concs (ExplRule _) = []
concs (ExplIdentityDef _) = []
concs (ExplViewDef _) = []
concs (ExplPattern _) = []
concs (ExplProcess _) = []
concs (ExplInterface _) = []
concs (ExplContext _) = []
expressionsIn _ = []
instance ConceptStructure (PairViewSegment Expression) where
concs (PairViewText _) = []
concs (PairViewExp _ x) = concs x
expressionsIn (PairViewText _) = []
expressionsIn (PairViewExp _ x) = expressionsIn x
instance ConceptStructure A_Gen where
concs g@Isa{} = nub [gengen g,genspc g]
concs g@IsE{} = nub (genspc g: genrhs g)
expressionsIn _ = fatal 160 "expressionsIn not allowed on A_Gen"