Language/Haskell/TH/PprLib.hs

    {-# LANGUAGE FlexibleInstances, MagicHash #-}

    -- | 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, 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
        (Name(..), showName', NameFlavour(..), NameIs(..))
    import qualified Text.PrettyPrint as HPJ
    import Control.Applicative (Applicative(..))
    import Control.Monad (liftM, liftM2, ap)
    import Data.Map ( Map )
    import qualified Data.Map as Map ( lookup, insert, empty )
    import GHC.Base (Int(..))

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

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

    -- The primitive Doc values

    instance Show Doc where
       show d = HPJ.render (to_HPJ_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
    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, Int)
    data PprM a = PprM { runPprM :: State -> (a, State) }

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

    pprName' :: NameIs -> Name -> Doc
    pprName' ni n@(Name o (NameU _))
     = PprM $ \s@(fm, i@(I# i'))
            -> let (n', s') = case Map.lookup n fm of
                             Just d -> (d, s)
                             Nothing -> let n'' = Name o (NameU i')
                                        in (n'', (Map.insert n n'' fm, i + 1))
               in (HPJ.text $ showName' ni n', s')
    pprName' ni n = text $ showName' ni 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 d = fst $ runPprM d (Map.empty, 0)

    instance Functor PprM where
          fmap = liftM

    instance Applicative PprM where
          pure = return
          (<*>) = ap

    instance Monad PprM where
        return x = PprM $ \s -> (x, s)
        m >>= k  = PprM $ \s -> let (x, s') = runPprM m s
                                in runPprM (k x) s'

    type Doc = PprM HPJ.Doc

    -- The primitive Doc values

    isEmpty = liftM HPJ.isEmpty

    empty = return HPJ.empty
    semi = return HPJ.semi
    comma = return HPJ.comma
    colon = return HPJ.colon
    space = return HPJ.space
    equals = return HPJ.equals
    arrow = return $ HPJ.text "->"
    lparen = return HPJ.lparen
    rparen = return HPJ.rparen
    lbrack = return HPJ.lbrack
    rbrack = return HPJ.rbrack
    lbrace = return HPJ.lbrace
    rbrace = return HPJ.rbrace

    text = return . HPJ.text
    ptext = return . HPJ.ptext
    char = return . HPJ.char
    int = return . HPJ.int
    integer = return . HPJ.integer
    float = return . HPJ.float
    double = return . HPJ.double
    rational = return . HPJ.rational

    parens = liftM HPJ.parens
    brackets = liftM HPJ.brackets
    braces = liftM HPJ.braces
    quotes = liftM HPJ.quotes
    doubleQuotes = liftM HPJ.doubleQuotes

    -- Combining @Doc@ values

    (<>) = liftM2 (HPJ.<>)
    hcat = liftM HPJ.hcat . sequence
    (<+>) = liftM2 (HPJ.<+>)
    hsep = liftM HPJ.hsep . sequence

    ($$) = liftM2 (HPJ.$$)
    ($+$) = liftM2 (HPJ.$+$)
    vcat = liftM HPJ.vcat . sequence

    cat  = liftM HPJ.cat . sequence
    sep  = liftM HPJ.sep . sequence
    fcat = liftM HPJ.fcat . sequence
    fsep = liftM HPJ.fsep . sequence

    nest n = liftM (HPJ.nest n)

    hang d1 n d2 = do d1' <- d1
                      d2' <- d2
                      return (HPJ.hang d1' n d2')

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