github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-18 12:21:57 +03:00
Code Issues Projects Releases Wiki Activity

Specialize the Pretty1 instance for Term to only apply to Terms of Unions.

Browse Source
This commit is contained in:
Rob Rix 2017-09-08 17:38:12 +01:00
parent 07bef3f75e
commit d5af300094
1 changed files with 3 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
src/Term.hs
View File

@ -53,15 +53,12 @@ hoistTerm 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
instance Apply1 Pretty1 fs => Pretty1 (Term (Union fs)) where
liftPretty p pl = go where go (a :< f) = p a <+> liftPrettyUnion go (Pretty.list . map (liftPretty p pl)) f
instance (Pretty1 f, Pretty a) => Pretty (Term f a) where
instance (Apply1 Pretty1 fs, Pretty a) => Pretty (Term (Union fs) a) where
pretty = liftPretty pretty prettyList
instance Apply1 Pretty1 fs => Pretty1 (Union fs) where
liftPretty = liftPrettyUnion
type instance Base (Term f a) = TermF f a
instance Functor f => Recursive (Term f a) where project = unTerm