Outputable.hs

{-  CAO Compiler
    Copyright (C) 2014 Cryptography and Information Security Group, HASLab - INESC TEC and Universidade do Minho

    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 3 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, see <http://www.gnu.org/licenses/>. -}

{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverlappingInstances #-}

{-
Module      :  $Header$
Description :  Typeclass for pretty printing
Copyright   :  (C) 2014 Cryptography and Information Security Group, HASLab - INESC TEC and Universidade do Minho
License     :  GPL

Maintainer  :  Paulo Silva <paufil@di.uminho.pt>
Stability   :  experimental
Portability :  non-portable

CAO 'PP' class based on the GHC Outputable typeclass
-}

module Language.CAO.Common.Outputable
    ( 
    -- * PP Class
      PP(..)

    , mppr
    , pprElems
  
    -- * Configurable Doc Type
    , CDoc
    , docToCDoc

    -- * Show CDoc
    , showCDoc, showCDocDebug, showCDocIds
    , showPpr, showPprDebug, showPprIds

    -- * Conditional pretty printing
    , ifPprDebug, ifPprIds
    , noPprDebug

    -- * Values to CDoc
    , char, text, int, integer, float, double, rational

    -- * Simple derived CDocs
    , semi, comma, colon, space, equals
    , lparen, rparen, lbrack, rbrack, lbrace, rbrace

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

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

    -- * Predicates on CDocs
    , isEmpty
    ) where

import Text.PrettyPrint ( Doc )
import qualified Text.PrettyPrint as Pretty

type CDoc = PprCfg -> Doc

showCDoc :: CDoc -> String
showCDoc d = show (d PprCode)

showCDocDebug :: CDoc -> String
showCDocDebug d = show (d PprDebug)

showCDocIds :: CDoc -> String
showCDocIds d = show (d PprIds)

data PprCfg
    = PprCode   -- Pretty printing code
    | PprIds    -- Pretty print variable ids
    | PprDebug  -- Full verbose pretty printing

ifPprDebug :: CDoc -> CDoc
ifPprDebug d sty@PprDebug = d sty
ifPprDebug _ _            = Pretty.empty

ifPprIds :: CDoc -> CDoc
ifPprIds d sty@PprIds = d sty
ifPprIds _ _          = Pretty.empty

noPprDebug :: CDoc -> CDoc
noPprDebug d0 PprDebug = d0 PprCode
noPprDebug d0 sty      = d0 sty

class PP a where
    ppr     :: a -> CDoc

showPpr :: PP a => a -> String
showPpr = showCDoc . ppr

showPprDebug :: PP a => a -> String
showPprDebug = showCDocDebug . ppr

showPprIds :: PP a => a -> String
showPprIds = showCDocIds . ppr

instance PP Doc where
    ppr a _sty = a

instance PP Integer where
    ppr i = integer i

instance PP Int where
    ppr i = int i

instance PP Char where
    ppr i = char i

instance PP a => PP (Maybe a) where
    ppr Nothing  = text "Nothing"
    ppr (Just a) = text "Just" <+> ppr a 

mppr :: PP a => Maybe a -> CDoc
mppr Nothing  = empty
mppr (Just a) = ppr a

instance PP String where
    ppr xs = text xs

instance PP a => PP [a] where
    ppr xs = brackets (pprElems xs)

pprElems :: PP a => [a] -> CDoc
pprElems xs = fsep (punctuate comma (map ppr xs))

instance (PP a, PP b) => PP (a, b) where
    ppr (a, b) = parens (ppr a <> comma <+> ppr b)

instance (PP a, PP b, PP c) => PP (a, b, c) where
    ppr (a, b, c) = parens $ ppr a <> comma <+> ppr b <> comma <+> ppr c

docToCDoc :: Doc -> CDoc
docToCDoc d = \_ -> d

char     :: Char       -> CDoc
char c _sty = Pretty.char c

text     :: String     -> CDoc
text s _sty = Pretty.text s

int      :: Int        -> CDoc
int n _sty = Pretty.int n

integer  :: Integer    -> CDoc
integer n _sty = Pretty.integer n

float    :: Float      -> CDoc
float n _sty = Pretty.float n

double   :: Double     -> CDoc
double n _sty = Pretty.double n

rational :: Rational   -> CDoc
rational n _sty = Pretty.rational n


semi :: CDoc
semi _sty = Pretty.semi

comma :: CDoc
comma _sty = Pretty.comma

colon :: CDoc
colon _sty = Pretty.colon

space :: CDoc
space _sty = Pretty.space

equals :: CDoc
equals _sty = Pretty.equals

lparen :: CDoc
lparen _sty = Pretty.lparen

rparen :: CDoc
rparen _sty = Pretty.rparen

lbrack :: CDoc
lbrack _sty = Pretty.lbrack

rbrack :: CDoc
rbrack _sty = Pretty.rbrack

lbrace :: CDoc
lbrace _sty = Pretty.lbrace

rbrace :: CDoc
rbrace _sty = Pretty.rbrace

parens :: CDoc -> CDoc
parens p sty = Pretty.parens (p sty)

brackets :: CDoc -> CDoc
brackets p sty = Pretty.brackets (p sty)

braces :: CDoc -> CDoc
braces p sty = Pretty.braces (p sty)

quotes :: CDoc -> CDoc
quotes p sty = Pretty.quotes (p sty)

doubleQuotes :: CDoc -> CDoc
doubleQuotes p sty = Pretty.doubleQuotes (p sty)

empty :: CDoc
empty _sty = Pretty.empty

(<>) :: CDoc -> CDoc -> CDoc
d1 <> d2 = \sty -> d1 sty Pretty.<> d2 sty

(<+>) :: CDoc -> CDoc -> CDoc
d1 <+> d2 = \sty ->  d1 sty Pretty.<+> d2 sty

hcat :: [CDoc] -> CDoc
hcat ds sty = Pretty.hcat [d sty | d <- ds]

hsep :: [CDoc] -> CDoc
hsep ds sty = Pretty.hsep [d sty | d <- ds]

($$) :: CDoc -> CDoc -> CDoc
d1 $$ d2 = \sty -> d1 sty Pretty.$$ d2 sty

($+$) :: CDoc -> CDoc -> CDoc
d1 $+$ d2 = \sty -> d1 sty Pretty.$+$ d2 sty

vcat :: [CDoc] -> CDoc
vcat ds sty = Pretty.vcat [d sty | d <- ds]

vsep :: [CDoc] -> CDoc
vsep ds = foldr ($+$) empty ds

sep :: [CDoc] -> CDoc
sep ds sty = Pretty.sep [d sty | d <- ds]

cat :: [CDoc] -> CDoc
cat ds sty = Pretty.cat [d sty | d <- ds]

fsep :: [CDoc] -> CDoc
fsep ds sty = Pretty.fsep [d sty | d <- ds]

fcat :: [CDoc] -> CDoc
fcat ds sty = Pretty.fcat [d sty | d <- ds]

nest :: Int -> CDoc -> CDoc
nest n d sty = Pretty.nest n (d sty)

hang :: CDoc -> Int -> CDoc -> CDoc
hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)

punctuate :: CDoc -> [CDoc] -> [CDoc]
punctuate _ []     = []
punctuate p (doc:docs) = go doc docs
    where 
    go d [] = [d]
    go d (e:es) = (d <> p) : go e es

isEmpty :: CDoc -> Bool
isEmpty d = Pretty.isEmpty (d PprCode)