1 {-# LANGUAGE FunctionalDependencies, NoMonomorphismRestriction, MultiParamTypeClasses #-}
2 module GArrowPretty(SourceCode(..),pprGArrow) where
3 import Prelude hiding (id,(.))
5 import Control.Category
6 import Text.PrettyPrint.HughesPJ
8 -- The Bool flag is to minimize the number of parentheses generated:
9 -- it is true iff the principal connective is of lower precedence than
11 data SourceCode a b = SC Bool Doc
13 instance Category SourceCode where
14 id = SC False $ text "id"
15 (SC _ g) . (SC _ f) = SC True $ f <+> (text ">>>") $$ g
17 instance GArrow SourceCode (,) () where
18 ga_first (SC x f) = SC True $ text "ga_first"
19 <+> if x then parens f else f
20 ga_second (SC x f) = SC True $ text "ga_second"
21 <+> if x then parens f else f
22 ga_cancell = SC False $ text "ga_cancell"
23 ga_cancelr = SC False $ text "ga_cancelr"
24 ga_uncancell = SC False $ text "ga_uncancell"
25 ga_uncancelr = SC False $ text "ga_uncancelr"
26 ga_assoc = SC False $ text "ga_assoc"
27 ga_unassoc = SC False $ text "ga_unassoc"
29 instance GArrowSwap SourceCode (,) () where
30 ga_swap = SC False $ text "ga_swap"
31 instance GArrowDrop SourceCode (,) () where
32 ga_drop = SC False $ text "ga_drop"
33 instance GArrowCopy SourceCode (,) () where
34 ga_copy = SC False $ text "ga_copy"
35 instance GArrowLoop SourceCode (,) () where
36 ga_loopl (SC x f) = SC True $ text "ga_loopl" <+> if x then parens f else f
37 ga_loopr (SC x f) = SC True $ text "ga_loopr" <+> if x then parens f else f
39 pprGArrow :: SourceCode x y -> Doc
40 pprGArrow (SC _ doc) = doc