# LANGUAGE MultiParamTypeClasses , FlexibleInstances #
-- | A Pretty printing class using multiparameter type classes for
-- maximal generality with some useful instances.
--
-- the pprinted type comes as the last argument so newtype deriving can be used
-- in more places.

module Doc.PPrint where

import Doc.DocLike
import qualified Data.Map as Map


  - some useful fixities for comparison 
  - 
  - application left 10 
  - infixr 9   . 
  - infixr 8   ^ , ^^ , * * 
  - infixl 7   *   , / , ` quot ` , ` rem ` , ` div ` , ` mod ` 
  - infixl 6   + , - 
  - infixr 5   : 
  - infix   4   = = , /= , < , < = , > = , > 
  - infixr 3   & & 
  - infixr 2   || 
  - infixl 1   > > , > > = 
  - infixr 1   = < < 
  - infixr 0   $ , $ ! , ` seq ` 
  - 
 
 - some useful fixities for comparison
 -
 - application left 10
 - infixr 9  .
 - infixr 8  ^, ^^, **
 - infixl 7  *  , /, `quot`, `rem`, `div`, `mod`
 - infixl 6  +, -
 - infixr 5  :
 - infix  4  ==, /=, <, <=, >=, >
 - infixr 3  &&
 - infixr 2  ||
 - infixl 1  >>, >>=
 - infixr 1  =<<
 - infixr 0  $, $!, `seq`
 -
 -}

data Assoc = AssocLeft | AssocRight | AssocNone
    deriving(Eq,Ord,Show)

class DocLike d => PPrint d a  where
    pprint ::  a -> d
    pprintAssoc :: Assoc -> Int -> a -> d

    pprintAssoc _ _ a = pprint a
    pprint a = pprintAssoc AssocNone (-1) a


    pplist    ::  [a] -> d
    pplist    xs = brackets (hcat (punctuate comma (map pprint xs)))

pprintParen :: PPrint d a => a -> d
pprintParen = pprintPrec 11

pprintPrec n a = pprintAssoc AssocNone n  a

instance PPrint d a => PPrint d [a] where
    pprint  = pplist

instance DocLike d => PPrint d Char where
  pprint  = char
  pplist  = text

instance DocLike d => PPrint d Integer where
  pprint  = tshow

instance DocLike d => PPrint d Int where
  pprint  = tshow

instance DocLike d => PPrint d Float where
  pprint  = tshow

instance DocLike d => PPrint d Double where
  pprint  = tshow

instance DocLike d => PPrint d () where
    pprint () = text "()"

instance (PPrint d a, PPrint d b) => PPrint d (a,b) where
  pprint (x,y) = parens (hsep [pprint x <> comma, pprint y])

checkAssoc a1 n1 a2 n2 | n2 < n1 = id
                       | n1 == n2 && a1 == a2 && a1 /= AssocNone = id
                       | otherwise = parens

checkAssocApp a n p = checkAssoc AssocLeft 10 a n p

pprintBinary a1 n1 a2 n2 x1 b x2 = checkAssoc a1 n1 a2 n2 $ pprintAssoc l n1 x1 <+> b <+> pprintAssoc r n1 x2 where
    l = if a1 == AssocLeft then AssocLeft else AssocNone
    r = if a1 == AssocRight then AssocRight else AssocNone

instance (PPrint d a, PPrint d b) => PPrint d (Either a b) where
  pprintAssoc a n (Left x)  = checkAssocApp a n $ text "Left" <+> pprintPrec 10 x
  pprintAssoc a n (Right x) = checkAssocApp a n $ text "Right" <+> pprintPrec 10 x

instance (PPrint d a, PPrint d b, PPrint d c) => PPrint d (a,b,c) where
  pprint (x,y,z) = parens (hsep [pprint x <> comma,
                                pprint y <> comma,
                                pprint z])

instance (PPrint d a, PPrint d b) => PPrint d (Map.Map a b) where
    pprint m = vcat [ pprint x <+> text "=>" <+> pprint y | (x,y) <- Map.toList m]



 | A Pretty printing class using multiparameter type classes for
 maximal generality with some useful instances.

 the pprinted type comes as the last argument so newtype deriving can be used
 in more places.
