examples/GArrowPretty.hs

   1 {-# LANGUAGE FunctionalDependencies, NoMonomorphismRestriction, MultiParamTypeClasses #-}
   2 module GArrowPretty(SourceCode(..),pprGArrow) where
   3 import Prelude hiding (id,(.))
   4 import Control.GArrow
   5 import Control.Category
   6 import Text.PrettyPrint.HughesPJ
   7
   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
  10 -- juxtaposition
  11 data SourceCode a b = SC Bool Doc
  12
  13 instance Category SourceCode where
  14   id                  = SC False $ text "id"
  15   (SC _ g) . (SC _ f) = SC True  $ f <+> (text ">>>") $$ g
  16
  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"
  28
  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
  38
  39 pprGArrow :: SourceCode x y -> Doc
  40 pprGArrow (SC _ doc) = doc
  41