module Graphics.Hoodle.Render.Background where
import Control.Applicative
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 qualified Graphics.UI.Gtk.Poppler.Document as Poppler
import qualified Graphics.UI.Gtk.Poppler.Page as PopplerPage
import System.Directory
import System.FilePath ((</>),(<.>))
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
-> IO (Maybe Poppler.Page)
popplerGetPageFromDoc doc pn = do
n <- Poppler.documentGetNPages doc
if pn > n
then return Nothing
else do
pg <- Poppler.documentGetPage doc (pn1)
return (Just pg)
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
..
h1 ]
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..w1]
mapM_ drawonegraphhoriz [0,predefined_RULING_GRAPHSPACING..h1]
_ -> return ()
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
..
h1 ]
ruleYs = filter (\y-> (y <= y2) && (y >= y1)) fullRuleYs
fullGraphXs = [0,predefined_RULING_GRAPHSPACING..w1]
fullGraphYs = [0,predefined_RULING_GRAPHSPACING..h1]
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 ()
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
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
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