Feature/relation default values issue1189

.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:

.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)

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.

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

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(..)

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 vals -> ARelDefaultAtom st <$> 
+                            traverse (pAtomValue2aAtomValue typ (case st of 
+                                                         Src -> source decSign
+                                                         Tgt -> target decSign)) vals
+      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 ()

src/Ampersand/ADL1/PrettyPrinters.hs

@@ -135,8 +135,14 @@ 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
+        <+> 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
@@ -377,18 +383,15 @@ 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 " <+> (cat . punctuate (text ", ") . toList $ fmap 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 

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")

src/Ampersand/Classes/Relational.hs

@@ -37,20 +37,20 @@ 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.
 -- Not every constraint that can be proven is obtained by this function. This does not hurt Ampersand.
 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,22 +162,22 @@ 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
  isSym r = Sym `elem` properties r
  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,17 +197,17 @@ 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
       EMp1{}     -> True
   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

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 vals -> PDefAtom st (fmap aAtomValue2pAtomValue vals)
+    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