Lifted Pretty classes

prettyprinter/src/Data/Text/Prettyprint/Doc.hs

@@ -267,6 +267,10 @@ module Data.Text.Prettyprint.Doc (
     PageWidth(..), LayoutOptions(..), defaultLayoutOptions,
     layoutPretty, layoutCompact, layoutSmart,
 
+    -- * Lifted classes.
+    Pretty1(..),
+    Pretty2(..),
+
     -- * Migration guide
     --
     -- $migration

prettyprinter/src/Data/Text/Prettyprint/Doc/Internal.hs

@@ -328,6 +328,15 @@ instance Pretty a => Pretty (Maybe a) where
     pretty = maybe mempty pretty
     prettyList = prettyList . catMaybes
 
+-- | Print 'Left' and 'Right' contents.
+--
+-- >>> pretty (Left True :: Either Bool Bool)
+-- True
+-- >>> pretty (Right True :: Either Bool Bool)
+-- True
+instance (Pretty a, Pretty b) => Pretty (Either a b) where
+    pretty = either pretty pretty
+
 -- | Automatically converts all newlines to @'line'@.
 --
 -- >>> pretty ("hello\nworld" :: Text)
@@ -352,7 +361,95 @@ instance Pretty Lazy.Text where pretty = pretty . Lazy.toStrict
 -- []
 instance Pretty Void where pretty = absurd
 
+-- | Overloaded conversion to 'Doc', lifted to unary type constructors.
+--
+-- This is most useful for:
+-- 1. defining 'Pretty' instances for recursive types,
+-- 2. defining 'Pretty' instances for type constructors without 'Functor'
+--    instances, and
+-- 3. efficiently pretty-printing type constructors with 'Functor' instances
+--    whose 'fmap' traverses the whole structure.
+--
+-- Laws:
+--
+--   1. output should be pretty. :-)
+class Pretty1 f where
+
+    -- | >>> liftPretty (parens . pretty) (list . map (parens . pretty)) (Just "hello")
+    -- (hello)
+    liftPretty
+        :: (a -> Doc ann)   -- ^ A function to print a single value.
+        -> ([a] -> Doc ann) -- ^ A function to print a list. Used for [].
+        -> f a
+        -> Doc ann
+
+-- | >>> liftPretty (parens . pretty) (list . map (parens . pretty)) [1,2,3]
+-- [(1), (2), (3)]
+instance Pretty1 [] where
+    liftPretty _ prettyList' = prettyList'
+
+instance Pretty1 NonEmpty where
+    liftPretty _ prettyList' (x:|xs) = prettyList' (x:xs)
 
+-- | Ignore 'Nothing's, print 'Just' contents with the supplied function.
+--
+-- >>> liftPretty (parens . pretty) (list . map (parens . pretty)) (Just True)
+-- (True)
+-- >>> braces (liftPretty (parens . pretty) (list . map (parens . pretty)) (Nothing :: Maybe Bool))
+-- {}
+instance Pretty1 Maybe where
+    liftPretty prettyJust _ = maybe mempty prettyJust
+
+-- | Print 'Left' contents with 'pretty', and 'Right' contents with the supplied
+-- function.
+--
+-- >>> liftPretty (parens . pretty) (list . map (parens . pretty)) (Left True :: Either Bool Bool)
+-- True
+-- >>> liftPretty (parens . pretty) (list . map (parens . pretty)) (Right True :: Either Bool Bool)
+-- (True)
+instance Pretty a => Pretty1 (Either a) where
+    liftPretty prettyRight _ = either pretty prettyRight
+
+-- | >>> liftPretty (parens . pretty) (list . map (parens . pretty)) (123, "hello")
+-- (123, (hello))
+instance Pretty a => Pretty1 ((,) a) where
+    liftPretty pretty2 _ (x1, x2) = tupled [pretty x1, pretty2 x2]
+
+-- | Overloaded conversion to 'Doc', lifted to binary type constructors.
+--
+-- This is most useful for:
+-- 1. defining 'Pretty' instances for recursive types,
+-- 2. defining 'Pretty' instances for type constructors without 'Functor'
+--    instances, and
+-- 3. efficiently pretty-printing type constructors with 'Functor' instances
+--    whose 'fmap' traverses the whole structure.
+--
+-- Laws:
+--
+--   1. output should be pretty. :-)
+class Pretty2 f where
+
+    liftPretty2
+        :: (a -> Doc ann)   -- ^ A function to print a single value of the first parameter.
+        -> ([a] -> Doc ann) -- ^ A function to print a list of the first parameter.
+        -> (b -> Doc ann)   -- ^ A function to print a single value of the second parameter.
+        -> ([b] -> Doc ann) -- ^ A function to print a list of the second parameter.
+        -> f a b
+        -> Doc ann
+
+-- | Print 'Left' and 'Right' contents with the supplied functions.
+--
+-- >>> liftPretty2 (parens . pretty) (list . map (parens . pretty)) (parens . pretty) (list . map (parens . pretty)) (Left True :: Either Bool Bool)
+-- (True)
+-- >>> liftPretty2 (parens . pretty) (list . map (parens . pretty)) (parens . pretty) (list . map (parens . pretty)) (Right True :: Either Bool Bool)
+-- (True)
+instance Pretty2 Either where
+    liftPretty2 prettyLeft _ prettyRight _ = either prettyLeft prettyRight
+
+-- | >>> liftPretty2 (parens . pretty) (list . map (parens . pretty)) (parens . pretty) (list . map (parens . pretty)) (123, "hello")
+-- ((123), (hello))
+instance Pretty2 (,) where
+    liftPretty2 pretty1 _ pretty2 _ (x1, x2) = tupled [pretty1 x1, pretty2 x2]
 
 -- | @(unsafeTextWithoutNewlines s)@ contains the literal string @s@.
 --