{-# LANGUAGE FlexibleInstances, Safe #-}

-- | Monadic front-end to Text.PrettyPrint

module Language.Haskell.TH.PprLib (

        -- * The document type
        Doc,            -- Abstract, instance of Show
        PprM,

        -- * Primitive Documents
        empty,
        semi, comma, colon, dcolon, space, equals, arrow,
        lparen, rparen, lbrack, rbrack, lbrace, rbrace,

        -- * Converting values into documents
        text, char, ptext,
        int, integer, float, double, rational,

        -- * Wrapping documents in delimiters
        parens, brackets, braces, quotes, doubleQuotes,

        -- * Combining documents
        (<>), (<+>), hcat, hsep,
        ($$), ($+$), vcat,
        sep, cat,
        fsep, fcat,
        nest,
        hang, punctuate,

        -- * Predicates on documents
        isEmpty,

    to_HPJ_Doc, pprName, pprName'
  ) where


import Language.Haskell.TH.Syntax
    (Uniq, Name(..), showName', NameFlavour(..), NameIs(..))
import qualified Text.PrettyPrint as HPJ
import Control.Monad (liftM, liftM2, ap)
import Language.Haskell.TH.Lib.Map ( Map )
import qualified Language.Haskell.TH.Lib.Map as Map ( lookup, insert, empty )
import Prelude hiding ((<>))

infixl 6 <>
infixl 6 <+>
infixl 5 $$, $+$

-- ---------------------------------------------------------------------------
-- The interface

-- The primitive Doc values

instance Show Doc where
   show :: Doc -> String
show Doc
d = Doc -> String
HPJ.render (Doc -> Doc
to_HPJ_Doc Doc
d)

isEmpty :: Doc    -> PprM Bool;  -- ^ Returns 'True' if the document is empty

empty   :: Doc;                 -- ^ An empty document
semi    :: Doc;                 -- ^ A ';' character
comma   :: Doc;                 -- ^ A ',' character
colon   :: Doc;                 -- ^ A ':' character
dcolon  :: Doc;                 -- ^ A "::" string
space   :: Doc;                 -- ^ A space character
equals  :: Doc;                 -- ^ A '=' character
arrow   :: Doc;                 -- ^ A "->" string
lparen  :: Doc;                 -- ^ A '(' character
rparen  :: Doc;                 -- ^ A ')' character
lbrack  :: Doc;                 -- ^ A '[' character
rbrack  :: Doc;                 -- ^ A ']' character
lbrace  :: Doc;                 -- ^ A '{' character
rbrace  :: Doc;                 -- ^ A '}' character

text     :: String   -> Doc
ptext    :: String   -> Doc
char     :: Char     -> Doc
int      :: Int      -> Doc
integer  :: Integer  -> Doc
float    :: Float    -> Doc
double   :: Double   -> Doc
rational :: Rational -> Doc


parens       :: Doc -> Doc;     -- ^ Wrap document in @(...)@
brackets     :: Doc -> Doc;     -- ^ Wrap document in @[...]@
braces       :: Doc -> Doc;     -- ^ Wrap document in @{...}@
quotes       :: Doc -> Doc;     -- ^ Wrap document in @\'...\'@
doubleQuotes :: Doc -> Doc;     -- ^ Wrap document in @\"...\"@

-- Combining @Doc@ values

(<>)   :: Doc -> Doc -> Doc;     -- ^Beside
hcat   :: [Doc] -> Doc;          -- ^List version of '<>'
(<+>)  :: Doc -> Doc -> Doc;     -- ^Beside, separated by space
hsep   :: [Doc] -> Doc;          -- ^List version of '<+>'

($$)   :: Doc -> Doc -> Doc;     -- ^Above; if there is no
                                 -- overlap it \"dovetails\" the two
($+$)  :: Doc -> Doc -> Doc;     -- ^Above, without dovetailing.
vcat   :: [Doc] -> Doc;          -- ^List version of '$$'

cat    :: [Doc] -> Doc;          -- ^ Either hcat or vcat
sep    :: [Doc] -> Doc;          -- ^ Either hsep or vcat
fcat   :: [Doc] -> Doc;          -- ^ \"Paragraph fill\" version of cat
fsep   :: [Doc] -> Doc;          -- ^ \"Paragraph fill\" version of sep

nest   :: Int -> Doc -> Doc;     -- ^ Nested


-- GHC-specific ones.

hang :: Doc -> Int -> Doc -> Doc;      -- ^ @hang d1 n d2 = sep [d1, nest n d2]@
punctuate :: Doc -> [Doc] -> [Doc]
   -- ^ @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@

-- ---------------------------------------------------------------------------
-- The "implementation"

type State = (Map Name Name, Uniq)
data PprM a = PprM { forall a. PprM a -> State -> (a, State)
runPprM :: State -> (a, State) }

pprName :: Name -> Doc
pprName :: Name -> Doc
pprName = NameIs -> Name -> Doc
pprName' NameIs
Alone

pprName' :: NameIs -> Name -> Doc
pprName' :: NameIs -> Name -> Doc
pprName' NameIs
ni n :: Name
n@(Name OccName
o (NameU Uniq
_))
 = (State -> (Doc, State)) -> Doc
forall a. (State -> (a, State)) -> PprM a
PprM ((State -> (Doc, State)) -> Doc) -> (State -> (Doc, State)) -> Doc
forall a b. (a -> b) -> a -> b
$ \s :: State
s@(Map Name Name
fm, Uniq
i)
        -> let (Name
n', State
s') = case Name -> Map Name Name -> Maybe Name
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n Map Name Name
fm of
                         Just Name
d -> (Name
d, State
s)
                         Maybe Name
Nothing -> let n'' :: Name
n'' = OccName -> NameFlavour -> Name
Name OccName
o (Uniq -> NameFlavour
NameU Uniq
i)
                                    in (Name
n'', (Name -> Name -> Map Name Name -> Map Name Name
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
n Name
n'' Map Name Name
fm, Uniq
i Uniq -> Uniq -> Uniq
forall a. Num a => a -> a -> a
+ Uniq
1))
           in (String -> Doc
HPJ.text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ NameIs -> Name -> String
showName' NameIs
ni Name
n', State
s')
pprName' NameIs
ni Name
n = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ NameIs -> Name -> String
showName' NameIs
ni Name
n

{-
instance Show Name where
  show (Name occ (NameU u))    = occString occ ++ "_" ++ show (I# u)
  show (Name occ NameS)        = occString occ
  show (Name occ (NameG ns m)) = modString m ++ "." ++ occString occ

data Name = Name OccName NameFlavour

data NameFlavour
  | NameU Int#                  -- A unique local name
-}

to_HPJ_Doc :: Doc -> HPJ.Doc
to_HPJ_Doc :: Doc -> Doc
to_HPJ_Doc Doc
d = (Doc, State) -> Doc
forall a b. (a, b) -> a
fst ((Doc, State) -> Doc) -> (Doc, State) -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> State -> (Doc, State)
forall a. PprM a -> State -> (a, State)
runPprM Doc
d (Map Name Name
forall k a. Map k a
Map.empty, Uniq
0)

instance Functor PprM where
      fmap :: forall a b. (a -> b) -> PprM a -> PprM b
fmap = (a -> b) -> PprM a -> PprM b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative PprM where
      pure :: forall a. a -> PprM a
pure a
x = (State -> (a, State)) -> PprM a
forall a. (State -> (a, State)) -> PprM a
PprM ((State -> (a, State)) -> PprM a)
-> (State -> (a, State)) -> PprM a
forall a b. (a -> b) -> a -> b
$ \State
s -> (a
x, State
s)
      <*> :: forall a b. PprM (a -> b) -> PprM a -> PprM b
(<*>) = PprM (a -> b) -> PprM a -> PprM b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad PprM where
    PprM a
m >>= :: forall a b. PprM a -> (a -> PprM b) -> PprM b
>>= a -> PprM b
k  = (State -> (b, State)) -> PprM b
forall a. (State -> (a, State)) -> PprM a
PprM ((State -> (b, State)) -> PprM b)
-> (State -> (b, State)) -> PprM b
forall a b. (a -> b) -> a -> b
$ \State
s -> let (a
x, State
s') = PprM a -> State -> (a, State)
forall a. PprM a -> State -> (a, State)
runPprM PprM a
m State
s
                            in PprM b -> State -> (b, State)
forall a. PprM a -> State -> (a, State)
runPprM (a -> PprM b
k a
x) State
s'

type Doc = PprM HPJ.Doc

-- The primitive Doc values

isEmpty :: Doc -> PprM Bool
isEmpty = (Doc -> Bool) -> Doc -> PprM Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Doc -> Bool
HPJ.isEmpty

empty :: Doc
empty = Doc -> Doc
forall a. a -> PprM a
forall (m :: * -> *) a. Monad m => a -> m a
return Doc
HPJ.empty
semi :: Doc
semi = Doc -> Doc
forall a. a -> PprM a
forall (m :: * -> *) a. Monad m => a -> m a
return Doc
HPJ.semi
comma :: Doc
comma = Doc -> Doc
forall a. a -> PprM a
forall (m :: * -> *) a. Monad m => a -> m a
return Doc
HPJ.comma
colon :: Doc
colon = Doc -> Doc
forall a. a -> PprM a
forall (m :: * -> *) a. Monad m => a -> m a
return Doc
HPJ.colon
dcolon :: Doc
dcolon = Doc -> Doc
forall a. a -> PprM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
HPJ.text String
"::"
space :: Doc
space = Doc -> Doc
forall a. a -> PprM a
forall (m :: * -> *) a. Monad m => a -> m a
return Doc
HPJ.space
equals :: Doc
equals = Doc -> Doc
forall a. a -> PprM a
forall (m :: * -> *) a. Monad m => a -> m a
return Doc
HPJ.equals
arrow :: Doc
arrow = Doc -> Doc
forall a. a -> PprM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
HPJ.text String
"->"
lparen :: Doc
lparen = Doc -> Doc
forall a. a -> PprM a
forall (m :: * -> *) a. Monad m => a -> m a
return Doc
HPJ.lparen
rparen :: Doc
rparen = Doc -> Doc
forall a. a -> PprM a
forall (m :: * -> *) a. Monad m => a -> m a
return Doc
HPJ.rparen
lbrack :: Doc
lbrack = Doc -> Doc
forall a. a -> PprM a
forall (m :: * -> *) a. Monad m => a -> m a
return Doc
HPJ.lbrack
rbrack :: Doc
rbrack = Doc -> Doc
forall a. a -> PprM a
forall (m :: * -> *) a. Monad m => a -> m a
return Doc
HPJ.rbrack
lbrace :: Doc
lbrace = Doc -> Doc
forall a. a -> PprM a
forall (m :: * -> *) a. Monad m => a -> m a
return Doc
HPJ.lbrace
rbrace :: Doc
rbrace = Doc -> Doc
forall a. a -> PprM a
forall (m :: * -> *) a. Monad m => a -> m a
return Doc
HPJ.rbrace

text :: String -> Doc
text = Doc -> Doc
forall a. a -> PprM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc -> Doc) -> (String -> Doc) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
HPJ.text
ptext :: String -> Doc
ptext = Doc -> Doc
forall a. a -> PprM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc -> Doc) -> (String -> Doc) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
HPJ.ptext
char :: Char -> Doc
char = Doc -> Doc
forall a. a -> PprM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc -> Doc) -> (Char -> Doc) -> Char -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Doc
HPJ.char
int :: Int -> Doc
int = Doc -> Doc
forall a. a -> PprM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc -> Doc) -> (Int -> Doc) -> Int -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Doc
HPJ.int
integer :: Uniq -> Doc
integer = Doc -> Doc
forall a. a -> PprM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc -> Doc) -> (Uniq -> Doc) -> Uniq -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Uniq -> Doc
HPJ.integer
float :: Float -> Doc
float = Doc -> Doc
forall a. a -> PprM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc -> Doc) -> (Float -> Doc) -> Float -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Doc
HPJ.float
double :: Double -> Doc
double = Doc -> Doc
forall a. a -> PprM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc -> Doc) -> (Double -> Doc) -> Double -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Doc
HPJ.double
rational :: Rational -> Doc
rational = Doc -> Doc
forall a. a -> PprM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc -> Doc) -> (Rational -> Doc) -> Rational -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Doc
HPJ.rational


