diff --git a/lib/haskell/natural4/src/LS/Interpreter.hs b/lib/haskell/natural4/src/LS/Interpreter.hs index 37e8fcdfe..16289986a 100644 --- 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 index 5483d58c6..c35d0bbf2 100644 --- 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