{-|

Module : $Header$

Copyright : (c) Uni Bremen 2002-2004

License : similar to LGPL, see HetCATS/LICENSE.txt or LIZENZ.txt

Maintainer : maeder@tzi.de

Stability : provisional

Portability : portable

the doc monad for HsPretty and AHsPretty

-}

module Haskell.Hatchet.Docs where

import qualified Common.Lib.Pretty as P

infixl 5 $$$

-----------------------------------------------------------------------------

-- pretty printing monad

data PPLayout = PPOffsideRule -- classical layout

| PPSemiColon -- classical layout made explicit

| PPInLine -- inline decls, \n between them

| PPNoLayout -- everything on a single line

deriving Eq

type Indent = Int

data PPHsMode = PPHsMode {

classIndent :: Indent, -- class, instance

doIndent :: Indent,

caseIndent :: Indent,

letIndent :: Indent,

whereIndent :: Indent,

onsideIndent :: Indent,

spacing :: Bool, -- blank lines between statements?

layout :: PPLayout, -- to do

comments :: Bool -- to come later

}

defaultMode = PPHsMode{

classIndent = 8,

doIndent = 3,

caseIndent = 4,

letIndent = 4,

whereIndent = 6,

onsideIndent = 2,

spacing = True,

layout = PPOffsideRule,

comments = True

}

newtype DocM s a = DocM (s -> a)

instance Functor (DocM s) where

fmap f xs = do x <- xs; return (f x)

instance Monad (DocM s) where

(>>=) = thenDocM

(>>) = then_DocM

return = retDocM

{-# INLINE thenDocM #-}

{-# INLINE then_DocM #-}

{-# INLINE retDocM #-}

{-# INLINE unDocM #-}

{-# INLINE getPPEnv #-}

thenDocM m k = DocM $ (\s -> case unDocM m $ s of a -> unDocM (k a) $ s)

then_DocM m k = DocM $ (\s ->case unDocM m $ s of a -> unDocM k $ s)

retDocM a = DocM (\s -> a)

unDocM :: DocM s a -> (s -> a)

unDocM (DocM f) = f

-- all this extra stuff, just for this one function..

getPPEnv :: DocM s s

getPPEnv = DocM id

-- So that pp code still looks the same

-- this means we lose some generality though

type Doc = DocM PPHsMode P.Doc

-- The pretty printing combinators

empty :: Doc

empty = return P.empty

nest :: Int -> Doc -> Doc

nest i m = m >>= return . P.nest i

-- Literals

text, ptext :: String -> Doc

text = return . P.text

ptext = return . P.text

char :: Char -> Doc

char = return . P.char

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 :: Rational -> Doc

rational = return . P.rational

-- Simple Combining Forms

parens, brackets, braces,quotes,doubleQuotes :: Doc -> Doc

parens d = d >>= return . P.parens

brackets d = d >>= return . P.brackets

braces d = d >>= return . P.braces

quotes d = d >>= return . P.quotes

doubleQuotes d = d >>= return . P.doubleQuotes

-- Constants

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,lbrace,rbrace :: Doc

lparen = return P.lparen

rparen = return P.rparen

lbrack = return P.lbrack

rbrack = return P.rbrack

lbrace = return P.lbrace

rbrace = return P.rbrace

-- Combinators

(<>),(<+>),($$),($+$) :: Doc -> Doc -> Doc

aM <> bM = do{a<-aM;b<-bM;return (a P.<> b)}

aM <+> bM = do{a<-aM;b<-bM;return (a P.<+> b)}

aM $$ bM = do{a<-aM;b<-bM;return (a P.$$ b)}

aM $+$ bM = do{a<-aM;b<-bM;return (a P.$+$ b)}

hcat,hsep,vcat,sep,cat,fsep,fcat :: [Doc] -> Doc

hcat dl = sequence dl >>= return . P.hcat

hsep dl = sequence dl >>= return . P.hsep

vcat dl = sequence dl >>= return . P.vcat

sep dl = sequence dl >>= return . P.sep

cat dl = sequence dl >>= return . P.cat

fsep dl = sequence dl >>= return . P.fsep

fcat dl = sequence dl >>= return . P.fcat

-- 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 [] = [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

------------------------- pp utils -------------------------

maybePP :: (a -> Doc) -> Maybe a -> Doc

maybePP pp Nothing = empty

maybePP pp (Just a) = pp a

parenList :: [Doc] -> Doc

parenList = parens . myFsepSimple . punctuate comma

braceList :: [Doc] -> Doc

braceList = braces . myFsepSimple . punctuate comma

bracketList :: [Doc] -> Doc

bracketList = brackets . myFsepSimple

-- Monadic PP Combinators -- these examine the env

blankline :: Doc -> Doc

blankline dl = do{e<-getPPEnv;if spacing e && layout e /= PPNoLayout

then space $$ dl else dl}

topLevel :: Doc -> [Doc] -> Doc

topLevel header dl = do

e <- fmap layout getPPEnv

case e of

PPOffsideRule -> header $$ vcat dl

PPSemiColon -> header $$ (braces . vcat . punctuate semi) dl

PPInLine -> header $$ (braces . vcat . punctuate semi) dl

PPNoLayout -> header <+> (braces . hsep . punctuate semi) dl

body :: (PPHsMode -> Int) -> [Doc] -> Doc

body f dl = do

e <- fmap layout getPPEnv

case e of PPOffsideRule -> indent

PPSemiColon -> indentExplicit

_ -> inline

where

inline = braces . hsep . punctuate semi $ dl

indent = do{i <-fmap f getPPEnv;nest i . vcat $ dl}

indentExplicit = do {i <- fmap f getPPEnv;

nest i . braces . vcat . punctuate semi $ dl}

($$$) :: Doc -> Doc -> Doc

a $$$ b = layoutChoice (a $$) (a <+>) b

mySep :: [Doc] -> Doc

mySep = layoutChoice mySep' hsep

where

-- ensure paragraph fills with indentation.

mySep' [x] = x

mySep' (x:xs) = x <+> fsep xs

mySep' [] = error "Internal error: mySep"

myVcat :: [Doc] -> Doc

myVcat = layoutChoice vcat hsep

myFsepSimple :: [Doc] -> Doc

myFsepSimple = layoutChoice fsep hsep

-- same, except that continuation lines are indented,

-- which is necessary to avoid triggering the offside rule.

myFsep :: [Doc] -> Doc

myFsep = layoutChoice fsep' hsep

where fsep' [] = empty

fsep' (d:ds) = do

e <- getPPEnv

let n = onsideIndent e

nest n (fsep (nest (-n) d:ds))

layoutChoice :: (a -> Doc) -> (a -> Doc) -> a -> Doc

layoutChoice a b dl = do e <- getPPEnv

if layout e == PPOffsideRule ||

layout e == PPSemiColon

then a dl else b dl

parensIf :: Bool -> Doc -> Doc

parensIf True = parens

parensIf False = id