{-# LANGUAGE OverloadedStrings #-}
module Network.Email.Header.Doc
(
RenderOptions(..)
, Encoding(..)
, defaultRenderOptions
, Doc
, render
, prim
, group
, builder
, string
, byteString
, text
, space
, newline
, line
, linebreak
, softline
, softbreak
, (</>)
, sep
, punctuate
) where
import qualified Data.ByteString as B
import Data.ByteString.Lazy.Builder (Builder)
import qualified Data.ByteString.Lazy.Builder as B
import qualified Data.ByteString.Lazy as LB
import Data.List (intersperse)
import Data.String
import qualified Data.Text.Lazy as L
import qualified Data.Text.Lazy.Encoding as L
import Network.Email.Charset
import Network.Email.Header.Layout (Layout)
import qualified Network.Email.Header.Layout as F
infixr 6 </>
data RenderOptions = RenderOptions
{
lineWidth :: Int
, indent :: Int
, charset :: Charset
, encoding :: Encoding
} deriving (Eq, Show)
data Encoding
= QP
| Base64
deriving (Eq, Ord, Read, Show, Enum, Bounded)
defaultRenderOptions :: RenderOptions
defaultRenderOptions = RenderOptions
{ lineWidth = 80
, indent = 2
, charset = defaultCharset
, encoding = QP
}
data Doc
= Empty
| Prim Bool (RenderOptions -> Bool -> Layout Builder)
| Cat Doc Doc
| Union Doc Doc
instance Semigroup Doc where
(<>) = Cat
instance Monoid Doc where
mempty = Empty
mappend = (<>)
instance IsString Doc where
fromString = string
render :: RenderOptions -> Int -> Doc -> Builder
render r i doc = F.layout i (go [doc])
where
w = lineWidth r
go [] = mempty
go (d:ds) = case d of
Empty -> go ds
Prim h f -> f r h <> go ds
Cat x y -> go (x:y:ds)
Union x y -> F.nicest w (go (x:ds)) (go (y:ds))
prim :: (RenderOptions -> Bool -> Layout Builder) -> Doc
prim = Prim False
flatten :: Doc -> Doc
flatten Empty = Empty
flatten (Prim _ f) = Prim True f
flatten (Cat x y) = Cat (flatten x) (flatten y)
flatten (Union x _) = x
group :: Doc -> Doc
group x = Union (flatten x) x
builder :: Int -> Builder -> Doc
builder k s = prim $ \_ _ -> F.span k s
string :: String -> Doc
string s = builder (length s) (B.string8 s)
byteString :: B.ByteString -> Doc
byteString s = builder (B.length s) (B.byteString s)
text :: L.Text -> Doc
text = byteString . LB.toStrict . L.encodeUtf8
space :: Layout Builder
space = F.span 1 (B.char8 ' ')
newline :: RenderOptions -> Layout Builder
newline r =
F.span 2 (B.byteString "\r\n") <>
F.break 0 <>
mconcat (replicate1 (indent r) space)
where
replicate1 n a = a : replicate (n - 1) a
line :: Doc
line = prim $ \r h -> if h then space else newline r
linebreak :: Doc
linebreak = prim $ \r h -> if h then mempty else newline r
softline :: Doc
softline = group line
softbreak :: Doc
softbreak = group linebreak
(</>) :: Doc -> Doc -> Doc
a </> b = a <> softline <> b
sep :: [Doc] -> Doc
sep = group . mconcat . intersperse line
punctuate :: Monoid a => a -> [a] -> [a]
punctuate p = go
where
go [] = []
go [x] = [x]
go (x:xs) = x <> p : go xs