parens :: Doc -> Doc
parens = (Doc -> Doc) -> Doc -> Doc
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Doc -> Doc
HPJ.parens
brackets :: Doc -> Doc
brackets = (Doc -> Doc) -> Doc -> Doc
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Doc -> Doc
HPJ.brackets
braces :: Doc -> Doc
braces = (Doc -> Doc) -> Doc -> Doc
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Doc -> Doc
HPJ.braces
quotes :: Doc -> Doc
quotes = (Doc -> Doc) -> Doc -> Doc
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Doc -> Doc
HPJ.quotes
doubleQuotes :: Doc -> Doc
doubleQuotes = (Doc -> Doc) -> Doc -> Doc
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Doc -> Doc
HPJ.doubleQuotes

-- Combining @Doc@ values

<> :: Doc -> Doc -> Doc
(<>) = (Doc -> Doc -> Doc) -> Doc -> Doc -> Doc
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Doc -> Doc -> Doc
(HPJ.<>)
hcat :: [Doc] -> Doc
hcat = ([Doc] -> Doc) -> PprM [Doc] -> Doc
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Doc] -> Doc
HPJ.hcat (PprM [Doc] -> Doc) -> ([Doc] -> PprM [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> PprM [Doc]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
<+> :: Doc -> Doc -> Doc
(<+>) = (Doc -> Doc -> Doc) -> Doc -> Doc -> Doc
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Doc -> Doc -> Doc
(HPJ.<+>)
hsep :: [Doc] -> Doc
hsep = ([Doc] -> Doc) -> PprM [Doc] -> Doc
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Doc] -> Doc
HPJ.hsep (PprM [Doc] -> Doc) -> ([Doc] -> PprM [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> PprM [Doc]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence

$$ :: Doc -> Doc -> Doc
($$) = (Doc -> Doc -> Doc) -> Doc -> Doc -> Doc
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Doc -> Doc -> Doc
(HPJ.$$)
$+$ :: Doc -> Doc -> Doc
($+$) = (Doc -> Doc -> Doc) -> Doc -> Doc -> Doc
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Doc -> Doc -> Doc
(HPJ.$+$)
vcat :: [Doc] -> Doc
vcat = ([Doc] -> Doc) -> PprM [Doc] -> Doc
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Doc] -> Doc
HPJ.vcat (PprM [Doc] -> Doc) -> ([Doc] -> PprM [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> PprM [Doc]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence

cat :: [Doc] -> Doc
cat  = ([Doc] -> Doc) -> PprM [Doc] -> Doc
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Doc] -> Doc
HPJ.cat (PprM [Doc] -> Doc) -> ([Doc] -> PprM [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> PprM [Doc]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
sep :: [Doc] -> Doc
sep  = ([Doc] -> Doc) -> PprM [Doc] -> Doc
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Doc] -> Doc
HPJ.sep (PprM [Doc] -> Doc) -> ([Doc] -> PprM [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> PprM [Doc]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
fcat :: [Doc] -> Doc
fcat = ([Doc] -> Doc) -> PprM [Doc] -> Doc
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Doc] -> Doc
HPJ.fcat (PprM [Doc] -> Doc) -> ([Doc] -> PprM [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> PprM [Doc]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
fsep :: [Doc] -> Doc
fsep = ([Doc] -> Doc) -> PprM [Doc] -> Doc
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Doc] -> Doc
HPJ.fsep (PprM [Doc] -> Doc) -> ([Doc] -> PprM [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> PprM [Doc]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence

nest :: Int -> Doc -> Doc
nest Int
n = (Doc -> Doc) -> Doc -> Doc
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Int -> Doc -> Doc
HPJ.nest Int
n)

hang :: Doc -> Int -> Doc -> Doc
hang Doc
d1 Int
n Doc
d2 = do d1' <- Doc
d1
                  d2' <- d2
                  return (HPJ.hang d1' n d2')

-- punctuate uses the same definition as Text.PrettyPrint
punctuate :: Doc -> [Doc] -> [Doc]
punctuate Doc
_ []     = []
punctuate Doc
p (Doc
d:[Doc]
ds) = Doc -> [Doc] -> [Doc]
go Doc
d [Doc]
ds
                   where
                     go :: Doc -> [Doc] -> [Doc]
go Doc
d' [] = [Doc
d']
                     go Doc
d' (Doc
e:[Doc]
es) = (Doc
d' Doc -> Doc -> Doc
<> Doc
p) Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: Doc -> [Doc] -> [Doc]
go Doc
e [Doc]
es