Merge pull request #4653 from unisonweb/cp/debug-term

Add `debug.term` `debug.type` for debugging

unison-cli/src/Unison/Codebase/Editor/HandleInput.hs

@@ -66,6 +66,7 @@ import Unison.Codebase.Editor.HandleInput.AuthLogin (authLogin)
 import Unison.Codebase.Editor.HandleInput.Branch (handleBranch)
 import Unison.Codebase.Editor.HandleInput.BranchRename (handleBranchRename)
 import Unison.Codebase.Editor.HandleInput.Branches (handleBranches)
+import Unison.Codebase.Editor.HandleInput.DebugDefinition qualified as DebugDefinition
 import Unison.Codebase.Editor.HandleInput.DeleteBranch (handleDeleteBranch)
 import Unison.Codebase.Editor.HandleInput.DeleteProject (handleDeleteProject)
 import Unison.Codebase.Editor.HandleInput.EditNamespace (handleEditNamespace)
@@ -1141,6 +1142,8 @@ loop e = do
                 traceM $ show name ++ ",Type," ++ Text.unpack (Reference.toText r)
               for_ (Relation.toList . Branch.deepTerms $ rootBranch0) \(r, name) ->
                 traceM $ show name ++ ",Term," ++ Text.unpack (Referent.toText r)
+            DebugTermI isVerbose hqName -> DebugDefinition.debugTerm isVerbose hqName
+            DebugTypeI hqName -> DebugDefinition.debugDecl hqName
             DebugClearWatchI {} ->
               Cli.runTransaction Codebase.clearWatches
             DebugDoctorI {} -> do
@@ -1355,6 +1358,11 @@ inputDescription input =
     DebugDoctorI {} -> wat
     DebugDumpNamespaceSimpleI {} -> wat
     DebugDumpNamespacesI {} -> wat
+    DebugTermI verbose hqName ->
+      if verbose
+        then pure ("debug.term.verbose " <> HQ.toText hqName)
+        else pure ("debug.term " <> HQ.toText hqName)
+    DebugTypeI hqName -> pure ("debug.type " <> HQ.toText hqName)
     DebugNameDiffI {} -> wat
     DebugNumberedArgsI {} -> wat
     DebugTabCompletionI _input -> wat

unison-cli/src/Unison/Codebase/Editor/HandleInput/DebugDefinition.hs

@@ -0,0 +1,59 @@
+module Unison.Codebase.Editor.HandleInput.DebugDefinition
+  ( debugTerm,
+    debugDecl,
+  )
+where
+
+import Control.Monad.Reader
+import Unison.Cli.Monad (Cli)
+import Unison.Cli.Monad qualified as Cli
+import Unison.Cli.NamesUtils qualified as Cli
+import Unison.Codebase qualified as Codebase
+import Unison.Codebase.Editor.Output (Output (..))
+import Unison.ConstructorReference (GConstructorReference (ConstructorReference))
+import Unison.DataDeclaration.ConstructorId (ConstructorId)
+import Unison.HashQualified qualified as HQ
+import Unison.Name (Name)
+import Unison.NamesWithHistory qualified as Names
+import Unison.Prelude
+import Unison.Reference (TermReference, TypeReference)
+import Unison.Reference qualified as Reference
+import Unison.Referent qualified as Referent
+
+debugTermReference :: Bool -> TermReference -> Cli ()
+debugTermReference verbose ref = do
+  Cli.Env {codebase} <- ask
+  case ref of
+    Reference.DerivedId refId -> do
+      Cli.runTransaction (Codebase.getTerm codebase refId) >>= \case
+        Nothing -> Cli.respond $ TermNotFound' (Reference.toShortHash ref)
+        Just term -> do
+          Cli.respond $ DebugTerm verbose (Right term)
+    Reference.Builtin builtinTxt -> do
+      Cli.respond $ DebugTerm verbose (Left builtinTxt)
+
+debugTypeReference :: TypeReference -> Maybe ConstructorId -> Cli ()
+debugTypeReference ref mayConId = do
+  Cli.Env {codebase} <- ask
+  case ref of
+    Reference.DerivedId refId -> do
+      Cli.runTransaction (Codebase.getTypeDeclaration codebase refId) >>= \case
+        Nothing -> Cli.respond $ TypeNotFound' (Reference.toShortHash ref)
+        Just decl -> do
+          Cli.respond $ DebugDecl (Right decl) mayConId
+    Reference.Builtin builtinTxt -> do
+      Cli.respond $ DebugDecl (Left builtinTxt) mayConId
+
+debugTerm :: Bool -> HQ.HashQualified Name -> Cli ()
+debugTerm verbose hqName = do
+  names <- Cli.currentNames
+  let matches = Names.lookupHQTerm Names.IncludeSuffixes hqName names
+  for_ matches \case
+    Referent.Ref termReference -> debugTermReference verbose termReference
+    Referent.Con (ConstructorReference typeRef conId) _conTyp -> debugTypeReference typeRef (Just conId)
+
+debugDecl :: HQ.HashQualified Name -> Cli ()
+debugDecl hqName = do
+  names <- Cli.currentNames
+  let matches = Names.lookupHQType Names.IncludeSuffixes hqName names
+  for_ matches \typeRef -> debugTypeReference typeRef Nothing

