PrettyM.hs

{-+
PrettyM redefines the combinators in Pretty, so that they pass an
environment around.  This can be used to adust the behaviour of the layout,
spacing etc., without parameterising the whole pretty printer.  To the user
it all appears the same.

May be useful to rewrite this as a state transformer, rather than a
state reader monad.  Could then set different display conditions for
subsections of the Parser.

See Pretty.lhs for description of the combinators.
-}
module PrettyM (module PrettyM, module PrettyEnv, P.Mode, P.TextDetails) where

import qualified Pretty as P
import Ratio
import Monad(liftM2,liftM)
import MUtils
import PrettyEnv

-- So that pp code still looks the same 
-- this means we lose some generality though
type Doc = DocM P.Doc

-- The pretty printing combinators

empty :: Doc
empty = return P.empty

isEmpty :: Doc -> Bool
isEmpty d = P.isEmpty $ unDocM d defaultMode

nest :: Int -> Doc -> Doc
nest i m = fmap (P.nest i) m

classNest, doNest, caseNest, letNest, funNest, dataNest
  :: Printable a => a -> Doc
classNest = nest' classIndent
doNest    = nest' doIndent
caseNest  = nest' caseIndent
letNest   = nest' letIndent
funNest   = nest' funIndent
dataNest  = nest' dataIndent

nest' p d = do { e <- getPPEnv ; nest (p e) (ppi d) }

-- Literals

text, ptext :: String -> Doc
text  = return . P.text
ptext = return . P.text

char :: Char -> Doc
char = return . P.char

litChar :: Char -> Doc
litChar = return . P.litChar

litString :: String -> Doc
litString = return . P.litString

int :: Int -> Doc
int = return . P.int

integer :: Integer -> Doc
integer = return . P.integer

float :: Float -> Doc
float = return . P.float

double :: Double -> Doc
double = return . P.double

rational :: Integral a => Ratio a -> Doc
rational = return . P.rational

-- Simple Combining Forms

quotes, charQuotes, backQuotes, doubleQuotes, parens, brackets, curlies, braces
  :: Printable a => a -> Doc
quotes       = lift1 P.quotes
charQuotes   = lift1 P.charQuotes
backQuotes   = lift1 P.backQuotes
doubleQuotes = lift1 P.doubleQuotes
parens       = lift1 P.parens
brackets     = lift1 P.brackets
curlies      = lift1 P.curlies
braces       = curlies

lift1 f d = fmap f (ppi d)

-- Constants

quote, backQuote, doubleQuote :: Doc
quote       = return P.quote
backQuote   = return P.backQuote
doubleQuote = return P.doubleQuote

semi, comma, colon, space, equals :: Doc
semi   = return P.semi
comma  = return P.comma
colon  = return P.colon
space  = return P.space
equals = return P.equals

lparen, rparen, lbrack, rbrack, lcurly, rcurly :: Doc
lparen = return P.lparen
rparen = return P.rparen
lbrack = return P.lbrack
rbrack = return P.rbrack
lcurly = return P.lcurly
rcurly = return P.rcurly

-- Combinators

(<>), (<+>), ($$), ($+$) :: (Printable a,Printable b) => a -> b -> Doc
(<>) = lift2 (P.<>)
(<+>) = lift2 (P.<+>)
($$) = lift2 (P.$$)
($+$) = lift2 (P.$+$)

lift2 op m1 m2 = liftM2 op (ppi m1) (ppi m2)

hcat, hsep, vcat, sep, cat, fsep, fcat :: Printable a => [a] -> Doc
hcat  = liftList P.hcat
hsep  = liftList P.hsep
vcat  = liftList P.vcat
sep   = liftList P.sep
cat   = liftList P.cat
fsep  = liftList P.fsep
fcat  = liftList P.fcat

liftList f ds = fmap f (mapM ppi ds)

-- Some More

hang :: Doc -> Int -> Doc -> Doc
hang dM i rM = do { d <- dM ; r <- rM ; return $ P.hang d i r }

-- Yuk, had to cut-n-paste this one from Pretty.hs
--punctuate :: Doc -> [Doc] -> [Doc]
punctuate p []     = []
punctuate p (d:ds) = go d ds
    where go d []     = [ppi d]
          go d (e:es) = (d <> p) : go e es



-- this is the equivalent of runM now.
renderWithMode :: PPHsMode -> Doc -> String
renderWithMode ppMode d = P.render . unDocM d $ ppMode

render :: Doc -> String
render = renderWithMode defaultMode

fullRenderWithMode :: PPHsMode -> P.Mode -> Int -> Float -> 
		      (P.TextDetails -> a -> a) -> a -> Doc -> a
