1 module PrettyClass
    2 
    3 ( PrettyClass (..)
    4 
    5 , ppSepp
    6 
    7 , tabstop
    8 , linewidth
    9 
   10 , alParens, alBrackets, alBraces
   11 , ppCommas
   12 , emitascii, emitlatex
   13 
   14 , ppSep2
   15 )
   16 
   17 where
   18 
   19 import Options
   20 
   21 import Pretty -- hslibs/ghc/src/Pretty.lhs, with modifications
   22 
   23 tabstop = 4 :: Int
   24 linewidth = 75 :: Int
   25 
   26 ------------------------------------------------------------------------
   27 
   28 
   29 alParens opts p = 
   30     caseopts opts "code"
   31         [ ("plain", ppBesides 
   32                 [ ppStr "(", ppNest tabstop p, ppStr ")" ])
   33         , ("latex", ppBesides 
   34                 [ ppStr "\\left(", ppNest tabstop p, ppStr "\\right)" ])
   35         ]
   36 
   37 alBrackets opts p =
   38     caseopts opts "code"
   39         [ ("plain", ppBesides 
   40                 [ ppStr "[", ppNest tabstop p, ppStr "]" ])
   41         , ("latex", ppBesides 
   42                 [ ppStr "\\left[", ppNest tabstop p, ppStr "\\right]" ])
   43         ]
   44 
   45 alBraces opts p =
   46     caseopts opts "code"
   47         [ ("plain", ppBesides 
   48                 [ ppStr "{", ppNest tabstop p, ppStr "}" ])
   49         , ("latex", ppBesides 
   50                 [ ppStr "\\left\\{", ppNest tabstop p, ppStr "\\right\\}" ])
   51         ]
   52 
   53 --------------------------------------------------------------------------
   54 
   55 x `ppSep2` y = ppSep [x, y]
   56 
   57 ppSepp :: [ Pretty ] -> Pretty
   58 ppSepp [] = ppNil
   59 ppSepp xs = 
   60     let l = length xs
   61         (as, bs) = splitAt (l `div` 2) xs
   62     in  case xs of
   63         [x] -> x
   64         _ -> ppSepp as `ppSep2` ppSepp bs
   65         
   66 
   67 ppInterleave2 :: Pretty -> [Pretty] -> Pretty
   68 ppInterleave2 p [] = ppNil
   69 ppInterleave2 p qs = ppi2 False p qs
   70 
   71 ppi2 finis p qs = 
   72     let l = length qs
   73         (as, bs) = splitAt (l `div` 2) qs
   74     in  case qs of [q] -> if finis then q `ppBeside` p else q
   75                    [ ] -> error "ppInterleave2"
   76                    _   -> ppi2 True p as `ppSep2` ppi2 finis p bs
   77 
   78 
   79 ---------------------------------------------------------------------
   80 
   81 
   82 class PrettyClass a where
   83         -- prettyprint
   84         pp :: Opts -> a -> Pretty
   85 
   86         -- prettyprint, with precedence
   87         ppp :: Opts -> Int -> a -> Pretty
   88 
   89         -- default methods
   90         pp opts = ppp opts 0
   91         ppp opts n = pp opts
   92 
   93 optslatex = listToOpts [("code","latex")]
   94 optsplain = listToOpts [("code","plain")]
   95 
   96 
   97 emitascii  :: PrettyClass a => a -> ShowS
   98 emitascii x cs = ppShow linewidth (pp optsplain x) ++ cs
   99 
  100 emitlatex  :: PrettyClass a => a -> ShowS
  101 emitlatex x cs = ppShow linewidth (pp optslatex x) ++ cs
  102 
  103 
  104 --------------------------------------------------------------------------
  105 
  106 instance PrettyClass Int  where pp opts n = ppStr (show n)
  107 instance PrettyClass Char  where pp opts n = ppStr (show n)
  108 instance PrettyClass Float  where pp opts n = ppStr (show n)
  109 instance PrettyClass Bool where pp opts n = ppStr (show n)
  110 
  111 ppCommas pps = ppInterleave2 ppComma pps
  112 
  113 instance PrettyClass a => PrettyClass [a] where
  114     pp opts xs = alBrackets opts 
  115         (ppCommas (map (pp opts) xs))
  116 
  117 instance (PrettyClass a, PrettyClass b) => PrettyClass (a, b) where
  118     pp opts (x, y) = alParens opts 
  119         (ppCommas [pp opts x, pp opts y])
  120 
  121 instance (PrettyClass a, PrettyClass b, PrettyClass c) 
  122         => PrettyClass (a, b, c) where
  123     pp opts (x, y, z) = alParens opts 
  124         (ppCommas [pp opts x, pp opts y, pp opts z])
  125