unison-cli/src/Unison/Codebase/Editor/Input.hs

@@ -220,6 +220,8 @@ data Input
   | DebugTypecheckedUnisonFileI
   | DebugDumpNamespacesI
   | DebugDumpNamespaceSimpleI
+  | DebugTermI (Bool {- Verbose mode -}) (HQ.HashQualified Name)
+  | DebugTypeI (HQ.HashQualified Name)
   | DebugClearWatchI
   | DebugDoctorI
   | DebugNameDiffI ShortCausalHash ShortCausalHash

unison-cli/src/Unison/Codebase/Editor/Output.hs

@@ -47,6 +47,7 @@ import Unison.Codebase.ShortCausalHash (ShortCausalHash)
 import Unison.Codebase.ShortCausalHash qualified as SCH
 import Unison.Codebase.Type (GitError)
 import Unison.CommandLine.InputPattern qualified as Input
+import Unison.DataDeclaration qualified as DD
 import Unison.DataDeclaration.ConstructorId (ConstructorId)
 import Unison.HashQualified qualified as HQ
 import Unison.HashQualified' qualified as HQ'
@@ -324,6 +325,8 @@ data Output
   | DisplayDebugCompletions [Completion.Completion]
   | DebugDisplayFuzzyOptions Text [String {- arg description, options -}]
   | DebugFuzzyOptionsNoResolver
