{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards  #-}
module Image.LaTeX.Render (
    -- * Rendering Formulas
    imageForFormula,
    Formula, SVG,
    -- * BaseLine
    BaseLine, getBaseline, alterForHTML,
    -- * Errors
    RenderError (..),
    -- * Options
    -- ** Environment Options
    EnvironmentOptions (..),
    defaultEnv,
    TempDirectoryHandling (..),
    -- ** Formula Options
    FormulaOptions (..),
    displaymath,
    math,
    defaultFormulaOptions,
    ) where

import Control.Applicative        (some, (<|>))
import Control.DeepSeq            (NFData (..), ($!!))
import Control.Monad              (when)
import Control.Monad.IO.Class     (MonadIO (..))
import Control.Monad.Trans.Except (ExceptT (..), runExceptT, throwE, withExceptT)
import Data.Char                  (isSpace)
import Data.List                  (foldl', isPrefixOf, sortOn, stripPrefix)
import Data.Maybe                 (fromMaybe, maybeToList)
import Numeric                    (showFFloat)
import System.Exit                (ExitCode (..))
import System.FilePath            ((<.>), (</>))
import System.IO.Temp             (withSystemTempDirectory, withTempDirectory)

-- import System.IO

import qualified Control.Exception          as E
import qualified Crypto.Hash.SHA256         as SHA256
import qualified Data.ByteString.Base64.URL as Base64
import qualified Data.ByteString.Builder    as B
import qualified Data.ByteString.Char8      as BS8
import qualified System.Directory           as Dir
import qualified System.Process             as Proc
import qualified Text.Parsec                as P
import qualified Text.Parsec.String         as P

-------------------------------------------------------------------------------
-- Types
-------------------------------------------------------------------------------

-- | A LaTeX formula, e.g @x=\frac{-b\pm\sqrt{b^2-4ac}}{2a}@ for the quadratic formula. Do not include any @$@s to denote the environment, just
--   specify the environment in the 'FormulaOptions' instead.
type Formula = String

-- | Number of points (@pt@) from the bottom of the image to the typesetting baseline. Useful for setting your formulae inline with text
type BaseLine = Double

-- | A source of 'SVG' image.
type SVG = String

-- | This type contains all possible errors than can happen while rendering an equation.
--   It includes all IO errors that can happen as well as more specific errors.
data RenderError
    = LaTeXFailure String        -- ^ @latex@ returned a nonzero error code
    | DVISVGMFailure String      -- ^ @dvisvgm@ returned a nonzero error code
    | IOException E.IOException  -- ^ An 'IOException' occurred while managing the temporary files used to convert the equation
  deriving (Int -> RenderError -> ShowS
[RenderError] -> ShowS
RenderError -> String
(Int -> RenderError -> ShowS)
-> (RenderError -> String)
-> ([RenderError] -> ShowS)
-> Show RenderError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RenderError -> ShowS
showsPrec :: Int -> RenderError -> ShowS
$cshow :: RenderError -> String
show :: RenderError -> String
$cshowList :: [RenderError] -> ShowS
showList :: [RenderError] -> ShowS
Show, RenderError -> RenderError -> Bool
(RenderError -> RenderError -> Bool)
-> (RenderError -> RenderError -> Bool) -> Eq RenderError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RenderError -> RenderError -> Bool
== :: RenderError -> RenderError -> Bool
$c/= :: RenderError -> RenderError -> Bool
/= :: RenderError -> RenderError -> Bool
Eq)

data TempDirectoryHandling
    = UseSystemTempDir String  -- ^ A temporary directory with a name based on the given template will be created in the system temporary files location
    | UseCurrentDir    String  -- ^ A temporary directory with a name based on the given template will be created in the current directory
  deriving (TempDirectoryHandling -> TempDirectoryHandling -> Bool
(TempDirectoryHandling -> TempDirectoryHandling -> Bool)
-> (TempDirectoryHandling -> TempDirectoryHandling -> Bool)
-> Eq TempDirectoryHandling
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TempDirectoryHandling -> TempDirectoryHandling -> Bool
== :: TempDirectoryHandling -> TempDirectoryHandling -> Bool
$c/= :: TempDirectoryHandling -> TempDirectoryHandling -> Bool
/= :: TempDirectoryHandling -> TempDirectoryHandling -> Bool
Eq, Int -> TempDirectoryHandling -> ShowS
[TempDirectoryHandling] -> ShowS
TempDirectoryHandling -> String
(Int -> TempDirectoryHandling -> ShowS)
-> (TempDirectoryHandling -> String)
-> ([TempDirectoryHandling] -> ShowS)
-> Show TempDirectoryHandling
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TempDirectoryHandling -> ShowS
showsPrec :: Int -> TempDirectoryHandling -> ShowS
$cshow :: TempDirectoryHandling -> String
show :: TempDirectoryHandling -> String
$cshowList :: [TempDirectoryHandling] -> ShowS
showList :: [TempDirectoryHandling] -> ShowS
Show, ReadPrec [TempDirectoryHandling]
ReadPrec TempDirectoryHandling
Int -> ReadS TempDirectoryHandling
ReadS [TempDirectoryHandling]
(Int -> ReadS TempDirectoryHandling)
-> ReadS [TempDirectoryHandling]
-> ReadPrec TempDirectoryHandling
-> ReadPrec [TempDirectoryHandling]
-> Read TempDirectoryHandling
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS TempDirectoryHandling
readsPrec :: Int -> ReadS TempDirectoryHandling
$creadList :: ReadS [TempDirectoryHandling]
readList :: ReadS [TempDirectoryHandling]
$creadPrec :: ReadPrec TempDirectoryHandling
readPrec :: ReadPrec TempDirectoryHandling
$creadListPrec :: ReadPrec [TempDirectoryHandling]
readListPrec :: ReadPrec [TempDirectoryHandling]
Read, Eq TempDirectoryHandling
Eq TempDirectoryHandling =>
(TempDirectoryHandling -> TempDirectoryHandling -> Ordering)
-> (TempDirectoryHandling -> TempDirectoryHandling -> Bool)
-> (TempDirectoryHandling -> TempDirectoryHandling -> Bool)
-> (TempDirectoryHandling -> TempDirectoryHandling -> Bool)
-> (TempDirectoryHandling -> TempDirectoryHandling -> Bool)
-> (TempDirectoryHandling
    -> TempDirectoryHandling -> TempDirectoryHandling)
-> (TempDirectoryHandling
    -> TempDirectoryHandling -> TempDirectoryHandling)
-> Ord TempDirectoryHandling
TempDirectoryHandling -> TempDirectoryHandling -> Bool
TempDirectoryHandling -> TempDirectoryHandling -> Ordering
TempDirectoryHandling
-> TempDirectoryHandling -> TempDirectoryHandling
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TempDirectoryHandling -> TempDirectoryHandling -> Ordering
compare :: TempDirectoryHandling -> TempDirectoryHandling -> Ordering
$c< :: TempDirectoryHandling -> TempDirectoryHandling -> Bool
< :: TempDirectoryHandling -> TempDirectoryHandling -> Bool
$c<= :: TempDirectoryHandling -> TempDirectoryHandling -> Bool
<= :: TempDirectoryHandling -> TempDirectoryHandling -> Bool
$c> :: TempDirectoryHandling -> TempDirectoryHandling -> Bool
> :: TempDirectoryHandling -> TempDirectoryHandling -> Bool
$c>= :: TempDirectoryHandling -> TempDirectoryHandling -> Bool
>= :: TempDirectoryHandling -> TempDirectoryHandling -> Bool
$cmax :: TempDirectoryHandling
-> TempDirectoryHandling -> TempDirectoryHandling
max :: TempDirectoryHandling
-> TempDirectoryHandling -> TempDirectoryHandling
$cmin :: TempDirectoryHandling
-> TempDirectoryHandling -> TempDirectoryHandling
min :: TempDirectoryHandling
-> TempDirectoryHandling -> TempDirectoryHandling
Ord)

data EnvironmentOptions = EnvironmentOptions
    { EnvironmentOptions -> String
latexCommand     :: String                  -- ^ Command to use for @latex@, default is @latex@
    , EnvironmentOptions -> String
dvisvgmCommand   :: String                  -- ^ Command to use for @dvisvgm@, default is @dvisvgm@
    , EnvironmentOptions -> [String]
latexArgs        :: [String]                -- ^ Any additional arguments for @latex@
    , EnvironmentOptions -> [String]
dvisvgmArgs      :: [String]                -- ^ Any additional arguments for @dvisvgm@
    , EnvironmentOptions -> Int
latexFontSize    :: Int                     -- ^ Document font size, one of @8,9,10,11,12,14,17,20@. If not @10,11,12@ then @extarticle@ document size is used.
    , EnvironmentOptions -> TempDirectoryHandling
tempDir          :: TempDirectoryHandling   -- ^ How to handle temporary files
    , EnvironmentOptions -> String
tempFileBaseName :: String                  -- ^ The base name to use for the temporary files.
    , EnvironmentOptions -> Bool
globalCache      :: Bool                    -- ^ Cache outputs globally in @XDG_CACHE/latex-svg@
    }
  deriving (EnvironmentOptions -> EnvironmentOptions -> Bool
(EnvironmentOptions -> EnvironmentOptions -> Bool)
-> (EnvironmentOptions -> EnvironmentOptions -> Bool)
-> Eq EnvironmentOptions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EnvironmentOptions -> EnvironmentOptions -> Bool
== :: EnvironmentOptions -> EnvironmentOptions -> Bool
$c/= :: EnvironmentOptions -> EnvironmentOptions -> Bool
/= :: EnvironmentOptions -> EnvironmentOptions -> Bool
Eq, Int -> EnvironmentOptions -> ShowS
[EnvironmentOptions] -> ShowS
EnvironmentOptions -> String
(Int -> EnvironmentOptions -> ShowS)
-> (EnvironmentOptions -> String)
-> ([EnvironmentOptions] -> ShowS)
-> Show EnvironmentOptions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EnvironmentOptions -> ShowS
showsPrec :: Int -> EnvironmentOptions -> ShowS
$cshow :: EnvironmentOptions -> String
show :: EnvironmentOptions -> String
$cshowList :: [EnvironmentOptions] -> ShowS
showList :: [EnvironmentOptions] -> ShowS
Show, ReadPrec [EnvironmentOptions]
ReadPrec EnvironmentOptions
Int -> ReadS EnvironmentOptions
ReadS [EnvironmentOptions]
(Int -> ReadS EnvironmentOptions)
-> ReadS [EnvironmentOptions]
-> ReadPrec EnvironmentOptions
-> ReadPrec [EnvironmentOptions]
-> Read EnvironmentOptions
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS EnvironmentOptions
readsPrec :: Int -> ReadS EnvironmentOptions
$creadList :: ReadS [EnvironmentOptions]
readList :: ReadS [EnvironmentOptions]
$creadPrec :: ReadPrec EnvironmentOptions
readPrec :: ReadPrec EnvironmentOptions
$creadListPrec :: ReadPrec [EnvironmentOptions]
readListPrec :: ReadPrec [EnvironmentOptions]
Read, Eq EnvironmentOptions
Eq EnvironmentOptions =>
(EnvironmentOptions -> EnvironmentOptions -> Ordering)
-> (EnvironmentOptions -> EnvironmentOptions -> Bool)
-> (EnvironmentOptions -> EnvironmentOptions -> Bool)
-> (EnvironmentOptions -> EnvironmentOptions -> Bool)
-> (EnvironmentOptions -> EnvironmentOptions -> Bool)
-> (EnvironmentOptions -> EnvironmentOptions -> EnvironmentOptions)
-> (EnvironmentOptions -> EnvironmentOptions -> EnvironmentOptions)
-> Ord EnvironmentOptions
EnvironmentOptions -> EnvironmentOptions -> Bool
EnvironmentOptions -> EnvironmentOptions -> Ordering
EnvironmentOptions -> EnvironmentOptions -> EnvironmentOptions
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: EnvironmentOptions -> EnvironmentOptions -> Ordering
compare :: EnvironmentOptions -> EnvironmentOptions -> Ordering
$c< :: EnvironmentOptions -> EnvironmentOptions -> Bool
< :: EnvironmentOptions -> EnvironmentOptions -> Bool
$c<= :: EnvironmentOptions -> EnvironmentOptions -> Bool
<= :: EnvironmentOptions -> EnvironmentOptions -> Bool
$c> :: EnvironmentOptions -> EnvironmentOptions -> Bool
> :: EnvironmentOptions -> EnvironmentOptions -> Bool
$c>= :: EnvironmentOptions -> EnvironmentOptions -> Bool
>= :: EnvironmentOptions -> EnvironmentOptions -> Bool
$cmax :: EnvironmentOptions -> EnvironmentOptions -> EnvironmentOptions
max :: EnvironmentOptions -> EnvironmentOptions -> EnvironmentOptions
$cmin :: EnvironmentOptions -> EnvironmentOptions -> EnvironmentOptions
min :: EnvironmentOptions -> EnvironmentOptions -> EnvironmentOptions
Ord)

data FormulaOptions = FormulaOptions
    { FormulaOptions -> String
preamble    :: String        -- ^ LaTeX preamble to use. Put your @\usepackage@ commands here.@ commands here.
    , FormulaOptions -> Maybe String
environment :: Maybe String  -- ^ LaTeX environment in which the equation will be typeset, usually 'math' or 'displaymath'
    }
  deriving (FormulaOptions -> FormulaOptions -> Bool
(FormulaOptions -> FormulaOptions -> Bool)
-> (FormulaOptions -> FormulaOptions -> Bool) -> Eq FormulaOptions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FormulaOptions -> FormulaOptions -> Bool
== :: FormulaOptions -> FormulaOptions -> Bool
$c/= :: FormulaOptions -> FormulaOptions -> Bool
/= :: FormulaOptions -> FormulaOptions -> Bool
Eq, Int -> FormulaOptions -> ShowS
[FormulaOptions] -> ShowS
FormulaOptions -> String
(Int -> FormulaOptions -> ShowS)
-> (FormulaOptions -> String)
-> ([FormulaOptions] -> ShowS)
-> Show FormulaOptions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FormulaOptions -> ShowS
showsPrec :: Int -> FormulaOptions -> ShowS
$cshow :: FormulaOptions -> String
show :: FormulaOptions -> String
$cshowList :: [FormulaOptions] -> ShowS
showList :: [FormulaOptions] -> ShowS
Show, ReadPrec [FormulaOptions]
ReadPrec FormulaOptions
Int -> ReadS FormulaOptions
ReadS [FormulaOptions]
(Int -> ReadS FormulaOptions)
-> ReadS [FormulaOptions]
-> ReadPrec FormulaOptions
-> ReadPrec [FormulaOptions]
-> Read FormulaOptions
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS FormulaOptions
readsPrec :: Int -> ReadS FormulaOptions
$creadList :: ReadS [FormulaOptions]
readList :: ReadS [FormulaOptions]
$creadPrec :: ReadPrec FormulaOptions
readPrec :: ReadPrec FormulaOptions
$creadListPrec :: ReadPrec [FormulaOptions]
readListPrec :: ReadPrec [FormulaOptions]
Read, Eq FormulaOptions
Eq FormulaOptions =>
(FormulaOptions -> FormulaOptions -> Ordering)
-> (FormulaOptions -> FormulaOptions -> Bool)
-> (FormulaOptions -> FormulaOptions -> Bool)
-> (FormulaOptions -> FormulaOptions -> Bool)
-> (FormulaOptions -> FormulaOptions -> Bool)
-> (FormulaOptions -> FormulaOptions -> FormulaOptions)
-> (FormulaOptions -> FormulaOptions -> FormulaOptions)
-> Ord FormulaOptions
FormulaOptions -> FormulaOptions -> Bool
FormulaOptions -> FormulaOptions -> Ordering
FormulaOptions -> FormulaOptions -> FormulaOptions
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: FormulaOptions -> FormulaOptions -> Ordering
compare :: FormulaOptions -> FormulaOptions -> Ordering
$c< :: FormulaOptions -> FormulaOptions -> Bool
< :: FormulaOptions -> FormulaOptions -> Bool
$c<= :: FormulaOptions -> FormulaOptions -> Bool
<= :: FormulaOptions -> FormulaOptions -> Bool
$c> :: FormulaOptions -> FormulaOptions -> Bool
> :: FormulaOptions -> FormulaOptions -> Bool
$c>= :: FormulaOptions -> FormulaOptions -> Bool
>= :: FormulaOptions -> FormulaOptions -> Bool
$cmax :: FormulaOptions -> FormulaOptions -> FormulaOptions
max :: FormulaOptions -> FormulaOptions -> FormulaOptions
$cmin :: FormulaOptions -> FormulaOptions -> FormulaOptions
min :: FormulaOptions -> FormulaOptions -> FormulaOptions
Ord)

-------------------------------------------------------------------------------
-- Defaults
-------------------------------------------------------------------------------

-- | Use the @amsmath@, @amsfonts@ and @lmodern@ packages.
defaultFormulaOptions :: FormulaOptions
defaultFormulaOptions :: FormulaOptions
defaultFormulaOptions = FormulaOptions
    { environment :: Maybe String
environment = Maybe String
forall a. Maybe a
Nothing
    , preamble :: String
preamble = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"\\usepackage{amsmath}"
        , String
"\\usepackage{amsfonts}"
        , String
"\\usepackage[T1]{fontenc}"
        , String
"\\usepackage{lmodern}"
        ]
    }

-- | Use the @amsmath@, @amsfonts@ and @lmodern@ package, the @displaymath@ environment.
displaymath :: FormulaOptions
displaymath :: FormulaOptions
displaymath = FormulaOptions
defaultFormulaOptions { environment = Just "displaymath" }

-- | Use the @amsmath@, @amsfonts@ and @lmodern@ package, the @math@ environment.
math :: FormulaOptions
math :: FormulaOptions
math = FormulaOptions
defaultFormulaOptions { environment = Just "math" }

-- | Sensible defaults for system environments. Works if @dvisvgm@ and @latex@ are recent enough and in your @$PATH@.
defaultEnv :: EnvironmentOptions
defaultEnv :: EnvironmentOptions
defaultEnv = EnvironmentOptions
    { latexCommand :: String
latexCommand     = String
"latex"
    , dvisvgmCommand :: String
dvisvgmCommand   = String
"dvisvgm"
    , latexArgs :: [String]
latexArgs        = []
    -- "--exact-bbox" is good idea if you have recent dvisvgm
    , dvisvgmArgs :: [String]
dvisvgmArgs      = [String
"--no-fonts=1", String
"--clipjoin", String
"--bbox=min", String
"--exact"]
    , latexFontSize :: Int
latexFontSize    = Int
12
    , tempDir :: TempDirectoryHandling
tempDir          = String -> TempDirectoryHandling
UseSystemTempDir String
"latex-eqn-temp"
    , tempFileBaseName :: String
tempFileBaseName = String
"working"
    , globalCache :: Bool
globalCache      = Bool
False
    }

-------------------------------------------------------------------------------
-- Image for formula
-------------------------------------------------------------------------------

-- | Convert a formula into a SVG image.
imageForFormula :: EnvironmentOptions -> FormulaOptions -> Formula -> IO (Either RenderError SVG)
imageForFormula :: EnvironmentOptions
-> FormulaOptions -> String -> IO (Either RenderError String)
imageForFormula EnvironmentOptions {Bool
Int
String
[String]
TempDirectoryHandling
latexCommand :: EnvironmentOptions -> String
dvisvgmCommand :: EnvironmentOptions -> String
latexArgs :: EnvironmentOptions -> [String]
dvisvgmArgs :: EnvironmentOptions -> [String]
latexFontSize :: EnvironmentOptions -> Int
tempDir :: EnvironmentOptions -> TempDirectoryHandling
tempFileBaseName :: EnvironmentOptions -> String
globalCache :: EnvironmentOptions -> Bool
latexCommand :: String
dvisvgmCommand :: String
latexArgs :: [String]
dvisvgmArgs :: [String]
latexFontSize :: Int
tempDir :: TempDirectoryHandling
tempFileBaseName :: String
globalCache :: Bool
..} FormulaOptions {String
Maybe String
preamble :: FormulaOptions -> String
environment :: FormulaOptions -> Maybe String
preamble :: String
environment :: Maybe String
..} String
eqn =
    (String -> IO (Either RenderError String))
-> IO (Either RenderError String)
forall {m :: * -> *} {a}.
(MonadIO m, MonadMask m) =>
(String -> m a) -> m a
withTemp ((String -> IO (Either RenderError String))
 -> IO (Either RenderError String))
-> (String -> IO (Either RenderError String))
-> IO (Either RenderError String)
forall a b. (a -> b) -> a -> b
$ \String
temp -> ExceptT RenderError IO String -> IO (Either RenderError String)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT RenderError IO String -> IO (Either RenderError String))
-> ExceptT RenderError IO String -> IO (Either RenderError String)
forall a b. (a -> b) -> a -> b
$ do
        let doc :: String
            doc :: String
