clarify class outputs in Org.hs

smucclaw · Aug 7, 2023 · 3c51d2c · 3c51d2c
1 parent d710808
commit 3c51d2c
Show file tree

Hide file tree

Showing 2 changed files with 31 additions and 16 deletions.
diff --git a/lib/haskell/natural4/src/LS/Interpreter.hs b/lib/haskell/natural4/src/LS/Interpreter.hs
@@ -141,7 +141,12 @@ symbolTable _iopts rs =
 
 -- | A map of all the classes we know about.
 --
+-- Currently this function returns both IS-A and HAS-A relationships for a given class.
+--
 -- Classes can contain other classes. Here the hierarchy represents the "has-a" relationship, conspicuous when a DECLARE HAS HAS HAS.
+--
+-- Most of the time, though, classes just contain attributes.
+--
 -- The output of this function is exposed in the `classtable` attribute of the `l4i` record.
 classHierarchy :: [Rule] -> ClsTab
 classHierarchy rs =
@@ -152,20 +157,20 @@ classHierarchy rs =
                             ( (listToMaybe (maybeToList ts1inf <> maybeToList ts2inf)
                               ,ts1s <> ts2s)
                             , CT $ clstab1 <> clstab2))
-  [ (thisclass, (classtype, attributes))
+  [ (thisclass, (superclass, attributes))
   | r@TypeDecl{} <- rs
   , let thisclass = mt2text (name r)
-        classtype = (super r, [])
+        superclass = (Just $ defaultToSuperType $ super r, [])
         attributes = classHierarchy (has r)
-  , (Just (SimpleType _ _), _) <- [classtype]
+  , (Just (SimpleType _ _), _) <- [superclass] -- exclude enums
   ]
 
 -- | A graph of all the classes we know about.
 --
--- redraw the class hierarchy as a rooted graph, where the fst in the pair contains all the breadcrumbs to the current node. root to the right.
+-- redraw the class hierarchy as a rooted graph, where the fst in the pair contains all the breadcrumbs to the current node. root to the right. I think this is overproducing a bit, because it's considering the attributes.
 classGraph :: ClsTab -> [EntityType] -> [([EntityType], TypedClass)]
 classGraph (CT ch) ancestors = concat
-  [ (nodePath, (_itypesig, childct)) : classGraph childct nodePath
+  [ pure (nodePath, (_itypesig, childct))
   | (childname, (_itypesig, childct)) <- Map.toList ch
   , let nodePath = childname : ancestors
   ]

diff --git a/lib/haskell/natural4/src/LS/XPile/Org.hs b/lib/haskell/natural4/src/LS/XPile/Org.hs
@@ -22,7 +22,7 @@ import LS.Interpreter
       extractEnums,
       defaultToSuperClass, defaultToSuperType,
       )
-import LS.PrettyPrinter ( tildes, (</>), vvsep, myrender )
+
 import LS.RelationalPredicates ( partitionExistentials, getBSR )
 import LS.Rule
     ( Interpreted(classtable, scopetable),
@@ -34,11 +34,13 @@ import LS.Rule
 import LS.Types ( unCT
                 , TypeSig (InlineEnum, SimpleType)
                 , ParamType (TOne, TOptional)
+                , ClassHierarchyMap
                 )
 import LS.PrettyPrinter
+    ( myrender, vvsep, (</>), tildes, (<//>), snake_case )
 
 import Prettyprinter
-    ( vsep, viaShow, hsep, emptyDoc, (<+>), Pretty(pretty), Doc )
+    ( vsep, viaShow, hsep, emptyDoc, (<+>), Pretty(pretty), Doc, indent, line )
 import Text.Pretty.Simple ( pShowNoColor )
 import Data.HashMap.Strict qualified as Map
 import Data.Maybe (mapMaybe)
@@ -69,17 +71,25 @@ musings l4i rs =
       decisionGraph = ruleDecisionGraph l4i rs
   in vvsep [ "* musings"
            , "** Global Facts" </> srchs (globalFacts l4i)
+
            , "** Class Hierarchy"
-           , vvsep [ vvsep [ "*** Class:" <+> pretty cname <>
-                             if null (Prelude.tail cname) then emptyDoc
-                             else hsep (" belongs to" : (pretty <$> Prelude.tail cname))
-                           , if null cchild
-                             then emptyDoc
-                             else "**** extends" <+> viaShow (defaultToSuperType $ fst . fst $ cchild) <+> "with new attributes"
-                                  </> srchs (snd cchild)
-                           , "**** deets" </> srchs cname
+           , vvsep [ vvsep [ "*** Class:" <+> pretty fullyQualifiedClassName <+>
+                             "extends" <+> viaShow superclass <>
+                             if not $ null (unCT attrs)
+                             then " with new attributes"
+                             </> let prettyClassAttrs :: ClassHierarchyMap -> Doc ann
+                                     prettyClassAttrs chmap =
+                                       vsep [ "-" <+> pretty attr <+> "::" <+> viaShow inferrableTypeSig
+                                              <> if not (null (unCT attrchildren))
+                                                 then line <> indent 2 (prettyClassAttrs (unCT attrchildren))
+                                                 else emptyDoc
+                                            | (attr, (inferrableTypeSig, attrchildren)) <- Map.toList chmap
+                                            ]
+                                 in prettyClassAttrs (unCT attrs)
+                             else emptyDoc
                            ]
-                   | (cname, cchild) <- cg ]
+                   | (cname, (superclass, attrs)) <- cg
+                   , let fullyQualifiedClassName = Text.intercalate "." (reverse cname) ]
            , "** The entire classgraph"
            , srchs cg