Refactor to use prettyprinter library

disco.cabal

@@ -460,7 +460,7 @@ library
                        mtl >=2.2 && <2.4,
                        megaparsec >= 6.1.1 && < 9.6,
                        parser-combinators >= 1.0.0 && < 1.4,
-                       pretty >=1.1 && <1.2,
+                       prettyprinter >=1.7 && < 1.8,
                        split >= 0.2 && < 0.3,
                        transformers >= 0.4 && < 0.7,
                        containers >=0.5 && <0.7,

src/Disco/AST/Core.hs

@@ -291,17 +291,15 @@ instance Pretty Core where
     CCase c l r -> do
       lunbind l $ \(x, lc) -> do
         lunbind r $ \(y, rc) -> do
-          "case"
-            <+> pretty c
-            <+> "of {"
-            $+$ nest
-              2
-              ( vcat
-                  [ withPA funPA $ "left" <+> rt (pretty x) <+> "->" <+> pretty lc
-                  , withPA funPA $ "right" <+> rt (pretty y) <+> "->" <+> pretty rc
-                  ]
-              )
-            $+$ "}"
+          nest 2 $
+            "case"
+              <+> pretty c
+              <+> "of {"
+              $+$ vcat
+                [ withPA funPA $ "left" <+> rt (pretty x) <+> "->" <+> pretty lc
+                , withPA funPA $ "right" <+> rt (pretty y) <+> "->" <+> pretty rc
+                ]
+              $+$ "}"
     CUnit -> "unit"
     CPair c1 c2 -> setPA initPA $ parens (pretty c1 <> ", " <> pretty c2)
     CProj s c -> withPA funPA $ selectSide s "fst" "snd" <+> rt (pretty c)
@@ -318,7 +316,7 @@ instance Pretty Core where
 toTuple :: [Core] -> Core
 toTuple = foldr CPair CUnit
 
-prettyTestVars :: Members '[Reader PA, LFresh] r => [(String, Type, Name Core)] -> Sem r Doc
+prettyTestVars :: Members '[Reader PA, LFresh] r => [(String, Type, Name Core)] -> Sem r (Doc ann)
 prettyTestVars = brackets . intercalate "," . map prettyTestVar
  where
   prettyTestVar (s, ty, n) = parens (intercalate "," [text s, pretty ty, pretty n])

src/Disco/AST/Surface.hs

@@ -2,10 +2,6 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE UndecidableInstances #-}
 
------------------------------------------------------------------------------
-
------------------------------------------------------------------------------
-
 -- |
 -- Module      :  Disco.AST.Surface
 -- Copyright   :  disco team and contributors
@@ -236,7 +232,7 @@ instance Pretty (Name a, Bind [Pattern] Term) where
     pretty x <> hcat (map prettyPatternP ps) <+> text "=" <+> setPA initPA (pretty t)
 
 -- | Pretty-print a type declaration.
-prettyTyDecl :: Members '[Reader PA, LFresh] r => Name t -> Type -> Sem r Doc
+prettyTyDecl :: Members '[Reader PA, LFresh] r => Name t -> Type -> Sem r (Doc ann)
 prettyTyDecl x ty = hsep [pretty x, text ":", pretty ty]
 
 ------------------------------------------------------------
@@ -526,7 +522,7 @@ pattern PNonlinear p x <- PNonlinear_ (unembed -> p) x
 -- term (e.g. via the :doc REPL command).
 
 -- | Pretty-print a term with guaranteed parentheses.
-prettyTermP :: Members '[LFresh, Reader PA] r => Term -> Sem r Doc
+prettyTermP :: Members '[LFresh, Reader PA] r => Term -> Sem r (Doc ann)
 prettyTermP t@TTup {} = setPA initPA $ pretty t
 -- prettyTermP t@TContainer{} = setPA initPA $ "" <+> prettyTerm t
 prettyTermP t = withPA initPA $ pretty t
@@ -630,12 +626,12 @@ instance Pretty Term where
     TWild -> text "_"
 
 -- | Print appropriate delimiters for a container literal.
