From 9753638606a0042301bf71ffb490f48bffaa207d Mon Sep 17 00:00:00 2001 From: hanjoosten Date: Thu, 21 Oct 2021 22:19:36 +0200 Subject: [PATCH 01/15] Releasenotes --- ReleaseNotes.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ReleaseNotes.md b/ReleaseNotes.md index dd96ee6e52..7febedbcac 100644 --- a/ReleaseNotes.md +++ b/ReleaseNotes.md @@ -2,6 +2,8 @@ ## Unreleased changes +* [Issue #1189](https://github.com/AmpersandTarski/Ampersand/issues/1189) Replace the previous solution. Now the defaults can be given in the `RELATION` statement. + ## v4.4.3 (17 October 2021) New CI workflow for releases to be pushed automatically to DockerHub with semver. Image is needed by prototype framework in Docker build. From cc54b907d0526b6c4a2d0d886dbb37c4b59aaa5a Mon Sep 17 00:00:00 2001 From: hanjoosten Date: Thu, 21 Oct 2021 22:11:59 +0200 Subject: [PATCH 02/15] temporarily disable weeder, for it doesn't build correctly. --- .github/workflows/ci2.yml | 2 +- .github/workflows/release.yml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/ci2.yml b/.github/workflows/ci2.yml index 3c76f74b3f..9b67ebda0e 100644 --- a/.github/workflows/ci2.yml +++ b/.github/workflows/ci2.yml @@ -38,7 +38,7 @@ jobs: uses: freckle/stack-action@main # stack-action does all these steps: dependencies, build, test. with: stack-arguments: '--copy-bins --flag ampersand:buildAll' - weeder: true + weeder: false # TODO: Re-enable. See https://github.com/AmpersandTarski/Ampersand/issues/1225 hlint: true build-and-test-macOS: diff --git a/.github/workflows/release.yml b/.github/workflows/release.yml index 9bcc190384..08da6ee97c 100644 --- a/.github/workflows/release.yml +++ b/.github/workflows/release.yml @@ -141,7 +141,7 @@ jobs: uses: freckle/stack-action@main # stack-action does all these steps: dependencies, build, test. with: stack-arguments: '--copy-bins --flag ampersand:buildAll' - weeder: true + weeder: false # TODO: Re-enable. See https://github.com/AmpersandTarski/Ampersand/issues/1225 hlint: true - name: Upload artifacts (Linux) From bfe5b5d3725c89460d75eebce0f38f73db5a5dda Mon Sep 17 00:00:00 2001 From: hanjoosten Date: Sat, 23 Oct 2021 19:02:56 +0200 Subject: [PATCH 03/15] Move defaults from props to relation --- src/Ampersand/ADL1.hs | 4 +- src/Ampersand/ADL1/P2A_Converters.hs | 44 ++++----- src/Ampersand/ADL1/PrettyPrinters.hs | 22 ++--- src/Ampersand/ADL1/Rule.hs | 20 ++-- src/Ampersand/Classes/Relational.hs | 38 ++++---- src/Ampersand/Core/A2P_Converters.hs | 17 ++-- src/Ampersand/Core/AbstractSyntaxTree.hs | 49 +++++----- src/Ampersand/Core/ParseTree.hs | 33 ++++--- src/Ampersand/FSpec/ShowHS.hs | 13 +-- src/Ampersand/FSpec/ShowMeatGrinder.hs | 1 + src/Ampersand/FSpec/ToFSpec/NormalForms.hs | 1 + src/Ampersand/FSpec/Transformers.hs | 102 ++++++++++----------- src/Ampersand/Input/ADL1/Parser.hs | 41 +++++---- src/Ampersand/Input/Archi/ArchiAnalyze.hs | 2 +- src/Ampersand/Input/Xslx/XLSX.hs | 3 +- src/Ampersand/Output/ToJSON/Relations.hs | 11 +-- src/Ampersand/Test/Parser/ArbitraryTree.hs | 15 ++- 17 files changed, 206 insertions(+), 210 deletions(-) diff --git a/src/Ampersand/ADL1.hs b/src/Ampersand/ADL1.hs index 1c0e3424c1..47731cfcf1 100644 --- a/src/Ampersand/ADL1.hs +++ b/src/Ampersand/ADL1.hs @@ -20,7 +20,7 @@ import Ampersand.Core.ParseTree ( , SrcOrTgt(..) , P_Rule(..),Role(..) , PProp(..) - , PPropDefault(..) + , PRelationDefault(..) , P_IdentDef, P_IdentSegment,P_IdentDf(..),P_IdentSegmnt(..) , P_ViewDef, P_ViewSegment(..),P_ViewSegmtPayLoad(..),P_ViewD(..),ViewHtmlTemplate(..) , P_Population(..),PAtomPair(..) @@ -56,7 +56,7 @@ import Ampersand.Core.AbstractSyntaxTree ( , Pattern(..) , Relation(..), Relations, getExpressionRelation, showRel , AProp(..), AProps - , APropDefault(..) + , ARelDefault(..), ARelDefaults , 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 54d3be16a5..730efc66d0 100644 --- a/src/Ampersand/ADL1/P2A_Converters.hs +++ b/src/Ampersand/ADL1/P2A_Converters.hs @@ -1107,11 +1107,13 @@ pDecl2aDecl :: -> P_Relation -> Guarded Relation pDecl2aDecl typ cptMap maybePatName defLanguage defFormat pd = do checkEndoProps - propLists <- mapM pProp2aProps . Set.toList $ dec_prps pd + --propLists <- mapM pProp2aProps . Set.toList $ dec_prps pd + dflts <- mapM pReldefault2aReldefaults . L.nub $ dec_defaults pd return Relation { decnm = dec_nm pd , decsgn = decSign - , decprps = Set.fromList . concat $ propLists + , decprps = Set.fromList . concatMap pProp2aProps . Set.toList $ dec_prps pd + , decDefaults = Set.fromList dflts , decprL = prL , decprM = prM , decprR = prR @@ -1123,28 +1125,26 @@ pDecl2aDecl typ cptMap maybePatName defLanguage defFormat pd } where + pReldefault2aReldefaults :: PRelationDefault -> Guarded ARelDefault + pReldefault2aReldefaults x = case x of + PDefAtom st val -> ARelDefaultAtom st <$> + pAtomValue2aAtomValue typ (case st of + Src -> source decSign + Tgt -> target decSign) val + PDefEvalPHP st txt -> pure $ ARelDefaultEvalPHP st txt (prL:prM:prR:_) = dec_pragma pd <> ["", "", ""] - pProp2aProps :: PProp -> Guarded [AProp] + pProp2aProps :: PProp -> [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 + 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 () diff --git a/src/Ampersand/ADL1/PrettyPrinters.hs b/src/Ampersand/ADL1/PrettyPrinters.hs index 6043cf5c14..f4bbb682b5 100644 --- a/src/Ampersand/ADL1/PrettyPrinters.hs +++ b/src/Ampersand/ADL1/PrettyPrinters.hs @@ -135,10 +135,12 @@ instance Pretty P_Pattern where <+\> text "ENDPATTERN" instance Pretty P_Relation where - pretty (P_Relation nm sign prps pragma mean _) = - text "RELATION" <+> (text . T.unpack) nm <~> sign <+> props <+\> pragmas <+\> prettyhsep mean + pretty (P_Relation nm sign prps dflts pragma mean _) = + text "RELATION" <+> (text . T.unpack) nm <~> sign <+> props <+\> defaults <+\> pragmas <+\> prettyhsep mean where props | null prps = empty | otherwise = pretty $ Set.toList prps + defaults | null dflts = empty + | otherwise = pretty dflts pragmas | T.null (T.concat pragma) = empty | otherwise = text "PRAGMA" <+> hsep (map quote pragma) @@ -377,18 +379,14 @@ instance Pretty PandocFormat where instance Pretty PProp where pretty p = case p of - P_Sur m_ppd -> text "SUR" <> doShow m_ppd - P_Tot m_ppd -> text "SUR" <> doShow m_ppd + P_Sur -> text "SUR" + P_Tot -> text "SUR" _ -> 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 + +instance Pretty PRelationDefault where pretty x = case x of - PDefAtom pav -> text "VALUE "<+>pretty pav - PDefEvalPHP txt -> text "EVALPHP " <+> text (show txt) + PDefAtom sOrT pav -> pretty sOrT<+>text "VALUE "<+>pretty pav + PDefEvalPHP sOrT txt -> pretty sOrT<+>text "EVALPHP " <+> text (show txt) instance Pretty PAtomPair where pretty (PPair _ l r) = text "(" <+> pretty l <~> text "," <+> pretty r diff --git a/src/Ampersand/ADL1/Rule.hs b/src/Ampersand/ADL1/Rule.hs index ca3dff0ee1..3b9110eb6d 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 b63a6c64c7..bf578fd3c4 100644 --- a/src/Ampersand/Classes/Relational.hs +++ b/src/Ampersand/Classes/Relational.hs @@ -37,10 +37,10 @@ isONE :: A_Concept -> Bool isONE ONE = True isONE _ = False isSESSION :: A_Concept -> Bool -isSESSION cpt = +isSESSION cpt = case cpt of PlainConcept{} -> "SESSION" `elem` aliases cpt - ONE -> False + ONE -> False -- The function "properties" does not only provide the properties provided by the Ampersand user, -- but tries to derive the most obvious constraints as well. The more property constraints are known, -- the better the data structure that is derived. @@ -48,9 +48,9 @@ isSESSION cpt = 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] - EDcV sgn -> Set.fromList $ + 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] + EDcV sgn -> Set.fromList $ --NOT totaal --NOT surjective [Inj | isONE (source sgn)] @@ -60,8 +60,8 @@ instance HasProps Expression where ++[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) - EPrd (l,r) -> Set.fromList $ [Tot Nothing | isTot l]++[Sur Nothing | isSur r]++[Rfx | isRfx l&&isRfx r]++[Trn] + 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] 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' @@ -122,7 +122,7 @@ instance Relational Expression where -- TODO: see if we can find more pro -- | The function isIdent tries to establish whether an expression is an identity relation. -- If it returns False, this must be interpreted as: the expression is definitely not I, an may not be equal to I as far as the computer can tell on face value. - isIdent expr = (\x -> if x && (source expr /= target expr) + isIdent expr = (\x -> if x && (source expr /= target expr) then fatal $ "Something wrong with isIdent." <> tshow expr else x ) $ @@ -162,13 +162,13 @@ instance Relational Expression where -- TODO: see if we can find more pro EFlp f -> isImin f _ -> False -- TODO: find richer answers for ELrs, ERrs, and EDia isFunction r = isUni r && isTot r - - isTot = isTotSur (Tot Nothing) - isSur = isTotSur (Sur Nothing) - + + isTot = isTotSur Tot + isSur = isTotSur Sur + isUni = isUniInj Uni isInj = isUniInj Inj - + isRfx r = Rfx `elem` properties r isIrf r = Irf `elem` properties r isTrn r = Trn `elem` properties r @@ -176,8 +176,8 @@ instance Relational Expression where -- TODO: see if we can find more pro isAsy r = Asy `elem` properties r -- Not to be exported: -isTotSur :: AProp -> Expression -> Bool -isTotSur prop expr +isTotSur :: AProp -> Expression -> Bool +isTotSur prop expr = case expr of EEqu (_,_) -> False EInc (_,_) -> False @@ -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 @@ -206,8 +206,8 @@ isTotSur prop expr where todo = prop `elem` properties expr -isUniInj :: AProp -> Expression -> Bool -isUniInj prop expr +isUniInj :: AProp -> Expression -> Bool +isUniInj prop expr = case expr of EEqu (_,_) -> False EInc (_,_) -> False diff --git a/src/Ampersand/Core/A2P_Converters.hs b/src/Ampersand/Core/A2P_Converters.hs index ad13d6e9e3..1896cf3589 100644 --- a/src/Ampersand/Core/A2P_Converters.hs +++ b/src/Ampersand/Core/A2P_Converters.hs @@ -103,11 +103,20 @@ aRelation2pRelation dcl = P_Relation { dec_nm = decnm dcl , dec_sign = aSign2pSign (decsgn dcl) , dec_prps = aProps2Pprops $ decprps dcl + , dec_defaults = aRelDefaults2pRelDefaults $ decDefaults dcl , dec_pragma = [decprL dcl, decprM dcl, decprR dcl] , dec_Mean = map aMeaning2pMeaning (decMean dcl) , pos = decfpos dcl } +aRelDefaults2pRelDefaults :: ARelDefaults -> [PRelationDefault] +aRelDefaults2pRelDefaults = map aRelDefaults2pRelDefault . toList + +aRelDefaults2pRelDefault :: ARelDefault -> PRelationDefault +aRelDefaults2pRelDefault x = case x of + ARelDefaultAtom st val -> PDefAtom st (aAtomValue2pAtomValue val) + + ARelDefaultEvalPHP st txt -> PDefEvalPHP st txt aProps2Pprops :: AProps -> Set PProp aProps2Pprops aps | P_Sym `elem` xs @@ -119,17 +128,13 @@ aProps2Pprops aps aProp2pProp p = case p of Uni -> P_Uni Inj -> P_Inj - Sur x -> P_Sur (aPropDef2pPropDef <$> x) - Tot x -> P_Tot (aPropDef2pPropDef <$> x) + Sur -> P_Sur + Tot -> P_Tot 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 98c6130d42..e144b96314 100644 --- a/src/Ampersand/Core/AbstractSyntaxTree.hs +++ b/src/Ampersand/Core/AbstractSyntaxTree.hs @@ -16,8 +16,8 @@ module Ampersand.Core.AbstractSyntaxTree ( , RuleKind(..) , AEnforce(..) , Relation(..), Relations, showRel + , ARelDefault(..), ARelDefaults , AProp(..), AProps - , APropDefault(..) , IdentityRule(..) , IdentitySegment(..) , ViewDef(..) @@ -71,6 +71,7 @@ import Ampersand.Core.ParseTree , PairView(..) , PairViewSegment(..) , Representation(..), TType(..), PAtomValue(..) + , SrcOrTgt(..) ) import Ampersand.ADL1.Lattices (Op1EqualitySystem) import Data.Default (Default(..)) @@ -251,9 +252,9 @@ data AProp | -- | injective Inj | -- | surjective - Sur (Maybe APropDefault) + Sur | -- | total - Tot (Maybe APropDefault) + Tot | -- | symmetric Sym | -- | antisymmetric @@ -268,12 +269,8 @@ data AProp instance Show AProp where show Uni = "UNI" show Inj = "INJ" - 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 Sur = "SUR" + show Tot = "TOT" show Sym = "SYM" show Asy = "ASY" show Trn = "TRN" @@ -285,30 +282,32 @@ instance Unique AProp where instance Flippable AProp where flp Uni = Inj - flp (Tot x) = Sur x - flp (Sur x) = Tot x + flp Tot = Sur + flp Sur = Tot flp Inj = Uni flp x = x -data APropDefault = - ADefAtom !AAtomValue - | ADefEvalPHP !Text +type ARelDefaults = Set ARelDefault +data ARelDefault = + ARelDefaultAtom !SrcOrTgt !AAtomValue + | ARelDefaultEvalPHP !SrcOrTgt !Text deriving (Eq, Ord, Show, Data) 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 - , decprps :: AProps -- ^ the user defined properties (Uni, Tot, Sur, Inj, Sym, Asy, Trn, Rfx, Irf) - , 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 - , decMean :: [Meaning] -- ^ the meaning of a relation, for each language supported by Ampersand. - , decfpos :: Origin -- ^ the position in the Ampersand source file where this declaration is declared. Not all declarations come from the ampersand souce file. - , decusr :: Bool -- ^ if true, this relation is declared by an author in the Ampersand script; otherwise it was generated by Ampersand. - , decpat :: Maybe Text -- ^ If the relation is declared inside a pattern, the name of that pattern. - , dechash :: Int + { decnm :: !Text -- ^ the name of the relation + , decsgn :: !Signature -- ^ the source and target concepts of the relation + , decprps :: !AProps -- ^ the user defined properties (Uni, Tot, Sur, Inj, Sym, Asy, Trn, Rfx, Irf) + , decDefaults :: !ARelDefaults -- ^ the defaults for atoms in pairs in the population of this relation, used when populating relations at runtime + , 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 + , decMean :: ![Meaning] -- ^ the meaning of a relation, for each language supported by Ampersand. + , decfpos :: !Origin -- ^ the position in the Ampersand source file where this declaration is declared. Not all declarations come from the ampersand souce file. + , decusr :: !Bool -- ^ if true, this relation is declared by an author in the Ampersand script; otherwise it was generated by Ampersand. + , decpat :: !(Maybe Text) -- ^ If the relation is declared inside a pattern, the name of that pattern. + , dechash :: !Int } deriving (Typeable, Data) instance Eq Relation where diff --git a/src/Ampersand/Core/ParseTree.hs b/src/Ampersand/Core/ParseTree.hs index a03049582c..317964c2c4 100644 --- a/src/Ampersand/Core/ParseTree.hs +++ b/src/Ampersand/Core/ParseTree.hs @@ -34,7 +34,7 @@ module Ampersand.Core.ParseTree ( , P_Markup(..) , PProp(..), PProps - , PPropDefault(..) + , PRelationDefault(..) -- Inherited stuff: , module Ampersand.Input.ADL1.FilePos ) where @@ -248,6 +248,8 @@ data P_Relation = P_Relation 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_defaults :: ![PRelationDefault], + -- | a list of default values for tuples in the relation dec_pragma :: ![Text], -- | the optional meaning of a relation, possibly more than one for different languages. dec_Mean :: ![PMeaning], @@ -280,7 +282,8 @@ mergeRels rs = map fun (eqCl signat rs) -- each equiv. class contains at least 1 = P_Relation { dec_nm = name r0 , dec_sign = dec_sign r0 , dec_prps = Set.unions (dec_prps <$> NE.toList rels) - , dec_pragma = case NE.filter (not . T.null . T.concat . dec_pragma) rels of + , dec_defaults = concatMap dec_defaults rels + , dec_pragma = case NE.filter (not . T.null . T.concat . dec_pragma) rels of [] -> dec_pragma r0 h:_ -> dec_pragma h , dec_Mean = L.nub $ concatMap dec_Mean rels @@ -502,7 +505,7 @@ instance Traced a => Traced (Term a) where PCpl orig _ -> orig PBrk orig _ -> orig -data SrcOrTgt = Src | Tgt deriving (Show, Eq, Ord, Generic, Enum, Bounded) +data SrcOrTgt = Src | Tgt deriving (Show, Eq, Ord, Generic, Enum, Bounded, Data) instance Hashable SrcOrTgt instance Flippable SrcOrTgt where flp Src = Tgt @@ -890,9 +893,9 @@ data PProp | -- | injective P_Inj | -- | surjective - P_Sur (Maybe PPropDefault) + P_Sur | -- | total - P_Tot (Maybe PPropDefault) + P_Tot | -- | symmetric P_Sym | -- | antisymmetric @@ -905,17 +908,13 @@ data PProp P_Irf | -- | PROP keyword, the parser must replace this by [Sym, Asy]. P_Prop - deriving (Eq, Ord, Typeable, Data) + deriving (Eq, Ord, Typeable, Data, Enum, Bounded) instance Show PProp where show P_Uni = "UNI" show P_Inj = "INJ" - 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_Sur = "SUR" + show P_Tot = "TOT" show P_Sym = "SYM" show P_Asy = "ASY" show P_Trn = "TRN" @@ -928,13 +927,13 @@ instance Unique PProp where instance Flippable PProp where flp P_Uni = P_Inj - flp (P_Tot x) = P_Sur x - flp (P_Sur x) = P_Tot x + flp P_Tot = P_Sur + flp P_Sur = P_Tot flp P_Inj = P_Uni flp x = x -data PPropDefault = - PDefAtom !PAtomValue - | PDefEvalPHP !Text +data PRelationDefault = + PDefAtom SrcOrTgt !PAtomValue + | PDefEvalPHP SrcOrTgt !Text deriving (Eq, Ord, Data, Show) mergeContexts :: P_Context -> P_Context -> P_Context mergeContexts ctx1 ctx2 = diff --git a/src/Ampersand/FSpec/ShowHS.hs b/src/Ampersand/FSpec/ShowHS.hs index 2d87811d27..da9d03c5df 100644 --- a/src/Ampersand/FSpec/ShowHS.hs +++ b/src/Ampersand/FSpec/ShowHS.hs @@ -633,15 +633,12 @@ instance ShowHSName AProp where showHSName Irf = "Irf" instance ShowHS AProp where - 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 _ indent prp = indent <> showHSName prp + +instance ShowHS ARelDefault where showHS _ _ d = case d of - ADefAtom aav -> "ADefAtom " <> tshow aav - ADefEvalPHP txt -> "ADefEvalPHP "<> tshow txt + ARelDefaultAtom st aav -> "ARelDefaultAtom "<>tshow st <> tshow aav + ARelDefaultEvalPHP st txt -> "ARelDefaultEvalPHP "<>tshow st <> tshow txt instance ShowHS FilePos where showHS _ _ = tshow diff --git a/src/Ampersand/FSpec/ShowMeatGrinder.hs b/src/Ampersand/FSpec/ShowMeatGrinder.hs index 340ee4a6b2..bc909dbeaf 100644 --- a/src/Ampersand/FSpec/ShowMeatGrinder.hs +++ b/src/Ampersand/FSpec/ShowMeatGrinder.hs @@ -86,6 +86,7 @@ metarelation tr = , dec_sign = P_Sign (mkPConcept (tSrc tr)) (mkPConcept (tTrg tr)) , dec_prps = aProps2Pprops $ mults tr + , dec_defaults = [] , dec_pragma = [] , dec_Mean = [] , pos = OriginUnknown diff --git a/src/Ampersand/FSpec/ToFSpec/NormalForms.hs b/src/Ampersand/FSpec/ToFSpec/NormalForms.hs index 30ca7c3c4a..ed6f46e745 100644 --- a/src/Ampersand/FSpec/ToFSpec/NormalForms.hs +++ b/src/Ampersand/FSpec/ToFSpec/NormalForms.hs @@ -547,6 +547,7 @@ rTerm2expr term { decnm = nm , decsgn = sgn , decprps = fatal "Illegal RTerm in rTerm2expr" + , decDefaults = fatal "Illegal RTerm in rTerm2expr" , decprL = fatal "Illegal RTerm in rTerm2expr" , decprM = fatal "Illegal RTerm in rTerm2expr" , decprR = fatal "Illegal RTerm in rTerm2expr" diff --git a/src/Ampersand/FSpec/Transformers.hs b/src/Ampersand/FSpec/Transformers.hs index af89f7f10c..0de33251bd 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 Nothing] + , Set.fromList [Uni,Tot] , [ (dirtyId expr, dirtyId x) | expr::Expression <- instanceList fSpec , Just x <- [arg expr] ] ) ,("asMarkdown" , "Markup" , "Text" - , Set.fromList [Uni,Tot Nothing] + , Set.fromList [Uni,Tot] , [ (dirtyId mrk,(PopAlphaNumeric . P.stringify . amPandoc) mrk) | mrk::Markup <- instanceList fSpec ] ) ,("bind" , "BindedRelation" , "Relation" - , Set.fromList [Uni,Tot Nothing] + , Set.fromList [Uni,Tot] , [ (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 Nothing] + , Set.fromList [Uni,Tot] , [ (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 Nothing] + , Set.fromList [Uni,Tot] , [ (dirtyId ifc,dirtyId ctx) | ctx::A_Context <- instanceList fSpec , ifc::Interface <- ctxifcs ctx ] ) ,("context" , "Isa" , "Context" - , Set.fromList [Uni,Tot Nothing] + , Set.fromList [Uni,Tot] , [ (dirtyId isa, dirtyId ctx) | ctx::A_Context <- instanceList fSpec , isa@Isa{} <- instanceList fSpec ] ) ,("context" , "IsE" , "Context" - , Set.fromList [Uni,Tot Nothing] + , Set.fromList [Uni,Tot] , [ (dirtyId ise, dirtyId ctx) | ctx::A_Context <- instanceList fSpec , ise@IsE{} <- instanceList fSpec ] ) ,("context" , "Pattern" , "Context" - , Set.fromList [Uni,Tot Nothing] + , Set.fromList [Uni,Tot] , [ (dirtyId pat, dirtyId ctx) | ctx::A_Context <- instanceList fSpec , pat::Pattern <- instanceList fSpec ] ) ,("context" , "Population" , "Context" - , Set.fromList [Uni,Tot Nothing] + , Set.fromList [Uni,Tot] , [ (dirtyId pop, dirtyId ctx) | ctx::A_Context <- instanceList fSpec , pop::Population <- instanceList fSpec ] ) ,("ctxcds" , "ConceptDef" , "Context" - , Set.fromList [Uni,Tot Nothing] + , Set.fromList [Uni,Tot] , [ (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 Nothing] + , Set.fromList [Uni,Tot] , [ (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 Nothing] + , Set.fromList [Uni,Tot] , [ (dirtyId fld, dirtyId obj) | obj::ObjectDef <- instanceList fSpec , fld <- fields obj ] ) ,("first" , "BinaryTerm" , "Term" - , Set.fromList [Uni,Tot Nothing] + , Set.fromList [Uni,Tot] , [ (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 Nothing] + , Set.fromList [Uni,Tot] , [ ( dirtyId isa, dirtyId (gengen isa)) | isa@Isa{} <- instanceList fSpec ] ) ,("gengen" , "IsE" , "Concept" - , Set.fromList [Tot Nothing] -- it is Tot by definition, because genrhs is a NonEmpty. + , Set.fromList [Tot] -- it is Tot by definition, because genrhs is a NonEmpty. , [ ( dirtyId ise, dirtyId cpt) | ise@IsE{} <- instanceList fSpec , cpt <- NE.toList $ genrhs ise] ) ,("genspc" , "IsE" , "Concept" - , Set.fromList [Uni,Tot Nothing] + , Set.fromList [Uni,Tot] , [ ( dirtyId ise, dirtyId (genspc ise)) | ise@IsE{} <- instanceList fSpec ] ) ,("genspc" , "Isa" , "Concept" - , Set.fromList [Uni,Tot Nothing] + , Set.fromList [Uni,Tot] , [ ( 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 Nothing] + , Set.fromList [Uni,Tot] , [ (dirtyId ifc, dirtyId (ifcObj ifc)) | ifc::Interface <- instanceList fSpec ] @@ -411,7 +411,7 @@ transformersFormalAmpersand fSpec = map toTransformer [ ] ) ,("label" , "FieldDef" , "FieldName" - , Set.fromList [Uni,Tot Nothing] + , Set.fromList [Uni,Tot] , [ (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 Nothing] + , Set.fromList [Uni,Tot] , [ (dirtyId mean, dirtyId . ameaMrk $ mean) | mean::Meaning <- Set.toList . meaningInstances $ fSpec ] ) ,("markup" , "Purpose" , "Markup" - , Set.fromList [Uni,Tot Nothing] + , Set.fromList [Uni,Tot] , [ (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 Nothing] + , Set.fromList [Sur] , [ (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 Nothing] + , Set.fromList [Tot] , [ (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 Nothing] + , Set.fromList [Uni,Tot] , [ (dirtyId ctx, (PopAlphaNumeric . name) ctx) | ctx::A_Context <- instanceList fSpec ] ) ,("name" , "Interface" , "InterfaceName" - , Set.fromList [Uni,Tot Nothing] + , Set.fromList [Uni,Tot] , [ (dirtyId ifc, (PopAlphaNumeric . name) ifc) | ifc::Interface <- instanceList fSpec ] ) ,("name" , "ObjectDef" , "ObjectName" - , Set.fromList [Uni,Tot Nothing] + , Set.fromList [Uni,Tot] , [ (dirtyId obj, (PopAlphaNumeric . name) obj) | obj::ObjectDef <- instanceList fSpec ] ) ,("name" , "Pattern" , "PatternName" - , Set.fromList [Uni,Tot Nothing] + , Set.fromList [Uni,Tot] , [ (dirtyId pat,(PopAlphaNumeric . name) pat) | pat::Pattern <- instanceList fSpec ] ) ,("name" , "Relation" , "RelationName" - , Set.fromList [Uni,Tot Nothing] + , Set.fromList [Uni,Tot] , [ (dirtyId rel,(PopAlphaNumeric . name) rel) | rel::Relation <- instanceList fSpec ] @@ -531,13 +531,13 @@ transformersFormalAmpersand fSpec = map toTransformer [ ] ) ,("name" , "Rule" , "RuleName" - , Set.fromList [Uni,Tot Nothing] + , Set.fromList [Uni,Tot] , [ (dirtyId rul,(PopAlphaNumeric . name) rul) | rul::Rule <- instanceList fSpec ] ) ,("name" , "View" , "ViewDefName" - , Set.fromList [Uni,Tot Nothing] + , Set.fromList [Uni,Tot] , [ (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 Nothing] + , Set.fromList [Uni,Tot] , [ (dirtyId expr, PopAlphaNumeric . tshow $ op) | expr::Expression <- instanceList fSpec , Just op <- [binOp expr] ] ) ,("operator" , "UnaryTerm" , "Operator" - , Set.fromList [Uni,Tot Nothing] + , Set.fromList [Uni,Tot] , [ (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 Nothing] + , Set.fromList [Uni,Tot] , [ (dirtyId quad, dirtyId (qDcl quad)) | quad <- vquads fSpec ] --TODO ) ,("qRule" , "Quad" , "Rule" - , Set.fromList [Uni,Tot Nothing] + , Set.fromList [Uni,Tot] , [ (dirtyId quad, dirtyId (qRule quad)) | quad <- vquads fSpec ] --TODO @@ -678,7 +678,7 @@ transformersFormalAmpersand fSpec = map toTransformer [ ] ) ,("second" , "BinaryTerm" , "Term" - , Set.fromList [Uni,Tot Nothing] + , Set.fromList [Uni,Tot] , [ (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 Nothing] + , Set.fromList [Uni,Tot] , [ (dirtyId expr, PopAlphaNumeric (showA expr)) | expr::Expression <- instanceList fSpec ] ) ,("sign" , "Term" , "Signature" - , Set.fromList [Uni,Tot Nothing] + , Set.fromList [Uni,Tot] , [ (dirtyId expr, dirtyId (sign expr)) | expr::Expression <- instanceList fSpec ] ) ,("sign" , "Relation" , "Signature" - , Set.fromList [Uni,Tot Nothing] + , Set.fromList [Uni,Tot] , [ (dirtyId rel, dirtyId (sign rel)) | rel::Relation <- instanceList fSpec ] ) ,("singleton" , "Singleton" , "AtomValue" - , Set.fromList [Uni,Tot Nothing] + , Set.fromList [Uni,Tot] , [ (dirtyId expr, dirtyId x) | expr::Expression <- instanceList fSpec , Just x <- [singleton expr] ] ) ,("source" , "Relation" , "Concept" - , Set.fromList [Uni,Tot Nothing] + , Set.fromList [Uni,Tot] , [ (dirtyId rel, dirtyId (source rel)) | rel::Relation <- instanceList fSpec ] ) ,("src" , "Signature" , "Concept" - , Set.fromList [Uni,Tot Nothing] + , Set.fromList [Uni,Tot] , [ (dirtyId sgn, dirtyId (source sgn)) | sgn::Signature <- instanceList fSpec ] ) ,("srcOrTgt" , "PairViewSegment" , "SourceOrTarget" - , Set.fromList [Uni,Tot Nothing] + , Set.fromList [Uni,Tot] , [] --TODO ) ,("target" , "Relation" , "Concept" - , Set.fromList [Uni,Tot Nothing] + , Set.fromList [Uni,Tot] , [ (dirtyId rel, dirtyId (target rel)) | rel::Relation <- instanceList fSpec ] ) ,("text" , "PairViewSegment" , "String" - , Set.fromList [Uni,Tot Nothing] + , Set.fromList [Uni,Tot] , [] --TODO ) ,("tgt" , "Signature" , "Concept" - , Set.fromList [Uni,Tot Nothing] + , Set.fromList [Uni,Tot] , [ (dirtyId sgn, dirtyId (target sgn)) | sgn::Signature <- instanceList fSpec ] @@ -811,28 +811,28 @@ transformersFormalAmpersand fSpec = map toTransformer [ ] ) ,("userCpt" , "Epsilon" , "Concept" - , Set.fromList [Uni,Tot Nothing] + , Set.fromList [Uni,Tot] , [ (dirtyId expr, dirtyId x) | expr::Expression <- instanceList fSpec , Just (x::A_Concept) <- [userCpt expr] ] ) ,("userSrc" , "V" , "Concept" - , Set.fromList [Uni,Tot Nothing] + , Set.fromList [Uni,Tot] , [ (dirtyId expr, dirtyId x) | expr::Expression <- instanceList fSpec , Just x <- [userSrc expr] ] ) ,("userTgt" , "V" , "Concept" - , Set.fromList [Uni,Tot Nothing] + , Set.fromList [Uni,Tot] , [ (dirtyId expr, dirtyId x) | expr::Expression <- instanceList fSpec , Just x <- [userTgt expr] ] ) ,("vdats" , "View" , "ViewSegment" - , Set.fromList [Inj,Sur Nothing] + , Set.fromList [Inj,Sur] , [ (dirtyId vd, PopAlphaNumeric . tshow $ vs) | vd::ViewDef <- instanceList fSpec , vs <- vdats vd @@ -852,7 +852,7 @@ transformersFormalAmpersand fSpec = map toTransformer [ ] ) ,("vdIsDefault" , "View" , "Concept" - , Set.fromList [Uni,Tot Nothing] + , Set.fromList [Uni,Tot] , [ (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 Nothing] + , Set.fromList [Uni,Tot] , [ (dirtyId ctx,PopAlphaNumeric (longVersion appVersion)) | ctx::A_Context <- instanceList fSpec ] diff --git a/src/Ampersand/Input/ADL1/Parser.hs b/src/Ampersand/Input/ADL1/Parser.hs index 3f790352b7..cf555fef9d 100644 --- a/src/Ampersand/Input/ADL1/Parser.hs +++ b/src/Ampersand/Input/ADL1/Parser.hs @@ -253,17 +253,18 @@ pRuleDef = P_Rule <$> currPos <|> PairViewExp <$> posOf (pKey "TGT") <*> return Tgt <*> pTerm <|> PairViewText <$> posOf (pKey "TXT") <*> asText pDoubleQuotedString ---- RelationDef ::= (RelationNew | RelationOld) Props? ('PRAGMA' Text+)? Meaning* ('=' Content)? '.'? +--- RelationDef ::= (RelationNew | RelationOld) Props? RelDefaults? ('PRAGMA' Text+)? Meaning* ('=' Content)? '.'? pRelationDef :: AmpParser (P_Relation, [P_Population]) pRelationDef = reorder <$> currPos <*> (pRelationNew <|> pRelationOld) <*> optSet pProps + <*> many pRelDefault <*> optList (pKey "PRAGMA" *> many1 (asText pDoubleQuotedString)) <*> many pMeaning <*> optList (pOperator "=" *> pContent) <* optList (pOperator ".") - where reorder pos' (nm,sign,fun) prop pragma meanings prs = - (P_Relation nm sign props pragma meanings pos', map pair2pop prs) + where reorder pos' (nm,sign,fun) prop dflts pragma meanings prs = + (P_Relation nm sign props dflts pragma meanings pos', map pair2pop prs) where props = prop `Set.union` fun pair2pop :: PAtomPair -> P_Population @@ -271,6 +272,18 @@ pRelationDef = reorder <$> currPos rel :: P_NamedRel -- the named relation rel = PNamedRel pos' nm (Just sign) +---RelDefault ::= ( 'SRC' | 'TGT' ) ( 'VALUE' '' | 'EVALPHP' '' ) +pRelDefault :: AmpParser PRelationDefault +pRelDefault = pDefAtom <|> pDefEvalPHP + where + pDefAtom :: AmpParser PRelationDefault + pDefAtom = PDefAtom <$> pSrcOrTgt + <*> pAtomValue + pDefEvalPHP :: AmpParser PRelationDefault + pDefEvalPHP = PDefEvalPHP <$> pSrcOrTgt + <*> asText pDoubleQuotedString + pSrcOrTgt = Src <$ pKey "SRC" + <|> Tgt <$ pKey "TGT" --- RelationNew ::= 'RELATION' Varid Signature pRelationNew :: AmpParser (Text,P_Sign,PProps) pRelationNew = (,,) <$ pKey "RELATION" @@ -291,19 +304,9 @@ pRelationOld = relOld <$> asText pVarid pProps :: AmpParser (Set.Set PProp) pProps = normalizeProps <$> pBrackets (pProp `sepBy` pComma) --- PropList ::= Prop (',' Prop)* - --- Prop ::= 'UNI' | 'INJ' | 'SUR' PropDefault? | 'TOT' PropDefault? | 'SYM' | 'ASY' | 'TRN' | 'RFX' | 'IRF' | 'PROP' + --- Prop ::= 'UNI' | 'INJ' | 'SUR' | 'TOT' | '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 - , PDefEvalPHP <$ pKey "EVALPHP" <*> (T.pack <$> pDoubleQuotedString) - ] + pProp = choice [ p <$ pKey (show p) | p <- [minBound..] ] normalizeProps :: [PProp] -> PProps normalizeProps = conv.rep . Set.fromList where -- replace PROP by SYM, ASY @@ -322,14 +325,14 @@ pProps = normalizeProps <$> pBrackets (pProp `sepBy` pComma) --- Fun ::= '*' | '->' | '<-' | '[' Mults ']' pFun :: AmpParser PProps pFun = Set.empty <$ pOperator "*" <|> - Set.fromList [P_Uni ,P_Tot Nothing ] <$ pOperator "->" <|> - Set.fromList [P_Sur Nothing ,P_Inj ] <$ pOperator "<-" <|> + Set.fromList [P_Uni ,P_Tot ] <$ pOperator "->" <|> + Set.fromList [P_Sur ,P_Inj ] <$ pOperator "<-" <|> pBrackets pMults --- Mults ::= Mult '-' Mult where pMults :: AmpParser PProps - pMults = Set.union <$> optSet (pMult (P_Sur Nothing ,P_Inj)) + pMults = Set.union <$> optSet (pMult (P_Sur ,P_Inj)) <* pDash - <*> optSet (pMult (P_Tot Nothing ,P_Uni)) + <*> optSet (pMult (P_Tot ,P_Uni)) --- Mult ::= ('0' | '1') '..' ('1' | '*') | '*' | '1' --TODO: refactor to Mult ::= '0' '..' ('1' | '*') | '1'('..' ('1' | '*'))? | '*' diff --git a/src/Ampersand/Input/Archi/ArchiAnalyze.hs b/src/Ampersand/Input/Archi/ArchiAnalyze.hs index 048ba9a205..3be8f2fcfb 100644 --- a/src/Ampersand/Input/Archi/ArchiAnalyze.hs +++ b/src/Ampersand/Input/Archi/ArchiAnalyze.hs @@ -512,7 +512,7 @@ translateArchiElem :: Text -> (Text, Text) -> Maybe Text -> Set.Set PProp-> [(Te -> (P_Population,P_Relation,Maybe Text,PPurpose) translateArchiElem label (srcLabel,tgtLabel) maybeViewName props tuples = ( P_RelPopu Nothing Nothing OriginUnknown ref_to_relation (transTuples tuples) - , P_Relation label ref_to_signature props [] [] OriginUnknown + , P_Relation label ref_to_signature props [] [] [] OriginUnknown , maybeViewName , PRef2 { pos = OriginUnknown -- the position in the Ampersand script of this purpose definition , pexObj = PRef2Relation ref_to_relation -- the reference to the object whose purpose is explained diff --git a/src/Ampersand/Input/Xslx/XLSX.hs b/src/Ampersand/Input/Xslx/XLSX.hs index 5a90b32172..0c7c7febbe 100644 --- a/src/Ampersand/Input/Xslx/XLSX.hs +++ b/src/Ampersand/Input/Xslx/XLSX.hs @@ -90,6 +90,7 @@ addRelations pCtx = enrichedContext , rel<-[ P_Relation{ dec_nm = name pop , dec_sign = P_Sign src' tgt' , dec_prps = mempty + , dec_defaults = mempty , dec_pragma = mempty , dec_Mean = mempty , pos = origin pop @@ -116,7 +117,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 $ filter (not . test) [P_Uni,P_Tot Nothing,P_Inj,P_Sur Nothing] + in Set.fromList $ filter (not . test) [P_Uni,P_Tot,P_Inj,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/Output/ToJSON/Relations.hs b/src/Ampersand/Output/ToJSON/Relations.hs index 3dea82d01d..a6057ae6f4 100644 --- a/src/Ampersand/Output/ToJSON/Relations.hs +++ b/src/Ampersand/Output/ToJSON/Relations.hs @@ -62,24 +62,19 @@ instance JSON Relation RelationJson where , 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 + [Sur] -> Nothing [_] -> 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 + [Tot] -> Nothing [_] -> 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 -> "{php}"<>txt + instance JSON Relation RelTableInfo where fromAmpersand env fSpec dcl = RelTableInfo { rtiJSONname = name plug diff --git a/src/Ampersand/Test/Parser/ArbitraryTree.hs b/src/Ampersand/Test/Parser/ArbitraryTree.hs index 0b285f0baa..eccfc24d90 100644 --- a/src/Ampersand/Test/Parser/ArbitraryTree.hs +++ b/src/Ampersand/Test/Parser/ArbitraryTree.hs @@ -157,6 +157,7 @@ instance Arbitrary P_Relation where <$> lowerId <*> arbitrary <*> arbitrary + <*> arbitrary <*> listOf safeStr1 `suchThat` (\xs -> 3 <= length xs) <*> arbitrary <*> arbitrary @@ -389,15 +390,11 @@ instance Arbitrary PandocFormat where arbitrary = elements [minBound..] instance Arbitrary PProp where - 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 <$> safeStr + arbitrary = elements [minBound..] + +instance Arbitrary PRelationDefault where + arbitrary = oneof [ PDefAtom <$> arbitrary <*> arbitrary + , PDefEvalPHP <$> arbitrary <*> safeStr ] noOne :: Foldable t => t P_Concept -> Bool From 3be65b8f696cb1443bd0d63eca464d4057db337d Mon Sep 17 00:00:00 2001 From: hanjoosten Date: Sat, 23 Oct 2021 20:04:40 +0200 Subject: [PATCH 04/15] fix Relation.json --- src/Ampersand/Core/A2P_Converters.hs | 2 +- src/Ampersand/Output/ToJSON/Relations.hs | 29 +++++++++++------------- 2 files changed, 14 insertions(+), 17 deletions(-) diff --git a/src/Ampersand/Core/A2P_Converters.hs b/src/Ampersand/Core/A2P_Converters.hs index 1896cf3589..a1a8471968 100644 --- a/src/Ampersand/Core/A2P_Converters.hs +++ b/src/Ampersand/Core/A2P_Converters.hs @@ -115,8 +115,8 @@ aRelDefaults2pRelDefaults = map aRelDefaults2pRelDefault . toList aRelDefaults2pRelDefault :: ARelDefault -> PRelationDefault aRelDefaults2pRelDefault x = case x of ARelDefaultAtom st val -> PDefAtom st (aAtomValue2pAtomValue val) - ARelDefaultEvalPHP st txt -> PDefEvalPHP st txt + aProps2Pprops :: AProps -> Set PProp aProps2Pprops aps | P_Sym `elem` xs diff --git a/src/Ampersand/Output/ToJSON/Relations.hs b/src/Ampersand/Output/ToJSON/Relations.hs index a6057ae6f4..40348294c7 100644 --- a/src/Ampersand/Output/ToJSON/Relations.hs +++ b/src/Ampersand/Output/ToJSON/Relations.hs @@ -7,7 +7,6 @@ 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) @@ -23,8 +22,8 @@ data RelationJson = RelationJson , relJSONprop :: Bool , relJSONaffectedConjuncts :: [Text] , relJSONmysqlTable :: RelTableInfo - , relJSONdefaultSrc :: Maybe Text - , relJSONdefaultTgt :: Maybe Text + , relJSONdefaultSrc :: [Text] + , relJSONdefaultTgt :: [Text] } deriving (Generic, Show) data RelTableInfo = RelTableInfo -- Contains info about where the relation is implemented in SQL { rtiJSONname :: Text @@ -37,6 +36,7 @@ data TableCol = TableCol , tcJSONnull :: Bool , tcJSONunique :: Bool } deriving (Generic, Show) + instance ToJSON Relationz where toJSON = amp2Jason instance ToJSON RelationJson where @@ -60,21 +60,18 @@ 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 - [_] -> 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 - [_] -> fatal "Nothing else than `Tot` is expected here!" - ps -> fatal $ "Multiple instances of Tot should have been prevented by the typechecker\n" - <>" "<>tshow ps + , relJSONdefaultSrc = map toText . Set.toList . Set.filter (is Src) $ decDefaults dcl + , relJSONdefaultTgt = map toText . Set.toList . Set.filter (is Tgt) $ decDefaults dcl } where bindedExp = EDcD dcl - + is :: SrcOrTgt -> ARelDefault -> Bool + is st x = case x of + ARelDefaultAtom st' _ -> st == st' + ARelDefaultEvalPHP st' _ -> st == st' + toText :: ARelDefault -> Text + toText x = case x of + ARelDefaultAtom _ val -> showValADL val + ARelDefaultEvalPHP _ txt -> txt instance JSON Relation RelTableInfo where fromAmpersand env fSpec dcl = RelTableInfo { rtiJSONname = name plug From 058a217dfe97066e74a0da0358177cdf825c107c Mon Sep 17 00:00:00 2001 From: hanjoosten Date: Sat, 23 Oct 2021 20:07:12 +0200 Subject: [PATCH 05/15] Add {php} to json text for php functions --- 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 40348294c7..19db852f32 100644 --- a/src/Ampersand/Output/ToJSON/Relations.hs +++ b/src/Ampersand/Output/ToJSON/Relations.hs @@ -71,7 +71,7 @@ instance JSON Relation RelationJson where toText :: ARelDefault -> Text toText x = case x of ARelDefaultAtom _ val -> showValADL val - ARelDefaultEvalPHP _ txt -> txt + ARelDefaultEvalPHP _ txt -> "{php}"<>txt instance JSON Relation RelTableInfo where fromAmpersand env fSpec dcl = RelTableInfo { rtiJSONname = name plug From b31a82f5923b974f5b7542406d0485cc210055d2 Mon Sep 17 00:00:00 2001 From: hanjoosten Date: Sat, 23 Oct 2021 20:20:31 +0200 Subject: [PATCH 06/15] forgot the keywords --- src/Ampersand/Input/ADL1/Parser.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Ampersand/Input/ADL1/Parser.hs b/src/Ampersand/Input/ADL1/Parser.hs index cf555fef9d..c8c5ac7e4f 100644 --- a/src/Ampersand/Input/ADL1/Parser.hs +++ b/src/Ampersand/Input/ADL1/Parser.hs @@ -278,9 +278,11 @@ pRelDefault = pDefAtom <|> pDefEvalPHP where pDefAtom :: AmpParser PRelationDefault pDefAtom = PDefAtom <$> pSrcOrTgt + <* pKey "VALUE" <*> pAtomValue pDefEvalPHP :: AmpParser PRelationDefault pDefEvalPHP = PDefEvalPHP <$> pSrcOrTgt + <* pKey "EVALPHP" <*> asText pDoubleQuotedString pSrcOrTgt = Src <$ pKey "SRC" <|> Tgt <$ pKey "TGT" From 56ccd8f82c82667dd66563f79ee7fdfea26686be Mon Sep 17 00:00:00 2001 From: hanjoosten Date: Sat, 23 Oct 2021 21:22:25 +0200 Subject: [PATCH 07/15] fix parser and prettyprinter --- src/Ampersand/ADL1/PrettyPrinters.hs | 7 +++---- src/Ampersand/Input/ADL1/Parser.hs | 19 ++++++++++--------- 2 files changed, 13 insertions(+), 13 deletions(-) diff --git a/src/Ampersand/ADL1/PrettyPrinters.hs b/src/Ampersand/ADL1/PrettyPrinters.hs index f4bbb682b5..e2cc95823d 100644 --- a/src/Ampersand/ADL1/PrettyPrinters.hs +++ b/src/Ampersand/ADL1/PrettyPrinters.hs @@ -136,14 +136,13 @@ instance Pretty P_Pattern where instance Pretty P_Relation where pretty (P_Relation nm sign prps dflts pragma mean _) = - text "RELATION" <+> (text . T.unpack) nm <~> sign <+> props <+\> defaults <+\> pragmas <+\> prettyhsep mean + text "RELATION" <+> (text . T.unpack) nm <~> sign <+> props <+\> sequential dflts<+\> pragmas <+\> prettyhsep mean where props | null prps = empty | otherwise = pretty $ Set.toList prps - defaults | null dflts = empty - | otherwise = pretty dflts pragmas | T.null (T.concat pragma) = empty | otherwise = text "PRAGMA" <+> hsep (map quote pragma) - + sequential :: Pretty a => [a] -> Doc + sequential = sep . map pretty instance Pretty a => Pretty (Term a) where pretty p = case p of Prim a -> pretty a diff --git a/src/Ampersand/Input/ADL1/Parser.hs b/src/Ampersand/Input/ADL1/Parser.hs index c8c5ac7e4f..f5a5a31b94 100644 --- a/src/Ampersand/Input/ADL1/Parser.hs +++ b/src/Ampersand/Input/ADL1/Parser.hs @@ -274,16 +274,17 @@ pRelationDef = reorder <$> currPos ---RelDefault ::= ( 'SRC' | 'TGT' ) ( 'VALUE' '' | 'EVALPHP' '' ) pRelDefault :: AmpParser PRelationDefault -pRelDefault = pDefAtom <|> pDefEvalPHP +pRelDefault = build <$> pSrcOrTgt + <*> pDef where - pDefAtom :: AmpParser PRelationDefault - pDefAtom = PDefAtom <$> pSrcOrTgt - <* pKey "VALUE" - <*> pAtomValue - pDefEvalPHP :: AmpParser PRelationDefault - pDefEvalPHP = PDefEvalPHP <$> pSrcOrTgt - <* pKey "EVALPHP" - <*> asText pDoubleQuotedString + build st (Left val) = PDefAtom st val + build st (Right txt) = PDefEvalPHP st txt + pDef :: AmpParser (Either PAtomValue Text) + pDef = pAtom <|> pPHP + pAtom = Left <$ pKey "VALUE" + <*> pAtomValue + pPHP = Right <$ pKey "EVALPHP" + <*> asText pDoubleQuotedString pSrcOrTgt = Src <$ pKey "SRC" <|> Tgt <$ pKey "TGT" --- RelationNew ::= 'RELATION' Varid Signature From 599edf590b79bedae1e3799a4ec68d3f54269d35 Mon Sep 17 00:00:00 2001 From: hanjoosten Date: Sat, 23 Oct 2021 21:47:47 +0200 Subject: [PATCH 08/15] Add testcases --- testing/Travis/testcases/Parsing/shouldFail/Issue1189.adl | 7 +++++++ .../Travis/testcases/Parsing/shouldSucceed/Issue1189.adl | 7 +++++++ 2 files changed, 14 insertions(+) create mode 100644 testing/Travis/testcases/Parsing/shouldFail/Issue1189.adl create mode 100644 testing/Travis/testcases/Parsing/shouldSucceed/Issue1189.adl diff --git a/testing/Travis/testcases/Parsing/shouldFail/Issue1189.adl b/testing/Travis/testcases/Parsing/shouldFail/Issue1189.adl new file mode 100644 index 0000000000..d401547c0e --- /dev/null +++ b/testing/Travis/testcases/Parsing/shouldFail/Issue1189.adl @@ -0,0 +1,7 @@ +CONTEXT Issue1189 + +RELATION r[A * B] TGT EVALPHP "Ordina" SRC VALUE 10 + +ENDCONTEXT + +-- This should fail, because 10 should match the TType of A \ No newline at end of file diff --git a/testing/Travis/testcases/Parsing/shouldSucceed/Issue1189.adl b/testing/Travis/testcases/Parsing/shouldSucceed/Issue1189.adl new file mode 100644 index 0000000000..1273bc3b7d --- /dev/null +++ b/testing/Travis/testcases/Parsing/shouldSucceed/Issue1189.adl @@ -0,0 +1,7 @@ +CONTEXT Issue1189 + +RELATION r[A * B] TGT EVALPHP "getdate()" SRC VALUE 10 +REPRESENT A TYPE INTEGER +REPRESENT B TYPE DATE --beware, the PHP function is not validated by the Ampersand typechecker. +ENDCONTEXT + From 51bce0988d47a02e5544a6f5773f7b1134073835 Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Sun, 7 Nov 2021 14:28:33 +0100 Subject: [PATCH 09/15] Add keyword DEFAULT to parser --- src/Ampersand/Input/ADL1/Parser.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Ampersand/Input/ADL1/Parser.hs b/src/Ampersand/Input/ADL1/Parser.hs index f5a5a31b94..817ba49235 100644 --- a/src/Ampersand/Input/ADL1/Parser.hs +++ b/src/Ampersand/Input/ADL1/Parser.hs @@ -258,7 +258,7 @@ pRelationDef :: AmpParser (P_Relation, [P_Population]) pRelationDef = reorder <$> currPos <*> (pRelationNew <|> pRelationOld) <*> optSet pProps - <*> many pRelDefault + <*> optList pRelDefaults <*> optList (pKey "PRAGMA" *> many1 (asText pDoubleQuotedString)) <*> many pMeaning <*> optList (pOperator "=" *> pContent) @@ -272,6 +272,9 @@ pRelationDef = reorder <$> currPos rel :: P_NamedRel -- the named relation rel = PNamedRel pos' nm (Just sign) +pRelDefaults :: AmpParser [PRelationDefault] +pRelDefaults = pKey "DEFAULT" *> many1 pRelDefault + ---RelDefault ::= ( 'SRC' | 'TGT' ) ( 'VALUE' '' | 'EVALPHP' '' ) pRelDefault :: AmpParser PRelationDefault pRelDefault = build <$> pSrcOrTgt From c474cea0c1bd18bad3d44d96ff562a0fefacdc9f Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Sun, 7 Nov 2021 15:04:17 +0100 Subject: [PATCH 10/15] Add comma separator between default statements and between multiple atom values --- src/Ampersand/Input/ADL1/Parser.hs | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/src/Ampersand/Input/ADL1/Parser.hs b/src/Ampersand/Input/ADL1/Parser.hs index 817ba49235..e4c9cf1526 100644 --- a/src/Ampersand/Input/ADL1/Parser.hs +++ b/src/Ampersand/Input/ADL1/Parser.hs @@ -272,20 +272,22 @@ pRelationDef = reorder <$> currPos rel :: P_NamedRel -- the named relation rel = PNamedRel pos' nm (Just sign) +--- RelDefaults ::= 'DEFAULT' RelDefault (',' RelDefault)* pRelDefaults :: AmpParser [PRelationDefault] -pRelDefaults = pKey "DEFAULT" *> many1 pRelDefault +pRelDefaults = pKey "DEFAULT" *> (toList . concat <$> sepBy1 pRelDefault pComma) ----RelDefault ::= ( 'SRC' | 'TGT' ) ( 'VALUE' '' | 'EVALPHP' '' ) -pRelDefault :: AmpParser PRelationDefault +--- RelDefault ::= ( 'SRC' | 'TGT' ) ( ('VALUE' AtomValue (',' AtomValue)*) | ('EVALPHP' '') ) +pRelDefault :: AmpParser [PRelationDefault] pRelDefault = build <$> pSrcOrTgt <*> pDef where - build st (Left val) = PDefAtom st val - build st (Right txt) = PDefEvalPHP st txt - pDef :: AmpParser (Either PAtomValue Text) + build :: SrcOrTgt -> Either [PAtomValue] Text -> [PRelationDefault] + build st (Left vals) = map (PDefAtom st) vals + build st (Right txt) = [PDefEvalPHP st txt] + pDef :: AmpParser (Either [PAtomValue] Text) pDef = pAtom <|> pPHP pAtom = Left <$ pKey "VALUE" - <*> pAtomValue + <*> (toList <$> sepBy1 pAtomValue pComma) pPHP = Right <$ pKey "EVALPHP" <*> asText pDoubleQuotedString pSrcOrTgt = Src <$ pKey "SRC" From 591fedb7bc989b6596ef75f02cf903ec00b5b547 Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Sun, 7 Nov 2021 21:00:44 +0100 Subject: [PATCH 11/15] Bugfix parser related to look ahead after comma Change of syntax to make it easier --- src/Ampersand/Input/ADL1/Parser.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Ampersand/Input/ADL1/Parser.hs b/src/Ampersand/Input/ADL1/Parser.hs index e4c9cf1526..bf407509da 100644 --- a/src/Ampersand/Input/ADL1/Parser.hs +++ b/src/Ampersand/Input/ADL1/Parser.hs @@ -272,9 +272,9 @@ pRelationDef = reorder <$> currPos rel :: P_NamedRel -- the named relation rel = PNamedRel pos' nm (Just sign) ---- RelDefaults ::= 'DEFAULT' RelDefault (',' RelDefault)* +--- RelDefaults ::= 'DEFAULT' RelDefault* pRelDefaults :: AmpParser [PRelationDefault] -pRelDefaults = pKey "DEFAULT" *> (toList . concat <$> sepBy1 pRelDefault pComma) +pRelDefaults = pKey "DEFAULT" *> (toList . concat <$> many1 pRelDefault) --- RelDefault ::= ( 'SRC' | 'TGT' ) ( ('VALUE' AtomValue (',' AtomValue)*) | ('EVALPHP' '') ) pRelDefault :: AmpParser [PRelationDefault] @@ -291,7 +291,8 @@ pRelDefault = build <$> pSrcOrTgt pPHP = Right <$ pKey "EVALPHP" <*> asText pDoubleQuotedString pSrcOrTgt = Src <$ pKey "SRC" - <|> Tgt <$ pKey "TGT" + <|> Tgt <$ pKey "TGT" + --- RelationNew ::= 'RELATION' Varid Signature pRelationNew :: AmpParser (Text,P_Sign,PProps) pRelationNew = (,,) <$ pKey "RELATION" From 8e6f716292d7a7dabaa5e586797de057bbfce050 Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Sun, 7 Nov 2021 22:29:31 +0100 Subject: [PATCH 12/15] Refactor data structure for default values --- src/Ampersand/ADL1/P2A_Converters.hs | 6 +++--- src/Ampersand/Core/A2P_Converters.hs | 2 +- src/Ampersand/Core/AbstractSyntaxTree.hs | 2 +- src/Ampersand/Core/ParseTree.hs | 4 ++-- src/Ampersand/Input/ADL1/Parser.hs | 10 +++++----- src/Ampersand/Output/ToJSON/Relations.hs | 10 +++++----- 6 files changed, 17 insertions(+), 17 deletions(-) diff --git a/src/Ampersand/ADL1/P2A_Converters.hs b/src/Ampersand/ADL1/P2A_Converters.hs index 730efc66d0..048a72932a 100644 --- a/src/Ampersand/ADL1/P2A_Converters.hs +++ b/src/Ampersand/ADL1/P2A_Converters.hs @@ -1127,10 +1127,10 @@ pDecl2aDecl typ cptMap maybePatName defLanguage defFormat pd where pReldefault2aReldefaults :: PRelationDefault -> Guarded ARelDefault pReldefault2aReldefaults x = case x of - PDefAtom st val -> ARelDefaultAtom st <$> - pAtomValue2aAtomValue typ (case st of + PDefAtom st vals -> ARelDefaultAtom st <$> + traverse (pAtomValue2aAtomValue typ (case st of Src -> source decSign - Tgt -> target decSign) val + Tgt -> target decSign)) vals PDefEvalPHP st txt -> pure $ ARelDefaultEvalPHP st txt (prL:prM:prR:_) = dec_pragma pd <> ["", "", ""] pProp2aProps :: PProp -> [AProp] diff --git a/src/Ampersand/Core/A2P_Converters.hs b/src/Ampersand/Core/A2P_Converters.hs index a1a8471968..cf02e2526a 100644 --- a/src/Ampersand/Core/A2P_Converters.hs +++ b/src/Ampersand/Core/A2P_Converters.hs @@ -114,7 +114,7 @@ aRelDefaults2pRelDefaults = map aRelDefaults2pRelDefault . toList aRelDefaults2pRelDefault :: ARelDefault -> PRelationDefault aRelDefaults2pRelDefault x = case x of - ARelDefaultAtom st val -> PDefAtom st (aAtomValue2pAtomValue val) + ARelDefaultAtom st vals -> PDefAtom st (map aAtomValue2pAtomValue vals) ARelDefaultEvalPHP st txt -> PDefEvalPHP st txt aProps2Pprops :: AProps -> Set PProp diff --git a/src/Ampersand/Core/AbstractSyntaxTree.hs b/src/Ampersand/Core/AbstractSyntaxTree.hs index e144b96314..f549e57ec8 100644 --- a/src/Ampersand/Core/AbstractSyntaxTree.hs +++ b/src/Ampersand/Core/AbstractSyntaxTree.hs @@ -289,7 +289,7 @@ instance Flippable AProp where type ARelDefaults = Set ARelDefault data ARelDefault = - ARelDefaultAtom !SrcOrTgt !AAtomValue + ARelDefaultAtom !SrcOrTgt ![AAtomValue] | ARelDefaultEvalPHP !SrcOrTgt !Text deriving (Eq, Ord, Show, Data) diff --git a/src/Ampersand/Core/ParseTree.hs b/src/Ampersand/Core/ParseTree.hs index 317964c2c4..475486fb41 100644 --- a/src/Ampersand/Core/ParseTree.hs +++ b/src/Ampersand/Core/ParseTree.hs @@ -932,8 +932,8 @@ instance Flippable PProp where flp P_Inj = P_Uni flp x = x data PRelationDefault = - PDefAtom SrcOrTgt !PAtomValue - | PDefEvalPHP SrcOrTgt !Text + PDefAtom SrcOrTgt [PAtomValue] + | PDefEvalPHP SrcOrTgt Text deriving (Eq, Ord, Data, Show) mergeContexts :: P_Context -> P_Context -> P_Context mergeContexts ctx1 ctx2 = diff --git a/src/Ampersand/Input/ADL1/Parser.hs b/src/Ampersand/Input/ADL1/Parser.hs index bf407509da..b38489f9a4 100644 --- a/src/Ampersand/Input/ADL1/Parser.hs +++ b/src/Ampersand/Input/ADL1/Parser.hs @@ -274,16 +274,16 @@ pRelationDef = reorder <$> currPos --- RelDefaults ::= 'DEFAULT' RelDefault* pRelDefaults :: AmpParser [PRelationDefault] -pRelDefaults = pKey "DEFAULT" *> (toList . concat <$> many1 pRelDefault) +pRelDefaults = pKey "DEFAULT" *> (toList <$> many1 pRelDefault) --- RelDefault ::= ( 'SRC' | 'TGT' ) ( ('VALUE' AtomValue (',' AtomValue)*) | ('EVALPHP' '') ) -pRelDefault :: AmpParser [PRelationDefault] +pRelDefault :: AmpParser PRelationDefault pRelDefault = build <$> pSrcOrTgt <*> pDef where - build :: SrcOrTgt -> Either [PAtomValue] Text -> [PRelationDefault] - build st (Left vals) = map (PDefAtom st) vals - build st (Right txt) = [PDefEvalPHP st txt] + build :: SrcOrTgt -> Either [PAtomValue] Text -> PRelationDefault + build st (Left vals) = PDefAtom st vals + build st (Right txt) = PDefEvalPHP st txt pDef :: AmpParser (Either [PAtomValue] Text) pDef = pAtom <|> pPHP pAtom = Left <$ pKey "VALUE" diff --git a/src/Ampersand/Output/ToJSON/Relations.hs b/src/Ampersand/Output/ToJSON/Relations.hs index 19db852f32..cae2e9fdd3 100644 --- a/src/Ampersand/Output/ToJSON/Relations.hs +++ b/src/Ampersand/Output/ToJSON/Relations.hs @@ -60,18 +60,18 @@ instance JSON Relation RelationJson where , relJSONprop = isProp bindedExp , relJSONaffectedConjuncts = maybe [] (map rc_id) . lookup dcl . allConjsPerDecl $ fSpec , relJSONmysqlTable = fromAmpersand env fSpec dcl - , relJSONdefaultSrc = map toText . Set.toList . Set.filter (is Src) $ decDefaults dcl - , relJSONdefaultTgt = map toText . Set.toList . Set.filter (is Tgt) $ decDefaults dcl + , relJSONdefaultSrc = concatMap toText . Set.toList . Set.filter (is Src) $ decDefaults dcl + , relJSONdefaultTgt = concatMap toText . Set.toList . Set.filter (is Tgt) $ decDefaults dcl } where bindedExp = EDcD dcl is :: SrcOrTgt -> ARelDefault -> Bool is st x = case x of ARelDefaultAtom st' _ -> st == st' ARelDefaultEvalPHP st' _ -> st == st' - toText :: ARelDefault -> Text + toText :: ARelDefault -> [Text] toText x = case x of - ARelDefaultAtom _ val -> showValADL val - ARelDefaultEvalPHP _ txt -> "{php}"<>txt + ARelDefaultAtom _ vals -> map showValADL vals + ARelDefaultEvalPHP _ txt -> ["{php}"<>txt] instance JSON Relation RelTableInfo where fromAmpersand env fSpec dcl = RelTableInfo { rtiJSONname = name plug From f0ceb4d0deaefa78dfb4b9d5637127a878ee4605 Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Sun, 7 Nov 2021 22:30:30 +0100 Subject: [PATCH 13/15] Adapt test cases to latest syntax proposal --- testing/Travis/testcases/Parsing/shouldFail/Issue1189.adl | 2 +- testing/Travis/testcases/Parsing/shouldSucceed/Issue1189.adl | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/testing/Travis/testcases/Parsing/shouldFail/Issue1189.adl b/testing/Travis/testcases/Parsing/shouldFail/Issue1189.adl index d401547c0e..6a358a06ba 100644 --- a/testing/Travis/testcases/Parsing/shouldFail/Issue1189.adl +++ b/testing/Travis/testcases/Parsing/shouldFail/Issue1189.adl @@ -1,6 +1,6 @@ CONTEXT Issue1189 -RELATION r[A * B] TGT EVALPHP "Ordina" SRC VALUE 10 +RELATION r[A * B] DEFAULT TGT EVALPHP "Ordina" SRC VALUE 10, 20 ENDCONTEXT diff --git a/testing/Travis/testcases/Parsing/shouldSucceed/Issue1189.adl b/testing/Travis/testcases/Parsing/shouldSucceed/Issue1189.adl index 1273bc3b7d..064a087393 100644 --- a/testing/Travis/testcases/Parsing/shouldSucceed/Issue1189.adl +++ b/testing/Travis/testcases/Parsing/shouldSucceed/Issue1189.adl @@ -1,6 +1,6 @@ CONTEXT Issue1189 -RELATION r[A * B] TGT EVALPHP "getdate()" SRC VALUE 10 +RELATION r[A * B] DEFAULT TGT EVALPHP "getdate()" SRC VALUE 10, 20 REPRESENT A TYPE INTEGER REPRESENT B TYPE DATE --beware, the PHP function is not validated by the Ampersand typechecker. ENDCONTEXT From 5862748aff814dc182fe4debf93295824e91bb29 Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Sun, 7 Nov 2021 22:31:04 +0100 Subject: [PATCH 14/15] Fix pretty printer --- src/Ampersand/ADL1/PrettyPrinters.hs | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/src/Ampersand/ADL1/PrettyPrinters.hs b/src/Ampersand/ADL1/PrettyPrinters.hs index e2cc95823d..28286dfd19 100644 --- a/src/Ampersand/ADL1/PrettyPrinters.hs +++ b/src/Ampersand/ADL1/PrettyPrinters.hs @@ -136,13 +136,18 @@ instance Pretty P_Pattern where instance Pretty P_Relation where pretty (P_Relation nm sign prps dflts pragma mean _) = - text "RELATION" <+> (text . T.unpack) nm <~> sign <+> props <+\> sequential dflts<+\> pragmas <+\> prettyhsep mean + text "RELATION" + <+> (text . T.unpack) nm <~> sign + <+> props + <+> if null dflts then empty else text "DEFAULT" + <+\> (hsep . map pretty) dflts + <+\> pragmas + <+\> prettyhsep mean where props | null prps = empty | otherwise = pretty $ Set.toList prps pragmas | T.null (T.concat pragma) = empty | otherwise = text "PRAGMA" <+> hsep (map quote pragma) - sequential :: Pretty a => [a] -> Doc - sequential = sep . map pretty + instance Pretty a => Pretty (Term a) where pretty p = case p of Prim a -> pretty a @@ -384,8 +389,9 @@ instance Pretty PProp where instance Pretty PRelationDefault where pretty x = case x of - PDefAtom sOrT pav -> pretty sOrT<+>text "VALUE "<+>pretty pav - PDefEvalPHP sOrT txt -> pretty sOrT<+>text "EVALPHP " <+> text (show txt) + PDefAtom sOrT pav -> pretty sOrT <+> text "VALUE " <+> pretty pav + PDefEvalPHP sOrT txt -> pretty sOrT <+> text "EVALPHP " <+> text (show txt) + instance Pretty PAtomPair where pretty (PPair _ l r) = text "(" <+> pretty l <~> text "," <+> pretty r From 97252b60601ecaf06af5a9f415adf44a22228e48 Mon Sep 17 00:00:00 2001 From: hanjoosten Date: Mon, 8 Nov 2021 11:18:26 +0100 Subject: [PATCH 15/15] Use NonEmpty instead of List --- ampersand.cabal | 2 ++ src/Ampersand/ADL1/PrettyPrinters.hs | 2 +- src/Ampersand/Core/A2P_Converters.hs | 2 +- src/Ampersand/Core/AbstractSyntaxTree.hs | 2 +- src/Ampersand/Core/ParseTree.hs | 2 +- src/Ampersand/Input/ADL1/Parser.hs | 6 +++--- src/Ampersand/Output/ToJSON/Relations.hs | 2 +- 7 files changed, 10 insertions(+), 8 deletions(-) diff --git a/ampersand.cabal b/ampersand.cabal index c96ddedb88..28de29546c 100644 --- a/ampersand.cabal +++ b/ampersand.cabal @@ -185,11 +185,13 @@ extra-source-files: testing/Travis/testcases/Misc/testinfo.yaml testing/Travis/testcases/Parsing/shouldFail/Issue1029a.adl testing/Travis/testcases/Parsing/shouldFail/Issue1029b.adl + testing/Travis/testcases/Parsing/shouldFail/Issue1189.adl testing/Travis/testcases/Parsing/shouldFail/Issue923.adl testing/Travis/testcases/Parsing/shouldFail/Issue980.adl testing/Travis/testcases/Parsing/shouldFail/testinfo.yaml testing/Travis/testcases/Parsing/shouldSucceed/Issue1014.adl testing/Travis/testcases/Parsing/shouldSucceed/Issue1183.adl + testing/Travis/testcases/Parsing/shouldSucceed/Issue1189.adl testing/Travis/testcases/Parsing/shouldSucceed/Issue899b.adl testing/Travis/testcases/Parsing/shouldSucceed/Issue960.adl testing/Travis/testcases/Parsing/shouldSucceed/testinfo.yaml diff --git a/src/Ampersand/ADL1/PrettyPrinters.hs b/src/Ampersand/ADL1/PrettyPrinters.hs index 28286dfd19..5ee467363d 100644 --- a/src/Ampersand/ADL1/PrettyPrinters.hs +++ b/src/Ampersand/ADL1/PrettyPrinters.hs @@ -389,7 +389,7 @@ instance Pretty PProp where instance Pretty PRelationDefault where pretty x = case x of - PDefAtom sOrT pav -> pretty sOrT <+> text "VALUE " <+> pretty pav + PDefAtom sOrT pav -> pretty sOrT <+> text "VALUE " <+> (cat . punctuate (text ", ") . toList $ fmap pretty pav) PDefEvalPHP sOrT txt -> pretty sOrT <+> text "EVALPHP " <+> text (show txt) instance Pretty PAtomPair where diff --git a/src/Ampersand/Core/A2P_Converters.hs b/src/Ampersand/Core/A2P_Converters.hs index cf02e2526a..07c4771ddc 100644 --- a/src/Ampersand/Core/A2P_Converters.hs +++ b/src/Ampersand/Core/A2P_Converters.hs @@ -114,7 +114,7 @@ aRelDefaults2pRelDefaults = map aRelDefaults2pRelDefault . toList aRelDefaults2pRelDefault :: ARelDefault -> PRelationDefault aRelDefaults2pRelDefault x = case x of - ARelDefaultAtom st vals -> PDefAtom st (map aAtomValue2pAtomValue vals) + ARelDefaultAtom st vals -> PDefAtom st (fmap aAtomValue2pAtomValue vals) ARelDefaultEvalPHP st txt -> PDefEvalPHP st txt aProps2Pprops :: AProps -> Set PProp diff --git a/src/Ampersand/Core/AbstractSyntaxTree.hs b/src/Ampersand/Core/AbstractSyntaxTree.hs index f549e57ec8..8e7aef44d1 100644 --- a/src/Ampersand/Core/AbstractSyntaxTree.hs +++ b/src/Ampersand/Core/AbstractSyntaxTree.hs @@ -289,7 +289,7 @@ instance Flippable AProp where type ARelDefaults = Set ARelDefault data ARelDefault = - ARelDefaultAtom !SrcOrTgt ![AAtomValue] + ARelDefaultAtom !SrcOrTgt !(NE.NonEmpty AAtomValue) | ARelDefaultEvalPHP !SrcOrTgt !Text deriving (Eq, Ord, Show, Data) diff --git a/src/Ampersand/Core/ParseTree.hs b/src/Ampersand/Core/ParseTree.hs index 475486fb41..c074dcf8cb 100644 --- a/src/Ampersand/Core/ParseTree.hs +++ b/src/Ampersand/Core/ParseTree.hs @@ -932,7 +932,7 @@ instance Flippable PProp where flp P_Inj = P_Uni flp x = x data PRelationDefault = - PDefAtom SrcOrTgt [PAtomValue] + PDefAtom SrcOrTgt (NE.NonEmpty PAtomValue) | PDefEvalPHP SrcOrTgt Text deriving (Eq, Ord, Data, Show) mergeContexts :: P_Context -> P_Context -> P_Context diff --git a/src/Ampersand/Input/ADL1/Parser.hs b/src/Ampersand/Input/ADL1/Parser.hs index b38489f9a4..d300cdfd71 100644 --- a/src/Ampersand/Input/ADL1/Parser.hs +++ b/src/Ampersand/Input/ADL1/Parser.hs @@ -281,13 +281,13 @@ pRelDefault :: AmpParser PRelationDefault pRelDefault = build <$> pSrcOrTgt <*> pDef where - build :: SrcOrTgt -> Either [PAtomValue] Text -> PRelationDefault + build :: SrcOrTgt -> Either (NE.NonEmpty PAtomValue) Text -> PRelationDefault build st (Left vals) = PDefAtom st vals build st (Right txt) = PDefEvalPHP st txt - pDef :: AmpParser (Either [PAtomValue] Text) + pDef :: AmpParser (Either (NE.NonEmpty PAtomValue) Text) pDef = pAtom <|> pPHP pAtom = Left <$ pKey "VALUE" - <*> (toList <$> sepBy1 pAtomValue pComma) + <*> sepBy1 pAtomValue pComma pPHP = Right <$ pKey "EVALPHP" <*> asText pDoubleQuotedString pSrcOrTgt = Src <$ pKey "SRC" diff --git a/src/Ampersand/Output/ToJSON/Relations.hs b/src/Ampersand/Output/ToJSON/Relations.hs index cae2e9fdd3..cd45b378c9 100644 --- a/src/Ampersand/Output/ToJSON/Relations.hs +++ b/src/Ampersand/Output/ToJSON/Relations.hs @@ -70,7 +70,7 @@ instance JSON Relation RelationJson where ARelDefaultEvalPHP st' _ -> st == st' toText :: ARelDefault -> [Text] toText x = case x of - ARelDefaultAtom _ vals -> map showValADL vals + ARelDefaultAtom _ vals -> toList $ fmap showValADL vals ARelDefaultEvalPHP _ txt -> ["{php}"<>txt] instance JSON Relation RelTableInfo where fromAmpersand env fSpec dcl = RelTableInfo