$SetReplaceTypeGraph (#621)

## Changes

* Adds a `$SetReplaceTypeGraph` constant.
* The constant contains the nicely formatted type graph.

## Examples

* Examples below do not work directly because they use fake types. To try them out, do something like
   ```wl
   AppendTo[$ContextPath, "SetReplace`PackageScope`"];
   ```
   and then evaluate the definitions (line 15 to 81) from `typeSystem.wlt`.

* Now, check `$SetReplaceTypeGraph`:
   ```wl
   In[] := $SetReplaceTypeGraph
   ```

   <img width="830" alt="image" src="https://user-images.githubusercontent.com/1479325/110015421-7493ce80-7ce9-11eb-920d-068a2aad7353.png">

Documentation/SymbolsAndFunctions/TypeSystem/$SetReplaceTypeGraph.md

@@ -0,0 +1,20 @@
+###### [Symbols and Functions](/README.md#symbols-and-functions) > [Type System](README.md)
+
+# $SetReplaceTypeGraph
+
+**`$SetReplaceTypeGraph`** gives the [`Graph`](https://reference.wolfram.com/language/ref/Graph.html) showing
+[types]($SetReplaceTypes.md) and [properties]($SetReplaceProperties.md) defined in *SetReplace* (including internal
+ones) and possible computation paths between them:
+
+```wl
+In[] := $SetReplaceTypeGraph
+```
+
+<img src="/Documentation/Images/$SetReplaceTypeGraph.png" width="478.2">
+
+It is a [`Graph`](https://reference.wolfram.com/language/ref/Graph.html) representation of a directed hypergraph with
+types and properties as vertices and implementations of translations and properties as edges.
+
+All vertices have the form `kind[name]`, where `kind` can be either [`SetReplaceType`](SetReplaceType.md),
+[`SetReplaceProperty`](SetReplaceProperty.md) or [`SetReplaceMethodImplementation`](SetReplaceMethodImplementation.md),
+and `name` is either a type specification or a symbol.

Documentation/SymbolsAndFunctions/TypeSystem/README.md

@@ -23,3 +23,20 @@ convert an object to a different type manually for persistence or optimization,
 
 [`SetReplaceObjectQ`](SetReplaceObjectQ.md) can be used to find out if an expression is a *SetReplace* object, and
 [`SetReplaceObjectType`](SetReplaceObjectType.md) can be used to determine its type.
+
+## Helper Symbols and Functions
+
+* Enumeration:
+  * [`$SetReplaceTypes`]($SetReplaceTypes.md)
+  * [`$SetReplaceProperties`]($SetReplaceProperties.md)
+  * [`$SetReplaceTypeGraph`]($SetReplaceTypeGraph.md) — a graph showing translations/property implementation paths
+    * Vertex heads: [`SetReplaceType`](SetReplaceType.md),
+                    [`SetReplaceProperty`](SetReplaceProperty.md),
+                    [`SetReplaceMethodImplementation`](SetReplaceMethodImplementation.md)
+* Introspection:
+  * [`SetReplaceObjectQ`](SetReplaceObjectQ.md)
+  * [`SetReplaceObjectType`](SetReplaceObjectType.md)
+* Conversion:
+  * [`SetReplaceTypeConvert`](SetReplaceTypeConvert.md) — change an object from one type to another
+* Types:
+  * [`Multihistory`](Multihistory.md) — a generic kind of types for computational systems

Documentation/SymbolsAndFunctions/TypeSystem/SetReplaceMethodImplementation.md

@@ -0,0 +1,8 @@
+###### [Symbols and Functions](/README.md#symbols-and-functions) > [Type System](README.md)
+
+# SetReplaceMethodImplementation
+
+**`SetReplaceMethodImplementation`** represents a (usually internal) implementation of either a translation or a
+property. It has the implementation symbol as the only argument.
+
+It is used in vertex names of [`$SetReplaceTypeGraph`]($SetReplaceTypeGraph.md).

Documentation/SymbolsAndFunctions/TypeSystem/SetReplaceProperty.md

@@ -0,0 +1,7 @@
+###### [Symbols and Functions](/README.md#symbols-and-functions) > [Type System](README.md)
+
+# SetReplaceProperty
+
+**`SetReplaceProperty`** represents a *SetReplace* property. It has the property symbol as its single argument.
+
+It is used in vertex names of [`$SetReplaceTypeGraph`]($SetReplaceTypeGraph.md).

Documentation/SymbolsAndFunctions/TypeSystem/SetReplaceType.md

@@ -0,0 +1,7 @@
+###### [Symbols and Functions](/README.md#symbols-and-functions) > [Type System](README.md)
+
+# SetReplaceType
+
+**`SetReplaceType`** represents a *SetReplace* type. It has the type specification as its single argument.
+
+It is used in vertex names of [`$SetReplaceTypeGraph`]($SetReplaceTypeGraph.md).

Kernel/A2$style.m → Kernel/A0$style.m

@@ -12,6 +12,15 @@
 
 PackageScope["$lightTheme"]
 
+PackageScope["$typeVertexStyle"]
+PackageScope["$typeVertexSize"]
+PackageScope["$propertyVertexStyle"]
+PackageScope["$propertyVertexSize"]
+PackageScope["$methodImplementationVertexStyle"]
+PackageScope["$methodImplementationVertexSize"]
+PackageScope["$typeGraphEdgeStyle"]
+PackageScope["$typeGraphLayout"]
+PackageScope["$typeGraphBackground"]
 PackageScope["$evolutionObjectIcon"]
 PackageScope["$destroyedEdgeStyle"]
 PackageScope["$createdEdgeStyle"]
@@ -81,6 +90,17 @@
 ];
 
 $styleNames = KeySort /@ KeySort @ <|
+  "TypeGraph" -> <|
+    "TypeVertexStyle" -> $typeVertexStyle,
+    "TypeVertexSize" -> $typeVertexSize,
+    "PropertyVertexStyle" -> $propertyVertexStyle,
+    "PropertyVertexSize" -> $propertyVertexSize,
+    "MethodImplementationVertexStyle" -> $methodImplementationVertexStyle,
+    "MethodImplementationVertexSize" -> $methodImplementationVertexSize,
+    "EdgeStyle" -> $typeGraphEdgeStyle,
+    "GraphLayout" -> $typeGraphLayout,
+    "Background" -> $typeGraphBackground
+  |>,
   "EvolutionObject" -> <|"Icon" -> $evolutionObjectIcon|>,
   "SpatialGraph" -> <|
     "DestroyedEdgeStyle" -> $destroyedEdgeStyle,
@@ -213,6 +233,17 @@
 $WolframPhysicsProjectPlotThemes = $SetReplacePlotThemes;
 
 style[$lightTheme] = <|
+  (* Type graph *)
+  $typeVertexStyle -> RGBColor[0.034, 0.30, 0.42],
+  $typeVertexSize -> Medium,
+  $propertyVertexStyle -> RGBColor[0.77, 0.83, 0.82],
+  $propertyVertexSize -> Medium,
+  $methodImplementationVertexStyle -> Black,
+  $methodImplementationVertexSize -> Small,
+  $typeGraphEdgeStyle -> GrayLevel[0.125],
+  $typeGraphLayout -> "SpringElectricalEmbedding",
+  $typeGraphBackground -> None,
+
   (* Evolution object *)
   $evolutionObjectIcon -> $graphIcon,
 

Kernel/A1$typeSystem.m

@@ -7,6 +7,11 @@
 PackageExport["SetReplaceObjectQ"]
 PackageExport["$SetReplaceTypes"]
 PackageExport["$SetReplaceProperties"]
+PackageExport["$SetReplaceTypeGraph"]
+
+PackageExport["SetReplaceType"]
+PackageExport["SetReplaceProperty"]
+PackageExport["SetReplaceMethodImplementation"]
 
 PackageScope["declareTypeTranslation"]
 PackageScope["declareRawProperty"]
@@ -16,6 +21,20 @@
 
 PackageScope["initializeTypeSystem"]
 
+(* SetReplaceType and SetReplaceProperty should be public because they are returned by SetReplaceTypeGraph. *)
+
+SetUsage @ "
+SetReplaceType[type$] represents a SetReplace type$.
+";
+
+SyntaxInformation[SetReplaceType] = {"ArgumentsPattern" -> {type_}};
+
+SetUsage @ "
+SetReplaceProperty[property$] represents a SetReplace property$.
+";
+
+SyntaxInformation[SetReplaceProperty] = {"ArgumentsPattern" -> {property_}};
+
 (* Object classes (like Multihistory) are expected to define their own objectType[...] implementation. This one is
    triggered if no other is found. *)
 
@@ -57,14 +76,10 @@
 (* Type translation functions can throw failure objects, in which case a message will be generated with a name
    corresponding to the Failure's type, and the keys passed to the message template. *)
 
-SetUsage @ "
-$SetReplaceTypes gives the list of all types defined in SetReplace.
-";
-
 $translations = {};
 
 declareTypeTranslation[function_, fromType_, toType_] :=
-  AppendTo[$translations, {function, type[fromType], type[toType]}];
+  AppendTo[$translations, {function, SetReplaceType[fromType], SetReplaceType[toType]}];
 
 (* This function is called after all declarations to combine translations to a Graph to allow multi-step conversions. *)
 
@@ -102,8 +117,9 @@
 
 typeConvert[toType_][object_] := ModuleScope[
   fromType = objectType[object];
-  If[!VertexQ[$typeGraph, type[#]], throw[Failure["unconvertibleType", <|"type" -> #|>]]] & /@ {fromType, toType};
-  path = FindShortestPath[$typeGraph, type[fromType], type[toType]];
+  If[!VertexQ[$typeGraph, SetReplaceType[#]], throw[Failure["unconvertibleType", <|"type" -> #|>]]] & /@
+    {fromType, toType};
+  path = FindShortestPath[$typeGraph, SetReplaceType[fromType], SetReplaceType[toType]];
   If[path === {} && toType =!= fromType,
     throw[Failure["noConversionPath", <|"from" -> fromType, "to" -> toType|>]];
   ];
@@ -119,14 +135,10 @@
    toProperty will need to be called as toProperty[args___][object_] or toProperty[object_, args___] where object can be
    of any type convertable to the implemented one. *)
 
-SetUsage @ "
-$SetReplaceProperties gives the list of all properties defined in SetReplace.
-";
-
 $rawProperties = {};
 
 declareRawProperty[implementationFunction_, fromType_, toProperty_Symbol] :=
-  AppendTo[$rawProperties, {implementationFunction, type[fromType], property[toProperty]}];
+  AppendTo[$rawProperties, {implementationFunction, SetReplaceType[fromType], SetReplaceProperty[toProperty]}];
 
 (* This function is called after all declarations to combine implementations to a Graph to allow multi-step conversions
    and to define DownValues for all property symbols. *)
@@ -136,7 +148,7 @@
   $propertyEvaluationFunctions = AssociationThread[newEdges -> (First /@ $rawProperties)];
   $typeGraph = EdgeAdd[$typeGraph, Keys[$propertyEvaluationFunctions]];
 
-  defineDownValuesForProperty /@ First /@ VertexList[$typeGraph, _property];
+  defineDownValuesForProperty /@ First /@ VertexList[$typeGraph, _SetReplaceProperty];
 ];
 
 (* declareCompositeProperty declares an implementation for a property that takes other properties as arguments. The
@@ -166,17 +178,66 @@
 freeFromInternalSymbolsQ[expr_] :=
   NoneTrue[Context /@ Cases[expr, _Symbol, {0, Infinity}, Heads -> True], StringMatchQ[#, "SetReplace`" ~~ __] &];
 
-initializeConstants[] :=
+SetUsage @ "
+$SetReplaceTypes gives the list of all types defined in SetReplace.
+";
+
+SetUsage @ "
+$SetReplaceProperties gives the list of all properties defined in SetReplace.
+";
+
+initializeTypeAndPropertyLists[] :=
   {$SetReplaceTypes, $SetReplaceProperties} =
-    Select[freeFromInternalSymbolsQ] /@ (Sort[First /@ VertexList[$typeGraph, #]] &) /@ {_type, _property};
+    Sort @ Select[freeFromInternalSymbolsQ][First /@ VertexList[$typeGraph, #]] & /@
+      {_SetReplaceType, _SetReplaceProperty};
+
+SetUsage @ "
+$SetReplaceTypeGraph gives the Graph of types and properties implemented in SetReplace.
+";
+
+SetUsage @ "
+SetReplaceMethodImplementation[symbol$] represents an implementation of a SetReplace method, such as a translation or \
+property.
+";
+
+SyntaxInformation[SetReplaceMethodImplementation] = {"SetReplaceMethodImplementation" -> {symbol_}};
+
+typeGraphVertexLabel[kind_, name_] :=
+  If[!freeFromInternalSymbolsQ[name] || kind === SetReplaceMethodImplementation, Placed[#, Tooltip] &, Identity] @
+    If[kind === SetReplaceProperty, ToString[#] <> "[\[Ellipsis]]" &, Identity] @
+      name;
+
+insertImplementationVertex[inputEdge : DirectedEdge[from_, to_]] := ModuleScope[
+  implementationSource = If[MatchQ[to, _SetReplaceProperty], $propertyEvaluationFunctions, $translationFunctions];
+  {DirectedEdge[from, SetReplaceMethodImplementation[implementationSource[inputEdge]]],
+   DirectedEdge[SetReplaceMethodImplementation[implementationSource[inputEdge]], to]}
+];
+
+initializePublicTypeGraph[] := Module[{extendedGraphEdges},
+  extendedGraphEdges = Catenate[insertImplementationVertex /@ EdgeList[$typeGraph]];
+  $SetReplaceTypeGraph = Graph[
+    DirectedEdge @@@ extendedGraphEdges,
+    VertexLabels -> kind_[name_] :> typeGraphVertexLabel[kind, name],
+    VertexStyle -> {_SetReplaceType -> style[$lightTheme][$typeVertexStyle],
+                    _SetReplaceProperty -> style[$lightTheme][$propertyVertexStyle],
+                    _SetReplaceMethodImplementation -> style[$lightTheme][$methodImplementationVertexStyle]},
+    VertexSize -> {_SetReplaceType -> style[$lightTheme][$typeVertexSize],
+                   _SetReplaceProperty -> style[$lightTheme][$propertyVertexSize],
+                   _SetReplaceMethodImplementation -> style[$lightTheme][$methodImplementationVertexSize]},
+    EdgeStyle -> style[$lightTheme][$typeGraphEdgeStyle],
+    GraphLayout -> style[$lightTheme][$typeGraphLayout],
+    Background -> style[$lightTheme][$typeGraphBackground],
+    PerformanceGoal -> "Quality"]
+];
 
 (* This function is called in init.m after all other files are loaded. *)
 
 initializeTypeSystem[] := (
   initializeTypeSystemTranslations[];
   initializeRawProperties[];
   initializeCompositeProperties[];
-  initializeConstants[];
+  initializeTypeAndPropertyLists[];
+  initializePublicTypeGraph[];
 );
 
 (* defineDownValuesForProperty defines both the operator form and the normal form for a property symbol. The DownValues
@@ -232,8 +293,8 @@ case a property is used not as an operator form (in which case expected and actu
 
   propertyImplementation[publicProperty][args___][object_] := ModuleScope[
     fromType = objectType[object];
-    If[!VertexQ[$typeGraph, type[fromType]], throw[Failure["unknownType", <|"type" -> fromType|>]]];
-    path = FindShortestPath[$typeGraph, type[fromType], property[publicProperty]];
+    If[!VertexQ[$typeGraph, SetReplaceType[fromType]], throw[Failure["unknownType", <|"type" -> fromType|>]]];
+    path = FindShortestPath[$typeGraph, SetReplaceType[fromType], SetReplaceProperty[publicProperty]];
     If[path === {},
       throw[Failure["noPropertyPath", <|"type" -> fromType, "property" -> publicProperty|>]];
     ];

Tests/typeSystem.wlt

@@ -72,11 +72,13 @@
       realDescription[][real_Real] := "I am a real " <> ToString[real] <> ".";
       realDescription[args__][_] := throwInvalidPropertyArgumentCount[0, Length[{args}]];
 
+      Unprotect[$SetReplaceTypeGraph];
       Unprotect[$SetReplaceProperties];
       Unprotect[$SetReplaceTypes];
       initializeTypeSystem[];
       Protect[$SetReplaceTypes];
       Protect[$SetReplaceProperties];
+      Protect[$SetReplaceTypeGraph];
     ),
     "tests" -> {
       (* Type and property lists *)
@@ -85,6 +87,17 @@
       VerificationTest[$SetReplaceTypes, Sort @ {"String", "Expression", "HalfInteger", "EvenInteger", "Real"}],
       VerificationTest[$SetReplaceProperties, Sort @ {description, multipliedHalf}],
 
+      VerificationTest[GraphQ @ $SetReplaceTypeGraph],
+      VerificationTest[ContainsOnly[Head /@ VertexList[$SetReplaceTypeGraph],
+                       {SetReplaceType, SetReplaceProperty, SetReplaceMethodImplementation}]],
+      VerificationTest[
+        Cases[
+          EdgeList[$SetReplaceTypeGraph],
+          Except[
+            DirectedEdge[_SetReplaceType | _SetReplaceProperty, _SetReplaceMethodImplementation] |
+              DirectedEdge[_SetReplaceMethodImplementation, _SetReplaceType | _SetReplaceProperty]]],
+        {}],
+
       (* Type querying *)
       VerificationTest[SetReplaceObjectType[evenInteger[4]], "EvenInteger"],
       VerificationTest[SetReplaceObjectType[2.4], "Real"],