diff --git a/.github/workflows/ci2.yml b/.github/workflows/ci2.yml index 5ada99ffc7..b0d7e8c2b7 100644 --- a/.github/workflows/ci2.yml +++ b/.github/workflows/ci2.yml @@ -1,5 +1,5 @@ # Inspired by https://tech.freckle.com/2021/05/18/haskell-on-actions/ -name: CI_test πŸš€ +name: Build and test πŸš€ on: pull_request: @@ -129,7 +129,7 @@ jobs: uses: freckle/stack-action@main # stack-action does all these steps: dependencies, build, test. with: stack-arguments: '--copy-bins --flag ampersand:buildAll' - weeder: false + weeder: true hlint: true - name: Upload artifacts (Linux) πŸ“€ diff --git a/ArchitectureAndDesign/Syntax/Current Student version/ADL_V4.0.ebnf b/ArchitectureAndDesign/Syntax/Current Student version/ADL_V4.0.ebnf new file mode 100644 index 0000000000..693eec780f --- /dev/null +++ b/ArchitectureAndDesign/Syntax/Current Student version/ADL_V4.0.ebnf @@ -0,0 +1,90 @@ +ADL_V2 ::= ContextDef +ContextDef ::= 'CONTEXT' Id IncludeStatement* LanguageRef? TextMarkup? + ( Meta | + PatternDef | + ProcessDef | + RuleDef | + RelationDef | + ConceptDef | + GenDef | + ViewDef | + InterfaceDef | + Plug | + Purpose | + Population | + Themes + )* 'ENDCONTEXT' +IncludeStatement ::= 'INCLUDE' FilePath +LanguageRef ::= 'IN' ('DUTCH' | 'ENGLISH') +TextMarkup ::= 'REST' | 'HTML' | 'LATEX' | 'MARKDOWN' +Meta ::= 'META' String String +PatternDef ::= 'PATTERN' Id + ( RuleDef | + GenDef | + RelationDef | + RoleRule | + ConceptDef | + RoleRelation | + ViewDef | + Purpose | + Population + )* 'ENDPATTERN' +RuleDef ::= 'RULE' (Id ':')? Term Meaning* + ('MESSAGE' LanguageRef? TextMarkup? (String | Expl))* + ('VIOLATION' (ViolElement (',' ViolElement)* )? +ViolElement ::= 'TXT' String | 'SRC' Term | 'TGT' Term +RelationDef ::= ((Id '::' ConceptRef ( '*'| '->' | '<-' | ('[' (('0'| '1') '..' ('1'|'*') | '1' | '*')? '-' (('0'| '1') '..' ('1'|'*') | '1' | '*')? ']' ) ) ConceptRef) | + (RELATION Id Sign)) + 'BYPLUG'? Props? 'BYPLUG'? ('PRAGMA' String String*)? Meaning? ('=' Content )? ('DEFINE' ('SRC' | 'TGT') String)? '.'? +Props ::= '['( ('UNI'|'INJ'|'SUR'|'TOT'|'SYM'|'ASY'|'TRN'|'RFX'|'IRF'|'PROP') + (',' ('UNI'|'INJ'|'SUR'|'TOT'|'SYM'|'ASY'|'TRN'|'RFX'|'IRF'|'PROP'))* + )? ']' +ConceptDef ::= 'CONCEPT' Id 'MEANING' LanguageRef? TextMarkup? ('REF' String)? Expl +GenDef ::= 'CLASSIFY' Id 'ISA' Id +ViewDef ::= 'VIEW' Id ConceptRef '(' ViewSegment (',' ViewSegment)* ')' | + 'VIEW' Id ConceptRef 'DEFAULT'? ('(' ViewSegment (',' ViewSegment)* ')'?) HTMLview 'ENDVIEW' +ViewSegment ::= Id ':' ( term | string ) +InterfaceDef ::= 'INTERFACE' 'API'? Id + ('(' RelSign (',' RelSign)* ')')? + ('FOR' Id (',' Id)* )? + ':' Term SubInterface +SubInterface ::= 'BOX' ('<' ('FORM' | 'TABLE' | 'TABS') '>')? Box +Plug ::= ('SQLPLUG' | 'PHPPLUG') Obj +Purpose ::= 'PURPOSE' + ('CONCEPT' Id | + 'RELATION' Id Sign? | + 'RULE' Id | + 'VIEW' Id | + 'PATTERN' Id | + 'INTERFACE' Id | + 'CONTEXT' Id + ) + LanguageRef? + TextMarkup? + ('REF' String)? Expl +Expl ::= '{+' String '-}' +Population ::= 'POPULATION' RelSign 'CONTAINS' RelContent | + 'POPULATION' Id 'CONTAINS' CptContent +RoleRule ::= 'ROLE' Id (',' Id)* 'MAINTAINS' Id (',' Id)* +Meaning ::= 'MEANING' LanguageRef? TextMarkup? Expl +Term ::= Trm1 (( '=' | '|-') Trm1)? +Trm1 ::= Trm2 (( '/\' | '\/') Trm2)* +Trm2 ::= Trm3 ('-' Trm3)? +Trm3 ::= Trm4 (( '\' | '/') Trm4)? +Trm4 ::= (Trm5 (';' Trm5)* ) | + (Trm5 ('!' Trm5)* ) | + Trm5 +Trm5 ::= '-'? Trm6 | + Trm6 ( Sign | '~' | '*' | '+') +Trm6 ::= RelationRef | + '(' Term ')' +RelationRef ::= 'I' | 'V' | Varid | Atom +RelSign ::= RelationRef Sign? +Sign ::= '[' ConceptRef ( '*' ConceptRef)? ']' +ConceptRef ::= 'ONE' | Id +# obsolete: +# LabelProps ::= Id ('{' Id (',' Id)* '}')* ':' +ObjDef ::= Id Term SubInterface? +Box ::= 'BOX' '[' ObjDef (',' ObjDef)* ']' +RelContent ::= '[' (('(' Value ',' Value ')') (',' ('(' Value ',' Value ')') )*)? ']' +CptContent ::= '[' (Value (',' Value )*)? ']' diff --git a/README.md b/README.md index 4eb23c83fa..5743123e42 100644 --- a/README.md +++ b/README.md @@ -1,5 +1,6 @@ # Ampersand +[![Build & Test πŸš€](https://github.com/AmpersandTarski/Ampersand/actions/workflows/ci2.yml/badge.svg)](https://github.com/AmpersandTarski/Ampersand/actions/workflows/ci2.yml) [![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 1ece7e0f09..0ca1d7d983 100644 --- a/ReleaseNotes.md +++ b/ReleaseNotes.md @@ -1,8 +1,16 @@ ο»Ώ# Release notes of Ampersand -## v4.1.5 (30 May 2021) +## v4.2.0 ( 16 July 2021) -* Upgrade to [LTS Haskell 17.9 (ghc-8.10.4)](https://www.stackage.org/lts-17.9) . This includes an upgrade of Pandoc. This might effect tables in the documentation that is generated with the `documentation` command. +* In the generated documentation, the Conceptual Analysis chapter has been revised to be readable by stakeholders with some knowledge of conceptual modeling. +* [Issue #1171](https://github.com/AmpersandTarski/Ampersand/issues/1171) Warn about labels with identical names in sections of VIEW statement. +* [Issue #1163](https://github.com/AmpersandTarski/Ampersand/issues/1163) Idenfifiers starting with an underscore (`_`) are no longer allowed. +* [Issue #1183](https://github.com/AmpersandTarski/Ampersand/issues/1183) Use markup in definition of Concept is now possible. +* Improvements to the way we test the build (CI/CD). + +## v4.1.5 ( 2 June 2021) + +* Upgrade to [LTS Haskell 17.9 (ghc-8.10.4)](https://www.stackage.org/lts-17.9) . This includes an upgrade of Pandoc. This might affect tables in the documentation that is generated with the `documentation` command. * Add switch `--numeric-version` * Improvement to the CI/CD. We abandon travis-ci and appveyor, and are now totally using github actions for our Continous Integration. diff --git a/ampersand.cabal b/ampersand.cabal index e71b5cf54b..db9f190f81 100644 --- a/ampersand.cabal +++ b/ampersand.cabal @@ -5,7 +5,7 @@ cabal-version: 2.0 -- see: https://github.com/sol/hpack name: ampersand -version: 4.1.5 +version: 4.2.0 synopsis: Toolsuite for automated design of enterprise information systems. description: You can define your business processes by means of rules, written in Relation Algebra. category: Database Design @@ -194,6 +194,7 @@ extra-source-files: testing/Travis/testcases/FuncSpec/Mandatering/Mandatering.adl testing/Travis/testcases/FuncSpec/Mandatering/ToevoegenMandaat.adl testing/Travis/testcases/FuncSpec/testinfo.yaml + testing/Travis/testcases/FuncSpec/testIssue1183.adl testing/Travis/testcases/FuncSpec/testPredLogic.adl testing/Travis/testcases/Misc/Arbeidsduur.adl testing/Travis/testcases/Misc/ArchiTest1.adl @@ -222,6 +223,7 @@ extra-source-files: testing/Travis/testcases/Parsing/shouldFail/Issue980.adl testing/Travis/testcases/Parsing/shouldFail/testinfo.yaml testing/Travis/testcases/Parsing/shouldSucceed/Issue1014.adl + testing/Travis/testcases/Parsing/shouldSucceed/Issue1183.adl testing/Travis/testcases/Parsing/shouldSucceed/Issue899b.adl testing/Travis/testcases/Parsing/shouldSucceed/Issue960.adl testing/Travis/testcases/Parsing/shouldSucceed/testinfo.yaml @@ -543,7 +545,6 @@ library Ampersand.Test.Parser.ParserTest Ampersand.Test.Parser.QuickChecks Ampersand.Test.Regression - Ampersand.Test.TestScripts MainApps Options.Applicative.Builder.Extra Ampersand.Basics.BuildInfo_Generated @@ -718,7 +719,7 @@ executable ampersand app/Ampersand default-extensions: NoImplicitPrelude - ghc-options: -Wall -Wcompat -Widentities -optP-Wno-nonportable-include-path -Wredundant-constraints -threaded + ghc-options: -Wall -Wcompat -Widentities -optP-Wno-nonportable-include-path -Wredundant-constraints -threaded -fwrite-ide-info build-depends: Cabal ==3.2.1.0 , HStringTemplate ==0.8.* diff --git a/package.yaml b/package.yaml index 6ed8c37646..4637a509b8 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: ampersand -version: 4.1.5 +version: 4.2.0 author: Stef Joosten maintainer: stef.joosten@ou.nl synopsis: Toolsuite for automated design of enterprise information systems. @@ -116,7 +116,6 @@ library: - Ampersand.Core.ShowPStruct - Ampersand.FSpec - Ampersand.FSpec.Crud -# - Ampersand.FSpec.FPA - Ampersand.FSpec.FSpec - Ampersand.FSpec.FSpecAux - Ampersand.FSpec.GenerateUML @@ -159,8 +158,6 @@ library: - Ampersand.Output.FSpec2SQL - Ampersand.Output.PandocAux - Ampersand.Output.Population2Xlsx -# - Ampersand.Output.PredLogic -# - Ampersand.Output.Statistics - Ampersand.Output.ToJSON.Concepts - Ampersand.Output.ToJSON.Conjuncts - Ampersand.Output.ToJSON.Interfaces @@ -190,8 +187,6 @@ library: - Ampersand.Test.Parser.ParserTest - Ampersand.Test.Parser.QuickChecks - Ampersand.Test.Regression -# - Ampersand.Test.RunAmpersand - - Ampersand.Test.TestScripts - MainApps - Options.Applicative.Builder.Extra generated-exposed-modules: @@ -216,6 +211,7 @@ executables: main: Main.hs ghc-options: - -threaded + - -fwrite-ide-info dependencies: - ampersand - Cabal == 3.2.1.0 diff --git a/src/Ampersand/ADL1.hs b/src/Ampersand/ADL1.hs index a4a027ee17..ee9117522d 100644 --- a/src/Ampersand/ADL1.hs +++ b/src/Ampersand/ADL1.hs @@ -31,7 +31,7 @@ import Ampersand.Core.ParseTree ( , TermPrim(..), P_NamedRel(..) , PClassify(..) , P_Relation(..) - , ConceptDef(..) + , PConceptDef(..), PCDDef(..) , PMeaning(..),PMessage(..),P_Markup(..) ) import Ampersand.Core.AbstractSyntaxTree ( @@ -56,6 +56,7 @@ import Ampersand.Core.AbstractSyntaxTree ( , Relation(..), Relations, getExpressionRelation, showRel , Rule(..), Rules, A_RoleRule(..) , A_Concept(..), A_Concepts, TType(..), showValADL, showValSQL, unsafePAtomVal2AtomValue + , AConceptDef(..) , Conjunct(..) , PAtomValue(..) , AAtomValues, AAtomPairs, safePSingleton2AAtomVal diff --git a/src/Ampersand/ADL1/P2A_Converters.hs b/src/Ampersand/ADL1/P2A_Converters.hs index 7256dcfc03..6a6cc68042 100644 --- a/src/Ampersand/ADL1/P2A_Converters.hs +++ b/src/Ampersand/ADL1/P2A_Converters.hs @@ -1,9 +1,6 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} module Ampersand.ADL1.P2A_Converters ( pCtx2aCtx @@ -65,28 +62,28 @@ checkPurposes ctx = let topLevelPurposes = ctxps ctx allPurposes = topLevelPurposes <> purposesInPatterns danglingPurposes = filter (isDanglingPurpose ctx) allPurposes in case danglingPurposes of - [] -> pure () - x:xs -> Errors $ + [] -> pure () + x:xs -> Errors $ mkDanglingPurposeError x NE.:| map mkDanglingPurposeError xs -- Return True if the ExplObj in this Purpose does not exist. isDanglingPurpose :: A_Context -> Purpose -> Bool -isDanglingPurpose ctx purp = +isDanglingPurpose ctx purp = case explObj purp of ExplConcept concDef -> let nm = name concDef in nm `notElem` map name (Set.elems $ concs ctx ) ExplRelation decl -> name decl `notElem` Set.map name (relsDefdIn ctx) -- is already covered by type checker - ExplRule nm -> nm `notElem` map name (Set.elems $ udefrules ctx) + ExplRule nm -> nm `notElem` map name (Set.elems $ udefrules ctx) ExplIdentityDef nm -> nm `notElem` map name (identities ctx) ExplViewDef nm -> nm `notElem` map name (viewDefs ctx) ExplPattern nm -> nm `notElem` map name (ctxpats ctx) ExplInterface nm -> nm `notElem` map name (ctxifcs ctx) - ExplContext nm -> ctxnm ctx /= nm + ExplContext nm -> ctxnm ctx /= nm && False -- HJO: This line is a workaround for the issue mentioned in https://github.com/AmpersandTarski/ampersand/issues/46 -- TODO: fix this when we pick up working on multiple contexts. -- Check that interface references are not cyclic checkInterfaceCycles :: A_Context -> Guarded () -checkInterfaceCycles ctx = +checkInterfaceCycles ctx = case interfaceCycles of [] -> return () x:xs -> Errors $ fmap mkInterfaceRefCycleError (x NE.:| xs) @@ -94,14 +91,14 @@ checkInterfaceCycles ctx = interfaceCycles = map ( fmap lookupInterface . fromMaybe (fatal "Empty list of interfacenames is unexpected here.") . NE.nonEmpty - ) + ) . getCycles $ refsPerInterface refsPerInterface :: [(Text, [Text])] refsPerInterface = [(name ifc, getDeepIfcRefs $ ifcObj ifc) | ifc <- ctxifcs ctx ] getDeepIfcRefs :: ObjectDef -> [Text] getDeepIfcRefs obj = case objmsub obj of Nothing -> [] - Just si -> case si of + Just si -> case si of InterfaceRef{} -> [siIfcId si | not (siIsLink si)] Box{} -> concatMap getDeepIfcRefs [x | BxExpr x <- siObjs si] lookupInterface :: Text -> Interface @@ -111,18 +108,18 @@ checkInterfaceCycles ctx = -- Check whether each concept has at most one default view checkMultipleDefaultViews :: A_Context -> Guarded () -checkMultipleDefaultViews ctx = +checkMultipleDefaultViews ctx = case conceptsWithMultipleViews of [] -> return () x:xs -> Errors $ fmap mkMultipleDefaultError (x NE.:| xs) where - conceptsWithMultipleViews = + conceptsWithMultipleViews = filter (\x -> NE.length x > 1) - . eqClass ((==) `on` vdcpt) + . eqClass ((==) `on` vdcpt) . filter vdIsDefault $ ctxvs ctx checkDanglingRulesInRuleRoles :: A_Context -> Guarded () -checkDanglingRulesInRuleRoles ctx = - case [mkDanglingRefError "Rule" nm (arPos rr) +checkDanglingRulesInRuleRoles ctx = + case [mkDanglingRefError "Rule" nm (arPos rr) | rr <- ctxrrules ctx , nm <- NE.toList $ arRules rr , nm `notElem` map name (Set.elems $ allRules ctx) @@ -130,10 +127,10 @@ checkDanglingRulesInRuleRoles ctx = [] -> return () x:xs -> Errors (x NE.:| xs) checkOtherAtomsInSessionConcept :: A_Context -> Guarded () -checkOtherAtomsInSessionConcept ctx = +checkOtherAtomsInSessionConcept ctx = case [mkOtherAtomInSessionError atom | pop@ACptPopu{popcpt =cpt} <- ctxpopus ctx - , isSESSION cpt + , isSESSION cpt , atom <- popas pop -- SJC: I think we should not allow _SESSION in a POPULATION statement, as there is no current session at that time (_SESSION should only be allowed as Atom in expressions) , not (_isPermittedSessionValue atom) @@ -153,14 +150,14 @@ checkOtherAtomsInSessionConcept ctx = _isPermittedSessionValue v@AAVString{} = aavtxt v == "_SESSION" _isPermittedSessionValue _ = False warnCaseProblems :: A_Context -> Guarded () -warnCaseProblems ctx = +warnCaseProblems ctx = let warnings :: [Warning] - warnings = warns (concs ctx) - <> warns (relsDefdIn ctx) + warnings = warns (concs ctx) + <> warns (relsDefdIn ctx) warns set = [ mkCaseProblemWarning x y | x <- lst, y<- lst , T.toUpper (name x) == T.toUpper (name y) - , name x < name y + , name x < name y ] where lst = toList set in addWarnings warnings $ return () @@ -228,7 +225,7 @@ pCtx2aCtx env , ctx_lang = ctxmLang , ctx_markup = pandocf , ctx_pats = p_patterns - , ctx_rs = p_rules + , ctx_rs = p_rules , ctx_ds = p_relations , ctx_cs = p_conceptdefs , ctx_ks = p_identdefs @@ -264,6 +261,7 @@ pCtx2aCtx env , ctxrs = Set.fromList rules , ctxds = Set.fromList relations , ctxpopus = udpops -- the content is copied from p_pops + , ctxcdsOutPats = allConceptDefsOutPats , ctxcds = allConceptDefs , ctxks = identdefs , ctxrrules = allRoleRules @@ -274,7 +272,7 @@ pCtx2aCtx env , ctxifcs = interfaces , ctxps = purposes , ctxmetas = p_metas - , ctxInfo = contextInfo + , ctxInfo = contextInfo } checkOtherAtomsInSessionConcept actx checkPurposes actx -- Check whether all purposes refer to existing objects @@ -312,6 +310,8 @@ pCtx2aCtx env , soloConcs = Set.filter (not . isInSystem genLattice) allConcs , gens_efficient = genLattice , conceptMap = conceptmap + , defaultLang = deflangCtxt + , defaultFormat = deffrmtCtxt } where gns = catMaybes $ pClassify2aClassify conceptmap <$> allGens @@ -321,10 +321,10 @@ pCtx2aCtx env -- | function `mkTypeMap` creates a lookup table of concepts with a representation. -- it is checked that concepts in the same conceptgroup share a common TType. mkTypeMap :: [[A_Concept]] -> [Representation] -> Guarded [(A_Concept , TType)] - mkTypeMap groups reprs + mkTypeMap groups reprs = f <$> traverse typeOfGroup groups <*> traverse typeOfSingle [c | c <- conceptsOfReprs, c `notElem` conceptsOfGroups] - where + where f :: [[(A_Concept,TType)]] -> [Maybe (A_Concept,TType,[Origin])] -> [(A_Concept , TType)] f typesOfGroups typesOfOthers = concat typesOfGroups <> map stripOrigin (catMaybes typesOfOthers) @@ -349,7 +349,7 @@ pCtx2aCtx env conceptsOfReprs = L.nub $ map fstOf3 reprTrios where fstOf3 (cpt,_,_)=cpt typeOfSingle :: A_Concept -> Guarded (Maybe (A_Concept,TType,[Origin])) - typeOfSingle cpt + typeOfSingle cpt = case filter ofCpt reprTrios of [] -> pure Nothing rs -> case L.nub (map getTType rs) of @@ -364,7 +364,7 @@ pCtx2aCtx env getTType :: (a,TType,b) -> TType getTType (_,t,_) = t typeOfGroup :: [A_Concept] -> Guarded [(A_Concept,TType)] - typeOfGroup grp + typeOfGroup grp = do singleTypes <- traverse typeOfSingle grp let typeList = catMaybes singleTypes case L.nub (map getTType typeList) of @@ -377,25 +377,25 @@ pCtx2aCtx env -- a. every two concepts in an element of `css` are connected. -- b. every `A_Concept` is in `css` connect :: [[A_Concept]] -> [[A_Concept]] -> [[A_Concept]] - connect typols gss = + connect typols gss = case gss of [] -> typols x:xs -> connect (t:typols) rest - where - (t,rest) = g' x xs + where + (t,rest) = g' x xs g' a as = case L.partition (disjoint a) as of (_,[]) -> (a,as) (hs',hs) -> g' (L.nub $ a <> concat hs) hs' -- | are two lists disjoint, with no elements in common. - disjoint :: Eq a => [a] -> [a] -> Bool + disjoint :: Eq a => [a] -> [a] -> Bool disjoint ys = null . L.intersect ys mkTypology :: [A_Concept] -> Guarded Typology - mkTypology cs = + mkTypology cs = case filter (not . isSpecific) cs of [] -> fatal "Every typology must have at least one specific concept." -- When this fatal occurs, there is something wrong with detecting cycles in the p-structure. - [r] -> pure + [r] -> pure Typology { tyroot = r , tyCpts = reverse . sortSpecific2Generic gns $ cs } @@ -403,12 +403,12 @@ pCtx2aCtx env case filter isInvolved gns of [] -> fatal "No involved gens" x:xs -> x NE.:| xs - where + where isSpecific :: A_Concept -> Bool isSpecific cpt = cpt `elem` map genspc (filter (not . isTrivial) gns) - where + where isTrivial g = - case g of + case g of Isa{} -> gengen g == genspc g IsE{} -> genrhs g == genspc g NE.:| [] isInvolved :: AClassify -> Bool @@ -418,7 +418,7 @@ pCtx2aCtx env conceptmap = makeConceptMap allGens p_interfaceAndDisambObjs :: DeclMap -> [(P_Interface, P_BoxItem (TermPrim, DisambPrim))] p_interfaceAndDisambObjs declMap = [ (ifc, disambiguate conceptmap (termPrimDisAmb conceptmap declMap) $ ifc_Obj ifc) | ifc <- p_interfaces ] - + -- story about genRules and genLattice -- the genRules is a list of equalities between concept sets, in which every set is interpreted as a conjunction of concepts -- the genLattice is the resulting optimized structure @@ -457,7 +457,7 @@ pCtx2aCtx env genLattice = optimize1 (foldr addEquality emptySystem completeRules) pClassify2aClassify :: ConceptMap -> PClassify -> Maybe AClassify - pClassify2aClassify fun pg = + pClassify2aClassify fun pg = case NE.tail (generics pg) of [] -> case filter (/= specCpt) [pCpt2aCpt fun . NE.head $ generics pg] of [] -> Nothing @@ -476,15 +476,15 @@ pCtx2aCtx env userConcept :: P_Concept -> Type userConcept P_ONE = BuiltIn TypeOfOne userConcept x = UserConcept (name x) - + pPop2aPop :: ContextInfo -> P_Population -> Guarded Population - pPop2aPop ci pop = + pPop2aPop ci pop = case pop of P_RelPopu{p_nmdr = nmdr, p_popps=aps, p_src = src, p_tgt = tgt} -> do dcl <- case p_mbSign nmdr of Nothing -> findDeclLooselyTyped declMap nmdr (name nmdr) (pCpt2aCpt cptMap <$> src) (pCpt2aCpt cptMap <$> tgt) _ -> namedRel2Decl cptMap declMap nmdr - + aps' <- traverse (pAtomPair2aAtomPair (representationOf ci) dcl) aps src' <- maybeOverGuarded (getAsConcept ci (origin pop) <=< (isMoreGeneric (origin pop) dcl Src . userConcept)) src tgt' <- maybeOverGuarded (getAsConcept ci (origin pop) <=< (isMoreGeneric (origin pop) dcl Tgt . userConcept)) tgt @@ -494,7 +494,7 @@ pCtx2aCtx env , poptgt = fromMaybe (target dcl) tgt' } P_CptPopu{} - -> let cpt = pCpt2aCpt cptMap (p_cpt pop) in + -> let cpt = pCpt2aCpt cptMap (p_cpt pop) in (\vals -> ACptPopu { popcpt = cpt , popas = vals @@ -506,7 +506,7 @@ pCtx2aCtx env = if givenType `elem` findExact genLattice (Atom (getConcept sourceOrTarget dcl) `Meet` Atom givenType) then pure givenType else mkTypeMismatchError o dcl sourceOrTarget givenType - + pObjDefDisamb2aObjDef :: ContextInfo -> P_BoxItem (TermPrim, DisambPrim) -> Guarded BoxItem pObjDefDisamb2aObjDef ci x = fmap fst (typecheckObjDef ci x) @@ -523,15 +523,16 @@ pCtx2aCtx env , vd_html = mHtml -- Html template , vd_ats = pvs -- view segments } - = (\vdts - -> Vd { vdpos = orig - , vdlbl = lbl - , vdcpt = pCpt2aCpt (conceptMap ci) cpt - , vdIsDefault = isDefault - , vdhtml = mHtml - , vdats = vdts - }) - <$> traverse typeCheckViewSegment (zip [0..] pvs) + = do segments <- traverse typeCheckViewSegment (zip [0..] pvs) + checkNoDoubleLables orig segments + let avd = Vd { vdpos = orig + , vdlbl = lbl + , vdcpt = pCpt2aCpt (conceptMap ci) cpt + , vdIsDefault = isDefault + , vdhtml = mHtml + , vdats = segments + } + return avd where typeCheckViewSegment :: (Integer, P_ViewSegment (TermPrim, DisambPrim)) -> Guarded ViewSegment typeCheckViewSegment (seqNr, seg) @@ -541,24 +542,24 @@ pCtx2aCtx env , vsmSeqNr = seqNr , vsmLoad = payload } - where + where typecheckPayload :: P_ViewSegmtPayLoad (TermPrim, DisambPrim) -> Guarded ViewSegmentPayLoad - typecheckPayload payload + typecheckPayload payload = case payload of - P_ViewExp term -> + P_ViewExp term -> do (viewExpr,(srcBounded,_)) <- typecheckTerm ci term - case userList (conceptMap ci) $toList$ findExact genLattice (flType$ lMeet c (source viewExpr)) of + case userList (conceptMap ci) . toList $ findExact genLattice (flType$ lMeet c (source viewExpr)) of [] -> mustBeOrdered (origin o) o (Src, source viewExpr, viewExpr) r@(h:_) -> if srcBounded || c `elem` r then pure (ViewExp (addEpsilonLeft genLattice h viewExpr)) else mustBeBound (origin seg) [(Tgt,viewExpr)] P_ViewText str -> pure$ ViewText str c = mustBeConceptBecauseMath ci (pConcToType (vd_cpt o)) - + isa :: Type -> Type -> Bool isa c1 c2 = c1 `elem` findExact genLattice (Atom c1 `Meet` Atom c2) -- shouldn't this Atom be called a Concept? SJC: Answer: we're using the constructor "Atom" in the lattice sense, not in the relation-algebra sense. c1 and c2 are indeed Concepts here isaC :: A_Concept -> A_Concept -> Bool isaC c1 c2 = aConcToType c1 `elem` findExact genLattice (Atom (aConcToType c1) `Meet` Atom (aConcToType c2)) - + typecheckObjDef :: ContextInfo -> P_BoxItem (TermPrim, DisambPrim) -> Guarded (BoxItem, Bool) typecheckObjDef declMap objDef = case objDef of @@ -575,14 +576,14 @@ pCtx2aCtx env case maybeObj of Just (newExpr,subStructures) -> return (obj crud (newExpr,srcBounded) (Just subStructures)) Nothing -> return (obj crud (objExpr,srcBounded) Nothing) - where + where lookupView :: Text -> Maybe P_ViewDef lookupView viewId = case [ vd | vd <- p_viewdefs, vd_lbl vd == viewId ] of [] -> Nothing vd:_ -> Just vd -- return the first one, if there are more, this is caught later on by uniqueness static check - + checkCrud :: Guarded() - checkCrud = + checkCrud = case (mCrud, subs) of (Just _ , Just P_InterfaceRef{si_isLink=False} ) -> Errors . pure $ mkCrudForRefInterfaceError orig @@ -590,13 +591,13 @@ pCtx2aCtx env typeCheckViewAnnotation :: Expression -> Maybe Text -> Guarded () typeCheckViewAnnotation _ Nothing = pure () typeCheckViewAnnotation objExpr (Just viewId) = - case lookupView viewId of + case lookupView viewId of Just vd -> let viewAnnCptStr = aConcToType $ target objExpr viewDefCptStr = pConcToType $ vd_cpt vd viewIsCompatible = viewAnnCptStr `isa` viewDefCptStr - in if viewIsCompatible + in if viewIsCompatible then pure () - else Errors . pure $ + else Errors . pure $ mkIncompatibleViewError objDef viewId viewAnnCptStr viewDefCptStr Nothing -> Errors . pure $ mkUndeclaredError "view" objDef viewId obj crud (e,sr) s @@ -618,16 +619,16 @@ pCtx2aCtx env },True) pCruds2aCruds :: Expression -> Maybe P_Cruds -> Guarded Cruds - pCruds2aCruds expr mCrud = - case mCrud of + pCruds2aCruds expr mCrud = + case mCrud of Nothing -> mostLiberalCruds (Origin "Default for Cruds") "" Just pc@(P_Cruds org userCrud ) | (length . L.nub . map toUpper) userCrudString == length userCrudString && all isValidChar userCrudString - -> warnings pc $ mostLiberalCruds org userCrud + -> warnings pc $ mostLiberalCruds org userCrud | otherwise -> Errors . pure $ mkInvalidCRUDError org userCrud where userCrudString = T.unpack userCrud - where + where isValidChar :: Char -> Bool isValidChar c = toUpper c `elem` ['C','R','U','D'] (defC, defR, defU, defD) = view defaultCrudL env @@ -640,7 +641,7 @@ pCtx2aCtx env , crudD = isFitForCrudD expr && f 'D' defD } where - f :: Char -> Bool -> Bool + f :: Char -> Bool -> Bool f c def' | toUpper c `elem` T.unpack str = True | toLower c `elem` T.unpack str = False @@ -649,8 +650,8 @@ pCtx2aCtx env warnings pc@(P_Cruds _ crd) aCruds = addWarnings warns aCruds where warns :: [Warning] - warns = map (mkCrudWarning pc) $ - [ + warns = map (mkCrudWarning pc) $ + [ [ "'C' was specified, but the expression " , " "<>showA expr , "doesn't allow for the creation of a new atom at its target concept ("<>name (target expr)<>") " @@ -694,9 +695,9 @@ pCtx2aCtx env ) pSubi2aSubi ci objExpr b o x = case x of - P_InterfaceRef{si_str = ifcId} + P_InterfaceRef{si_str = ifcId} -> do (refIfcExpr,_) <- case lookupDisambIfcObj (declDisambMap ci) ifcId of - Just disambObj -> typecheckTerm ci + Just disambObj -> typecheckTerm ci $ case disambObj of P_BxExpr{} -> obj_ctx disambObj -- term is type checked twice, but otherwise we need a more complicated type check method to access already-checked interfaces. TODO: hide possible duplicate errors in a nice way (that is: via CtxError) P_BxTxt {} -> fatal "TXT is not expected here." @@ -709,8 +710,8 @@ pCtx2aCtx env ) P_Box{} -> addWarnings warnings $ - build <$> traverse (fn <=< typecheckObjDef ci) l - <* uniqueNames "attribute within a BOX specification" (btKeys . si_header $ x) + build <$> traverse (fn <=< typecheckObjDef ci) l + <* uniqueNames "attribute within a BOX specification" (btKeys . si_header $ x) <* 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)] @@ -732,28 +733,28 @@ pCtx2aCtx env where matchWith :: (ObjectDef, Bool) -> Guarded ObjectDef matchWith (ojd,exprBound) = if b || exprBound then - case userList (conceptMap ci) $toList$ findExact genLattice (flType $ lMeet (target objExpr) (source . objExpression $ ojd)) of + case userList (conceptMap ci) . toList . findExact genLattice . flType . lMeet (target objExpr) . source . objExpression $ ojd of [] -> mustBeOrderedLst x [(source (objExpression ojd),Src, aObjectDef2pObjectDef $ BxExpr ojd)] (r:_) -> pure (ojd{objExpression=addEpsilonLeft genLattice r (objExpression ojd)}) else mustBeBound (origin ojd) [(Src,objExpression ojd),(Tgt,objExpr)] warnings :: [Warning] warnings = [mkBoxRowsnhWarning (origin x) | "ROWSNH" == (btType . si_header $ x) ] -- See issue #925 <>[mkNoBoxItemsWarning (origin x) | null (si_box x) ] - + typeCheckInterfaceRef :: P_BoxItem a -> Text -> Expression -> Expression -> Guarded Expression - typeCheckInterfaceRef objDef ifcRef objExpr ifcExpr = + typeCheckInterfaceRef objDef ifcRef objExpr ifcExpr = let expTarget = target objExpr ifcSource = source ifcExpr refIsCompatible = expTarget `isaC` ifcSource || ifcSource `isaC` expTarget - in if refIsCompatible - then pure $ addEpsilonRight genLattice ifcSource objExpr + in if refIsCompatible + then pure $ addEpsilonRight genLattice ifcSource objExpr else Errors . pure $ mkIncompatibleInterfaceError objDef expTarget ifcSource ifcRef lookupDisambIfcObj :: DeclMap -> Text -> Maybe (P_BoxItem (TermPrim, DisambPrim)) lookupDisambIfcObj declMap ifcId = case [ disambObj | (vd,disambObj) <- p_interfaceAndDisambObjs declMap, ifc_Name vd == ifcId ] of [] -> Nothing disambObj:_ -> Just disambObj -- return the first one, if there are more, this is caught later on by uniqueness static check - + -- this function helps in the disambiguation process: -- it adds a set of potential disambiguation outcomes to things that need to be disambiguated. For typed and untyped identities, singleton elements etc, this is immediate, but for relations we need to find it in the list of declarations. termPrimDisAmb :: ConceptMap -> DeclMap -> TermPrim -> (TermPrim, DisambPrim) @@ -772,21 +773,21 @@ pCtx2aCtx env disambNamedRel (PNamedRel _ r (Just s)) = findRelsTyped declMap r $ pSign2aSign fun s pIfc2aIfc :: ContextInfo -> (P_Interface, P_BoxItem (TermPrim, DisambPrim)) -> Guarded Interface - pIfc2aIfc declMap (pIfc, objDisamb) = + pIfc2aIfc declMap (pIfc, objDisamb) = build $ pObjDefDisamb2aObjDef declMap objDisamb - where + where build :: Guarded BoxItem -> Guarded Interface - build gb = + build gb = case gb of Errors x -> Errors x - Checked obj' ws -> + Checked obj' ws -> addWarnings ws $ case obj' of BxExpr o -> case ttype . target . objExpression $ o of - Object -> + Object -> pure Ifc { ifcIsAPI = ifc_IsAPI pIfc - , ifcname = name pIfc + , ifcname = name pIfc , ifcRoles = ifc_Roles pIfc , ifcObj = o , ifcControls = [] -- to be enriched in Adl2fSpec with rules to be checked @@ -805,24 +806,30 @@ pCtx2aCtx env , arRules = mRules prr , arPos = origin prr } - + pPat2aPat :: ContextInfo -> P_Pattern -> Guarded Pattern pPat2aPat ci ppat = f <$> traverse (pRul2aRul ci (Just $ name ppat)) (pt_rls ppat) - <*> traverse (pIdentity2aIdentity ci (Just $ name ppat)) (pt_ids ppat) + <*> traverse (pIdentity2aIdentity ci (Just $ name ppat)) (pt_ids ppat) <*> traverse (pPop2aPop ci) (pt_pop ppat) - <*> traverse (pViewDef2aViewDef ci) (pt_vds ppat) + <*> traverse (pViewDef2aViewDef ci) (pt_vds ppat) <*> traverse (pPurp2aPurp ci) (pt_xps ppat) <*> traverse (pDecl2aDecl cptMap (Just $ name ppat) deflangCtxt deffrmtCtxt) (pt_dcs ppat) + <*> traverse (pure.pConcDef2aConcDef (defaultLang ci) (defaultFormat ci)) (pt_cds ppat) + <*> traverse (pure.pRoleRule2aRoleRule) (pt_RRuls ppat) + <*> traverse pure (pt_Reprs ppat) where - f rules' keys' pops' views' xpls relations + f rules' keys' pops' views' xpls relations conceptdefs roleRules representations = A_Pat { ptnm = name ppat , ptpos = origin ppat , ptend = pt_end ppat , ptrls = Set.fromList rules' , ptgns = catMaybes $ pClassify2aClassify (conceptMap ci) <$> pt_gns ppat , ptdcs = Set.fromList relations - , ptups = pops' + , ptrrs = roleRules + , ptcds = conceptdefs + , ptrps = representations + , ptups = pops' , ptids = keys' , ptvds = views' , ptxps = xpls @@ -830,7 +837,7 @@ pCtx2aCtx env pRul2aRul :: ContextInfo -> Maybe Text -- name of pattern the rule is defined in (if any) -> P_Rule TermPrim -> Guarded Rule pRul2aRul ci mPat = typeCheckRul ci mPat . disambiguate (conceptMap ci) (termPrimDisAmb (conceptMap ci) (declDisambMap ci)) - typeCheckRul :: ContextInfo -> + typeCheckRul :: ContextInfo -> Maybe Text -- name of pattern the rule is defined in (if any) -> P_Rule (TermPrim, DisambPrim) -> Guarded Rule typeCheckRul ci mPat P_Rule { pos = orig @@ -851,7 +858,7 @@ pCtx2aCtx env , rrdcl = Nothing , rrpat = mPat , r_usr = UserDefined - , isSignal = not . any (\x -> nm `elem` arRules x) $ allRoleRules + , isSignal = not . any (\x -> nm `elem` arRules x) $ allRoleRules } pIdentity2aIdentity :: ContextInfo -> Maybe Text -- name of pattern the rule is defined in (if any) @@ -873,7 +880,7 @@ pCtx2aCtx env do ob <- pObjDefDisamb2aObjDef ci ojd case ob of BxExpr o -> - case toList$ findExact genLattice $ aConcToType (source $ objExpression o) `lJoin` aConcToType conc of + case toList . findExact genLattice $ aConcToType (source $ objExpression o) `lJoin` aConcToType conc of [] -> mustBeOrdered orig (Src, origin ojd, objExpression o) pidt _ -> pure $ IdentityExp o{objExpression = addEpsilonLeft genLattice conc (objExpression o)} BxTxt t -> fatal $ "TXT is not expected in IDENT statements. ("<>tshow (origin t)<>")" @@ -893,10 +900,10 @@ pCtx2aCtx env mustBeBound o [(Src, e)] pPurp2aPurp :: ContextInfo -> PPurpose -> Guarded Purpose pPurp2aPurp ci - PRef2 { pos = orig -- :: Origin - , pexObj = objref -- :: PRefObj - , pexMarkup = pmarkup -- :: P_Markup - , pexRefIDs = refIds -- :: [Text] + PRef2 { pos = orig -- :: Origin + , pexObj = objref -- :: PRefObj + , pexMarkup = pmarkup -- :: P_Markup + , pexRefIDs = refIds -- :: [Text] } = (\ obj -> Expl { explPos = orig , explObj = obj @@ -914,10 +921,12 @@ pCtx2aCtx env pRefObj2aRefObj _ (PRef2Pattern s ) = pure$ ExplPattern s pRefObj2aRefObj _ (PRef2Interface s ) = pure$ ExplInterface s pRefObj2aRefObj _ (PRef2Context s ) = pure$ ExplContext s - allConceptDefs :: [ConceptDef] - allConceptDefs = p_conceptdefs<>concatMap pt_cds p_patterns + allConceptDefsOutPats :: [AConceptDef] + allConceptDefsOutPats = map (pConcDef2aConcDef deflangCtxt deffrmtCtxt) p_conceptdefs + allConceptDefs :: [AConceptDef] + allConceptDefs = map (pConcDef2aConcDef deflangCtxt deffrmtCtxt) (p_conceptdefs<>concatMap pt_cds p_patterns) allRoleRules :: [A_RoleRule] - allRoleRules = map pRoleRule2aRoleRule + allRoleRules = map pRoleRule2aRoleRule (p_roleRules <> concatMap pt_RRuls p_patterns) leastConcept :: Op1EqualitySystem Type -> A_Concept -> A_Concept -> A_Concept @@ -947,11 +956,11 @@ typecheckTerm ci tct -> (x, (True, True)) <$ pAtomValue2aAtomValue (representationOf ci) c s _ -> return - (x, + (x, case t of PVee _ -> (False, False) _ -> (True, True)) - ) + ) =<< pDisAmb2Expr (t, v) PEqu _ a b -> join $ binary (.==.) (MBE (Src,fst) (Src,snd), MBE (Tgt,fst) (Tgt,snd)) <$> tt a <*> tt b PInc _ a b -> join $ binary (.|-.) (MBG (Src,snd) (Src,fst), MBG (Tgt,snd) (Tgt,fst)) <$> tt a <*> tt b @@ -968,7 +977,7 @@ typecheckTerm ci tct PKl1 _ a -> unary EKl1 (UNI (Src, id) (Tgt, id), UNI (Src, id) (Tgt, id)) =<< tt a PFlp _ a -> (\(x,(s,t)) -> (EFlp x, (t,s))) <$> tt a PCpl _ a -> (\(x,_) -> (ECpl x,(False,False))) <$> tt a - PBrk _ e -> first EBrk <$> tt e + PBrk _ e -> first EBrk <$> tt e where cptMap = conceptMap ci genLattice = gens_efficient ci @@ -1011,8 +1020,8 @@ typecheckTerm ci tct unary cbn tp e1 = wrap (fst e1) <$> deriv tp e1 where wrap expr ((src,b1), (tgt,b2)) = (cbn (addEpsilon genLattice src tgt expr), (b1, b2)) - binary' cbn preConcept tp side1 side2 e1 e2 = - do a <- deriv1 (fmap (resolve (e1,e2)) preConcept) + binary' cbn preConcept tp side1 side2 e1 e2 = + do a <- deriv1 (fmap (resolve (e1,e2)) preConcept) b <- deriv' tp (e1,e2) wrap (fst e1,fst e2) a b where @@ -1037,11 +1046,11 @@ typecheckTerm ci tct ) <$> getAndCheckType lMeet (p1, b1, e1) (p2, b2, e2) where getExactType flf (p1,e1) (p2,e2) - = case userList cptMap $toList$ findExact genLattice (flType$ flf (getAConcept p1 e1) (getAConcept p2 e2)) of + = case userList cptMap . toList . findExact genLattice . flType $ flf (getAConcept p1 e1) (getAConcept p2 e2) of [] -> mustBeOrdered o (p1,e1) (p2,e2) h:_ -> pure h getAndCheckType flf (p1,b1,e1) (p2,b2,e2) - = case fmap (userList cptMap . toList)$toList$ findUpperbounds genLattice (flType$ flf (getAConcept p1 e1) (getAConcept p2 e2)) of -- note: we could have used GetOneGuarded, but this yields more specific error messages + = case userList cptMap . toList <$> (toList . findUpperbounds genLattice . flType $ flf (getAConcept p1 e1) (getAConcept p2 e2)) of -- note: we could have used GetOneGuarded, but this yields more specific error messages [] -> mustBeOrdered o (p1,e1) (p2,e2) [r@(h:_)] -> case (b1 || elem (getAConcept p1 e1) r,b2 || elem (getAConcept p2 e2) r ) of @@ -1050,8 +1059,8 @@ typecheckTerm ci tct lst -> mustBeOrderedConcLst o (p1,e1) (p2,e2) lst pAtomPair2aAtomPair :: (A_Concept -> TType) -> Relation -> PAtomPair -> Guarded AAtomPair -pAtomPair2aAtomPair typ dcl pp = - mkAtomPair +pAtomPair2aAtomPair typ dcl pp = + mkAtomPair <$> pAtomValue2aAtomValue typ (source dcl) (ppLeft pp) <*> pAtomValue2aAtomValue typ (target dcl) (ppRight pp) @@ -1103,6 +1112,28 @@ pDisAmb2Expr (_,Known x) = pure x pDisAmb2Expr (_,Rel [x]) = pure x pDisAmb2Expr (o,dx) = cannotDisambiguate o dx +pConcDef2aConcDef :: + Lang -> -- The default language + PandocFormat -> -- The default pandocFormatPConceptDef + PConceptDef -> + AConceptDef +pConcDef2aConcDef defLanguage defFormat pCd = + AConceptDef + { pos = origin pCd, + acdcpt = name pCd, + acddef2 = pCDDef2Mean defLanguage defFormat $ cddef2 pCd, + acdmean = map (pMean2aMean defLanguage defFormat) (cdmean pCd), + acdfrom = cdfrom pCd + } +pCDDef2Mean :: Lang -- The default language + -> PandocFormat -- The default pandocFormat + -> PCDDef -> Meaning +pCDDef2Mean defLanguage defFormat x = case x of + PCDDefLegacy defStr refStr -> + Meaning Markup{ amLang = defLanguage + , amPandoc = string2Blocks defFormat (defStr <> if T.null refStr then mempty else "["<>refStr<>"]") + } + PCDDefNew m -> pMean2aMean defLanguage defFormat m pMean2aMean :: Lang -- The default language -> PandocFormat -- The default pandocFormat -> PMeaning -> Meaning @@ -1172,7 +1203,7 @@ instance Functor TT where fmap f (ISC a b) = ISC (f a) (f b) fmap f (MBE a b) = MBE (f a) (f b) fmap f (MBG a b) = MBG (f a) (f b) - + getAConcept :: HasSignature a => SrcOrTgt -> a -> A_Concept getAConcept Src = source getAConcept Tgt = target diff --git a/src/Ampersand/ADL1/PrettyPrinters.hs b/src/Ampersand/ADL1/PrettyPrinters.hs index 93a520164b..01be178efd 100644 --- a/src/Ampersand/ADL1/PrettyPrinters.hs +++ b/src/Ampersand/ADL1/PrettyPrinters.hs @@ -207,10 +207,13 @@ instance Pretty (P_Rule TermPrim) where where rName = if T.null nm then empty else maybeQuote nm <> text ":" -instance Pretty ConceptDef where - pretty (Cd _ cpt def ref _) -- from, the last argument, is not used in the parser +instance Pretty PConceptDef where + pretty (PConceptDef _ cpt def mean _) -- from, the last argument, is not used in the parser = text "CONCEPT" <+> quoteConcept cpt - <+> quote def <+> maybeText ref + <+> pretty def <+\> perline mean +instance Pretty PCDDef where + pretty (PCDDefNew mean) = pretty mean + pretty (PCDDefLegacy def ref) = quote def <+> maybeText ("["<>ref<>"]") where maybeText txt = if T.null txt then empty else quote txt diff --git a/src/Ampersand/Basics/PandocExtended.hs b/src/Ampersand/Basics/PandocExtended.hs index 60c23ea34a..5b59137bc7 100644 --- a/src/Ampersand/Basics/PandocExtended.hs +++ b/src/Ampersand/Basics/PandocExtended.hs @@ -9,17 +9,18 @@ module Ampersand.Basics.PandocExtended where import Ampersand.Basics.Languages -import Ampersand.Basics.Prelude +import Ampersand.Basics.Prelude hiding (toList) import Ampersand.Basics.Unique import Ampersand.Basics.Version import qualified RIO.Text as T import Text.Pandoc hiding (Meta) +import Text.Pandoc.Builder hiding (str) data PandocFormat = HTML | ReST | LaTeX | Markdown deriving (Eq, Show, Ord, Enum, Bounded) data Markup = Markup { amLang :: Lang -- No Maybe here! In the A-structure, it will be defined by the default if the P-structure does not define it. In the P-structure, the language is optional. - , amPandoc :: [Block] + , amPandoc :: Blocks } deriving (Show, Eq, Ord, Typeable, Data) instance Unique Markup where showUnique = tshow @@ -29,21 +30,21 @@ instance Unique Markup where aMarkup2String :: Markup -> Text aMarkup2String = blocks2String . amPandoc where - blocks2String :: [Block] -> Text + blocks2String :: Blocks -> Text blocks2String ec - = case runPure $ writeMarkdown def (Pandoc nullMeta ec) of + = case runPure $ writeMarkdown def (Pandoc nullMeta (toList ec)) of Left pandocError -> fatal $ "Pandoc error: "<>tshow pandocError Right txt -> txt -- | use a suitable format to read generated strings. if you have just normal text, ReST is fine. -- | defaultPandocReader should be used on user-defined strings. -string2Blocks :: PandocFormat -> Text -> [Block] +string2Blocks :: PandocFormat -> Text -> Blocks string2Blocks defaultformat str = case runPure $ theParser (removeCRs str) of Left err -> fatal ("Proper error handling of Pandoc is still TODO." - <>"\n This particular error is cause by some "<>tshow defaultformat<>" in your script:" + <>"\n This particular error is caused by some "<>tshow defaultformat<>" in your script:" <>"\n"<>tshow err) - Right (Pandoc _ blocks) -> blocks + Right (Pandoc _ blocks) -> fromList blocks where theParser = case defaultformat of diff --git a/src/Ampersand/Classes/ConceptStructure.hs b/src/Ampersand/Classes/ConceptStructure.hs index beecc4202e..9416b4975b 100644 --- a/src/Ampersand/Classes/ConceptStructure.hs +++ b/src/Ampersand/Classes/ConceptStructure.hs @@ -57,7 +57,7 @@ instance ConceptStructure A_Context where concs ctx = Set.unions -- ONE and [SESSION] are allways in any context. (see https://github.com/AmpersandTarski/ampersand/issues/70) [ Set.singleton ONE -- , Set.singleton (makeConcept "SESSION") --SESSION is in PrototypeContext.adl - , (concs . ctxcds) ctx + , (concs . ctxcdsOutPats) ctx , (concs . ctxds) ctx , (concs . ctxgs) ctx , (concs . ctxifcs) ctx @@ -110,8 +110,8 @@ instance ConceptStructure A_Concept where concs c = Set.singleton c expressionsIn _ = Set.empty -instance ConceptStructure ConceptDef where - concs _ = Set.empty -- singleton . makeConcept . name -- TODO: To do this properly, we need to separate Conceptdef into P_ConceptDef and A_ConceptDef +instance ConceptStructure AConceptDef where + concs _ = Set.empty -- singleton . makeConcept . name -- TODO: To do this properly, we need to separate Conceptdef into PConceptDef and A_ConceptDef expressionsIn _ = Set.empty instance ConceptStructure Signature where diff --git a/src/Ampersand/Classes/ViewPoint.hs b/src/Ampersand/Classes/ViewPoint.hs index 04689f7b11..367db2768b 100644 --- a/src/Ampersand/Classes/ViewPoint.hs +++ b/src/Ampersand/Classes/ViewPoint.hs @@ -41,17 +41,11 @@ rulesFromIdentity identity where (h NE.:| t) = fmap ((\ expr -> expr .:. flp expr) . objExpression . segment) . identityAts $ identity - meaningEN :: Text - meaningEN = "Identity rule" <> ", following from identity "<>name identity - meaningNL = "Identiteitsregel" <> ", volgend uit identiteit "<>name identity mkKeyRule expression = Ru { rrnm = "identity_" <> name identity , formalExpression = expression , rrfps = origin identity -- position in source file - , rrmean = - [ Meaning $ Markup English (string2Blocks ReST meaningEN) - , Meaning $ Markup Dutch (string2Blocks ReST meaningNL) - ] + , rrmean = map toMeaning [minBound ..] , rrmsg = [] , rrviol = Nothing , rrdcl = Nothing -- This rule was not generated from a property of some relation. @@ -59,6 +53,11 @@ rulesFromIdentity identity , r_usr = Identity -- This rule was not specified as a rule in the Ampersand script, but has been generated by a computer , isSignal = False -- This is not a signal rule } + where toMeaning lang = + Meaning . Markup lang . string2Blocks ReST $ + case lang of + English -> "Identity rule, following from identity "<>name identity + Dutch -> "Identiteitsregel, volgend uit identiteit "<>name identity instance (Eq a,Language a) => Language [a] where relsDefdIn = Set.unions . map relsDefdIn diff --git a/src/Ampersand/Commands/Test.hs b/src/Ampersand/Commands/Test.hs index 2a84182b21..29a62ed1de 100644 --- a/src/Ampersand/Commands/Test.hs +++ b/src/Ampersand/Commands/Test.hs @@ -1,48 +1,32 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} -- | Generate a prototype from a project. module Ampersand.Commands.Test - (test - ,HasTestOpts(..) - ) where + ( test, + HasTestOpts (..), + ) +where + +import Ampersand.Basics +import Ampersand.Misc.HasClasses (HasTestOpts (..)) +import Ampersand.Test.Parser.QuickChecks +import Ampersand.Test.Regression (regressionTest) +import Ampersand.Types.Config (HasRunner) -import Ampersand.Basics -import Ampersand.Misc.HasClasses -import Ampersand.Types.Config -import Ampersand.Test.Parser.QuickChecks -import Ampersand.Test.Regression -import qualified RIO.Text as T test :: (HasTestOpts env, HasRunner env) => RIO env () test = do parserRoundtripTest regressionTest - parserRoundtripTest :: (HasRunner env) => RIO env () -parserRoundtripTest = do - logInfo "Starting Quickcheck tests." - funcs <- testFunctions - -- testAmpersandScripts - tests funcs - where - tests :: (HasLogFunc env) => [([Text], RIO env Bool)] -> RIO env () - tests [] = pure () - tests ((msg,tst):xs) = do - mapM_ (logInfo .display) msg - success <- tst - if success then tests xs - else exitWith (SomeTestsFailed ["*** Some tests failed***"]) - testFunctions :: RIO env [([Text], RIO env Bool)] - testFunctions = do - (parserCheckResult, msg) <- parserQuickChecks - return [ ( if parserCheckResult - then ["Parser & prettyprinter test PASSED."] - else T.lines . T.intercalate "\n " $ - ["QuickCheck found errors in the roundtrip in parsing/prettyprinting for the following case:"] - <>T.lines msg - , return parserCheckResult - ) - ] +parserRoundtripTest = do + logInfo "Starting Quickcheck tests." + success <- doAllQuickCheckPropertyTests + if success + then logInfo "βœ… Passed." + else do + logError "❗❗❗ Failed. Quickcheck tests." + exitWith (SomeTestsFailed ["Quickcheck test failed!"]) \ No newline at end of file diff --git a/src/Ampersand/Core/A2P_Converters.hs b/src/Ampersand/Core/A2P_Converters.hs index 467a598f33..9d623f148a 100644 --- a/src/Ampersand/Core/A2P_Converters.hs +++ b/src/Ampersand/Core/A2P_Converters.hs @@ -36,7 +36,7 @@ aCtx2pCtx ctx = , ctx_pats = map aPattern2pPattern . ctxpats $ ctx , ctx_rs = map aRule2pRule . Set.elems . ctxrs $ ctx , ctx_ds = map aRelation2pRelation . Set.elems . ctxds $ ctx - , ctx_cs = ctxcds ctx + , ctx_cs = map aConcDef2pConcDef $ ctxcdsOutPats ctx , ctx_ks = map aIdentityDef2pIdentityDef . ctxks $ ctx , ctx_rrules = map aRoleRule2pRoleRule .ctxrrules $ ctx , ctx_reprs = reprList (ctxInfo ctx) @@ -47,7 +47,17 @@ aCtx2pCtx ctx = , ctx_pops = map aPopulation2pPopulation . ctxpopus $ ctx , ctx_metas = ctxmetas ctx } - + +aConcDef2pConcDef :: AConceptDef -> PConceptDef +aConcDef2pConcDef aCd = + PConceptDef + { pos = origin aCd, + cdcpt = name aCd, + cddef2 = PCDDefNew (aMeaning2pMeaning $ acddef2 aCd), + cdmean = map aMeaning2pMeaning $ acdmean aCd, + cdfrom = acdfrom aCd + } + aPattern2pPattern :: Pattern -> P_Pattern aPattern2pPattern pat = P_Pat { pos = ptpos pat @@ -55,8 +65,8 @@ aPattern2pPattern pat = , pt_rls = map aRule2pRule . Set.elems . ptrls $ pat , pt_gns = map aClassify2pClassify . ptgns $ pat , pt_dcs = map aRelation2pRelation . Set.elems . ptdcs $ pat - , pt_RRuls = [] --TODO: should this be empty? There is nothing in the A-structure - , pt_cds = [] --TODO: should this be empty? There is nothing in the A-structure + , pt_RRuls = map aRoleRule2pRoleRule . ptrrs $ pat + , pt_cds = map aConcDef2pConcDef (ptcds pat) , pt_Reprs = [] --TODO: should this be empty? There is nothing in the A-structure , pt_ids = map aIdentityDef2pIdentityDef . ptids $ pat , pt_vds = map aViewDef2pViewDef . ptvds $ pat diff --git a/src/Ampersand/Core/AbstractSyntaxTree.hs b/src/Ampersand/Core/AbstractSyntaxTree.hs index 273f4f226f..e41f45f45e 100644 --- a/src/Ampersand/Core/AbstractSyntaxTree.hs +++ b/src/Ampersand/Core/AbstractSyntaxTree.hs @@ -33,6 +33,7 @@ module Ampersand.Core.AbstractSyntaxTree ( , Expression(..) , getExpressionRelation , A_Concept(..), A_Concepts + , AConceptDef(..) , ShowWithAliases(..) , Meaning(..) , A_RoleRule(..) @@ -57,7 +58,7 @@ import Ampersand.Basics import Ampersand.Core.ParseTree ( Meta(..) , Role(..) - , ConceptDef, P_Concept(..), mkPConcept, PClassify(specific,generics) + , P_Concept(..), mkPConcept, PClassify(specific,generics) , Origin(..) , maybeOrdering , Traced(..) @@ -89,7 +90,8 @@ data A_Context , ctxrs :: Rules -- ^ All user defined rules in this context, but outside patterns and outside processes , ctxds :: Relations -- ^ The relations that are declared in this context, outside the scope of patterns , ctxpopus :: [Population] -- ^ The user defined populations of relations defined in this context, including those from patterns and processes - , ctxcds :: [ConceptDef] -- ^ The concept definitions defined in this context, including those from patterns and processes + , ctxcdsOutPats :: [AConceptDef] -- ^ The concept definitions defined outside the patterns of this context. + , ctxcds :: [AConceptDef] -- ^ The concept definitions defined in this context, including those from patterns and processes , ctxks :: [IdentityDef] -- ^ The identity definitions defined in this context, outside the scope of patterns , ctxrrules :: [A_RoleRule] , ctxreprs :: A_Concept -> TType @@ -111,17 +113,20 @@ instance Named A_Context where name = ctxnm data Pattern - = A_Pat { ptnm :: Text -- ^ Name of this pattern - , ptpos :: Origin -- ^ the position in the file in which this pattern was declared. - , ptend :: Origin -- ^ the end position in the file, elements with a position between pos and end are elements of this pattern. - , ptrls :: Rules -- ^ The user defined rules in this pattern - , ptgns :: [AClassify] -- ^ The generalizations defined in this pattern - , ptdcs :: Relations -- ^ The relations that are declared in this pattern - , ptups :: [Population] -- ^ The user defined populations in this pattern - , ptids :: [IdentityDef] -- ^ The identity definitions defined in this pattern - , ptvds :: [ViewDef] -- ^ The view definitions defined in this pattern - , ptxps :: [Purpose] -- ^ The purposes of elements defined in this pattern - } deriving (Typeable) -- Show for debugging purposes + = A_Pat { ptnm :: Text -- ^ Name of this pattern + , ptpos :: Origin -- ^ the position in the file in which this pattern was declared. + , ptend :: Origin -- ^ the end position in the file, elements with a position between pos and end are elements of this pattern. + , ptrls :: Rules -- ^ The user defined rules in this pattern + , ptgns :: [AClassify] -- ^ The generalizations defined in this pattern + , ptdcs :: Relations -- ^ The relations that are declared in this pattern + , ptrrs :: [A_RoleRule] -- ^ The role-rule assignments that are declared in this pattern + , ptcds :: [AConceptDef] -- ^ The concept definitions that are declared in this pattern + , ptrps :: [Representation] -- ^ The concept definitions that are declared in this pattern + , ptups :: [Population] -- ^ The user defined populations in this pattern + , ptids :: [IdentityDef] -- ^ The identity definitions defined in this pattern + , ptvds :: [ViewDef] -- ^ The view definitions defined in this pattern + , ptxps :: [Purpose] -- ^ The purposes of elements defined in this pattern + } deriving (Typeable) -- Show for debugging purposes instance Eq Pattern where a == b = compare a b == EQ instance Unique Pattern where @@ -133,7 +138,28 @@ instance Named Pattern where instance Traced Pattern where origin = ptpos - +data AConceptDef = AConceptDef + { pos :: !Origin -- ^ The position of this definition in the text of the Ampersand source (filename, line number and column number). + , acdcpt :: !Text -- ^ The name of the concept for which this is the definition. If there is no such concept, the conceptdefinition is ignored. + , acddef2 :: !Meaning -- ^ The textual definition of this concept. + , acdmean :: ![Meaning] -- ^ User-specified meanings, possibly more than one, for multiple languages. + , acdfrom:: !Text -- ^ The name of the pattern or context in which this concept definition was made --TODO: Refactor to Maybe Pattern. + } deriving (Show,Typeable) +instance Named AConceptDef where + name = acdcpt +instance Traced AConceptDef where + origin = pos +instance Ord AConceptDef where + compare a b = case compare (name a) (name b) of + EQ -> fromMaybe (fatal . T.intercalate "\n" $ + ["ConceptDef should have a non-fuzzy Origin." + , tshow (origin a) + , tshow (origin b) + ]) + (maybeOrdering (origin a) (origin b)) + x -> x +instance Eq AConceptDef where + a == b = compare a b == EQ data A_RoleRule = A_RoleRule { arPos :: Origin , arRoles :: NE.NonEmpty Role , arRules :: NE.NonEmpty Text -- the names of the rules @@ -880,14 +906,36 @@ class HasSignature rel where -- Convenient data structure to hold information about concepts and their representations -- in a context. data ContextInfo = - CI { ctxiGens :: [AClassify] -- The generalisation relations in the context - , representationOf :: A_Concept -> TType -- a list containing all user defined Representations in the context - , multiKernels :: [Typology] -- a list of typologies, based only on the CLASSIFY statements. Single-concept typologies are not included - , reprList :: [Representation] -- a list of all Representations - , declDisambMap :: Map.Map Text (Map.Map SignOrd Expression) -- a map of declarations and the corresponding types - , soloConcs :: Set.Set Type -- types not used in any declaration - , gens_efficient :: Op1EqualitySystem Type -- generalisation relations again, as a type system (including phantom types) - , conceptMap :: ConceptMap -- a map that must be used to convert P_Concept to A_Concept + CI { + -- | The generalisation relations in the context + ctxiGens :: [AClassify] + , + -- | a list containing all user defined Representations in the context + representationOf :: A_Concept -> TType + , + -- | a list of typologies, based only on the CLASSIFY statements. Single-concept typologies are not included + multiKernels :: [Typology] + , + -- | a list of all Representations + reprList :: [Representation] + , + -- | a map of declarations and the corresponding types + declDisambMap :: Map.Map Text (Map.Map SignOrd Expression) + , + -- | types not used in any declaration + soloConcs :: Set.Set Type + , + -- | generalisation relations again, as a type system (including phantom types) + gens_efficient :: Op1EqualitySystem Type + , + -- | a map that must be used to convert P_Concept to A_Concept + conceptMap :: ConceptMap + , + -- | the default language used to interpret markup texts in this context + defaultLang :: Lang + , + -- | the default format used to interpret markup texts in this context + defaultFormat :: PandocFormat } instance Named Type where diff --git a/src/Ampersand/Core/ParseTree.hs b/src/Ampersand/Core/ParseTree.hs index 87d117ccb9..6f0935682a 100644 --- a/src/Ampersand/Core/ParseTree.hs +++ b/src/Ampersand/Core/ParseTree.hs @@ -14,7 +14,7 @@ module Ampersand.Core.ParseTree ( , BoxHeader(..), TemplateKeyValue(..) , SrcOrTgt(..) , P_Rule(..) - , ConceptDef(..) + , PConceptDef(..), PCDDef(..) , Representation(..), TType(..) , P_Population(..) , PAtomPair(..), PAtomValue(..), mkPair, makePSingleton @@ -55,7 +55,7 @@ data P_Context , ctx_pats :: [P_Pattern] -- ^ The patterns defined in this context , ctx_rs :: [P_Rule TermPrim] -- ^ All user defined rules in this context, but outside patterns and outside processes , ctx_ds :: [P_Relation] -- ^ The relations defined in this context, outside the scope of patterns - , ctx_cs :: [ConceptDef] -- ^ The concept definitions defined in this context, outside the scope of patterns + , ctx_cs :: [PConceptDef] -- ^ The concept definitions defined in this context, outside the scope of patterns , ctx_ks :: [P_IdentDef] -- ^ The identity definitions defined in this context, outside the scope of patterns , ctx_rrules :: [P_RoleRule] -- ^ The MAINTAIN definitions defined in this context, outside the scope of patterns , ctx_reprs :: [Representation] @@ -110,7 +110,7 @@ data P_Pattern , pt_gns :: [PClassify] -- ^ The generalizations defined in this pattern , pt_dcs :: [P_Relation] -- ^ The relations that are declared in this pattern , pt_RRuls :: [P_RoleRule] -- ^ The assignment of roles to rules. - , pt_cds :: [ConceptDef] -- ^ The concept definitions defined in this pattern + , pt_cds :: [PConceptDef] -- ^ The concept definitions defined in this pattern , pt_Reprs :: [Representation] -- ^ The type into which concepts is represented , pt_ids :: [P_IdentDef] -- ^ The identity definitions defined in this pattern , pt_vds :: [P_ViewDef] -- ^ The view definitions defined in this pattern @@ -136,14 +136,21 @@ instance Named P_Pattern where instance Traced P_Pattern where origin = pos -data ConceptDef - = Cd { pos :: Origin -- ^ The position of this definition in the text of the Ampersand source (filename, line number and column number). - , cdcpt :: Text -- ^ The name of the concept for which this is the definition. If there is no such concept, the conceptdefinition is ignored. - , cddef :: Text -- ^ The textual definition of this concept. - , cdref :: Text -- ^ A label meant to identify the source of the definition. (useful as LaTeX' symbolic reference) - , cdfrom:: Text -- ^ The name of the pattern or context in which this concept definition was made - } deriving (Show,Typeable) -instance Ord ConceptDef where +data PConceptDef = PConceptDef + { -- | The position of this definition in the text of the Ampersand source (filename, line number and column number). + pos :: !Origin, + -- | The name of the concept for which this is the definition. If there is no such concept, the conceptdefinition is ignored. + cdcpt :: !Text, + -- | The textual definition of this concept. + cddef2 :: !PCDDef, + -- | A label meant to identify the source of the definition. (useful as LaTeX' symbolic reference) + cdmean :: ![PMeaning], + -- | The name of the pattern or context in which this concept definition was made + cdfrom :: !Text + } + deriving (Show, Typeable) + +instance Ord PConceptDef where compare a b = case compare (name a) (name b) of EQ -> fromMaybe (fatal . T.intercalate "\n" $ ["ConceptDef should have a non-fuzzy Origin." @@ -152,15 +159,30 @@ instance Ord ConceptDef where ]) (maybeOrdering (origin a) (origin b)) x -> x -instance Eq ConceptDef where +instance Eq PConceptDef where a == b = compare a b == EQ -instance Unique ConceptDef where +instance Unique PConceptDef where showUnique cd = cdcpt cd<>"At"<>tshow (typeOf x) <>"_" <> tshow x where x = origin cd -instance Traced ConceptDef where +instance Traced PConceptDef where origin = pos -instance Named ConceptDef where +instance Named PConceptDef where name = cdcpt + +-- | Data structure to implement the change to the new way to specify +-- the definition part of a concept. By using this structure, we can +-- implement the change in a fully backwards compatible way. +data PCDDef + = PCDDefLegacy + { -- | The textual definition of this concept. + pcddef :: !Text, + -- | A label meant to identify the source of the definition. (useful as LaTeX' symbolic reference) + pcdref :: !Text + } + | PCDDefNew + { pcdmean :: !PMeaning + } + deriving (Show, Typeable) data Representation = Repr { pos :: Origin , reprcpts :: NE.NonEmpty P_Concept -- ^ the concepts diff --git a/src/Ampersand/FSpec/FSpec.hs b/src/Ampersand/FSpec/FSpec.hs index d5a6973aab..e5e2b820ef 100644 --- a/src/Ampersand/FSpec/FSpec.hs +++ b/src/Ampersand/FSpec/FSpec.hs @@ -105,7 +105,7 @@ data FSpec = FSpec { fsName :: Text -- ^ generated: The data structure containing the generalization structure of concepts , vpatterns :: [Pattern] -- ^ All patterns taken from the Ampersand script - , conceptDefs :: [ConceptDef] + , conceptDefs :: [AConceptDef] -- ^ All concept definitions defined throughout a context, including those inside patterns and processes , fSexpls :: Set.Set Purpose -- ^ All purposes that have been declared anywhere in the current specification, including the patterns and interfaces. @@ -192,7 +192,7 @@ instance Unique A_Pair where showUnique x = showUnique (lnkDcl x) <> showUnique (lnkLeft x) <> showUnique (lnkRight x) -concDefs :: FSpec -> A_Concept -> [ConceptDef] +concDefs :: FSpec -> A_Concept -> [AConceptDef] concDefs fSpec c = case c of ONE -> [] diff --git a/src/Ampersand/FSpec/Motivations.hs b/src/Ampersand/FSpec/Motivations.hs index 5b11ed090b..69e065cee3 100644 --- a/src/Ampersand/FSpec/Motivations.hs +++ b/src/Ampersand/FSpec/Motivations.hs @@ -63,6 +63,10 @@ class Named a => HasMeaning a where meanings :: a -> [Meaning] {-# MINIMAL meanings #-} +instance HasMeaning AConceptDef where + meanings cd = + acddef2 cd : acdmean cd + instance HasMeaning Rule where meanings = rrmean -- meaning l rule diff --git a/src/Ampersand/FSpec/ShowHS.hs b/src/Ampersand/FSpec/ShowHS.hs index 0a82fcd20a..fb812c2f3f 100644 --- a/src/Ampersand/FSpec/ShowHS.hs +++ b/src/Ampersand/FSpec/ShowHS.hs @@ -593,9 +593,21 @@ instance ShowHS Relation where -- instance ShowHSName ConceptDef where -- showHSName cd = haskellIdentifier ("cDef_"<>cdcpt cd) -instance ShowHS ConceptDef where - showHS env _ cd - = " Cd ("<>showHS env "" (origin cd)<>") "<>tshow (cdcpt cd)<>" "<>tshow (cddef cd)<>" "<>tshow (cdref cd)<>" "<>tshow (cdfrom cd)-- +instance ShowHS AConceptDef where + showHS env indent cd = + T.intercalate + indent + [ "AConceptDef { pos = " <> showHS env "" (origin cd), + " , acdcpt = " <> tshow (acdcpt cd), + " , acddef2 = " <> showHS env " " (acddef2 cd), + " , acdmean = " + <> showHS + env + " " + (acdmean cd), + " , acdfrom = " <> tshow (acdfrom cd) + ] + instance ShowHSName A_Concept where showHSName ONE = haskellIdentifier "cptOne" showHSName c = haskellIdentifier ("cpt_"<>name c) diff --git a/src/Ampersand/FSpec/Transformers.hs b/src/Ampersand/FSpec/Transformers.hs index 5f0ca765a3..98404a6ded 100644 --- a/src/Ampersand/FSpec/Transformers.hs +++ b/src/Ampersand/FSpec/Transformers.hs @@ -921,7 +921,7 @@ instance Instances AClassify where instances = Set.fromList . gens . originalContext instance Instances A_Concept where instances = concs . originalContext -instance Instances ConceptDef where +instance Instances AConceptDef where instances = Set.fromList . ctxcds . originalContext instance Instances Conjunct where instances = Set.fromList . allConjuncts diff --git a/src/Ampersand/Graphic/Graphics.hs b/src/Ampersand/Graphic/Graphics.hs index 38d14d1798..80eab95f1b 100644 --- a/src/Ampersand/Graphic/Graphics.hs +++ b/src/Ampersand/Graphic/Graphics.hs @@ -86,8 +86,8 @@ makePicture env fSpec pr = , dotProgName = graphVizCmdForConceptualGraph , caption = case outputLang' of - English -> "Concept diagram of the rules about " <> name cpt - Dutch -> "Conceptueel diagram van de regels rond " <> name cpt + English -> "Concept diagram of " <> name cpt + Dutch -> "Conceptueel diagram van " <> name cpt } PTDeclaredInPat pat -> Pict { pType = pr , scale = scale' @@ -105,7 +105,7 @@ makePicture env fSpec pr = , caption = case outputLang' of English -> "Concept diagram of the rules in " <> name pat - Dutch -> "Conceptueel diagram van de regels in " <> name pat + Dutch -> "Conceptueel diagram van " <> name pat } PTCDRule rul -> Pict { pType = pr , scale = scale' @@ -223,6 +223,7 @@ writePicture pict = do -- writeDot Canon --Pretty-printed Dot output with no layout performed. -- writeDot DotOutput --Reproduces the input along with layout information. writeDot imagePathRelativeToCurrentDir Png --handy format to include in github comments/issues + -- writeDot imagePathRelativeToCurrentDir Canon -- To obtain the Graphviz source code of the images -- writeDot imagePathRelativeToCurrentDir Svg -- format that is used when docx docs are being generated. -- writePdf imagePathRelativeToCurrentDir Eps -- .eps file that is postprocessed to a .pdf file where @@ -287,7 +288,7 @@ instance ReferableFromPandoc Picture where Fpdf -> "png" -- When Pandoc makes a PDF file, Ampersand delivers the pictures in .png format. .pdf-pictures don't seem to work. Fdocx -> "png" -- When Pandoc makes a .docx file, Ampersand delivers the pictures in .pdf format. The .svg format for scalable rendering does not work in MS-word. Fhtml -> "png" - _ -> "pdf" + _ -> "dot" data ConceptualStructure = CStruct { csCpts :: [A_Concept] -- ^ The concepts to draw in the graph , csRels :: [Relation] -- ^ The relations, (the edges in the graph) diff --git a/src/Ampersand/Input.hs b/src/Ampersand/Input.hs index 382ad81c65..0007064c3a 100644 --- a/src/Ampersand/Input.hs +++ b/src/Ampersand/Input.hs @@ -3,5 +3,5 @@ module Ampersand.Input , module Ampersand.Input.Parsing ) where import Ampersand.Input.ADL1.CtxError -import Ampersand.Input.Parsing (parseFileTransitive,parseFormalAmpersand,parsePrototypeContext,parseRule,runParser) +import Ampersand.Input.Parsing \ No newline at end of file diff --git a/src/Ampersand/Input/ADL1/CtxError.hs b/src/Ampersand/Input/ADL1/CtxError.hs index 5007413f7d..34470a44f1 100644 --- a/src/Ampersand/Input/ADL1/CtxError.hs +++ b/src/Ampersand/Input/ADL1/CtxError.hs @@ -32,9 +32,12 @@ module Ampersand.Input.ADL1.CtxError , mkCrudWarning , mkBoxRowsnhWarning , mkCaseProblemWarning + , checkNoDoubleLables , mkNoBoxItemsWarning , Guarded(..) -- If you use Guarded in a monad, make sure you use "ApplicativeDo" in order to get error messages in parallel. - , whenCheckedM, whenChecked, whenError + , whenCheckedM + , mkRoundTripError + , mkRoundTripTextError ) -- SJC: I consider it ill practice to export any CtxError constructors -- Reason: All error messages should pass through the CtxError module @@ -62,8 +65,9 @@ import qualified RIO.Text as T import Text.Parsec data CtxError = CTXE Origin Text -- SJC: I consider it ill practice to export CTXE, see remark at top - | PE ParseError + | PE ParseError | LE LexerError + | RoundTripError Text (Either (NonEmpty CtxError) Text) --The prettyprinted script and either the error given at the script or some descriptive error text. instance Show CtxError where -- The vscode extension expects errors and warnings -- to be in a standardized format. The show function @@ -71,7 +75,7 @@ instance Show CtxError where -- this function is changed, please verify -- the proper working of the ampersand-language-extension show err = T.unpack . T.intercalate "\n " $ - [tshow (origin err) <> " error:"] <> + [tshow (origin err) <> " error:"] <> (case err of CTXE _ s -> T.lines s PE e -> -- The first line of a parse error allways contains @@ -82,6 +86,12 @@ instance Show CtxError where [] -> fatal "Whoh! the impossible just happened! (triggered by a parse error somewhere in your script)" _:xs -> xs LE (LexerError _ info) -> T.lines (tshow info) + RoundTripError script err' -> + ["Roundtrip test failed. Script that was tried:"] + ++ map (" "<>) (T.lines script) + ++["Yields the following error:"] + ++ map (" "<>) (T.lines $ tshow err') + ) data Warning = Warning Origin Text @@ -100,11 +110,19 @@ instance Show Warning where instance Traced CtxError where origin (CTXE o _) = o - origin (PE perr) = let sourcePos = errorPos perr + origin (PE perr) = let sourcePos = errorPos perr in FileLoc (FilePos (sourceName sourcePos) (sourceLine sourcePos) (sourceColumn sourcePos)) "" origin (LE (LexerError fp info)) = FileLoc fp (tshow info) + origin (RoundTripError _ _) = Origin "File generated by QuickCheck. When you see it in an error, there is something wrong with the parser!" + +mkRoundTripError :: Text -> NonEmpty CtxError -> Guarded a +mkRoundTripError parsestring err = + Errors (RoundTripError parsestring (Left err) NE.:| []) + +mkRoundTripTextError :: Text -> Text -> Guarded a +mkRoundTripTextError parsestring msg = + Errors (RoundTripError parsestring (Right msg) NE.:| []) ---TODO: Give the errors in a better way lexerError2CtxError :: LexerError -> CtxError lexerError2CtxError = LE @@ -113,8 +131,8 @@ errors (Checked _ _) = Nothing errors (Errors lst) = Just lst unexpectedType :: Origin -> Maybe TType -> Guarded A_Concept -unexpectedType o x = - Errors (CTXE o ((case x of +unexpectedType o x = + Errors (CTXE o ((case x of Nothing -> "The Generic Built-in type was unexpeced. " Just ttyp -> "Unexpected built-in type: "<>tshow ttyp )<>"\n expecting a concept.") @@ -183,6 +201,7 @@ class GetOneGuarded a b | b -> a where Just (CTXE o' s NE.:| _) -> Errors . pure $ CTXE o' $ "Found too many:\n "<>s Just (PE _ NE.:| _) -> fatal "Didn't expect a PE constructor here" Just (LE _ NE.:| _) -> fatal "Didn't expect a LE constructor here" + Just (RoundTripError _ _ NE.:| _) -> fatal "Didn't expect a RoundTripError constructor here" hasNone :: b -- the object where the problem is arising -> Guarded a hasNone o = getOneExactly o [] @@ -279,8 +298,21 @@ uniqueNames nameclass = uniqueBy name <> "." ) messageFor _ = fatal "messageFor must only be used on lists with more that one element!" - moreThanOne (_:_:_) = True - moreThanOne _ = False + moreThanOne (_:_:_) = True + moreThanOne _ = False +checkNoDoubleLables :: Origin -> [ViewSegment] -> Guarded () +checkNoDoubleLables orig segments = addWarnings warnings $ pure() + where + warnings = mapMaybe toWarning . groupWith vsmlabel $ segments + toWarning :: [ViewSegment] -> Maybe Warning + toWarning [] = Nothing + toWarning (h:tl) = case (vsmlabel h,tl) of + (Just l,_:_) -> Just . Warning orig . T.intercalate "\n" $ + ["The label `"<>l<>"` occurs "<>tshow (length (h:tl))<>" times" + ,"in the VIEW statement defined at: " + ," "<>tshow orig<>"." + ] + _ -> Nothing mkDanglingPurposeError :: Purpose -> CtxError mkDanglingPurposeError p = CTXE (origin p) $ "Purpose refers to non-existent " <> showA (explObj p) @@ -530,6 +562,11 @@ data Guarded a = | Checked a [Warning] -- deriving Show +instance Eq a => Eq (Guarded a) where + Checked a1 _ == Checked a2 _ = a1 == a2 + _ == _ = False + + instance Functor Guarded where fmap _ (Errors a) = Errors a fmap f (Checked a ws) = Checked (f a) ws @@ -552,15 +589,6 @@ whenCheckedM ioGA fIOGB = Checked a ws1 -> do gb <- fIOGB a return $ addWarnings ws1 gb -whenChecked :: Guarded a -> (a -> Guarded b) -> Guarded b -whenChecked ga fgb = - case ga of - Checked a ws -> addWarnings ws $ fgb a - Errors err -> Errors err - -whenError :: Guarded a -> Guarded a -> Guarded a -whenError (Errors _) a = a -whenError a@(Checked _ _) _ = a showFullOrig :: Origin -> Text diff --git a/src/Ampersand/Input/ADL1/Lexer.hs b/src/Ampersand/Input/ADL1/Lexer.hs index 74cb23a138..4709720d75 100644 --- a/src/Ampersand/Input/ADL1/Lexer.hs +++ b/src/Ampersand/Input/ADL1/Lexer.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} module Ampersand.Input.ADL1.Lexer @@ -20,6 +19,7 @@ module Ampersand.Input.ADL1.Lexer , lexemeText , initPos , FilePos(..) + , isSafeIdChar ) where import Ampersand.Basics @@ -30,7 +30,6 @@ import Ampersand.Input.ADL1.LexerToken import RIO.Char hiding(isSymbol) import qualified RIO.List as L import qualified RIO.Char.Partial as Partial (chr) -import qualified RIO.Set as Set import qualified RIO.Text as T import RIO.Time import Numeric @@ -124,7 +123,7 @@ mainLexer :: Lexer mainLexer _ [] = return [] -mainLexer p ('-':'-':s) = mainLexer p (skipLine s) --TODO: Test if we should increase line number and reset the column number +mainLexer p ('-':'-':s) = mainLexer p (skipLine s) mainLexer p (c:s) | isSpace c = let (spc,next) = span isSpaceNoTab s isSpaceNoTab x = isSpace x && (not . isTab) x @@ -137,7 +136,7 @@ mainLexer p ('{':'+':s) = lexMarkup mainLexer (addPos 2 p) s mainLexer p ('"':ss) = let (s,swidth,rest) = scanString ss in case rest of - ('"':xs) -> returnToken (LexString s) p mainLexer (addPos (swidth+2) p) xs + ('"':xs) -> returnToken (LexDubbleQuotedString s) p mainLexer (addPos (swidth+2) p) xs _ -> lexerError (NonTerminatedString s) p @@ -151,13 +150,11 @@ mainLexer p ('<':d:s) = if isOperator ['<',d] else returnToken (LexSymbol '<') p mainLexer (addPos 1 p) (d:s) mainLexer p cs@(c:s) - | isIdStart c || isUpper c + | isSafeIdChar True c = let (name', p', s') = scanIdent (addPos 1 p) s - name'' = c:name' - tokt | iskw name'' = LexKeyword name'' - | otherwise = if isIdStart c - then LexVarId name'' - else LexConId name'' + name'' = c:name' + tokt | iskeyword name'' = LexKeyword name'' + | otherwise = LexSafeID name'' in returnToken tokt p mainLexer p' s' | isOperatorBegin c = let (name', s') = getOp cs @@ -189,28 +186,27 @@ mainLexer p cs@(c:s) -- Check on keywords - operators - special chars ----------------------------------------------------------- -locatein :: Ord a => [a] -> a -> Bool -locatein es e = e `elem` Set.fromList es - -iskw :: String -> Bool -iskw = locatein keywords +iskeyword :: String -> Bool +iskeyword str = str `elem` keywords isSymbol :: Char -> Bool -isSymbol = locatein symbols +isSymbol c = c `elem` symbols isOperator :: String -> Bool -isOperator = locatein operators +isOperator str = str `elem` operators isOperatorBegin :: Char -> Bool -isOperatorBegin = locatein (mapMaybe head operators) +isOperatorBegin c = c `elem` mapMaybe head operators where head :: [a] -> Maybe a head (a:_) = Just a head [] = Nothing -isIdStart :: Char -> Bool -isIdStart c = isLower c || c == '_' -isIdChar :: Char -> Bool -isIdChar c = isAlphaNum c || c == '_' +-- | Tells if a character is valid as character in an identifier. Because there are +-- different rules for the first character of an identifier and the rest of the +-- characters of an identifier, a boolean is required that tells if this is the +-- first character. +isSafeIdChar :: Bool -> Char -> Bool +isSafeIdChar isFirst c = isLetter c || (not isFirst && (isAlphaNum c || c == '_')) -- Finds the longest prefix of cs occurring in keywordsops getOp :: String -> (String, String) @@ -223,9 +219,9 @@ getOp cs = findOper operators cs "" else findOper found rest (op ++ [c]) where found = [s' | o:s'<-ops, c==o] --- scan ident receives a file position and the resting contents, returning the scanned identifier, the file location and the resting contents. +-- scan ident receives a file position and the resting contents, returning the scanned identifier, the file location and the remaining contents. scanIdent :: FilePos -> String -> (String, FilePos, String) -scanIdent p s = let (nm,rest) = span isIdChar s +scanIdent p s = let (nm,rest) = span (isSafeIdChar False) s in (nm,addPos (length nm) p,rest) diff --git a/src/Ampersand/Input/ADL1/LexerToken.hs b/src/Ampersand/Input/ADL1/LexerToken.hs index 44c0758d31..65cc12632e 100644 --- a/src/Ampersand/Input/ADL1/LexerToken.hs +++ b/src/Ampersand/Input/ADL1/LexerToken.hs @@ -19,36 +19,47 @@ instance Show Token where show (Tok lx p) = show lx ++ " " ++ show p -- | The Ampersand Lexemes -data Lexeme = LexSymbol Char -- ^ A symbol - | LexOperator String -- ^ An operator - | LexKeyword String -- ^ A keyword - | LexString String -- ^ A quoted string - | LexMarkup String -- ^ A markup (string to be parsed by Pandoc) - | LexSingleton String -- ^ An atomvalue in an Expression - | LexDecimal Int -- ^ A decimal number - | LexFloat Double -- ^ A decimal floating point thing - | LexOctal Int -- ^ An octal number - | LexHex Int -- ^ A hexadecimal number - | LexConId String -- ^ An upper case identifier - | LexVarId String -- ^ A lower case identifier - | LexDateTime UTCTime -- ^ A date-time - | LexDate Day -- ^ A date +data Lexeme + = -- | A symbol + LexSymbol !Char + | -- | An operator + LexOperator !String + | -- | A keyword + LexKeyword !String + | -- | A single quoted (possibly empty) string + LexSingleQuotedString !String + | -- | A double quoted (possibly empty) string + LexDubbleQuotedString !String + | -- | A markup (string to be parsed by Pandoc) + LexMarkup !String + | -- | A decimal number + LexDecimal !Int + | -- | A decimal floating point thing + LexFloat !Double + | -- | An octal number + LexOctal !Int + | -- | A hexadecimal number + LexHex !Int + | -- | An identifier that is safe to be used as a name in a database. It must contain only alphanumeric (UTF8) characters and underscore `_`. It may not begin with a numeric character or an underscore. + LexSafeID !String + | -- | A date-time + LexDateTime !UTCTime + | -- | A date + LexDate !Day deriving (Eq, Ord) - instance Show Lexeme where show x = case x of LexSymbol val -> "symbol " ++ "'" ++ [val] ++ "'" LexOperator val -> "operator " ++ "'" ++ val ++ "'" LexKeyword val -> "keyword " ++ show val - LexString val -> "string " ++ "\"" ++ val ++ "\"" + LexSingleQuotedString val -> "single quoted string " ++ "'" ++ val ++ "'" + LexDubbleQuotedString val -> "double quoted string " ++ "\"" ++ val ++ "\"" LexMarkup val -> "markup " ++ "{+" ++ val ++ "+}" - LexSingleton val -> "singleton " ++ "'" ++ val ++ "'" LexDecimal _ -> "integer " ++ lexemeText x LexFloat _ -> "float " ++ lexemeText x LexOctal _ -> "octal " ++ lexemeText x LexHex _ -> "hexadecimal " ++ lexemeText x - LexVarId val -> "lower case identifier " ++ val - LexConId val -> "upper case identifier " ++ val + LexSafeID val -> "identifier " ++ val LexDateTime _ -> "iso 8601 date time " ++ lexemeText x LexDate _ -> "iso 8601 date " ++ lexemeText x @@ -66,15 +77,14 @@ lexemeText l = case l of LexSymbol val -> [val] LexOperator val -> val LexKeyword val -> val - LexString val -> val + LexSingleQuotedString val -> val + LexDubbleQuotedString val -> val LexMarkup val -> val - LexSingleton val -> val LexDecimal val -> show val LexFloat val -> show val LexOctal val -> "0o" ++ toBase 8 val LexHex val -> "0x" ++ toBase 16 val - LexConId val -> val - LexVarId val -> val + LexSafeID val -> val LexDateTime val -> show val LexDate val -> show val diff --git a/src/Ampersand/Input/ADL1/Parser.hs b/src/Ampersand/Input/ADL1/Parser.hs index 45d4c60e02..c3a23976af 100644 --- a/src/Ampersand/Input/ADL1/Parser.hs +++ b/src/Ampersand/Input/ADL1/Parser.hs @@ -82,7 +82,7 @@ data ContextElement = CMeta Meta | CRul (P_Rule TermPrim) | CCfy [PClassify] | CRel (P_Relation, [P_Population]) - | CCon (Text -> ConceptDef) + | CCon (Text -> PConceptDef) | CRep Representation | Cm P_RoleRule | CIndx P_IdentDef @@ -98,8 +98,8 @@ pIncludeStatement :: AmpParser Include pIncludeStatement = Include <$> currPos <* pKey "INCLUDE" - <*> pString - <*> (pBrackets (asText pString `sepBy` pComma) <|> return []) + <*> pDoubleQuotedString + <*> (pBrackets (asText pDoubleQuotedString `sepBy` pComma) <|> return []) --- LanguageRef ::= 'IN' ('DUTCH' | 'ENGLISH') pLanguageRef :: AmpParser Lang @@ -116,7 +116,7 @@ pTextMarkup = ReST <$ pKey "REST" <|> --- Meta ::= 'META' Text Text pMeta :: AmpParser Meta -pMeta = Meta <$> currPos <* pKey "META" <*> asText pString <*> asText pString +pMeta = Meta <$> currPos <* pKey "META" <*> asText pDoubleQuotedString <*> asText pDoubleQuotedString --- PatternDef ::= 'PATTERN' ConceptName PatElem* 'ENDPATTERN' pPatternDef :: AmpParser P_Pattern @@ -164,7 +164,7 @@ data PatElem = Pr (P_Rule TermPrim) | Py [PClassify] | Pd (P_Relation, [P_Population]) | Pm P_RoleRule - | Pc (Text -> ConceptDef) + | Pc (Text -> PConceptDef) | Prep Representation | Pk P_IdentDef | Pv P_ViewDef @@ -224,14 +224,14 @@ pRuleDef = P_Rule <$> currPos pPairViewSegment :: AmpParser (PairViewSegment (Term TermPrim)) pPairViewSegment = PairViewExp <$> posOf (pKey "SRC") <*> return Src <*> pTerm <|> PairViewExp <$> posOf (pKey "TGT") <*> return Tgt <*> pTerm - <|> PairViewText <$> posOf (pKey "TXT") <*> asText pString + <|> PairViewText <$> posOf (pKey "TXT") <*> asText pDoubleQuotedString --- RelationDef ::= (RelationNew | RelationOld) Props? ('PRAGMA' Text+)? Meaning* ('=' Content)? '.'? pRelationDef :: AmpParser (P_Relation, [P_Population]) pRelationDef = reorder <$> currPos <*> (pRelationNew <|> pRelationOld) <*> optSet pProps - <*> optList (pKey "PRAGMA" *> many1 (asText pString)) + <*> optList (pKey "PRAGMA" *> many1 (asText pDoubleQuotedString)) <*> many pMeaning <*> optList (pOperator "=" *> pContent) <* optList (pOperator ".") @@ -304,13 +304,19 @@ pFun = Set.empty <$ pOperator "*" <|> Set.fromList [ts,ui] <$ try pOne --- ConceptDef ::= 'CONCEPT' ConceptName Text ('TYPE' Text)? Text? -pConceptDef :: AmpParser (Text->ConceptDef) -pConceptDef = Cd <$> currPos +pConceptDef :: AmpParser (Text->PConceptDef) +pConceptDef = PConceptDef <$> currPos <* pKey "CONCEPT" <*> pConceptName - <*> (asText pString "concept definition (string)") - <*> (asText pString `opt` "") -- a reference to the source of this definition. - + <*> pPCDDef2 + <*> many pMeaning + where + pPCDDef2 :: AmpParser PCDDef + pPCDDef2 = + (PCDDefLegacy <$> (asText pDoubleQuotedString "concept definition (string)") + <*> (asText pDoubleQuotedString `opt` "") -- a reference to the source of this definition. + ) + <|> (PCDDefNew <$> pMeaning) --- Representation ::= 'REPRESENT' ConceptNameList 'TYPE' AdlTType pRepresentation :: AmpParser Representation pRepresentation @@ -368,7 +374,7 @@ pFancyViewDef = mkViewDef <$> currPos <*> pLabel <*> pConceptOneRef <*> pIsThere (pKey "DEFAULT") - <*> (pBraces (pViewSegment False `sepBy` pComma) `opt` []) + <*> pBraces (pViewSegment False `sepBy` pComma) `opt` [] <*> pMaybe pHtmlView <* pKey "ENDVIEW" where mkViewDef pos' nm cpt isDef ats html = @@ -382,11 +388,11 @@ pFancyViewDef = mkViewDef <$> currPos --- ViewSegmentList ::= ViewSegment (',' ViewSegment)* --- HtmlView ::= 'HTML' 'TEMPLATE' Text pHtmlView :: AmpParser ViewHtmlTemplate - pHtmlView = ViewHtmlTemplateFile <$ pKey "HTML" <* pKey "TEMPLATE" <*> pString + pHtmlView = ViewHtmlTemplateFile <$ pKey "HTML" <* pKey "TEMPLATE" <*> pDoubleQuotedString --- ViewSegmentLoad ::= Term | 'TXT' Text pViewSegmentLoad :: AmpParser (P_ViewSegmtPayLoad TermPrim) pViewSegmentLoad = P_ViewExp <$> pTerm - <|> P_ViewText <$ pKey "TXT" <*> asText pString + <|> P_ViewText <$ pKey "TXT" <*> asText pDoubleQuotedString --- ViewSegment ::= Label ViewSegmentLoad pViewSegment :: Bool -> AmpParser (P_ViewSegment TermPrim) @@ -466,7 +472,7 @@ pSubInterface = P_Box <$> currPos <*> pBoxHeader <*> pBox TemplateKeyValue <$> currPos <*> asText (pVarid <|> pConid <|> anyKeyWord) - <*> optional (id <$ pOperator "=" <*> asText pString) + <*> optional (id <$ pOperator "=" <*> asText pDoubleQuotedString) --- ObjDef ::= Label Term ('<' Conid '>')? SubInterface? --- ObjDefList ::= ObjDef (',' ObjDef)* @@ -485,8 +491,8 @@ pObjDef = pBoxItem <$> currPos <*> pMaybe pCruds <*> pMaybe (pChevrons $ asText pConid) --for the view <*> pMaybe pSubInterface -- the optional subinterface - where obj ctx mCrud mView msub = - P_BxExpr { obj_nm = fatal "This should have been filled in promptly." + where obj ctx mCrud mView msub = + P_BxExpr { obj_nm = fatal "This should have been filled in promptly." , pos = fatal "This should have been filled in promptly." , obj_ctx = ctx , obj_crud = mCrud @@ -495,8 +501,8 @@ pObjDef = pBoxItem <$> currPos } pTxt :: AmpParser P_BoxItemTermPrim pTxt = obj <$ pKey "TXT" - <*> asText pString - where obj txt = + <*> asText pDoubleQuotedString + where obj txt = P_BxTxt { obj_nm = fatal "This should have been filled in promptly." , pos = fatal "This should have been filled in promptly." , obj_txt = txt @@ -517,7 +523,7 @@ pPurpose = rebuild <$> currPos <*> pRef2Obj <*> pMaybe pLanguageRef <*> pMaybe pTextMarkup - <*> pMaybe (pKey "REF" *> asText pString `sepBy1` pSemi) + <*> pMaybe (pKey "REF" *> asText pDoubleQuotedString `sepBy1` pSemi) <*> asText pAmpersandMarkup where rebuild :: Origin -> PRef2Obj -> Maybe Lang -> Maybe PandocFormat -> Maybe (NE.NonEmpty Text) -> Text -> PPurpose @@ -586,7 +592,7 @@ pMarkup :: AmpParser P_Markup pMarkup = P_Markup <$> pMaybe pLanguageRef <*> pMaybe pTextMarkup - <*> (asText pString <|> asText pAmpersandMarkup) + <*> (asText pDoubleQuotedString <|> asText pAmpersandMarkup) --- Rule ::= Term ('=' Term | '|-' Term)? -- | Parses a rule @@ -715,7 +721,7 @@ pSign = pBrackets sign --- ConceptName ::= Conid | Text --- ConceptNameList ::= ConceptName (',' ConceptName) pConceptName :: AmpParser Text -pConceptName = asText $ pConid <|> pString +pConceptName = asText $ pConid <|> pDoubleQuotedString --- ConceptRef ::= ConceptName pConceptRef :: AmpParser P_Concept @@ -746,7 +752,7 @@ pContent = pBrackets (pRecord `sepBy` (pComma <|> pSemi)) --- ADLidList ::= ADLid (',' ADLid)* --- ADLidListList ::= ADLid+ (',' ADLid+)* pADLid :: AmpParser Text -pADLid = asText $ pVarid <|> pConid <|> pString +pADLid = asText $ pVarid <|> pConid <|> pDoubleQuotedString asText :: AmpParser String -> AmpParser Text asText = fmap T.pack \ No newline at end of file diff --git a/src/Ampersand/Input/ADL1/ParsingLib.hs b/src/Ampersand/Input/ADL1/ParsingLib.hs index 759fc258e4..8971a3c265 100644 --- a/src/Ampersand/Input/ADL1/ParsingLib.hs +++ b/src/Ampersand/Input/ADL1/ParsingLib.hs @@ -11,7 +11,7 @@ module Ampersand.Input.ADL1.ParsingLib( -- * Positions currPos, posOf, valPosOf, -- * Basic parsers - pConid, pString, pAmpersandMarkup, pVarid, pCrudString, + pConid, pDoubleQuotedString, pAmpersandMarkup, pVarid, pCrudString, -- * special parsers pAtomValInPopulation, Value(..), -- * Parsers for special symbols @@ -27,7 +27,7 @@ module Ampersand.Input.ADL1.ParsingLib( import Ampersand.Basics hiding (many,try) import Ampersand.Input.ADL1.FilePos (Origin(..),FilePos(..)) import Ampersand.Input.ADL1.LexerToken(Token(..),Lexeme(..),lexemeText) -import RIO.Char(toUpper) +import RIO.Char ( toUpper, isLower, isUpper ) import qualified RIO.List as L import qualified RIO.NonEmpty as NE import qualified RIO.Set as Set @@ -121,18 +121,18 @@ check predicate = tokenPrim showTok nextPos matchTok match :: Lexeme -> AmpParser String match lx = check (\lx' -> if lx == lx' then Just (lexemeText lx) else Nothing) show lx ---- Conid ::= UpperChar (Char | '_')* +--- Conid ::= UpperChar AlphaNumericChar* pConid :: AmpParser String pConid = check (\case - LexConId s -> Just s + LexSafeID s@(h:_) -> if isUpper h then Just s else Nothing _ -> Nothing) "upper case identifier" --- String ::= '"' Any* '"' --- StringListSemi ::= String (';' String)* -pString :: AmpParser String -pString = check (\case - LexString s -> Just s - _ -> Nothing) "string" +pDoubleQuotedString :: AmpParser String +pDoubleQuotedString = check (\case + LexDubbleQuotedString s -> Just s + _ -> Nothing) "double quoted string" --- Markup ::= '{+' Any* '+}' pAmpersandMarkup :: AmpParser String @@ -140,18 +140,17 @@ pAmpersandMarkup = check (\case LexMarkup s -> Just s _ -> Nothing) "markup" ---- Varid ::= (LowerChar | '_') (Char | '_')* +--- Varid ::= LowerChar AlphaNumericChar* pVarid :: AmpParser String pVarid = check (\case - LexVarId s -> Just s + LexSafeID s@(h:_) -> if isLower h then Just s else Nothing _ -> Nothing) "lower case identifier" -- A non-empty string that contains only the the characters "crud" in any case (upper/lower), but each of them -- at most once. The order of the characters is free. pCrudString :: AmpParser String pCrudString = check (\case - LexConId s -> testCrud s - LexVarId s -> testCrud s + LexSafeID s -> testCrud s _ -> Nothing) "crud definition" where testCrud s = @@ -170,6 +169,7 @@ data Value = VRealString Text | VBoolean Bool | VDateTime UTCTime | VDate Day + pAtomValInPopulation :: Bool -> AmpParser Value -- An atomvalue can be lots of things. However, since it can be used in -- as a term (singleton expression), an ambiguity might occur if we allow @@ -181,7 +181,7 @@ pAtomValInPopulation :: Bool -> AmpParser Value pAtomValInPopulation constrainsApply = VBoolean True <$ pKey "TRUE" <|> VBoolean False <$ pKey "FALSE" - <|> VRealString <$> (T.pack <$> pString) + <|> VRealString <$> (T.pack <$> pDoubleQuotedString) <|> VDateTime <$> pUTCTime <|> VDate <$> pDay <|> fromNumeric <$> (if constrainsApply then pUnsignedNumeric else pNumeric) -- Motivated in issue #713 diff --git a/src/Ampersand/Input/Archi/ArchiAnalyze.hs b/src/Ampersand/Input/Archi/ArchiAnalyze.hs index 03a3c68efb..c2d369dd4f 100644 --- a/src/Ampersand/Input/Archi/ArchiAnalyze.hs +++ b/src/Ampersand/Input/Archi/ArchiAnalyze.hs @@ -217,12 +217,12 @@ allFolders = concatMap recur . archFolders -- | `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. - , fldObjs :: [ArchiObj] -- the elements in the current folder, without the subfolders - , fldFolders :: [Folder] -- the subfolders + { 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) -- | `data ArchiObj` represents every ArchiMate element in the ArchiMate repo diff --git a/src/Ampersand/Input/Parsing.hs b/src/Ampersand/Input/Parsing.hs index d8c16b98ff..a56cef2d17 100644 --- a/src/Ampersand/Input/Parsing.hs +++ b/src/Ampersand/Input/Parsing.hs @@ -9,7 +9,7 @@ module Ampersand.Input.Parsing ( , parseFormalAmpersand , parsePrototypeContext , parseRule - , runParser + , parseCtx , ParseCandidate(..) -- exported for use with --daemon ) where @@ -17,7 +17,7 @@ import Ampersand.ADL1 import Ampersand.Basics import Ampersand.Core.ShowPStruct import Ampersand.Input.ADL1.CtxError -import Ampersand.Input.ADL1.Lexer +import Ampersand.Input.ADL1.Lexer ( initPos, Token(tokPos), lexer ) import Ampersand.Input.ADL1.Parser import Ampersand.Input.Archi.ArchiAnalyze import Ampersand.Input.PreProcessor diff --git a/src/Ampersand/Output/FSpec2Pandoc.hs b/src/Ampersand/Output/FSpec2Pandoc.hs index 7925333470..45db2e1833 100644 --- a/src/Ampersand/Output/FSpec2Pandoc.hs +++ b/src/Ampersand/Output/FSpec2Pandoc.hs @@ -78,17 +78,20 @@ fSpec2Pandoc env now fSpec = (thePandoc,thePictures) <> cref True --required for pandoc-crossref to do its work properly <> chapters True -- Numbering with subnumbers per chapter - diagnosisOnly = view chaptersL env == [Diagnosis] thePandoc = wrap . setTitle (case metaValues "title" fSpec of - [] -> (if diagnosisOnly + [] -> (if view chaptersL env == [Diagnosis] then (text.l) - ( NL "Functioneel Ontwerp van " - , EN "Functional Design of ") - else (text.l) ( NL "Diagnose van " , EN "Diagnosis of ") + else if view chaptersL env == [ConceptualAnalysis] + then (text.l) + ( NL "Conceptuele Analyse van " + , EN "Conceptual Analysis of ") + else (text.l) + ( NL "Functioneel Ontwerp van " + , EN "Functional Design of ") ) <> (singleQuoted.text.name) fSpec titles -> (text . T.concat . L.nub) titles --reduce doubles, for when multiple script files are included, this could cause titles to be mentioned several times. ) diff --git a/src/Ampersand/Output/PandocAux.hs b/src/Ampersand/Output/PandocAux.hs index 436995193d..c69e2bfa92 100644 --- a/src/Ampersand/Output/PandocAux.hs +++ b/src/Ampersand/Output/PandocAux.hs @@ -9,7 +9,6 @@ module Ampersand.Output.PandocAux , count , showMath , texOnlyMarginNote - , newGlossaryEntry , commaPandocAnd , commaPandocOr , outputLang @@ -366,13 +365,6 @@ inMathFlip = "^{\\smallsmile}" inMathOverline :: Text -> Text inMathOverline x = " \\overline{"<>x<>"} " -newGlossaryEntry :: Text -> Text -> Inlines -newGlossaryEntry nm cnt = - rawInline "latex" - ("\\newglossaryentry{"<> escapeLatex nm <>"}\n"<> - " { name={"<> toLatexVariable nm <>"}\n"<> - " , description={"<> cnt<>"}}\n") - texOnlyMarginNote :: Text -> Text texOnlyMarginNote marginNote = "\\marginpar{\\begin{minipage}[t]{3cm}{\\noindent\\small\\em "<>marginNote<>"}\\end{minipage}}" diff --git a/src/Ampersand/Output/ToPandoc/ChapterConceptualAnalysis.hs b/src/Ampersand/Output/ToPandoc/ChapterConceptualAnalysis.hs index ef42584939..78b526f632 100644 --- a/src/Ampersand/Output/ToPandoc/ChapterConceptualAnalysis.hs +++ b/src/Ampersand/Output/ToPandoc/ChapterConceptualAnalysis.hs @@ -2,20 +2,22 @@ {-# LANGUAGE OverloadedStrings #-} module Ampersand.Output.ToPandoc.ChapterConceptualAnalysis where +import Ampersand.Graphic.ClassDiagram +import Ampersand.Graphic.Fspec2ClassDiagrams import Ampersand.Output.ToPandoc.SharedAmongChapters import qualified RIO.List as L import qualified RIO.Set as Set +import qualified RIO.Text as T - -chpConceptualAnalysis :: (HasDirOutput env, HasDocumentOpts env) +chpConceptualAnalysis :: (HasDirOutput env, HasDocumentOpts env) => env -> Int -> FSpec -> (Blocks,[Picture]) -chpConceptualAnalysis env lev fSpec = ( - -- *** Header *** - xDefBlck env fSpec ConceptualAnalysis - <> -- *** Intro *** - caIntro - <> -- *** For all patterns, a section containing the conceptual analysis for that pattern *** - caBlocks, pictures) +chpConceptualAnalysis env lev fSpec + = ( -- *** Header *** + xDefBlck env fSpec ConceptualAnalysis + <> -- *** Intro *** + caIntro + <> (mconcat . map caSection . orderingByTheme env) fSpec + , pictures) where -- shorthand for easy localizing l :: LocalizedStr -> Text @@ -25,35 +27,19 @@ chpConceptualAnalysis env lev fSpec = ( caIntro = (case outputLang' of Dutch -> para - ( "Dit hoofdstuk beschrijft een formele taal, waarin functionele eisen ten behoeve van " - <> (singleQuoted.str.name) fSpec - <> " kunnen worden besproken en uitgedrukt. " - <> "De formalisering dient om een bouwbare specificatie te verkrijgen. " - <> "Een derde met voldoende deskundigheid kan op basis van dit hoofdstuk toetsen of de gemaakte afspraken " - <> "overeenkomen met de formele regels en definities. " + ( "Dit hoofdstuk analyseert de \"taal van de business\", om functionele eisen ten behoeve van " + <> (singleQuoted.str.name) fSpec <> " te kunnen bespreken. " + <> "Deze analyse beoogt om een bouwbare, maar oplossingsonafhankelijke specificatie op te leveren. " + <> "Het begrijpen van tekst vereist deskundigheid op het gebied van conceptueel modelleren." ) English -> para - ( "This chapter defines the formal language, in which functional requirements of " - <> (singleQuoted.str.name) fSpec - <> " can be analysed and expressed." - <> "The purpose of this formalisation is to obtain a buildable specification. " - <> "This chapter allows an independent professional with sufficient background to check whether the agreements made " - <> "correspond to the formal rules and definitions. " + ( "This chapter analyses the \"language of the business\" for the purpose of discussing functional requirements of " + <> (singleQuoted.str.name) fSpec <> "." + <> "The analysis is necessary is to obtain a buildable specification that is solution independent. " + <> "The text targets readers with sufficient skill in conceptual modeling." ) )<> purposes2Blocks env (purposesOf fSpec outputLang' fSpec) -- This explains the purpose of this context. - caBlocks = - mconcat (map caSection (vpatterns fSpec)) - <>(case outputLang' of - Dutch -> para "De definities van concepten zijn te vinden in de index." - <> header (lev+3) "Gedeclareerde relaties" - <> para "Deze paragraaf geeft een opsomming van de gedeclareerde relaties met eigenschappen en betekenis." - English -> para "The definitions of concepts can be found in the glossary." - <> header (lev+3) "Declared relations" - <> para "This section itemizes the declared relations with properties and purpose." - ) - <> definitionList (map caRelation (Set.elems $ vrels fSpec)) - pictures = map pictOfPat (vpatterns fSpec) <> map pictOfConcept (Set.elems $ concs fSpec) <> map pictOfRule (Set.elems $ vrules fSpec) @@ -65,24 +51,38 @@ chpConceptualAnalysis env lev fSpec = ( pictOfRule = makePicture env fSpec . PTCDRule pictOfConcept :: A_Concept -> Picture pictOfConcept = makePicture env fSpec . PTCDConcept - caSection :: Pattern -> Blocks - caSection pat - = -- new section to explain this pattern - xDefBlck env fSpec (XRefConceptualAnalysisPattern pat) - -- The section starts with the reason why this pattern exists - <> purposes2Blocks env (purposesOf fSpec outputLang' pat) + caSection :: ThemeContent -> Blocks + caSection themeContent + | isNothing (patOfTheme themeContent) && + null (cptsOfTheme themeContent) && + null (dclsOfTheme themeContent) && + null (rulesOfTheme themeContent) = mempty + | otherwise = + -- *** Header of the theme: *** + (xDefBlck env fSpec . XRefSharedLangTheme . patOfTheme) themeContent + -- The section starts with the reason(s) why this pattern exist(s) + <> case patOfTheme themeContent of + Just pat -> purposes2Blocks env (purposesOf fSpec outputLang' pat) + Nothing -> mempty -- followed by a conceptual model for this pattern - <> ( case outputLang' of - Dutch -> -- announce the conceptual diagram - para (hyperLinkTo (pictOfPat pat) <> " geeft een conceptueel diagram van dit pattern.") - -- draw the conceptual diagram - <>(xDefBlck env fSpec . pictOfPat) pat - English -> para (hyperLinkTo (pictOfPat pat) <> " shows a conceptual diagram of this pattern.") - <>(xDefBlck env fSpec . pictOfPat) pat - ) <> - ( - -- now provide the text of this pattern. - case map caRule . Set.elems $ invariants fSpec `Set.intersection` udefrules pat of + <> (mconcat . map (printConcept env l) . cptsOfTheme) themeContent + <> ( case (outputLang', patOfTheme themeContent) of + (Dutch, Just pat) -> -- announce the conceptual diagram + para (hyperLinkTo (pictOfPat pat) <> "Conceptueel diagram van " <> (singleQuoted . str . name) pat<> ".") + -- draw the conceptual diagram + <>(xDefBlck env fSpec . pictOfPat) pat + (English, Just pat) -> para (hyperLinkTo (pictOfPat pat) <> "Conceptual diagram of " <> (singleQuoted . str . name) pat<> ".") + <>(xDefBlck env fSpec . pictOfPat) pat + (_, Nothing) -> mempty + ) + -- Now we discuss the attributes of each entity (with sufficiently documented attributes) in one subsection + <> mconcat (map fst caSubsections) + -- Finally we discuss the remaining attributes (of smaller entities) and remaining relations + -- This list contains empty spots for relations without documentation. + <> caRemainingRelations + <> + ( -- print the rules that are defined in this pattern. + case map caRule . Set.elems $ invariants fSpec `Set.intersection` (Set.fromList . map (cRul . theLoad) . rulesOfTheme) themeContent of [] -> mempty blocks -> (case outputLang' of Dutch -> header (lev+3) "Regels" @@ -92,7 +92,115 @@ chpConceptualAnalysis env lev fSpec = ( ) <> definitionList blocks ) - + where + themeClasses :: [Class] + themeClasses = case patOfTheme themeContent of + Just pat -> classes (cdAnalysis fSpec pat) + Nothing -> [] + + caEntity :: Class -> (Blocks, [Relation]) + caEntity cl + = ( simpleTable [ (plain.text.l) (NL "Attribuut", EN "Attribute") + ,(plain.text.l) (NL "Betekenis", EN "Meaning") + ] + ( [[ (plain . text . name) attr + , defineRel rel + ] + | attr<-clAtts cl, rel<-lookupRel attr + ] + ) + , [ rel | attr<-clAtts cl, rel<-lookupRel attr] + ) + where + lookupRel :: CdAttribute -> [Relation] + lookupRel attr + = L.nub [ r + | Nr _ decl <- dclsOfTheme themeContent, let rel = cDcl decl + , (r,s,t)<-[(rel,source rel,target rel), (rel, target rel, source rel)] + , name r==name attr, name cl==name s, attTyp attr==name t + , (not . null . decMean) rel ] + + defineRel :: Relation -> Blocks + defineRel rel = case map (amPandoc . ameaMrk) (decMean rel) of + [] -> mempty + [blocks] -> blocks + bss -> bulletList bss + <> (printPurposes . purposesOf fSpec outputLang') rel + + caSubsections :: [(Blocks, [Relation])] + caSubsections= + [ ( header 3 (str (name cl)) <> entityBlocks + , entityRels) + | cl <- themeClasses, (entityBlocks, entityRels) <- [caEntity cl], length entityRels>1 + ] + + caRemainingRelations :: Blocks + caRemainingRelations + = simpleTable [ (plain.text.l) (NL "Relatie", EN "Relation") + , (plain.text.l) (NL "Betekenis", EN "Meaning") + ] + ( [[ (plain . text) (name rel <> " " <> if null cls then tshow (sign rel) else l (NL " (Attribuut van ", EN " (Attribute of ") <> T.concat cls <> ")") + , defineRel rel -- use "tshow.attType" for the technical type. + ] + | rel<-rels + , let cls = [ name cl | cl <-themeClasses, (_, entRels) <- [caEntity cl], rel `elem` entRels ] + ] + ) + where + -- | Compute all relations that are not discussed in the subsections before, + -- i.e. all relations that are not an attribute (not INJ and not UNI) plus the relations that were left out to avoid tables with one attribute only. + rels :: [Relation] + rels = map (cDcl . theLoad) (dclsOfTheme themeContent) L.\\ Set.toList entityRels + -- | Compute all relations that are discussed in the subsections before. + entityRels :: Set Relation + entityRels = Set.unions (map (Set.fromList . snd) caSubsections) + +{- + printConcept :: Numbered CptCont -> Blocks + printConcept nCpt + = -- Purposes: + case (nubByText . cCptDefs . theLoad) nCpt of + [] -> mempty -- There is no definition of the concept + [cd] -> printCDef cd Nothing + cds -> mconcat + [printCDef cd (Just $ T.snoc "." suffx) + |(cd,suffx) <- zip cds ['a' ..] -- There are multiple definitions. Which one is the correct one? + ] + <> (printPurposes . cCptPurps . theLoad) nCpt + where + fspecFormat = view fspecFormatL env + nubByText = L.nubBy (\x y -> acddef2 x ==acddef2 y && acdref x == acdref y) -- fixes https://github.com/AmpersandTarski/Ampersand/issues/617 + printCDef :: AConceptDef -- the definition to print + -> Maybe Text -- when multiple definitions exist of a single concept, this is to distinguish + -> Blocks + printCDef cDef suffx + = definitionList + [( str (l (NL"Definitie " ,EN "Definition ")) + <> ( if fspecFormat `elem` [Fpdf, Flatex] + then (str . tshow .theNr) nCpt + else (str . name) cDef + ) + <> str (fromMaybe "" suffx) <> ":" + , [para ( newGlossaryEntry (name cDef<>fromMaybe "" suffx) (acddef cDef) + <> ( if fspecFormat `elem` [Fpdf, Flatex] + then rawInline "latex" + ("~"<>texOnlyMarginNote + ("\\gls{"<>escapeLatex + (name cDef<>fromMaybe "" suffx) + <>"}" + ) + ) + else mempty + ) + <> str (acddef cDef) + <> if T.null (acdref cDef) then mempty + else str (" ["<>acdref cDef<>"]") + ) + ] + ) + ] + + unused code, possibly useful later... caRelation :: Relation -> (Inlines, [Blocks]) caRelation d = (titel, [body]) where @@ -115,6 +223,7 @@ chpConceptualAnalysis env lev fSpec = ( then commaNL "en" (map adj . Set.elems $ properties d Set.\\ Set.fromList [Uni,Tot])<>" functie" else commaNL "en" (map adj . Set.elems $ properties d)<>" relatie" adj = propFullName True outputLang' +-} caRule :: Rule -> (Inlines, [Blocks]) caRule r @@ -146,7 +255,7 @@ chpConceptualAnalysis env lev fSpec = ( <> str (l (NL " - geformaliseerd als " ,EN ", this is formalized as ")) ) - <> pandocEquationWithLabel env fSpec (XRefConceptualAnalysisRule r) (showMath r) + <> pandocEquationWithLabel env fSpec (XRefConceptualAnalysisRule r) (showMath r) -- followed by a conceptual model for this rule <> para ( hyperLinkTo (pictOfRule r) <> str (l (NL " geeft een conceptueel diagram van deze regel." @@ -154,4 +263,4 @@ chpConceptualAnalysis env lev fSpec = ( ) <> xDefBlck env fSpec (pictOfRule r) ] - ) \ No newline at end of file + ) diff --git a/src/Ampersand/Output/ToPandoc/ChapterDataAnalysis.hs b/src/Ampersand/Output/ToPandoc/ChapterDataAnalysis.hs index eec5bfb26a..93cfed49a1 100644 --- a/src/Ampersand/Output/ToPandoc/ChapterDataAnalysis.hs +++ b/src/Ampersand/Output/ToPandoc/ChapterDataAnalysis.hs @@ -15,7 +15,7 @@ import qualified RIO.Text as T ------------------------------------------------------------ --DESCR -> the data analysis contains a section for each class diagram in the fSpec -- the class diagram and multiplicity rules are printed -chpDataAnalysis :: (HasDirOutput env, HasDocumentOpts env) +chpDataAnalysis :: (HasDirOutput env, HasDocumentOpts env) => env -> FSpec -> (Blocks,[Picture]) chpDataAnalysis env fSpec = (theBlocks, thePictures) where @@ -25,7 +25,7 @@ chpDataAnalysis env fSpec = (theBlocks, thePictures) outputLang' :: Lang outputLang' = outputLang env fSpec sectionLevel = 2 - + theBlocks = xDefBlck env fSpec DataAnalysis -- The header <> (case outputLang' of @@ -44,9 +44,9 @@ chpDataAnalysis env fSpec = (theBlocks, thePictures) <> "Finally, the logical and technical data model are discussed." ) ) - <> ( if null (classes $ clAnalysis fSpec) + <> ( if null (classes $ clAnalysis fSpec) then mempty - else + else header sectionLevel (text.l $ (NL "Classificaties", EN "Classifications") ) @@ -59,17 +59,17 @@ chpDataAnalysis env fSpec = (theBlocks, thePictures) ) ) <> xDefBlck env fSpec classificationPicture - - ) + + ) <> daRulesSection <> logicalDataModelBlocks <> technicalDataModelBlocks - <> crudMatrixSection + <> crudMatrixSection thePictures = [classificationPicture, logicalDataModelPicture, technicalDataModelPicture] classificationPicture = makePicture env fSpec PTClassDiagram - + logicalDataModelBlocks = header sectionLevel @@ -111,31 +111,27 @@ chpDataAnalysis env fSpec = (theBlocks, thePictures) conceptTables :: Blocks -- This produces two separate tables: -- The first table contains the concepts that have their own table in the logical data model. -- The second table contains all other concepts. - conceptTables = + conceptTables = legacyTable (text.l $ (NL "Logische gegevensverzamelingen" ,EN "Logical entity types")) [(AlignLeft,1/8),(AlignLeft,4/8),(AlignLeft,1/8),(AlignLeft,1/8),(AlignLeft,1/8)] [ (plain.text.l) (NL "Concept" , EN "Concept") , (plain.text.l) (NL "Betekenis" , EN "Meaning") - , (plain.text.l) (NL "Aantal" , EN "Count") - , (plain.text.l) (NL "Vullingsgraad" , EN "Filling degree") - ] + , (plain.text.l) (NL "Aantal" , EN "Count") + , (plain.text.l) (NL "Vullingsgraad" , EN "Filling degree") + ] [ [ (plain.text.name) c , meaningOf c - <> ( fromList - . concatMap (amPandoc . explMarkup) - . purposesOf fSpec outputLang' - $ c - ) + <> (mconcat . map (amPandoc . explMarkup) . purposesOf fSpec outputLang') c , (plain . text . tshow . Set.size . atomsInCptIncludingSmaller fSpec) c , (plain . text . tshow) (percent (sum [ Set.size pairs | attr<-attributesOfConcept fSpec c, pairs<-[(pairsInExpr fSpec . attExpr) (attr::SqlAttribute)] ]) (Set.size (atomsInCptIncludingSmaller fSpec c)*length (attributesOfConcept fSpec c))) ] - | c <- L.sortBy (compare `on` name) - . filter isKey - . L.delete ONE - . Set.elems + | c <- L.sortBy (compare `on` name) + . filter isKey + . L.delete ONE + . Set.elems $ concs fSpec ] <> legacyTable (text.l $ (NL "Overige attributen" @@ -143,34 +139,35 @@ chpDataAnalysis env fSpec = (theBlocks, thePictures) [(AlignLeft,1/6),(AlignLeft,4/6),(AlignLeft,1/6)] [ (plain.text.l) (NL "Concept" , EN "Concept") , (plain.text.l) (NL "Voorbeelden" , EN "Examples") - , (plain.text.l) (NL "Aantal" , EN "Count") - ] + , (plain.text.l) (NL "Aantal" , EN "Count") + ] [ [ (plain . text . name) c ] -- max 20 voorbeelden van atomen van concept c ++(map (plain . text . showA) . take 20 . Set.toList . atomsInCptIncludingSmaller fSpec) c ++[ (plain . text . tshow . Set.size . atomsInCptIncludingSmaller fSpec) c ] - | c <- L.sortBy (compare `on` name) - . Set.elems - . Set.filter (not.isKey) + | c <- L.sortBy (compare `on` name) + . Set.elems + . Set.filter (not.isKey) $ concs fSpec ] where isKey :: A_Concept -> Bool isKey cpt = cpt `elem` ooCpts oocd meaningOf :: A_Concept -> Blocks - meaningOf = mconcat . map (fromList . string2Blocks ReST . cddef) . concDefs fSpec - + meaningOf = agregateMany . map (maybe mempty meaning2Blocks . meaning outputLang') . concDefs fSpec + agregateMany :: [Many a] -> Many a + agregateMany = Many . join . unMany . fromList . fmap unMany percent :: (Integral a, Show a) => a -> a -> Text percent num denom = if denom==0 then tshow num else tshow num<>"("<>tshow (round ((fromIntegral num*100.0/fromIntegral denom)::Float)::Integer)<>"%)" - + detailsOfClass :: Class -> Blocks detailsOfClass cl = - header (sectionLevel+1) + header (sectionLevel+1) ((text.l) (NL "Gegevensverzameling: ", EN "Entity type: ") <> (emph.strong.text.name) cl) <> case clcpt cl of Nothing -> mempty @@ -205,7 +202,7 @@ chpDataAnalysis env fSpec = (theBlocks, thePictures) ] ) <> let asscs = [ assoc | assoc <- assocs oocd, assSrc assoc == clName cl || assTgt assoc == clName cl - ] + ] in case asscs of [] -> para ( text (name cl) <> text (l (NL " heeft geen associaties.", EN " has no associations."))) _ -> para ( text (name cl) <> text (l (NL " heeft de volgende associaties: ", EN " has the following associations: "))) @@ -271,9 +268,9 @@ chpDataAnalysis env fSpec = (theBlocks, thePictures) | (cncpt, (ifcsC, ifcsR, ifcsU, ifcsD)) <- crudObjsPerConcept (crudInfo fSpec) ] ] - - technicalDataModelBlocks = + + technicalDataModelBlocks = header sectionLevel (case outputLang' of Dutch -> "Technisch datamodel" @@ -318,7 +315,7 @@ chpDataAnalysis env fSpec = (theBlocks, thePictures) InternalPlug bin@BinSQL{} -> para ( (text.l) (NL "Dit is een koppeltabel, die " ,EN "This is a link-table, implementing ") - <> primExpr2pandocMath outputLang' + <> primExpr2pandocMath outputLang' (case dLkpTbl bin of [store] -> EDcD (rsDcl store) ss -> fatal ("Exactly one relation sould be stored in BinSQL. However, there are "<>tshow (length ss)) @@ -365,7 +362,7 @@ chpDataAnalysis env fSpec = (theBlocks, thePictures) technicalDataModelPicture = makePicture env fSpec PTTechnicalDM daRulesSection :: Blocks - daRulesSection = mconcat + daRulesSection = mconcat [ header sectionLevel . text $ l (NL "Regels", EN "Rules") , para . text $ l ( NL $ "Nu volgt een opsomming van alle regels. Per regel wordt de formele expressie ervan gegeven. " <> "Eerst worden de procesregels gegeven, vervolgens de invarianten." @@ -388,27 +385,27 @@ chpDataAnalysis env fSpec = (theBlocks, thePictures) ] where docRules :: LocalizedStr -> LocalizedStr -> LocalizedStr -> LocalizedStr -> Rules -> Blocks - docRules title intro noRules heading rules = - if null rules + docRules title intro noRules heading rules = + if null rules then (para . text . l) noRules else mconcat $ - [ header (sectionLevel+1) . text $ l title + [ header (sectionLevel+1) . text $ l title , para . text $ l intro ] <> map (docRule heading) (Set.elems rules) - + docRule :: LocalizedStr -> Rule -> Blocks docRule heading rule = mconcat [ plain $ strong (text (l heading <> ": ") <> emph (text (rrnm rule))) - , fromList . concatMap (amPandoc . explMarkup) . purposesOf fSpec outputLang' $ rule + , mconcat . map (amPandoc . explMarkup) . purposesOf fSpec outputLang' $ rule , printMeaning outputLang' rule , para (showMath rule) , if isSignal rule then mempty else case rrviol rule of Nothing -> mempty - Just sgmts -> - para (if isSignal rule + Just sgmts -> + para (if isSignal rule then (text.l)(NL "Een overtreding van deze regel wordt gesignaleerd door middel van de melding: " ,EN "Violations of this rule are reported with the following message: " ) @@ -417,9 +414,9 @@ chpDataAnalysis env fSpec = (theBlocks, thePictures) ) ) <>bulletList [para $ violation2Inlines env fSpec sgmts] - - ] - + + ] + primExpr2pandocMath :: Lang -> Expression -> Inlines primExpr2pandocMath lang e = case e of @@ -447,7 +444,7 @@ primExpr2pandocMath lang e = Dutch -> text "de identiteitsrelatie van " English -> text "the identityrelation of " <> math (name c) - (EEps c _) -> + (EEps c _) -> case lang of Dutch -> text "de identiteitsrelatie van " English -> text "the identityrelation of " diff --git a/src/Ampersand/Output/ToPandoc/ChapterDiagnosis.hs b/src/Ampersand/Output/ToPandoc/ChapterDiagnosis.hs index 8243f8e8ac..be555dd752 100644 --- a/src/Ampersand/Output/ToPandoc/ChapterDiagnosis.hs +++ b/src/Ampersand/Output/ToPandoc/ChapterDiagnosis.hs @@ -501,11 +501,7 @@ chpDiagnosis env fSpec -- Alignment: (replicate 1 (AlignLeft,1)) -- Headers: - ( ( fmap singleton - . concatMap (amPandoc . ameaMrk) - . meanings - ) r - ) + (map (amPandoc . ameaMrk) . meanings $ r) -- Rows: (mkInvariantViolationsError (applyViolText fSpec) (r,ps)) diff --git a/src/Ampersand/Output/ToPandoc/ChapterIntroduction.hs b/src/Ampersand/Output/ToPandoc/ChapterIntroduction.hs index 731382fc46..6f46e08efe 100644 --- a/src/Ampersand/Output/ToPandoc/ChapterIntroduction.hs +++ b/src/Ampersand/Output/ToPandoc/ChapterIntroduction.hs @@ -11,8 +11,8 @@ chpIntroduction :: (HasDirOutput env, HasDocumentOpts env) => env -> UTCTime -> FSpec -> Blocks chpIntroduction env now fSpec = xDefBlck env fSpec Intro - <> fromList purposesOfContext -- the motivation(s) of this context - <> readingGuide -- tells what can be expected in this document. + <> purposesOfContext -- the motivation(s) of this context + <> readingGuide -- tells what can be expected in this document. where outputLang' = outputLang env fSpec readingGuide @@ -121,4 +121,6 @@ chpIntroduction env now fSpec = time :: Text time = T.pack $ formatTime (lclForLang outputLang') "%H:%M:%S" now - purposesOfContext = concat [amPandoc (explMarkup p) | p<-purposesOf fSpec outputLang' fSpec] + purposesOfContext :: Blocks + purposesOfContext = mconcat . map (amPandoc . explMarkup) . purposesOf fSpec outputLang' $ fSpec + \ No newline at end of file diff --git a/src/Ampersand/Output/ToPandoc/ChapterNatLangReqs.hs b/src/Ampersand/Output/ToPandoc/ChapterNatLangReqs.hs index de220af8f1..8352814874 100644 --- a/src/Ampersand/Output/ToPandoc/ChapterNatLangReqs.hs +++ b/src/Ampersand/Output/ToPandoc/ChapterNatLangReqs.hs @@ -85,7 +85,7 @@ chpNatLangReqs env lev fSpec = [] -> printIntro (cptsOfTheme tc) purps -> purposes2Blocks env purps ) - <> (mconcat . map printConcept . cptsOfTheme ) tc + <> (mconcat . map (printConcept env l). cptsOfTheme ) tc <> (mconcat . map printRel . dclsOfTheme ) tc <> (mconcat . map printRule . rulesOfTheme) tc where @@ -145,49 +145,6 @@ chpNatLangReqs env lev fSpec = (_:_:_) -> True _ -> False - printConcept :: Numbered CptCont -> Blocks - printConcept nCpt - = -- Purposes: - (printPurposes . cCptPurps . theLoad) nCpt - <> case (nubByText.cCptDefs.theLoad) nCpt of - [] -> mempty -- There is no definition of the concept - [cd] -> printCDef cd Nothing - cds -> mconcat - [printCDef cd (Just $ T.snoc "." suffx) - |(cd,suffx) <- zip cds ['a' ..] -- There are multiple definitions. Which one is the correct one? - ] - where - fspecFormat = view fspecFormatL env - nubByText = L.nubBy (\x y -> cddef x ==cddef y && cdref x == cdref y) -- fixes https://github.com/AmpersandTarski/Ampersand/issues/617 - printCDef :: ConceptDef -- the definition to print - -> Maybe Text -- when multiple definitions exist of a single concept, this is to distinguish - -> Blocks - printCDef cDef suffx - = definitionList - [( str (l (NL"Definitie " ,EN "Definition ")) - <> ( if fspecFormat `elem` [Fpdf, Flatex] - then (str . tshow .theNr) nCpt - else (str . name) cDef - ) - <> str (fromMaybe "" suffx) <> ":" - , [para ( newGlossaryEntry (name cDef<>fromMaybe "" suffx) (cddef cDef) - <> ( if fspecFormat `elem` [Fpdf, Flatex] - then rawInline "latex" - ("~"<>texOnlyMarginNote - ("\\gls{"<>escapeLatex - (name cDef<>fromMaybe "" suffx) - <>"}" - ) - ) - else mempty - ) - <> str (cddef cDef) - <> if T.null (cdref cDef) then mempty - else str (" ["<>cdref cDef<>"]") - ) - ] - ) - ] printRel :: Numbered DeclCont -> Blocks printRel nDcl = diff --git a/src/Ampersand/Output/ToPandoc/SharedAmongChapters.hs b/src/Ampersand/Output/ToPandoc/SharedAmongChapters.hs index 6db242b3bb..ed7188db69 100644 --- a/src/Ampersand/Output/ToPandoc/SharedAmongChapters.hs +++ b/src/Ampersand/Output/ToPandoc/SharedAmongChapters.hs @@ -22,6 +22,7 @@ module Ampersand.Output.ToPandoc.SharedAmongChapters , printMarkup , printPurposes , purposes2Blocks + , meaning2Blocks , violation2Inlines , isMissing , lclForLang @@ -31,13 +32,13 @@ module Ampersand.Output.ToPandoc.SharedAmongChapters , plainText , showPredLogic , legacyTable + , printConcept ) where import Ampersand.ADL1 hiding (Meta) import Ampersand.Basics hiding (Reader,Identity,toList,link) import Ampersand.Classes import Ampersand.Core.ShowAStruct -import Ampersand.Input.ADL1.FilePos import Ampersand.FSpec import Ampersand.Graphic.Graphics import Ampersand.Misc.HasClasses @@ -97,27 +98,24 @@ instance Xreferenceble Picture where dirOutput = view dirOutputL env src = dirOutput imagePathRelativeToDirOutput env a instance Xreferenceble CustomSection where - xSafeLabel a = + xSafeLabel a = (tshow . xrefPrefix . refStuff $ a) <> tshow (chapterOfSection x) <> typeOfSection x <> "-" <> (tshow . hash . nameOfThing $ x) -- Hash, to make sure there are no fancy characters. - where + where x = refStuff a hyperLinkTo = codeGen' xDefBlck env fSpec a = either id (fatal ("You should use xDefInln for:\n "<>tshow (refStuff a))) (hyperTarget env fSpec a) xDefInln env fSpec a = either (fatal ("You should use xDefBlck for:\n "<>tshow (refStuff a))) id (hyperTarget env fSpec a) -hyperTarget :: (HasOutputLanguage env) => env -> FSpec -> CustomSection -> Either Blocks Inlines +hyperTarget :: (HasOutputLanguage env) => env -> FSpec -> CustomSection -> Either Blocks Inlines hyperTarget env fSpec a = case a of XRefConceptualAnalysisPattern{} -> Left . hdr $ (text.l) (NL "Thema: ",EN "Theme: ") <> (singleQuoted . str . nameOfThing . refStuff $ a) - XRefSharedLangTheme mPat -> Left . hdr $ - (case mPat of - Nothing -> (text.l) (NL "Losse eindjes...",EN "Loose ends...") - Just pat -> text (name pat) - ) + XRefSharedLangTheme (Just pat) -> (Left . hdr . text . name) pat + XRefSharedLangTheme Nothing -> (Left . hdr . text . l) (NL "Overig",EN "Remaining") XRefSharedLangRelation d -> Right $ spanWith (xSafeLabel a,[],[]) (str . showRel $ d) -- Left $ divWith (xSafeLabel a,[],[]) -- ( (para . str $ showRel d) @@ -133,21 +131,21 @@ hyperTarget env fSpec a = -- -- ( "Deze REGEL moet nog verder worden uitgewerkt in de Haskell code") -- <>printMeaning (outputLang env fSpec) r -- ) - XRefConceptualAnalysisRelation _d - -> Right $ spanWith (xSafeLabel a,[],[]) + XRefConceptualAnalysisRelation _d + -> Right $ spanWith (xSafeLabel a,[],[]) ( (text.l) (NL "Relatie ",EN "Relation ") -- <> (str . show . numberOf fSpec $ d) - ) - XRefConceptualAnalysisRule _r - -> Right $ spanWith (xSafeLabel a,[],[]) + ) + XRefConceptualAnalysisRule _r + -> Right $ spanWith (xSafeLabel a,[],[]) ( (text.l) (NL "Regel ",EN "Rule ") -- <> (str . show . numberOf fSpec $ r) - ) + ) XRefConceptualAnalysisExpression _r - -> Right $ spanWith (xSafeLabel a,[],[]) + -> Right $ spanWith (xSafeLabel a,[],[]) ( (text.l) (NL "Regel ",EN "Rule ") -- <> (str . show . numberOf fSpec $ r) - ) + ) _ -> fatal ("hyperTarget not yet defined for "<>tshow (refStuff a)) where hdr = headerWith (xSafeLabel a, [], []) 2 @@ -155,7 +153,7 @@ hyperTarget env fSpec a = l :: LocalizedStr -> Text l = localize (outputLang env fSpec) codeGen' :: Xreferenceble a => a -> Inlines -codeGen' a = +codeGen' a = cite [Citation { citationId = xSafeLabel a , citationPrefix = [Space] , citationSuffix = [Space] @@ -180,19 +178,19 @@ instance Show CrossrefType where Tbl -> "tbl:" Fig -> "fig:" pandocEquationWithLabel :: (HasOutputLanguage env) => env -> FSpec -> CustomSection -> Inlines -> Blocks -pandocEquationWithLabel env fSpec xref x = +pandocEquationWithLabel env fSpec xref x = para (strong (xDefInln env fSpec xref) <> x) -data RefStuff = +data RefStuff = RefStuff { typeOfSection :: Text , chapterOfSection :: Chapter , nameOfThing :: Text , xrefPrefix :: CrossrefType } deriving Show refStuff :: CustomSection -> RefStuff -refStuff x = +refStuff x = case x of - XRefSharedLangRelation d + XRefSharedLangRelation d -> RefStuff { typeOfSection = relation , chapterOfSection = SharedLang , nameOfThing = showRel d @@ -222,13 +220,13 @@ refStuff x = , nameOfThing = showRel d , xrefPrefix = Eq } - XRefConceptualAnalysisRule r + XRefConceptualAnalysisRule r -> RefStuff { typeOfSection = rule , chapterOfSection = ConceptualAnalysis , nameOfThing = name r , xrefPrefix = Eq } - XRefConceptualAnalysisExpression r + XRefConceptualAnalysisExpression r -> RefStuff { typeOfSection = expression , chapterOfSection = ConceptualAnalysis , nameOfThing = name r @@ -237,46 +235,13 @@ refStuff x = XRefSharedLangTheme mt -> RefStuff { typeOfSection = theme , chapterOfSection = SharedLang - , nameOfThing = maybe ":losseEindjes" name mt + , nameOfThing = maybe ":overig" name mt , xrefPrefix = Sec } where (relation , rule , expression , pattern' , theme) = ("relation","rule" ,"expression","pattern","theme") - - -{- -class NumberedThing a where - numberOf :: FSpec -> a -> Int - -instance NumberedThing Rule where - numberOf fSpec r = case filter isTheOne ns of - [] -> fatal ("Rule has not been numbered: "<>name r) - [nr] -> theNr nr - _ -> fatal ("Rule has been numbered multiple times: "<>name r) - where ns = concatMap rulesOfTheme (orderingByTheme fSpec) - isTheOne :: Numbered RuleCont -> Bool - isTheOne = (r ==) . cRul . theLoad -instance NumberedThing Relation where - numberOf fSpec d = case filter isTheOne ns of - [] -> fatal ("Relation has not been numbered: "<>showRel d) - [nr] -> theNr nr - _ -> fatal ("Relation has been numbered multiple times: "<>showRel d) - where ns = concatMap dclsOfTheme (orderingByTheme fSpec) - isTheOne :: Numbered DeclCont -> Bool - isTheOne = (d ==) . cDcl . theLoad -instance NumberedThing A_Concept where - numberOf fSpec c = case filter isTheOne ns of - [] -> fatal ("Concept has not been numbered: "<>name c) - [nr] -> theNr nr - _ -> fatal ("Concept has been numbered multiple times: "<>name c) - where ns = concatMap cptsOfTheme (orderingByTheme fSpec) - isTheOne :: Numbered CptCont -> Bool - isTheOne = (c ==) . cCpt . theLoad --} - --- | This function orders the content to print by theme. It returns a list of --- tripples by theme. The last tripple might not have a theme, but will contain everything --- that isn't handled in a specific theme. + + data ThemeContent = Thm { themeNr :: Int @@ -301,7 +266,7 @@ data DeclCont = CDcl { cDcl :: Relation , cDclPairs :: AAtomPairs } data CptCont = CCpt { cCpt :: A_Concept - , cCptDefs :: [ConceptDef] + , cCptDefs :: [AConceptDef] , cCptPurps :: [Purpose] } instance Named RuleCont where @@ -310,127 +275,74 @@ instance Named DeclCont where name = name . cDcl instance Named CptCont where name = name . cCpt -data Counters - = Counter { pNr :: Int --Theme number - , definitionNr :: Int --For Concepts - , agreementNr :: Int --For relations andrules - } - --- orderingByTheme organizes the content of a specification in patterns according to a define-before-use policy. --- It must ensure that all rules, relations and concepts from the context are included in the specification. -orderingByTheme :: (HasOutputLanguage env) => env -> FSpec -> [ThemeContent] -orderingByTheme env fSpec - = f ( Counter 1 1 1 --the initial numbers of the countes - , (sortWithOrigins . filter rulMustBeShown . Set.elems . fallRules) fSpec - , (sortWithOrigins . filter relMustBeShown . Set.elems . relsDefdIn) fSpec - , (L.sortBy conceptOrder . filter cptMustBeShown . Set.elems . concs) fSpec - ) $ - [Just pat | pat <- vpatterns fSpec -- The patterns that should be taken into account for this ordering - ]<>[Nothing] --Make sure the last is Nothing, to take all res stuff. - where - conceptOrder :: A_Concept -> A_Concept -> Ordering - conceptOrder a b = - -- The sorting of Concepts is done by the origin of its first definition if there is one. - -- Concepts without definition are placed last, and sorted by name. - case (originOfFirstCDef a, originOfFirstCDef b) of - (Just origA, Just origB) -> case maybeOrdering origA origB of - Just ord -> ord - Nothing -> case (isFuzzyOrigin origA,isFuzzyOrigin origB) of - (False,False) -> fatal "This should be impossible" - (False,True) -> LT - (True,False) -> GT - (True,True) -> comparing name a b - (Just _ , Nothing ) -> LT - (Nothing , Just _ ) -> GT - (Nothing , Nothing ) -> comparing name a b - originOfFirstCDef :: A_Concept -> Maybe Origin - originOfFirstCDef cpt - = case sortWithOrigins $ concDefs fSpec cpt of - [] -> Nothing - cd :_ -> Just (origin cd) - rulMustBeShown :: Rule -> Bool - rulMustBeShown r = - not . isPropertyRule $ r -- property rules are shown as part of the declaration - relMustBeShown :: Relation -> Bool - relMustBeShown = decusr - cptMustBeShown = not . null . concDefs fSpec - f :: (Counters, [Rule], [Relation], [A_Concept]) -> [Maybe Pattern] -> [ThemeContent] - f stuff pats - = case pats of - pat:pats' -> let ( thm, rest) = partitionByTheme pat stuff - in thm : f rest pats' - [] -> case stuff of - (_,[],[],[]) -> [] - _ -> fatal "No stuff should be left over." - - rul2rulCont :: Rule -> RuleCont - rul2rulCont rul - = CRul { cRul = rul - , cRulPurps = purposesOf fSpec (outputLang env fSpec) rul - , cRulMeanings = meanings rul - } - dcl2dclCont :: Relation -> DeclCont - dcl2dclCont dcl - = CDcl { cDcl = dcl - , cDclPurps = purposesOf fSpec (outputLang env fSpec) dcl - , cDclMeanings = meanings dcl - , cDclPairs = pairsInExpr fSpec (EDcD dcl) - } - - cpt2cptCont :: A_Concept -> CptCont - cpt2cptCont cpt - = CCpt { cCpt = cpt - , cCptDefs = sortWithOrigins $ concDefs fSpec cpt - , cCptPurps = purposesOf fSpec (outputLang env fSpec) cpt - } - - setNumbers :: Int -- ^ the initial number - -> (t -> a) -- ^ the constructor function - -> [t] -- ^ a list of things that are numberd - -> [Numbered a] - setNumbers i construct items = - case items of - [] -> [] - (x:xs) -> Nr { theNr = i - , theLoad = construct x - }:setNumbers (i+1) construct xs - -- | This function takes care of partitioning each of the - -- lists in a pair of lists of elements which do and do not belong - -- to the theme, respectively - partitionByTheme :: Maybe Pattern -- Just pat if this theme is from a pattern, otherwise this stuff comes from outside a pattern (but inside a context). - -> ( Counters, [Rule], [Relation], [A_Concept]) - -> ( ThemeContent , ( Counters ,[Rule], [Relation], [A_Concept]) - ) - partitionByTheme mPat (cnt, ruls, rels, cpts) - = ( Thm { themeNr = pNr cnt - , patOfTheme = mPat - , rulesOfTheme = setNumbers (agreementNr cnt + length themeDcls ) rul2rulCont thmRuls - , dclsOfTheme = setNumbers (agreementNr cnt) dcl2dclCont themeDcls - , cptsOfTheme = setNumbers (definitionNr cnt) cpt2cptCont themeCpts - } - , (Counter {pNr = pNr cnt +1 - ,definitionNr = definitionNr cnt + length themeCpts - ,agreementNr = agreementNr cnt + length themeDcls + length thmRuls +-- | orderingByTheme collects materials from the fSpec to distribute over themes. +-- It ensures that all rules, relations and concepts from the context are included in the specification. +-- The principle is that every rule, relation, or concept that is defined in a pattern is documented in the corresponding theme. +-- Everything that is defined outside themes is documented in the last theme. +-- As a consequence, something that is declared in several patterns occurs in the corresponding themes and may be seen as a double occurrence. +-- However, that may be the intention of the Ampersand modeler. +-- The story: materials from the patterns are gathered in ruless, conceptss, and relationss. +-- Numbering of each item is done recursively by `numbered`, while keeping the structure intact. +-- Finally, the theme content is constructed. +orderingByTheme :: HasOutputLanguage env => env -> FSpec -> [ThemeContent] +orderingByTheme env fSpec + = [ Thm { themeNr = i + , patOfTheme = Just pat + , rulesOfTheme = fmap rul2rulCont nrules + , dclsOfTheme = fmap dcl2dclCont nrelations + , cptsOfTheme = fmap cpt2cptCont nconcepts + } + | (pat, i, nrules, nrelations, nconcepts)<-L.zip5 (vpatterns fSpec) [0..] (NE.init nruless) (NE.init nrelationss) (NE.init nconceptss) ] <> + [ Thm { themeNr = length (vpatterns fSpec) + , patOfTheme = Nothing + , rulesOfTheme = fmap rul2rulCont (NE.last nruless) + , dclsOfTheme = fmap dcl2dclCont (NE.last nrelationss) + , cptsOfTheme = fmap cpt2cptCont (NE.last nconceptss) + } ] + where + nruless :: NonEmpty [Numbered Rule] + nconceptss :: NonEmpty [Numbered AConceptDef] + nrelationss :: NonEmpty [Numbered Relation] + nruless = transformNonEmpty (numbering 0 (map Set.toList ruless <>[Set.toList (ctxrs aCtx)])) + nconceptss = transformNonEmpty (numbering 0 ( conceptss <>[ctxcdsOutPats aCtx] )) + nrelationss = transformNonEmpty (numbering 0 (map Set.toList relationss<>[Set.toList (ctxds aCtx)])) + transformNonEmpty :: [a] -> NonEmpty a + transformNonEmpty x = case NE.nonEmpty x of Just ne -> ne; Nothing -> fatal "onbereikbare code" + aCtx = originalContext fSpec + ruless :: [Rules] + conceptss :: [[AConceptDef]] + relationss :: [Relations] + (ruless, conceptss, relationss) + = L.unzip3 [ (ptrls pat, ptcds pat, ptdcs pat) | pat<-vpatterns fSpec ] + numbering :: Int -> [[a]] -> [[Numbered a]] + numbering n (xs:xss) = [ Nr i x | (x,i)<-zip xs [n..]]: numbering (n+length xs) xss + numbering _ _ = [] + + rul2rulCont :: Numbered Rule -> Numbered RuleCont + rul2rulCont (Nr n rul) + = Nr n CRul { cRul = rul + , cRulPurps = purposesOf fSpec (outputLang env fSpec) rul + , cRulMeanings = meanings rul + } + dcl2dclCont :: Numbered Relation -> Numbered DeclCont + dcl2dclCont (Nr n dcl) + = Nr n CDcl { cDcl = dcl + , cDclPurps = purposesOf fSpec (outputLang env fSpec) dcl + , cDclMeanings = meanings dcl + , cDclPairs = pairsInExpr fSpec (EDcD dcl) } - , restRuls, restDcls, restCpts) - ) - where - (thmRuls,restRuls) = L.partition (inThisTheme rulesInTheme) ruls - where rulesInTheme p = Set.filter ( \r -> Just (name p) == rrpat r) (fallRules fSpec) - (themeDcls,restDcls) = L.partition (inThisTheme relsInTheme) rels - where relsInTheme p = relsDefdIn p `Set.union` bindedRelationsIn p - (themeCpts,restCpts) = L.partition (inThisTheme concs) cpts - inThisTheme :: Eq a => (Pattern -> Set.Set a) -> a -> Bool - inThisTheme allElemsOf x - = case mPat of - Nothing -> True - Just pat -> x `elem` allElemsOf pat - ---GMI: What's the meaning of the Int? HJO: This has to do with the numbering of rules -dpRule' :: (HasDocumentOpts env) => - env -> FSpec -> [Rule] -> Int -> A_Concepts -> Relations - -> ([(Inlines, [Blocks])], Int, A_Concepts, Relations) + + cpt2cptCont :: Numbered AConceptDef -> Numbered CptCont + cpt2cptCont (Nr n cpt) + = Nr n CCpt { cCpt = c + , cCptDefs = [cpt] + , cCptPurps = purposesOf fSpec (outputLang env fSpec) c + } where c = PlainConcept (acdcpt cpt NE.:| []) + +dpRule' :: (HasDocumentOpts env) => + env -> FSpec -> [Rule] -> Int -> A_Concepts -> Relations + -> ([(Inlines, [Blocks])], Int, A_Concepts, Relations) dpRule' env fSpec = dpR where l lstr = text $ localize (outputLang env fSpec) lstr @@ -462,7 +374,7 @@ dpRule' env fSpec = dpR [] -> mempty [rd] -> plain ( l (NL "Om dit te formalizeren maken we gebruik van relatie " ,EN "We use relation ") - <> showRef rd + <> showRef rd <> l (NL ".", EN " to formalize this.") ) _ -> plain ( l (NL "Dit formaliseren we door gebruik te maken van de volgende relaties: " @@ -471,11 +383,11 @@ dpRule' env fSpec = dpR else case Set.elems rds of [] -> mempty [rd] -> plain ( l (NL "Daarnaast gebruiken we relatie ", EN "Beside that, we use relation ") - <> showRef rd + <> showRef rd <> l (NL " om ", EN " to formalize ") <> hyperLinkTo (XRefSharedLangRule r) <> l (NL " te formaliseren: ", EN ": ") - ) + ) _ -> plain ( l (NL " Om ", EN " To formalize ") <> hyperLinkTo (XRefSharedLangRule r) <> l (NL " te formaliseren, gebruiken we daarnaast ook de relaties: " @@ -499,9 +411,9 @@ dpRule' env fSpec = dpR ) showRef :: Relation -> Inlines showRef dcl = hyperLinkTo (XRefConceptualAnalysisRelation dcl) <> "(" <> (str . showRel) dcl <> ")" - + ncs = concs r Set.\\ seenConcs -- newly seen concepts - cds = [(c,cd) | c<-Set.elems ncs, cd<-conceptDefs fSpec, cdcpt cd==name c] -- ... and their definitions + cds = [(c,cd) | c<-Set.elems ncs, cd<-conceptDefs fSpec, name cd==name c] -- ... and their definitions ds = bindedRelationsIn r nds = ds Set.\\ seenRelations -- newly seen relations rds = ds `Set.intersection` seenRelations -- previously seen relations @@ -514,17 +426,19 @@ printPurposes :: [Purpose] -> Blocks printPurposes = mconcat . map (printMarkup . explMarkup) printMarkup :: Markup -> Blocks -printMarkup = fromList . amPandoc +printMarkup = amPandoc + +meaning2Blocks :: Meaning -> Blocks +meaning2Blocks + = printMarkup . ameaMrk purposes2Blocks :: (HasDocumentOpts env) => env -> [Purpose] -> Blocks purposes2Blocks env ps - = case ps of - [] -> mempty - -- by putting the ref after the first inline of the definition, it aligns nicely with the definition - _ -> case concatMarkup [expl{amPandoc = insertAfterFirstInline (ref purp) $ amPandoc expl} | purp<-ps, let expl=explMarkup purp] of - Nothing -> mempty - Just p -> fromList $ amPandoc p - where -- The reference information, if available for this purpose, is put + = maybe mempty amPandoc (concatMarkup . map markup' $ ps) + where -- The reference information, if available for this purpose, is put + markup' purp = Markup { amLang= amLang . explMarkup $ purp + , amPandoc= insertAfterFirstInline (ref purp) $ amPandoc . explMarkup $ purp + } ref :: Purpose -> [Inline] ref purp = [RawInline (Text.Pandoc.Builder.Format "latex") @@ -538,18 +452,20 @@ concatMarkup es = case eqCl amLang es of [] -> Nothing [cl] -> Just Markup { amLang = amLang (NE.head cl) - , amPandoc = concatMap amPandoc es + , amPandoc = mconcat (map amPandoc es) } cls -> fatal ("don't call concatMarkup with different languages and formats\n "<> T.intercalate "\n " (map (tshow . amLang . NE.head) cls) ) -- Insert an inline after the first inline in the list of blocks, if possible. -insertAfterFirstInline :: [Inline] -> [Block] -> [Block] -insertAfterFirstInline inlines ( Plain (inl:inls):pblocks) = Plain (inl : (inlines<>inls)) : pblocks -insertAfterFirstInline inlines ( Para (inl:inls):pblocks) = Para (inl : (inlines<>inls)) : pblocks -insertAfterFirstInline inlines (BlockQuote (Para (inl:inls):pblocks):blocks) = BlockQuote (Para (inl : (inlines<>inls)) : pblocks):blocks -insertAfterFirstInline inlines blocks = Plain inlines : blocks +insertAfterFirstInline :: [Inline] -> Blocks -> Blocks +insertAfterFirstInline inlines = fromList . insertAfterFirstInline' . toList + where + insertAfterFirstInline' ( Plain (inl:inls):pblocks) = Plain (inl : (inlines<>inls)) : pblocks + insertAfterFirstInline' ( Para (inl:inls):pblocks) = Para (inl : (inlines<>inls)) : pblocks + insertAfterFirstInline' (BlockQuote (Para (inl:inls):pblocks):blocks) = BlockQuote (Para (inl : (inlines<>inls)) : pblocks):blocks + insertAfterFirstInline' blocks = Plain inlines : blocks isMissing :: Maybe Purpose -> Bool isMissing = maybe True (not . explUserdefd) @@ -577,25 +493,25 @@ violation2Inlines env fSpec _ = (text.l) (NL " [(Alignment, Double)] -- ^ Column alignments and fractional widths -> [Blocks] -- ^ Headers -> [[Blocks]] -- ^ Rows -> Blocks -legacyTable caption' cellspecs headers rows = +legacyTable caption' cellspecs headers rows = table tCaption tColSpec tHead tBodies tFooter where tCaption :: Caption - tCaption - | null caption' = emptyCaption + tCaption + | null caption' = emptyCaption | otherwise = Caption (Just . toList $ caption') [] tColSpec :: [ColSpec] tColSpec = map toColSpec cellspecs where toColSpec :: (Alignment, Double) -> ColSpec toColSpec (a, d) = (a, ColWidth d) - tHead :: TableHead - tHead = TableHead nullAttr (zipWith toRow (map fst cellspecs) headers) + tHead :: TableHead + tHead = TableHead nullAttr (zipWith toRow (map fst cellspecs) headers) where toRow :: Alignment -> Blocks -> Row toRow a bs = Row nullAttr (map (toCell a . singleton) $ toList bs) toCell :: Alignment -> Blocks -> Cell @@ -603,6 +519,40 @@ legacyTable caption' cellspecs headers rows = tBodies :: [TableBody] tBodies = map toBodyRow rows where toBodyRow :: [Blocks] -> TableBody - toBodyRow bs = TableBody nullAttr (RowHeadColumns 0) [] [Row nullAttr $ zipWith toCell (map fst cellspecs) bs] + toBodyRow bs = TableBody nullAttr (RowHeadColumns 0) [] [Row nullAttr $ zipWith toCell (map fst cellspecs) bs] tFooter :: TableFoot tFooter = TableFoot nullAttr [] + +-- | This function is used in the conceptual analysis chapter as wel as the natural language chapter. To avoid +-- code duplication, it has been placed in this shared module. +printConcept :: (HasDocumentOpts env) => + env -> (LocalizedStr -> Text) -> Numbered CptCont -> Blocks +printConcept env l nCpt + = -- Purposes: + (printPurposes . cCptPurps . theLoad) nCpt + <> case (nubByContent . cCptDefs . theLoad) nCpt of + [] -> mempty -- There is no definition of the concept + [cd] -> printCDef cd Nothing + cds -> mconcat + [printCDef cd (Just $ T.snoc "." suffx) + |(cd,suffx) <- zip cds ['a' ..] -- There are multiple definitions. Which one is the correct one? + ] + where + fspecFormat = view fspecFormatL env + nubByContent = L.nubBy (\x y -> fun x == fun y) -- fixes https://github.com/AmpersandTarski/Ampersand/issues/617 + where fun = amPandoc . ameaMrk . acddef2 + printCDef :: AConceptDef -- the definition to print + -> Maybe Text -- when multiple definitions exist of a single concept, this is to distinguish + -> Blocks + printCDef cDef suffx + = definitionList + [( str (l (NL"Definitie " ,EN "Definition ")) + <> ( if fspecFormat `elem` [Fpdf, Flatex] + then (str . tshow .theNr) nCpt + else (str . name) cDef + ) + <> str (fromMaybe "" suffx) <> ":" + , [meaning2Blocks (acddef2 cDef)] + ) + ] + diff --git a/src/Ampersand/Runners.hs b/src/Ampersand/Runners.hs index a713fa36e0..32292715d4 100644 --- a/src/Ampersand/Runners.hs +++ b/src/Ampersand/Runners.hs @@ -134,17 +134,17 @@ withRunnerGlobal go inner = do hSupportsANSIWithoutEmulation stderr let defaultTerminalWidth = 100 termWidth <- clipWidth <$> maybe (fromMaybe defaultTerminalWidth - <$> fmap (fmap width) size) + <$> (fmap width <$> size)) pure (globalTermWidth go) menv <- mkDefaultProcessContext logOptions0 <- logOptionsHandle stderr False let logOptions = setLogUseColor useColor - $ setLogUseTime (globalTimeInLog go) - $ setLogMinLevel (globalLogLevel go) - $ setLogVerboseFormat (globalLogLevel go <= LevelDebug) - $ setLogTerminal (globalTerminal go) - logOptions0 + . setLogUseTime (globalTimeInLog go) + . setLogMinLevel (globalLogLevel go) + . setLogVerboseFormat (globalLogLevel go <= LevelDebug) + . setLogTerminal (globalTerminal go) + $ logOptions0 withLogFunc logOptions $ \logFunc -> runRIO Runner { runnerGlobalOpts = go , runnerUseColor = useColor diff --git a/src/Ampersand/Test.hs b/src/Ampersand/Test.hs index cfb4e3a6bb..88974ba180 100644 --- a/src/Ampersand/Test.hs +++ b/src/Ampersand/Test.hs @@ -1,11 +1,13 @@ module Ampersand.Test - ( module Ampersand.Test.Regression - , module Ampersand.Test.TestScripts - , module Ampersand.Test.Parser.ParserTest - , module Ampersand.Test.Parser.QuickChecks - ) + ( module Ampersand.Test.Regression, + module Ampersand.Test.Parser.ParserTest, + module Ampersand.Test.Parser.QuickChecks, + ) where -import Ampersand.Test.Regression -import Ampersand.Test.TestScripts (getTestScripts, testAmpersandScripts) -import Ampersand.Test.Parser.ParserTest (parseScripts) -import Ampersand.Test.Parser.QuickChecks (parserQuickChecks) \ No newline at end of file + +import Ampersand.Test.Parser.ParserTest + ( parseScripts, + showErrors, + ) +import Ampersand.Test.Parser.QuickChecks (doAllQuickCheckPropertyTests) +import Ampersand.Test.Regression (regressionTest) diff --git a/src/Ampersand/Test/Parser/ArbitraryTree.hs b/src/Ampersand/Test/Parser/ArbitraryTree.hs index 83721dd39e..839abae125 100644 --- a/src/Ampersand/Test/Parser/ArbitraryTree.hs +++ b/src/Ampersand/Test/Parser/ArbitraryTree.hs @@ -5,7 +5,7 @@ module Ampersand.Test.Parser.ArbitraryTree () where import Ampersand.Basics import Ampersand.Core.ParseTree -import Ampersand.Input.ADL1.Lexer (keywords) +import Ampersand.Input.ADL1.Lexer ( keywords, isSafeIdChar ) import RIO.Char import qualified RIO.List as L import qualified RIO.NonEmpty as NE @@ -40,24 +40,29 @@ safeFilePath = T.unpack <$> safeStr -- Genrates a valid ADL identifier identifier :: Gen Text -identifier = suchThat str2 noKeyword - where noKeyword :: Text -> Bool - noKeyword x = x `notElem` map T.pack keywords - -- The prelude functions accept Unicode characters - idChar = elements (['a'..'z']++['A'..'Z']++['0'..'9']++"_") - str2 :: Gen Text - str2 = (T.pack <$> listOf idChar) `suchThat` (\s -> T.length s > 1) +identifier = (T.cons <$> firstChar <*> (T.pack <$> listOf restChar)) + `suchThat` noKeyword + where + firstChar :: Gen Char + firstChar = arbitrary `suchThat` isAscii `suchThat` isSafeIdChar True + restChar :: Gen Char + restChar = arbitrary `suchThat` isAscii `suchThat` isSafeIdChar False + + + noKeyword :: Text -> Bool + noKeyword x = x `notElem` map T.pack keywords + -- Genrates a valid ADL upper-case identifier upperId :: Gen Text -upperId = suchThat identifier startUpper +upperId = identifier `suchThat` startUpper where startUpper txt = case T.uncons txt of Nothing -> False Just (h,_) -> isUpper h -- Genrates a valid ADL lower-case identifier lowerId :: Gen Text -lowerId = suchThat identifier startLower +lowerId = identifier `suchThat` startLower where startLower txt = case T.uncons txt of Nothing -> False Just (h,_) -> isLower h @@ -74,24 +79,21 @@ objTermPrim isTxtAllowed i = genPrim :: Gen TermPrim genPrim = PNamedR <$> arbitrary ---TODO: refactor obj/ifc generators -genObj :: Arbitrary a => Bool -> Int -> Gen (P_BoxItem a) -genObj isTxtAllowed = makeObj isTxtAllowed arbitrary genIfc (pure Nothing) makeObj :: Bool -> Gen a -> (Int -> Gen (P_SubIfc a)) -> Gen (Maybe Text) -> Int -> Gen (P_BoxItem a) makeObj isTxtAllowed genPrim ifcGen genView n = - oneof $ (P_BxExpr <$> lowerId <*> arbitrary <*> term <*> arbitrary <*> genView <*> ifc) - :[P_BxTxt <$> lowerId <*> arbitrary <*> safeStr | isTxtAllowed] + oneof $ (P_BxExpr <$> identifier <*> arbitrary <*> term <*> arbitrary <*> genView <*> ifc) + :[P_BxTxt <$> identifier <*> arbitrary <*> safeStr | isTxtAllowed] where term = Prim <$> genPrim ifc = if n == 0 then pure Nothing else Just <$> ifcGen (n`div`2) genIfc :: Arbitrary a => Int -> Gen (P_SubIfc a) -genIfc = subIfc $ genObj True +genIfc = subIfc $ makeObj True arbitrary genIfc (pure Nothing) subIfc :: (Int -> Gen (P_BoxItem a)) -> Int -> Gen (P_SubIfc a) subIfc objGen n - | n == 0 = P_InterfaceRef <$> arbitrary <*> arbitrary <*> safeStr1 + | n == 0 = P_InterfaceRef <$> arbitrary <*> arbitrary <*> identifier | otherwise = P_Box <$> arbitrary <*> arbitrary <*> vectorOf n (objGen$ n`div`2) instance Arbitrary BoxHeader where @@ -118,7 +120,7 @@ instance Arbitrary Origin where instance Arbitrary P_Context where arbitrary = PCtx - <$> upperId -- name + <$> identifier -- name <*> arbitrary -- pos <*> arbitrary -- lang <*> arbitrary -- markup @@ -140,7 +142,7 @@ instance Arbitrary Meta where arbitrary = Meta <$> arbitrary <*> safeStr <*> safeStr instance Arbitrary P_RoleRule where - arbitrary = Maintain <$> arbitrary <*> arbitrary <*> listOf1 safeStr + arbitrary = Maintain <$> arbitrary <*> arbitrary <*> listOf1 identifier instance Arbitrary Representation where arbitrary = Repr <$> arbitrary @@ -152,12 +154,12 @@ instance Arbitrary TType where instance Arbitrary Role where arbitrary = - oneof [ Role <$> safeStr - , Service <$> safeStr + oneof [ Role <$> identifier + , Service <$> identifier ] instance Arbitrary P_Pattern where - arbitrary = P_Pat <$> arbitrary <*> safeStr1 <*> arbitrary <*> arbitrary <*> arbitrary + arbitrary = P_Pat <$> arbitrary <*> identifier <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary @@ -242,16 +244,22 @@ instance Arbitrary SrcOrTgt where instance Arbitrary a => Arbitrary (P_Rule a) where arbitrary = P_Rule <$> arbitrary - <*> safeStr + <*> identifier <*> sized (genTerm 0) -- rule is a term level 0 <*> arbitrary <*> arbitrary <*> arbitrary -instance Arbitrary ConceptDef where - arbitrary = Cd <$> arbitrary <*> safeStr <*> safeStr - <*> safeStr <*> safeStr - +instance Arbitrary PConceptDef where + arbitrary = + PConceptDef <$> arbitrary <*> identifier <*> arbitrary + <*> arbitrary + <*> identifier +instance Arbitrary PCDDef where + arbitrary = oneof + [ PCDDefLegacy <$> safeStr <*> safeStr + , PCDDefNew <$> arbitrary + ] instance Arbitrary PAtomPair where arbitrary = PPair <$> arbitrary <*> arbitrary <*> arbitrary @@ -289,7 +297,7 @@ instance Arbitrary PAtomValue where isValid c = c `notElem` ['\'', '"', '\\'] instance Arbitrary P_Interface where arbitrary = P_Ifc <$> arbitrary - <*> safeStr1 + <*> identifier <*> arbitrary <*> sized (objTermPrim False) <*> arbitrary @@ -300,7 +308,7 @@ instance Arbitrary a => Arbitrary (P_SubIfc a) where instance Arbitrary P_IdentDef where arbitrary = P_Id <$> arbitrary - <*> safeStr + <*> identifier <*> arbitrary `suchThat` notIsOne <*> arbitrary @@ -308,14 +316,14 @@ instance Arbitrary P_IdentSegment where arbitrary = P_IdentExp <$> sized (objTermPrim False) instance Arbitrary a => Arbitrary (P_ViewD a) where - arbitrary = P_Vd <$> arbitrary <*> safeStr <*> arbitrary + arbitrary = P_Vd <$> arbitrary <*> identifier <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary ViewHtmlTemplate where arbitrary = ViewHtmlTemplateFile <$> safeFilePath instance Arbitrary a => Arbitrary (P_ViewSegment a) where - arbitrary = P_ViewSegment <$> (Just <$> safeStr) <*> arbitrary <*> arbitrary + arbitrary = P_ViewSegment <$> (Just <$> identifier) <*> arbitrary <*> arbitrary instance Arbitrary a => Arbitrary (P_ViewSegmtPayLoad a) where arbitrary = oneof [ P_ViewExp <$> sized(genTerm 1) -- only accepts pTerm, no pRule. @@ -328,14 +336,14 @@ instance Arbitrary PPurpose where instance Arbitrary PRef2Obj where arbitrary = oneof [ - PRef2ConceptDef <$> safeStr, + PRef2ConceptDef <$> identifier, PRef2Relation <$> arbitrary, - PRef2Rule <$> upperId, - PRef2IdentityDef <$> upperId, - PRef2ViewDef <$> upperId, - PRef2Pattern <$> upperId, - PRef2Interface <$> upperId, - PRef2Context <$> upperId + PRef2Rule <$> identifier, + PRef2IdentityDef <$> identifier, + PRef2ViewDef <$> identifier, + PRef2Pattern <$> identifier, + PRef2Interface <$> identifier, + PRef2Context <$> identifier ] instance Arbitrary PMeaning where diff --git a/src/Ampersand/Test/Parser/ParserTest.hs b/src/Ampersand/Test/Parser/ParserTest.hs index c5d8781ae4..a02d71a3ed 100644 --- a/src/Ampersand/Test/Parser/ParserTest.hs +++ b/src/Ampersand/Test/Parser/ParserTest.hs @@ -3,14 +3,11 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} module Ampersand.Test.Parser.ParserTest ( - parseReparse, parseScripts, showErrors + parseScripts, showErrors ) where -import Ampersand.ADL1.PrettyPrinters(prettyPrint) import Ampersand.Basics -import Ampersand.Core.ParseTree -import Ampersand.Input.ADL1.CtxError (Guarded(..),whenChecked,CtxError) -import Ampersand.Input.ADL1.Parser +import Ampersand.Input.ADL1.CtxError (Guarded(..),CtxError) import Ampersand.Input.Parsing import Ampersand.Options.FSpecGenOptsParser import Ampersand.Types.Config @@ -38,9 +35,3 @@ parseScripts paths = showErrors :: (HasLogFunc env) => [CtxError] -> RIO env () showErrors = mapM_ (logError . displayShow) -parse :: FilePath -> Text -> Guarded P_Context -parse file txt = whenChecked (runParser pContext file txt) (pure . fst) - -parseReparse :: FilePath -> Text -> Guarded P_Context -parseReparse file txt = whenChecked (parse file txt) reparse - where reparse p = parse (file ++ "**pretty") (prettyPrint p) diff --git a/src/Ampersand/Test/Parser/QuickChecks.hs b/src/Ampersand/Test/Parser/QuickChecks.hs index 1225f41ea6..ec3b2e052d 100644 --- a/src/Ampersand/Test/Parser/QuickChecks.hs +++ b/src/Ampersand/Test/Parser/QuickChecks.hs @@ -1,57 +1,101 @@ -{-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wno-deprecations #-} --to avoid warning for trace +{-# LANGUAGE NoMonomorphismRestriction #-} +--to avoid warning for trace +{-# OPTIONS_GHC -Wno-deprecations #-} module Ampersand.Test.Parser.QuickChecks - ( parserQuickChecks - ) where + ( doAllQuickCheckPropertyTests, + TestResult (..), + ) +where -import Ampersand.ADL1.PrettyPrinters(prettyPrint) +import Ampersand.ADL1.PrettyPrinters (prettyPrint) import Ampersand.Basics import Ampersand.Core.ParseTree (P_Context) -import Ampersand.Input.ADL1.CtxError (Guarded(..)) -import Ampersand.Test.Parser.ArbitraryTree() -import Ampersand.Test.Parser.ParserTest (parseReparse) -import Test.QuickCheck(Args(..), quickCheckWithResult, Testable, Result(..)) +import Ampersand.Input.ADL1.CtxError (Guarded (..)) +import Ampersand.Input.Parsing (parseCtx) +import Ampersand.Test.Parser.ArbitraryTree () import qualified RIO.Text as T +import Test.QuickCheck --- Tries to parse a string, and if successful, tests the result with the given function -testParse :: Text -> (P_Context -> Bool) -> Bool -testParse str check = case parseReparse "File generated by QuickCheck. When you see it in an error, there is something wrong with the parser!" str of - Checked a _ -> check a - Errors _ -> {- (tshow e <> "\n" <> str) -} False - -- TODO: Errors e -> do { showErrors e; return False } - --- Tests whether the parsed context is equal to the original one -prop_pretty :: P_Context -> Bool -prop_pretty ctx = testParse prettyCtx eq - where eq p = ctx == p || {- trace ("Printed versions are different: " <> prettyCtx <> "\n\n---------\n\n" <> prettyPrint p) -} False - prettyCtx = T.unlines - . zipWith (curry includeLineNr) [1 ..] - . T.lines - . prettyPrint $ ctx - includeLineNr :: (Int,Text) -> Text - includeLineNr (nr,str) = "{-"<>T.replicate (4 - T.length (tshow nr)) "0"<>tshow nr<>"-} "<>str - -checkArgs :: Args -checkArgs = Args - { replay = Nothing - , maxSuccess = 64 - , maxDiscardRatio = 8 - , maxSize = 8 -- otherwise there's nothing quick about it. - , maxShrinks = 50 - , chatty = False +-- | An application specific data type that enables nice error +-- messages in the output. +data TestResult = TestResult + { qcPropName :: !Text, + qcIsSuccess :: !Bool, + qcMessage :: ![Text], + qcQuickCheckResult :: !Result } --- TODO: Improve the messages given here, remove all trace's -test :: Testable prop => prop -> RIO env (Bool, Text) -test p = do - res <- liftIO $ quickCheckWithResult checkArgs p - case res of - Success {} -> return (True, "") - _ -> return (False, tshow res ) +doAllQuickCheckPropertyTests :: (HasLogFunc env) => RIO env Bool +doAllQuickCheckPropertyTests = + whileSuccess + [ doRoundtripTest + -- More tests can be inserted here + ] + where + whileSuccess :: (HasLogFunc env) => [RIO env TestResult] -> RIO env Bool + whileSuccess [] = do + logInfo "All tests succeeded." + pure True + whileSuccess (h : tl) = do + res <- h + if qcIsSuccess res + then do + logInfo . display $ "βœ… Passed: " <> qcPropName res + whileSuccess tl + else do + logInfo . display $ "❗❗❗Failed: " <> qcPropName res + pure False + +doRoundtripTest :: RIO env TestResult +doRoundtripTest = do + qcResult <- liftIO . quickCheckWithResult checkArgs $ prop_parserRoundtrip + pure + TestResult + { qcPropName = "Prettyprint/Parser roundtrip.", + qcIsSuccess = isSuccess qcResult, + qcMessage = ["---Some message---"], + qcQuickCheckResult = qcResult + } + where + checkArgs :: Args + checkArgs = Args + { replay = Nothing + , maxSuccess = 100 + , maxDiscardRatio = 8 + , maxSize = 15 -- otherwise there's nothing quick about it. + , maxShrinks = 50 + , chatty = True + } + +prop_parserRoundtrip :: P_Context -> Bool +prop_parserRoundtrip pCtx = + case roundtrip pCtx of + Checked _ _ -> True + Errors err -> + exitWith . SomeTestsFailed $ + T.lines (tshow err) + <> T.lines (prettyCtx pCtx) + +roundtrip :: P_Context -> Guarded P_Context +roundtrip pCtx = + fst + <$> parseCtx + ( "❗❗❗ ERROR: There is something wrong with the parser and/or with the\n" + <> " way an arbitrary P_Context is defined. (See ArbitraryTree.hs)\n" + <> " Below file at position" + ) + (prettyCtx pCtx) -parserQuickChecks :: RIO env (Bool,Text) -parserQuickChecks = test prop_pretty +prettyCtx :: P_Context -> Text +prettyCtx = + T.unlines + . zipWith (curry includeLineNr) [1 ..] + . T.lines + . prettyPrint + where + includeLineNr :: (Int, Text) -> Text + includeLineNr (nr, str) = "{-" <> T.replicate (4 - T.length (tshow nr)) "0" <> tshow nr <> "-} " <> str diff --git a/src/Ampersand/Test/Regression.hs b/src/Ampersand/Test/Regression.hs index f673a438c7..b483112711 100644 --- a/src/Ampersand/Test/Regression.hs +++ b/src/Ampersand/Test/Regression.hs @@ -92,7 +92,7 @@ doTestsInDir :: (HasProcessContext env, HasLogFunc env) => ConduitT DirData Test doTestsInDir = awaitForever once where once x = do - lift $ logInfo $ ">> " <> displayShow (traversalNr x) <> ": "<> (display . T.pack $ path x) + lift . logInfo $ ">> " <> displayShow (traversalNr x) <> ": "<> (display . T.pack $ path x) let candidates = filter isCandidate (filesOf . dirContent $ x) where isCandidate :: FilePath -> Bool @@ -148,7 +148,7 @@ doTestsInDir = awaitForever once loop sofar = await >>= maybe (return sofar) (\result -> loop $! add sofar result) parseYaml :: RIO env (Either ParseException TestInfo) - parseYaml = liftIO $ decodeFileEither $ path x yaml + parseYaml = liftIO . decodeFileEither $ path x yaml sayInstruction :: HasLogFunc env => TestInstruction -> RIO env () sayInstruction x = logDebug $ indent <> " Command: "<>display (command x)<>if exitcode x == 0 then " (should succeed)." else " (should fail with exitcode "<>display (exitcode x)<>")." indent :: IsString a => a @@ -210,10 +210,10 @@ testAdlfile indent dir adl tinfo = do where passHandler :: (HasLogFunc env) => (ExitCode, BL.ByteString, BL.ByteString) -> RIO env () passHandler (_, _, _) = do - logInfo $ indent<>"Passed." + logInfo $ indent<>"βœ… Passed." failHandler :: (HasLogFunc env) => (ExitCode, BL.ByteString, BL.ByteString) -> RIO env () failHandler (exit_code, out, err) = do - logError $ "***FAIL*** "<>indent<> (display . T.pack $ adl)<>" " + logError $ "❗❗❗ Failed. "<>indent<> (display . T.pack $ adl)<>" " <>"(Expected: "<>(if exitcode tinfo == 0 then "ExitSuccess" else "ExitFailure "<>display (exitcode tinfo) diff --git a/src/Ampersand/Test/TestScripts.hs b/src/Ampersand/Test/TestScripts.hs deleted file mode 100644 index b4cd817168..0000000000 --- a/src/Ampersand/Test/TestScripts.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Ampersand.Test.TestScripts (getTestScripts,testAmpersandScripts) where - - -import Ampersand.Basics ---endswith :: String -> String -> Bool ---endswith a b = drop (length a - length b) a == b - - - -getTestScripts :: RIO env [FilePath] -getTestScripts = --- fs <- getFiles ".adl" "ArchitectureAndDesign" --- ss <- getFiles ".adl" $ ".." "ampersand-models" "Tests" "ShouldSucceed" --- ds <- getFiles ".adl" $ "AmpersandData" "FormalAmpersand" - return [] --enabling these test as a single testcase will stop the sentinel from working. Was: fs ++ ss ++ ds -- ++ models - - - ---data DirContent = DirList [FilePath] [FilePath] -- files and directories in a directory --- | DirError IOException ---data DirData = DirData FilePath DirContent -- path and content of a directory - -testAmpersandScripts :: HasLogFunc env => RIO env () -testAmpersandScripts = do - logInfo "Testscripts of this kind are not available." -{- -testAmpersandScripts' :: IO () -testAmpersandScripts' - = do - walk baseDir $$ myVisitor - where - baseDir = ".." "ampersand-models" - --- Produces directory data -walk :: FilePath -> Source IO DirData -walk path = do - result <- lift $ tryIOError listdir - case result of - Right dl - -> case dl of - DirList subdirs _ - -> do - yield (DirData path dl) - forM_ subdirs (walk . (path )) - DirError err - -> yield (DirData path (DirError err)) - Left err - -> yield (DirData path (DirError err)) - - where - listdir = do - entries <- getDirectoryContents path >>= filterHidden - subdirs <- filterM isDir entries - files <- filterM isFile entries - return $ DirList subdirs (filter isRelevant files) - where - isFile entry = doesFileExist (path entry) - isDir entry = doesDirectoryExist (path entry) - filterHidden paths = return $ filter (not.isHidden) paths - isRelevant f = map toUpper (takeExtension f) `elem` [".ADL"] - isHidden dir = head dir == '.' - --- Consume directories -myVisitor :: Sink DirData IO () -myVisitor = addCleanup (\_ -> logInfo "Finished.") $ loop 1 - where - loop :: Int -> ConduitM DirData a IO () - loop n = do - lift $ say $ ">> " ++ show n - mr <- await - case mr of - Nothing -> return () - Just r -> lift (process r) >> loop (n + 1) - process :: DirData -> IO () - process (DirData path (DirError err)) = do - logInfo $ "I've tried to look in " ++ path ++ "." - logInfo $ " There was an error: " - logInfo $ " " ++ show err - - process (DirData path (DirList dirs files)) = do - logInfo $ path ++ ". ("++ show (length dirs) ++ " directorie(s) and " ++ show (length files) ++ " relevant file(s):" - forM_ files (runATest path) - -runATest :: FilePath -> FilePath -> IO() -runATest path file = - catch (runATest' path file) showError - where - showError :: SomeException -> IO() - showError err - = do logInfo "***** ERROR: Fatal error was thrown: *****" - logInfo $ (path file) - logInfo $ show err - logInfo "******************************************" - -runATest' :: FilePath -> FilePath -> IO() -runATest' path file = do - [errs] <- ampersand [path file] - logInfo - ( file ++": "++ - case (shouldFail,errs) of - (False, []) -> "OK. => Pass" - (False, _ ) -> "Fail => NOT PASSED:" - (True , []) -> "Ok. => NOT PASSED" - (True , _ ) -> "Fail => Pass" - ) - unless shouldFail $ mapM_ logInfo (map show (take 1 errs)) --for now, only show the first error - where shouldFail = "SHOULDFAIL" `isInfixOf` map toUpper (path file) --} diff --git a/stack.yaml b/stack.yaml index e630c22fc4..d86d3fe5f3 100644 --- a/stack.yaml +++ b/stack.yaml @@ -48,7 +48,7 @@ build: # Ampersand is large, and sometimes stack may crash out of memory. # Reducing the number of parallel jobs lowers the memory use to acceptable levels. # This resolved issue #1040 and is inspired on https://github.com/commercialhaskell/stack/issues/1910. -jobs: 2 +jobs: 4 # Require a specific version of stack, using version ranges # require-stack-version: -any # Default diff --git a/testing/Travis/testcases/FuncSpec/testIssue1183.adl b/testing/Travis/testcases/FuncSpec/testIssue1183.adl new file mode 100644 index 0000000000..02145ab6c3 --- /dev/null +++ b/testing/Travis/testcases/FuncSpec/testIssue1183.adl @@ -0,0 +1,34 @@ +CONTEXT TestIssue1183 + +PATTERN FOO +CONCEPT A123 "string 1" "ref" +MEANING {+ string 2 +} + +CONCEPT A123L "string 1" "ref" +MEANING LATEX {+ string 2 +} + +CONCEPT A13 "string 1" +MEANING {+ string 2 +} + +CONCEPT A13L "string 1" +MEANING LATEX {+ string 2 +} + +CONCEPT A12 "string 1" "ref" + +CONCEPT A1 "string 1" + +CONCEPT A123 "string 3" "ref" +MEANING {+ string 4 +} + +RELATION foo[A123 * A123L] +RELATION foo[A133 * A13L] +RELATION foo[A1 * A12] +ENDPATTERN + +CONCEPT A3 +MEANING {+ string 5 +} + +CONCEPT A3L +MEANING LATEX {+ string 6 +} + +ENDCONTEXT \ No newline at end of file diff --git a/testing/Travis/testcases/Parsing/shouldSucceed/Issue1183.adl b/testing/Travis/testcases/Parsing/shouldSucceed/Issue1183.adl new file mode 100644 index 0000000000..2b4dbb5fd7 --- /dev/null +++ b/testing/Travis/testcases/Parsing/shouldSucceed/Issue1183.adl @@ -0,0 +1,6 @@ +CONTEXT ISSUE1183 + +CONCEPT SomeConcept "description" "this description comes out of thin air" + MEANING {+this is some markup for an explainaition of the concept+} + +ENDCONTEXT \ No newline at end of file diff --git a/weeder.dhall b/weeder.dhall index 37db39a947..264f1bce18 100644 --- a/weeder.dhall +++ b/weeder.dhall @@ -1 +1,5 @@ -{ roots = [ "^Main.main$" ], type-class-roots = True } \ No newline at end of file +{ roots = [ "^Main.main$" + , "Paths_ampersand.*" + ] +, type-class-roots = True +} \ No newline at end of file