uhc-util-0.1.6.7: src/UHC/Util/PrettySimple.hs
{-# LANGUAGE TypeSynonymInstances #-}
-------------------------------------------------------------------------
-- Subset of UU.Pretty, based on very simple pretty printing
-------------------------------------------------------------------------
module UHC.Util.PrettySimple
( PP_Doc, PP(..)
, disp
, hPut
, Doc(..)
, (>|<), (>-<)
, (>#<)
, hlist, hlistReverse, vlist, hv
, fill
, indent
{-
, pp_wrap, pp_quotes, pp_doubleQuotes, pp_parens, pp_brackets, pp_braces
, ppPacked, ppParens, ppBrackets, ppBraces, ppCurlys
-}
, empty, text
-- * Internal use only
, isSingleLine
)
where
import System.IO
-- import Data.Data
import Data.Typeable
-------------------------------------------------------------------------
-- Doc structure
-------------------------------------------------------------------------
-- | Cached info about combi of sub Docs
data Cached = Cached
{ cchEmp :: !Bool -- ^ is it empty
, cchSng :: !Bool -- ^ is it a single line
}
deriving (Typeable)
-- | Doc structure
data Doc
= Emp
| Str !String -- basic string
| Hor !Cached !Doc !Doc -- horizontal positioning
| Ver !Cached !Doc !Doc -- vertical positioning
| Ind !Int !Doc -- indent
deriving (Typeable)
type PP_Doc = Doc
-------------------------------------------------------------------------
-- Basic combinators
-------------------------------------------------------------------------
infixr 3 >|<, >#<
infixr 2 >-<
cached :: (PP a, PP b) => (PP_Doc -> PP_Doc -> Cached) -> (Cached -> PP_Doc -> PP_Doc -> PP_Doc) -> a -> b -> PP_Doc
cached cchd mk l r = mk (cchd l' r') l' r'
where l' = pp l
r' = pp r
-- | PP horizontally aside
(>|<) :: (PP a, PP b) => a -> b -> PP_Doc
l >|< r = cached mkcch Hor l r -- pp l `Hor` pp r
where mkcch l r = Cached emp sng
where emp = isEmpty l && isEmpty r
sng = isSingleLine l && isSingleLine r
-- | PP vertically above
(>-<) :: (PP a, PP b) => a -> b -> PP_Doc
l >-< r = cached mkcch Ver l r -- pp l `Ver` pp r -- pp l <$$> pp r
where mkcch l r = Cached (empl && empr) sng
where empl = isEmpty l
empr = isEmpty r
sng = empl && isSingleLine r || empr && isSingleLine l
-- | PP horizontally aside with 1 blank in between
(>#<) :: (PP a, PP b) => a -> b -> PP_Doc
l >#< r = l >|< " " >|< r
-- | Indent
indent :: PP a => Int -> a -> PP_Doc
indent i d = Ind i $ pp d
{-# INLINE indent #-}
-- | basic string
text :: String -> PP_Doc
text = Str
{-# INLINE text #-}
-- | empty PP
empty :: PP_Doc
empty = Emp
{-# INLINE empty #-}
-------------------------------------------------------------------------
-- Derived combinators
-------------------------------------------------------------------------
vlist, hlist, hlistReverse :: PP a => [a] -> PP_Doc
-- | PP list horizontally
vlist [] = empty
vlist as = foldr (>-<) empty as
-- | PP list vertically
hlist [] = empty
hlist as = foldr (>|<) empty as
-- | PP list vertically reverse
hlistReverse [] = empty
hlistReverse as = foldr (flip (>|<)) empty as
-- | PP list vertically, alias for 'vlist'
hv :: PP a => [a] -> PP_Doc
hv = vlist
-- | PP list horizontally, alias for 'hlist'
fill :: PP a => [a] -> PP_Doc
fill = hlist
-------------------------------------------------------------------------
-- PP class
-------------------------------------------------------------------------
-- | Interface for PP
class Show a => PP a where
pp :: a -> PP_Doc
pp = text . show
ppList :: [a] -> PP_Doc
ppList as = hlist as
instance PP PP_Doc where
pp = id
instance PP Char where
pp c = text [c]
ppList = text
instance PP a => PP [a] where
pp = ppList
instance Show PP_Doc where
show p = disp p 200 ""
instance PP Int where
pp = text . show
instance PP Integer where
pp = text . show
instance PP Float where
pp = text . show
-------------------------------------------------------------------------
-- Observation
-------------------------------------------------------------------------
-- | Is empty doc?
isEmpty :: PP_Doc -> Bool
isEmpty Emp = True
isEmpty (Ver c d1 d2) = cchEmp c
isEmpty (Hor c d1 d2) = cchEmp c
isEmpty (Ind _ d ) = isEmpty d
isEmpty (Str _ ) = False
-- | Is single line doc?
isSingleLine :: PP_Doc -> Bool
isSingleLine Emp = True
isSingleLine (Ver c d1 d2) = cchSng c
isSingleLine (Hor c d1 d2) = cchSng c
isSingleLine (Ind _ d ) = isSingleLine d
isSingleLine (Str _ ) = True
-------------------------------------------------------------------------
-- Rendering
-------------------------------------------------------------------------
-- | Display to string
disp :: PP_Doc -> Int -> ShowS
disp d _ s
= r
where (r,_) = put 0 d s
put p d s
= case d of
Emp -> (s,p)
Str s' -> (s' ++ s,p + length s')
Ind i d -> (ind ++ r,p')
where (r,p') = put (p+i) d s
ind = replicate i ' '
Hor _ d1 d2 -> (r1,p2)
where (r1,p1) = put p d1 r2
(r2,p2) = put p1 d2 s
Ver _ d1 d2 | isEmpty d1
-> put p d2 s
Ver _ d1 d2 | isEmpty d2
-> put p d1 s
Ver _ d1 d2 -> (r1,p2)
where (r1,p1) = put p d1 $ "\n" ++ ind ++ r2
(r2,p2) = put p d2 s
ind = replicate p ' '
-- | Display to Handle
hPut :: Handle -> PP_Doc -> Int -> IO ()
hPut h d _
= do _ <- put 0 d h
return ()
where put p d h
= case d of
Emp -> return p
Str s -> do hPutStr h s
return $ p + length s
Ind i d -> do hPutStr h $ replicate i ' '
put (p+i) d h
Hor _ d1 d2 -> do p' <- put p d1 h
put p' d2 h
Ver _ d1 d2 | isEmpty d1
-> put p d2 h
Ver _ d1 d2 | isEmpty d2
-> put p d1 h
Ver _ d1 d2 -> do _ <- put p d1 h
hPutStr h $ "\n" ++ replicate p ' '
put p d2 h