PrettyPrint2.hs

module PrettyPrint2 where
import qualified PrettyDoc as P(Doc)
import PrettyDoc hiding (Doc)
import PrettyEnv
import TokenTags
import MUtils

type Doc = DocM P.Doc

class Show a => Printable a where
  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

  ppi     = plain

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

-- Essential instances:
instance Show Doc where show (DocM d) = show (d defaultMode) -- useless?
instance Printable Doc  where ppi = id

instance Printable Char where
    ppi	c   = char c
    ppiList = text -- this defines how strings are printed, since String=[Char]
    wrap    = ppi

instance Printable a => Printable [a] where
    ppi  = ppiList
    ppis = map ppi
    wrap = ppi

-- A class to make it easier to print Haskell infix operators correctly:
class Printable a => PrintableOp a where
    isOp :: a -> Bool
    ppiOp :: a -> Doc
{-      How to print operators "mod"   and "+":

	  ppi   should produce "mod"   and "+".
	  wrap  should produce "mod"   and "(+)".
	  ppiOp should produce "`mod`" and "+".      -}

-- A class to make it easier to print type applications like (,) a b and
-- [] Int in the normal way, (a,b) and [Int].
class Printable fun => PrintableApp fun arg where
  wrapApp,ppiApp :: fun -> [arg] -> Doc


cdoc = DocM . const

-- Hughes/SimonPJ style pretty printing operators:

char   = cdoc . Char
text   = cdoc . Text
empty  = cdoc Empty
group l ds = DocM $ \e->Group l [de|DocM d<-map ppi ds,let de=d e,nonEmpty de]
nest n = fmap (nest' n) . ppi
  where
    nest' n (Nest n' d) = nest' (n+n') d
    nest' n d = Nest n d

-- Eta expansions because of the annying monomorphism restriction!
attr a = fmap (Attr a) . ppi
kw   d = attr Reserved d
var  d = attr Var d
con  d = attr Con d
varop d = attr VarOp d
conop d = attr ConOp d
tcon d = attr TCon d
lit  d = attr Lit d
cmnt d = attr Comment d
modn d = attr ModName d

a<>b = hcat [ppi a,ppi b]
a<+>b = hsep [ppi a,ppi b]
a$$b = vcat [ppi a,ppi b]

hcat ds = group (Horiz Cat) ds
hsep ds = group (Horiz Sep) ds
vcat ds = group Vert ds
cat  ds = group (HorizOrVert Cat) ds
sep  ds = group (HorizOrVert Sep) ds
fcat ds = group (Fill Cat) ds
fsep ds = group (Fill Sep) ds

plain x = text (show x)

punctuate p []     = []
punctuate p (d:ds) = go d ds
    where go d []     = [ppi d]
          go d (e:es) = (d <> p) : go e es

-- Additional pretty printing functions:
{-
ppiSeq :: Printable a => [a] -> Doc
ppiSet :: Printable a => Doc -> [a] -> Doc
ppiSep0 :: Printable a => ([Doc] -> Doc) -> Doc -> [a] -> Doc
ppiFSeq :: Printable a => [a] -> Doc
ppiFSet :: Printable a => Doc -> [a] -> Doc
ppiTuple :: Printable a => [a] -> Doc
ppiFTuple :: Printable a => [a] -> Doc
wrapTuple :: Printable a => [a] -> Doc
wrapSeq :: Printable a => [a] -> Doc
wrapSet :: Printable a => Doc -> [a] -> Doc
wrapFTuple :: Printable a => [a] -> Doc
wrapFSeq :: Printable a => [a] -> Doc
wrapFSet :: Printable a => Doc -> [a] -> Doc
wrapSep0 :: Printable a => ([Doc] -> Doc) -> Doc -> [a] -> Doc
-}

ppiSeq ds = ppiSet ',' ds

ppiSet s ds = ppiSep0 sep s ds

ppiSep0 sepOp separator []  = empty
ppiSep0 sepOp separator [d] = ppi d
ppiSep0 sepOp separator ds  = sepOp $ punctuate separator $ map ppi ds

ppiFSeq ds = ppiFSet ',' ds
ppiFSet s ds = ppiSep0 fsep s ds

ppiTuple ds = parens (ppiSeq ds)
ppiFTuple ds = parens (ppiFSeq ds)
wrapTuple ds = parens (wrapSeq ds)
wrapSeq ds = wrapSet ',' ds
wrapSet s ds = wrapSep0 sep s ds
wrapFTuple ds = parens (wrapFSeq ds)
wrapFSeq ds = wrapFSet ',' ds
wrapFSet s ds = wrapSep0 fsep s ds

wrapSep0 sepOp separator []  = empty
wrapSep0 sepOp separator [d] = wrap d
wrapSep0 sepOp separator ds  = sepOp $ punctuate separator $ map wrap ds


--maybepp :: (a -> Doc) -> Maybe a -> Doc
maybepp pf (Just a) = pf a
maybepp _  Nothing  = empty

optpp b x = if b then ppi x else empty

ppiBinOp lhs op rhs = sep [lhs<+>op,letNest rhs]

parenBinOp x op y = parens (ppiBinOp x op y) -- should consult infixParens!!

-- These are rather pointless, but kept around for backwards compatibility:
lparen = kw '('
rparen = kw ')'
lbrack = kw '['
rbrack = kw ']'
lbrace = kw '{'
rbrace = kw '}'
quote = kw '\''
dquote = kw '"'
bquote = kw '`'
equals = kw '='
comma = kw ','
float = plain :: Float->Doc
double = plain :: Double->Doc
space = ppi ' '

parens d = lparen<>d<>rparen
brackets d = lbrack<>d<>rbrack
braces d = lbrace<>d<>rbrace
doubleQuotes d = dquote<>d<>dquote
backQuotes d = bquote<>d<>bquote
{-
	quotes, charQuotes, backQuotes, doubleQuotes,
        quote, backQuote, doubleQuote, semi, comma, colon, space, equals,

        hang, punctuate,
-}

-- Environment manipulating functions:

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

ppIfDebug debug = ifM (debugInfo # getPPEnv) (ppi debug) empty
ppIfTypeInfo tinfo = ifM (typeInfo # getPPEnv) (ppi tinfo) 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

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) }

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

layout ds = do e <- getPPEnv
	       case layoutType e of
		 --PPSemiColon   ->
		 --PPUtrecht     ->
		 PPNoLayout    -> braces . hsep . punctuate ';' $ ds
		 _             -> vcat ds

-- Obsolete:
appParensOn = id
appParensOff = id