-containerDelims :: Member (Reader PA) r => Container -> (Sem r Doc -> Sem r Doc)
+containerDelims :: Member (Reader PA) r => Container -> (Sem r (Doc ann) -> Sem r (Doc ann))
 containerDelims ListContainer = brackets
 containerDelims BagContainer = bag
 containerDelims SetContainer = braces
 
-prettyBranches :: Members '[Reader PA, LFresh] r => [Branch] -> Sem r Doc
+prettyBranches :: Members '[Reader PA, LFresh] r => [Branch] -> Sem r (Doc ann)
 prettyBranches = \case
   [] -> error "Empty branches are disallowed."
   b : bs ->
@@ -681,7 +677,7 @@ instance Pretty Qual where
     QGuard (unembed -> t) -> pretty t
 
 -- | Pretty-print a pattern with guaranteed parentheses.
-prettyPatternP :: Members '[LFresh, Reader PA] r => Pattern -> Sem r Doc
+prettyPatternP :: Members '[LFresh, Reader PA] r => Pattern -> Sem r (Doc ann)
 prettyPatternP p@PTup {} = setPA initPA $ pretty p
 prettyPatternP p = withPA initPA $ pretty p
 

src/Disco/Error.hs

@@ -82,7 +82,7 @@
 panic :: Member (Error DiscoError) r => String -> Sem r a
 panic = throw . Panic
 
