Simplified public interface to type/term printer

2024-10-05 06:07:21 +03:00 · 2022-10-27 21:21:18 -04:00 · 2022-10-27 21:21:18 -04:00 · 68e94f9a24
commit 68e94f9a24
parent 7a3808e656
9 changed files with 71 additions and 66 deletions
--- a/parser-typechecker/src/Unison/Syntax/DeclPrinter.hs
+++ b/parser-typechecker/src/Unison/Syntax/DeclPrinter.hs
@ -17,12 +17,12 @@ import qualified Unison.Name as Name
 import Unison.Prelude
 import Unison.PrettyPrintEnv (PrettyPrintEnv)
 import qualified Unison.PrettyPrintEnv as PPE
-import Unison.PrettyPrintEnv.MonadPretty (runPretty)
 import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (..))
 import Unison.Reference (Reference (DerivedId))
 import qualified Unison.Referent as Referent
 import qualified Unison.Result as Result
 import Unison.Syntax.NamePrinter (styleHashQualified'')
+import Unison.Syntax.TypePrinter (runPretty)
 import qualified Unison.Syntax.TypePrinter as TypePrinter
 import qualified Unison.Term as Term
 import qualified Unison.Type as Type
--- a/parser-typechecker/src/Unison/Syntax/TermPrinter.hs
+++ b/parser-typechecker/src/Unison/Syntax/TermPrinter.hs
@ -2,7 +2,7 @@
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ViewPatterns #-}

-module Unison.Syntax.TermPrinter where
+module Unison.Syntax.TermPrinter (emptyAc, pretty, prettyBlock, prettyBlock', pretty', prettyBinding, prettyBinding', pretty0, runPretty) where

 import Control.Lens (unsnoc, (^.))
 import Control.Monad.State (evalState)
@ -779,20 +779,22 @@ a + b = ...

 -}
 prettyBinding ::
-  MonadPretty v m =>
+  Var v =>
+  PrettyPrintEnv ->
  HQ.HashQualified Name ->
  Term2 v at ap v a ->
-  m (Pretty SyntaxText)
-prettyBinding = prettyBinding0 $ ac (-1) Block Map.empty MaybeDoc
+  Pretty SyntaxText
+prettyBinding ppe n = runPretty ppe . prettyBinding0 (ac (-1) Block Map.empty MaybeDoc) n

 prettyBinding' ::
-  MonadPretty v m =>
+  Var v =>
+  PrettyPrintEnv ->
  Width ->
  HQ.HashQualified Name ->
  Term v a ->
-  m ColorText
-prettyBinding' width v t =
-  PP.render width . PP.syntaxToColor <$> prettyBinding v t
+  ColorText
+prettyBinding' ppe width v t =
+  PP.render width . PP.syntaxToColor $ prettyBinding ppe v t

 prettyBinding0 ::
  MonadPretty v m =>
@ -1885,18 +1887,18 @@ toDocEmbedSignatureLink ppe (App' (Ref' r) (Delay' (Referent' tm)))
  | nameEndsWith ppe ".docEmbedSignatureLink" r = Just tm
 toDocEmbedSignatureLink _ _ = Nothing

-toDocEmbedAnnotation :: PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
-toDocEmbedAnnotation ppe (App' (Ref' r) tm)
-  | nameEndsWith ppe ".docEmbedAnnotation" r = Just tm
-toDocEmbedAnnotation _ _ = Nothing
+-- toDocEmbedAnnotation :: PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
+-- toDocEmbedAnnotation ppe (App' (Ref' r) tm)
+--   | nameEndsWith ppe ".docEmbedAnnotation" r = Just tm
+-- toDocEmbedAnnotation _ _ = Nothing

