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

-- 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 >|< :: a -> b -> PP_Doc
>|< b
r = a -> PP_Doc
forall a. PP a => a -> PP_Doc
pp a
l PP_Doc -> PP_Doc -> PP_Doc
`Hor` b -> PP_Doc
forall a. PP a => a -> PP_Doc
pp b
r

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

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

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

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

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

-- empty1 is not a zero for >#<

empty1 :: PP_Doc
empty1 :: PP_Doc
empty1 = PP_Doc
Emp1

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

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

-- Derived combinators

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


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

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

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

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

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

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

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

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

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

-- PP class

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


class Show a => PP a where
  pp     :: a   -> PP_Doc
  pp       = [Char] -> PP_Doc
text ([Char] -> PP_Doc) -> (a -> [Char]) -> a -> PP_Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Char]
forall a. Show a => a -> [Char]
show

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

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

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

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

instance Show Doc where
  show :: PP_Doc -> [Char]
show PP_Doc
p = PP_Doc -> Int -> ShowS
disp PP_Doc
p Int
200 [Char]
""

instance PP Int where
  pp :: Int -> PP_Doc
pp = [Char] -> PP_Doc
text ([Char] -> PP_Doc) -> (Int -> [Char]) -> Int -> PP_Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char]
forall a. Show a => a -> [Char]
show

instance PP Float where
  pp :: Float -> PP_Doc
pp = [Char] -> PP_Doc
text ([Char] -> PP_Doc) -> (Float -> [Char]) -> Float -> PP_Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> [Char]
forall a. Show a => a -> [Char]
show

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

-- Observation

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


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

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

-- Rendering

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


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