{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
module PDF.Content (
      Content(..)
    , ContentUnit(..)
    , GraphicContextUnit(..)
    , TextContext
    , content
    , parse
  ) where

import Control.Applicative ((<|>), many)
import Control.Monad.State (MonadState(..), evalStateT, modify)
import Data.ByteString (ByteString)
import PDF.Content.Operator (Instruction, operator)
import PDF.Object (blank, directObject)
import PDF.Output (Output(..), line)
import PDF.Parser (MonadParser, endOfInput, evalParser, peek, string)

data GraphicContextUnit =
    GraphicInstruction Instruction
  | ContentUnit ContentUnit
  deriving Show
type TextContext = [Instruction]
data ContentUnit =
    GraphicContext [GraphicContextUnit]
  | TextContext TextContext
  deriving Show
newtype Content = Content [ContentUnit] deriving Show

content :: MonadParser m => m Content
content = Content <$> many contentUnit <* blank <* endOfInput

contentUnit :: MonadParser m => m ContentUnit
contentUnit = next >>= handle
  where
    handle 'q' = GraphicContext <$> graphicContext
    handle 'B' = TextContext <$> textContext
    handle _ = fail "content unit"

graphicContext :: MonadParser m => m [GraphicContextUnit]
graphicContext = string "q" *> evalStateT graphicContextUnits []
  where
    graphicContextUnits = next >>= handle
    handle 'Q' = string "Q" *> (reverse <$> get)
    handle c
      | c `elem` ['q', 'B'] =
        (ContentUnit <$> contentUnit >>= push) *> graphicContextUnits
      | otherwise =
        (GraphicInstruction <$> instruction >>= push) *> graphicContextUnits

instruction :: MonadParser m => m Instruction
instruction = evalStateT stackParser []
  where
    stackParser = ((directObject <* blank >>= push) *> stackParser) <|> operator

next :: MonadParser m => m Char
next = blank *> peek

push :: MonadState [a] m => a -> m ()
push a = modify (a:)

parse :: ByteString -> Either String Content
parse = evalParser content ()

textContext :: MonadParser m => m TextContext
textContext = string "BT" *> evalStateT instructions []
  where
    instructions = next >>= handle
    handle 'E' = string "ET" *> (reverse <$> get)
    handle _ = (instruction >>= push) *> instructions

instance Output Content where
  output (Content contentUnits) = output contentUnits

instance Output ContentUnit where
  output (GraphicContext gc) = line "q" `mappend` output gc `mappend` line "Q"
  output (TextContext tc) = line "BT" `mappend` output tc `mappend` line "ET"

instance Output GraphicContextUnit where
  output (GraphicInstruction gi) = output gi
  output (ContentUnit cu) = output cu