diff --git a/.travis.yml b/.travis.yml index 2b7d32e9ac..8b72d514ab 100644 --- a/.travis.yml +++ b/.travis.yml @@ -136,14 +136,14 @@ install: - | case "$BUILD" in stack) - ./travis_long `# guarantee that something is written to output every minute, so travis doesn't stop premature` \ + ./travis_long `# guarantee that something is written to output every minute, so Travis doesn't stop prematurely` \ stack build `# build is the common task which is composable.` \ --test `# run the tests` \ --copy-bins `# install executables to the path` \ - --haddock `# create haddock documentation, thus ensuring that haddock parse rules are enforsed.` \ - --no-terminal `# fixes bug with sticky output on travis` \ + --haddock `# create haddock documentation, thus ensuring that haddock parse rules are enforced.` \ + --no-terminal `# fixes bug with sticky output on Travis` \ $ARGS `#` \ - --flag ampersand:buildAll `# build all executables of ampersand` + --flag ampersand:buildAll `# build all executables of Ampersand` ;; cabal) cabal --version diff --git a/README.md b/README.md index 29ceb05380..7d40a0ceac 100644 --- a/README.md +++ b/README.md @@ -1,7 +1,7 @@ # Ampersand [![Build Status](https://travis-ci.org/AmpersandTarski/Ampersand.svg?branch=master)](https://travis-ci.org/AmpersandTarski/Ampersand) -[![Build status](https://ci.appveyor.com/api/projects/status/ai0pwvb7corwkjjm?svg=true)](https://ci.appveyor.com/project/hanjoosten/ampersand) +[![Build status](https://ci.appveyor.com/api/projects/status/9stn8mx3w8vsbt2r?svg=true)](https://ci.appveyor.com/project/Ampersand-Sentinel/ampersand) [![Latest Release](https://img.shields.io/github/release/AmpersandTarski/Ampersand.svg)](https://github.com/AmpersandTarski/Ampersand/releases/latest) ## Releases diff --git a/ReleaseNotes.md b/ReleaseNotes.md index 426115ff45..4c812d8fa8 100644 --- a/ReleaseNotes.md +++ b/ReleaseNotes.md @@ -1,5 +1,11 @@ # Release notes of Ampersand +## v4.0.1 (19 june 2020) + +* [Issue #1026](https://github.com/AmpersandTarski/Ampersand/issues/1026) Allow PATTERNs with the same name. Meaning: all declarations from patterns with the same name are merged into one. +* [Issue #1081](https://github.com/AmpersandTarski/Ampersand/issues/1081) Disable invariant checking for documentation. +* [Issue #988](https://github.com/AmpersandTarski/Ampersand/issues/988) Add switch to disable warnings with `ampersand daemon` command + ## v4.0.0 (23 may 2020) * Refactor Docker image for Ampersand compiler @@ -8,9 +14,9 @@ * [Issue #1029](https://github.com/AmpersandTarski/Ampersand/issues/1029) Fixed detection of rules with same name. * [Issue #1047](https://github.com/AmpersandTarski/Ampersand/issues/1047) Non-existing directory is generated automagically when required for output. * [Issue #999](https://github.com/AmpersandTarski/Ampersand/issues/999) Treat all concepts in a cycle in CLASSIFY statements as aliases of a single concept. -* [Issue #1056](https://github.com/AmpersandTarski/Ampersand/issues/#1056) Bugfix in .xlsx parser -* [Issue #1054](https://github.com/AmpersandTarski/Ampersand/issues/#1054) Ampersand daemon now also reports type errors -* [Issue #1063](https://github.com/AmpersandTarski/Ampersand/issues/#1063) Return violations of invariants with standard check +* [Issue #1056](https://github.com/AmpersandTarski/Ampersand/issues/1056) Bugfix in .xlsx parser +* [Issue #1054](https://github.com/AmpersandTarski/Ampersand/issues/1054) Ampersand daemon now also reports type errors +* [Issue #1063](https://github.com/AmpersandTarski/Ampersand/issues/1063) Return violations of invariants with standard check * [Issue #735](https://github.com/AmpersandTarski/Ampersand/issues/735) Upgrade to pandoc 2.9. * Remove option --skip-composer. Relates to topic of [Archicture of Ampersand compiler](https://github.com/AmpersandTarski/Ampersand/issues/903) diff --git a/package.yaml b/package.yaml index 540ce98cd7..65aac59669 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: ampersand -version: 4.0.0 +version: 4.0.1 author: Stef Joosten maintainer: stef.joosten@ou.nl synopsis: Toolsuite for automated design of enterprise information systems. @@ -7,7 +7,7 @@ description: You can define your business processes by means of rules, writte homepage: http://ampersandtarski.github.io/ category: Database Design stability: alpha -tested-with: GHC == 8.6.5 +tested-with: GHC == 8.8.3 build-type: Custom license: GPL license-file: LICENSE diff --git a/src/Ampersand/ADL1/P2A_Converters.hs b/src/Ampersand/ADL1/P2A_Converters.hs index 32fb76ce34..ea5dc69fcb 100644 --- a/src/Ampersand/ADL1/P2A_Converters.hs +++ b/src/Ampersand/ADL1/P2A_Converters.hs @@ -243,15 +243,15 @@ pCtx2aCtx env } = do contextInfo <- g_contextInfo -- the minimal amount of data needed to transform things from P-structure to A-structure. let declMap = declDisambMap contextInfo - uniqueNames p_patterns + -- uniqueNames "pattern" p_patterns -- Unclear why this restriction was in place. So I removed it pats <- traverse (pPat2aPat contextInfo) p_patterns -- The patterns defined in this context - uniqueNames $ p_rules <> concatMap pt_rls p_patterns + uniqueNames "rule" $ p_rules <> concatMap pt_rls p_patterns rules <- traverse (pRul2aRul contextInfo Nothing) p_rules -- All user defined rules in this context, but outside patterns - uniqueNames $ p_identdefs <> concatMap pt_ids p_patterns + uniqueNames "identity definition" $ p_identdefs <> concatMap pt_ids p_patterns identdefs <- traverse (pIdentity2aIdentity contextInfo Nothing) p_identdefs -- The identity definitions defined in this context, outside the scope of patterns - uniqueNames $ p_viewdefs <> concatMap pt_vds p_patterns + uniqueNames "view definition" $ p_viewdefs <> concatMap pt_vds p_patterns viewdefs <- traverse (pViewDef2aViewDef contextInfo) p_viewdefs -- The view definitions defined in this context, outside the scope of patterns - uniqueNames p_interfaces + uniqueNames "interface" p_interfaces interfaces <- traverse (pIfc2aIfc contextInfo) (p_interfaceAndDisambObjs declMap) -- TODO: explain ... The interfaces defined in this context, outside the scope of patterns purposes <- traverse (pPurp2aPurp contextInfo) p_purposes -- The purposes of objects defined in this context, outside the scope of patterns udpops <- traverse (pPop2aPop contextInfo) p_pops -- [Population] @@ -709,7 +709,7 @@ pCtx2aCtx env P_Box{} -> addWarnings warnings $ build <$> traverse (join . fmap fn . typecheckObjDef ci) l - <* uniqueNames l -- ensure that each label in a box has a unique name. + <* uniqueNames "label in box" l -- ensure that each label in a box has a unique name. <* mustBeObject (target objExpr) where l :: [P_BoxItem (TermPrim, DisambPrim)] l = si_box x diff --git a/src/Ampersand/ADL1/PrettyPrinters.hs b/src/Ampersand/ADL1/PrettyPrinters.hs index 4b60ac6e99..2834c6fddf 100644 --- a/src/Ampersand/ADL1/PrettyPrinters.hs +++ b/src/Ampersand/ADL1/PrettyPrinters.hs @@ -129,7 +129,7 @@ instance Pretty P_Pattern where <+\> perline vds <+\> perline xps <+\> perline pop - <+> text "ENDPATTERN" + <+\> text "ENDPATTERN" instance Pretty P_Relation where pretty (P_Sgn nm sign prps pragma mean _) = @@ -334,9 +334,7 @@ instance Pretty P_Concept where pretty P_ONE = text "ONE" instance Pretty P_Sign where - pretty (P_Sign src tgt) = brackets (pretty src <> maybeTgt) - where maybeTgt = if src == tgt then empty - else text "*" <> pretty tgt + pretty (P_Sign src tgt) = brackets (pretty src <> text "*" <> pretty tgt) instance Pretty PClassify where pretty p = diff --git a/src/Ampersand/Core/ParseTree.hs b/src/Ampersand/Core/ParseTree.hs index b973180cc1..3f58c3dab5 100644 --- a/src/Ampersand/Core/ParseTree.hs +++ b/src/Ampersand/Core/ParseTree.hs @@ -215,7 +215,7 @@ data P_Relation = -- It is easy to see that if the locations are the same, then the relations must be the same. -- But is that true all the time? ... No. If one or both origins are unknown, we revert to comparing name and signature. -- This is still not true for MEATGRINDER stuff! - +-- So, -- DO NOT USE ORD and EQ on P_Relation! instance Named P_Relation where name = dec_nm @@ -579,7 +579,7 @@ newtype PMeaning = PMeaning P_Markup newtype PMessage = PMessage P_Markup deriving Show data P_Markup = - P_Markup { mLang :: Maybe Lang + P_Markup { mLang :: Maybe Lang , mFormat :: Maybe PandocFormat , mString :: Text } deriving (Show,Eq) -- for debugging only diff --git a/src/Ampersand/Daemon/Parser.hs b/src/Ampersand/Daemon/Parser.hs index f7ee17528b..2cd07bbca8 100644 --- a/src/Ampersand/Daemon/Parser.hs +++ b/src/Ampersand/Daemon/Parser.hs @@ -15,22 +15,26 @@ import qualified RIO.NonEmpty as NE import Ampersand.FSpec.MetaModels import Ampersand.Types.Config import Ampersand.Options.FSpecGenOptsParser +import Ampersand.Misc.HasClasses (HasDaemonOpts(..), showWarningsL) -- | parseProject will try to parse a file. If it succeeds, it will -- also parse all INCLUDED files transitive. All of these parses could -- fail. It will return a tuple containing the Loads and a list of -- the filepaths that are read. -parseProject :: (HasRunner env) => +parseProject :: (HasDaemonOpts env, HasRunner env) => FilePath -> RIO env ([Load],[FilePath]) parseProject rootAdl = do + env1 <- ask let fSpecGenOpts = defFSpecGenOpts rootAdl extendWith fSpecGenOpts $ do (pc,gPctx) <- parseFileTransitive rootAdl - env <- ask + env2 <- ask let loadedFiles = map pcCanonical pc - gActx = join $ pCtx2Fspec env <$> gPctx + gActx = join $ pCtx2Fspec env2 <$> gPctx return ( case gActx of - Checked _ ws -> map warning2Load $ ws + Checked _ ws + | view showWarningsL env1 -> map warning2Load ws + | otherwise -> [] Errors es -> NE.toList . fmap error2Load $ es , loadedFiles ) diff --git a/src/Ampersand/FSpec/ToFSpec/CreateFspec.hs b/src/Ampersand/FSpec/ToFSpec/CreateFspec.hs index baf80ccc0b..8ea358e291 100644 --- a/src/Ampersand/FSpec/ToFSpec/CreateFspec.hs +++ b/src/Ampersand/FSpec/ToFSpec/CreateFspec.hs @@ -107,9 +107,9 @@ cook :: (HasFSpecGenOpts env) => -> Map MetaModel GrindInfo -- ^ A map containing all GrindInfo that could be required -> Guarded P_Context -- ^ The original user's P_Context, Guarded because it might have errors -> Guarded P_Context -cook env (BuildRecipe start steps) grindInfoMap user = +cook env (BuildRecipe start steps) grindInfoMap userScript = join $ doSteps <$> case start of - UserScript -> user + UserScript -> userScript MetaScript mm -> pure . pModel $ gInfo mm where doSteps :: P_Context -> Guarded P_Context @@ -120,7 +120,7 @@ cook env (BuildRecipe start steps) grindInfoMap user = case step of EncloseInConstraints -> pure $ encloseInConstraints ctx Grind mm -> grind (gInfo mm) <$> (pCtx2Fspec env ctx) - MergeWith recipe -> mergeContexts ctx <$> cook env recipe grindInfoMap user + MergeWith recipe -> mergeContexts ctx <$> cook env recipe grindInfoMap userScript gInfo :: MetaModel -> GrindInfo gInfo mm = case Map.lookup mm grindInfoMap of Just x -> x diff --git a/src/Ampersand/Graphic/Graphics.hs b/src/Ampersand/Graphic/Graphics.hs index 1ef3ece0ee..09d96bc6a1 100644 --- a/src/Ampersand/Graphic/Graphics.hs +++ b/src/Ampersand/Graphic/Graphics.hs @@ -281,7 +281,7 @@ instance ReferableFromPandoc Picture where extention = case view fspecFormatL env of Fpdf -> "png" -- If Pandoc makes a PDF file, the pictures must be delivered in .png format. .pdf-pictures don't seem to work. - Fdocx -> "svg" -- If Pandoc makes a .docx file, the pictures are delivered in .svg format for scalable rendering in MS-word. + Fdocx -> "png" -- If Pandoc makes a .docx file, the pictures are delivered in .svg format for scalable rendering in MS-word. Fhtml -> "png" _ -> "pdf" diff --git a/src/Ampersand/Input/ADL1/CtxError.hs b/src/Ampersand/Input/ADL1/CtxError.hs index ff526a8edb..b149643800 100644 --- a/src/Ampersand/Input/ADL1/CtxError.hs +++ b/src/Ampersand/Input/ADL1/CtxError.hs @@ -8,7 +8,7 @@ module Ampersand.Input.ADL1.CtxError , cannotDisambiguate , mustBeOrdered, mustBeOrderedLst, mustBeOrderedConcLst , mustBeBound - , GetOneGuarded(..), uniqueNames, uniqueBy + , GetOneGuarded(..), uniqueNames , unexpectedType , mkErrorReadingINCLUDE , mkDanglingPurposeError @@ -246,22 +246,26 @@ cannotDisambiguate o x = Errors . pure $ CTXE (origin o) message EDcD rel -> " ("<>tshow (origin rel)<>")" EFlp e' -> showA' e' _ -> "" +-- | Rules, identity statements, view definitions, interfaces, and box labels +-- need unique names. The `nameclass` ("rule", "interface", etc.) is used to +-- provide a more meaningful error message. uniqueNames :: (Named a, Traced a) => - [a] -> Guarded () -uniqueNames = uniqueBy name -uniqueBy :: (Traced a, Show b, Ord b) => (a -> b) -> [a] -> Guarded () -uniqueBy fun a = case (filter moreThanOne . groupWith fun) a of - [] -> pure () - x:xs -> Errors . fmap messageFor $ x NE.:| xs - where - moreThanOne (_:_:_) = True - moreThanOne _ = False - messageFor (x:xs) = CTXE (origin x) - ("Names / labels must be unique. "<>(tshow . fun) x<>", however, is used at:" - <> T.intercalate ("\n ") (map (tshow . origin) (x:xs)) - <> "." - ) - messageFor _ = fatal "messageFor must only be used on lists with more that one element!" + Text -> [a] -> Guarded () +uniqueNames nameclass = uniqueBy name + where + uniqueBy :: (Traced a, Show b, Ord b) => (a -> b) -> [a] -> Guarded () + uniqueBy fun a = case (filter moreThanOne . groupWith fun) a of + [] -> pure () + x:xs -> Errors . fmap messageFor $ x NE.:| xs + where + messageFor (x:xs) = CTXE (origin x) + ("Every "<>nameclass<>" must have a unique name. "<>(tshow . fun) x<>", however, is used at:" + <> T.intercalate ("\n ") (map (tshow . origin) (x:xs)) + <> "." + ) + messageFor _ = fatal "messageFor must only be used on lists with more that one element!" + moreThanOne (_:_:_) = True + moreThanOne _ = False mkDanglingPurposeError :: Purpose -> CtxError mkDanglingPurposeError p = CTXE (origin p) $ "Purpose refers to non-existent " <> showA (explObj p) diff --git a/src/Ampersand/Input/Archi/ArchiAnalyze.hs b/src/Ampersand/Input/Archi/ArchiAnalyze.hs index 3f000c4c09..fb29bdcd4d 100644 --- a/src/Ampersand/Input/Archi/ArchiAnalyze.hs +++ b/src/Ampersand/Input/Archi/ArchiAnalyze.hs @@ -5,10 +5,16 @@ Description : Interprets an ArchiMate(r) repository as Ampersand context. Maintainer : stef.joosten@ou.nl Stability : experimental -The purpose of this module is to load Archimate content into an Ampersand context. +The purpose of this module is to load ArchiMate content into an Ampersand context. This module parses an Archi-repository by means of function `archi2PContext`, which produces a `P_Context` for merging into Ampersand. -That `P_Context` contains both the Archimate-metamodel (in the form of declarations) and the Archimate population that represents the model. -In this way, `archi2PContext ` deals with the fact that Archimate produces a mix of model and metamodel. +That `P_Context` contains both the ArchiMate-metamodel (in the form of declarations) and the ArchiMate population that represents the model. +In this way, `archi2PContext ` deals with the fact that ArchiMate produces a mix of model and metamodel. + +It works as follows: +1. A parser transforms an Archi-file (*.archimate) to a Haskell data structure of type ArchiRepo. +2. A grinder, grindArchi, turns this data structure in relations, populations and patterns to assemble a metamodel of the ArchiMate repository. This yields a context. +3. This context is absorbed as though it were a separate file, so it can be included into another Ampersand script by the statement: + INCLUDE ".archimate" -} module Ampersand.Input.Archi.ArchiAnalyze (archi2PContext) where @@ -24,42 +30,46 @@ import qualified RIO.List as L import qualified RIO.Text as T import Text.XML.HXT.Core hiding (utf8, fatal,trace) +-- Auxiliary +fst4 :: (a, b, c, d) -> a +fst4 (x,_,_,_) = x + -- | Function `archi2PContext` is meant to grind the contents of an Archi-repository into declarations and population inside a fresh Ampersand P_Context. -- The process starts by parsing an XML-file by means of function `processStraight` into a data structure called `archiRepo`. This function uses arrow-logic from the HXT-module. -- The resulting data structure contains the folder structure of the tool Archi (https://github.com/archimatetool/archi) and represents the model-elements and their properties. --- A lookup-function, `elemLookup`,is derived from `archiRepo`. +-- A lookup-function, `typeLookup`,is derived from `archiRepo`. -- It assigns the Archi-type (e.g. Business Process) to the identifier of an arbitrary Archi-object (e.g. "0957873"). -- Then, the properties have to be provided with identifiers (see class `WithProperties`), because Archi represents them just as key-value pairs. -- The function `grindArchi` retrieves the population of meta-relations --- It produces the P_Populations and P_Declarations that represent the Archimate model. +-- It produces the P_Populations and P_Declarations that represent the ArchiMate model. -- Finally, the function `mkArchiContext` produces a `P_Context` ready to be merged into the rest of Ampersand's population. archi2PContext :: (HasLogFunc env) => FilePath -> RIO env (Guarded P_Context) archi2PContext archiRepoFilename -- e.g. "CArepository.archimate" = do -- hSetEncoding stdout utf8 archiRepo <- liftIO $ runX (processStraight archiRepoFilename) - let fst3 (x,_,_) = x - let elemLookup atom = (Map.lookup atom . Map.fromList . typeMap) archiRepo - let archiRepoWithProps = (grindArchi elemLookup.identifyProps []) archiRepo - let relPops = (filter (not.null.p_popps) . sortRelPops . map fst3) archiRepoWithProps - let cptPops = (filter (not.null.p_popas) . sortCptPops . map fst3) archiRepoWithProps + let typeLookup atom = (Map.lookup atom . typeMap Nothing) archiRepo + let archiRepoWithProps = (grindArchi (Nothing,typeLookup,Nothing) . identifyProps []) archiRepo + let relPops = (filter (not.null.p_popps) . sortRelPops . map fst4) archiRepoWithProps + let cptPops = (filter (not.null.p_popas) . sortCptPops . map fst4) archiRepoWithProps let elemCount archiConcept = (Map.lookup archiConcept . Map.fromList . atomCount . atomMap) relPops let countPop :: P_Population -> Text countPop pop = let sig = ((\(Just sgn)->sgn).p_mbSign.p_nmdr) pop in - (tshow.length.p_popps) pop <>"\t"<> - (p_nrnm.p_nmdr) pop <>"\t"<> - (p_cptnm.pSrc) sig <>"\t"<> + (tshow.length.p_popps) pop <>"\t"<> + (p_nrnm.p_nmdr) pop <>"\t"<> + (p_cptnm.pSrc) sig <>"\t"<> (tshow.length.eqCl ppLeft.p_popps) pop <>"\t"<> - (showMaybeInt.elemCount.pSrc) sig <>"\t"<> - (p_cptnm.pTgt) sig <>"\t"<> + (showMaybeInt.elemCount.pSrc) sig <>"\t"<> + (p_cptnm.pTgt) sig <>"\t"<> (tshow.length.eqCl ppRight.p_popps) pop <>"\t"<> (showMaybeInt.elemCount.pTgt) sig + -- logInfo (displayShow archiRepo<>"\n") -- for debugging writeFileUtf8 "ArchiCount.txt" (T.intercalate "\n" $ (fmap countPop relPops) <> ((fmap showArchiElems) . atomCount . atomMap $ relPops<>cptPops) ) logInfo ("ArchiCount.txt written") - return (mkArchiContext archiRepoWithProps) + return (mkArchiContext archiRepo archiRepoWithProps) where sortRelPops, sortCptPops :: [P_Population] -> [P_Population] -- assembles P_Populations with the same signature into one sortRelPops pops = [ (NE.head cl){p_popps = foldr L.union [] [p_popps decl | decl<-NE.toList cl]} | cl<-eqClass samePop [pop | pop@P_RelPopu{}<-pops] ] sortCptPops pops = [ (NE.head cl){p_popas = foldr L.union [] [p_popas cpt | cpt <-NE.toList cl]} | cl<-eqClass samePop [pop | pop@P_CptPopu{}<-pops] ] @@ -90,89 +100,188 @@ samePop pop@P_RelPopu{} pop'@P_RelPopu{} _ -> fatal ("Cannot compare partially defined populations of\n"<>tshow nr<>" and\n"<>tshow nr') samePop pop@P_CptPopu{} pop'@P_CptPopu{} = p_cpt pop == p_cpt pop' samePop _ _ = False +sameRel :: P_Relation -> P_Relation -> Bool +sameRel rel rel' = dec_nm rel==dec_nm rel' && dec_sign rel==dec_sign rel' +samePurp :: PPurpose -> PPurpose -> Bool +samePurp prp prp' = mString (pexMarkup prp)==mString (pexMarkup prp') + +{- reminder +data PPurpose = PRef2 { pos :: Origin -- the position in the Ampersand script of this purpose definition + , pexObj :: PRef2Obj -- the reference to the object whose purpose is explained + , pexMarkup:: P_Markup -- the piece of text, including markup and language info + , pexRefIDs :: [Text] -- the references (for traceability) + } deriving Show + +-} -- | Function `mkArchiContext` defines the P_Context that has been constructed from the ArchiMate repo -mkArchiContext :: [(P_Population,Maybe P_Relation,[PClassify])] -> Guarded P_Context -mkArchiContext pops = pure - PCtx{ ctx_nm = "Archimate" +mkArchiContext :: [ArchiRepo] -> [(P_Population,P_Relation,Maybe Text,PPurpose)] -> Guarded P_Context +mkArchiContext [archiRepo] pops = pure + PCtx{ ctx_nm = archRepoName archiRepo , ctx_pos = [] , ctx_lang = Just Dutch -- fatal "No language because of Archi-import hack. Please report this as a bug" , ctx_markup = Nothing - , ctx_pats = [] + , ctx_pats = pats , ctx_rs = [] - , ctx_ds = (fmap NE.head . eqCl nameSign) [ ad | Just ad<-archiDecls ] + , ctx_ds = archiDecls , ctx_cs = [] , ctx_ks = [] , ctx_rrules = [] , ctx_reprs = [] , ctx_vs = [] - , ctx_gs = L.nub (concat archiGenss) + , ctx_gs = [] , ctx_ifcs = [] - , ctx_ps = [] - , ctx_pops = sortRelPops archiPops <> sortCptPops archiPops + , ctx_ps = archiPurps + , ctx_pops = archiPops , ctx_metas = [] } - where archiPops :: [P_Population] - archiDecls :: [Maybe P_Relation] - archiGenss :: [[PClassify]] - (archiPops, archiDecls, archiGenss) = L.unzip3 pops - sortRelPops, sortCptPops :: [P_Population] -> [P_Population] -- assembles P_Populations with the same signature into one - sortRelPops popus = [ (NE.head cl){p_popps = foldr L.union [] [p_popps decl | decl<-NE.toList cl]} | cl<-eqClass samePop [pop | pop@P_RelPopu{}<-popus] ] - sortCptPops popus = [ (NE.head cl){p_popas = foldr L.union [] [p_popas cpt | cpt <-NE.toList cl]} | cl<-eqClass samePop [pop | pop@P_CptPopu{}<-popus] ] - nameSign decl = (name decl, dec_sign decl) + where -- vwAts picks triples that belong to one view, to assemble a pattern for that view. + vwAts :: ArchiObj -> [(P_Population,P_Relation,Maybe Text,PPurpose)] + vwAts vw@View{} + = [ (pop,rel,v,purp) + | (pop,rel,v,purp)<-pops + , participatingRel rel + , dec_nm rel `L.notElem` ["inside","inView"] + , PPair _ (ScriptString _ x) _<-p_popps pop + , x `Set.member` viewAtoms + ] + where viewAtoms + = Set.fromList + [ a + | (pop,rel,Just viewname,_)<-pops, viewname==viewName vw + , participatingRel rel + , PPair _ (ScriptString _ x) (ScriptString _ y)<-p_popps pop + , a<-[x,y] + ] + vwAts _ = fatal "May not call vwAts on a non-view element" + + participatingRel :: P_Relation -> Bool + participatingRel rel = pSrc (dec_sign rel) `L.notElem` map PCpt ["Relationship","Property","View"] + -- viewpoprels contains all triples that are picked by vwAts, for all views, + -- to compute the triples that are not assembled in any pattern. + viewpoprels :: [(P_Population,P_Relation,Maybe Text,PPurpose)] + viewpoprels = removeDoubles + [ popRelVw + | folder<-allFolders archiRepo + , vw@View{}<-fldObjs folder + , popRelVw<-vwAts vw] + removeDoubles :: [(P_Population,P_Relation,Maybe Text,PPurpose)] -> [(P_Population,P_Relation,Maybe Text,PPurpose)] + removeDoubles = map NE.head . eqCl (Set.fromList . p_popps . fst4) + -- to compute the left-over triples, we must use L.deleteFirstsBy because we do not have Ord P_Population. + leftovers = L.deleteFirstsBy f pops viewpoprels + where f (pop,_,_,_) (pop',_,_,_) = Set.fromList (p_popps pop)==Set.fromList (p_popps pop') + archiPops :: [P_Population] + archiPops = sortRelPops -- The populations that are local to this pattern + [ pop | (pop,_,_,_)<-leftovers ] + archiDecls :: [P_Relation] + archiDecls = sortDecls -- The relations that are declared in this pattern + [ rel | (_,rel,_,_)<-leftovers ] + archiPurps = sortPurps -- The relations that are declared in this pattern + [ purp | (_,_,_,purp)<-leftovers ] + pats + = [ P_Pat { pos = OriginUnknown -- the starting position in the file in which this pattern was declared. + , pt_nm = viewName vw -- Name of this pattern + , pt_rls = [] -- The user defined rules in this pattern + , pt_gns = [] -- The generalizations defined in this pattern + , pt_dcs = sortDecls rels -- The relations that are declared in this pattern + , pt_RRuls = [] -- The assignment of roles to rules. + , pt_cds = [] -- The concept definitions defined in this pattern + , pt_Reprs = [] -- The type into which concepts is represented + , pt_ids = [] -- The identity definitions defined in this pattern + , pt_vds = [] -- The view definitions defined in this pattern + , pt_xps = purps -- The purposes of elements defined in this pattern + , pt_pop = sortRelPops popus -- The populations that are local to this pattern + , pt_end = OriginUnknown -- the end position in the file in which this pattern was declared. + } + | folder<-allFolders archiRepo + , vw@View{}<-fldObjs folder + , let (popus,rels,_,purps) = L.unzip4 (vwAts vw) + ] + + sortRelPops :: [P_Population] -> [P_Population] -- assembles P_Populations with the same signature into one + sortRelPops popus = [ (NE.head cl){p_popps = foldr L.union [] [p_popps decl | decl<-NE.toList cl]} + | cl<-eqClass samePop [pop | pop@P_RelPopu{}<-popus] ] + sortDecls :: [P_Relation] -> [P_Relation] -- assembles P_Relations with the same signature into one + sortDecls decls = [ NE.head cl | cl<-eqClass sameRel decls ] + sortPurps :: [PPurpose] -> [PPurpose] -- assembles P_Relations with the same signature into one + sortPurps purps = [ NE.head cl | cl<-eqClass samePurp purps ] +mkArchiContext _ _ = fatal "Something dead-wrong with mkArchiContext." -- The following code defines a data structure (called ArchiRepo) that corresponds to an Archi-repository in XML. -- | `data ArchiRepo` represents an entire ArchiMate repository in one Haskell data structure. data ArchiRepo = ArchiRepo - { archRepoName :: Text - , archRepoId :: Text + { archRepoId :: Text + , archRepoName :: Text , archFolders :: [Folder] , archProperties :: [ArchiProp] , archPurposes :: [ArchiPurpose] } deriving (Show, Eq) +-- | Where 'archFolders' gives the top level folders, allFolders provides all subfolders as well. +allFolders :: ArchiRepo -> [Folder] +allFolders = concat . map recur . archFolders + where + recur :: Folder -> [Folder] + recur fld = fld : (concat . map recur . fldFolders) fld + -- | `data Folder` represents the folder structure of the ArchiMate Tool. data Folder = Folder - { fldName :: Text -- the name of the folder - , fldId :: Text -- the Archi-id (e.g. "b12f3af5") - , fldType :: Text -- the xsi:type of the folder - , fldLevel :: Int -- the nesting level: 0=top level, 1=subfolder, 2=subsubfolder, etc. - , fldElems :: [Element] -- the elements in the current folder, without the subfolders - , fldFolders :: [Folder] -- the subfolders - } deriving (Show, Eq) - --- | `data Element` represents every ArchiMate element in the ArchiMate repo -data Element = Element - { elemType :: Text - , elemId :: Text - , elemName :: Text - , elemSrc :: Text - , elemTgt :: Text - , elemAccTp :: Text - , elemDocu :: Text - , elChilds :: [Child] - , elProps :: [ArchiProp] - , elDocus :: [ArchiDocu] + { fldName :: Text -- the name of the folder + , fldId :: Text -- the Archi-id (e.g. "b12f3af5") + , fldType :: Text -- the xsi:type of the folder + , fldLevel :: Int -- the nesting level: 0=top level, 1=subfolder, 2=subsubfolder, etc. + , fldObjs :: [ArchiObj] -- the elements in the current folder, without the subfolders + , fldFolders :: [Folder] -- the subfolders } deriving (Show, Eq) --- | Children occur in views only. +-- | `data ArchiObj` represents every ArchiMate element in the ArchiMate repo +data ArchiObj + = Element + { elemId :: Text + , elemName :: Text + , elemType :: Text + , elemDocu :: Text + , elemProps :: [ArchiProp] + , elemDocus :: [ArchiDocu] + } + | Relationship + { relId :: Text + , relName :: Text + , relType :: Text + , relDocu :: Text + , relProps :: [ArchiProp] + , relDocus :: [ArchiDocu] + , relSrc :: Text + , relTgt :: Text + , relAccTp :: Text + } + | View + { viewId :: Text + , viewName :: Text + -- , viewType :: Text -- this is always "archimate:ArchimateDiagramModel" in Archi + , viewDocu :: Text + , viewProps :: [ArchiProp] + , viewDocus :: [ArchiDocu] + , viewPoint :: Text + , viewChilds :: [Child] + } + deriving (Show, Eq) + +-- | We do not analyze all information that is available in views. +-- Still, the omitted information is written below, but commented out so you can follow the structure in the ArchiMate-file. data Child = Child - { chldType :: Text - , chldId :: Text - , chldAlgn :: Text - , chldFCol :: Text - , chldElem :: Text - , trgtConn :: Text - , bound :: Bound + { +-- chldType :: Text +--, chldId :: Text +--, chldAlgn :: Text +--, chldFCol :: Text + chldElem :: Text +--, trgtConn :: Text +--, bound :: Bound , srcConns :: [SourceConnection] , childs :: [Child] } deriving (Show, Eq) -data Relation = Relation - { relType :: Text - , relHref :: Text - } deriving (Show, Eq) - data Bound = Bound { bnd_x :: Text , bnd_y :: Text @@ -181,21 +290,24 @@ data Bound = Bound } deriving (Show, Eq) data SourceConnection = SrcConn - { sConType :: Text - , sConId :: Text - , sConSrc :: Text - , sConTgt :: Text - , sConRel :: Text - , sConRelat :: [Relation] - , sCbendPts :: [BendPoint] + { +-- sConType :: Text, +-- sConId :: Text, +-- sConSrc :: Text, +-- sConTgt :: Text, + sConRel :: Text +-- sConRelat :: [Relation], +-- sCbendPts :: [BendPoint] } deriving (Show, Eq) +{- data BendPoint = BendPt { bpStartX :: Text , bpStartY :: Text , bpEndX :: Text , bpEndY :: Text } deriving (Show, Eq) +-} data ArchiProp = ArchiProp { archPropId :: Maybe Text @@ -213,10 +325,10 @@ data ArchiDocu = ArchiDocu -- | The class WithProperties is defined to generate keys for properties, -- to be inserted in the grinding process. --- Properties in Archimate have no identifying key. +-- Properties in ArchiMate have no identifying key. -- The only data structures with properties in the inner structure of Archi -- (i.e. in the repository minus the Views) are folders and elements. --- In Ampersand, that key is necessary to get objects that represent an Archimate-property. +-- In Ampersand, that key is necessary to get objects that represent an ArchiMate-property. -- For this reason, the types ArchiRepo, Folder, and Element are instances -- of class WithProperties. class WithProperties a where @@ -237,20 +349,25 @@ instance WithProperties ArchiRepo where propIds = drop len identifiers instance WithProperties Folder where - allProps folder = allProps (fldElems folder) <> allProps (fldFolders folder) + allProps folder = allProps (fldObjs folder) <> allProps (fldFolders folder) identifyProps identifiers folder = folder - { fldElems = identifyProps elemsIdentifiers (fldElems folder) + { fldObjs = identifyProps elemsIdentifiers (fldObjs folder) , fldFolders = identifyProps foldersIdentifiers (fldFolders folder) } where - elemsIdentifiers = take ((length.allProps.fldElems) folder) identifiers - foldersIdentifiers = drop ((length.allProps.fldElems) folder) identifiers - -instance WithProperties Element where - allProps element = elProps element --- <> allProps (elChilds element) -- children are not (yet) being analyzed, so we skip the elChilds of the element. - identifyProps identifiers element = element - { elProps = [ prop{archPropId=Just propId} | (propId,prop)<- zip identifiers (elProps element) ] } + elemsIdentifiers = take ((length.allProps.fldObjs) folder) identifiers + foldersIdentifiers = drop ((length.allProps.fldObjs) folder) identifiers + +instance WithProperties ArchiObj where + allProps element@Element{} = elemProps element + allProps relation@Relationship{} = relProps relation + allProps vw@View{} = viewProps vw + identifyProps identifiers element@Element{} = element + { elemProps = [ prop{archPropId=Just propId} | (propId,prop)<- zip identifiers (elemProps element) ] } + identifyProps identifiers relation@Relationship{} = relation + { relProps = [ prop{archPropId=Just propId} | (propId,prop)<- zip identifiers (relProps relation) ] } + identifyProps identifiers vw@View{} = vw + { viewProps = [ prop{archPropId=Just propId} | (propId,prop)<- zip identifiers (viewProps vw) ] } instance WithProperties a => WithProperties [a] where allProps xs = concatMap allProps xs @@ -269,223 +386,167 @@ instance WithProperties a => WithProperties [a] where -- we must grind that contents into binary tables. For that purpose, we define the -- class MetaArchi, and instantiate it on ArchiRepo and all its constituent types. class MetaArchi a where - typeMap :: a -> [(Text,Text)] -- the map that determines the type (xsi:type) of every atom (id-field) in the repository - grindArchi :: (Text->Maybe Text) -> a -> -- create population and the corresponding metamodel for the P-structure in Ampersand - [(P_Population, Maybe P_Relation, [PClassify])] - keyArchi :: a -> Text -- get the key value (dirty identifier) of an a. + typeMap :: Maybe Text -> a -> Map Text Text -- the map that determines the type (xsi:type) of every atom (id-field) in the repository + -- grindArchi takes two parameters: + -- 1. the view name (Maybe Text), just used when scanning inside a view to link an ArchiMate object to a view; + -- 2. a lookup function (Text->Maybe Text) called typeLookup, that looks up the type of an ArchiMate object. E.g. typeLookup ("702221af-2740-46e2-a0ae-c64d0226ff95") = "BusinessRole" + grindArchi :: (Maybe Text,Text->Maybe Text,Maybe Text) -> a -> -- create population and the corresponding metamodel for the P-structure in Ampersand + [(P_Population, P_Relation,Maybe Text,PPurpose)] instance MetaArchi ArchiRepo where - typeMap archiRepo - = typeMap [ folder | folder<-archFolders archiRepo, fldName folder/="Views"] <> - (typeMap.archProperties) archiRepo - grindArchi elemLookup archiRepo - = [ translateArchiObj "purpose" "ArchiRepo" - [(keyArchi archiRepo, archPurpVal purp) | purp<-archPurposes archiRepo] + typeMap _ archiRepo + = typeMap Nothing (archFolders archiRepo) + grindArchi env archiRepo + = [ translateArchiElem "name" ("ArchiRepo","Text") Nothing (Set.singleton Uni) + [(archRepoId archiRepo, archRepoName archiRepo)] + ] <> + [ translateArchiElem "purpose" ("ArchiRepo","Text") Nothing (Set.singleton Uni) + [(archRepoId archiRepo, archPurpVal purp) | purp<-archPurposes archiRepo] | (not.null.archPurposes) archiRepo ] <> - (concat.map (grindArchi elemLookup)) backendFolders <> - (concat.map (grindArchi elemLookup).archProperties) archiRepo - where backendFolders = [ folder | folder<-archFolders archiRepo, fldName folder/="Views"] - keyArchi = archRepoId + [ translateArchiElem "propOf" ("Property", "ArchiRepo") Nothing (Set.singleton Uni) [(propid, archRepoId archiRepo)] + | prop<-archProperties archiRepo, Just propid<-[archPropId prop]] <> + (concat . map (grindArchi env)) (archFolders archiRepo) <> + (concat . map (grindArchi env) . archProperties) archiRepo instance MetaArchi Folder where - typeMap folder - = (typeMap.fldElems) folder <> - (typeMap.fldFolders) folder - grindArchi elemLookup folder - = [ translateArchiObj "folderName" "ArchiFolder" [(keyArchi folder, fldName folder)]] <> - [ translateArchiObj "type" "ArchiFolder" [(keyArchi folder, fldType folder)]] <> - [ translateArchiObj "level" "ArchiFolder" [(keyArchi folder, (tshow.fldLevel) folder)]] <> - [ translateArchiObj "sub" "ArchiFolder" - [(keyArchi subFolder, keyArchi folder) | subFolder<-fldFolders folder] - | (not.null.fldFolders) folder ] <> - [ translateArchiObj "in" "ArchiFolder" - [(keyArchi element, keyArchi folder) | element<-fldElems folder] - | (not.null.fldElems) folder ] <> - [ translateArchiObj "cat" (elemType element) [(keyArchi element, fldName folder)] - | fldLevel folder>1, element<-fldElems folder] <> - [ translateArchiObj "archiLayer" (elemType element) - [(keyArchi element, fldType folder)] - | element<-fldElems folder] <> - [ translateArchiObj "inFolder" (fldName folder) - [(keyArchi element, fldName folder)] - | element<-fldElems folder] <> - (concat.map (grindArchi elemLookup) .fldElems) folder <> - (concat.map (grindArchi elemLookup.insType folder).fldFolders) folder - keyArchi = fldId - --- | If a folder has a fldType, all subfolders without a type are meant to have the same fldType. --- For this purpose, the fldType is transported recursively to subfolders. -insType :: Folder -> Folder -> Folder -insType super sub - = case (fldType super, fldType sub) of - ("",_) -> sub - (ftyp,"") -> sub{fldType=ftyp} - _ -> sub + typeMap _ folder + = (typeMap Nothing . fldObjs) folder <> + (typeMap Nothing . fldFolders) folder + grindArchi env folder + = (concat . map (grindArchi env) . fldObjs) folder <> + (concat . map (grindArchi env) . fldFolders) folder -- A type map is constructed for Archi-objects only. Taking relationships into this map brings Archi into higher order logic, and may cause black holes in Haskell. -instance MetaArchi Element where - typeMap element - = [(keyArchi element, elemType element) | (not.T.null.elemName) element, (T.null.elemSrc) element] <> - typeMap (elProps element) - grindArchi elemLookup element - = [ translateArchiObj "name" (elemType element) [(keyArchi element, elemName element)] - | (not . T.null . elemName) element, (T.null . elemSrc) element] <> - [ translateArchiObj "docu" (elemType element) [(keyArchi element, elemDocu element)] -- documentation in the XML-tag - | (not . T.null . elemDocu) element, (T.null . elemSrc) element] <> - [ translateArchiObj "docu" (elemType element) [(keyArchi element, archDocuVal eldo)] -- documentation with tags. - | eldo<-elDocus element] <> - (if isRelationship element then translateArchiRel elemLookup element else [] ) <> - [ translateArchiObj "accessType" (elemType element) [(keyArchi element, elemAccTp element)] - | (not . T.null . elemAccTp) element] <> - [ translateArchiObj "elprop" (elemType element) [(keyArchi prop, keyArchi element)] - | prop<-elProps element] <> - (concat.map (grindArchi elemLookup).elProps) element - keyArchi = elemId - --- | Function `isRelationship` can tell whether this XML-element is an Archimate Relationship. -isRelationship :: Element -> Bool -isRelationship element = (not . T.null . elemSrc) element +instance MetaArchi ArchiObj where + typeMap maybeViewName element@Element{} + = Map.fromList [(elemId element, elemType element)] <> + typeMap maybeViewName (elemProps element) + typeMap maybeViewName relation@Relationship{} + = Map.fromList [(relId relation, "Relationship")] <> + typeMap maybeViewName (relProps relation) + typeMap _ diagram@View{} + = Map.fromList [(viewId diagram, "View") | (not.T.null.viewName) diagram] <> + typeMap (Just (viewName diagram)) (viewProps diagram) + grindArchi env@(_,_,maybeViewname) element@Element{} + = [ translateArchiElem "name" (elemType element,"Text") maybeViewname (Set.singleton Uni) [(elemId element, elemName element)] + | (not . T.null . elemName) element] <> + [ translateArchiElem "docu" (elemType element,"Text") maybeViewname (Set.singleton Uni) [(elemId element, elemDocu element)] -- documentation in the XML-tag + | (not . T.null . elemDocu) element] <> + [ translateArchiElem "docu" (elemType element,"Text") maybeViewname (Set.singleton Uni) [(elemId element, archDocuVal eldo)] -- documentation with tags. + | eldo<-elemDocus element] <> + [ translateArchiElem "propOf" ("Property", "ArchiObject") maybeViewname (Set.singleton Uni) [(propid, elemId element)] + | prop<-elemProps element, Just propid<-[archPropId prop]] <> + (concat.map (grindArchi env).elemProps) element + grindArchi env@(_,typeLookup,maybeViewname) relation@Relationship{} + = [ translateArchiElem relLabel (xType,yType) maybeViewname (Set.empty) [(relSrc relation,relTgt relation)]] <> + [ translateArchiElem "name" ("Relationship","Text") maybeViewname (Set.singleton Uni) [(relId relation, relLabel)]] <> + [ translateArchiElem "type" ("Relationship","Text") maybeViewname (Set.singleton Uni) [(relId relation, relTyp)]] <> + [ translateArchiElem "source" ("Relationship",xType) maybeViewname (Set.singleton Uni) [(relId relation, relSrc relation)]] <> + [ translateArchiElem "target" ("Relationship",yType) maybeViewname (Set.singleton Uni) [(relId relation, relTgt relation)]] <> + [ translateArchiElem "docu" ("Relationship","Text") maybeViewname (Set.singleton Uni) [(relId relation, relDocu relation)] -- documentation in the XML-tag + | (not . T.null . relDocu) relation] <> + [ translateArchiElem "docu" ("Relationship","Text") maybeViewname (Set.singleton Uni) [(relId relation, archDocuVal reldo)] -- documentation with tags. + | reldo<-relDocus relation] <> + [ translateArchiElem "accessType" ("Relationship","AccessType") maybeViewname (Set.singleton Uni) [(relId relation, relAccTp relation)] + | (not . T.null . relAccTp) relation] <> + [ translateArchiElem "propOf" ("Property", "Relationship") maybeViewname (Set.singleton Uni) [(propid, relId relation)] + | prop<-relProps relation, Just propid<-[archPropId prop]] <> + (concat.map (grindArchi env).relProps) relation + where + relTyp = (relCase . unFix . relType) relation -- the relation type, e.g. "access" + relLabel = case relTyp of + "association" + -> if T.null (relName relation) + then relTyp + else relCase (relName relation) -- the name given by the user, e.g. "create/update" + _ -> relTyp + xType = case typeLookup (relSrc relation) of + Just str -> str + Nothing -> fatal ("No Archi-object found for Archi-identifier "<>tshow (relSrc relation)) + yType = case typeLookup (relTgt relation) of + Just str -> str + Nothing -> fatal ("No Archi-object found for Archi-identifier "<>tshow (relTgt relation)) + grindArchi (_, typeLookup,_) diagram@View{} + = [ translateArchiElem "name" ("View","Text") maybeViewName (Set.singleton Uni) [(viewId diagram, viewName diagram)] + | (not . T.null . viewName) diagram] <> + [ translateArchiElem "propOf" ("Property", "View") maybeViewName (Set.singleton Uni) [(propid, viewId diagram)] + | prop<-viewProps diagram, Just propid<-[archPropId prop]] <> + [ translateArchiElem "docu" ("View","Text") maybeViewName (Set.singleton Uni) [(viewId diagram, viewDocu diagram)] -- documentation in the XML-tag + | (not . T.null . viewDocu) diagram] <> + [ translateArchiElem "docu" ("View","Text") maybeViewName (Set.singleton Uni) [(viewId diagram, archDocuVal viewdoc)] -- documentation with tags. + | viewdoc<-viewDocus diagram] <> + [ translateArchiElem "inView" (chldType,"View") maybeViewName (Set.empty) [(chldElem viewelem, viewId diagram)] -- register the views in which an element is used. + | viewelem<-viewChilds diagram, Just chldType<-[typeLookup (chldElem viewelem)]] <> + [ translateArchiElem "viewpoint" ("View","ViewPoint") maybeViewName (Set.singleton Uni) [(viewId diagram, viewPoint diagram)] -- documentation with tags. + | (not . T.null . viewPoint) diagram] <> + (concat . map (grindArchi (Nothing,typeLookup,maybeViewName)) . viewProps) diagram <> + (concat . map (grindArchi (Just (viewId diagram),typeLookup,maybeViewName)) . viewChilds) diagram + where maybeViewName = Just (viewName diagram) + +instance MetaArchi Child where + typeMap _ _ + = Map.empty + grindArchi env@(Just viewid,typeLookup,maybeViewName) diagrObj + = [ translateArchiElem "inView" (elType,viewtype) maybeViewName (Set.empty) [(chldElem child,viewid)] + | child<-childs diagrObj, Just elType<-[typeLookup (chldElem child)], Just viewtype<-[typeLookup viewid]] <> + [ translateArchiElem "inView" (connType,viewtype) maybeViewName (Set.empty) [(sConRel conn,viewid)] + | conn<-srcConns diagrObj, Just connType<-[typeLookup (sConRel conn)], Just viewtype<-[typeLookup viewid]] <> + [ translateArchiElem "inside" (childtype,objtype) maybeViewName (Set.empty) [(chldElem child,chldElem diagrObj)] + | child<-childs diagrObj, Just childtype<-[typeLookup (chldElem child)], Just objtype<-[typeLookup (chldElem diagrObj)]] <> + (concat.map (grindArchi env).childs) diagrObj + grindArchi (maybeViewid,_,maybeViewName) _ = fatal ("\nmaybeViewid = "<>tshow maybeViewid<>"\nmaybeViewName = "<>tshow maybeViewName) instance MetaArchi ArchiProp where - typeMap _ - = [] - grindArchi _ property - = [ translateArchiObj "key" "Property" - [(keyArchi property, archPropKey property) | (not . T.null . archPropKey) property ] - , translateArchiObj "value" "Property" - [(keyArchi property, archPropVal property) | (not . T.null . archPropVal) property ] + typeMap _ property + = Map.fromList [ (propid, "Property") | Just propid<-[archPropId property] ] + grindArchi (_,_,maybeViewname) property + = [ translateArchiElem "key" ("Property","Text") maybeViewname (Set.singleton Uni) + [(propid, archPropKey property) + | (not . T.null . archPropKey) property, Just propid<-[archPropId property] ] + , translateArchiElem "value" ("Property","Text") maybeViewname (Set.singleton Uni) + [(propid, archPropVal property) + | (not . T.null . archPropVal) property, Just propid<-[archPropId property] ] ] - keyArchi = fromMaybe (error "fatal: No key defined yet") . archPropId instance MetaArchi a => MetaArchi [a] where - typeMap xs = concat [ typeMap x | x<-xs ] - grindArchi elemLookup xs = concat [ grindArchi elemLookup x | x<-xs ] - keyArchi = error "fatal: cannot use keyArchi on a list" + typeMap maybeViewName xs = Map.unions [ typeMap maybeViewName x | x<-xs ] + grindArchi typeLookup xs = concat [ grindArchi typeLookup x | x<-xs ] --- | The function `translateArchiObj` does the actual compilation of data objects from archiRepo into the Ampersand structure. +-- | The function `translateArchiElem` does the actual compilation of data objects from archiRepo into the Ampersand structure. -- It looks redundant to produce both a `P_Population` and a `P_Relation`, but the first contains the population and the second is used to --- include the metamodel of Archimate in the population. This saves the author the effort of maintaining an Archimate-metamodel. -translateArchiObj :: Text -> Text -> [(Text, Text)] -> (P_Population,Maybe P_Relation,[PClassify]) -translateArchiObj "purpose" "ArchiRepo" tuples - = ( P_RelPopu Nothing Nothing OriginUnknown (PNamedRel OriginUnknown "purpose" (Just (P_Sign (PCpt "ArchiFolder") (PCpt "Tekst")))) (transTuples tuples) - , Just $ P_Sgn "purpose" (P_Sign (PCpt "ArchiFolder") (PCpt "Tekst")) (Set.fromList [Uni]) [] [] OriginUnknown, [] ) -translateArchiObj "folderName" _ tuples - = ( P_RelPopu Nothing Nothing OriginUnknown (PNamedRel OriginUnknown "name" (Just (P_Sign (PCpt "ArchiFolder") (PCpt "FolderName")))) (transTuples tuples) - , Just $ P_Sgn "name" (P_Sign (PCpt "ArchiFolder") (PCpt "FolderName")) (Set.fromList [Uni]) [] [] OriginUnknown, [] ) -translateArchiObj "name" typeLabel tuples - = ( P_RelPopu Nothing Nothing OriginUnknown (PNamedRel OriginUnknown "name" (Just (P_Sign (PCpt typeLabel) (PCpt "Tekst")))) (transTuples tuples) - , Just $ P_Sgn "name" (P_Sign (PCpt typeLabel) (PCpt "Tekst")) (Set.fromList [Uni]) [] [] OriginUnknown, [] ) -translateArchiObj "type" typeLabel tuples - = ( P_RelPopu Nothing Nothing OriginUnknown (PNamedRel OriginUnknown "type" (Just (P_Sign (PCpt typeLabel) (PCpt "Tekst")))) (transTuples tuples) - , Just $ P_Sgn "type" (P_Sign (PCpt typeLabel) (PCpt "Tekst")) (Set.fromList [Uni]) [] [] OriginUnknown, [] ) -translateArchiObj "level" _ tuples - = ( P_RelPopu Nothing Nothing OriginUnknown (PNamedRel OriginUnknown "level" (Just (P_Sign (PCpt "ArchiFolder") (PCpt "Tekst")))) (transTuples tuples) - , Just $ P_Sgn "level" (P_Sign (PCpt "ArchiFolder") (PCpt "Tekst")) (Set.fromList [Uni]) [] [] OriginUnknown, [] ) -translateArchiObj "sub" typeLabel tuples - = ( P_RelPopu Nothing Nothing OriginUnknown (PNamedRel OriginUnknown "sub" (Just (P_Sign (PCpt typeLabel) (PCpt typeLabel)))) (transTuples tuples) - , Just $ P_Sgn "sub" (P_Sign (PCpt typeLabel) (PCpt typeLabel)) (Set.fromList []) [] [] OriginUnknown, [] ) -translateArchiObj "in" _ tuples - = ( P_RelPopu Nothing Nothing OriginUnknown (PNamedRel OriginUnknown "folder" (Just (P_Sign (PCpt "ArchiObject") (PCpt "ArchiFolder")))) (transTuples tuples) - , Just $ P_Sgn "folder" (P_Sign (PCpt "ArchiObject") (PCpt "ArchiFolder")) (Set.fromList [Uni]) [] [] OriginUnknown, [] ) -translateArchiObj "cat" typeLabel tuples - = ( P_RelPopu Nothing Nothing OriginUnknown (PNamedRel OriginUnknown "inFolderName" (Just (P_Sign (PCpt typeLabel) (PCpt "FolderName")))) (transTuples tuples) - , Just $ P_Sgn "inFolderName" (P_Sign (PCpt typeLabel) (PCpt "FolderName")) (Set.fromList [Uni]) [] [] OriginUnknown, [] ) -translateArchiObj "docu" typeLabel tuples - = ( P_RelPopu Nothing Nothing OriginUnknown (PNamedRel OriginUnknown "documentation" (Just (P_Sign (PCpt typeLabel) (PCpt "Tekst")))) (transTuples tuples) - , Just $ P_Sgn "documentation" (P_Sign (PCpt typeLabel) (PCpt "Tekst")) (Set.fromList [Uni]) [] [] OriginUnknown, [] ) -translateArchiObj "inFolder" typeLabel tuples - = ( P_RelPopu Nothing Nothing OriginUnknown (PNamedRel OriginUnknown "inFolder" (Just (P_Sign (PCpt typeLabel) (PCpt "ArchiObject")))) (transTuples tuples) - , Just $ P_Sgn "inFolder" (P_Sign (PCpt typeLabel) (PCpt "ArchiObject")) (Set.fromList [Uni]) [] [] OriginUnknown, [] ) -translateArchiObj "key" "Property" tuples - = ( P_RelPopu Nothing Nothing OriginUnknown (PNamedRel OriginUnknown "key" (Just (P_Sign (PCpt "Property") (PCpt "Tekst")))) (transTuples tuples) - , Just $ P_Sgn "key" (P_Sign (PCpt "Property") (PCpt "Tekst")) (Set.fromList [Uni]) [] [] OriginUnknown, [] ) -translateArchiObj "value" "Property" tuples - = ( P_RelPopu Nothing Nothing OriginUnknown (PNamedRel OriginUnknown "value" (Just (P_Sign (PCpt "Property") (PCpt "Tekst")))) (transTuples tuples) - , Just $ P_Sgn "value" (P_Sign (PCpt "Property") (PCpt "Tekst")) (Set.fromList [Uni]) [] [] OriginUnknown, [] ) -translateArchiObj "elprop" _ tuples - = ( P_RelPopu Nothing Nothing OriginUnknown (PNamedRel OriginUnknown "propOf" (Just (P_Sign (PCpt "Property") (PCpt "ArchiObject")))) (transTuples tuples) - , Just $ P_Sgn "propOf" (P_Sign (PCpt "Property") (PCpt "ArchiObject")) (Set.fromList [Uni]) [] [] OriginUnknown, [] ) -translateArchiObj "archiLayer" typeLabel tuples - = ( P_RelPopu Nothing Nothing OriginUnknown (PNamedRel OriginUnknown "archiLayer" (Just (P_Sign (PCpt typeLabel) (PCpt "ArchiLayer")))) (transTuples tuples) - , Just $ P_Sgn "archiLayer" (P_Sign (PCpt typeLabel) (PCpt "ArchiLayer")) (Set.fromList [Uni]) [] [] OriginUnknown, [] ) -translateArchiObj "accessType" typeLabel tuples - = ( P_RelPopu Nothing Nothing OriginUnknown (PNamedRel OriginUnknown "accessType" (Just (P_Sign (PCpt typeLabel) (PCpt "AccessType")))) (transTuples tuples) - , Just $ P_Sgn "accessType" (P_Sign (PCpt typeLabel) (PCpt "AccessType")) (Set.fromList [Uni]) [] [] OriginUnknown, [] ) -translateArchiObj a b c = error ("!fatal: non-exhaustive pattern in translateArchiObj\ntranslateArchiObj "<> show a<>" "<>show b<>" "<>show c) - --- | Purpose: To generate relationships from archiRepo as elements the Ampersand P-structure --- | Pre: isRelationship element -translateArchiRel :: (Text -> Maybe Text) -> Element -> [(P_Population, Maybe P_Relation, [PClassify])] -translateArchiRel elemLookup element - = [ ( P_RelPopu Nothing Nothing OriginUnknown (PNamedRel OriginUnknown relNm (Just (P_Sign (PCpt xType) (PCpt yType)))) (transTuples [(x,y)]) - , Just $ P_Sgn relNm (P_Sign (PCpt xType) (PCpt yType)) (Set.fromList []) [] [] OriginUnknown - , [] - ) - , ( P_RelPopu Nothing Nothing OriginUnknown (PNamedRel OriginUnknown "source" (Just (P_Sign (PCpt "Relationship") (PCpt "ArchiObject")))) (transTuples [(relId,x)]) - , Just $ P_Sgn "source" (P_Sign (PCpt "Relationship") (PCpt "ArchiObject")) (Set.fromList [Uni]) [] [] OriginUnknown - , [] -- [ PGen OriginUnknown (PCpt xType) (PCpt "ArchiObject") ] - ) - , ( P_RelPopu Nothing Nothing OriginUnknown (PNamedRel OriginUnknown "isa" (Just (P_Sign (PCpt xType) (PCpt "ArchiObject")))) (transTuples [(x,x)]) - , Just $ P_Sgn "isa" (P_Sign (PCpt xType) (PCpt "ArchiObject")) (Set.fromList [Uni,Inj]) [] [] OriginUnknown - , [] - ) - , ( P_RelPopu Nothing Nothing OriginUnknown (PNamedRel OriginUnknown "target" (Just (P_Sign (PCpt "Relationship") (PCpt "ArchiObject")))) (transTuples [(relId,y)]) - , Just $ P_Sgn "target" (P_Sign (PCpt "Relationship") (PCpt "ArchiObject")) (Set.fromList [Uni]) [] [] OriginUnknown - , [] -- [ PGen OriginUnknown (PCpt yType) (PCpt "ArchiObject") ] - ) - , ( P_RelPopu Nothing Nothing OriginUnknown (PNamedRel OriginUnknown "isa" (Just (P_Sign (PCpt yType) (PCpt "ArchiObject")))) (transTuples [(y,y)]) - , Just $ P_Sgn "isa" (P_Sign (PCpt yType) (PCpt "ArchiObject")) (Set.fromList [Uni,Inj]) [] [] OriginUnknown - , [] - ) - ] <> - [ ( P_CptPopu { pos = OriginUnknown - , p_cpt = PCpt relTyp - , p_popas = [ScriptString OriginUnknown relId] - } - , Nothing - , [ PClassify - { pos = OriginUnknown - , specific = PCpt relTyp -- specific concept - , generics = PCpt "Relationship" NE.:| [] -- generic concepts - } ] - ) - | relTyp/="Relationship" ] <> - [ ( P_RelPopu Nothing Nothing OriginUnknown (PNamedRel OriginUnknown "datatype" (Just (P_Sign (PCpt "Relationship") (PCpt "Tekst")))) (transTuples [(relId,relLabel)]) - , Just $ P_Sgn "datatype" (P_Sign (PCpt "Relationship") (PCpt "Tekst")) (Set.fromList [Uni]) [] [] OriginUnknown - , [] - ) - | xType=="ApplicationComponent" && yType=="ApplicationComponent" ] - where - relId = keyArchi element -- the key from Archi, e.g. "693" - relTyp = elemType element -- the relation type, e.g. "AccessRelationship" - relLabel = if (T.null . elemName) element - then unfixRel (elemType element) - else relCase (elemName element) -- the name given by the user, e.g. "create/update" - (x,y) = (elemSrc element, elemTgt element) - xType = case elemLookup x of - Just str -> str - Nothing -> fatal ("No Archi-object found for Archi-identifier "<>tshow x) - yType = case elemLookup y of - Just str -> str - Nothing -> fatal ("No Archi-object found for Archi-identifier "<>tshow y) - relNm = relCase relLabel -- <>"["<>xType<>"*"<>yType<>"]" - --- | Function `unfixRel` is used to generate Ampersand keys from Archimate identifiers. --- It removes a trailing `R` and whatever comes after it. -unfixRel :: Text -> Text -unfixRel = T.reverse . T.drop 1 . T.dropWhile (/='R') . T.reverse . relCase +-- include the metamodel of ArchiMate in the population. This saves the author the effort of maintaining an ArchiMate-metamodel. +translateArchiElem :: Text -> (Text, Text) -> Maybe Text -> Set.Set Prop-> [(Text, Text)] + -> (P_Population,P_Relation,Maybe Text,PPurpose) +translateArchiElem label (srcLabel,tgtLabel) maybeViewName props tuples + = ( P_RelPopu Nothing Nothing OriginUnknown ref_to_relation (transTuples tuples) + , P_Sgn label (P_Sign (PCpt srcLabel) (PCpt tgtLabel)) props [] [] OriginUnknown + , maybeViewName + , PRef2 { pos = OriginUnknown -- the position in the Ampersand script of this purpose definition + , pexObj = PRef2Relation ref_to_relation -- the reference to the object whose purpose is explained + , pexMarkup = P_Markup Nothing Nothing "To embody the ArchiMate metamodel" -- the piece of text, including markup and language info + , pexRefIDs = [] -- the references (for traceability) + } + ) + where + ref_to_relation :: P_NamedRel + ref_to_relation = PNamedRel OriginUnknown label (Just (P_Sign (PCpt srcLabel) (PCpt tgtLabel))) + +-- | Function `relCase` is used to generate relation identifiers that are syntactically valid in Ampersand. relCase :: Text -> Text -relCase txt' = case T.uncons txt' of +relCase str = case T.uncons str of Nothing -> fatal "fatal empty relation identifier." - Just (c,cs) -> T.cons (toLower c) cs + Just (c,cs) -> escapeIdentifier . T.cons (toLower c) $ cs + +-- | Function `unFix` is used to remove the "Relationship" suffix, which is specific to Archi. +unFix :: Text -> Text +unFix str = if "Relationship" `T.isSuffixOf` str + then (T.reverse . T.drop 12 . T.reverse) str else str +-- | Function `transTuples` is used to save ourselves some writing effort transTuples :: [(Text, Text)] -> [PAtomPair] transTuples tuples = [ PPair OriginUnknown (ScriptString OriginUnknown x) (ScriptString OriginUnknown y) - | (x,y)<-tuples - , (not.T.null) x - , (not.T.null) y - ] + | (x,y)<-tuples ] -- | The function `processStraight` derives an ArchiRepo from an Archi-XML-file. processStraight :: FilePath -> IOSLA (XIOState s0) XmlTree ArchiRepo @@ -505,32 +566,83 @@ processStraight absFilePath analArchiRepo :: ArrowXml a => a XmlTree ArchiRepo analArchiRepo = (atTag "archimate:model"<+>atTag "archimate:ArchimateModel") >>> - proc l -> do repoNm' <- getAttrValue "name" -< l - repoId' <- getAttrValue "id" -< l - purposes' <- listA (getChildren >>> getPurpose) -< l - folders' <- listA (getChildren >>> getFolder 0) -< l - props' <- listA (getChildren >>> getProp) -< l - returnA -< ArchiRepo { archRepoName = T.pack repoNm' - , archRepoId = T.pack repoId' - , archFolders = folders' - , archProperties = [ prop{archPropId=Just $ "pr-"<>tshow i} | (prop,i)<- zip props' [length (allProps folders')..] ] - , archPurposes = purposes' - } + proc l -> do repoNm <- getAttrValue "name" -< l + repoId <- getAttrValue "id" -< l + purposes <- listA (getChildren >>> getPurpose) -< l + folders <- listA (getChildren >>> getFolder 0) -< l + props <- listA (getChildren >>> getProp) -< l + returnA -< ArchiRepo { archRepoName = T.pack repoNm + , archRepoId = T.pack repoId + , archFolders = folders + , archProperties = [ prop{archPropId=Just $ "pr-"<>tshow i} | (prop,i)<- zip props [length (allProps folders)..] ] + , archPurposes = purposes + } + getFolder :: ArrowXml a => Int -> a XmlTree Folder getFolder level = isElem >>> (hasName "folder"<+>hasName "folders") >>> - proc l -> do fldNm' <- getAttrValue "name" -< l - fldId' <- getAttrValue "id" -< l - fldType' <- getAttrValue "type" -< l - elems' <- listA (getChildren >>> getElement) -< l - subFlds' <- listA (getChildren >>> getFolder (level+1)) -< l - returnA -< Folder { fldName = T.pack fldNm' - , fldId = T.pack fldId' - , fldType = T.pack fldType' - , fldLevel = level - , fldElems = elems' - , fldFolders = subFlds' - } + proc l -> do fldNm' <- getAttrValue "name" -< l + fldId' <- getAttrValue "id" -< l + fldType' <- getAttrValue "type" -< l + objects <- listA (getChildren >>> getArchiObj) -< l + subFlds <- listA (getChildren >>> getFolder (level+1)) -< l + returnA -< Folder { fldName = T.pack fldNm' + , fldId = T.pack fldId' + , fldType = T.pack fldType' + , fldLevel = level + , fldObjs = objects + , fldFolders = subFlds + } + + getArchiObj :: ArrowXml a => a XmlTree ArchiObj + getArchiObj = isElem >>> (hasName "element"<+>hasName "elements") >>> -- don't use atTag, because there is recursion in getFolder. + proc l -> do objId <- getAttrValue "id" -< l + objName <- getAttrValue "name" -< l + objType <- getAttrValue "xsi:type" -< l + objDocu <- getAttrValue "documentation" -< l -- This accommodates Archi vs. 2 + objDocus <- listA (getChildren >>> getDocu) -< l + objProps <- listA (getChildren >>> getProp) -< l + objSrc <- getAttrValue "source" -< l -- specific for Relationships + objTgt <- getAttrValue "target" -< l -- specific for Relationships + objAccTp <- getAttrValue "accessType" -< l -- specific for Relationships + objVwPt <- getAttrValue "viewpoint" -< l -- specific for Views + objChilds <- listA (getChildren >>> getChild) -< l -- specific for Views + returnA -< if objType=="archimate:ArchimateDiagramModel" then + View + { viewId = T.pack objId + , viewName = T.pack objName + , viewDocu = T.pack objDocu + , viewDocus = objDocus + , viewProps = objProps + , viewPoint = T.pack objVwPt + , viewChilds = objChilds + } + else if null objSrc then + Element + { elemId = T.pack objId + , elemName = T.pack objName + , elemType = unPrefix (T.pack objType) + , elemDocu = T.pack objDocu + , elemDocus = objDocus + , elemProps = objProps + } + else + Relationship + { relId = T.pack objId + , relName = T.pack objName + , relType = unPrefix (T.pack objType) + , relDocu = T.pack objDocu + , relDocus = objDocus + , relProps = objProps + , relSrc = T.pack objSrc + , relTgt = T.pack objTgt + , relAccTp = T.pack objAccTp + } + -- | drops the prefix "archimate:", which is specific for Archi types. + unPrefix :: Text -> Text + unPrefix str = if "archimate:" `T.isPrefixOf` str + then T.drop 10 str else str + getProp :: ArrowXml a => a XmlTree ArchiProp getProp = isElem >>> (hasName "property"<+>hasName "properties") >>> proc l -> do propKey <- getAttrValue "key" -< l @@ -547,29 +659,57 @@ processStraight absFilePath getDocu = isElem >>> hasName "documentation" >>> proc l -> do docuVal <- text -< l returnA -< ArchiDocu { archDocuVal = T.pack docuVal } - getElement :: ArrowXml a => a XmlTree Element - getElement = isElem >>> (hasName "element"<+>hasName "elements") >>> -- don't use atTag, because recursion is in getFolder. - proc l -> do elemType' <- getAttrValue "xsi:type" -< l - elemId' <- getAttrValue "id" -< l - elemName' <- getAttrValue "name" -< l - elemSrc' <- getAttrValue "source" -< l - elemTgt' <- getAttrValue "target" -< l - elemAccTp' <- getAttrValue "accessType" -< l - elemDocu' <- getAttrValue "documentation" -< l - childs' <- listA (getChildren >>> getChild) -< l - props' <- listA (getChildren >>> getProp) -< l - docus' <- listA (getChildren >>> getDocu) -< l - returnA -< Element { elemType = T.drop 1 . T.dropWhile (/=':') . T.pack $ elemType' -- drop the prefix "archimate:" - , elemId = T.pack elemId' - , elemName = T.pack elemName' - , elemSrc = T.pack elemSrc' - , elemTgt = T.pack elemTgt' - , elemAccTp = T.pack elemAccTp' - , elemDocu = T.pack elemDocu' - , elChilds = childs' - , elProps = props' - , elDocus = docus' - } + + getChild :: ArrowXml a => a XmlTree Child + getChild + = atTag "child"<+>atTag "children" >>> + proc l -> do + -- chldType' <- getAttrValue "xsi:type" -< l + -- chldId' <- getAttrValue "id" -< l + -- chldName' <- getAttrValue "name" -< l -- defined, but not used. + -- chldFCol' <- getAttrValue "fillColor" -< l + -- chldAlgn' <- getAttrValue "textAlignment" -< l + chldElem' <- getAttrValue "archimateElement" -< l + -- trgtConn' <- getAttrValue "targetConnections" -< l + -- bound' <- getChildren >>> getBound -< l + srcConns' <- listA (getChildren >>> getSrcConn) -< l + childs' <- listA (getChildren >>> getChild) -< l + returnA -< Child { + -- chldType = unPrefix (T.pack chldType') + -- , chldId = T.pack chldId' + -- , chldAlgn = T.pack chldAlgn' + -- , chldFCol = T.pack chldFCol' + chldElem = T.pack chldElem' + -- , trgtConn = T.pack trgtConn' + -- , bound = bound' + , srcConns = srcConns' + , childs = childs' + } + +-- The following does not work yet for recent versions of Archi +-- which should parse with hasName "sourceConnection", but doesn't. TODO +-- However, forget about this after the ArchiMate Exchange Format can be parsed. + getSrcConn :: ArrowXml a => a XmlTree SourceConnection + getSrcConn = isElem >>> hasName "sourceConnection"<+>hasName "sourceConnections" >>> + proc l -> do + -- sConType' <- getAttrValue "xsi:type" -< l + -- sConId' <- getAttrValue "id" -< l + -- sConSrc' <- getAttrValue "source" -< l + -- sConTgt' <- getAttrValue "target" -< l + sConRel' <- getAttrValue "archimateRelationship" -< l + -- sConRelat' <- listA (getChildren>>>getRelation) -< l + -- bendPts' <- listA (getChildren>>>getBendPt) -< l + returnA -< SrcConn { + -- sConType = T.pack sConType' + -- sConId = T.pack sConId' + -- sConSrc = T.pack sConSrc' + -- sConTgt = T.pack sConTgt' + sConRel = T.pack sConRel' + -- sConRelat = sConRelat' + -- sCbendPts = bendPts' + } + +{- We no longer analyze all information that is available. getRelation :: ArrowXml a => a XmlTree Relation getRelation = isElem >>> hasName "relationship" >>> proc l -> do relType' <- getAttrValue "xsi:type" -< l @@ -588,23 +728,6 @@ processStraight absFilePath , bnd_width = T.pack bndWidth' , bnd_height = T.pack bndHeight' } - getSrcConn :: ArrowXml a => a XmlTree SourceConnection - getSrcConn = isElem >>> hasName "sourceConnections" >>> - proc l -> do sConType' <- getAttrValue "xsi:type" -< l - sConId' <- getAttrValue "id" -< l - sConSrc' <- getAttrValue "source" -< l - sConTgt' <- getAttrValue "target" -< l - sConRel' <- getAttrValue "relationship" -< l - sConRelat' <- listA (getChildren>>>getRelation)-< l - bendPts' <- listA (getChildren>>>getBendPt) -< l - returnA -< SrcConn { sConType = T.pack sConType' - , sConId = T.pack sConId' - , sConSrc = T.pack sConSrc' - , sConTgt = T.pack sConTgt' - , sConRel = T.pack sConRel' - , sConRelat = sConRelat' - , sCbendPts = bendPts' - } getBendPt :: ArrowXml a => a XmlTree BendPoint getBendPt = isElem >>> hasName "bendpoints" >>> proc l -> do bpStartX' <- getAttrValue "startX" -< l @@ -616,29 +739,7 @@ processStraight absFilePath , bpEndX = T.pack bpEndX' , bpEndY = T.pack bpEndY' } - - getChild - = atTag "children" >>> - proc l -> do chldType' <- getAttrValue "xsi:type" -< l - chldId' <- getAttrValue "id" -< l - -- chldName' <- getAttrValue "name" -< l -- defined, but not used. - chldFCol' <- getAttrValue "fillColor" -< l - chldAlgn' <- getAttrValue "textAlignment" -< l - chldElem' <- getAttrValue "archimateElement" -< l - trgtConn' <- getAttrValue "targetConnections" -< l - bound' <- getChildren >>> getBound -< l - srcConns' <- listA (getChildren >>> getSrcConn) -< l - childs' <- listA (getChildren >>> getChild) -< l - returnA -< Child { chldType = T.pack chldType' - , chldId = T.pack chldId' - , chldAlgn = T.pack chldAlgn' - , chldFCol = T.pack chldFCol' - , chldElem = T.pack chldElem' - , trgtConn = T.pack trgtConn' - , bound = bound' - , srcConns = srcConns' - , childs = childs' - } +-} -- | Auxiliaries `atTag` and `text` have been copied from the tutorial papers about arrows atTag :: ArrowXml a => Text -> a (NTree XNode) XmlTree diff --git a/src/Ampersand/Misc/Commands.hs b/src/Ampersand/Misc/Commands.hs index ffd5bd3b4b..5c4310896a 100644 --- a/src/Ampersand/Misc/Commands.hs +++ b/src/Ampersand/Misc/Commands.hs @@ -17,7 +17,6 @@ import Ampersand.Commands.Daemon import Ampersand.Commands.Documentation import Ampersand.Commands.Devoutput import Ampersand.Commands.ExportAsADL ---import Ampersand.Commands.Init import Ampersand.Commands.Population import Ampersand.Commands.Proof import Ampersand.Commands.Test @@ -51,8 +50,6 @@ import qualified RIO.NonEmpty as NE import qualified RIO.Text as T import System.Environment ({-getProgName,-} withArgs) ---import System.FilePath (isValid, pathSeparator, takeDirectory) - -- A lot of inspiration in this file comes from https://github.com/commercialhaskell/stack/ -- Vertically combine only the error component of the first argument with the @@ -318,12 +315,15 @@ daemonCmd daemonOpts = extendWith daemonOpts runDaemon documentationCmd :: DocOpts -> RIO Runner () -documentationCmd docOpts = - extendWith docOpts $ do - env <- ask - let recipe = recipeBuilder False env - mFSpec <- createFspec recipe - doOrDie mFSpec doGenDocument +documentationCmd docOpts = do + extendWith docOpts . forceAllowInvariants $ do + env <- ask + let recipe = recipeBuilder False env + mFSpec <- createFspec recipe + doOrDie mFSpec doGenDocument + where + forceAllowInvariants :: HasFSpecGenOpts env => RIO env a -> RIO env a + forceAllowInvariants env = local (set allowInvariantViolationsL True) env -- | Create a prototype based on the current script. protoCmd :: ProtoOpts -> RIO Runner () @@ -408,7 +408,7 @@ doOrDie gA act = Checked a ws -> do showWarnings ws act a - Errors err -> exitWith . NoValidFSpec . T.lines . T.intercalate (T.replicate 30 "=") + Errors err -> exitWith . NoValidFSpec . T.lines . T.intercalate (T.replicate 30 "=" <> "\n") . NE.toList . fmap tshow $ err where showWarnings ws = mapM_ logWarn (fmap displayShow ws) diff --git a/src/Ampersand/Misc/HasClasses.hs b/src/Ampersand/Misc/HasClasses.hs index ce51cdf17f..6371bf6a7f 100644 --- a/src/Ampersand/Misc/HasClasses.hs +++ b/src/Ampersand/Misc/HasClasses.hs @@ -126,6 +126,11 @@ instance HasOutputLanguage DocOpts where instance HasOutputLanguage UmlOpts where languageL = lens x4OutputLanguage (\x y -> x { x4OutputLanguage = y }) +class HasShowWarnings a where + showWarningsL :: Lens' a Bool -- Should warnings be given to the output? +instance HasDaemonOpts a => HasShowWarnings a where + showWarningsL = daemonOptsL . lens xshowWarnings (\x y -> x { xshowWarnings = y }) + class HasDirCustomizations a where dirCustomizationsL :: Lens' a (Maybe [FilePath]) -- the directories that are copied after generating the prototype instance HasDirCustomizations ProtoOpts where @@ -207,8 +212,10 @@ instance HasTestOpts TestOpts where data DaemonOpts = DaemonOpts { x2OutputLanguage :: !(Maybe Lang) , xdaemonConfig :: !FilePath - , x2fSpecGenOpts :: !FSpecGenOpts -- ^ The path (relative from current directory OR absolute) and filename of a file that contains the root file(s) to be watched by the daemon. + , x2fSpecGenOpts :: !FSpecGenOpts + , xshowWarnings :: !Bool -- ^ Enable/disable show of warnings (if any). + } class (HasFSpecGenOpts a) => HasDaemonOpts a where daemonOptsL :: Lens' a DaemonOpts diff --git a/src/Ampersand/Options/DaemonParser.hs b/src/Ampersand/Options/DaemonParser.hs index 346025573d..9736012271 100644 --- a/src/Ampersand/Options/DaemonParser.hs +++ b/src/Ampersand/Options/DaemonParser.hs @@ -6,15 +6,18 @@ import Ampersand.Misc.HasClasses import Ampersand.Basics import Ampersand.Options.Utils import Ampersand.Options.FSpecGenOptsParser +import Options.Applicative.Builder.Extra (boolFlags) -- | Command-line parser for the daemon command. daemonOptsParser :: Parser DaemonOpts daemonOptsParser = - ( \outputLanguage daemonConfig fSpecGenOpts -> DaemonOpts + ( \outputLanguage daemonConfig fSpecGenOpts + showWarnings-> DaemonOpts { x2OutputLanguage = outputLanguage , xdaemonConfig = daemonConfig , x2fSpecGenOpts = fSpecGenOpts - }) + , xshowWarnings = showWarnings + }) <$> outputLanguageP <*> strOption ( long "daemonconfig" @@ -24,5 +27,8 @@ daemonOptsParser = <> help ("The config file contains the list of files to be monitored.") ) <*> fSpecGenOptsParser True + <*> boolFlags True "warnings" + ( "show warnings in the output, if any. " + ) mempty diff --git a/src/Ampersand/Options/FSpecGenOptsParser.hs b/src/Ampersand/Options/FSpecGenOptsParser.hs index ba7e7e8a6e..484a8e7b1f 100644 --- a/src/Ampersand/Options/FSpecGenOptsParser.hs +++ b/src/Ampersand/Options/FSpecGenOptsParser.hs @@ -135,6 +135,9 @@ knownRecipeP = toKnownRecipe . T.pack <$> strOption allowInvariantViolationsP :: Parser Bool allowInvariantViolationsP = switch ( long "ignore-invariant-violations" - <> help ("Do not report (totally ignore) violations of invariants. (See " - <>"https://github.com/AmpersandTarski/Ampersand/issues/728)") + <> help ("ignore invariant violations. In case of the prototype command, the" + <>"generated prototype might not behave as you expect. " + <>"Documentation is not affected. This means that invariant violations" + <>"are reported anyway. " + <>"(See https://github.com/AmpersandTarski/Ampersand/issues/728)") ) diff --git a/src/Ampersand/Output/ToPandoc/ChapterDiagnosis.hs b/src/Ampersand/Output/ToPandoc/ChapterDiagnosis.hs index f9e69d3c23..ff5699d6d8 100644 --- a/src/Ampersand/Output/ToPandoc/ChapterDiagnosis.hs +++ b/src/Ampersand/Output/ToPandoc/ChapterDiagnosis.hs @@ -102,15 +102,15 @@ chpDiagnosis env fSpec case missing of [] -> if (null.concs) fSpec then mempty - else (para.str.l) (NL "Alle concepten in dit document zijn voorzien van een bestaansreden." + else (para.str.l) (NL "Alle concepten in dit document zijn voorzien van een oogmerk (purpose)." ,EN "All concepts in this document have been provided with a purpose.") - [c] -> para ( (str.l) (NL "De bestaansreden van concept " + [c] -> para ( (str.l) (NL "Het oogmerk (purpose) van concept " ,EN "The concept ") <> (singleQuoted.str.name) c <> (str.l) (NL " is niet gedocumenteerd." ,EN " remains without a purpose.") ) - xs -> para ( (str.l) (NL "De bestaansreden van de concepten: " + xs -> para ( (str.l) (NL "Het oogmerk (purpose) van de concepten: " ,EN "Concepts ") <> commaPandocAnd outputLang' (map (str.name) xs) <> (str.l) (NL " is niet gedocumenteerd." @@ -253,7 +253,7 @@ chpDiagnosis env fSpec ,EN "All rules in this document have been provided with a meaning and a purpose.") else ( case filter (not.hasPurpose) ruls of [] -> mempty - rls -> (para.str.l) (NL "Van de volgende regels is de bestaansreden niet uitgelegd:" + rls -> (para.str.l) (NL "Van de volgende regels is het oogmerk (purpose) niet uitgelegd:" ,EN "Rules are defined without documenting their purpose:") <> bulletList [ (para.emph.str.name) r <> (plain.str.tshow.origin) r @@ -465,17 +465,35 @@ chpDiagnosis env fSpec <>(str.name) r ) -- Alignment: - (replicate 2 (AlignLeft,1/2)) + (replicate 1 (AlignLeft,1/1)) -- Headers: - [(para.strong.text.name.source.formalExpression) r - ,(para.strong.text.name.target.formalExpression) r - ] + ( ( fmap singleton + . concat + . fmap (amPandoc . ameaMrk) + . meanings + ) r + ) -- Rows: - [ [(para.text.showValADL.apLeft) p - ,(para.text.showValADL.apRight) p - ] - | p<- Set.elems ps] + (mkInvariantViolationsError (applyViolText fSpec) (r,ps)) + mkInvariantViolationsError :: (Rule->AAtomPair->Text) -> (Rule,AAtomPairs) -> [[Blocks]] + mkInvariantViolationsError applyViolText (r,ps) = + [[(para.strong.text) violationMessage]] + where + violationMessage :: Text + violationMessage = T.unlines $ + [if length ps == 1 + then "There is one violation of RULE " <>tshow (name r)<>":" + else "There are "<>tshow (length ps)<>" violations of RULE "<>tshow (name r)<>":" + ] + <> (map (" "<>) . listPairs 10 . Set.toList $ ps) + listPairs :: Int -> [AAtomPair] -> [Text] + listPairs i xs = + case xs of + [] -> [] + h:tl + | i == 0 -> [" ... ("<>tshow (length xs)<>" more)"] + | otherwise -> applyViolText r h : listPairs (i-1) tl violtable :: Rule -> AAtomPairs -> Blocks diff --git a/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try10.adl b/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try10.adl index 318b03dce7..f4f6d396a9 100644 --- a/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try10.adl +++ b/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try10.adl @@ -3,14 +3,14 @@ CONTEXT Try10 IN ENGLISH PURPOSE PATTERN Try10 IN ENGLISH {+ This pattern is meant to test the translation of ObjectDefs in Ampersand. --} ++} PATTERN Try10 r :: A*A s :: C*X t :: A*B - CLASSIFY D ISA A - CLASSIFY D ISA C + CLASSIFY A ISA D + CLASSIFY C ISA D ENDPATTERN INTERFACE Overview : I[ONE] @@ -29,39 +29,16 @@ INTERFACE Overview : I[ONE] ENDCONTEXT {- - Purpose: to examine the error message deeply inside an interface. + Purpose: to check that uniqueness of lables in boxes are tested. Result: FAIL - Reason: on line 23 there is an error because the source of an attribute (s) does not match with its environment. + Reason: on lines 19 and 20 there are duplicate labels. Message: -Error(s) found: -Type error in BOX -Cannot match: -- concept "C", Src of : s -if you think there is no type error, add an order between the mismatched concepts. -Error at symbol () in file /home/sentinel/git/ampersand-models/Tests/ShouldFail/Try10.adl at line 18 : 9 -============================== -Cannot disambiguate: I -Please add a signature. -You may have intended one of these: -I[B] -I[C] -Error at symbol () in file /home/sentinel/git/ampersand-models/Tests/ShouldFail/Try10.adl at line 22 : 28 -============================== -Type error in BOX -Cannot match: -- concept "C", Src of : s -if you think there is no type error, add an order between the mismatched concepts. -Error at symbol () in file /home/sentinel/git/ampersand-models/Tests/ShouldFail/Try10.adl at line 22 : 15 -============================== -Ambiguous type when matching: Tgt of t~ -and Src of s. -The type can be "C" or "A" -None of these concepts is known to be the smallest, you may want to add an order between them. -Error at symbol () in file /home/sentinel/git/ampersand-models/Tests/ShouldFail/Try10.adl at line 24 : 30 -============================== -Names / labels must be unique. "r", however, is used at: -line 19:15, file /home/sentinel/git/ampersand-models/Tests/ShouldFail/Try10.adl -line 20:15, file /home/sentinel/git/ampersand-models/Tests/ShouldFail/Try10.adl. -Error at symbol () in file /home/sentinel/git/ampersand-models/Tests/ShouldFail/Try10.adl at line 19 : 15 +C:> ampersand check Try10.adl +Reading file /Users/sjo00577/git/Ampersand/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try10.adl +/Users/sjo00577/git/Ampersand/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try10.adl:19:15 error: + Every label in box must have a unique name. "r", however, is used at:/Users/sjo00577/git/Ampersand/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try10.adl:19:15 + /Users/sjo00577/git/Ampersand/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try10.adl:20:15. +ExitFailure 10 +C:> -} \ No newline at end of file diff --git a/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try11.adl b/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try11.adl new file mode 100644 index 0000000000..1169745102 --- /dev/null +++ b/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try11.adl @@ -0,0 +1,32 @@ +CONTEXT Try11 IN ENGLISH + +PURPOSE PATTERN Try11 IN ENGLISH +{+ +This pattern is meant to test the translation of Rules in Ampersand. ++} + +PATTERN Try11 + r :: A*A + s :: A*A + t :: A*A +ENDPATTERN + +RULE "Test Try11" : -(r\/s) +RULE "Test Try11" : t|-s + +ENDCONTEXT + +{- + Purpose: to check that uniqueness of RULE names are tested. + Result: FAIL + Reason: on line 16 and 17 there are two rules with the same name. + + Message: +C:> ampersand check Try11.adl +Reading file /Users/sjo00577/git/Ampersand/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try11.adl +/Users/sjo00577/git/Ampersand/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try11.adl:14:1 error: + Every rule must have a unique name. "Test Try11", however, is used at:/Users/sjo00577/git/Ampersand/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try11.adl:14:1 + /Users/sjo00577/git/Ampersand/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try11.adl:15:1. +ExitFailure 10 +C:> +-} \ No newline at end of file diff --git a/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try13.adl b/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try13.adl new file mode 100644 index 0000000000..6db32aaa57 --- /dev/null +++ b/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try13.adl @@ -0,0 +1,31 @@ +CONTEXT Try13 IN ENGLISH + +PURPOSE PATTERN Try13 IN ENGLISH +{+ +This pattern is meant to test the translation of Views in Ampersand. ++} + +PATTERN Try13 + r :: A*A + s :: A*A + t :: A*A +ENDPATTERN + +VIEW Try13: A(TXT "aap",I[A]) +VIEW Try13: A(TXT "noot",r) +ENDCONTEXT + +{- + Purpose: to check that uniqueness of VIEW labels are tested. + Result: FAIL + Reason: on line 14 and 15 there are two views with the same name. + + Message: +C:> ampersand check Try13.adl +Reading file /Users/sjo00577/git/Ampersand/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try13.adl +/Users/sjo00577/git/Ampersand/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try13.adl:14:1 error: + Multiple default views for concept A:VIEW Try13 (at /Users/sjo00577/git/Ampersand/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try13.adl:14:1) + VIEW Try13 (at /Users/sjo00577/git/Ampersand/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try13.adl:15:1) +ExitFailure 10 +C:> +-} \ No newline at end of file diff --git a/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try15.adl b/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try15.adl new file mode 100644 index 0000000000..ee451b6420 --- /dev/null +++ b/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try15.adl @@ -0,0 +1,31 @@ +CONTEXT Try15 IN ENGLISH + +PURPOSE PATTERN Try15 IN ENGLISH +{+ +This pattern is meant to test the translation of Interfaces in Ampersand. ++} + +PATTERN Try15 + r :: A*A + s :: A*A + t :: A*A +ENDPATTERN + +INTERFACE "TEST Try15": I[A] cRud BOX [ id : I ] +INTERFACE "TEST Try15": I[B] cRud BOX [ id : I ] +ENDCONTEXT + +{- + Purpose: to check that uniqueness of INTERFACE labels are tested. + Result: FAIL + Reason: on line 14 and 15 there are two views with the same name. + + Message: +C:> ampersand check Try15.adl +Reading file /Users/sjo00577/git/Ampersand/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try15.adl +/Users/sjo00577/git/Ampersand/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try15.adl:14:1 error: + Every interface must have a unique name. "TEST Try15", however, is used at:/Users/sjo00577/git/Ampersand/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try15.adl:14:1 + /Users/sjo00577/git/Ampersand/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try15.adl:15:1. +ExitFailure 10 +C:> +-} \ No newline at end of file diff --git a/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try16.adl b/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try16.adl new file mode 100644 index 0000000000..caa17bedfe --- /dev/null +++ b/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try16.adl @@ -0,0 +1,31 @@ +CONTEXT Try16 IN ENGLISH + +PURPOSE PATTERN Try16 IN ENGLISH +{+ +This pattern is meant to test the translation of Interfaces in Ampersand. ++} + +PATTERN Try16 + r :: A*A + s :: A*A + t :: A*A +ENDPATTERN + +INTERFACE "TEST Try16": I[A] cRud BOX [ id : I ] +INTERFACE "TEST Try16": I[B] cRud BOX [ id : I ] +ENDCONTEXT + +{- + Purpose: to check that uniqueness of INTERFACE labels are tested. + Result: FAIL + Reason: on line 14 and 15 there are two views with the same name. + + Message: +C:> ampersand check Try16.adl +Reading file /Users/sjo00577/git/Ampersand/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try16.adl +/Users/sjo00577/git/Ampersand/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try16.adl:14:1 error: + Every interface must have a unique name. "TEST Try16", however, is used at:/Users/sjo00577/git/Ampersand/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try16.adl:14:1 + /Users/sjo00577/git/Ampersand/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try16.adl:15:1. +ExitFailure 10 +C:> +-} \ No newline at end of file diff --git a/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try20.adl b/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try20.adl new file mode 100644 index 0000000000..5df247e240 --- /dev/null +++ b/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try20.adl @@ -0,0 +1,31 @@ +CONTEXT Try20 IN ENGLISH + +PURPOSE PATTERN Try20 IN ENGLISH +{+ +This pattern is meant to test the translation of identity definitions in Ampersand. ++} + +PATTERN Try20 + r :: A*A + s :: A*A + t :: A*A +ENDPATTERN + +IDENT "TEST Try20": A(I) +IDENT "TEST Try20": B(I) +ENDCONTEXT + +{- + Purpose: to check that uniqueness of IDENT labels are tested. + Result: FAIL + Reason: on line 14 and 15 there are two identity definitions with the same label. + + Message: +C:> ampersand check Try20.adl +Reading file /Users/sjo00577/git/Ampersand/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try20.adl +/Users/sjo00577/git/Ampersand/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try20.adl:14:1 error: + Every identity definition must have a unique name. "TEST Try20", however, is used at:/Users/sjo00577/git/Ampersand/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try20.adl:14:1 + /Users/sjo00577/git/Ampersand/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/Try20.adl:15:1. +ExitFailure 10 +C:> +-} \ No newline at end of file diff --git a/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/try46.adl b/testing/Travis/testcases/prototype/shouldSucceed/Issue1026.adl similarity index 85% rename from testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/try46.adl rename to testing/Travis/testcases/prototype/shouldSucceed/Issue1026.adl index 8a7d2a82f5..01e1e92448 100644 --- a/testing/Travis/testcases/prototype/shouldFail/ParserOrTypecheckFailures/try46.adl +++ b/testing/Travis/testcases/prototype/shouldSucceed/Issue1026.adl @@ -1,15 +1,15 @@ -CONTEXT Try46 IN ENGLISH +CONTEXT Issue1026 IN ENGLISH r :: A*B s :: A*B -PATTERN Try46 +PATTERN SameName RULE ifRthenS : r |- s PURPOSE RULE ifRthenS IN DUTCH {+Dit is de tekst voor de regel ifRthenS. Deze staat in het eerste pattern met de naam Try46.+} ENDPATTERN -PATTERN Try46 +PATTERN SameName RULE ifSthenR : s |- r PURPOSE RULE ifSthenR IN DUTCH {+Dit is de tekst voor de regel ifSthenR. Deze staat in het tweede pattern met de naam Try46.+}