-outputDiscoErrors :: Member (Output Message) r => Sem (Error DiscoError ': r) () -> Sem r ()
+outputDiscoErrors :: Member (Output (Message ann)) r => Sem (Error DiscoError ': r) () -> Sem r ()
 outputDiscoErrors m = do
   e <- runError m
   either (err . pretty') return e
@@ -93,9 +93,9 @@
     CyclicImport ms -> cyclicImportError ms
     TypeCheckErr (LocTCError Nothing te) -> prettyTCError te
     TypeCheckErr (LocTCError (Just n) te) ->
-      vcat
+      nest 2 $ vcat
         [ "While checking " <> pretty' n <> ":"
-        , nest 2 $ prettyTCError te
+        , prettyTCError te
         ]
     ParseErr pe -> text (errorBundlePretty pe)
     EvalErr ee -> prettyEvalError ee
@@ -105,23 +105,23 @@
         , "Please report this as a bug at https://github.com/disco-lang/disco/issues/ ."
         ]
 
-rtd :: String -> Sem r Doc
+rtd :: String -> Sem r (Doc ann)
 rtd page = "https://disco-lang.readthedocs.io/en/latest/reference/" <> text page <> ".html"
 
-issue :: Int -> Sem r Doc
+issue :: Int -> Sem r (Doc ann)
 issue n = "See https://github.com/disco-lang/disco/issues/" <> text (show n)
 
 cyclicImportError ::
   Members '[Reader PA, LFresh] r =>
   [ModuleName] ->
-  Sem r Doc
+  Sem r (Doc ann)
 cyclicImportError ms =
-  vcat
+  nest 2 $ vcat
     [ "Error: module imports form a cycle:"
-    , nest 2 $ intercalate " ->" (map pretty ms)
+    , intercalate " ->" (map pretty ms)
     ]
 
-prettyEvalError :: Members '[Reader PA, LFresh] r => EvalError -> Sem r Doc
+prettyEvalError :: Members '[Reader PA, LFresh] r => EvalError -> Sem r (Doc ann)
 prettyEvalError = \case
   UnboundPanic x ->
     ("Bug! No variable found named" <+> pretty' x <> ".")
@@ -138,7 +138,7 @@
 -- [ ] Step 3: improve error messages according to notes below
 -- [ ] Step 4: get it to return multiple error messages
 -- [ ] Step 5: save parse locations, display with errors
-prettyTCError :: Members '[Reader PA, LFresh] r => TCError -> Sem r Doc
+prettyTCError :: Members '[Reader PA, LFresh] r => TCError -> Sem r (Doc ann)
 prettyTCError = \case
   -- XXX include some potential misspellings along with Unbound
   --   see https://github.com/disco-lang/disco/issues/180
@@ -150,7 +150,7 @@
   Ambiguous x ms ->
     vcat
       [ "Error: the name" <+> pretty' x <+> "is ambiguous. It could refer to:"
-      , nest 2 (vcat . map (\m -> pretty' m <> "." <> pretty' x) $ ms)
+      , indent 2 . vcat . map (\m -> pretty' m <> "." <> pretty' x) $ ms
       , rtd "ambiguous"
       ]
   NoType x ->
@@ -166,9 +166,9 @@
   NotCon c t ty ->
     vcat
       [ "Error: the expression"
-      , nest 2 $ pretty' t
+      , indent 2 $ pretty' t
       , "must have both a" <+> conWord c <+> "type and also the incompatible type"
-      , nest 2 $ pretty' ty <> "."
+      , indent 2 $ pretty' ty <> "."
       , rtd "notcon"
       ]
   EmptyCase ->
@@ -179,9 +179,9 @@
   PatternType c pat ty ->
     vcat
       [ "Error: the pattern"
-      , nest 2 $ pretty' pat
+      , indent 2 $ pretty' pat
       , "is supposed to have type"
-      , nest 2 $ pretty' ty <> ","
+      , indent 2 $ pretty' ty <> ","
       , "but instead it has a" <+> conWord c <+> "type."
       , rtd "pattern-type"
       ]
@@ -220,7 +220,7 @@
   NoSearch ty ->
     vcat
       [ "Error: the type"
-      , nest 2 $ pretty' ty
+      , indent 2 $ pretty' ty
       , "is not searchable (i.e. it cannot be used in a forall)."
       , rtd "no-search"
       ]
@@ -259,15 +259,15 @@
   NoPolyRec s ss tys ->
     vcat
       [ "Error: in the definition of " <> text s <> parens (intercalate "," (map text ss)) <> ": recursive occurrences of" <+> text s <+> "may only have type variables as arguments."
-      , nest
+      , indent
           2
           ( text s <> parens (intercalate "," (map pretty' tys)) <+> "does not follow this rule."
           )
       , rtd "no-poly-rec"
       ]
   NoError -> empty
 
-conWord :: Con -> Sem r Doc
+conWord :: Con -> Sem r (Doc ann)
 conWord = \case
   CArr -> "function"
   CProd -> "pair"
@@ -280,7 +280,7 @@
   CGraph -> "graph"
   CUser s -> text s
 
-prettySolveError :: Members '[Reader PA, LFresh] r => SolveError -> Sem r Doc
+prettySolveError :: Members '[Reader PA, LFresh] r => SolveError -> Sem r (Doc ann)
 prettySolveError = \case
   -- XXX say which types!
   NoWeakUnifier ->
@@ -307,16 +307,16 @@
   QualSkolem q a ->
     vcat
       [ "Error: type variable" <+> pretty' a <+> "represents any type, so we cannot assume values of that type"
-      , nest 2 (qualPhrase True q) <> "."
+      , indent 2 (qualPhrase True q) <> "."
       , rtd "qual-skolem"
       ]
 
-qualPhrase :: Bool -> Qualifier -> Sem r Doc
+qualPhrase :: Bool -> Qualifier -> Sem r (Doc ann)
 qualPhrase b q
   | q `elem` [QBool, QBasic, QSimple] = "are" <+> (if b then empty else "not") <+> qualAction q
   | otherwise = "can" <> (if b then empty else "not") <+> "be" <+> qualAction q
 
-qualAction :: Qualifier -> Sem r Doc
+qualAction :: Qualifier -> Sem r (Doc ann)
 qualAction = \case
   QNum -> "added and multiplied"
   QSub -> "subtracted"

src/Disco/Eval.hs

@@ -2,10 +2,6 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 
------------------------------------------------------------------------------
-
------------------------------------------------------------------------------
-
 -- |
 -- Module      :  Disco.Eval
 -- Copyright   :  disco team and contributors
@@ -164,10 +160,10 @@ type family AppendEffects (r :: EffectRow) (s :: EffectRow) :: EffectRow where
 -- However, just manually implementing it here seems easier.
 
 -- | Effects needed at the top level.
-type TopEffects = '[Error DiscoError, State TopInfo, Output Message, Embed IO, Final (H.InputT IO)]
+type TopEffects = '[Error DiscoError, State TopInfo, Output (Message ()), Embed IO, Final (H.InputT IO)]
 
 -- | Effects needed for evaluation.
-type EvalEffects = [Error EvalError, Random, LFresh, Output Message, State Mem]
+type EvalEffects = [Error EvalError, Random, LFresh, Output (Message ()), State Mem]
 
 -- XXX write about order.
 -- memory, counter etc. should not be reset by errors.
@@ -296,7 +292,7 @@ typecheckTop tcm = do
 --   The 'Resolver' argument specifies where to look for imported
 --   modules.
 loadDiscoModule ::
-  Members '[State TopInfo, Output Message, Random, State Mem, Error DiscoError, Embed IO] r =>
+  Members '[State TopInfo, Output (Message ann), Random, State Mem, Error DiscoError, Embed IO] r =>
   Bool ->
   Resolver ->
   FilePath ->
@@ -310,7 +306,7 @@ loadDiscoModule quiet resolver =
 --   module loaded from disk).  Used for e.g. blocks/modules entered
 --   at the REPL prompt.
 loadParsedDiscoModule ::
-  Members '[State TopInfo, Output Message, Random, State Mem, Error DiscoError, Embed IO] r =>
+  Members '[State TopInfo, Output (Message ann), Random, State Mem, Error DiscoError, Embed IO] r =>
   Bool ->
   Resolver ->
   ModuleName ->
@@ -324,7 +320,7 @@ loadParsedDiscoModule quiet resolver =
 --   any imported module more than once. Resolve the module, load and
 --   parse it, then call 'loadParsedDiscoModule''.
 loadDiscoModule' ::
-  Members '[State TopInfo, Output Message, Random, State Mem, Error DiscoError, Embed IO] r =>
+  Members '[State TopInfo, Output (Message ann), Random, State Mem, Error DiscoError, Embed IO] r =>
   Bool ->
   Resolver ->
   [ModuleName] ->
@@ -356,7 +352,7 @@ stdLib = ["list", "container"]
 --   'LoadingMode' parameter is 'REPL'.  Recursively load all its
 --   imports, then typecheck it.
 loadParsedDiscoModule' ::
-  Members '[State TopInfo, Output Message, Random, State Mem, Error DiscoError, Embed IO] r =>
+  Members '[State TopInfo, Output (Message ann), Random, State Mem, Error DiscoError, Embed IO] r =>
   Bool ->
   LoadingMode ->
   Resolver ->
@@ -398,7 +394,7 @@ loadParsedDiscoModule' quiet mode resolver inProcess name cm@(Module _ mns _ _ _
 
 -- | Try loading the contents of a file from the filesystem, emitting
 --   an error if it's not found.
-loadFile :: Members '[Output Message, Embed IO] r => FilePath -> Sem r (Maybe String)
+loadFile :: Members '[Output (Message ann), Embed IO] r => FilePath -> Sem r (Maybe String)
 loadFile file = do
   res <- liftIO $ handle @SomeException (return . Left) (Right <$> readFile file)
   case res of
@@ -408,7 +404,7 @@ loadFile file = do
 -- | Add things from the given module to the set of currently loaded
 --   things.
 addToREPLModule ::
-  Members '[Error DiscoError, State TopInfo, Random, State Mem, Output Message] r =>
+  Members '[Error DiscoError, State TopInfo, Random, State Mem, Output (Message ann)] r =>
   ModuleInfo ->
   Sem r ()
 addToREPLModule mi = modify @TopInfo (replModInfo <>~ mi)
@@ -418,7 +414,7 @@ addToREPLModule mi = modify @TopInfo (replModInfo <>~ mi)
 --   term definitions, documentation, types, and type definitions.
 --   Replaces any previously loaded module.
 setREPLModule ::
-  Members '[State TopInfo, Random, Error EvalError, State Mem, Output Message] r =>
+  Members '[State TopInfo, Random, Error EvalError, State Mem, Output (Message ann)] r =>
   ModuleInfo ->
   Sem r ()
 setREPLModule mi = do