{-# LANGUAGE FunctionalDependencies, NoMonomorphismRestriction, MultiParamTypeClasses #-} module GArrowPretty(SourceCode(..),pprGArrow) where import Prelude hiding (id,(.)) import Control.GArrow import Control.Category import Text.PrettyPrint.HughesPJ -- The Bool flag is to minimize the number of parentheses generated: -- it is true iff the principal connective is of lower precedence than -- juxtaposition data SourceCode a b = SC Bool Doc instance Category SourceCode where id = SC False $ text "id" (SC _ g) . (SC _ f) = SC True $ f <+> (text ">>>") $$ g instance GArrow SourceCode (,) () where ga_first (SC x f) = SC True $ text "ga_first" <+> if x then parens f else f ga_second (SC x f) = SC True $ text "ga_second" <+> if x then parens f else f ga_cancell = SC False $ text "ga_cancell" ga_cancelr = SC False $ text "ga_cancelr" ga_uncancell = SC False $ text "ga_uncancell" ga_uncancelr = SC False $ text "ga_uncancelr" ga_assoc = SC False $ text "ga_assoc" ga_unassoc = SC False $ text "ga_unassoc" instance GArrowSwap SourceCode (,) () where ga_swap = SC False $ text "ga_swap" instance GArrowDrop SourceCode (,) () where ga_drop = SC False $ text "ga_drop" instance GArrowCopy SourceCode (,) () where ga_copy = SC False $ text "ga_copy" instance GArrowLoop SourceCode (,) () where ga_loopl (SC x f) = SC True $ text "ga_loopl" <+> if x then parens f else f ga_loopr (SC x f) = SC True $ text "ga_loopr" <+> if x then parens f else f pprGArrow :: SourceCode x y -> Doc pprGArrow (SC _ doc) = doc