{-# LANGUAGE CPP #-}
{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}
#if __GLASGOW_HASKELL__ >= 706
{-# LANGUAGE DeriveGeneric #-}
#endif
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
module Text.Printer
(
Printer(..)
, StringBuilder(..)
, buildString
, buildText
, buildLazyText
, AsciiBuilder(..)
, buildAscii
, buildLazyAscii
, Utf8Builder(..)
, buildUtf8
, buildLazyUtf8
, PrettyPrinter(..)
, renderPretty
, (<>)
, hcat
, fcat
, separate
, (<+>)
, hsep
, fsep
, list
, parens
, brackets
, braces
, angles
, squotes
, dquotes
, punctuateL
, punctuateR
, 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
class (IsString p, Semigroup p, Monoid p) ⇒ Printer p where
char ∷ Char → p
char c = string [c]
{-# INLINE char #-}
char7 ∷ Char → p
char7 = char
{-# INLINE char7 #-}
string ∷ String → p
string = fromString
{-# INLINE string #-}
string7 ∷ String → p
string7 = string
{-# INLINE string7 #-}
text ∷ TS.Text → p
text = string . TS.unpack
{-# INLINE text #-}
lazyText ∷ TL.Text → p
lazyText = string . TL.unpack
{-# INLINE lazyText #-}
ascii ∷ BS.ByteString → p
ascii = string . BS8.unpack
{-# INLINE ascii #-}
lazyAscii ∷ BL.ByteString → p
lazyAscii = string . BL8.unpack
{-# INLINE lazyAscii #-}
utf8 ∷ BS.ByteString → p
utf8 = text . TS.decodeUtf8
{-# INLINE utf8 #-}
lazyUtf8 ∷ BL.ByteString → p
lazyUtf8 = lazyText . TL.decodeUtf8
{-# INLINE lazyUtf8 #-}
instance Printer String where
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 #-}
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 #-}
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 #-}
renderPretty ∷ PrettyPrinter → String
renderPretty = PP.render . prettyPrinter
#if !MIN_VERSION_base(4,5,0)
(<>) ∷ Monoid m ⇒ m → m → m
(<>) = mappend
{-# INLINE (<>) #-}
#endif
hcat ∷ (Printer p, Foldable f) ⇒ f p → p
hcat = fold
{-# INLINE hcat #-}
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 #-}
separate ∷ Printer p
⇒ p
→ p → p → p
separate s x y = x <> s <> y
{-# INLINE separate #-}
infixr 6 <+>
(<+>) ∷ Printer p ⇒ p → p → p
(<+>) = separate (char7 ' ')
{-# INLINE (<+>) #-}
hsep ∷ (Printer p, Foldable f) ⇒ f p → p
hsep = fcat (<+>)
{-# INLINE hsep #-}
fsep ∷ (Foldable f, Printer p) ⇒ p → f p → p
fsep = fcat . separate
{-# INLINE fsep #-}
list ∷ (Foldable f, Printer p) ⇒ f p → p
list = fsep (char7 ',')
{-# INLINE list #-}
parens ∷ Printer p ⇒ p → p
parens p = char7 '(' <> p <> char7 ')'
{-# INLINE parens #-}
brackets ∷ Printer p ⇒ p → p
brackets p = char7 '[' <> p <> char7 ']'
{-# INLINE brackets #-}
braces ∷ Printer p ⇒ p → p
braces p = char7 '{' <> p <> char7 '}'
{-# INLINE braces #-}
angles ∷ Printer p ⇒ p → p
angles p = char7 '<' <> p <> char7 '>'
{-# INLINE angles #-}
squotes ∷ Printer p ⇒ p → p
squotes p = char7 '\'' <> p <> char7 '\''
{-# INLINE squotes #-}
dquotes ∷ Printer p ⇒ p → p
dquotes p = char7 '\"' <> p <> char7 '\"'
{-# INLINE dquotes #-}
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 #-}
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 <->
class Printer p ⇒ MultilinePrinter p where
(<->) ∷ p → p → p
instance MultilinePrinter PrettyPrinter where
p₁ <-> p₂ = PrettyPrinter
$ (PP.$+$) (prettyPrinter p₁) (prettyPrinter p₂)
{-# INLINE (<->) #-}
lines ∷ (MultilinePrinter p, Foldable f) ⇒ f p → p
lines = fcat (<->)
{-# INLINE lines #-}
newLine ∷ Printer p ⇒ p
newLine = char '\n'
{-# INLINE newLine #-}
crlf ∷ Printer p ⇒ p
crlf = char '\r' <> char '\n'
{-# INLINE crlf #-}
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 (<->) #-}
lfPrinter ∷ Printer p ⇒ LinePrinter p → p
lfPrinter p = linePrinter p (separate newLine)
{-# INLINE lfPrinter #-}
crlfPrinter ∷ Printer p ⇒ LinePrinter p → p
crlfPrinter p = linePrinter p (separate crlf)
{-# INLINE crlfPrinter #-}