fullRenderWithMode ppMode m i f fn e mD = 
		   P.fullRender m i f fn e $ (unDocM mD) ppMode


fullRender :: P.Mode -> Int -> Float -> (P.TextDetails -> a -> a) 
	      -> a -> Doc -> a
fullRender = fullRenderWithMode defaultMode

withPPEnv :: PPHsMode -> Doc -> Doc
withPPEnv mode d = return $ (unDocM d) mode

updPPEnv f d = do e <- getPPEnv; withPPEnv (f e) d

doNotation :: Doc -> Doc
doNotation = updPPEnv (\e->e { insideDo = True })


doElseNest d = do e <- getPPEnv
		  if insideDo e then nest (doElseIndent e) (ppi d) else ppi d

-- An attempt at intelligent recovery of parentheses in applications (used
-- currently only for types).  The first time appParens is called, it does not
-- parenthesize the given document, but changes the environment to ensure that
-- subsequent applications are. 
{-
appParens d = do e <- getPPEnv
		 if insideApp e
		    then parens d
		    else withPPEnv (e { insideApp = True }) d
-}

-- This sets insideApp to True without adding parens as well.
--appParensOn = id --updPPEnv (\e->e { insideApp = True })

-- This sets insideApp to False without adding parens as well.  Used when other
-- forms serve to parenthesize, e.g., to prevent [(M a)].
--appParensOff = id -- updPPEnv (\e->e { insideApp = False })


-- This is only used for lists where people most commonly put their _own_
-- curlies and semis.  It is not intended to recreate correct explicit layout
-- for Haskell programs, but merely to allow for pretty printing with curlies
-- and semis.  It might possibly be extendible into something to create
-- explicit layout.
{-
layout :: [Doc] -> Doc
layout []   = empty
layout docs = do e <- getPPEnv
		 case layoutType e of
		     PPSemiColon   ->
		         let (ds, d) = (init docs, last docs)
		         in
			     lcurly <+>
			     (vcat $
		              (map (\ d -> d <+> semi) ds) ++ [ d <+> rcurly ])
		     PPUtrecht     ->
		         let (d:ds) = docs
		         in
		             vcat $
			     (lcurly <+> d) :
			     map (semi <+>) ds ++
			     [ rcurly ]
		     _             ->
		         vcat docs
			 -- all others done as for classic (for the moment)
-}

blankline :: Doc -> Doc
blankline d = do e <- getPPEnv
		 if spacing e && layoutType e /= PPNoLayout
		     then d
			  $$ space
		     else d


ppIfDebug debug = ifM (debugInfo # getPPEnv) (ppi debug) empty

ppIfUnicode unicode ascii =
    ifM (useUnicode # getPPEnv)
        (ppi unicode)
        (ppi ascii)

withUnicode d = updPPEnv (\e->e{useUnicode=True}) d
withDebug   d = updPPEnv (\e->e{debugInfo=True}) d
--------------------------------------------------------------------------------

{-
  The Printable class is due to Urban Boquist.  We define instances for those
  types we want to pretty print.  It should also make the job of extensiblilty
  much easier.
-}

class (Show a{-, Eq a-}) => Printable a where
--  pp      :: a   -> String               -- Prettyprint
    ppi     :: a   -> Doc                  -- Prettyprint Intelligently
    ppiList :: [a] -> Doc                  -- Specialized for Char/String
    ppis    :: a   -> [Doc]                -- To allow for cases in which we
					   -- can generate a list of Docs from
					   -- a given type
    wrap    :: a   -> Doc		   -- for bracketing


--  pp      = render . ppi
    ppi     = text . show

    ppiList = brackets . ppiFSeq
    ppis a  = [ ppi a ]
    wrap    = parens . ppi

pp d = render (ppi d) -- pp used to be a method, but no instance defined it...

instance Show Doc where show = render

instance Printable Doc  where
    ppi = id

ppiSeq :: Printable a => [a] -> Doc
ppiSeq = ppiSet comma

ppiSet :: Printable a => Doc -> [a] -> Doc
ppiSet = ppiSep0 sep

ppiSep0 :: Printable a => ([Doc] -> Doc) -> Doc -> [a] -> Doc
ppiSep0 sepOp separator []  = empty
ppiSep0 sepOp separator [d] = ppi d
ppiSep0 sepOp separator ds  = sepOp $ punctuate separator $ map ppi ds

ppiFSeq :: Printable a => [a] -> Doc
ppiFSeq = ppiFSet comma

ppiFSet :: Printable a => Doc -> [a] -> Doc
ppiFSet = ppiSep0 fsep