+  | DebugTerm (Bool {- verbose mode -}) (Either (Text {- A builtin hash -}) (Term Symbol Ann))
+  | DebugDecl (Either (Text {- A builtin hash -}) (DD.Decl Symbol Ann)) (Maybe ConstructorId {- If 'Just' we're debugging a constructor of the given decl -})
   | ClearScreen
   | PulledEmptyBranch (ReadRemoteNamespace Share.RemoteProjectBranch)
   | CreatedProject Bool {- randomly-generated name? -} ProjectName
@@ -569,6 +572,8 @@ isFailure o = case o of
   DisplayDebugCompletions {} -> False
   DebugDisplayFuzzyOptions {} -> False
   DebugFuzzyOptionsNoResolver {} -> True
+  DebugTerm {} -> False
+  DebugDecl {} -> False
   DisplayDebugNameDiff {} -> False
   ClearScreen -> False
   PulledEmptyBranch {} -> False

unison-cli/src/Unison/CommandLine/InputPatterns.hs

@@ -2275,6 +2275,45 @@ debugDumpNamespaceSimple =
     "Dump the namespace to a text file"
     (const $ Right Input.DebugDumpNamespaceSimpleI)
 
+debugTerm :: InputPattern
+debugTerm =
+  InputPattern
+    "debug.term.abt"
+    []
+    I.Hidden
+    [("term", Required, exactDefinitionTermQueryArg)]
+    "View debugging information for a given term."
+    ( \case
+        [thing] -> fmap (Input.DebugTermI False) $ parseHashQualifiedName thing
+        _ -> Left (I.help debugTerm)
+    )
+
+debugTermVerbose :: InputPattern
+debugTermVerbose =
+  InputPattern
+    "debug.term.abt.verbose"
+    []
+    I.Hidden
+    [("term", Required, exactDefinitionTermQueryArg)]
+    "View verbose debugging information for a given term."
+    ( \case
+        [thing] -> fmap (Input.DebugTermI True) $ parseHashQualifiedName thing
+        _ -> Left (I.help debugTermVerbose)
+    )
+
+debugType :: InputPattern
+debugType =
+  InputPattern
+    "debug.type.abt"
+    []
+    I.Hidden
+    [("type", Required, exactDefinitionTypeQueryArg)]
+    "View debugging information for a given type."
+    ( \case
+        [thing] -> fmap (Input.DebugTypeI) $ parseHashQualifiedName thing
+        _ -> Left (I.help debugType)
+    )
+
 debugClearWatchCache :: InputPattern
 debugClearWatchCache =
   InputPattern
@@ -3001,6 +3040,9 @@ validInputs =
       debugDoctor,
       debugDumpNamespace,
       debugDumpNamespaceSimple,
+      debugTerm,
+      debugTermVerbose,
+      debugType,
       debugFileHashes,
       debugNameDiff,
       debugNumberedArgs,

unison-cli/src/Unison/CommandLine/OutputMessages.hs

@@ -21,15 +21,18 @@ import Data.Set qualified as Set
 import Data.Set.NonEmpty (NESet)
 import Data.Text qualified as Text
 import Data.Text.Encoding qualified as Text
+import Data.Text.Lazy qualified as TL
 import Data.Time (UTCTime, getCurrentTime)
 import Data.Tuple (swap)
 import Data.Tuple.Extra (dupe)
 import Data.Void (absurd)
+import Debug.RecoverRTTI qualified as RTTI
 import Network.HTTP.Types qualified as Http
 import Servant.Client qualified as Servant
 import System.Console.ANSI qualified as ANSI
 import System.Console.Haskeline.Completion qualified as Completion
 import System.Directory (canonicalizePath, getHomeDirectory)
+import Text.Pretty.Simple (pShowNoColor, pStringNoColor)
 import U.Codebase.Branch (NamespaceStats (..))
 import U.Codebase.Branch.Diff (NameChanges (..))
 import U.Codebase.HashTags (CausalHash (..))
@@ -1772,6 +1775,21 @@ notifyUser dir = \case
   IntegrityCheck result -> pure $ case result of
     NoIntegrityErrors -> "🎉 No issues detected 🎉"
     IntegrityErrorDetected ns -> prettyPrintIntegrityErrors ns
+  DebugTerm verbose builtinOrTerm -> pure $ case builtinOrTerm of
+    Left builtin -> "Builtin term: ##" <> P.text builtin
+    Right trm ->
+      if verbose
+        then P.text . TL.toStrict . pStringNoColor $ RTTI.anythingToString trm
+        else P.shown trm
+  DebugDecl typ mayConId -> do
+    let constructorMsg = case mayConId of
+          Nothing -> ""
+          Just conId -> "Constructor #" <> P.shown conId <> " of the following type:\n"
+    pure $
+      constructorMsg
+        <> case typ of
+          Left builtinTxt -> "Builtin type: ##" <> P.text builtinTxt
+          Right decl -> either (P.text . TL.toStrict . pShowNoColor) (P.text . TL.toStrict . pShowNoColor) decl
   DisplayDebugNameDiff NameChanges {termNameAdds, termNameRemovals, typeNameAdds, typeNameRemovals} -> do
     let referentText =
           -- We don't use the constructor type in the actual output here, so there's no
@@ -2748,7 +2766,7 @@ renderEditConflicts ppe Patch {..} = do
                  then "deprecated and also replaced with"
                  else "replaced with"
              )
-            `P.hang` P.lines replacements
+          `P.hang` P.lines replacements
     formatTermEdits ::
       (Reference.TermReference, Set TermEdit.TermEdit) ->
       Numbered Pretty
@@ -2763,7 +2781,7 @@ renderEditConflicts ppe Patch {..} = do
                  then "deprecated and also replaced with"
                  else "replaced with"
              )
-            `P.hang` P.lines replacements
+          `P.hang` P.lines replacements
     formatConflict ::
       Either
         (Reference, Set TypeEdit.TypeEdit)

unison-cli/unison-cli.cabal

@@ -50,6 +50,7 @@ library
       Unison.Codebase.Editor.HandleInput.Branch
       Unison.Codebase.Editor.HandleInput.Branches
       Unison.Codebase.Editor.HandleInput.BranchRename
+      Unison.Codebase.Editor.HandleInput.DebugDefinition
       Unison.Codebase.Editor.HandleInput.DeleteBranch
       Unison.Codebase.Editor.HandleInput.DeleteProject
       Unison.Codebase.Editor.HandleInput.EditNamespace

unison-src/transcripts/debug-definitions.md

@@ -0,0 +1,28 @@
+```ucm:hide
+.> builtins.merge
+```
+
+```unison:hide
+x = 30
+
+y : Nat
+y = 
+  z = x + 2
+  z + 10
+
+structural type Optional a = Some a | None
+
+ability Ask a where
+  ask : a
+```
+
+```ucm
+.> add
+.> debug.term.abt Nat.+
+.> debug.term.abt y
+.> debug.term.abt Some
+.> debug.term.abt ask
+.> debug.type.abt Nat
+.> debug.type.abt Optional
+.> debug.type.abt Ask
+```