Show help about constructors

GaloisInc · Jan 22, 2024 · c7f12ad · c7f12ad
1 parent a0179c0
commit c7f12ad
Showing 1 changed file with 34 additions and 22 deletions.
diff --git a/src/Cryptol/REPL/Help.hs b/src/Cryptol/REPL/Help.hs
@@ -34,18 +34,20 @@ helpForNamed qname =
          rnEnv  = M.mctxNames  fe
          disp   = M.mctxNameDisp fe
 
-         vNames = M.lookupListNS M.NSValue  qname rnEnv
-         tNames = M.lookupListNS M.NSType   qname rnEnv
-         mNames = M.lookupListNS M.NSModule qname rnEnv
+         vNames = M.lookupListNS M.NSValue       qname rnEnv
+         cNames = M.lookupListNS M.NSConstructor qname rnEnv
+         tNames = M.lookupListNS M.NSType        qname rnEnv
+         mNames = M.lookupListNS M.NSModule      qname rnEnv
 
      let helps = map (showTypeHelp params env disp) tNames ++
                  map (showValHelp params env disp qname) vNames ++
+                 map (showConHelp env disp qname) cNames ++
                  map (showModHelp env disp) mNames
 
          separ = rPutStrLn "            ---------"
      sequence_ (intersperse separ helps)
 
-     when (null (vNames ++ tNames ++ mNames)) $
+     when (null (vNames ++ cNames ++ tNames ++ mNames)) $
        rPrint $ "Undefined name:" <+> pp qname
 
 
@@ -245,7 +247,13 @@ showTypeHelp ctxparams env nameEnv name =
        let decl = pp nt $$
                   vcat
                     [ pp x <+> text ":" <+> pp t
-                    | (x,t) <- T.newtypeConTypes nt ]
+                    | case T.ntDef nt of
+                        T.Struct {} -> False
+                         -- Don't show constructor, as it will be shown
+                         -- separately
+                        _ -> True
+                    , (x,t) <- T.newtypeConTypes nt
+                    ]
        return $ doShowTyHelp nameEnv decl (T.ntDoc nt)
 
   fromPrimType =
@@ -296,14 +304,34 @@ doShowTyHelp nameEnv decl doc =
      rPrint (runDoc nameEnv (nest 4 decl))
      doShowDocString doc
 
+showConHelp :: M.IfaceDecls -> NameDisp -> P.PName -> T.Name -> REPL ()
+showConHelp env nameEnv qname name =
+  fromMaybe (noInfo nameEnv name) (Map.lookup name allCons)
+  where
+  allCons = foldr addCons mempty (M.ifNewtypes env)
+    where
+    getDocs nt =
+      case T.ntDef nt of
+        T.Struct {} -> [ T.ntDoc nt ]
+        T.Enum cs   -> map T.ecDoc cs
+
+    addCons nt mp = foldr (addCon nt) mp
+                      (zip (T.newtypeConTypes nt) (getDocs nt))
+    addCon nt ((c,t),d) = Map.insert c $
+      do rPutStrLn ""
+         rPrint (runDoc nameEnv $ vcat
+            [ "Constructor of" <+> pp (T.ntName nt)
+            , indent 4 $ hsep [ pp qname, ":", pp t ]
+            ])
+         doShowDocString d
 
 
 showValHelp ::
   M.ModContextParams -> M.IfaceDecls -> NameDisp -> P.PName -> T.Name -> REPL ()
 
 showValHelp ctxparams env nameEnv qname name =
   fromMaybe (noInfo nameEnv name)
-            (msum [ fromDecl, fromNewtype, fromParameter ])
+            (msum [ fromDecl, fromParameter ])
   where
   fromDecl =
     do M.IfaceDecl { .. } <- Map.lookup name (M.ifDecls env)
@@ -324,22 +352,6 @@ showValHelp ctxparams env nameEnv qname name =
 
             doShowDocString ifDeclDoc
 
-  fromNewtype = Map.lookup name allCons
-
-  allCons = foldr addCons mempty (M.ifNewtypes env)
-    where
-    getDocs nt =
-      case T.ntDef nt of
-        T.Struct {} -> [ T.ntDoc nt ]
-        T.Enum cs   -> map T.ecDoc cs
-
-    addCons nt mp = foldr addCon mp
-                      (zip (T.newtypeConTypes nt) (getDocs nt))
-    addCon ((c,t),d) = Map.insert c $
-      do rPutStrLn ""
-         rPrint (runDoc nameEnv $ indent 4 $ hsep [ pp c, ":", pp t ])
-         doShowDocString d
-
   allParamNames =
     case ctxparams of
       M.NoParams -> mempty