{-# OPTIONS_GHC -Wall #-} {-# LANGUAGE ScopedTypeVariables #-} module DatabaseDesign.Ampersand.Output.ToPandoc.ChapterDiagnosis where import DatabaseDesign.Ampersand.Output.ToPandoc.SharedAmongChapters import DatabaseDesign.Ampersand.ADL1 import DatabaseDesign.Ampersand.Classes import Data.List import DatabaseDesign.Ampersand.Output.PandocAux fatal :: Int -> String -> a fatal = fatalMsg "Output.ToPandoc.ChapterDiagnosis" chpDiagnosis :: Fspc -> Options -> (Blocks,[Picture]) chpDiagnosis fSpec flags = ( (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 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 ruleRelationRefTable ++ -- table that shows percentages of relations and rules that have references invariantsInProcesses ++ -- processrulesInPatterns++ -- -- 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 diagIntro :: [Block] diagIntro = case fsLang fSpec of Dutch -> [Para [ Str "Dit hoofdstuk geeft een analyse van het Ampersand-script van ", Quoted SingleQuote [Str (name fSpec)], Str ". " , Str "Deze analyse is bedoeld voor de auteurs van dit script. " , Str "Op basis hiervan kunnen zij het script completeren en mogelijke tekortkomingen verbeteren. " ]] English -> [Para [ Str "This chapter provides an analysis of the Ampersand script of ", Quoted SingleQuote [Str (name fSpec)], Str ". " , Str "This analysis is intended for the authors of this script. " , Str "It can be used to complete the script or to improve possible flaws. " ]] roleRuleTable :: [Block] roleRuleTable | null ruls = [] | null (fRoles fSpec) = case fsLang fSpec of Dutch -> [Para [ Str $ upCap (name fSpec)++" specificeert geen rollen. " ]] English -> [Para [ Str $ upCap (name fSpec)++" does not define any roles. " ]] | null [r | r<-vrules fSpec, isSignal r ] = case fsLang fSpec of Dutch -> [Para [ Str $ upCap (name fSpec)++" kent geen procesregels. " ]] English -> [Para [ Str $ upCap (name fSpec)++" does not define any process rules. " ]] | otherwise = (case fsLang fSpec of Dutch -> Para [ Str $ upCap (name fSpec)++" kent regels aan rollen toe. " , Str "De volgende tabel toont welke regels door een bepaalde rol kunnen worden gehandhaafd."] English -> Para [ Str $ upCap (name fSpec)++" assigns rules to roles. " , Str "The following table shows the rules that are being maintained by a given role."] ) : [Table [] -- the table containing the role-rule assignments (AlignLeft:[AlignCenter |_<-fRoles fSpec]) (0.0:[0.0 |_<-fRoles fSpec]) (( case fsLang fSpec of Dutch -> [Plain [Str "regel"]] English -> [Plain [Str "rule" ]] ) : [ [Plain [Str r]] | r <- fRoles fSpec ] ) [ [Plain [Str (name rul)]]:[f r rul | r<-fRoles fSpec] | rul<-ruls ] ] where ruls = if null (themes fSpec) then [r | r<-vrules fSpec, isSignal r ] else [r | pat<-patterns fSpec, name pat `elem` themes fSpec, r<-udefrules pat, isSignal r ] ++ [r | prc<-vprocesses fSpec, name prc `elem` themes fSpec, r<-udefrules (fpProc prc) , isSignal r ] f r rul | (r,rul) `elem` maintained = [Plain [Math InlineMath "\\surd"]] | (r,rul) `elem` dead = [Plain [Math InlineMath "\\times"]] | (r,rul) `elem` fRoleRuls fSpec = [Plain [Math InlineMath "\\odot"]] | otherwise = [] maintained -- (r,rul) `elem` maintained means that r can maintain rul without restrictions. = [ (role,rul) | (role,rul)<-fRoleRuls fSpec , 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) (relsUsedIn rul)) ] roleomissions :: [Block] roleomissions = if null (themes fSpec) && (not.null) (vprocesses fSpec) || (not.null) (themes fSpec) && (not.null) (themes fSpec `isc` [name prc | prc<-vprocesses fSpec]) then [ case fsLang fSpec of Dutch -> Plain [ Str $ upCap (name fSpec)++" kent geen regels aan rollen toe. " , Str "Een generieke rol, User, zal worden gedefinieerd om al het werk te doen wat in het bedrijfsproces moet worden uitgevoerd." ] English -> Plain [ Str $ upCap (name fSpec)++" does not assign rules to roles. " , Str "A generic role, User, will be defined to do all the work that is necessary in the business process." ] | (null.fRoleRuls) fSpec && (not.null.udefrules) fSpec] ++ [ case fsLang fSpec of Dutch -> Plain [ Str $ upCap (name fSpec)++" specificeert niet welke rollen de inhoud van welke relaties mogen wijzigen. " , Str "" ] English -> Plain [ Str $ upCap (name fSpec)++" does not specify which roles may change the contents of which relations. " , Str "" ] | null (fRoleRels fSpec), (not.null.fRoleRuls) fSpec ||(not.null.fRoleRels) fSpec] else [] missingConceptDefs :: [Block] missingConceptDefs = case (fsLang fSpec, missing) of (Dutch,[]) -> [Para [Str "Alle concepten in dit document zijn voorzien van een bestaansreden."] | (not.null.concs) fSpec] (Dutch,[c]) -> [Para [Str "De bestaansreden van concept ", Quoted SingleQuote [Str (name c)], Str " is niet gedocumenteerd."] ] (Dutch,xs) -> [Para $ [Str "De bestaansreden van de concepten: "]++commaNLPandoc (Str "en") (map (Str . name) xs)++[Str " is niet gedocumenteerd."] ] (English,[]) -> [Para [Str "All concepts in this document have been provided with a purpose."] | (not.null.concs) fSpec] (English,[c]) -> [Para [Str "The concept ", Quoted SingleQuote [Str (name c)], Str " remains without a purpose."] ] (English,xs) -> [Para $ [Str "Concepts "]++commaEngPandoc (Str "and") (map (Str . name) xs)++[Str " remain without a purpose."] ] where missing = [c | c <-ccs , cd <- concDefs fSpec c , null (purposesDefinedIn fSpec (fsLang fSpec) cd) ]++ [c | c <-ccs, null (concDefs fSpec c)] 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 (Dutch,[]) -> [Para [Str "Alle conceptdefinities in dit document worden gebruikt in relaties."] | (not.null.cDefsInScope) fSpec] (Dutch,[c]) -> [Para [Str "Het concept ", Quoted SingleQuote [Str (name c)], Str " is gedefinieerd, maar wordt niet gebruikt."] ] (Dutch,xs) -> [Para $ [Str "De concepten: "]++commaNLPandoc (Str "en") (map (Str . name) xs)++[Str " zijn gedefinieerd, maar worden niet gebruikt."] ] (English,[]) -> [Para [Str "All concept definitions in this document are used in relations."] | (not.null.cDefsInScope) fSpec] (English,[c]) -> [Para [Str "The concept ", Quoted SingleQuote [Str (name c)], Str " is defined, but isn't used."] ] (English,xs) -> [Para $ [Str "Concepts "]++commaEngPandoc (Str "and") (map (Str . name) xs)++[Str " are defined, but not used."] ] where unused = [cd | cd <-cDefsInScope fSpec, name cd `notElem` map name (allConcepts fSpec)] missingRels :: [Block] missingRels = case (fsLang fSpec, missing) of (Dutch,[]) -> [Para [Str "Alle relaties in dit document zijn voorzien van een reden van bestaan (purpose)."] | (not.null.relsMentionedIn.udefrules) fSpec] (Dutch,[r]) -> [Para [ Str "De reden waarom relatie ", r , Str " bestaat wordt niet uitgelegd." ] ] (Dutch,rs) -> [Para $ [ Str "Relaties "]++commaNLPandoc (Str "en") rs++ [ Str " zijn niet voorzien van een reden van bestaan (purpose)." ] ] (English,[]) -> [Para [Str "All relations in this document have been provided with a purpose."] | (not.null.relsMentionedIn.udefrules) fSpec] (English,[r]) -> [Para [ Str "The purpose of relation ", r , Str " remains unexplained." ] ] (English,rs) -> [Para $ [ Str "The purpose of relations "]++commaEngPandoc (Str "and") rs++ [ Str " is not documented." ] ] where missing = [(Math InlineMath . showMath) (EDcD d) | d@Sgn{} <- relsInThemes fSpec , null (purposesDefinedIn fSpec (fsLang fSpec) d) ] relsNotUsed :: [Block] pics :: [Picture] (relsNotUsed,pics) = ( ( case (fsLang fSpec, notUsed) of (Dutch,[]) -> [Para [Str "Alle relaties in dit document worden in één of meer regels gebruikt."] | (not.null.relsMentionedIn.udefrules) fSpec] (Dutch,[r]) -> [Para [ Str "De relatie ", r , Str " wordt in geen enkele regel gebruikt. " ] ] (Dutch,rs) -> [Para $ [ Str "Relaties "]++commaNLPandoc (Str "en") rs++ [ Str " worden niet gebruikt in regels. " ] ] (English,[]) -> [Para [Str "All relations in this document are being used in one or more rules."] | (not.null.relsMentionedIn.udefrules) fSpec] (English,[r]) -> [Para [ Str "Relation ", r , Str " is not being used in any rule. " ] ] (English,rs) -> [Para $ [ Str "Relations "]++commaEngPandoc (Str "and") rs++ [ Str " are not used in any rule. " ] ] ) ++ ( case (fsLang fSpec, pictsWithUnusedRels) of (Dutch,[pict]) -> [ Para [ Str "Figuur " , xrefReference pict , Str " geeft een conceptueel diagram met alle relaties." ] , Plain ((toList . showImage flags) pict) ] (English,[pict]) -> [ Para [ Str "Figure " , xrefReference pict , Str " shows a conceptual diagram with all relations." ] , Plain ((toList . showImage flags) pict) ] (Dutch,picts) -> concat [ Para [ Str "Figuur " , xrefReference pict , Str " geeft een conceptueel diagram met alle relaties die gedeclareerd zijn in " , Quoted SingleQuote [Str (name pat)] , Str "." ] : [Plain ((toList . showImage flags) pict)] | (pict,pat)<-zip picts pats ] (English,picts) -> concat [ Para [ Str "Figure " , xrefReference pict , Str " shows a conceptual diagram with all relations declared in " , Quoted SingleQuote [Str (name pat)] , Str "." ] : [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{} <- relsInThemes fSpec -- only signal relations that are used or defined in the selected themes , decusr d , 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) (relsDefdIn pat>-relsUsedIn pat) ] pictsWithUnusedRels = [makePicture flags fSpec (PTDeclaredInPat pat) | pat<-pats ] missingRules :: [Block] missingRules = case (fsLang fSpec, missingPurp, missingMeaning) of (Dutch,[],[]) -> [ Para [Str "Alle regels in dit document zijn voorzien van een uitleg."] | (length.udefrules) fSpec>1] (Dutch,rs,rs') -> [Para (case rs>-rs' of [] -> [] [r] -> [ Str "De bestaansreden van regel ", Emph [Str (name r)] , Str (" op regelnummer "++ln r++" van bestand "++fn r) , Str " wordt niet uitgelegd. " ] rls -> (upC . commaNLPandoc (Str "en") ) [let nrs = [(Str . show . linenr) l | l<-cl] in strconcat ([Str ("op regelnummer"++(if length nrs>1 then "s" else "")++" ")]++ commaNLPandoc (Str "en") nrs++ [Str " van bestand "]++[(Str . locnm . head) cl]) | cl<-eqCl locnm (map origin rls)] ++ [ Str " worden regels gedefinieerd, waarvan de bestaansreden niet wordt uitgelegd. " ] ++ case rs'>-rs of [] -> [] [r] -> [ Str "De betekenis van regel ", Emph [Str (name r)] , Str (" op regelnummer "++ln r++" van bestand "++fn r) , Str " wordt uitgelegd in taal die door de computer is gegenereerd. " ] rls -> (upC . commaNLPandoc (Str "en") ) [let nrs = [(Str . show . linenr) l | l<-cl] in strconcat ([Str ("op regelnummer"++(if length nrs>1 then "s" else "")++" ")]++ commaNLPandoc (Str "en") nrs++ [Str " van bestand "]++[(Str . locnm . head) cl]) | cl<-eqCl locnm (map origin rls)] ++ [ Str " staan regels, waarvan de betekenis wordt uitgelegd in taal die door de computer is gegenereerd. " ] ++ case rs `isc` rs' of [] -> [] [r] -> [ Str "Regel ", Emph [Str (name r)] , Str (" op regelnummer "++ln r++" van bestand "++fn r++" wordt niet uitgelegd. ") ] rls -> (upC . commaNLPandoc (Str "en") ) [let nrs = [(Str . show . linenr) l | l<-cl] in strconcat ([Str ("op regelnummer"++(if length nrs>1 then "s" else "")++" ")]++ commaNLPandoc (Str "en") nrs++ [Str " van bestand "]++[(Str . locnm . head) cl]) | cl<-eqCl locnm (map origin rls)] ++ [ Str " worden regels gedefinieerd, zonder verdere uitleg. " ] ) ] (English,[],[]) -> [ Para [Str "All rules in this document have been provided with a meaning and a purpose."] | (length.udefrules) fSpec>1] (English,rs,rs') -> [Para $ ( case rs>-rs' of [] -> [] [r] -> [ Str "The purpose of rule ", Emph [Str (name r)] , Str (" on line "++ln r++" of file "++fn r) , Str " is not documented. " ] rls -> (upC . commaEngPandoc (Str "and") ) [let nrs = [(Str . show . linenr) l | l<-cl] in strconcat ([ Str ("on line number"++(if length nrs>1 then "s" else "")++" ")]++ commaEngPandoc (Str "and") nrs ++ [Str " of file "]++[(Str . locnm . head) cl]) | cl<-eqCl locnm (map origin rls)] ++ [ Str " rules are defined without documenting their purpose. " ] ) ++ ( case rs'>-rs of [] -> [] [r] -> [ Str "The meaning of rule ", Emph [Str (name r)] , Str (" on line "++ln r++" of file "++fn r) , Str " is documented by means of computer generated language. " ] rls -> (upC . commaEngPandoc (Str "and") ) [let nrs = [(Str . show . linenr) l | l<-cl] in strconcat ([ Str ("on line number"++(if length nrs>1 then "s" else "")++" ")]++ commaEngPandoc (Str "and") nrs ++ [Str " of file "]++[(Str . locnm . head) cl]) | cl<-eqCl locnm (map origin rls)] ++ [ Str " rules are defined, the meaning of which is documented by means of computer generated language. " ] ) ++ ( case rs `isc` rs' of [] -> [] [r] -> [ Str "Rule ", Emph [Str (name r)] , Str (" on line "++ln r++" of file "++fn r++" is not documented. ") ] rls -> (upC . commaEngPandoc (Str "and") ) [let nrs = [(Str . show . linenr) l | l<-cl] in strconcat ([ Str ("on line number"++(if length nrs>1 then "s" else "")++" ")]++ commaEngPandoc (Str "and") nrs ++ [Str " of file "]++[(Str . locnm . head) cl]) | cl<-eqCl locnm (map origin rls)] ++ [ Str " rules are defined without any explanation. " ] ) ] where missingPurp = nub [ r | r<-ruls , null (purposesDefinedIn fSpec (fsLang fSpec) r) ] missingMeaning = nub [ r | r<-ruls , null [m | m <- ameaMrk (rrmean r), amLang m == fsLang fSpec] ] ruls = if null (themes fSpec) 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' fn r = locnm (origin r) ln r = locln (origin r) strconcat :: [Inline] -> Inline strconcat strs = (Str . concat) [ str' | Str str'<-strs] ruleRelationRefTable = [ Para [ Str descriptionStr ] , Table [] (AlignLeft : replicate 6 AlignCenter) [0.0,0.0,0.0,0.0,0.0,0.0,0.0] (map strCell [ themeStr, relationsStr, withRefStr, "%", rulesStr, withRefStr, "%"]) (map mkTableRowPat (vpatterns fSpec) ++ map mkTableRowProc (vprocesses fSpec) ++ [[]] ++ -- empty row [mkTableRow contextStr (filter decusr $ vrels fSpec) (vrules fSpec)]) ] where mkTableRowPat p = mkTableRow (name p) (ptdcs p) (ptrls p) mkTableRowProc (FProc p _) = mkTableRow (name p) (prcDcls p) (prcRules p) mkTableRow nm decls ruls = let nrOfRels = length decls nrOfRefRels = length $ filter hasRef decls nrOfRules = length ruls nrOfRefRules = length $ filter hasRef ruls in map strCell [ nm , show nrOfRels, show nrOfRefRels, showPercentage nrOfRels nrOfRefRels , show nrOfRules, show nrOfRefRules, showPercentage nrOfRules nrOfRefRules ] hasRef x = maybe False (any ((/=[]).explRefIds)) (purposeOf fSpec (fsLang fSpec) x) showPercentage x y = if x == 0 then "-" else show (y*100 `div` x)++"%" strCell strng = [Plain [Str strng]] (descriptionStr, themeStr, relationsStr, withRefStr, rulesStr, contextStr) = case fsLang fSpec of Dutch -> ( "Onderstaande tabel bevat per thema (dwz. proces of patroon) tellingen van het aantal relaties en regels, " ++ "gevolgd door het aantal en het percentage daarvan dat een referentie bevat. Relaties die in meerdere thema's " ++ "gedeclareerd worden, worden ook meerdere keren geteld." , "Thema", "Relaties", "Met referentie", "Regels", "Gehele context") _ -> ( "The table below shows for each theme (i.e. process or pattern) the number of relations and rules, followed " ++ " by the number and percentage that have a reference. Relations declared in multiple themes are counted multiple " ++ " times." , "Theme", "Relations", "With reference", "Rules", "Entire context") locnm (FileLoc(FilePos(filename,_,_))) = filename locnm (DBLoc str') = str' locnm _ = "NO FILENAME" locln (FileLoc(FilePos(_,Pos l _,_))) = show l locln (DBLoc str') = str' locln p = fatal 875 ("funny position "++show p++" in function 'locln'") -- TODO: give richer feedback... invariantsInProcesses :: [Block] invariantsInProcesses = (case (fsLang fSpec, prs, procs) of (_, [],[] ) -> [] (Dutch, [],[p]) -> [ Para [ Str $ "Alle regels in proces "++name p++" zijn gekoppeld aan rollen." ]] (English,[],[p]) -> [ Para [ Str $ "All rules in process "++name p++" are linked to roles." ]] (Dutch, [], _ ) -> [ Para [ Str "Alle regels in alle processen zijn gekoppeld aan rollen." ]] (English,[], _ ) -> [ Para [ Str "All rules in all processes are linked to roles." ]] (Dutch, _ , _ ) -> [ Para [ Str "De volgende tabel toont welke regels in welke processen niet aan een rol gekoppeld zijn. " , Str "Dit heeft als consequentie dat de computer de betreffende regel(s) zal handhaven." ]] (English,_ , _ ) -> [ Para [ Str "The following table shows which rules are not linked to a role within a particular process. " , Str "This has as consequence that these rule(s) will be maintained by the computer." ]] )++ -- the table containing the role-rule assignments [ Table [] [AlignLeft,AlignLeft] [0.0,0.0] ( case fsLang fSpec of Dutch -> [ [Plain [Str "proces" ]] , [Plain [Str "regel"]] ] English -> [ [Plain [Str "process"]] , [Plain [Str "rule" ]] ] ) [ [[Plain [Str (name p)]], [Plain (intercalate [Str ", "] [[Str (name r)] | r<-rs])]] | (p,rs)<-prs ] | not (null prs)] where prs = [(fp,rs) | fp<-procs , let rs=invariants (fpProc fp), not (null rs) ] procs = if null (themes fSpec) then vprocesses fSpec else [prc | prc<-vprocesses fSpec, name prc `elem` themes fSpec ] processrulesInPatterns :: [Block] processrulesInPatterns = [ case (fsLang fSpec, procs,prs) of (Dutch, [p],[]) -> Para [ Str "Alle rol-regel-koppelingen gaan over regels die binnen proces ", Quoted SingleQuote [Str (name p)], Str " gedefinieerd zijn. " ] (English,[p],[]) -> Para [ Str "All role-rule assigments involve rules that are defined in process ", Quoted SingleQuote [Str (name p)], Str ". " ] (Dutch, _,[]) -> Para [ Str "Voor elk proces geldt dat alle rol-regel-koppelingen gaan over regels die binnen dat proces zijn gedefinieerd." ] (English,_,[]) -> Para [ Str "The role-rule assignments in any of the described processes have been assigned to rules within that same process." ] (Dutch, _,[(p,rol,rul)]) -> Para [ Str "Er is één koppeling tussen een rol en een regel van buiten het proces: " , Str "Rol ", Quoted SingleQuote [Str rol], Str " uit proces ", Quoted SingleQuote [Str (name p)], Str " is gebonden aan regel ", Quoted SingleQuote [Str (name rul)], Str " uit ", Quoted SingleQuote [Str (r_env rul)], Str "." ] (English,_,[(p,rol,rul)]) -> Para [ Str "There is one role that is assigned to a rule outside the process: " , Str "Role ", Quoted SingleQuote [Str rol], Str ", defined in process ", Quoted SingleQuote [Str (name p)], Str ", is assigned to rule ", Quoted SingleQuote [Str (name rul)], Str " from ", Quoted SingleQuote [Str (r_env rul)], Str "." ] (Dutch, [p],_) -> Para [ Str "De volgende tabel toont welke regels in welke patterns aan een rol gekoppeld zijn. " , Str "Dit heeft als consequentie dat de computer de betreffende regel(s) in proces ", Quoted SingleQuote [Str (name p)], Str " zal handhaven. " ] (English,[p],_) -> Para [ Str "The following table shows which rules from outside the process are linked to a role in the process. " , Str "This has as consequence that these rule(s) will be maintained in the corresponding process ", Quoted SingleQuote [Str (name p)], Str ". " ] (Dutch, _,_) -> Para [ Str "Er zijn koppelingen tussen rollen en regels, die buiten de grenzen van het proces reiken. " , Str "De volgende tabel toont welke regels in welke patterns aan een rol gekoppeld zijn. " , Str "Dit heeft als consequentie dat de computer de betreffende regel(s) in de bijbehorende processen zal handhaven." ] (English,_,_) -> Para [ Str "There are roles assigned to rules outside the bounds of the process. " , Str "The following table shows which rules that are defined in a pattern are linked to a role within a process." , Str "This has as consequence that these rule(s) will be maintained in the corresponding process(es)." ] | (not.null.vprocesses) fSpec && (not.null) [rra | prc<-procs, rra<-maintains prc] ] ++ -- the table containing the role-rule assignments [ Table [] ([AlignLeft]++[AlignLeft | multProcs]++[AlignLeft,AlignLeft]) ([0.0]++[0.0 | multProcs]++[0.0,0.0]) ( case fsLang fSpec of Dutch -> [[Plain [Str "rol"]] ]++[[Plain [Str "in proces" ]] | multProcs]++[[Plain [Str "regel"]], [Plain [Str "uit" ]] ] English -> [[Plain [Str "role"]]]++[[Plain [Str "in process"]] | multProcs]++[[Plain [Str "rule" ]], [Plain [Str "from" ]] ] ) [ [[Plain [Str rol]]]++[[Plain [Str (name p)]] | multProcs]++[[Plain [Str (name rul)]], [Plain [Str (r_env rul)]]] | (p,rol,rul)<-prs ] | length prs>1] where prs = [(p,rol,rul) | p<-procs, (rol,rul)<-maintains p, name rul `notElem` map name (udefrules p) ] multProcs = length procs>1 procs = [fpProc fp | fp<-vprocesses fSpec , null (themes fSpec) || name fp `elem` themes fSpec] -- restrict if this is partial documentation. -- populationReport :: [Block] -- populationReport -- = [ 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. " ] -- (English,[], _ ) -> [ Str "No relation contains any population. " ] -- (Dutch, [p],[_]) -> [ Str "Relatie ", Math InlineMath ((showMath.popdcl) p), Str " heeft een populatie van ", Str (count Dutch (length (popps p)) "paar"), Str ". " ] -- Every d is typeable, so showMathDamb may be used. -- (English,[p],[_]) -> [ Str "Relation ", Math InlineMath ((showMath.popdcl) p), Str " has ", Str (count English (length (popps p)) "pair"), Str " in its population. " ] -- (Dutch, [p], _ ) -> [ Str "Alleen relatie ", Math InlineMath ((showMath.popdcl) p), Str " heeft een populatie. Deze bevat ", Str (count Dutch (length (popps p)) "paar"), Str ". " ] -- (English,[p], _ ) -> [ Str "Only relation ", Math InlineMath ((showMath.popdcl) p), Str " is populated. It contains ", Str (count English (length (popps p)) "pair"), Str ". " ] -- (Dutch, _ , _ ) -> [ Str "De onderstaande tabel geeft de populatie van de verschillende relaties weer. " ] -- (English, _ , _ ) -> [ Str "The following table represents the population of various relations. " ]) -- ] ++ -- [ Table [] -- [AlignLeft,AlignRight] -- [0.0,0.0] -- (case fsLang fSpec of -- Dutch -> [[Plain [Str "Concept"]], [Plain [Str "Populatie"] ]] -- English -> [[Plain [Str "Concept"]], [Plain [Str "Population"] ]] -- ) -- [ [[Plain [Str (name c)]], [Plain [(Str . show . length . atomsOf) c]]] -- | c<-cs -- ] -- | length cs>=1 ] ++ -- [ Table [] -- [AlignLeft,AlignRight] -- [0.0,0.0] -- (case fsLang fSpec of -- Dutch -> [[Plain [Str "Relatie"]], [Plain [Str "Populatie"] ]] -- English -> [[Plain [Str "Relation"]], [Plain [Str "Population"] ]] -- ) -- [ [[Plain [Math InlineMath ((showMath .popdcl) p)]], [Plain [(Str . show . length . popps) p]]] -- Every d is typeable, so showMathDamb may be used. -- | p<-ps -- ] -- | length ps>1 ] -- where -- ps = [p | p<-initialPops fSpec -- , 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<-relsDefdIn fSpec, null (themes fSpec)||decpat d `elem` themes fSpec] -- restrict if the documentation is partial. wipReport :: [Block] wipReport = [ Para (case (fsLang fSpec, concat popwork,popwork) of (Dutch, [],_) -> [ Str "De populatie in dit script beschrijft geen onderhanden werk. " | (not.null.initialPops) fSpec ] -- SJ 20131212 Is dit correct? Waarom? (English,[],_) -> [ Str "The population in this script does not specify any work in progress. " | (not.null.initialPops) fSpec ] -- SJ 20131212 Is this correct? Why (Dutch, [(r,ps)],_) -> [ Str "Regel ", quoterule r, Str (" laat "++count Dutch (length ps) "taak"++" zien.") ] (English,[(r,ps)],_) -> [ Str "Rule ", quoterule r, Str (" shows "++count English (length ps) "task"++".") ] (Dutch, _,[_]) -> [ Str "Dit script bevat onderhanden werk. De volgende tabel bevat details met regelnummers in het oorspronkelijk script-bestand." ] (English,_,[_]) -> [ Str "This script contains work in progress. The following table provides details with line numbers from the original script file." ] (Dutch, _,_) -> [ Str "Dit script bevat onderhanden werk. De volgende tabellen geven details met regelnummers in de oorspronkelijk script-bestanden." ] (English,_,_) -> [ Str "This script contains work in progress. The following tables provide details with line numbers from the original script files." ] ) ] ++ -- the following table actually belongs to the intro [ Table [] [AlignLeft,AlignRight,AlignRight] [0.0,0.0,0.0] ( case fsLang fSpec of Dutch -> [[Plain [Str "regel"]], [Plain $[Str ((locnm . origin . fst . head) cl++" ") |length popwork>1]++[Str "script",LineBreak,Str "regel#"]], [Plain [Str "#signalen"] ]] English -> [[Plain [Str "rule" ]], [Plain $[Str ((locnm . origin . fst . head) cl++" ") |length popwork>1]++[Str "line#"]], [Plain [Str "#signals"] ]] ) [ [[Plain [Str (name r)]], [Plain [(Str . locln . origin) r]], [Plain [(Str . show . length) ps]]] | (r,ps)<-cl, length ps>0 ] | (length.concat) popwork>1, cl<-popwork ] ++ -- the tables containing the actual work in progress population concat [ [ Para ( (case fsLang fSpec of Dutch -> Str "Regel" English -> Str "Rule"): [Space,quoterule r,Space]++ if xrefSupported flags then [ Str "(", RawInline (Format "latex") $ symReqRef r, Str ") "] else []++ (case fsLang fSpec of Dutch -> [ Str "luidt: " ] English -> [ Str "says: " ] ) )] ++meaning2Blocks (fsLang fSpec) r++ [Plain ( case fsLang fSpec of Dutch -> [ Str "Deze regel bevat nog werk (voor "]++ commaNLPandoc (Str "of") (nub [Str rol | (rol, rul)<-fRoleRuls fSpec, r==rul])++[Str ")"]++ (if length ps == 1 then [Str ", te weten "]++oneviol r ps++[Str ". "] else [ Str (". De volgende tabel laat de "++(if length ps>10 then "eerste tien " else "")++"items zien die aandacht vragen.")] ) English -> [ Str "This rule contains work"]++ commaEngPandoc (Str "or") (nub [Str rol | (rol, rul)<-fRoleRuls fSpec, r==rul])++[Str ")"]++ if length ps == 1 then [Str " by "]++oneviol r ps++[Str ". "] else [ Str ("The following table shows the "++(if length ps>10 then "first ten " else "")++"items that require attention.")] ) ]++ [ violtable r ps | length ps>1] | (r,ps)<-concat popwork ] where -- text r -- = if null expls -- then explains2Blocks (autoMeaning (fsLang fSpec) r) -- else expls -- where expls = [Plain (block++[Space]) | Means l econt<-rrxpl r, l==Just (fsLang fSpec) || l==Nothing, Para block<-econt] quoterule r = if name r=="" then case fsLang fSpec of English -> Str ("on "++show (origin r)) Dutch -> Str ("op "++show (origin r)) else Quoted SingleQuote [Str (name r)] 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,Pairs)]]; popwork = eqCl (locnm.origin.fst) [(r,ps) | (r,ps) <- allViolations fSpec, isSignal r, partofThemes r] partofThemes r = or [ null (themes fSpec) , r `elem` concat [udefrules pat | pat<-patterns fSpec, name pat `elem` themes fSpec] , r `elem` concat [udefrules (fpProc prc) | prc<-vprocesses fSpec, name prc `elem` themes fSpec] ] violationReport :: Blocks violationReport = let (processViolations,invariantViolations) = partition (isSignal.fst) (allViolations fSpec) showViolatedRule :: (Rule,Pairs) -> Blocks showViolatedRule (r,ps) = let capt = case (fsLang fSpec,isSignal r) of (Dutch , False) -> text "Overtredingen van regel "<> text (name r) (English, False) -> text "Violations of rule "<> text (name r) (Dutch , True ) -> text "Openstaande taken voor " <> text (commaNL "of" (nub [rol | (rol, rul)<-fRoleRuls fSpec, r==rul])) (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.srcPaire) p,(para.text.trgPaire) p] in para ( case fsLang fSpec of Dutch -> text "Regel " English -> text "Rule " <> text (name r) ) <> para (text (case (fsLang fSpec,isSignal r) of (Dutch , False) -> "Totaal aantal overtredingen: "++show (length ps) (English, False) -> "Total number of violations: " ++show (length ps) (Dutch , True ) -> "Totaal aantal taken: " ++show (length ps) (English, True ) -> "Total number of work items: " ++show (length ps) ) ) <> table capt [(AlignLeft,0) ,(AlignLeft,0) ] [(para.strong.text.name.source.rrexp) r,(para.strong.text.name.target.rrexp) r] (map showRow ps) in (para (case (fsLang fSpec, invariantViolations, processViolations) of (Dutch ,[] , [] ) -> text "De populatie in dit script overtreedt geen regels. " (English,[] , [] ) -> text "The population in this script violates no rule. " (Dutch ,iVs, pVs) -> text ("De populatie in dit script overtreedt " ++show(length iVs)++" invariant"++(if length iVs == 1 then "" else "en")++" en " ++show(length pVs)++" procesregel"++if length pVs == 1 then "" else "s"++"." ) (English,iVs, pVs) -> text ("The population in this script violates " ++show(length iVs)++" invariant"++(if length iVs == 1 then "" else "s")++" and " ++show(length pVs)++" process rule"++if length pVs == 1 then "" else "s"++"." ) ) ) <> bulletList [showViolatedRule vs | vs<- invariantViolations] <> bulletList [showViolatedRule vs | vs<- processViolations] ---- the table containing the rule violation counts -- [ Table [] -- [AlignLeft,AlignRight,AlignRight] -- [0.0,0.0,0.0] -- ( case fsLang fSpec of -- Dutch -> -- [[Plain [Str "regel"]], [Plain $[Str ((locnm . origin . fst . head) cl++" ") |length popviol>1]++[Str "regel#"]], [Plain [Str "#overtredingen"] ]] -- English -> -- [[Plain [Str "rule" ]], [Plain $[Str ((locnm . origin . fst . head) cl++" ") |length popviol>1]++[Str "line#"]], [Plain [Str "#violations"] ]] -- ) -- [ [[Plain [Str (name r)]], [Plain [(Str . locln . origin) r]], [Plain [(Str . show . length) ps]]] -- | (r,ps)<-cl, length ps>0 -- ] -- | (length.concat) popviol>1, cl<-popviol, not (null cl) ] ++ ---- the table containing the multiplicity counts -- [ Table [] -- [AlignLeft,AlignRight,AlignRight] -- [0.0,0.0,0.0] -- ( case fsLang fSpec of -- Dutch -> -- [[Plain [Str "regel"]], [Plain $[Str ((locnm . origin . fst . head) cl++" ") |length multviol>1]++[Str "regel#"]], [Plain [Str "#overtredingen"] ]] -- English -> -- [[Plain [Str "rule" ]], [Plain $[Str ((locnm . origin . fst . head) cl++" ") |length multviol>1]++[Str "line#"]], [Plain [Str "#violations"] ]] -- ) -- [ [[Plain [Str (name r)]], [Plain [(Str . locln . origin) r]], [Plain [(Str . show . length) ps]]] -- | (r,ps)<-cl, length ps>0 -- ] -- | (length.concat) multviol>1, cl<-multviol, not (null cl) ] ++ -- the tables containing the actual violations of user defined rules -- concat -- [ [ Para ( (case fsLang fSpec of -- Dutch -> Str "Regel" -- English -> Str "Rule"): -- [Space,quoterule r,Space]++ -- if fspecFormat flags==FLatex then [ Str "(", RawInline (Text.Pandoc.Builder.Format "latex") $ symReqRef r, Str ") "] else []++ -- (case fsLang fSpec of -- Dutch -> [ Str "luidt: " ] -- English -> [ Str "says: "]) -- )] ++meaning2Blocks (fsLang fSpec) r++ -- [Plain ( case fsLang fSpec of -- Dutch -> -- Str "Deze regel wordt overtreden": -- (if length ps == 1 then [Str " door "]++oneviol r ps++[Str ". "] else -- [ Str (". De volgende tabel laat de "++if length ps>10 then "eerste tien " else ""++"overtredingen zien.")] -- ) -- English -> -- Str "This rule is violated": -- (if length ps == 1 then [Str " by "]++oneviol r ps++[Str ". "] else -- [ Str ("The following table shows the "++if length ps>10 then "first ten " else ""++"violations.")] -- ) -- )]++ -- [ violtable r ps | length ps>1] -- | (r,ps)<-popviols, length popviols>1 ]++ ---- the tables containing the actual violations of multiplicity rules -- [ BulletList -- [ textMult r++ -- [Plain ( case fsLang fSpec of -- Dutch -> -- if length ps == 1 then [Str "Deze regel wordt overtreden door "]++oneviol r ps++[Str ". "] else -- [ Str ("De volgende tabel laat de "++(if length ps>10 then "eerste tien overtredingen zien." else count Dutch (length ps) ((unCap.name.source)r)++" zien die deze regel overtreden."))] -- -- English -> -- if length ps == 1 then [Str "This rule is violated by "]++oneviol r ps++[Str ". "] else -- [ Str ("The following table shows the "++(if length ps>10 then "first ten violations." else count English (length ps) ((unCap.name.source)r)++" that violate this rule."))] -- -- )]++ -- [ violtable r ps | length ps>1] -- | (r,ps)<-multviols, length multviols>1 ] -- | not (null multviols) ] -- where -- textMult r -- = concat [ [Plain [Str "De relatie ",Space]] -- ++ amPandoc mrkup -- ++ [Plain [Str ".",Space]] -- -- | mrkup <- (ameaMrk . rrmean) r, amLang mrkup==fsLang fSpec] -- quoterule r = if name r=="" -- then Str ("on "++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 _ _ = fatal 810 "oneviol must have a singleton list as argument." -- popviols = [(r,ps) | (r,ps) <- allViolations fSpec, partofThemes r, r_usr r == UserDefined ] -- multviols = [(r,ps) | (r,ps) <- allViolations fSpec, partofThemes r, not (r_usr r == UserDefined)] -- popviols = [(r,ps) | r<-invs++identityRs -- , let ps=ruleviolations r, not (null ps)] -- multviols = [(r,ps) | r<-mults -- , let ps=ruleviolations r, not (null ps)] -- popviol :: [[(Rule,[(String, String)])]] -- popviol = eqCl (locnm.origin.fst) [(r,ps) | r<-invs, let ps=ruleviolations r, not (null ps)] -- multviol :: [[(Rule,[(String, String)])]] -- multviol = eqCl (locnm.origin.fst) [(r,ps) | r<-mults, let ps=ruleviolations r, not (null ps)] -- invs = if null (themes fSpec) -- then invariants fSpec -- else concat [invariants pat | pat<-patterns fSpec, name pat `elem` themes fSpec]++ -- concat [invariants (fpProc prc) | prc<-vprocesses fSpec, name prc `elem` themes fSpec] -- mults = if null (themes fSpec) -- then multrules fSpec -- else concat [multrules pat | pat<-patterns fSpec, name pat `elem` themes fSpec]++ -- concat [multrules (fpProc prc) | prc<-vprocesses fSpec, name prc `elem` themes fSpec] -- identityRs = if null (themes fSpec) -- then identityRules fSpec -- 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 (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 (srcPaire p)]], [Plain [Str (trgPaire p)]]] | p <-take 10 ps ]