From d82aae3a158b11e02e5c52814227d63417e4dfbb Mon Sep 17 00:00:00 2001 From: hanjoosten Date: Sun, 5 Sep 2021 15:07:44 +0200 Subject: [PATCH 01/11] Split Prop into PProp and AProp --- src/Ampersand/ADL1.hs | 4 +- src/Ampersand/ADL1/P2A_Converters.hs | 28 +++-- src/Ampersand/ADL1/PrettyPrinters.hs | 7 +- src/Ampersand/ADL1/Rule.hs | 9 +- src/Ampersand/Classes/Relational.hs | 8 +- src/Ampersand/Core/A2P_Converters.hs | 21 +++- src/Ampersand/Core/AbstractSyntaxTree.hs | 45 ++++++- src/Ampersand/Core/ParseTree.hs | 135 +++++++++++---------- src/Ampersand/FSpec/ShowHS.hs | 5 +- src/Ampersand/FSpec/ShowMeatGrinder.hs | 4 +- src/Ampersand/FSpec/Transformers.hs | 4 +- src/Ampersand/Input/ADL1/CtxError.hs | 2 +- src/Ampersand/Input/ADL1/Lexer.hs | 2 +- src/Ampersand/Input/ADL1/Parser.hs | 34 +++--- src/Ampersand/Input/Archi/ArchiAnalyze.hs | 46 +++---- src/Ampersand/Input/Xslx/XLSX.hs | 2 +- src/Ampersand/Test/Parser/ArbitraryTree.hs | 2 +- 17 files changed, 211 insertions(+), 147 deletions(-) diff --git a/src/Ampersand/ADL1.hs b/src/Ampersand/ADL1.hs index ab46ed7709..632f36af48 100644 --- a/src/Ampersand/ADL1.hs +++ b/src/Ampersand/ADL1.hs @@ -9,7 +9,6 @@ import Ampersand.Core.ParseTree ( PPurpose(..), PRef2Obj(..) , mkPair , FilePos(..), Origin(..), Traced(..) - , Prop(..) , P_Concept(..) , P_Sign(..) , P_Enforce(..), EnforceOperator(..) @@ -20,7 +19,7 @@ import Ampersand.Core.ParseTree ( , PairView(..), PairViewSegment(..) , SrcOrTgt(..) , P_Rule(..),Role(..) - , Prop(..),Props + , PProp(..) , P_IdentDef, P_IdentSegment,P_IdentDf(..),P_IdentSegmnt(..) , P_ViewDef, P_ViewSegment(..),P_ViewSegmtPayLoad(..),P_ViewD(..),ViewHtmlTemplate(..) , P_Population(..),PAtomPair(..) @@ -55,6 +54,7 @@ import Ampersand.Core.AbstractSyntaxTree ( , Interface(..), getInterfaceByName , Pattern(..) , Relation(..), Relations, getExpressionRelation, showRel + , AProp(..), AProps , Rule(..), Rules, A_RoleRule(..) , A_Concept(..), A_Concepts, TType(..), showValADL, showValSQL, unsafePAtomVal2AtomValue , Representation(..) diff --git a/src/Ampersand/ADL1/P2A_Converters.hs b/src/Ampersand/ADL1/P2A_Converters.hs index 48ecd3110d..b8c0ac5755 100644 --- a/src/Ampersand/ADL1/P2A_Converters.hs +++ b/src/Ampersand/ADL1/P2A_Converters.hs @@ -28,6 +28,7 @@ import qualified RIO.Map as Map import qualified RIO.Set as Set import qualified RIO.Text as T + pConcToType :: P_Concept -> Type pConcToType P_ONE = BuiltIn TypeOfOne pConcToType p = UserConcept (name p) @@ -1107,7 +1108,7 @@ pDecl2aDecl cptMap maybePatName defLanguage defFormat pd dcl = Relation { decnm = dec_nm pd , decsgn = decSign - , decprps = dec_prps pd + , decprps = Set.fromList . concatMap pProp2aProps $ dec_prps pd , decprps_calc = Nothing --decprps_calc in an A_Context are still the user-defined only. prps are calculated in adl2fspec. , decprL = prL , decprM = prM @@ -1121,17 +1122,28 @@ pDecl2aDecl cptMap maybePatName defLanguage defFormat pd in checkEndoProps >> pure dcl where + pProp2aProps :: PProp -> [AProp] + pProp2aProps p = case p of + P_Uni -> [Uni ] + P_Inj -> [Inj ] + P_Sur -> [Sur ] + P_Tot -> [Tot ] + P_Sym -> [Sym ] + P_Asy -> [Asy ] + P_Trn -> [Trn ] + P_Rfx -> [Rfx ] + P_Irf -> [Irf ] + P_Prop ->[Sym, Asy] + decSign = pSign2aSign cptMap (dec_sign pd) checkEndoProps :: Guarded () checkEndoProps - | source decSign == target decSign - = pure () - | Set.null xs + | source decSign == target decSign && null xs = pure () - | otherwise = Errors . pure $ mkEndoPropertyError (origin pd) (Set.elems xs) - where xs = Set.fromList [Prop,Sym,Asy,Trn,Rfx,Irf] `Set.intersection` dec_prps pd - - + | otherwise = Errors . pure $ mkEndoPropertyError (origin pd) (Set.toList xs) + where xs = Set.filter isEndoProp $ dec_prps pd + isEndoProp :: PProp -> Bool + isEndoProp p = p `elem` [P_Prop, P_Sym,P_Asy,P_Trn,P_Rfx,P_Irf] pDisAmb2Expr :: (TermPrim, DisambPrim) -> Guarded Expression pDisAmb2Expr (_,Known x) = pure x pDisAmb2Expr (_,Rel [x]) = pure x diff --git a/src/Ampersand/ADL1/PrettyPrinters.hs b/src/Ampersand/ADL1/PrettyPrinters.hs index fd51b731e1..0e0a22eff2 100644 --- a/src/Ampersand/ADL1/PrettyPrinters.hs +++ b/src/Ampersand/ADL1/PrettyPrinters.hs @@ -138,9 +138,8 @@ instance Pretty P_Pattern where instance Pretty P_Relation where pretty (P_Relation nm sign prps pragma mean _) = text "RELATION" <+> (text . T.unpack) nm <~> sign <+> props <+\> pragmas <+\> prettyhsep mean - where props | prps == Set.fromList [Sym, Asy] = text "[PROP]" - | null prps = empty - | otherwise = text ("["++(L.intercalate ",". map show . Set.toList) prps ++ "]") -- do not prettyprint list of properties. + where props | null prps = empty + | otherwise = text ("["++(L.intercalate ",". map show) (Set.toList prps) ++ "]") -- do not prettyprint list of properties. pragmas | T.null (T.concat pragma) = empty | otherwise = text "PRAGMA" <+> hsep (map quote pragma) @@ -377,7 +376,7 @@ instance Pretty P_Markup where instance Pretty PandocFormat where pretty = text . map toUpper . show -instance Pretty Prop where +instance Pretty PProp where pretty = text . map toUpper . show instance Pretty PAtomPair where diff --git a/src/Ampersand/ADL1/Rule.hs b/src/Ampersand/ADL1/Rule.hs index 715dbef16d..e8fff71889 100644 --- a/src/Ampersand/ADL1/Rule.hs +++ b/src/Ampersand/ADL1/Rule.hs @@ -34,7 +34,7 @@ isPropertyRule r= case rrkind r of Propty{} -> True _ -> False -- rulefromProp specifies a rule that defines property prp of relation d. -rulefromProp :: Prop -> Relation -> Rule +rulefromProp :: AProp -> Relation -> Rule rulefromProp prp d = Ru { rrnm = tshow prp<>" "<>showDcl , formalExpression = rExpr @@ -62,7 +62,6 @@ rulefromProp prp d = Trn-> r .:. r .|-. r Rfx-> EDcI (source r) .|-. r Irf-> r .|-. ECpl (EDcI (source r)) - Prop -> fatal "Prop should have been converted by the parser" meanings prop = map (Meaning . markup) [English,Dutch] where markup lang = Markup lang (string2Blocks ReST $ f lang) @@ -86,7 +85,6 @@ rulefromProp prp d = Inj-> "Each " <>t<>" may only have one "<>s<>"" <>" in the relation "<>name d Tot ->"Every "<>s<>" must have a " <>t<>"" <>" in the relation "<>name d Sur ->"Every "<>t<>" must have a " <>s<>"" <>" in the relation "<>name d - Prop -> fatal "Prop should have been converted by the parser" Dutch -> case prop of Sym-> explByFullName lang @@ -98,10 +96,9 @@ rulefromProp prp d = Inj-> "Elke "<>t<>" mag slechts één "<>s<> " hebben" <>" in de relatie "<>name d Tot-> "Elke "<>s<>" dient één " <>t<>" te hebben" <>" in de relatie "<>name d Sur-> "Elke "<>t<>" dient een " <>s<>" te hebben" <>" in de relatie "<>name d - Prop -> fatal "Prop should have been converted by pattern the parser" explByFullName lang = showDcl<>" is "<>propFullName False lang prop -propFullName :: Bool -> Lang -> Prop -> Text +propFullName :: Bool -> Lang -> AProp -> Text propFullName isAdjective lang prop = case lang of English -> @@ -115,7 +112,6 @@ propFullName isAdjective lang prop = Sur-> "surjective" Inj-> "injective" Tot-> "total" - Prop -> fatal "Prop should have been converted by the parser" Dutch -> (if isAdjective then snd else fst) $ case prop of Sym-> ("symmetrisch" ,"symmetrische") @@ -127,4 +123,3 @@ propFullName isAdjective lang prop = Sur-> ("surjectief" ,"surjectieve") Inj-> ("injectief" ,"injectieve") Tot-> ("totaal" ,"totale") - Prop -> fatal "Prop should have been converted by the parser" diff --git a/src/Ampersand/Classes/Relational.hs b/src/Ampersand/Classes/Relational.hs index 56bbcf162f..3183fd03da 100644 --- a/src/Ampersand/Classes/Relational.hs +++ b/src/Ampersand/Classes/Relational.hs @@ -10,7 +10,7 @@ import Ampersand.Basics import qualified RIO.Set as Set class HasProps r where - properties :: r -> Props + properties :: r -> AProps class Relational r where isProp :: r -> Bool -- > tells whether the argument is a property isImin :: r -> Bool -- > tells whether the argument is equivalent to I- @@ -45,7 +45,7 @@ isSESSION cpt = -- but tries to derive the most obvious constraints as well. The more property constraints are known, -- the better the data structure that is derived. -- Not every constraint that can be proven is obtained by this function. This does not hurt Ampersand. -properties' :: Expression -> Props +properties' :: Expression -> AProps properties' expr = case expr of EDcD dcl -> properties dcl EDcI{} -> Set.fromList [Uni,Tot,Inj,Sur,Sym,Asy,Trn,Rfx] @@ -176,7 +176,7 @@ instance Relational Expression where -- TODO: see if we can find more pro isAsy r = Asy `elem` properties' r -- Not to be exported: -isTotSur :: Prop -> Expression -> Bool +isTotSur :: AProp -> Expression -> Bool isTotSur prop expr = case expr of EEqu (_,_) -> False @@ -206,7 +206,7 @@ isTotSur prop expr where todo = prop `elem` properties' expr -isUniInj :: Prop -> Expression -> Bool +isUniInj :: AProp -> Expression -> Bool isUniInj prop expr = case expr of EEqu (_,_) -> False diff --git a/src/Ampersand/Core/A2P_Converters.hs b/src/Ampersand/Core/A2P_Converters.hs index 43ffe155a3..40b8f08a49 100644 --- a/src/Ampersand/Core/A2P_Converters.hs +++ b/src/Ampersand/Core/A2P_Converters.hs @@ -11,6 +11,7 @@ module Ampersand.Core.A2P_Converters ( , aIdentityDef2pIdentityDef , aObjectDef2pObjectDef , aRelation2pRelation + , aProps2Pprops , aPopulation2pPopulation , aRule2pRule , aSign2pSign @@ -101,12 +102,30 @@ aRelation2pRelation :: Relation -> P_Relation aRelation2pRelation dcl = P_Relation { dec_nm = decnm dcl , dec_sign = aSign2pSign (decsgn dcl) - , dec_prps = decprps dcl + , dec_prps = aProps2Pprops $ decprps dcl , dec_pragma = [decprL dcl, decprM dcl, decprR dcl] , dec_Mean = map aMeaning2pMeaning (decMean dcl) , pos = decfpos dcl } +aProps2Pprops :: AProps -> Set PProp +aProps2Pprops aps + | P_Sym `elem` xs + && P_Asy `elem` xs = Set.singleton P_Prop `Set.union` (xs Set.\\ Set.fromList [P_Sym, P_Asy]) + | otherwise = xs + where + xs = Set.map aProp2pProp aps + aProp2pProp :: AProp -> PProp + aProp2pProp p = case p of + Uni -> P_Uni + Inj -> P_Inj + Sur -> P_Sur + Tot -> P_Tot + Sym -> P_Sym + Asy -> P_Asy + Trn -> P_Trn + Rfx -> P_Rfx + Irf -> P_Irf aRelation2pNamedRel :: Relation -> P_NamedRel aRelation2pNamedRel dcl = PNamedRel { pos = decfpos dcl diff --git a/src/Ampersand/Core/AbstractSyntaxTree.hs b/src/Ampersand/Core/AbstractSyntaxTree.hs index ee029128b3..809d343af9 100644 --- a/src/Ampersand/Core/AbstractSyntaxTree.hs +++ b/src/Ampersand/Core/AbstractSyntaxTree.hs @@ -16,6 +16,7 @@ module Ampersand.Core.AbstractSyntaxTree ( , RuleKind(..) , AEnforce(..) , Relation(..), Relations, showRel + , AProp(..), AProps , IdentityRule(..) , IdentitySegment(..) , ViewDef(..) @@ -43,7 +44,7 @@ module Ampersand.Core.AbstractSyntaxTree ( , Signature(..) , Population(..) , HasSignature(..) - , Prop(..),Traced(..) + , Traced(..) , Conjunct(..), DnfClause(..) , AAtomPair(..), AAtomPairs , AAtomValue(..), AAtomValues, mkAtomPair, PAtomValue(..) @@ -68,7 +69,6 @@ import Ampersand.Core.ParseTree , BoxHeader(..) -- , TemplateKeyValue(..) , PairView(..) , PairViewSegment(..) - , Prop(..), Props , Representation(..), TType(..), PAtomValue(..) ) import Ampersand.ADL1.Lattices (Op1EqualitySystem) @@ -187,7 +187,7 @@ instance Eq A_RoleRule where instance Traced A_RoleRule where origin = arPos data RuleKind = UserDefined -- This rule was specified explicitly as a rule in the Ampersand script - | Propty !Prop !Relation + | Propty !AProp !Relation -- This rule follows implicitly from the Ampersand script (Because of a property) and generated by a computer | Identity -- This rule follows implicitly from the Ampersand script (Because of a identity) and generated by a computer | Enforce -- This rule follows implicitly from the Ampersand script (Because of an Enforce statement) and generated by a computer @@ -243,13 +243,48 @@ instance Unique Conjunct where instance Ord Conjunct where compare = compare `on` rc_id +type AProps = Set.Set AProp +data AProp = Uni -- ^ univalent + | Inj -- ^ injective + | Sur -- ^ surjective + | Tot -- ^ total + | Sym -- ^ symmetric + | Asy -- ^ antisymmetric + | Trn -- ^ transitive + | Rfx -- ^ reflexive + | Irf -- ^ irreflexive + deriving (Eq, Ord, Enum, Bounded,Typeable, Data) + +instance Show AProp where + show Uni = "UNI" + show Inj = "INJ" + show Sur = "SUR" + show Tot = "TOT" + show Sym = "SYM" + show Asy = "ASY" + show Trn = "TRN" + show Rfx = "RFX" + show Irf = "IRF" + +instance Unique AProp where + showUnique = tshow + +instance Flippable AProp where + flp Uni = Inj + flp Tot = Sur + flp Sur = Tot + flp Inj = Uni + flp x = x + + + type Relations = Set.Set Relation data Relation = Relation { decnm :: Text -- ^ the name of the relation , decsgn :: Signature -- ^ the source and target concepts of the relation --properties returns decprps_calc, when it has been calculated. So if you only need the user defined properties do not use 'properties' but 'decprps'. - , decprps :: Props -- ^ the user defined properties (Uni, Tot, Sur, Inj, Sym, Asy, Trn, Rfx, Irf) - , decprps_calc :: Maybe Props -- ^ the calculated and user defined properties. Note that calculated properties are made by adl2fspec, so in the A-structure decprps and decprps_calc yield exactly the same answer. + , decprps :: AProps -- ^ the user defined properties (Uni, Tot, Sur, Inj, Sym, Asy, Trn, Rfx, Irf) + , decprps_calc :: Maybe AProps -- ^ the calculated and user defined properties. Note that calculated properties are made by adl2fspec, so in the A-structure decprps and decprps_calc yield exactly the same answer. , decprL :: Text -- ^ three strings, which form the pragma. E.g. if pragma consists of the three strings: "Person ", " is married to person ", and " in Vegas." , decprM :: Text -- ^ then a tuple ("Peter","Jane") in the list of links means that Person Peter is married to person Jane in Vegas. , decprR :: Text diff --git a/src/Ampersand/Core/ParseTree.hs b/src/Ampersand/Core/ParseTree.hs index 3978d4d2ff..5ee2a29ada 100644 --- a/src/Ampersand/Core/ParseTree.hs +++ b/src/Ampersand/Core/ParseTree.hs @@ -33,7 +33,7 @@ module Ampersand.Core.ParseTree ( , P_Markup(..) - , Prop(..), Props + , PProp(..), PProps -- Inherited stuff: , module Ampersand.Input.ADL1.FilePos ) where @@ -82,10 +82,10 @@ data MetaData = MetaData { pos :: Origin instance Traced MetaData where origin = pos -data EnforceOperator = - IsSuperSet Origin +data EnforceOperator = + IsSuperSet Origin | IsSubSet Origin - | IsSameSet Origin + | IsSameSet Origin deriving (Show,Eq) data P_Enforce a = P_Enforce @@ -149,7 +149,7 @@ instance Ord P_Pattern where , tshow (origin b) ]) (maybeOrdering (origin a) (origin b)) - x -> x + x -> x instance Eq P_Pattern where a == b = compare a b == EQ instance Named P_Pattern where @@ -180,7 +180,7 @@ instance Ord PConceptDef where , tshow (origin b) ]) (maybeOrdering (origin a) (origin b)) - x -> x + x -> x instance Eq PConceptDef where a == b = compare a b == EQ instance Unique PConceptDef where @@ -238,16 +238,22 @@ instance Show TType where Float -> "FLOAT" Object -> "OBJECT" TypeOfOne -> "TYPEOFONE" -data P_Relation = - P_Relation { dec_nm :: Text -- ^ the name of the relation - , dec_sign :: P_Sign -- ^ the type. Parser must guarantee it is not empty. - , dec_prps :: Props -- ^ the user defined properties (Uni, Tot, Sur, Inj, Sym, Asy, Trn, Rfx, Irf) - , dec_pragma :: [Text] -- ^ Three strings, which form the pragma. E.g. if pragma consists of the three strings: "Person ", " is married to person ", and " in Vegas." - -- ^ then a tuple ("Peter","Jane") in the list of links means that Person Peter is married to person Jane in Vegas. - , dec_Mean :: [PMeaning] -- ^ the optional meaning of a relation, possibly more than one for different languages. - , pos :: Origin -- ^ the position in the Ampersand source file where this relation is declared. Not all relations come from the ampersand souce file. - } deriving (Show) --For QuickCheck error messages only! - +data P_Relation = P_Relation + { -- | the name of the relation + dec_nm :: !Text, + -- | the type. Parser must guarantee it is not empty. + dec_sign :: !P_Sign, + -- | the user defined properties (Uni, Tot, Sur, Inj, Sym, Asy, Trn, Rfx, Irf, Prop) + dec_prps :: !PProps, + -- | Three strings, which form the pragma. E.g. if pragma consists of the three strings: "Person ", " is married to person ", and " in Vegas." + -- ^ then a tuple ("Peter","Jane") in the list of links means that Person Peter is married to person Jane in Vegas. + dec_pragma :: ![Text], + -- | the optional meaning of a relation, possibly more than one for different languages. + dec_Mean :: ![PMeaning], + -- | the position in the Ampersand source file where this relation is declared. Not all relations come from the ampersand souce file. + pos :: !Origin + } + deriving (Show) --For QuickCheck error messages only! -- | Equality on P_Relation -- Normally, equality on relations means equality of both name (dec_nm) and signature (dec_sign). -- However, in the parser, we need to distinguish between two relations with the same name and signature when they are in different locations. @@ -272,7 +278,7 @@ mergeRels rs = map fun (eqCl signat rs) -- each equiv. class contains at least 1 fun rels = P_Relation { dec_nm = name r0 , dec_sign = dec_sign r0 - , dec_prps = Set.unions (fmap dec_prps rels) + , dec_prps = Set.unions (dec_prps <$> NE.toList rels) , dec_pragma = case NE.filter (not . T.null . T.concat . dec_pragma) rels of [] -> dec_pragma r0 h:_ -> dec_pragma h @@ -341,7 +347,7 @@ instance Show PAtomValue where -- Used for showing in Expressions as PSingleton ComnBool _ b -> show b ScriptDate _ x -> show x ScriptDateTime _ x -> show x - + instance Eq PAtomValue where a == b = compare a b == EQ @@ -470,7 +476,7 @@ instance Functor P_BoxItem where fmap = fmapDefault instance Foldable P_BoxItem where foldMap = foldMapDefault instance Traversable P_BoxItem where traverse f (P_BxExpr nm orig ctx mCrud mView msub) - = (\ctx' msub'-> P_BxExpr nm orig ctx' mCrud mView msub') + = (\ctx' msub'-> P_BxExpr nm orig ctx' mCrud mView msub') <$> traverse f ctx <*> traverse (traverse f) msub traverse _ (P_BxTxt nm pos' str) = pure (P_BxTxt nm pos' str) @@ -540,7 +546,7 @@ data PairViewSegment a = instance Eq (PairViewSegment a) where p1 == p2 = compare p1 p2 == EQ instance Ord (PairViewSegment a) where - compare a b = fromMaybe + compare a b = fromMaybe (fatal . T.intercalate "\n" $ ["P_Rule a should have a non-fuzzy Origin." , tshow (origin a) @@ -573,7 +579,7 @@ instance Traversable PairView where instance Functor PairView where fmap = fmapDefault instance Foldable PairView where foldMap = foldMapDefault -data P_Rule a = P_Rule +data P_Rule a = P_Rule { pos :: Origin -- ^ Position in the Ampersand file , rr_nm :: Text -- ^ Name of this rule , rr_exp :: Term a -- ^ The rule expression @@ -589,7 +595,7 @@ instance Ord (P_Rule a) where , tshow (origin b) ]) (maybeOrdering (origin a) (origin b)) - x -> x + x -> x instance Eq (P_Rule a) where --Required for merge of P_Contexts a == b = compare a b == EQ instance Traced (P_Rule a) where @@ -669,15 +675,15 @@ data P_SubIfc a | P_InterfaceRef { pos :: !Origin , si_isLink :: !Bool --True iff LINKTO is used. (will display as hyperlink) , si_str :: !Text -- Name of the interface that is reffered to - } + } deriving (Show) -- | Key-value pairs used to supply attributes into an HTML template that is used to render a subinterface data BoxHeader = BoxHeader { pos :: !Origin - , btType :: !Text + , btType :: !Text -- ^ Type of the HTML template that is used for rendering - , btKeys :: [TemplateKeyValue] + , btKeys :: [TemplateKeyValue] -- ^ Key-value pairs } deriving (Show,Data) @@ -740,7 +746,7 @@ instance Ord (P_IdentDf a) where , tshow (origin b) ]) (maybeOrdering (origin a) (origin b)) -instance Eq (P_IdentDf a) where +instance Eq (P_IdentDf a) where a == b = compare a b == EQ instance Traced (P_IdentDf a) where origin = pos @@ -788,7 +794,7 @@ instance Foldable P_ViewD where foldMap = foldMapDefault instance Traversable P_ViewD where traverse fn (P_Vd a b c d e f) = P_Vd a b c d e <$> traverse (traverse fn) f -data P_ViewSegment a = +data P_ViewSegment a = P_ViewSegment { vsm_labl :: Maybe Text , pos :: Origin , vsm_load :: P_ViewSegmtPayLoad a @@ -799,7 +805,7 @@ instance Functor P_ViewSegment where fmap = fmapDefault instance Foldable P_ViewSegment where foldMap = foldMapDefault instance Traversable P_ViewSegment where traverse fn (P_ViewSegment a b c) = P_ViewSegment a b <$> traverse fn c -data P_ViewSegmtPayLoad a +data P_ViewSegmtPayLoad a = P_ViewExp { vs_expr :: Term a } | P_ViewText { vs_txt :: Text } deriving (Show) @@ -863,7 +869,7 @@ instance Ord PPurpose where --Required for merge of P_Contexts ]) (maybeOrdering (origin a) (origin b)) x -> x - + instance Eq PPurpose where --Required for merge of P_Contexts a == b = compare a b == EQ @@ -909,40 +915,39 @@ instance Eq PClassify where instance Traced PClassify where origin = pos -type Props = Set.Set Prop - -data Prop = Uni -- ^ univalent - | Inj -- ^ injective - | Sur -- ^ surjective - | Tot -- ^ total - | Sym -- ^ symmetric - | Asy -- ^ antisymmetric - | Trn -- ^ transitive - | Rfx -- ^ reflexive - | Irf -- ^ irreflexive - | Prop -- ^ PROP keyword, the parser must replace this by [Sym, Asy]. It may not occur in the A-structure. +type PProps = Set PProp +data PProp = P_Uni -- ^ univalent + | P_Inj -- ^ injective + | P_Sur -- ^ surjective + | P_Tot -- ^ total + | P_Sym -- ^ symmetric + | P_Asy -- ^ antisymmetric + | P_Trn -- ^ transitive + | P_Rfx -- ^ reflexive + | P_Irf -- ^ irreflexive + | P_Prop -- ^ PROP keyword, the parser must replace this by [Sym, Asy]. deriving (Eq, Ord, Enum, Bounded,Typeable, Data) -instance Show Prop where - show Uni = "UNI" - show Inj = "INJ" - show Sur = "SUR" - show Tot = "TOT" - show Sym = "SYM" - show Asy = "ASY" - show Trn = "TRN" - show Rfx = "RFX" - show Irf = "IRF" - show Prop = "PROP" - -instance Unique Prop where +instance Show PProp where + show P_Uni = "UNI" + show P_Inj = "INJ" + show P_Sur = "SUR" + show P_Tot = "TOT" + show P_Sym = "SYM" + show P_Asy = "ASY" + show P_Trn = "TRN" + show P_Rfx = "RFX" + show P_Irf = "IRF" + show P_Prop = "PROP" + +instance Unique PProp where showUnique = tshow -instance Flippable Prop where - flp Uni = Inj - flp Tot = Sur - flp Sur = Tot - flp Inj = Uni +instance Flippable PProp where + flp P_Uni = P_Inj + flp P_Tot = P_Sur + flp P_Sur = P_Tot + flp P_Inj = P_Uni flp x = x mergeContexts :: P_Context -> P_Context -> P_Context @@ -975,26 +980,26 @@ mergeContexts ctx1 ctx2 = -- not know a proper origin of some element. Sometimes the origin -- is used to distinquish between two elements. That is not -- usefull here, and might lead to information lost. - fromContextsKeepDoubles :: (P_Context -> [a]) -> [a] - fromContextsKeepDoubles fun = concatMap fun contexts + fromContextsKeepDoubles :: (P_Context -> [a]) -> [a] + fromContextsKeepDoubles fun = concatMap fun contexts contexts = [ctx1,ctx2] fromContextsRemoveDoubles :: Ord b => (P_Context -> [b]) -> [b] - fromContextsRemoveDoubles f = + fromContextsRemoveDoubles f = Set.toList . Set.unions . map (Set.fromList . f) $ contexts mergePops :: [P_Population] -> [P_Population] mergePops = map mergePopsSameType . NE.groupBy groupCondition where groupCondition :: P_Population -> P_Population -> Bool - groupCondition a b = + groupCondition a b = case (a,b) of - (P_RelPopu{},P_RelPopu{}) -> p_src a == p_src b + (P_RelPopu{},P_RelPopu{}) -> p_src a == p_src b && p_tgt a == p_tgt b && sameNamedRels (p_nmdr a) (p_nmdr b) (P_CptPopu{},P_CptPopu{}) -> p_cpt a == p_cpt b _ -> False where sameNamedRels :: P_NamedRel -> P_NamedRel -> Bool - sameNamedRels x y = p_nrnm x == p_nrnm y + sameNamedRels x y = p_nrnm x == p_nrnm y && p_mbSign x == p_mbSign y mergePopsSameType :: NE.NonEmpty P_Population -> P_Population mergePopsSameType (h :| tl) = case h of diff --git a/src/Ampersand/FSpec/ShowHS.hs b/src/Ampersand/FSpec/ShowHS.hs index fb0f277b19..3fdc1bc3c3 100644 --- a/src/Ampersand/FSpec/ShowHS.hs +++ b/src/Ampersand/FSpec/ShowHS.hs @@ -624,7 +624,7 @@ instance ShowHS A_Concept where PlainConcept{} -> "PlainConcept "<>tshow (name c) ONE -> "ONE" -instance ShowHSName Prop where +instance ShowHSName AProp where showHSName Uni = "Uni" showHSName Inj = "Inj" showHSName Sur = "Sur" @@ -634,9 +634,8 @@ instance ShowHSName Prop where showHSName Trn = "Trn" showHSName Rfx = "Rfx" showHSName Irf = "Irf" - showHSName Prop = "Prop" -instance ShowHS Prop where +instance ShowHS AProp where showHS _ _ = showHSName instance ShowHS FilePos where diff --git a/src/Ampersand/FSpec/ShowMeatGrinder.hs b/src/Ampersand/FSpec/ShowMeatGrinder.hs index ae4768e551..340ee4a6b2 100644 --- a/src/Ampersand/FSpec/ShowMeatGrinder.hs +++ b/src/Ampersand/FSpec/ShowMeatGrinder.hs @@ -12,7 +12,7 @@ where import Ampersand.ADL1 import Ampersand.Basics import Ampersand.Core.ParseTree --- import Ampersand.Core.A2P_Converters +import Ampersand.Core.A2P_Converters import Ampersand.FSpec.FSpec import Ampersand.FSpec.Transformers -- import qualified RIO.Set as Set @@ -85,7 +85,7 @@ metarelation tr = P_Relation { dec_nm = tRel tr , dec_sign = P_Sign (mkPConcept (tSrc tr)) (mkPConcept (tTrg tr)) - , dec_prps = mults tr + , dec_prps = aProps2Pprops $ mults tr , dec_pragma = [] , dec_Mean = [] , pos = OriginUnknown diff --git a/src/Ampersand/FSpec/Transformers.hs b/src/Ampersand/FSpec/Transformers.hs index 74563ed0b7..7034272b23 100644 --- a/src/Ampersand/FSpec/Transformers.hs +++ b/src/Ampersand/FSpec/Transformers.hs @@ -28,7 +28,7 @@ data Transformer = Transformer { tRel :: Text -- name of relation , tSrc :: Text -- name of source , tTrg :: Text -- name of target - , mults :: Props -- property constraints + , mults :: AProps -- property constraints , tPairs :: [PAtomPair]-- the population of this relation from the user's script. } @@ -53,7 +53,7 @@ dirtyId :: Unique a => a -> PopAtom dirtyId = DirtyId . idWithoutType -- Function for PrototypeContext transformers. These atoms don't need to have a type prefix -toTransformer :: (Text, Text, Text, Props, [ (PopAtom,PopAtom)] ) -> Transformer +toTransformer :: (Text, Text, Text, AProps, [ (PopAtom,PopAtom)] ) -> Transformer toTransformer (rel,src,tgt,props,tuples) = Transformer rel src tgt props tuples' where diff --git a/src/Ampersand/Input/ADL1/CtxError.hs b/src/Ampersand/Input/ADL1/CtxError.hs index 78cea237c2..1e6dc6502e 100644 --- a/src/Ampersand/Input/ADL1/CtxError.hs +++ b/src/Ampersand/Input/ADL1/CtxError.hs @@ -333,7 +333,7 @@ mkUndeclaredError entity objDef ref = "Undeclared " <> entity <> " " <> tshow ref <> " referenced at field " <> tshow (obj_nm objDef) _ -> fatal "Unexpected use of mkUndeclaredError." -mkEndoPropertyError :: Origin -> [Prop] -> CtxError +mkEndoPropertyError :: Origin -> [PProp] -> CtxError mkEndoPropertyError orig ps = CTXE orig msg where diff --git a/src/Ampersand/Input/ADL1/Lexer.hs b/src/Ampersand/Input/ADL1/Lexer.hs index df9ef03ae9..d32e2f137f 100644 --- a/src/Ampersand/Input/ADL1/Lexer.hs +++ b/src/Ampersand/Input/ADL1/Lexer.hs @@ -49,7 +49,7 @@ keywords = L.nub $ -- Keywords for Relation-statements , "RELATION", "PRAGMA", "MEANING" ] ++ - [map toUpper $ show x | x::Prop <-[minBound..] + [map toUpper $ show x | x::PProp <-[minBound..] ] ++ [ "POPULATION", "CONTAINS" -- Keywords for rules diff --git a/src/Ampersand/Input/ADL1/Parser.hs b/src/Ampersand/Input/ADL1/Parser.hs index 9cc8349af1..d042c39f8a 100644 --- a/src/Ampersand/Input/ADL1/Parser.hs +++ b/src/Ampersand/Input/ADL1/Parser.hs @@ -272,14 +272,14 @@ pRelationDef = reorder <$> currPos rel = PNamedRel pos' nm (Just sign) --- RelationNew ::= 'RELATION' Varid Signature -pRelationNew :: AmpParser (Text,P_Sign,Props) +pRelationNew :: AmpParser (Text,P_Sign,PProps) pRelationNew = (,,) <$ pKey "RELATION" <*> asText pVarid <*> pSign <*> return Set.empty --- RelationOld ::= Varid '::' ConceptRef Fun ConceptRef -pRelationOld :: AmpParser (Text,P_Sign,Props) +pRelationOld :: AmpParser (Text,P_Sign,PProps) pRelationOld = relOld <$> asText pVarid <* pOperator "::" <*> pConceptRef @@ -288,42 +288,42 @@ pRelationOld = relOld <$> asText pVarid where relOld nm src fun tgt = (nm,P_Sign src tgt,fun) --- Props ::= '[' PropList? ']' -pProps :: AmpParser (Set.Set Prop) +pProps :: AmpParser (Set.Set PProp) pProps = normalizeProps <$> pBrackets (pProp `sepBy` pComma) --- PropList ::= Prop (',' Prop)* --- Prop ::= 'UNI' | 'INJ' | 'SUR' | 'TOT' | 'SYM' | 'ASY' | 'TRN' | 'RFX' | 'IRF' | 'PROP' - where pProp :: AmpParser Prop + where pProp :: AmpParser PProp pProp = choice [ p <$ pKey (show p) | p <- [minBound..] ] - normalizeProps :: [Prop] -> Props + normalizeProps :: [PProp] -> PProps normalizeProps = conv.rep . Set.fromList where -- replace PROP by SYM, ASY - rep :: Props -> Props + rep :: PProps -> PProps rep ps - | Prop `elem` ps = Set.fromList [Sym, Asy] `Set.union` (Prop `Set.delete` ps) + | P_Prop `elem` ps = Set.fromList [P_Sym, P_Asy] `Set.union` (P_Prop `Set.delete` ps) | otherwise = ps -- add Uni and Inj if ps has neither Sym nor Asy - conv :: Props -> Props + conv :: PProps -> PProps conv ps = ps `Set.union` - if Sym `elem` ps && Asy `elem` ps - then Set.fromList [Uni,Inj] + if P_Sym `elem` ps && P_Asy `elem` ps + then Set.fromList [P_Uni,P_Inj] else Set.empty --- Fun ::= '*' | '->' | '<-' | '[' Mults ']' -pFun :: AmpParser Props +pFun :: AmpParser PProps pFun = Set.empty <$ pOperator "*" <|> - Set.fromList [Uni,Tot] <$ pOperator "->" <|> - Set.fromList [Sur,Inj] <$ pOperator "<-" <|> + Set.fromList [P_Uni,P_Tot] <$ pOperator "->" <|> + Set.fromList [P_Sur,P_Inj] <$ pOperator "<-" <|> pBrackets pMults --- Mults ::= Mult '-' Mult - where pMults :: AmpParser Props - pMults = Set.union <$> optSet (pMult (Sur,Inj)) + where pMults :: AmpParser PProps + pMults = Set.union <$> optSet (pMult (P_Sur,P_Inj)) <* pDash - <*> optSet (pMult (Tot,Uni)) + <*> optSet (pMult (P_Tot,P_Uni)) --- Mult ::= ('0' | '1') '..' ('1' | '*') | '*' | '1' --TODO: refactor to Mult ::= '0' '..' ('1' | '*') | '1'('..' ('1' | '*'))? | '*' - pMult :: (Prop,Prop) -> AmpParser Props + pMult :: (PProp,PProp) -> AmpParser PProps pMult (ts,ui) = Set.union <$> (Set.empty <$ pZero <|> Set.singleton ts <$ try pOne) <* pOperator ".." <*> (Set.singleton ui <$ try pOne <|> (Set.empty <$ pOperator "*" )) <|> diff --git a/src/Ampersand/Input/Archi/ArchiAnalyze.hs b/src/Ampersand/Input/Archi/ArchiAnalyze.hs index 00d4ebc983..048ba9a205 100644 --- a/src/Ampersand/Input/Archi/ArchiAnalyze.hs +++ b/src/Ampersand/Input/Archi/ArchiAnalyze.hs @@ -390,13 +390,13 @@ instance MetaArchi ArchiRepo where typeMap _ archiRepo = typeMap Nothing (archFolders archiRepo) grindArchi env archiRepo - = [ translateArchiElem "name" ("ArchiRepo","Text") Nothing (Set.singleton Uni) + = [ translateArchiElem "name" ("ArchiRepo","Text") Nothing (Set.singleton P_Uni) [(archRepoId archiRepo, archRepoName archiRepo)] ] <> - [ translateArchiElem "purpose" ("ArchiRepo","Text") Nothing (Set.singleton Uni) + [ translateArchiElem "purpose" ("ArchiRepo","Text") Nothing (Set.singleton P_Uni) [(archRepoId archiRepo, archPurpVal purp) | purp<-archPurposes archiRepo] | (not.null.archPurposes) archiRepo ] <> - [ translateArchiElem "propOf" ("Property", "ArchiRepo") Nothing (Set.singleton Uni) [(propid, archRepoId archiRepo)] + [ translateArchiElem "propOf" ("Property", "ArchiRepo") Nothing (Set.singleton P_Uni) [(propid, archRepoId archiRepo)] | prop<-archProperties archiRepo, Just propid<-[archPropId prop]] <> concatMap (grindArchi env) (archFolders archiRepo) <> (concatMap (grindArchi env) . archProperties) archiRepo @@ -421,28 +421,28 @@ instance MetaArchi ArchiObj where = Map.fromList [(viewId diagram, "View") | (not.T.null.viewName) diagram] <> typeMap (Just (viewName diagram)) (viewProps diagram) grindArchi env@(_,_,maybeViewname) element@Element{} - = [ translateArchiElem "name" (elemType element,"Text") maybeViewname (Set.singleton Uni) [(elemId element, elemName element)] + = [ translateArchiElem "name" (elemType element,"Text") maybeViewname (Set.singleton P_Uni) [(elemId element, elemName element)] | (not . T.null . elemName) element] <> - [ translateArchiElem "docu" (elemType element,"Text") maybeViewname (Set.singleton Uni) [(elemId element, elemDocu element)] -- documentation in the XML-tag + [ translateArchiElem "docu" (elemType element,"Text") maybeViewname (Set.singleton P_Uni) [(elemId element, elemDocu element)] -- documentation in the XML-tag | (not . T.null . elemDocu) element] <> - [ translateArchiElem "docu" (elemType element,"Text") maybeViewname (Set.singleton Uni) [(elemId element, archDocuVal eldo)] -- documentation with tags. + [ translateArchiElem "docu" (elemType element,"Text") maybeViewname (Set.singleton P_Uni) [(elemId element, archDocuVal eldo)] -- documentation with tags. | eldo<-elemDocus element] <> - [ translateArchiElem "propOf" ("Property", "ArchiObject") maybeViewname (Set.singleton Uni) [(propid, elemId element)] + [ translateArchiElem "propOf" ("Property", "ArchiObject") maybeViewname (Set.singleton P_Uni) [(propid, elemId element)] | prop<-elemProps element, Just propid<-[archPropId prop]] <> (concatMap (grindArchi env).elemProps) element grindArchi env@(_,typeLookup,maybeViewname) relation@Relationship{} = [ translateArchiElem relLabel (xType,yType) maybeViewname Set.empty [(relSrc relation,relTgt relation)]] <> - [ translateArchiElem "name" ("Relationship","Text") maybeViewname (Set.singleton Uni) [(relId relation, relLabel)]] <> - [ translateArchiElem "type" ("Relationship","Text") maybeViewname (Set.singleton Uni) [(relId relation, relTyp)]] <> - [ translateArchiElem "source" ("Relationship",xType) maybeViewname (Set.singleton Uni) [(relId relation, relSrc relation)]] <> - [ translateArchiElem "target" ("Relationship",yType) maybeViewname (Set.singleton Uni) [(relId relation, relTgt relation)]] <> - [ translateArchiElem "docu" ("Relationship","Text") maybeViewname (Set.singleton Uni) [(relId relation, relDocu relation)] -- documentation in the XML-tag + [ translateArchiElem "name" ("Relationship","Text") maybeViewname (Set.singleton P_Uni) [(relId relation, relLabel)]] <> + [ translateArchiElem "type" ("Relationship","Text") maybeViewname (Set.singleton P_Uni) [(relId relation, relTyp)]] <> + [ translateArchiElem "source" ("Relationship",xType) maybeViewname (Set.singleton P_Uni) [(relId relation, relSrc relation)]] <> + [ translateArchiElem "target" ("Relationship",yType) maybeViewname (Set.singleton P_Uni) [(relId relation, relTgt relation)]] <> + [ translateArchiElem "docu" ("Relationship","Text") maybeViewname (Set.singleton P_Uni) [(relId relation, relDocu relation)] -- documentation in the XML-tag | (not . T.null . relDocu) relation] <> - [ translateArchiElem "docu" ("Relationship","Text") maybeViewname (Set.singleton Uni) [(relId relation, archDocuVal reldo)] -- documentation with tags. + [ translateArchiElem "docu" ("Relationship","Text") maybeViewname (Set.singleton P_Uni) [(relId relation, archDocuVal reldo)] -- documentation with tags. | reldo<-relDocus relation] <> - [ translateArchiElem "accessType" ("Relationship","AccessType") maybeViewname (Set.singleton Uni) [(relId relation, relAccTp relation)] + [ translateArchiElem "accessType" ("Relationship","AccessType") maybeViewname (Set.singleton P_Uni) [(relId relation, relAccTp relation)] | (not . T.null . relAccTp) relation] <> - [ translateArchiElem "propOf" ("Property", "Relationship") maybeViewname (Set.singleton Uni) [(propid, relId relation)] + [ translateArchiElem "propOf" ("Property", "Relationship") maybeViewname (Set.singleton P_Uni) [(propid, relId relation)] | prop<-relProps relation, Just propid<-[archPropId prop]] <> (concatMap (grindArchi env).relProps) relation where @@ -460,17 +460,17 @@ instance MetaArchi ArchiObj where Just str -> str Nothing -> fatal ("No Archi-object found for Archi-identifier "<>tshow (relTgt relation)) grindArchi (_, typeLookup,_) diagram@View{} - = [ translateArchiElem "name" ("View","Text") maybeViewName (Set.singleton Uni) [(viewId diagram, viewName diagram)] + = [ translateArchiElem "name" ("View","Text") maybeViewName (Set.singleton P_Uni) [(viewId diagram, viewName diagram)] | (not . T.null . viewName) diagram] <> - [ translateArchiElem "propOf" ("Property", "View") maybeViewName (Set.singleton Uni) [(propid, viewId diagram)] + [ translateArchiElem "propOf" ("Property", "View") maybeViewName (Set.singleton P_Uni) [(propid, viewId diagram)] | prop<-viewProps diagram, Just propid<-[archPropId prop]] <> - [ translateArchiElem "docu" ("View","Text") maybeViewName (Set.singleton Uni) [(viewId diagram, viewDocu diagram)] -- documentation in the XML-tag + [ translateArchiElem "docu" ("View","Text") maybeViewName (Set.singleton P_Uni) [(viewId diagram, viewDocu diagram)] -- documentation in the XML-tag | (not . T.null . viewDocu) diagram] <> - [ translateArchiElem "docu" ("View","Text") maybeViewName (Set.singleton Uni) [(viewId diagram, archDocuVal viewdoc)] -- documentation with tags. + [ translateArchiElem "docu" ("View","Text") maybeViewName (Set.singleton P_Uni) [(viewId diagram, archDocuVal viewdoc)] -- documentation with tags. | viewdoc<-viewDocus diagram] <> [ translateArchiElem "inView" (chldType,"View") maybeViewName Set.empty [(chldElem viewelem, viewId diagram)] -- register the views in which an element is used. | viewelem<-viewChilds diagram, Just chldType<-[typeLookup (chldElem viewelem)]] <> - [ translateArchiElem "viewpoint" ("View","ViewPoint") maybeViewName (Set.singleton Uni) [(viewId diagram, viewPoint diagram)] -- documentation with tags. + [ translateArchiElem "viewpoint" ("View","ViewPoint") maybeViewName (Set.singleton P_Uni) [(viewId diagram, viewPoint diagram)] -- documentation with tags. | (not . T.null . viewPoint) diagram] <> (concatMap (grindArchi (Nothing,typeLookup,maybeViewName)) . viewProps) diagram <> (concatMap (grindArchi (Just (viewId diagram),typeLookup,maybeViewName)) . viewChilds) diagram @@ -493,10 +493,10 @@ instance MetaArchi ArchiProp where typeMap _ property = Map.fromList [ (propid, "Property") | Just propid<-[archPropId property] ] grindArchi (_,_,maybeViewname) property - = [ translateArchiElem "key" ("Property","Text") maybeViewname (Set.singleton Uni) + = [ translateArchiElem "key" ("Property","Text") maybeViewname (Set.singleton P_Uni) [(propid, archPropKey property) | (not . T.null . archPropKey) property, Just propid<-[archPropId property] ] - , translateArchiElem "value" ("Property","Text") maybeViewname (Set.singleton Uni) + , translateArchiElem "value" ("Property","Text") maybeViewname (Set.singleton P_Uni) [(propid, archPropVal property) | (not . T.null . archPropVal) property, Just propid<-[archPropId property] ] ] @@ -508,7 +508,7 @@ instance MetaArchi a => MetaArchi [a] where -- | The function `translateArchiElem` does the actual compilation of data objects from archiRepo into the Ampersand structure. -- It looks redundant to produce both a `P_Population` and a `P_Relation`, but the first contains the population and the second is used to -- include the metamodel of ArchiMate in the population. This saves the author the effort of maintaining an ArchiMate-metamodel. -translateArchiElem :: Text -> (Text, Text) -> Maybe Text -> Set.Set Prop-> [(Text, Text)] +translateArchiElem :: Text -> (Text, Text) -> Maybe Text -> Set.Set PProp-> [(Text, Text)] -> (P_Population,P_Relation,Maybe Text,PPurpose) translateArchiElem label (srcLabel,tgtLabel) maybeViewName props tuples = ( P_RelPopu Nothing Nothing OriginUnknown ref_to_relation (transTuples tuples) diff --git a/src/Ampersand/Input/Xslx/XLSX.hs b/src/Ampersand/Input/Xslx/XLSX.hs index 8205550b0c..54a1c2fbfa 100644 --- a/src/Ampersand/Input/Xslx/XLSX.hs +++ b/src/Ampersand/Input/Xslx/XLSX.hs @@ -116,7 +116,7 @@ addRelations pCtx = enrichedContext = L.unzip [ ( headrel{ dec_sign = P_Sign g (targt (NE.head sRel)) , dec_prps = let test prop = prop `elem` foldr Set.intersection Set.empty (fmap dec_prps sRel) - in Set.fromList ([Uni |test Uni]<>[Tot |test Tot]<>[Inj |test Inj]<>[Sur |test Sur]) + in Set.fromList ([P_Uni |test P_Uni]<>[P_Tot |test P_Tot]<>[P_Inj |test P_Inj]<>[P_Sur |test P_Sur]) } -- the generic relation that summarizes sRel -- , [ rel| rel<-sRel, sourc rel `elem` specs ] -- the specific (and therefore obsolete) relations , [ rel| rel<-NE.toList sRel, sourc rel `notElem` specs ] -- the remaining relations diff --git a/src/Ampersand/Test/Parser/ArbitraryTree.hs b/src/Ampersand/Test/Parser/ArbitraryTree.hs index 715c8512e6..8b9088134f 100644 --- a/src/Ampersand/Test/Parser/ArbitraryTree.hs +++ b/src/Ampersand/Test/Parser/ArbitraryTree.hs @@ -388,7 +388,7 @@ instance Arbitrary P_Markup where instance Arbitrary PandocFormat where arbitrary = elements [minBound..] -instance Arbitrary Prop where +instance Arbitrary PProp where arbitrary = elements [minBound..] From 4c4ad306745c4e7c5baffdcccb4e8fa51d632cc6 Mon Sep 17 00:00:00 2001 From: hanjoosten Date: Sun, 5 Sep 2021 16:59:58 +0200 Subject: [PATCH 02/11] remove old stuff --- src/Ampersand/Core/ParseTree.hs | 39 +++------------------------------ 1 file changed, 3 insertions(+), 36 deletions(-) diff --git a/src/Ampersand/Core/ParseTree.hs b/src/Ampersand/Core/ParseTree.hs index 5ee2a29ada..14eab60a83 100644 --- a/src/Ampersand/Core/ParseTree.hs +++ b/src/Ampersand/Core/ParseTree.hs @@ -304,26 +304,10 @@ instance Traced PAtomPair where instance Flippable PAtomPair where flp pr = pr{ppLeft = ppRight pr ,ppRight = ppLeft pr} ---data PSingleton --- = PSingleton { pos :: Origin --- , psRaw :: Text --- , psInterprets :: [PAtomValue] --- } ---instance Show PSingleton where --- show = psRaw ---instance Eq PSingleton where --- a == b = compare a b == EQ ---instance Ord PSingleton where --- compare a b = compare (psRaw a) (psRaw b) ---instance Traced PSingleton where --- origin = pos ---type PSingleton = PAtomValue + makePSingleton :: Text -> PAtomValue makePSingleton s = PSingleton (Origin "ParseTree.hs") s Nothing --- PSingleton { psOrig =Origin "ParseTree.hs" --- , psRaw = s --- , psInterprets = fatal "Probably no need to make something up..." --- } + data PAtomValue = PSingleton Origin Text (Maybe PAtomValue) | ScriptString Origin Text -- string from script char to enquote with when printed @@ -335,6 +319,7 @@ data PAtomValue | ScriptDate Origin Day | ScriptDateTime Origin UTCTime deriving (Typeable, Data) + instance Show PAtomValue where -- Used for showing in Expressions as PSingleton show pav = case pav of @@ -490,15 +475,6 @@ instance Traced TermPrim where Pfull orig _ _ -> orig PNamedR r -> origin r ---instance Named TermPrim where --- name e = case e of --- PI _ -> "I" --- Pid _ _ -> "I" --- Patm _ s _ -> s --- PVee _ -> "V" --- Pfull _ _ _ -> "V" --- PNamedR r -> name r --- instance Traced P_NamedRel where origin (PNamedRel o _ _) = o @@ -814,12 +790,6 @@ newtype ViewHtmlTemplate = ViewHtmlTemplateFile FilePath -- | ViewHtmlTemplateInline Text -- Future extension deriving (Eq, Ord, Show) -{- Future extension: -data ViewText = ViewTextTemplateFile Text - | ViewTextTemplateInline Text - deriving (Eq, Ord, Show) --} - instance Functor P_ViewSegmtPayLoad where fmap = fmapDefault instance Foldable P_ViewSegmtPayLoad where foldMap = foldMapDefault instance Traversable P_ViewSegmtPayLoad where @@ -827,9 +797,6 @@ instance Traversable P_ViewSegmtPayLoad where traverse _ (P_ViewText a) = pure (P_ViewText a) --- PPurpose is a parse-time constructor. It contains the name of the object it explains. --- It is a pre-explanation in the sense that it contains a reference to something that is not yet built by the compiler. --- Constructor name RefID Explanation data PRef2Obj = PRef2ConceptDef Text | PRef2Relation P_NamedRel | PRef2Rule Text From 2b95dc65c8be3818560834ccdcedeb50d7f70ae1 Mon Sep 17 00:00:00 2001 From: hanjoosten Date: Sun, 5 Sep 2021 17:00:14 +0200 Subject: [PATCH 03/11] Rectify a previous change --- src/Ampersand/ADL1/P2A_Converters.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Ampersand/ADL1/P2A_Converters.hs b/src/Ampersand/ADL1/P2A_Converters.hs index b8c0ac5755..4cc2e3b573 100644 --- a/src/Ampersand/ADL1/P2A_Converters.hs +++ b/src/Ampersand/ADL1/P2A_Converters.hs @@ -1138,7 +1138,9 @@ pDecl2aDecl cptMap maybePatName defLanguage defFormat pd decSign = pSign2aSign cptMap (dec_sign pd) checkEndoProps :: Guarded () checkEndoProps - | source decSign == target decSign && null xs + | source decSign == target decSign + = pure () + | null xs = pure () | otherwise = Errors . pure $ mkEndoPropertyError (origin pd) (Set.toList xs) where xs = Set.filter isEndoProp $ dec_prps pd From 1001602b3029319d53db47e99fa920f5d0537ea0 Mon Sep 17 00:00:00 2001 From: hanjoosten Date: Wed, 8 Sep 2021 21:06:19 +0200 Subject: [PATCH 04/11] typechecked new default values stuff --- src/Ampersand/ADL1.hs | 2 + src/Ampersand/ADL1/P2A_Converters.hs | 102 ++++++++++++--------- src/Ampersand/ADL1/Rule.hs | 20 ++-- src/Ampersand/Classes/Relational.hs | 16 ++-- src/Ampersand/Core/A2P_Converters.hs | 8 +- src/Ampersand/Core/AbstractSyntaxTree.hs | 50 ++++++---- src/Ampersand/Core/ParseTree.hs | 53 +++++++---- src/Ampersand/FSpec/ShowHS.hs | 16 +++- src/Ampersand/FSpec/Transformers.hs | 102 ++++++++++----------- src/Ampersand/Input/ADL1/Lexer.hs | 6 +- src/Ampersand/Input/ADL1/Parser.hs | 75 ++++++++------- src/Ampersand/Input/Xslx/XLSX.hs | 2 +- src/Ampersand/Test/Parser/ArbitraryTree.hs | 72 ++++++++------- 13 files changed, 301 insertions(+), 223 deletions(-) diff --git a/src/Ampersand/ADL1.hs b/src/Ampersand/ADL1.hs index 632f36af48..1c0e3424c1 100644 --- a/src/Ampersand/ADL1.hs +++ b/src/Ampersand/ADL1.hs @@ -20,6 +20,7 @@ import Ampersand.Core.ParseTree ( , SrcOrTgt(..) , P_Rule(..),Role(..) , PProp(..) + , PPropDefault(..) , P_IdentDef, P_IdentSegment,P_IdentDf(..),P_IdentSegmnt(..) , P_ViewDef, P_ViewSegment(..),P_ViewSegmtPayLoad(..),P_ViewD(..),ViewHtmlTemplate(..) , P_Population(..),PAtomPair(..) @@ -55,6 +56,7 @@ import Ampersand.Core.AbstractSyntaxTree ( , Pattern(..) , Relation(..), Relations, getExpressionRelation, showRel , AProp(..), AProps + , APropDefault(..) , Rule(..), Rules, A_RoleRule(..) , A_Concept(..), A_Concepts, TType(..), showValADL, showValSQL, unsafePAtomVal2AtomValue , Representation(..) diff --git a/src/Ampersand/ADL1/P2A_Converters.hs b/src/Ampersand/ADL1/P2A_Converters.hs index 4cc2e3b573..598d4d184e 100644 --- a/src/Ampersand/ADL1/P2A_Converters.hs +++ b/src/Ampersand/ADL1/P2A_Converters.hs @@ -253,7 +253,7 @@ pCtx2aCtx env interfaces <- traverse (pIfc2aIfc contextInfo) (p_interfaceAndDisambObjs declMap) -- TODO: explain ... The interfaces defined in this context, outside the scope of patterns purposes <- traverse (pPurp2aPurp contextInfo) p_purposes -- The purposes of objects defined in this context, outside the scope of patterns udpops <- traverse (pPop2aPop contextInfo) p_pops -- [Population] - relations <- traverse (pDecl2aDecl cptMap Nothing deflangCtxt deffrmtCtxt) p_relations + relations <- traverse (pDecl2aDecl (representationOf contextInfo) cptMap Nothing deflangCtxt deffrmtCtxt) p_relations enforces' <- traverse (pEnforce2aEnforce contextInfo Nothing) p_enfs let actx = ACtx{ ctxnm = n1 , ctxpos = n2 @@ -299,14 +299,15 @@ pCtx2aCtx env -- > SJ: It seems to mee that `multitypologies` can be implemented more concisely and more maintainably by using a transitive closure algorithm (Warshall). -- Also, `connectedConcepts` is not used in the result, so is avoidable when using a transitive closure approach. multitypologies <- traverse mkTypology connectedConcepts -- SJ: why `traverse` instead of `map`? Does this have to do with guarded as well? - decls <- traverse (pDecl2aDecl cptMap Nothing deflangCtxt deffrmtCtxt) (p_relations <> concatMap pt_dcs p_patterns) + let reprOf cpt = fromMaybe + Object -- default representation is Object (sometimes called `ugly identifiers') + (lookup cpt typeMap) + decls <- traverse (pDecl2aDecl reprOf cptMap Nothing deflangCtxt deffrmtCtxt) (p_relations <> concatMap pt_dcs p_patterns) let declMap = Map.map groupOnTp (Map.fromListWith (<>) [(name d,[EDcD d]) | d <- decls]) where groupOnTp lst = Map.fromListWith const [(SignOrd$ sign d,d) | d <- lst] let allConcs = Set.fromList (map aConcToType (map source decls <> map target decls)) :: Set.Set Type return CI { ctxiGens = gns - , representationOf = \cpt -> fromMaybe - Object -- default representation is Object (sometimes called `ugly identifiers') - (lookup cpt typeMap) + , representationOf = reprOf , multiKernels = multitypologies , reprList = allReprs , declDisambMap = declMap @@ -817,7 +818,7 @@ pCtx2aCtx env <*> traverse (pPop2aPop ci) (pt_pop 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 (pDecl2aDecl (representationOf ci) 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) @@ -868,24 +869,24 @@ pCtx2aCtx env pEnforce2aEnforce ci mPat = typeCheckEnforce ci mPat . disambiguate (conceptMap ci) (termPrimDisAmb (conceptMap ci) (declDisambMap ci)) typeCheckEnforce :: ContextInfo -> Maybe Text -- name of pattern the enforce is defined in (if any) - -> P_Enforce (TermPrim, DisambPrim) + -> P_Enforce (TermPrim, DisambPrim) -> Guarded AEnforce typeCheckEnforce ci mPat P_Enforce { pos = pos' , penfRel = pRel , penfOp = oper , penfExpr= x - } + } = case pRel of (_,Known (EDcD rel)) -> do (expr,(_srcBounded,_tgtBounded)) <- typecheckTerm ci x - return AEnforce { pos=pos' + return AEnforce { pos=pos' , enfRel=rel , enfOp=oper , enfExpr=expr , enfPatName=mPat } - (o,dx) -> cannotDisambiguate o dx - + (o,dx) -> cannotDisambiguate o dx + pIdentity2aIdentity :: ContextInfo -> Maybe Text -- name of pattern the rule is defined in (if any) -> P_IdentDef -> Guarded IdentityRule @@ -1098,42 +1099,53 @@ pAtomValue2aAtomValue typ cpt pav = where ttyp = typ cpt pDecl2aDecl :: - ConceptMap + (A_Concept -> TType) + -> ConceptMap -> Maybe Text -- name of pattern the rule is defined in (if any) -> Lang -- The default language -> PandocFormat -- The default pandocFormat -> P_Relation -> Guarded Relation -pDecl2aDecl cptMap maybePatName defLanguage defFormat pd - = let (prL:prM:prR:_) = dec_pragma pd <> ["", "", ""] - dcl = Relation - { decnm = dec_nm pd - , decsgn = decSign - , decprps = Set.fromList . concatMap pProp2aProps $ dec_prps pd - , decprps_calc = Nothing --decprps_calc in an A_Context are still the user-defined only. prps are calculated in adl2fspec. - , decprL = prL - , decprM = prM - , decprR = prR - , decMean = map (pMean2aMean defLanguage defFormat) (dec_Mean pd) - , decfpos = origin pd - , decusr = True - , decpat = maybePatName - , dechash = hash (dec_nm pd) `hashWithSalt` decSign - } - in checkEndoProps >> pure dcl +pDecl2aDecl typ cptMap maybePatName defLanguage defFormat pd + = do checkEndoProps + propLists <- mapM pProp2aProps . Set.toList $ dec_prps pd + return Relation + { decnm = dec_nm pd + , decsgn = decSign + , decprps = Set.fromList . concat $ propLists + , decprps_calc = Nothing --decprps_calc in an A_Context are still the user-defined only. prps are calculated in adl2fspec. + , decprL = prL + , decprM = prM + , decprR = prR + , decMean = map (pMean2aMean defLanguage defFormat) (dec_Mean pd) + , decfpos = origin pd + , decusr = True + , decpat = maybePatName + , dechash = hash (dec_nm pd) `hashWithSalt` decSign + } where - pProp2aProps :: PProp -> [AProp] - pProp2aProps p = case p of - P_Uni -> [Uni ] - P_Inj -> [Inj ] - P_Sur -> [Sur ] - P_Tot -> [Tot ] - P_Sym -> [Sym ] - P_Asy -> [Asy ] - P_Trn -> [Trn ] - P_Rfx -> [Rfx ] - P_Irf -> [Irf ] - P_Prop ->[Sym, Asy] + (prL:prM:prR:_) = dec_pragma pd <> ["", "", ""] + pProp2aProps :: PProp -> Guarded [AProp] + pProp2aProps p = case p of + P_Uni -> pure [Uni ] + P_Inj -> pure [Inj ] + P_Sur x -> f Sur x + P_Tot x -> f Tot x + P_Sym -> pure [Sym ] + P_Asy -> pure [Asy ] + P_Trn -> pure [Trn ] + P_Rfx -> pure [Rfx ] + P_Irf -> pure [Irf ] + P_Prop -> pure [Sym, Asy] + where f :: (Maybe APropDefault -> AProp) -> Maybe PPropDefault -> Guarded [AProp] + f surOrTot x = + case x of + Nothing -> pure [surOrTot Nothing] + Just d -> (: []) . surOrTot . Just <$> ppropDef2apropDef d + ppropDef2apropDef :: PPropDefault -> Guarded APropDefault + ppropDef2apropDef x = case x of + PDefAtom val -> ADefAtom <$> pAtomValue2aAtomValue typ (target decSign) val + PDefEvalPHP txt -> pure $ ADefEvalPHP txt decSign = pSign2aSign cptMap (dec_sign pd) checkEndoProps :: Guarded () @@ -1144,7 +1156,7 @@ pDecl2aDecl cptMap maybePatName defLanguage defFormat pd = pure () | otherwise = Errors . pure $ mkEndoPropertyError (origin pd) (Set.toList xs) where xs = Set.filter isEndoProp $ dec_prps pd - isEndoProp :: PProp -> Bool + isEndoProp :: PProp -> Bool isEndoProp p = p `elem` [P_Prop, P_Sym,P_Asy,P_Trn,P_Rfx,P_Irf] pDisAmb2Expr :: (TermPrim, DisambPrim) -> Guarded Expression pDisAmb2Expr (_,Known x) = pure x @@ -1167,11 +1179,11 @@ pConcDef2aConcDef defLanguage defFormat pCd = pCDDef2Mean :: Lang -- The default language -> PandocFormat -- The default pandocFormat -> PCDDef -> Meaning -pCDDef2Mean defLanguage defFormat x = case x of - PCDDefLegacy defStr refStr -> +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 diff --git a/src/Ampersand/ADL1/Rule.hs b/src/Ampersand/ADL1/Rule.hs index e8fff71889..ca3dff0ee1 100644 --- a/src/Ampersand/ADL1/Rule.hs +++ b/src/Ampersand/ADL1/Rule.hs @@ -54,9 +54,9 @@ rulefromProp prp d = then fatal ("Illegal property of an endo relation "<>tshow (name d)) else case prp of Uni-> r .:. ECpl (EDcI (target r)) .:. flp r .|-. ECpl (EDcI (source r)) - Tot-> EDcI (source r) .|-. r .:. flp r + Tot _ -> EDcI (source r) .|-. r .:. flp r Inj-> flp r .:. ECpl (EDcI (source r)) .:. r .|-. ECpl (EDcI (target r)) - Sur-> EDcI (target r) .|-. flp r .:. r + Sur _ -> EDcI (target r) .|-. flp r .:. r Sym-> r .==. flp r Asy-> flp r ./\. r .|-. EDcI (source r) Trn-> r .:. r .|-. r @@ -83,8 +83,8 @@ rulefromProp prp d = Irf-> explByFullName lang Uni-> "Each " <>s<>" may only have one "<>t<>"" <>" in the relation "<>name d Inj-> "Each " <>t<>" may only have one "<>s<>"" <>" in the relation "<>name d - Tot ->"Every "<>s<>" must have a " <>t<>"" <>" in the relation "<>name d - Sur ->"Every "<>t<>" must have a " <>s<>"" <>" in the relation "<>name d + Tot _ ->"Every "<>s<>" must have a " <>t<>"" <>" in the relation "<>name d + Sur _ ->"Every "<>t<>" must have a " <>s<>"" <>" in the relation "<>name d Dutch -> case prop of Sym-> explByFullName lang @@ -94,8 +94,8 @@ rulefromProp prp d = Irf-> explByFullName lang Uni-> "Elke "<>s<>" mag slechts één "<>t<> " hebben" <>" in de relatie "<>name d Inj-> "Elke "<>t<>" mag slechts één "<>s<> " hebben" <>" in de relatie "<>name d - Tot-> "Elke "<>s<>" dient één " <>t<>" te hebben" <>" in de relatie "<>name d - Sur-> "Elke "<>t<>" dient een " <>s<>" te hebben" <>" in de relatie "<>name d + Tot _ -> "Elke "<>s<>" dient één " <>t<>" te hebben" <>" in de relatie "<>name d + Sur _ -> "Elke "<>t<>" dient een " <>s<>" te hebben" <>" in de relatie "<>name d explByFullName lang = showDcl<>" is "<>propFullName False lang prop propFullName :: Bool -> Lang -> AProp -> Text @@ -109,9 +109,9 @@ propFullName isAdjective lang prop = Rfx-> "reflexive" Irf-> "irreflexive" Uni-> "univalent" - Sur-> "surjective" + Sur _ -> "surjective" Inj-> "injective" - Tot-> "total" + Tot _ -> "total" Dutch -> (if isAdjective then snd else fst) $ case prop of Sym-> ("symmetrisch" ,"symmetrische") @@ -120,6 +120,6 @@ propFullName isAdjective lang prop = Rfx-> ("reflexief" ,"reflexieve") Irf-> ("irreflexief" ,"irreflexieve") Uni-> ("univalent" ,"univalente") - Sur-> ("surjectief" ,"surjectieve") + Sur _ -> ("surjectief" ,"surjectieve") Inj-> ("injectief" ,"injectieve") - Tot-> ("totaal" ,"totale") + Tot _ -> ("totaal" ,"totale") diff --git a/src/Ampersand/Classes/Relational.hs b/src/Ampersand/Classes/Relational.hs index 3183fd03da..c1717aef9e 100644 --- a/src/Ampersand/Classes/Relational.hs +++ b/src/Ampersand/Classes/Relational.hs @@ -48,8 +48,8 @@ isSESSION cpt = properties' :: Expression -> AProps properties' expr = case expr of EDcD dcl -> properties dcl - EDcI{} -> Set.fromList [Uni,Tot,Inj,Sur,Sym,Asy,Trn,Rfx] - EEps a sgn -> Set.fromList $ [Tot | a == source sgn]++[Sur | a == target sgn] ++ [Uni,Inj] + EDcI{} -> Set.fromList [Uni,Tot Nothing,Inj,Sur Nothing,Sym,Asy,Trn,Rfx] + EEps a sgn -> Set.fromList $ [Tot Nothing| a == source sgn]++[Sur Nothing | a == target sgn] ++ [Uni,Inj] EDcV sgn -> Set.fromList $ --NOT totaal --NOT surjective @@ -60,8 +60,8 @@ properties' expr = case expr of ++[Rfx | isEndo sgn] ++[Trn | isEndo sgn] EBrk f -> properties' f - ECps (l,r) -> Set.filter (\x->x `elem` [Uni,Tot,Inj,Sur]) (properties' l `Set.intersection` properties' r) - EPrd (l,r) -> Set.fromList $ [Tot | isTot l]++[Sur | isSur r]++[Rfx | isRfx l&&isRfx r]++[Trn] + ECps (l,r) -> Set.filter (\x->x `elem` [Uni,Tot Nothing,Inj,Sur Nothing]) (properties' l `Set.intersection` properties' r) + EPrd (l,r) -> Set.fromList $ [Tot Nothing | isTot l]++[Sur Nothing | isSur r]++[Rfx | isRfx l&&isRfx r]++[Trn] EKl0 e' -> Set.fromList [Rfx,Trn] `Set.union` (properties' e' Set.\\ Set.fromList [Uni,Inj]) EKl1 e' -> Set.singleton Trn `Set.union` (properties' e' Set.\\ Set.fromList [Uni,Inj]) ECpl e' -> Set.singleton Sym `Set.intersection` properties' e' @@ -163,8 +163,8 @@ instance Relational Expression where -- TODO: see if we can find more pro _ -> False -- TODO: find richer answers for ELrs, ERrs, and EDia isFunction r = isUni r && isTot r - isTot = isTotSur Tot - isSur = isTotSur Sur + isTot = isTotSur (Tot Nothing) + isSur = isTotSur (Sur Nothing) isUni = isUniInj Uni isInj = isUniInj Inj @@ -197,8 +197,8 @@ isTotSur prop expr EDcD d -> prop `elem` properties d EDcI{} -> True EEps c sgn -> case prop of - Tot -> c == source sgn - Sur -> c == target sgn + Tot _ -> c == source sgn + Sur _ -> c == target sgn _ -> fatal $ "isTotSur must not be called with "<>tshow prop EDcV{} -> todo EBrk e -> isTotSur prop e diff --git a/src/Ampersand/Core/A2P_Converters.hs b/src/Ampersand/Core/A2P_Converters.hs index 40b8f08a49..ad13d6e9e3 100644 --- a/src/Ampersand/Core/A2P_Converters.hs +++ b/src/Ampersand/Core/A2P_Converters.hs @@ -119,13 +119,17 @@ aProps2Pprops aps aProp2pProp p = case p of Uni -> P_Uni Inj -> P_Inj - Sur -> P_Sur - Tot -> P_Tot + Sur x -> P_Sur (aPropDef2pPropDef <$> x) + Tot x -> P_Tot (aPropDef2pPropDef <$> x) Sym -> P_Sym Asy -> P_Asy Trn -> P_Trn Rfx -> P_Rfx Irf -> P_Irf + aPropDef2pPropDef :: APropDefault -> PPropDefault + aPropDef2pPropDef x = case x of + ADefAtom val -> PDefAtom $ aAtomValue2pAtomValue val + ADefEvalPHP txt -> PDefEvalPHP txt aRelation2pNamedRel :: Relation -> P_NamedRel aRelation2pNamedRel dcl = PNamedRel { pos = decfpos dcl diff --git a/src/Ampersand/Core/AbstractSyntaxTree.hs b/src/Ampersand/Core/AbstractSyntaxTree.hs index 809d343af9..41eddc1ddd 100644 --- a/src/Ampersand/Core/AbstractSyntaxTree.hs +++ b/src/Ampersand/Core/AbstractSyntaxTree.hs @@ -17,6 +17,7 @@ module Ampersand.Core.AbstractSyntaxTree ( , AEnforce(..) , Relation(..), Relations, showRel , AProp(..), AProps + , APropDefault(..) , IdentityRule(..) , IdentitySegment(..) , ViewDef(..) @@ -244,22 +245,35 @@ instance Ord Conjunct where compare = compare `on` rc_id type AProps = Set.Set AProp -data AProp = Uni -- ^ univalent - | Inj -- ^ injective - | Sur -- ^ surjective - | Tot -- ^ total - | Sym -- ^ symmetric - | Asy -- ^ antisymmetric - | Trn -- ^ transitive - | Rfx -- ^ reflexive - | Irf -- ^ irreflexive - deriving (Eq, Ord, Enum, Bounded,Typeable, Data) - +data AProp + = -- | univalent + Uni + | -- | injective + Inj + | -- | surjective + Sur (Maybe APropDefault) + | -- | total + Tot (Maybe APropDefault) + | -- | symmetric + Sym + | -- | antisymmetric + Asy + | -- | transitive + Trn + | -- | reflexive + Rfx + | -- | irreflexive + Irf + deriving (Eq, Ord, Data, Typeable) instance Show AProp where show Uni = "UNI" show Inj = "INJ" - show Sur = "SUR" - show Tot = "TOT" + show (Sur x) = "SUR"<>(case x of + Nothing -> mempty + Just d -> " "<>show d) + show (Tot x) = "TOT"<>(case x of + Nothing -> mempty + Just d -> " "<>show d) show Sym = "SYM" show Asy = "ASY" show Trn = "TRN" @@ -271,11 +285,15 @@ instance Unique AProp where instance Flippable AProp where flp Uni = Inj - flp Tot = Sur - flp Sur = Tot + flp (Tot x) = Sur x + flp (Sur x) = Tot x flp Inj = Uni flp x = x +data APropDefault = + ADefAtom !AAtomValue + | ADefEvalPHP !Text + deriving (Eq, Ord, Show, Data) type Relations = Set.Set Relation @@ -622,7 +640,7 @@ data AAtomValue | AAVDateTime { aavtyp :: TType , aadatetime :: UTCTime } - | AtomValueOfONE deriving (Eq,Ord, Show) + | AtomValueOfONE deriving (Eq,Ord, Show, Data) instance Unique AAtomValue where -- FIXME: this in incorrect! (AAtomValue should probably not be in Unique at all. We need to look into where this is used for.) showUnique pop@AAVString{} = (tshow.aavhash) pop diff --git a/src/Ampersand/Core/ParseTree.hs b/src/Ampersand/Core/ParseTree.hs index 14eab60a83..a03049582c 100644 --- a/src/Ampersand/Core/ParseTree.hs +++ b/src/Ampersand/Core/ParseTree.hs @@ -34,6 +34,7 @@ module Ampersand.Core.ParseTree ( , P_Markup(..) , PProp(..), PProps + , PPropDefault(..) -- Inherited stuff: , module Ampersand.Input.ADL1.FilePos ) where @@ -219,7 +220,7 @@ data TType | Date | DateTime | Boolean | Integer | Float | Object | TypeOfOne --special type for the special concept ONE. - deriving (Eq, Ord, Typeable, Enum, Bounded) + deriving (Eq, Ord, Data, Typeable, Enum, Bounded) instance Unique TType where showUnique = tshow instance Show TType where @@ -883,23 +884,38 @@ instance Traced PClassify where origin = pos type PProps = Set PProp -data PProp = P_Uni -- ^ univalent - | P_Inj -- ^ injective - | P_Sur -- ^ surjective - | P_Tot -- ^ total - | P_Sym -- ^ symmetric - | P_Asy -- ^ antisymmetric - | P_Trn -- ^ transitive - | P_Rfx -- ^ reflexive - | P_Irf -- ^ irreflexive - | P_Prop -- ^ PROP keyword, the parser must replace this by [Sym, Asy]. - deriving (Eq, Ord, Enum, Bounded,Typeable, Data) +data PProp + = -- | univalent + P_Uni + | -- | injective + P_Inj + | -- | surjective + P_Sur (Maybe PPropDefault) + | -- | total + P_Tot (Maybe PPropDefault) + | -- | symmetric + P_Sym + | -- | antisymmetric + P_Asy + | -- | transitive + P_Trn + | -- | reflexive + P_Rfx + | -- | irreflexive + P_Irf + | -- | PROP keyword, the parser must replace this by [Sym, Asy]. + P_Prop + deriving (Eq, Ord, Typeable, Data) instance Show PProp where show P_Uni = "UNI" show P_Inj = "INJ" - show P_Sur = "SUR" - show P_Tot = "TOT" + show (P_Sur x) = "SUR"<>case x of + Nothing -> mempty + Just d -> " "<>show d + show (P_Tot x) = "TOT"<>case x of + Nothing -> mempty + Just d -> " "<>show d show P_Sym = "SYM" show P_Asy = "ASY" show P_Trn = "TRN" @@ -912,11 +928,14 @@ instance Unique PProp where instance Flippable PProp where flp P_Uni = P_Inj - flp P_Tot = P_Sur - flp P_Sur = P_Tot + flp (P_Tot x) = P_Sur x + flp (P_Sur x) = P_Tot x flp P_Inj = P_Uni flp x = x - +data PPropDefault = + PDefAtom !PAtomValue + | PDefEvalPHP !Text + deriving (Eq, Ord, Data, Show) mergeContexts :: P_Context -> P_Context -> P_Context mergeContexts ctx1 ctx2 = PCtx{ ctx_nm = case (filter (not.T.null) . map ctx_nm) contexts of diff --git a/src/Ampersand/FSpec/ShowHS.hs b/src/Ampersand/FSpec/ShowHS.hs index 3fdc1bc3c3..d80271cde8 100644 --- a/src/Ampersand/FSpec/ShowHS.hs +++ b/src/Ampersand/FSpec/ShowHS.hs @@ -432,7 +432,7 @@ instance ShowHS Rule where ," , rrviol = " <> showHS env "" (rrviol r) ," , rrpat = " <> tshow (rrpat r) ," , rrkind = " <> (case rrkind r of - Propty prp rel -> "Propty "<>showHSName prp<>", "<>showHSName rel + Propty prp rel -> "Propty "<>showHS env "" prp<>", "<>showHSName rel x -> tshow x ) @@ -627,8 +627,8 @@ instance ShowHS A_Concept where instance ShowHSName AProp where showHSName Uni = "Uni" showHSName Inj = "Inj" - showHSName Sur = "Sur" - showHSName Tot = "Tot" + showHSName Sur{} = "Sur" + showHSName Tot{} = "Tot" showHSName Sym = "Sym" showHSName Asy = "Asy" showHSName Trn = "Trn" @@ -636,7 +636,15 @@ instance ShowHSName AProp where showHSName Irf = "Irf" instance ShowHS AProp where - showHS _ _ = showHSName + showHS env indent prp = indent <> showHSName prp <> + case prp of + Sur d -> " "<> showHS env indent d + Tot d -> " "<> showHS env indent d + _ -> mempty +instance ShowHS APropDefault where + showHS _ _ d = case d of + ADefAtom aav -> "ADefAtom " <> tshow aav + ADefEvalPHP txt -> "ADefEvalPHP "<> tshow txt instance ShowHS FilePos where showHS _ _ = tshow diff --git a/src/Ampersand/FSpec/Transformers.hs b/src/Ampersand/FSpec/Transformers.hs index 7034272b23..49eafdac71 100644 --- a/src/Ampersand/FSpec/Transformers.hs +++ b/src/Ampersand/FSpec/Transformers.hs @@ -140,20 +140,20 @@ transformersFormalAmpersand fSpec = map toTransformer [ ] ) ,("arg" , "UnaryTerm" , "Term" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId expr, dirtyId x) | expr::Expression <- instanceList fSpec , Just x <- [arg expr] ] ) ,("asMarkdown" , "Markup" , "Text" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId mrk,(PopAlphaNumeric . P.stringify . amPandoc) mrk) | mrk::Markup <- instanceList fSpec ] ) ,("bind" , "BindedRelation" , "Relation" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId expr, dirtyId x) | expr::Expression <- instanceList fSpec , Just x <- [bindedRel expr] @@ -167,7 +167,7 @@ transformersFormalAmpersand fSpec = map toTransformer [ ] ) ,("rc_conjunct" , "Conjunct" , "Term" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId conj, dirtyId (rc_conjunct conj)) | conj::Conjunct <- instanceList fSpec ] @@ -180,49 +180,49 @@ transformersFormalAmpersand fSpec = map toTransformer [ ] ) ,("context" , "Interface" , "Context" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId ifc,dirtyId ctx) | ctx::A_Context <- instanceList fSpec , ifc::Interface <- ctxifcs ctx ] ) ,("context" , "Isa" , "Context" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId isa, dirtyId ctx) | ctx::A_Context <- instanceList fSpec , isa@Isa{} <- instanceList fSpec ] ) ,("context" , "IsE" , "Context" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId ise, dirtyId ctx) | ctx::A_Context <- instanceList fSpec , ise@IsE{} <- instanceList fSpec ] ) ,("context" , "Pattern" , "Context" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId pat, dirtyId ctx) | ctx::A_Context <- instanceList fSpec , pat::Pattern <- instanceList fSpec ] ) ,("context" , "Population" , "Context" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId pop, dirtyId ctx) | ctx::A_Context <- instanceList fSpec , pop::Population <- instanceList fSpec ] ) ,("ctxcds" , "ConceptDef" , "Context" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId cdf, dirtyId ctx) | ctx::A_Context <- instanceList fSpec , cdf::AConceptDef <- instanceList fSpec ] ) ,("relsDefdIn" , "Relation" , "Context" ---contains ALL relations defined in this context - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId rel, dirtyId ctx) | ctx::A_Context <- instanceList fSpec , rel::Relation <- Set.elems $ relsDefdIn ctx @@ -286,14 +286,14 @@ transformersFormalAmpersand fSpec = map toTransformer [ , [] --TODO ) ,("fieldIn" , "FieldDef" , "ObjectDef" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId fld, dirtyId obj) | obj::ObjectDef <- instanceList fSpec , fld <- fields obj ] ) ,("first" , "BinaryTerm" , "Term" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId expr, dirtyId x) | expr::Expression <- instanceList fSpec , Just x <- [first expr] @@ -306,25 +306,25 @@ transformersFormalAmpersand fSpec = map toTransformer [ ] ) ,("gengen" , "Isa" , "Concept" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ ( dirtyId isa, dirtyId (gengen isa)) | isa@Isa{} <- instanceList fSpec ] ) ,("gengen" , "IsE" , "Concept" - , Set.fromList [Tot] + , Set.fromList [Tot Nothing] , [ ( dirtyId ise, dirtyId cpt) | ise@IsE{} <- instanceList fSpec , cpt <- NE.toList $ genrhs ise] ) ,("genspc" , "IsE" , "Concept" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ ( dirtyId ise, dirtyId (genspc ise)) | ise@IsE{} <- instanceList fSpec ] ) ,("genspc" , "Isa" , "Concept" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ ( dirtyId isa, dirtyId (genspc isa)) | isa@Isa{} <- instanceList fSpec ] @@ -355,7 +355,7 @@ transformersFormalAmpersand fSpec = map toTransformer [ , [] --TODO ) ,("ifcObj" , "Interface" , "ObjectDef" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId ifc, dirtyId (ifcObj ifc)) | ifc::Interface <- instanceList fSpec ] @@ -411,7 +411,7 @@ transformersFormalAmpersand fSpec = map toTransformer [ ] ) ,("label" , "FieldDef" , "FieldName" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId fld, PopAlphaNumeric (name obj)) | obj::ObjectDef <- instanceList fSpec , fld <- fields obj @@ -436,13 +436,13 @@ transformersFormalAmpersand fSpec = map toTransformer [ ] ) ,("markup" , "Meaning" , "Markup" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId mean, dirtyId . ameaMrk $ mean) | mean::Meaning <- Set.toList . meaningInstances $ fSpec ] ) ,("markup" , "Purpose" , "Markup" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId purp, dirtyId . explMarkup $ purp) | purp::Purpose <- Set.toList . purposeInstances $ fSpec ] @@ -473,7 +473,7 @@ transformersFormalAmpersand fSpec = map toTransformer [ ] ) ,("propertyRule" , "Relation" , "PropertyRule" - , Set.fromList [Sur] + , Set.fromList [Sur Nothing] , [ (dirtyId rel, dirtyId rul) | ctx::A_Context <- instanceList fSpec , rul <- Set.elems $ proprules ctx @@ -481,7 +481,7 @@ transformersFormalAmpersand fSpec = map toTransformer [ ] ) ,("declaredthrough" , "PropertyRule" , "Property" - , Set.fromList [Tot] + , Set.fromList [Tot Nothing] , [ (dirtyId rul, (PopAlphaNumeric . tshow) prop) | ctx::A_Context <- instanceList fSpec , rul <- Set.elems $ proprules ctx @@ -495,31 +495,31 @@ transformersFormalAmpersand fSpec = map toTransformer [ ] ) ,("name" , "Context" , "ContextName" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId ctx, (PopAlphaNumeric . name) ctx) | ctx::A_Context <- instanceList fSpec ] ) ,("name" , "Interface" , "InterfaceName" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId ifc, (PopAlphaNumeric . name) ifc) | ifc::Interface <- instanceList fSpec ] ) ,("name" , "ObjectDef" , "ObjectName" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId obj, (PopAlphaNumeric . name) obj) | obj::ObjectDef <- instanceList fSpec ] ) ,("name" , "Pattern" , "PatternName" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId pat,(PopAlphaNumeric . name) pat) | pat::Pattern <- instanceList fSpec ] ) ,("name" , "Relation" , "RelationName" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId rel,(PopAlphaNumeric . name) rel) | rel::Relation <- instanceList fSpec ] @@ -531,13 +531,13 @@ transformersFormalAmpersand fSpec = map toTransformer [ ] ) ,("name" , "Rule" , "RuleName" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId rul,(PopAlphaNumeric . name) rul) | rul::Rule <- instanceList fSpec ] ) ,("name" , "ViewDef" , "ViewDefName" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId vd, PopAlphaNumeric . tshow . name $ vd) | vd::ViewDef <- instanceList fSpec ] @@ -557,14 +557,14 @@ transformersFormalAmpersand fSpec = map toTransformer [ ] ) ,("operator" , "BinaryTerm" , "Operator" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId expr, PopAlphaNumeric . tshow $ op) | expr::Expression <- instanceList fSpec , Just op <- [binOp expr] ] ) ,("operator" , "UnaryTerm" , "Operator" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId expr, PopAlphaNumeric . tshow $ op) | expr::Expression <- instanceList fSpec , Just op <- [unaryOp expr] @@ -652,13 +652,13 @@ transformersFormalAmpersand fSpec = map toTransformer [ ] --TODO ) ,("qDcl" , "Quad" , "Relation" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId quad, dirtyId (qDcl quad)) | quad <- vquads fSpec ] --TODO ) ,("qRule" , "Quad" , "Rule" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId quad, dirtyId (qRule quad)) | quad <- vquads fSpec ] --TODO @@ -678,7 +678,7 @@ transformersFormalAmpersand fSpec = map toTransformer [ ] ) ,("second" , "BinaryTerm" , "Term" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId expr, dirtyId x) | expr::Expression <- instanceList fSpec , Just x <- [second expr] @@ -709,58 +709,58 @@ transformersFormalAmpersand fSpec = map toTransformer [ , [] --TODO ) ,("showADL" , "Term" , "ShowADL" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId expr, PopAlphaNumeric (showA expr)) | expr::Expression <- instanceList fSpec ] ) ,("sign" , "Term" , "Signature" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId expr, dirtyId (sign expr)) | expr::Expression <- instanceList fSpec ] ) ,("sign" , "Relation" , "Signature" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId rel, dirtyId (sign rel)) | rel::Relation <- instanceList fSpec ] ) ,("singleton" , "Singleton" , "AtomValue" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId expr, dirtyId x) | expr::Expression <- instanceList fSpec , Just x <- [singleton expr] ] ) ,("source" , "Relation" , "Concept" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId rel, dirtyId (source rel)) | rel::Relation <- instanceList fSpec ] ) ,("src" , "Signature" , "Concept" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId sgn, dirtyId (source sgn)) | sgn::Signature <- instanceList fSpec ] ) ,("srcOrTgt" , "PairViewSegment" , "SourceOrTarget" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [] --TODO ) ,("target" , "Relation" , "Concept" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId rel, dirtyId (target rel)) | rel::Relation <- instanceList fSpec ] ) ,("text" , "PairViewSegment" , "String" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [] --TODO ) ,("tgt" , "Signature" , "Concept" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId sgn, dirtyId (target sgn)) | sgn::Signature <- instanceList fSpec ] @@ -811,28 +811,28 @@ transformersFormalAmpersand fSpec = map toTransformer [ ] ) ,("userCpt" , "Epsilon" , "Concept" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId expr, dirtyId x) | expr::Expression <- instanceList fSpec , Just (x::A_Concept) <- [userCpt expr] ] ) ,("userSrc" , "V" , "Concept" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId expr, dirtyId x) | expr::Expression <- instanceList fSpec , Just x <- [userSrc expr] ] ) ,("userTgt" , "V" , "Concept" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId expr, dirtyId x) | expr::Expression <- instanceList fSpec , Just x <- [userTgt expr] ] ) ,("vdats" , "ViewDef" , "ViewSegment" - , Set.fromList [Inj,Sur] + , Set.fromList [Inj,Sur Nothing] , [ (dirtyId vd, PopAlphaNumeric . tshow $ vs) | vd::ViewDef <- instanceList fSpec , vs <- vdats vd @@ -852,7 +852,7 @@ transformersFormalAmpersand fSpec = map toTransformer [ ] ) ,("vdIsDefault" , "ViewDef" , "Concept" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId vd, PopAlphaNumeric . tshow . vdcpt $ vd) | vd::ViewDef <- instanceList fSpec ] @@ -865,7 +865,7 @@ transformersFormalAmpersand fSpec = map toTransformer [ ] ) ,("versionInfo" , "Context" , "AmpersandVersion" - , Set.fromList [Uni,Tot] + , Set.fromList [Uni,Tot Nothing] , [ (dirtyId ctx,PopAlphaNumeric (longVersion appVersion)) | ctx::A_Context <- instanceList fSpec ] diff --git a/src/Ampersand/Input/ADL1/Lexer.hs b/src/Ampersand/Input/ADL1/Lexer.hs index d32e2f137f..e21a3d82d1 100644 --- a/src/Ampersand/Input/ADL1/Lexer.hs +++ b/src/Ampersand/Input/ADL1/Lexer.hs @@ -48,10 +48,8 @@ keywords = L.nub $ , "CONCEPT" -- Keywords for Relation-statements , "RELATION", "PRAGMA", "MEANING" - ] ++ - [map toUpper $ show x | x::PProp <-[minBound..] - ] ++ - [ "POPULATION", "CONTAINS" + , "ASY", "INJ", "IRF", "RFX", "SUR", "SYM", "TOT", "TRN", "UNI", "EVALPHP" + , "POPULATION", "CONTAINS" -- Keywords for rules , "RULE", "MESSAGE", "VIOLATION", "TXT" ] ++ diff --git a/src/Ampersand/Input/ADL1/Parser.hs b/src/Ampersand/Input/ADL1/Parser.hs index d042c39f8a..dc37793f3c 100644 --- a/src/Ampersand/Input/ADL1/Parser.hs +++ b/src/Ampersand/Input/ADL1/Parser.hs @@ -98,9 +98,9 @@ data ContextElement = CMeta MetaData data Include = Include Origin FilePath [Text] --- IncludeStatement ::= 'INCLUDE' Text pIncludeStatement :: AmpParser Include -pIncludeStatement = +pIncludeStatement = Include <$> currPos - <* pKey "INCLUDE" + <* pKey "INCLUDE" <*> pDoubleQuotedString <*> (pBrackets (asText pDoubleQuotedString `sepBy` pComma) <|> return []) @@ -209,8 +209,8 @@ pClassify = fun <$> currPos where fun :: Origin -> NE.NonEmpty P_Concept -> (Bool, [P_Concept]) -> [PClassify] fun p lhs (isISA ,rhs) = NE.toList $ fmap f lhs - where - f s = PClassify + where + f s = PClassify { pos = p , specific = s , generics = if isISA then s NE.:| rhs else PARTIAL.fromList rhs @@ -245,7 +245,7 @@ pRuleDef = P_Rule <$> currPos pPairView :: AmpParser (PairView (Term TermPrim)) pPairView = PairView <$> pParens (pPairViewSegment `sepBy1` pComma) -- where f xs = PairView {ppv_segs = xs} - + --- PairViewSegmentList ::= PairViewSegment (',' PairViewSegment)* --- PairViewSegment ::= 'SRC' Term | 'TGT' Term | 'TXT' Text pPairViewSegment :: AmpParser (PairViewSegment (Term TermPrim)) @@ -264,7 +264,7 @@ pRelationDef = reorder <$> currPos <* optList (pOperator ".") where reorder pos' (nm,sign,fun) prop pragma meanings prs = (P_Relation nm sign props pragma meanings pos', map pair2pop prs) - where + where props = prop `Set.union` fun pair2pop :: PAtomPair -> P_Population pair2pop a = P_RelPopu Nothing Nothing (origin a) rel [a] @@ -293,18 +293,27 @@ pProps = normalizeProps <$> pBrackets (pProp `sepBy` pComma) --- PropList ::= Prop (',' Prop)* --- Prop ::= 'UNI' | 'INJ' | 'SUR' | 'TOT' | 'SYM' | 'ASY' | 'TRN' | 'RFX' | 'IRF' | 'PROP' where pProp :: AmpParser PProp - pProp = choice [ p <$ pKey (show p) | p <- [minBound..] ] + pProp = choice $ + [ p <$ pKey (show p) | p <- [P_Uni, P_Inj, P_Sym, P_Asy, P_Trn, P_Rfx, P_Irf, P_Prop] + ] <> + [ P_Tot <$ pKey "TOT" <*> pMaybe pPropDefault + , P_Sur <$ pKey "SUR" <*> pMaybe pPropDefault] + where pPropDefault :: AmpParser PPropDefault + pPropDefault = choice + [ PDefAtom <$ pKey "VALUE" <*> pAtomValue + , PDefEvalPHP <$ pKey "EVALPHP" <*> (T.pack <$> pDoubleQuotedString) + ] normalizeProps :: [PProp] -> PProps normalizeProps = conv.rep . Set.fromList where -- replace PROP by SYM, ASY rep :: PProps -> PProps - rep ps + rep ps | P_Prop `elem` ps = Set.fromList [P_Sym, P_Asy] `Set.union` (P_Prop `Set.delete` ps) | otherwise = ps -- add Uni and Inj if ps has neither Sym nor Asy conv :: PProps -> PProps conv ps = ps `Set.union` - if P_Sym `elem` ps && P_Asy `elem` ps + if P_Sym `elem` ps && P_Asy `elem` ps then Set.fromList [P_Uni,P_Inj] else Set.empty @@ -312,14 +321,14 @@ pProps = normalizeProps <$> pBrackets (pProp `sepBy` pComma) --- Fun ::= '*' | '->' | '<-' | '[' Mults ']' pFun :: AmpParser PProps pFun = Set.empty <$ pOperator "*" <|> - Set.fromList [P_Uni,P_Tot] <$ pOperator "->" <|> - Set.fromList [P_Sur,P_Inj] <$ pOperator "<-" <|> + Set.fromList [P_Uni ,P_Tot Nothing ] <$ pOperator "->" <|> + Set.fromList [P_Sur Nothing ,P_Inj ] <$ pOperator "<-" <|> pBrackets pMults --- Mults ::= Mult '-' Mult where pMults :: AmpParser PProps - pMults = Set.union <$> optSet (pMult (P_Sur,P_Inj)) + pMults = Set.union <$> optSet (pMult (P_Sur Nothing ,P_Inj)) <* pDash - <*> optSet (pMult (P_Tot,P_Uni)) + <*> optSet (pMult (P_Tot Nothing ,P_Uni)) --- Mult ::= ('0' | '1') '..' ('1' | '*') | '*' | '1' --TODO: refactor to Mult ::= '0' '..' ('1' | '*') | '1'('..' ('1' | '*'))? | '*' @@ -339,11 +348,11 @@ pConceptDef = PConceptDef <$> currPos <*> many pMeaning where pPCDDef2 :: AmpParser PCDDef - pPCDDef2 = + pPCDDef2 = (PCDDefLegacy <$> (asText pDoubleQuotedString "concept definition (string)") <*> (asText pDoubleQuotedString `opt` "") -- a reference to the source of this definition. ) - <|> (PCDDefNew <$> pMeaning) + <|> (PCDDefNew <$> pMeaning) --- Representation ::= 'REPRESENT' ConceptNameList 'TYPE' AdlTType pRepresentation :: AmpParser Representation pRepresentation @@ -417,10 +426,10 @@ pFancyViewDef = mkViewDef <$> currPos pHtmlView :: AmpParser ViewHtmlTemplate pHtmlView = ViewHtmlTemplateFile <$ pKey "HTML" <* pKey "TEMPLATE" <*> pDoubleQuotedString --- ViewSegmentLoad ::= Term | 'TXT' Text -pViewSegmentLoad :: AmpParser (P_ViewSegmtPayLoad TermPrim) +pViewSegmentLoad :: AmpParser (P_ViewSegmtPayLoad TermPrim) pViewSegmentLoad = P_ViewExp <$> pTerm <|> P_ViewText <$ pKey "TXT" <*> asText pDoubleQuotedString - + --- ViewSegment ::= Label ViewSegmentLoad pViewSegment :: Bool -> AmpParser (P_ViewSegment TermPrim) pViewSegment labelIsOptional @@ -442,11 +451,11 @@ pViewDefLegacy = P_Vd <$> currPos --- Interface ::= 'INTERFACE' ADLid Params? Roles? ':' Term (ADLid | Conid)? SubInterface? pInterface :: AmpParser P_Interface -pInterface = lbl <$> currPos +pInterface = lbl <$> currPos <*> pInterfaceIsAPI <*> pADLid <*> pMaybe pParams - <*> pMaybe pRoles + <*> pMaybe pRoles <*> (pColon *> pTerm) -- the expression of the interface object <*> pMaybe pCruds -- The Crud-string (will later be tested, that it can contain only characters crud (upper/lower case) <*> pMaybe (pChevrons $ asText pConid) -- The view that should be used for this object @@ -474,29 +483,29 @@ pInterface = lbl <$> currPos --- SubInterface ::= 'BOX' BoxHeader? Box | 'LINKTO'? 'INTERFACE' ADLid pSubInterface :: AmpParser P_SubInterface pSubInterface = P_Box <$> currPos <*> pBoxHeader <*> pBox - <|> P_InterfaceRef <$> currPos - <*> pIsThere (pKey "LINKTO") <* pInterfaceKey + <|> P_InterfaceRef <$> currPos + <*> pIsThere (pKey "LINKTO") <* pInterfaceKey <*> pADLid where pBoxHeader :: AmpParser BoxHeader - pBoxHeader = + pBoxHeader = build <$> currPos <* pKey "BOX" <*> optional pBoxSpecification build :: Origin -> Maybe (Text, [TemplateKeyValue]) -> BoxHeader build o x = BoxHeader o typ keys - where (typ,keys) = case x of - Nothing -> ("FORM",[]) - Just (boxtype, atts) -> (boxtype,atts) + where (typ,keys) = case x of + Nothing -> ("FORM",[]) + Just (boxtype, atts) -> (boxtype,atts) pBoxSpecification :: AmpParser (Text, [TemplateKeyValue]) pBoxSpecification = pChevrons $ (,) <$> asText (pVarid <|> pConid <|> anyKeyWord) <*> many pTemplateKeyValue - + anyKeyWord :: AmpParser String anyKeyWord = case map pKey keywords of [] -> fatal "We should have keywords. We always have." h:tl -> foldr (<|>) h tl pTemplateKeyValue :: AmpParser TemplateKeyValue - pTemplateKeyValue = - TemplateKeyValue + pTemplateKeyValue = + TemplateKeyValue <$> currPos <*> asText (pVarid <|> pConid <|> anyKeyWord) <*> optional (id <$ pOperator "=" <*> asText pDoubleQuotedString) @@ -506,13 +515,13 @@ pSubInterface = P_Box <$> currPos <*> pBoxHeader <*> pBox pObjDef :: AmpParser P_BoxItemTermPrim pObjDef = pBoxItem <$> currPos <*> pLabel - <*> (pObj <|> pTxt) + <*> (pObj <|> pTxt) where --build p lable fun = pBoxItem p lable <$> fun pBoxItem :: Origin -> Text -> P_BoxItemTermPrim -> P_BoxItemTermPrim pBoxItem p nm fun = fun{ pos = p , obj_nm = nm} - + pObj :: AmpParser P_BoxItemTermPrim pObj = obj <$> pTerm -- the context expression (for example: I[c]) <*> pMaybe pCruds @@ -529,7 +538,7 @@ pObjDef = pBoxItem <$> currPos pTxt :: AmpParser P_BoxItemTermPrim pTxt = obj <$ pKey "TXT" <*> asText pDoubleQuotedString - where obj txt = + 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 @@ -705,10 +714,10 @@ pRelationRef = PNamedR <$> pNamedRel pfull orig (Just (P_Sign src trg)) = Pfull orig src trg pSingleton :: AmpParser PAtomValue -pSingleton = value2PAtomValue <$> currPos <*> +pSingleton = value2PAtomValue <$> currPos <*> ( pAtomValInPopulation True <|> pBraces (pAtomValInPopulation False) - ) + ) pAtomValue :: AmpParser PAtomValue pAtomValue = value2PAtomValue <$> currPos <*> pAtomValInPopulation False diff --git a/src/Ampersand/Input/Xslx/XLSX.hs b/src/Ampersand/Input/Xslx/XLSX.hs index 54a1c2fbfa..5a90b32172 100644 --- a/src/Ampersand/Input/Xslx/XLSX.hs +++ b/src/Ampersand/Input/Xslx/XLSX.hs @@ -116,7 +116,7 @@ addRelations pCtx = enrichedContext = L.unzip [ ( headrel{ dec_sign = P_Sign g (targt (NE.head sRel)) , dec_prps = let test prop = prop `elem` foldr Set.intersection Set.empty (fmap dec_prps sRel) - in Set.fromList ([P_Uni |test P_Uni]<>[P_Tot |test P_Tot]<>[P_Inj |test P_Inj]<>[P_Sur |test P_Sur]) + in Set.fromList $ filter (not . test) [P_Uni,P_Tot Nothing,P_Inj,P_Sur Nothing] } -- the generic relation that summarizes sRel -- , [ rel| rel<-sRel, sourc rel `elem` specs ] -- the specific (and therefore obsolete) relations , [ rel| rel<-NE.toList sRel, sourc rel `notElem` specs ] -- the remaining relations diff --git a/src/Ampersand/Test/Parser/ArbitraryTree.hs b/src/Ampersand/Test/Parser/ArbitraryTree.hs index 8b9088134f..319309ffed 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, isSafeIdChar ) +import Ampersand.Input.ADL1.Lexer ( keywords, isSafeIdChar ) import RIO.Char import qualified RIO.List as L import qualified RIO.NonEmpty as NE @@ -46,7 +46,7 @@ identifier = (T.cons <$> firstChar <*> (T.pack <$> listOf restChar)) firstChar :: Gen Char firstChar = arbitrary `suchThat` isAscii `suchThat` isSafeIdChar True restChar :: Gen Char - restChar = arbitrary `suchThat` isAscii `suchThat` isSafeIdChar False + restChar = arbitrary `suchThat` isAscii `suchThat` isSafeIdChar False noKeyword :: Text -> Bool @@ -87,21 +87,21 @@ makeObj isTxtAllowed genPrim ifcGen genView n = 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 $ makeObj True arbitrary genIfc (pure Nothing) subIfc :: (Int -> Gen (P_BoxItem a)) -> Int -> Gen (P_SubIfc a) -subIfc objGen n +subIfc objGen n | n == 0 = P_InterfaceRef <$> arbitrary <*> arbitrary <*> identifier | otherwise = P_Box <$> arbitrary <*> arbitrary <*> vectorOf n (objGen$ n`div`2) instance Arbitrary BoxHeader where arbitrary = BoxHeader <$> arbitrary <*> pure "BOX" <*> listOf arbitrary - + instance Arbitrary TemplateKeyValue where - arbitrary = TemplateKeyValue - <$> arbitrary + arbitrary = TemplateKeyValue + <$> arbitrary <*> identifier `suchThat` startsWithLetter <*> liftArbitrary safeStr1 where startsWithLetter :: Text -> Bool @@ -134,7 +134,7 @@ instance Arbitrary P_RoleRule where arbitrary = Maintain <$> arbitrary <*> arbitrary <*> listOf1 identifier instance Arbitrary Representation where - arbitrary = Repr <$> arbitrary + arbitrary = Repr <$> arbitrary <*> arbitrary `suchThat` noOne <*> arbitrary @@ -153,7 +153,7 @@ instance Arbitrary P_Pattern where <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary P_Relation where - arbitrary = P_Relation + arbitrary = P_Relation <$> lowerId <*> arbitrary <*> arbitrary @@ -203,7 +203,7 @@ genTerm lv n = if n == 0 Prim <$> arbitrary]] instance Arbitrary TermPrim where - arbitrary = oneof + arbitrary = oneof [ PI <$> arbitrary , Pid <$> arbitrary <*> arbitrary , Patm <$> arbitrary <*> arbitrary <*> arbitrary @@ -214,9 +214,9 @@ instance Arbitrary TermPrim where instance Arbitrary a => Arbitrary (PairView (Term a)) where arbitrary = PairView <$> arbitrary - + instance Arbitrary a => Arbitrary (PairViewSegment (Term a)) where - arbitrary = oneof + arbitrary = oneof [ PairViewText <$> arbitrary <*> safeStr , PairViewExp <$> arbitrary <*> arbitrary <*> sized(genTerm 1) -- only accepts pTerm, no pRule. ] @@ -231,7 +231,7 @@ instance Arbitrary SrcOrTgt where arbitrary = elements [minBound..] instance Arbitrary a => Arbitrary (P_Rule a) where - arbitrary = P_Rule + arbitrary = P_Rule <$> arbitrary <*> identifier <*> sized (genTerm 0) -- rule is a term level 0 @@ -240,32 +240,32 @@ instance Arbitrary a => Arbitrary (P_Rule a) where <*> arbitrary instance Arbitrary (P_Enforce TermPrim) where - arbitrary = P_Enforce <$> arbitrary + arbitrary = P_Enforce <$> arbitrary <*> arbitrary `suchThat` isNamedRelation <*> arbitrary <*> arbitrary `suchThat` (not . isForRulesOnly) - where isForRulesOnly :: Term TermPrim -> Bool + where isForRulesOnly :: Term TermPrim -> Bool isForRulesOnly PEqu{} = True isForRulesOnly PInc{} = True isForRulesOnly _ = False isNamedRelation :: TermPrim -> Bool - isNamedRelation PNamedR{} = True + isNamedRelation PNamedR{} = True isNamedRelation _ = False instance Arbitrary EnforceOperator where - arbitrary = oneof + arbitrary = oneof [ IsSuperSet <$> arbitrary , IsSubSet <$> arbitrary , IsSameSet <$> arbitrary ] - + instance Arbitrary PConceptDef where arbitrary = PConceptDef <$> arbitrary <*> identifier <*> arbitrary <*> arbitrary <*> identifier instance Arbitrary PCDDef where - arbitrary = oneof + arbitrary = oneof [ PCDDefLegacy <$> safeStr <*> safeStr , PCDDefNew <$> arbitrary ] @@ -273,14 +273,14 @@ instance Arbitrary PAtomPair where arbitrary = PPair <$> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary P_Population where - arbitrary = oneof - [ P_RelPopu + arbitrary = oneof + [ P_RelPopu <$> arbitrary `suchThat` noOne <*> arbitrary `suchThat` noOne <*> arbitrary <*> arbitrary <*> arbitrary - , P_CptPopu + , P_CptPopu <$> arbitrary <*> arbitrary `suchThat` notIsOne <*> arbitrary @@ -316,7 +316,7 @@ instance Arbitrary a => Arbitrary (P_SubIfc a) where arbitrary = sized genIfc instance Arbitrary P_IdentDef where - arbitrary = P_Id <$> arbitrary + arbitrary = P_Id <$> arbitrary <*> identifier <*> arbitrary `suchThat` notIsOne <*> arbitrary @@ -332,7 +332,7 @@ instance Arbitrary ViewHtmlTemplate where arbitrary = ViewHtmlTemplateFile <$> safeFilePath instance Arbitrary a => Arbitrary (P_ViewSegment a) where - arbitrary = P_ViewSegment <$> (Just <$> identifier) <*> 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. @@ -362,7 +362,7 @@ instance Arbitrary PMessage where arbitrary = PMessage <$> arbitrary instance Arbitrary P_Concept where - arbitrary = frequency + arbitrary = frequency [ (100, PCpt <$> upperId) , ( 1, pure P_ONE) ] @@ -371,17 +371,17 @@ instance Arbitrary P_Sign where arbitrary = P_Sign <$> arbitrary <*> arbitrary instance Arbitrary PClassify where - arbitrary = PClassify - <$> arbitrary + arbitrary = PClassify + <$> arbitrary <*> arbitrary `suchThat` notIsOne <*> arbitrary `suchThat` noOne - + instance Arbitrary Lang where arbitrary = elements [minBound..] instance Arbitrary P_Markup where arbitrary = P_Markup <$> arbitrary <*> arbitrary <*> safeStr `suchThat` noEndMarkup - where + where noEndMarkup :: Text -> Bool noEndMarkup = not . T.isInfixOf "+}" @@ -389,10 +389,18 @@ instance Arbitrary PandocFormat where arbitrary = elements [minBound..] instance Arbitrary PProp where - arbitrary = elements [minBound..] - + arbitrary = oneof [ elements [ P_Uni, P_Inj + , P_Sym, P_Asy, P_Trn, P_Rfx, P_Irf, P_Prop + ] + , P_Tot <$> arbitrary + , P_Sur <$> arbitrary + ] +instance Arbitrary PPropDefault where + arbitrary = oneof [ PDefAtom <$> arbitrary + , PDefEvalPHP <$> arbitrary + ] noOne :: Foldable t => t P_Concept -> Bool noOne = all notIsOne notIsOne :: P_Concept -> Bool -notIsOne = (P_ONE /= ) +notIsOne = (P_ONE /= ) From 69c0891aa8f0fbe64aa111286725091e6f3a4a60 Mon Sep 17 00:00:00 2001 From: hanjoosten Date: Wed, 8 Sep 2021 21:14:05 +0200 Subject: [PATCH 05/11] remove obsolete decprps_calc --- src/Ampersand/ADL1/P2A_Converters.hs | 1 - src/Ampersand/Classes/Relational.hs | 2 +- src/Ampersand/Classes/ViewPoint.hs | 5 ++--- src/Ampersand/Core/AbstractSyntaxTree.hs | 2 -- src/Ampersand/FSpec/ShowHS.hs | 3 --- src/Ampersand/FSpec/ToFSpec/NormalForms.hs | 2 -- 6 files changed, 3 insertions(+), 12 deletions(-) diff --git a/src/Ampersand/ADL1/P2A_Converters.hs b/src/Ampersand/ADL1/P2A_Converters.hs index 598d4d184e..54d3be16a5 100644 --- a/src/Ampersand/ADL1/P2A_Converters.hs +++ b/src/Ampersand/ADL1/P2A_Converters.hs @@ -1112,7 +1112,6 @@ pDecl2aDecl typ cptMap maybePatName defLanguage defFormat pd { decnm = dec_nm pd , decsgn = decSign , decprps = Set.fromList . concat $ propLists - , decprps_calc = Nothing --decprps_calc in an A_Context are still the user-defined only. prps are calculated in adl2fspec. , decprL = prL , decprM = prM , decprR = prR diff --git a/src/Ampersand/Classes/Relational.hs b/src/Ampersand/Classes/Relational.hs index c1717aef9e..a3504aa495 100644 --- a/src/Ampersand/Classes/Relational.hs +++ b/src/Ampersand/Classes/Relational.hs @@ -30,7 +30,7 @@ class Relational r where isEpsilon :: r -> Bool -- > tells whether the argument is equivalent to I instance HasProps Relation where - properties d = fromMaybe (decprps d) (decprps_calc d) + properties = decprps -- | Is the concept the ONE and only? (universal singleton) isONE :: A_Concept -> Bool diff --git a/src/Ampersand/Classes/ViewPoint.hs b/src/Ampersand/Classes/ViewPoint.hs index d85f32943c..055a23c410 100644 --- a/src/Ampersand/Classes/ViewPoint.hs +++ b/src/Ampersand/Classes/ViewPoint.hs @@ -86,14 +86,13 @@ instance Language A_Context where `Set.union` ctxds context) where -- relations with the same name, but different properties (decprps,pragma,etc.) may exist and need to be united - -- decprps and decprps_calc are united, all others are taken from the head. + -- decprps are united, all others are taken from the head. uniteRels :: Relations -> Relations uniteRels ds = Set.fromList . map fun . eqClass (==) $ Set.elems ds where fun :: NE.NonEmpty Relation -> Relation fun rels = (NE.head rels) {decprps = Set.unions . fmap decprps $ rels - ,decprps_calc = Nothing -- Calculation is only done in ADL2Fspc. - } + } udefrules context = (Set.unions . map udefrules $ ctxpats context) `Set.union` ctxrs context identities context = concatMap identities (ctxpats context) <> ctxks context viewDefs context = concatMap viewDefs (ctxpats context) <> ctxvs context diff --git a/src/Ampersand/Core/AbstractSyntaxTree.hs b/src/Ampersand/Core/AbstractSyntaxTree.hs index 41eddc1ddd..98c6130d42 100644 --- a/src/Ampersand/Core/AbstractSyntaxTree.hs +++ b/src/Ampersand/Core/AbstractSyntaxTree.hs @@ -300,9 +300,7 @@ type Relations = Set.Set Relation data Relation = Relation { decnm :: Text -- ^ the name of the relation , decsgn :: Signature -- ^ the source and target concepts of the relation - --properties returns decprps_calc, when it has been calculated. So if you only need the user defined properties do not use 'properties' but 'decprps'. , decprps :: AProps -- ^ the user defined properties (Uni, Tot, Sur, Inj, Sym, Asy, Trn, Rfx, Irf) - , decprps_calc :: Maybe AProps -- ^ the calculated and user defined properties. Note that calculated properties are made by adl2fspec, so in the A-structure decprps and decprps_calc yield exactly the same answer. , decprL :: Text -- ^ three strings, which form the pragma. E.g. if pragma consists of the three strings: "Person ", " is married to person ", and " in Vegas." , decprM :: Text -- ^ then a tuple ("Peter","Jane") in the list of links means that Person Peter is married to person Jane in Vegas. , decprR :: Text diff --git a/src/Ampersand/FSpec/ShowHS.hs b/src/Ampersand/FSpec/ShowHS.hs index d80271cde8..2d87811d27 100644 --- a/src/Ampersand/FSpec/ShowHS.hs +++ b/src/Ampersand/FSpec/ShowHS.hs @@ -586,9 +586,6 @@ instance ShowHS Relation where ["Relation { decnm = " <> tshow (decnm d) ," , decsgn = " <> showHS env "" (sign d) ," , decprps = " <> showL(map (showHS env "") (Set.elems $ decprps d)) - ," , decprps_calc = " <> case decprps_calc d of - Nothing -> "Nothing" - Just ps -> "Just "<>showL(map (showHS env "") (Set.elems ps)) ," , decprL = " <> tshow (decprL d) ," , decprM = " <> tshow (decprM d) ," , decprR = " <> tshow (decprR d) diff --git a/src/Ampersand/FSpec/ToFSpec/NormalForms.hs b/src/Ampersand/FSpec/ToFSpec/NormalForms.hs index c875276a42..30ca7c3c4a 100644 --- a/src/Ampersand/FSpec/ToFSpec/NormalForms.hs +++ b/src/Ampersand/FSpec/ToFSpec/NormalForms.hs @@ -547,7 +547,6 @@ rTerm2expr term { decnm = nm , decsgn = sgn , decprps = fatal "Illegal RTerm in rTerm2expr" - , decprps_calc = Nothing , decprL = fatal "Illegal RTerm in rTerm2expr" , decprM = fatal "Illegal RTerm in rTerm2expr" , decprR = fatal "Illegal RTerm in rTerm2expr" @@ -1029,7 +1028,6 @@ delta sgn { decnm = T.pack "Delta" , decsgn = sgn , decprps = Set.empty - , decprps_calc = Nothing , decprL = "" , decprM = "" , decprR = "" From 5eee126a5c1f2541fe7cf25511a41946e31f1914 Mon Sep 17 00:00:00 2001 From: hanjoosten Date: Wed, 8 Sep 2021 21:35:19 +0200 Subject: [PATCH 06/11] Minor parser stuff --- src/Ampersand/Input/ADL1/Lexer.hs | 2 +- src/Ampersand/Input/ADL1/Parser.hs | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Ampersand/Input/ADL1/Lexer.hs b/src/Ampersand/Input/ADL1/Lexer.hs index e21a3d82d1..0885ceaf6f 100644 --- a/src/Ampersand/Input/ADL1/Lexer.hs +++ b/src/Ampersand/Input/ADL1/Lexer.hs @@ -48,7 +48,7 @@ keywords = L.nub $ , "CONCEPT" -- Keywords for Relation-statements , "RELATION", "PRAGMA", "MEANING" - , "ASY", "INJ", "IRF", "RFX", "SUR", "SYM", "TOT", "TRN", "UNI", "EVALPHP" + , "ASY", "INJ", "IRF", "RFX", "SUR", "SYM", "TOT", "TRN", "UNI", "PROP", "VALUE", "EVALPHP" , "POPULATION", "CONTAINS" -- Keywords for rules , "RULE", "MESSAGE", "VIOLATION", "TXT" diff --git a/src/Ampersand/Input/ADL1/Parser.hs b/src/Ampersand/Input/ADL1/Parser.hs index dc37793f3c..3f790352b7 100644 --- a/src/Ampersand/Input/ADL1/Parser.hs +++ b/src/Ampersand/Input/ADL1/Parser.hs @@ -291,13 +291,14 @@ pRelationOld = relOld <$> asText pVarid pProps :: AmpParser (Set.Set PProp) pProps = normalizeProps <$> pBrackets (pProp `sepBy` pComma) --- PropList ::= Prop (',' Prop)* - --- Prop ::= 'UNI' | 'INJ' | 'SUR' | 'TOT' | 'SYM' | 'ASY' | 'TRN' | 'RFX' | 'IRF' | 'PROP' + --- Prop ::= 'UNI' | 'INJ' | 'SUR' PropDefault? | 'TOT' PropDefault? | 'SYM' | 'ASY' | 'TRN' | 'RFX' | 'IRF' | 'PROP' where pProp :: AmpParser PProp pProp = choice $ [ p <$ pKey (show p) | p <- [P_Uni, P_Inj, P_Sym, P_Asy, P_Trn, P_Rfx, P_Irf, P_Prop] ] <> [ P_Tot <$ pKey "TOT" <*> pMaybe pPropDefault , P_Sur <$ pKey "SUR" <*> pMaybe pPropDefault] + --- PropDefault ::= 'VALUE' AtomValue | 'EVALPHP' DoubleQuotedString where pPropDefault :: AmpParser PPropDefault pPropDefault = choice [ PDefAtom <$ pKey "VALUE" <*> pAtomValue From 6be4b9788d7957e6a99eb84726eac40f7de8f8a3 Mon Sep 17 00:00:00 2001 From: hanjoosten Date: Wed, 8 Sep 2021 22:01:00 +0200 Subject: [PATCH 07/11] refactoring --- src/Ampersand/Classes/Relational.hs | 30 ++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/src/Ampersand/Classes/Relational.hs b/src/Ampersand/Classes/Relational.hs index a3504aa495..b63a6c64c7 100644 --- a/src/Ampersand/Classes/Relational.hs +++ b/src/Ampersand/Classes/Relational.hs @@ -45,8 +45,8 @@ isSESSION cpt = -- but tries to derive the most obvious constraints as well. The more property constraints are known, -- the better the data structure that is derived. -- Not every constraint that can be proven is obtained by this function. This does not hurt Ampersand. -properties' :: Expression -> AProps -properties' expr = case expr of +instance HasProps Expression where + properties expr = case expr of EDcD dcl -> properties dcl EDcI{} -> Set.fromList [Uni,Tot Nothing,Inj,Sur Nothing,Sym,Asy,Trn,Rfx] EEps a sgn -> Set.fromList $ [Tot Nothing| a == source sgn]++[Sur Nothing | a == target sgn] ++ [Uni,Inj] @@ -59,13 +59,13 @@ properties' expr = case expr of ++[Sym | isEndo sgn] ++[Rfx | isEndo sgn] ++[Trn | isEndo sgn] - EBrk f -> properties' f - ECps (l,r) -> Set.filter (\x->x `elem` [Uni,Tot Nothing,Inj,Sur Nothing]) (properties' l `Set.intersection` properties' r) + EBrk f -> properties f + ECps (l,r) -> Set.filter (\x->x `elem` [Uni,Tot Nothing,Inj,Sur Nothing]) (properties l `Set.intersection` properties r) EPrd (l,r) -> Set.fromList $ [Tot Nothing | isTot l]++[Sur Nothing | isSur r]++[Rfx | isRfx l&&isRfx r]++[Trn] - EKl0 e' -> Set.fromList [Rfx,Trn] `Set.union` (properties' e' Set.\\ Set.fromList [Uni,Inj]) - EKl1 e' -> Set.singleton Trn `Set.union` (properties' e' Set.\\ Set.fromList [Uni,Inj]) - ECpl e' -> Set.singleton Sym `Set.intersection` properties' e' - EFlp e' -> Set.map flp $ properties' e' + EKl0 e' -> Set.fromList [Rfx,Trn] `Set.union` (properties e' Set.\\ Set.fromList [Uni,Inj]) + EKl1 e' -> Set.singleton Trn `Set.union` (properties e' Set.\\ Set.fromList [Uni,Inj]) + ECpl e' -> Set.singleton Sym `Set.intersection` properties e' + EFlp e' -> Set.map flp $ properties e' EMp1{} -> Set.fromList [Uni,Inj,Sym,Asy,Trn] _ -> Set.empty @@ -169,11 +169,11 @@ instance Relational Expression where -- TODO: see if we can find more pro isUni = isUniInj Uni isInj = isUniInj Inj - isRfx r = Rfx `elem` properties' r - isIrf r = Irf `elem` properties' r - isTrn r = Trn `elem` properties' r - isSym r = Sym `elem` properties' r - isAsy r = Asy `elem` properties' r + isRfx r = Rfx `elem` properties r + isIrf r = Irf `elem` properties r + isTrn r = Trn `elem` properties r + isSym r = Sym `elem` properties r + isAsy r = Asy `elem` properties r -- Not to be exported: isTotSur :: AProp -> Expression -> Bool @@ -204,7 +204,7 @@ isTotSur prop expr EBrk e -> isTotSur prop e EMp1{} -> True where - todo = prop `elem` properties' expr + todo = prop `elem` properties expr isUniInj :: AProp -> Expression -> Bool isUniInj prop expr @@ -231,4 +231,4 @@ isUniInj prop expr EBrk e -> isUniInj prop e EMp1{} -> True where - todo = prop `elem` properties' expr + todo = prop `elem` properties expr From 994d7be2a1899b176c2b3f0db1e162b7b4b34e34 Mon Sep 17 00:00:00 2001 From: hanjoosten Date: Wed, 8 Sep 2021 22:30:59 +0200 Subject: [PATCH 08/11] fix Pretty PProp --- src/Ampersand/ADL1/PrettyPrinters.hs | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/src/Ampersand/ADL1/PrettyPrinters.hs b/src/Ampersand/ADL1/PrettyPrinters.hs index 0e0a22eff2..0e7a6b1a68 100644 --- a/src/Ampersand/ADL1/PrettyPrinters.hs +++ b/src/Ampersand/ADL1/PrettyPrinters.hs @@ -9,7 +9,6 @@ import Ampersand.Basics hiding ((<$>),view) import Ampersand.Core.ParseTree import Ampersand.Input.ADL1.Lexer(keywords) import RIO.Char (toUpper) -import qualified RIO.List as L import qualified RIO.NonEmpty as NE import qualified RIO.Text as T import qualified RIO.Text.Partial as Partial(replace) @@ -139,7 +138,7 @@ instance Pretty P_Relation where pretty (P_Relation nm sign prps pragma mean _) = text "RELATION" <+> (text . T.unpack) nm <~> sign <+> props <+\> pragmas <+\> prettyhsep mean where props | null prps = empty - | otherwise = text ("["++(L.intercalate ",". map show) (Set.toList prps) ++ "]") -- do not prettyprint list of properties. + | otherwise = pretty $ Set.toList prps pragmas | T.null (T.concat pragma) = empty | otherwise = text "PRAGMA" <+> hsep (map quote pragma) @@ -377,8 +376,19 @@ instance Pretty PandocFormat where pretty = text . map toUpper . show instance Pretty PProp where - pretty = text . map toUpper . show - + pretty p = case p of + P_Sur m_ppd -> text "SUR" <> doShow m_ppd + P_Tot m_ppd -> text "SUR" <> doShow m_ppd + _ -> text . map toUpper . show $ p + where + doShow :: Maybe PPropDefault -> Doc + doShow x = case x of + Nothing -> mempty + Just ppd -> text " "<+> pretty ppd +instance Pretty PPropDefault where + pretty x = case x of + PDefAtom pav -> text "VALUE "<+>pretty pav + PDefEvalPHP txt -> text "EVALPHP" <+> text (show txt) instance Pretty PAtomPair where pretty (PPair _ l r) = text "(" <+> pretty l <~> text "," <+> pretty r From 1538cdef9f3e4344aa87c99da7d0c556f0f17eaa Mon Sep 17 00:00:00 2001 From: hanjoosten Date: Wed, 8 Sep 2021 22:50:14 +0200 Subject: [PATCH 09/11] bugfix roundtrip --- src/Ampersand/ADL1/PrettyPrinters.hs | 2 +- src/Ampersand/Test/Parser/ArbitraryTree.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Ampersand/ADL1/PrettyPrinters.hs b/src/Ampersand/ADL1/PrettyPrinters.hs index 0e7a6b1a68..6043cf5c14 100644 --- a/src/Ampersand/ADL1/PrettyPrinters.hs +++ b/src/Ampersand/ADL1/PrettyPrinters.hs @@ -388,7 +388,7 @@ instance Pretty PProp where instance Pretty PPropDefault where pretty x = case x of PDefAtom pav -> text "VALUE "<+>pretty pav - PDefEvalPHP txt -> text "EVALPHP" <+> text (show txt) + PDefEvalPHP txt -> text "EVALPHP " <+> text (show txt) instance Pretty PAtomPair where pretty (PPair _ l r) = text "(" <+> pretty l <~> text "," <+> pretty r diff --git a/src/Ampersand/Test/Parser/ArbitraryTree.hs b/src/Ampersand/Test/Parser/ArbitraryTree.hs index 319309ffed..0b285f0baa 100644 --- a/src/Ampersand/Test/Parser/ArbitraryTree.hs +++ b/src/Ampersand/Test/Parser/ArbitraryTree.hs @@ -397,7 +397,7 @@ instance Arbitrary PProp where ] instance Arbitrary PPropDefault where arbitrary = oneof [ PDefAtom <$> arbitrary - , PDefEvalPHP <$> arbitrary + , PDefEvalPHP <$> safeStr ] noOne :: Foldable t => t P_Concept -> Bool From 5bcbcb0c97dcdefc1beb01b550cef5822c385db9 Mon Sep 17 00:00:00 2001 From: hanjoosten Date: Thu, 9 Sep 2021 00:23:01 +0200 Subject: [PATCH 10/11] Add defaultSrc and defaultTgt to relations.json --- src/Ampersand/Output/ToJSON/Relations.hs | 22 +++++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) diff --git a/src/Ampersand/Output/ToJSON/Relations.hs b/src/Ampersand/Output/ToJSON/Relations.hs index d09d688825..6853e9d5e8 100644 --- a/src/Ampersand/Output/ToJSON/Relations.hs +++ b/src/Ampersand/Output/ToJSON/Relations.hs @@ -7,6 +7,7 @@ where import Ampersand.ADL1 import Ampersand.FSpec.FSpecAux import Ampersand.Output.ToJSON.JSONutils +import qualified RIO.List as L import qualified RIO.Set as Set newtype Relationz = Relationz [RelationJson]deriving (Generic, Show) @@ -22,6 +23,8 @@ data RelationJson = RelationJson , relJSONprop :: Bool , relJSONaffectedConjuncts :: [Text] , relJSONmysqlTable :: RelTableInfo + , relJSONdefaultSrc :: Maybe Text + , relJSONdefaultTgt :: Maybe Text } deriving (Generic, Show) data RelTableInfo = RelTableInfo -- Contains info about where the relation is implemented in SQL { rtiJSONname :: Text @@ -57,9 +60,26 @@ instance JSON Relation RelationJson where , relJSONprop = isProp bindedExp , relJSONaffectedConjuncts = maybe [] (map rc_id) . lookup dcl . allConjsPerDecl $ fSpec , relJSONmysqlTable = fromAmpersand env fSpec dcl + , relJSONdefaultSrc = case L.nub [p | p@Sur {} <- Set.toList $ properties dcl] of + [] -> Nothing + [Sur Nothing] -> Nothing + [Sur (Just d)] -> Just $ toText d + [_] -> fatal "Nothing else than `Sur` is expected here!" + ps -> fatal $ "Multiple instances of Sur should have been prevented by the typechecker\n" + <>" "<>tshow ps + , relJSONdefaultTgt = case L.nub [p | p@Tot {} <- Set.toList $ properties dcl] of + [] -> Nothing + [Tot Nothing] -> Nothing + [Tot (Just d)] -> Just $ toText d + [_] -> fatal "Nothing else than `Tot` is expected here!" + ps -> fatal $ "Multiple instances of Tot should have been prevented by the typechecker\n" + <>" "<>tshow ps } where bindedExp = EDcD dcl - + toText :: APropDefault -> Text + toText d = case d of + ADefAtom aav -> tshow aav + ADefEvalPHP txt -> "{EX}{php}"<>txt instance JSON Relation RelTableInfo where fromAmpersand env fSpec dcl = RelTableInfo { rtiJSONname = name plug From 9126a76e7482626f02b41ca0b5781b611c2be052 Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Fri, 10 Sep 2021 13:47:05 +0200 Subject: [PATCH 11/11] Change output for default value for eval php from {EX}{php} to {php} ExecEngine is not playing a role here --- src/Ampersand/Output/ToJSON/Relations.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Ampersand/Output/ToJSON/Relations.hs b/src/Ampersand/Output/ToJSON/Relations.hs index 6853e9d5e8..3dea82d01d 100644 --- a/src/Ampersand/Output/ToJSON/Relations.hs +++ b/src/Ampersand/Output/ToJSON/Relations.hs @@ -79,7 +79,7 @@ instance JSON Relation RelationJson where toText :: APropDefault -> Text toText d = case d of ADefAtom aav -> tshow aav - ADefEvalPHP txt -> "{EX}{php}"<>txt + ADefEvalPHP txt -> "{php}"<>txt instance JSON Relation RelTableInfo where fromAmpersand env fSpec dcl = RelTableInfo { rtiJSONname = name plug