Fix issue with P_Concept

src/Ampersand/ADL1/P2A_Converters.hs

@@ -31,11 +31,11 @@ import qualified RIO.Text as T
 
 pConcToType :: P_Concept -> Type
 pConcToType P_ONE = BuiltIn TypeOfOne
-pConcToType p = UserConcept (name p, p_cptlabel p)
+pConcToType p = UserConcept (name p)
 
 aConcToType :: A_Concept -> Type
 aConcToType ONE = BuiltIn TypeOfOne
-aConcToType p = UserConcept (NE.head $ aliases p)
+aConcToType p = UserConcept (fst . NE.head $ aliases p)
 
 getAsConcept :: ContextInfo -> Origin -> Type -> Guarded A_Concept
 getAsConcept ci o v = case typeOrConcept (conceptMap ci) v of
@@ -230,7 +230,7 @@ findRelsTyped declMap x tp = Map.findWithDefault [] (SignOrd tp) (Map.map (: [])
 type DeclMap = Map.Map Name (Map.Map SignOrd Expression)
 
 onlyUserConcepts :: ContextInfo -> [[Type]] -> [[A_Concept]]
-onlyUserConcepts ci = fmap $ userList (conceptMap ci)
+onlyUserConcepts = fmap . userList . conceptMap
 
 -- | pCtx2aCtx has three tasks:
 -- 1. Disambiguate the structures.
@@ -463,7 +463,7 @@ pCtx2aCtx
               isInvolved gn = not . null $ concs gn `Set.intersection` Set.fromList cs
 
       conceptmap :: ConceptMap
-      conceptmap = makeConceptMap allGens
+      conceptmap = makeConceptMap (p_conceptdefs <> concatMap pt_cds p_patterns) allGens
       p_interfaceAndDisambObjs :: DeclMap -> [(P_Interface, P_BoxItem (TermPrim, DisambPrim))]
       p_interfaceAndDisambObjs declMap = [(ifc, disambiguate conceptmap (termPrimDisAmb conceptmap declMap) $ ifc_Obj ifc) | ifc <- p_interfaces]
 
@@ -534,7 +534,7 @@ pCtx2aCtx
           specCpt = pCpt2aCpt fun $ specific pg
       userConcept :: P_Concept -> Type
       userConcept P_ONE = BuiltIn TypeOfOne
-      userConcept (PCpt nm lbl') = UserConcept (nm, lbl')
+      userConcept (PCpt nm) = UserConcept nm
 
       pPop2aPop :: ContextInfo -> P_Population -> Guarded Population
       pPop2aPop ci pop =
@@ -1172,7 +1172,7 @@ pCtx2aCtx
           )
             <$> pRefObj2aRefObj ci objref
       pRefObj2aRefObj :: ContextInfo -> PRef2Obj -> Guarded ExplObj
-      pRefObj2aRefObj ci (PRef2ConceptDef s) = pure $ ExplConcept (pCpt2aCpt (conceptMap ci) $ mkPConcept s Nothing)
+      pRefObj2aRefObj ci (PRef2ConceptDef s) = pure $ ExplConcept (pCpt2aCpt (conceptMap ci) $ mkPConcept s)
       pRefObj2aRefObj ci (PRef2Relation tm) = ExplRelation <$> namedRel2Decl (conceptMap ci) (declDisambMap ci) tm
       pRefObj2aRefObj _ (PRef2Rule s) = pure $ ExplRule s
       pRefObj2aRefObj _ (PRef2IdentityDef s) = pure $ ExplIdentityDef s
