-- 
-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons
--               2005 Stefan Wehr - http://www.stefanwehr.de
--
-- This program is free software; you can redistribute it and/or
-- modify it under the terms of the GNU General Public License as
-- published by the Free Software Foundation; either version 2 of
-- the License, or (at your option) any later version.
-- 
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- General Public License for more details.
-- 
-- You should have received a copy of the GNU General Public License
-- along with this program; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
-- 02111-1307, USA.
-- 

module Phrac.Pretty (

    Pretty(..), {- instances -}
    printDoc, showPpr, showPpr', showList, showCommaListed, pprList, pprPair,
    pprPair', dumpMap,

    Precedence, minPrec, maxPrec, Assoc(..), OpSpec, pprInfixOp, usedWhen,

    -- our own combinators
    (<::>),(<:>), (<=>), (<->>),

    module Text.PrettyPrint

  ) where

--
-- Just reexport the standard pretty printer at the moment, however, we
-- may add more ppr combinators here
--

import Text.PrettyPrint
import System.IO
import qualified Phrac.Map as Map

type Precedence = Int
minPrec,maxPrec :: Precedence
minPrec = 0 
maxPrec = 10

class Pretty a where 
    pprPrec :: Precedence -> a -> Doc
    pprPrec _ = ppr
    ppr :: a -> Doc
    ppr = pprPrec 0

instance Pretty Int where pprPrec _ i = text (show i)
instance Pretty Bool where pprPrec _ = text . show
instance Pretty Char where pprPrec _ = char
--instance (Pretty a, Pretty b) => Pretty (a, b) where
--    ppr (a,b) = parens (ppr a <> comma <+> ppr b)

instance Pretty a => Pretty [a] where 
    pprPrec prec s = 
        parens `usedWhen` (prec > minPrec) $ hcat (map (pprPrec maxPrec) s)

instance Pretty Doc where 
    pprPrec _ = id

showPpr :: Pretty p => p -> String
showPpr = show . ppr

showPpr' :: Pretty p => p -> String
showPpr' p = show $ text "`" <> ppr p <> text "'"

pprList :: Pretty p => String -> [p] -> Doc
pprList delim l = 
    hcat $ punctuate (text delim) (map ppr l)

pprPair :: (Pretty p, Pretty q) => (p, q) -> Doc
pprPair (p, q) = parens (ppr p <> text ", " <> ppr q)

pprPair' :: (Pretty p, Pretty q) => String -> (p, q) -> Doc
pprPair' s (p, q) = (ppr p <> text s <> ppr q)

showCommaListed :: Pretty p => [p] -> String
showCommaListed l = 
    show $ text "{" <> pprList ", " l <> text "}"

dumpMap :: (Pretty k, Pretty a) => Map.Map k a -> Doc
dumpMap m = hcat $
            punctuate (text ", ") 
                      (map (\ (k,v) -> ppr k <+> text "-->" <+> ppr v)
                       (Map.assocs m))


--
-- stolen from $fptools/ghc/compiler/utils/Pretty.lhs
-- 
-- This code has a BSD-style license
--
printDoc :: Mode -> Handle -> Doc -> IO ()
printDoc m hdl doc = do 
    fullRender m cols 1.5 put done doc
    hFlush hdl
  where
    put (Chr c) next  = hPutChar hdl c >> next 
    put (Str s) next  = hPutStr  hdl s >> next 
    put (PStr s) next = hPutStr  hdl s >> next 

    done = hPutChar hdl '\n'

    cols = 80


-- partly stolen from http://www.cse.unsw.edu.au/~chak/haskell/code/Pretty.hs

-- associativity of an infix operator
data Assoc = LeftAssoc | RightAssoc | NoAssoc
	   deriving (Eq)

-- conditionally apply a document transformer
--
-- * typically a function like `parens' is applied when the precedences require
--   this
--
usedWhen                        :: (Doc -> Doc) -> Bool -> Doc -> Doc
usedWhen wrap c doc | c          = wrap doc
		    | otherwise  = doc

-- associativity and precedence of an operator
type OpSpec = (Assoc, Precedence)

-- precedence for the left branch of a binary operator given the 
-- associativity and the precedence of the operator.
leftPrec :: OpSpec -> Precedence
leftPrec (opAssoc, opPrec) = 
    if (opAssoc == RightAssoc) then opPrec + 1 else opPrec

-- the same for the right branch
rightPrec :: OpSpec -> Precedence
rightPrec (opAssoc, opPrec) = 
    if (opAssoc == LeftAssoc) then opPrec + 1 else opPrec

pprInfixOp :: (Pretty left, Pretty right, Pretty op) =>
              Precedence   -- context precedence
           -> OpSpec       -- specification for the operator
           -> left -> op -> right -> Doc
pprInfixOp prec spec left op right = 
    parens `usedWhen` (prec > snd spec) $
           (pprPrec (leftPrec spec) left <>
            ppr op <>
            pprPrec (rightPrec spec) right)
           

-- ---------------------------------------------------------------------
-- some stuff we use

infixl 6 <::>
infixl 6 <:>
infixl 6 <=>
infixl 6 <->>

(<::>), (<:>), (<=>), (<->>) :: Doc -> Doc -> Doc

p <::>  q = p <> text " :: " <> q
p <:>   q = p <> text " : "  <> q
p <=>   q = p <> text " = "  <> q
p <->>  q = p <> text " -> " <> q