Feature/default atoms

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,8 @@ import Ampersand.Core.ParseTree (
          , PairView(..), PairViewSegment(..)
          , SrcOrTgt(..)
          , P_Rule(..),Role(..)
-         , Prop(..),Props
+         , PProp(..)
+         , PPropDefault(..)
          , P_IdentDef, P_IdentSegment,P_IdentDf(..),P_IdentSegmnt(..)
          , P_ViewDef, P_ViewSegment(..),P_ViewSegmtPayLoad(..),P_ViewD(..),ViewHtmlTemplate(..)
          , P_Population(..),PAtomPair(..)
@@ -55,6 +55,8 @@ import Ampersand.Core.AbstractSyntaxTree (
          , Interface(..), getInterfaceByName
          , Pattern(..)
          , Relation(..), Relations, getExpressionRelation, showRel
+         , AProp(..), AProps
+         , APropDefault(..)
          , Rule(..), Rules, A_RoleRule(..)
          , A_Concept(..), A_Concepts, TType(..), showValADL, showValSQL, unsafePAtomVal2AtomValue 
          , Representation(..)

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)
@@ -252,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
@@ -298,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
@@ -816,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)
@@ -867,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
@@ -1097,41 +1099,64 @@ 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 = 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
+        , 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
+  (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 ()
   checkEndoProps
     | source decSign == target decSign
                 = pure ()
-    | Set.null xs
+    | 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
@@ -1153,11 +1178,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

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)
@@ -138,9 +137,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                       = pretty $ Set.toList prps
               pragmas | T.null (T.concat pragma) = empty
                       | otherwise   = text "PRAGMA" <+> hsep (map quote pragma)
 
@@ -377,9 +375,20 @@ instance Pretty P_Markup where
 instance Pretty PandocFormat where
     pretty = text . map toUpper . show
 
-instance Pretty Prop where
-    pretty = text . map toUpper . show
-
+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
+      _ -> 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 

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
@@ -54,15 +54,14 @@ 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
                      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)
@@ -84,9 +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
-                    Prop -> fatal "Prop should have been converted by the parser"
+                    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
@@ -96,12 +94,11 @@ 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
-                    Prop -> fatal "Prop should have been converted by pattern the parser"
+                    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 -> Prop -> Text
+propFullName :: Bool -> Lang -> AProp -> Text
 propFullName isAdjective lang prop =
   case lang of 
     English ->
@@ -112,10 +109,9 @@ propFullName isAdjective lang prop =
           Rfx-> "reflexive"
           Irf-> "irreflexive"
           Uni-> "univalent"
-          Sur-> "surjective"
+          Sur _ -> "surjective"
           Inj-> "injective"
-          Tot-> "total"
-          Prop -> fatal "Prop should have been converted by the parser"
+          Tot _ -> "total"
     Dutch -> (if isAdjective then snd else fst) $
         case prop of
           Sym-> ("symmetrisch"    ,"symmetrische")
@@ -124,7 +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")
-          Prop -> fatal "Prop should have been converted by the parser"
+          Tot _ -> ("totaal"         ,"totale")