ampersand 3.0.1 → 3.0.2
raw patch · 60 files changed
+2620/−2734 lines, 60 filesdep +ConfigFiledep ~ampersand
Dependencies added: ConfigFile
Dependency ranges changed: ampersand
Files
- AmpersandData/FormalAmpersand/RAP.adl +1/−1
- AmpersandData/FormalAmpersand/student_AST_interfaces.adl +3/−3
- README.txt +0/−0
- ampersand.cabal +7/−5
- src/exec/Main.hs +0/−5
- src/lib/DatabaseDesign/Ampersand.hs +9/−9
- src/lib/DatabaseDesign/Ampersand/ADL1.hs +6/−5
- src/lib/DatabaseDesign/Ampersand/ADL1/Disambiguate.hs +4/−1
- src/lib/DatabaseDesign/Ampersand/ADL1/ECArule.hs +29/−17
- src/lib/DatabaseDesign/Ampersand/ADL1/Expression.hs +87/−2
- src/lib/DatabaseDesign/Ampersand/ADL1/P2A_Converters.hs +46/−32
- src/lib/DatabaseDesign/Ampersand/ADL1/Pair.hs +6/−42
- src/lib/DatabaseDesign/Ampersand/ADL1/Rule.hs +8/−6
- src/lib/DatabaseDesign/Ampersand/Basics/Auxiliaries.hs +7/−9
- src/lib/DatabaseDesign/Ampersand/Basics/BuildInfo_Generated.hs +3/−3
- src/lib/DatabaseDesign/Ampersand/Classes.hs +2/−2
- src/lib/DatabaseDesign/Ampersand/Classes/ConceptStructure.hs +26/−15
- src/lib/DatabaseDesign/Ampersand/Classes/Populated.hs +88/−110
- src/lib/DatabaseDesign/Ampersand/Classes/Relational.hs +4/−4
- src/lib/DatabaseDesign/Ampersand/Classes/ViewPoint.hs +46/−58
- src/lib/DatabaseDesign/Ampersand/Components.hs +2/−1
- src/lib/DatabaseDesign/Ampersand/Core/AbstractSyntaxTree.hs +36/−64
- src/lib/DatabaseDesign/Ampersand/Core/ParseTree.hs +8/−8
- src/lib/DatabaseDesign/Ampersand/Fspec.hs +1/−3
- src/lib/DatabaseDesign/Ampersand/Fspec/Fspec.hs +44/−57
- src/lib/DatabaseDesign/Ampersand/Fspec/Graphic/ClassDiagram.hs +36/−34
- src/lib/DatabaseDesign/Ampersand/Fspec/Graphic/Graphics.hs +291/−157
- src/lib/DatabaseDesign/Ampersand/Fspec/Graphic/Picture.hs +0/−136
- src/lib/DatabaseDesign/Ampersand/Fspec/Motivations.hs +9/−5
- src/lib/DatabaseDesign/Ampersand/Fspec/Plug.hs +22/−38
- src/lib/DatabaseDesign/Ampersand/Fspec/ShowADL.hs +70/−76
- src/lib/DatabaseDesign/Ampersand/Fspec/ShowECA.hs +10/−51
- src/lib/DatabaseDesign/Ampersand/Fspec/ShowHS.hs +55/−56
- src/lib/DatabaseDesign/Ampersand/Fspec/ShowMeatGrinder.hs +9/−12
- src/lib/DatabaseDesign/Ampersand/Fspec/ShowXMLtiny.hs +1/−0
- src/lib/DatabaseDesign/Ampersand/Fspec/Switchboard.hs +29/−27
- src/lib/DatabaseDesign/Ampersand/Fspec/ToFspec/ADL2Fspec.hs +48/−443
- src/lib/DatabaseDesign/Ampersand/Fspec/ToFspec/ADL2Plug.hs +55/−19
- src/lib/DatabaseDesign/Ampersand/Fspec/ToFspec/Calc.hs +429/−238
- src/lib/DatabaseDesign/Ampersand/Fspec/ToFspec/NormalForms.hs +90/−53
- src/lib/DatabaseDesign/Ampersand/Input/ADL1/CtxError.hs +16/−11
- src/lib/DatabaseDesign/Ampersand/Input/ADL1/FilePos.hs +1/−2
- src/lib/DatabaseDesign/Ampersand/Input/ADL1/Parser.hs +31/−31
- src/lib/DatabaseDesign/Ampersand/Input/Parsing.hs +2/−4
- src/lib/DatabaseDesign/Ampersand/InputProcessing.hs +2/−4
- src/lib/DatabaseDesign/Ampersand/Misc.hs +1/−1
- src/lib/DatabaseDesign/Ampersand/Misc/Options.hs +326/−278
- src/lib/DatabaseDesign/Ampersand/Output/Fspec2Pandoc.hs +8/−9
- src/lib/DatabaseDesign/Ampersand/Output/PandocAux.hs +21/−5
- src/lib/DatabaseDesign/Ampersand/Output/PredLogic.hs +8/−7
- src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterConceptualAnalysis.hs +92/−70
- src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterDataAnalysis.hs +110/−151
- src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterDiagnosis.hs +42/−45
- src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterECArules.hs +40/−21
- src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterGlossary.hs +1/−1
- src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterInterfaces.hs +15/−29
- src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterNatLangReqs.hs +190/−174
- src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterProcessAnalysis.hs +39/−44
- src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterSoftwareMetrics.hs +2/−2
- src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/SharedAmongChapters.hs +46/−38
AmpersandData/FormalAmpersand/RAP.adl view
@@ -65,7 +65,7 @@ RULE "otherviolations": -((-I[PropertyRule] /\ I[Rule]);rrviols) MESSAGE "<br/><br/><span class='violsignal'>A business rule that involves several relations is violated.</span> Add or delete tuple(s) in one or more of the relation(s) to correct the violation(s)." -VIOLATION (TXT "RULE ",SRC I, TXT " is violated by the tuple ", TGT I, TXT " in combination with some other tuple(s).") +VIOLATION (TXT "RULE ",SRC I[Rule], TXT " is violated by the violation ", TGT I, TXT " in combination with some other tuple(s).") ENDPROCESS PROCESS Admin
AmpersandData/FormalAmpersand/student_AST_interfaces.adl view
@@ -16,7 +16,7 @@ BOX ["CONTEXT":I,"source file (click to edit)":sourcefile \/ includes,"operations (click to perform)":sourcefile;applyto~] ,"overview of files" : V[ONE*User] BOX [ "open new source file" : newfile - , "source files" : uploaded[User*AdlFile];I[AdlFile] BOX ["file name (click to edit)":I,"created at":filetime,"operations (click to perform)":applyto~] + , "source files" : uploaded[User*File];I[AdlFile] BOX ["file name (click to edit)":I[AdlFile],"created at":filetime,"operations (click to perform)":applyto~] ] ] @@ -136,7 +136,7 @@ BOX ["Export POPULATIONs to...":V[ONE*Context];savepopulation BOX ["file (INCLUDE only)":I[SavePopFile],"type a file name":filename] ,"User settings": V[ONE*User] BOX ["use role to load files":userrole] - , "files with only POPULATIONs" : V[ONE*User];uploaded;(I[File] /\ -I[AdlFile]) BOX ["file name":I,"created at":filetime] + , "files with only POPULATIONs" : V[ONE*User];uploaded;(I[File] /\ -I[AdlFile]) BOX ["file name":I[File],"created at":filetime] ] INTERFACE "CONTEXT" FOR Student: I[Context] @@ -166,7 +166,7 @@ ,"name" :cptnm ,"POPULATION" :cptos BOX ["atom":atomvalue] ,"POPULATION (through ISA)":(genspc~;gengen \/ genspc~;gengen;genspc~;gengen \/ genspc~;gengen;genspc~;gengen;genspc~;gengen)~ --TODO closure - BOX ["more specific concept":I, "POPULATION":cptos;atomvalue] + BOX ["more specific concept":I[Concept], "POPULATION":cptos;atomvalue] ,"more generic concepts" : genspc~;gengen \/ genspc~;gengen;genspc~;gengen \/ genspc~;gengen;genspc~;gengen;genspc~;gengen --TODO closure -- ,"comparable atoms":order;order~;cptos BOX ["atom":atomvalue, "of concept":cptos~] ,"used in relations": (decsgn;(src \/ trg))~
+ README.txt view
ampersand.cabal view
@@ -1,5 +1,5 @@ name: ampersand -version: 3.0.1 +version: 3.0.2 author: Stef Joosten maintainer: stef.joosten@ou.nl synopsis: Toolsuite for automated design of business processes. @@ -41,7 +41,9 @@ outputTemplates/default.s5, outputTemplates/default.slidy, outputTemplates/default.texinfo, - outputTemplates/default.textile + outputTemplates/default.textile, + LICENSE, + README.txt source-repository head type: svn @@ -72,7 +74,8 @@ SpreadsheetML >= 0.1 && < 0.2, process >= 1.1.0.1 && < 1.2, split >= 0.1 && < 0.2, - old-locale >= 1.0.0.4 && < 1.1 + old-locale >= 1.0.0.4 && < 1.1, + ConfigFile >= 1.1.1 exposed-modules: DatabaseDesign.Ampersand other-modules: DatabaseDesign.Ampersand.ADL1, @@ -107,7 +110,6 @@ DatabaseDesign.Ampersand.Fspec.GenerateUML, DatabaseDesign.Ampersand.Fspec.Graphic.ClassDiagram, DatabaseDesign.Ampersand.Fspec.Graphic.Graphics, - DatabaseDesign.Ampersand.Fspec.Graphic.Picture, DatabaseDesign.Ampersand.Fspec.Motivations, DatabaseDesign.Ampersand.Fspec.Plug, DatabaseDesign.Ampersand.Fspec.ShowADL, @@ -164,7 +166,7 @@ executable ampersand main-is: Main.hs hs-source-dirs: src/exec - build-depends: ampersand == 3.0.1, + build-depends: ampersand == 3.0.2, graphviz >= 2999.16.0.0 && <= 2999.17, filepath >= 1.3.0.0 && < 1.4, base >= 4.5.0.0
src/exec/Main.hs view
@@ -6,11 +6,6 @@ import Prelude hiding (readFile,writeFile) import Data.List (intersperse) import DatabaseDesign.Ampersand (getOptions, showErr, showVersion, showHelp, helpNVersionTexts, ampersandVersionStr, createFspec, Guarded(..), generateAmpersandOutput)--- import DatabaseDesign.Ampersand.Misc --- import qualified DatabaseDesign.Ampersand.Basics as Basics--- import DatabaseDesign.Ampersand.Components--- import DatabaseDesign.Ampersand.InputProcessing--- import DatabaseDesign.Ampersand.Input.ADL1.CtxError (showErr) main :: IO () main =
src/lib/DatabaseDesign/Ampersand.hs view
@@ -3,13 +3,13 @@ ( -- Data Constructors: A_Context , P_Context(..), P_Population(..), PairView(..), PairViewSegment(..), SrcOrTgt(..), P_Rule(..), Term(..), TermPrim(..), P_Sign(..), P_Concept(..), P_Declaration(..), P_Pattern(..), P_Gen(..) - , P_Markup(..), PRef2Obj(..), PPurpose(..), PMeaning(..), RelConceptDef(..), Meta(..), MetaObj(..) + , P_Markup(..), PRef2Obj(..), PPurpose(..), PMeaning(..), Meta(..), MetaObj(..) , A_Concept(..), A_Gen(..) , Sign(..), ConceptDef(..), ConceptStructure(..) , Activity(..) , AMeaning(..) , Quad(..), RuleClause(..) - , ECArule(..) + , Fswitchboard(..), ECArule(..), Event(..), InsDel(..) -- (required for --haskell output) , Pattern(..) , Declaration(..) , IdentityDef(..) @@ -19,8 +19,8 @@ , Expression(..) , Population(..) , Fspc(..), concDefs - , Fswitchboard(..) , PlugSQL(..), SqlField(..), SqlType(..), PlugInfo(..) + , PAclause(..) , Rule(..) , Process(..) , FProcess(..) , Prop(..), RuleOrigin(..) @@ -28,7 +28,7 @@ , SqlFieldUsage(..) , DnfClause(..), Clauses(..) , Options(..), DocTheme(..) - , Picture(..), writePicture, DrawingType(..) + , Picture(..), writePicture , PictureReq(..), makePicture , FilePos(..), Origin(..), Pos(Pos) , FPA(..), FPcompl(..) , mkPair @@ -46,13 +46,12 @@ , Motivated(..) , Traced(..) , Language(..) - , Dotable(..) , FPAble(..) , ShowHS(..), ShowHSName(..), haskellIdentifier -- * Functions on concepts , (<==>),meet,join,sortWith,atomsOf , smallerConcepts, largerConcepts, rootConcepts - -- * Functions on declarations + -- * Functions on relations -- * Functions on rules -- * Functions on expressions: , conjNF, disjNF, simplify @@ -60,9 +59,9 @@ , lookupCpt , showPrf , notCpl, isCpl, isPos, isNeg, foldrMapExpression - , (.==.), (.|-.), (./\.), (.\/.), (.-.), (./.), (.\.), (.:.), (.!.), (.*.) + , (.==.), (.|-.), (./\.), (.\/.), (.-.), (./.), (.\.), (.<>.), (.:.), (.!.), (.*.) , deMorganERad, deMorganECps, deMorganEUni, deMorganEIsc - , exprUni2list, exprIsc2list, exprCps2list, exprRad2list + , exprUni2list, exprIsc2list, exprCps2list, exprRad2list, exprPrd2list -- * Functions with plugs: , plugFields, tblcontents, plugpath, fldauto, requires, requiredFields, isPlugIndex -- * Parser related stuff @@ -92,7 +91,8 @@ -- * Stuff that should probably not be in the prototype , A_Markup(..), blocks2String, aMarkup2String, PandocFormat(..), Meaning(..) , rulefromProp - , Populated(..), Paire, Purpose(..), ExplObj(..), PictType(..) + , fullContents, Paire, srcPaire,trgPaire + , Purpose(..), ExplObj(..) ) where import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
src/lib/DatabaseDesign/Ampersand/ADL1.hs view
@@ -34,7 +34,6 @@ A_Concept(..) ,Sign(..),showSign,GenR() , (<==>),meet,join - ,Signaling(..) ,A_Context(..),Process(..) ,Association(..) ,Expression(..) @@ -53,12 +52,14 @@ ,RoleRelation(..) ,Population(..) ,Purpose(..), ExplObj(..) - , (.==.), (.|-.), (./\.), (.\/.), (.-.), (./.), (.\.), (.:.), (.!.), (.*.) + , (.==.), (.|-.), (./\.), (.\/.), (.-.), (./.), (.\.), (.<>.), (.:.), (.!.), (.*.) ) -import DatabaseDesign.Ampersand.ADL1.Expression as X ( - notCpl, isCpl, deMorganERad, deMorganECps, deMorganEUni, deMorganEIsc) +import DatabaseDesign.Ampersand.ADL1.Expression as X + ( notCpl, isCpl, deMorganERad, deMorganECps, deMorganEUni, deMorganEIsc + , exprIsc2list, exprUni2list, exprCps2list, exprRad2list, exprPrd2list + , insParentheses) import DatabaseDesign.Ampersand.ADL1.ECArule as X ( - isAll, isCHC, isBlk, isNop, isDo, dos) + isAll, isCHC, isBlk, isNop, isDo, eventsFrom) import DatabaseDesign.Ampersand.ADL1.Rule as X ( rulefromProp, ruleviolations ,consequent,antecedent,hasantecedent)
src/lib/DatabaseDesign/Ampersand/ADL1/Disambiguate.hs view
@@ -127,6 +127,9 @@ disambInfo (PRrs o a b) (ia1,ib1) = ( PRrs o a' b', (ia, ib) ) where (a', (ic1,ia)) = disambInfo a (ic2,ia1) (b', (ic2,ib)) = disambInfo b (ic1,ib1)+ disambInfo (PDia o a b) (ia1,ib1) = ( PDia o a' b', (ia, ib) )+ where (a', (ia,ic1)) = disambInfo a (ia1,ic2)+ (b', (ib,ic2)) = disambInfo b (ib1,ic1) disambInfo (PCps o a b) (ia1,ib1) = ( PCps o a' b', (ia, ib) ) where (a', (ia,ic1)) = disambInfo a (ia1,ic2) (b', (ic2,ib)) = disambInfo b (ic1,ib1)@@ -143,7 +146,7 @@ | Ident | Vee | Mp1 String- | Known Expression+ | Known Expression deriving Show -- Here, deriving Show serves debugging purposes only. -- get concept: gc :: Association expr => SrcOrTgt -> expr -> String
src/lib/DatabaseDesign/Ampersand/ADL1/ECArule.hs view
@@ -4,10 +4,10 @@ , isBlk , isNop , isDo - , dos - + , eventsFrom ) where +import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree import DatabaseDesign.Ampersand.Fspec.Fspec import DatabaseDesign.Ampersand.Basics (fatalMsg) @@ -25,7 +25,6 @@ fatal :: Int -> String -> a fatal = fatalMsg "ADL1.ECArule" - isAll :: PAclause -> Bool isAll ALL{} = True @@ -47,18 +46,31 @@ isDo Do{} = True isDo _ = False -dos :: PAclause -> [PAclause] -- gather all Do's from a PAclause -dos p@CHC{} = concatMap dos (paCls p) -dos p@ALL{} = concatMap dos (paCls p) -dos p@Do{} = [p] -dos p@Sel{} = dos (paCl p "x") -dos p@New{} = dos (paCl p "x") -dos p@Rmv{} = dos (paCl p "x") -dos Nop{} = [] -dos Blk{} = [] -dos Let{} = fatal 56 "dos not defined for `Let` constructor of PAclause" -dos Ref{} = fatal 57 "dos not defined for `Ref` constructor of PAclause" +{- + | Do { paSrt :: InsDel -- do Insert or Delete + , paTo :: Declaration -- into toExpr or from toExpr + , paDelta :: Expression -- delta + , paMotiv :: [(Expression,[Rule] )] - - - + | New { paCpt :: A_Concept -- make a new instance of type c + , paCl :: String->PAclause -- to be done after creating the concept + , paMotiv :: [(Expression,[Rule] )] + } + | Rmv { paCpt :: A_Concept -- Remove an instance of type c + , paCl :: String->PAclause -- to be done afteremoving the concept + , paMotiv :: [(Expression,[Rule] )] + } +-} + +-- | eventsFrom is written for constructing switchboard diagrams. +eventsFrom :: PAclause -> [Event] -- gather all Do's from a PAclause +eventsFrom p@CHC{} = concatMap eventsFrom (paCls p) +eventsFrom p@GCH{} = concatMap eventsFrom [ paClause | (_,_,paClause)<-paGCls p] +eventsFrom p@ALL{} = concatMap eventsFrom (paCls p) +eventsFrom (Do tOp dcl _ _) = [On tOp dcl] +eventsFrom p@New{} = On Ins (Isn (paCpt p)): eventsFrom (paCl p "x") +eventsFrom p@Rmv{} = On Del (Isn (paCpt p)): eventsFrom (paCl p "x") +eventsFrom Nop{} = [] +eventsFrom Blk{} = [] +eventsFrom Let{} = fatal 56 "eventsFrom not defined for `Let` constructor of PAclause" +eventsFrom Ref{} = fatal 57 "eventsFrom not defined for `Ref` constructor of PAclause"
src/lib/DatabaseDesign/Ampersand/ADL1/Expression.hs view
@@ -3,11 +3,14 @@ module DatabaseDesign.Ampersand.ADL1.Expression ( subst ,foldlMapExpression,foldrMapExpression - ,primitives,isMp1 - ,isPos,isNeg, deMorganERad, deMorganECps, deMorganEUni, deMorganEIsc, notCpl, isCpl) + ,primitives,isMp1, isEEps + ,isPos,isNeg, deMorganERad, deMorganECps, deMorganEUni, deMorganEIsc, notCpl, isCpl + ,exprIsc2list, exprUni2list, exprCps2list, exprRad2list, exprPrd2list + ,insParentheses) where import DatabaseDesign.Ampersand.Basics (uni) import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree +--import Debug.Trace -- fatal :: Int -> String -> a -- fatal = fatalMsg "ADL1.Expression" @@ -25,6 +28,7 @@ subs (EDif (l,r)) = EDif (subs l,subs r) subs (ELrs (l,r)) = ELrs (subs l,subs r) subs (ERrs (l,r)) = ERrs (subs l,subs r) + subs (EDia (l,r)) = EDia (subs l,subs r) subs (ECps (l,r)) = ECps (subs l,subs r) subs (ERad (l,r)) = ERad (subs l,subs r) subs (EPrd (l,r)) = EPrd (subs l,subs r) @@ -51,6 +55,7 @@ foldrMapExpression f g a (EDif (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r foldrMapExpression f g a (ELrs (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r foldrMapExpression f g a (ERrs (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r +foldrMapExpression f g a (EDia (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r foldrMapExpression f g a (ECps (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r foldrMapExpression f g a (ERad (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r foldrMapExpression f g a (EPrd (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r @@ -75,6 +80,7 @@ (EDif (l,r)) -> primitives l `uni` primitives r (ELrs (l,r)) -> primitives l `uni` primitives r (ERrs (l,r)) -> primitives l `uni` primitives r + (EDia (l,r)) -> primitives l `uni` primitives r (ECps (l,r)) -> primitives l `uni` primitives r (ERad (l,r)) -> primitives l `uni` primitives r (EPrd (l,r)) -> primitives l `uni` primitives r @@ -133,3 +139,82 @@ isMp1 :: Expression -> Bool isMp1 EMp1{} = True isMp1 _ = False + +isEEps :: Expression -> Bool +isEEps EEps{} = True +isEEps _ = False + +exprIsc2list, exprUni2list, exprCps2list, exprRad2list, exprPrd2list :: Expression -> [Expression] +exprIsc2list (EIsc (l,r)) = exprIsc2list l++exprIsc2list r +exprIsc2list r = [r] +exprUni2list (EUni (l,r)) = exprUni2list l++exprUni2list r +exprUni2list r = [r] +exprCps2list (ECps (l,r)) = exprCps2list l++exprCps2list r +exprCps2list r = [r] +exprRad2list (ERad (l,r)) = exprRad2list l++exprRad2list r +exprRad2list r = [r] +exprPrd2list (EPrd (l,r)) = exprPrd2list l++exprPrd2list r +exprPrd2list r = [r] + +insParentheses :: Expression -> Expression +insParentheses expr = insPar 0 expr + where + wrap :: Integer -> Integer -> Expression -> Expression + wrap i j e' = if i<=j then e' else EBrk (insPar 0 e') + insPar :: Integer -> Expression -> Expression + insPar i (EEqu (l,r)) = wrap i 0 (insPar 1 l .==. insPar 1 r) + insPar i (EImp (l,r)) = wrap i 0 (insPar 1 l .|-. insPar 1 r) + insPar i x@EIsc{} = wrap i 2 (foldr1 (./\.) [insPar 3 e | e<-exprIsc2list x ]) + insPar i x@EUni{} = wrap i 2 (foldr1 (.\/.) [insPar 3 e | e<-exprUni2list x ]) + insPar i (EDif (l,r)) = wrap i 4 (insPar 5 l .-. insPar 5 r) + insPar i (ELrs (l,r)) = wrap i 6 (insPar 7 l ./. insPar 7 r) + insPar i (ERrs (l,r)) = wrap i 6 (insPar 7 l .\. insPar 7 r) + insPar i (EDia (l,r)) = wrap i 6 (insPar 7 l .<>. insPar 7 r) + insPar i x@ECps{} = wrap i 8 (foldr1 (.:.) [insPar 9 e | e<-exprCps2list x ]) + insPar i x@ERad{} = wrap i 8 (foldr1 (.!.) [insPar 9 e | e<-exprRad2list x ]) + insPar i x@EPrd{} = wrap i 8 (foldr1 (.*.) [insPar 9 e | e<-exprPrd2list x ]) + insPar _ (EKl0 e) = EKl0 (insPar 10 e) + insPar _ (EKl1 e) = EKl1 (insPar 10 e) + insPar _ (EFlp e) = EFlp (insPar 10 e) + insPar _ (ECpl e) = ECpl (insPar 10 e) + insPar i (EBrk e) = insPar i e + insPar _ x = x + +{- + insPar 0 (r/\s/\t/\x/\y |- p) += + wrap 0 0 (insPar 1 (r/\s/\t/\x/\y) |- insPar 1 p) += + insPar 1 (r/\s/\t/\x/\y) |- insPar 1 p += + wrap 1 2 (foldr1 f [insPar 3 e | e<-exprIsc2list (r/\s/\t/\x/\y) ]) |- p where f x y = EIsc (x,y) += + foldr1 f [insPar 3 e | e<-exprIsc2list (r/\s/\t/\x/\y) ] |- p where f x y = EIsc (x,y) += + foldr1 f [insPar 3 e | e<-[r,s,t,x,y] ] |- p where f x y = EIsc (x,y) += + foldr1 f [insPar 3 r,insPar 3 s,insPar 3 t,insPar 3 x,insPar 3 y] |- p where f x y = EIsc (x,y) += + foldr1 f [r,s,t,x,y] |- p where f x y = EIsc (x,y) += + r/\s/\t/\x/\y |- p + + + + insPar 0 (r;s;t;x;y |- p) += + wrap 0 0 (insPar 1 (r;s;t;x;y) |- insPar 1 p) += + insPar 1 (r;s;t;x;y) |- insPar 1 p += + wrap 1 8 (insPar 8 r ; insPar 8 (s;t;x;y)) |- p += + r; insPar 8 (s;t;x;y) |- p += + r; wrap 8 8 (insPar 8 s; insPar 8 (t;x;y)) |- p += + r; insPar 8 s; insPar 8 (t;x;y) |- p += + r; s; insPar 8 (t;x;y) |- p +-} +
src/lib/DatabaseDesign/Ampersand/ADL1/P2A_Converters.hs view
@@ -7,6 +7,8 @@ import DatabaseDesign.Ampersand.Input.ADL1.CtxError import DatabaseDesign.Ampersand.ADL1.Lattices import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree hiding (sortWith, maxima, greatest) +import DatabaseDesign.Ampersand.Classes.ViewPoint hiding (interfaces,gens) +import DatabaseDesign.Ampersand.Classes.ConceptStructure import DatabaseDesign.Ampersand.Basics (Identified(name), fatalMsg) import DatabaseDesign.Ampersand.Misc import Prelude hiding (head, sequence, mapM) @@ -15,7 +17,7 @@ import qualified Data.Set as Set import qualified Data.Map as Map import Data.Maybe -import Data.List(nub, intercalate) +import Data.List(nub) head :: [a] -> a head [] = fatal 30 "head must not be used on an empty list!" @@ -31,7 +33,19 @@ (==) (SignOrd (Sign a b)) (SignOrd (Sign c d)) = (name a,name b) == (name c,name d) pCtx2aCtx :: P_Context -> Guarded A_Context -pCtx2aCtx +pCtx2aCtx pCtx = finalChecksOnAContext <?> pCtx2aCtx' pCtx + where + finalChecksOnAContext :: A_Context -> Guarded A_Context + finalChecksOnAContext ctx = checkUniqueRuleNames + where + checkUniqueRuleNames + = case uniqueNames (udefrules ctx) of + Checked _ -> Checked ctx + Errors err -> Errors err + + +pCtx2aCtx' :: P_Context -> Guarded A_Context +pCtx2aCtx' PCtx { ctx_nm = n1 , ctx_pos = n2 , ctx_lang = lang @@ -40,14 +54,14 @@ , ctx_pats = p_patterns -- The patterns defined in this context , ctx_PPrcs = p_processes -- The processes as defined by the parser , ctx_rs = p_rules -- All user defined rules in this context, but outside patterns and outside processes - , ctx_ds = p_declarations -- The declarations defined in this context, outside the scope of patterns + , ctx_ds = p_declarations -- The relations declared in this context, outside the scope of patterns , ctx_cs = p_conceptdefs -- The concept definitions defined in this context, outside the scope of patterns , ctx_ks = p_identdefs -- The identity definitions defined in this context, outside the scope of patterns , ctx_vs = p_viewdefs -- The view definitions defined in this context, outside the scope of patterns , ctx_gs = p_gens -- The gen definitions defined in this context, outside the scope of patterns , ctx_ifcs = p_interfaces -- The interfaces defined in this context, outside the scope of patterns , ctx_ps = p_purposes -- The purposes defined in this context, outside the scope of patterns - , ctx_pops = p_pops -- The populations defined in this context + , ctx_pops = p_pops -- The populations defined in this context, but outside patterns and outside processes , ctx_sql = p_sqldefs -- user defined sqlplugs, taken from the Ampersand script , ctx_php = p_phpdefs -- user defined phpplugs, taken from the Ampersand script , ctx_metas = p_metas -- generic meta information (name/value pairs) that can be used for experimenting without having to modify the adl syntax @@ -62,7 +76,7 @@ , ctxprocs = procs , ctxrs = rules , ctxds = ctxDecls - , ctxpopus = nub (udpops++ dclPops) + , ctxpopus = nub (udpops++dclPops++mp1Pops rules++mp1Pops pats++mp1Pops procs++mp1Pops identdefs++mp1Pops viewdefs++mp1Pops interfaces) , ctxcds = allConceptDefs , ctxks = identdefs , ctxvs = viewdefs @@ -76,7 +90,7 @@ } ) <$> traverse pPat2aPat p_patterns -- The patterns defined in this context <*> traverse pProc2aProc p_processes -- The processes defined in this context - <*> traverse (pRul2aRul [] n1) p_rules -- All user defined rules in this context, but outside patterns and outside processes + <*> traverse (pRul2aRul [] n1) p_rules -- All user defined rules in this context, but outside patterns and outside processes <*> traverse pIdentity2aIdentity p_identdefs -- The identity definitions defined in this context, outside the scope of patterns <*> traverse pViewDef2aViewDef p_viewdefs -- The view definitions defined in this context, outside the scope of patterns <*> traverse pIfc2aIfc p_interfaces -- The interfaces defined in this context, outside the scope of patterns @@ -102,14 +116,14 @@ soloConcs = filter (not . isInSystem genLattice) (Set.toList allConcs) deflangCtxt = fromMaybe English lang -- explanation: if lang==Nothing, then English, if lang==Just l then l - deffrmtCtxt = fromMaybe HTML pandocf + deffrmtCtxt = fromMaybe ReST pandocf (decls,dclPops)= unzip dps (ctxDecls,_ ) = unzip ctxDecls' dps = ctxDecls'++patDecls++patProcs - ctxDecls' = [ pDecl2aDecl n1 deflangCtxt deffrmtCtxt pDecl | pDecl<-p_declarations ] -- The declarations defined in this context, outside the scope of patterns - patDecls = [ pDecl2aDecl (name pat) deflangCtxt deffrmtCtxt pDecl | pat<-p_patterns, pDecl<-pt_dcs pat ] -- The declarations defined in all patterns within this context. - patProcs = [ pDecl2aDecl (name prc) deflangCtxt deffrmtCtxt pDecl | prc<-p_processes, pDecl<-procDcls prc ] -- The declarations defined in all processes within this context. + ctxDecls' = [ pDecl2aDecl n1 deflangCtxt deffrmtCtxt pDecl | pDecl<-p_declarations ] -- The relations declared in this context, outside the scope of patterns + patDecls = [ pDecl2aDecl (name pat) deflangCtxt deffrmtCtxt pDecl | pat<-p_patterns, pDecl<-pt_dcs pat ] -- The relations declared in all patterns within this context. + patProcs = [ pDecl2aDecl (name prc) deflangCtxt deffrmtCtxt pDecl | prc<-p_processes, pDecl<-procDcls prc ] -- The relations declared in all processes within this context. declMap = Map.map groupOnTp (Map.fromListWith (++) [(name d,[d]) | d <- decls]) where groupOnTp lst = Map.fromListWith accumDecl [(SignOrd$ sign d,d) | d <- lst] @@ -117,7 +131,7 @@ findDecl o x = getOneExactly o . Map.elems $ findDecls x findDeclsTyped x tp = Map.findWithDefault [] (SignOrd tp) (Map.map (:[]) (findDecls x)) findDeclTyped o x tp = getOneExactly o (findDeclsTyped x tp) - -- accumDecl is the function that combines two declarations into one + -- accumDecl is the function that combines two relations into one -- meanings, for instance, two should get combined into a list of meanings, et cetera -- positions are combined -- TODO @@ -138,11 +152,9 @@ , decprM = dec_prM pd , decprR = dec_prR pd , decMean = pMean2aMean defLanguage defFormat (dec_Mean pd) - , decConceptDef = dec_conceptDef pd , decfpos = dec_fpos pd , deciss = True , decusr = True - , decISA = False , decpat = patNm , decplug = dec_plug pd } @@ -153,13 +165,11 @@ pGen2aGen :: P_Gen -> A_Gen pGen2aGen pg@PGen{} - = Isa{genfp = gen_fp pg - ,gengen = pCpt2aCpt (gen_gen pg) + = Isa{gengen = pCpt2aCpt (gen_gen pg) ,genspc = pCpt2aCpt (gen_spc pg) } pGen2aGen pg@P_Cy{} - = IsE { genfp = gen_fp pg - , genrhs = map pCpt2aCpt (gen_rhs pg) + = IsE { genrhs = map pCpt2aCpt (gen_rhs pg) , genspc = pCpt2aCpt (gen_spc pg) } @@ -301,10 +311,11 @@ PIsc _ a b -> binary (./\.) (ISC (Src,fst) (Src,snd), ISC (Tgt,fst) (Tgt,snd)) <?> ((,)<$>tt a<*>tt b) PUni _ a b -> binary (.\/.) (UNI (Src,fst) (Src,snd), UNI (Tgt,fst) (Tgt,snd)) <?> ((,)<$>tt a<*>tt b) PDif _ a b -> binary (.-.) (MBG (Src,fst) (Src,snd), MBG (Tgt,fst) (Tgt,snd)) <?> ((,)<$>tt a<*>tt b) - PLrs _ a b -> binary' (./.) (MBG (Tgt,snd) (Tgt,fst)) ((Src,fst),(Src,snd)) <?> ((,)<$>tt a<*>tt b) - PRrs _ a b -> binary' (.\.) (MBG (Src,fst) (Src,snd)) ((Tgt,fst),(Tgt,snd)) <?> ((,)<$>tt a<*>tt b) - PCps _ a b -> binary' (.:.) (ISC (Tgt,fst) (Src,snd)) ((Src,fst),(Tgt,snd)) <?> ((,)<$>tt a<*>tt b) - PRad _ a b -> binary' (.!.) (MBE (Tgt,fst) (Src,snd)) ((Src,fst),(Tgt,snd)) <?> ((,)<$>tt a<*>tt b) + PLrs _ a b -> binary' (./.) (MBG (Tgt,snd) (Tgt,fst)) ((Src,fst),(Src,snd)) Tgt Tgt <?> ((,)<$>tt a<*>tt b) + PRrs _ a b -> binary' (.\.) (MBG (Src,fst) (Src,snd)) ((Tgt,fst),(Tgt,snd)) Src Src <?> ((,)<$>tt a<*>tt b) + PDia _ a b -> binary' (.<>.) (ISC (Tgt,fst) (Src,snd)) ((Src,fst),(Tgt,snd)) Tgt Src <?> ((,)<$>tt a<*>tt b) -- MBE would have been correct, but too restrictive + PCps _ a b -> binary' (.:.) (ISC (Tgt,fst) (Src,snd)) ((Src,fst),(Tgt,snd)) Tgt Src <?> ((,)<$>tt a<*>tt b) + PRad _ a b -> binary' (.!.) (MBE (Tgt,fst) (Src,snd)) ((Src,fst),(Tgt,snd)) Tgt Src <?> ((,)<$>tt a<*>tt b) -- Using MBE instead of ISC allows the programmer to use De Morgan PPrd _ a b -> (\((x,(s,_)),(y,(_,t))) -> (x .*. y, (s,t))) <$> ((,)<$>tt a<*>tt b) PKl0 _ a -> unary EKl0 (UNI (Src, id) (Tgt, id), UNI (Src, id) (Tgt, id)) <?> tt a PKl1 _ a -> unary EKl1 (UNI (Src, id) (Tgt, id), UNI (Src, id) (Tgt, id)) <?> tt a @@ -344,12 +355,17 @@ ) -- simple instruction on how to derive the type -> ((Expression,(Bool,Bool)), (Expression,(Bool,Bool))) -- expressions to feed into the combinator after translation -> Guarded (Expression,(Bool,Bool)) - binary cbn tp (e1,e2) = wrap'' cbn (fst e1,fst e2) <$> deriv tp (e1,e2) - unary cbn tp e1 = wrap cbn (fst e1 ) <$> deriv tp e1 - binary' cbn cpt tp (e1,e2) = wrap' cbn (fst e1,fst e2) <$> deriv1 o (fmap (resolve (e1,e2)) cpt) <*> deriv' tp (e1,e2) - wrap'' f (e1,e2) ((src,b1), (tgt,b2)) = (f (addEpsilon src tgt e1) (addEpsilon src tgt e2), (b1, b2)) - wrap f expr ((src,b1), (tgt,b2)) = (f (addEpsilon src tgt expr), (b1, b2)) - wrap' f (e1,e2) (cpt,_) ((_,b1), (_,b2)) = (f (addEpsilonRight' cpt e1) (addEpsilonLeft' cpt e2), (b1, b2)) + binary cbn tp (e1,e2) = wrap (fst e1,fst e2) <$> deriv tp (e1,e2) + where + wrap (expr1,expr2) ((src,b1), (tgt,b2)) = (cbn (addEpsilon src tgt expr1) (addEpsilon src tgt expr2), (b1, b2)) + unary cbn tp e1 = wrap (fst e1) <$> deriv tp e1 + where + wrap expr ((src,b1), (tgt,b2)) = (cbn (addEpsilon src tgt expr), (b1, b2)) + binary' cbn preConcept tp side1 side2 (e1,e2) = wrap (fst e1,fst e2) <$> deriv1 o (fmap (resolve (e1,e2)) preConcept) <*> deriv' tp (e1,e2) + where + wrap (expr1,expr2) (cpt,_) ((_,b1), (_,b2)) + = (cbn (lrDecide side1 expr1) (lrDecide side2 expr2), (b1, b2)) + where lrDecide side e = case side of Src -> addEpsilonLeft' cpt e; Tgt -> addEpsilonRight' cpt e deriv (t1,t2) es = (,) <$> deriv1 o (fmap (resolve es) t1) <*> deriv1 o (fmap (resolve es) t2) deriv1 o x' @@ -438,7 +454,7 @@ , prcRules = map snd ruls' , prcGens = map pGen2aGen gens , prcDcls = decls' - , prcUps = nub $ pops' ++ dPops + , prcUps = pops' ++ [ dp | dp@PRelPopu{}<-dPops, (not.null.popps) dp ] ++ [ cp | cp@PCptPopu{}<-dPops, (not.null.popas) cp ] , prcRRuls = [(rol,r)|(rols,r)<-ruls',rol<-rols] , prcRRels = [(rol,r)|(rols,rs)<-rels',rol<-rols,r<-rs] , prcIds = idefs' @@ -464,7 +480,7 @@ , ptrls = map snd prules , ptgns = agens' , ptdcs = decls' - , ptups = nub $ pops' ++ dPops + , ptups = pops' ++ [ dp | dp@PRelPopu{}<-dPops, (not.null.popps) dp ] ++ [ cp | cp@PCptPopu{}<-dPops, (not.null.popas) cp ] , ptrruls = [(rol,r)|(rols,r)<-prules,rol<-rols] , ptrrels = [(rol,dcl)|rr<-rrels', rol<-rrRoles rr, dcl<-rrRels rr] -- The assignment of roles to Relations. , ptids = keys' @@ -510,7 +526,7 @@ , rrdcl = Nothing , r_env = env , r_usr = UserDefined - , r_sgl = not (null sgl) + , isSignal = not (null sgl) , srrel = Sgn{ decnm = nm , decsgn = (sign exp') , decprps = [] @@ -519,11 +535,9 @@ , decprM = "" , decprR = "" , decMean = pMean2aMean deflangCtxt deffrmtCtxt meanings - , decConceptDef = Nothing , decfpos = orig , deciss = True , decusr = False - , decISA = False , decpat = env , decplug = False }
src/lib/DatabaseDesign/Ampersand/ADL1/Pair.hs view
@@ -3,59 +3,23 @@ {-# LANGUAGE FlexibleInstances #-} module DatabaseDesign.Ampersand.ADL1.Pair ( Paire,Pairs - , kleenejoin , srcPaire,trgPaire , mkPair - , closPair - , clos1 ) where - import DatabaseDesign.Ampersand.Basics (Collection(isc,uni),eqCl) - import Data.List (nub) - import GHC.Exts (sortWith) type Pairs = [Paire] srcPaire :: Paire -> String trgPaire :: Paire -> String - mkPair :: String -> String -> Paire type Paire = (String,String) + mkPair :: String -> String -> Paire mkPair a b = (a,b) srcPaire = fst trgPaire = snd +-- data Paire = Paire {srcPaire ::String +-- ,trgPaire ::String +-- } deriving (Show ,Eq) +-- mkPair = Paire - -- | Operations for representations that act as a Kleene algebra (RA without complement and with the closure operators) - -- | A Kleene algebra has two binary operations 'union' and 'kleenejoin', and one function 'closure' (usually written as +, � and * respectively) - class KAComputable a where - kleenejoin :: a->a->a - closPair :: a->a - -- TODO: add the 'uni' operator - - instance (KAComputable a) => KAComputable (Maybe a) where - kleenejoin (Just a) (Just b) = Just (kleenejoin a b) - kleenejoin _ _ = Nothing - closPair (Just p) = Just (closPair p) - closPair _ = Nothing - - instance KAComputable Pairs where - kleenejoin a b = merge ((sortWith (trgPaire.head).eqCl trgPaire) a) - ((sortWith (srcPaire.head).eqCl srcPaire) b) - where merge (xs:xss) (ys:yss) - | trgPaire (head xs)<srcPaire (head ys) = merge xss (ys:yss) - | trgPaire (head xs)>srcPaire (head ys) = merge (xs:xss) yss - | otherwise = [mkPair (srcPaire x) (trgPaire y) |x<-xs,y<-ys]++ merge xss yss - merge _ _ = [] - closPair ps = toPairs (clos1 (toList ps)) - where - toPairs :: [(String,String)] -> Pairs - toPairs pairs = [mkPair a b | (a,b)<-pairs] - toList :: Pairs -> [(String,String)] - toList pairs = [(srcPaire p, trgPaire p) | p<-pairs] ----------------------------------------------------- --- Warshall's transitive closure algorithm in Haskell: ----------------------------------------------------- - clos1 :: (Eq a) => [(a,a)] -> [(a,a)] -- e.g. a list of pairs - clos1 xs - = foldl f xs (nub (map fst xs) `isc` nub (map snd xs)) - where - f q x = q `uni` [(a, b') | (a, b) <- q, b == x, (a', b') <- q, a' == x] +
src/lib/DatabaseDesign/Ampersand/ADL1/Rule.hs view
@@ -5,7 +5,7 @@ import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree import DatabaseDesign.Ampersand.Basics import DatabaseDesign.Ampersand.Core.ParseTree ( Prop(..)) - import DatabaseDesign.Ampersand.Classes.Populated ( Populated(..)) + import DatabaseDesign.Ampersand.Classes.Populated ( fullContents) import DatabaseDesign.Ampersand.Misc fatal :: Int -> String -> a @@ -41,7 +41,7 @@ crc = fullContents gens pt (consequent r) -- rulefromProp specifies a rule that defines property prp of declaration d. --- The table of all declarations is provided, in order to generate shorter names if possible. +-- The table of all relations is provided, in order to generate shorter names if possible. rulefromProp :: Prop -> Declaration -> Rule rulefromProp prp d@Sgn{} = Ru { rrnm = show prp++" "++name d++"::"++s++"*"++t @@ -54,7 +54,7 @@ , rrdcl = Just (prp,d) -- For traceability: The original property and declaration. , r_env = decpat d -- For traceability: The name of the pattern. Unknown at this position but it may be changed by the environment. , r_usr = Multiplicity - , r_sgl = False + , isSignal = False , srrel = d{decnm=show prp++name d} } where @@ -62,7 +62,9 @@ t = name (target d) r:: Expression r = EDcD d - rExpr = case prp of + rExpr = if not (isEndo r) && prp `elem` [Sym, Asy, Trn, Rfx, Irf] + then fatal 70 ("Illegal property of an endo relation "++show (name d)) else + case prp of Uni-> flp r .:. r .|-. EDcI (target r) Tot-> EDcI (source r) .|-. r .:. flp r Inj-> r .:. flp r .|-. EDcI (source r) @@ -71,7 +73,7 @@ Asy-> flp r ./\. r .|-. EDcI (source r) Trn-> r .:. r .|-. r Rfx-> EDcI (source r) .|-. r - Irf-> EDcI (source r) ./\. (EDcV (sign r) .-. r) + Irf-> r .|-. ECpl (EDcI (source r)) explain isPositive prop = [ A_Markup English ReST (string2Blocks ReST ( case prop of Sym-> state isPositive English (name d++"["++s++"]") "symmetric" @@ -102,4 +104,4 @@ state False English left right = left ++ " is not " ++ right state False Dutch left right = left ++ " is niet " ++ right - rulefromProp _ _ = fatal 252 "Properties can only be set on user-defined declarations." + rulefromProp _ _ = fatal 252 "Properties can only be set on user-defined relations."
src/lib/DatabaseDesign/Ampersand/Basics/Auxiliaries.hs view
@@ -1,13 +1,5 @@ {-# OPTIONS_GHC -Wall #-} module DatabaseDesign.Ampersand.Basics.Auxiliaries - ( eqCl - , eqClass - , getCycles - , combinations - , commaEng - , commaNL - , Flippable(..) - ) where import Data.List (nub,elemIndex) import Data.Graph (stronglyConnComp, SCC(CyclicSCC)) @@ -61,7 +53,13 @@ commaNL str (a:as) = a++", "++commaNL str as commaNL _ [] = "" - + fst3 :: (a,b,c)->a + snd3 :: (a,b,c)->b + thd3 :: (a,b,c)->c + fst3 (a,_,_) = a + snd3 (_,b,_) = b + thd3 (_,_,c) = c + class Flippable a where flp :: a -> a
src/lib/DatabaseDesign/Ampersand/Basics/BuildInfo_Generated.hs view
@@ -4,12 +4,12 @@ {-# NOINLINE cabalVersionStr #-} cabalVersionStr :: String -cabalVersionStr = "3.0.1" +cabalVersionStr = "3.0.2" {-# NOINLINE svnRevisionStr #-} svnRevisionStr :: String -svnRevisionStr = "1305M" +svnRevisionStr = "1366" {-# NOINLINE buildTimeStr #-} buildTimeStr :: String -buildTimeStr = "15-Mar-14 12:32:56 UTC" +buildTimeStr = "15-Jun-14 20:03:10 UTC"
src/lib/DatabaseDesign/Ampersand/Classes.hs view
@@ -1,9 +1,9 @@ {-# OPTIONS_GHC -Wall #-} module DatabaseDesign.Ampersand.Classes (module X) where import DatabaseDesign.Ampersand.Classes.Populated as X - (Populated(..),atomsOf) + (fullContents,atomsOf) import DatabaseDesign.Ampersand.Classes.ConceptStructure as X - (ConceptStructure(..)) + (ConceptStructure(..),prim2rel) import DatabaseDesign.Ampersand.Classes.Relational as X (Relational(..)) import DatabaseDesign.Ampersand.Classes.ViewPoint as X
src/lib/DatabaseDesign/Ampersand/Classes/ConceptStructure.hs view
@@ -1,7 +1,6 @@ {-# OPTIONS_GHC -Wall #-} {-# LANGUAGE FlexibleInstances #-} -module DatabaseDesign.Ampersand.Classes.ConceptStructure (ConceptStructure(..) - ) +module DatabaseDesign.Ampersand.Classes.ConceptStructure (ConceptStructure(..), prim2rel) where import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree import DatabaseDesign.Ampersand.Core.ParseTree (ConceptDef(..)) @@ -15,22 +14,34 @@ class ConceptStructure a where concs :: a -> [A_Concept] -- ^ the set of all concepts used in data structure a - declsUsedIn :: a -> [Declaration] -- ^ the set of all declaratons used within data structure a. `used within` means that there is a relation that refers to that declaration. - declsUsedIn a = [ d | EDcD d@Sgn{}<-(nub.concatMap primitives.expressionsIn) a] relsUsedIn :: a -> [Declaration] -- ^ the set of all declaratons used within data structure a. `used within` means that there is a relation that refers to that declaration. - relsUsedIn a = [ prim2dcl e | e<-nub ((concatMap primitives.expressionsIn) a++(map EDcI . concs) a), not (isMp1 e) ] - where prim2dcl expr = - case expr of - EDcD d@Sgn{} -> d - EDcD{} -> fatal 23 "invalid declaration in EDcD{}" - EDcI c -> Isn c - EDcV sgn -> Vs sgn - EMp1{} -> fatal 25 "EMp1 should be filtered out from primitives. use `filter (not isMp1)`" - _ -> fatal 26 "prim2dcl is not supposed to be called on a non-primitive expression." + relsUsedIn a = [ d | d@Sgn{}<-relsMentionedIn a]++[Isn c | c<-concs a] + relsMentionedIn :: a -> [Declaration] -- ^ the set of all declaratons used within data structure a. `used within` means that there is a relation that refers to that declaration. + relsMentionedIn = nub . map prim2rel . primsMentionedIn + primsMentionedIn :: a -> [Expression] + primsMentionedIn = nub . concatMap primitives . expressionsIn expressionsIn :: a -> [Expression] -- ^The set of all expressions within data structure a mp1Exprs :: a -> [Expression] -- ^ the set of all EMp1 expressions within data structure a (needed to get the atoms of these relations into the populationtable) - mp1Exprs = filter isMp1.nub.concatMap primitives.expressionsIn + mp1Exprs = filter isMp1.primsMentionedIn + -- | mp1Pops draws the population from singleton expressions. + 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 @@ -146,7 +157,7 @@ ] instance ConceptStructure Interface where - concs ifc = concs (ifcObj ifc) + concs ifc = concs (ifcObj ifc) expressionsIn ifc = foldr (uni) [] [ (expressionsIn.ifcObj) ifc , (expressionsIn.ifcParams) ifc
src/lib/DatabaseDesign/Ampersand/Classes/Populated.hs view
@@ -1,133 +1,111 @@ {-# OPTIONS_GHC -Wall #-} -module DatabaseDesign.Ampersand.Classes.Populated (Populated(..),atomsOf) +module DatabaseDesign.Ampersand.Classes.Populated (fullContents,atomsOf) +{- This file contains all functions to compute populations. + The implementation is done through Haskell's Map mechanism, as defined in Data.Map, for reasons of efficiency. +-} where - import DatabaseDesign.Ampersand.ADL1.Pair (kleenejoin,mkPair,closPair,srcPaire,trgPaire) + import Prelude hiding (lookup) + import DatabaseDesign.Ampersand.ADL1.Pair import DatabaseDesign.Ampersand.ADL1.Expression (notCpl) import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree - import DatabaseDesign.Ampersand.Classes.Relational - import DatabaseDesign.Ampersand.Basics (Collection (..),fatalMsg, Identified(..)) - import qualified Data.Map as Map + import DatabaseDesign.Ampersand.Basics (Collection (uni,isc,(>-)),fatalMsg, Identified(..)) + import Data.Map (Map, (!), lookup, keys, assocs, elems, fromList, fromListWith, unionWith, unionsWith, differenceWith, mergeWithKey, empty) + -- WHY: don't we use strict Maps? Since the sets of atoms and pairs are finite, we might want the efficiency of strictness. + import Data.Maybe (maybeToList) import Data.List (nub) fatal :: Int -> String -> a fatal = fatalMsg "Classes.Populated" - class Populated a where - -- | this function returns the pairs as content of a specific a, given a list of populations. - -- The list of populations should contain all user-defined populations. - fullContents :: [A_Gen] -> [Population] -> a -> Pairs - -- | This function returns the atoms of a concept (like fullContents does for relation-like things.) atomsOf :: [A_Gen] -- the generalisation relations from the context -> [Population] -- the user defined populations in the context -> A_Concept -- the concept from which the population is requested -> [String] -- the elements in the concept's set of atoms - atomsOf gens pt c = - case c of - ONE -> ["1"] -- fatal 126 "Asking for the value of the universal singleton" - PlainConcept{} - -> nub$ [srcPaire p | PRelPopu dcl ps <- pt, p <- ps, source dcl `elem` c:smallerConcepts gens c] - ++[trgPaire p | PRelPopu dcl ps <- pt, p <- ps, target dcl `elem` c:smallerConcepts gens c] - ++[a | PCptPopu cpt atms <- pt, a <- atms, cpt `elem` c:smallerConcepts gens c] - - instance Populated Declaration where - fullContents gens pt dcl - = case dcl of - Isn c -> [ mkPair a a | a <-atomsOf gens pt c] - Vs sgn -> [ mkPair sa ta | sa <-atomsOf gens pt (source sgn) - , ta <-atomsOf gens pt (target sgn)] - Sgn{} -> if decISA dcl - then [ mkPair a a | a <-atomsOf gens pt (source dcl)] - else concatMap popps (filter (isTheDecl dcl) pt) - where isTheDecl d pop = - case pop of - PRelPopu{} -> d == popdcl pop - PCptPopu{} -> False + atomsOf gens pt c + = case c of + ONE -> ["1"] -- fatal 22 "Asking for the value of the universal singleton" + PlainConcept{} + -> let smallerconcs = c:smallerConcepts gens c in + nub$ [srcPaire p | pop@PRelPopu{} <- pt, source (popdcl pop) `elem` smallerconcs, p <- popps pop] + ++[trgPaire p | pop@PRelPopu{} <- pt, target (popdcl pop) `elem` smallerconcs, p <- popps pop] + ++[a | pop@PCptPopu{} <- pt, popcpt pop `elem` smallerconcs, a <- popas pop] + pairsOf :: [A_Gen] -> [Population] -> Declaration -> Map String [String] + pairsOf gens pt dcl + = case dcl of + Isn c -> fromList [ (a,[a]) | a <-atomsOf gens pt c] + Vs sgn -> fromList [ (sa, atomsOf gens pt (target sgn)) | sa <-atomsOf gens pt (source sgn)] + Sgn{} -> unionsWith uni + [ fromListWith uni [ (srcPaire p,[trgPaire p]) | p<-popps pop] + | pop@PRelPopu{} <- pt + , name dcl==name (popdcl pop) + , let s=source (popdcl pop) in s `elem` s:smallerConcepts gens (source dcl) + , let t=target (popdcl pop) in t `elem` t:smallerConcepts gens (target dcl) + ] - instance Populated Expression where - fullContents gens pt = contents + fullContents :: [A_Gen] -> [Population] -> Expression -> Pairs + fullContents gens pt e = [ mkPair a b | let pairMap=contents e, a<-keys pairMap, b<-pairMap ! a ] where + unions t1 t2 = unionWith uni t1 t2 + inters t1 t2 = mergeWithKey (\_ l r ->case l `isc` r of [] -> Nothing; atoms -> Just atoms) c c t1 t2 + where c=const empty + differ t1 t2 = differenceWith (\l r->case l >- r of [] -> Nothing; atoms -> Just atoms) t1 t2 + contents :: Expression -> Map String [String] contents expr - = case expr of + = let lkp x contMap = (concat.maybeToList.lookup x) contMap in -- (!) may not be used, because we don't know whether x `elem` keys fmap + case expr of EEqu (l,r) -> contents ((l .|-. r) ./\. (r .|-. l)) EImp (l,r) -> contents (notCpl l .\/. r) - EUni (l,r) -> contents l `uni` contents r - EIsc (l,r) -> contents l `isc` contents r - EDif (l,r) -> contents l >- contents r + EUni (l,r) -> unions (contents l) (contents r) + EIsc (l,r) -> inters (contents l) (contents r) + EDif (l,r) -> differ (contents l) (contents r) -- The left residual l/r is defined by: for all x,y: x(l/r)y <=> for all z in X, y r z implies x l z. - ELrs (l,r) -> [(x,y) | let fL = Map.fromListWith (++) ([(a,[z]) | (a,z)<-contents l]++[(a,[]) | not (isTot l), a<-atomsOf gens pt (source l)]) - , let fR = Map.fromListWith (++) ([(b,[z]) | (b,z)<-contents r]++[(b,[]) | not (isTot r), b<-atomsOf gens pt (source r)]) - , x<-atomsOf gens pt (source l), y<-atomsOf gens pt (source r) - , null (fR Map.! y >- fL Map.! x) - ] + ELrs (l,r) -> fromListWith (++) + [(x,[y]) | x<-atomsOf gens pt (source l), y<-atomsOf gens pt (source r) + , null (lkp y (contents r) >- lkp x (contents l)) + ] -- The right residual l\r defined by: for all x,y: x(l\r)y <=> for all z in X, z l x implies z r y. - ERrs (l,r) -> [(x,y) | let fLflip = Map.fromListWith (++) ([(a,[z]) | (z,a)<-contents l]++[(a,[]) | not (isSur l), a<-atomsOf gens pt (target l)]) - , let fRflip = Map.fromListWith (++) ([(b,[z]) | (z,b)<-contents r]++[(b,[]) | not (isSur r), b<-atomsOf gens pt (target r)]) - , x<-atomsOf gens pt (target l), y<-atomsOf gens pt (target r) - , null (fLflip Map.! x >- fRflip Map.! y) - ] - ERad (l,r) -> [(x,y) | x <- case source l of - sl@PlainConcept{} -> atomsOf gens pt sl - sl -> fatal 97 ("source l should be PlainConcept instead of "++show sl++".") - , y <- case target r of - tr@PlainConcept{} -> atomsOf gens pt tr - tr -> fatal 100 ("target r should be PlainConcept instead of "++show tr++".") - , and [(x,z) `elem` contents l || (z,y) `elem` contents r | z<- atomsOf gens pt (target l) `uni` atomsOf gens pt (source r)] - ] - EPrd (l,r) -> [ (a,b) | a <- atomsOf gens pt (source l), b <- atomsOf gens pt (target r) ] - ECps (l,r) -> contents l `kleenejoin` contents r - EKl0 e -> if source e == target e --see #166 - then closPair (contents e `uni` contents (EDcI (source e))) - else fatal 69 ("source and target of "++show e++show (sign e)++ " are not equal.") - EKl1 e -> closPair (contents e) - EFlp e -> [(b,a) | (a,b)<-contents e] - ECpl e -> [apair | apair <-[ mkPair x y | x<-atomsOf gens pt (source e), y<-atomsOf gens pt (target e)] - , apair `notElem` contents e ] - EBrk e -> contents e - EDcD dcl -> fullContents gens pt dcl - EDcI c -> [mkPair a a | a <- atomsOf gens pt c] - EEps i _ -> [mkPair a a | a <- atomsOf gens pt i] - EDcV sgn -> [mkPair s t | s <- atomsOf gens pt (source sgn), t <- atomsOf gens pt (target sgn) ] - EMp1 a c -> [mkPair a a | name c/="SESSION"] -- prevent populating SESSION - -{- Derivation of contents (ERrs (l,r)): -The right residual l\r defined by: for all x,y: x(l\r)y <=> for all z in X, z l x implies z r y. - -Consider the following derivation in terms of list comprehension: - and [ (z,x) `elem` contents l -> (z,y) `elem` contents r | z<-contents (source l)] -= - and [ (z,x) `notElem` contents l || (z,y) `elem` contents r | z<-contents (source l)] -= - not ( or [not((z,x) `notElem` contents l || (z,y) `elem` contents r) | z<-contents (source l)]) -= - not ( or [ (z,x) `elem` contents l && (z,y) `notElem` contents r | z<-contents (source l)]) -= - null [ () | z<-contents (source l), (z,x) `elem` contents l && (z,y) `notElem` contents r] -= - null [ () | z<-contents (source l), (z,x) `elem` contents l, (z,y) `notElem` contents r] -= - null [ () | (z,x') <- contents l, x==x', (z,y) `notElem` contents r ] -= - null [ () | (z,x') <- contents l, x==x' && (z,y) `notElem` contents r ] - -Based on this derivation, - contents (ERrs (l,r)) - = [(x,y) | x<-contents (target l), y<-contents (target r) - , null [ () | (z,x') <- contents l, x==x', (z,y) `notElem` contents r ] - ] - -So we construct the PSEUDO-query: + ERrs (l,r) -> fromListWith uni + [(x,[y]) | x<-atomsOf gens pt (target l), y<-atomsOf gens pt (target r) + , null (lkp x (contents (EFlp l)) >- lkp y (contents (EFlp r))) + ] + EDia (l,r) -> fromListWith (++) + [(x,[y]) | x<-atomsOf gens pt (source l), y<-atomsOf gens pt (source r) + , null (lkp y (contents r) >- lkp x (contents l)) + , null (lkp y (contents l) >- lkp x (contents r)) + ] + ERad (l,r) -> fromListWith uni + [(x,[y]) | x<-atomsOf gens pt (source l), y<-atomsOf gens pt (target r) + , null (atomsOf gens pt (target l) >- (lkp x (contents l) `uni` lkp y (contents (EFlp r)))) + ] + EPrd (l,r) -> fromList $ + [ (a,cod) | a <- atomsOf gens pt (source l), let cod=atomsOf gens pt (target r), not (null cod) ] + ECps (l,r) -> fromListWith uni + [(x,[y]) | x<-keys (contents l), y<-keys flipr + , (not.null) ((contents l ! x ) `isc` (flipr ! y)) + ] where flipr = contents (EFlp r) + EKl0 x -> if source x == target x --see #166 + then closMap (unionWith uni (contents x) (contents (EDcI (source x)))) + else fatal 87 ("source and target of "++show x++show (sign x)++ " are not equal.") + EKl1 x -> if source x == target x --see #166 + then closMap (contents x) + else fatal 90 ("source and target of "++show x++show (sign x)++ " are not equal.") + EFlp x -> fromListWith uni [(b,[a]) | (a,bs)<-assocs (contents x), b<-bs] + ECpl x -> contents (EDcV (sign x) .-. x) + EBrk x -> contents x + EDcD dcl -> pairsOf gens pt dcl + EDcI c -> fromList [(a,[a]) | a <- atomsOf gens pt c] + EEps i _ -> fromList [(a,[a]) | a <- atomsOf gens pt i] + EDcV sgn -> fromList [(s, cod) | s <- atomsOf gens pt (source sgn), let cod=atomsOf gens pt (target sgn), not (null cod) ] + EMp1 a c -> fromList [(a,[a]) | name c/="SESSION"] -- prevent populating SESSION -SELECT x, y FROM CONTtgtL, CONTtgtR -WHERE NOT EXISTS - (SELECT z, x' - FROM L - WHERE x'=x AND - NOT EXISTS - (SELECT c, d - FROM R - WHERE z=c AND y=d - ) - ) --} +---------------------------------------------------- +-- Warshall's transitive closure algorithm in Haskell: +---------------------------------------------------- + closMap :: (Eq a, Ord a) => Map a [a] -> Map a [a] + closMap xs + = foldl f xs (keys xs `isc` nub (concat (elems xs))) + where + f :: (Eq a, Ord a) => Map a [a] -> a -> Map a [a] -- The type is given for documentation purposes only + f q x = unionWith uni q (fromListWith uni [(a, q ! x) | (a, bs) <- assocs q, x `elem` bs])
src/lib/DatabaseDesign/Ampersand/Classes/Relational.hs view
@@ -144,7 +144,7 @@ EEps i _ -> isSingleton i EDcV{} -> True EBrk e -> isTrue e - _ -> False -- TODO: find richer answers for ERrs, ELrs, ERad, and EMp1 + _ -> False -- TODO: find richer answers for ERrs, ELrs, EDia, ERad, and EMp1 -- | isFalse e == True means that e is false, i.e. the population of e is empty. -- isFalse e == False does not mean anything. @@ -167,7 +167,7 @@ EEps{} -> False EDcV{} -> False EBrk e -> isFalse e - _ -> False -- TODO: find richer answers for ERrs, ELrs, and ERad + _ -> False -- TODO: find richer answers for ERrs, ELrs, EDia, and ERad isProp expr = null ([Asy,Sym]>-multiplicities expr) @@ -191,7 +191,7 @@ EDcV sgn -> isEndo sgn && isSingleton (source sgn) EBrk f -> isIdent f EFlp f -> isIdent f - _ -> False -- TODO: find richer answers for ERrs, ELrs, EPrd, and ERad + _ -> False -- TODO: find richer answers for ELrs, ERrs, EDia, EPrd, and ERad isEpsilon e = case e of EEps{} -> True _ -> False @@ -209,4 +209,4 @@ EDcV{} -> False EBrk f -> isImin f EFlp f -> isImin f - _ -> False -- TODO: find richer answers for ERrs and ELrs + _ -> False -- TODO: find richer answers for ELrs, ERrs, and EDia
src/lib/DatabaseDesign/Ampersand/Classes/ViewPoint.hs view
@@ -5,7 +5,6 @@ import Prelude hiding (Ord(..)) import DatabaseDesign.Ampersand.ADL1.Rule (rulefromProp, ruleviolations) import DatabaseDesign.Ampersand.Classes.Relational (Relational(multiplicities)) -import DatabaseDesign.Ampersand.Classes.ConceptStructure (ConceptStructure(..)) import DatabaseDesign.Ampersand.Basics import DatabaseDesign.Ampersand.Misc.Explain import Data.List @@ -14,14 +13,14 @@ 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, declarations, etc.) +-- 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 - declarations :: a -> [Declaration] -- ^ all relations that exist in the scope of this viewpoint. - -- These are user defined declarations and all generated declarations, - -- i.e. one declaration for each GEN and one for each signal rule. - -- Don't confuse declarations with declsUsedIn, which gives the declarations that are + 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. @@ -30,10 +29,10 @@ -- ^ 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<-declarations x, p<-multiplicities d] - identityRules :: a -> [Rule] -- all identity rules 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 + 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 @@ -76,7 +75,7 @@ , 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 - , r_sgl = False -- This is not a signal rule + , isSignal = False -- This is not a signal rule , srrel = Sgn { decnm = ruleName , decsgn = sign expression , decprps = [] @@ -88,11 +87,9 @@ [ A_Markup English ReST (string2Blocks ReST meaningEN) , A_Markup Dutch ReST (string2Blocks ReST meaningNL) ] - , decConceptDef = Nothing , decfpos = origin identity , deciss = False , decusr = False - , decISA = False , decpat = "" , decplug = False } @@ -114,11 +111,11 @@ , objmsub = Just . Box ONE $ map (objectdef) (ctxpats context) , objstrs = [] } - declarations context = uniteRels (concatMap declarations (patterns context) - ++ concatMap declarations (processes context) - ++ ctxds context) + relsDefdIn context = uniteRels (concatMap relsDefdIn (patterns context) + ++ concatMap relsDefdIn (processes context) + ++ ctxds context) where - -- declarations with the same name, but different properties (decprps,pragma,decpopu,etc.) may exist and need to be united + -- 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 [] = [] @@ -150,13 +147,13 @@ , objmsub = Nothing , objstrs = [] } - declarations 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 _ = [] + 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] @@ -175,22 +172,13 @@ , objmsub = Nothing , objstrs = [] } - declarations 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 ProcessStructure Pattern where - processes _ = [] - roles _ = [] - interfaces _ = [] - objDefs _ = [] - processRules pat = [r |r<-ptrls pat, isSignal r] - maintains = ptrruls -- says which roles maintain which rules. - mayEdit = ptrrels -- says which roles may change the population of which relation. + 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 @@ -199,23 +187,23 @@ , objmsub = Nothing , objstrs = [] } - declarations 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 ] + 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 = declsUsedIn r - , ptups = [] - , ptrruls = [] - , ptrrels = [] - , ptids = [] - , ptvds = [] - , ptxps = [] - } - ] + 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 = [] + } + ]
src/lib/DatabaseDesign/Ampersand/Components.hs view
@@ -68,13 +68,14 @@ doGenProofs :: Fspc -> Options -> IO() doGenProofs fSpec flags = do { verboseLn flags $ "Generating Proof for " ++ name fSpec ++ " into " ++ outputFile ++ "." +-- ; verboseLn flags $ writeTextile def thePandoc ; writeFile outputFile $ writeHtmlString def thePandoc ; verboseLn flags "Proof written." } where outputFile = combine (dirOutput flags) $ replaceExtension ("proofs_of_"++baseName flags) ".html" thePandoc = setTitle title (doc theDoc) title = text $ "Proofs for "++name fSpec - theDoc = para $ fromList (deriveProofs flags fSpec) + theDoc = deriveProofs flags fSpec --theDoc = plain (text "Aap") -- use for testing... doGenHaskell :: Fspc -> Options -> IO()
src/lib/DatabaseDesign/Ampersand/Core/AbstractSyntaxTree.hs view
@@ -32,7 +32,6 @@ , Sign(..) , Population(..) , GenR- , Signaling(..) , Association(..) -- (Poset.<=) is not exported because it requires hiding/qualifying the Prelude.<= or Poset.<= too much -- import directly from DatabaseDesign.Ampersand.Core.Poset when needed@@ -40,14 +39,13 @@ , smallerConcepts, largerConcepts, rootConcepts , showSign , aMarkup2String- , insParentheses , module DatabaseDesign.Ampersand.Core.ParseTree -- export all used contstructors of the parsetree, because they have actually become part of the Abstract Syntax Tree.- , (.==.), (.|-.), (./\.), (.\/.), (.-.), (./.), (.\.), (.:.), (.!.), (.*.)+ , (.==.), (.|-.), (./\.), (.\/.), (.-.), (./.), (.\.), (.<>.), (.:.), (.!.), (.*.) )where import qualified Prelude import Prelude hiding (Ord(..), Ordering(..)) import DatabaseDesign.Ampersand.Basics-import DatabaseDesign.Ampersand.Core.ParseTree (MetaObj(..),Meta(..),ConceptDef,Origin(..),Traced(..),PairView(..),PairViewSegment(..),Prop,Lang,Pairs, PandocFormat, P_Markup(..), PMeaning(..), SrcOrTgt(..), isSrc, RelConceptDef(..))+import DatabaseDesign.Ampersand.Core.ParseTree (MetaObj(..),Meta(..),ConceptDef,Origin(..),Traced(..),PairView(..),PairViewSegment(..),Prop,Lang,Pairs, PandocFormat, P_Markup(..), PMeaning(..), SrcOrTgt(..), isSrc) import DatabaseDesign.Ampersand.Core.Poset (Poset(..), Sortable(..),Ordering(..),greatest,least,maxima,minima,sortWith) import DatabaseDesign.Ampersand.Misc import Text.Pandoc hiding (Meta)@@ -65,7 +63,7 @@ , ctxpats :: [Pattern] -- ^ The patterns defined in this context , ctxprocs :: [Process] -- ^ The processes defined in this context , ctxrs :: [Rule] -- ^ All user defined rules in this context, but outside patterns and outside processes- , ctxds :: [Declaration] -- ^ The declarations defined in this context, outside the scope of patterns+ , ctxds :: [Declaration] -- ^ The relations that are declared in this context, outside the scope of patterns , ctxpopus :: [Population] -- ^ The user defined populations of relations defined in this context, including those from patterns and processes , ctxcds :: [ConceptDef] -- ^ The concept definitions defined in this context, including those from patterns and processes , ctxks :: [IdentityDef] -- ^ The identity definitions defined in this context, outside the scope of patterns@@ -130,7 +128,7 @@ , ptend :: Origin -- ^ the end position in the file, elements with a position between pos and end are elements of this pattern. , ptrls :: [Rule] -- ^ The user defined rules in this pattern , ptgns :: [A_Gen] -- ^ The generalizations defined in this pattern- , ptdcs :: [Declaration] -- ^ The declarations declared in this pattern+ , ptdcs :: [Declaration] -- ^ The relations that are declared in this pattern , ptups :: [Population] -- ^ The user defined populations in this pattern , ptrruls :: [(String,Rule)] -- ^ The assignment of roles to rules. , ptrrels :: [(String,Declaration)] -- ^ The assignment of roles to Relations.@@ -164,7 +162,7 @@ , rrdcl :: Maybe (Prop,Declaration) -- ^ The property, if this rule originates from a property on a Declaration , r_env :: String -- ^ Name of pattern in which it was defined. , r_usr :: RuleOrigin -- ^ Where does this rule come from?- , r_sgl :: Bool -- ^ True if this is a signal; False if it is an invariant+ , isSignal :: Bool -- ^ True if this is a signal; False if it is an invariant , srrel :: Declaration -- ^ the signal relation } instance Eq Rule where@@ -178,8 +176,6 @@ name = rrnm instance Association Rule where sign = rrtyp-instance Signaling Rule where- isSignal = r_sgl data RuleType = Implication | Equivalence | Truth deriving (Eq,Show) @@ -193,18 +189,16 @@ , decprM :: String -- ^ then a tuple ("Peter","Jane") in the list of links means that Person Peter is married to person Jane in Vegas. , decprR :: String , decMean :: AMeaning -- ^ the meaning of a declaration, for each language supported by Ampersand.- , decConceptDef :: Maybe RelConceptDef -- ^ alternative definition for the source or target concept in the context of this relation , decfpos :: Origin -- ^ the position in the Ampersand source file where this declaration is declared. Not all decalartions come from the ampersand souce file. , deciss :: Bool -- ^ if true, this is a signal relation; otherwise it is an ordinary relation. , decusr :: Bool -- ^ if true, this relation is declared by an author in the Ampersand script; otherwise it was generated by Ampersand.- , decISA :: Bool -- ^ if true, this relation is the result of an ISA declaration. , decpat :: String -- ^ the pattern where this declaration has been declared. , decplug :: Bool -- ^ if true, this relation may not be stored in or retrieved from the standard database (it should be gotten from a Plug of some sort instead) } | - Isn + Isn { detyp :: A_Concept -- ^ The type } |- Vs + Vs { decsgn :: Sign } @@ -214,17 +208,23 @@ d@Vs{} == d'@Vs{} = decsgn d==decsgn d' _ == _ = False instance Show Declaration where -- For debugging purposes only (and fatal messages)- showsPrec _ d@Sgn{}- = showString (unwords (["RELATION",decnm d,show (decsgn d),show (decprps_calc d)- ,"PRAGMA",show (decprL d),show (decprM d),show (decprR d)]- ++concatMap showMeaning (ameaMrk (decMean d))- ) )- where - showMeaning m = "MEANING"- : ["IN", show (amLang m)]- ++ [show (amFormat m)]- ++ ["{+",aMarkup2String m,"-}"] - -- then [] else ["MEANING",show (decMean d)] ))+ showsPrec _ decl@Sgn{}+ = showString (case decl of+ Sgn{} -> name decl++showSign (sign decl)+ Isn{} -> "I["++show (detyp decl)++"]" -- Isn{} is of type Declaration and it is implicitly defined+ Vs{} -> "V"++show (decsgn decl) )+-- was:+-- = showString (unwords (["RELATION",decnm decl,show (decsgn decl),show (decprps_calc decl)+-- ,"PRAGMA",show (decprL decl),show (decprM decl),show (decprR decl)]+-- ++concatMap showMeaning (ameaMrk (decMean decl))+-- ) )+-- where +-- showMeaning m = "MEANING"+-- : ["IN", show (amLang m)]+-- ++ [show (amFormat m)]+-- ++ ["{+",aMarkup2String m,"-}"] +-- -- then [] else ["MEANING",show (decMean decl)] ))+ showsPrec _ d@Isn{} = showString $ "Isn{detyp="++show(detyp d)++"}" showsPrec _ d@Vs{} = showString $ "V"++showSign(decsgn d) @@ -273,14 +273,12 @@ data ViewSegment = ViewExp ObjectDef | ViewText String | ViewHtml String deriving (Eq, Show) -- | data structure A_Gen contains the CLASSIFY statements from an Ampersand script--- CLASSIFY Employee ISA Person translates to Isa orig (C "Person") (C "Employee")+-- CLASSIFY Employee ISA Person translates to Isa (C "Person") (C "Employee") -- CLASSIFY Workingstudent IS Employee/\Student translates to IsE orig (C "Workingstudent") [C "Employee",C "Student"]-data A_Gen = Isa { genfp :: Origin -- ^ the position of the GEN-rule- , genspc :: A_Concept -- ^ specific concept+data A_Gen = Isa { genspc :: A_Concept -- ^ specific concept , gengen :: A_Concept -- ^ generic concept }- | IsE { genfp :: Origin -- ^ the position of the GEN-rule- , genspc :: A_Concept -- ^ specific concept+ | IsE { genspc :: A_Concept -- ^ specific concept , genrhs :: [A_Concept] -- ^ concepts of which the conjunction is equivalent to the specific concept } instance Show A_Gen where@@ -289,8 +287,6 @@ case g of Isa{} -> showString ("CLASSIFY "++show (genspc g)++" ISA "++show (gengen g)) IsE{} -> showString ("CLASSIFY "++show (genspc g)++" IS "++intercalate " /\\ " (map show (genrhs g)))-instance Traced A_Gen where- origin = genfp -- | this function takes all generalisation relations from the context and a concept and delivers a list of all concepts that are more specific than the given concept. -- If there are no cycles in the generalization graph, cpt cannot be an element of smallerConcepts gens cpt.@@ -396,6 +392,7 @@ | EDif (Expression,Expression) -- ^ difference - | ELrs (Expression,Expression) -- ^ left residual / | ERrs (Expression,Expression) -- ^ right residual \+ | EDia (Expression,Expression) -- ^ diamond <> | ECps (Expression,Expression) -- ^ composition ; | ERad (Expression,Expression) -- ^ relative addition ! | EPrd (Expression,Expression) -- ^ cartesian product * @@ -411,7 +408,7 @@ | EMp1 String A_Concept -- ^ constant (string between single quotes) deriving (Eq,Show) -(.==.), (.|-.), (./\.), (.\/.), (.-.), (./.), (.\.), (.:.), (.!.), (.*.) :: Expression -> Expression -> Expression+(.==.), (.|-.), (./\.), (.\/.), (.-.), (./.), (.\.), (.<>.), (.:.), (.!.), (.*.) :: Expression -> Expression -> Expression infixl 1 .==. -- equivalence infixl 1 .|-. -- implication@@ -420,6 +417,7 @@ infixl 4 .-. -- difference infixl 6 ./. -- left residual infixl 6 .\. -- right residual+infixl 6 .<>. -- diamond infixl 8 .:. -- composition -- .;. was unavailable, because Haskell's scanner does not recognize it as an operator. infixl 8 .!. -- relative addition infixl 8 .*. -- cartesian product@@ -439,9 +437,11 @@ ELrs (l,r) l .\. r = if source l/=source r then fatal 436 ("Cannot residuate (with operator \"\\\") expression\n "++show l++"\n with "++show r++".") else ERrs (l,r)-l .:. r = if source r/=target l then fatal 438 ("Cannot compose (with operator \";\") expression\n "++show l++"\n with "++show r++".") else+l .<>. r = if source l/=target r then fatal 438 ("Cannot use diamond operator \"<>\") on\n "++show l++"\n and "++show r++".") else+ EDia (l,r)+l .:. r = if source r/=target l then fatal 440 ("Cannot compose (with operator \";\") expression\n "++show l++"\n with "++show r++".") else ECps (l,r)-l .!. r = if source r/=target l then fatal 440 ("Cannot add (with operator \"!\") expression\n "++show l++"\n with "++show r++".") else+l .!. r = if source r/=target l then fatal 442 ("Cannot add (with operator \"!\") expression\n "++show l++"\n with "++show r++".") else ERad (l,r) l .*. r = -- SJC: always fits! No fatal here.. EPrd (l,r)@@ -460,6 +460,7 @@ EDif (l,r) -> EDif (flp l, flp r) ELrs (l,r) -> ERrs (flp r, flp l) ERrs (l,r) -> ELrs (flp r, flp l)+ EDia (l,r) -> EDia (flp r, flp l) ECps (l,r) -> ECps (flp r, flp l) ERad (l,r) -> ERad (flp r, flp l) EPrd (l,r) -> EPrd (flp r, flp l)@@ -474,33 +475,6 @@ EDcV sgn -> EDcV (flp sgn) EMp1{} -> expr -insParentheses :: Expression -> Expression-insParentheses = insPar 0- where- wrap :: Integer -> Integer -> Expression -> Expression- wrap i j e' = if i<=j then e' else EBrk e'- insPar :: Integer -> Expression -> Expression- insPar i (EEqu (l,r)) = wrap i 0 (EEqu (insPar 1 l, insPar 1 r))- insPar i (EImp (l,r)) = wrap i 0 (EImp (insPar 1 l, insPar 1 r))- insPar i (EUni (l,r)) = wrap (i+1) 2 (EUni (insPar 2 l, insPar 2 r))- insPar i (EIsc (l,r)) = wrap (i+1) 2 (EIsc (insPar 2 l, insPar 2 r))- insPar i (EDif (l,r)) = wrap i 4 (EDif (insPar 5 l, insPar 5 r))- insPar i (ELrs (l,r)) = wrap i 6 (ELrs (insPar 7 l, insPar 7 r))- insPar i (ERrs (l,r)) = wrap i 6 (ERrs (insPar 7 l, insPar 7 r))- insPar i (ECps (l,r)) = wrap (i+1) 8 (ECps (insPar 8 l, insPar 8 r))- insPar i (ERad (l,r)) = wrap (i+1) 8 (ERad (insPar 8 l, insPar 8 r))- insPar i (EPrd (l,r)) = wrap (i+1) 8 (EPrd (insPar 8 l, insPar 8 r))- insPar _ (EKl0 e) = EKl0 (insPar 10 e)- insPar _ (EKl1 e) = EKl1 (insPar 10 e)- insPar _ (EFlp e) = EFlp (insPar 10 e)- insPar _ (ECpl e) = ECpl (insPar 10 e)- insPar i (EBrk f) = insPar i f- insPar _ e@EDcD{} = e- insPar _ e@EDcI{} = e- insPar _ e@EEps{} = e- insPar _ e@EDcV{} = e- insPar _ e@EMp1{} = e- instance Association Expression where sign (EEqu (l,r)) = Sign (source l) (target r) sign (EImp (l,r)) = Sign (source l) (target r)@@ -509,6 +483,7 @@ sign (EDif (l,r)) = Sign (source l) (target r) sign (ELrs (l,r)) = Sign (source l) (source r) sign (ERrs (l,r)) = Sign (target l) (target r)+ sign (EDia (l,r)) = Sign (source l) (target r) sign (ECps (l,r)) = Sign (source l) (target r) sign (ERad (l,r)) = Sign (source l) (target r) sign (EPrd (l,r)) = Sign (source l) (target r)@@ -569,9 +544,6 @@ isEndo :: rel -> Bool isEndo s = source s == target s -class Signaling a where- isSignal :: a -> Bool -- > tells whether the argument refers to a signal- {- -- a <= b means that concept a is more specific than b and b is more generic than a. For instance 'Elephant' <= 'Animal'
src/lib/DatabaseDesign/Ampersand/Core/ParseTree.hs view
@@ -7,7 +7,7 @@ , P_RoleRelation(..) , RoleRule(..) , P_Pattern(..) - , RelConceptDef(..), P_Declaration(..) + , P_Declaration(..) , Term(..), TermPrim(..) , PairView(..), PairViewSegment(..), PairViewTerm(..), PairViewSegmentTerm(..) , SrcOrTgt(..), isSrc @@ -61,7 +61,7 @@ , ctx_pats :: [P_Pattern] -- ^ The patterns defined in this context , ctx_PPrcs :: [P_Process] -- ^ The processes as defined by the parser , ctx_rs :: [(P_Rule TermPrim)] -- ^ All user defined rules in this context, but outside patterns and outside processes - , ctx_ds :: [P_Declaration] -- ^ The declarations defined in this context, outside the scope of patterns + , ctx_ds :: [P_Declaration] -- ^ The relations defined in this context, outside the scope of patterns , ctx_cs :: [ConceptDef] -- ^ The concept definitions defined in this context, outside the scope of patterns , ctx_ks :: [P_IdentDef] -- ^ The identity definitions defined in this context, outside the scope of patterns , ctx_vs :: [P_ViewDef] -- ^ The view definitions defined in this context, outside the scope of patterns @@ -104,7 +104,7 @@ , procEnd :: Origin -- ^ the end position in the file , procRules :: [(P_Rule TermPrim)] -- ^ the rules in this process , procGens :: [P_Gen] -- ^ the generalizations in this process - , procDcls :: [P_Declaration] -- ^ the relation declarations in this process + , procDcls :: [P_Declaration] -- ^ the relation that are declared in this process , procRRuls :: [RoleRule] -- ^ The assignment of roles to rules. , procRRels :: [P_RoleRelation] -- ^ The assignment of roles to Relations. , procCds :: [ConceptDef] -- ^ The concept definitions defined in this process @@ -137,7 +137,7 @@ , pt_end :: Origin -- ^ the end position in the file in which this pattern was declared. , pt_rls :: [(P_Rule TermPrim)] -- ^ The user defined rules in this pattern , pt_gns :: [P_Gen] -- ^ The generalizations defined in this pattern - , pt_dcs :: [P_Declaration] -- ^ The declarations declared in this pattern + , pt_dcs :: [P_Declaration] -- ^ The relations that are declared in this pattern , pt_rus :: [RoleRule] -- ^ The assignment of roles to rules. , pt_res :: [P_RoleRelation] -- ^ The assignment of roles to Relations. , pt_cds :: [ConceptDef] -- ^ The concept definitions defined in this pattern @@ -167,9 +167,7 @@ origin = cdpos instance Identified ConceptDef where name = cdcpt - - data RelConceptDef = RelConceptDef SrcOrTgt String deriving (Eq, Show) - + data P_Declaration = P_Sgn { dec_nm :: String -- ^ the name of the declaration , dec_sign :: P_Sign -- ^ the type. Parser must guarantee it is not empty. @@ -178,7 +176,6 @@ , dec_prM :: String -- ^ then a tuple ("Peter","Jane") in the list of links means that Person Peter is married to person Jane in Vegas. , dec_prR :: String , dec_Mean :: [PMeaning] -- ^ the optional meaning of a declaration, possibly more than one for different languages. - , dec_conceptDef :: Maybe RelConceptDef -- ^ alternative definition for the source or target concept in the context of this relation , dec_popu :: Pairs -- ^ the list of tuples, of which the relation consists. , dec_fpos :: Origin -- ^ the position in the Ampersand source file where this declaration is declared. Not all decalartions come from the ampersand souce file. , dec_plug :: Bool -- ^ if true, this relation may not be stored in or retrieved from the standard database (it should be gotten from a Plug of some sort instead) @@ -215,6 +212,7 @@ | PDif Origin (Term a) (Term a) -- ^ difference - | PLrs Origin (Term a) (Term a) -- ^ left residual / | PRrs Origin (Term a) (Term a) -- ^ right residual \ + | PDia Origin (Term a) (Term a) -- ^ diamond <> | PCps Origin (Term a) (Term a) -- ^ composition ; | PRad Origin (Term a) (Term a) -- ^ relative addition ! | PPrd Origin (Term a) (Term a) -- ^ cartesian product * @@ -237,6 +235,7 @@ PDif o a b -> PDif o <$> (f a) <*> (f b) PLrs o a b -> PLrs o <$> (f a) <*> (f b) PRrs o a b -> PRrs o <$> (f a) <*> (f b) + PDia o a b -> PDia o <$> (f a) <*> (f b) PCps o a b -> PCps o <$> (f a) <*> (f b) PRad o a b -> PRad o <$> (f a) <*> (f b) PPrd o a b -> PPrd o <$> (f a) <*> (f b) @@ -293,6 +292,7 @@ PDif orig _ _ -> orig PLrs orig _ _ -> orig PRrs orig _ _ -> orig + PDia orig _ _ -> orig PCps orig _ _ -> orig PRad orig _ _ -> orig PPrd orig _ _ -> orig
src/lib/DatabaseDesign/Ampersand/Fspec.hs view
@@ -14,9 +14,7 @@ import DatabaseDesign.Ampersand.Fspec.Graphic.ClassDiagram as X (clAnalysis, cdAnalysis, ClassDiag(..)) import DatabaseDesign.Ampersand.Fspec.Graphic.Graphics as X - (Dotable(..), makePictureObj, printDotGraph, DrawingType(..)) -import DatabaseDesign.Ampersand.Fspec.Graphic.Picture as X - (Picture(..), PictType(..), writePicture) + (makePicture,writePicture,Picture(..), PictureReq(..),imagePath) import DatabaseDesign.Ampersand.Fspec.ToFspec.Calc as X (deriveProofs,showProof,showPrf) import DatabaseDesign.Ampersand.Fspec.ToFspec.ADL2Fspec as X
src/lib/DatabaseDesign/Ampersand/Fspec/Fspec.hs view
@@ -8,7 +8,7 @@ are merely different ways to show Fspc. -} module DatabaseDesign.Ampersand.Fspec.Fspec - ( Fspc(..), concDefs + ( Fspc(..), concDefs, Atom(..) , Fswitchboard(..), Clauses(..), Quad(..) , FSid(..), FProcess(..) , InsDel(..) @@ -28,15 +28,15 @@ , SqlType(..) , SqlFieldUsage(..) , getGeneralizations, getSpecializations - , RuleClause(..),DnfClause(..), dnf2expr, events + , RuleClause(..),DnfClause(..), dnf2expr ) where import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree import DatabaseDesign.Ampersand.Classes import DatabaseDesign.Ampersand.Basics -import Data.List(nub) import DatabaseDesign.Ampersand.ADL1.Pair import DatabaseDesign.Ampersand.ADL1.Expression (notCpl) +--import Debug.Trace fatal :: Int -> String -> a fatal = fatalMsg "Fspec.Fspec" @@ -66,10 +66,10 @@ , grules :: [Rule] -- ^ All rules that are generated: multiplicity rules and identity rules , invars :: [Rule] -- ^ All invariant rules , allRules:: [Rule] -- ^ All rules, both generated (from multiplicity and keys) as well as user defined ones. - , allUsedDecls :: [Declaration] -- ^ All used declarations in the fSpec - , allDecls :: [Declaration] -- ^ All declarations in the fSpec - , vrels :: [Declaration] -- ^ All user defined and generated declarations plus all defined and computed totals. - -- The generated declarations are all generalizations and + , allUsedDecls :: [Declaration] -- ^ All relations that are used in the fSpec + , allDecls :: [Declaration] -- ^ All relations that are declared in the fSpec + , vrels :: [Declaration] -- ^ All user defined and generated relations plus all defined and computed totals. + -- The generated relations are all generalizations and -- one declaration for each signal. , allConcepts :: [A_Concept] -- ^ All concepts in the fSpec , kernels :: [[A_Concept]] -- ^ All concepts, grouped by their classifications @@ -83,21 +83,27 @@ , vpatterns :: [Pattern] -- ^ All patterns taken from the Ampersand script , conceptDefs :: [ConceptDef] -- ^ All concept definitions defined throughout a context, including those inside patterns and processes , fSexpls :: [Purpose] -- ^ All purposes that have been declared at the top level of the current specification, but not in the processes, patterns and interfaces. - , metas :: [Meta] -- ^ All meta declarations from the entire context + , metas :: [Meta] -- ^ All meta relations from the entire context , initialPops :: [Population] -- all user defined populations of relations and concepts , allViolations :: [(Rule,[Paire])] -- all rules with violations. } metaValues :: String -> Fspc -> [String] metaValues key fSpec = [mtVal m | m <-metas fSpec, mtName m == key] +data Atom = Atom { atmRoot :: A_Concept -- The root concept of the atom. (this implies that there can only be a single root for + , atmVal :: String + } deriving Eq + concDefs :: Fspc -> A_Concept -> [ConceptDef] concDefs fSpec c = [ cdef | cdef<-conceptDefs fSpec, name cdef==name c ] instance ConceptStructure Fspc where - concs fSpec = concs (vrels fSpec) -- The set of all concepts used in this Fspc + concs fSpec = allConcepts fSpec -- The set of all concepts used in this Fspc expressionsIn fSpec = foldr (uni) [] [ (expressionsIn.interfaceS) fSpec , (expressionsIn.vrules) fSpec + , (expressionsIn.vviews) fSpec + , (expressionsIn.vIndices) fSpec ] mp1Exprs _ = fatal 77 "do not use mp1Exprs from an Fspc" @@ -109,13 +115,13 @@ , objstrs = [] } --REMARK: in the fSpec we do not distinguish between the disjoint relation declarations and rule declarations (yet?). - declarations = vrels - udefrules = vrules -- only user defined rules - invariants = invars - identities = vIndices - viewDefs = vviews - gens = vgens - patterns = vpatterns + relsDefdIn = vrels + udefrules = vrules -- only user defined rules + invariants = invars + identities = vIndices + viewDefs = vviews + gens = vgens + patterns = vpatterns data FProcess = FProc { fpProc :: Process @@ -125,14 +131,14 @@ name = name . fpProc instance Language FProcess where - objectdef = objectdef.fpProc - declarations = declarations.fpProc - udefrules = udefrules.fpProc - invariants = invariants.fpProc - identities = identities.fpProc - viewDefs = viewDefs.fpProc - gens = gens.fpProc - patterns = patterns.fpProc + objectdef = objectdef.fpProc + relsDefdIn = relsDefdIn.fpProc + udefrules = udefrules.fpProc + invariants = invariants.fpProc + identities = identities.fpProc + viewDefs = viewDefs.fpProc + gens = gens.fpProc + patterns = patterns.fpProc -- | A list of ECA rules, which is used for automated functionality. data Fswitchboard @@ -205,10 +211,10 @@ data InsDel = Ins | Del deriving (Show,Eq) -data ECArule= ECA { ecaTriggr :: Event -- The event on which this rule is activated +data ECArule= ECA { ecaTriggr :: Event -- The event on which this rule is activated , ecaDelta :: Declaration -- The delta to be inserted or deleted from this rule. It actually serves very much like a formal parameter. - , ecaAction :: PAclause -- The action to be taken when triggered. - , ecaNum :: Int -- A unique number that identifies the ECArule within its scope. + , ecaAction :: PAclause -- The action to be taken when triggered. + , ecaNum :: Int -- A unique number that identifies the ECArule within its scope. } instance Eq (ECArule) where e==e' = ecaNum e==ecaNum e' @@ -218,22 +224,20 @@ } deriving (Show,Eq) data PAclause - = CHC { paCls :: [PAclause] - , paMotiv :: [(Expression,[Rule] )] -- tells which conjunct from whichule is being maintained + = CHC { paCls :: [PAclause] -- precisely one clause is executed. + , paMotiv :: [(Expression,[Rule] )] -- tells which conjunct from which rule is being maintained } - | ALL { paCls :: [PAclause] + | GCH { paGCls :: [(InsDel,Expression,PAclause)] -- guarded choice; The rule is maintained if one of the clauses of which the expression is populated is executed. + , paMotiv :: [(Expression,[Rule] )] -- tells which conjunct from which rule is being maintained + } + | ALL { paCls :: [PAclause] -- all clauses are executed. , paMotiv :: [(Expression,[Rule] )] } | Do { paSrt :: InsDel -- do Insert or Delete - , paTo :: Declaration -- into toExpr or from toExpr + , paTo :: Declaration -- into toExpr or from toExpr , paDelta :: Expression -- delta , paMotiv :: [(Expression,[Rule] )] } - | Sel { paCpt :: A_Concept -- pick an existing instance of type c - , paExp :: Expression -- the expression to pick from - , paCl :: String->PAclause -- the completion of the clause - , paMotiv :: [(Expression,[Rule] )] - } | New { paCpt :: A_Concept -- make a new instance of type c , paCl :: String->PAclause -- to be done after creating the concept , paMotiv :: [(Expression,[Rule] )] @@ -253,26 +257,12 @@ | Ref { paVar :: String } -events :: PAclause -> [(InsDel,Declaration)] -events paClause = nub (evs paClause) - where evs clause - = case clause of - CHC{} -> (concat.map evs) (paCls clause) - ALL{} -> (concat.map evs) (paCls clause) - Do{} -> [(paSrt paClause, paTo clause)] - Sel{} -> evs (paCl clause "") - New{} -> evs (paCl clause "") - Rmv{} -> evs (paCl clause "") - Nop{} -> [] - Blk{} -> [] - Let{} -> fatal 305 "events for let undetermined" - Ref{} -> fatal 306 "events for Ref undetermined" - -- The data structure Clauses is meant for calculation purposes. -- It must always satisfy for every i<length (cl_rule cl): cl_rule cl is equivalent to EIsc [EUni disj | (conj, dnfClauses)<-cl_conjNF cl, disj<-[conj!!i]] -- Every rule is transformed to this form, as a step to derive eca-rules instance Eq PAclause where CHC ds _ == CHC ds' _ = ds==ds' + GCH ds _ == GCH ds' _ = ds==ds' ALL ds _ == ALL ds' _ = ds==ds' p@Do{} == p'@Do{} = paSrt p==paSrt p' && paTo p==paTo p' && paDelta p==paDelta p' Nop _ == Nop _ = True @@ -370,7 +360,7 @@ -- | stores one relation r in two ordered columns -- i.e. a tuple of SqlField -> (source r,target r) with (fldexpr=I/\r;r~, fldexpr=r) -- (note: if r TOT then (I/\r;r~ = I). Thus, the concept (source r) is stored in this plug too) - -- with tblcontents = [[x,y] |(x,y)<-contents r]. + -- with tblcontents = [[Just x,Just y] |(x,y)<-contents r]. -- Typical for BinSQL is that it has exactly two columns that are not unique and may not contain NULL values | BinSQL { sqlname :: String , columns :: (SqlField,SqlField) @@ -381,7 +371,7 @@ } -- |stores one concept c in one column -- i.e. a SqlField -> c - -- with tblcontents = [[x] |(x,_)<-contents c]. + -- with tblcontents = [[Just x] |(x,_)<-contents c]. -- Typical for ScalarSQL is that it has exactly one column that is unique and may not contain NULL values i.e. fldexpr=I[c] | ScalarSQL { sqlname :: String @@ -410,12 +400,9 @@ [(plug,fld) |InternalPlug plug@BinSQL{}<-plugInfos fSpec, (c,fld)<-cLkpTbl plug,c==cpt]++ [(plug,sqlColumn plug) |InternalPlug plug@ScalarSQL{}<-plugInfos fSpec, cLkp plug==cpt] -data SqlFieldUsage = PrimKey A_Concept -- The field is the primary key of the table +data SqlFieldUsage = TableKey Bool A_Concept -- The field is the (primary) key of the table. (The boolean tells whether or not it is primary) | ForeignKey A_Concept -- The field is a reference (containing the primary key value of) a TblSQL | PlainAttr -- None of the above - | NonMainKey -- Key value of an Specialization of the Primary key. (field could be null) - | UserDefinedUsage - | FillInLater -- Must be filled in later.... deriving (Eq, Show) data SqlField = Fld { fldname :: String
src/lib/DatabaseDesign/Ampersand/Fspec/Graphic/ClassDiagram.hs view
@@ -82,7 +82,6 @@ where inKernel fld = null([Uni,Inj,Sur]>-multiplicities (fldexpr fld)) && not (isPropty fld) lookup' c = [plug |InternalPlug plug@TblSQL{}<-plugInfos fSpec , (c',_)<-cLkpTbl plug, c'==c] isPropty fld = null([Sym,Asy]>-multiplicities (fldexpr fld)) - -- | This function, cdAnalysis, generates a conceptual data model. @@ -91,32 +90,33 @@ -- Properties and identities are not shown. cdAnalysis :: Fspc -> Options -> ClassDiag cdAnalysis fSpec _ = - OOclassdiagram {cdName = "logical_"++name fSpec - ,classes = - [ OOClass{ clName = name root - , clcpt = Just root - , clAtts = map ooAttr (filter (\x -> source x == root) attribs) - , clMths = [] - } - | root <- roots] - ,assocs = - [ OOAssoc { assSrc = Left (source r) - , assSrcPort = (name.head.declsUsedIn) r - , asslhm = (mults.flp) r - , asslhr = "" - , assTgt = Left (target r) - , assrhm = mults r - , assrhr = (name.head.declsUsedIn) r + OOclassdiagram { cdName = "logical_"++name fSpec + , classes = + [ OOClass{ clName = name root + , clcpt = Just root + , clAtts = map ooAttr ooClass + , clMths = [] } - | r <- allrels, target r `elem` roots - ] - ,aggrs = [] - ,geners = [] - ,ooCpts = roots + | ooClass <- ooClasses, let root=source (head ooClass)] + , assocs = + [ OOAssoc { assSrc = Left (source r) + , assSrcPort = name d + , asslhm = (mults.flp) r + , asslhr = "" + , assTgt = Left (target r) + , assrhm = mults r + , assrhr = name d + } + | r@(EDcD d) <- allrels, target r `elem` roots + ] + , aggrs = [] + , geners = [] + , ooCpts = roots } where - ooAttr r = OOAttr { attNm = (name.head.declsUsedIn) r + ooAttr :: Expression -> CdAttribute + ooAttr r = OOAttr { attNm = (name . head . relsMentionedIn) r , attTyp = (name.target) r , attOptional = (not.isTot) r } @@ -124,15 +124,17 @@ maxVal = if isInj r then MaxOne else MaxMany in Mult minVal maxVal allrels = [ EDcD r -- restricted to those themes that must be printed. - | r <- (nub.concat) - ([declarations p ++ declsUsedIn p | p <- pattsInScope fSpec ]++ - [declarations p ++ declsUsedIn p | p <- procsInScope fSpec ]) + | r@Sgn{} <- (nub.concat) + ([relsDefdIn p ++ relsMentionedIn p | p <- pattsInScope fSpec ]++ + [relsDefdIn p ++ relsMentionedIn p | p <- procsInScope fSpec ]) , decusr r] attribs = map flipWhenInj (filter isAttribRel allrels) where isAttribRel r = isUni r || isInj r flipWhenInj r = if isInj r then flp r else r - roots = nub (map source allrels) - + ooClasses = eqCl source attribs -- an equivalence class wrt source yields the attributes that constitute an OO-class. + roots = map (source.head) ooClasses + + -- | This function generates a technical data model. -- It is based on the plugs that are calculated. tdAnalysis :: Fspc -> Options -> ClassDiag @@ -226,7 +228,7 @@ , asslhr = fldname f , assTgt = Left (rootOf (target expr)) , assrhm = mults expr - , assrhr = (name.head.declsUsedIn) expr + , assrhr = case [name d | d@Sgn{}<-relsMentionedIn expr] of h:_ -> h ; _ -> fatal 229 "no relations used in expr" } mults r = let minVal = if isTot r then MinOne else MinZero maxVal = if isInj r then MaxOne else MaxMany @@ -239,16 +241,16 @@ -- [r |r<-rels, isUni r, isInj r, isSur r]++[flp r |r<-rels, isUni r , isInj r, not (isSur r)] ---- assRels contains all relations that do not occur as attributes in classes -- assRels = [r |r<-relsLim, not (isUni r), not (isInj r)] --- attrs rs = [ OOAttr ((name.head.declsUsedIn) r) (name (target r)) (not(isTot r)) +-- attrs rs = [ OOAttr ((name.head.relsMentionedIn) r) (name (target r)) (not(isTot r)) -- | r<-rs, not (isPropty r)] -- isPropty r = null([Sym,Asy]>-multiplicities r) -- | translate a ClassDiagram to a DotGraph, so it can be used to show it as a picture. classdiagram2dot :: Options -> ClassDiag -> DotGraph String - classdiagram2dot flags cd - = DotGraph { strictGraph = False - , directedGraph = True - , graphID = Nothing + classdiagram2dot flags cd + = DotGraph { strictGraph = False + , directedGraph = True + , graphID = Nothing , graphStatements = dotstmts } where
src/lib/DatabaseDesign/Ampersand/Fspec/Graphic/Graphics.hs view
@@ -1,30 +1,303 @@ {-# OPTIONS_GHC -Wall #-} module DatabaseDesign.Ampersand.Fspec.Graphic.Graphics - (Dotable(..), makePictureObj, printDotGraph, DrawingType(..) - -- ,GraphvizCommand(..) - -- ,GraphvizOutput(..) - -- ,runGraphvizCommand) + (makePicture, writePicture, Picture(..), PictureReq(..),imagePath )where --- TODO url links for atlas -import Data.GraphViz hiding (addExtension ) +import Data.GraphViz import DatabaseDesign.Ampersand.ADL1 import DatabaseDesign.Ampersand.Fspec.Fspec import DatabaseDesign.Ampersand.Classes import DatabaseDesign.Ampersand.Fspec.Switchboard import DatabaseDesign.Ampersand.Misc -import DatabaseDesign.Ampersand.Basics (fatalMsg,eqCl,Collection(..),Identified(..)) -import DatabaseDesign.Ampersand.Fspec.Graphic.Picture -import DatabaseDesign.Ampersand.Fspec.Graphic.ClassDiagram (ClassDiag,classdiagram2dot) +import DatabaseDesign.Ampersand.Basics +import DatabaseDesign.Ampersand.Fspec.Graphic.ClassDiagram -- (ClassDiag,classdiagram2dot) import Data.GraphViz.Attributes.Complete -import Data.List (nub) +import Data.List import Data.String +import System.FilePath hiding (addExtension) +import System.Directory + fatal :: Int -> String -> a fatal = fatalMsg "Fspec.Graphic.Graphics" +data PictureReq = PTClassDiagram + | PTRelsUsedInPat Pattern + | PTDeclaredInPat Pattern + | PTProcess FProcess + | PTConcept A_Concept + | PTSwitchBoard Activity + | PTFinterface Activity + | PTIsaInPattern Pattern -- Not used at all... + | PTSingleRule Rule + | PTLogicalDM + | PTTechnicalDM + +data Picture = Pict { pType :: PictureReq -- ^ the type of the picture + , scale :: String -- ^ a scale factor, intended to pass on to LaTeX, because Pandoc seems to have a problem with scaling. + , dotSource :: DotGraph String -- ^ the string representing the .dot + , dotProgName :: GraphvizCommand -- ^ the name of the program to use ("dot" or "neato" or "fdp" or "Sfdp") + , caption :: String -- ^ a human readable name of this picture + } + + +makePicture :: Options -> Fspc -> PictureReq -> Picture +makePicture flags fSpec pr = + case pr of + PTClassDiagram -> Pict { pType = pr + , scale = scale' + , dotSource = classdiagram2dot flags (clAnalysis fSpec flags) + , dotProgName = Dot + , caption = + case fsLang fSpec of + English -> "Classification of " ++ name fSpec + Dutch -> "Classificatie van " ++ name fSpec + } + PTLogicalDM -> Pict { pType = pr + , scale = scale' + , dotSource = classdiagram2dot flags (cdAnalysis fSpec flags) + , dotProgName = Dot + , caption = + case fsLang fSpec of + English -> "Logical data model of " ++ name fSpec + Dutch -> "Logisch gegevensmodel van " ++ name fSpec + } + PTTechnicalDM -> Pict { pType = pr + , scale = scale' + , dotSource = classdiagram2dot flags (tdAnalysis fSpec flags) + , dotProgName = Dot + , caption = + case fsLang fSpec of + English -> "Technical data model of " ++ name fSpec + Dutch -> "Technisch gegevensmodel van " ++ name fSpec + } + PTConcept cpt -> Pict { pType = pr + , scale = scale' + , dotSource = conceptualGraph' fSpec flags pr + , dotProgName = graphVizCmdForConceptualGraph + , caption = + case fsLang fSpec of + English -> "Concept diagram of the rules about " ++ name cpt + Dutch -> "Conceptueel diagram van de regels rond " ++ name cpt + } + PTDeclaredInPat pat -> Pict { pType = pr + , scale = scale' + , dotSource = conceptualGraph' fSpec flags pr + , dotProgName = graphVizCmdForConceptualGraph + , caption = + case fsLang fSpec of + English -> "Concept diagram of relations in " ++ name pat + Dutch -> "Conceptueel diagram van relaties in " ++ name pat + } + PTIsaInPattern pat -> Pict { pType = pr + , scale = scale' + , dotSource = conceptualGraph' fSpec flags pr + , dotProgName = graphVizCmdForConceptualGraph + , caption = + case fsLang fSpec of + English -> "Classifications of " ++ name pat + Dutch -> "Classificaties van " ++ name pat + } + PTRelsUsedInPat pat -> Pict { pType = pr + , scale = scale' + , dotSource = conceptualGraph' fSpec flags pr + , dotProgName = graphVizCmdForConceptualGraph + , caption = + case fsLang fSpec of + English -> "Concept diagram of the rules in " ++ name pat + Dutch -> "Conceptueel diagram van de regels in " ++ name pat + } + PTFinterface act -> Pict { pType = pr + , scale = scale' + , dotSource = conceptualGraph' fSpec flags pr + , dotProgName = graphVizCmdForConceptualGraph + , caption = + case fsLang fSpec of + English -> "Concept diagram of interface " ++ name act + Dutch -> "Conceptueel diagram van interface " ++ name act + } + PTSingleRule rul -> Pict { pType = pr + , scale = scale' + , dotSource = conceptualGraph' fSpec flags pr + , dotProgName = graphVizCmdForConceptualGraph + , caption = + case fsLang fSpec of + English -> "Concept diagram of rule " ++ name rul + Dutch -> "Conceptueel diagram van regel " ++ name rul + } + PTProcess fp -> Pict { pType = pr + , scale = scale' + , dotSource = processModel fp + , dotProgName = graphVizCmdForConceptualGraph + , caption = + case fsLang fSpec of + English -> "Process model of " ++ name fp + Dutch -> "Procesmodel van " ++ name fp + } + PTSwitchBoard act -> Pict { pType = pr + , scale = scale' + , dotSource = sbdotGraph (switchboardAct fSpec act) + , dotProgName = graphVizCmdForConceptualGraph + , caption = + case fsLang fSpec of + English -> "Switchboard diagram of " ++ name act + Dutch -> "Schakelpaneel van " ++ name act + } + where + scale' = + case pr of + PTClassDiagram -> "1.0" + PTRelsUsedInPat{}-> "0.7" + PTDeclaredInPat{}-> "0.5" + PTProcess{} -> "0.4" + PTSwitchBoard{} -> "0.4" + PTIsaInPattern{} -> "0.7" + PTSingleRule{} -> "0.7" + PTConcept{} -> "0.7" + PTFinterface{} -> "0.7" + PTLogicalDM -> "0.7" + PTTechnicalDM -> "0.7" + graphVizCmdForConceptualGraph = Sfdp + +pictureID :: PictureReq -> String +pictureID pr = + case pr of + PTClassDiagram -> "Classification" + PTLogicalDM -> "LogicalDataModel" + PTTechnicalDM -> "TechnicalDataModel" + PTConcept cpt -> "RulesWithConcept"++name cpt + PTDeclaredInPat pat -> "RelationsInPattern"++name pat + PTIsaInPattern pat -> "IsasInPattern"++name pat + PTRelsUsedInPat pat -> "RulesInPattern"++name pat + PTProcess fp -> "ProcessModel"++name fp + PTFinterface act -> "KnowledgeGraph"++name act + PTSwitchBoard x -> "SwitchBoard"++name x + PTSingleRule r -> "SingleRule"++name r + +conceptualGraph' :: Fspc -> Options -> PictureReq -> DotGraph String +conceptualGraph' fSpec flags pr = conceptual2Dot flags cstruct + where + cstruct = + case pr of + PTConcept c -> + let gs = fsisa fSpec + cpts' = concs rs + rs = [r | r<-udefrules fSpec, c `elem` concs r] + in + CStruct { csCpts = nub$cpts' ++ [g |(s,g)<-gs, elem g cpts' || elem s cpts'] ++ [s |(s,g)<-gs, elem g cpts' || elem s cpts'] + , csRels = [r | r@Sgn{} <- relsMentionedIn rs -- the use of "relsMentionedIn" restricts relations to those actually used in rs + , not (isProp r) + ] + , csIdgs = [(s,g) |(s,g)<-gs, elem g cpts' || elem s cpts'] -- all isa edges + } + -- PTRelsUsedInPat makes a picture of at least the relations within pat; + -- extended with a limited number of more general concepts; + -- and rels to prevent disconnected concepts, which can be connected given the entire context. + PTRelsUsedInPat pat -> + let orphans = [c | c<-cpts, not(c `elem` map fst idgs || c `elem` map snd idgs || c `elem` map source rels || c `elem` map target rels)] + xrels = nub [r | c<-orphans, r@Sgn{}<-relsDefdIn fSpec + , (c == source r && target r `elem` cpts) || (c == target r && source r `elem` cpts) + , source r /= target r, decusr r + ] + idgs = [(s,g) |(s,g)<-gs, g `elem` cpts, s `elem` cpts] -- all isa edges within the concepts + gs = fsisa fSpec + cpts = cpts' `uni` [g |cl<-eqCl id [g |(s,g)<-gs, s `elem` cpts'], length cl<3, g<-cl] -- up to two more general concepts + cpts' = concs pat `uni` concs rels + rels = [r | r@Sgn{}<-relsMentionedIn pat + , not (isProp r) -- r is not a property + ] + in + CStruct { csCpts = cpts' `uni` [g |cl<-eqCl id [g |(s,g)<-gs, s `elem` cpts'], length cl<3, g<-cl] -- up to two more general concepts + , csRels = rels `uni` xrels -- extra rels to connect concepts without rels in this picture, but with rels in the fSpec + , csIdgs = idgs + } + + -- PTDeclaredInPat makes a picture of relations and gens within pat only + PTDeclaredInPat pat -> + let gs = fsisa fSpec + cpts = concs decs `uni` concs (gens pat) + decs = relsDefdIn pat `uni` relsMentionedIn (udefrules pat) + in + CStruct { csCpts = cpts + , csRels = [r | r@Sgn{}<-decs + , not (isProp r), decusr r -- r is not a property + ] + , csIdgs = [(s,g) |(s,g)<-gs, g `elem` cpts, s `elem` cpts] -- all isa edges within the concepts + } + PTIsaInPattern pat -> + let gs = fsisa fSpec + cpts = concs edges + cpts' = concs pat >- concs gs + edges = clos gs idgs + idgs = [(s,g) |(s,g)<-gs, elem g cpts' || elem s cpts'] -- all isa edges + clos tuples ts = f (tuples>-ts) ts [] + where f [] new result = result++new + f _ [] result = result + f tups new result = f (tups>-new) [ t |t<-tups, (not.null) (concs t `isc` concs result') ] result' + where result' = result++new + in + CStruct { csCpts = cpts + , csRels = [] + , csIdgs = idgs + } + + PTFinterface ifc -> + let gs = fsisa fSpec + cpts = nub $ cpts' ++ [c |(s,g)<-idgs, c<-[g,s]] + cpts' = concs rs + rs = [r | r<-udefrules fSpec, affected r] + affected r = (not.null) [d | d@Sgn{} <- relsMentionedIn r `isc` relsMentionedIn ifc] + idgs = [(s,g) |(s,g)<-gs, elem g cpts' || elem s cpts'] -- all isa edges + rels = [r | r@Sgn{}<-relsMentionedIn ifc, decusr r + , not (isProp r) -- r is not a property + ] + in + CStruct { csCpts = cpts -- involve all concepts involved either in the affected rules or in the isa-links + , csRels = rels + , csIdgs = idgs -- involve all isa links from concepts touched by one of the affected rules + } + PTSingleRule r -> + let idgs = [(s,g) | (s,g)<-fsisa fSpec + , g `elem` concs r || s `elem` concs r] -- all isa edges + in + CStruct { csCpts = nub $ concs r++[c |(s,g)<-idgs, c<-[g,s]] + , csRels = [d | d@Sgn{}<-relsMentionedIn r, decusr d + , not (isProp d) -- d is not a property + ] + , csIdgs = idgs -- involve all isa links from concepts touched by one of the affected rules + } + _ -> fatal 276 "No conceptual graph defined for this type." + + +writePicture :: Options -> Picture -> IO() +writePicture flags pict + = sequence_ ( + [createDirectoryIfMissing True (takeDirectory (imagePath flags pict)) | genAtlas flags ]++ + [writeDot Canon | {- genFspec flags || -} genAtlas flags ]++ +-- [writeDot XDot | genFspec flags || genAtlas flags ]++ + [writeDot Png | genFspec flags || genAtlas flags ]++ + [writeDot Cmapx | genAtlas flags ] + ) + where + writeDot :: GraphvizOutput + -> IO () + writeDot gvOutput = + do verboseLn flags ("Generating "++show gvOutput++" using "++show gvCommand++".") + path <- addExtension (runGraphvizCommand gvCommand (dotSource pict)) gvOutput ((dropExtension . imagePath flags) pict) + verboseLn flags (path++" written.") + where gvCommand = dotProgName pict + + +class ReferableFromPandoc a where + imagePath :: Options ->a -> FilePath -- ^ the full file path to the image file + +instance ReferableFromPandoc Picture where + imagePath flags p = + (if genAtlas flags then dirPrototype flags </> "images" else dirOutput flags) + </> (escapeNonAlphaNum . pictureID . pType ) p <.> "png" + class Identified a => Navigatable a where - interfacename :: a -> String + interfacename :: a -> String itemstring :: a -> String theURL :: Options -> a -> EscString -- url of the web page in Atlas used when clicked on a node or edge in a .map file theURL flags x @@ -49,157 +322,18 @@ ++ (if source x==target x then name(source x) else name(source x)++"*"++name(target x)) ++ "]" -data DrawingType - = Plain_CG -- Plain Conceptual graph. No frills - | Rel_CG -- Conceptual graph that focuses on relations - | Gen_CG -- Conceptual graph that focuses on generalizations --- Chapter 1: All objects that can be transformed to a conceptual diagram are Dotable... -class Identified a => Dotable a where - conceptualGraph :: Fspc - -> Options -- the options - -> DrawingType -- this parameter allows for different alternative graphs for the same a - -> a -> DotGraph String -- yields a function that maps a to a DotGraph - -- makePicture is an abbreviation of three steps: - -- 1. conceptualGraph: creates a DotGraph data structure - -- 2. printDotGraph: makes a string, which is the contents of the dot-file for GraphViz - -- 3. makePictureObj: creates a Picture data structure, containing the required metadata needed for production. - makePicture :: Options - -> Fspc - -> DrawingType - -> a - -> Picture -{- This instance of Dotable is meant for drawing data models -} -instance Dotable ClassDiag where - conceptualGraph _ _ _ _ = fatal 58 "TODO: ClassDiagram moet nog netjes naar nieuwe Graphviz worden verbouwd." - makePicture flags fSpec _ cd = - makePictureObj flags (fsLang fSpec) (name cd) PTClassDiagram (classdiagram2dot flags cd) - -instance Dotable A_Concept where - conceptualGraph fSpec flags _ c = conceptual2Dot flags (name c) cpts rels idgs - where - rs = [r | r<-udefrules fSpec, c `elem` concs r] - idgs = [(s,g) |(s,g)<-gs, elem g cpts' || elem s cpts'] -- all isa edges - gs = fsisa fSpec --- TODO: removal of redundant isa edges might be done more efficiently - cpts = nub$cpts' ++ [g |(s,g)<-gs, elem g cpts' || elem s cpts'] ++ [s |(s,g)<-gs, elem g cpts' || elem s cpts'] - cpts' = concs rs - rels = [r | r<-declsUsedIn rs -- the use of "declsUsedIn" restricts relations to those actually used in rs - , not (isProp r) -- r is not a property - ] - makePicture flags fSpec variant x = - (makePictureObj flags (fsLang fSpec) (name x) PTConcept . conceptualGraph fSpec flags variant) x - -instance Dotable Pattern where - -- | The Plain_CG of pat makes a picture of at least the declsUsedIn within pat; - -- extended with a limited number of more general concepts; - -- and rels to prevent disconnected concepts, which can be connected given the entire context. - conceptualGraph fSpec flags Plain_CG pat = conceptual2Dot flags (name pat) cpts (rels `uni` xrels) idgs - where - --DESCR -> get concepts and arcs from pattern - idgs = [(s,g) |(s,g)<-gs, g `elem` cpts, s `elem` cpts] -- all isa edges within the concepts - gs = fsisa fSpec - cpts = let cpts' = concs pat `uni` concs rels - in cpts' `uni` [g |cl<-eqCl id [g |(s,g)<-gs, s `elem` cpts'], length cl<3, g<-cl] -- up to two more general concepts - rels = [r | r@Sgn{}<-declsUsedIn pat - , not (isProp r) -- r is not a property - ] - -- extra rels to connect concepts without rels in this picture, but with rels in the fSpec - xrels = let orphans = [c | c<-cpts, not(c `elem` map fst idgs || c `elem` map snd idgs || c `elem` map source rels || c `elem` map target rels)] - in nub [r | c<-orphans, r@Sgn{}<-declarations fSpec - , (c == source r && target r `elem` cpts) || (c == target r && source r `elem` cpts) - , source r /= target r, decusr r - ] - -- | The Rel_CG of pat makes a picture of declarations and gens within pat only - conceptualGraph fSpec flags Rel_CG pat = conceptual2Dot flags (name pat) cpts rels idgs - where - --DESCR -> get concepts and arcs from pattern - idgs = [(s,g) |(s,g)<-gs, g `elem` cpts, s `elem` cpts] -- all isa edges within the concepts - gs = fsisa fSpec - cpts = concs (declarations pat) `uni` concs (gens pat) - rels = [r | r@Sgn{}<-declarations pat - , not (isProp r), decusr r -- r is not a property - ] - conceptualGraph fSpec flags Gen_CG pat = conceptual2Dot flags (name pat) cpts [] edges - where - --DESCR -> get concepts and arcs from pattern - idgs = [(s,g) |(s,g)<-gs, elem g cpts' || elem s cpts'] -- all isa edges - gs = fsisa fSpec - edges = clos gs idgs - cpts = concs edges - cpts' = concs pat >- concs gs - clos tuples ts = f (tuples>-ts) ts [] - where f [] new result = result++new - f _ [] result = result - f tups new result = f (tups>-new) [ t |t<-tups, (not.null) (concs t `isc` concs result') ] result' - where result' = result++new - makePicture flags fSpec variant pat = - (makePictureObj flags (fsLang fSpec) (name pat) PTPattern . conceptualGraph fSpec flags variant) pat - -instance Dotable FProcess where - conceptualGraph fSpec flags _ fproc = conceptual2Dot flags (name fproc) cpts rels idgs - where - --DESCR -> get concepts and arcs from process - idgs = [(s,g) |(s,g)<-gs, g `elem` cpts'] -- all isa edges - gs = fsisa fSpec - cpts = nub(cpts' ++ [g |(g,_)<-idgs] ++ [s |(_,s)<-idgs]) - cpts' = concs (fpProc fproc) - rels = [r | r@Sgn{}<-declsUsedIn (fpProc fproc), decusr r - , not (isProp r) -- r is not a property - ] - makePicture flags fSpec _ x = - (makePictureObj flags (fsLang fSpec) (name x) PTProcess . processModel) x -{- inspired by: - makePicture flags fSpec _ cd = - makePictureObj flags (fsLang fSpec) (name cd) PTClassDiagram (classdiagram2dot flags cd) -} - -instance Dotable Activity where - conceptualGraph fSpec flags _ ifc = conceptual2Dot flags (name ifc) cpts rels idgs - where - -- involve all rules from the specification that are affected by this interface - rs = [r | r<-udefrules fSpec, affected r] - affected r = not (null (declsUsedIn r `isc` declsUsedIn ifc)) - -- involve all isa links from concepts touched by one of the affected rules - idgs = [(s,g) |(s,g)<-gs, elem g cpts' || elem s cpts'] -- all isa edges - gs = fsisa fSpec - -- involve all concepts involved either in the affected rules or in the isa-links - cpts = nub $ cpts' ++ [c |(s,g)<-idgs, c<-[g,s]] - cpts' = concs rs - rels = [r | r@Sgn{}<-declsUsedIn ifc, decusr r - , not (isProp r) -- r is not a property - ] - makePicture flags fSpec variant x = - (makePictureObj flags (fsLang fSpec) (name x) PTFinterface . conceptualGraph fSpec flags variant) x - -instance Dotable SwitchBdDiagram where - conceptualGraph _ _ _ = sbdotGraph - makePicture flags fSpec variant x = - (makePictureObj flags (fsLang fSpec) (name x) PTSwitchBoard . conceptualGraph fSpec flags variant) x - -instance Dotable Rule where - conceptualGraph fSpec flags _ r = conceptual2Dot flags (name r) cpts rels idgs - where - idgs = [(s,g) | (s,g)<-fsisa fSpec - , g `elem` concs r || s `elem` concs r] -- all isa edges - cpts = nub $ concs r++[c |(s,g)<-idgs, c<-[g,s]] - rels = [d | d@Sgn{}<-declsUsedIn r, decusr d - , not (isProp d) -- d is not a property - ] - makePicture flags fSpec variant x = - (makePictureObj flags (fsLang fSpec) (name x) PTRule . conceptualGraph fSpec flags variant) x +data ConceptualStructure = CStruct { csCpts :: [A_Concept] -- ^ The concepts to draw in the graph + , csRels :: [Declaration] -- ^ The relations, (the edges in the graph) + , csIdgs :: [(A_Concept, A_Concept)] -- ^ list of Isa relations + } --- Chapter 2: Formation of a conceptual graph as a DotGraph data structure. -conceptual2Dot :: Options -- ^ the flags - -> String -- ^ the name of the Graph - -> [A_Concept] -- ^ The concepts to draw in the graph - -> [Declaration] -- ^ The relations, (the edges in the graph) - -> [(A_Concept, A_Concept)] -- ^ list of Isa relations - -> DotGraph String -- ^ The resulting DotGraph -conceptual2Dot flags graphName cpts' rels idgs +conceptual2Dot :: Options -> ConceptualStructure -> DotGraph String +conceptual2Dot flags (CStruct cpts' rels idgs) = DotGraph { strictGraph = False , directedGraph = True - , graphID = Just (Str (fromString graphName)) + , graphID = Nothing , graphStatements = DotStmts { attrStmts = [GraphAttrs (handleFlags TotalPicture flags)] , subGraphs = []
− src/lib/DatabaseDesign/Ampersand/Fspec/Graphic/Picture.hs
@@ -1,136 +0,0 @@-{-# OPTIONS_GHC -Wall #-} --- This module is for the definition of Picture and PictureList. -module DatabaseDesign.Ampersand.Fspec.Graphic.Picture - ( Picture(origName,uniqueName,caption,relPng,pType,scale) -- Other fields are hidden, for there is no need for them outside this module... - , Pictures,PictType(..),uniquePicName - , makePictureObj,writePicture - ) -where -import System.FilePath -- (replaceExtension,takeBaseName, (</>) ) -import System.Directory -import DatabaseDesign.Ampersand.Misc -import Control.Monad -import DatabaseDesign.Ampersand.Basics -import Prelude hiding (writeFile,readFile,getContents,putStr,putStrLn) -import Data.GraphViz.Types.Canonical -import Data.GraphViz.Commands - -fatal :: Int -> String -> a -fatal = fatalMsg "Fspec.Graphic.Picture" - -type Pictures = [Picture] -data Picture = Pict { origName :: String -- ^ The original name of the object this picture was made for. (could include spaces!) - , pType :: PictType -- ^ the type of the picture - , scale :: String -- ^ a scale factor, intended to pass on to LaTeX, because Pandoc seems to have a problem with scaling. - , uniqueName :: String -- ^ used to reference the picture in pandoc or tex - , dotSource :: DotGraph String -- ^ the string representing the .dot - , fullPath :: FilePath -- ^ the full file path where the .dot and .png file resides - , relPng :: FilePath -- ^ the relative file path where the .png file resides - , dotProgName :: GraphvizCommand -- ^ the name of the program to use ("dot" or "neato" or "fdp" or "Sfdp") - , caption :: String -- ^ a human readable name of this picture - } -data PictType = PTClassDiagram -- a UML class diagram, or something that comes close - | PTPattern -- a conceptual diagram with the relations USED in a pattern - | PTFullPat -- a conceptual diagram with the relations DECLARED in a pattern - | PTProcess -- a process diagram, that shows dependencies between activities - | PTProcLang -- a conceptual diagram that shows the language of a process - | PTConcept -- a conceptual diagram that shows a concept in relation with the rules it occurs in. - | PTRule -- a conceptual diagram that shows a rule - | PTSwitchBoard - | PTFinterface deriving Eq -picType2prefix :: PictType -> String -picType2prefix pt = case pt of - PTClassDiagram -> "CD_" - PTPattern -> "Pat_" - PTFullPat -> "Lat_" - PTProcess -> "Proc_" - PTProcLang -> "PL_" - PTConcept -> "Cpt_" - PTRule -> "Rul_" - PTSwitchBoard -> "SB_" - PTFinterface -> "Serv_" - -makePictureObj :: Options - -> Lang - -> String -- Name of the picture - -> PictType -- Type of the picture - -> DotGraph String -- The dot source. Should be canonnical. - -> Picture -- The ADT of a picture -makePictureObj flags lang nm pTyp dotsource - = Pict { origName = nm - , uniqueName = cdName - , dotSource = dotsource - , fullPath = absImgPath </> cdName - , relPng = relImgPath </> cdName - , pType = pTyp - , scale = case pTyp of - PTClassDiagram -> "1.0" - PTPattern -> "0.7" - PTFullPat -> "0.5" - PTProcess -> "0.4" - PTSwitchBoard -> "0.4" - PTProcLang -> "0.7" - _ -> "0.7" - , dotProgName = case pTyp of - PTClassDiagram -> Dot - PTSwitchBoard -> Dot - _ -> Sfdp - , caption = case (pTyp,lang) of - (PTClassDiagram,English) -> "Class Diagram of " ++ nm - (PTClassDiagram,Dutch ) -> "Klassediagram van " ++ nm - (PTPattern ,English) -> "Concept diagram of the rules in " ++ nm - (PTPattern ,Dutch ) -> "Conceptueel diagram van de regels in " ++ nm - (PTFullPat ,English) -> "Concept diagram of relations in " ++ nm - (PTFullPat ,Dutch ) -> "Conceptueel diagram van relaties in " ++ nm - (PTProcess ,English) -> "Process model of " ++ nm - (PTProcess ,Dutch ) -> "Procesmodel van " ++ nm - (PTSwitchBoard ,English) -> "Switchboard diagram of " ++ nm - (PTSwitchBoard ,Dutch ) -> "Schakelpaneel van " ++ nm - (_ ,English) -> "Knowledge graph about " ++ nm - (_ ,Dutch ) -> "Kennisgraaf rond " ++ nm - } - where - absImgPath | genAtlas flags = dirPrototype flags </> relImgPath - | otherwise = dirOutput flags </> relImgPath - relImgPath | genAtlas flags = "images" - | otherwise = [] - cdName = uniquePicName pTyp nm ---GMI voor Han -> (isAlpha c) verwijdert uit lijst comprehensie, dit gooit nummers (bv. rule nummers) uit de naam weg --- zodat alle ongelabelde rules de naam RUL_Rule hebben, dat is niet uniek. --- Deze functie garandeert sowieso geen uniekheid, is die garantie nodig? --- unieke namen voor (ConceptualGraph) datatypes zouden moeten worden gegarandeerd op het datatype als dat nodig is -uniquePicName :: PictType -> String -> String -uniquePicName pt nm = escapeNonAlphaNum (picType2prefix pt++nm) - --- relImgPath = "img" </> user </> (baseName flags) --- user = takeWhile (/='.') (userAtlas flags) -writePicture :: Options -> Picture -> IO() -writePicture flags pict - = sequence_ ( - [createDirectoryIfMissing True (takeDirectory (fullPath pict)) | genAtlas flags ]++ - [writeDot (dotProgName pict) Canon (dotSource pict) (fullPath pict) | genFspec flags || genAtlas flags ]++ --- [writeDot (dotProgName pict) XDot (dotSource pict) (fullPath pict) | genFspec flags || genAtlas flags ]++ - [writeDot (dotProgName pict) Png (dotSource pict) (fullPath pict) | genFspec flags || genAtlas flags ]++ - [writeDot (dotProgName pict) Cmapx (dotSource pict) (fullPath pict) | genAtlas flags ] - ) - where - writeDot :: GraphvizCommand - -> GraphvizOutput - -> DotGraph String - -> FilePath - -> IO () - writeDot gvCommand gvOutput graph filePath = - do verboseLn flags ("Generating "++show gvOutput++" using "++show gvCommand++".") - path <- runGraphvizCommand gvCommand graph gvOutput (replaceExtension filePath (extentionOf gvOutput)) - verboseLn flags (path++" written.") - where extentionOf :: GraphvizOutput -> String - extentionOf x = case x of - Canon -> "dot" - Png -> "png" - Cmapx -> "map" - XDot -> "xdot" - Svg -> "svg" - Gif -> "gif" - _ -> fatal 139 "GraphvizOutput has undefined extention" - -
src/lib/DatabaseDesign/Ampersand/Fspec/Motivations.hs view
@@ -360,11 +360,15 @@ where isLang m = l == amLang m instance Meaning Declaration where - meaning l d = case filter isLang (ameaMrk (decMean d)) of - [] -> Nothing - [m] -> Just m - _ -> fatal 388 ("In the "++show l++" language, too many meanings given for declaration "++name d ++".") - where isLang m = l == amLang m + meaning l d = + case d of + Sgn{} -> let isLang m = l == amLang m + in case filter isLang (ameaMrk (decMean d)) of + [] -> Nothing + [m] -> Just m + _ -> fatal 388 ("In the "++show l++" language, too many meanings given for declaration "++name d ++".") + Isn{} -> fatal 370 "meaning is undefined for Isn" + Vs{} -> fatal 371 "meaning is undefined for Vs" instance Motivated Fspc where -- meaning _ fSpec = fatal 329 ("No Fspc has an intrinsic meaning, (used with Fspc '"++name fSpec++"')")
src/lib/DatabaseDesign/Ampersand/Fspec/Plug.hs view
@@ -17,9 +17,9 @@ ) where import DatabaseDesign.Ampersand.ADL1 -import DatabaseDesign.Ampersand.Classes (Populated(..),atomsOf,Relational(..))+import DatabaseDesign.Ampersand.Classes (fullContents,atomsOf,Relational(..)) import DatabaseDesign.Ampersand.Basics-import Data.List(elemIndex,nub)+import Data.List(nub,transpose) import GHC.Exts (sortWith) import DatabaseDesign.Ampersand.Fspec.Fspec import Prelude hiding (Ordering(..))@@ -109,19 +109,11 @@ --REMARK151210 -> one would expect I[entityconcept p], -- but any p (as instance of Object) has one always existing concept p suitable to replace entityconcept p. -- concept p and entityconcept p are related uni,tot,inj,sur.---data SqlFieldUsage = PrimKey A_Concept -- The field is the primary key of the table--- | ForeignKey A_Concept -- The field is a reference (containing the primary key value of) a TblSQL--- | PlainAttr -- None of the above--- | NonMainKey -- Key value of an Specialization of the Primary key. (field could be null)--- | UserDefinedUsage--- | FillInLater -- Must be filled in later.... --the entity stored in a plug is an imaginary concept, that is uni,tot,inj,sur with (concept p) --REMARK: there is a (concept p) because all kernel fields are related SUR with (concept p) -- --Maintain rule: Object ObjectDef = Object (makeUserDefinedSqlPlug :: ObjectDef -> PlugSQL) --TODO151210 -> Build a check which checks this rule for userdefined/showADL generated plugs(::[ObjectDef]) --TODO151210 -> The ObjectDef of a BinSQL plug for relation r is that:@@ -382,12 +374,14 @@ | otherwise = head c1==head c2 -type TblRecord = [String]+-- | tblcontents is meant to compute the contents of an entity table.+-- It yields a list of records. Values in the records may be absent, which is why Maybe String is used rather than String.+type TblRecord = [Maybe String] tblcontents :: [A_Gen] -> [Population] -> PlugSQL -> [TblRecord] tblcontents gens udp plug@ScalarSQL{}- = [[x] | x<-atomsOf gens udp (cLkp plug)]+ = [[Just x] | x<-atomsOf gens udp (cLkp plug)] tblcontents gens udp plug@BinSQL{}- = [[x,y] |(x,y)<-fullContents gens udp (mLkp plug)]+ = [[(Just . srcPaire) p,(Just . trgPaire) p] |p<-fullContents gens udp (mLkp plug)] tblcontents gens udp plug@TblSQL{} --TODO15122010 -> remove the assumptions (see comment data PlugSQL) --fields are assumed to be in the order kernel+other, @@ -395,28 +389,18 @@ --and the first field is unique and not null --(r,s,t)<-mLkpTbl: s is assumed to be in the kernel, fldexpr t is expected to hold r or (flp r), s and t are assumed to be different | null(fields plug) = fatal 593 "no fields in plug."- | flduniq idfld && not(fldnull idfld) && isIdent (fldexpr idfld)- = let - pos fld = case elemIndex fld (fields plug) of - Just n -> n+1- Nothing -> fatal 598 "field is expected."- rels fld = [ ((pos s,pos t),xy) | (_,s,t)<-mLkpTbl plug- , s /= t - , fld==s- , xy<-fullContents gens udp (fldexpr t)- ]- in --add relation values to the record, from left to right field (concat=rels with source idfld++rels with source fld2++..) - [ foldl insertrel --(a -> b -> a)- (take (length (fields plug)) (idval:[[] |_<-[(1::Int)..]])) --new record for id- (concatMap rels (fields plug)) - | idval<-map fst (fullContents gens udp (fldexpr idfld)) ]- | otherwise = fatal 609 "fields are assumed to be in the order kernel+other, starting with an id-field."- where idfld = head (fields plug)---if x at position n of some record, then position r is replaced by y (position starts at 1, not 0!)-insertrel::TblRecord->((Int,Int),Paire)->TblRecord-insertrel rec ((n,r),(x,y))- | length rec < n || length rec < r - = fatal 615 $ "cannot take position "++show n++" or "++show r++" of "++show rec++"."- | x==(rec !! (n - 1)) --x at position n of rec- = take (r-1) rec++y:drop r rec --position r is replaced by y- | otherwise = rec --unchanged+ | otherwise = transpose+ ( map Just cAtoms+ : [case fExp of+ EDcI c -> [ if a `elem` atomsOf gens udp c then Just a else Nothing | a<-cAtoms ]+ _ -> [ (lkp a . fullContents gens udp) fExp | a<-cAtoms ]+ | fld<-tail (fields plug), let fExp=fldexpr fld+ ]+ )+ where+ cAtoms = (atomsOf gens udp . source . fldexpr . head . fields) plug+ lkp a pairs+ = case [ p | p<-pairs, a==srcPaire p ] of+ [] -> Nothing+ [p] -> Just (trgPaire p)+ ps -> fatal 428 ("Multiple values in one field: "++show ps)
src/lib/DatabaseDesign/Ampersand/Fspec/ShowADL.hs view
@@ -9,15 +9,17 @@ -- -- Every Expression should be disambiguated before printing to ensure unambiguity. module DatabaseDesign.Ampersand.Fspec.ShowADL - ( ShowADL(..), LanguageDependent(..)) + ( ShowADL(..), LanguageDependent(..), showPAclause, showREL) where import DatabaseDesign.Ampersand.Core.ParseTree import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree import DatabaseDesign.Ampersand.Basics (fatalMsg,eqCl,Collection(..),Identified(..)) import DatabaseDesign.Ampersand.Classes +import DatabaseDesign.Ampersand.ADL1 (insParentheses) import DatabaseDesign.Ampersand.Fspec.Fspec import Data.List hiding (head) import Prelude hiding (head) +--import Debug.Trace head :: [a] -> a head [] = fatal 30 "head must not be used on an empty list!" @@ -141,8 +143,6 @@ showstr :: String -> String showstr str = "\""++str++"\"" --- The declarations of the pattern are supplemented by all declarations needed to define the rules. --- Thus, the resulting pattern is self-contained with respect to declarations. instance ShowADL Process where showADL prc = "PROCESS " ++ name prc @@ -152,8 +152,13 @@ -- concept definitions are not printed, because we have no way of telling where they come from.... ++ (if null (prcIds prc) then "" else "\n " ++intercalate "\n " (map showADL (prcIds prc)) ++ "\n") ++ (if null (prcXps prc) then "" else "\n " ++intercalate "\n " (map showADL (prcXps prc)) ++ "\n") +-- The relations declared in the pattern are supplemented by all relations used by the rules. +-- Thus, the resulting pattern is self-contained with respect to declarations. + ++ (if null decls then "" else "\n " ++intercalate "\n " (map showADL decls) ++ "\n") ++ "ENDPROCESS" - where -- TODO: the following definitions should be unneccessary, but 'map showADL (maintains prc)' and "map showADL (mayEdit prc)" don't work... + where + decls = [d | d@Sgn{}<-relsDefdIn prc `uni` relsMentionedIn prc] + -- TODO: the following definitions should be unneccessary, but 'map showADL (maintains prc)' and "map showADL (mayEdit prc)" don't work... showRM :: Process -> String showRM pr = intercalate "\n " [ "ROLE "++role++" MAINTAINS "++intercalate ", " [name rul | (_,rul)<-cl] | cl<-eqCl fst (maintains pr), let role = fst (head cl)] @@ -174,20 +179,11 @@ showADL pat = "PATTERN " ++ showstr (name pat) ++ "\n" ++ (if null (ptrls pat) then "" else "\n " ++intercalate "\n " (map showADL (ptrls pat)) ++ "\n") - ++ (if null (maintains pat) then "" else "\n " ++ showRM pat ++ "\n") - ++ (if null (mayEdit pat) then "" else "\n " ++ showRR pat ++ "\n") ++ (if null (ptgns pat) then "" else "\n " ++intercalate "\n " (map showADL (ptgns pat)) ++ "\n") ++ (if null (ptdcs pat) then "" else "\n " ++intercalate "\n " (map showADL (ptdcs pat)) ++ "\n") -- concept definitions are not printed, because we have no way of telling where they come from.... ++ (if null (ptids pat) then "" else "\n " ++intercalate "\n " (map showADL (ptids pat)) ++ "\n") ++ "ENDPATTERN" - where -- TODO: the following definitions should be unneccessary, but 'map showADL (maintains prc)' and "map showADL (mayEdit prc)" don't work... - showRM :: Pattern -> String - showRM pt = intercalate "\n " [ "ROLE "++role++" MAINTAINS "++intercalate ", " [name rul | (_,rul)<-cl] - | cl<-eqCl fst (maintains pt), let role = fst (head cl)] - showRR :: Pattern -> String - showRR pt = intercalate "\n " [ "ROLE "++role++" EDITS "++intercalate ", " [name rul | (_,rul)<-cl] - | cl<-eqCl fst (mayEdit pt), let role = fst (head cl)] instance ShowADL (PairViewSegment Expression) where showADL (PairViewText str) = "TXT " ++ show str @@ -257,13 +253,14 @@ -- showADL rel = show rel instance ShowADL Expression where - showADL = showExpr (" = ", " |- ", " /\\ ", " \\/ ", " - ", " / ", " \\ ", ";", "!", "*", "*", "+", "~", ("-"++), "(", ")", "[", "*", "]") . insParentheses + showADL = showExpr (" = ", " |- ", " /\\ ", " \\/ ", " - ", " / ", " \\ ", " <> ", ";", "!", "*", "*", "+", "~", ("-"++), "(", ")", "[", "*", "]") -- NOTE: retain space after \\, because of unexpected side effects if it is used just before an 'r' or 'n'.... where - showExpr :: (String,String,String,String,String,String,String,String,String,String,String,String,String,String -> String,String,String,String,String,String) + showExpr :: (String,String,String,String,String,String,String,String,String,String,String,String,String,String,String -> String,String,String,String,String,String) -> Expression -> String - showExpr (equi, impl, inter, union',diff, lresi, rresi, rMul , rAdd , rPrd ,closK0,closK1,flp', compl, lpar, rpar, lbr, star, rbr) expr - = showchar (insA_Parentheses expr) + showExpr (equi, impl, inter, union',diff, lresi, rresi, rDia, rMul , rAdd , rPrd ,closK0,closK1,flp', compl, lpar, rpar, lbr, star, rbr) expr + = --let c = PlainConcept "A" in trace (showchar (insParentheses (ECps (ECps (EDcI c,EDcI c),ECps (EDcI c,EDcI c))))) $ + showchar (insParentheses expr) where showchar (EEqu (l,r)) = showchar l++equi++showchar r showchar (EImp (l,r)) = showchar l++impl++showchar r @@ -272,10 +269,7 @@ showchar (EDif (l,r)) = showchar l++diff ++showchar r showchar (ELrs (l,r)) = showchar l++lresi++showchar r showchar (ERrs (l,r)) = showchar l++rresi++showchar r -{- showchar (ECps (EEps i sgn,r)) | i==source sgn||i==target sgn = showchar r - | otherwise = showchar (ECps (EDcI i,r)) - showchar (ECps (l,EEps i sgn)) | i==source sgn||i==target sgn = showchar l - | otherwise = showchar (ECps (l,EDcI i)) -} + showchar (EDia (l,r)) = showchar l++rDia++showchar r showchar (ECps (l,r)) = showchar l++rMul++showchar r showchar (ERad (l,r)) = showchar l++rAdd++showchar r showchar (EPrd (l,r)) = showchar l++rPrd++showchar r @@ -290,29 +284,6 @@ showchar (EDcV sgn) = "V"++lbr++name (source sgn)++star++name (target sgn)++rbr showchar (EMp1 a c) = "'"++a++"'"++lbr++name c++rbr - insA_Parentheses :: Expression -> Expression - insA_Parentheses = insPar 0 - where - wrap :: Integer -> Integer -> Expression -> Expression - wrap i j e' = if i<=j then e' else EBrk e' - insPar :: Integer -> Expression -> Expression - insPar i (EEqu (l,r)) = wrap i 0 (EEqu (insPar 1 l, insPar 1 r)) - insPar i (EImp (l,r)) = wrap i 0 (EImp (insPar 1 l, insPar 1 r)) - insPar i (EIsc (l,r)) = wrap (i+1) 2 (EIsc (insPar 2 l, insPar 2 r)) - insPar i (EUni (l,r)) = wrap (i+1) 2 (EUni (insPar 2 l, insPar 2 r)) - insPar i (EDif (l,r)) = wrap i 4 (EDif (insPar 5 l, insPar 5 r)) - insPar i (ELrs (l,r)) = wrap i 6 (ELrs (insPar 7 l, insPar 7 r)) - insPar i (ERrs (l,r)) = wrap i 6 (ERrs (insPar 7 l, insPar 7 r)) - insPar i (ECps (l,r)) = wrap i 8 (ECps (insPar 8 l, insPar 8 r)) - insPar i (ERad (l,r)) = wrap (i+1) 8 (ERad (insPar 8 l, insPar 8 r)) - insPar i (EPrd (l,r)) = wrap (i+1) 8 (EPrd (insPar 8 l, insPar 8 r)) - insPar _ (EKl0 e) = EKl0 (insPar 10 e) - insPar _ (EKl1 e) = EKl1 (insPar 10 e) - insPar _ (EFlp e) = EFlp (insPar 10 e) - insPar _ (ECpl e) = ECpl (insPar 10 e) - insPar i (EBrk e) = insPar i e - insPar _ x = x - instance ShowADL DnfClause where showADL dnfClause = showADL (dnf2expr dnfClause) @@ -325,13 +296,21 @@ (if null(decprL decl++decprM decl++decprR decl) then "" else " PRAGMA "++unwords (map show [decprL decl,decprM decl,decprR decl])) ++ concatMap meaning (ameaMrk (decMean decl)) - ++ maybe "" (\(RelConceptDef srcOrTgt def) -> " DEFINE "++showADL srcOrTgt ++ " " ++ def) (decConceptDef decl) - Isn{} -> "DECLARE I["++show (detyp decl)++"]" -- Isn{} is of type Declaration and it is implicitly defined - Vs{} -> "DECLARE V"++show (decsgn decl) -- Vs{} is of type Declaration and it is implicitly defined + Isn{} -> "I["++show (detyp decl)++"]" -- Isn{} is of type Declaration and it is implicitly defined + Vs{} -> "V"++show (decsgn decl) -- Vs{} is of type Declaration and it is implicitly defined where meaning :: A_Markup -> String meaning pmkup = " MEANING "++showADL pmkup +showREL :: Declaration-> String +showREL decl = show decl +{- + case decl of + Sgn{} -> name decl++showSign (sign decl) + Isn{} -> "I["++show (detyp decl)++"]" -- Isn{} is of type Declaration and it is implicitly defined + Vs{} -> "V"++show (decsgn decl) +-} + instance ShowADL P_Markup where showADL (P_Markup lng fmt str) = case lng of Nothing -> "" @@ -378,22 +357,26 @@ else "\n"++intercalate "\n\n" (map (showADL . ifcObj) [] {- map fsv_ifcdef (fActivities fSpec) -}) ++ "\n") ++ (if null (metas fSpec) then "" else "\n"++intercalate "\n\n" (map showADL (metas fSpec)) ++ "\n") ++ (if null (patterns fSpec) then "" else "\n"++intercalate "\n\n" (map showADL (patterns fSpec)) ++ "\n") +-- ++ (if null (vprocesses fSpec) then "" else "\n"++intercalate "\n\n" (map showADL (vprocesses fSpec)) ++ "\n") -- TODO implement ShowADL FProcess ++ (if null (conceptDefs fSpec) then "" else "\n"++intercalate "\n" (map showADL (conceptDefs fSpec)) ++ "\n") ++ (if null (gens fSpec) then "" else "\n"++intercalate "\n" (map showADL (gens fSpec)) ++ "\n") ++ (if null (identities fSpec) then "" else "\n"++intercalate "\n" (map showADL (identities fSpec >- concatMap identities (patterns fSpec))) ++ "\n") - ++ (if null (declarations fSpec) then "" else "\n"++intercalate "\n" (map showADL (declarations fSpec >- concatMap declarations (patterns fSpec))) ++ "\n") + ++ (if null decls then "" else "\n"++intercalate "\n" (map showADL decls) ++ "\n") ++ (if null (udefrules fSpec) then "" else "\n"++intercalate "\n" (map showADL (udefrules fSpec >- concatMap udefrules (patterns fSpec))) ++ "\n") ++ (if null (fSexpls fSpec) then "" else "\n"++intercalate "\n" (map showADL (fSexpls fSpec)) ++ "\n") ++ "TODO: Populations are not shown..\n" --TODO. -- ++ (if null showADLpops then "" else "\n"++intercalate "\n\n" showADLpops ++ "\n") ++ (if null (interfaceS fSpec) then "" else "\n"++intercalate "\n\n" (map showADL (interfaceS fSpec)) ++ "\n") ++ "\n\nENDCONTEXT" + where decls = relsDefdIn fSpec >- (concatMap relsDefdIn (patterns fSpec) `uni` concatMap relsDefdIn (vprocesses fSpec)) instance ShowADL (Maybe String) where showADL _ = "" instance ShowADL ECArule where showADL eca = "ECA #"++show (ecaNum eca) + instance ShowADL Event where - showADL = show + showADL ev = " On " ++show (eSrt ev)++" "++showREL (eDcl ev) + instance (ShowADL a, ShowADL b) => ShowADL (a,b) where showADL (a,b) = "(" ++ showADL a ++ ", " ++ showADL b ++ ")" @@ -461,9 +444,9 @@ --used to compose error messages at p2a time instance (ShowADL a, Traced a) => ShowADL (Term a) where - showADL = showPExpr (" = ", " |- ", " /\\ ", " \\/ ", " - ", " / ", " \\ ", ";", "!", "*", "*", "+", "~", "(", ")") + showADL = showPExpr (" = ", " |- ", " /\\ ", " \\/ ", " - ", " / ", " \\ ", "<>", ";", "!", "*", "*", "+", "~", "(", ")") where - showPExpr (equi,impl,inter,union',diff,lresi,rresi,rMul,rAdd,rPrd,closK0,closK1,flp',lpar,rpar) expr + showPExpr (equi,impl,inter,union',diff,lresi,rresi,rDia,rMul,rAdd,rPrd,closK0,closK1,flp',lpar,rpar) expr = showchar (insP_Parentheses expr) where showchar (Prim a) = showADL a @@ -474,6 +457,7 @@ showchar (PDif _ l r) = showchar l++diff ++showchar r showchar (PLrs _ l r) = showchar l++lresi++showchar r showchar (PRrs _ l r) = showchar l++rresi++showchar r + showchar (PDia _ l r) = showchar l++rDia++showchar r showchar (PCps _ l r) = showchar l++rMul++showchar r showchar (PRad _ l r) = showchar l++rAdd++showchar r showchar (PPrd _ l r) = showchar l++rPrd++showchar r @@ -496,6 +480,7 @@ insPar i (PDif o l r) = wrap i 4 (PDif o (insPar 5 l) (insPar 5 r)) insPar i (PLrs o l r) = wrap i 6 (PLrs o (insPar 7 l) (insPar 7 r)) insPar i (PRrs o l r) = wrap i 6 (PRrs o (insPar 7 l) (insPar 7 r)) + insPar i (PDia o l r) = wrap i 6 (PDia o (insPar 7 l) (insPar 7 r)) insPar i (PCps o l r) = wrap (i+1) 8 (PCps o (insPar 8 l) (insPar 8 r)) insPar i (PRad o l r) = wrap (i+1) 8 (PRad o (insPar 8 l) (insPar 8 r)) insPar i (PPrd o l r) = wrap (i+1) 8 (PPrd o (insPar 8 l) (insPar 8 r)) @@ -513,31 +498,40 @@ instance ShowADL PAclause where showADL = showPAclause "\n " - where - showPAclause indent pa@CHC{} - = let indent'=indent++" " in "execute ONE from"++indent'++intercalate indent' [showPAclause indent' p' | p'<-paCls pa] - showPAclause indent pa@ALL{} - = let indent'=indent++" " in "execute ALL of"++indent'++intercalate indent' [showPAclause indent' p' | p'<-paCls pa] - showPAclause indent pa@Do{} + +showPAclause :: String -> PAclause -> String +showPAclause indent pa@Do{} = ( case paSrt pa of Ins -> "INSERT INTO " Del -> "DELETE FROM ")++ - show (paTo pa)++ - " SELECTFROM "++ - show (paDelta pa) - ++concat [ indent++showConj rs | (_,rs)<-paMotiv pa ] - showPAclause indent pa@Sel{} - = let indent'=indent++" " in - "SELECT x:"++show (paCpt pa)++" FROM "++showADL (paExp pa)++";"++indent'++showPAclause indent' (paCl pa "x") - showPAclause indent pa@New{} - = let indent'=indent++" " in - "CREATE x:"++show (paCpt pa)++";"++indent'++showPAclause indent' (paCl pa "x") - showPAclause indent pa@Rmv{} - = let indent'=indent++" " in - "REMOVE x:"++show (paCpt pa)++";"++indent'++showPAclause indent' (paCl pa "x") - showPAclause _ Nop{} = "Nop" - showPAclause _ Blk{} = "Blk" - showPAclause _ (Let _ _ _) = fatal 390 "showPAclause not defined for `Let`. Consult your dealer!" - showPAclause _ (Ref _) = fatal 391 "showPAclause not defined for `Ref`. Consult your dealer!" - showConj rs - = "(TO MAINTAIN"++intercalate ", " [name r | r<-rs]++")" + showREL (paTo pa) ++ + indent++" SELECTFROM "++ + showADL (paDelta pa)++ + indent++motivate indent "TO MAINTAIN " (paMotiv pa) +showPAclause indent (New c clause cj_ruls) + = "NEW x:"++show c++";"++indent'++showPAclause indent' (clause "x")++motivate indent "MAINTAINING" cj_ruls + where indent' = indent++" " +showPAclause indent (Rmv c clause cj_ruls) + = "REMOVE x:"++show c++";"++indent'++showPAclause indent' (clause "x")++motivate indent "MAINTAINING" cj_ruls + where indent' = indent++" " +showPAclause indent (CHC ds cj_ruls) + = "ONE OF "++intercalate indent' [showPAclause indent' d | d<-ds]++motivate indent "MAINTAINING" cj_ruls + where indent' = indent++" " +showPAclause indent (GCH ds cj_ruls) + = "ONE NONEMPTY ALTERNATIVE OF "++intercalate indent' + ["PICK a,b FROM "++showADL links++indent'++"THEN "++showPAclause (indent'++" ") p| (_,links,p)<-ds]++ + motivate indent "MAINTAINING" cj_ruls + where indent' = indent++" " +showPAclause indent (ALL ds cj_ruls) + = "ALL of "++intercalate indent' [showPAclause indent' d | d<-ds]++motivate indent "MAINTAINING" cj_ruls + where indent' = indent++" " +showPAclause indent (Nop cj_ruls) + = "DO NOTHING"++motivate indent "TO MAINTAIN" cj_ruls +showPAclause indent (Blk cj_ruls) + = "BLOCK"++motivate indent "CANNOT CHANGE" cj_ruls +showPAclause _ (Let _ _ _) = fatal 55 "showPAclause is missing for `Let`. Contact your dealer!" +showPAclause _ (Ref _) = fatal 56 "showPAclause is missing for `Ref`. Contact your dealer!" + +motivate :: [Char] -> [Char] -> [(Expression, [Rule])] -> [Char] +motivate indent motive motives = concat [ indent++showConj cj_rul | cj_rul<-motives ] + where showConj (conj,rs) = "("++motive++" "++showADL conj++" FROM "++intercalate ", " (map name rs) ++")"
src/lib/DatabaseDesign/Ampersand/Fspec/ShowECA.hs view
@@ -1,61 +1,20 @@ {-# OPTIONS_GHC -Wall #-} module DatabaseDesign.Ampersand.Fspec.ShowECA (showECA) where import DatabaseDesign.Ampersand.Fspec.Fspec - import DatabaseDesign.Ampersand.Basics (fatalMsg,Identified(..)) - import DatabaseDesign.Ampersand.Fspec.ShowADL (ShowADL(..)) - import Data.List (intercalate) - - fatal :: Int -> String -> a - fatal = fatalMsg "Fspec.ShowECA" - + import DatabaseDesign.Ampersand.Fspec.ShowADL (showPAclause, showREL) class ECA a where - showECA :: Fspc -> String -> a -> String + showECA :: String -> a -> String instance ECA ECArule where - showECA fSpec indent er = showECA fSpec indent (ecaTriggr er)++ " EXECUTE -- (ECA rule " - ++ show (ecaNum er) - ++ ")" - ++ - indent++showECA fSpec indent (ecaAction er) + showECA indent er = showECA indent (ecaTriggr er)++ " EXECUTE -- (ECA rule " + ++ show (ecaNum er) + ++ ")" + ++ + indent++showECA indent (ecaAction er) instance ECA Event where - showECA _ _ (On Ins rel) = "ON INSERT Delta IN " ++ showADL rel - showECA _ _ (On Del rel) = "ON DELETE Delta FROM " ++ showADL rel + showECA _ (On Ins rel) = "ON INSERT Delta IN " ++ showREL rel + showECA _ (On Del rel) = "ON DELETE Delta FROM " ++ showREL rel instance ECA PAclause where - showECA _ = showPAclause - where - showPAclause :: String -> PAclause -> String - showPAclause indent pa@Do{} - = ( case paSrt pa of - Ins -> "INSERT INTO " - Del -> "DELETE FROM ")++ - showADL (paTo pa)++ - " SELECTFROM"++indent++" "++ - showADL (paDelta pa)++ - motivate indent "TO MAINTAIN" (paMotiv pa) - showPAclause indent (New c clause cj_ruls) - = "CREATE x:"++show c++";"++indent'++showPAclause indent' (clause "x")++motivate indent "MAINTAINING" cj_ruls - where indent' = indent++" " - showPAclause indent (Rmv c clause cj_ruls) - = "REMOVE x:"++show c++";"++indent'++showPAclause indent' (clause "x")++motivate indent "MAINTAINING" cj_ruls - where indent' = indent++" " - showPAclause indent (Sel c e r cj_ruls) - = "SELECT x:"++show c++" FROM codomain("++ showADL e ++");" - ++indent'++showPAclause indent' (r "x")++motivate indent "MAINTAINING" cj_ruls - where indent' = indent++" " - showPAclause indent (CHC ds cj_ruls) - = "ONE of "++intercalate indent' [showPAclause indent' d | d<-ds]++motivate indent "MAINTAINING" cj_ruls - where indent' = indent++" " - showPAclause indent (ALL ds cj_ruls) - = "ALL of "++intercalate indent' [showPAclause indent' d | d<-ds]++motivate indent "MAINTAINING" cj_ruls - where indent' = indent++" " - showPAclause indent (Nop cj_ruls) - = "DO NOTHING"++motivate indent "TO MAINTAIN" cj_ruls - showPAclause indent (Blk cj_ruls) - = "BLOCK"++motivate indent "CANNOT CHANGE" cj_ruls - showPAclause _ (Let _ _ _) = fatal 55 "showPAclause is missing for `Let`. Contact your dealer!" - showPAclause _ (Ref _) = fatal 56 "showPAclause is missing for `Ref`. Contact your dealer!" - - motivate indent motive motives = concat [ indent++showConj cj_rul | cj_rul<-motives ] - where showConj (conj,rs) = "("++motive++" "++showADL conj++" FROM "++intercalate ", " (map name rs) ++")" + showECA indent = showPAclause indent
src/lib/DatabaseDesign/Ampersand/Fspec/ShowHS.hs view
@@ -8,7 +8,7 @@ import DatabaseDesign.Ampersand.Basics import DatabaseDesign.Ampersand.Fspec.Plug import DatabaseDesign.Ampersand.Fspec.Fspec--- import DatabaseDesign.Ampersand.Fspec.ShowADL (ShowADL(..)) -- for traceability, we generate comment in the Haskell code.+ import DatabaseDesign.Ampersand.Fspec.ShowADL (ShowADL(..)) -- for traceability, we generate comment in the Haskell code. -- import DatabaseDesign.Ampersand.Fspec.FPA (fpa) import Data.List import DatabaseDesign.Ampersand.Classes@@ -69,8 +69,8 @@ instance (ShowHSName a , ShowHSName b) => ShowHSName (a,b) where showHSName (a,b) = "( "++showHSName a++" , "++showHSName b++" )" -- | The following is used to showHS flags for signs: (Concept, Concept)- instance (ShowHS a , ShowHS b) => ShowHS (a,b) where- showHS flags indent (a,b) = "("++showHS flags (indent++" ") a++","++showHS flags (indent++" ") b++")"+-- instance (ShowHS a , ShowHS b) => ShowHS (a,b) where+-- showHS flags indent (a,b) = "("++showHS flags (indent++" ") a++","++showHS flags (indent++" ") b++")" @@ -126,11 +126,17 @@ then "On " ++ show (eSrt e)++indent++" " ++ showHSName (eDcl e)++indent++" " else "On " ++ show (eSrt e)++ " " ++ showHSName (eDcl e)++ "" + instance ShowHS (InsDel, Expression, PAclause) where+ showHS flags indent (tOp, links, p) + = "( "++show tOp++indent++", "++showHS flags (indent++" ") links++indent++", "++showHS flags (indent++" ") p++indent++")"+ instance ShowHS PAclause where showHS flags indent p = case p of CHC{} -> wrap "CHC " (indent ++" ") (showHS flags) (paCls p)++ wrap (if null ms then "" else indent ++" ") (indent ++" ") showMotiv ms+ GCH{} -> wrap "GCH " (indent ++" ") (showHS flags) (paGCls p)+++ wrap (if null ms then "" else indent ++" ") (indent ++" ") showMotiv ms ALL{} -> wrap "ALL " (indent ++" ") (showHS flags) (paCls p)++ wrap (if null ms then "" else indent ++" ") (indent ++" ") showMotiv ms Do{} -> "Do "++show (paSrt p)++ " ("++showHS flags (indent++" ") (paTo p)++indent++" )"++@@ -142,10 +148,6 @@ Rmv{} -> "Rmv ("++showHS flags "" (paCpt p)++")"++ indent++" (\\x->"++showHS flags (indent++" ") (paCl p "x")++indent++" )"++ wrap (if null ms then "" else indent ++" ") (indent ++" ") showMotiv ms- Sel{} -> "Sel ("++showHS flags "" (paCpt p)++")"++- indent++" ( "++showHS flags (indent++" ") (paExp p)++indent++" )"++- indent++" (\\x->"++showHS flags (indent++" ") (paCl p "x")++indent++" )"++- wrap (if null ms then "" else indent ++" ") (indent ++" ") showMotiv ms Nop{} -> "Nop "++wrap "" (indent ++" ") showMotiv ms Blk{} -> "Blk "++wrap "" (indent ++" ") showMotiv ms Let{} -> wrap "Let " (indent ++" ") (showHS flags) (paCls p)++@@ -153,7 +155,7 @@ wrap (if null ms then "" else indent ++" ") (indent ++" ") showMotiv ms Ref{} -> "Ref "++paVar p where ms = paMotiv p- showMotiv ind (conj,rs) = "("++showHS flags (ind++" ") conj++", "++showHSName rs++")"+ showMotiv ind (conj,rs) = "( "++showHS flags (ind++" ") conj++" -- conjunct: "++showADL conj++ind++", "++showHSName rs++ind++")" instance ShowHSName SqlField where showHSName sqFd = haskellIdentifier ("sqlFld_"++fldname sqFd)@@ -172,12 +174,9 @@ indentB = indentA++" " -- adding the width of ", fldexpr = " instance ShowHS SqlFieldUsage where- showHS _ _ (PrimKey aCpt) = "PrimKey " ++showHSName aCpt- showHS _ _ (ForeignKey aCpt) = "ForeignKey "++showHSName aCpt- showHS _ _ PlainAttr = "PlainAttr "- showHS _ _ NonMainKey = "NonMainKey "- showHS _ _ UserDefinedUsage = "UserDefinedUsage "- showHS _ _ FillInLater = "FillInLater "+ showHS _ _ (TableKey isPrimary aCpt) = "TableKey " ++show isPrimary++" "++showHSName aCpt+ showHS _ _ (ForeignKey aCpt) = "ForeignKey "++showHSName aCpt+ showHS _ _ PlainAttr = "PlainAttr " instance ShowHS SqlType where showHS _ indent (SQLChar i) = indent++"SQLChar "++show i@@ -234,8 +233,8 @@ instance ShowHS DnfClause where showHS flags indent (Dnf antcs conss) = intercalate indent- [ wrap "Dnf " (indent++" ") (\_->showHS flags (indent++" ")) antcs- , wrap " " (indent++" ") (\_->showHS flags (indent++" ")) conss+ [ wrap "Dnf " (indent++" ") (\_->showHS flags (indent++" ")) antcs+ , wrap " " (indent++" ") (\_->showHS flags (indent++" ")) conss ] instance ShowHSName RuleClause where@@ -266,14 +265,13 @@ ,wrap ", procsInScope = " indentA (\_->showHSName) (procsInScope fSpec) ,wrap ", rulesInScope = " indentA (\_->showHSName) (rulesInScope fSpec) ,wrap ", declsInScope = " indentA (\_->showHSName) (declsInScope fSpec)- ,wrap ", cDefsInScope = " indentA (\_->showHSName) (cDefsInScope fSpec)+ ,wrap ", cDefsInScope = " indentA (\_->showHS flags (indentA++" ")) (cDefsInScope fSpec) ,wrap ", gensInScope = " indentA (showHS flags) (gensInScope fSpec) ,wrap ", vprocesses = " indentA (\_->showHSName) (vprocesses fSpec) ,wrap ", vplugInfos = " indentA (\_->showHS flags (indentA++" ")) (vplugInfos fSpec) ,wrap ", plugInfos = " indentA (\_->showHS flags (indentA++" ")) (plugInfos fSpec) , ", interfaceS = interfaceS'" , ", interfaceG = interfaceG'"- , ", fSwitchboard = "++showHS flags indentA (fSwitchboard fSpec) ,wrap ", fActivities = " indentA (\_->showHS flags (indentA++" ")) (fActivities fSpec) , ", fRoleRels = " ++ case fRoleRels fSpec of@@ -302,8 +300,9 @@ ,wrap ", vconjs = " indentA (\_->showHSName) (vconjs fSpec) ,wrap ", vquads = " indentA (\_->showHSName) (vquads fSpec) ,wrap ", vEcas = " indentA (\_->showHSName) (vEcas fSpec)+ , ", fSwitchboard = "++showHS flags indentA (fSwitchboard fSpec) ,wrap ", vpatterns = " indentA (\_->showHSName) (patterns fSpec)- ,wrap ", conceptDefs = " indentA (\_->showHSName) (conceptDefs fSpec)+ ,wrap ", conceptDefs = " indentA (showHS flags) (conceptDefs fSpec) ,wrap ", fSexpls = " indentA (showHS flags) (fSexpls fSpec) , ", metas = allMetas" ,wrap ", initialPops = " indentA (showHS flags) (initialPops fSpec)@@ -339,7 +338,7 @@ )++ (let ds fs = allDecls fs `uni` allUsedDecls fs `uni` vrels fSpec `uni` nub (map qDcl (vquads fs)) in if null (ds fSpec) then "" else- "\n -- *** Declarations (total: "++(show.length.ds) fSpec++" declarations) ***: "+++ "\n -- *** Declared relations (in total: "++(show.length.ds) fSpec++" relations) ***: "++ concat [indent++" "++showHSName x++indent++" = "++showHS flags (indent++" ") x |x<-ds fSpec]++"\n" ) ++ (if null (vIndices fSpec) then "" else@@ -352,8 +351,9 @@ ) ++ (if null (vprocesses fSpec ) then "" else "\n -- *** Processes (total: "++(show.length.vprocesses) fSpec++" processes) ***: "++- concat [indent++" "++showHSName x++indent++" = "++showHS flags (indent++" ") x |x<-vprocesses fSpec ]++"\n"- )+++ concat [indent++" "++showHSName x++indent++" = "++showHS flags (indent++" ") x |x<-vprocesses fSpec ]++"\n"+++ concat [indent++" "++showHSName x++indent++" = "++showHS flags (indent++" ") x |x<-map fpProc (vprocesses fSpec) ]++"\n"+ ) ++ (if null (vrules fSpec ) then "" else "\n -- *** User defined rules (total: "++(show.length.vrules) fSpec++" rules) ***: "++ concat [indent++" "++showHSName x++indent++" = "++showHS flags (indent++" ") x |x<-vrules fSpec ]++"\n"++@@ -385,10 +385,10 @@ "\n -- *** Patterns (total: "++(show.length.vpatterns) fSpec++" patterns) ***: "++ concat [indent++" "++showHSName x++indent++" = "++showHS flags (indent++" ") x |x<-vpatterns fSpec]++"\n" )++- (if null (conceptDefs fSpec) then "" else- "\n -- *** ConceptDefs (total: "++(show.length.conceptDefs) fSpec++" conceptDefs) ***: "++- concat [indent++" "++showHSName cd++indent++" = "++showHS flags (indent++" ") cd | c<-concs fSpec, cd<-concDefs fSpec c]++"\n"- )+++-- (if null (conceptDefs fSpec) then "" else+-- "\n -- *** ConceptDefs (total: "++(show.length.conceptDefs) fSpec++" conceptDefs) ***: "+++-- concat [indent++" "++showHSName cd++indent++" = "++showHS flags (indent++" ") cd | c<-concs fSpec, cd<-concDefs fSpec c]++"\n"+-- )++ (if null (allConcepts fSpec) then "" else "\n -- *** Concepts (total: "++(show.length.allConcepts) fSpec++" concepts) ***: "++ concat [indent++" "++showHSName x++indent++" = "++showHS flags (indent++" ") x@@ -397,11 +397,16 @@ where indentA = indent ++" " indentB = indent ++" " showAtomsOfConcept c =- "-- atoms: "++(show.sort) (atomsOf (gens fSpec)(initialPops fSpec) c)+ "-- atoms: [ "++ intercalate indentC strs++"]"+ where+ strs = map show (sort (atomsOf (gens fSpec)(initialPops fSpec) c))+ indentC = if sum (map length strs) > 300+ then indent ++ " -- , "+ else ", " showViolatedRule :: String -> (Rule,Pairs) -> String showViolatedRule indent' (r,ps) = intercalate indent'- [ " ( "++showHSName r++" -- This is "++(if r_sgl r then "a process rule." else "an invariant")+++ [ " ( "++showHSName r++" -- This is "++(if isSignal r then "a process rule." else "an invariant")++ indent'++" , "++ wrap "" (indent'++" ") (let showPair _ p = show p --"( "++ (show.fst) p++", "++(show.snd) p++")" in showPair) ps++ indent'++" )"@@ -450,7 +455,7 @@ , ", ptend = "++showHS flags "" (ptend pat) , ", ptrls = [" ++intercalate ", " [showHSName r | r<-ptrls pat] ++ concat [" {- no rules -} " | null (ptrls pat)] ++"]" , wrap ", ptgns = " indentB (showHS flags) (ptgns pat)- , ", ptdcs = [" ++intercalate ", " [showHSName d | d<-ptdcs pat] ++ concat [" {- no declarations -} " | null (ptdcs pat)] ++"]"+ , ", ptdcs = [ " ++intercalate (indentB++", ") [showHSName d | d<-ptdcs pat] ++ concat [" {- no relations -} " | null (ptdcs pat)] ++indentB++"]" , wrap ", ptups = " indentB (showHS flags) (ptups pat) , case ptrruls pat of [] -> ", ptrruls = [] {- no role-rule assignments -}"@@ -472,7 +477,7 @@ instance ShowHS FProcess where showHS flags indent prc = intercalate indentA- [ "FProc { fpProc = "++showHS flags (indent++" ") (fpProc prc)+ [ "FProc { fpProc = "++showHSName (fpProc prc) , wrap ", fpActivities = " indentB (showHS flags) (fpActivities prc) , " }" ] where indentA = indent ++" " -- adding the width of "FProc "@@ -489,16 +494,16 @@ , ", prcEnd = "++showHS flags "" (prcEnd prc) , ", prcRules = [" ++intercalate ", " [showHSName r | r<-prcRules prc] ++ concat [" {- no rules -} " | null (prcRules prc)] ++"]" , wrap ", prcGens = " indentB (showHS flags) (prcGens prc)- , ", prcDcls = [" ++intercalate ", " [showHSName d | d<-prcDcls prc] ++ concat [" {- no declarations -} " | null (prcDcls prc)] ++"]"+ , ", prcDcls = [" ++intercalate ", " [showHSName d | d<-prcDcls prc] ++ concat [" {- no relations -} " | null (prcDcls prc)] ++"]" , wrap ", prcUps = " indentB (showHS flags) (prcUps prc) , case prcRRuls prc of- [] -> " , prcRRuls = [] {- no role-rule assignments -}"- [(rol,rul)] -> " , prcRRuls = [ ("++show rol++", "++showHSName rul++") ]"- rs -> " , prcRRuls = [ "++intercalate (indentB++", ") ["("++show rol++", "++showHSName rul++")" | (rol,rul)<-rs] ++indentB++"]"+ [] -> ", prcRRuls = [] {- no role-rule assignments -}"+ [(rol,rul)] -> ", prcRRuls = [ ("++show rol++", "++showHSName rul++") ]"+ rs -> ", prcRRuls = [ "++intercalate (indentB++", ") ["("++show rol++", "++showHSName rul++")" | (rol,rul)<-rs] ++indentB++"]" , case prcRRels prc of- [] -> " , prcRRels = [] {- no role-relation assignments -}"- [(rol,rel)] -> " , prcRRels = [ ("++show rol++", "++showHS flags "" rel++") ]"- rs -> " , prcRRels = [ "++intercalate (indentB++", ") ["("++show rol++", "++showHS flags "" rel++")" | (rol,rel)<-rs] ++indentB++"]"+ [] -> ", prcRRels = [] {- no role-relation assignments -}"+ [(rol,rel)] -> ", prcRRels = [ ("++show rol++", "++showHS flags "" rel++") ]"+ rs -> ", prcRRels = [ "++intercalate (indentB++", ") ["("++show rol++", "++showHS flags "" rel++")" | (rol,rel)<-rs] ++indentB++"]" , wrap ", prcIds = " indentB (showHS flags) (prcIds prc) , wrap ", prcVds = " indentB (showHS flags) (prcVds prc) , wrap ", prcXps = " indentB (showHS flags) (prcXps prc)@@ -553,8 +558,8 @@ ++show (explRefIds expla)++" " instance ShowHS ExplObj where- showHS _ {-flags-} _ {-i-} peObj = case peObj of -- SJ: names of variables commented out to prevent warnings.- ExplConceptDef cd -> "ExplConceptDef " ++showHSName cd+ showHS flags i peObj = case peObj of+ ExplConceptDef cd -> "ExplConceptDef " ++showHS flags i cd ExplDeclaration d -> "ExplDeclaration "++showHSName d ExplRule str -> "ExplRule " ++show str ExplIdentityDef str-> "ExplIdentityDef "++show str@@ -597,7 +602,7 @@ showHS flags indent r@(Ru _ _ _ _ _ _ _ _ _ _ _ _) -- This pattern matching occurs so Haskell will detect any change in the definition of Ru. = intercalate indent ["Ru{ rrnm = " ++ show (rrnm r)- ," , rrexp = " ++ showHS flags (indent++" ") (rrexp r)+ ," , rrexp = -- " ++ showADL (rrexp r) ++ indent++" " ++ showHS flags (indent++" ") (rrexp r) ," , rrfps = " ++ showHS flags "" (rrfps r) ," , rrmean = " ++ showHS flags (indent++" ") (rrmean r) ," , rrmsg = " ++ showHS flags "" (rrmsg r)@@ -608,7 +613,7 @@ Nothing -> "Nothing" ," , r_env = " ++ show (r_env r) ," , r_usr = " ++ show (r_usr r)- ," , r_sgl = " ++ show (r_sgl r)+ ," , isSignal = " ++ show (isSignal r) ," , srrel = " ++ showHSName (srrel r) ," }" ]@@ -706,6 +711,7 @@ showHS flags indent (EDif (l,r)) = "EDif ("++showHS flags (indent++" ") l++indent++" ,"++showHS flags (indent++" ") r++indent++" )" showHS flags indent (ELrs (l,r)) = "ELrs ("++showHS flags (indent++" ") l++indent++" ,"++showHS flags (indent++" ") r++indent++" )" showHS flags indent (ERrs (l,r)) = "ERrs ("++showHS flags (indent++" ") l++indent++" ,"++showHS flags (indent++" ") r++indent++" )"+ showHS flags indent (EDia (l,r)) = "EDia ("++showHS flags (indent++" ") l++indent++" ,"++showHS flags (indent++" ") r++indent++" )" showHS flags indent (ECps (l,r)) = "ECps ("++showHS flags (indent++" ") l++indent++" ,"++showHS flags (indent++" ") r++indent++" )" showHS flags indent (ERad (l,r)) = "ERad ("++showHS flags (indent++" ") l++indent++" ,"++showHS flags (indent++" ") r++indent++" )" showHS flags indent (EPrd (l,r)) = "EPrd ("++showHS flags (indent++" ") l++indent++" ,"++showHS flags (indent++" ") r++indent++" )"@@ -724,10 +730,10 @@ showHS _ _ sgn = "Sign "++showHSName (source sgn)++" "++showHSName (target sgn) instance ShowHS A_Gen where- showHS flags _ gen =+ showHS _ _ gen = case gen of - Isa{} -> "Isa ("++showHS flags "" (genfp gen)++") "++showHSName (genspc gen)++" "++showHSName (gengen gen)++" "- IsE{} -> "IsE ("++showHS flags "" (genfp gen)++") "++showHSName (genspc gen)++" ["++intercalate ", " (map showHSName (genrhs gen))++"] "+ Isa{} -> "Isa "++showHSName (genspc gen)++" "++showHSName (gengen gen)++" "+ IsE{} -> "IsE "++showHSName (genspc gen)++" ["++intercalate ", " (map showHSName (genrhs gen))++"] " instance ShowHSName Declaration where showHSName d@Isn{} = haskellIdentifier ("rel_"++name d++"_"++name (source d)) -- identity relation@@ -750,11 +756,9 @@ ," , decprM = " ++ show (decprM d) ," , decprR = " ++ show (decprR d) ," , decMean = " ++ show (decMean d)- ," , decConceptDef = " ++ show (decConceptDef d) ," , decfpos = " ++ showHS flags "" (decfpos d) ," , deciss = " ++ show (deciss d) ," , decusr = " ++ show (decusr d)- ," , decISA = " ++ show (decISA d) ," , decpat = " ++ show (decpat d) ," , decplug = " ++ show (decplug d) ]++"}"@@ -762,8 +766,8 @@ Vs{} -> "Vs { decsgn = " ++ showHS flags "" (sign d)++"}" - instance ShowHSName ConceptDef where- showHSName cd = haskellIdentifier ("cDef_"++cdcpt cd)+-- instance ShowHSName ConceptDef where+-- showHSName cd = haskellIdentifier ("cDef_"++cdcpt cd) instance ShowHS ConceptDef where showHS flags _ cd@@ -811,17 +815,12 @@ DBLoc l -> "DBLoc " ++ show l Origin s -> "Origin " ++ show s OriginUnknown -> "OriginUnknown"- SomewhereNear s -> "SomewhereNear "++show s instance ShowHS Origin where showHS flags indent (FileLoc l) = "FileLoc (" ++ showHS flags indent l++")"- showHS _ _ (DBLoc l) = "DBLoc " ++ show l- showHS _ _ (Origin s) = "Origin " ++ show s- showHS _ _ OriginUnknown- = "OriginUnknown"- showHS _ _ (SomewhereNear s) - = "SomewhereNear "++show s-+ showHS _ _ (DBLoc l) = "DBLoc " ++ show l+ showHS _ _ (Origin s) = "Origin " ++ show s+ showHS _ _ OriginUnknown = "OriginUnknown" instance ShowHS Block where
src/lib/DatabaseDesign/Ampersand/Fspec/ShowMeatGrinder.hs view
@@ -84,15 +84,12 @@ instance AdlId Sign where uri (Sign s t) = "Sgn"++(show.hash) (uri s++uri t) instance AdlId Paire where - uri (l,r) = "Paire"++(show.hash) (l++"_"++r) + uri p = "Paire"++(show.hash) (srcPaire p++"_"++trgPaire p) data RelPopuType = InitPop | CurrPop deriving Show mkUriRelPopu :: Declaration -> RelPopuType -> String mkUriRelPopu d t = show t++"Of"++uri d -data Atom = Atom { atmRoot :: A_Concept -- The root concept of the atom. (this implies that there can only be a single root for - , atmVal :: String - } deriving Eq instance AdlId Atom where uri a="Atm"++atmVal a++"Of"++(uri.atmRoot) a @@ -110,10 +107,10 @@ filter (not.nullContent) ( [ Comment " " - , Comment "The following declarations are all known declarations. This list should be" - , Comment "helpfull during the developement of the meatgrinder." + , Comment "The following relations are all known to be declared. This list" + , Comment "should be helpful during the developement of the meatgrinder." , Comment "NOTE:" - , Comment " The order of the declarations is determined in a special way, based on Concepts." + , Comment " The order of the relations is determined in a special way, based on Concepts." ] ++[Comment (" "++show i++") "++"Pop "++(show.name) dcl++" "++(show.name.source) dcl++" "++(show.name.target) dcl) | (i,dcl) <- (declOrder.allDecls) fSpec] ++[ Pop "ctxnm" "Context" "Conid" @@ -140,13 +137,13 @@ where atoms :: Population -> [Atom] atoms udp = case udp of - PRelPopu{} -> map (mkAtom ((source.popdcl) udp).fst) (popps udp) - ++ map (mkAtom ((target.popdcl) udp).snd) (popps udp) - PCptPopu{} -> map (mkAtom ( popcpt udp) ) (popas udp) + PRelPopu{} -> map (mkAtom ((source.popdcl) udp).srcPaire) (popps udp) + ++ map (mkAtom ((target.popdcl) udp).trgPaire) (popps udp) + PCptPopu{} -> map (mkAtom ( popcpt udp) ) (popas udp) nullContent :: Pop -> Bool nullContent (Pop _ _ _ []) = True nullContent _ = False - -- | the order of declarations is done by an order of the concepts, which is a hardcoded list + -- | the order of relations is done by an order of the concepts, which is a hardcoded list declOrder ::[Declaration] -> [(Int,Declaration)] declOrder decls = zip [1..] (concatMap (sortBy f) (declGroups conceptOrder decls)) where @@ -263,7 +260,7 @@ Nothing -> False Just (_,d) -> d == dcl instance MetaPopulations Atom where - metaPops _ _ atm = [] + metaPops _ _ _ = [] -- [ Pop "root" "AtomID" "Concept" -- [(uri atm,uri(atmRoot atm))] -- , Pop "atomvalue" "AtomID" "AtomValue"
src/lib/DatabaseDesign/Ampersand/Fspec/ShowXMLtiny.hs view
@@ -145,6 +145,7 @@ (EDif (l,r)) -> Elem (simpleTag "DIFF") (map mkXmlTree [l,r]) (ELrs (l,r)) -> Elem (simpleTag "LRES") (map mkXmlTree [l,r]) (ERrs (l,r)) -> Elem (simpleTag "RRES") (map mkXmlTree [l,r]) + (EDia (l,r)) -> Elem (simpleTag "DIAM") (map mkXmlTree [l,r]) (ECps (l,r)) -> Elem (simpleTag "RMUL") (map mkXmlTree [l,r]) (ERad (l,r)) -> Elem (simpleTag "RADD") (map mkXmlTree [l,r]) (EPrd (l,r)) -> Elem (simpleTag "RPRD") (map mkXmlTree [l,r])
src/lib/DatabaseDesign/Ampersand/Fspec/Switchboard.hs view
@@ -1,12 +1,11 @@ {-# OPTIONS_GHC -Wall #-} module DatabaseDesign.Ampersand.Fspec.Switchboard (SwitchBdDiagram(..),switchboardAct,sbDiagram,processModel) where --- Go to http://hackage.haskell.org/package/graphviz for Graphviz bindings for Haskell. import Data.GraphViz import Data.GraphViz.Attributes.Complete import Data.List - import DatabaseDesign.Ampersand.Basics (fatalMsg,Identified(..),flp) + import DatabaseDesign.Ampersand.Basics (fatalMsg,Identified(..), flp) import DatabaseDesign.Ampersand.ADL1 import DatabaseDesign.Ampersand.Classes import DatabaseDesign.Ampersand.Fspec.Fspec @@ -68,13 +67,27 @@ } deriving (Show,Eq) -} eventsIn = [(e,d,act) | act<-fpActivities fp, eca<-actEcas act, let On e d = ecaTriggr eca] - eventsOut = [(e,d,act) | act<-fpActivities fp, eca<-actEcas act, (e,d)<-events (ecaAction eca)] + eventsOut = [(e,d,act) | act<-fpActivities fp, eca<-actEcas act, (e,d)<-(nub.evs.ecaAction) eca] + where evs :: PAclause -> [(InsDel,Declaration)] + evs clause + = case clause of + CHC{} -> (concat.map evs) (paCls clause) + GCH{} -> concat [ evs p | (_,_,p)<-paGCls clause] + ALL{} -> (concat.map evs) (paCls clause) + Do{} -> [(paSrt clause, paTo clause)] + New{} -> evs (paCl clause "") + Rmv{} -> evs (paCl clause "") + Nop{} -> [] + Blk{} -> [] + Let{} -> fatal 305 "events for let undetermined" + Ref{} -> fatal 306 "events for Ref undetermined" + colorRule :: Rule -> X11Color colorRule r | isSignal r = Orange | otherwise = Green - sbDiagram :: Fspc -> Fswitchboard -> SwitchBdDiagram - sbDiagram fSpec fsb + sbDiagram :: Fspc -> SwitchBdDiagram + sbDiagram fSpec = SBdgrm { sbName = name fSpec , sbdotGraph @@ -90,6 +103,7 @@ } } where + fsb = fSwitchboard fSpec --DESCR -> The relations from which changes can come inEvNodes = [ DotNode { nodeID = nameINode eventsIn ev , nodeAttributes = [Label (StrLabel (fromString (show (eSrt ev)++" "++showADL (eDcl ev))))] @@ -121,7 +135,7 @@ , toNode = nameCNode (fsbConjs fsb) (rul,c) , edgeAttributes = [Dir Forward] } - | (rul,c)<-fsbConjs fsb, ev<-eventsIn, eDcl ev `elem` declsUsedIn c] + | (rul,c)<-fsbConjs fsb, ev<-eventsIn, eDcl ev `elem` relsUsedIn c] edgesCjEc = [ DotEdge { fromNode = nameCNode (fsbConjs fsb) (rul,c) , toNode = nameENode (fsbECAs fsb) eca , edgeAttributes = [Dir Forward] @@ -133,27 +147,14 @@ , edgeAttributes = [Dir Forward] } | eca<-fsbECAs fsb, not (isBlk (ecaAction eca)) - , Do tOp rel _ _<-dos (ecaAction eca) -{- for testing purposes: - , doAct<-dos (ecaAction eca) - , if not (isDo doAct) then fatal 136 ("not in \"Do\" shape: "++showECA fSpec "\n " doAct) else True - , let Do tOp expr _ _=doAct - isTm ERel{} = True - isTm _ = False - , if not (isTm expr) then fatal 138 ("not in \"ERel\" shape: "++showECA fSpec "\n " doAct) else True - , let ERel rel _ = expr -Note: -The expression 'isDo doAct' will become False if a property is being maintained -(a property is a relation that are both Sym and Asy). -This situation is implicitly avoided by 'Do tOp (ERel rel _) _ _<-dos (ecaAction eca)'. --} + , On tOp rel<-eventsFrom (ecaAction eca) ] nameINode = nmLkp fSpec "in_" nameCNode = nmLkp fSpec "cj_" nameENode = nmLkp fSpec "eca_" nameONode = nmLkp fSpec "out_" eventsIn = nub [ecaTriggr eca | eca<-fsbECAs fsb, not (isBlk (ecaAction eca)) ] - eventsOut = nub [On tOp rel | eca<-fsbECAs fsb, let act=ecaAction eca, not (isBlk act), Do tOp rel _ _<-dos act] + eventsOut = nub [evt | eca<-fsbECAs fsb, let act=ecaAction eca, not (isBlk act), evt<-eventsFrom act] switchboardAct :: Fspc -> Activity -> SwitchBdDiagram switchboardAct fSpec act @@ -208,7 +209,7 @@ "+-"))) ,Dir Forward] } - | (rul,c)<-conjuncts, r<-declsUsedIn c, r `elem` fromRels] + | (rul,c)<-conjuncts, r<-relsUsedIn c, r `elem` fromRels] edgesOut = [ DotEdge { fromNode = nameCNode conjuncts (rul,c) , toNode = nameONode toRels r , edgeAttributes = [Label (StrLabel (fromString @@ -217,7 +218,7 @@ "+-"))) ,Dir Forward] } - | (rul,c)<-conjuncts, r<-declsUsedIn c] + | (rul,c)<-conjuncts, r<-relsUsedIn c] nameINode :: [Declaration] -> Declaration -> String nameINode = nmLkp fSpec "in_" nameCNode = nmLkp fSpec "cj_" @@ -234,13 +235,14 @@ positiveIn :: Expression -> Declaration -> [Bool] positiveIn expr decl = f expr -- all are True, so an insert in rel means an insert in expr where - f (EEqu _) = fatal 245 "Illegal call of positiveIn." + f (EEqu _) = fatal 237 "Illegal call of positiveIn." f (EImp (l,r)) = f (notCpl l .\/. r) f (EIsc (l,r)) = f l ++ f r f (EUni (l,r)) = f l ++ f r - f (EDif (l,r)) = f (l ./\. notCpl r) - f (ELrs (l,r)) = f (l .!. notCpl (flp r)) - f (ERrs (l,r)) = f (notCpl (flp l) .!. r) + f (EDif (l,r)) = f l ++ f (notCpl r) + f (ELrs (l,r)) = f l ++ f (notCpl r) + f (ERrs (l,r)) = f (notCpl l) ++ f r + f (EDia (l,r)) = f (flp l .\. r ./\. l ./. flp r) f (ECps (l,r)) = f l ++ f r f (ERad (l,r)) = f l ++ f r f (EPrd (l,r)) = f l ++ f r
src/lib/DatabaseDesign/Ampersand/Fspec/ToFspec/ADL2Fspec.hs view
@@ -1,6 +1,6 @@-{-# OPTIONS_GHC -Wall #-} -module DatabaseDesign.Ampersand.Fspec.ToFspec.ADL2Fspec - (makeFspec,actSem, delta, allClauses, quads, assembleECAs, preEmpt, genPAclause, editable, conjuncts) +{-# OPTIONS_GHC -Wall #-} +module DatabaseDesign.Ampersand.Fspec.ToFspec.ADL2Fspec + (makeFspec,allClauses, quads, preEmpt, editable) where import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree import DatabaseDesign.Ampersand.Core.Poset @@ -11,16 +11,17 @@ import DatabaseDesign.Ampersand.ADL1 import DatabaseDesign.Ampersand.Fspec.Fspec import DatabaseDesign.Ampersand.Misc - import DatabaseDesign.Ampersand.Fspec.ToFspec.NormalForms -- (conjNF,disjNF,normPA, exprUni2list, exprIsc2list, exprCps2list) + import DatabaseDesign.Ampersand.Fspec.ToFspec.NormalForms -- (delta,conjNF,disjNF,normPA) import DatabaseDesign.Ampersand.Fspec.ToFspec.ADL2Plug + import DatabaseDesign.Ampersand.Fspec.ToFspec.Calc -- import DatabaseDesign.Ampersand.Fspec.ShowHS -- only for diagnostic purposes during debugging import DatabaseDesign.Ampersand.Fspec.ShowADL import Text.Pandoc import Data.Maybe - import Data.List (nub,nubBy,intercalate,intersect,partition,group,delete) + import Data.List (nub,nubBy,intersect,partition,group,delete) import DatabaseDesign.Ampersand.ADL1.Expression import Data.Char (toLower) --- import Debug.Trace +-- import Debug.Trace -- only for diagnostic purposes during debugging head :: [a] -> a head [] = fatal 30 "head must not be used on an empty list!" head (a:_) = a @@ -63,15 +64,15 @@ , vconjs = let equalOnConjunct a b = rc_conjunct a == rc_conjunct b in nubBy equalOnConjunct (concatMap (cl_conjNF.qClauses)allQuads) , vquads = allQuads - , vEcas = {-preEmpt-} assembleECAs [q | q<-vquads fSpec, isInvariantQuad q] -- TODO: preEmpt gives problems. Readdress the preEmption problem and redo, but properly. + , vEcas = let (ecas,_)=(unzip.assembleECAs) fSpec in {-preEmpt-} ecas -- TODO: preEmpt gives problems. Readdress the preEmption problem and redo, but properly. , vrels = calculatedDecls - , allUsedDecls = declsUsedIn context - , allDecls = declarations context + , 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, x ) | x<-(genrhs gen)] + IsE{} -> [(genspc gen, g ) | g<-genrhs gen] in concatMap f (gens context) , vpatterns = patterns context , vgens = gens context @@ -81,7 +82,7 @@ , 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)] + , allViolations = [(r,vs) |r<-allrules, not (isSignal r), let vs = ruleviolations (gens context) initialpops r, not (null vs)] } themesInScope = if null (ctxthms context) -- The names of patterns/processes to be printed in the functional specification. (for making partial documentation) then map name (patterns context) ++ map name allProcs @@ -95,13 +96,17 @@ gensInThemesInScope = ctxgs context ++ concatMap prcGens procsInThemesInScope ++ concatMap ptgns pattsInThemesInScope allQuads = quads flags (\_->True) allrules - initialpops = userDefPops++singletonpops - userDefPops = ctxpopus context - singletonpops = [ PCptPopu{ popcpt = head [c | EMp1 _ c<-cl ] - , popas = [a | EMp1 a c<-cl, not (name c=="SESSION") ] - } - | cl<-eqCl (\(EMp1 _ c)->c) (mp1Exprs context)] - isInvariantQuad q = null [r | (r,rul)<-maintains context, rul==cl_rule (qClauses q)] + 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) + +-- isInvariantQuad q = null [r | (r,rul)<-maintains context, rul==cl_rule (qClauses q)] allrules = vRules ++ gRules vRules = udefrules context -- all user defined rules gRules = multrules context++identityRules context @@ -116,7 +121,7 @@ calcProps d = d{decprps_calc = Just calculated} where calculated = decprps d `uni` [Tot | d `elem` totals] `uni` [Sur | d `elem` surjectives] - calculatedDecls = map calcProps (declarations context) + calculatedDecls = map calcProps (relsDefdIn context) constructKernels = foldl f (group (delete ONE (concs context))) (gens context) where f disjuncLists g = concat haves : nohaves where @@ -149,7 +154,7 @@ | p <- uniqueNames (map name definedplugs) -- the names of definedplugs will not be changed, assuming they are all unique (makeGeneratedSqlPlugs flags context totsurs entityRels) ] - -- declarations to be saved in generated plugs: if decplug=True, the declaration has the BYPLUG and therefore may not be saved in a database + -- relations to be saved in generated plugs: if decplug=True, the declaration has the BYPLUG and therefore may not be saved in a database -- WHAT -> is a BYPLUG? entityRels = [ d | d<-calculatedDecls, not (decplug d)] -- The persistent relations. @@ -201,14 +206,14 @@ -- Ampersand generates interfaces for the purpose of quick prototyping. -- A script without any mention of interfaces is supplemented -- by a number of interface definitions that gives a user full access to all data. --- Step 1: select and arrange all declarations to obtain a set cRels of total relations +-- Step 1: select and arrange all relations to obtain a set cRels of total relations -- to ensure insertability of entities (signal declarations are excluded) - cRels = [ EDcD d | d@Sgn{}<-declarations context, not(deciss d), isTot d, not$decplug d]++ - [flp (EDcD d) | d@Sgn{}<-declarations context, not(deciss d), not (isTot d) && isSur d, not$decplug d] --- Step 2: select and arrange all declarations to obtain a set dRels of injective relations + 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] +-- Step 2: select and arrange all relations to obtain a set dRels of injective relations -- to ensure deletability of entities (signal declarations are excluded) - dRels = [ EDcD d | d@Sgn{}<-declarations context, not(deciss d), isInj d, not$decplug d]++ - [flp (EDcD d) | d@Sgn{}<-declarations context, not(deciss d), not (isInj d) && isUni 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] -- Step 3: compute longest sequences of total expressions and longest sequences of injective expressions. maxTotPaths = clos cRels -- maxTotPaths = cRels+, i.e. the transitive closure of cRels maxInjPaths = clos dRels -- maxInjPaths = dRels+, i.e. the transitive closure of dRels @@ -225,7 +230,7 @@ -- ii) generate interfaces starting with INTERFACE concepts: V[ONE*Concept] -- note: based on a theme one can pick a certain set of generated interfaces (there is not one correct set) -- default theme => generate interfaces from the clos total expressions and clos injective expressions (see step1-3). --- student theme => generate interface for each concept with declarations where concept is source or target (note: step1-3 are skipped) +-- student theme => generate interface for each concept with relations where concept is source or target (note: step1-3 are skipped) interfaceGen = step4a ++ step4b step4a | theme flags == StudentTheme @@ -253,7 +258,7 @@ , ifcPrp = "Interface " ++name c++" has been generated by Ampersand." , ifcRoles = [] } - | c<-concs fSpec, let directdeclsExprs = [EDcD d | d<-declarations fSpec, c `elem` concs d]] + | c<-concs fSpec, let directdeclsExprs = [EDcD d | d<-relsDefdIn fSpec, c `elem` concs d]] --end student theme --otherwise: default theme | otherwise --note: the uni of maxInj and maxTot may take significant time (e.g. -p while generating index.htm) @@ -362,7 +367,7 @@ ] } in s where --- declarations that may be affected by an edit action within the transaction +-- relations that may be affected by an edit action within the transaction decls = relsUsedIn rul -- the quads that induce automated action on an editable relation. -- (A quad contains the conjunct(s) to be maintained.) @@ -383,8 +388,6 @@ f q x = q `un` [(a, qs `uni` qs', b') | (a, qs, b) <- q, b == x, (a', qs', b') <- q, a' == x] - fst3 (a,_,_) = a - thd3 (_,_,c) = c ts `un` [] = ts ts `un` ((a',qs',b'):ts') = ([(a,qs `uni` qs',b) | (a,qs,b)<-ts, a==a' && b==b']++ @@ -413,7 +416,7 @@ } | (dnfClause,i)<-zip (conjuncts rule) [0..] ] rule allShifts :: Options -> DnfClause -> [DnfClause] - allShifts _ conjunct = nub [ e'| e'<-shiftL conjunct++shiftR conjunct] + allShifts _ conjunct = (map head.eqCl (disjNF.dnf2expr)) [ e'| e'<-shiftL conjunct++shiftR conjunct] -- we want to nub all dnf-clauses, but nub itself does not do the trick... -- allShifts conjunct = error $ show conjunct++concat [ "\n"++show e'| e'<-shiftL conjunct++shiftR conjunct] -- for debugging where {- @@ -427,7 +430,7 @@ | null antcs || null conss = [dc] -- shiftL doesn't work here. This is just to make sure that both antss and conss are really not empty | otherwise = [ Dnf ass (case css of [] -> let antcExpr = foldr1 (./\.) ass in - if source antcExpr==target antcExpr then [EDcI (source antcExpr)] else fatal 425 "antcExpr should be endorelation" + if isEndo antcExpr then [EDcI (source antcExpr)] else fatal 425 "antcExpr should be endorelation" _ -> css ) | (ass,css)<-nub (move antcs conss) @@ -445,12 +448,14 @@ , length (eqClass (==) headEs) == 1 -- example: True, because map head css == [ "x" ] , let h=head headEs -- example: h= "x" , isUni h -- example: assume True - , ts<-move [flp h.:.as |as<-ass] (map tailECps css)]++ -- example: ts<-move [ [flp "x","r","s"], [flp "x","p","r"] ] [ ["y","z"] ] + , ts<-move [if source h==source as then flp h.:.as else fatal 455 "type mismatch" + |as<-ass] (map tailECps css)]++ -- example: ts<-move [ [flp "x","r","s"], [flp "x","p","r"] ] [ ["y","z"] ] [ts | let lastEs = map lastECps css , length (eqClass (==) lastEs) == 1 , let l=head lastEs , isInj l - , ts<-move [as.:.flp l |as<-ass] (map initECps css)] -- example: ts<-move [ ["r","s",flp "z"], ["p","r",flp "z"] ] [ ["x","y"] ] + , ts<-move [if target as==target l then as.:.flp l else fatal 461 "type mismatch" + |as<-ass] (map initECps css)] -- example: ts<-move [ ["r","s",flp "z"], ["p","r",flp "z"] ] [ ["x","y"] ] else [] -- Here is (informally) what the example does: -- move [ r;s , p;r ] [ x;y ] @@ -484,12 +489,14 @@ , length (eqClass (==) headEs) == 1 -- example: True, because map headECps ass == [ "r", "r" ] , let h=head headEs -- example: h= "r" , isSur h -- example: assume True - , ts<-move (map tailECps ass) [flp h.:.cs |cs<-css]]++ -- example: ts<-move [["s"], ["r"]] [ [flp "r","x","y","z"] ] + , ts<-move (map tailECps ass) [if source h==source cs then flp h.:.cs else fatal 496 "type mismatch" + |cs<-css]]++ -- example: ts<-move [["s"], ["r"]] [ [flp "r","x","y","z"] ] [ts | let lastEs = map lastECps ass , length (eqClass (==) lastEs) == 1 -- example: False, because map lastECps ass == [ ["s"], ["r"] ] , let l=head lastEs , isTot l - , ts<-move (map initECps ass) [cs.:.flp l |cs<-css]] -- is dit goed? cs.:.flp l wordt links zwaar, terwijl de normalisator rechts zwaar maakt. + , ts<-move (map initECps ass) [if target cs==target l then cs.:.flp l else fatal 502 "type mismatch" + |cs<-css]] -- is dit goed? cs.:.flp l wordt links zwaar, terwijl de normalisator rechts zwaar maakt. else [] -- Here is (informally) what the example does: -- move [ r;s , r;r ] [ x;y ] @@ -532,64 +539,6 @@ isEDcI _ = False --- Deze functie neemt verschillende clauses samen met het oog op het genereren van code. --- Hierdoor kunnen grotere brokken procesalgebra worden gegenereerd. - assembleECAs :: [Quad] -> [ECArule] - assembleECAs qs - = [] -- [er{ecaAction=normPA (ecaAction er)} | (ecarule,i) <- zip ecas [(1::Int)..], let er=ecarule i] - where - -- the quads that are derived for this fSpec contain dnf clauses. - -- A dnf clause dc that is generated from rule r contains the information how to restore the truth of r. - -- Suppose an insert or delete event on a relation rel has occurred and rel is used in rule r. - -- A restore action from dnf clause dc will then restore the truth of r. - - -- First, we harvest the quads from fSpec in quadruples. - -- rel is a relation that may be affected by an (insert- or delete-) event. - -- dnfClauses is a set of dnf clauses that can restore the truth of conj after rel has been affected. - -- conj is an expression that must remain true at all times. - -- rul is the rule from which the above have been derived (for traceability) - -- these quadruples are organized per relation. - -- This puts together all dnf clauses we need for each relation. - relEqCls = eqCl fst4 [(dcl,rc_dnfClauses x,rc_conjunct x,cl_rule ccrs) | Quad dcl ccrs<-qs, x <-cl_conjNF ccrs] - -- The eca rules can now be assembled from the available material - ecas - = [ ECA (On ev dcl) delt act - | relEq <- relEqCls -- The material required for one relation - , let (dcl,_,_,_) = head relEq -- This is the relation - , let EDcD delt = delta (sign dcl) -- delt is a placeholder for the pairs that have been inserted or deleted in rel. - , ev<-[Ins,Del] -- This determines the event: On ev rel - , let act = ALL [ CHC [ (if isTrue clause' || isTrue step then Nop else - if isFalse clause' then Blk else --- if not (visible rel) then Blk else - let visible _ = True in genPAclause visible ev toExpr viols - ) [(conj,causes)] -- the motivation for these actions - | clause@(Dnf antcs conss) <- dnfClauses - , let expr = dnf2expr clause - , let sgn = sign expr -- different dnf clauses may have different signatures - , let clause' = conjNF (subst (dcl, actSem ev dcl (delta (sign dcl))) expr) - , let step = conjNF (notCpl expr .\/. clause') - , let viols = conjNF (notCpl clause') - , let negs = foldr (./\.) (EDcV sgn) antcs - , let poss = foldr (.\/.) (notCpl (EDcV sgn)) conss - , let frExpr = if ev==Ins - then conjNF negs - else conjNF poss - , dcl `elem` relsUsedIn frExpr - , let toExpr = if ev==Ins - then conjNF poss - else conjNF (notCpl negs) - ] - [(conj,causes)] -- to supply motivations on runtime - | conjEq <- eqCl snd3 [(dnfClauses,conj,rule) | (_,dnfClauses,conj,rule)<-relEq] - , let causes = nub (map thd3 conjEq) - , let (dnfClauses,conj,_) = head conjEq - ] - [(conj,nub [r |(_,_,_,r)<-cl]) | cl<-eqCl thd4 relEq, let (_,_,conj,_) = head cl] -- to supply motivations on runtime - ] - fst4 (w,_,_,_) = w - snd3 (_,y,_) = y - thd3 (_,_,z) = z - thd4 (_,_,z,_) = z -- If one rule r blocks upon an event, e.g. e@(ON Ins rel), while another ECA rule r' -- maintains something else with that same event e, we can save r' the trouble. @@ -624,350 +573,16 @@ 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 (Sel c e cl m) = ((fst.cascade rel.cl) "dummystr", Sel c e (snd.cascade rel.cl) m) +-- cascade rel (Sel c e cl m) = ((fst.cascade rel.cl) "dummystr", Sel c e (snd.cascade rel.cl) 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" -- HJO, 20131205:Toegevoegd om warning te verwijderen cascade _ (Ref _) = fatal 612 "Deze constructor is niet gedefinieerd" -- HJO, 20131205:Toegevoegd om warning te verwijderen + cascade _ (GCH{}) = fatal 655 "Deze constructor is niet gedefinieerd" -- SJO, 20140428:Toegevoegd om warning te verwijderen - conjuncts :: Rule -> [DnfClause] - conjuncts = map disjuncts.exprIsc2list.conjNF.rrexp - disjuncts :: Expression -> DnfClause - disjuncts conj = (split (Dnf [] []).exprUni2list) conj - where split :: DnfClause -> [Expression] -> DnfClause - split (Dnf antc cons) (ECpl e: rest) = split (Dnf (e:antc) cons) rest - split (Dnf antc cons) ( e: rest) = split (Dnf antc (e:cons)) rest - split dc [] = dc - -- | Action semantics for inserting a delta into a relation dcl. - actSem :: InsDel -> Declaration -> Expression -> Expression - actSem Ins dcl e@(EDcD d) | dcl==d = EDcD dcl - | otherwise = EDcD dcl .\/. e - actSem Ins dcl delt | sign dcl/=sign delt = fatal 598 "Type error in actSem Ins" - | otherwise = disjNF (EDcD dcl .\/. delt) - actSem Del dcl e@(EDcD d) | dcl==d = notCpl (EDcV (sign d)) - | otherwise = EDcD dcl ./\. notCpl e - actSem Del dcl delt | sign dcl/=sign delt = fatal 603 "Type error in actSem Del" - | otherwise = conjNF (EDcD dcl ./\. notCpl delt) - - delta :: Sign -> Expression - delta sgn - = EDcD Sgn { decnm = "Delta" - , decsgn = sgn - , decprps = [] - , decprps_calc = Nothing - , decprL = "" - , decprM = "" - , decprR = "" - , decMean = AMeaning [ A_Markup Dutch ReST (string2Blocks ReST "TODO: Doel van deze Delta relatie opschrijven") - , A_Markup English ReST (string2Blocks ReST "TODO: Write down the purpose of this Delta relation.") - ] - , decConceptDef = Nothing - , decfpos = Origin ("generated relation (Delta "++show sgn++")") - , deciss = True - , decusr = False - , decISA = False - , decpat = "" - , decplug = True - } - - -- | de functie genPAclause beschrijft de voornaamste mogelijkheden om een expressie delta' te verwerken in expr (met tOp'==Ins of tOp==Del) --- TODO: Vind een wetenschappelijk artikel waar de hier beschreven transformatie uitputtend wordt behandeld. --- TODO: Deze code is onvolledig en misschien zelfs fout.... - genPAclause :: (Declaration->Bool) -- ^True if a relation may be changed (i.e. is editable) - -> InsDel -- ^the type of action: Insert or Delete - -> Expression -- ^the expression in which a delete or insert takes place - -> Expression -- ^the delta to be inserted or deleted - -> [(Expression,[Rule])] -- ^the motivation, consisting of the conjuncts (traced back to their rules) that are being restored by this code fragment. - -> PAclause - genPAclause editAble tOp' expr1 delta1 motive = genPAcl delta1 tOp' expr1 motive - where - genPAcl deltaX tOp exprX motiv = - case (tOp, exprX) of - (_ , EFlp x) -> genPAcl (flp deltaX) tOp x motiv - (_ , EBrk x) -> genPAcl deltaX tOp x motiv - (Ins, ECpl x) -> genPAcl deltaX Del x motiv - (Del, ECpl x) -> genPAcl deltaX Ins x motiv - (Ins, e@EUni{}) -> CHC [ genPAcl deltaX Ins f motiv | f<-exprUni2list e{-, not (f==expr1 && Ins/=tOp') -}] motiv -- the filter prevents self compensating PA-clauses. - (Ins, e@EIsc{}) -> ALL [ genPAcl deltaX Ins f [] | f<-exprIsc2list e ] motiv - (Ins, e@ECps{}) -> CHC [ {- the following might be useful for diagnostics: - if showADL exprX=="project;partof~" - then fatal 702 ( "Diagnostic error\n"++ - "chop (exprCps2list e)= "++show [(map showADL ls, map showADL rs)| (ls,rs)<-chop (exprCps2list e) ]++ - "\nConcepts c="++showADL c++", target els="++showADL (target els)++", source ers="++showADL (source ers)++ - "\nfLft \"x\"= "++showADL (fLft "x") ++ - "\nfRht \"x\"= "++showADL (fRht "x") - ) - else -} - if els==flp ers - then CHC [ New c fLft motiv - , Sel c els fLft motiv - ] motiv - else CHC [ New c (\x->ALL [fLft x, fRht x] motiv) motiv - , Sel c els fLft motiv - , Sel c (flp ers) fRht motiv - ] motiv - | (ls,rs)<-chop (exprCps2list e) - , let els=foldCompose ls - , let ers=foldCompose rs - , let c=source ers -- SJ 20131202: Note that target ers==source els - , let fLft atom = genPAcl (disjNF ((EMp1 atom (source ers) .*. deltaX) .\/. notCpl ers)) Ins ers [] - , let fRht atom = genPAcl (disjNF ((deltaX .*. EMp1 atom (target els)) .\/. notCpl els)) Ins els [] - ] motiv - where foldCompose xs = case xs of - [] -> fatal 659 "Going into (foldr1 (.:.)) with an empty list" - _ -> foldr1 (.:.) xs -{- Problem: how to insert Delta into r;s -This corresponds with: genPAclause editAble Ins (ECps (r,s)) Delta motive -Let us solve it mathematically, and gradually transform via pseudo-code into Haskell code. -The problem is how to find dr and ds such that - Delta \/ r;s |- (dr\/r) ; (ds\/s) -Since r;s |- (dr\/r) ; (ds\/s) is true by definition, we simplify: - Delta |- (dr\/r) ; (ds\/s) -One way of doing this is the "bow tie" solution, which uses one element, c, and chooses dr = Delta*c and ds = c*Delta. -There is a fair chance, however, that this solution breaks existing rules. -For example, if Delta< has multiple elements and r is injective, we have a violation. (Similarly, if Delta> has multiple elements and s is univalent) -Since we make no assumptions on the rules that r and s must satisfy, let us look for more subtle solutions. -For instance, we might choose dr = d;s~ and ds = r~;d, for that part of Delta that is not in r;s (let d = Delta-r;s) -The approach is to do this first, then see which links are left and connect these last ones with a bow tie approach. - -SEQ [ ASSIGN d (EDif (delta,e)) - , ALL [ FOREACH (x,y) FROM d DO - SEQ [ SEL z FROM SELECT (x',z) FROM r WHERE x==x' - , INSERT (z,y) INTO s - ] - , FOREACH (x,y) FROM d DO - SEQ [ SEL z FROM SELECT (z,y') FROM s WHERE y==y' - , INSERT (x,z) INTO r - ] - , SEQ [ ASSIGN delta' [ (x,y) | (x,y)<-d, x `notElem` dom e, y `notElem` cod e] - , CHC [ NEW z IN target r `meet` source s - , SEL z FROM contents (target r `meet` source s) - ] - , INSERT [ (z,y) | (x,y)<-delta' ] INTO s - , INSERT [ (x,z) | (x,y)<-delta' ] INTO r - ] - ] - ] - -On this algorithm, there are some attractive optimizations. -Some code generation can be prevented, when we know that r or s are not editable. -Generation of a SEL statement can be prevented, when we know that r is univalent or s is injective. - -This is what becomes of it: - -SEQ [ ASSIGN d (EDif (delta,e)) - , COMMENT "Variable d contains only those links that need to be inserted into e." - , CONDITIONAL not (null d) - (ALL((if editable s - then [ COMMENT "The following statement inserts tuples only on the right side of the composition." - , FOREACH (x,y) FROM d DO - SEQ [ if injective s - then SELECT (x',z) FROM r WHERE x==x' - else SEL z FROM SELECT (x',z) FROM r WHERE x==x' - , INSERT (z,y) INTO s - ] - ] - else [] )++ - (if editable r - then [ COMMENT "The following statement inserts tuples only on the left side of the composition." - , FOREACH (x,y) FROM d DO - SEQ [ if injective s - then SELECT (z,y') FROM s WHERE y==y' - else SEL z FROM SELECT (z,y') FROM s WHERE y==y' - , INSERT (x,z) INTO r - ] - ] - else [] )++ - (if editable r && editable s - then [ COMMENT "All links that can be added just in r or just in s have now been added. Now we finish the rest with a bow tie." - , COMMENT "The following statement inserts tuples both on the left and the right side of the composition." - , SEQ [ ASSIGN delta' [ (x,y) | (x,y)<-d, x `notElem` dom e, y `notElem` cod e] - , CHC [ NEW z IN target r `meet` source s - , SEL z FROM contents (target r `meet` source s) - ] - , INSERT [ (z,y) | (x,y)<-delta' ] INTO s - , INSERT [ (x,z) | (x,y)<-delta' ] INTO r - ] - ] - else [] ))) - ] - -We can use an "Algebra of Imperative Programs" to move towards real code. Suppose we have the following data structure of imperative programs: -data Program = SEQ [Program] -- execute programs in sequence - | CONDITIONAL Cond Program -- evaluate the computation (Cond), which yields a boolean result, and execute the program if it is true - | CHC [Program] -- execute precisely one program from the list - | ALL [Program] -- execute all programs in arbitrary order (may even be parallel) - | New String Concept Program -- create a named variable (the String) of type C (the concept) and execute the program, which may use this concept. - | NewAtom PHPRel Concept -- assign a brand new atom of type Concept to the PHPRel, which must be a PHPvar (i.e. a variable). - | ASSIGN PHPRel PHPExpression -- execute a relation expression in PHP and assign its result to the PHPRel, which must be a PHPvar (i.e. a variable). - | Insert PHPExpression DBrel -- execute the computation and insert its result into the database - | Delete PHPExpression DBrel -- execute the computation and delete its result from the database - | COMMENT String -- ignore this. This is part of the algebra, so we can generate commented code. - | Nop -- do nothing - | Blk [(Expression,[Rule])] -- abort, leaving an error message that motivates this. The motivation consists of the conjuncts (traced back to their rules) that are being restored by this code fragment. -data Cond = NotNull PHPRel -- a condition on a PHPRel - -In order to proceed to the next refinement, we have enriched the PHPExpression data structure with variables (PHPvar) and queries (PHPqry) -We need a variable in PHP that represents a relation, which gets the label PHPvar. -We also need to query an Expression on the SQL server. The result of that query is relation contents in PHP, which gets the label PHPqry. -The 'almost Haskell' program fragment for generating an insertion of Delta into r;s is now: -let delta = PHPvar{ phpVar = "delta" -- this is the input - , phptyp = phpsign (sign e) -- the type is used nowhere, but it feels good to know the type. - } in -let d = PHPvar{ phpVar = "d" -- this is the input, from which everything already in Ecps es is removed. - , phptyp = phpsign (sign e) -- the type is used nowhere, but it feels good to know the type. - } in -let newAtoms = [ NewAtom (PHPvar (head (name c):show i) c | (r,s,i)<-zip3 (init es) (tail es) [1..], let c=target(r) `meet` source(s)] in -SEQ [ ASSIGN d (PHPEDif (PHPERel delta, PHPRel (PHPqry e))) -- let d = Delta - e0;e1;e2;... - , COMMENT "d contains all links that must be inserted in r;s" - , CONDITIONAL (NotNull d) - (SEQ [ ALL ( (if editable(head es) - then [ Insert (PHPECps [PHPERel d, PHPERel (PHPqry (flp (ECps (tail es))))]) (mkDBrel (head es)) ] - else []) ++ - (if editable(last es) - then [ Insert (PHPECps [PHPERel (PHPqry (flp (ECps (init es)))), PHPERel d]) (mkDBrel (last es)) ] - else []) ) - , COMMENT "All links that can be added just in r or just in s have now been added. Now we finish the rest with a bow tie."] ++ - if or [not (editable e) | e<-es] || or [ not (editable (I c)) | NewAtom _ c<-newAtoms ] then [] else - [ -- let us see which links are left to be inserted - ASSIGN d (PHPEDif (PHPERel d, PHPRel (PHPqry (ECps es)))) - , COMMENT "d contains the remaining links to be inserted in r;s" - , CONDITIONAL (NotNull d) - (SEQ ( newAtoms ++ - ALL ( let vs = [ v | NewAtom v _ <- newAtoms ] in - [ Insert (PHPEPrd [PHPERel d, PHPERel (PHPvar (head vs))]) (mkDBrel (head es)) ]++ - [ Insert (PHPEprd [PHPERel cl, PHPERel cr]) (mkDBrel e) | (cl,cr,e)<-zip (init vs) (tail vs) tail (init es))] ++ - [ Insert (PHPEPrd [PHPERel (PHPvar (last vs)), PHPERel d]) (mkDBrel (last es)) ]) - ) ) - ] - ) - ] - -In order to proceed to the real code, we must realize that mkDBrel is not defined yet. -The argument of mkDBrel is an Expression. This can be an ERel{} or something different. -In case it is an ERel{}, the insert can be translated directly to a database action. -If it is not, the insert can be treated as a recursive call to genPAcl, which breaks down the expression further until it reaches a relation. -let delta = PHPvar{ phpVar = "delta" -- this is the input - , phptyp = phpsign (sign e) -- the type is used nowhere, but it feels good to know the type. - } in -let d = PHPvar{ phpVar = "d" -- this is the input, from which everything already in Ecps es is removed. - , phptyp = phpsign (sign e) -- the type is used nowhere, but it feels good to know the type. - } in -let newAtoms = [ NewAtom (PHPvar (head (name c):show i) c | (r,s,i)<-zip3 (init es) (tail es) [1..], let c=target(r) `meet` source(s)] in -SEQUENCE [ ASSIGN d (PHPEDif (PHPERel delta, PHPRel (PHPqry (ECps es)))) - , COMMENT "d contains all links to be inserted in r;s" - , CONDITIONAL (NotNull d) - (SEQUENCE([ ALL ( (if editable(head es) - then [ if isRel (head es) - then Insert (PHPECps (PHPERel d, PHPERel (PHPqry (flp (ECps (tail es)))))) (let PHPRel r = head es in r) - else genPAclause editAble Ins (head es) (PHPECps [PHPERel d, PHPERel (PHPqry (flp (ECps (tail es))))]) motive - ] - else []) ++ - (if editable(last es) - then [ if isRel (last es) - then Insert (PHPECps [PHPERel (PHPqry (flp (ECps (init es)))), PHPERel d]) (let PHPRel r = last es in r) - else genPAclause editAble Ins (last es) (PHPECps [PHPERel (PHPqry (flp (ECps (init es)))), PHPERel d]) motive - ] - else []) ) - , COMMENT "All links that can be added just in r or just in s have now been added. Now we finish the rest with a bow tie."] ++ - if or [not (editable e) | e<-es] || or [ not (editable (I c)) | NewAtom _ c<-newAtoms ] then [] else - [ -- let us see which links are left to be inserted - ASSIGN d (PHPEDif (PHPERel d, PHPRel (PHPqry (ECps es)))) - , COMMENT "d contains the remaining links to be inserted in r;s" - , CONDITIONAL (NotNull d) - (SEQ ( newAtoms ++ - ALL ( let vs = [ v | NewAtom v _ <- newAtoms ] in - [ if isRel (head es) - then Insert (PHPEPrd [PHPERel d, PHPERel (PHPvar (head vs))]) (let PHPRel r = head es in r) - else genPAclause editAble Ins (head es) (PHPEPrd [PHPERel d, PHPERel (PHPvar (head vs))]) motive]++ - [ Insert (PHPEprd [PHPERel cl, PHPERel cr]) (mkDBrel e) | (cl,cr,e)<-zip (init vs) (tail vs) tail (init es))] ++ - [ if isRel (last es) - then Insert (PHPEPrd [PHPERel (PHPvar (last vs)), PHPERel d]) (let PHPRel r = last es in r) - else genPAclause editAble Ins (last es) (PHPEPrd [PHPERel d, PHPERel (PHPvar (head vs))]) motive ]) - ) ) - ]) - ) - ] - --} - (Del, e@ECps{}) -> CHC [ if els==flp ers - then CHC [ Sel c (disjNF els) (\_->Rmv c fLft motiv) motiv - , Sel c (disjNF els) fLft motiv - ] motiv - else CHC [ Sel c (disjNF (els ./\. flp ers)) (\_->Rmv c (\x->ALL [fLft x, fRht x] motiv) motiv) motiv - , Sel c (disjNF (els ./\. flp ers)) fLft motiv - , Sel c (disjNF (els ./\. flp ers)) fRht motiv - ] motiv - | (ls,rs)<-chop (exprCps2list e) - , let ers=foldCompose rs - , let els=foldCompose ls - , let c=source ers -- SJ 20131202: Note that target ers==source els - , let fLft atom = genPAcl (disjNF ((EMp1 atom (source ers) .*. deltaX) .\/. notCpl ers)) Del ers [] -- TODO (SJ 26-01-2013) is this double code? - , let fRht atom = genPAcl (disjNF ((deltaX .*. EMp1 atom (target els)) .\/. notCpl els)) Del els [] - ] motiv - where foldCompose xs = case xs of - [] -> fatal 851 "Going into (foldr1 (.:.)) with an empty list" - _ -> foldr1 (.:.) xs -{- Purpose: how to delete Delta from ECps es -This corresponds with: genPAclause editAble Del (ECps es) Delta motive -One way of doing this is to select from es one subexpression, e, that is editable. -By removing the proper links from that particular e, all chains are broken. - -Splitting the terms on one particular subexpression can be done as follows: - triples = [ (take i es, es!!i, drop (i+1) es) | i<-[0..length es-1] ] -This gives us triples, (left,e,right), each of which is a candidate for deletion. -There is no point in having two candidates, (left,e,right) and (left',e',right'), with e==e'. -Since e and e' are aliases of the underlying database relation, deletion from e need not be repeated by deletion from e'. -That is why double candidates may be excluded. Here is how: - triples = [ (take i es, es!!i, drop (i+1) es) | i<-[0..length es-1], es!!i `notElem` (take i es) ] -If e is a relation and editable as well, this relation can be used for deletion. -The elements from e to be deleted are those, that establish a link between cod(left) and dom(right). -In order to eliminate these, no link from the expression left~;e;right~ may survive. -If we sum up the alternatives in pseudocode, we get: -CHC [ DELETE ((ECps (reverse (map flp left) ++ [e] ++ reverse (map flp right))) FROM e - | (left,ERel e _,right)<-triples - , editable e ] -In order to refine further to real code, we must realize that deletion can be done in relations only. Not in expressions. -So if e is a relation, the DELETE can be executed. -If it is an expression, the function genPAclause can be called recursively. -We now get the following code fragment: -CHC [ if isRel e - then DELETE (ECps (reverse (map flp left) ++ [e] ++ reverse (map flp right))) FROM (let PHPRel r = e in r) - else genPAclause editAble Del e (ECps (reverse (map flp left) ++ [e] ++ reverse (map flp right))) motive - | (left,ERel e _,right)<-triples - , editable e ] - --} - (Del, e@EUni{}) -> ALL [ genPAcl deltaX Del f [] | f<-exprUni2list e {-, not (f==expr1 && Del/=tOp') -}] motiv -- the filter prevents self compensating PA-clauses. - (Del, e@EIsc{}) -> CHC [ genPAcl deltaX Del f motiv | f<-exprIsc2list e ] motiv --- Op basis van De Morgan is de procesalgebra in het geval van (Ins, ERad ts) afleidbaar uit uit het geval van (Del, ECps ts) ... - (_ , e@ERad{}) -> genPAcl deltaX tOp (deMorganERad e) motiv - (_ , EPrd{}) -> fatal 896 "TODO" - (_ , EKl0 x ) -> genPAcl (deltaK0 deltaX tOp x) tOp x motiv - (_ , EKl1 x ) -> genPAcl (deltaK1 deltaX tOp x) tOp x motiv - (_ , e@(EDcD d)) -> -- fatal 742 ("DIAG ADL2Fspec 764:\ndoCod ("++showADL deltaX++") "++show tOp++" ("++showADL exprX++"),\n" - -- -- ++"\nwith disjNF deltaX:\n "++showADL (disjNF deltaX)) - if editAble d then Do tOp d deltaX motiv else Blk [(e, nub [r |(_,rs)<-motiv, r<-rs])] - --- HJO, 20130423: *LET OP!! De volgende code is er bij gefreubeld om geen last te hebben van de fatal767, maar is niet goed. ***** --- Dit is in overleg met Stef, die deze hele code toch compleet wil herzien, i.v.m. de nieuwe typechecker. --- SJC, 20131012: Dan lijkt me dit een goed moment om deze regel weer uit te commentaren, aangezien ik nu de typechecker aan het herzien ben --- ik doe dit even met een fatal ipv `echt' commentaar --- SJ 20131117: I think not. Refactoring of this generator is nigh, though holding uppe other developments cannot be tolerated! So ye following code shall remain wrong rather than fatal... Long live the King! ^_^ - (_ , e@EDcV{}) -> Blk [(e, nub [r |(_,rs)<-motiv, r<-rs])] - (_ , _) -> fatal 767 ( "(Stef?) Non-exhaustive patterns in the recursive call\n" - ++"doCod ("++showADL deltaX++") -- deltaX\n "++show tOp++" -- tOp\n ("++showADL exprX++") -- exprX\n"++ - "within function\ndoCode "++show tOp'++" -- tOp'\n ("++showADL expr1++") -- expr1\n ("++showADL delta1++") -- delta1\n"++ - concat - [ "while trying to maintain conjunct "++showADL conjunct++ - "\nfrom rule "++intercalate "\n " [show r | r<-rs] - | (conjunct,rs)<-motive ] ++ - if null motive then "null motive" else "" - ) - switchboard :: Options -> Fspc -> Fswitchboard switchboard flags fSpec = Fswtch @@ -979,23 +594,13 @@ where qs :: [Quad] qs = quads flags visible (invariants fSpec) - ecas = assembleECAs qs + (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 [On tOp dcl | eca<-ecas, doAct<-dos (ecaAction eca), let Do tOp e _ _=doAct, EDcD dcl<-[EDcD e, flp $ EDcD e]] -- TODO (SJ 26-01-2013) silly code: ERel rel _<-[ERel e (sign e), flp $ ERel e (sign e)] Why is this? + eventsOut = nub [evt | eca<-ecas, evt<-eventsFrom (ecaAction eca)] visible _ = True --- Auxiliaries - chop :: [a] -> [([a], [a])] - chop xs = [ splitAt i xs | i <- [1..length xs-1]] - deltaK0 :: t -> InsDel -> t1 -> t - deltaK0 delta' Ins _ = delta' -- error! (tijdelijk... moet berekenen welke paren in x gezet moeten worden zodat delta |- x*) - deltaK0 delta' Del _ = delta' -- error! (tijdelijk... moet berekenen welke paren uit x verwijderd moeten worden zodat delta/\x* leeg is) - deltaK1 :: t -> InsDel -> t1 -> t - deltaK1 delta' Ins _ = delta' -- error! (tijdelijk... moet berekenen welke paren in x gezet moeten worden zodat delta |- x+) - deltaK1 delta' Del _ = delta' -- error! (tijdelijk... moet berekenen welke paren uit x verwijderd moeten worden zodat delta/\x+ leeg is) - class Identified a => Rename a where rename :: a->String->a
src/lib/DatabaseDesign/Ampersand/Fspec/ToFspec/ADL2Plug.hs view
@@ -26,7 +26,7 @@ makeGeneratedSqlPlugs :: Options -> A_Context -> [Expression] - -> [Declaration] -- ^ declarations to be saved in generated database plugs. + -> [Declaration] -- ^ relations to be saved in generated database plugs. -> [PlugSQL] makeGeneratedSqlPlugs flags context totsurs entityDcls = gTables where @@ -34,8 +34,8 @@ gTables = gPlugs ++ gLinkTables gPlugs :: [PlugSQL] gPlugs = --trace "---\nStart makeEntityTables " $ - --trace ("with "++show (length entityDcls)++" declarations and "++show(length vsqlplugs)++" userdefined plugs.\n") - (makeEntityTables flags context entityDcls (ctxgs context) (ctxgenconcs context) (declsUsedIn vsqlplugs)) + --trace ("with "++show (length entityDcls)++" relations and "++show(length vsqlplugs)++" userdefined plugs.\n") + (makeEntityTables flags context entityDcls (gens context) (ctxgenconcs context) (relsUsedIn vsqlplugs)) -- all plugs for relations not touched by definedplugs and gPlugs gLinkTables :: [PlugSQL] gLinkTables = [ makeLinkTable context dcl totsurs @@ -73,7 +73,9 @@ Fld { fldname = concat["Src" | isEndo dcl]++name (source trgExpr) , fldexpr = srcExpr , fldtype = sqlTypeOf context (target srcExpr) - , flduse = ForeignKey (target srcExpr) + , flduse = if suitableAsKey (sqlTypeOf context (target srcExpr)) + then ForeignKey (target srcExpr) + else PlainAttr , fldnull = isTot trgExpr , flduniq = isUni trgExpr } @@ -81,7 +83,9 @@ Fld { fldname = concat["Tgt" | isEndo dcl]++name (target trgExpr) , fldexpr = trgExpr , fldtype = sqlTypeOf context (target trgExpr) - , flduse = ForeignKey (target trgExpr) + , flduse = if suitableAsKey (sqlTypeOf context (target trgExpr)) + then ForeignKey (target trgExpr) + else PlainAttr , fldnull = isSur trgExpr , flduniq = isInj trgExpr } @@ -104,6 +108,22 @@ | not r_is_Tot && r_is_Sur = flp (EDcD dcl) | otherwise = EDcD dcl +suitableAsKey :: SqlType -> Bool +suitableAsKey st = + case st of + SQLChar{} -> True + SQLBlob -> False + SQLPass -> False + SQLSingle -> True + SQLDouble -> True + SQLText -> False + SQLuInt{} -> True + SQLsInt{} -> True + SQLId{} -> True + SQLVarchar{} -> True + SQLBool{} -> True + + ----------------------------------------- --rel2fld ----------------------------------------- @@ -137,7 +157,9 @@ , flduse = let f expr = case expr of - EDcI c -> PrimKey c + EDcI c -> if suitableAsKey (sqlTypeOf context c) + then TableKey ((not.maybenull) e) c + else PlainAttr EDcD _ -> PlainAttr EFlp e' -> f e' _ -> fatal 144 ("No flduse defined for "++show expr) @@ -267,15 +289,30 @@ "\nexclusions:" ++ concat ["\n "++showHSName r | r<-exclusions]++ "\nattRels:" ++ concat ["\n "++showHS flags " " e | e<-attRels]++ "\n" - rootss = map (rootConcepts isas) conceptss --- Obsolete: (because kernels are found in the fSpec) --- kernels = [ nub (roots++concat [ smallerConcepts isas c | c <- roots ]) --- | roots<-rootss ] - kernels = 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 - kernelsWithAttributes = dist attRels kernels [] + -- | kernels are computed, starting with the set of concepts, on the basis of generalization tuples. + kernPartition :: [A_Gen] -> [[A_Concept]] -- ^ This function contains the recipe to derive a set of kernels from a set of isa-pairs. + kernPartition specialzs + = foldl f (group (delete ONE (concs context))) specialzs + where f disjuncLists g = concat haves : nohaves + where + (haves,nohaves) = partition (not.null.intersect (concs g)) disjuncLists + preKernels = kernPartition (gens context) -- Step 1: compute the kernels from the isa-pairs from the context + extraIsas -- Step 2: Maybe extra isa-pairs are needed to ensure that each kernel has precisely one largest concept + = concat + [ case [c | c<-kernel, null (largerConcepts isas c)] of -- determine how many concepts in one kernel are largest + [_] -> [] + rs -> [ Isa{gengen=rootConcept, genspc=c} | c<-rs ] + | (rootConcept,kernel) <- zip [rc | i<-[0::Int ..] + , let rc=PlainConcept ("rootConcept"++show i) + , rc `notElem` concs context ] + preKernels + ] + kernls -- Step 3: compute the kernels + = [ largerCs++[ c | c<-kernel, c `notElem` largerCs ] -- put the largest element up front + | kernel <- kernPartition (extraIsas++gens context) -- recompute the kernels with the extra isa-pairs. + , let largerCs = [c | c<-kernel, null (largerConcepts isas c)] -- get the set of largest concepts (each kernel has precisely one) + ] + kernelsWithAttributes = dist attRels kernls [] where dist :: (Association attrib, Show attrib) => [attrib] -> [[A_Concept]] -> [([A_Concept], [attrib])] -> [([A_Concept], [attrib])] dist [] [] result = result @@ -294,8 +331,7 @@ } where (isaAtts,atts) = partition isISA attsAndIsaRels - where -- isISA (EDcD r) = decISA r - isISA (EDcI _) = True + where isISA (EDcI _) = True isISA _ = False mainkernel = map EDcI kernel plugMors :: [Expression] @@ -308,8 +344,8 @@ lookupC cpt = head [f |(c',f)<-conceptLookuptable, cpt==c'] fld a = rel2fld context mainkernel atts a isaLookuptable = [(e,lookupC (source e),lookupC (target e)) | e <- isaAtts ] --- attRels contains all relations that will be attribute of a kernel. --- The type is the largest possible type, which is the declared type, because that contains all atoms (also the atoms of subtypes) needed in the operation. + -- attRels contains all relations that will be attribute of a kernel. + -- The type is the largest possible type, which is the declared type, because that contains all atoms (also the atoms of subtypes) needed in the operation. attRels :: [Expression] attRels = mapMaybe attExprOf (allDcls>- exclusions) where
src/lib/DatabaseDesign/Ampersand/Fspec/ToFspec/Calc.hs view
@@ -1,28 +1,32 @@ {-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} module DatabaseDesign.Ampersand.Fspec.ToFspec.Calc ( deriveProofs , lambda , checkMono - , showProof, showPrf + , showProof, showPrf, assembleECAs, conjuncts, genPAclause -- , testInterface ) where - import DatabaseDesign.Ampersand.Basics (fatalMsg,Collection (isc),Identified(..),eqCl) + import DatabaseDesign.Ampersand.Basics (fatalMsg,Collection (isc),Identified(..),eqCl,Flippable(..)) import Data.List hiding (head) import GHC.Exts (sortWith) +-- import Data.ByteString.Char8 +-- import Data.ByteString.Lazy.Char8 import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree hiding (sortWith) import DatabaseDesign.Ampersand.ADL1 - import DatabaseDesign.Ampersand.ADL1.Expression (subst,isNeg) + import DatabaseDesign.Ampersand.ADL1.Expression import DatabaseDesign.Ampersand.Classes - import DatabaseDesign.Ampersand.Fspec.Fspec (Fspc(..),Clauses(..),RuleClause(..),Quad(..),ECArule(..),InsDel(..),PAclause(..), DnfClause(..), dnf2expr) - import DatabaseDesign.Ampersand.Fspec.ShowADL (ShowADL(..)) + import DatabaseDesign.Ampersand.Fspec.Fspec + import DatabaseDesign.Ampersand.Fspec.ShowADL (ShowADL(..), showREL) import DatabaseDesign.Ampersand.Fspec.ShowECA (showECA) - import DatabaseDesign.Ampersand.Fspec.ToFspec.ADL2Fspec - import DatabaseDesign.Ampersand.Fspec.ToFspec.NormalForms (conjNF,disjNF,cfProof,dfProof,nfProof,simplify,normPA,exprIsc2list, exprUni2list, exprCps2list, exprRad2list) --,proofPA) -- proofPA may be used to test derivations of PAclauses. + import DatabaseDesign.Ampersand.Fspec.ToFspec.NormalForms (delta,conjNF,disjNF,cfProof,dfProof,nfProof,simplify,normPA,proofPA) import DatabaseDesign.Ampersand.Misc (Lang(..),Options(..),PandocFormat(ReST),string2Blocks) - import Text.Pandoc + import Text.Pandoc.Builder import Prelude hiding (head) +-- import Debug.Trace fatal :: Int -> String -> a fatal = fatalMsg "Fspec.ToFspec.Calc" @@ -31,6 +35,16 @@ head [] = fatal 30 "head must not be used on an empty list!" head (a:_) = a + conjuncts :: Rule -> [DnfClause] + conjuncts = map disjuncts.exprIsc2list.conjNF.rrexp + disjuncts :: Expression -> DnfClause + disjuncts conj = (split (Dnf [] []).exprUni2list) conj + where split :: DnfClause -> [Expression] -> DnfClause + split (Dnf antc cons) (ECpl e: rest) = split (Dnf (e:antc) cons) rest + split (Dnf antc cons) ( e: rest) = split (Dnf antc (e:cons)) rest + split dc [] = dc + + -- testInterface :: Fspc -> Interface -> String -- Deze functie is bedoeld om te bedenken hoe interfaces moeten worden afgeleid uit een vers vertaalde ObjectDef. -- Nadat deze goed werkt kunnen de bewijsgenerator en de codegenerator worden gemaakt. @@ -43,8 +57,8 @@ -- " - Derivation of clauses for ECA-rules:" ++ -- concat [showClause fSpec (allClauses flags rule) | rule<-invs]++"\n"++ --{- --- " - ECA rules:"++concat [ "\n\n "++showECA fSpec "\n> " (eca{ecaAction=normPA (ecaAction eca)}) --- ++"\n------ Derivation ----->"++showProof (showECA fSpec "\n> ") (proofPA (ecaAction eca))++"\n<------End Derivation --" +-- " - ECA rules:"++concat [ "\n\n "++showECA "\n " (eca{ecaAction=normPA (ecaAction eca)}) +-- ++"\n------ Derivation ----->"++showProof (codeBlock . ("\n "++) . showECA "\n ") (proofPA (ecaAction eca))++"\n<------End Derivation --" -- | eca<-ecaRs]++"\n\n"++ ---} -- " - Visible relations:\n "++intercalate "\n " (spread 80 ", " [showADL r | r<-vis])++"\n" @@ -58,7 +72,7 @@ -- -- visible r = r `elem` vis -- invs = [rule | rule<-invariants fSpec, (not.null) (map makeDeclaration (relsUsedIn rule) `isc` vis)] -- -- qs = vquads fSpec --- -- ecaRs = assembleECAs qs +-- -- ecaRs = assembleECAs fSpec ---- editable (ERel Rel{} _) = True --WHY?? Stef, welke functie is de juiste?? TODO deze functie staat ook in ADL2Fspec.hs, maar is daar ANDERS(!)... ---- editable _ = False ---- editMph (ERel r@Rel{} _) = r --WHY?? Stef, welke functie is de juiste?? TODO deze functie staat ook in ADL2Fspec.hs, maar is daar ANDERS(!)... @@ -76,256 +90,152 @@ -- | otherwise = stored: f cs css -- where new = stored++str++cs - deriveProofs :: Options -> Fspc -> [Inline] + deriveProofs :: Options -> Fspc -> Blocks deriveProofs flags fSpec - = [ Str ("Rules and their conjuncts for "++name fSpec), LineBreak - ] ++ --- conjuncts = map disjuncts.exprIsc2list.conjNF.rrexp - intercalate [LineBreak,Str "-- next rule ------------", LineBreak] - [ [ Str "rule r: ", Str (showADL r), LineBreak]++ - [ Str "rrexp r: ", Str (showADL (rrexp r)), LineBreak]++ - [ Str "conjNF: ", Str (showADL (conjNF (rrexp r))), LineBreak]++ - intercalate [LineBreak] [ [Str " conj: ", Str (showADL conj)] | conj<-conjuncts r] - | r<-grules fSpec++vrules fSpec] ++ - [ --"\nSignals for "++name fSpec++"\n--------------\n"++ - --proof (signals fSpec)++ - LineBreak - , Str ("Transformation of user specified rules into ECA rules for "++name fSpec) - , LineBreak, Str "--------------", LineBreak, Str "--------------", LineBreak - , LineBreak, Str "First step: determine all (", Str (show (length qs)), Str ") quads", LineBreak - , LineBreak, Str "-- first quad ------------", LineBreak - ] - ++ - intercalate [LineBreak,Str "-- next quad ------------",LineBreak] - [ [ Str "When relation ", Str (showADL rel), Str " is changed," - , LineBreak, Str (showADL r) - ]++ (if length (cl_conjNF ccrs)<=1 then [Space] else [Str " (", Str (show (length (cl_conjNF ccrs))), Str " conjuncts)"]) ++ - [ Str " must be restored.", LineBreak, Str "This quad has conjunct: ", Str (showADL (rc_conjunct x)) - , Str " and ", Str (show (length (rc_dnfClauses x))), Str " dnf clauses." - ]++ - [ inl - | dc<-(rc_dnfClauses x), inl<-[LineBreak, Str "Dnf clause ", Str (showADL dc)]] - | Quad rel ccrs<-qs, let r=cl_rule ccrs , x<-cl_conjNF ccrs ] - ++ - [ LineBreak, Str "-- end ------------", LineBreak, LineBreak, Str "Second step: assemble dnf clauses." - , LineBreak, Str "-- first dnf clause ------------", LineBreak] - ++ - intercalate [LineBreak,Str "-- next dnf clause ------------",LineBreak] - [ [ Str "Dnf clause ", Str (showADL dc) - , LineBreak, Str "is derived from rule ", Str (showADL r) - , LineBreak - , Str ( case ms of - [] -> "no relations affect this clause" - [rel] -> "It can be called when relation " ++showADL rel++" is affected." - _ -> "It can be called when relations "++commaEng "or" [showADL rel | rel<-ms]++" are affected." - ) - ] - | (ms,dc,r)<- - [ (nub [ dcl |(dcl,_,_)<-cl],dc,r) - | cl<-eqCl (\(_,_,dc)->dc) [(dcl,dc,r) |Quad dcl ccrs<-qs, let r=cl_rule ccrs, x<-cl_conjNF ccrs, dc<-rc_dnfClauses x] - , let (_,dc,r) = head cl - ] - ] - ++ - [ LineBreak, Str "-- end ------------", LineBreak, LineBreak, Str "Third step: determine ECA rules"] ++ - [ if verboseP flags - then Str " (Turn --verbose off if you want to see ECA rules only)" - else Str " (Turn on --verbose if you want to see more detail)" ] ++ - [ LineBreak ] - ++ - concat - [ [ LineBreak,Str "-- ECA Rule ", Str (show (ecaNum ecarule)), Str " ---------", LineBreak - , Str (showECA fSpec "\n " ecarule{ecaAction=normPA (ecaAction ecarule)}) ]++ - concat [ [ LineBreak, Str "delta expression", LineBreak, Space, Str (showADL d) - , LineBreak, Str "derivation:" - , LineBreak, Space]++ - (showProof showADL. nfProof showADL) d ++ -- nfProof produces its result in disjunctive normal form - [ LineBreak, Str "disjunctly normalized delta expression" - , LineBreak, Str (showADL (disjNF d)) - ] - | verboseP flags, e@Do{}<-[ecaAction ecarule], let d = paDelta e ] - | ecarule <- ecaRs] + = para ("Rules and their conjuncts for "<>(str.name) fSpec)<> + bulletList [ para ("rule r: "<>str (showADL r)<>linebreak<> + "rrexp r: "<>str (showADL (rrexp r))<>linebreak<> + "conjNF: "<>str (showADL (conjNF (rrexp r)))<>linebreak<> + interText linebreak [ " conj: "<>str (showADL conj) | conj<-conjuncts r ] + ) + | r<-grules fSpec++vrules fSpec]<> + para ("Transformation of user specified rules into ECA rules for "<>(str.name) fSpec)<> + para (linebreak<>"--------------"<>linebreak<>"First step: determine the "<>(str.show.length) qs<>" quads:")<> + bulletList [ para ( "-- quad ------------"<>linebreak<>"When relation "<>str (showADL rel)<>" is changed," + <>linebreak<>str (showADL r) + <>(if length (cl_conjNF ccrs)<=1 then space else " ("<>(str.show.length.cl_conjNF) ccrs<>" conjuncts)") + <>" must be restored."<>linebreak<>"This quad has conjunct: "<>(str.showADL.rc_conjunct) x + <>" and "<>(str.show.length.rc_dnfClauses) x<>" dnf clauses." + ) <> + bulletList [ para (linebreak<>"Dnf clause "<>str (showADL dc)) | dc<-rc_dnfClauses x] + | Quad rel ccrs<-qs, let r=cl_rule ccrs , x<-cl_conjNF ccrs ] <> + para (linebreak<>linebreak<>"Second step: assemble dnf clauses.") <> + bulletList [ para ( "Dnf clause "<>str (showADL dc) + <>linebreak<>"is derived from rule "<>str (showADL r) + <>linebreak + <>case ms of + [] -> "No relations affect this clause." + [rel] -> "It can be called when relation " <>str (showADL rel)<>" is affected." + _ -> "It can be called when relations "<>str (commaEng "or" [showADL rel | rel<-ms])<>" are affected." + ) + | (ms,dc,r)<- + [ (nub [ dcl |(dcl,_,_)<-cl],dc,r) + | cl<-eqCl (\(_,_,dc)->dc) [(dcl,dc,r) |Quad dcl ccrs<-qs, let r=cl_rule ccrs, x<-cl_conjNF ccrs, dc<-rc_dnfClauses x] + , let (_,dc,r) = head cl + ] + ]<> + para (linebreak<>"Third step: determine "<>(str.show.length.udefrules) fSpec<>" ECA rules"<> + if verboseP flags + then " (Turn --verbose off if you want to see ECA rules only)" + else " (Turn on --verbose if you want to see more detail)" + )<> + ( if verboseP flags then para ( "--------------"<>linebreak)<>bulletList derivations else fromList [] )<> + bulletList [ para ( "-- ECA Rule "<>(str.show.ecaNum) ecarule<>" ---------")<> + codeBlock ("\n "++showECA "\n " ecarule{ecaAction=normPA (ecaAction ecarule)})<> + bulletList [ para (linebreak<>"delta expression"<>linebreak<>space<>str (showADL d) + <>linebreak<>"derivation:" + )<> + (showProof (para.str.showADL).nfProof showADL) d<> -- nfProof produces its result in disjunctive normal form + para ("disjunctly normalized delta expression"<>linebreak<>(str.showADL.disjNF) d) + | verboseP flags, e@Do{}<-[ecaAction ecarule], let d = paDelta e ] + | ecarule <- ecaRs] + {- ++ - [ LineBreak, Str "--------------", LineBreak, LineBreak, Str "Fourth step: cascade blocking rules" - , LineBreak + [ linebreak<>"--------------", linebreak, linebreak<>"Fourth step: cascade blocking rules" + , linebreak ]++ - intercalate [] - [ [LineBreak, Str ("-- Raw ECA rule "++show (ecaNum er)++"------------"), LineBreak, Str (showECA fSpec "\n " er)] + interText [] + [ [linebreak<>"-- Raw ECA rule "<>(str.show.ecaNum) er<>"------------"<>linebreak<>str (showECA "\n " er)] | er<- ecaRs] ++ - [ LineBreak, Str "--------------", LineBreak, LineBreak, Str "Fifth step: preEmpt the rules (= optimize)" - , LineBreak + [ linebreak<>"--------------", linebreak, linebreak<>"Fifth step: preEmpt the rules (= optimize)" + , linebreak ]++ {- TODO: readdress preEmpt. It is wrong - intercalate [] - [ [LineBreak, Str ("-- Preempted ECA rule "++show (ecaNum er)++"------------"), LineBreak, Str (showECA fSpec "\n " er)] + interText [] + [ [linebreak<>"-- Preempted ECA rule "<>(str.show.ecaNum) er<>"------------"<>linebreak<>str (showECA "\n " er)] | er<- preEmpt ecaRs] ++ -} - [ Str "--------------", LineBreak, Str "Final step: derivations --------------", LineBreak] - ++ - intercalate [LineBreak, Str "--------------", LineBreak] - [ derivation rule - | rule<-udefrules fSpec]++ - [Str ("Aantal Rules: "++(show.length.udefrules) fSpec)] {- - ++ - [ LineBreak, Str "--------------", LineBreak] + [ linebreak<>"--------------", linebreak] ++ -- TODO: make an ontological analysis, which explains the delete behaviour. - [ Str "Ontological analysis: ", LineBreak, Str " "] + [ Str "Ontological analysis: ", linebreak<>" "] ++ - intercalate [LineBreak, LineBreak, Str " "] - [ [Str (name ifc), Str "("] - ++ intercalate [Str ", "] - [[Str (name a), Str "[", Str ((name.target.ctx) a), Str "]"] + interText [linebreak, linebreak<>" "] + [ [Str (name ifc)<>"("] + ++ interText ", " + [str (name a)<>"["<>(str.name.target.ctx) a<>"]" |a<-attributes (ifcObj ifc)] - ++ [Str "):", LineBreak, Str " "] + ++ [Str "):", linebreak<>" "] | ifc<-interfaceS fSpec] ++ - [ LineBreak, Str "--------------", LineBreak - , Str "Analyzing interfaces:", LineBreak, Str " "] + [ linebreak<>"--------------", linebreak + <>"Analyzing interfaces:", linebreak<>" "] ++ - intercalate [LineBreak, Str " "] + interText [linebreak<>" "] [[Str (testInterface flags fSpec ifc)] | ifc<-take 1 (interfaceG fSpec)] ++ - [ LineBreak, Str "--------------", LineBreak] + [ linebreak<>"--------------", linebreak] -} +-} where -- visible _ = True -- We take all quads into account. qs = vquads fSpec -- the quads that are derived for this fSpec specify dnf clauses, meant to maintain rule r, to be called when relation rel is affected (rel is in r). - -- assembleECAs :: (Relation Concept->Bool) -> [Quad] -> [ECArule] - ecaRs = assembleECAs qs -- this creates all ECA rules from the available quads. They are still raw (unoptimized). - - -- relEqCls = eqCl fst4 [(rel,dnfClauses,conj,cl_rule ccrs) | Quad rel ccrs<-qs, (conj,dnfClauses)<-cl_conjNF ccrs] --- This is what ADL2Fpsec has to say about computing ECA rules: --- ecas --- = [ ECA (On ev rel) delt act --- | relEq <- relEqCls -- The material required for one relation --- , let (rel,_,_,_) = head relEq -- This is the relation --- , let ERel delt _ = delta (sign rel) -- delt is a placeholder for the pairs that have been inserted or deleted in rel. --- , ev<-[Ins,Del] -- This determines the event: On ev rel --- , let act = ALL [ CHC [ (if isTrue clause' || isTrue step then Nop else --- if isFalse clause' then Blk else ----- if not (visible rel) then Blk else --- let visible _ = True in genPAclause visible ev toExpr viols) --- [(conj,causes)] -- the motivation for these actions --- | dc@(Dnf antcs conss) <- dnfClauses --- , let clause = dnf2expr dc --- , let sgn = sign clause --- , let clause' = conjNF (subst (rel, actSem Ins rel (delta (sign rel))) clause) --- , let step = conjNF (notCpl clause .\/. clause') --- , let viols = conjNF (notCpl clause') --- , let negs = EUni [notCpl f | f<-antcs] --- , let poss = EUni conss --- , let frExpr = if ev==Ins --- then conjNF negs --- else conjNF poss --- , rel `elem` relsUsedIn frExpr --- , let toExpr = if ev==Ins --- then conjNF poss --- else conjNF (notCpl negs) --- ] --- [(conj,causes)] -- to supply motivations on runtime --- | conjEq <- eqCl snd3 [(dnfClauses,conj,rule) | (_,dnfClauses,conj,rule)<-relEq] --- , let causes = nub (map thd3 conjEq) --- , let (dnfClauses,conj,_) = head conjEq --- ] --- [(conj,nub [r |(_,_,_,r)<-cl]) | cl<-eqCl thd4 relEq, let (_,_,conj,_) = head cl] -- to supply motivations on runtime --- ] --- fst4 (w,_,_,_) = w --- snd3 (_,y,_) = y --- thd3 (_,_,z) = z --- thd4 (_,_,z,_) = z - --TODO: See ticket #105 - derivation :: Rule -> [Inline] - derivation rule - = [Str (showADL rule)]++ - ( if exx'==e - then [Str " is already in conjunctive normal form", LineBreak] - else [LineBreak, Str "Convert into conjunctive normal form", LineBreak] ++ showProof showADL ((e,[],"<=>"):prf) - )++ - [ LineBreak, Str "Violations are computed by (disjNF . ECpl . normexpr) rule:\n " ]++ - (disjProof. notCpl. rrexp) rule++[ LineBreak, LineBreak ] ++ - concat [ [LineBreak, Str "Conjunct: ", Space, Space, Space, Space, Space, Str (showADL (rc_conjunct x))]++ - concat [ [LineBreak, Str "This conjunct has ", Str (show (length (rc_dnfClauses x))), Str " clauses:"] | length (rc_dnfClauses x)>1 ]++ - concat [ [LineBreak, Str " Clause: ", Str (showADL clause)] | clause<-(rc_dnfClauses x)]++[ LineBreak]++ - concat [ [LineBreak, Str "For each clause, let us analyse the insert- and delete events."] | length (rc_dnfClauses x)>1 ]++ - concat [ [LineBreak, Str " Clause: ", Str (showADL clause), Str " may be affected by the following events:",LineBreak]++ - concat [ [Str "event = ", Str (show ev), Space, Str (showADL dcl), Str " means doing the following substitution", LineBreak ] ++ - [Str (showADL clause++"["++showADL dcl++":="++showADL (actSem ev dcl (delta (sign dcl)))++"] = clause'"), LineBreak ] ++ - [Str ("clause' = "++showADL ex'), LineBreak ] ++ - concat [ [Str ("which has CNF: "++showADL ex'), LineBreak] | clause'/=ex'] ++ - [Str ("Computing the violations means to negate the conjunct: "++showADL (notClau)), LineBreak ] ++ - concat [ [Str ("which has CNF: "++showADL viols), LineBreak] | notClau/=viols] ++ - [Str "Now try to derive whether clause |- clause' is true... ", LineBreak, Str (showADL (notClau .\/. clause')), LineBreak, Str "<=>", LineBreak, Str (showADL step), LineBreak ] - | dcl <-relsUsedIn r - , ev<-[Ins,Del] - , let ex' = subst (dcl, actSem ev dcl (delta (sign dcl))) expr - , let clause' = conjNF ex' - , let notClau = notCpl clause' - , let step = conjNF (notClau .\/. clause') - , let viols = conjNF (notClau) - , let negs = foldr (./\.) (EDcV sgn) antcs - , let poss = foldr (.\/.) (notCpl (EDcV sgn)) conss - , let frExpr = if ev==Ins - then conjNF negs - else conjNF poss - , dcl `elem` relsUsedIn frExpr - -- , let toExpr = if ev==Ins - -- then conjNF poss - -- else conjNF (notCpl negs) - ] - | clause@(Dnf antcs conss) <- rc_dnfClauses x - , let expr = dnf2expr clause, let sgn = sign expr ] - | let Clauses ts r = allClauses flags rule, x <-ts] ++ - [LineBreak] + -- assembleECAs :: Fspc -> [ECArule] + commaEng :: String -> [String] -> String + commaEng _ [] = "" + commaEng _ [x] = x + commaEng chs [x,y] = x++" "++chs++" "++y + commaEng chs (x:y:ys) = x++", "++commaEng chs (y:ys) + -- interText :: (Data.String.IsString a, Data.Monoid.Monoid a) => a -> [a] -> a + interText _ [] = "" + interText inbetween (xs:xss) = xs<>inbetween<>interText inbetween xss + derivations :: [Blocks] + ecaRs :: [ECArule] + (ecaRs, derivations) = unzip (assembleECAs fSpec) {- - [ Str ("Available code fragments on rule "++name rule++":", LineBreak ]++ - intercalate [LineBreak] [showADL rule++ " yields\n"++intercalate "\n\n" - [ [Str "event = ", Str (show ev), Space, Str (showADL rel), LineBreak ] ++ - [Str (showADL r++"["++showADL rel++":="++showADL (actSem ev rel (delta (sign rel)))++"] = r'"), LineBreak ] ++ - [Str "r' = "] ++ conjProof r' ++ [LineBreak ] ++ - [Str "viols = r'-"] ++ disjProof (ECpl r') ++ [ LineBreak ] ++ - "violations, considering that the valuation of "++showADL rel++" has just been changed to "++showADL (actSem ev rel (delta (sign rel)))++ - " "++conjProof (ECpl r) ++"\n"++ - "reaction? evaluate r |- r' ("++(showADL.conjNF) (notCpl r .\/. r')++")"++ - conjProof (notCpl r .\/. r')++"\n"++ - "delta: r-/\\r' = "++conjProof (EIsc[notCpl r,r'])++ - "\nNow compute a reaction\n(isTrue.conjNF) (notCpl r .\/. r') = "++show ((isTrue.conjNF) (notCpl r .\/. r'))++"\n"++ + [ str ("Available code fragments on rule "<>name rule<>":", linebreak ]<> + interText [linebreak] [showADL rule<> " yields\n"<>interText "\n\n" + [ ["event = ", str (show ev), space, str (showADL rel), linebreak ] <> + [str (showADL r<>"["<>showADL rel<>":="<>showADL (actSem ev (EDcD rel) (delta (sign rel)))<>"] = r'"), linebreak ] <> + ["r' = "] <> conjProof r' <> [linebreak ] <> + ["viols = r'-"] <> disjProof (ECpl r') <> [ linebreak ] <> + "violations, considering that the valuation of "<>showADL rel<>" has just been changed to "<>showADL (actSem ev (EDcD rel) (delta (sign rel)))<> + " "<>conjProof (ECpl r) <>"\n"<> + "reaction? evaluate r |- r' ("<>(str.showADL.conjNF) (notCpl r .\/. r')<>")"<> + conjProof (notCpl r .\/. r')<>"\n"<> + "delta: r-/\\r' = "<>conjProof (EIsc[notCpl r,r'])<> + "\nNow compute a reaction\n(isTrue.conjNF) (notCpl r .\/. r') = "<>show ((isTrue.conjNF) (notCpl r .\/. r'))<>"\n"<> (if null (lambda ev (ERel rel ) r) - then "lambda "++showADL rel++" ("++showADL r++") = empty\n" + then "lambda "<>showADL rel<>" ("<>showADL r<>") = empty\n" else -- for debug purposes: - -- "lambda "++show ev++" "++showADL rel++" ("++showADL r++") = \n"++(intercalate "\n\n".map showPr.lambda ev (ERel rel)) r++"\n"++ - -- "derivMono ("++showADL r++") "++show ev++" "++showADL rel++"\n = "++({-intercalate "\n". map -}showPr.derivMono r ev) rel++"\n"++ - -- "\nNow compute checkMono r ev rel = \n"++show (checkMono r ev rel)++"\n"++ + -- "lambda "<>show ev<>" "<>showADL rel<>" ("<>showADL r<>") = \n"<>(interText "\n\n".map showPr.lambda ev (ERel rel)) r<>"\n"<> + -- "derivMono ("<>showADL r<>") "<>show ev<>" "<>showADL rel<>"\n = "<>({-interText "\n". map -}showPr.derivMono r ev) rel<>"\n"<> + -- "\nNow compute checkMono r ev rel = \n"<>show (checkMono r ev rel)<>"\n"<> if (isTrue.conjNF) (notCpl r .\/. r') - then "A reaction is not required, because r |- r'. Proof:"++conjProof (notCpl r .\/. r')++"\n" + then "A reaction is not required, because r |- r'. Proof:"<>conjProof (notCpl r .\/. r')<>"\n" else if checkMono r ev rel - then "A reaction is not required, because r |- r'. Proof:"{-++(showPr.derivMono r ev) rel-}++"NIET TYPECORRECT: (showPr.derivMono r ev) rel"++"\n" --WHY? Stef, gaarne herstellen...Deze fout vond ik nadat ik het type van showProof had opgegeven. + then "A reaction is not required, because r |- r'. Proof:"{-<>(str.showPr.derivMono r ev) rel-}<>"NIET TYPECORRECT: (showPr.derivMono r ev) rel"<>"\n" --WHY? Stef, gaarne herstellen...Deze fout vond ik nadat ik het type van showProof had opgegeven. else let ERel _ _ = delta (sign rel) in "An appropriate reaction on this event is required." - -- showECA fSpec "\n " (ECA (On ev rel) delt (genPAclause visible Ins r viols conj [rule]) 0) + -- showECA "\n " (ECA (On ev rel) delt (genPAclause visible Ins r viols conj [rule]) 0) ) - | rel<-nub [x |x<-relsUsedIn r, not (isIdent x)] -- TODO: include proofs that allow: isIdent rel' + | rel<-relsUsedIn r -- nub [x |x<-relsUsedIn r, not (isIdent x)] -- TODO: include proofs that allow: isIdent rel' , ev<-[Ins,Del] - , r'<-[subst (rel, actSem ev rel (delta (sign rel))) r] + , r'<-[subst (rel, actSem ev (EDcD rel) (delta (sign rel))) r] -- , viols<-[conjNF (ECpl r')] , True ] -- (isTrue.conjNF) (notCpl r .\/. r') | r<-[dc | cs<-[allClauses flags rule], (_,dnfClauses)<-cl_conjNF cs, dc<-dnfClauses] ] --} - where e = rrexp rule - prf = cfProof showADL e - (exx',_,_) = last prf - -- conjProof = showProof showADL . cfProof showADL - disjProof = showProof showADL . dfProof showADL --- showPr = showProof showADL -- hoort bij de uitgecommentaarde code hierboven... + where e = rrexp rule + prf = cfProof showADL e + (exx',_,_) = last prf + -- conjProof = showProof (para.str.showADL) . cfProof showADL + disjProof = showProof (para.str.showADL) . dfProof showADL +-- showPr = showProof (para.str.showADL) -- hoort bij de uitgecommentaarde code hierboven... --TODO: See ticket #105 - commaEng :: String -> [String] -> String - commaEng _ [] = "" - commaEng _ [x] = x - commaEng str [x,y] = x++" "++str++" "++y - commaEng str (x:y:ys) = x++", "++commaEng str (y:ys) +-} -- Stel we voeren een actie a uit, die een(1) van de volgende twee is: -- {r} INS rel INTO expr {r'} ofwel @@ -340,7 +250,7 @@ = case ruleType conclusion of Truth -> fatal 247 "derivMono came up with a Truth!" _ -> simplify expr == simplify (antecedent conclusion) && - simplify (subst (dcl, actSem ev dcl (delta (sign dcl))) expr) == + simplify (subst (dcl, actSem ev (EDcD dcl) (delta (sign dcl))) expr) == simplify (consequent conclusion) where (conclusion,_,_) = last (derivMono expr ev dcl) @@ -357,15 +267,15 @@ rev "<--" = "-->" rev x = x - showProof :: (expr->String) -> Proof expr -> [Inline] - showProof shw [(expr,_,_)] = [ LineBreak, Space, Space, Space, Space, Space, Space, Str (shw expr), LineBreak] - showProof shw ((expr,ss,equ):prf) = [ LineBreak, Space, Space, Space, Space, Space, Space, Str (shw expr), LineBreak] ++ - (if null ss then [ Space, Space, Space, Str equ ] else - if null equ then [ Str (unwords ss) ] else - [ Space, Space, Space, Str equ, Str (" { "++intercalate " and " ss++" }") ])++ + showProof :: (expr->Blocks) -> Proof expr -> Blocks + showProof shw [(expr,_,_)] = shw expr + showProof shw ((expr,ss,equ):prf) = shw expr<> + para (if null ss then str equ else + if null equ then str (unwords ss) else + str equ<>str (" { "++intercalate " and " ss++" }"))<> showProof shw prf --where e'= if null prf then "" else let (expr,_,_):_ = prf in showHS options "" expr - showProof _ [] = [] + showProof _ [] = fromList [] showPrf :: (expr->String) -> Proof expr -> [String] showPrf shw [(expr,_,_)] = [ " "++shw expr] @@ -414,7 +324,7 @@ , rrdcl = Nothing , r_env = "" , r_usr = Multiplicity - , r_sgl = fatal 336 $ "erroneous reference to r_sgl in rule ("++showADL neg'++") |- ("++showADL pos'++")" + , isSignal = fatal 336 $ "erroneous reference to isSignal in rule ("++showADL neg'++") |- ("++showADL pos'++")" , srrel = fatal 337 $ "erroneous reference to srrel in rule ("++showADL neg'++") |- ("++showADL pos'++")" } | otherwise = Ru { rrnm = "" @@ -429,7 +339,7 @@ , rrdcl = Nothing , r_env = "" , r_usr = Multiplicity - , r_sgl = fatal 352 $ "illegal reference to r_sgl in rule ("++showADL neg'++") |- ("++showADL pos'++")" + , isSignal = fatal 352 $ "illegal reference to isSignal in rule ("++showADL neg'++") |- ("++showADL pos'++")" , srrel = fatal 353 $ "illegal reference to srrel in rule ("++showADL neg'++") |- ("++showADL pos'++")" } showOp expr' = case expr' of @@ -440,6 +350,7 @@ EDif{} -> "-" ELrs{} -> "/" ERrs{} -> "\\" + EDia{} -> "<>" ECps{} -> ";" ERad{} -> "!" EPrd{} -> "*" @@ -456,8 +367,8 @@ lambda :: InsDel -> Expression -> Expression -> [Proof Expression] - lambda tOp' e' expr' = [reversePrf[(e'',text,op) - | (e'',_,text,op)<-prf] + lambda tOp' e' expr' = [reversePrf[(e'',txt,op) + | (e'',_,txt,op)<-prf] | prf<-lam tOp' e' expr' ] where lam :: InsDel -> Expression -> Expression -> @@ -517,7 +428,9 @@ const' e@EIsc{} = [f |f<-exprIsc2list e, isConst f e3] const' expr'' = fatal 440 $ "'const'("++ show expr''++")' is not defined.Consult your dealer!" inter' e@EUni{} = foldr (.\/.) (notCpl (EDcV sgn)) [f |f<-exprUni2list e, isVar f e3] - inter' e@EIsc{} = foldr (./\.) (EDcV sgn) [f |f<-exprIsc2list e, isVar f e3] + inter' e@EIsc{} = if and [sgn==sign f | f<-exprIsc2list e, isVar f e3] + then foldr (./\.) (EDcV sgn) [f | f<-exprIsc2list e, isVar f e3] + else fatal 532 ("signature error in inter' "++show [(showADL f,showSign (sign f)) | f<-exprIsc2list e, isVar f e3]) inter' expr'' = fatal 443 $ "'inter'("++ show expr''++")' is not defined.Consult your dealer!" -- lam tOp e f = [] @@ -538,7 +451,7 @@ derivtext :: InsDel -> String -> Expression -> Expression -> String derivtext tOp "invert" e'' expr = sh tOp++showADL e''++" means "++sh (inv tOp)++showADL expr++"." derivtext tOp "mono" e'' expr = "("++showADL e''++"->"++showADL expr++") is monotonous, so "++sh tOp++showADL e''++" means "++sh tOp++showADL expr++"." - derivtext _ str _ _ = str + derivtext _ txt _ _ = txt sh :: InsDel -> String sh Ins = "insert into " sh Del = "delete from " @@ -555,4 +468,282 @@ EImp{} -> Implication _ -> Truth + + -- | Action semantics for inserting a delta into a relation dcl. + actSem :: InsDel -> Expression -> Expression -> Expression + actSem Ins dcl delt | sign dcl/=sign delt = fatal 598 "Type error in actSem Ins" + | dcl==delt = dcl + | otherwise = disjNF (dcl .\/. delt) + actSem Del dcl delt | sign dcl/=sign delt = fatal 598 "Type error in actSem Del" + | dcl==delt = notCpl (EDcV (sign dcl)) + | otherwise = conjNF (dcl ./\. notCpl delt) + + -- | assembleECAs assembles larger chunks of code, because it combines acts that are triggered by the same event. + assembleECAs :: Fspc -> [(ECArule,Blocks)] + assembleECAs fSpec + = [eca i | (eca,i) <- zip ecas [(1::Int)..]] + where + ecas :: [Int->(ECArule,Blocks)] + ecas + = [ (\ruleNr->( ECA ecaEvt delt normEcaAct ruleNr + , para ("Let us analyse what happens "<>str (show (On ev rel))<>".")<> + bulletList [ txt | (_,_,_,txt)<-acts]<> + ( if length ecaProof>1 + then para ("The resulting action is:\n ")<> + showProof (codeBlock . ("\n "++) . showECA "\n ") ecaProof + else fromList [] + )<> + para ("These results lead to the following ECA-rule:\n ")<> + (codeBlock . ("\n "++) . showECA "\n ".ecaRule) ruleNr + ) + ) + | rel <- allDecls fSpec ++ [ Isn c | c<-allConcepts fSpec, c/=ONE] -- This is the relation in which a delta is being inserted or deleted. + , let relEq = [ q | q<-vquads fSpec, qDcl q==rel] -- Gather the quads with the same declaration (qDcl). A quad has a declaration (qDcl) and clauses (qClauses) + , let quadClauses = (nub.map qClauses) relEq -- these are the clauses + , let EDcD delt = delta (sign rel) -- delt is a placeholder for the pairs that have been inserted or deleted in rel. + , ev<-[Ins,Del] + , let acts = [ -- go through all the events that affect that clause: + (normPA act, conj, rule, + para ("Let us analyse clause "<>str (showADL expr)<>" from rule "<>(singleQuoted.str.name) rule<>".")<> + para ("event = "<>str (show ev)<>space<>str (showREL rel)<>" means doing the following substitution")<> + para (str (showADL clause<>"["<>showREL rel<>":="<>showADL (actSem ev (EDcD rel) (delta (sign rel)))<>"] = clause'"))<> + para ("clause' = "<>str (showADL ex')<> + if clause'==ex' + then ", which is already in conjunctive normal form."<>linebreak + else ", which has conjunctive normal form: "<>linebreak<>str (showADL clause') + )<> + para ("Let us compute the violations to see whether invariance is maintained."<>linebreak<> + "This means to negate the result (notClau = notCpl clause'): ")<> + (showProof (para.str.showADL). cfProof showADL) notClau<> + para ("So, notClau has CNF: "<>str (showADL viols )<>linebreak<> + ( if viols==viols' + then "This expression is in disjunctive normal form as well." + else str ("In DNF, notClau is: "<>showADL viols'<>".")))<> + ( if isTrue clause' + then para ("This result proves the absence of violations, so a reaction of doing nothing is appropriate."<>linebreak + <>"Just for fun, let us try to derive whether clause |- clause' is true... ")<> + (showProof (para.str.showADL). cfProof showADL) (expr .|-. clause') + else para ("This result does not prove the absence of violations, so we cannot conclude that invariance is maintained."<>linebreak<> + "We must compute a reaction to compensate for violations..."<>linebreak<> + "That would be to reinsert violations that originate from "<> + ( if ev==Ins + then str (showADL (conjNF negs))<>" into "<> str (showADL (disjNF poss))<>"." + else str (showADL (disjNF poss))<>" into "<> str (showADL (conjNF negs))<>"." + )<>linebreak<>"deltFr: ")<> + (showProof (para.str.showADL). dfProof showADL) deltFr<> + ( let pr=proofPA act in + if length pr>1 + then para "Now let us remove redundancy from the ECA action:\n "<> + showProof (codeBlock . ("\n "++) . showECA "\n ") (proofPA act) + else fromList [] + ) + {- <> "To finish the analysis of case "<>str (show ev)<>space<>str (showADL rel) + <>", let us compute the contents of "<>str (showADL toExpr)<>" after insertion of viols."<>linebreak + <> + ( if length (nub [sign viols, sign viols', sign toExpr])>1 + then fatal 248 ("viols"<>showSign (sign viols) <>" "<>showADL viols <>"\n"<> + "viols'"<>showSign (sign viols')<>" "<>showADL viols'<>"\n"<> + "toExpr"<>showSign (sign toExpr)<>" "<>showADL toExpr) + else if ev==Ins + then (showProof (para.str.showADL). cfProof showADL) (viols'.\/.toExpr)<>linebreak + else (showProof (para.str.showADL). dfProof showADL) (notCpl viols./\.toExpr)<>linebreak + ) -} + )) + | Clauses ts rule<-quadClauses, conj<-ts -- get conjuncts from the clauses + , clause@(Dnf antcs conss) <- rc_dnfClauses conj -- the DNF form of each clause + , let expr = dnf2expr clause -- Note that this differs from: rc_conjunct conj + , let vee = EDcV (sign expr) + , let ex' = subst (rel, actSem ev (EDcD rel) (delta (sign rel))) expr -- the clause after the edit action + , let clause' = conjNF ex' -- its CNF + , not (isTrue clause') + , let notClau = notCpl clause' -- the violations after the edit action + , let viols = conjNF notClau -- the violations after the edit action + , let viols' = disjNF notClau -- the violations after the edit action + , let negs = if (length.nub.map sign) (vee:antcs)>1 + then fatal 265 ("type inconsistencies in antcs: "++show (map showADL (vee:antcs))) + else foldr (./\.) vee antcs + , let poss = if (length.nub.map sign) (vee:conss)>1 + then fatal 265 ("type inconsistencies in conss: "++show (map showADL (vee:conss))) + else foldr (.\/.) (notCpl vee) conss + , let frExpr = case ev of + Ins -> disjNF (notCpl negs) + Del -> disjNF poss + , let deltFr = if sign poss/=sign negs + then fatal 274 ("type inconsistencies in deltFr: "++showADL clause) + else if ev==Ins + then (subst (rel, actSem ev (EDcD rel) (delta (sign rel)))) negs ./\. notCpl poss + else (notCpl . subst (rel, actSem ev (EDcD rel) (delta (sign rel)))) poss ./\. negs + , let deltFr' = disjNF deltFr + , rel `elem` relsMentionedIn frExpr + , let toExpr = if ev==Ins + then disjNF poss + else disjNF (notCpl negs) + , let visible _ = True + , if length (nub (map sign [toExpr, deltFr', expr]))>1 + then fatal 285 "type problem" + else True + , let act = genPAclause visible Ins toExpr deltFr' [(expr,[rule])] + ] + , let ecaAct = ALL (map fst4 acts + -- The following acts add the implicit rules, which allows the user to add and delete atoms from concepts in a safe way. + ++ [act' | (ev',rel',act')<-rulesDecls++rulesGens rel, ev==ev', rel==rel' ] + ) + [ (rc_conjunct conj,[rule]) | (_,conj,rule,_)<-acts] --motivation is of type [(Expression,[Rule])] + , let normEcaAct = normPA ecaAct + , let ecaProof = proofPA ecaAct + , let ecaEvt = On ev rel + , let ecaRule = ECA ecaEvt delt normEcaAct + ] +-- the following eca-rules are derived from the typing rules, rather than explicit rules specified by users. +-- This concerns the following rules: +-- Each declaration "RELATION r[A*B]" represents the rule "RULE r[A*B] |- V[A*B]" +-- Besides, for every A, B: "RULE I[A]*I[B] = V[A*B]" +-- For every "CLASSIFY A ISA B" we get "RULE I[A] |- I[B]" +-- For every "CLASSIFY A IS B /\ C" we get "RULE I[A] |- I[B]" and "RULE I[A] |- I[C]" +-- The results of both classify statements are available through vgens. +-- Finally, for every Atom c a there is a rule "RULE 'a' |- I[c]" +-- The eca-rules that can be derived from these rules are produced by ecasFromTypes + {- V[A*B] is implicit, so we don't generate ECA (On Ins rel) delt (Do Ins (Vs (Sign a b)) delt motive). + Neither do we generate ECA (On Del (Vs (Sign a b))) delt (Do Del rel delt motive). + However, we do generate: ECA (On Ins rel) delt (Do Ins (Isn a) ((dlt.<>.flp dlt).-.EDcI a) motive) + and: ECA (On Ins rel) delt (Do Ins (Isn b) ((flp dlt.<>.dlt).-.EDcI b) motive), + because the delta to be inserted might contain new atoms. + Similarly, upon deletion of an atom from a concept we must delete the appropriate links from relations that share this concept. + So, we generate ECA (On Del (Isn a)) delt (Do Del rel (delt.:.V[A*B]) motive) + and: ECA (On Del (Isn b)) delt (Do Del rel (V[A*B].:.delt) motive) + ECA-rules that are derivable from relation declarations are generated by rulesDecls + -} + rulesDecls :: [(InsDel, Declaration, PAclause)] + rulesDecls + = concat + [ [ (Ins, rel, Do Ins (Isn a) ((dlt.:.flp dlt ./\. EDcI a).-.EDcI a) []) + , (Ins, rel, Do Ins (Isn b) ((flp dlt.:.dlt ./\. EDcI b).-.EDcI b) []) + , (Del, Isn a, Do Del rel (delta (Sign a a).:.vee) []) + , (Del, Isn b, Do Del rel (vee.:.delta (Sign b b)) []) + ] + | rel <- allDecls fSpec, let dlt = delta (sign rel) + , let a=source rel, let b=target rel + , let vee = (EDcV . sign) rel + ] + {- We generate: + for every "RULE I[A] |- I[B]": ECA (On Ins (Isn a)) delt (Do Ins (Isn b) (EDcD delt) motive) + and: ECA (On Del (Isn b)) delt (Do Del (Isn a) (EDcD delt) motive) + for every "RULE 'a' |- I[c]": ECA (On Del (Isn c)) ('a','a') (Blk motive) + -} + rulesGens :: Declaration -> [(InsDel, Declaration, PAclause)] + rulesGens rel + = concat + [ [ (Ins, Isn s, Do Ins (Isn g) dlt []) + , (Del, Isn g, Do Del (Isn s) dlt []) + ] + | let dlt = delta (sign rel), (s,g) <- fsisa fSpec + ] + fst4 (x,_,_,_) = x + + -- | de functie genPAclause beschrijft de voornaamste mogelijkheden om een expressie delta' te verwerken in expr (met tOp'==Ins of tOp==Del) + -- TODO: Vind een wetenschappelijk artikel waar de hier beschreven transformatie uitputtend wordt behandeld. + -- TODO: Deze code is onvolledig en misschien zelfs fout.... + genPAclause :: (Declaration->Bool) -- ^True if a relation may be changed (i.e. is editable) + -> InsDel -- ^the type of action: Insert or Delete + -> Expression -- ^the expression in which a delete or insert takes place + -> Expression -- ^the delta to be inserted or deleted + -> [(Expression,[Rule])] -- ^the motivation, consisting of the conjuncts (traced back to their rules) that are being restored by this code fragment. + -> PAclause + genPAclause editAble tOp' expr1 delta1 motive = genPAcl delta1 tOp' expr1 + where + testPA i l r ex + = if (source l,target r)/=(source ex,target ex) + then fatal i ("test with sign deltaX = ["++show (source l)++"*"++show (target r)++"], and sign expr = "++show (sign ex)++":\ndeltaX = "++showADL (l.:.r)++"\nexpr = "++show ex) + else if source r/=target l + then fatal i ("test with source r = "++show (source r)++", and target l = "++show (target l)++":\nl"++showSign (sign l)++" = "++showADL l++"\nr"++showSign (sign r)++" = "++showADL r++"\nexpr = "++show ex) + else id + + genPAcl deltaX tOp expr = + case (tOp, expr) of + (_ , EEqu{}) -> Blk [(expr, nub [r |(_,rs)<-motive, r<-rs])] + (_ , EImp{}) -> Blk [(expr, nub [r |(_,rs)<-motive, r<-rs])] + (_ , EFlp x) -> genPAcl (flp deltaX) tOp x + (_ , EBrk x) -> genPAcl deltaX tOp x + (Ins, ECpl x) -> genPAcl deltaX Del x + (Del, ECpl x) -> genPAcl deltaX Ins x + (Ins, EUni{}) -> CHC [ genPAcl deltaX Ins f | f<-exprUni2list expr{-, not (f==expr1 && Ins/=tOp') -}] motive -- the filter prevents self compensating PA-clauses. + (Ins, EIsc{}) -> ALL [ genPAcl deltaX Ins f | f<-exprIsc2list expr ] motive + (Del, EUni{}) -> ALL [ genPAcl deltaX Del f | f<-exprUni2list expr {-, not (f==expr1 && Del/=tOp') -}] motive -- the filter prevents self compensating PA-clauses. + (Del, EIsc{}) -> CHC [ genPAcl deltaX Del f | f<-exprIsc2list expr ] motive + (Ins, EDif (l,r)) -> CHC [ genPAcl deltaX Ins l, genPAcl deltaX Del r ] motive + (Del, EDif (l,r)) -> CHC [ genPAcl deltaX Del l, genPAcl deltaX Ins r ] motive + (Ins, EDia (l,r)) -> CHC [ ALL [ genPAcl (testPA 986 (deltaX) (flp r) l $ deltaX.:.flp r ) Ins l + , genPAcl (testPA 987 (flp l) (deltaX) r $ flp l.:.deltaX ) Ins r] motive + , ALL [ genPAcl (testPA 988 (deltaX) (notCpl (flp r)) l $ deltaX.:.notCpl (flp r)) Del l + , genPAcl (testPA 989 (deltaX) (flp r) l $ deltaX.:.flp r ) Ins l] motive + , ALL [ genPAcl (testPA 990 (notCpl (flp l)) (deltaX) r $ notCpl (flp l).:.deltaX) Del r + , genPAcl (testPA 991 (flp l) (deltaX) r $ flp l.:.deltaX ) Ins r] motive + , ALL [ genPAcl (testPA 992 (deltaX) (notCpl (flp r)) l $ deltaX.:.notCpl (flp r)) Del l + , genPAcl (testPA 993 (notCpl (flp l)) (deltaX) r $ notCpl (flp l).:.deltaX) Del r] motive + ] motive + (Del, EDia (l,r)) -> GCH [ (Del, (testPA 995 (deltaX) (flp r) l $ deltaX.:.flp r), genPAcl (EMp1 "a" (source l).*.EMp1 "b" (target l)) tOp l) + , (Ins, (testPA 996 (deltaX) (flp (notCpl r)) l $ deltaX.:.flp (notCpl r)), genPAcl (EMp1 "a" (source l).*.EMp1 "b" (target l)) tOp l) + , (Del, (testPA 997 (flp l) (deltaX) r $ flp l.:.deltaX), genPAcl (EMp1 "a" (source r).*.EMp1 "b" (target r)) tOp r) + , (Ins, (testPA 998 (notCpl (flp l)) (deltaX) r $ notCpl (flp l).:.deltaX), genPAcl (EMp1 "a" (source r).*.EMp1 "b" (target r)) tOp r) + ] motive + (Ins, ERrs (l,r)) -> CHC [ genPAcl (testPA 1000 (notCpl r) (flp deltaX) l $ notCpl r.:.flp deltaX) Del l + , genPAcl (testPA 1001 (l) (deltaX) r $ l.:.deltaX) Ins r + ] motive + (Del, ERrs (l,r)) -> GCH [ (Ins, (testPA 1003 (notCpl r) (flp deltaX) l $ notCpl r.:.flp deltaX), genPAcl (EMp1 "a" (source l).*.EMp1 "b" (target l)) tOp l) + , (Del, (testPA 1004 (l) (deltaX) r $ l.:.deltaX), genPAcl (EMp1 "a" (source r).*.EMp1 "b" (target r)) tOp r) + ] motive + (Ins, ELrs (l,r)) -> CHC [ genPAcl (testPA 1006 (flp deltaX) (notCpl l) r $ flp deltaX.:.notCpl l) Del r + , genPAcl (testPA 1007 (deltaX) (r) l $ deltaX.:.r ) Ins l + ] motive + (Del, ELrs (l,r)) -> GCH [ (Ins, (testPA 1009 (flp deltaX) (notCpl l) r $ flp deltaX.:.notCpl l), genPAcl (EMp1 "a" (source r).*.EMp1 "b" (target r)) tOp r) + , (Del, (testPA 1010 (deltaX) (r) l $ deltaX.:.r), genPAcl (EMp1 "a" (source l).*.EMp1 "b" (target l)) tOp l) + ] motive + (Ins, ECps (l,r)) -> CHC [ GCH [ (Ins, (testPA 1012 (deltaX) (flp r) l $ deltaX.:.flp r), genPAcl (EMp1 "a" (source l).*.EMp1 "b" (target l)) tOp l) + , (Ins, (testPA 1013 (flp l) (deltaX) r $ flp l.:.deltaX), genPAcl (EMp1 "a" (source r).*.EMp1 "b" (target r)) tOp r) + ] motive + , New (source r) (\x->ALL [ genPAcl (deltaX.*.EMp1 x (target l)) Ins l + , genPAcl (EMp1 x (source r).*.deltaX) Ins r] motive) motive + ] motive + (Del, ECps (l,r)) -> CHC [ genPAcl (testPA 1018 (deltaX) (flp r) l $ deltaX.:.flp r) Del l + , genPAcl (testPA 1019 (flp l) (deltaX) r $ flp l.:.deltaX) Del r + ] motive + (Ins, ERad (l,r)) -> CHC [ genPAcl (testPA 1021 (deltaX) (notCpl (flp r)) l $ deltaX.:.notCpl (flp r)) Ins l + , genPAcl (testPA 1022 (notCpl (flp l)) (deltaX) r $ notCpl (flp l).:.deltaX) Ins r + ] motive + (Del, ERad (l,r)) -> CHC [ GCH [ (Del, (testPA 1024 (deltaX) (flp r) l $ deltaX.:.flp r), genPAcl (EMp1 "a" (source l).*.EMp1 "b" (target l)) tOp l) + , (Del, (testPA 1025 (flp l) (deltaX) r $ flp l.:.deltaX), genPAcl (EMp1 "a" (source r).*.EMp1 "b" (target r)) tOp r) + ] motive + , New (source r) (\_->Nop motive) motive + ] motive + (Ins, EPrd (l,r)) -> ALL [ genPAcl (EDcV (Sign ONE (source deltaX)).:.deltaX) Ins (EDcV (Sign ONE (source r)).:.r) + , genPAcl (deltaX.:.EDcV (Sign (target deltaX) ONE)) Ins (l.:.EDcV (Sign (target l) ONE)) + ] motive + (Del, EPrd (l,r)) -> ALL [ genPAcl (EDcV (Sign ONE (source deltaX)).:.deltaX) Del (EDcV (Sign ONE (source r)).:.r) + , genPAcl (deltaX.:.EDcV (Sign (target deltaX) ONE)) Del (l.:.EDcV (Sign (target l) ONE)) + ] motive + (_ , EKl0 x ) -> genPAcl (deltaK0 deltaX tOp x) tOp x + (_ , EKl1 x ) -> genPAcl (deltaK1 deltaX tOp x) tOp x + (_ , EDcD d) -> if editAble d then Do tOp d deltaX motive else Blk [(expr, nub [r |(_,rs)<-motive, r<-rs])] + (_ , EDcI c) -> if editAble (Isn c) then Do tOp (Isn c) deltaX motive else Blk [(expr, nub [r |(_,rs)<-motive, r<-rs])] + (_ , EDcV{}) -> Blk [(expr, nub [r |(_,rs)<-motive, r<-rs])] + (_ , EMp1{}) -> Blk [(expr, nub [r |(_,rs)<-motive, r<-rs])] + (_ , EEps{}) -> Nop [(expr, nub [r |(_,rs)<-motive, r<-rs])] + +{- (_ , _) -> fatal 767 ( "(Stef?) Non-exhaustive patterns in the recursive call\n" + ++"doCod ("++showADL deltaX++") -- deltaX\n "++show tOp++" -- tOp\n ("++showADL expr++") -- expr\n"++ + "within function\ndoCode "++show tOp'++" -- tOp'\n ("++showADL expr1++") -- expr1\n ("++showADL delta1++") -- delta1\n"++ + concat + [ "while trying to maintain conjunct "++showADL conjunct++ + "\nfrom rule "++intercalate "\n " [show r | r<-rs] + | (conjunct,rs)<-motive ] ++ + if null motive then "null motive" else "" + ) +-} + + deltaK0 :: t -> InsDel -> t1 -> t + deltaK0 delta' Ins _ = delta' -- error! (tijdelijk... moet berekenen welke paren in x gezet moeten worden zodat delta |- x*) + deltaK0 delta' Del _ = delta' -- error! (tijdelijk... moet berekenen welke paren uit x verwijderd moeten worden zodat delta/\x* leeg is) + deltaK1 :: t -> InsDel -> t1 -> t + deltaK1 delta' Ins _ = delta' -- error! (tijdelijk... moet berekenen welke paren in x gezet moeten worden zodat delta |- x+) + deltaK1 delta' Del _ = delta' -- error! (tijdelijk... moet berekenen welke paren uit x verwijderd moeten worden zodat delta/\x+ leeg is)
src/lib/DatabaseDesign/Ampersand/Fspec/ToFspec/NormalForms.hs view
@@ -1,6 +1,6 @@ {-# OPTIONS_GHC -Wall #-} -module DatabaseDesign.Ampersand.Fspec.ToFspec.NormalForms - (conjNF,disjNF,normPA,nfProof,cfProof,dfProof,proofPA,simplify,exprIsc2list, exprUni2list, exprCps2list, exprRad2list) +module DatabaseDesign.Ampersand.Fspec.ToFspec.NormalForms + (delta,conjNF,disjNF,normPA,nfProof,cfProof,dfProof,proofPA,simplify) where import DatabaseDesign.Ampersand.Basics import DatabaseDesign.Ampersand.ADL1.ECArule @@ -20,31 +20,41 @@ head [] = fatal 30 "head must not be used on an empty list!" head (a:_) = a + -- | This delta is meant to be used as a placeholder for inserting or removing links from expressions. + delta :: Sign -> Expression + delta sgn + = EDcD Sgn { decnm = "Delta" + , decsgn = sgn + , decprps = [] + , decprps_calc = Nothing + , decprL = "" + , decprM = "" + , decprR = "" + , decMean = AMeaning [ -- A_Markup Dutch ReST (string2Blocks ReST "Delta is bedoeld als variabele, die de plaats in een expressie vasthoudt waar paren worden ingevoegd of verwijderd.") + -- , A_Markup English ReST (string2Blocks ReST "Delta is meant as a variable, to be used as a placeholder for inserting or removing links from expressions.") + ] + , decfpos = Origin ("generated relation (Delta "++show sgn++")") + , deciss = True + , decusr = False + , decpat = "" + , decplug = True + } {- Normalization of process algebra clauses -} normPA :: PAclause -> PAclause - normPA expr = expr' - where (expr',_,_) = if null (proofPA expr) then fatal 21 "last: empty list" else last (proofPA expr) + normPA pac = pac' + where (pac',_,_) = if null (proofPA pac) then fatal 21 "last: empty list" else last (proofPA pac) type Proof a = [(a, [String], String)] proofPA :: PAclause -> Proof PAclause proofPA = {-reverse.take 3.reverse.-}pPA - where pPA expr' = case normstepPA expr' of - ( _ , [] ,equ) -> [(expr',[] ,equ)] -- is dus (expr,[],"<=>") - (res,steps,equ) -> (expr',steps,equ):pPA res + where pPA pac' = case normstepPA pac' of + ( _ , [] ,equ) -> [(pac',[] ,equ)] -- is dus (pac,[],"<=>") + (res,steps,equ) -> (pac',steps,equ):pPA res - normstepPA :: PAclause -> (PAclause,[String],String) - normstepPA expr = (res,ss,"<=>") - where - (res,ss) = norm expr - norm :: PAclause -> (PAclause,[String]) - norm (CHC [] ms) = (Blk ms, ["Run out of options"]) - norm (CHC [r] ms) = (r', ["Flatten ONE"]) - where r' = case r of - Blk{} -> r - _ -> r{paMotiv = ms} +{- The following rewriter is used to simplify the actions inside eca rules. -- WHY? Stef, kan je uitleggen wat hier gebeurt? Enig commentaar is hier wel op zijn plaats. -- Ook zou het helpen om bij de verschillende constructoren van PAclause een beschrijving te geven van het idee er achter. -- BECAUSE! Kan ik wel uitleggen, maar het is een heel verhaal. Dat moet tzt in een wetenschappelijk artikel gebeuren, zodat het er goed staat. @@ -53,14 +63,35 @@ -- Helaas zijn de herschrijfregels nu nog hard gecodeerd, zodat ik voor PAclause een afzonderlijke Haskell functie moet schrijven. -- Hierna volgt de normalisator voor relatiealgebra-expressies, genaamd normStep. Die heeft dezelfde structuur, -- maar gebruikt herschrijfregels vanuit gelijkheden die gelden in relatiealgebra. +-} + normstepPA :: PAclause -> (PAclause,[String],String) + normstepPA pac = (res,ss,"<=>") + where + (res,ss) = norm pac + norm :: PAclause -> (PAclause,[String]) + norm (CHC [] ms) = (Blk ms, ["Run out of options"]) + norm (CHC [r] ms) = (r', ["Flatten ONE"]) + where r' = case r of + Blk{} -> r + _ -> r{paMotiv = ms} norm (CHC ds ms) | (not.null) msgs = (CHC ops ms, msgs) | (not.null) [d | d<-ds, isCHC d] = (CHC (nub [ d' | d<-ds, d'<-if isCHC d then let CHC ops' _ = d in ops' else [d] ]) ms, ["flatten CHC"]) -- flatten | (not.null) [Nop | Nop{}<-ops] = (Nop{paMotiv=ms}, ["Choose to do nothing"]) | (not.null) [Blk | Blk{}<-ops] = (CHC [op | op<-ops, not (isBlk op)] ms, ["Choose anything but block"]) + | (not.null) doubles = (CHC [ head cl | cl<-eqClass (==) ds ] ms, ["remove double occurrences"]) | otherwise = (CHC ds ms, []) where nds = map norm ds msgs = concatMap snd nds ops = map fst nds + doubles = [ d | cl<-eqClass (==) ds, length cl>1, d<-cl ] + norm (GCH [] ms) = (Blk ms, ["Run out of options"]) + norm (GCH ds ms) | (not.null) [() | (_,links,_)<-normds, isFalse links] = (GCH [(tOp,links,p) | (tOp,links,p)<-normds, not (isFalse links)] ms, ["Remove provably empty guard(s)."]) + | (not.null) [() | (_, _ ,p)<-normds, isNop p] + = (GCH [(tOp,links,p) | (tOp,links,p)<-normds, not (isNop p)] ms, ["Remove unneccessary SELECT."]) + | (not.null) doubles = (GCH [ (fst3 (head cl), foldr1 (.\/.) (map snd3 cl), thd3 (head cl)) | cl<-eqCl (\(tOp,_,p)->(tOp,p)) ds ] ms, ["remove double occurrences"]) + | otherwise = (GCH ds ms, []) + where normds = [ (tOp, conjNF links, let (p',_)=norm p in p') | (tOp,links,p)<-ds] + doubles = [ d | cl<-eqCl (\(tOp,_,p)->(tOp,p)) ds, length cl>1, d<-cl ] norm (ALL [] ms) = (Nop ms, ["ALL [] = No Operation"]) norm (ALL [d] ms) = (d', ["Flatten ONE"]) where d' = case d of @@ -70,21 +101,24 @@ | (not.null) [d | d<-ds, isAll d] = (ALL (nub [ d' | d<-ds, d'<-if isAll d then let ALL ops' _ = d in ops' else [d] ]) ms, ["flatten ALL"]) -- flatten | (not.null) [Blk | Blk{}<-ops] = (Blk{paMotiv = [m | op@Blk{}<-ops,m<-paMotiv op]}, ["Block all"]) | (not.null) [Nop | Nop{}<-ops] = (ALL [op | op<-ops, not (isNop op)] ms, ["Ignore Nop"]) - | (not.null) long = (ALL ds' ms, ["Take the expressions for "++commaEng "and" [name (paTo (head cl)) |cl<-long]++"together"]) + | (not.null) doubles = (CHC [ head cl | cl<-eqClass (==) ds ] ms, ["remove double occurrences"]) + | (not.null) long = (ALL ds' ms, ["Take the expressions for "++commaEng "and" [name (paTo (head cl)) |cl<-long]++"together"]) | otherwise = (ALL ds ms, []) - where ds' = [ let p=head cl in - if length cl==1 then p else p{paDelta=disjNF (foldr1 (.\/.) [paDelta c | c<-cl]), paMotiv=concatMap paMotiv cl} - | cl<-dCls {- not (null cl) is guaranteed by eqCl -} ] - ++[d | d<-ds, not (isDo d)] - nds = map norm ds - msgs = concatMap snd nds - ops = map fst nds + where ds' = [ let p=head cl in + if length cl==1 then p else p{paDelta=disjNF (foldr1 (.\/.) [paDelta c | c<-cl]), paMotiv=concatMap paMotiv cl} + | cl<-dCls {- not (null cl) is guaranteed by eqCl -} ] + ++[d | d<-ds, not (isDo d)] + nds = map norm ds + msgs = concatMap snd nds + ops = map fst nds + doubles = [ d | cl<-eqClass (==) ds, length cl>1, d<-cl ] dCls :: [[PAclause]] dCls = eqCl to [d | d<-ds, isDo d] long :: [[PAclause]] long = [cl | cl<-dCls, length cl>1] - to d@Do{} = (paSrt d,paTo d) - to _ = fatal 74 "illegal call of to(d)" + to d = case d of + Do{} -> (paSrt d, paTo d) + _ -> fatal 74 "illegal call of to(d)" norm (New c p ms) = ( case p' of Blk{} -> p'{paMotiv = ms} _ -> New c (\x->let (p'', _) = norm (p x) in p'') ms @@ -95,11 +129,6 @@ _ -> Rmv c (\x->let (p'', _) = norm (p x) in p'') ms , msgs) where (p', msgs) = norm (p "x") - norm (Sel c e p ms) = ( case p' of - Blk{} -> p'{paMotiv = ms} - _ -> Sel c e (\x->let (p'', _) = norm (p x) in p'') ms - , msgs) - where (p', msgs) = norm (p "x") norm p = (p, []) @@ -139,8 +168,8 @@ nM :: Bool -> Expression -> [Expression] -> (Expression,[String],String) -- posCpl indicates whether the expression is positive under a complement. It is False when expr is inside a complemented expression. nM posCpl (EEqu (l,r)) _ | simpl = (t .==. f, steps++steps', fEqu [equ',equ'']) - where (t,steps, equ') = nM posCpl l [] - (f,steps',equ'') = nM posCpl r [] + where (t,steps, equ') = nM posCpl l [] -- TODO: the use of posCpl is erroneous + (f,steps',equ'') = nM posCpl r [] -- TODO: the use of posCpl is erroneous nM posCpl (EImp (l,r)) _ | simpl = (t .|-. f, steps++steps', fEqu [equ',equ'']) where (t,steps, equ') = nM (not posCpl) l [] (f,steps',equ'') = nM posCpl r [] @@ -163,6 +192,9 @@ nM posCpl (ERrs (l,r)) _ | simpl = (t .\. f, steps++steps', fEqu [equ',equ'']) where (t,steps, equ') = nM (not posCpl) l [] (f,steps',equ'') = nM posCpl r [] + nM posCpl (EDia (l,r)) _ | simpl = (t .<>. f, steps++steps', fEqu [equ',equ'']) + where (t,steps, equ') = nM posCpl l [] -- TODO: the use of posCpl is erroneous + (f,steps',equ'') = nM posCpl r [] -- TODO: the use of posCpl is erroneous nM posCpl (ERad (ERad (l,k),r)) rs = nM posCpl (l .!. (k .!. r)) rs -- standardize, using associativity of .!. nM posCpl (ERad (l,r)) rs | simpl = (t .!. f, steps++steps', fEqu [equ',equ'']) where (t,steps, equ') = nM posCpl l [] @@ -186,8 +218,10 @@ nM _ (EImp (x,ELrs (z,y))) _ = (x .:. y .|-. z, ["remove left residual (/)"],"<=>") nM _ (EImp (y,ERrs (x,z))) _ = (x .:. y .|-. z, ["remove right residual (\\)"],"<=>") nM _ (EImp (l,r)) _ = (notCpl l .\/. r, ["remove |-"],"<=>") - nM posCpl e@(ECpl EIsc{}) _ | posCpl==dnf = (deMorganEIsc e, ["De Morgan"], "<=>") - nM posCpl e@(ECpl EUni{}) _ | posCpl/=dnf = (deMorganEUni e, ["De Morgan"], "<=>") +-- nM posCpl e@(ECpl EIsc{}) _ | posCpl==dnf = (deMorganEIsc e, ["De Morgan"], "<=>") +-- nM posCpl e@(ECpl EUni{}) _ | posCpl/=dnf = (deMorganEUni e, ["De Morgan"], "<=>") + nM _ e@(ECpl EIsc{}) _ = (deMorganEIsc e, ["De Morgan"], "<=>") + nM _ e@(ECpl EUni{}) _ = (deMorganEUni e, ["De Morgan"], "<=>") nM _ e@(ECpl (ERad (_,ECpl{}))) _ = (deMorganERad e, ["De Morgan"], "<=>") nM _ e@(ECpl (ERad (ECpl{},_))) _ = (deMorganERad e, ["De Morgan"], "<=>") nM _ e@(ECpl (ECps (ECpl{},ECpl{}))) _ = (deMorganECps e, ["De Morgan"], "<=>") @@ -225,14 +259,24 @@ where (t,steps, equ') = nM posCpl l [] (f,steps',equ'') = nM posCpl r (l:rs) nM _ x@(EEps i sgn) _ | source sgn==i && i==target sgn = (EDcI i, ["source and target are equal to "++name i++", so "++showADL x++"="++showADL (EDcI i)], "<=>") + nM _ (ELrs (ECps (x,y),z)) _ | not eq && y==z = (x, ["(x;y)/y |- x"], "==>") + nM _ (ELrs (ECps (x,y),z)) _ | not eq && flp x==z= (flp y, [case (x, y) of + (EFlp _, EFlp _) -> "(SJ) (x~;y~)/x |- y" + ( _, EFlp _) -> "(SJ) (x;y~)/x~ |- y" + (EFlp _, _) -> "(SJ) (x~;y)/x |- y~" + ( _, _) -> "(SJ) (x;y)/x~ |- y~"], "==>") nM _ (ELrs (ELrs (x,z),y)) _ = (ELrs (x,ECps (y,z)), ["Jipsen&Tsinakis: x/yz = (x/z)/y"], "<=>") nM posCpl (ELrs (l,r)) _ = (t ./. f, steps++steps', fEqu [equ',equ'']) where (t,steps, equ') = nM posCpl l [] (f,steps',equ'') = nM (not posCpl) r [] nM _ (ERrs (y,ERrs (x,z))) _ = (ERrs (ECps (x,y),z), ["Jipsen&Tsinakis: xy\\z = y\\(x\\z)"], "<=>") + nM _ (ERrs (x,ECps (y,z))) _ | not eq && x==y = (z, ["x\\(x;y) |- y"], "==>") nM posCpl (ERrs (l,r)) _ = (t .\. f, steps++steps', fEqu [equ',equ'']) where (t,steps, equ') = nM (not posCpl) l [] (f,steps',equ'') = nM posCpl r [] + nM posCpl (EDia (l,r)) _ = (t .<>. f, steps++steps', fEqu [equ',equ'']) + where (t,steps, equ') = nM posCpl l [] + (f,steps',equ'') = nM posCpl r [] nM _ (ERad (l,r)) _ | isImin l = (r, ["-I!x = x"], "<=>") nM _ (ERad (l,r)) _ | isImin r = (l, ["x!-I = x"], "<=>") -- nM False (ERad (ECps (r,s),q)) _ | not eq = (r.:.(s.!.q), ["Peirce: (r;s)!q |- r;(s!q)"],"==>") -- SJ 20131124 TODO: check this rule. It is wrong! @@ -241,7 +285,7 @@ nM False (ERad (r,EUni (s,q))) _ | not eq = ((r.!.s).\/.(r.!.q), ["distribute ! over \\/"],"==>") nM _ (ERad (EIsc (q,s),r)) _ = ((q.!.r)./\.(s.!.r), ["distribute ! over /\\"],"<=>") nM _ (ERad (l,EIsc (q,s))) _ = ((l.!.q)./\.(l.!.s), ["distribute ! over /\\"],"<=>") - nM _ (ERad(ECpl l,r)) _ = (flp l .\. r, [case l of EFlp{} -> "-l~!r = l\r"; _ -> "-l!r = l~\r"], "<=>") + nM _ (ERad(ECpl l,r)) _ = (flp l .\. r, [case l of EFlp{} -> "-l~!r = l\\r"; _ -> "-l!r = l~\\r"], "<=>") nM _ (ERad(l,ECpl r)) _ = (l ./. flp r, [case r of EFlp{} -> "l!-r~ = l/r"; _ -> "l!-r = l/r~"], "<=>") nM posCpl (ERad (l,r)) rs = (t .!. f, steps++steps', fEqu [equ',equ'']) where (t,steps, equ') = nM posCpl l [] @@ -250,8 +294,8 @@ nM posCpl (EPrd (l,r)) _ = (t .*. f, steps++steps', fEqu [equ',equ'']) where (t,steps, equ') = nM posCpl l [] (f,steps',equ'') = nM posCpl r [] - nM _ (EIsc (EUni (l,k),r)) _ | dnf = ((l./\.r) .\/. (k./\.r), ["distribute /\\ over \\/"],"<=>") - nM _ (EIsc (l,EUni (k,r))) _ | dnf = ((l./\.k) .\/. (l./\.r), ["distribute /\\ over \\/"],"<=>") + nM posCpl (EIsc (EUni (l,k),r)) _ | posCpl==dnf = ((l./\.r) .\/. (k./\.r), ["distribute /\\ over \\/"],"<=>") + nM posCpl (EIsc (l,EUni (k,r))) _ | posCpl==dnf = ((l./\.k) .\/. (l./\.r), ["distribute /\\ over \\/"],"<=>") nM posCpl x@(EIsc (l,r)) rs -- Absorb equals: r/\r --> r | or [length cl>1 |cl<-absorbClasses] @@ -259,12 +303,15 @@ , [shw e++" /\\ "++shw e++" = "++shw e | cl<-absorbClasses, length cl>1, let e=head cl] , "<=>" ) +-- Absorb True: r/\V --> r + | isTrue l = (r, ["V/\\x = x"], "<=>") + | isTrue r = (l, ["x/\\V = x"], "<=>") -- Inconsistency: r/\-r --> False | not (null incons) = let i = head incons in (notCpl (EDcV (sign i)), [shw (notCpl i)++" /\\ "++shw i++" = V-"], "<=>") -- Inconsistency: x/\\V- --> False - | (not.null) [t' |t'<-exprIsc2list l++exprIsc2list r, isFalse t'] - = (notCpl (EDcV (sign x)), ["x/\\V- = V-"], "<=>") + | isFalse l = (notCpl (EDcV (sign x)), ["-V/\\x = -V"], "<=>") + | isFalse r = (notCpl (EDcV (sign x)), ["x/\\-V = -V"], "<=>") -- Absorb if r is antisymmetric: r/\r~ --> I | not eq && or [length cl>1 |cl<-absorbAsy] = ( foldr1 (./\.) [if length cl>1 then EDcI (source e) else e | cl<-absorbAsy, let e=head cl] @@ -311,8 +358,8 @@ absorbAsy = eqClass same eList where e `same` e' = isAsy e && isAsy e' && e == flp e' absorbAsyRfx = eqClass same eList where e `same` e' = isRfx e && isAsy e && isRfx e' && isAsy e' && e == flp e' eList = rs++exprIsc2list l++exprIsc2list r - nM _ (EUni (EIsc (l,k),r)) _ | not dnf = ((l.\/.r) ./\. (k.\/.r), ["distribute \\/ over /\\"],"<=>") - nM _ (EUni (l,EIsc (k,r))) _ | not dnf = ((l.\/.k) ./\. (l.\/.r), ["distribute \\/ over /\\"],"<=>") + nM posCpl (EUni (EIsc (l,k),r)) _ | posCpl/=dnf = ((l.\/.r) ./\. (k.\/.r), ["distribute \\/ over /\\"],"<=>") + nM posCpl (EUni (l,EIsc (k,r))) _ | posCpl/=dnf = ((l.\/.k) ./\. (l.\/.r), ["distribute \\/ over /\\"],"<=>") nM posCpl x@(EUni (l,r)) rs -- Absorb equals: r\/r --> r | or [length cl>1 |cl<-absorbClasses] -- yields False if absorbClasses is empty @@ -358,16 +405,6 @@ absor1' = [(t', exprIsc2list r>-[t']) | t'<-exprIsc2list r, ECpl f'<-rs++exprUni2list l, t'==f']++[(e, exprIsc2list r>-[e]) | e@(ECpl t')<-exprIsc2list r, f'<-rs++exprUni2list l, t'==f'] nM _ (EFlp e) _ | isSym e = (e,[shw e++" is symmetric"],"<=>") nM _ x _ = (x,[],"<=>") - - exprIsc2list, exprUni2list, exprCps2list, exprRad2list :: Expression -> [Expression] - exprIsc2list (EIsc (l,r)) = exprIsc2list l++exprIsc2list r - exprIsc2list r = [r] - exprUni2list (EUni (l,r)) = exprUni2list l++exprUni2list r - exprUni2list r = [r] - exprCps2list (ECps (l,r)) = exprCps2list l++exprCps2list r - exprCps2list r = [r] - exprRad2list (ERad (l,r)) = exprRad2list l++exprRad2list r - exprRad2list r = [r] fEqu :: [String] -> String fEqu ss = if and [s=="<=>" | s<-ss] then "<=>" else "==>"
src/lib/DatabaseDesign/Ampersand/Input/ADL1/CtxError.hs view
@@ -21,7 +21,8 @@ import DatabaseDesign.Ampersand.Fspec.ShowADL import DatabaseDesign.Ampersand.Basics -- import Data.Traversable -import Data.List (intercalate, partition) +import Data.List (intercalate) +import GHC.Exts (groupWith) import DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner (Token) import DatabaseDesign.Ampersand.Input.ADL1.UU_Parsing (Message) import DatabaseDesign.Ampersand.Core.ParseTree (TermPrim(..),P_ViewD(..),P_SubIfc,Traced(..), Origin(..), SrcOrTgt(..),FilePos(..)) @@ -74,17 +75,21 @@ uniqueNames :: (Identified a, Traced a) => [a] -> Guarded () -uniqueNames a = case findDuplicates (map name a) of +uniqueNames a = case (filter moreThanOne . groupWith name) a of [] -> pure () - [r] -> Errors [CTXE (origin (head a))$ "Names / labels must be unique. "++show r++", however, is not."] - r -> Errors [CTXE (origin (head a))$ "Names / labels must be unique. The following are not: "++concat ["\n - "++l'|l'<-r]] -findDuplicates :: Eq a => [a] -> [a] -findDuplicates [] = [] -findDuplicates (a:as) - = case (partition (== a) as) of - ([],r) -> findDuplicates r - (_,r) -> a:findDuplicates r - + xs -> Errors (map messageFor xs) + where + moreThanOne (_:_:_) = True + moreThanOne _ = False + messageFor :: (Identified a, Traced a) => [a] -> CtxError + messageFor (x:xs) = CTXE (origin x) + ("Names / labels must be unique. "++(show . name) x++", however, is also used at:"++ + concatMap (("\n "++ ) . show . origin) xs + ++"." + ) + messageFor _ = fatal 90 "messageFor must only be used on lists with more thatn one element!" +-- [r] -> Errors [CTXE (origin (head r))$ "Names / labels must be unique. "++(show . name) r++", however, is not."] +-- r -> Errors [CTXE (origin (head a))$ "Names / labels must be unique. The following are not: "++concat ["\n - "++l'|l'<-r]] class ErrorConcept a where showEC :: a -> String showMini :: a -> String
src/lib/DatabaseDesign/Ampersand/Input/ADL1/FilePos.hs view
@@ -10,7 +10,7 @@ --Traced a have an origin, which may be unknown. data FilePos = FilePos ( String, Pos, String) deriving (Eq, Ord) - data Origin = SomewhereNear String | OriginUnknown | Origin String | FileLoc FilePos | DBLoc String deriving (Eq, Ord) + data Origin = OriginUnknown | Origin String | FileLoc FilePos | DBLoc String deriving (Eq, Ord) --line column pos {- SJ20140216: made obsolete. This was used to tell which concept definitions are declared within a pattern or within a process. @@ -34,7 +34,6 @@ show (DBLoc str) = "Database location: "++str show (Origin str) = str show OriginUnknown = "Unknown origin" - show (SomewhereNear str) = "Somewhere near: "++str class Traced a where origin :: a -> Origin filenm :: a -> String
src/lib/DatabaseDesign/Ampersand/Input/ADL1/Parser.hs view
@@ -34,7 +34,7 @@ , "POPULATION", "CONTAINS" , "UNI", "INJ", "SUR", "TOT", "SYM", "ASY", "TRN", "RFX", "IRF", "PROP", "ALWAYS" , "RULE", "MESSAGE", "VIOLATION", "SRC", "TGT", "TEST"- , "RELATION", "MEANING", "DEFINE", "CONCEPT", "IDENT"+ , "RELATION", "MEANING", "CONCEPT", "IDENT" , "VIEW", "TXT", "PRIMHTML" , "KEY" -- HJO, 20130605: Obsolete. Only usefull as long as the old prototype generator is still in use. , "IMPORT", "SPEC", "ISA", "IS", "I", "V"@@ -46,7 +46,7 @@ , "ROLE", "EDITS", "MAINTAINS" ] keywordsops :: [String]- keywordsops = [ "|-", "-", "->", "<-", ">", "=", "~", "+", ";", "!", "*", "::", ":", "\\/", "/\\", "\\", "/", "<>"+ keywordsops = [ "|-", "-", "->", "<-", ">", "=", "~", "+", "*", ";", "!", "#", "::", ":", "\\/", "/\\", "\\", "/", "<>" , "..", "." , "0", "1"] specialchars :: String specialchars = "()[],{}"@@ -58,7 +58,7 @@ pPopulations = pList1 pPopulation pContext :: Parser Token (P_Context, [String]) -- the result is the parsed context and a list of include filenames- pContext = rebuild <$> pKey_pos "CONTEXT" <*> pConid+ pContext = rebuild <$> pKey_pos "CONTEXT" <*> pConceptName <*> optional pLanguageRef <*> optional pTextMarkup <*> pList pContextElement <* pKey "ENDCONTEXT"@@ -73,7 +73,7 @@ , ctx_pats = [p | CPat p<-ces] -- The patterns defined in this context , ctx_PPrcs = [p | CPrc p<-ces] -- The processes as defined by the parser , ctx_rs = [p | CRul p<-ces] -- All user defined rules in this context, but outside patterns and outside processes- , ctx_ds = [p | CRel p<-ces] -- The declarations defined in this context, outside the scope of patterns+ , ctx_ds = [p | CRel p<-ces] -- The relations defined in this context, outside the scope of patterns , ctx_cs = [c ("CONTEXT "++nm) | CCon c<-ces] -- The concept definitions defined in this context, outside the scope of patterns , ctx_gs = [g | CGen g<-ces] -- The gen definitions defined in this context, outside the scope of patterns , ctx_ks = [k | CIndx k<-ces] -- The identity definitions defined in this context, outside the scope of patterns@@ -235,7 +235,7 @@ | PrE PPurpose | PrP P_Population - pClassify :: Parser Token P_Gen+ pClassify :: Parser Token P_Gen -- Example: CLASSIFY A IS B /\ C /\ D pClassify = rebuild <$> pKey_pos "CLASSIFY" <*> pConceptRef <* pKey "IS"@@ -295,13 +295,12 @@ <*> ((True <$ pKey "BYPLUG") `opt` False) <*> (pPragma `opt` []) <*> pList pMeaning- <*> ((\st d -> Just $ RelConceptDef st d) <$ pKey "DEFINE" <*> pSrcOrTgt <*> pString `opt` Nothing) <*> ((pKey "=" *> pContent) `opt` []) <* (pKey "." `opt` "") -- in the syntax before 2011, a dot was required. This optional dot is there to save user irritation during the transition to a dotless era :-) .- where rebuild nm pos' src fun' trg bp1 props --bp2 pragma meanings conceptDef content- = rbd pos' nm (P_Sign src trg,pos') bp1 props' --bp2 pragma meanings conceptDef content+ where rebuild nm pos' src fun' trg bp1 props --bp2 pragma meanings content+ = rbd pos' nm (P_Sign src trg,pos') bp1 props' --bp2 pragma meanings content where props'= nub (props `uni` fun')- rbd pos' nm (sgn,_) bp1 props bp2 pragma meanings conceptDef content+ rbd pos' nm (sgn,_) bp1 props bp2 pragma meanings content = P_Sgn { dec_nm = nm , dec_sign = sgn , dec_prps = props@@ -309,7 +308,6 @@ , dec_prM = pr!!1 , dec_prR = pr!!2 , dec_Mean = meanings- , dec_conceptDef = conceptDef , dec_popu = content , dec_fpos = pos' , dec_plug = bp1 || bp2@@ -580,26 +578,26 @@ PMessage (P_Markup lang fmt mkup) {- Basically we would have the following expression syntax:-pRule ::= pTrm1 "=" pTerm |- pTrm1 "|-" pTerm |+pRule ::= pTrm1 "=" pTerm | -- equivalence+ pTrm1 "|-" pTerm | -- implication or subset pTrm1 .-pTerm ::= pList1Sep "/\\" pTrm2 |- pList1Sep "\\/" pTrm2 |+pTerm ::= pList1Sep "/\\" pTrm2 | -- intersection+ pList1Sep "\\/" pTrm2 | -- union pTrm2 .-pTrm2 ::= pTrm3 "-" pTrm3 |+pTrm2 ::= pTrm3 "-" pTrm3 | -- set difference pTrm3 .-pTrm3 ::= pTrm4 "\\" pTrm4 |- pTrm4 "/" pTrm4 |+pTrm3 ::= pTrm4 "\\" pTrm4 | -- right residual+ pTrm4 "/" pTrm4 | -- left residual pTrm4 .-pTrm4 ::= pList1Sep ";" pTrm5 |- pList1Sep "!" pTrm5 |- pList1Sep "*" pTrm5 |+pTrm4 ::= pList1Sep ";" pTrm5 | -- composition (semicolon)+ pList1Sep "!" pTrm5 | -- relative addition (dagger)+ pList1Sep "#" pTrm5 | -- cartesian product (asterisk) pTrm5 .-pTrm5 ::= "-" pTrm6 |- pTrm6 pSign |- pTrm6 "~" |- pTrm6 "*" |- pTrm6 "+" |+pTrm5 ::= "-" pTrm6 | -- unary complement+ pTrm6 pSign | -- unary type cast+ pTrm6 "~" | -- unary flip+ pTrm6 "*" | -- unary Kleene star+ pTrm6 "+" | -- unary Kleene plus pTrm6 . pTrm6 ::= pRelation | "(" pTerm ")" .@@ -648,20 +646,22 @@ -- The left factored version of right- and left residuals: pTrm3 :: Parser Token (Term TermPrim)- pTrm3 = pTrm4 <??> (fRrs <$> pKey_pos "\\" <*> pTrm4 <|> fLrs <$> pKey_pos "/" <*> pTrm4 )- where fRrs orig rExp lExp = PRrs orig lExp rExp- fLrs orig rExp lExp = PLrs orig lExp rExp+ pTrm3 = pTrm4 <??> (fLrs <$> pKey_pos "/" <*> pTrm4 <|> fRrs <$> pKey_pos "\\" <*> pTrm4 <|> fDia <$> pKey_pos "<>" <*> pTrm4 )+ where fLrs orig rExp lExp = PLrs orig lExp rExp+ fRrs orig rExp lExp = PRrs orig lExp rExp+ fDia orig rExp lExp = PDia orig lExp rExp {- by the way, a slightly different way of getting exactly the same result is: pTrm3 :: Parser Token (Term TermPrim)- pTrm3 = pTrm4 <??> (f <$> (pKey_val_pos "\\" <|> pKey_val_pos "/") <*> pTrm4 )+ pTrm3 = pTrm4 <??> (f <$> (pKey_val_pos "/" <|> pKey_val_pos "\\" <|> pKey_val_pos "<>") <*> pTrm4 ) where f ("\\", orig) rExp lExp = PRrs orig lExp rExp- f (_ , orig) rExp lExp = PLrs orig lExp rExp+ f ("/" , orig) rExp lExp = PLrs orig lExp rExp+ f (_ , orig) rExp lExp = PDia orig lExp rExp -} -- composition and relational addition are associative, and parsed similar to union and intersect... pTrm4 :: Parser Token (Term TermPrim)- pTrm4 = pTrm5 <??> (f PCps <$> pars PCps ";" <|> f PRad <$> pars PRad "!" <|> f PPrd <$> pars PPrd "*")+ pTrm4 = pTrm5 <??> (f PCps <$> pars PCps ";" <|> f PRad <$> pars PRad "!" <|> f PPrd <$> pars PPrd "#") where pars combinator operator = g <$> pKey_pos operator <*> pTrm5 <*> optional (pars combinator operator) where g orig y Nothing = (orig, y)
src/lib/DatabaseDesign/Ampersand/Input/Parsing.hs view
@@ -16,7 +16,6 @@ import DatabaseDesign.Ampersand.Input.ADL1.UU_Parsing -- (getMsgs,parse,evalSteps,parseIO) import DatabaseDesign.Ampersand.ADL1 import Control.Exception -import Paths_ampersand type ParseError = Message Token @@ -32,8 +31,7 @@ parseContext flags file = do { verboseLn flags $ "Parsing with "++show (parserVersion flags)++"..." ; rapRes <- if includeRap flags - then do dataDir <- getDataDir - let rapFile = dataDir </> "AmpersandData" </> "RepoRap" </> "RAP.adl" + then do let rapFile = ampersandDataDir flags </> "RepoRap" </> "RAP.adl" exists <- doesFileExist rapFile when (not exists) (fatal 39 $ "RAP file isn't installed properly. RAP.adl expected at:" ++"\n "++show rapFile @@ -193,7 +191,7 @@ where addEmptyIncludes parsedContext = (parsedContext, []) -- the old parsed does not support include filenames, so we add an empty list --- | Same as passeCtx_ , however this one is for a list of populations +-- | Same as parseCtx_ , however this one is for a list of populations parsePops :: String -- ^ The string to be parsed -> String -- ^ The name of the .pop file (used for error messages) -> ParserVersion -- ^ The specific version of the parser to be used
src/lib/DatabaseDesign/Ampersand/InputProcessing.hs view
@@ -18,7 +18,6 @@ import Data.List import System.Directory import System.FilePath -import Paths_ampersand import Control.Monad import Data.Traversable (sequenceA) import Control.Applicative @@ -32,8 +31,7 @@ createFspec flags = do userCtx <- parseWithIncluded flags (fileName flags) bothCtx <- if includeRap flags - then do dataDir <- getDataDir - let rapFile = dataDir </> "AmpersandData" </> "FormalAmpersand" </> "FormalAmpersand.adl" + then do let rapFile = ampersandDataDir flags </> "FormalAmpersand" </> "FormalAmpersand.adl" exists <- doesFileExist rapFile when (not exists) (fatal 39 $ "Ampersand isn't installed properly. Formal specification of Ampersand expected at:" ++"\n "++show rapFile @@ -73,7 +71,7 @@ (Errors err) -> fatal 64 ("MeatGrinder has errors!" ++ intercalate "\n"(map showErr err)) (Checked (pctx,[])) -> return (Checked pctx) - (Checked (_,includes)) -> fatal 67 "Meatgrinder returns included file????" + (Checked _ ) -> fatal 67 "Meatgrinder returns included file????" )
src/lib/DatabaseDesign/Ampersand/Misc.hs view
@@ -3,7 +3,7 @@ import DatabaseDesign.Ampersand.Misc.Languages as X (Lang(..), plural) import DatabaseDesign.Ampersand.Misc.Options as X - (getOptions, Options(..), defaultFlags, ParserVersion(..), + (getOptions, Options(..), ParserVersion(..), verboseLn, verbose, DocTheme(..), FspecFormat(..), FileFormat(..), helpNVersionTexts) import DatabaseDesign.Ampersand.Misc.Explain as X
src/lib/DatabaseDesign/Ampersand/Misc/Options.hs view
@@ -1,12 +1,12 @@ {-# LANGUAGE PatternGuards #-} {-# OPTIONS_GHC -Wall #-} module DatabaseDesign.Ampersand.Misc.Options - (Options(..),getOptions,defaultFlags,usageInfo' + (Options(..),getOptions,usageInfo' ,ParserVersion(..) ,verboseLn,verbose,FspecFormat(..),FileFormat(..) ,DocTheme(..),allFspecFormats,helpNVersionTexts) where -import System.Environment (getArgs, getProgName,getEnvironment) +import System.Environment (getArgs, getProgName,getEnvironment,getExecutablePath ) import DatabaseDesign.Ampersand.Misc.Languages (Lang(..)) import Data.Char (toUpper) import System.Console.GetOpt @@ -17,6 +17,7 @@ import Control.Monad import Data.Maybe import DatabaseDesign.Ampersand.Basics +import Paths_ampersand (getDataDir) import Prelude hiding (writeFile,readFile,getContents,putStr,putStrLn) import Data.List @@ -39,7 +40,6 @@ , development :: Bool , validateSQL :: Bool , genPrototype :: Bool - , autoid :: Bool --implies forall Concept A => value::A->Datatype [INJ]. where instances of A are autogenerated , dirPrototype :: String -- the directory to generate the prototype in. , allInterfaces :: Bool , dbName :: String @@ -76,118 +76,111 @@ , genMeat :: Bool -- Generate the meta-population and output it to an .adl file , language :: Maybe Lang -- The language in which the user wants the documentation to be printed. , dirExec :: String --the base for relative paths to input files + , ampersandDataDir :: FilePath -- the directory where Ampersand data files are. , progrName :: String --The name of the adl executable , fileName :: FilePath --the file with the Ampersand context , baseName :: String - , logName :: String + , logName :: FilePath , genTime :: LocalTime , export2adl :: Bool , test :: Bool , includeRap :: Bool -- When set, the standard RAP is 'merged' into the generated prototype.(experimental) , pangoFont :: String -- use specified font in PanDoc. May be used to avoid pango-warnings. - , sqlHost :: Maybe String -- do database queries to the specified host - , sqlLogin :: Maybe String -- pass login name to the database server - , sqlPwd :: Maybe String -- pass password on to the database server + , sqlHost :: String -- do database queries to the specified host + , sqlLogin :: String -- pass login name to the database server + , sqlPwd :: String -- pass password on to the database server , parserVersion :: ParserVersion - } -- deriving Show + } -defaultFlags :: Options -defaultFlags = Options {genTime = fatal 81 "No monadic options available." - , dirOutput = fatal 82 "No monadic options available." - , outputfile = fatal 83 "No monadic options available." - , autoid = False - , dirPrototype = fatal 84 "No monadic options available." - , dbName = fatal 85 "No monadic options available." - , logName = fatal 86 "No monadic options available." - , dirExec = fatal 87 "No monadic options available." - , preVersion = fatal 88 "No monadic options available." - , postVersion = fatal 89 "No monadic options available." - , theme = DefaultTheme - , showVersion = False - , showHelp = False - , verboseP = False - , development = False - , validateSQL = False - , genPrototype = False - , allInterfaces = False - , genAtlas = False - , namespace = [] - , autoRefresh = Nothing - , testRule = Nothing - , customCssFile = Nothing - , importfile = [] - , fileformat = fatal 101 "--fileformat is required for --import." - , genXML = False - , genFspec = False - , diag = False - , fspecFormat = fatal 105 $ "Unknown fspec format. Currently supported formats are "++allFspecFormats++"." - , genGraphics = True - , genEcaDoc = False - , proofs = False - , haskell = False - , crowfoot = False - , blackWhite = False - , doubleEdges = False - , showPredExpr = False - , noDiagnosis = False - , diagnosisOnly = False - , genLegalRefs = False - , genUML = False - , genFPAExcel = False - , genStaticFiles= True - , genBericht = False - , genMeat = False - , language = Nothing - , progrName = fatal 118 "No monadic options available." - , fileName = fatal 119 "no default value for fileName." - , baseName = fatal 120 "no default value for baseName." - , export2adl = False - , test = False - , includeRap = False - , pangoFont = "Sans" - , sqlHost = Nothing - , sqlLogin = Nothing - , sqlPwd = Nothing - , parserVersion = Current - } getOptions :: IO Options getOptions = do args <- getArgs progName <- getProgName + exePath <- getExecutablePath -- findExecutable progName + env <- getEnvironment + haskellInstallationDirectoryOfAmpersand <- getDataDir + let dataDirOfAmpersandInstallation = takeDirectory exePath </> ".." </> "AmpersandData" let usage = "\nType '"++ progName++" --help' for usage info." - let (o,n,errs) = getOpt Permute (each options) args - when ((not.null) errs) (error $ concat errs ++ usage) - defaultOpts <- defaultOptionsM (head (n++(error $ "Please supply the name of an ampersand file" ++ usage))) - let flags = foldl (flip id) defaultOpts o + let (actions, nonOptions, errors) = getOpt Permute (each options) args + let fName = head (nonOptions++(error $ "Please supply the name of an ampersand file" ++ usage)) + localTime <- getLocalTime + when ((not.null) errors) (error $ concat errors ++ usage) + + -- Here we thread startOptions through all supplied option actions + flags <- foldl (>>=) (return (startOptions fName localTime env exePath progName dataDirOfAmpersandInstallation)) actions + -- defaultOpts <- defaultOptionsM + -- let flags = foldl (flip id) opts actions if showHelp flags || showVersion flags then return flags - else checkNSetOptionsAndFileNameM (flags,n) usage + else checkNSetOptionsAndFileNameM (flags,nonOptions) usage where - defaultOptionsM :: String -> IO Options - defaultOptionsM fName = - do utcTime <- getCurrentTime - timeZone <- getCurrentTimeZone - let localTime = utcToLocalTime timeZone utcTime - progName <- getProgName - exePath <- findExecutable progName - env <- getEnvironment - return - defaultFlags - { genTime = localTime - , dirOutput = fromMaybe "." (lookup envdirOutput env) - , dirPrototype = fromMaybe ("." </> (addExtension (takeBaseName fName) ".proto")) - (lookup envdirPrototype env) </> (addExtension (takeBaseName fName) ".proto") - , dbName = fromMaybe "" (lookup envdbName env) - , logName = fromMaybe "Ampersand.log" (lookup envlogName env) - , dirExec = case exePath of - Nothing -> fatal 155 $ "Specify the path location of "++progName++" in your system PATH variable." - Just s -> takeDirectory s - , preVersion = fromMaybe "" (lookup "CCPreVersion" env) - , postVersion = fromMaybe "" (lookup "CCPostVersion" env) - , progrName = progName - } + getLocalTime :: IO LocalTime + getLocalTime = do utcTime <- getCurrentTime + timeZone <- getCurrentTimeZone + return (utcToLocalTime timeZone utcTime) + startOptions :: String -> LocalTime -> [(String,String)] -> FilePath -> String -> FilePath -> Options + startOptions fName localTime env exePath progName dataDirOfAmpersandInstallation= + Options {genTime = localTime + , dirOutput = fromMaybe "." (lookup envdirOutput env) + , outputfile = fatal 83 "No monadic options available." + , dirPrototype = fromMaybe ("." </> (addExtension (takeBaseName fName) ".proto")) + (lookup envdirPrototype env) </> (addExtension (takeBaseName fName) ".proto") + , dbName = fromMaybe "" (lookup envdbName env) + , logName = fromMaybe "Ampersand.log" (lookup envlogName env) + , dirExec = takeDirectory exePath + , ampersandDataDir = dataDirOfAmpersandInstallation + , preVersion = fromMaybe "" (lookup "CCPreVersion" env) + , postVersion = fromMaybe "" (lookup "CCPostVersion" env) + , theme = DefaultTheme + , showVersion = False + , showHelp = False + , verboseP = False + , development = False + , validateSQL = False + , genPrototype = False + , allInterfaces = False + , genAtlas = False + , namespace = [] + , autoRefresh = Nothing + , testRule = Nothing + , customCssFile = Nothing + , importfile = [] + , fileformat = fatal 101 "--fileformat is required for --import." + , genXML = False + , genFspec = False + , diag = False + , fspecFormat = fatal 105 $ "Unknown fspec format. Currently supported formats are "++allFspecFormats++"." + , genGraphics = True + , genEcaDoc = False + , proofs = False + , haskell = False + , crowfoot = False + , blackWhite = False + , doubleEdges = False + , showPredExpr = False + , noDiagnosis = False + , diagnosisOnly = False + , genLegalRefs = False + , genUML = False + , genFPAExcel = False + , genStaticFiles= True + , genBericht = False + , genMeat = False + , language = Nothing + , progrName = progName + , fileName = fatal 119 "no default value for fileName." + , baseName = fatal 120 "no default value for baseName." + , export2adl = False + , test = False + , includeRap = False + , pangoFont = "Sans" + , sqlHost = "localhost" + , sqlLogin = "ampersand" + , sqlPwd = "ampersand" + , parserVersion = Current + } @@ -265,70 +258,243 @@ each :: [(a, DisplayMode) ] -> [a] each flags = [o |(o,_) <- flags] -options :: [(OptDescr (Options -> Options), DisplayMode) ] +type OptionDef = OptDescr (Options -> IO Options) +options :: [(OptionDef, DisplayMode) ] options = map pp - [ (Option "v" ["version"] (NoArg versionOpt) "show version and exit.", Public) - , (Option "h?" ["help"] (NoArg helpOpt) "get (this) usage information.", Public) - , (Option "" ["verbose"] (NoArg verboseOpt) "verbose error message format.", Public) - , (Option "" ["dev"] (NoArg developmentOpt) "Report and generate extra development information", Hidden) - , (Option "" ["validate"] (NoArg (\flags -> flags{validateSQL = True})) "Compare results of rule evaluation in Haskell and SQL (requires command line php with MySQL support)", Hidden) - , (Option "p" ["proto"] (OptArg prototypeOpt "dir") ("generate a functional prototype (overwrites environment variable " - ++ envdirPrototype ++ ")."), Public) - , (Option "d" ["dbName"] (ReqArg dbNameOpt "name") ("database name (overwrites environment variable " - ++ envdbName ++ ", defaults to filename)"), Public) - , (Option [] ["theme"] (ReqArg themeOpt "theme") "differentiate between certain outputs e.g. student", Public) - , (Option "x" ["interfaces"] (NoArg maxInterfacesOpt) "generate interfaces.", Public) - , (Option "e" ["export"] (OptArg exportOpt "file") "export as ASCII Ampersand syntax.", Public) - , (Option "o" ["outputDir"] (ReqArg outputDirOpt "dir") ("output directory (dir overwrites environment variable " - ++ envdirOutput ++ ")."), Public) - , (Option [] ["log"] (ReqArg logOpt "name") ("log file name (name overwrites environment variable " - ++ envlogName ++ ")."), Hidden) - , (Option [] ["import"] (ReqArg importOpt "file") "import this file as the population of the context.", Public) - , (Option [] ["fileformat"] (ReqArg formatOpt "format")("format of import file (format=" - ++allFileFormats++")."), Public) - , (Option [] ["namespace"] (ReqArg namespaceOpt "ns") "places the population in this namespace within the context.", Public) - , (Option "f" ["fspec"] (ReqArg fspecRenderOpt "format") - ("generate a functional specification document in specified format (format=" - ++allFspecFormats++")."), Public) - , (Option [] ["refresh"] (OptArg autoRefreshOpt "interval") "Experimental auto-refresh feature", Hidden) - , (Option [] ["testRule"] (ReqArg (\ruleName flags -> flags{ testRule = Just ruleName }) "rule name") - "Show contents and violations of specified rule.", Hidden) - , (Option [] ["css"] (ReqArg (\pth flags -> flags{ customCssFile = Just pth }) "file") - "Custom.css file to customize the style of the prototype.", Public) - , (Option [] ["noGraphics"] (NoArg noGraphicsOpt) "save compilation time by not generating any graphics.", Public) - , (Option [] ["ECA"] (NoArg genEcaDocOpt) "generate documentation with ECA rules.", Public) - , (Option [] ["proofs"] (NoArg proofsOpt) "generate derivations.", Public) - , (Option [] ["XML"] (NoArg xmlOpt) "generate internal data structure, written in XML (for debugging).", Public) - , (Option [] ["haskell"] (NoArg haskellOpt) "generate internal data structure, written in Haskell (for debugging).", Public) - , (Option [] ["crowfoot"] (NoArg crowfootOpt) "generate crowfoot notation in graphics.", Public) - , (Option [] ["blackWhite"] (NoArg blackWhiteOpt) "do not use colours in generated graphics", Public) - , (Option [] ["doubleEdges"] (NoArg doubleEdgesOpt) "generate graphics in an alternate way. (you may experiment with this option to see the differences for yourself)", Public) - , (Option [] ["predLogic"] (NoArg predLogicOpt) "show logical expressions in the form of predicate logic." , Public) - , (Option [] ["noDiagnosis"] (NoArg noDiagnosisOpt) "omit the diagnosis chapter from the functional specification document." , Public) - , (Option [] ["diagnosis"] (NoArg diagnosisOpt) "diagnose your Ampersand script (generates a .pdf file).", Public) - , (Option [] ["legalrefs"] (NoArg (\flags -> flags{genLegalRefs = True})) - "generate a table of legal references in Natural Language chapter.", Public) - , (Option [] ["uml"] (NoArg (\flags -> flags{genUML = True})) - "Generate a UML 2.0 data model.", Hidden) - , (Option [] ["FPA"] (NoArg (\flags -> flags{genFPAExcel = True})) - "Generate a Excel workbook (.xls).", Hidden) - , (Option [] ["bericht"] (NoArg (\flags -> flags{genBericht = True})) - "Generate definitions for 'berichten' (specific to INDOORS project).", Hidden) - , (Option [] ["language"] (ReqArg languageOpt "lang") "Pick 'NL' for Dutch or 'EN' for English,\nas the language to be used in your output.\nWithout this option, output is written in the language of your context.", Public) - , (Option [] ["test"] (NoArg testOpt) "Used for test purposes only.", Hidden) - , (Option [] ["rap"] (NoArg (\flags -> flags{includeRap = True})) - "Include RAP into the generated artifacts (experimental)", Hidden) - , (Option [] ["meta"] (NoArg (\flags -> flags{genMeat = True})) - "Generate meta-population in an .adl file (experimental)", Hidden) - , (Option [] ["pango"] (OptArg pangoOpt "fontname") "specify font name for Pango in graphics.", Hidden) - , (Option [] ["no-static-files"] (NoArg (\flags -> flags{genStaticFiles = False})) - "Do not generate static files into the prototype directory", Public) - , (Option [] ["sqlHost"] (OptArg sqlHostOpt "name") "specify database host name.", Hidden) - , (Option [] ["sqlLogin"] (OptArg sqlLoginOpt "name") "specify database login name.", Hidden) - , (Option [] ["sqlPwd"] (OptArg sqlPwdOpt "str") "specify database password.", Hidden) - , (Option [] ["forceSyntax"] (ReqArg forceSyntaxOpt "versionNumber") "version number of the syntax to be used, ('1' or '2'). Without this, Ampersand will guess the version used.", Hidden) + [ (Option "v" ["version"] + (NoArg (\flags -> return flags{showVersion = True})) + "show version and exit." + , Public) + , (Option "h?" ["help"] + (NoArg (\flags -> return flags{showHelp = True})) + "get (this) usage information." + , Public) + , (Option "" ["verbose"] + (NoArg (\flags -> return flags{verboseP = True})) + "verbose error message format." + , Public) + , (Option "" ["dev"] + (NoArg (\flags -> return flags{development = True})) + "Report and generate extra development information" + , Hidden) + , (Option "" ["validate"] + (NoArg (\flags -> return flags{validateSQL = True})) + "Compare results of rule evaluation in Haskell and SQL (requires command line php with MySQL support)" + , Hidden) + , (Option "p" ["proto"] + (OptArg (\nm flags -> return flags {dirPrototype = fromMaybe (dirPrototype flags) nm + ,genPrototype = True} + ) "DIRECTORY") + ("generate a functional prototype (overwrites environment variable "++ envdirPrototype ++ ").") + , Public) + , (Option "d" ["dbName"] + (ReqArg (\nm flags -> return flags{dbName = if nm == "" + then baseName flags + else nm} + ) "NAME") + ("database name (overwrites environment variable "++ envdbName ++ ", defaults to filename)") + , Public) + , (Option [] ["theme"] + (ReqArg (\t flags -> return flags{theme = case map toUpper t of + "STUDENT" -> StudentTheme + "STUDENTDESIGNER" -> StudentDesignerTheme + "DESIGNER" -> DesignerTheme + "PROOF" -> ProofTheme + _ -> DefaultTheme} + ) "THEME") + "differentiate between certain outputs e.g. student" + , Public) + , (Option "x" ["interfaces"] + (NoArg (\flags -> return flags{allInterfaces = True})) + "generate interfaces." + , Public) + , (Option "e" ["export"] + (OptArg (\mbnm flags -> return flags{export2adl = True + ,outputfile = fromMaybe "Export.adl" mbnm}) "file") + "export as plain Ampersand script." + , Public) + , (Option "o" ["outputDir"] + (ReqArg (\nm flags -> return flags{dirOutput = nm} + ) "DIR") + ("output directory (dir overwrites environment variable "++ envdirOutput ++ ").") + , Public) + , (Option [] ["log"] + (ReqArg (\nm flags -> return flags{logName = nm} + ) "NAME") + ("log file name (name overwrites environment variable "++ envlogName ++ ").") + , Hidden) + , (Option [] ["import"] + (ReqArg (\nm flags -> return flags{importfile = nm} + ) "FILE") + "import this file as the population of the context." + , Public) + , (Option [] ["fileformat"] + (ReqArg (\f flags -> return + flags{fileformat = case map toUpper f of + "ADL" -> Adl1Format + "ADL1"-> Adl1Format + "POP" -> Adl1PopFormat + "POP1"-> Adl1PopFormat + _ -> fileformat flags + } + ) "FORMAT") + ("format of import file (format=ADL (.adl), ADL1 (.adl), POP (.pop), POP1 (.pop)).") + , Public) + , (Option [] ["namespace"] + (ReqArg (\nm flags -> return flags{namespace = nm} + ) "NAMESPACE") + "places the population in this namespace within the context." + , Public) + , (Option "f" ["fspec"] + (ReqArg (\w flags -> return flags + { genFspec=True + , fspecFormat= case map toUpper w of + ('A': _ ) -> Fasciidoc + ('C': _ ) -> Fcontext + ('D': _ ) -> Fdocbook + ('H': _ ) -> Fhtml + ('L': _ ) -> FLatex + ('M':'A':'N': _ ) -> Fman + ('M':'A': _ ) -> Fmarkdown + ('M':'E': _ ) -> Fmediawiki + ('O':'P': _ ) -> Fopendocument + ('O':'R': _ ) -> Forg + ('P':'A': _ ) -> FPandoc + ('P':'L': _ ) -> Fplain + ('R':'S': _ ) -> Frst + ('R':'T': _ ) -> Frtf + ('T':'E':'X':'I': _ ) -> Ftexinfo + ('T':'E':'X':'T': _ ) -> Ftextile + _ -> fspecFormat flags} + ) "FORMAT") + ("generate a functional specification document in specified format (format="++allFspecFormats++").") + , Public) + , (Option [] ["refresh"] + (OptArg (\r flags -> return + flags{autoRefresh = Just (case r of + Just str | [(i,"")] <- reads str -> i + _ -> 5 + )} + ) "INTERVAL") + "Experimental auto-refresh feature" + , Hidden) + , (Option [] ["testRule"] + (ReqArg (\ruleName flags -> return flags{ testRule = Just ruleName } + ) "RULE") + "Show contents and violations of specified rule." + , Hidden) + , (Option [] ["css"] + (ReqArg (\pth flags -> return flags{ customCssFile = Just pth }) "file") + "Custom.css file to customize the style of the prototype." + , Public) + , (Option [] ["noGraphics"] + (NoArg (\flags -> return flags{genGraphics = False})) + "save compilation time by not generating any graphics." + , Public) + , (Option [] ["ECA"] + (NoArg (\flags -> return flags{genEcaDoc = True})) + "generate documentation with ECA rules." + , Public) + , (Option [] ["proofs"] + (NoArg (\flags -> return flags{proofs = True})) + "generate derivations." + , Public) + , (Option [] ["XML"] + (NoArg (\flags -> return flags{genXML = True})) + "generate internal data structure, written in XML (for debugging)." + , Public) + , (Option [] ["haskell"] + (NoArg (\flags -> return flags{haskell = True})) + "generate internal data structure, written in Haskell (for debugging)." + , Public) + , (Option [] ["crowfoot"] + (NoArg (\flags -> return flags{crowfoot = True})) + "generate crowfoot notation in graphics." + , Public) + , (Option [] ["blackWhite"] + (NoArg (\flags -> return flags{blackWhite = True})) + "do not use colours in generated graphics" + , Public) + , (Option [] ["doubleEdges"] + (NoArg (\flags -> return flags{doubleEdges = not (doubleEdges flags)})) + "generate graphics in an alternate way. (you may experiment with this option to see the differences for yourself)" + , Public) + , (Option [] ["predLogic"] + (NoArg (\flags -> return flags{showPredExpr = True})) + "show logical expressions in the form of predicate logic." + , Public) + , (Option [] ["noDiagnosis"] + (NoArg (\flags -> return flags{noDiagnosis = True})) + "omit the diagnosis chapter from the functional specification document." + , Public) + , (Option [] ["diagnosis"] + (NoArg (\flags -> return flags{diagnosisOnly = True})) + "diagnose your Ampersand script (generates a .pdf file)." + , Public) + , (Option [] ["legalrefs"] + (NoArg (\flags -> return flags{genLegalRefs = True})) + "generate a table of legal references in Natural Language chapter." + , Public) + , (Option [] ["uml"] + (NoArg (\flags -> return flags{genUML = True})) + "Generate a UML 2.0 data model." + , Hidden) + , (Option [] ["FPA"] + (NoArg (\flags -> return flags{genFPAExcel = True})) + "Generate a Excel workbook (.xls)." + , Hidden) + , (Option [] ["bericht"] + (NoArg (\flags -> return flags{genBericht = True})) + "Generate definitions for 'berichten' (specific to INDOORS project)." + , Hidden) + , (Option [] ["language"] + (ReqArg (\l flags-> return flags{language = case map toUpper l of + "NL" -> Just Dutch + "UK" -> Just English + "US" -> Just English + "EN" -> Just English + _ -> Nothing} + ) "LANG") + "Pick 'NL' for Dutch or 'EN' for English, as the language to be used in your output. Without this option, output is written in the language of your context." + , Public) + , (Option [] ["test"] + (NoArg (\flags -> return flags{test = True})) + "Used for test purposes only." + , Hidden) + , (Option [] ["rap"] + (NoArg (\flags -> return flags{includeRap = True})) + "Include RAP into the generated artifacts (experimental)" + , Hidden) + , (Option [] ["meta"] + (NoArg (\flags -> return flags{genMeat = True})) + "Generate meta-population in an .adl file (experimental)" + , Hidden) + , (Option [] ["pango"] + (ReqArg (\nm flags -> return flags{pangoFont = nm} + ) "FONTNAME") + "specify font name for Pango in graphics." + , Hidden) + , (Option [] ["no-static-files"] + (NoArg (\flags -> return flags{genStaticFiles = False})) + "Do not generate static files into the prototype directory" + , Public) + , (Option [] ["sqlHost"] + (ReqArg (\nm flags -> return flags{sqlHost = nm} + ) "HOSTNAME") + "specify database host name." + , Hidden) + , (Option [] ["sqlLogin"] + (ReqArg (\nm flags -> return flags{sqlLogin = nm} + ) "NAME") + "specify database login name." + , Hidden) + , (Option [] ["sqlPwd"] + (ReqArg (\nm flags -> return flags{sqlPwd = nm} + ) "STR") + "specify database password." + , Hidden) ] - where pp :: (OptDescr (Options -> Options), DisplayMode) -> (OptDescr (Options -> Options), DisplayMode) + where pp :: (OptionDef, DisplayMode) -> (OptionDef, DisplayMode) pp (Option a b' c d,e) = (Option a b' c d',e) where d' = afkappen [] [] (words d) 40 afkappen :: [[String]] -> [String] -> [String] -> Int -> String @@ -348,127 +514,7 @@ envlogName :: String envlogName="CClogName" -versionOpt :: Options -> Options -versionOpt flags = flags{showVersion = True} -helpOpt :: Options -> Options -helpOpt flags = flags{showHelp = True} -verboseOpt :: Options -> Options -verboseOpt flags = flags{ verboseP = True} -developmentOpt :: Options -> Options -developmentOpt flags = flags{ development = True} -autoRefreshOpt :: Maybe String -> Options -> Options -autoRefreshOpt (Just interval) flags | [(i,"")] <- reads interval = flags{autoRefresh = Just i} -autoRefreshOpt _ flags = flags{autoRefresh = Just 5} -prototypeOpt :: Maybe String -> Options -> Options -prototypeOpt nm flags - = flags { dirPrototype = fromMaybe (dirPrototype flags) nm - , genPrototype = True} -importOpt :: String -> Options -> Options -importOpt nm flags - = flags { importfile = nm } -formatOpt :: String -> Options -> Options -formatOpt f flags = case map toUpper f of - "ADL" -> flags{fileformat = Adl1Format} - "ADL1"-> flags{fileformat = Adl1Format} - "POP" -> flags{fileformat = Adl1PopFormat} - "POP1"-> flags{fileformat = Adl1PopFormat} - _ -> flags -maxInterfacesOpt :: Options -> Options -maxInterfacesOpt flags = flags{allInterfaces = True} -themeOpt :: String -> Options -> Options -themeOpt t flags = flags{theme = case map toUpper t of - "STUDENT" -> StudentTheme - "STUDENTDESIGNER" -> StudentDesignerTheme - "DESIGNER" -> DesignerTheme - "PROOF" -> ProofTheme - _ -> DefaultTheme} -dbNameOpt :: String -> Options -> Options -dbNameOpt nm flags = flags{dbName = if nm == "" - then baseName flags - else nm - } -namespaceOpt :: String -> Options -> Options -namespaceOpt x flags = flags{namespace = x} -xmlOpt :: Options -> Options -xmlOpt flags = flags{genXML = True} -fspecRenderOpt :: String -> Options -> Options -fspecRenderOpt w flags = flags{ genFspec=True - , fspecFormat= case map toUpper w of - ('A': _ ) -> Fasciidoc - ('C': _ ) -> Fcontext - ('D': _ ) -> Fdocbook - ('H': _ ) -> Fhtml - ('L': _ ) -> FLatex - ('M':'A':'N': _ ) -> Fman - ('M':'A': _ ) -> Fmarkdown - ('M':'E': _ ) -> Fmediawiki - ('O':'P': _ ) -> Fopendocument - ('O':'R': _ ) -> Forg - ('P':'A': _ ) -> FPandoc - ('P':'L': _ ) -> Fplain - ('R':'S': _ ) -> Frst - ('R':'T': _ ) -> Frtf - ('T':'E':'X':'I': _ ) -> Ftexinfo - ('T':'E':'X':'T': _ ) -> Ftextile - _ -> fspecFormat flags - - } -allFileFormats :: String -allFileFormats = "ADL (.adl), ADL1 (.adl), POP (.pop), POP1 (.pop)" -noGraphicsOpt :: Options -> Options -noGraphicsOpt flags = flags{genGraphics = False} -genEcaDocOpt :: Options -> Options -genEcaDocOpt flags = flags{genEcaDoc = True} -proofsOpt :: Options -> Options -proofsOpt flags = flags{proofs = True} -exportOpt :: Maybe String -> Options -> Options -exportOpt mbnm flags = flags{export2adl = True - ,outputfile = fromMaybe "Export.adl" mbnm} -haskellOpt :: Options -> Options -haskellOpt flags = flags{haskell = True} -outputDirOpt :: String -> Options -> Options -outputDirOpt nm flags = flags{dirOutput = nm} -crowfootOpt :: Options -> Options -crowfootOpt flags = flags{crowfoot = True} -blackWhiteOpt :: Options -> Options -blackWhiteOpt flags = flags{blackWhite = True} -doubleEdgesOpt :: Options -> Options -doubleEdgesOpt flags = flags{doubleEdges = not (doubleEdges flags)} -predLogicOpt :: Options -> Options -predLogicOpt flags = flags{showPredExpr = True} -noDiagnosisOpt :: Options -> Options -noDiagnosisOpt flags = flags{noDiagnosis = True} -diagnosisOpt :: Options -> Options -diagnosisOpt flags = flags{diagnosisOnly = True} -languageOpt :: String -> Options -> Options -languageOpt l flags = flags{language = case map toUpper l of - "NL" -> Just Dutch - "UK" -> Just English - "US" -> Just English - "EN" -> Just English - _ -> Nothing} -forceSyntaxOpt :: String -> Options -> Options -forceSyntaxOpt s flags = flags{parserVersion = case s of - "1" -> Legacy - "2" -> Current - "0" -> Current --indicates latest - _ -> error $ "Unknown value for syntax version: "++s++". Known values are 0, 1 or 2. 0 indicates latest." - } -logOpt :: String -> Options -> Options -logOpt nm flags = flags{logName = nm} -pangoOpt :: Maybe String -> Options -> Options -pangoOpt (Just nm) flags = flags{pangoFont = nm} -pangoOpt Nothing flags = flags -sqlHostOpt :: Maybe String -> Options -> Options -sqlHostOpt mnm flags = flags{sqlHost = mnm} -sqlLoginOpt :: Maybe String -> Options -> Options -sqlLoginOpt mnm flags = flags{sqlLogin = mnm} -sqlPwdOpt :: Maybe String -> Options -> Options -sqlPwdOpt mnm flags = flags{sqlPwd = mnm} -testOpt :: Options -> Options -testOpt flags = flags{test = True} - verbose :: Options -> String -> IO () verbose flags x | verboseP flags = putStr x @@ -480,5 +526,7 @@ mapM_ putStrLn (lines x) | otherwise = return () helpNVersionTexts :: String -> Options -> [String] -helpNVersionTexts vs flags = [preVersion flags++vs++postVersion flags++"\n" | showVersion flags]++ +helpNVersionTexts vs flags = ["Executable: "++show (dirExec flags)++"\n"++ + preVersion flags++vs++postVersion flags++"\n" | showVersion flags]++ [usageInfo' flags | showHelp flags] +
src/lib/DatabaseDesign/Ampersand/Output/Fspec2Pandoc.hs view
@@ -68,15 +68,14 @@ where myDoc = ( (setTitle - (text- (case (fsLang fSpec, diagnosisOnly flags) of- (Dutch , False) -> "Functionele Specificatie van "- (English, False) -> "Functional Specification of "- (Dutch , True) -> "Diagnose van "- (English, True) -> "Diagnosis of "- )- <>- (singleQuoted.text.name) fSpec+ (case metaValues "title" fSpec of+ [] -> text (case (fsLang fSpec, diagnosisOnly flags) of+ (Dutch , False) -> "Functionele Specificatie van "+ (English, False) -> "Functional Specification of "+ (Dutch , True) -> "Diagnose van "+ (English, True) -> "Diagnosis of "+ ) <> (singleQuoted.text.name) fSpec+ titles -> (text.concat.nub) titles --reduce doubles, for when multiple script files are included, this could cause titles to be mentioned several times. ) ) . (setAuthors (case metaValues "authors" fSpec of
src/lib/DatabaseDesign/Ampersand/Output/PandocAux.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE OverloadedStrings #-} module DatabaseDesign.Ampersand.Output.PandocAux ( writepandoc , labeledThing@@ -17,6 +18,7 @@ , texOnly_fun , texOnly_rel , commaEngPandoc, commaNLPandoc+ , commaEngPandoc', commaNLPandoc' ) where import DatabaseDesign.Ampersand.ADL1@@ -31,7 +33,6 @@ import System.Process (system) import System.Exit (ExitCode(ExitSuccess,ExitFailure)) import System.IO (hPutStrLn, stderr)-import Paths_ampersand import System.FilePath -- (combine,addExtension,replaceExtension) import System.Directory import System.Info (os)@@ -179,11 +180,11 @@ Ftextile -> "textile" readDefaultTemplate :: String -> IO(Maybe String) readDefaultTemplate s = - do { dataDir <- getDataDir- ; let fp = dataDir </> "outputTemplates" </> "default."++s+ do { let fp = ampersandDataDir flags </> ".." </> "outputTemplates" </> "default."++s ; exists <- doesFileExist fp ; (if exists - then do contents <- readFile fp+ then do verboseLn flags $ "Using Template: "++fp+ contents <- readFile fp return $ Just contents else do verboseLn flags $ "Template file does not exist: "++fp verboseLn flags "...trying without template...(but you might want to reinstall ampersand...)" @@ -400,6 +401,7 @@ showExpr (EDif (l,r)) = showExpr l++texOnly_bx ++showExpr r showExpr (ELrs (l,r)) = showExpr l++texOnly_lRes++showExpr r showExpr (ERrs (l,r)) = showExpr l++texOnly_rRes++showExpr r+ showExpr (EDia (l,r)) = showExpr l++texOnly_dia++showExpr r showExpr (ECps (EEps i sgn,r)) | i==source sgn||i==target sgn = showExpr r | otherwise = showExpr (ECps (EDcI i,r)) showExpr (ECps (l,EEps i sgn)) | i==source sgn||i==target sgn = showExpr l@@ -601,7 +603,13 @@ -- by putting the ref after the first word of the definition, it aligns nicely with the definition insertAfterFirstWord s wordsStr = let (fstWord, rest) = break (==' ') wordsStr in fstWord ++ s ++ rest- +commaEngPandoc' :: Inlines -> [Inlines] -> Inlines+commaEngPandoc' s [a,b,c]= a <> ", " <> b <> ", " <> s <> space <> c+commaEngPandoc' s [a,b] = a <> space <> s <> space <> b+commaEngPandoc' _ [a] = a+commaEngPandoc' s (a:as) = a <> ", " <> commaEngPandoc' s as+commaEngPandoc' _ [] = mempty+ commaEngPandoc :: Inline -> [Inline] -> [Inline] commaEngPandoc s [a,b,c]= [a,Str ", ",b,Str ", ",s, Str " ", c] commaEngPandoc s [a,b] = [a,Str " ",s, Str " ", b]@@ -609,6 +617,11 @@ commaEngPandoc s (a:as) = [a, Str ", "]++commaEngPandoc s as commaEngPandoc _ [] = [] +commaNLPandoc' :: Inlines -> [Inlines] -> Inlines+commaNLPandoc' s [a,b] = a <> space <> s <> space <> b+commaNLPandoc' _ [a] = a+commaNLPandoc' s (a:as) = a <> ", " <> commaNLPandoc' s as+commaNLPandoc' _ [] = mempty commaNLPandoc :: Inline -> [Inline] -> [Inline] commaNLPandoc s [a,b] = [a,Str " ",s, Str " ", b] commaNLPandoc _ [a] = [a]@@ -663,6 +676,9 @@ texOnly_rRes :: String texOnly_rRes = " \\backslash "++texOnly_dia :: String+texOnly_dia = " \\Diamond " texOnly_flip :: String texOnly_flip = "\\smallsmile "
src/lib/DatabaseDesign/Ampersand/Output/PredLogic.hs view
@@ -11,7 +11,6 @@ import DatabaseDesign.Ampersand.Misc import DatabaseDesign.Ampersand.Fspec.ShowADL import Data.Char (toLower) - import DatabaseDesign.Ampersand.Fspec.ToFspec.NormalForms (exprUni2list, exprIsc2list, exprCps2list, exprRad2list) import DatabaseDesign.Ampersand.Output.PandocAux (latexEscShw,texOnly_Id) fatal :: Int -> String -> a @@ -230,11 +229,9 @@ , decprM = "" , decprR = "" , decMean = fatal 223 "Do not refer to decMean of this dummy relation" - , decConceptDef = Nothing , decfpos = OriginUnknown , deciss = fatal 226 "Do not refer to deciss of this dummy relation" , decusr = False - , decISA = False , decpat = fatal 228 "Do not refer to decpat of this dummy relation" , decplug = fatal 229 "Do not refer to decplug of this dummy relation" } @@ -271,6 +268,9 @@ f exclVars (ERrs (l,r)) (a,b) = Forall [c] (Implies (f eVars l (c,a)) (f eVars r (c,b))) where [c] = mkVar exclVars [source l] eVars = exclVars++[c] + f exclVars (EDia (l,r)) (a,b) = Forall [c] (Equiv (f eVars r (b,c)) (f eVars l (a,c))) + where [c] = mkVar exclVars [target l] + eVars = exclVars++[c] f exclVars e@ECps{} (a,b) = fECps exclVars e (a,b) -- special treatment, see below f exclVars e@ERad{} (a,b) = fERad exclVars e (a,b) -- special treatment, see below f _ (EPrd (l,r)) (a,b) = Conj [Dom l a, Cod r b] @@ -296,6 +296,7 @@ f _ (EMp1 atom _) _ = Atom atom f _ (EDcI _) ((a,_),(b,tv)) = R (Funs a []) (Isn tv) (Funs b []) f _ (EDcV _) _ = Atom "True" + f _ e _ = fatal 298 ("Non-exhaustive pattern in subexpression "++showADL e++" of assemble (<"++showADL expr++">)") -- fECps treats the case of a composition. It works as follows: -- An expression, e.g. r;s;t , is translated to Exists (zip ivs ics) (Conj (frels s t)), @@ -329,7 +330,7 @@ (Left _, Left _ ) -> [] (Left atom, Right _ ) -> [ Left atom ] (Right _ , Left atom) -> [ Left atom ] - (Right trg, Right src) -> [ Right trg ] -- SJ 20131117, was: (if trg==src then [ Right trg ] else [ Right (trg `meet` src) ]) + (Right trg, Right _ ) -> [ Right trg ] -- SJ 20131117, was: (if trg==src then [ Right trg ] else [ Right (trg `meet` src) ]) -- This code assumes no ISA's in the A-structure. This works due to the introduction of EEps expressions. | (v',w)<-zip [ case l ("",src) ("",trg) of atom@Atom{} -> Left atom @@ -384,7 +385,7 @@ (Left _, Left _ ) -> [] (Left atom, Right _ ) -> [ Left atom ] (Right _ , Left atom) -> [ Left atom ] - (Right trg, Right src) -> [ Right trg ] -- SJ 20131117, was: (if trg==src then [ Right trg ] else [ Right (trg `meet` src) ]) + (Right trg, Right _ ) -> [ Right trg ] -- SJ 20131117, was: (if trg==src then [ Right trg ] else [ Right (trg `meet` src) ]) -- This code assumes no ISA's in the A-structure. This works due to the introduction of EEps expressions. | (v',w)<-zip [ case l ("",src) ("",trg) of atom@Atom{} -> Left atom @@ -399,8 +400,8 @@ relFun :: [Var] -> [Expression] -> Expression -> [Expression] -> Var->Var->PredLogic relFun exclVars lhs e rhs = case e of - EDcD dcl -> \sv tv->R (Funs (fst sv) [r | t'<- lhs, r<-declsUsedIn t']) dcl (Funs (fst tv) [r | t'<-reverse rhs, r<-declsUsedIn t']) - EFlp (EDcD dcl) -> \sv tv->R (Funs (fst tv) [r | t'<-reverse rhs, r<-declsUsedIn t']) dcl (Funs (fst sv) [r | t'<- lhs, r<-declsUsedIn t']) + EDcD dcl -> \sv tv->R (Funs (fst sv) [r | t'<- lhs, r<-relsMentionedIn t']) dcl (Funs (fst tv) [r | t'<-reverse rhs, r<-relsMentionedIn t']) + EFlp (EDcD dcl) -> \sv tv->R (Funs (fst tv) [r | t'<-reverse rhs, r<-relsMentionedIn t']) dcl (Funs (fst sv) [r | t'<- lhs, r<-relsMentionedIn t']) EMp1 atom _ -> \_ _->Atom atom EFlp EMp1{} -> relFun exclVars lhs e rhs _ -> \sv tv->f (exclVars++[sv,tv]) e (sv,tv)
src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterConceptualAnalysis.hs view
@@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wall #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} module DatabaseDesign.Ampersand.Output.ToPandoc.ChapterConceptualAnalysis where import DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters @@ -13,56 +14,60 @@ fatal = fatalMsg "Output.ToPandoc.ChapterConceptualAnalysis" chpConceptualAnalysis :: Int -> Fspc -> Options -> (Blocks,[Picture]) -chpConceptualAnalysis lev fSpec flags = (chptHeader (fsLang fSpec) ConceptualAnalysis <> caIntro <> caBlocks, pictures) +chpConceptualAnalysis lev fSpec flags = ( + -- *** Header *** + chptHeader (fsLang fSpec) ConceptualAnalysis + <> -- *** Intro *** + caIntro + <> -- *** For all themes, a section containing the conceptual analysis for that theme *** + caBlocks, pictures) where caIntro :: Blocks caIntro - = fromList $ (case fsLang fSpec of - Dutch -> [Para - [ Str "Dit hoofdstuk beschrijft een formele taal, waarin functionele eisen ten behoeve van " - , Quoted SingleQuote [Str (name fSpec)] - , Str " kunnen worden besproken en uitgedrukt. " - , Str "De formalisering dient om een bouwbare specificatie te verkrijgen. " - , Str "Een derde met voldoende deskundigheid kan op basis van dit hoofdstuk toetsen of de gemaakte afspraken " - , Str "overeenkomen met de formele regels en definities. " - ]] - English -> [Para --- [ Str "This chapter provides an analysis of the principles described in chapter " --- --- , Str ". Each section in that chapter is analysed in terms of relations " --- , Str "and each principle is then translated in a rule. " - [ Str "This chapter defines the formal language, in which functional requirements of " - , Quoted SingleQuote [Str (name fSpec)] - , Str " can be analysed and expressed." - , Str "The purpose of this formalisation is to obtain a buildable specification. " - , Str "This chapter allows an independent professional with sufficient background to check whether the agreements made " - , Str "correspond to the formal rules and definitions. " - ]]) - ++ purposes2Blocks flags (purposesDefinedIn fSpec (fsLang fSpec) fSpec) -- This explains the purpose of this context. + = (case fsLang fSpec of + Dutch -> para + ( "Dit hoofdstuk beschrijft een formele taal, waarin functionele eisen ten behoeve van " + <> (singleQuoted.str.name) fSpec + <> " kunnen worden besproken en uitgedrukt. " + <> "De formalisering dient om een bouwbare specificatie te verkrijgen. " + <> "Een derde met voldoende deskundigheid kan op basis van dit hoofdstuk toetsen of de gemaakte afspraken " + <> "overeenkomen met de formele regels en definities. " + ) + English -> para + ( "This chapter defines the formal language, in which functional requirements of " + <> (singleQuoted.str.name) fSpec + <> " can be analysed and expressed." + <> "The purpose of this formalisation is to obtain a buildable specification. " + <> "This chapter allows an independent professional with sufficient background to check whether the agreements made " + <> "correspond to the formal rules and definitions. " + ) + )<> purposes2Blocks flags (purposesDefinedIn fSpec (fsLang fSpec) fSpec) -- This explains the purpose of this context. caBlocks = fromList $ concat(map caSection (patterns fSpec)) - pictures = map pict (patterns fSpec) + pictures = concatMap patPicts (patterns fSpec) ----------------------------------------------------- -- the Picture that represents this pattern's conceptual graph - pict :: Pattern -> Picture - pict pat = (makePicture flags fSpec Plain_CG pat) - {caption = case fsLang fSpec of - Dutch ->"Conceptdiagram van "++name pat - English ->"Concept diagram of "++name pat} + patPicts :: Pattern -> [Picture] + patPicts pat = pictOfPat pat : + (map pictOfRule (invariants pat `isc` udefrules pat)) + pictOfPat :: Pattern -> Picture + pictOfPat = makePicture flags fSpec . PTRelsUsedInPat + pictOfRule :: Rule -> Picture + pictOfRule = makePicture flags fSpec . PTSingleRule caSection :: Pattern -> [Block] caSection pat = -- new section to explain this pattern toList ( labeledThing flags (lev+1) (xLabel ConceptualAnalysis++"_"++name pat) (name pat)) -- The section starts with the reason why this pattern exists - ++ purposes2Blocks flags (purposesDefinedIn fSpec (fsLang fSpec) pat) + ++ toList (purposes2Blocks flags (purposesDefinedIn fSpec (fsLang fSpec) pat)) -- followed by a conceptual model for this pattern ++ ( case (genGraphics flags, fsLang fSpec) of (True,Dutch ) -> -- announce the conceptual diagram - [Para [Str "Figuur ", xrefReference (pict pat), Str " geeft een conceptueel diagram van dit pattern."] + [Para [Str "Figuur ", xrefReference (pictOfPat pat), Str " geeft een conceptueel diagram van dit pattern."] -- draw the conceptual diagram - ,Plain (xrefFigure1 (pict pat))] - (True,English) -> [Para [Str "Figure ", xrefReference (pict pat), Str " shows a conceptual diagram of this pattern."] - ,Plain (xrefFigure1 (pict pat))] + ,Plain ((toList . showImage flags) (pictOfPat pat))] + (True,English) -> [Para [Str "Figure ", xrefReference (pictOfPat pat), Str " shows a conceptual diagram of this pattern."] + ,Plain ((toList . showImage flags) (pictOfPat pat))] _ -> []) -- now provide the text of this pattern. ++ (case fsLang fSpec of @@ -70,13 +75,13 @@ ]++ toList (labeledThing flags (lev+2) (xLabel ConceptualAnalysis++"_relationsOf_"++name pat) "Gedeclareerde relaties") ++ - [Para [Str "Deze paragraaf geeft een opsomming van de gedeclareerde relaties met eigenschappen en een betekenis."]] + [Para [Str "Deze paragraaf geeft een opsomming van de gedeclareerde relaties met eigenschappen en betekenis."]] English -> [Para [Str "The definitions of concepts can be found in the glossary."] ]++ toList (labeledThing flags (lev+2) (xLabel ConceptualAnalysis++"_relationsOf_"++name pat) "Declared relations") ++ - [Para [Str "This section itemizes the declared relations with properties and a meaning."]]) - ++ [DefinitionList blocks | let blocks = map caRelation (declarations pat), not(null blocks)] + [Para [Str "This section itemizes the declared relations with properties and purpose."]]) + ++ [DefinitionList blocks | let blocks = map caRelation [d | d@Sgn{}<-relsDefdIn pat `uni` relsMentionedIn pat], not(null blocks)] ++ (case fsLang fSpec of Dutch -> toList (labeledThing flags (lev+2) (xLabel ConceptualAnalysis++"_rulesOf_"++name pat) "Formele regels") ++ @@ -88,13 +93,15 @@ caRelation :: Declaration -> ([Inline], [[Block]]) caRelation d - = let purp = purposes2Blocks flags [p | p<-purposesDefinedIn fSpec (fsLang fSpec) d] + = let purp = toList (purposes2Blocks flags [p | p<-purposesDefinedIn fSpec (fsLang fSpec) d]) in ([] ,[ -- First the reason why the relation exists, if any, with its properties as fundamental parts of its being.. ( if null purp - then [ Plain$[ Str ("De volgende "++nladjs d++" relatie is gedeclareerd ") | fsLang fSpec==Dutch] - ++ [ Str ("The following "++ukadjs d++" relation has been declared ") | fsLang fSpec==English] ] - else purp ) -- If there is a purpose, its text should introduce the declaration and the generator remains silent. + then [ Plain$[ Str ("De volgende "++nladjs d++" is gedefinieerd ") | fsLang fSpec==Dutch] + ++ [ Str ("The following "++ukadjs d++" has been defined ") | fsLang fSpec==English] ] + else purp++ + [ Plain$[ Str ("Voor dat doel is de volgende "++nladjs d++" gedefinieerd ") | fsLang fSpec==Dutch] + ++ [ Str ("For this purpose, the following "++ukadjs d++" has been defined ") | fsLang fSpec==English] ] ) -- Then the declaration of the relation with its properties and its intended meaning ++ pandocEqnArray [ ( texOnly_Id(name d) @@ -108,29 +115,36 @@ | null (meaning2Blocks (fsLang fSpec) d)] ++ meaning2Blocks (fsLang fSpec) d ]) - ukadjs d = commaEng "and" (map ukadj (multiplicities d)) - ukadj Uni = "univalent" - ukadj Inj = "injective" - ukadj Sur = "surjective" - ukadj Tot = "total" - ukadj Sym = "symmetric" - ukadj Asy = "antisymmetric" - ukadj Trn = "transitive" - ukadj Rfx = "reflexive" - ukadj Irf = "irreflexive" - nladjs d = commaNL "en" (map nladj (multiplicities d)) - nladj Uni = "univalente" - nladj Inj = "injectieve" - nladj Sur = "surjectieve" - nladj Tot = "totale" - nladj Sym = "symmetrische" - nladj Asy = "antisymmetrische" - nladj Trn = "transitieve" - nladj Rfx = "reflexieve" - nladj Irf = "irreflexieve" + ukadjs d = case [Uni,Tot]>-multiplicities d of + [] -> commaEng "and" (map ukadj (multiplicities d>-[Uni,Tot]))++" function" + _ -> commaEng "and" (map ukadj (multiplicities d))++" relation" + where + ukadj Uni = "univalent" + ukadj Inj = "injective" + ukadj Sur = "surjective" + ukadj Tot = "total" + ukadj Sym = "symmetric" + ukadj Asy = "antisymmetric" + ukadj Trn = "transitive" + ukadj Rfx = "reflexive" + ukadj Irf = "irreflexive" + nladjs d = case [Uni,Tot]>-multiplicities d of + [] -> commaNL "en" (map nladj (multiplicities d>-[Uni,Tot]))++" functie" + _ -> commaNL "en" (map nladj (multiplicities d))++" relatie" + where + nladj Uni = "univalente" + nladj Inj = "injectieve" + nladj Sur = "surjectieve" + nladj Tot = "totale" + nladj Sym = "symmetrische" + nladj Asy = "antisymmetrische" + nladj Trn = "transitieve" + nladj Rfx = "reflexieve" + nladj Irf = "irreflexieve" caRule :: Rule -> ([Inline], [[Block]]) caRule r - = let purp = purposes2Blocks flags (purposesDefinedIn fSpec (fsLang fSpec) r) + = let purp = toList (purposes2Blocks flags (purposesDefinedIn fSpec (fsLang fSpec) r)) + in ( [] , [ -- First the reason why the rule exists, if any.. purp @@ -139,24 +153,32 @@ else Str "Daarom is als afspraak gesteld in paragraaf " | fsLang fSpec==Dutch] ++ [if null purp then Str "The following requirement has been defined in section " else Str "Therefore the following requirement has been defined in section " | fsLang fSpec==English] - ++ [RawInline (DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters.Format "latex") "~" - ,RawInline (DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters.Format "latex") $ symReqRef r + ++ [RawInline (Format "latex") "~" + ,RawInline (Format "latex") $ symReqRef r ,Str " p." - ,RawInline (DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters.Format "latex") "~" - ,RawInline (DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters.Format "latex") $ symReqPageRef r + ,RawInline (Format "latex") "~" + ,RawInline (Format "latex") $ symReqPageRef r ,Str ": "]] ++ meaning2Blocks (fsLang fSpec) r -- then the formal rule ++ [Plain$[Str "Dit is geformaliseerd - gebruikmakend van relaties " | fsLang fSpec==Dutch] ++ [Str "This is formalized - using relations " | fsLang fSpec==English] - ++ intercalate [Str ", "] [[RawInline (DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters.Format "latex") $ symDefRef d] | d@Sgn{}<-declsUsedIn r] + ++ intercalate [Str ", "] [[RawInline (Format "latex") $ symDefRef d] | d@Sgn{}<-relsMentionedIn r] ++ [Str " - als " | fsLang fSpec==Dutch] ++ [Str " - as " | fsLang fSpec==English]] ++ (if showPredExpr flags then pandocEqnArrayOnelabel (symDefLabel r) ((showLatex.toPredLogic) r) else pandocEquation (showMath r++symDefLabel r) ) + -- followed by a conceptual model for this rule + ++ toList + ( case (genGraphics flags, fsLang fSpec) of + (True,Dutch ) -> + para ("Figuur " <> xRefReference flags (pictOfRule r) <> " geeft een conceptueel diagram van deze regel.") + <> plain (showImage flags (pictOfRule r)) + (True,English) -> + para ("Figure " <> xRefReference flags (pictOfRule r) <> " shows a conceptual diagram of this rule.") + <> plain (showImage flags (pictOfRule r)) + _ -> mempty) + ]) - - -
src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterDataAnalysis.hs view
@@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wall #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} module DatabaseDesign.Ampersand.Output.ToPandoc.ChapterDataAnalysis (chpDataAnalysis) where import DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters @@ -25,23 +26,23 @@ theBlocks = chptHeader (fsLang fSpec) DataAnalysis -- The header <> (case fsLang fSpec of - Dutch -> para ( text "Dit hoofdstuk bevat het resultaat van de gegevensanalyse. " - <> text "De opbouw is als volgt:" + Dutch -> para ( "Dit hoofdstuk bevat het resultaat van de gegevensanalyse. " + <> "De opbouw is als volgt:" ) <> para ( if summaryOnly - then text "We beginnen met " - else text "We beginnen met het classificatiemodel, gevolgd door " - <> text "een overzicht van alle relaties, die samen de basis vormen van de rest van deze analyse. " - <> text "tenslotte volgen achtereenvolgend het logische- en technische gegevensmodel." + then "We beginnen met " + else "We beginnen met het classificatiemodel, gevolgd door " + <> "een overzicht van alle relaties, die samen de basis vormen van de rest van deze analyse. " + <> "tenslotte volgen achtereenvolgend het logische- en technische gegevensmodel." ) - English -> para ( text "This chapter contains the result of the data analisys. " - <> text "It is structured as follows:" + English -> para ( "This chapter contains the result of the data analisys. " + <> "It is structured as follows:" ) <> para ( if summaryOnly - then text "We start with " - else text "We start with the classification model, followed by " - <> text "a list of all relations, that are the foundation of the rest of the analisys. " - <> text "Finally, the logical and technical data model are discussed." + then "We start with " + else "We start with the classification model, followed by " + <> "a list of all relations, that are the foundation of the rest of the analisys. " + <> "Finally, the logical and technical data model are discussed." ) ) <> if summaryOnly then mempty else classificationBlocks @@ -68,23 +69,26 @@ where theBlocks = header lev (case fsLang fSpec of - Dutch -> text "Classificaties" - English -> text "Classifications" + Dutch -> "Classificaties" + English -> "Classifications" ) <> content content = if null (classes classificationModel) - then para $ text "Er zijn geen classificaties gedefinieerd." + then para (case fsLang fSpec of + Dutch -> "Er zijn geen classificaties gedefinieerd." + English -> "No classifications have been defined" + ) else para (case fsLang fSpec of - Dutch -> text "Een aantal concepten zit in een classificatiestructuur. " + Dutch -> "Een aantal concepten zit in een classificatiestructuur. " <> (if canXRefer flags - then text "Deze is in figuur " <> xRefReference flags pict <> text "weergegeven." - else text "Deze is in onderstaand figuur weergegeven." + then "Deze is in figuur " <> xRefReference flags pict <> "weergegeven." + else "Deze is in onderstaand figuur weergegeven." ) - English -> text "A number of concepts is organized in a classification structure. " + English -> "A number of concepts is organized in a classification structure. " <> (if canXRefer flags - then text "This is shown in figure " <> xRefReference flags pict <> text "." - else text "This is shown in the figure below." + then "This is shown in figure " <> xRefReference flags pict <> "." + else "This is shown in the figure below." ) ) <> para (showImage flags pict) @@ -94,10 +98,8 @@ classificationModel = clAnalysis fSpec flags pict :: Picture - pict = (makePicture flags fSpec Gen_CG classificationModel) - {caption = case fsLang fSpec of - Dutch ->"Classificatie van "++name fSpec - English ->"Classification of "++name fSpec} + pict = makePicture flags fSpec PTClassDiagram + logicalDataModelSection :: Int -> Fspc -> Options -> (Blocks,[Picture]) @@ -138,10 +140,8 @@ <> mconcat (map detailsOfClass (sortBy (compare `on` name) (classes oocd))) pict :: Picture - pict = (makePicture flags fSpec Plain_CG oocd) - {caption = case fsLang fSpec of - Dutch -> "Logisch gegevensmodel van "++name fSpec - English -> "Logical data model of "++name fSpec} + pict = makePicture flags fSpec PTLogicalDM + oocd :: ClassDiag oocd = cdAnalysis fSpec flags @@ -201,58 +201,50 @@ Dutch -> para ( text "Ieder(e) " <> (emph.text.nm.assSrc) assoc <> let rel = (singleQuoted.text.assrhr) assoc - rel' = text "" + rel' = "" in (case assrhm assoc of - Mult MinZero MaxOne -> text " " <> rel <> text " maximaal één " - Mult MinZero MaxMany -> text " " <> rel <> text " geen tot meerdere " - Mult MinOne MaxOne -> text " moet " <> rel <> text " precies één " - Mult MinOne MaxMany -> text " moet " <> rel <> text " ten minste één " + Mult MinZero MaxOne -> " " <> rel <> " maximaal één " + Mult MinZero MaxMany -> " " <> rel <> " geen tot meerdere " + Mult MinOne MaxOne -> " moet " <> rel <> " precies één " + Mult MinOne MaxMany -> " moet " <> rel <> " ten minste één " ) <> (emph.text.nm.assTgt) assoc - <> text ". Over deze relatie geldt omgekeerd dat " - <> text "ieder(e) " + <> ". Over deze relatie geldt omgekeerd dat " + <> "ieder(e) " <> (emph.text.nm.assTgt) assoc <> (case asslhm assoc of - Mult MinZero MaxOne -> text " " <> rel' <> text " maximaal één " - Mult MinZero MaxMany -> text " " <> rel' <> text " geen tot meerdere " - Mult MinOne MaxOne -> text " moet " <> rel' <> text " precies één " - Mult MinOne MaxMany -> text " moet " <> rel' <> text " ten minste één " + Mult MinZero MaxOne -> " " <> rel' <> " maximaal één " + Mult MinZero MaxMany -> " " <> rel' <> " geen tot meerdere " + Mult MinOne MaxOne -> " moet " <> rel' <> " precies één " + Mult MinOne MaxMany -> " moet " <> rel' <> " ten minste één " ) <> (emph.text.nm.assSrc) assoc - <> text " kan hebben." + <> " kan hebben." ) - English -> para ( text "Every " + English -> para ( "Every " <> (emph.text.nm.assSrc) assoc <> let rel = (singleQuoted.text.assrhr) assoc - rel' = text "" + rel' = "" in (case assrhm assoc of - Mult MinZero MaxOne -> text " " <> rel <> text " at most one " - Mult MinZero MaxMany -> text " " <> rel <> text " zero or more " - Mult MinOne MaxOne -> text " must " <> rel <> text " exactly one " - Mult MinOne MaxMany -> text " must " <> rel <> text " at least one " + Mult MinZero MaxOne -> " " <> rel <> " at most one " + Mult MinZero MaxMany -> " " <> rel <> " zero or more " + Mult MinOne MaxOne -> " must " <> rel <> " exactly one " + Mult MinOne MaxMany -> " must " <> rel <> " at least one " ) <> (emph.text.nm.assTgt) assoc - <> text ". For the other way round, for this relation holds that " - <> text "each " + <> ". For the other way round, for this relation holds that " + <> "each " <> (emph.text.nm.assTgt) assoc <> (case asslhm assoc of - Mult MinZero MaxOne -> text " " <> rel' <> text " at most one " - Mult MinZero MaxMany -> text " " <> rel' <> text " zero or more " - Mult MinOne MaxOne -> text " must " <> rel' <> text " exactly one " - Mult MinOne MaxMany -> text " must " <> rel' <> text " at least one " + Mult MinZero MaxOne -> " " <> rel' <> " at most one " + Mult MinZero MaxMany -> " " <> rel' <> " zero or more " + Mult MinOne MaxOne -> " must " <> rel' <> " exactly one " + Mult MinOne MaxMany -> " must " <> rel' <> " at least one " ) <> (emph.text.nm.assSrc) assoc - <> text "." + <> "." ) - showDummy :: DatabaseDesign.Ampersand.Fspec.Graphic.ClassDiagram.Association -> Blocks - showDummy assoc = --(plain.text.show) assoc - (para.text) ("assSrc: "++(nm.assSrc) assoc) - <> (para.text) ("asslhm: "++(show.asslhm) assoc) - <> (para.text) ("asslhr: "++( asslhr) assoc) - <> (para.text) ("assTgt: "++(nm.assTgt) assoc) - <> (para.text) ("assrhm: "++(show.assrhm) assoc) - <> (para.text) ("assrhr: "++( assrhr) assoc) nm :: Identified a => Either a String -> String nm x = case x of @@ -264,19 +256,19 @@ where theBlocks = header lev (case fsLang fSpec of - Dutch -> text "Technisch datamodel" - English -> text "Technical datamodel" + Dutch -> "Technisch datamodel" + English -> "Technical datamodel" ) <> para (case fsLang fSpec of - Dutch -> (text "De afspraken zijn vertaald naar een technisch datamodel. " + Dutch -> ( "De afspraken zijn vertaald naar een technisch datamodel. " <> ( if canXRefer flags - then text "Dit model is in figuur " <> xRefReference flags pict <> text " weergegeven." - else text "Dit model is in onderstaand figuur weergegeven. " + then "Dit model is in figuur " <> xRefReference flags pict <> " weergegeven." + else "Dit model is in onderstaand figuur weergegeven. " ) ) - English -> (text "The functional requirements have been translated into a technical data model. " + English -> ( "The functional requirements have been translated into a technical data model. " <> ( if canXRefer flags - then text "This model is shown by figure " <> xRefReference flags pict <> text "." - else text "This model is shown by the figure below. " + then "This model is shown by figure " <> xRefReference flags pict <> "." + else "This model is shown by the figure below. " ) ) ) <> para (showImage flags pict) @@ -296,10 +288,10 @@ detailsOfplug :: PlugInfo -> Blocks detailsOfplug p = header 3 ( case (fsLang fSpec, p) of - (Dutch , InternalPlug{}) -> text "Tabel: " - (Dutch , ExternalPlug{}) -> text "Dataservice: " - (English, InternalPlug{}) -> text "Table: " - (English, ExternalPlug{}) -> text "Data service: " + (Dutch , InternalPlug{}) -> "Tabel: " + (Dutch , ExternalPlug{}) -> "Dataservice: " + (English, InternalPlug{}) -> "Table: " + (English, ExternalPlug{}) -> "Data service: " <> text (name p) ) <> case p of @@ -315,14 +307,14 @@ -> para (case fsLang fSpec of Dutch - -> text "Dit is een koppeltabel, die " + -> "Dit is een koppeltabel, die " <> primExpr2pandocMath (fsLang fSpec) (mLkp bin) - <> text " implementeert. De tabel bestaat uit de volgende kolommen:" + <> " implementeert. De tabel bestaat uit de volgende kolommen:" English - -> text "This is a link-table, implementing " + -> "This is a link-table, implementing " <> primExpr2pandocMath (fsLang fSpec) (mLkp bin) - <> text ". It contains the following columns:" + <> ". It contains the following columns:" ) <> showFields (plugFields bin) @@ -331,13 +323,13 @@ -> mempty ExternalPlug _ -> case fsLang fSpec of - Dutch -> para (text "De details van deze service zijn in dit document (nog) niet verder uitgewerkt.") - English -> para (text "The details of this dataservice are not available in this document.") + Dutch -> para "De details van deze service zijn in dit document (nog) niet verder uitgewerkt." + English -> para "The details of this dataservice are not available in this document." showFields :: [SqlField] -> Blocks showFields flds = bulletList (map showField flds) where - eRelIs = [c | EDcI c <- map fldexpr flds] showField fld = +--FIXME 20140525: Onderstaande code vervangen door afl te leiden van `flduse`. Daar zit deze info al in verwerkt! let isPrimaryKey = case fldexpr fld of e@EDcI{} -> e==fldexpr (head flds) -- The first field represents the most general concept _ -> False @@ -348,47 +340,42 @@ <> linebreak <> (if isPrimaryKey then case fsLang fSpec of - Dutch -> text ("Dit attribuut is de primaire sleutel. ") - English -> text ("This attribute is the primary key. ") + Dutch -> "Dit attribuut is de primaire sleutel. " + English -> "This attribute is the primary key. " else case mForeignKey of Just c -> case fsLang fSpec of - Dutch -> text ("Dit attribuut verwijst naar een voorkomen in de tabel ") - English -> text ("This attribute is a foreign key to ") + Dutch -> "Dit attribuut verwijst naar een voorkomen in de tabel " + English -> "This attribute is a foreign key to " <> (text.name) c Nothing -- (no foreign key...) -> --if isBool --then --else (case fsLang fSpec of - Dutch -> text ("Dit attribuut implementeert ") - English -> text ("This attribute implements ") + Dutch -> "Dit attribuut implementeert " + English -> "This attribute implements " <> primExpr2pandocMath (fsLang fSpec) (fldexpr fld) - <> text "." + <> "." ) ) <> linebreak <> (code.show.fldtype) fld - <> text ", " + <> ", " <> (case fsLang fSpec of Dutch - -> text (if fldnull fld then "Optioneel" else "Verplicht") - <>text (if flduniq fld then ", Uniek" else "") - <>text "." + -> (if fldnull fld then "Optioneel" else "Verplicht") + <> (if flduniq fld then ", Uniek" else "") + <> "." English - -> text (if fldnull fld then "Optional" else "Mandatory") - <>text (if flduniq fld then ", Unique" else "") - <>text "." + -> (if fldnull fld then "Optional" else "Mandatory") + <> (if flduniq fld then ", Unique" else "") + <> "." ) ) pict :: Picture - pict = (makePicture flags fSpec Plain_CG oocd) - {caption = case fsLang fSpec of - Dutch -> "Technisch gegevensmodel van "++name fSpec - English -> "Technical data model of "++name fSpec} - oocd :: ClassDiag - oocd = tdAnalysis fSpec flags - + pict = makePicture flags fSpec PTTechnicalDM + daBasicsSection :: Int -> Fspc -> Options -> Blocks @@ -397,46 +384,18 @@ where theBlocks = header lev (case fsLang fSpec of - Dutch -> text "Basiszinnen" - English -> text "Fact types" + Dutch -> "Basiszinnen" + English -> "Fact types" ) <> case fsLang fSpec of - Dutch -> para (text "In deze paragraaf worden de basiszinnen opgesomd, die een rol spelen bij het ontwerp van de gegevensstructuur. " - <>text "Per basiszin wordt de naam en het bron- en doelconcept gegeven, alsook de eigenschappen van deze relatie." + Dutch -> para ( "In deze paragraaf worden de basiszinnen opgesomd, die een rol spelen bij het ontwerp van de gegevensstructuur. " + <> "Per basiszin wordt de naam en het bron- en doelconcept gegeven, alsook de eigenschappen van deze relatie." ) - English -> para (text "This section enumerates the fact types, that have been used in the design of the datastructure. " - <>text "For each fact type its name, the source and target concept and the properties are documented." + English -> para ( "This section enumerates the fact types, that have been used in the design of the datastructure. " + <> "For each fact type its name, the source and target concept and the properties are documented." ) - <> definitionList (map toDef declsInRelevantThemes) --- HJO, 20130526: onderstaande tabel vervangen door bovenstaande lijst, ivm leesbaarheid. --- <> table --- (-- caption -- --- case fsLang fSpec of --- Dutch -> text "Deze tabel bevat de basiszinnen, die gebruikt zijn als basis voor de gegevensanalyse." --- English -> text "This table lists the fact types, that have been used in assembling the data models." --- ) --- [(AlignLeft,0.4) , (AlignCenter, 0.4) , (AlignCenter, 0.2)] --- ( case fsLang fSpec of --- Dutch -> [plain (text "Relatie") , plain (text "Beschrijving"), plain (text "Eigenschappen")] --- English -> [plain (text "Relation"), plain (text "Description") , plain (text "Properties") ] --- ) --- (map toRow declsInRelevantThemes) + <> definitionList (map toDef (relsInThemes fSpec)) where - declsInRelevantThemes = - -- a declaration is considered relevant iff it is declared or used in one of the relevant themes. - [d | d<-declarations fSpec - , decusr d - , ( decpat d `elem` themes fSpec - || d `elem` declsUsedIn [p | p<- patterns fSpec , name p `elem` themes fSpec] - || d `elem` declsUsedIn [p | p<-map fpProc (vprocesses fSpec), name p `elem` themes fSpec] - ) - ] - toRow :: Declaration -> [Blocks] - toRow d - = [ (plain.math.showMath) d - , fromList (meaning2Blocks (fsLang fSpec) d) - , plain ( inlineIntercalate (str ", ") [ text (showADL m) | m <-multiplicities d]) - ] toDef :: Declaration -> (Inlines, [Blocks]) toDef d = ( (math.showMath) d @@ -457,7 +416,7 @@ ) --- The properties of various declarations are documented in different tables. +-- The properties of various relations are documented in different tables. -- First, we document the heterogeneous properties of all relations -- Then, the endo-poperties are given, and finally -- the signals are documented. @@ -558,7 +517,7 @@ | length hMults>0 ] where hMults :: [Declaration] - hMults = [decl | decl@Sgn{}<- declsUsedIn fSpec, isEndo decl + hMults = [decl | decl@Sgn{}<- relsUsedIn fSpec, isEndo decl , null (themes fSpec) || decpat decl `elem` themes fSpec] identityDocumentation = case (identities fSpec, fsLang fSpec) of @@ -630,21 +589,21 @@ , f<-filter isNeg fus , s<-strands f , e<-[head s, flp (last s)] - , r<-declsUsedIn e + , r<-relsUsedIn e ] ts = nub [r | EUni fus<-clauses , isIdent (EIsc [notCpl f | f<-fus, isNeg f] sgn) , f<-filter isPos fus , s<-strands f , e<-[head s, flp (last s)] - , r<-declsUsedIn e + , r<-relsUsedIn e ] strands (ECps fs) = [fs] strands _ = [] -- <-- we could maybe do better than this... - tots = [d | t<-ts, inline t, d<-map makeDeclaration (declsUsedIn t)] - unis = [d | t<-is, inline t, d<-map makeDeclaration (declsUsedIn t)] - surs = [d | t<-ts, not (inline t), d<-map makeDeclaration (declsUsedIn t)] - injs = [d | t<-is, not (inline t), d<-map makeDeclaration (declsUsedIn t)] + tots = [d | t<-ts, inline t, d<-map makeDeclaration (relsUsedIn t)] + unis = [d | t<-is, inline t, d<-map makeDeclaration (relsUsedIn t)] + surs = [d | t<-ts, not (inline t), d<-map makeDeclaration (relsUsedIn t)] + injs = [d | t<-is, not (inline t), d<-map makeDeclaration (relsUsedIn t)] -} -- daPlugs describes data sets. @@ -665,7 +624,7 @@ content = daAttributes p ++ plugRules ++ plugSignals ++ plugIdentities ++ iRules plugRules = case fsLang fSpec of - English -> case [r | r<-invariants fSpec, null (declsUsedIn r >- declsUsedIn p)] of + English -> case [r | r<-invariants fSpec, null [d | d@Sgn{} <- relsMentionedIn r, d `notElem` relsUsedIn p]] of [] -> [] [r] -> [ Para [ Str "Within this data set, the following integrity rule shall be true at all times. " ]]++ if showPredExpr flags @@ -676,7 +635,7 @@ then BulletList [(pandocEqnArrayOnelabel (symDefLabel r) . showLatex . toPredLogic) r | r<-rs ] else BulletList [ [Para [Math DisplayMath $ showMath r]] | r<-rs ] ] - Dutch -> case [r | r<-invariants fSpec, null (declsUsedIn r >- declsUsedIn p)] of + Dutch -> case [r | r<-invariants fSpec, null [d | d@Sgn{} <- relsMentionedIn r, d `notElem` relsUsedIn p]] of [] -> [] [r] -> [ Para [ Str "Binnen deze gegevensverzameling dient de volgende integriteitsregel te allen tijde waar te zijn. " ]]++ if showPredExpr flags @@ -689,7 +648,7 @@ ] plugIdentities = case fsLang fSpec of - English -> case [k | k<-identityRules fSpec, null (declsUsedIn k >- declsUsedIn p)] of + English -> case [k | k<-identityRules fSpec, null [d | d@Sgn{} <- relsMentionedIn k, d `notElem` relsUsedIn p]] of [] -> [] [s] -> [ Para [ Str "This data set contains one key. " ]]++ if showPredExpr flags @@ -701,7 +660,7 @@ else BulletList [ [Para [Math DisplayMath $ showMath s]] | s<-ss ] ] - Dutch -> case [k | k<-identityRules fSpec, null (declsUsedIn k >- declsUsedIn p)] of + Dutch -> case [k | k<-identityRules fSpec, null [d | d@Sgn{} <- relsMentionedIn k, d `notElem` relsUsedIn p]] of [] -> [] [s] -> [ Para [ Str ("Deze gegevensverzameling genereert één key. ") ]]++ if showPredExpr flags @@ -713,8 +672,8 @@ else BulletList [ [Para [Math DisplayMath $ showMath s]] | s<-ss ] ] plugSignals - = case (fsLang fSpec, [r | r<-vrules fSpec, isSignal r , null (declsUsedIn r >- declsUsedIn p)]) of - -- English -> case [r | r<-vrules fSpec, isSignal r , null (declsUsedIn r >- declsUsedIn p)] of + = case (fsLang fSpec, [r | r<-vrules fSpec, isSignal r , null [d | d@Sgn{} <- relsMentionedIn r, d `notElem` relsUsedIn p]]) of + -- English -> case [r | r<-vrules fSpec, isSignal r , null [d | d@Sgn{} <- relsMentionedIn r, d `notElem` relsUsedIn p]] of (_ , []) -> [] (English, [s]) -> [ Para [ Str "This data set generates one process rule. " ]]++ if showPredExpr flags
src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterDiagnosis.hs view
@@ -13,13 +13,14 @@ chpDiagnosis :: Fspc -> Options -> (Blocks,[Picture]) chpDiagnosis fSpec flags - = ( fromList $ - header ++ -- the chapter header + = ( (chptHeader (fsLang fSpec) Diagnosis) <> + fromList + ( diagIntro ++ -- an introductory text roleomissions ++ -- tells which role-rule, role-interface, and role-relation assignments are missing roleRuleTable ++ -- gives an overview of rule-rule assignments - missingConceptDefs ++ -- tells which concept definitions are missing - missingRels ++ -- tells which relation declarations are missing + missingConceptDefs ++ -- tells which concept definitions have been declared without a purpose + missingRels ++ -- tells which relations have been declared without a purpose unusedConceptDefs ++ -- tells which concept definitions are not used in any relation relsNotUsed ++ -- tells which relations are not used in any rule missingRules ++ -- tells which rule definitions are missing @@ -29,10 +30,9 @@ -- TODO: Needs rework. populationReport++ -- says which relations are populated. wipReport++ -- sums up the work items (i.e. the violations of process rules) toList violationReport -- sums up the violations caused by the population of this script. + ) , pics ) where - header :: [Block] - header = toList (chptHeader (fsLang fSpec) Diagnosis) diagIntro :: [Block] diagIntro = case fsLang fSpec of @@ -88,14 +88,14 @@ maintained -- (r,rul) `elem` maintained means that r can maintain rul without restrictions. = [ (role,rul) | (role,rul)<-fRoleRuls fSpec - , and (map (mayEdit role) (declsUsedIn rul)) + , and (map (mayEdit role) (relsUsedIn rul)) ] mayEdit :: String -> Declaration -> Bool mayEdit role decl = decl `elem` ((snd.unzip) (filter (\x -> role == fst x) (fRoleRels fSpec))) dead -- (r,rul) `elem` dead means that r cannot maintain rul without restrictions. = [ (role,rul) | (role,rul)<-fRoleRuls fSpec - , (not.or) (map (mayEdit role) (declsUsedIn rul)) + , (not.or) (map (mayEdit role) (relsUsedIn rul)) ] roleomissions :: [Block] @@ -149,7 +149,7 @@ , null (purposesDefinedIn fSpec (fsLang fSpec) cd) ]++ [c | c <-ccs, null (concDefs fSpec c)] - ccs = concs [ d | d<-declarations fSpec, null (themes fSpec)||decpat d `elem` themes fSpec] -- restrict if the documentation is partial. + ccs = concs [ d | d<-relsDefdIn fSpec, null (themes fSpec)||decpat d `elem` themes fSpec] -- restrict if the documentation is partial. unusedConceptDefs :: [Block] unusedConceptDefs = case (fsLang fSpec, unused) of @@ -180,7 +180,7 @@ = case (fsLang fSpec, missing) of (Dutch,[]) -> [Para [Str "Alle relaties in dit document zijn voorzien van een reden van bestaan (purpose)."] - | (not.null.declsUsedIn.udefrules) fSpec] + | (not.null.relsMentionedIn.udefrules) fSpec] (Dutch,[r]) -> [Para [ Str "De reden waarom relatie ", r , Str " bestaat wordt niet uitgelegd." @@ -191,7 +191,7 @@ ] ] (English,[]) -> [Para [Str "All relations in this document have been provided with a purpose."] - | (not.null.declsUsedIn.udefrules) fSpec] + | (not.null.relsMentionedIn.udefrules) fSpec] (English,[r]) -> [Para [ Str "The purpose of relation ", r , Str " remains unexplained." @@ -201,11 +201,7 @@ [ Str " is not documented." ] ] where missing = [(Math InlineMath . showMath) (EDcD d) - | d@Sgn{} <-if null (themes fSpec) - then declsUsedIn fSpec - else declsUsedIn [pat | pat<-patterns fSpec, name pat `elem` themes fSpec]++ - declsUsedIn [fpProc prc | prc<-vprocesses fSpec, name prc `elem` themes fSpec] - , not (isIdent d) + | d@Sgn{} <- relsInThemes fSpec , null (purposesDefinedIn fSpec (fsLang fSpec) d) ] @@ -215,7 +211,7 @@ = ( ( case (fsLang fSpec, notUsed) of (Dutch,[]) -> [Para [Str "Alle relaties in dit document worden in één of meer regels gebruikt."] - | (not.null.declsUsedIn.udefrules) fSpec] + | (not.null.relsMentionedIn.udefrules) fSpec] (Dutch,[r]) -> [Para [ Str "De relatie ", r , Str " wordt in geen enkele regel gebruikt. " @@ -226,7 +222,7 @@ ] ] (English,[]) -> [Para [Str "All relations in this document are being used in one or more rules."] - | (not.null.declsUsedIn.udefrules) fSpec] + | (not.null.relsMentionedIn.udefrules) fSpec] (English,[r]) -> [Para [ Str "Relation ", r , Str " is not being used in any rule. " @@ -240,13 +236,13 @@ , xrefReference pict , Str " geeft een conceptueel diagram met alle relaties." ] - , Plain (xrefFigure1 pict) + , Plain ((toList . showImage flags) pict) ] (English,[pict]) -> [ Para [ Str "Figure " , xrefReference pict , Str " shows a conceptual diagram with all relations." ] - , Plain (xrefFigure1 pict) + , Plain ((toList . showImage flags) pict) ] (Dutch,picts) -> concat [ Para [ Str "Figuur " @@ -255,7 +251,7 @@ , Quoted SingleQuote [Str (name pat)] , Str "." ] - : [Plain (xrefFigure1 pict)] + : [Plain ((toList . showImage flags) pict)] | (pict,pat)<-zip picts pats ] (English,picts) -> concat [ Para [ Str "Figure " @@ -264,20 +260,19 @@ , Quoted SingleQuote [Str (name pat)] , Str "." ] - : [Plain (xrefFigure1 pict)] + : [Plain ((toList . showImage flags) pict)] | (pict,pat)<-zip picts pats ] ) , pictsWithUnusedRels -- draw the conceptual diagram ) where notUsed = nub [(Math InlineMath . showMath) (EDcD d) - | d@Sgn{} <- declarations fSpec - , null (themes fSpec) || decpat d `elem` themes fSpec -- restrict if the documentation is partial. + | d@Sgn{} <- relsInThemes fSpec -- only signal relations that are used or defined in the selected themes , decusr d - , d `notElem` (declsUsedIn . udefrules) fSpec + , d `notElem` (relsMentionedIn . udefrules) fSpec ] pats = [ pat | pat<-patterns fSpec , null (themes fSpec) || name pat `elem` themes fSpec -- restrict if the documentation is partial. - , (not.null) (declarations pat>-declsUsedIn pat) ] - pictsWithUnusedRels = [makePicture flags fSpec Rel_CG pat | pat<-pats ] + , (not.null) (relsDefdIn pat>-relsUsedIn pat) ] + pictsWithUnusedRels = [makePicture flags fSpec (PTDeclaredInPat pat) | pat<-pats ] missingRules :: [Block] missingRules @@ -386,12 +381,12 @@ then udefrules fSpec else concat [udefrules pat | pat<-patterns fSpec, name pat `elem` themes fSpec]++ concat [udefrules (fpProc prc) | prc<-vprocesses fSpec, name prc `elem` themes fSpec] - upC (Str str:strs) = Str (upCap str):strs - upC str = str + upC (Str str':strs) = Str (upCap str'):strs + upC str' = str' fn r = locnm (origin r) ln r = locln (origin r) strconcat :: [Inline] -> Inline - strconcat strs = (Str . concat) [ str | Str str<-strs] + strconcat strs = (Str . concat) [ str' | Str str'<-strs] ruleRelationRefTable = [ Para [ Str descriptionStr ] @@ -430,10 +425,10 @@ , "Theme", "Relations", "With reference", "Rules", "Entire context") locnm (FileLoc(FilePos(filename,_,_))) = filename - locnm (DBLoc str) = str + locnm (DBLoc str') = str' locnm _ = "NO FILENAME" locln (FileLoc(FilePos(_,Pos l _,_))) = show l - locln (DBLoc str) = str + locln (DBLoc str') = str' locln p = fatal 875 ("funny position "++show p++" in function 'locln'") -- TODO: give richer feedback... @@ -518,7 +513,7 @@ -- populationReport :: [Block] -- populationReport --- = [ Para (case (fsLang fSpec, ps, declarations fSpec) of +-- = [ Para (case (fsLang fSpec, ps, relsDefdIn fSpec) of -- (Dutch, [], [] ) -> [ Str "Dit script is leeg. " ] -- (English,[], [] ) -> [ Str "This script is empty. " ] -- (Dutch, [], _ ) -> [ Str "Geen relatie bevat enige populatie. " ] @@ -557,7 +552,7 @@ -- , null (themes fSpec) || (decpat.popdcl) p `elem` themes fSpec -- restrict if the documentation is partial. -- , (not.null.popps) p] -- cs = [c | c@C{}<-ccs, (not.null.atomsOf) c] --- ccs = concs [ d | d<-declarations fSpec, null (themes fSpec)||decpat d `elem` themes fSpec] -- restrict if the documentation is partial. +-- ccs = concs [ d | d<-relsDefdIn fSpec, null (themes fSpec)||decpat d `elem` themes fSpec] -- restrict if the documentation is partial. wipReport :: [Block] wipReport @@ -594,7 +589,7 @@ Dutch -> Str "Regel" English -> Str "Rule"): [Space,quoterule r,Space]++ - if xrefSupported flags then [ Str "(", RawInline (DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters.Format "latex") $ symReqRef r, Str ") "] else []++ + if xrefSupported flags then [ Str "(", RawInline (Format "latex") $ symReqRef r, Str ") "] else []++ (case fsLang fSpec of Dutch -> [ Str "luidt: " ] English -> [ Str "says: " ] @@ -628,12 +623,13 @@ English -> Str ("on "++show (origin r)) Dutch -> Str ("op "++show (origin r)) else Quoted SingleQuote [Str (name r)] - oneviol r [(a,b)] - = if source r==target r && a==b - then [Quoted SingleQuote [Str (name (source r)),Space,Str a]] - else [Str "(",Str (name (source r)),Space,Str a,Str ", ",Str (name (target r)),Space,Str b,Str ")"] + oneviol :: Rule -> Pairs -> [Inline] + oneviol r [p] + = if source r==target r && srcPaire p==trgPaire p + then [Quoted SingleQuote [Str (name (source r)),Space,Str (srcPaire p)]] + else [Str "(",Str (name (source r)),Space,Str (srcPaire p),Str ", ",Str (name (target r)),Space,Str (trgPaire p),Str ")"] oneviol _ _ = fatal 810 "oneviol must have a singleton list as argument." - popwork :: [[(Rule,[(String, String)])]]; + popwork :: [[(Rule,Pairs)]]; popwork = eqCl (locnm.origin.fst) [(r,ps) | (r,ps) <- allViolations fSpec, isSignal r, partofThemes r] partofThemes r = or [ null (themes fSpec) @@ -653,7 +649,7 @@ (English, True ) -> text "Tasks yet to be performed by " <> text (commaEng "or" (nub [rol | (rol, rul)<-fRoleRuls fSpec, r==rul])) showRow :: Paire -> [Blocks] - showRow p = [(para.text.fst) p,(para.text.snd) p] + showRow p = [(para.text.srcPaire) p,(para.text.trgPaire) p] in para ( case fsLang fSpec of Dutch -> text "Regel " English -> text "Rule " @@ -799,21 +795,22 @@ -- else concat [identityRules pat | pat<-patterns fSpec, name pat `elem` themes fSpec]++ -- concat [identityRules (fpProc prc) | prc<-vprocesses fSpec, name prc `elem` themes fSpec] + violtable :: Rule -> Pairs -> Block violtable r ps = if hasantecedent r && isIdent (antecedent r) -- note: treat 'isIdent (consequent r) as binary table. then Table [] [AlignLeft] [0.0] [[Plain [(Str . name . source) r]]] - [ [[Plain [Str a]]] - | (a,_)<-take 10 ps + [ [[Plain [Str (srcPaire p)]]] + | p <-take 10 ps ] else Table [] [AlignLeft,AlignLeft] [0.0,0.0] [[Plain [(Str . name . source) r]], [Plain [(Str . name . target) r] ]] - [ [[Plain [Str a]], [Plain [Str b]]] - | (a,b)<-take 10 ps + [ [[Plain [Str (srcPaire p)]], [Plain [Str (trgPaire p)]]] + | p <-take 10 ps ]
src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterECArules.hs view
@@ -1,37 +1,56 @@ {-# OPTIONS_GHC -Wall #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} module DatabaseDesign.Ampersand.Output.ToPandoc.ChapterECArules where import DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters +import DatabaseDesign.Ampersand.Fspec.ToFspec.NormalForms (proofPA) import DatabaseDesign.Ampersand.ADL1 chpECArules :: Fspc -> Options -> Blocks -chpECArules fSpec _ +chpECArules fSpec flags = + if genEcaDoc flags + then chpECArules' fSpec + else mempty + +chpECArules' :: Fspc -> Blocks +chpECArules' fSpec = chptHeader (fsLang fSpec) EcaRules <> ecaIntro <> ifcECA where ecaIntro :: Blocks ecaIntro - = fromList - [ Plain $ case fsLang fSpec of - Dutch -> [Str "Dit hoofdstuk bevat de ECA regels." ] - English -> [Str "This chapter lists the ECA rules." ] - ] + = case fsLang fSpec of + Dutch -> plain "Dit hoofdstuk bevat de ECA regels." + English -> plain "This chapter lists the ECA rules." + ifcECA :: Blocks ifcECA - = fromList $ - case fsLang fSpec of - Dutch -> Para [ Str "ECA rules:",LineBreak, Str " ",Str "tijdelijk ongedocumenteerd" ] : - [ BlockQuote (toList (codeBlock - ( showECA fSpec "\n " eca --- Dit inschakelen ++[LineBreak, Str "------ Derivation ----->"] --- voor het bewijs ++showProof (showECA fSpec [LineBreak, Str "> "]) (proofPA (ecaAction eca)) --- ++[LineBreak, Str "<------End Derivation --"] - ) ) ) - | eca<-vEcas fSpec, not (isNop (ecaAction eca))] - English -> Para [ Str "ECA rules:",LineBreak, Str " ",Str "temporarily not documented" ] : - [ BlockQuote (toList (codeBlock - ( showECA fSpec "\n" eca ))) - | eca<-vEcas fSpec, not (isNop (ecaAction eca))] - + = case fsLang fSpec of + Dutch -> para ( "ECA regels:" <> linebreak + <> " tijdelijk ongedocumenteerd") + <> mconcat + [ (blockQuote . codeBlock . ("\n "++) . showECA "\n ") eca + <> para ( linebreak <> + "------ Afleiding ----->" -- Dit in- en uitschakelbaar maken + ) + <> (showProof (codeBlock . ("\n "++) . showECA "\n ") . proofPA . ecaAction) eca -- voor het bewijs + <> para ( linebreak <> + "<------Einde afleiding --" -- Dit in- en uitschakelbaar maken + ) + | eca<-vEcas fSpec, (not.isNop.ecaAction) eca + ] + English -> para ( "ECA rules:" <> linebreak + <> " temporarily not documented") + <> mconcat + [ (blockQuote . codeBlock . ("\n "++) . showECA "\n ") eca + <> para ( linebreak <> + "------ Derivation ----->" -- Dit in- en uitschakelbaar maken + ) + <> (showProof (codeBlock . ("\n "++) . showECA "\n ") . proofPA . ecaAction) eca -- voor het bewijs + <> para ( linebreak <> + "<------End Derivation --" -- Dit in- en uitschakelbaar maken + ) + | eca<-vEcas fSpec, (not.isNop.ecaAction) eca + ]
src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterGlossary.hs view
@@ -12,7 +12,7 @@ chpGlossary _ fSpec flags = fromList $ if fspecFormat flags==FLatex - then [ Para [RawInline (DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters.Format "latex") "\\printglossaries"] ] + then [ Para [RawInline (Format "latex") "\\printglossaries"] ] else [ Table [] [AlignLeft,AlignLeft,AlignLeft] [0.0,0.0,0.0] ( case fsLang fSpec of Dutch ->
src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterInterfaces.hs view
@@ -9,7 +9,6 @@ import DatabaseDesign.Ampersand.ADL1 import Data.List import DatabaseDesign.Ampersand.Fspec.Fspec -import DatabaseDesign.Ampersand.Fspec.Switchboard (switchboardAct) import DatabaseDesign.Ampersand.Output.PandocAux chpInterfacesPics :: Fspc -> Options -> [Picture] @@ -22,20 +21,20 @@ interfaceChap :: Activity -> Blocks interfaceChap act -- TODO: This should be one chapter for all interfaces. - = ( fromList $ - header act ++ ifcIntro act - ++ (if genGraphics flags then txtKnowledgeGraph act else []) + = (labeledThing flags lev ("chpIfc"++name act) (name act)) <> + ifcIntro act <> + fromList + ( + + (if genGraphics flags then txtKnowledgeGraph act else []) -- ifcFieldTables ++ (if graphic flags then txtSwitchboard act else []) - -- , picKnowledgeGraph : [picSwitchboard | graphic] - ) - header :: Activity ->[Block] - header act = toList (labeledThing flags lev ("chpIfc"++name act) (name act)) - ifcIntro :: Activity -> [Block] + ) + ifcIntro :: Activity -> Blocks ifcIntro act - = purposes2Blocks flags purps - ++ifcAutoRules act++ - (if genEcaDoc flags then ifcEcaRules act else []) + = purposes2Blocks flags purps + <> fromList (ifcAutoRules act) + <> fromList (if genEcaDoc flags then ifcEcaRules act else []) where purps = purposesDefinedIn fSpec (fsLang fSpec) fSpec {- @@ -176,7 +175,7 @@ English -> [Para [ Str "Figure ", xrefReference (picKnowledgeGraph flags fSpec act) , Str " shows the knowledge graph of this interface."]] ) - ++ [Plain (xrefFigure1 (picKnowledgeGraph flags fSpec act))] -- draw the knowledge graph + ++ [Plain ((toList . showImage flags) (picKnowledgeGraph flags fSpec act))] -- draw the knowledge graph txtSwitchboard :: Activity ->[Block] txtSwitchboard act @@ -187,7 +186,7 @@ English -> [Para [ Str "Figure ", xrefReference (picSwitchboard flags fSpec act) , Str " shows the switchboard diagram of this interface."]] ) - ++ [Plain (xrefFigure1 (picSwitchboard flags fSpec act))] -- draw the switchboard + ++ [Plain ((toList . showImage flags) (picSwitchboard flags fSpec act))] -- draw the switchboard switchboardIntro :: [Block] switchboardIntro @@ -226,24 +225,11 @@ ] picKnowledgeGraph :: Options -> Fspc -> Activity ->Picture -picKnowledgeGraph flags fSpec act - = (makePicture flags fSpec Plain_CG act) -- the Picture that represents this interface's knowledge graph - {caption = case fsLang fSpec of - Dutch ->"Taaldiagram van "++name act - English ->"Language diagram of "++name act} --- where --- knGph = conceptualGraph fSpec flags Plain_CG act -- the DotGraph String that represents this interface's knowledge graph --- kn = printDotGraph knGph -- the String that represents this interface's knowledge graph +picKnowledgeGraph flags fSpec act = makePicture flags fSpec (PTFinterface act) picSwitchboard :: Options -> Fspc -> Activity -> Picture picSwitchboard flags fSpec act - = (makePicture flags fSpec Plain_CG (switchboardAct fSpec act)) -- the Picture that represents this interface's knowledge graph - {caption = case fsLang fSpec of - Dutch ->"Schakelpaneel van "++name act - English ->"Switchboard of "++name act} --- where --- sbGph = switchboardAct fSpec act -- the DotGraph String that represents this interface's knowledge graph --- sb = printDotGraph sbGph -- the String that represents this interface's knowledge graph + = makePicture flags fSpec (PTSwitchBoard act) -- the Picture that represents this interface's knowledge graph graphic :: Options -> Bool
src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterNatLangReqs.hs view
@@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wall #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} module DatabaseDesign.Ampersand.Output.ToPandoc.ChapterNatLangReqs where import Data.Char hiding (Space) @@ -7,12 +8,12 @@ import Data.List.Split import GHC.Exts (sortWith) import Data.Maybe +import DatabaseDesign.Ampersand.Basics import DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters hiding (sortWith) import DatabaseDesign.Ampersand.ADL1 import DatabaseDesign.Ampersand.Classes import DatabaseDesign.Ampersand.Output.PandocAux import Text.Pandoc.Builder ---import Debug.Trace fatal :: Int -> String -> a fatal = fatalMsg "Output.ToPandoc.ChapterNatLangReqs" @@ -28,48 +29,49 @@ <> -- *** Intro *** case fsLang fSpec of Dutch -> para - ( str "Dit hoofdstuk beschrijft een natuurlijke taal, waarin functionele eisen ten behoeve van " + ( "Dit hoofdstuk beschrijft een natuurlijke taal, waarin functionele eisen ten behoeve van " <> (singleQuoted.str.name) fSpec - <> str " kunnen worden besproken en uitgedrukt. " - <> str "Hiermee wordt beoogd dat verschillende belanghebbenden hun afspraken op dezelfde manier begrijpen. " - <> str "De taal van " + <> " kunnen worden besproken en uitgedrukt. " + <> "Hiermee wordt beoogd dat verschillende belanghebbenden hun afspraken op dezelfde manier begrijpen. " + <> "De taal van " <> (singleQuoted. str. name) fSpec - <> str " bestaat uit begrippen en basiszinnen, " - <> str "waarin afspraken worden uitgedrukt. " - <> str "Wanneer alle belanghebbenden afspreken dat zij deze basiszinnen gebruiken, " - <> str "althans voor zover het " + <> " bestaat uit begrippen en basiszinnen, " + <> "waarin afspraken worden uitgedrukt. " + <> "Wanneer alle belanghebbenden afspreken dat zij deze basiszinnen gebruiken, " + <> "althans voor zover het " <> (singleQuoted. str. name) fSpec - <> str " betreft, " - <> str "delen zij precies voldoende taal om afspraken op dezelfde manier te begrijpen. " - <> str "Alle definities zijn genummerd omwille van de traceerbaarheid. " + <> " betreft, " + <> "delen zij precies voldoende taal om afspraken op dezelfde manier te begrijpen. " + <> "Alle definities zijn genummerd omwille van de traceerbaarheid. " ) English -> para - ( str "This chapter defines the natural language, in which functional requirements of " + ( "This chapter defines the natural language, in which functional requirements of " <> (singleQuoted.str.name) fSpec - <> str " can be discussed and expressed. " - <> str "The purpose of this chapter is to create shared understanding among stakeholders. " - <> str "The language of " + <> " can be discussed and expressed. " + <> "The purpose of this chapter is to create shared understanding among stakeholders. " + <> "The language of " <> (singleQuoted.str.name) fSpec - <> str " consists of concepts and basic sentences. " - <> str "All functional requirements are expressed in these terms. " - <> str "When stakeholders can agree upon this language, " - <> str "at least within the scope of " + <> " consists of concepts and basic sentences. " + <> "All functional requirements are expressed in these terms. " + <> "When stakeholders can agree upon this language, " + <> "at least within the scope of " <> (singleQuoted.str.name) fSpec - <> str ", they share precisely enough language to have meaningful discussions about functional requirements. " - <> str "All definitions have been numbered for the sake of traceability. " + <> ", they share precisely enough language to have meaningful discussions about functional requirements. " + <> "All definitions have been numbered for the sake of traceability. " ) <> -- *** Requirements *** - fromList dpRequirements + fromList dpRequirementsOld +-- dpRequirementesNew <> -- *** Legal Refs *** - if (not.genLegalRefs) flags then mempty else - legalRefs + if genLegalRefs flags then legalRefs else mempty + where legalRefs :: Blocks legalRefs = (labeledThing flags (lev+1) "LegalRefs" sectionTitle) - <> table (str caption') + <> table caption' [(AlignLeft,1/4),(AlignLeft,3/4)] - [(plain.str) lawHeader, (plain.str) articleHeader] --headers + [plain lawHeader, plain articleHeader] --headers [ [(para.str.aOlLaw) art , (para.str.unscanRef.aOlArt) art] | art <-(sort.nub.concatMap getArticlesOfLaw.getRefs) fSpec ] @@ -80,9 +82,23 @@ getRefs ::Fspc -> [LawRef] getRefs f = concatMap catMaybes ((map (map toLawRef).map explRefIds.explanations) f) - dpRequirements :: [Block] - dpRequirements = theBlocks + dpRequirementesNew :: Blocks + dpRequirementesNew = let (_,blocks) = foldl printTheme (newCounter,mempty) (orderingByTheme fSpec) + in blocks where + printTheme :: (Counter,Blocks) + -> ( Maybe Theme -- A theme is about either a pattern or a process. + , [Rule] -- The rules of that theme + , [Declaration] -- The relations that are used in a rule of this theme, but not in any rule of a previous theme. + , [A_Concept] -- The concepts that are used in a rule of this theme, but not in any rule of a previous theme. + ) -> (Counter,Blocks) + printTheme (counter,bs) themeStuff = + let (blocks,count') = printOneTheme themeStuff counter + in (count',bs <> blocks) + + dpRequirementsOld :: [Block] + dpRequirementsOld = theBlocks + where (theBlocks,_) = if null (themes fSpec) then printThemes toBeProcessedStuff newCounter $ map PatternTheme (patterns fSpec) ++ map (ProcessTheme . fpProc) (vprocesses fSpec) else printThemes toBeProcessedStuff newCounter $ [ PatternTheme pat | pat<-patterns fSpec, name pat `elem` themes fSpec ] ++ @@ -92,18 +108,17 @@ , [r | r<-vrules fSpec, r_usr r == UserDefined] ) -- All user declared rules where conceptsWith -- All concepts that have at least one non-empty definition (must be the first) - = [ (c, pps) + = [ c | c@PlainConcept{} <- concs fSpec , (not.null) (concDefs fSpec c) - , let pps = [p | p <- purposesDefinedIn fSpec (fsLang fSpec) c, explUserdefd p] ] allRelsThatMustBeShown -- All relations declared in this specification that have at least one user-defined purpose. - = [ d | d <- declarations fSpec + = [ d | d <- relsDefdIn fSpec , decusr d , not . null $ purposesDefinedIn fSpec (fsLang fSpec) d ] - printThemes :: ( [(A_Concept,[Purpose])] -- all concepts that have one or more definitions or purposes. These are to be used into this section and the sections to come + printThemes :: ( [A_Concept] -- all concepts that have one or more definitions or purposes. These are to be used into this section and the sections to come , [Declaration] -- all relations to be processed into this section and the sections to come , [Rule]) -- all rules to be processed into this section and the sections to come -> Counter -- unique definition counters @@ -113,60 +128,76 @@ = case allThemes of [] -> if null still2doCPre && null still2doRelsPre && null still2doRelsPre then ([],iPre) - else printOneTheme Nothing (still2doCPre, still2doRelsPre, still2doRulesPre) iPre - _ -> (blocksOfOneTheme ++ blocksOfThemes,iPost) + else let (a,b) = printOneTheme (Nothing, still2doRulesPre, still2doRelsPre, still2doCPre) iPre + in (toList a,b) + _ -> (toList blocksOfOneTheme ++ blocksOfThemes,iPost) where (thm:thms) = allThemes - (blocksOfOneTheme,iPostFirst) = printOneTheme (Just thm) thisThemeStuff iPre + (blocksOfOneTheme,iPostFirst) = printOneTheme thisThemeStuff iPre (blocksOfThemes,iPost) = printThemes stuff2PrintLater iPostFirst thms - thisThemeStuff = (thisThemeCs, thisThemeRels, [r | r<-thisThemeRules, r_usr r == UserDefined]) + thisThemeStuff = (Just thm, [r | r<-thisThemeRules, r_usr r == UserDefined], thisThemeRels, thisThemeCs) thisThemeRules = [r | r<-still2doRulesPre, r_env r == name thm ] -- only user defined rules, because generated rules are documented in whatever caused the generation of that rule. rules2PrintLater = still2doRulesPre >- thisThemeRules thisThemeRels = [ d | d <- still2doRelsPre , decpat d == name thm || -- all relations declared in this theme, combined - d `eleM` declsUsedIn thisThemeRules] -- all relations used in this theme's rules + d `eleM` relsMentionedIn thisThemeRules] -- all relations used in this theme's rules rels2PrintLater = [x | x <-still2doRelsPre, (not.or) [ x==y | y <- thisThemeRels ]] - thisThemeCs = [(c,ps) |(c,ps)<- still2doCPre, c `eleM` (concs thisThemeRules ++ concs thisThemeRels)] -- relations are rules ('Eis') too + thisThemeCs = [c | c <- still2doCPre, c `eleM` (concs thisThemeRules ++ concs thisThemeRels)] -- relations are rules ('Eis') too concs2PrintLater = still2doCPre >- thisThemeCs stuff2PrintLater = (concs2PrintLater, rels2PrintLater, rules2PrintLater) --- (blocksOfThemes,iPost) = aThemeAtATime stuff2PrintLater xs iPostFirst --- thisThemeStuff = (thisThemeCdefs, thisThemeRels, [r | r<-thisThemeRules, r_usr r]) --- thisThemeRules = [r | r<-still2doRulesPre, r_env r == name x ] -- only user defined rules, because generated rules are documented in whatever caused the generation of that rule. --- rules2PrintLater = still2doRulesPre >- thisThemeRules --- thisThemeRels = [r | r<-still2doRelsPre, r `eleM` declsUsedIn thisThemeRules] `uni` -- all relations used in this theme's rules --- [ makeRelation d | d<-declarations x, (not.null) (multiplicities d)] -- all relations used in multiplicity rules --- rels2PrintLater = still2doRelsPre >- thisThemeRels --- thisThemeCdefs = [(c,cd) |(c,cd)<- still2doCdefsPre, c `eleM` (concs thisThemeRules ++ concs thisThemeRels)] --- thisThemeCpurps = [(c,ps) |(c,ps)<- still2doCpurpPre, c `eleM` (concs thisThemeRules ++ concs thisThemeRels)] --- cDefs2PrintLater = still2doCdefsPre >- thisThemeCdefs --- cPurps2PrintLater = still2doCpurpPre >- thisThemeCpurps --- stuff2PrintLater = (cDefs2PrintLater, cPurps2PrintLater, rels2PrintLater, rules2PrintLater) -- | printOneTheme tells the story in natural language of a single theme. -- For this purpose, Ampersand authors should take care in composing explanations. -- Each explanation should state the purpose (and nothing else). - printOneTheme :: Maybe Theme -- name of the theme to process (if any) - -> ( [(A_Concept,[Purpose])] -- all concepts that have one or more definitions, to be printed in this section - , [Declaration] -- Relations to print in this section - , [Rule]) -- Rules to print in this section - -> Counter -- first free number to use for numbered items - -> ([Block],Counter)-- the resulting blocks and the last used number. - printOneTheme mTheme (concs2print, rels2print, rules2print) counter0 - = case (mTheme, themes fSpec) of - (Nothing, _:_) -> ( [], counter0 ) -- The document is partial (because themes have been defined), so we don't print loose ends. - _ -> ( header' ++ explainsPat ++ printIntro concs2print relConcepts ++ reqdefs - , Counter (getEisnr counter0 + length reqs) - ) + printOneTheme :: ( Maybe Theme -- The theme to process (if any) + , [Rule] -- Rules to print in this section + , [Declaration] -- Relations to print in this section + , [A_Concept] -- Concepts, to print in this section + ) + -> Counter -- first free number to use for numbered items + -> (Blocks,Counter)-- the resulting blocks and first free number after processing of the theme. + printOneTheme (mTheme, rules2print, rels2print, concs2print) counter0 + = case (mTheme, themes fSpec) of + (Nothing, _:_) + -> ( mempty, counter0 ) -- The document is partial (because themes have been defined), so we don't print loose ends. + _ -> ( ( -- *** Header of the theme: *** + labeledThing flags (lev+1) + (xLabel DataAnalysis++case mTheme of + Nothing -> "_LooseEnds" + _ -> themeName + ) + (case (mTheme,fsLang fSpec) of + (Nothing, Dutch ) -> "Losse eindjes..." + (Nothing, English) -> "Loose ends..." + _ -> themeName + ) + + + <> -- *** Purpose of the theme: *** + case mTheme of + Nothing -> case fsLang fSpec of + Dutch -> para $ + "Deze paragraaf beschrijft de relaties en concepten die " + <> "niet in voorgaande secties zijn beschreven." + English -> para $ + "This paragraph shows remaining fact types and concepts " + <> "that have not been described in previous paragraphs." + Just pat -> purposes2Blocks flags (purposesDefinedIn fSpec (fsLang fSpec) pat) + <> -- *** Introduction text of the theme: *** + printIntro (filter isDefined concs2print) + <> fromList reqdefs + ) + , Counter (getEisnr counter0 + length reqs) + ) where + isDefined :: A_Concept -> Bool + isDefined = not.null.concDefs fSpec -- the concepts for which one of the relations of this theme contains a source or target definition -- (these will be printed, regardless whether the concept was printed before) - relConcepts = [ (upCap $ name d,def, origin d) - | d@Sgn{decConceptDef=Just (RelConceptDef _ def)} <- rels2print - ] -- sort the requirements by file position reqs = sortWith fst [ ((i,filenm org, linenr org,colnr org), bs) - | (i,org,bs)<- addIndex 0 (printConcepts concs2print) ++ addIndex 2 (printRelConcepts relConcepts) ++ + | (i,org,bs)<- addIndex 0 (printConcepts concs2print) ++ addIndex 2 (printRels rels2print) ++ addIndex 3 (printRules rules2print)] where addIndex i ps = [ (i::Int,fs, sn) | (fs,sn) <- ps ] -- add an index to sort first on category (concept, rel, ..) @@ -179,107 +210,92 @@ Just pat -> name pat --Just (PatternTheme pat) -> "Pattern "++name pat --Just (ProcessTheme prc) -> "Process "++name prc - header' :: [Block] - header' = toList (labeledThing flags (lev+1) (xLabel DataAnalysis++case mTheme of - Nothing -> "_LooseEnds" - _ -> themeName - ) - (case (mTheme,fsLang fSpec) of - (Nothing, Dutch ) -> "Losse eindjes..." - (Nothing, English) -> "Loose ends..." - _ -> themeName - )) - explainsPat :: [Block] - explainsPat - = case mTheme of - Nothing -> [Para - (case fsLang fSpec of - Dutch -> [Str "Deze paragraaf beschrijft de relaties en concepten die niet in voorgaande secties zijn beschreven."] - English -> [Str "This paragraph shows remaining fact types and concepts " - ,Str "that have not been described in previous paragraphs."] - )] - Just pat -> purposes2Blocks flags purps - where purps = purposesDefinedIn fSpec (fsLang fSpec) pat - printIntro :: [(A_Concept, [Purpose])] -> [(String, String, Origin)] -> [Block] - printIntro [] [] = [] - printIntro ccds relConcpts +-- The following paragraph produces an introduction of one theme (i.e. pattern or process). + printIntro :: [A_Concept] -> Blocks + printIntro [] = mempty + printIntro ccds = case fsLang fSpec of - Dutch -> [Para$ (case ([Emph [Str $ unCap cname] | cname<-map (name . fst) ccds ++ map fst3 relConcpts] - , length [p |p <- map PatternTheme (patterns fSpec) ++ map (ProcessTheme . fpProc) (vprocesses fSpec), name p == themeName]) of - ([] ,_) -> [] - ([_],1) -> [ Str $ "In het volgende wordt de taal geïntroduceerd ten behoeve van "++themeName++". " | themeName/=""] - (cs ,1) -> [ Str "Nu volgen definities van de concepten "]++ - commaNLPandoc (Str "en") cs++ - [ Str ". Daarna worden de basiszinnen en regels geïntroduceerd."] - ([c],_) -> [ Str "Deze sectie introduceert het concept " - , c] - (cs ,_) -> [ Str "Deze sectie introduceert de concepten "]++ - commaNLPandoc (Str "en") cs++ - [ Str ". "] - )++ - (let cs = [(c,cds,cps) | (c,cps)<-ccds, let cds = concDefs fSpec c,length cds>1] in - case (cs, length cs==length ccds) of - ([] , _ ) -> [] - ([(c,_,_)] , False) -> [ Str $ "Eén daarvan, "++name c++", heeft meerdere definities. " ] - (_ , False) -> [ Str "Daarvan hebben "]++commaNLPandoc (Str "en") (map (Str . name . fst3) cs)++[Str " meerdere definities. "] - ([(_,cds,_)], True ) -> [ Str $ "Deze heeft "++count Dutch (length cds) "definitie"++". " ] - (_ , True ) -> [ Str "Elk daarvan heeft meerdere definities. "] - ) - ] - English -> [Para$ (case ([Emph [Str $ unCap cname] |cname<-map (name . fst) ccds ++ map fst3 relConcpts] - , length [p |p <- map PatternTheme (patterns fSpec) ++ map (ProcessTheme . fpProc) (vprocesses fSpec), name p == themeName]) of - ([] ,_) -> [] - ([_],1) -> [ Str $ "The sequel introduces the language of "++themeName++". " | themeName/=""] - (cs ,1) -> [ Str "At this point, the definitions of "]++ - commaEngPandoc (Str "and") cs++ - [ Str " are given. Directly after that, the basic sentences and rules are introduced."] - ([c],_) -> [ Str "This section introduces concept " - , Emph [c]] - (cs ,_) -> [ Str "This section introduces concepts "]++ - commaEngPandoc (Str "and") cs++ - [ Str ". "] - )++ - (let cs = [(c,cds,cps) | (c,cps)<-ccds, let cds = concDefs fSpec c, length cds>1] in - case (cs, length cs==length ccds) of - ([] , _ ) -> [] - ([(c,_,_)] , False) -> [ Str $ "One of these concepts, "++name c++", has multiple definitions. " ] - (_ , False) -> [ Str "Of those concepts "]++commaEngPandoc (Str "and") (map (Str . name . fst3) cs)++[Str " have multiple definitions. "] - ([(_,cds,_)], True ) -> [ Str $ "It has "++count English (length cds) "definition"++". " ] - (_ , True ) -> [ Str "Each one has several definitions. "] - ) - ] - where fst3 (a,_,_) = a + Dutch -> (case ([(emph.str.unCap) cname | cname<-map name ccds] + , length [p |p <- map PatternTheme (patterns fSpec) ++ map (ProcessTheme . fpProc) (vprocesses fSpec), name p == themeName] + ) of + ([] ,_) -> mempty + ([_],1) -> case mTheme of + Nothing -> mempty + Just tme -> para ( "In het volgende wordt de taal geïntroduceerd ten behoeve van " + <> (str.name) tme <> "." + ) + (cs ,1) -> para ( "Nu volgen definities van de concepten " + <> commaNLPandoc' ("en") cs <> ".") + ([c],_) -> para ( "Deze sectie introduceert het concept " <> c ) + (cs ,_) -> para ( "Deze sectie introduceert de concepten " <> + commaNLPandoc' "en" cs <> ". ") + ) <> + (let cs = [(c,cds) | (c)<-ccds, let cds = concDefs fSpec c,length cds>1] in + case (cs, length cs==length ccds) of + ([] , _ ) -> mempty + ([(c,_)] , False) -> para ("Eén daarvan, " <> (str.name) c <>", heeft meerdere definities. ") + (_ , False) -> para ("Daarvan hebben "<>commaNLPandoc' "en" (map (str. name . fst) cs)<> " meerdere definities. ") + ([(_,cds)], True ) -> para ("Deze heeft "<>str(count Dutch (length cds) "definitie")<>". ") + (_ , True ) -> para ("Elk daarvan heeft meerdere definities. ") + ) + + English -> (case ([(emph.str.unCap) cname | cname<-map name ccds] + , length [p |p <- map PatternTheme (patterns fSpec) ++ map (ProcessTheme . fpProc) (vprocesses fSpec), name p == themeName] + ) of + ([] ,_) -> mempty + ([_],1) -> case mTheme of + Nothing -> mempty + Just tme -> para ( "The sequel introduces the language of " + <> (str.name) tme <> "." + ) + (cs ,1) -> para ( "At this point, the definitions of " + <> commaEngPandoc' "and" cs <>" are given.") + ([c],_) -> para ("This section introduces concept " <> c ) + (cs ,_) -> para ("This section introduces concepts " <> + commaEngPandoc' "and" cs <> ". ") + )<> + (let cs = [(c,cds) | c <- ccds, let cds = concDefs fSpec c, length cds>1] in + case (cs, length cs==length ccds) of + ([] , _ ) -> mempty + ([(c,_)] , False) -> para ("One of these concepts, " <> (str.name) c <>", has multiple definitions. ") + (_ , False) -> para ("Of those concepts "<>commaEngPandoc' "and" (map (str. name . fst) cs)<> " have multiple definitions. ") + ([(_,cds)], True ) -> para ("It has "<>str(count English (length cds) "definition")<>". ") + (_ , True ) -> para ("Each one has several definitions. ") + ) + -- | the origin of c is the origin of the head of uniquecds c -- after sorting by origin the counter will be applied - printConcepts :: [(A_Concept, [Purpose])] -> [(Origin, Counter -> [Block])] - printConcepts = let mborigin c = if null (uniquecds fSpec c) then OriginUnknown else (origin . snd . head . uniquecds fSpec) c - in map (\(c,exps) -> (mborigin c, cptBlock (c,exps))) + printConcepts :: [A_Concept] -> [(Origin, Counter -> [Block])] + printConcepts cs = map printConcept cs + printConcept :: A_Concept -> (Origin, Counter -> [Block]) + printConcept c = (case uniquecds fSpec c of + [] -> OriginUnknown + (_,x):_ -> origin x + , cptBlock c + ) -- | make a block for a c with all its purposes and definitions - cptBlock :: (A_Concept, [Purpose]) -> Counter -> [Block] - cptBlock (c,exps) cnt = concat [amPandoc (explMarkup e) | e<-exps] + cptBlock :: A_Concept -> Counter -> [Block] + cptBlock cpt cnt = concat [amPandoc (explMarkup e) | e<-exps] ++ zipWith cdBlock - (if length (uniquecds fSpec c) == 1 then [(cnt, "")] else + (if length (uniquecds fSpec cpt) == 1 then [(cnt, "")] else [(cnt, '.' : show i) | i <- [(1 :: Int) ..]]) - [ (nm, symDefLabel cd, cddef cd, cdref cd) | (nm, cd) <- uniquecds fSpec c ] + [ (nm, symDefLabel cd, cddef cd, cdref cd) | (nm, cd) <- uniquecds fSpec cpt ] + where exps = case purposeOf fSpec (fsLang fSpec) cpt of + Nothing -> [] + Just ps -> ps -- | make a block for a concept definition cdBlock :: (Counter,String) -> (String,String,String,String) -> Block - cdBlock (cnt,xcnt) (nm,lbl,def,ref) = DefinitionList + cdBlock (cnt,xcnt) (nm,lbl,def',ref) = DefinitionList [( [ Str (case fsLang fSpec of Dutch -> "Definitie " English -> "Definition ") , Str (show (getEisnr cnt)++xcnt) , Str ":"] - , [ makeDefinition flags (getEisnr cnt) nm lbl def ref ])] + , [ makeDefinition flags (getEisnr cnt) nm lbl def' ref ])] - printRelConcepts :: [(String, String, Origin)] -> [(Origin, Counter -> [Block])] - printRelConcepts relConcpts = map printRelConcept relConcpts - - printRelConcept (relcncpt, def, org) = - ( org, \cnt -> [cdBlock (cnt,"") (relcncpt, "", def, "")] - ) -- | sctds prints the requirements related to relations that are introduced in this theme. printRels :: [Declaration] -> [(Origin, Counter -> [Block])] @@ -287,7 +303,7 @@ printRel :: Declaration -> Counter -> [Block] printRel dcl cnt = Plain [RawInline (Text.Pandoc.Builder.Format "latex") "\\bigskip"] : - purposes2Blocks flags purps + toList (purposes2Blocks flags purps) ++ [ DefinitionList [ ( [ Str (case fsLang fSpec of Dutch -> "Afspraak " @@ -307,12 +323,12 @@ ) ++ sampleSentences where purps = purposesDefinedIn fSpec (fsLang fSpec) dcl - samplePop = take 3 (fullContents (gens fSpec) (initialPops fSpec) dcl) + samplePop = (take 3 . fullContents (gens fSpec) (initialPops fSpec) . EDcD) dcl sampleSentences = [ Para $ mkSentence (development flags) dcl srcViewAtom tgtViewAtom - | (srcAtom,tgtAtom)<-samplePop - , let srcViewAtom = showViewAtom fSpec (Just dcl) (source dcl) srcAtom - , let tgtViewAtom = showViewAtom fSpec Nothing (target dcl) tgtAtom + | p <-samplePop + , let srcViewAtom = showViewAtom fSpec (Just dcl) (source dcl) (srcPaire p) + , let tgtViewAtom = showViewAtom fSpec Nothing (target dcl) (trgPaire p) ] ++ (if null samplePop then [] else [Plain [RawInline (Text.Pandoc.Builder.Format "latex") "\\medskip"]]) @@ -322,7 +338,7 @@ printRule :: Rule -> Counter -> [Block] printRule rul cnt = Plain [RawInline (Text.Pandoc.Builder.Format "latex") "\\bigskip"] : - purposes2Blocks flags purps + toList (purposes2Blocks flags purps) ++ [ DefinitionList [ ( [ Str (case fsLang fSpec of Dutch -> "Afspraak " @@ -341,20 +357,20 @@ mkSentence isDev decl srcAtom tgtAtom = case decl of Sgn{} | null (prL++prM++prR) - -> [str (upCap srcAtom), Space] ++ devShow (source decl) ++ [Str "corresponds",Space,Str "to",Space,str tgtAtom, Space] ++ devShow (target decl) ++[Str "in",Space,Str "relation",Space,str (decnm decl),Str "."] + -> [str' (upCap srcAtom), Space] ++ devShow (source decl) ++ [Str "corresponds",Space,Str "to",Space,str' tgtAtom, Space] ++ devShow (target decl) ++[Str "in",Space,Str "relation",Space,str' (decnm decl),Str "."] | otherwise -> leftHalf prL ++ rightHalf where prL = decprL decl prM = decprM decl prR = decprR decl leftHalf "" = devShow (source decl) - leftHalf prLft = [str (upCap prLft), Space] ++ devShow (source decl) - rightHalf = [str srcAtom,Space,str prM, Space] ++ devShow (target decl) ++ [str tgtAtom]++(if null prR then [] else [Space,str prR]) ++ [Str "."] + leftHalf prLft = [str' (upCap prLft), Space] ++ devShow (source decl) + rightHalf = [str' srcAtom,Space,str' prM, Space] ++ devShow (target decl) ++ [str' tgtAtom]++(if null prR then [] else [Space,str' prR]) ++ [str' "."] - Isn{} -> devShow (source decl) ++ [str (upCap srcAtom),Space,Str "equals",Space,str tgtAtom,Str "."] + Isn{} -> devShow (source decl) ++ [str' (upCap srcAtom),Space,Str "equals",Space,str' tgtAtom,Str "."] Vs{} -> [Str "True"] - where str = if fspecFormat flags==FLatex then RawInline (Text.Pandoc.Builder.Format "latex") . latexEscShw else Str - devShow c | isDev = [Str "(", str $ name c, Str ") "] -- only show the concept when --dev option is given + where str' = if fspecFormat flags==FLatex then RawInline (Text.Pandoc.Builder.Format "latex") . latexEscShw else Str + devShow c | isDev = [Str "(", str' $ name c, Str ") "] -- only show the concept when --dev option is given | otherwise = [] -- TODO: fix showing/not showing based on relation @@ -370,10 +386,10 @@ then atom else concatMap showViewSegment (vdats view) -- if we are showing one of the view relations, don't expand the view - where showViewSegment (ViewText str) = str - showViewSegment (ViewHtml str) = str + where showViewSegment (ViewText str') = str' + showViewSegment (ViewHtml str') = str' showViewSegment (ViewExp objDef) = - case [ tgtAtom | (srcAtom, tgtAtom) <- fullContents (gens fSpec) (initialPops fSpec) (objctx objDef), atom == srcAtom ] of + case [ trgPaire p | p <- fullContents (gens fSpec) (initialPops fSpec) (objctx objDef), atom == srcPaire p ] of [] -> "" viewAtom:_ -> viewAtom -- justViewRels = map (Just . objctx) [objDef | ViewExp objDef <- vdats view] @@ -412,22 +428,22 @@ -- group string in number and text sequences, so "Art 12" appears after "Art 2" when sorting (unlike in normal lexicographic string sort) scanRef :: String -> [Either String Int] scanRef "" = [] - scanRef str@(c:_) | isDigit c = scanRefInt str - | otherwise = scanRefTxt str + scanRef str'@(c:_) | isDigit c = scanRefInt str' + | otherwise = scanRefTxt str' scanRefTxt "" = [] - scanRefTxt str = let (txt, rest) = break isDigit str - in Left txt : scanRefInt rest + scanRefTxt str' = let (txt, rest) = break isDigit str' + in Left txt : scanRefInt rest scanRefInt "" = [] - scanRefInt str = let (digits, rest) = break (not . isDigit) str - in Right (read digits) : scanRefTxt rest + scanRefInt str' = let (digits, rest) = break (not . isDigit) str' + in Right (read digits) : scanRefTxt rest instance Ord ArticleOfLaw where compare a b = case compare (aOlLaw a) (aOlLaw b) of - EQ -> compare (aOlArt a) (aOlArt b) - ord -> ord + EQ -> compare (aOlArt a) (aOlArt b) + ord' -> ord' unscanRef :: [Either String Int] -> String unscanRef scannedRef = concat $ map (either id show) scannedRef
src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterProcessAnalysis.hs view
@@ -18,7 +18,7 @@ chpProcessAnalysis lev fSpec flags = if null procs then (mempty,[]) - else (fromList $ headerBlocks ++ roleRuleBlocks ++ roleRelationBlocks ++ processSections , pictures) + else (headerBlocks <> fromList (roleRuleBlocks ++ roleRelationBlocks ++ processSections) , pictures) where pictures = [pict | (_,picts)<-procSections procs,pict<-picts] procs = if null (themes fSpec) @@ -28,10 +28,11 @@ processSections = [block | (bs,_)<-procSections procs, block<-bs] - headerBlocks :: [Block] + headerBlocks :: Blocks headerBlocks - = toList (chptHeader (fsLang fSpec) ProcessAnalysis) ++ - purposes2Blocks flags purps ++ -- This explains the purpose of this context. + = (chptHeader (fsLang fSpec) ProcessAnalysis) <> + purposes2Blocks flags purps <> -- This explains the purpose of this context. + fromList( [ case fsLang fSpec of Dutch -> Plain [ Str $ upCap (name fSpec)++" benoemt geen enkele rol. " @@ -51,7 +52,7 @@ Plain [ Str $ upCap (name fSpec)++" does not specify which roles may change the contents of which relations. " , Str "" ] - | null (fRoleRels fSpec)] + | null (fRoleRels fSpec)]) where purps = purposesDefinedIn fSpec (fsLang fSpec) fSpec roleRuleBlocks :: [Block] @@ -67,19 +68,19 @@ , Str "The following table shows the rules that are being maintained by a given role." ] -- the table containing the role-rule assignments - , Para $ [ RawInline (DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters.Format "latex") "\\begin{tabular}{|l|l|}\\hline\n" + , Para $ [ RawInline (Format "latex") "\\begin{tabular}{|l|l|}\\hline\n" , case fsLang fSpec of - Dutch -> RawInline (DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters.Format "latex") "Rol&Regel\\\\ \\hline\n" - English -> RawInline (DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters.Format "latex") "Role&Rule\\\\ \\hline\n" + Dutch -> RawInline (Format "latex") "Rol&Regel\\\\ \\hline\n" + English -> RawInline (Format "latex") "Role&Rule\\\\ \\hline\n" ]++ - [ RawInline (DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters.Format "latex") $ intercalate "\\\\ \\hline\n " + [ RawInline (Format "latex") $ intercalate "\\\\ \\hline\n " [ role++" & "++name r++ concat[ "\\\\\n &"++name rul | rul<-map snd (tail rrClass)] | rrClass<-eqCl fst (fRoleRuls fSpec) , let role=fst (head rrClass), let r=snd (head rrClass) ] ]++ - [ RawInline (DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters.Format "latex") "\\\\ \\hline\n\\end{tabular}" + [ RawInline (Format "latex") "\\\\ \\hline\n\\end{tabular}" ] ] @@ -96,61 +97,60 @@ Para [ Str $ upCap (name fSpec)++" assigns roles to relations. " , Str "The following table shows the relations, the content of which can be altered by anyone who fulfills a given role." ] - , Para $ [ RawInline (DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters.Format "latex") "\\begin{tabular}{|l|l|}\\hline\n" - , RawInline (DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters.Format "latex") + , Para $ [ RawInline (Format "latex") "\\begin{tabular}{|l|l|}\\hline\n" + , RawInline (Format "latex") (case fsLang fSpec of Dutch -> "Rol&Relatie\\\\ \\hline\n" English -> "Role&Relation\\\\ \\hline\n") ]++ - [ RawInline (DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters.Format "latex") $ intercalate "\\\\ \\hline\n " + [ RawInline (Format "latex") $ intercalate "\\\\ \\hline\n " [ role++" & $"++showMath r++"$"++ concat[ "\\\\\n &$"++showMath (snd rs)++"$" | rs<-tail rrClass] | rrClass<-eqCl fst (fRoleRels fSpec) , let role=fst (head rrClass), let r=snd (head rrClass) ] ]++ - [ RawInline (DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters.Format "latex") "\\\\ \\hline\n" | not (null rolelessRels)]++ - [ RawInline (DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters.Format "latex") $ intercalate "\\\\\n " [ "&$"++showMath d++"$" | d<-rolelessRels] | not (null rolelessRels)]++ - [ RawInline (DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters.Format "latex") "\\\\ \\hline\n\\end{tabular}" + [ RawInline (Format "latex") "\\\\ \\hline\n" | not (null rolelessRels)]++ + [ RawInline (Format "latex") $ intercalate "\\\\\n " [ "&$"++showMath d++"$" | d<-rolelessRels] | not (null rolelessRels)]++ + [ RawInline (Format "latex") "\\\\ \\hline\n\\end{tabular}" ] ] where - rolelessRels = [ d | d<-declarations fSpec, d `notElem` (nub.map snd) (fRoleRels fSpec) ] + rolelessRels = [ d | d<-relsDefdIn fSpec, d `notElem` (nub.map snd) (fRoleRels fSpec) ] emptyProcess :: Process -> Bool emptyProcess p = null (udefrules p) -- the sections in which processes are analyzed procSections :: [FProcess] -> [([Block],[Picture])] - procSections fprocs = iterat [fp |fp<-fprocs, not (emptyProcess (fpProc fp))] 1 (concs (patterns fSpec)) ((concatMap declarations.patterns) fSpec) + procSections fprocs = iterat [fp |fp<-fprocs, (not.emptyProcess.fpProc) fp] 1 declaredConcepts declaredRelations where + declaredRelations = (concatMap relsDefdIn.map fpProc.vprocesses) fSpec + declaredConcepts = (concs.map fpProc.vprocesses) fSpec iterat :: [FProcess] -> Int -> [A_Concept] -> [Declaration] -> [([Block],[Picture])] iterat [] _ _ _ = [] iterat (fproc:fps) i seenConcepts seenDeclarations = ( toList (labeledThing flags (lev+1) (xLabel ProcessAnalysis++"_"++name fproc) (name fproc)) -- new section to explain this theme - ++ sctMotivation -- The section startss with the reason why this process exists, + ++ toList (purposes2Blocks flags (purposesDefinedIn fSpec (fsLang fSpec) fproc)) ++ txtProcessModel fproc - ++ txtLangModel fproc + -- ++ txtLangModel fproc ++ (if null sctRules then [] else [DefinitionList sctRules]) - , [picProcessModel fproc, picLangModel fproc]): iterat fps i' seenCrs seenDrs + , [picProcessModel fproc]): iterat fps i' seenCrs seenDrs where - sctMotivation - = purposes2Blocks flags purps - purps = purposesDefinedIn fSpec (fsLang fSpec) fproc sctRules :: [([Inline], [[Block]])] (sctRules,i',seenCrs,seenDrs) = dpRule fSpec flags (udefrules (fpProc fproc)) i seenConcepts seenDeclarations - txtLangModel :: FProcess->[Block] - txtLangModel fp - = if not (genGraphics flags) then [] else - -- (if name ifc==name (head (fActivities fSpec)) then processModelIntro else [])++ - [Para (case fsLang fSpec of -- announce the conceptual diagram - Dutch -> [ Str "Het conceptueel diagram in figuur ", xrefReference pict - , Str " geeft een overzicht van de taal waarin dit proces wordt uitgedrukt."] - English -> [ Str "The conceptual diagram of figure ", xrefReference pict - , Str " provides an overview of the language in which this process is expressed."]) - ,Plain (xrefFigure1 pict)] -- draw the diagram - where pict = picLangModel fp +-- txtLangModel :: FProcess->[Block] +-- txtLangModel fp +-- = if not (genGraphics flags) then [] else +-- -- (if name ifc==name (head (fActivities fSpec)) then processModelIntro else [])++ +-- [Para (case fsLang fSpec of -- announce the conceptual diagram +-- Dutch -> [ Str "Het conceptueel diagram in figuur ", xrefReference pict +-- , Str " geeft een overzicht van de taal waarin dit proces wordt uitgedrukt."] +-- English -> [ Str "The conceptual diagram of figure ", xrefReference pict +-- , Str " provides an overview of the language in which this process is expressed."]) +-- ,Plain ((toList . showImage flags) pict)] -- draw the diagram +-- where pict = picLangModel fp txtProcessModel :: FProcess->[Block] txtProcessModel p @@ -161,18 +161,13 @@ , Str " geeft het procesmodel weer."] English -> [ Str "Figure ", xrefReference pict , Str " shows the process model."]) - ,Plain (xrefFigure1 pict)] -- draw the diagram + ,Plain ((toList . showImage flags) pict)] -- draw the diagram where pict = picProcessModel p - picLangModel :: FProcess->Picture - picLangModel fproc - = ((makePictureObj flags (fsLang fSpec) (name fproc) PTProcLang . conceptualGraph fSpec flags Rel_CG) fproc) -- the Picture that represents this process's knowledge graph with all user defined relations (controlled by Rel_CG) - {caption = case fsLang fSpec of - Dutch ->"Basiszinnen van "++name fproc - English ->"Basic sentences of "++name fproc} + + -- | the Picture that represents this interface's knowledge graph with only those relations that are used in rules (controlled by Plain_CG). picProcessModel :: FProcess->Picture - picProcessModel fproc - = makePicture flags fSpec Plain_CG fproc -- the Picture that represents this interface's knowledge graph with only those relations that are used in rules (controlled by Plain_CG). + picProcessModel fproc = makePicture flags fSpec (PTProcess fproc)
src/lib/DatabaseDesign/Ampersand/Output/ToPandoc/ChapterSoftwareMetrics.hs view
@@ -3,8 +3,8 @@ module DatabaseDesign.Ampersand.Output.ToPandoc.ChapterSoftwareMetrics where import DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters -import DatabaseDesign.Ampersand.Output.Statistics (Statistics(..)) -import DatabaseDesign.Ampersand.Output.PandocAux +--import DatabaseDesign.Ampersand.Output.Statistics (Statistics(..)) +--import DatabaseDesign.Ampersand.Output.PandocAux ------------------ Function Point Analysis --------------------
@@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wall #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} module DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters ( module Text.Pandoc , module Text.Pandoc.Builder @@ -15,7 +16,6 @@ , chptHeader , chptTitle , Xreferencable(..) - , xrefFigure1 , showImage , canXRefer , Purpose(..) @@ -23,8 +23,10 @@ , isMissing , lclForLang , dpRule + , relsInThemes , Counter(..),newCounter,incEis , inlineIntercalate + , orderingByTheme ) where import DatabaseDesign.Ampersand.Basics @@ -62,7 +64,7 @@ chaptersInDoc flags = [chp | chp<-chapters, chp `notElem` disabled] where -- temporarily switch off chapters that need too much refactoring, but keep this Haskell code compilable. - disabled = [EcaRules,Interfaces] + disabled = [Interfaces] chapters | test flags = [SharedLang] | diagnosisOnly flags = [Diagnosis] @@ -81,8 +83,8 @@ -- | This function returns a header of a chapter chptHeader :: Lang -> Chapter -> Blocks -chptHeader lang cpt - = header 1 (chptTitle lang cpt ) +chptHeader lang chap + = header 1 (chptTitle lang chap ) <> singleton (Para [xrefLabel chap]) chptTitle :: Lang -> Chapter -> Inlines chptTitle lang cpt = @@ -127,7 +129,7 @@ xLabel a = "chapter" ++ escapeNonAlphaNum (show a) instance Xreferencable Picture where - xLabel a = "figure" ++ escapeNonAlphaNum (uniqueName a) + xLabel a = "figure" ++ escapeNonAlphaNum (caption a) --Image [Inline] Target -- alt.text (URL,title) @@ -136,7 +138,7 @@ case fspecFormat flags of FLatex -> rawInline "latex" ("\\begin{figure}[htb]\n\\begin{center}\n\\scalebox{"++scale pict++"}["++scale pict++"]{") _ -> mempty - <> image (uniqueName pict) (xLabel pict) (text $ "Here, "++uniqueName pict++" should have been visible" ) + <> image (imagePath flags pict) (xLabel pict) (text $ "Here, "++caption pict++" should have been visible" ) <> case fspecFormat flags of FLatex -> rawInline "latex" "}\n" <>rawInline "latex" ("\\caption{"++latexEscShw (caption pict)++"}\n") @@ -145,27 +147,22 @@ <> case fspecFormat flags of FLatex -> rawInline "latex" "\n\\end{center}\n\\end{figure}" _ -> mempty -xrefFigure1 :: Picture -> [Inline] --DEPRECIATED! Use showImage instead. -xrefFigure1 pict = - [ RawInline (Text.Pandoc.Builder.Format "latex") ("\\begin{figure}[htb]\n\\begin{center}\n\\scalebox{"++scale pict++"}["++scale pict++"]{") - , Image [Str $ "Here, "++uniqueName pict++" should have been visible"] (uniqueName pict, xLabel pict) - , RawInline (Text.Pandoc.Builder.Format "latex") "}\n" - , RawInline (Text.Pandoc.Builder.Format "latex") ("\\caption{"++latexEscShw (caption pict)++"}\n") - , xrefLabel pict - , RawInline (Text.Pandoc.Builder.Format "latex") "\n\\end{center}\n\\end{figure}"] -- | This function orders the content to print by theme. It returns a list of -- tripples by theme. The last tripple might not have a theme, but will contain everything -- that isn't handled in a specific theme. -orderingByTheme :: Fspc -> [( Maybe Theme -- A theme is about either a pattern of a process. +orderingByTheme :: Fspc -> [( Maybe Theme -- A theme is about either a pattern or a process. , [Rule] -- The rules of that theme , [Declaration] -- The relations that are used in a rule of this theme, but not in any rule of a previous theme. , [A_Concept] -- The concepts that are used in a rule of this theme, but not in any rule of a previous theme. ) ] orderingByTheme fSpec - = f (allRules fSpec) (declsUsedIn fSpec) (allConcepts fSpec) tms + = f (allRules fSpec) (filter isUserDefined (relsMentionedIn fSpec)) (allConcepts fSpec) tms where + isUserDefined d = case d of + Sgn{} -> decusr d + _ -> False -- | The themes that should be taken into account for this ordering tms = if null (themes fSpec) then map PatternTheme (patterns fSpec) ++ map (ProcessTheme . fpProc) (vprocesses fSpec) @@ -200,7 +197,7 @@ ProcessTheme prc -> prcRules prc ) (relsOfTheme,relsNotOfTheme) = partition isRelOfTheme rels - isRelOfTheme r = r `elem` concatMap declsUsedIn rulsOfTheme + isRelOfTheme r = r `elem` (concatMap relsDefdIn rulsOfTheme++concatMap relsUsedIn rulsOfTheme) (cptsOfTheme,cptsNotOfTheme) = partition isCptOfTheme cpts isCptOfTheme c = c `elem` concatMap concs relsOfTheme @@ -214,8 +211,8 @@ dpR (r:rs) n seenConcs seenDeclarations = ( ( [Str (name r)] , [ let purps = purposesDefinedIn fSpec (fsLang fSpec) r in -- Als eerste de uitleg van de betreffende regel.. - purposes2Blocks flags purps ++ - purposes2Blocks flags [p | d<-nds, p<-purposesDefinedIn fSpec (fsLang fSpec) d] ++ -- Dan de uitleg van de betreffende relaties + toList (purposes2Blocks flags purps) ++ + toList (purposes2Blocks flags [p | d<-nds, p<-purposesDefinedIn fSpec (fsLang fSpec) d]) ++ -- Dan de uitleg van de betreffende relaties [ Plain text1 | not (null nds)] ++ pandocEqnArray [ ( texOnly_Id(name d) , ":" @@ -266,10 +263,10 @@ (English,False) -> [Str "This means: "] (Dutch ,True) -> [Str "Activiteiten, die door deze regel zijn gedefinieerd, zijn afgerond zodra: "] (English,True) -> [Str "Activities that are defined by this rule are finished when: "] - text4 - = case fsLang fSpec of - Dutch -> [Str " Deze activiteiten worden opgestart door:"] - English -> [Str " These activities are signalled by:"] +-- text4 +-- = case fsLang fSpec of +-- Dutch -> [Str " Deze activiteiten worden opgestart door:"] +-- English -> [Str " These activities are signalled by:"] text5 = case (fsLang fSpec,isSignal r) of (Dutch ,False) -> [ Plain [ Str "Dit komt overeen met de afspraak op pg.",RawInline (Text.Pandoc.Builder.Format "latex") "~",RawInline (Text.Pandoc.Builder.Format "latex") $ symReqPageRef r, Str ":"]]++meaning2Blocks (fsLang fSpec) r @@ -282,11 +279,21 @@ , Str " (",RawInline (Text.Pandoc.Builder.Format "latex") $ symReqRef r, Str " op pg.",RawInline (Text.Pandoc.Builder.Format "latex") "~",RawInline (Text.Pandoc.Builder.Format "latex") $ symReqPageRef r, Str ")."]] ncs = concs r >- seenConcs -- newly seen concepts cds = [(c,cd) | c<-ncs, cd<-cDefsInScope fSpec, cdcpt cd==name c] -- ... and their definitions - ds = declsUsedIn r - nds = [d | d@Sgn{}<-ds >- seenDeclarations] -- newly seen declarations - rds = [d | d@Sgn{}<-ds `isc` seenDeclarations] -- previously seen declarations + ds = relsUsedIn r + nds = [d | d@Sgn{}<-ds >- seenDeclarations] -- newly seen relations + rds = [d | d@Sgn{}<-ds `isc` seenDeclarations] -- previously seen relations ( dpNext, n', seenCs, seenDs ) = dpR rs (n+length cds+length nds+1) (ncs++seenConcs) (nds++seenDeclarations) +relsInThemes :: Fspc -> [Declaration] +relsInThemes fSpec + -- a relation is considered relevant iff it is declared or mentioned in one of the relevant themes. + = [d | d<-relsDefdIn fSpec + , decusr d + , ( decpat d `elem` themes fSpec + || d `elem` relsMentionedIn [p | p<- patterns fSpec , name p `elem` themes fSpec] + || d `elem` relsMentionedIn [p | p<-map fpProc (vprocesses fSpec), name p `elem` themes fSpec] + ) + ] data Counter = Counter { --getConc :: Int -- getDecl :: Int @@ -301,19 +308,20 @@ --incRule x = x{getRule = getRule x + 1} incEis x = x{getEisnr = getEisnr x + 1} -purposes2Blocks :: Options -> [Purpose] -> [Block] +purposes2Blocks :: Options -> [Purpose] -> Blocks purposes2Blocks flags ps - = case ps of - [] -> [] - -- by putting the ref after the first inline of the definition, it aligns nicely with the definition - _ -> case concatMarkup [expl{amPandoc = insertAfterFirstInline (ref purp) $ amPandoc expl} | purp<-ps, let expl=explMarkup purp] of - Nothing -> [] - Just p -> amPandoc p - where -- The reference information, if available for this purpose, is put - ref purp = case fspecFormat flags of - FLatex | (not.null.explRefIds) purp-> [RawInline (Text.Pandoc.Builder.Format "latex") - ("\\marge{"++intercalate "; " (map latexEscShw (explRefIds purp))++"}\n")] - _ -> [] + = fromList $ + case ps of + [] -> [] + -- by putting the ref after the first inline of the definition, it aligns nicely with the definition + _ -> case concatMarkup [expl{amPandoc = insertAfterFirstInline (ref purp) $ amPandoc expl} | purp<-ps, let expl=explMarkup purp] of + Nothing -> [] + Just p -> amPandoc p + where -- The reference information, if available for this purpose, is put + ref purp = case fspecFormat flags of + FLatex | (not.null.explRefIds) purp-> [RawInline (Text.Pandoc.Builder.Format "latex") + ("\\marge{"++intercalate "; " (map latexEscShw (explRefIds purp))++"}\n")] + _ -> [] concatMarkup :: [A_Markup] -> Maybe A_Markup concatMarkup es = case eqCl f es of