-toDocEmbedAnnotations :: PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe [Term3 v PrintAnnotation]
-toDocEmbedAnnotations ppe (App' (Ref' r) (List' tms))
-  | nameEndsWith ppe ".docEmbedAnnotations" r =
-    case [ann | Just ann <- toDocEmbedAnnotation ppe <$> toList tms] of
-      tms' | length tms' == length tms -> Just tms'
-      _ -> Nothing
-toDocEmbedAnnotations _ _ = Nothing
+-- toDocEmbedAnnotations :: PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe [Term3 v PrintAnnotation]
+-- toDocEmbedAnnotations ppe (App' (Ref' r) (List' tms))
+--   | nameEndsWith ppe ".docEmbedAnnotations" r =
+--     case [ann | Just ann <- toDocEmbedAnnotation ppe <$> toList tms] of
+--       tms' | length tms' == length tms -> Just tms'
+--       _ -> Nothing
+-- toDocEmbedAnnotations _ _ = Nothing

 toDocSignature :: Ord v => PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe [Referent]
 toDocSignature ppe (App' (Ref' r) (List' tms))
--- a/parser-typechecker/src/Unison/Syntax/TypePrinter.hs
+++ b/parser-typechecker/src/Unison/Syntax/TypePrinter.hs
@ -13,6 +13,7 @@ module Unison.Syntax.TypePrinter
    prettySignaturesCTCollapsed,
    prettySignaturesAlt,
    prettySignaturesAlt',
+    runPretty,
  )
 where

@ -181,26 +182,29 @@ fmt = PP.withSyntax

 -- todo: provide sample output in comment
 prettySignaturesCT ::
-  MonadPretty v m =>
+  Var v =>
+  PrettyPrintEnv ->
  [(Referent, HashQualified Name, Type v a)] ->
-  m [Pretty ColorText]
-prettySignaturesCT ts = map PP.syntaxToColor <$> prettySignaturesST ts
+  [Pretty ColorText]
+prettySignaturesCT ppe ts = map PP.syntaxToColor $ prettySignaturesST ppe ts

 prettySignaturesCTCollapsed ::
-  MonadPretty v m =>
+  Var v =>
+  PrettyPrintEnv ->
  [(Referent, HashQualified Name, Type v a)] ->
-  m (Pretty ColorText)
-prettySignaturesCTCollapsed ts =
+  Pretty ColorText
+prettySignaturesCTCollapsed ppe ts =
  PP.lines
    . map PP.group
-    <$> prettySignaturesCT ts
+    $ prettySignaturesCT ppe ts

 prettySignaturesST ::
-  MonadPretty v m =>
+  Var v =>
+  PrettyPrintEnv ->
  [(Referent, HashQualified Name, Type v a)] ->
-  m [Pretty SyntaxText]
-prettySignaturesST ts =
-  PP.align <$> traverse (\(r, hq, typ) -> (name r hq,) <$> sig typ) ts
+  [Pretty SyntaxText]
+prettySignaturesST ppe ts =
+  PP.align . runPretty ppe $ traverse (\(r, hq, typ) -> (name r hq,) <$> sig typ) ts
  where
    name r hq =
      styleHashQualified'' (fmt $ S.TermReference r) hq
@ -211,16 +215,16 @@ prettySignaturesST ts =

 -- todo: provide sample output in comment; different from prettySignatures'
 prettySignaturesAlt' ::
-  forall a v m.
-  MonadPretty v m =>
+  Var v =>
+  PrettyPrintEnv ->
  [([HashQualified Name], Type v a)] ->
-  m [Pretty ColorText]
-prettySignaturesAlt' ts =
+  [Pretty ColorText]
+prettySignaturesAlt' ppe ts = runPretty ppe $
  do
    ts' <- traverse f ts
    pure $ map PP.syntaxToColor $ PP.align ts'
  where
-    f :: ([HashQualified Name], Type v a) -> m (Pretty SyntaxText, Pretty SyntaxText)
+    f :: MonadPretty v m => ([HashQualified Name], Type v a) -> m (Pretty SyntaxText, Pretty SyntaxText)
    f (names, typ) = do
      typ' <- pretty0 Map.empty (-1) typ
      let col = fmt S.TypeAscriptionColon ": "
@ -233,10 +237,11 @@ prettySignaturesAlt' ts =
 -- prettySignatures'' env ts = prettySignatures' env (first HQ.fromName <$> ts)

 prettySignaturesAlt ::
-  MonadPretty v m =>
+  Var v =>
+  PrettyPrintEnv ->
  [([HashQualified Name], Type v a)] ->
-  m (Pretty ColorText)
-prettySignaturesAlt ts =
+  Pretty ColorText
+prettySignaturesAlt ppe ts =
  PP.lines
    . map PP.group
-    <$> prettySignaturesAlt' ts
+    $ prettySignaturesAlt' ppe ts
--- a/parser-typechecker/tests/Unison/Test/Syntax/TermPrinter.hs
+++ b/parser-typechecker/tests/Unison/Test/Syntax/TermPrinter.hs
@ -9,7 +9,6 @@ import qualified Unison.Builtin
 import qualified Unison.HashQualified as HQ
 import Unison.Parser.Ann (Ann (..))
 import qualified Unison.PrettyPrintEnv as PPE
-import Unison.PrettyPrintEnv.MonadPretty (runPretty)
 import qualified Unison.PrettyPrintEnv.Names as PPE
 import Unison.Symbol (Symbol, symbol)
 import Unison.Syntax.TermPrinter
@ -84,8 +83,9 @@ tcBinding width v mtp tm expected =
      varV = symbol $ Text.pack v
      prettied =
        fmap CT.toPlain $
-          PP.syntaxToColor . runPretty getNames $
+          PP.syntaxToColor $
            prettyBinding
+              getNames
              (HQ.unsafeFromVar varV)
              (inputTerm inputType)
      actual =
--- a/parser-typechecker/tests/Unison/Test/Syntax/TypePrinter.hs
+++ b/parser-typechecker/tests/Unison/Test/Syntax/TypePrinter.hs
@ -1,12 +1,12 @@
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

 {-# HLINT ignore "Use camelCase" #-}
+
 module Unison.Test.Syntax.TypePrinter where

 import qualified Data.Map as Map
 import EasyTest
 import qualified Unison.Builtin
-import Unison.PrettyPrintEnv.MonadPretty (runPretty)
 import qualified Unison.PrettyPrintEnv.Names as PPE
 import Unison.Syntax.TypePrinter
 import qualified Unison.Test.Common as Common
--- a/unison-cli/src/Unison/CommandLine/DisplayValues.hs
+++ b/unison-cli/src/Unison/CommandLine/DisplayValues.hs
@ -16,7 +16,6 @@ import qualified Unison.ConstructorType as CT
 import qualified Unison.DataDeclaration as DD
 import Unison.Prelude
 import qualified Unison.PrettyPrintEnv as PPE
-import Unison.PrettyPrintEnv.MonadPretty (runPretty)
 import qualified Unison.PrettyPrintEnv.Util as PPE
 import qualified Unison.PrettyPrintEnvDecl as PPE
 import Unison.Reference (Reference)
@ -246,9 +245,10 @@ displayPretty pped terms typeOf eval types tm = go tm
      typeOf r >>= \case
        Nothing -> pure $ termName (PPE.suffixifiedPPE pped) r
        Just typ ->
-          pure . P.group
-            . runPretty (PPE.suffixifiedPPE pped)
-            $ TypePrinter.prettySignaturesCTCollapsed [(r, PPE.termName (PPE.suffixifiedPPE pped) r, typ)]
+          pure . P.group $
+            TypePrinter.prettySignaturesCTCollapsed
+              (PPE.suffixifiedPPE pped)
+              [(r, PPE.termName (PPE.suffixifiedPPE pped) r, typ)]

    goColor c = case c of
      DD.AnsiColorBlack -> P.black
@ -310,8 +310,9 @@ displayDoc pped terms typeOf evaluated types = go
      typeOf r >>= \case
        Nothing -> pure $ termName (PPE.unsuffixifiedPPE pped) r
        Just typ ->
-          pure . P.group . runPretty (PPE.suffixifiedPPE pped) $
+          pure . P.group $
            TypePrinter.prettySignaturesCTCollapsed
+              (PPE.suffixifiedPPE pped)
              [(r, PPE.termName (PPE.unsuffixifiedPPE pped) r, typ)]
    prettyEval terms r = case r of
      Referent.Ref (Reference.Builtin n) -> pure . P.syntaxToColor $ P.text n
@ -327,7 +328,7 @@ displayDoc pped terms typeOf evaluated types = go
        let ppe = PPE.declarationPPE pped ref
         in terms ref >>= \case
              Nothing -> pure $ "😶  Missing term source for: " <> termName ppe r
-              Just tm -> pure . P.syntaxToColor . P.group . runPretty ppe $ TP.prettyBinding (PPE.termName ppe r) tm
+              Just tm -> pure . P.syntaxToColor . P.group $ TP.prettyBinding ppe (PPE.termName ppe r) tm
      Referent.Con (ConstructorReference r _) _ -> prettyType r
    prettyType r =
      let ppe = PPE.declarationPPE pped r
--- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs
+++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs
@ -102,7 +102,6 @@ import qualified Unison.NamesWithHistory as Names
 import Unison.Parser.Ann (Ann, startingLine)
 import Unison.Prelude
 import qualified Unison.PrettyPrintEnv as PPE
-import Unison.PrettyPrintEnv.MonadPretty (runPretty)
 import qualified Unison.PrettyPrintEnv.Util as PPE
 import qualified Unison.PrettyPrintEnvDecl as PPED
 import Unison.PrettyTerminal
@ -1039,7 +1038,7 @@ notifyUser dir o = case o of
              P.bracket . P.lines $
                P.wrap "The watch expression(s) reference these definitions:" :
                "" :
-                  [ P.syntaxToColor . runPretty ppe $ TermPrinter.prettyBinding (HQ.unsafeFromVar v) b
+                  [ P.syntaxToColor $ TermPrinter.prettyBinding ppe (HQ.unsafeFromVar v) b
                    | (v, b) <- bindings
                  ]
            prettyWatches =
@ -1976,7 +1975,7 @@ displayDefinitions' ppe0 types terms = P.syntaxToColor $ P.sep "\n\n" (prettyTyp
          P.hang
            ("builtin " <> prettyHashQualified n <> " :")
            (TypePrinter.prettySyntax (ppeBody r) typ)
-        UserObject tm -> runPretty (ppeBody r) $ TermPrinter.prettyBinding n tm
+        UserObject tm -> TermPrinter.prettyBinding (ppeBody r) n tm
    go2 ((n, r), dt) =
      case dt of
        MissingObject r -> missing n r
@ -2081,7 +2080,7 @@ displayDefinitions outputLoc ppe types terms =
              P.hang
                ("builtin " <> prettyHashQualified n <> " :")
                (TypePrinter.prettySyntax (ppeBody n r) typ)
-            UserObject tm -> runPretty (ppeBody n r) $ TermPrinter.prettyBinding n tm
+            UserObject tm -> TermPrinter.prettyBinding (ppeBody n r) n tm
        go2 ((n, r), dt) =
          case dt of
            MissingObject r -> missing n r
@ -2148,7 +2147,7 @@ unsafePrettyTermResultSig' ::
  Pretty
 unsafePrettyTermResultSig' ppe = \case
  SR'.TermResult' name (Just typ) r _aliases ->
-    head (runPretty ppe $ TypePrinter.prettySignaturesCT [(r, name, typ)])
+    head (TypePrinter.prettySignaturesCT ppe [(r, name, typ)])
  _ -> error "Don't pass Nothing"

 -- produces:
@ -2396,7 +2395,7 @@ todoOutput ppe todo = runNumbered do
      termNumbers <- for filteredTerms \(ref, _, _) -> do
        n <- addNumberedArg (HQ.toString $ PPE.termName ppeu ref)
        pure $ formatNum n
-      let formattedTerms = runPretty ppes $ TypePrinter.prettySignaturesCT filteredTerms
+      let formattedTerms = TypePrinter.prettySignaturesCT ppes filteredTerms
          numberedTerms = zipWith (<>) termNumbers formattedTerms
      pure $
        Monoid.unlessM (TO.noEdits todo) . P.callout "🚧" . P.sep "\n\n" . P.nonEmpty $
@ -2407,7 +2406,7 @@ todoOutput ppe todo = runNumbered do
              ),
            P.indentN 2 . P.lines $
              ( (prettyDeclPair ppeu <$> toList frontierTypes)
-                  ++ runPretty ppes (TypePrinter.prettySignaturesCT (goodTerms frontierTerms))
+                  ++ TypePrinter.prettySignaturesCT ppes (goodTerms frontierTerms)
              ),
            P.wrap "I recommend working on them in the following order:",
            P.lines $ numberedTypes ++ numberedTerms,
--- a/unison-share-api/src/Unison/Server/Backend.hs
+++ b/unison-share-api/src/Unison/Server/Backend.hs
@ -73,7 +73,6 @@ import qualified Unison.NamesWithHistory as NamesWithHistory
 import Unison.Parser.Ann (Ann)
 import Unison.Prelude
 import qualified Unison.PrettyPrintEnv as PPE
-import Unison.PrettyPrintEnv.MonadPretty (runPretty)
 import qualified Unison.PrettyPrintEnv.Util as PPE
 import qualified Unison.PrettyPrintEnvDecl as PPED
 import qualified Unison.PrettyPrintEnvDecl.Names as PPED
@ -1073,7 +1072,7 @@ bestNameForTerm ppe width =
  Text.pack
    . Pretty.render width
    . fmap UST.toPlain
-    . runPretty ppe
+    . TermPrinter.runPretty ppe
    . TermPrinter.pretty0 @v TermPrinter.emptyAc
    . Term.fromReferent mempty

@ -1260,8 +1259,7 @@ termsToSyntax suff width ppe0 terms =
      DisplayObject.UserObject tm ->
        DisplayObject.UserObject
          . Pretty.render width
-          . runPretty (ppeBody r)
-          $ TermPrinter.prettyBinding n tm
+          $ TermPrinter.prettyBinding (ppeBody r) n tm

 typesToSyntax ::
  Var v =>
--- a/unison-share-api/src/Unison/Server/Doc.hs
+++ b/unison-share-api/src/Unison/Server/Doc.hs
@ -30,7 +30,6 @@ import qualified Unison.Codebase.Editor.DisplayObject as DO
 import qualified Unison.ConstructorReference as ConstructorReference
 import qualified Unison.DataDeclaration as DD
 import qualified Unison.PrettyPrintEnv as PPE
-import Unison.PrettyPrintEnv.MonadPretty (runPretty)
 import qualified Unison.PrettyPrintEnvDecl as PPE
 import Unison.Reference (Reference)
 import qualified Unison.Reference as Reference
@ -189,8 +188,9 @@ renderDoc pped terms typeOf eval types tm =
      runMaybeT (traverse (MaybeT . typeOf) rs) >>= \case
        Nothing -> pure ["🆘  codebase is missing type signature for these definitions"]
        Just types ->
-          pure . fmap P.group . runPretty (PPE.suffixifiedPPE pped) $
+          pure . fmap P.group $
            TypePrinter.prettySignaturesST
+              (PPE.suffixifiedPPE pped)
              [(r, PPE.termName (PPE.suffixifiedPPE pped) r, ty) | (r, ty) <- zip rs types]

    goSpecial :: Term v () -> m SpecialForm
@ -312,12 +312,12 @@ renderDoc pped terms typeOf eval types tm =
                              typ <- fromMaybe (Type.builtin () "unknown") <$> typeOf (Referent.Ref ref)
                              let name = PPE.termName ppe (Referent.Ref ref)
                              let folded =
-                                    formatPretty . P.lines . runPretty ppe $
-                                      TypePrinter.prettySignaturesST [(Referent.Ref ref, name, typ)]
+                                    formatPretty . P.lines $
+                                      TypePrinter.prettySignaturesST ppe [(Referent.Ref ref, name, typ)]
                              let full tm@(Term.Ann' _ _) _ =
-                                    formatPretty (runPretty ppe $ TermPrinter.prettyBinding name tm)
+                                    formatPretty (TermPrinter.prettyBinding ppe name tm)
                                  full tm typ =
-                                    formatPretty (runPretty ppe $ TermPrinter.prettyBinding name (Term.ann () tm typ))
+                                    formatPretty (TermPrinter.prettyBinding ppe name (Term.ann () tm typ))
                              pure (DO.UserObject (Src folded (full tm typ)))
                  Term.RequestOrCtor' (view ConstructorReference.reference_ -> r) | Set.notMember r seen -> (: acc) <$> goType r
                  _ -> pure acc