# LANGUAGE MultiParamTypeClasses , FlexibleInstances #

module Doc.PPrint where

import Doc.DocLike
import qualified Data.Map as Map


  - some useful fixities for comparison 
  - 
  - application left 10 
  - infixr 9   . 
  - infixr 8   ^ , ^^ , * * 
  - infixl 7   *   , / , ` quot ` , ` rem ` , ` div ` , ` mod ` 
  - infixl 6   + , - 
  - infixr 5   : 
  - infix   4   = = , /= , < , < = , > = , > 
  - infixr 3   & & 
  - infixr 2   || 
  - infixl 1   > > , > > = 
  - infixr 1   = < < 
  - infixr 0   $ , $ ! , ` seq ` 
  - 
 
 - some useful fixities for comparison
 -
 - application left 10
 - infixr 9  .
 - infixr 8  ^, ^^, **
 - infixl 7  *  , /, `quot`, `rem`, `div`, `mod`
 - infixl 6  +, -
 - infixr 5  :
 - infix  4  ==, /=, <, <=, >=, >
 - infixr 3  &&
 - infixr 2  ||
 - infixl 1  >>, >>=
 - infixr 1  =<<
 - infixr 0  $, $!, `seq`
 -
 -}

data Assoc = AssocLeft | AssocRight | AssocNone
    deriving(Eq,Ord,Show)

class DocLike d => PPrint d a  where
    pprint ::  a -> d
    pprintAssoc :: Assoc -> Int -> a -> d

    pprintAssoc _ _ a = pprint a
    pprint a = pprintAssoc AssocNone (-1) a


    pplist    ::  [a] -> d
    pplist    xs = brackets (hcat (punctuate comma (map pprint xs)))

pprintParen :: PPrint d a => a -> d
pprintParen = pprintPrec 11

pprintPrec n a = pprintAssoc AssocNone n  a

instance PPrint d a => PPrint d [a] where
    pprint  = pplist

instance DocLike d => PPrint d Char where
  pprint  = char
  pplist  = text

instance DocLike d => PPrint d Integer where
  pprint  = tshow

instance DocLike d => PPrint d Int where
  pprint  = tshow

instance DocLike d => PPrint d Float where
  pprint  = tshow

instance DocLike d => PPrint d Double where
  pprint  = tshow

instance DocLike d => PPrint d () where
    pprint () = text "()"

instance (PPrint d a, PPrint d b) => PPrint d (a,b) where
  pprint (x,y) = parens (hsep [pprint x <> comma, pprint y])

checkAssoc a1 n1 a2 n2 | n2 < n1 = id
                       | n1 == n2 && a1 == a2 && a1 /= AssocNone = id
                       | otherwise = parens

checkAssocApp a n p = checkAssoc AssocLeft 10 a n p

pprintBinary a1 n1 a2 n2 x1 b x2 = checkAssoc a1 n1 a2 n2 $ pprintAssoc l n1 x1 <+> b <+> pprintAssoc r n1 x2 where
    l = if a1 == AssocLeft then AssocLeft else AssocNone
    r = if a1 == AssocRight then AssocRight else AssocNone

instance (PPrint d a, PPrint d b) => PPrint d (Either a b) where
  pprintAssoc a n (Left x)  = checkAssocApp a n $ text "Left" <+> pprintPrec 10 x
  pprintAssoc a n (Right x) = checkAssocApp a n $ text "Right" <+> pprintPrec 10 x

instance (PPrint d a, PPrint d b, PPrint d c) => PPrint d (a,b,c) where
  pprint (x,y,z) = parens (hsep [pprint x <> comma,
                                pprint y <> comma,
                                pprint z])

instance (PPrint d a, PPrint d b) => PPrint d (Map.Map a b) where
    pprint m = vcat [ pprint x <+> text "=>" <+> pprint y | (x,y) <- Map.toList m]