doc = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
                [ String
"% " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
latexCommand String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
latexArgs
                , String
"% " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
dvisvgmCommand String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
dvisvgmArgs
                , String
"\\nonstopmode"
                , String
"\\documentclass[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
latexFontSize' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"pt]{" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
documentClass String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"}"
                , String
"\\pagestyle{empty}"
                , String
"\\usepackage[active,tightpage]{preview}"
                , String
preamble
                , String
"\\begin{document}"
                , String
"\\begin{preview}"
                ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
                [ String
"\\begin{" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"}" | String
e <- Maybe String -> [String]
forall a. Maybe a -> [a]
maybeToList Maybe String
environment ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
                (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace) (String -> [String]
lines String
eqn) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
                [ String
"\\end{" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"}"  | String
e <- Maybe String -> [String]
forall a. Maybe a -> [a]
maybeToList Maybe String
environment ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
                [ String
"\\end{preview}"
                , String
"\\end{document}"
                ]

        String
-> ExceptT RenderError IO String -> ExceptT RenderError IO String
cached String
doc (ExceptT RenderError IO String -> ExceptT RenderError IO String)
-> ExceptT RenderError IO String -> ExceptT RenderError IO String
forall a b. (a -> b) -> a -> b
$ do
            -- io $ hPutStrLn stderr doc
            IO () -> ExceptT RenderError IO ()
forall a. NFData a => IO a -> ExceptT RenderError IO a
io (IO () -> ExceptT RenderError IO ())
-> IO () -> ExceptT RenderError IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
writeFile (String
temp String -> ShowS
</> String
tempFileBaseName String -> ShowS
<.> String
"tex") String
doc

            (c,o,e) <- IO (ExitCode, String, String)
-> ExceptT RenderError IO (ExitCode, String, String)
forall a. NFData a => IO a -> ExceptT RenderError IO a
io (IO (ExitCode, String, String)
 -> ExceptT RenderError IO (ExitCode, String, String))
-> IO (ExitCode, String, String)
-> ExceptT RenderError IO (ExitCode, String, String)
forall a b. (a -> b) -> a -> b
$ String -> String -> [String] -> IO (ExitCode, String, String)
readProcessWithCWD String
temp String
latexCommand ([String] -> IO (ExitCode, String, String))
-> [String] -> IO (ExitCode, String, String)
forall a b. (a -> b) -> a -> b
$ [String]
latexArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
tempFileBaseName String -> ShowS
<.> String
"tex"]
            when (c /= ExitSuccess) $ throwE $ LaTeXFailure (o ++ "\n" ++ e)

            (c',o',e') <- io $ readProcessWithCWD temp dvisvgmCommand $ dvisvgmArgs ++ ["-o", tempFileBaseName <.> "svg", tempFileBaseName <.> "dvi"]
            when (c' /= ExitSuccess) $ throwE $ DVISVGMFailure (o' ++ "\n" ++ e')

            svg <- io $ readFile (temp </> tempFileBaseName <.> "svg")

            return $ addTitle eqn svg
  where
    latexFontSize' :: Int
latexFontSize'
        | Int
latexFontSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
8  = Int
8
        | Int
latexFontSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
20 = Int
20
        | Bool
otherwise          = [Int] -> Int
forall a. HasCallStack => [a] -> a
head ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> [Int] -> [Int]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (\Int
s -> Int -> Int
forall a. Num a => a -> a
abs (Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
latexFontSize)) [Int]
sizes

    sizes :: [Int]
    sizes :: [Int]
sizes = [Int
8,Int
9,Int
10,Int
11,Int
12,Int
14,Int
17,Int
20]

    documentClass :: String
documentClass
        | Int
latexFontSize' Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
10,Int
11,Int
12] = String
"article"
        | Bool
otherwise                        = String
"extarticle"

    io :: NFData a => IO a -> ExceptT RenderError IO a
    io :: forall a. NFData a => IO a -> ExceptT RenderError IO a
io = (IOException -> RenderError)
-> ExceptT IOException IO a -> ExceptT RenderError IO a
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT IOException -> RenderError
IOException (ExceptT IOException IO a -> ExceptT RenderError IO a)
-> (IO a -> ExceptT IOException IO a)
-> IO a
-> ExceptT RenderError IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> ExceptT IOException IO a
forall (m :: * -> *) a.
(MonadIO m, NFData a) =>
IO a -> ExceptT IOException m a
tryIO

    withTemp :: (String -> m a) -> m a
withTemp String -> m a
a = case TempDirectoryHandling
tempDir of
        UseSystemTempDir String
f -> String -> (String -> m a) -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> m a) -> m a
withSystemTempDirectory String
f String -> m a
a
        UseCurrentDir String
f    -> String -> String -> (String -> m a) -> m a
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
String -> String -> (String -> m a) -> m a
withTempDirectory String
"." String
f String -> m a
a

    cached :: String -> ExceptT RenderError IO String -> ExceptT RenderError IO String
    cached :: String
-> ExceptT RenderError IO String -> ExceptT RenderError IO String
cached String
doc ExceptT RenderError IO String
action
        | Bool -> Bool
not Bool
globalCache = ExceptT RenderError IO String
action
        | Bool
otherwise       = do
            let key :: String
                key :: String
key = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'=')
                    ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ByteString -> String
BS8.unpack
                    (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
Base64.encode
                    (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
SHA256.hashlazy
                    (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
B.toLazyByteString
                    (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> Builder
B.stringUtf8 String
doc

            -- cache directory
            xdgCache <- IO String -> ExceptT RenderError IO String
forall a. NFData a => IO a -> ExceptT RenderError IO a
io (IO String -> ExceptT RenderError IO String)
-> IO String -> ExceptT RenderError IO String
forall a b. (a -> b) -> a -> b
$ XdgDirectory -> String -> IO String
Dir.getXdgDirectory XdgDirectory
Dir.XdgCache String
"latex-svg"
            io $ Dir.createDirectoryIfMissing True xdgCache
            let path = String
xdgCache String -> ShowS
</> String
key String -> ShowS
<.> String
"svg"

            readFile path `orElse` do
                result <- action
                io $ writeFile path result
                return result

    orElse :: IO a -> ExceptT e IO a -> ExceptT e IO a
    orElse :: forall a e. IO a -> ExceptT e IO a -> ExceptT e IO a
orElse IO a
lft ExceptT e IO a
rgt = IO (Either e a) -> ExceptT e IO a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either e a) -> ExceptT e IO a)
-> IO (Either e a) -> ExceptT e IO a
forall a b. (a -> b) -> a -> b
$ (a -> Either e a) -> IO a -> IO (Either e a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either e a
forall a b. b -> Either a b
Right IO a
lft IO (Either e a)
-> (IOException -> IO (Either e a)) -> IO (Either e a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` ExceptT e IO a -> IOException -> IO (Either e a)
forall e a. ExceptT e IO a -> IOException -> IO (Either e a)
handler ExceptT e IO a
rgt

    handler :: ExceptT e IO a -> E.IOException -> IO (Either e a)
    handler :: forall e a. ExceptT e IO a -> IOException -> IO (Either e a)
handler ExceptT e IO a
rgt IOException
_ = ExceptT e IO a -> IO (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT e IO a
rgt

-------------------------------------------------------------------------------
-- Baseline and other postprocessing
-------------------------------------------------------------------------------

addTitle :: Formula -> String -> String
addTitle :: String -> ShowS
addTitle String
eqn String
svg =
    let (String
x0,String
x1) = String -> String -> (String, String)
forall a. Eq a => [a] -> [a] -> ([a], [a])
spanL String
"<svg" String
svg
        (String
y1,String
y2) = Char -> String -> (String, String)
forall a. Eq a => a -> [a] -> ([a], [a])
spanR Char
'>' String
x1
    in String
x0 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
y1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n<title>" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
processAltString String
eqn String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"</title>" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
y2

spanL :: Eq a => [a] -> [a] -> ([a], [a])
spanL :: forall a. Eq a => [a] -> [a] -> ([a], [a])
spanL [a]
sep = [a] -> ([a], [a])
go where
    go :: [a] -> ([a], [a])
go str :: [a]
str@[]                  = ([a]
str, [a]
str)
    go str :: [a]
str@(a
c:[a]
sfx)
        | [a]
sep [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [a]
str = ([], [a]
str)
        | Bool
otherwise            = (a
ca -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs , [a]
ys)
      where
        ~([a]
xs,[a]
ys) = [a] -> ([a], [a])
go [a]
sfx

spanR :: Eq a => a -> [a] -> ([a], [a])
spanR :: forall a. Eq a => a -> [a] -> ([a], [a])
spanR a
sep = [a] -> ([a], [a])
go where
    go :: [a] -> ([a], [a])
go  str :: [a]
str@[]      = ([a]
str, [a]
str)
    go _str :: [a]
_str@(a
c:[a]
sfx)
        | a
sep a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
c  = ([a
c], [a]
sfx)
        | Bool
otherwise = (a
ca -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs , [a]
ys)
      where
        ~([a]
xs,[a]
ys) = [a] -> ([a], [a])
go [a]
sfx

processAltString :: String -> String
processAltString :: ShowS
processAltString = (Char -> String) -> ShowS
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Char -> String) -> ShowS) -> (Char -> String) -> ShowS
forall a b. (a -> b) -> a -> b
$ \Char
c -> case Char
c of
    Char
'<'  -> String
"&lt;"
    Char
'>'  -> String
"&gt;"
    Char
'&'  -> String
"&amp;"
    Char
'"'  -> String
"&quot;"
    Char
'\'' -> String
"&39;"
    Char
'\n' -> String
" "
    Char
'\r' -> String
" "
    Char
'\t' -> String
" "
    Char
x    -> [Char
x]

getBaseline :: SVG -> Double
getBaseline :: String -> Double
getBaseline String
str = String -> Double
getBaseline' String
sfx
  where
    (String
_pfx, String
sfx) = String -> String -> (String, String)
forall a. Eq a => [a] -> [a] -> ([a], [a])
spanL String
viewboxMarker String
str

-- | Alter 'SVG' image to be embeddable in HTML page, i.e.align baseline.
--
-- * Add @style="vertical-align: baseline-correction"@
-- * Remove @id="page1"@
--
alterForHTML :: SVG -> SVG
alterForHTML :: ShowS
alterForHTML String
xml =
    String
pfx String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" style='vertical-align: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe Int -> Double -> ShowS
forall a. RealFloat a => Maybe Int -> a -> ShowS
showFFloat (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
6) Double
baseline String
"" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"pt'" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
stripId String
sfx
  where
    (String
_,  String
svg)   = String -> String -> (String, String)
forall a. Eq a => [a] -> [a] -> ([a], [a])
spanL String
"<svg" String
xml
    (String
pfx, String
sfx) = String -> String -> (String, String)
forall a. Eq a => [a] -> [a] -> ([a], [a])
spanL String
viewboxMarker String
svg
    baseline :: Double
baseline   = String -> Double
getBaseline' String
sfx

viewboxMarker :: String
viewboxMarker :: String
viewboxMarker = String
" viewBox='"

stripId :: String -> String
stripId :: ShowS
stripId String
str = String
pfx String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
sfx'
  where
    (String
pfx, String
sfx) = String -> String -> (String, String)
forall a. Eq a => [a] -> [a] -> ([a], [a])
spanL String
needle String
str
    sfx' :: String
sfx'       = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
sfx (String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
needle String
sfx)

    needle :: String
needle = String
"id='page1'"

getBaseline' :: String -> Double
getBaseline' :: String -> Double
getBaseline' String
sfx = case Parsec String () Double
-> String -> String -> Either ParseError Double
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
P.parse Parsec String () Double
parser String
"<input>" String
sfx of
    Left ParseError
err -> String -> Double
forall a. HasCallStack => String -> a
error (String -> Double) -> String -> Double
forall a b. (a -> b) -> a -> b
$ (ParseError, String) -> String
forall a. Show a => a -> String
show (ParseError
err, String
sfx)
    Right Double
x  -> Double -> Double
forall a. Num a => a -> a
negate Double
x
  where
    parser :: P.Parser Double
    parser :: Parsec String () Double
parser = do
        _ <- String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
P.string String
viewboxMarker
        _ <- lexeme double
        _ <- P.spaces
        x <- lexeme double
        _ <- lexeme double
        y <- lexeme double
        return (y + x)

    double :: P.Parser Double
    double :: Parsec String () Double
double = Parser (Double -> Double)
sign Parser (Double -> Double)
-> Parsec String () Double -> Parsec String () Double
forall a b.
ParsecT String () Identity (a -> b)
-> ParsecT String () Identity a -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parsec String () Double
float1 Parsec String () Double
-> Parsec String () Double -> Parsec String () Double
forall a.
ParsecT String () Identity a
-> ParsecT String () Identity a -> ParsecT String () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec String () Double
float2)

    float1 :: P.Parser Double
    float1 :: Parsec String () Double
float1 = do
        d <- Parsec String () Double
decimal
        f <- P.option 0 (P.char '.' *> fraction)
        return (d + f)

    float2 :: P.Parser Double
    float2 :: Parsec String () Double
float2 = Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'.' ParsecT String () Identity Char
-> Parsec String () Double -> Parsec String () Double
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec String () Double
fraction

    decimal :: P.Parser Double
    decimal :: Parsec String () Double
decimal = (Double -> Char -> Double) -> Double -> String -> Double
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Double
x Char
d ->  Double
10Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Char -> Double
forall {a}. Num a => Char -> a
digitToInt Char
d) Double
0
        (String -> Double)
-> ParsecT String () Identity String -> Parsec String () Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity String
forall {u}. ParsecT String u Identity String
digits1

    fraction :: P.Parser Double
    fraction :: Parsec String () Double
fraction = (Double -> Double -> Double) -> (Double, Double) -> Double
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Double -> Double -> Double
forall a. Fractional a => a -> a -> a
(/) ((Double, Double) -> Double)
-> (String -> (Double, Double)) -> String -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Double, Double) -> Char -> (Double, Double))
-> (Double, Double) -> String -> (Double, Double)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\(Double
x,Double
n) Char
d -> (Double
10Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Char -> Double
forall {a}. Num a => Char -> a
digitToInt Char
d,Double
nDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
10)) (Double
0,Double
1)
        (String -> Double)
-> ParsecT String () Identity String -> Parsec String () Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity String
forall {u}. ParsecT String u Identity String
digits1

    digits1 :: ParsecT String u Identity String
digits1 = ParsecT String u Identity Char -> ParsecT String u Identity String
forall a.
ParsecT String u Identity a -> ParsecT String u Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ParsecT String u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
P.digit

    digitToInt :: Char -> a
digitToInt Char
'0' = a
0
    digitToInt Char
'1' = a
1
    digitToInt Char
'2' = a
2
    digitToInt Char
'3' = a
3
    digitToInt Char
'4' = a
4
    digitToInt Char
'5' = a
5
    digitToInt Char
'6' = a
6
    digitToInt Char
'7' = a
7
    digitToInt Char
'8' = a
8
    digitToInt Char
'9' = a
9
    digitToInt Char
_   = a
0

    sign :: P.Parser (Double -> Double)
    sign :: Parser (Double -> Double)
sign = (Double -> Double)
-> Parser (Double -> Double) -> Parser (Double -> Double)
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
P.option Double -> Double
forall a. a -> a
id (Double -> Double
forall a. Num a => a -> a
negate (Double -> Double)
-> ParsecT String () Identity Char -> Parser (Double -> Double)
forall a b.
a -> ParsecT String () Identity b -> ParsecT String () Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'-')

    lexeme :: P.Parser a -> P.Parser a
    lexeme :: forall a. Parser a -> Parser a
lexeme Parser a
p = Parser a
p Parser a -> ParsecT String () Identity () -> Parser a
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
P.spaces

-------------------------------------------------------------------------------
-- Utilities
-------------------------------------------------------------------------------

readProcessWithCWD
    :: FilePath                     -- ^ working  directory
    -> FilePath                     -- ^ Filename of the executable (see 'RawCommand' for details)
    -> [String]                     -- ^ any arguments
    -> IO (ExitCode,String,String)  -- ^ exitcode, stdout, stderr
readProcessWithCWD :: String -> String -> [String] -> IO (ExitCode, String, String)
readProcessWithCWD String
cwd String
cmd [String]
args = CreateProcess -> String -> IO (ExitCode, String, String)
Proc.readCreateProcessWithExitCode
    ((String -> [String] -> CreateProcess
Proc.proc String
cmd [String]
args) { Proc.cwd = Just cwd })
    String
""

-- | Catch 'IOException's and convert them to the 'ExceptT' monad
tryIO :: (MonadIO m, NFData a) => IO a -> ExceptT E.IOException m a
tryIO :: forall (m :: * -> *) a.
(MonadIO m, NFData a) =>
IO a -> ExceptT IOException m a
tryIO IO a
action = m (Either IOException a) -> ExceptT IOException m a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either IOException a) -> ExceptT IOException m a)
-> m (Either IOException a) -> ExceptT IOException m a
forall a b. (a -> b) -> a -> b
$ IO (Either IOException a) -> m (Either IOException a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOException a) -> m (Either IOException a))
-> IO (Either IOException a) -> m (Either IOException a)
forall a b. (a -> b) -> a -> b
$ IO a -> IO (Either IOException a)
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO a -> IO (Either IOException a))
-> IO a -> IO (Either IOException a)
forall a b. (a -> b) -> a -> b
$ IO a -> IO a
forall a. NFData a => IO a -> IO a
evaluateDeep IO a
action

-- | Internal helper function
evaluateDeep :: NFData a => IO a -> IO a
evaluateDeep :: forall a. NFData a => IO a -> IO a
evaluateDeep IO a
action = do
    res <- IO a
action
    E.evaluate $!! res