From a16c6e4f7582c4d7ca5f7596b0c5eccd9dfc8cc3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 8 Sep 2017 17:20:55 +0100 Subject: [PATCH] Extract union pretty-printing to the top level. --- src/Term.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Term.hs b/src/Term.hs index 736c592c7..2c999d6db 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -57,6 +57,9 @@ unTerm (a :< f) = a :<< f hoistCofree :: Functor f => (forall a. f a -> g a) -> Term f a -> Term g a hoistCofree f = go where go (a :< r) = a :< f (fmap go r) +liftPrettyUnion :: Apply1 Pretty1 fs => (a -> Doc ann) -> ([a] -> Doc ann) -> Union fs a -> Doc ann +liftPrettyUnion p pl = apply1 (Proxy :: Proxy Pretty1) (liftPretty p pl) + instance Pretty1 f => Pretty1 (Term f) where liftPretty p pl = go where go (a :< f) = p a <+> liftPretty go (Pretty.list . map (liftPretty p pl)) f @@ -64,7 +67,7 @@ instance (Pretty1 f, Pretty a) => Pretty (Term f a) where pretty = liftPretty pretty prettyList instance Apply1 Pretty1 fs => Pretty1 (Union fs) where - liftPretty p pl = apply1 (Proxy :: Proxy Pretty1) (liftPretty p pl) + liftPretty = liftPrettyUnion type instance Base (Term f a) = TermF f a