{-# LANGUAGE CPP #-}
{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}
#if __GLASGOW_HASKELL__ >= 706
{-# LANGUAGE DeriveGeneric #-}
#endif
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}

-- | Monoids with a homomorphism from 'String' to themselves.
module Text.Printer
  (
  -- * The class
    Printer(..)
  -- * Builders
  , StringBuilder(..)
  , buildString
  , buildText
  , buildLazyText
  , AsciiBuilder(..)
  , buildAscii
  , buildLazyAscii
  , Utf8Builder(..)
  , buildUtf8
  , buildLazyUtf8
  , PrettyPrinter(..)
  , renderPretty
  -- * Combinators
  , (<>)
  , hcat
  , fcat
  , separate
  , (<+>)
  , hsep
  , fsep
  , list
  , parens
  , brackets
  , braces
  , angles
  , squotes
  , dquotes
  , punctuateL
  , punctuateR
  -- * Multiline printers
  , MultilinePrinter(..)
  , lines
  , newLine
  , crlf
  , LinePrinter(..)
  , lfPrinter
  , crlfPrinter
  ) where

import Prelude hiding (foldr, foldr1, print, lines)
#if __GLASGOW_HASKELL__ >= 706
import GHC.Generics (Generic)
#endif
import Data.Typeable (Typeable)
import Data.String (IsString(..))
import Data.Semigroup (Semigroup)
import qualified Data.Semigroup as S
import Data.Monoid (Monoid(..))
#if MIN_VERSION_base(4,5,0)
import Data.Monoid ((<>))
#endif
import Data.Foldable (Foldable(..), toList)
import Data.Traversable (Traversable, mapAccumL, mapAccumR)
import qualified Data.Text as TS
import qualified Data.Text.Encoding as TS
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import qualified Data.Text.Lazy.Builder as TB
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BL8
import qualified Data.ByteString.Lazy.Builder as BB
import qualified Text.PrettyPrint as PP

-- | Text monoid. 'string' must be equivalent to 'fromString' and be a monoid
--   homomorphism, i.e. @'string' 'mempty' = 'mempty'@ and
--   @'mappend' ('string' /x/) ('string' /y/) = 'string' ('mappend' /x/ /y/)@.
--   Other operations must be monoid homomorphisms that are eqiuvalent (but
--   possibly faster) to the composition of 'string' and the corresponding
--   embedding, e.g. @'text' = 'string' . 'TS.unpack'@.
class (IsString p, Semigroup p, Monoid p)  Printer p where
  -- | Print a character. @'char' /c/@ must be equivalent to
  --   @'string' [/c/]@, but hopefully is faster.
  char  Char  p
  char c = string [c]
  {-# INLINE char #-}
  -- | Print an ASCII character, can be faster than 'char'.
  char7  Char  p
  char7 = char
  {-# INLINE char7 #-}
  -- | Print a string.
  string  String  p
  string = fromString
  {-# INLINE string #-}
  -- | Print an ASCII string, can be faster than 'string'.
  string7  String  p
  string7 = string
  {-# INLINE string7 #-}
  -- | Print a 'TS.Text'.
  text  TS.Text  p
  text = string . TS.unpack
  {-# INLINE text #-}
  -- | Print a lazy 'TL.Text'.
  lazyText  TL.Text  p
  lazyText = string . TL.unpack
  {-# INLINE lazyText #-}
  -- | Print an ASCII 'BS.ByteString'.
  ascii  BS.ByteString  p
  ascii = string . BS8.unpack
  {-# INLINE ascii #-}
  -- | Print a lazy ASCII 'BL.ByteString'.
  lazyAscii  BL.ByteString  p
  lazyAscii = string . BL8.unpack
  {-# INLINE lazyAscii #-}
  -- | Print a UTF-8 'BS.ByteString'.
  utf8  BS.ByteString  p
  utf8 = text . TS.decodeUtf8
  {-# INLINE utf8 #-}
  -- | Print a lazy UTF-8 'BL.ByteString'
  lazyUtf8  BL.ByteString  p
  lazyUtf8 = lazyText . TL.decodeUtf8
  {-# INLINE lazyUtf8 #-}

instance Printer String where

-- | A simple string builder as used by 'Show'.
newtype StringBuilder = StringBuilder { stringBuilder  String  String }
                        deriving ( Typeable
#if __GLASGOW_HASKELL__ >= 706
                                 , Generic
#endif
                                 , Semigroup
                                 , Monoid)

instance IsString StringBuilder where
  fromString s = StringBuilder (s ++)
  {-# INLINE fromString #-}

instance Printer StringBuilder where
  char c = StringBuilder (c :)
  {-# INLINE char #-}

buildString  StringBuilder  String
buildString b = stringBuilder b ""
{-# INLINE buildString #-}

instance Printer TB.Builder where
  char = TB.singleton
  {-# INLINE char #-}
  text = TB.fromText
  {-# INLINE text #-}
  lazyText = TB.fromLazyText
  {-# INLINE lazyText #-}

buildText  TB.Builder  TS.Text
buildText = fold . TL.toChunks . buildLazyText
{-# INLINE buildText #-}

buildLazyText  TB.Builder  TL.Text
buildLazyText = TB.toLazyText
{-# INLINE buildLazyText #-}

-- | Use this builder when you are sure that only ASCII characters
--   will get printed to it.
newtype AsciiBuilder = AsciiBuilder { asciiBuilder  BB.Builder }
                       deriving ( Typeable
#if __GLASGOW_HASKELL__ >= 706
                                , Generic
#endif
                                , Monoid)

instance IsString AsciiBuilder where
  fromString = AsciiBuilder . BB.string7
  {-# INLINE fromString #-}

instance Semigroup AsciiBuilder where
  b₁ <> b₂ = AsciiBuilder $ asciiBuilder b₁ <> asciiBuilder b₂
  {-# INLINE (<>) #-}
  stimes = S.stimesMonoid
  {-# INLINE stimes #-}

instance Printer AsciiBuilder where
  char = AsciiBuilder . BB.char7
  {-# INLINE char #-}
  ascii = AsciiBuilder . BB.byteString
  {-# INLINE ascii #-}
  lazyAscii = AsciiBuilder . BB.lazyByteString
  {-# INLINE lazyAscii #-}
  utf8 = AsciiBuilder . BB.byteString
  {-# INLINE utf8 #-}
  lazyUtf8 = AsciiBuilder . BB.lazyByteString
  {-# INLINE lazyUtf8 #-}

buildAscii  AsciiBuilder  BS.ByteString
buildAscii = fold . BL.toChunks . buildLazyAscii
{-# INLINE buildAscii #-}

buildLazyAscii  AsciiBuilder  BL.ByteString
buildLazyAscii = BB.toLazyByteString . asciiBuilder
{-# INLINE buildLazyAscii #-}

-- | UTF-8 lazy 'BL.ByteString' builder.
newtype Utf8Builder = Utf8Builder { utf8Builder  BB.Builder }
                      deriving ( Typeable
#if __GLASGOW_HASKELL__ >= 706
                               , Generic
#endif
                               , Monoid)

instance IsString Utf8Builder where
  fromString = Utf8Builder . BB.stringUtf8
  {-# INLINE fromString #-}

instance Semigroup Utf8Builder where
  b₁ <> b₂ = Utf8Builder $ utf8Builder b₁ <> utf8Builder b₂
  {-# INLINE (<>) #-}
  stimes = S.stimesMonoid
  {-# INLINE stimes #-}

instance Printer Utf8Builder where
  char = Utf8Builder . BB.charUtf8
  {-# INLINE char #-}
  char7 = Utf8Builder . BB.char7
  {-# INLINE char7 #-}
  string7 = Utf8Builder . BB.string7
  {-# INLINE string7 #-}
  text = Utf8Builder . BB.byteString . TS.encodeUtf8
  {-# INLINE text #-}
  lazyText = Utf8Builder . BB.lazyByteString . TL.encodeUtf8
  {-# INLINE lazyText #-}
  ascii = Utf8Builder . BB.byteString
  {-# INLINE ascii #-}
  lazyAscii = Utf8Builder . BB.lazyByteString
  {-# INLINE lazyAscii #-}
  utf8 = Utf8Builder . BB.byteString
  {-# INLINE utf8 #-}
  lazyUtf8 = Utf8Builder . BB.lazyByteString
  {-# INLINE lazyUtf8 #-}

buildUtf8  Utf8Builder  BS.ByteString
buildUtf8 = fold . BL.toChunks . buildLazyUtf8
{-# INLINE buildUtf8 #-}

buildLazyUtf8  Utf8Builder  BL.ByteString
buildLazyUtf8 = BB.toLazyByteString . utf8Builder
{-# INLINE buildLazyUtf8 #-}

newtype PrettyPrinter = PrettyPrinter { prettyPrinter  PP.Doc }
                        deriving ( Typeable
#if __GLASGOW_HASKELL__ >= 706
                                 , Generic
#endif
#if MIN_VERSION_pretty(1,1,0)
                                 , IsString
# if MIN_VERSION_base(4,9,0)
                                 , Semigroup
# endif
                                 , Monoid
#endif
                                 )

#if !MIN_VERSION_pretty(1,1,0)
instance IsString PrettyPrinter where
  fromString = PrettyPrinter . PP.text
  {-# INLINE fromString #-}
#endif

#if !MIN_VERSION_base(4,9,0) || !MIN_VERSION_pretty(1,1,0)
instance Semigroup PrettyPrinter where
  p₁ <> p₂ = PrettyPrinter
           $ (PP.<>) (prettyPrinter p₁) (prettyPrinter p₂)
  {-# INLINE (<>) #-}
  stimes = S.stimesMonoid
  {-# INLINE stimes #-}
#endif

#if !MIN_VERSION_pretty(1,1,0)
instance Monoid PrettyPrinter where
  mempty = PP.empty
  {-# INLINE mempty #-}
  mappend = (S.<>)
  {-# INLINE mappend #-}
#endif

instance Printer PrettyPrinter where
  char = PrettyPrinter . PP.char
  {-# INLINE char #-}

-- | An alias for @'PP.render' . 'prettyPrinter'@
renderPretty  PrettyPrinter  String
renderPretty = PP.render . prettyPrinter

#if !MIN_VERSION_base(4,5,0)
-- | An infix synonym for 'mappend'.
(<>)  Monoid m  m  m  m
(<>) = mappend
{-# INLINE (<>) #-}
#endif

-- | 'mconcat' for 'Foldable' data structures.
hcat  (Printer p, Foldable f)  f p  p
hcat = fold
{-# INLINE hcat #-}

-- | Combine the items of a 'Foldable' data structure using the provided
--   function. If the data structure is empty, 'mempty' is returned.
fcat  (Foldable f, Printer p)  (p  p  p)  f p  p
fcat c f = case toList f of
  []  mempty
  ps  foldr1 c ps
{-# INLINABLE fcat #-}

-- | Concatenate two 'Printer's with a separator between them.
separate  Printer p
          p -- ^ The separator
          p  p  p
separate s x y = x <> s <> y
{-# INLINE separate #-}

infixr 6 <+>

-- | Concatenate two 'Printer's with a space between them.
(<+>)  Printer p  p  p  p
(<+>) = separate (char7 ' ')
{-# INLINE (<+>) #-}

-- | Concatenate the items of a 'Foldable' data structure
--   with spaces between them.
hsep  (Printer p, Foldable f)  f p  p
hsep = fcat (<+>)
{-# INLINE hsep #-}

-- | A shorthand for @'fcat' . 'separate'@.
fsep  (Foldable f, Printer p)  p  f p  p
fsep = fcat . separate
{-# INLINE fsep #-}

-- | Concatenate the items of a 'Foldable' data structure with commas
--   between them.
--
-- @
--   'list' = 'fsep' ('char7' ',')
-- @
list  (Foldable f, Printer p)  f p  p
list = fsep (char7 ',')
{-# INLINE list #-}

-- | Enclose a 'Printer' with parentheses.
parens  Printer p  p  p
parens p = char7 '(' <> p <> char7 ')'
{-# INLINE parens #-}

-- | Enclose a 'Printer' with square brackets.
brackets  Printer p  p  p
brackets p = char7 '[' <> p <> char7 ']'
{-# INLINE brackets #-}

-- | Enclose a 'Printer' with curly braces.
braces  Printer p  p  p
braces p = char7 '{' <> p <> char7 '}'
{-# INLINE braces #-}

-- | Enclose a 'Printer' with angle brackets.
angles  Printer p  p  p
angles p = char7 '<' <> p <> char7 '>'
{-# INLINE angles #-}

-- | Enclose a 'Printer' with single quotes.
squotes  Printer p  p  p
squotes p = char7 '\'' <> p <> char7 '\''
{-# INLINE squotes #-}

-- | Enclose a 'Printer' with double quotes.
dquotes  Printer p  p  p
dquotes p  = char7 '\"' <> p <> char7 '\"'
{-# INLINE dquotes #-}

-- | Prepend all but the first element of a 'Traversable' with the
--   provided value, e.g.
--   @'punctuateL' /p/ [/x1/, /x2/, ..., /xN/] =
--      [/x1/, /p/ '<>' /x2/, ..., /p/ '<>' /xN/]@
punctuateL  (Traversable t, Printer p)  p  t p  t p
punctuateL p =
  snd . mapAccumL (\f a  if f then (False, a) else (False, p <> a)) True
{-# INLINE punctuateL #-}

-- | Append the provided value to all but the last element of a 'Traversable',
--   e.g. @'punctuateR' /p/ [/x1/, ..., /xN-1/, /xN/] =
--           [/x1/ '<>' /p/, ..., /xN-1/ '<>' /p/, /xN/]@
punctuateR  (Traversable t, Printer p)  p  t p  t p
punctuateR p =
  snd . mapAccumR (\l a  if l then (False, a) else (False, a <> p)) True
{-# INLINE punctuateR #-}

infixr 5 <->

-- | Printers that can produce multiple lines of text.
class Printer p  MultilinePrinter p where
  -- | Combine two lines. Must be associative, i.e.
  --   /x/ '<->' (/y/ '<->' /z/) = (/x/ '<->' /y/) '<->' /z/.
  (<->)  p  p  p

instance MultilinePrinter PrettyPrinter where
  p₁ <-> p₂ = PrettyPrinter
            $ (PP.$+$) (prettyPrinter p₁) (prettyPrinter p₂)
  {-# INLINE (<->) #-}

-- | Combine the items of a 'Foldable' data structure with '<->'.
lines  (MultilinePrinter p, Foldable f)  f p  p
lines = fcat (<->)
{-# INLINE lines #-}

-- | Print the LF character (/'\n'/).
newLine  Printer p  p
newLine = char '\n'
{-# INLINE newLine #-}

-- | Print CR (/'\r'/) followed by LF (/'\n'/).
crlf  Printer p  p
crlf = char '\r' <> char '\n'
{-# INLINE crlf #-}

-- | A multiline printer that combines lines with the provided function.
newtype LinePrinter p = LinePrinter { linePrinter  (p  p  p)  p }
                        deriving ( Typeable
#if __GLASGOW_HASKELL__ >= 706
                                 , Generic
#endif
                                 )

instance IsString p  IsString (LinePrinter p) where
  fromString = LinePrinter . const . fromString
  {-# INLINE fromString #-}

instance Semigroup p  Semigroup (LinePrinter p) where
  x <> y = LinePrinter $ \l  linePrinter x l S.<> linePrinter y l
  {-# INLINE (<>) #-}
  stimes n x = LinePrinter $ S.stimes n . linePrinter x
  {-# INLINE stimes #-}

instance Monoid p  Monoid (LinePrinter p) where
  mempty = LinePrinter $ const mempty
  {-# INLINE mempty #-}
  mappend x y = LinePrinter $ \l  mappend (linePrinter x l) (linePrinter y l)
  {-# INLINE mappend #-}
  mconcat xs = LinePrinter $ \l  mconcat (map (\x  linePrinter x l) xs)
  {-# INLINE mconcat #-}

instance Printer p  Printer (LinePrinter p) where
  char = LinePrinter . const . char
  {-# INLINE char #-}
  char7 = LinePrinter . const . char7
  {-# INLINE char7 #-}
  string = LinePrinter . const . string
  {-# INLINE string #-}
  string7 = LinePrinter . const . string7
  {-# INLINE string7 #-}
  text = LinePrinter . const . text
  {-# INLINE text #-}
  lazyText = LinePrinter . const . lazyText
  {-# INLINE lazyText #-}
  ascii = LinePrinter . const . ascii
  {-# INLINE ascii #-}
  lazyAscii = LinePrinter . const . lazyAscii
  {-# INLINE lazyAscii #-}
  utf8 = LinePrinter . const . utf8
  {-# INLINE utf8 #-}
  lazyUtf8 = LinePrinter . const . lazyUtf8
  {-# INLINE lazyUtf8 #-}

instance Printer p  MultilinePrinter (LinePrinter p) where
  x <-> y = LinePrinter $ \l  l (linePrinter x l) (linePrinter y l)
  {-# INLINE (<->) #-}

-- | Separate lines with 'newLine'.
lfPrinter  Printer p  LinePrinter p  p
lfPrinter p = linePrinter p (separate newLine)
{-# INLINE lfPrinter #-}

-- | Separate lines with 'crlf'.
crlfPrinter  Printer p  LinePrinter p  p
crlfPrinter p = linePrinter p (separate crlf)
{-# INLINE crlfPrinter #-}