{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
module PDF.Content.Operator (
      Instruction
    , Operator(..)
    , operator
  ) where

import Control.Monad.Fail (MonadFail(..))
import Control.Monad.State (MonadState(..))
import Data.ByteString.Char8 (ByteString, pack, unpack)
import Data.Char (toLower)
import Data.Map (Map, (!?))
import qualified Data.Map as Map (fromList)
import qualified PDF.Content.Operator.Color as Color (Operator, signature)
import PDF.Content.Operator.Common (Signature)
import qualified PDF.Content.Operator.GraphicState as GraphicState (Operator, signature)
import qualified PDF.Content.Operator.Path as Path (Operator, signature)
import qualified PDF.Content.Operator.Text as Text (Operator, signature)
import PDF.Object (DirectObject, blank, regular)
import PDF.Output (Output(..), join, line)
import PDF.Parser (MonadParser, takeAll1)
import Prelude hiding (fail)
import Text.Printf (printf)

data Operator =
    GraphicState GraphicState.Operator
  | Path Path.Operator
  | Color Color.Operator
  | Text Text.Operator 

instance Show Operator where
  show (GraphicState gcOp) = code gcOp
  show (Path pOp) = code pOp
  show (Color cOp) = code cOp
  show (Text tOp) = code tOp

type Instruction = (Operator, [DirectObject])

instance Output Instruction where
  output (op, args) = join " " ((output <$> args) ++ [line (show op)])

operatorsTable :: Map ByteString (Signature Operator)
operatorsTable = Map.fromList (
      (prepare GraphicState <$> GraphicState.signature)
    ++ (prepare Path <$> Path.signature)
    ++ (prepare Color <$> Color.signature)
    ++ (prepare Text <$> Text.signature)
  )
  where
    prepare constructor (op, sig) = (pack $ code op, (constructor op, sig))

code :: Show a => a -> String
code = expand . show
  where
    expand "" = ""
    expand (c:'_':s) = toLower c : expand s
    expand ('s':'t':'a':'r':s) = '*' : expand s
    expand ('Q':'u':'o':'t':'e':s) = '\'' : expand s
    expand ('D':'Q':'u':'o':'t':'e':s) = '"' : expand s
    expand (c:s) = c : expand s

type StackParser m = (MonadState [DirectObject] m, MonadParser m)

operator :: StackParser m => m Instruction
operator = do
  chunk <- takeAll1 regular <* blank
  args <- reverse <$> get
  case operatorsTable !? chunk of
    Just (op, sig)
      | sig args -> return (op, args)
      | otherwise -> 
        get >>= fail . printf "Operator %s with stack %s" (show op) . show
    _ -> fail ("Unknown chunk " ++ unpack chunk)