# Language BlockArguments , RecordWildCards , DataKinds , TypeFamilies #
module PdfMonad.Transformer
  ( PdfT
  , runPdfT, PdfResult(..)
  , PdfParser(..)
  , ObjIndex, R(..), ObjLoc(..)
  , Cipher(..)
  , EncContext(..) 
  , doM
  , ParseError
  , module RTS.ParserAPI
  ) where

import Data.ByteString(ByteString)
import Data.Map(Map)
import Data.Set(Set)
import qualified Data.Set as Set
import qualified Data.Map as Map
import Control.Monad(liftM,ap)
import Data.Word (Word32)

import RTS.ParseError
import RTS.Annot
import RTS.ParserAPI
import Daedalus.RTS.Numeric


data R = R { refObj :: {-# UNPACK #-} !Int
           , refGen :: {-# UNPACK #-} !Int
           } deriving (Eq,Ord,Show)

type ObjIndex = Map R ObjLoc -- Maps opbject ids to their locations.

data ObjLoc = InFileAt !Int   -- ^ At this index
            | InObj !R !Int   -- ^ In this object stream, at this index.
              deriving (Eq,Ord,Show)

newtype PdfT m a = P (RO -> RW -> m (a,RW))

data Cipher = V2RC4 | V4AES | V4RC4 

data EncContext = EncContext 
  { key    :: ByteString
  , robj   :: Int
  , rgen   :: Int 
  , ciph   :: Cipher 
  }

data RO = RO
  { roTopInput  :: Input
  , roObjMap    :: ObjIndex
  , roResolving :: Set R        -- ^ we are currently resolving these
  , encContext  :: Maybe EncContext
  }

data RW = RW
  { rwValidated :: Map R ByteString
  , rwEmitted :: [Word32]
    -- | References that are validated (or in the process) at the given type
  }

data PdfResult a = ParseOk a
                 | ParseAmbig [a]
                 | ParseErr ParseError

type ParseError = ParseErrorG Annotation

runPdfT :: Functor m => Input -> ObjIndex -> Maybe EncContext -> PdfT m a -> m a
runPdfT inp objMap ec (P m) = fst <$> m ro rw
  where
  ro = RO { roTopInput = inp, roObjMap = objMap, roResolving = Set.empty, encContext = ec }
  rw = RW { rwValidated = Map.empty, rwEmitted = [] }
# INLINE runPdfT #

doM :: Monad m => m a -> PdfT m a
doM m = P \_ s -> liftS s m
# INLINE doM #


class BasicParser m => PdfParser m where
  resolving       :: R -> m a -> m a
  extendObjIndex  :: ObjIndex -> m a -> m a
  getObjIndex     :: m ObjIndex
  getTopInput     :: m Input
  isValidated     :: R -> ByteString -> m Bool
  startvalidating :: R -> ByteString -> m ()
  getEncContext   :: m (Maybe EncContext)
  emitChar        :: UInt 32 -> m ()


instance BasicParser m => PdfParser (PdfT m) where
  resolving r (P m) = P \RO {..} s ->
    if r `Set.member` roResolving
      then liftS s $ pError' FromSystem [] "Reference cycle"
      else m RO { roResolving = Set.insert r roResolving, .. } s

  extendObjIndex prevInFileObjMap (P m) = P \RO{..} ->
    m RO { roObjMap = Map.union roObjMap prevInFileObjMap, .. }
    -- NOTE:
    --  - shadowing object indexes happens often.
    --  - this appears to be functioning correctly, it appears unintuitive but note 
    --     - Map.union is left-biased
      - extendObjIndex is called in order from the bottom of the file ( last update first )
    --     - thus 'roObjMap' is what has been constructed from the bottom of the file.
    --     - so 'prevInFileObjMap' is an objectMap that is "previous in file" with respect to 'rObjMap'
    
  getObjIndex = P \RO { .. } s -> pure (roObjMap,s)

  getTopInput = P \RO { .. } s -> pure (roTopInput,s)

  isValidated r b = P \_ s ->
    case Map.lookup r (rwValidated s) of
      Nothing -> pure (False,s)
      Just b1 | b == b1 -> pure (True,s)
              | otherwise -> pError' FromSystem [] msg
        where
        msg = "Reference R:" ++ show (refObj r) ++ ":" ++
              show (refGen r) ++ " used at multiple types " ++
              show b ++ " and " ++ show b1

  startvalidating r b = P \_ RW{..} ->
    pure ((), RW { rwValidated = Map.insert r b rwValidated, .. })

  getEncContext = P \ro rw -> pure (encContext ro, rw)

  emitChar (UInt x) = P \_ rw ->
    let rw' = rw { rwEmitted = x : rwEmitted rw }
    in rw' `seq` pure ((), rw')

  {-# INLINE resolving  #-}
  {-# INLINE getObjIndex #-}
  {-# INLINE extendObjIndex #-}
  {-# INLINE getTopInput #-}


instance Monad m => Functor (PdfT m) where
  fmap = liftM
# INLINE fmap #

instance Monad m => Applicative (PdfT m) where
  pure a = P \_ s -> pure (a,s)
  (<*>)  = ap
# INLINE pure #
  {-# INLINE (<*>) #-}

instance Monad m => Monad (PdfT m) where
  P m >>= f   = P \ro s -> do (a,s1) <- m ro s
                              let P m1 = f a
                              m1 ro s1
  {-# INLINE (>>=) #-}

liftS :: Monad m => s -> m a -> m (a,s)
liftS s m = do a <- m
               pure (a,s)
# INLINE liftS #

instance BasicParser m => BasicParser (PdfT m) where
  type Annot (PdfT m) = Annot m

  P m ||| P n     = P \ro s -> m ro s ||| n ro s
  P m <|| P n     = P \ro s -> m ro s <|| n ro s
  pFail e         = doM (pFail e)
  pByte r         = doM (pByte r)
  pEnter l (P m)  = P \ro s -> pEnter l (m ro s)
  pStack          = doM pStack
  pPeek           = doM pPeek
  pSetInput i     = doM (pSetInput i)
  pITrace         = doM pITrace
  pSetITrace x    = doM (pSetITrace x)

  pErrorMode e (P m) = P \ro s -> pErrorMode e (m ro s)

  {-# INLINE (|||)      #-}
  {-# INLINE (<||)      #-}
# INLINE pFail       #
  {-# INLINE pByte      #-}
  {-# INLINE pEnter     #-}
  {-# INLINE pStack     #-}
  {-# INLINE pPeek      #-}
  {-# INLINE pSetInput  #-}
# INLINE pErrorMode #



# UNPACK #
# UNPACK #
 Maps opbject ids to their locations.
 ^ At this index
 ^ In this object stream, at this index.
 ^ we are currently resolving these
 | References that are validated (or in the process) at the given type
 NOTE:
  - shadowing object indexes happens often.
  - this appears to be functioning correctly, it appears unintuitive but note 
     - Map.union is left-biased
     - thus 'roObjMap' is what has been constructed from the bottom of the file.
     - so 'prevInFileObjMap' is an objectMap that is "previous in file" with respect to 'rObjMap'
# INLINE resolving  #
# INLINE getObjIndex #
# INLINE extendObjIndex #
# INLINE getTopInput #
# INLINE (<*>) #
# INLINE (>>=) #
# INLINE (|||)      #
# INLINE (<||)      #
# INLINE pByte      #
# INLINE pEnter     #
# INLINE pStack     #
# INLINE pPeek      #
# INLINE pSetInput  #
# Language BlockArguments , RecordWildCards , DataKinds , TypeFamilies #
module PdfMonad.Transformer
  ( PdfT
  , runPdfT, PdfResult(..)
  , PdfParser(..)
  , ObjIndex, R(..), ObjLoc(..)
  , Cipher(..)
  , EncContext(..) 
  , doM
  , ParseError
  , module RTS.ParserAPI
  ) where

import Data.ByteString(ByteString)
import Data.Map(Map)
import Data.Set(Set)
import qualified Data.Set as Set
import qualified Data.Map as Map
import Control.Monad(liftM,ap)
import Data.Word (Word32)

import RTS.ParseError
import RTS.Annot
import RTS.ParserAPI
import Daedalus.RTS.Numeric


           } deriving (Eq,Ord,Show)


              deriving (Eq,Ord,Show)

newtype PdfT m a = P (RO -> RW -> m (a,RW))

data Cipher = V2RC4 | V4AES | V4RC4 

data EncContext = EncContext 
  { key    :: ByteString
  , robj   :: Int
  , rgen   :: Int 
  , ciph   :: Cipher 
  }

data RO = RO
  { roTopInput  :: Input
  , roObjMap    :: ObjIndex
  , encContext  :: Maybe EncContext
  }

data RW = RW
  { rwValidated :: Map R ByteString
  , rwEmitted :: [Word32]
  }

data PdfResult a = ParseOk a
                 | ParseAmbig [a]
                 | ParseErr ParseError

type ParseError = ParseErrorG Annotation

runPdfT :: Functor m => Input -> ObjIndex -> Maybe EncContext -> PdfT m a -> m a
runPdfT inp objMap ec (P m) = fst <$> m ro rw
  where
  ro = RO { roTopInput = inp, roObjMap = objMap, roResolving = Set.empty, encContext = ec }
  rw = RW { rwValidated = Map.empty, rwEmitted = [] }
# INLINE runPdfT #

doM :: Monad m => m a -> PdfT m a
doM m = P \_ s -> liftS s m
# INLINE doM #


class BasicParser m => PdfParser m where
  resolving       :: R -> m a -> m a
  extendObjIndex  :: ObjIndex -> m a -> m a
  getObjIndex     :: m ObjIndex
  getTopInput     :: m Input
  isValidated     :: R -> ByteString -> m Bool
  startvalidating :: R -> ByteString -> m ()
  getEncContext   :: m (Maybe EncContext)
  emitChar        :: UInt 32 -> m ()


instance BasicParser m => PdfParser (PdfT m) where
  resolving r (P m) = P \RO {..} s ->
    if r `Set.member` roResolving
      then liftS s $ pError' FromSystem [] "Reference cycle"
      else m RO { roResolving = Set.insert r roResolving, .. } s

  extendObjIndex prevInFileObjMap (P m) = P \RO{..} ->
    m RO { roObjMap = Map.union roObjMap prevInFileObjMap, .. }
      - extendObjIndex is called in order from the bottom of the file ( last update first )
    
  getObjIndex = P \RO { .. } s -> pure (roObjMap,s)

  getTopInput = P \RO { .. } s -> pure (roTopInput,s)

  isValidated r b = P \_ s ->
    case Map.lookup r (rwValidated s) of
      Nothing -> pure (False,s)
      Just b1 | b == b1 -> pure (True,s)
              | otherwise -> pError' FromSystem [] msg
        where
        msg = "Reference R:" ++ show (refObj r) ++ ":" ++
              show (refGen r) ++ " used at multiple types " ++
              show b ++ " and " ++ show b1

  startvalidating r b = P \_ RW{..} ->
    pure ((), RW { rwValidated = Map.insert r b rwValidated, .. })

  getEncContext = P \ro rw -> pure (encContext ro, rw)

  emitChar (UInt x) = P \_ rw ->
    let rw' = rw { rwEmitted = x : rwEmitted rw }
    in rw' `seq` pure ((), rw')



instance Monad m => Functor (PdfT m) where
  fmap = liftM
# INLINE fmap #

instance Monad m => Applicative (PdfT m) where
  pure a = P \_ s -> pure (a,s)
  (<*>)  = ap
# INLINE pure #

instance Monad m => Monad (PdfT m) where
  P m >>= f   = P \ro s -> do (a,s1) <- m ro s
                              let P m1 = f a
                              m1 ro s1

liftS :: Monad m => s -> m a -> m (a,s)
liftS s m = do a <- m
               pure (a,s)
# INLINE liftS #

instance BasicParser m => BasicParser (PdfT m) where
  type Annot (PdfT m) = Annot m

  P m ||| P n     = P \ro s -> m ro s ||| n ro s
  P m <|| P n     = P \ro s -> m ro s <|| n ro s
  pFail e         = doM (pFail e)
  pByte r         = doM (pByte r)
  pEnter l (P m)  = P \ro s -> pEnter l (m ro s)
  pStack          = doM pStack
  pPeek           = doM pPeek
  pSetInput i     = doM (pSetInput i)
  pITrace         = doM pITrace
  pSetITrace x    = doM (pSetITrace x)

  pErrorMode e (P m) = P \ro s -> pErrorMode e (m ro s)

# INLINE pFail       #
# INLINE pErrorMode #


