mirror of
https://github.com/unisonweb/unison.git
synced 2024-10-04 21:57:25 +03:00
Simplified public interface to type/term printer
This commit is contained in:
parent
7a3808e656
commit
68e94f9a24
@ -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
|
||||
|
@ -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))
|
||||
|
@ -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
|
||||
|
@ -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 =
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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,
|
||||
|
@ -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 =>
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user