{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : Graphics.Hoodle.Render.Background -- Copyright : (c) 2011-2015 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC -- ----------------------------------------------------------------------------- module Graphics.Hoodle.Render.Background where import Control.Applicative -- import Control.Concurrent import Control.Concurrent.STM import Control.Monad.State hiding (mapM_) import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader (ask) import Data.ByteString hiding (putStrLn,filter) import Data.Foldable (mapM_) import qualified Data.Map as M import Data.ByteString.Base64 import qualified Data.ByteString.Char8 as C import Data.Monoid import Data.UUID.V4 (nextRandom) import qualified Graphics.Rendering.Cairo as Cairo -- import Graphics.UI.Gtk (postGUIAsync) import qualified Graphics.UI.Gtk.Poppler.Document as Poppler import qualified Graphics.UI.Gtk.Poppler.Page as PopplerPage import System.Directory import System.FilePath ((),(<.>)) -- from hoodle-platform import Data.Hoodle.BBox import Data.Hoodle.Predefined import Data.Hoodle.Simple -- import Graphics.Hoodle.Render.Type.Background import Graphics.Hoodle.Render.Type.Renderer -- import Prelude hiding (mapM_) -- | popplerGetDocFromFile :: ByteString -> IO (Maybe Poppler.Document) popplerGetDocFromFile fp = Poppler.documentNewFromFile (C.unpack ("file://localhost" `mappend` fp)) Nothing -- | getByteStringIfEmbeddedPDF :: ByteString -> Maybe ByteString getByteStringIfEmbeddedPDF bstr = do guard (C.length bstr > 30) let (header,dat) = C.splitAt 30 bstr guard (header == "data:application/x-pdf;base64,") either (const Nothing) return (decode dat) -- | popplerGetDocFromDataURI :: ByteString -> IO (Maybe Poppler.Document) popplerGetDocFromDataURI dat = do let mdecoded = getByteStringIfEmbeddedPDF dat case mdecoded of Nothing -> return Nothing Just decoded -> do uuidstr <- liftM show nextRandom tmpdir <- getTemporaryDirectory let tmpfile = tmpdir uuidstr <.> "pdf" C.writeFile tmpfile decoded mdoc <- popplerGetDocFromFile (C.pack tmpfile) removeFile tmpfile return mdoc -- | popplerGetPageFromDoc :: Poppler.Document -> Int -- ^ page number -> IO (Maybe Poppler.Page) popplerGetPageFromDoc doc pn = do n <- Poppler.documentGetNPages doc if pn > n then return Nothing else do pg <- Poppler.documentGetPage doc (pn-1) return (Just pg) -- | draw ruling all drawRuling :: Double -> Double -> ByteString -> Cairo.Render () drawRuling w h style = do let drawHorizRules = do let (r,g,b,a) = predefined_RULING_COLOR Cairo.setSourceRGBA r g b a Cairo.setLineWidth predefined_RULING_THICKNESS let drawonerule y = do Cairo.moveTo 0 y Cairo.lineTo w y Cairo.stroke mapM_ drawonerule [ predefined_RULING_TOPMARGIN , predefined_RULING_TOPMARGIN+predefined_RULING_SPACING .. h-1 ] case style of "plain" -> return () "lined" -> do drawHorizRules let (r2,g2,b2,a2) = predefined_RULING_MARGIN_COLOR Cairo.setSourceRGBA r2 g2 b2 a2 Cairo.setLineWidth predefined_RULING_THICKNESS Cairo.moveTo predefined_RULING_LEFTMARGIN 0 Cairo.lineTo predefined_RULING_LEFTMARGIN h Cairo.stroke "ruled" -> drawHorizRules "graph" -> do let (r3,g3,b3,a3) = predefined_RULING_COLOR Cairo.setSourceRGBA r3 g3 b3 a3 Cairo.setLineWidth predefined_RULING_THICKNESS let drawonegraphvert x = do Cairo.moveTo x 0 Cairo.lineTo x h Cairo.stroke let drawonegraphhoriz y = do Cairo.moveTo 0 y Cairo.lineTo w y Cairo.stroke mapM_ drawonegraphvert [0,predefined_RULING_GRAPHSPACING..w-1] mapM_ drawonegraphhoriz [0,predefined_RULING_GRAPHSPACING..h-1] _ -> return () -- | draw ruling in bbox drawRuling_InBBox :: BBox -> Double -> Double -> ByteString -> Cairo.Render () drawRuling_InBBox (BBox (x1,y1) (x2,y2)) w h style = do let drawonerule y = do Cairo.moveTo x1 y Cairo.lineTo x2 y Cairo.stroke let drawonegraphvert x = do Cairo.moveTo x y1 Cairo.lineTo x y2 Cairo.stroke let drawonegraphhoriz y = do Cairo.moveTo x1 y Cairo.lineTo x2 y Cairo.stroke fullRuleYs = [ predefined_RULING_TOPMARGIN , predefined_RULING_TOPMARGIN+predefined_RULING_SPACING .. h-1 ] ruleYs = filter (\y-> (y <= y2) && (y >= y1)) fullRuleYs fullGraphXs = [0,predefined_RULING_GRAPHSPACING..w-1] fullGraphYs = [0,predefined_RULING_GRAPHSPACING..h-1] graphXs = filter (\x->(x<=x2)&&(x>=x1)) fullGraphXs graphYs = filter (\y->(y<=y2)&&(y>=y1)) fullGraphYs let drawHorizRules = do let (r,g,b,a) = predefined_RULING_COLOR Cairo.setSourceRGBA r g b a Cairo.setLineWidth predefined_RULING_THICKNESS mapM_ drawonerule ruleYs case style of "plain" -> return () "lined" -> do drawHorizRules let (r2,g2,b2,a2) = predefined_RULING_MARGIN_COLOR Cairo.setSourceRGBA r2 g2 b2 a2 Cairo.setLineWidth predefined_RULING_THICKNESS Cairo.moveTo predefined_RULING_LEFTMARGIN 0 Cairo.lineTo predefined_RULING_LEFTMARGIN h Cairo.stroke "ruled" -> drawHorizRules "graph" -> do let (r3,g3,b3,a3) = predefined_RULING_COLOR Cairo.setSourceRGBA r3 g3 b3 a3 Cairo.setLineWidth predefined_RULING_THICKNESS mapM_ drawonegraphvert graphXs mapM_ drawonegraphhoriz graphYs _ -> return () -- | render background without any constraint renderBkg :: (Background,Dimension) -> Cairo.Render () renderBkg (Background _typ col sty,Dim w h) = do let c = M.lookup col predefined_bkgcolor case c of Just (r,g,b,_a) -> Cairo.setSourceRGB r g b Nothing -> Cairo.setSourceRGB 1 1 1 Cairo.rectangle 0 0 w h Cairo.fill drawRuling w h sty renderBkg (BackgroundPdf _ _ _ _,Dim w h) = do Cairo.setSourceRGBA 1 1 1 1 Cairo.rectangle 0 0 w h Cairo.fill renderBkg (BackgroundEmbedPdf _ _,Dim w h) = do Cairo.setSourceRGBA 1 1 1 1 Cairo.rectangle 0 0 w h Cairo.fill -- | this has some bugs. need to fix cnstrctRBkg_StateT :: Dimension -> Background -> StateT (Maybe Context) Renderer RBackground cnstrctRBkg_StateT _ bkg = do (qpdf,_qgen) <- ((,) <$> rendererPDFCmdQ <*> rendererGenCmdQ) <$> lift ask sfcid <- issueSurfaceID case bkg of Background _t c s -> return (RBkgSmpl c s sfcid) BackgroundPdf _t md mf pn -> do r <- runMaybeT $ do (_pg,rbkg) <- case (md,mf) of (Just d, Just f) -> do cmdiddoc <- issuePDFCommandID docvar <- liftIO (atomically newEmptyTMVar) liftIO . atomically $ sendPDFCommand qpdf cmdiddoc (GetDocFromFile f docvar) doc <- MaybeT . liftIO $ atomically $ takeTMVar docvar lift . put $ Just (Context d f (Just doc) Nothing) pg <- pdfRequest qpdf doc pn return (pg, RBkgPDF md f pn (Just pg) sfcid) _ -> do Context oldd oldf olddoc _ <- MaybeT get doc <- MaybeT . return $ olddoc pg <- pdfRequest qpdf doc pn return (pg, RBkgPDF (Just oldd) oldf pn (Just pg) sfcid) return rbkg case r of Nothing -> error "error in cnstrctRBkg_StateT" Just x -> return x BackgroundEmbedPdf _ pn -> do r <- runMaybeT $ do Context _ _ _ mdoc <- MaybeT get doc <- (MaybeT . return) mdoc pg <- pdfRequest qpdf doc pn return (RBkgEmbedPDF pn (Just pg) sfcid) case r of Nothing -> error "error in cnstrctRBkg_StateT" Just x -> return x where pdfRequest q doc pn = do cmdidpg <- issuePDFCommandID pgvar <- liftIO (atomically newEmptyTMVar) liftIO . atomically $ sendPDFCommand q cmdidpg (GetPageFromDoc doc pn pgvar) MaybeT . liftIO $ atomically $ takeTMVar pgvar -- | For simple hoodle background renderBackground_StateT :: Dimension -> Background -> StateT Context Cairo.Render () renderBackground_StateT dim@(Dim w h) bkg = do case bkg of Background _t _c _s -> lift (renderBkg (bkg,dim)) BackgroundPdf _t md mf pn -> do r <- runMaybeT $ do case (md,mf) of (Just d, Just f) -> do doc <- (MaybeT . liftIO . popplerGetDocFromFile) f lift . put $ (Context d f (Just doc) Nothing) pdfRenderDoc doc pn _ -> do Context _oldd _oldf olddoc _ <- lift get doc <- MaybeT . return $ olddoc pdfRenderDoc doc pn maybe (error "renderBackground_StateT") (const (return ())) r BackgroundEmbedPdf _ pn -> do r <- runMaybeT $ do Context _ _ _ mdoc <- lift get doc <- (MaybeT . return) mdoc pdfRenderDoc doc pn maybe (error "renderBackground_StateT") (const (return ())) r where pdfRender pg = do Cairo.setSourceRGBA 1 1 1 1 Cairo.rectangle 0 0 w h Cairo.fill PopplerPage.pageRender pg pdfRenderDoc doc pn = (MaybeT . liftIO) (popplerGetPageFromDoc doc pn) >>= lift . lift . pdfRender