-------------------------------------------------------------------------
-- Subset of UU.Pretty, based on very simple pretty printing
-- Extended with line-nr tracking
-------------------------------------------------------------------------

module Pretty
  ( PP_Doc, PP(..)
  , disp

  , (>|<), (>-<)
  , (>#<)
  , ppWithLineNr
  , hlist, vlist, hv
  , fill
  , indent

  , pp_block
  , vlist_sep
  , pp_parens
  , pp_braces
  , hv_sp

  , empty, empty1, text
  , isEmpty
  )
  where

import Data.List(intersperse)

-------------------------------------------------------------------------
-- Doc structure
-------------------------------------------------------------------------

data Doc
  = Emp
  | Emp1
  | Str         !String                 -- basic string
  | Hor         Doc  !Doc               -- horizontal positioning
  | Ver         Doc  !Doc               -- vertical positioning
  | Ind         !Int Doc                -- indent
  | Line        (Int -> Doc)            -- line nr

type PP_Doc = Doc

-------------------------------------------------------------------------
-- Basic combinators
-------------------------------------------------------------------------

infixr 3 >|<, >#<
infixr 2 >-<

(>|<) :: (PP a, PP b) => a -> b -> PP_Doc
a
l >|< :: forall a b. (PP a, PP b) => a -> b -> Doc
>|< b
r = forall a. PP a => a -> Doc
pp a
l Doc -> Doc -> Doc
`Hor` forall a. PP a => a -> Doc
pp b
r

(>-<) :: (PP a, PP b) => a -> b -> PP_Doc
a
l >-< :: forall a b. (PP a, PP b) => a -> b -> Doc
>-< b
r  | Doc -> Bool
isEmpty Doc
a = Doc
b
         | Doc -> Bool
isEmpty Doc
b = Doc
a
         | Bool
otherwise = Doc
a Doc -> Doc -> Doc
`Ver` Doc
b
         where a :: Doc
a = forall a. PP a => a -> Doc
pp a
l
               b :: Doc
b = forall a. PP a => a -> Doc
pp b
r

(>#<) :: (PP a, PP b) => a -> b -> PP_Doc
a
l >#< :: forall a b. (PP a, PP b) => a -> b -> Doc
>#< b
r  | Doc -> Bool
isEmpty Doc
a = Doc
b
         | Doc -> Bool
isEmpty Doc
b = Doc
a
         | Bool
otherwise = Doc
a forall a b. (PP a, PP b) => a -> b -> Doc
>|< String
" " forall a b. (PP a, PP b) => a -> b -> Doc
>|< Doc
b
         where a :: Doc
a = forall a. PP a => a -> Doc
pp a
l
               b :: Doc
b = forall a. PP a => a -> Doc
pp b
r

indent :: PP a => Int -> a -> PP_Doc
indent :: forall a. PP a => Int -> a -> Doc
indent Int
i a
d = Int -> Doc -> Doc
Ind Int
i forall a b. (a -> b) -> a -> b
$ forall a. PP a => a -> Doc
pp a
d

text :: String -> PP_Doc
text :: String -> Doc
text String
s
  = let ls :: [String]
ls = String -> [String]
lines String
s
        ls' :: [String]
ls' | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
ls   = [String
""]
            | Bool
otherwise = [String]
ls
    in forall a. PP a => [a] -> Doc
vlist (forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
Str [String]
ls')

empty :: PP_Doc
empty :: Doc
empty = Doc
Emp

-- empty1 is not a zero for >#<
empty1 :: PP_Doc
empty1 :: Doc
empty1 = Doc
Emp1

ppWithLineNr :: PP a => (Int -> a) -> PP_Doc
ppWithLineNr :: forall a. PP a => (Int -> a) -> Doc
ppWithLineNr Int -> a
f = (Int -> Doc) -> Doc
Line (forall a. PP a => a -> Doc
pp forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a
f)

-------------------------------------------------------------------------
-- Derived combinators
-------------------------------------------------------------------------

hlist, vlist :: PP a => [a] -> PP_Doc
vlist :: forall a. PP a => [a] -> Doc
vlist [] = Doc
empty
vlist [a]
as = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr  forall a b. (PP a, PP b) => a -> b -> Doc
(>-<) Doc
empty [a]
as
hlist :: forall a. PP a => [a] -> Doc
hlist [] = Doc
empty
hlist [a]
as = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr  forall a b. (PP a, PP b) => a -> b -> Doc
(>|<) Doc
empty [a]
as

hv :: PP a => [a] -> PP_Doc
hv :: forall a. PP a => [a] -> Doc
hv = forall a. PP a => [a] -> Doc
vlist

hv_sp :: PP a => [a] -> PP_Doc
hv_sp :: forall a. PP a => [a] -> Doc
hv_sp = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a b. (PP a, PP b) => a -> b -> Doc
(>#<) Doc
empty

fill :: PP a => [a] -> PP_Doc
fill :: forall a. PP a => [a] -> Doc
fill = forall a. PP a => [a] -> Doc
hlist

pp_block:: (PP a, PP b, PP c) => a -> b -> c -> [PP_Doc] -> PP_Doc
pp_block :: forall a b c. (PP a, PP b, PP c) => a -> b -> c -> [Doc] -> Doc
pp_block a
o b
c c
s [Doc]
as = forall a. PP a => a -> Doc
pp a
o forall a b. (PP a, PP b) => a -> b -> Doc
>|< forall a. PP a => [a] -> Doc
hlist (forall a. a -> [a] -> [a]
intersperse (forall a. PP a => a -> Doc
pp c
s) [Doc]
as) forall a b. (PP a, PP b) => a -> b -> Doc
>|< forall a. PP a => a -> Doc
pp b
c

pp_parens :: PP a => a -> PP_Doc
pp_parens :: forall a. PP a => a -> Doc
pp_parens a
p = Char
'(' forall a b. (PP a, PP b) => a -> b -> Doc
>|< a
p forall a b. (PP a, PP b) => a -> b -> Doc
>|< Char
')'

pp_braces :: PP a => a -> PP_Doc
pp_braces :: forall a. PP a => a -> Doc
pp_braces a
p = Char
'{' forall a b. (PP a, PP b) => a -> b -> Doc
>-< a
p forall a b. (PP a, PP b) => a -> b -> Doc
>-< Char
'}'

vlist_sep :: (PP a, PP b) => a -> [b] -> PP_Doc
vlist_sep :: forall a b. (PP a, PP b) => a -> [b] -> Doc
vlist_sep a
sep [b]
lst
  = forall a. PP a => [a] -> Doc
vlist (forall a. a -> [a] -> [a]
intersperse (forall a. PP a => a -> Doc
pp a
sep) (forall a b. (a -> b) -> [a] -> [b]
map forall a. PP a => a -> Doc
pp [b]
lst))

-------------------------------------------------------------------------
-- PP class
-------------------------------------------------------------------------

class Show a => PP a where
  pp     :: a   -> PP_Doc
  pp       = String -> Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

  ppList :: [a] -> PP_Doc
  ppList [a]
as = forall a. PP a => [a] -> Doc
hlist [a]
as

instance PP Doc where
  pp :: Doc -> Doc
pp     = forall a. a -> a
id

instance PP Char where
  pp :: Char -> Doc
pp Char
c   = String -> Doc
text [Char
c]
  ppList :: String -> Doc
ppList = String -> Doc
text

instance PP a => PP [a] where
  pp :: [a] -> Doc
pp = forall a. PP a => [a] -> Doc
ppList

instance Show Doc where
  show :: Doc -> String
show Doc
p = Doc -> Int -> ShowS
disp Doc
p Int
200 String
""

instance PP Int where
  pp :: Int -> Doc
pp = String -> Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

instance PP Float where
  pp :: Float -> Doc
pp = String -> Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

-------------------------------------------------------------------------
-- Observation
-------------------------------------------------------------------------

isEmpty :: PP_Doc -> Bool
isEmpty :: Doc -> Bool
isEmpty Doc
Emp         = Bool
True
isEmpty Doc
Emp1        = Bool
False
isEmpty (Ver Doc
d1 Doc
d2) = Doc -> Bool
isEmpty Doc
d1 Bool -> Bool -> Bool
&& Doc -> Bool
isEmpty Doc
d2
isEmpty (Hor Doc
d1 Doc
d2) = Doc -> Bool
isEmpty Doc
d1 Bool -> Bool -> Bool
&& Doc -> Bool
isEmpty Doc
d2
isEmpty (Ind Int
_  Doc
d ) = Doc -> Bool
isEmpty Doc
d
isEmpty Doc
_           = Bool
False

-------------------------------------------------------------------------
-- Rendering
-------------------------------------------------------------------------

disp  ::  PP_Doc -> Int -> ShowS
disp :: Doc -> Int -> ShowS
disp Doc
d0 Int
_ String
s0
  = String
r
  where (String
r,Int
_,Int
_) = Int -> Int -> Doc -> String -> (String, Int, Int)
put Int
0 Int
1 Doc
d0 String
s0
        put :: Int -> Int -> Doc -> String -> (String, Int, Int)
put Int
p Int
l Doc
d String
s
          = case Doc
d of
              Doc
Emp              -> (String
s,Int
p,Int
l)
              Doc
Emp1             -> (String
s,Int
p,Int
l)
              Str String
s'           -> (String
s' forall a. [a] -> [a] -> [a]
++ String
s,Int
p forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s',Int
l)
              Ind Int
i  Doc
d1        -> (String
ind forall a. [a] -> [a] -> [a]
++ String
r',Int
p', Int
l')
                               where (String
r',Int
p',Int
l') = Int -> Int -> Doc -> String -> (String, Int, Int)
put (Int
pforall a. Num a => a -> a -> a
+Int
i) Int
l Doc
d1 String
s
                                     ind :: String
ind = forall a. Int -> a -> [a]
replicate Int
i Char
' '
              Hor Doc
d1 Doc
d2        -> (String
r1,Int
p2,Int
l2)
                               where (String
r1,Int
p1,Int
l1) = Int -> Int -> Doc -> String -> (String, Int, Int)
put Int
p  Int
l  Doc
d1 String
r2
                                     (String
r2,Int
p2,Int
l2) = Int -> Int -> Doc -> String -> (String, Int, Int)
put Int
p1 Int
l1 Doc
d2 String
s
              Ver Doc
d1 Doc
d2 | Doc -> Bool
isEmpty Doc
d1
                               -> Int -> Int -> Doc -> String -> (String, Int, Int)
put Int
p Int
l Doc
d2 String
s
              Ver Doc
d1 Doc
d2 | Doc -> Bool
isEmpty Doc
d2
                               -> Int -> Int -> Doc -> String -> (String, Int, Int)
put Int
p Int
l Doc
d1 String
s
              Ver Doc
d1 Doc
d2        -> (String
r1,Int
p2,Int
l2)
                               where (String
r1,Int
_ ,Int
l1) = Int -> Int -> Doc -> String -> (String, Int, Int)
put Int
p Int
l Doc
d1 forall a b. (a -> b) -> a -> b
$ String
"\n" forall a. [a] -> [a] -> [a]
++ String
ind forall a. [a] -> [a] -> [a]
++ String
r2
                                     (String
r2,Int
p2,Int
l2) = Int -> Int -> Doc -> String -> (String, Int, Int)
put Int
p (Int
l1forall a. Num a => a -> a -> a
+Int
1) Doc
d2 String
s
                                     ind :: String
ind = forall a. Int -> a -> [a]
replicate Int
p Char
' '
              Line Int -> Doc
f           -> (String
r',Int
p',Int
l')
                               where (String
r',Int
p',Int
l') = Int -> Int -> Doc -> String -> (String, Int, Int)
put Int
p Int
l (Int -> Doc
f Int
l) String
s