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

import Codec.Compression.Zlib (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 (fromStrict, toStrict)
import Data.Map ((!))
import qualified Data.Map as Map (lookup)
import PDF.Object (
      Content(..), Dictionary, DirectObject(..), IndirectObjCoordinates(..)
    , Name(..), Object(..), Structure(..)
  )
import PDF.Output (ObjectId)
import Prelude hiding (fail)
import Text.Printf (printf)

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

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
  content <- ask
  return (objects content ! objectId)

(./) :: PDFContent m => m Object -> String -> 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 -> [String] -> m Object
(//) object [] = object
(//) object (key:keys) = object ./ key // keys

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

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

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

openStream :: MonadFail m => Object -> m ByteString
openStream (Stream {header, streamContent}) = return $
  case Map.lookup (Name "Filter") header of
    Just (NameObject (Name "FlateDecode")) ->
      Lazy.toStrict . decompress . Lazy.fromStrict $ streamContent
    _ -> streamContent
openStream obj = expected "stream" obj