@@ -1429,7 +1429,7 @@ pConcDef2aConcDef ::
 pConcDef2aConcDef conceptmap defLanguage defFormat pCd =
   AConceptDef
     { pos = origin pCd,
-      acdcpt = pCpt2aCpt conceptmap (PCpt {p_cptnm = name pCd, p_cptlabel = cdlbl pCd}),
+      acdcpt = pCpt2aCpt conceptmap (PCpt {p_cptnm = name pCd}),
       acdname = name pCd,
       acdlabel = cdlbl pCd,
       acddef2 = pCDDef2Mean defLanguage defFormat $ cddef2 pCd,

src/Ampersand/ADL1/PrettyPrinters.hs

@@ -399,7 +399,7 @@ instance Pretty PMessage where
   pretty (PMessage markup) = text "MESSAGE" <~> markup
 
 instance Pretty P_Concept where
-  pretty (PCpt nm lbl) = pretty nm <~> pretty lbl
+  pretty (PCpt nm) = pretty nm
   pretty P_ONE = text "ONE"
 
 instance Pretty P_Sign where

src/Ampersand/Core/A2P_Converters.hs

@@ -238,8 +238,7 @@ aConcept2pConcept cpt =
     ONE -> P_ONE
     PlainConcept {} ->
       PCpt
-        { p_cptnm = name cpt,
-          p_cptlabel = snd . NE.head . aliases $ cpt
+        { p_cptnm = name cpt
         }
 
 aPurpose2pPurpose :: Purpose -> Maybe PPurpose

src/Ampersand/Core/AbstractSyntaxTree.hs

@@ -99,6 +99,7 @@ import Ampersand.Core.ParseTree
     Origin (..),
     PAtomValue (..),
     PClassify (generics, specific),
+    PConceptDef,
     P_Concept (..),
     PairView (..),
     PairViewSegment (..),
@@ -1453,20 +1454,20 @@ data ContextInfo = CI
   }
 
 typeOrConcept :: ConceptMap -> Type -> Either A_Concept (Maybe TType)
-typeOrConcept fun (BuiltIn TypeOfOne) = Left . fun $ mkPConcept nameOfONE Nothing
-typeOrConcept fun (UserConcept (nm, lbl)) = Left . fun $ mkPConcept nm lbl
+typeOrConcept fun (BuiltIn TypeOfOne) = Left . fun $ mkPConcept nameOfONE
+typeOrConcept fun (UserConcept nm) = Left . fun $ mkPConcept nm
 typeOrConcept _ (BuiltIn x) = Right (Just x)
 typeOrConcept _ RepresentSeparator = Right Nothing
 
 data Type
-  = UserConcept !(Name, Maybe Label)
+  = UserConcept !Name
   | BuiltIn !TType
   | RepresentSeparator
   deriving (Eq, Ord)
 
 instance Named Type where
   name t = case t of
-    UserConcept (nm, _) -> nm
+    UserConcept nm -> nm
     BuiltIn tt -> mkName ConceptName . fmap toNamePart' $ ("AmpersandBuiltIn" NE.:| [tshow tt])
     RepresentSeparator -> mkName ConceptName . fmap toNamePart' $ "AmpersandBuiltIn" NE.:| ["RepresentSeparator"]
     where
@@ -1477,7 +1478,7 @@ instance Named Type where
 
 instance Show Type where
   show a = T.unpack $ case a of
-    UserConcept (nm, _) -> fullName nm
+    UserConcept nm -> fullName nm
     BuiltIn tt -> "BuiltIn " <> tshow tt
     RepresentSeparator -> "RepresentSeparator"
 
@@ -1754,8 +1755,8 @@ data Typology = Typology
 --   whenever we need to know the A_Concept for a P_Concept.
 type ConceptMap = P_Concept -> A_Concept
 
-makeConceptMap :: [PClassify] -> ConceptMap
-makeConceptMap gs = mapFunction
+makeConceptMap :: [PConceptDef] -> [PClassify] -> ConceptMap
+makeConceptMap cds gs = mapFunction
   where
     mapFunction :: P_Concept -> A_Concept
     mapFunction pCpt = case L.nub . concat . filter inCycle $ getCycles edges of
@@ -1772,7 +1773,12 @@ makeConceptMap gs = mapFunction
             }
       where
         toTuple :: P_Concept -> (Name, Maybe Label)
-        toTuple cpt = (name cpt, p_cptlabel cpt)
+        toTuple cpt =
+          ( name cpt,
+            case mapMaybe mLabel . filter (\cd -> name cd == name cpt) $ cds of
+              [] -> Nothing
+              h : _ -> Just h
+          )
     edges :: [(P_Concept, [P_Concept])]
     edges = L.nub . map mkEdge . eqCl specific $ gs
     mkEdge :: NonEmpty PClassify -> (P_Concept, [P_Concept])

src/Ampersand/Core/ParseTree.hs

@@ -1238,8 +1238,8 @@ instance Traced PPurpose where
 data P_Concept
   = -- | The name of this Concept
     PCpt
