{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
module PDF.Object.Navigation (
      Error(..)
    , PDFContent
    , StreamContent(..)
    , (./)
    , (//)
    , (>./)
    , (>//)
    , getDictionary
    , objectById
    , origin
  ) where

import Codec.Compression.Zlib (compress, decompress)
import Control.Applicative (Alternative(..))
import Control.Monad (MonadPlus(..))
import Control.Monad.Reader (MonadReader(..))
import Control.Monad.Fail (MonadFail(..))
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as Lazy (ByteString, fromStrict, toStrict)
import Data.Map ((!))
import qualified Data.Map as Map (lookup)
import PDF.Box (Box(..))
import PDF.Layer (Layer(..))
import PDF.Object (
      Dictionary, DirectObject(..), IndirectObjCoordinates(..)
    , Name(..), Object(..), Structure(..)
  )
import PDF.Output (ObjectId)
import Prelude hiding (fail)
import Text.Printf (printf)

type PDFContent m = (Alternative m, MonadReader Layer m, MonadFail m)
newtype Error a = Error {
    runError :: Either String a
  } deriving (Alternative, Functor, Applicative, Monad, MonadPlus)
instance MonadFail Error where
  fail = Error . Left
type Component = String

getDictionary :: PDFContent m => Object -> m Dictionary
getDictionary (Direct (Dictionary aDict)) = return aDict
getDictionary (Direct (Reference (IndirectObjCoordinates {objectId}))) =
  objectById objectId >>= getDictionary
getDictionary (Stream {header}) = return header
getDictionary obj = expected "dictionary : " obj

expected :: (MonadFail m, Show a) => String -> a -> m b
expected name = fail . printf "Not a %s: %s" name . show

getField :: MonadFail m => String -> Dictionary -> m DirectObject
getField key aDictionary =
  maybe (fail errorMessage) return (Map.lookup (Name key) aDictionary)
  where
    errorMessage =
      printf "Key %s not found in dictionary %s" key (show aDictionary)

objectById :: PDFContent m => ObjectId -> m Object
objectById objectId = do
  layer <- ask
  return (objects layer ! objectId)

(./) :: PDFContent m => m Object -> Component -> m Object
(./) object key = (object >>= getDictionary >>= getField key >>= castObject)
  where
    castObject (Reference (IndirectObjCoordinates {objectId})) =
      objectById objectId
    castObject directObject = return $ Direct directObject

(//) :: PDFContent m => m Object -> [Component] -> m Object
(//) object [] = object
(//) object (key:keys) = object ./ key // keys

(>./) :: PDFContent m => Object -> Component -> m Object
(>./) object = (return object ./)

(>//) :: PDFContent m => Object -> [Component] -> m Object
(>//) object = (return object //)

origin :: PDFContent m => m Object
origin = Direct . Dictionary . trailer . docStructure <$> ask

data StreamContent = StreamContent

onLazy :: (Lazy.ByteString -> Lazy.ByteString) -> ByteString -> ByteString
onLazy f = Lazy.toStrict . f . Lazy.fromStrict

instance MonadFail m => Box m StreamContent Object ByteString where
  r StreamContent (Stream {header, streamContent}) = return $
    case Map.lookup (Name "Filter") header of
      Just (NameObject (Name "FlateDecode")) -> onLazy decompress streamContent
      _ -> streamContent
  r StreamContent obj = expected "stream" obj

  w StreamContent streamContent obj@(Stream {header}) = return $
    case Map.lookup (Name "Filter") header of
      Just (NameObject (Name "FlateDecode")) ->
        obj {streamContent = onLazy compress streamContent}
      _ -> obj {streamContent}
  w _ _ obj = expected "stream" obj