Rlangqq.hs

{-# OPTIONS_GHC -fno-warn-missing-fields #-}
{-# LANGUAGE TupleSections, TemplateHaskell #-}

module IHaskell.Display.Rlangqq (
    module RlangQQ,
    rDisp,
    rDisplayAll,
    rOutputParsed,
    rOutput,
    getPlotNames,
    getCaptions,
    ) where

import           RlangQQ
import           RlangQQ.ParseKnitted

import           System.Directory
import           System.FilePath
import           Data.Maybe
import           Data.List
import           Text.Read
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as Char
import qualified Data.ByteString.Base64 as Base64
import           IHaskell.Display
import           IHaskell.Display.Blaze () -- to confirm it's installed
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as H
import           Data.Char
import           Control.Monad
import           Data.Ord
import           Data.List.Split
import           Text.XFormat.Show hiding ((<>))
import           Control.Applicative
import           Control.Concurrent
import           Data.Monoid
import           Data.Typeable

import           Control.Concurrent.STM
import           Language.Haskell.TH.Quote

-- | same as 'RlangQQ.r', but displays plots at the end too
rDisp = QuasiQuoter { quoteExp = \s -> [|do
                                           result <- $(quoteExp r s)
                                           p <- rDisplayAll
                                           printDisplay p
                                           return result|] }

rOutput :: IO [Int]
rOutput = do
  fs <- mapMaybe (readMaybe <=< stripPrefix "raw" <=< stripSuffix ".md")
        <$> getDirectoryContents "Rtmp"
  fs' <- forM fs $ \f -> (,f) <$> getModificationTime (showf ("Rtmp/raw" % Int % ".md") f)
  return $ map snd $ sortBy (flip (comparing fst)) fs'

-- | like 'stripPrefix' except on the end
stripSuffix :: String -> String -> Maybe String
stripSuffix s x = fmap reverse $ stripPrefix (reverse s) $ reverse x

rOutputParsed :: IO [KnitInteraction]
rOutputParsed = do
  ns <- rOutput
  case ns of
    []  -> return []
    n:_ -> parseKnitted <$> readFile (showf ("Rtmp/raw" % Int % ".md") n)

getPlotNames :: IO [String]
getPlotNames = do
  interactions <- rOutputParsed
  return [p | KnitInteraction _ is <- interactions
            , KnitImage _ p <- is]

getCaptions :: IO [String]
getCaptions = do
  interactions <- rOutputParsed
  return
    [c | KnitInteraction _ is <- interactions
       , KnitImage c _ <- is
       , not (isBoringCaption c)]

-- | true when the caption name looks like one knitr will automatically generate
isBoringCaption :: String -> Bool
isBoringCaption s = maybe False (all isDigit) (stripPrefix "plot of chunk unnamed-chunk-" s)

rDisplayAll :: IO Display
rDisplayAll = do
  ns <- rOutputParsed
  imgs <- sequence [displayInteraction o | KnitInteraction _ os <- ns
                                         , o <- os]
  display (mconcat imgs)

displayInteraction :: KnitOutput -> IO Display
displayInteraction (KnitPrint c) = display (plain c)
displayInteraction (KnitWarning c) = display (plain c)
displayInteraction (KnitError c) = display (plain c)
displayInteraction (KnitAsIs c) = display (plain c)
displayInteraction (KnitImage cap img) = do
  let caption
        | isBoringCaption cap = mempty
        | otherwise = H.p (H.toMarkup cap)
  encoded <- Base64.encode <$> B.readFile img
  display $ H.img H.! H.src
                        (H.unsafeByteStringValue
                           -- assumes you use the default device which is png
                           (Char.pack "data:image/png;base64," <> encoded))
            <> caption