-      { p_cptnm :: !Name,
-        p_cptlabel :: !(Maybe Label)
+      { p_cptnm :: !Name
+      -- Note: HJO, 20240901: NO LABEL HERE, because this is only a reference to a (maybe implicilty defined) ConceptDef.
       }
   | -- | The universal Singleton: 'I'['Anything'] = 'V'['Anything'*'Anything']
     P_ONE
@@ -1252,11 +1252,11 @@ instance Ord P_Concept where
   -- (Sebastiaan 16 jul 2016) P_Concept has been defined Ord, only because we want to maintain sets of concepts in the type checker for quicker lookups.
   compare a b = compare (name a) (name b)
 
-mkPConcept :: Name -> Maybe Label -> P_Concept
-mkPConcept nm lbl =
+mkPConcept :: Name -> P_Concept
+mkPConcept nm =
   if nm == nameOfONE
     then P_ONE
-    else PCpt {p_cptnm = nm, p_cptlabel = lbl}
+    else PCpt {p_cptnm = nm}
 
 instance Named P_Concept where
   name PCpt {p_cptnm = nm} = nm

src/Ampersand/FSpec/ToFSpec/CreateFspec.hs

@@ -194,8 +194,8 @@ transformer2pop tr =
             p_mbSign =
               Just
                 ( P_Sign
-                    (mkPConcept (tSrc tr) Nothing)
-                    (mkPConcept (tTrg tr) Nothing)
+                    (mkPConcept (tSrc tr))
+                    (mkPConcept (tTrg tr))
                 )
           },
       p_popps = tPairs tr

src/Ampersand/Input/ADL1/Parser.hs

@@ -1271,7 +1271,7 @@ pSign = pBrackets sign
 
 --- ConceptRef ::= ConceptName
 pConceptRef :: AmpParser P_Concept
-pConceptRef = PCpt <$> pNameWithoutLabel ConceptName <*> pure Nothing
+pConceptRef = PCpt <$> pNameWithoutLabel ConceptName
 
 --- ConceptOneRef ::= 'ONE' | ConceptRef
 pConceptOneRef :: AmpParser P_Concept

src/Ampersand/Input/Archi/ArchiAnalyze.hs

@@ -170,11 +170,10 @@ mkArchiContext [archiRepo] pops = do
           mkArchiConcept :: Text1 -> P_Concept
           mkArchiConcept x =
             PCpt
-              { p_cptnm = withNameSpace archiNameSpace nm,
-                p_cptlabel = lbl
+              { p_cptnm = withNameSpace archiNameSpace nm
               }
             where
-              (nm, lbl) = suggestName ConceptName x
+              nm = fst . suggestName ConceptName $ x
       _ -> fatal "May not call vwAts on a non-view element"
     -- viewpoprels contains all triples that are picked by vwAts, for all views,
     -- to compute the triples that are not assembled in any pattern.
@@ -205,7 +204,7 @@ mkArchiContext [archiRepo] pops = do
     archiPurps =
       (map NE.head . eqClass samePurp) --  The relations that are declared in this pattern
         (map grainPurp leftovers)
-    pats = map mkPattern . filter isView . concatMap fldObjs . allFolders $ archiRepo
+    pats = map mkPattern . concatMap (filter isView . fldObjs) . allFolders $ archiRepo
       where
         isView :: ArchiObj -> Bool
         isView View {} = True
@@ -424,7 +423,7 @@ instance WithProperties ArchiObj where
       }
 
 instance (WithProperties a) => WithProperties [a] where
-  allProps xs = concatMap allProps xs
+  allProps = concatMap allProps
   identifyProps identifiers xs =
     [identifyProps ids x | (ids, x) <- zip idss xs]
     where
@@ -649,7 +648,7 @@ translateArchiElem plainNm (plainSrcName, plainTgtName) maybeViewName props tupl
             dec_prps = props,
             dec_pragma = Nothing,
             dec_nm = relName',
-            dec_label = relLabel,
+            dec_label = Nothing,
             dec_defaults = [],
             dec_Mean = [],
             pos = OriginUnknown
@@ -664,19 +663,20 @@ translateArchiElem plainNm (plainSrcName, plainTgtName) maybeViewName props tupl
           }
     }
   where
-    toNameAndLabel :: NameType -> Text1 -> (Name, Maybe Label)
-    toNameAndLabel typ x = (withNameSpace archiNameSpace nm, lbl)
+    -- This is unsafe, for not all Text1 is valid for a Name
+    toNameUnsafe :: NameType -> Text1 -> Name
+    toNameUnsafe typ x = withNameSpace archiNameSpace nm
       where
