module DatabaseDesign.Ampersand.Fspec.ToFspec.ADL2Fspec
(makeFspec,allClauses, quads, preEmpt, editable)
where
import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
import DatabaseDesign.Ampersand.Core.Poset
import Prelude hiding (Ord(..),head)
import DatabaseDesign.Ampersand.ADL1.Rule
import DatabaseDesign.Ampersand.Basics
import DatabaseDesign.Ampersand.Classes
import DatabaseDesign.Ampersand.ADL1
import DatabaseDesign.Ampersand.Fspec.Fspec
import DatabaseDesign.Ampersand.Misc
import DatabaseDesign.Ampersand.Fspec.ToFspec.NormalForms
import DatabaseDesign.Ampersand.Fspec.ToFspec.ADL2Plug
import DatabaseDesign.Ampersand.Fspec.ToFspec.Calc
import DatabaseDesign.Ampersand.Fspec.ShowADL
import Text.Pandoc
import Data.Maybe
import Data.List (nub,nubBy,intersect,partition,group,delete)
import DatabaseDesign.Ampersand.ADL1.Expression
import Data.Char (toLower)
head :: [a] -> a
head [] = fatal 30 "head must not be used on an empty list!"
head (a:_) = a
fatal :: Int -> String -> a
fatal = fatalMsg "Fspec.ToFspec.ADL2Fspec"
makeFspec :: Options -> A_Context -> Fspc
makeFspec flags context = fSpec
where
fSpec =
Fspc { fsName = name context
, fspos = ctxpos context
, themes = themesInScope
, pattsInScope = pattsInThemesInScope
, procsInScope = procsInThemesInScope
, rulesInScope = rulesInThemesInScope
, declsInScope = declsInThemesInScope
, concsInScope = concsInThemesInScope
, cDefsInScope = cDefsInThemesInScope
, gensInScope = gensInThemesInScope
, fsLang = fromMaybe (ctxlang context) (language flags)
, vprocesses = allProcs
, vplugInfos = definedplugs
, plugInfos = allplugs
, interfaceS = ctxifcs context
, interfaceG = [ifc | ifc<-interfaceGen, let ctxrel = objctx (ifcObj ifc)
, isIdent ctxrel && source ctxrel==ONE
|| ctxrel `notElem` map (objctx.ifcObj) (interfaceS fSpec)
, allInterfaces flags]
, fSwitchboard = switchboard flags fSpec
, fActivities = [ makeActivity fSpec rul | rul <-processRules context]
, fRoleRels = mayEdit context
, fRoleRuls = maintains context
, fRoles = roles context
, vrules = vRules
, grules = gRules
, invars = invariants context
, allRules = allrules
, vconjs = let equalOnConjunct a b = rc_conjunct a == rc_conjunct b
in nubBy equalOnConjunct (concatMap (cl_conjNF.qClauses)allQuads)
, vquads = allQuads
, vEcas = let (ecas,_)=(unzip.assembleECAs) fSpec in ecas
, vrels = calculatedDecls
, allUsedDecls = relsUsedIn context
, allDecls = relsDefdIn context
, allConcepts = concs context `uni` [ONE]
, kernels = constructKernels
, fsisa = let f gen = case gen of
Isa{} -> [(genspc gen, gengen gen)]
IsE{} -> [(genspc gen, g ) | g<-genrhs gen]
in concatMap f (gens context)
, vpatterns = patterns context
, vgens = gens context
, vIndices = identities context
, vviews = viewDefs context
, conceptDefs = ctxcds context
, fSexpls = ctxps context
, metas = ctxmetas context
, initialPops = initialpops
, allViolations = [(r,vs) |r<-allrules, not (isSignal r), let vs = ruleviolations (gens context) initialpops r, not (null vs)]
}
themesInScope = if null (ctxthms context)
then map name (patterns context) ++ map name allProcs
else ctxthms context
pattsInThemesInScope = filter (\p -> name p `elem` themesInScope) (patterns context)
procsInThemesInScope = filter (\p -> name p `elem` themesInScope) (ctxprocs context)
cDefsInThemesInScope = filter (\cd -> cdfrom cd `elem` themesInScope) (ctxcds context)
rulesInThemesInScope = ctxrs context `uni` concatMap prcRules procsInThemesInScope `uni` concatMap ptrls pattsInThemesInScope
declsInThemesInScope = ctxds context `uni` concatMap prcDcls procsInThemesInScope `uni` concatMap ptdcs pattsInThemesInScope
concsInThemesInScope = concs (ctxrs context) `uni` concs procsInThemesInScope `uni` concs pattsInThemesInScope
gensInThemesInScope = ctxgs context ++ concatMap prcGens procsInThemesInScope ++ concatMap ptgns pattsInThemesInScope
allQuads = quads flags (\_->True) allrules
initialpops = [ PRelPopu{ popdcl = popdcl (head eqclass)
, popps = (nub.concat) [ popps pop | pop<-eqclass ]
}
| eqclass<-eqCl popdcl [ pop | pop@PRelPopu{}<-populations ] ] ++
[ PCptPopu{ popcpt = popcpt (head eqclass)
, popas = (nub.concat) [ popas pop | pop<-eqclass ]
}
| eqclass<-eqCl popcpt [ pop | pop@PCptPopu{}<-populations ] ]
where populations = ctxpopus context++concatMap prcUps (processes context)++concatMap ptups (patterns context)
allrules = vRules ++ gRules
vRules = udefrules context
gRules = multrules context++identityRules context
allProcs = [ FProc {fpProc = p
,fpActivities =selectActs p
} | p<-ctxprocs context ]
where selectActs p = [act | act<-fActivities fSpec
, (not.null) (selRoles p act)]
selRoles p act = [r | (r,rul)<-maintains context, rul==actRule act, r `elem` roles p]
calcProps :: Declaration -> Declaration
calcProps d = d{decprps_calc = Just calculated}
where calculated = decprps d `uni` [Tot | d `elem` totals]
`uni` [Sur | d `elem` surjectives]
calculatedDecls = map calcProps (relsDefdIn context)
constructKernels = foldl f (group (delete ONE (concs context))) (gens context)
where f disjuncLists g = concat haves : nohaves
where
(haves,nohaves) = partition (not.null.intersect (concs g)) disjuncLists
totals = [ d | EDcD d <- totsurs ]
surjectives = [ d | EFlp (EDcD d) <- totsurs ]
totsurs :: [Expression]
totsurs
= nub [rel | q<-quads flags visible (invariants context), isIdent (qDcl q)
, x<-cl_conjNF (qClauses q), Dnf antcs conss<-rc_dnfClauses x
, let antc = conjNF (foldr (./\.) (EDcV (sign (head (antcs++conss)))) antcs)
, isRfx antc
, cons<-map exprCps2list conss
, rel<-init cons++[flp r | r<-tail cons]
]
where
visible _ = True
vsqlplugs = [ (makeUserDefinedSqlPlug context p) | p<-ctxsql context]
definedplugs = map InternalPlug vsqlplugs
++ map ExternalPlug (ctxphp context)
allplugs = definedplugs ++
genPlugs
genPlugs = [InternalPlug (rename p (qlfname (name p)))
| p <- uniqueNames (map name definedplugs)
(makeGeneratedSqlPlugs flags context totsurs entityRels)
]
entityRels = [ d | d<-calculatedDecls, not (decplug d)]
qlfname x = if null (namespace flags) then x else "ns"++namespace flags++x
--r::A*B[TOT].
--t::E*ECps[UNI].
--ENDPATTERN
--ENDCONTEXT
cRels = [ EDcD d | d@Sgn{}<-relsDefdIn context, not(deciss d), isTot d, not$decplug d]++
[flp (EDcD d) | d@Sgn{}<-relsDefdIn context, not(deciss d), not (isTot d) && isSur d, not$decplug d]
dRels = [ EDcD d | d@Sgn{}<-relsDefdIn context, not(deciss d), isInj d, not$decplug d]++
[flp (EDcD d) | d@Sgn{}<-relsDefdIn context, not(deciss d), not (isInj d) && isUni d, not$decplug d]
maxTotPaths = clos cRels
maxInjPaths = clos dRels
clos :: [Expression] -> [[Expression]]
clos xs
= foldl f [ [ x ] | x<-xs] (nub (map source xs) `isc` nub (map target xs))
where
f :: [[Expression]] -> A_Concept -> [[Expression]]
f q x = q ++ [l ++ r | l <- q, x == target (last l),
r <- q, x == source (head r), null (l `isc` r)]
interfaceGen = step4a ++ step4b
step4a
| theme flags == StudentTheme
= [Ifc { ifcParams = directdeclsExprs
, ifcArgs = []
, ifcObj = Obj { objnm = name c ++ " (instantie)"
, objpos = Origin "generated object for interface for each concept in TblSQL or ScalarSQL"
, objctx = EDcI c
, objmsub = Just . Box c $
Obj { objnm = "I["++name c++"]"
, objpos = Origin "generated object: step 4a - default theme"
, objctx = EDcI c
, objmsub = Nothing
, objstrs = [] }
:[Obj { objnm = case dcl of
EDcD d -> name d ++ "::"++name (source d)++"*"++name (target d)
_ -> fatal 246 "Invalid expression for a parameter."
, objpos = Origin "generated object: step 4a - default theme"
, objctx = if source dcl==c then dcl else flp dcl
, objmsub = Nothing
, objstrs = [] }
| dcl <- directdeclsExprs]
, objstrs = [] }
, ifcPos = Origin "generated interface for each concept in TblSQL or ScalarSQL"
, ifcPrp = "Interface " ++name c++" has been generated by Ampersand."
, ifcRoles = []
}
| c<-concs fSpec, let directdeclsExprs = [EDcD d | d<-relsDefdIn fSpec, c `elem` concs d]]
| otherwise
= let recur es
= [ Obj { objnm = showADL t
, objpos = Origin "generated recur object: step 4a - default theme"
, objctx = t
, objmsub = Just . Box (target t) $ recur [ pth | (_:pth)<-cl, not (null pth) ]
, objstrs = [] }
| cl<-eqCl head es, (t:_)<-take 1 cl]
gPlugConcepts = [ c | InternalPlug plug@TblSQL{}<-genPlugs , (c,_)<-take 1 (cLkpTbl plug) ]
in
[Ifc { ifcParams = [ p | p <- concatMap primitives (expressionsIn objattributes), not (isIdent p)]
, ifcArgs = []
, ifcObj = Obj { objnm = name c
, objpos = Origin "generated object: step 4a - default theme"
, objctx = EDcI c
, objmsub = Just . Box c $ objattributes
, objstrs = [] }
, ifcPos = Origin "generated interface: step 4a - default theme"
, ifcPrp = "Interface " ++name c++" has been generated by Ampersand."
, ifcRoles = []
}
| cl <- eqCl (source.head) [ pth | pth<-maxTotPaths `uni` maxInjPaths, (source.head) pth `elem` gPlugConcepts ]
, let objattributes = recur cl
, not (null objattributes)
,
not (length objattributes==1 && isIdent(objctx(head objattributes)))
, let e0=head cl, if null e0 then fatal 284 "null e0" else True
, let c=source (head e0)
]
step4b
= [Ifc { ifcParams = ifcParams ifcc
, ifcArgs = ifcArgs ifcc
, ifcObj = Obj { objnm = nm
, objpos = Origin "generated object: step 4b"
, objctx = EDcI ONE
, objmsub = Just . Box ONE $ [att]
, objstrs = [] }
, ifcPos = ifcPos ifcc
, ifcPrp = ifcPrp ifcc
, ifcRoles = []
}
| ifcc<-step4a
, let c = source(objctx (ifcObj ifcc))
nm'::Int->String
nm' 0 = plural (fsLang fSpec) (name c)
nm' i = plural (fsLang fSpec) (name c) ++ show i
nms = [nm' i |i<-[0..], nm' i `notElem` map name (ctxifcs context)]
nm
| theme flags == StudentTheme = name c
| null nms = fatal 355 "impossible"
| otherwise = head nms
att = Obj (name c) (Origin "generated attribute object: step 4b") (EDcV (Sign ONE c)) Nothing []
]
editable :: Expression -> Bool
editable (EDcD Sgn{}) = True
editable _ = False
makeActivity :: Fspc -> Rule -> Activity
makeActivity fSpec rul
= let s = Act{ actRule = rul
, actTrig = decls
, actAffect = nub [ d' | (d,_,d')<-clos affectPairs, d `elem` decls]
, actQuads = invQs
, actEcas = [eca | eca<-vEcas fSpec, eDcl (ecaTriggr eca) `elem` decls]
, actPurp = [Expl { explPos = OriginUnknown
, explObj = ExplRule (name rul)
, explMarkup = A_Markup { amLang = Dutch
, amFormat = ReST
, amPandoc = [Plain [Str "Waartoe activiteit ", Quoted SingleQuote [Str (name rul)], Str" bestaat is niet gedocumenteerd." ]]
}
, explUserdefd = False
, explRefIds = ["Regel "++name rul]
}
,Expl { explPos = OriginUnknown
, explObj = ExplRule (name rul)
, explMarkup = A_Markup { amLang = English
, amFormat = ReST
, amPandoc = [Plain [Str "For what purpose activity ", Quoted SingleQuote [Str (name rul)], Str" exists remains undocumented." ]]
}
, explUserdefd = False
, explRefIds = ["Regel "++name rul]
}
]
} in s
where
decls = relsUsedIn rul
invQs = [q | q@(Quad _ ccrs)<-vquads fSpec, (not.isSignal.cl_rule.qClauses) q
, (not.null) ((relsUsedIn.cl_rule) ccrs `isc` decls)]
affectPairs = [(qDcl q,[q], d) | q<-invQs, d<-(relsUsedIn.cl_rule.qClauses) q]
clos :: (Eq a,Eq b) => [(a,[b],a)] -> [(a,[b],a)]
clos xs
= foldl f xs (nub (map fst3 xs) `isc` nub (map thd3 xs))
where
f q x = q `un`
[(a, qs `uni` qs', b') | (a, qs, b) <- q, b == x,
(a', qs', b') <- q, a' == x]
ts `un` [] = ts
ts `un` ((a',qs',b'):ts')
= ([(a,qs `uni` qs',b) | (a,qs,b)<-ts, a==a' && b==b']++
[(a,qs,b) | (a,qs,b)<-ts, a/=a' || b/=b']++
[(a',qs',b') | (a',b') `notElem` [(a,b) |(a,_,b)<-ts]]) `un` ts'
quads :: Options -> (Declaration->Bool) -> [Rule] -> [Quad]
quads flags visible rs
= [ Quad { qDcl = d
, qClauses = allClauses flags rule
}
| rule<-rs, d<-relsUsedIn rule, visible d
]
allClauses :: Options -> Rule -> Clauses
allClauses flags rule = Clauses [RC { rc_int = i
, rc_rulename = name rule
, rc_conjunct = dnf2expr dnfClause
, rc_dnfClauses = allShifts flags dnfClause
} | (dnfClause,i)<-zip (conjuncts rule) [0..] ] rule
allShifts :: Options -> DnfClause -> [DnfClause]
allShifts _ conjunct = (map head.eqCl (disjNF.dnf2expr)) [ e'| e'<-shiftL conjunct++shiftR conjunct]
where
shiftL :: DnfClause -> [DnfClause]
shiftL dc@(Dnf antcs conss)
| null antcs || null conss = [dc]
| otherwise = [ Dnf ass (case css of
[] -> let antcExpr = foldr1 (./\.) ass in
if isEndo antcExpr then [EDcI (source antcExpr)] else fatal 425 "antcExpr should be endorelation"
_ -> css
)
| (ass,css)<-nub (move antcs conss)
]
where
move :: [Expression] -> [Expression] -> [([Expression],[Expression])]
move ass [] = [(ass,[])]
move ass css
= (ass,css):
if and [ (not.isEDcI) cs | cs<-css]
then [ts | let headEs = map headECps css
, length (eqClass (==) headEs) == 1
, let h=head headEs
, isUni h
, ts<-move [if source h==source as then flp h.:.as else fatal 455 "type mismatch"
|as<-ass] (map tailECps css)]++
[ts | let lastEs = map lastECps css
, length (eqClass (==) lastEs) == 1
, let l=head lastEs
, isInj l
, ts<-move [if target as==target l then as.:.flp l else fatal 461 "type mismatch"
|as<-ass] (map initECps css)]
else []
shiftR :: DnfClause -> [DnfClause]
shiftR dc@(Dnf antcs conss)
| null antcs || null conss = [dc]
| otherwise = [ Dnf (case ass of
[] -> let consExpr = foldr1 (.\/.) css in
if source consExpr==target consExpr then [EDcI (source consExpr)] else fatal 463 "consExpr should be endorelation"
_ -> ass
) css
| (ass,css)<-nub (move antcs conss)
]
where
move :: [Expression] -> [Expression] -> [([Expression],[Expression])]
move ass css =
case ass of
[] -> []
_ ->
(ass,css):
if and [ (not.isEDcI) as | as<-ass]
then [ts | let headEs = map headECps ass
, length (eqClass (==) headEs) == 1
, let h=head headEs
, isSur h
, ts<-move (map tailECps ass) [if source h==source cs then flp h.:.cs else fatal 496 "type mismatch"
|cs<-css]]++
[ts | let lastEs = map lastECps ass
, length (eqClass (==) lastEs) == 1
, let l=head lastEs
, isTot l
, ts<-move (map initECps ass) [if target cs==target l then cs.:.flp l else fatal 502 "type mismatch"
|cs<-css]]
else []
headECps :: Expression -> Expression
headECps expr = f expr
where f (ECps (l@ECps{},_)) = f l
f (ECps (l,_)) = l
f _ = expr
tailECps :: Expression -> Expression
tailECps expr = f expr
where f (ECps (ECps (l,r),q)) = f (ECps (l, ECps (r,q)))
f (ECps (_,r)) = r
f _ = EDcI (target expr)
initECps :: Expression -> Expression
initECps expr = f expr
where f (ECps (l, ECps (r,q))) = initECps (ECps (ECps (l,r),q))
f (ECps (l,_)) = l
f _ = EDcI (source expr)
lastECps :: Expression -> Expression
lastECps expr = f expr
where f (ECps (_,r@ECps{})) = f r
f (ECps (_,r)) = r
f _ = expr
isEDcI :: Expression -> Bool
isEDcI EDcI{} = True
isEDcI _ = False
preEmpt :: [ECArule] -> [ECArule]
preEmpt ers = pr [length ers] (10::Int)
where
pr :: [Int] -> Int -> [ECArule]
pr ls n
| n == 0 = fatal 633 $ "too many cascading levels in preEmpt "++show ls
| (not.null) cascaded = pr (length cascaded:ls)
(n1)
| otherwise = [er{ecaAction=normPA (ecaAction er)} | er<-uncasced]
where
new = [er{ecaAction=normPA (ecaAction er)} | er<-ers]
cascaded = [er{ecaAction=action'} | er<-new, let (c,action') = cascade (eDcl (ecaTriggr er)) (ecaAction er), c]
uncasced = [er | er<-new, let (c,_) = cascade (eDcl (ecaTriggr er)) (ecaAction er), not c]
cascade dcl (Do srt to _ _) | (not.null) blkErs = (True, ecaAction (head blkErs))
where blkErs = [er | er<-ers
, Blk _<-[ecaAction er]
, let t = ecaTriggr er
, eSrt t == srt
, eDcl t == to
, not (dcl ==to)
]
cascade _ c@Do{} = (False, c)
cascade rel (New c clause m) = ((fst.cascade rel.clause) "dummystr", New c (snd.cascade rel.clause) m)
cascade rel (Rmv c clause m) = ((fst.cascade rel.clause) "dummystr", Rmv c (snd.cascade rel.clause) m)
cascade rel (CHC ds m) = (any (fst.cascade rel) ds, CHC (map (snd.cascade rel) ds) m)
cascade rel (ALL ds m) = (any (fst.cascade rel) ds, ALL (map (snd.cascade rel) ds) m)
cascade _ (Nop m) = (False, Nop m)
cascade _ (Blk m) = (False, Blk m)
cascade _ (Let _ _ _) = fatal 611 "Deze constructor is niet gedefinieerd"
cascade _ (Ref _) = fatal 612 "Deze constructor is niet gedefinieerd"
cascade _ (GCH{}) = fatal 655 "Deze constructor is niet gedefinieerd"
switchboard :: Options -> Fspc -> Fswitchboard
switchboard flags fSpec
= Fswtch
{ fsbEvIn = eventsIn
, fsbEvOut = eventsOut
, fsbConjs = conjs
, fsbECAs = ecas
}
where
qs :: [Quad]
qs = quads flags visible (invariants fSpec)
(ecas, _) = unzip (assembleECAs fSpec)
conjs = nub [ (cl_rule ccrs,rc_conjunct x) | Quad _ ccrs<-qs, x<-cl_conjNF ccrs]
eventsIn = nub [ecaTriggr eca | eca<-ecas ]
eventsOut = nub [evt | eca<-ecas, evt<-eventsFrom (ecaAction eca)]
visible _ = True
class Identified a => Rename a where
rename :: a->String->a
uniqueNames :: [String]->[a]->[a]
uniqueNames taken xs
= [p | cl<-eqCl (map toLower.name) xs
, p <-if name (head cl) `elem` taken || length cl>1
then [rename p (name p++show i) | (p,i)<-zip cl [(1::Int)..]]
else cl
]
instance Rename PlugSQL where
rename p x = p{sqlname=x}