X-Git-Url: http://git.megacz.com/?p=coq-hetmet.git;a=blobdiff_plain;f=examples%2FGArrowPretty.hs;fp=examples%2FGArrowPretty.hs;h=0be25dc1f3fd0f175d15779e153923ae4e44771e;hp=0000000000000000000000000000000000000000;hb=ec996e8cb550676d89d187061db7d018af9ec88d;hpb=2f22f2f26622f85e457060de3a5c534004a26e79

diff --git a/examples/GArrowPretty.hs b/examples/GArrowPretty.hs
new file mode 100644
index 0000000..0be25dc
--- /dev/null
+++ b/examples/GArrowPretty.hs
@@ -0,0 +1,41 @@
+{-# 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
+