-        (nm, lbl) = suggestName typ x
-    (relName', relLabel) = toNameAndLabel RelationName plainNm
-    (srcName, srcLabel) = toNameAndLabel ConceptName plainSrcName
-    (tgtName, tgtLabel) = toNameAndLabel ConceptName plainTgtName
+        (nm, _) = suggestName typ x
+    relName' = toNameUnsafe RelationName plainNm
+    srcName = toNameUnsafe ConceptName plainSrcName
+    tgtName = toNameUnsafe ConceptName plainTgtName
     purpText :: Text
     purpText = showP ref_to_relation <> " serves to embody the ArchiMate metamodel"
     ref_to_relation :: P_NamedRel
     ref_to_relation = PNamedRel OriginUnknown relName' (Just ref_to_signature)
     ref_to_signature :: P_Sign
-    ref_to_signature = P_Sign (PCpt srcName srcLabel) (PCpt tgtName tgtLabel)
+    ref_to_signature = P_Sign (PCpt srcName) (PCpt tgtName)
 
 -- | Function `relCase` is used to generate relation identifiers that are syntactically valid in Ampersand.
 relCase :: Text1 -> Text1

src/Ampersand/Input/AtlasImport.hs

@@ -267,8 +267,7 @@ instance JSON.FromJSON PCDDef where
 instance JSON.FromJSON P_Concept where
   parseJSON :: JSON.Value -> JSON.Parser P_Concept
   parseJSON (JSON.Object v) =
-    (PCpt . textToNameInJSON ConceptName <$> (v JSON..: "name"))
-      <*> ((v JSON..:? "label") <&> fmap textToLabelInJSON)
+    PCpt . textToNameInJSON ConceptName <$> (v JSON..: "name")
   parseJSON invalid =
     JSON.prependFailure
       "parsing P_Concept failed, "

src/Ampersand/Input/Xslx/XLSX.hs

@@ -192,9 +192,9 @@ addRelations pCtx = enrichedContext
                 )
         recur _ rels popus [] = (rels, popus)
         srcPop, tgtPop :: P_Population -> P_Concept -- get the source concept of a P_Population.
-        srcPop pop@P_CptPopu {} = PCpt (name pop) Nothing
+        srcPop pop@P_CptPopu {} = PCpt (name pop)
         srcPop pop@P_RelPopu {p_src = src} = case src of Just s -> s; _ -> fatal ("srcPop (" <> showP pop <> ") is mistaken.")
-        tgtPop pop@P_CptPopu {} = PCpt (name pop) Nothing
+        tgtPop pop@P_CptPopu {} = PCpt (name pop)
         tgtPop pop@P_RelPopu {p_tgt = tgt} = case tgt of Just t -> t; _ -> fatal ("tgtPop (" <> showP pop <> ") is mistaken.")
 
     sourc, targt :: P_Relation -> P_Concept -- get the source concept of a P_Relation.
@@ -212,7 +212,7 @@ addRelations pCtx = enrichedContext
     signatur rel = (name rel, dec_sign rel)
     concepts =
       L.nub
-        $ [PCpt (name pop) Nothing | pop@P_CptPopu {} <- ctx_pops pCtx]
+        $ [PCpt (name pop) | pop@P_CptPopu {} <- ctx_pops pCtx]
         <> [src' | P_RelPopu {p_src = src} <- ctx_pops pCtx, Just src' <- [src]]
         <> [tgt' | P_RelPopu {p_tgt = tgt} <- ctx_pops pCtx, Just tgt' <- [tgt]]
         <> map sourc declaredRelations
@@ -285,7 +285,7 @@ toPops env ns file x = map popForColumn (colNrs x)
         then
           P_CptPopu
             { pos = popOrigin,
-              p_cpt = mkPConcept sourceConceptName Nothing,
+              p_cpt = mkPConcept sourceConceptName,
               p_popas =
                 concat
                   [ case value (row, i) of
@@ -305,9 +305,8 @@ toPops env ns file x = map popForColumn (colNrs x)
       where
         src, trg :: Maybe P_Concept
         (src, trg) = case mTargetConceptName of
-          Just tCptName -> both (fmap mkPConcept') $ (if isFlipped' then swap else id) (Just sourceConceptName, Just tCptName)
+          Just tCptName -> both (fmap mkPConcept) $ (if isFlipped' then swap else id) (Just sourceConceptName, Just tCptName)
           Nothing -> (Nothing, Nothing)
-        mkPConcept' nm = mkPConcept nm Nothing
         popOrigin :: Origin
         popOrigin = originOfCell (relNamesRow, targetCol)
         relNamesRow, conceptNamesRow :: RowIndex