{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module PDF.Output (
      OBuilder
    , ObjectId(..)
    , OContext(..)
    , Offset(..)
    , Output(..)
    , Resource(..)
    , byteString
    , char
    , getOffsets
    , join
    , line
    , newLine
    , saveOffset
    , string
    , render
  ) where

import Data.ByteString.Builder (Builder, char8, string8, toLazyByteString)
import qualified Data.ByteString.Builder as B (byteString)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS (length)
import qualified Data.ByteString.Lazy as Lazy (ByteString)
import Data.Map (Map)
import qualified Data.Map as Map (singleton)
import Data.String (IsString(..))
import Control.Monad.RWS (RWS, runRWS, ask, get, listen, modify, tell)
import qualified PDF.EOL as EOL (Style(..))

newtype ObjectId = ObjectId {getObjectId :: Int} deriving (Enum, Eq, Ord, Show)
newtype Offset = Offset {getOffset :: Int} deriving (Show)

data Resource = StartXRef | Object ObjectId deriving (Eq, Ord)

newtype OContext a = OContext (RWS EOL.Style (Map Resource Offset) Offset a)
type OBuilder = OContext Builder

instance Functor OContext where
  fmap f (OContext oc) = OContext $ fmap f oc

instance Applicative OContext where
  pure = OContext . pure
  (<*>) (OContext f) (OContext a) = OContext (f <*> a)

instance Monad OContext where
  (>>=) (OContext a) f = OContext (a >>= (\x -> let OContext y = f x in y))

saveOffset :: Resource -> OContext ()
saveOffset resource = OContext $
  get >>= tell . Map.singleton resource

lift :: (a -> Builder) -> a -> OBuilder
lift f a = return (f a)

getOffsets :: OBuilder -> OContext (OBuilder, Map Resource Offset)
getOffsets (OContext builder) =
  OContext (listen builder >>= \(a, w) -> return (return a, w))

append :: OBuilder -> OBuilder -> OBuilder
append (OContext a) (OContext b) = OContext (mappend <$> a <*> b)

#if MIN_VERSION_base(4,11,0)
instance Semigroup OBuilder where
  (<>) = append
#endif

instance Monoid OBuilder where
  mempty = OContext (return mempty)
#if !(MIN_VERSION_base(4,11,0))
  mappend = append
#endif

instance IsString OBuilder where
  fromString = string

class Output a where
  output :: a -> OBuilder

instance Output OBuilder where
  output = id

instance Output Bool where
  output False = string "false"
  output True = string "true"

instance Output a => Output [a] where
  output = mconcat . fmap output

join :: Output a => String -> [a] -> OBuilder
join _ [] = mempty
join _ [a] = output a
join separator (a:as) =
  output a `mappend` string separator `mappend` (join separator as)

offset :: (Int -> Int) -> OContext ()
offset f = OContext $ modify $ \(Offset o) -> Offset (f o)

newLine :: OBuilder
newLine = buildEOL =<< OContext ask
  where
    buildEOL EOL.CR = return (char8 '\r') <* offset (+1)
    buildEOL EOL.LF = return (char8 '\n') <* offset (+1)
    buildEOL EOL.CRLF = return (string8 "\r\n") <* offset (+2)

char :: Char -> OBuilder
char c = lift char8 c <* offset (+1)

string :: String -> OBuilder
string s = lift string8 s <* offset (+ length s)

line :: String -> OBuilder
line l = string l `mappend` newLine

byteString :: ByteString -> OBuilder
byteString bs = lift B.byteString bs <* offset (+ BS.length bs)

render :: Output a => EOL.Style -> a -> Lazy.ByteString
render eolStyle a =
  let OContext builder = output a in
  let (outputByteString, _, _) = runRWS builder eolStyle (Offset 0) in
  toLazyByteString outputByteString