{-# LANGUAGE OverloadedStrings #-}

module Main
(
  main
)
where

import qualified Data.Traversable as Traversable
import qualified Data.Map as Map
import qualified Data.ByteString.Char8 as BS8
import qualified Data.Text as Text
import Data.IORef
import Control.Monad
import Control.Monad.IO.Class
import Control.Concurrent
import System.IO
import qualified System.IO.Streams as Streams
import qualified System.IO.Streams.Attoparsec as Streams
import System.Directory
import System.FilePath
import System.Random (randomIO)
import System.Process
import System.Exit
import Graphics.UI.Gtk hiding (Rectangle, FontMap, rectangle)
import Graphics.Rendering.Cairo as Cairo hiding (transform, Glyph)

import Pdf.Toolbox.Document
import Pdf.Toolbox.Document.Encryption
import Pdf.Toolbox.Content

data ViewerState = ViewerState {
  viewerPage :: Page,
  viewerPageNum :: Int,
  viewerRenderIM :: Bool,
  viewerRenderText :: Bool,
  viewerRenderGlyphs :: Bool
  }

main :: IO ()
main = do
  [file] <- initGUI

  mvar <- newEmptyMVar
  withBinaryFile file ReadMode $ \h -> do
  _ <- forkIO $ pdfThread h mvar

  (rootNode, totalPages, title) <- pdfSync mvar $ do
    encrypted <- isEncrypted
    when encrypted $ do
      liftIO $ putStrLn "WARNING: Document is encrypted, it is not fully supported yet"
      ok <- setUserPassword defaultUserPassword
      unless ok $ error "Need user password"
    pdf <- document
    title <- do
      info <- documentInfo pdf
      case info of
        Nothing -> return Nothing
        Just i -> infoTitle i
    root <- documentCatalog pdf >>= catalogPageNode
    total <- pageNodeNKids root
    return (root, total, title)

  firstPage <- pdfSync mvar $ do
    pageNodePageByNum rootNode 0

  viewerState <- newIORef ViewerState {
    viewerPage = firstPage,
    viewerPageNum = 0,
    viewerRenderIM = False,
    viewerRenderText = True,
    viewerRenderGlyphs = False
    }

  let winTitle = maybe "Untitled" (\(Str s) -> BS8.unpack s) title

  window <- windowNew
  set window [
    windowDefaultWidth := 300,
    windowDefaultHeight := 300,
    windowTitle := winTitle
    ]
  _ <- on window deleteEvent $ liftIO mainQuit >> return True

  vbox <- vBoxNew False 10
  containerAdd window vbox

  hbuttonBox <- hButtonBoxNew
  boxPackStart vbox hbuttonBox PackNatural 0

  prevButton <- buttonNewWithLabel ("Prev" :: String)
  boxPackStart hbuttonBox prevButton PackNatural 0

  nextButton <- buttonNewWithLabel ("Next" :: String)
  boxPackStart hbuttonBox nextButton PackNatural 0

  renderPdfToggle <- checkButtonNewWithLabel ("Render via ImageMagick" :: String)
  set renderPdfToggle [
    toggleButtonActive := False
    ]
  boxPackStart hbuttonBox renderPdfToggle PackNatural 0

  renderTextToggle <- checkButtonNewWithLabel ("Render extracted text" :: String)
  set renderTextToggle [
    toggleButtonActive := True
    ]
  boxPackStart hbuttonBox renderTextToggle PackNatural 0

  renderGlyphsToggle <- checkButtonNewWithLabel ("Render glyphs" :: String)
  set renderGlyphsToggle [
    toggleButtonActive := False
    ]
  boxPackStart hbuttonBox renderGlyphsToggle PackNatural 0

  frame <- frameNew
  boxPackStart vbox frame PackGrow 0

  canvas <- drawingAreaNew
  containerAdd frame canvas

  _ <- on renderPdfToggle toggled $ do
    st <- get renderPdfToggle toggleButtonActive
    modifyIORef viewerState $ \s -> s {
      viewerRenderIM = st
      }
    widgetQueueDraw canvas

  _ <- on renderTextToggle toggled $ do
    st <- get renderTextToggle toggleButtonActive
    modifyIORef viewerState $ \s -> s {
      viewerRenderText = st
      }
    widgetQueueDraw canvas

  _ <- on renderGlyphsToggle toggled $ do
    st <- get renderGlyphsToggle toggleButtonActive
    modifyIORef viewerState $ \s -> s {
      viewerRenderGlyphs = st
      }
    widgetQueueDraw canvas

  _ <- on prevButton buttonActivated $ do
    num <- viewerPageNum <$> readIORef viewerState
    when (num > 0) $ do
      p <- pdfSync mvar $ pageNodePageByNum rootNode (num - 1)
      modifyIORef viewerState $ \s -> s {
        viewerPage = p,
        viewerPageNum = num - 1
        }
      widgetQueueDraw canvas

  _ <- on nextButton buttonActivated $ do
    num <- viewerPageNum <$> readIORef viewerState
    when (num < totalPages - 1) $ do
      p <- pdfSync mvar $ pageNodePageByNum rootNode (num + 1)
      modifyIORef viewerState $ \s -> s {
        viewerPage = p,
        viewerPageNum = num + 1
        }
      widgetQueueDraw canvas

  widgetShowAll window
  draw <- widgetGetDrawWindow canvas
  _ <- on canvas exposeEvent $ do
    liftIO $ renderWithDrawable draw $ onDraw file mvar viewerState
    return True

  mainGUI

onDraw :: FilePath -> MVar (Pdf IO Bool) -> IORef ViewerState -> Render ()
onDraw file mvar viewerState = do
  Cairo.scale 2 2
  st <- liftIO $ readIORef viewerState
  let pg = viewerPage st
      num = viewerPageNum st

  when (viewerRenderIM st) $ do
    randomNum <- liftIO $ randomIO :: Render Int
    tmpDir <- liftIO $ getTemporaryDirectory
    let tmpFile = tmpDir </> ("pdf-toolbox-viewer-" ++ show randomNum ++ ".png")
    (_, _, _, procHandle) <- liftIO $ createProcess $ proc "convert" [file ++ "[" ++ show num ++ "]", tmpFile]
    hasPng <- (== ExitSuccess) <$> liftIO (waitForProcess procHandle)
    if hasPng
      then do
        surface <- liftIO $ imageSurfaceCreateFromPNG tmpFile
        setSourceSurface surface 0 0
        paint
        surfaceFinish surface
        liftIO $ removeFile tmpFile
      else liftIO $ putStrLn "Can't render pdf via ImageMagick. Please check that you have \"convert\" in PATH"

  setSourceRGB 1 1 1
  setLineWidth 1

  Rectangle llx lly urx ury <- liftIO $ pdfSync mvar $ pageMediaBox pg

  chan <- liftIO $ startRender mvar pg

  moveTo llx lly
  lineTo llx ury
  lineTo urx ury
  lineTo urx lly
  lineTo llx lly
  closePath
  stroke

  let loop = do
        cmd <- liftIO $ readChan chan
        case cmd of
          Nothing -> return ()
          Just glyph -> do
            let Vector x1 y1 = glyphTopLeft glyph
                Vector x2 y2 = glyphBottomRight glyph
            when (viewerRenderText st) $ do
              setSourceRGB 0 0 0
              case glyphText glyph of
                Nothing -> return ()
                Just txt -> do
                  moveTo x1 (ury - y1)
                  showText $ Text.unpack txt
                  stroke
            when (viewerRenderGlyphs st) $ do
              setSourceRGBA 0 0 0 0.2
              rectangle x1 (ury - y1) (x2 - x1) (y2 - y1)
              fill
            loop
  loop

pageGlyphDecoder :: (MonadPdf m, MonadIO m) => Page -> PdfE m GlyphDecoder
pageGlyphDecoder page = do
  fontDicts <- Map.fromList <$> pageFontDicts page
  decoders <- Traversable.forM fontDicts $ \fontDict -> do
    fontInfo <- fontDictLoadInfo fontDict
    return $ fontInfoDecodeGlyphs fontInfo
  return $ \fontName str ->
    case Map.lookup fontName decoders of
      Nothing -> error "Not font!?" -- []
      Just decode -> decode str

startRender :: MVar (Pdf IO Bool) -> Page -> IO (Chan (Maybe Glyph))
startRender mvar page = do
  chan <- newChan
  putMVar mvar $ do
    glyphDecoder <- pageGlyphDecoder page
    --pageExtractText page >>= liftIO . print

    contents <- pageContents page
    streams <- forM contents $ \ref -> do
      s@(Stream dict _) <- lookupObject ref >>= toStream
      len <- lookupDict "Length" dict >>= deref >>= fromObject >>= intValue
      return (s, ref, len)
    ris <- getRIS
    decryptor <- do
      dec <- getDecryptor
      case dec of
        Nothing -> return $ \_ is -> return is
        Just d -> return $ \ref is -> d ref DecryptStream is
    is <- parseContentStream ris knownFilters decryptor streams

    xobjects <- Map.fromList <$> pageXObjects page

    let loop s p = do
          next <- readNextOperator s
          case next of
            Nothing -> do
              return p
            Just (Op_Do, [OName n]) -> processDo n p >>= loop s
            Just (Op_quote, args) -> error $ "Op_quote (please report): " ++ show args
            Just op -> processOp op p >>= loop s

        processDo name p = do
          case Map.lookup name xobjects of
            Nothing -> return p
            Just (XObject cont gdec) -> do
              xois <- liftIO $ do
                cont_is <- Streams.fromLazyByteString cont
                Streams.parserToInputStream parseContent cont_is
              let gdec' = prGlyphDecoder p
              p' <- loop xois (p {prGlyphDecoder = gdec})
              return (p' {prGlyphDecoder = gdec'})

    p <- loop is $ mkProcessor {
      prGlyphDecoder = glyphDecoder
      }
    forM_ (prGlyphs p) $ \glyphs ->
      forM_ glyphs $ \glyph ->
        liftIO $ writeChan chan (Just glyph)
    --liftIO $ print $ prGlyphs p

    liftIO $ writeChan chan Nothing
    return False
  return chan

pdfThread :: Handle -> MVar (Pdf IO Bool) -> IO ()
pdfThread handle mvar = do
  res <- runPdfWithHandle handle knownFilters loop
  print res
  where
  loop = do
    action <- liftIO $ takeMVar mvar
    exit <- action
    unless exit loop

pdfSync :: MVar (Pdf IO Bool) -> Pdf IO a -> IO a
pdfSync mvar action = do
  mvar' <- newEmptyMVar
  putMVar mvar $ do
    res <- (Right <$> action) `catchE` (return . Left)
    liftIO $ putMVar mvar' res
    return False
  res <- takeMVar mvar'
  case res of
    Left e -> print e >> fail (show e)
    Right r -> return r