{-# LANGUAGE OverloadedStrings, CPP #-}

module Haskintex (haskintex) where

-- System
import System.Process (readProcess, readCreateProcess, shell)
import System.FilePath
import System.Directory
import System.IO (hFlush,stdout)
-- Text
import Data.Text (pack,unpack)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Text.Encoding
-- Parser
import Text.Parsec hiding (many,(<|>))
import Text.Parsec.Text ()
-- Transformers
import Control.Monad (when,unless,replicateM)
import Control.Monad.Trans.Class
import Control.Monad.Trans.State
-- LaTeX
import Text.LaTeX hiding (version)
import qualified Text.LaTeX as Hatex
import Text.LaTeX.Base.Syntax
-- Utils
import Control.Applicative
#if !MIN_VERSION_base(4,8,0)
import Data.Foldable (foldMap)
#endif
import Numeric (showFFloat)
-- Paths
import Paths_haskintex (version)
import Data.Version (showVersion)
-- Lists
import Data.List (intersperse, isSuffixOf)
-- GHC
import Language.Haskell.Interpreter hiding (get, modName)
import Language.Haskell.Interpreter.Unsafe (unsafeRunInterpreterWithArgs)
import Data.Typeable
import qualified Language.Haskell.Exts.Pretty as H
import qualified Language.Haskell.Exts.Parser as H
import qualified Language.Haskell.Exts.Syntax as H
-- Map
import qualified Data.Map as M
-- Binary
import Data.Binary.Put
import Data.Binary.Get hiding (lookAhead)
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString as SB

-- Syntax

-- | The 'Syntax' datatype describes how haskintex see a LaTeX
--   file. When haskintex processes an input file, it parsers
--   to this structure. It differentiates between these parts:
--
-- * writehaskell environments (WriteHaskell), either marked
--   visible or not, located either in the header (for pragmas)
--   or in the body (for regular code).
--
-- * Haskell expression of type 'LaTeX' (InsertHaTeX).
--   See the HaTeX package for details about this type.
--
-- * Haskell expression of tyep 'IO LaTeX' (InsertHaTeXIO).
--   Exactly like InsertHaTeX, but within the IO monad.
--
-- * evalhaskell commands and environments (EvalHaskell).
--
-- * Anything else (WriteLaTeX).
--
data Syntax =
    WriteLaTeX   Text
  | WriteHaskell Bool -- Visibility: False for Hidden, True for Visible
                 Bool -- Location: True for Header, False for Body
                 Text
  | InsertHaTeX  Bool -- Memorized expression?
                 Text
  | InsertHaTeXIO Bool -- Memorized expression?
                  Text
  | EvalHaskell  Bool -- Type: False for Command, True for Environment
                 Bool -- Memorized expression?
                 Text
  | Sequence     [Syntax]
    deriving Int -> Syntax -> ShowS
[Syntax] -> ShowS
Syntax -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Syntax] -> ShowS
$cshowList :: [Syntax] -> ShowS
show :: Syntax -> [Char]
$cshow :: Syntax -> [Char]
showsPrec :: Int -> Syntax -> ShowS
$cshowsPrec :: Int -> Syntax -> ShowS
Show -- Show instance for debugging.

-- Configuration

-- | Possible sources of package DBs. The value of the type is constructed from
-- CLI argument and tells haskintex which strategy to use for package DB selection.
--
-- If no CLI argument is presented, haskintex tries to guess from local environment
-- which package DB to use.
data PackageDB =
    CabalSandboxDB -- ^ Pick package-db from `.cabal-sandbox` folder
  | StackDB -- ^ Pick package-db from `stack path`
  deriving Int -> PackageDB -> ShowS
[PackageDB] -> ShowS
PackageDB -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PackageDB] -> ShowS
$cshowList :: [PackageDB] -> ShowS
show :: PackageDB -> [Char]
$cshow :: PackageDB -> [Char]
showsPrec :: Int -> PackageDB -> ShowS
$cshowsPrec :: Int -> PackageDB -> ShowS
Show

-- | True if the input value is cabal sandbox package-db
isCabalSandboxDB :: PackageDB -> Bool
isCabalSandboxDB :: PackageDB -> Bool
isCabalSandboxDB PackageDB
v = case PackageDB
v of
  PackageDB
CabalSandboxDB -> Bool
True
  PackageDB
_ -> Bool
False

-- | True if the input value is stack package-db
isStackDB :: PackageDB -> Bool
isStackDB :: PackageDB -> Bool
isStackDB PackageDB
v = case PackageDB
v of
  PackageDB
StackDB -> Bool
True
  PackageDB
_ -> Bool
False

data Conf = Conf
  { Conf -> Bool
keepFlag      :: Bool
  , Conf -> Bool
visibleFlag   :: Bool
  , Conf -> Bool
verboseFlag   :: Bool
  , Conf -> Bool
manualFlag    :: Bool
  , Conf -> Bool
helpFlag      :: Bool
  , Conf -> Bool
lhs2texFlag   :: Bool
  , Conf -> Bool
stdoutFlag    :: Bool
  , Conf -> Bool
overwriteFlag :: Bool
  , Conf -> Bool
debugFlag     :: Bool
  , Conf -> Bool
memoFlag      :: Bool
  , Conf -> Bool
memocleanFlag :: Bool
  , Conf -> Bool
autotexyFlag  :: Bool
  , Conf -> Bool
nosandboxFlag :: Bool
  , Conf -> Maybe PackageDB
packageDb     :: Maybe PackageDB
  , Conf -> Bool
werrorFlag    :: Bool
  , Conf -> [[Char]]
unknownFlags  :: [String]
  , Conf -> [[Char]]
inputs        :: [FilePath]
  , Conf -> MemoTree
memoTree      :: MemoTree
    }

supportedFlags :: [(String,Conf -> Bool)]
supportedFlags :: [([Char], Conf -> Bool)]
supportedFlags =
  [ ([Char]
"keep"      , Conf -> Bool
keepFlag)
  , ([Char]
"visible"   , Conf -> Bool
visibleFlag)
  , ([Char]
"verbose"   , Conf -> Bool
verboseFlag)
  , ([Char]
"manual"    , Conf -> Bool
manualFlag)
  , ([Char]
"help"      , Conf -> Bool
helpFlag)
  , ([Char]
"lhs2tex"   , Conf -> Bool
lhs2texFlag)
  , ([Char]
"stdout"    , Conf -> Bool
stdoutFlag)
  , ([Char]
"overwrite" , Conf -> Bool
overwriteFlag)
  , ([Char]
"debug"     , Conf -> Bool
debugFlag)
  , ([Char]
"memo"      , Conf -> Bool
memoFlag)
  , ([Char]
"memoclean" , Conf -> Bool
memocleanFlag)
  , ([Char]
"autotexy"  , Conf -> Bool
autotexyFlag)
  , ([Char]
"nosandbox" , Conf -> Bool
nosandboxFlag)
  , ([Char]
"cabaldb"   , forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False PackageDB -> Bool
isCabalSandboxDB forall b c a. (b -> c) -> (a -> b) -> a -> c
. Conf -> Maybe PackageDB
packageDb)
  , ([Char]
"stackdb"   , forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False PackageDB -> Bool
isStackDB forall b c a. (b -> c) -> (a -> b) -> a -> c
. Conf -> Maybe PackageDB
packageDb)
  , ([Char]
"werror"    , Conf -> Bool
werrorFlag)
    ]

readConf :: [String] -> Conf
readConf :: [[Char]] -> Conf
readConf = Conf -> [[Char]] -> Conf
go forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Maybe PackageDB
-> Bool
-> [[Char]]
-> [[Char]]
-> MemoTree
-> Conf
Conf Bool
False Bool
False Bool
False Bool
False Bool
False Bool
False Bool
False Bool
False Bool
False Bool
False Bool
False Bool
False Bool
False forall a. Maybe a
Nothing Bool
False [] [] forall k a. Map k a
M.empty
  where
    go :: Conf -> [[Char]] -> Conf
go Conf
c [] = Conf
c
    go Conf
c ([Char]
x:[[Char]]
xs) =
       case [Char]
x of
        -- Arguments starting with '-' are considered a flag.
        (Char
'-':[Char]
flag) ->
           case [Char]
flag of
             [Char]
"keep"      -> Conf -> [[Char]] -> Conf
go (Conf
c {keepFlag :: Bool
keepFlag      = Bool
True}) [[Char]]
xs
             [Char]
"visible"   -> Conf -> [[Char]] -> Conf
go (Conf
c {visibleFlag :: Bool
visibleFlag   = Bool
True}) [[Char]]
xs
             [Char]
"verbose"   -> Conf -> [[Char]] -> Conf
go (Conf
c {verboseFlag :: Bool
verboseFlag   = Bool
True}) [[Char]]
xs
             [Char]
"manual"    -> Conf -> [[Char]] -> Conf
go (Conf
c {manualFlag :: Bool
manualFlag    = Bool
True}) [[Char]]
xs
             [Char]
"help"      -> Conf -> [[Char]] -> Conf
go (Conf
c {helpFlag :: Bool
helpFlag      = Bool
True}) [[Char]]
xs
             [Char]
"lhs2tex"   -> Conf -> [[Char]] -> Conf
go (Conf
c {lhs2texFlag :: Bool
lhs2texFlag   = Bool
True}) [[Char]]
xs
             [Char]
"stdout"    -> Conf -> [[Char]] -> Conf
go (Conf
c {stdoutFlag :: Bool
stdoutFlag    = Bool
True}) [[Char]]
xs
             [Char]
"overwrite" -> Conf -> [[Char]] -> Conf
go (Conf
c {overwriteFlag :: Bool
overwriteFlag = Bool
True}) [[Char]]
xs
             [Char]
"debug"     -> Conf -> [[Char]] -> Conf
go (Conf
c {debugFlag :: Bool
debugFlag     = Bool
True}) [[Char]]
xs
             [Char]
"memo"      -> Conf -> [[Char]] -> Conf
go (Conf
c {memoFlag :: Bool
memoFlag      = Bool
True}) [[Char]]
xs
             [Char]
"memoclean" -> Conf -> [[Char]] -> Conf
go (Conf
c {memocleanFlag :: Bool
memocleanFlag = Bool
True}) [[Char]]
xs
             [Char]
"autotexy"  -> Conf -> [[Char]] -> Conf
go (Conf
c {autotexyFlag :: Bool
autotexyFlag  = Bool
True}) [[Char]]
xs
             [Char]
"nosandbox" -> Conf -> [[Char]] -> Conf
go (Conf
c {nosandboxFlag :: Bool
nosandboxFlag = Bool
True}) [[Char]]
xs
             [Char]
"cabaldb"   -> Conf -> [[Char]] -> Conf
go (Conf
c {packageDb :: Maybe PackageDB
packageDb     = forall a. a -> Maybe a
Just PackageDB
CabalSandboxDB}) [[Char]]
xs
             [Char]
"stackdb"   -> Conf -> [[Char]] -> Conf
go (Conf
c {packageDb :: Maybe PackageDB
packageDb     = forall a. a -> Maybe a
Just PackageDB
StackDB}) [[Char]]
xs
             [Char]
"werror"    -> Conf -> [[Char]] -> Conf
go (Conf
c {werrorFlag :: Bool
werrorFlag    = Bool
True}) [[Char]]
xs
             [Char]
_           -> Conf -> [[Char]] -> Conf
go (Conf
c {unknownFlags :: [[Char]]
unknownFlags = Conf -> [[Char]]
unknownFlags Conf
c forall a. [a] -> [a] -> [a]
++ [[Char]
flag]}) [[Char]]
xs
        -- Otherwise, an input file.
        [Char]
_ -> Conf -> [[Char]] -> Conf
go (Conf
c {inputs :: [[Char]]
inputs = Conf -> [[Char]]
inputs Conf
c forall a. [a] -> [a] -> [a]
++ [[Char]
x]}) [[Char]]
xs

-- Haskintex monad

type Haskintex = StateT Conf IO

outputStr :: String -> Haskintex ()
outputStr :: [Char] -> Haskintex ()
outputStr [Char]
str = do
  Bool
b <- Conf -> Bool
verboseFlag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s. Monad m => StateT s m s
get
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
str

-- PARSING

type Parser = ParsecT Text () Haskintex

parseSyntax :: Parser Syntax
parseSyntax :: Parser Syntax
parseSyntax = do
  Syntax
s <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Syntax] -> Syntax
Sequence forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Alternative f => f a -> f [a]
many forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice [ Parser Syntax
p_writehaskell, Bool -> Parser Syntax
p_inserthatex Bool
False , Bool -> Parser Syntax
p_inserthatex Bool
True , Parser Syntax
p_evalhaskell, Parser Syntax
p_writelatex ]
  forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
  forall (m :: * -> *) a. Monad m => a -> m a
return Syntax
s

p_writehaskell :: Parser Syntax
p_writehaskell :: Parser Syntax
p_writehaskell = do
  Bool
isH <- (forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"\\begin{writehaskell}" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
           forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"\\begin{haskellpragmas}" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
  Bool
b <- forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try [ forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"[hidden]"  forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                         , forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"[visible]" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                         , forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Conf -> Bool
visibleFlag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s. Monad m => StateT s m s
get ] -- When no option is given, take the default.
  [Char]
h <- forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar forall a b. (a -> b) -> a -> b
$ forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string forall a b. (a -> b) -> a -> b
$ if Bool
isH then [Char]
"\\end{haskellpragmas}" else [Char]
"\\end{writehaskell}"
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> Text -> Syntax
WriteHaskell Bool
b Bool
isH forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack [Char]
h

readMemo :: Parser Bool
readMemo :: ParsecT Text () Haskintex Bool
readMemo = (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'[' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice forall {u}. [ParsecT Text u Haskintex Bool]
xs forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
']') forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Conf -> Bool
memoFlag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s. Monad m => StateT s m s
get)
  where
    xs :: [ParsecT Text u Haskintex Bool]
xs = [ forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"memo" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
         , forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"notmemo" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False ]

processExp :: (H.Exp () -> H.Exp ()) -- ^ Transformation to apply to Haskell Expression
           -> Text -- ^ Haskell expression
           -> Parser Text
processExp :: (Exp () -> Exp ()) -> Text -> Parser Text
processExp Exp () -> Exp ()
f Text
t = do
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case [Char] -> ParseResult (Exp SrcSpanInfo)
H.parseExp (Text -> [Char]
unpack Text
t) of
    H.ParseOk Exp SrcSpanInfo
e -> [Char] -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> [Char]
H.prettyPrint forall a b. (a -> b) -> a -> b
$ Exp () -> Exp ()
f forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const () forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp SrcSpanInfo
e
    ParseResult (Exp SrcSpanInfo)
_ -> Text
t

p_inserthatex :: Bool -- False for pure, True for IO
              -> Parser Syntax
p_inserthatex :: Bool -> Parser Syntax
p_inserthatex Bool
isIO = do
  --
  let iden :: [Char]
iden = if Bool
isIO then [Char]
"iohatex" else [Char]
"hatex"
      cons :: Bool -> Text -> Syntax
cons = if Bool
isIO then Bool -> Text -> Syntax
InsertHaTeXIO else Bool -> Text -> Syntax
InsertHaTeX
  --
  [Char]
_ <- forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string forall a b. (a -> b) -> a -> b
$ Char
'\\' forall a. a -> [a] -> [a]
: [Char]
iden
  Bool
b <- ParsecT Text () Haskintex Bool
readMemo
  Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'{'
  [Char]
h <- Int -> ParsecT Text () Haskintex [Char]
p_haskell Int
0
  Bool
auto <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Conf -> Bool
autotexyFlag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s. Monad m => StateT s m s
get
  let v :: [Char] -> Exp ()
v = forall l. l -> QName l -> Exp l
H.Var () forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. l -> Name l -> QName l
H.UnQual () forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. l -> [Char] -> Name l
H.Ident ()
      f :: Exp () -> Exp ()
f = if Bool
auto then forall l. l -> Exp l -> Exp l -> Exp l
H.App () forall a b. (a -> b) -> a -> b
$ if Bool
isIO then forall l. l -> Exp l -> Exp l -> Exp l
H.App () ([Char] -> Exp ()
v [Char]
"fmap") ([Char] -> Exp ()
v [Char]
"texy")
                                          else [Char] -> Exp ()
v [Char]
"texy"
                  else forall a. a -> a
id
  Bool -> Text -> Syntax
cons Bool
b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp () -> Exp ()) -> Text -> Parser Text
processExp Exp () -> Exp ()
f ([Char] -> Text
pack [Char]
h)

p_evalhaskell :: Parser Syntax
p_evalhaskell :: Parser Syntax
p_evalhaskell = forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice [ Parser Syntax
p_evalhaskellenv, Parser Syntax
p_evalhaskellcomm ]

p_evalhaskellenv :: Parser Syntax
p_evalhaskellenv :: Parser Syntax
p_evalhaskellenv = do
  [Char]
_ <- forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"\\begin{evalhaskell}"
  Bool
b <- ParsecT Text () Haskintex Bool
readMemo
  [Char]
h <- forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar forall a b. (a -> b) -> a -> b
$ forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"\\end{evalhaskell}"
  Bool -> Bool -> Text -> Syntax
EvalHaskell Bool
True Bool
b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp () -> Exp ()) -> Text -> Parser Text
processExp forall a. a -> a
id ([Char] -> Text
pack [Char]
h)

p_evalhaskellcomm :: Parser Syntax
p_evalhaskellcomm :: Parser Syntax
p_evalhaskellcomm = do
  [Char]
_  <- forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"\\evalhaskell"
  Bool
b <- ParsecT Text () Haskintex Bool
readMemo
  Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'{'
  [Char]
h  <- Int -> ParsecT Text () Haskintex [Char]
p_haskell Int
0
  Bool -> Bool -> Text -> Syntax
EvalHaskell Bool
False Bool
b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp () -> Exp ()) -> Text -> Parser Text
processExp forall a. a -> a
id ([Char] -> Text
pack [Char]
h)

p_haskell :: Int -> Parser String
p_haskell :: Int -> ParsecT Text () Haskintex [Char]
p_haskell Int
n = forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice [
    do Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'{'
       (Char
'{'forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> ParsecT Text () Haskintex [Char]
p_haskell (Int
nforall a. Num a => a -> a -> a
+Int
1)
  , do Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'}'
       if Int
n forall a. Eq a => a -> a -> Bool
== Int
0
          then forall (m :: * -> *) a. Monad m => a -> m a
return []
          else (Char
'}'forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> ParsecT Text () Haskintex [Char]
p_haskell (Int
nforall a. Num a => a -> a -> a
-Int
1)
  , do Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\"'
       forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall a. [a] -> [a] -> [a]
(++) ((Char
'\"'forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Haskintex [Char]
p_string) (Int -> ParsecT Text () Haskintex [Char]
p_haskell Int
n)
  , forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"'{'") forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
"'{'"
  , forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"'}'") forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
"'}'"
  , forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (:) forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (Int -> ParsecT Text () Haskintex [Char]
p_haskell Int
n)
    ]

p_string :: Parser String
p_string :: ParsecT Text () Haskintex [Char]
p_string = forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice [
    forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall a. [a] -> [a] -> [a]
(++) (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\\' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\"' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
"\\\"") ParsecT Text () Haskintex [Char]
p_string
  , forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (:) (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\"') (forall (m :: * -> *) a. Monad m => a -> m a
return [])
  , forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (:) forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar ParsecT Text () Haskintex [Char]
p_string
    ]

p_writelatex :: Parser Syntax
p_writelatex :: Parser Syntax
p_writelatex = (Text -> Syntax
WriteLaTeX forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
pack) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (forall {u}. ParsecT Text u Haskintex Bool
p_other forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b -> if Bool
b then forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar else forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"stop write latex")
  where
    p_other :: ParsecT Text u Haskintex Bool
p_other =
      forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead)
             [ forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"\\begin{writehaskell}"   forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False -- starts p_writehaskell (for body)
             , forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"\\begin{haskellpragmas}" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False -- starts p_writehaskell (for header)
             , forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"\\hatex"                 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False -- starts p_inserthatex
             , forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"\\iohatex"               forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False -- starts p_inserthatexio
             , forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"\\begin{evalhaskell}"    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False -- starts p_evalhaskellenv
             , forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"\\evalhaskell"           forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False -- starts p_evalhaskellcomm
             , forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
             ]

----------------------------------------------------------
----------------------------------------------------------
-- MEMO TREE

-- | A 'MemoTree' maps each expression to its reduced form.
type MemoTree = M.Map Text Text

-- | Search in current directory and all parents dirs for given file.
-- Return 'True' if found such file, 'False' either way. Search is performed
-- until root folder is not hit.
doesFileExistsUp :: FilePath -> IO Bool
doesFileExistsUp :: [Char] -> IO Bool
doesFileExistsUp [Char]
fname = do
  [[Char]]
parents <- [Char] -> [[Char]]
getAllParents forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [Char]
getCurrentDirectory
  [Bool]
checks <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Char] -> IO Bool
doesFileExist forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> ShowS
</> [Char]
fname)) [[Char]]
parents
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
checks

-- | Generate list of all parents of the given path including the path itself.
getAllParents :: FilePath -> [FilePath]
getAllParents :: [Char] -> [[Char]]
getAllParents = [[Char]] -> [[Char]]
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
splitDirectories
  where
    go :: [[Char]] -> [[Char]]
go [] = []
    go [[Char]]
segs = let
      parent :: [Char]
parent = [[Char]] -> [Char]
joinPath forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [[Char]]
segs
      in [Char]
parent forall a. a -> [a] -> [a]
: [[Char]] -> [[Char]]
go (forall a. Int -> [a] -> [a]
drop Int
1 [[Char]]
segs)

-- | Try to detect cabal sandbox or stack project and get pathes to package DBs.
--
-- If ambigous situation is presented (both stack and cabal sandbox is found),
-- then fail with descriptive message.
autoDetectSandbox :: Haskintex (Maybe [String])
autoDetectSandbox :: Haskintex (Maybe [[Char]])
autoDetectSandbox = do
  Bool
noSandbox <- Conf -> Bool
nosandboxFlag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s. Monad m => StateT s m s
get
  if Bool
noSandbox
     then do
       [Char] -> Haskintex ()
outputStr [Char]
"Ignoring sandbox."
       forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
     else do Bool
inSandbox <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> IO Bool
doesDirectoryExist [Char]
".cabal-sandbox"
             Bool
hasStackFile <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> IO Bool
doesFileExistsUp [Char]
"stack.yaml"
             case (Bool
inSandbox, Bool
hasStackFile) of
               (Bool
True, Bool
False) -> do
                 [Char] -> Haskintex ()
outputStr [Char]
"Detected cabal sandbox."
                 Haskintex (Maybe [[Char]])
loadCabalSandboxDBPaths
               (Bool
False, Bool
True) -> do
                 [Char] -> Haskintex ()
outputStr [Char]
"Detected stack sandbox."
                 Haskintex (Maybe [[Char]])
loadStackDBPaths
               (Bool
True, Bool
True) -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"Found both cabal sandbox and stack project. Please, specify which package DB to use with either "
                 forall a. [a] -> [a] -> [a]
++ [Char]
" '-cabaldb' or '-stackdb' flags."
               (Bool
False, Bool
False) -> do
                 [Char] -> Haskintex ()
outputStr [Char]
"No sandbox or stack project detected."
                 forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

-- | Generate CLI arguments for GHC for package DB using cabal sandbox
loadCabalSandboxDBPaths :: Haskintex (Maybe [String])
loadCabalSandboxDBPaths :: Haskintex (Maybe [[Char]])
loadCabalSandboxDBPaths = do
  [Char] -> Haskintex ()
outputStr [Char]
"Using cabal sandbox for package db"
  [[Char]]
sand <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> IO [[Char]]
getDirectoryContents [Char]
".cabal-sandbox"
  let pkgdbs :: [[Char]]
pkgdbs = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf [Char]
"packages.conf.d") [[Char]]
sand
  case [[Char]]
pkgdbs of
    [Char]
pkgdb : [[Char]]
_ -> do
      [Char] -> Haskintex ()
outputStr forall a b. (a -> b) -> a -> b
$ [Char]
"Using sandbox package db: " forall a. [a] -> [a] -> [a]
++ [Char]
pkgdb
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [[Char]
".cabal-sandbox/" forall a. [a] -> [a] -> [a]
++ [Char]
pkgdb]
    [[Char]]
_ -> do
      [Char] -> Haskintex ()
outputStr [Char]
"Don't use sandbox. Empty .cabal-sandbox"
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

-- | Generate CLI arguments for GHC for package DB using stack environment
loadStackDBPaths :: Haskintex (Maybe [String])
loadStackDBPaths :: Haskintex (Maybe [[Char]])
loadStackDBPaths = do
  [Char] -> Haskintex ()
outputStr [Char]
"Using stack environment for package db"
  let getDBPath :: [Char] -> t IO [Char]
getDBPath [Char]
s = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= Char
'\n')) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ CreateProcess -> [Char] -> IO [Char]
readCreateProcess ([Char] -> CreateProcess
shell forall a b. (a -> b) -> a -> b
$ [Char]
"stack path --" forall a. [a] -> [a] -> [a]
++ [Char]
s) [Char]
""
  [Char]
pkgdbSnapshot <- forall {t :: (* -> *) -> * -> *}.
(Functor (t IO), MonadTrans t) =>
[Char] -> t IO [Char]
getDBPath [Char]
"snapshot-pkg-db"
  [Char]
pkgdbGlobal <- forall {t :: (* -> *) -> * -> *}.
(Functor (t IO), MonadTrans t) =>
[Char] -> t IO [Char]
getDBPath [Char]
"global-pkg-db"
  [Char]
pkgdbLocal <- forall {t :: (* -> *) -> * -> *}.
(Functor (t IO), MonadTrans t) =>
[Char] -> t IO [Char]
getDBPath [Char]
"local-pkg-db"
  [Char] -> Haskintex ()
outputStr forall a b. (a -> b) -> a -> b
$ [Char]
"Using sandbox package db: \n" forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unlines [[Char]
pkgdbSnapshot, [Char]
pkgdbGlobal, [Char]
pkgdbLocal]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [[Char]
pkgdbSnapshot, [Char]
pkgdbGlobal, [Char]
pkgdbLocal]

-- | Try to detect cabal sandbox and use stack's ones if user specifies the 'stackdb' flag.
getSandbox :: Haskintex (Maybe [String])
getSandbox :: Haskintex (Maybe [[Char]])
getSandbox = do
  Maybe PackageDB
pkgDbConf <- Conf -> Maybe PackageDB
packageDb forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s. Monad m => StateT s m s
get
  case Maybe PackageDB
pkgDbConf of
    Maybe PackageDB
Nothing -> Haskintex (Maybe [[Char]])
autoDetectSandbox
    Just PackageDB
CabalSandboxDB -> Haskintex (Maybe [[Char]])
loadCabalSandboxDBPaths
    Just PackageDB
StackDB -> Haskintex (Maybe [[Char]])
loadStackDBPaths

memoreduce :: Typeable t
           => String -- ^ Auxiliar module name
           -> Bool -- ^ Is this expression memorized?
           -> Text -- ^ Input
           -> t -- ^ Type
           -> (t -> Haskintex Text) -- ^ Rendering function
           -> Haskintex Text
memoreduce :: forall t.
Typeable t =>
[Char]
-> Bool -> Text -> t -> (t -> Haskintex Text) -> Haskintex Text
memoreduce [Char]
modName Bool
isMemo Text
t t
ty t -> Haskintex Text
f = do
  let e :: [Char]
e = Text -> [Char]
unpack Text
t
  [Char] -> Haskintex ()
outputStr forall a b. (a -> b) -> a -> b
$ [Char]
"Evaluation (" forall a. [a] -> [a] -> [a]
++ TypeRep -> ShowS
showsTypeRep (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just t
ty) [Char]
"" forall a. [a] -> [a] -> [a]
++ [Char]
"): " forall a. [a] -> [a] -> [a]
++ [Char]
e
  MemoTree
memt <- Conf -> MemoTree
memoTree forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s. Monad m => StateT s m s
get
  let p :: Maybe Text
p = if Bool
isMemo then forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
t MemoTree
memt else forall a. Maybe a
Nothing
  case Maybe Text
p of
    Maybe Text
Nothing -> do
      let int :: InterpreterT Haskintex t
int = do
             forall (m :: * -> *). MonadInterpreter m => [[Char]] -> m ()
loadModules [[Char]
modName]
             forall (m :: * -> *). MonadInterpreter m => [[Char]] -> m ()
setTopLevelModules [[Char]
modName]
             forall (m :: * -> *). MonadInterpreter m => [[Char]] -> m ()
setImports [[Char]
"Prelude"]
             forall (m :: * -> *) a.
(MonadInterpreter m, Typeable a) =>
[Char] -> a -> m a
interpret [Char]
e t
ty
      -- Sandbox recognition and executing interpreter
      Either InterpreterError t
r <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
InterpreterT m a -> m (Either InterpreterError a)
runInterpreter InterpreterT Haskintex t
int) (\[[Char]]
pkgdbs -> forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
[[Char]] -> InterpreterT m a -> m (Either InterpreterError a)
unsafeRunInterpreterWithArgs (([Char]
"-package-db " forall a. [a] -> [a] -> [a]
++) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Char]]
pkgdbs) InterpreterT Haskintex t
int) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Haskintex (Maybe [[Char]])
getSandbox
      case Either InterpreterError t
r of
        Left InterpreterError
err -> do
          Bool
shouldFail <- Conf -> Bool
werrorFlag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s. Monad m => StateT s m s
get
          if Bool
shouldFail
            then forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"Error: failed while evaluating the expression: \n"
                   forall a. [a] -> [a] -> [a]
++ InterpreterError -> [Char]
errorString InterpreterError
err
            else [Char] -> Haskintex ()
outputStr forall a b. (a -> b) -> a -> b
$ [Char]
"Warning: Error while evaluating the expression.\n"
                   forall a. [a] -> [a] -> [a]
++ InterpreterError -> [Char]
errorString InterpreterError
err
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
        Right t
x -> do
          -- Render result
          Text
t' <- t -> Haskintex Text
f t
x
          -- If the expression is marked to be memorized, store it in the 'MemoTree'.
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isMemo forall a b. (a -> b) -> a -> b
$ do
            forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify forall a b. (a -> b) -> a -> b
$ \Conf
st -> Conf
st { memoTree :: MemoTree
memoTree = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
t Text
t' forall a b. (a -> b) -> a -> b
$ Conf -> MemoTree
memoTree Conf
st }
            [Char] -> Haskintex ()
outputStr forall a b. (a -> b) -> a -> b
$ [Char]
"-> Result has been memorized."
          -- Return result
          forall (m :: * -> *) a. Monad m => a -> m a
return Text
t'
    Just Text
o -> do
      [Char] -> Haskintex ()
outputStr [Char]
"-> Result of the evaluation recovered from memo tree."
      forall (m :: * -> *) a. Monad m => a -> m a
return Text
o

{- Memo Tree Format

A memo tree is stored as a list of (key,value) in key ascending order.
Keys and values are encoded in UTF-8.

| offset |   description        | size (in bytes) |
---------------------------------------------------
| 00     | Number of blocks     | 2               |
| 02     | Zero or more blocks  | variable        |

Each block has the following structure:

| offset |   description        | size (in bytes) |
---------------------------------------------------
| 00     | Length of key (k)    | 2               |
| 02     | Length of value (v)  | 2               |
| 04     | Key                  | k               |
| 04+k   | Value                | v               |

-}

memoTreeToBinary :: MemoTree -> ByteString
memoTreeToBinary :: MemoTree -> ByteString
memoTreeToBinary MemoTree
memt = Put -> ByteString
runPut forall a b. (a -> b) -> a -> b
$ do
  Word16 -> Put
putWord16le forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> Int
M.size MemoTree
memt
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(Text
t,Text
t') -> do
    let b :: ByteString
b  = Text -> ByteString
encodeUtf8 Text
t
        b' :: ByteString
b' = Text -> ByteString
encodeUtf8 Text
t'
    Word16 -> Put
putWord16le forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
SB.length ByteString
b
    Word16 -> Put
putWord16le forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
SB.length ByteString
b'
    ByteString -> Put
putByteString ByteString
b
    ByteString -> Put
putByteString ByteString
b'
    ) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toAscList MemoTree
memt

memoTreeFromBinary :: ByteString -> Either String MemoTree
memoTreeFromBinary :: ByteString -> Either [Char] MemoTree
memoTreeFromBinary ByteString
b =
  case forall a.
Get a
-> ByteString
-> Either (ByteString, Int64, [Char]) (ByteString, Int64, a)
runGetOrFail Get MemoTree
getMemoTree ByteString
b of
    Left (ByteString
_,Int64
_,[Char]
err) -> forall a b. a -> Either a b
Left [Char]
err
    Right (ByteString
_,Int64
_,MemoTree
memt) -> forall a b. b -> Either a b
Right MemoTree
memt

getMemoTree :: Get MemoTree
getMemoTree :: Get MemoTree
getMemoTree = do
  Int
n <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word16
getWord16le
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k a. Eq k => [(k, a)] -> Map k a
M.fromAscList forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n forall a b. (a -> b) -> a -> b
$ do
    Word16
l  <- Get Word16
getWord16le
    Word16
l' <- Get Word16
getWord16le
    ByteString
b  <- Int -> Get ByteString
getByteString forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
l
    ByteString
b' <- Int -> Get ByteString
getByteString forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
l'
    forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Text
decodeUtf8 ByteString
b, ByteString -> Text
decodeUtf8 ByteString
b')

memoTreeOpen :: Haskintex ()
memoTreeOpen :: Haskintex ()
memoTreeOpen = do
  [Char]
d <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
getAppUserDataDirectory [Char]
"haskintex"
  let fp :: [Char]
fp = [Char]
d [Char] -> ShowS
</> [Char]
"memotree"
  Bool
b <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO Bool
doesFileExist [Char]
fp
  if Bool
b then do ByteString
t <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ByteString
LB.readFile [Char]
fp
               case ByteString -> Either [Char] MemoTree
memoTreeFromBinary ByteString
t of
                 Left [Char]
err -> do
                   [Char] -> Haskintex ()
outputStr forall a b. (a -> b) -> a -> b
$ [Char]
"Error: memotree failed to read: " forall a. [a] -> [a] -> [a]
++ [Char]
err
                   [Char] -> Haskintex ()
outputStr [Char]
"-> Using empty memotree."
                   forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify forall a b. (a -> b) -> a -> b
$ \Conf
st -> Conf
st { memoTree :: MemoTree
memoTree = forall k a. Map k a
M.empty }
                 Right MemoTree
memt -> do
                   forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify forall a b. (a -> b) -> a -> b
$ \Conf
st -> Conf
st { memoTree :: MemoTree
memoTree = MemoTree
memt }
                   let n :: Int64
n = ByteString -> Int64
LB.length ByteString
t
                       kbs :: Double
                       kbs :: Double
kbs = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
n forall a. Fractional a => a -> a -> a
/ Double
1024
                       s :: [Char]
s = if Double
kbs forall a. Ord a => a -> a -> Bool
< Double
1 then forall a. Show a => a -> [Char]
show Int64
n forall a. [a] -> [a] -> [a]
++ [Char]
" Bs"
                                      else forall a. RealFloat a => Maybe Int -> a -> ShowS
showFFloat (forall a. a -> Maybe a
Just Int
2) Double
kbs [Char]
" KBs"
                   [Char] -> Haskintex ()
outputStr forall a b. (a -> b) -> a -> b
$ [Char]
"Info: memotree loaded (" forall a. [a] -> [a] -> [a]
++ [Char]
s forall a. [a] -> [a] -> [a]
++ [Char]
")."
       else do [Char] -> Haskintex ()
outputStr [Char]
"Info: memotree does not exist."
               [Char] -> Haskintex ()
outputStr [Char]
"-> Using empty memotree."
               forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify forall a b. (a -> b) -> a -> b
$ \Conf
st -> Conf
st { memoTree :: MemoTree
memoTree = forall k a. Map k a
M.empty }

memoTreeSave :: Haskintex ()
memoTreeSave :: Haskintex ()
memoTreeSave = do
  MemoTree
memt <- Conf -> MemoTree
memoTree forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s. Monad m => StateT s m s
get
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall k a. Map k a -> Bool
M.null MemoTree
memt) forall a b. (a -> b) -> a -> b
$ do
    [Char] -> Haskintex ()
outputStr [Char]
"Saving memotree..."
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
      [Char]
d <- [Char] -> IO [Char]
getAppUserDataDirectory [Char]
"haskintex"
      Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True [Char]
d
      let fp :: [Char]
fp = [Char]
d [Char] -> ShowS
</> [Char]
"memotree"
      [Char] -> ByteString -> IO ()
LB.writeFile [Char]
fp forall a b. (a -> b) -> a -> b
$ MemoTree -> ByteString
memoTreeToBinary MemoTree
memt
    [Char] -> Haskintex ()
outputStr [Char]
"Info: memotree saved."

memoTreeClean :: Haskintex ()
memoTreeClean :: Haskintex ()
memoTreeClean = do
  [Char]
d <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
getAppUserDataDirectory [Char]
"haskintex"
  let fp :: [Char]
fp = [Char]
d [Char] -> ShowS
</> [Char]
"memotree"
  Bool
b <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO Bool
doesFileExist [Char]
fp
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
removeFile [Char]
fp
    [Char] -> Haskintex ()
outputStr [Char]
"Info: memotree removed."

----------------------------------------------------------

-- PASS 1: Extract code from processed Syntax.

extractCode :: Syntax -> (Text,Text)
extractCode :: Syntax -> (Text, Text)
extractCode (WriteHaskell Bool
_ Bool
isH Text
t) = if Bool
isH then (Text
t,forall a. Monoid a => a
mempty) else (forall a. Monoid a => a
mempty,Text
t)
extractCode (Sequence [Syntax]
xs) = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Syntax -> (Text, Text)
extractCode [Syntax]
xs
extractCode Syntax
_ = forall a. Monoid a => a
mempty

-- PASS 2: Evaluate Haskell expressions from processed Syntax.

evalCode :: String -- ^ Auxiliary module name
         -> Syntax -> Haskintex Text
evalCode :: [Char] -> Syntax -> Haskintex Text
evalCode [Char]
modName = Syntax -> Haskintex Text
go
  where
    go :: Syntax -> Haskintex Text
go (WriteLaTeX Text
t) = forall (m :: * -> *) a. Monad m => a -> m a
return Text
t
    go (WriteHaskell Bool
b Bool
_ Text
t) = do
         Bool
mFlag <- Conf -> Bool
manualFlag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s. Monad m => StateT s m s
get
         Bool
lhsFlag <- Conf -> Bool
lhs2texFlag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s. Monad m => StateT s m s
get
         let f :: Text -> LaTeX
             f :: Text -> LaTeX
f Text
x | Bool -> Bool
not Bool
b = forall a. Monoid a => a
mempty
                 | Bool
mFlag = forall l. LaTeXC l => Text -> l
raw Text
x
                 | Bool
lhsFlag = [Char] -> [TeXArg] -> LaTeX -> LaTeX
TeXEnv [Char]
"code" [] forall a b. (a -> b) -> a -> b
$ forall l. LaTeXC l => Text -> l
raw Text
x
                 | Bool
otherwise = forall l. LaTeXC l => Text -> l
verbatim Text
x
         forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Render a => a -> Text
render forall a b. (a -> b) -> a -> b
$ Text -> LaTeX
f Text
t
    go (InsertHaTeX   Bool
isMemo Text
t) = forall t.
Typeable t =>
[Char]
-> Bool -> Text -> t -> (t -> Haskintex Text) -> Haskintex Text
memoreduce [Char]
modName Bool
isMemo Text
t (forall a. Typeable a => a
as ::    LaTeX) (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
.      forall a. Render a => a -> Text
render)
    go (InsertHaTeXIO Bool
isMemo Text
t) = forall t.
Typeable t =>
[Char]
-> Bool -> Text -> t -> (t -> Haskintex Text) -> Haskintex Text
memoreduce [Char]
modName Bool
isMemo Text
t (forall a. Typeable a => a
as :: IO LaTeX) (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Render a => a -> Text
render)
    go (EvalHaskell Bool
env Bool
isMemo Text
t) = do
         Bool
mFlag <- Conf -> Bool
manualFlag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s. Monad m => StateT s m s
get
         Bool
lhsFlag <- Conf -> Bool
lhs2texFlag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s. Monad m => StateT s m s
get
         let f :: Text -> LaTeX
             f :: Text -> LaTeX
f Text
x | Bool
mFlag = forall l. LaTeXC l => Text -> l
raw Text
x -- Manual flag overrides lhs2tex flag behavior
                 | Bool
env Bool -> Bool -> Bool
&& Bool
lhsFlag = [Char] -> [TeXArg] -> LaTeX -> LaTeX
TeXEnv [Char]
"code" [] forall a b. (a -> b) -> a -> b
$ forall l. LaTeXC l => Text -> l
raw Text
x
                 | Bool
lhsFlag = forall l. LaTeXC l => Text -> l
raw forall a b. (a -> b) -> a -> b
$ Text
"|" forall a. Semigroup a => a -> a -> a
<> Text
x forall a. Semigroup a => a -> a -> a
<> Text
"|"
                 | Bool
env = forall l. LaTeXC l => Text -> l
verbatim forall a b. (a -> b) -> a -> b
$ Text -> Text
layout Text
x
                 | Bool
otherwise = forall l. LaTeXC l => Text -> l
verb Text
x
         (forall a. Render a => a -> Text
render forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LaTeX
f) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Bool -> Text -> Haskintex Text
ghc [Char]
modName Bool
isMemo Text
t
    go (Sequence [Syntax]
xs) = forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Syntax -> Haskintex Text
go [Syntax]
xs

ghc :: String -> Bool -> Text -> Haskintex Text
ghc :: [Char] -> Bool -> Text -> Haskintex Text
ghc [Char]
modName Bool
isMemo Text
t = do
  let e :: [Char]
e = Text -> [Char]
unpack Text
t
  [Char] -> Haskintex ()
outputStr forall a b. (a -> b) -> a -> b
$ [Char]
"Evaluation: " forall a. [a] -> [a] -> [a]
++ [Char]
e
  MemoTree
memt <- Conf -> MemoTree
memoTree forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s. Monad m => StateT s m s
get
  let p :: Maybe Text
p = if Bool
isMemo then forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
t MemoTree
memt else forall a. Maybe a
Nothing
  case Maybe Text
p of
    Maybe Text
Nothing -> do
      Bool
useStack <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False PackageDB -> Bool
isStackDB forall b c a. (b -> c) -> (a -> b) -> a -> c
. Conf -> Maybe PackageDB
packageDb) forall (m :: * -> *) s. Monad m => StateT s m s
get
      -- Run GHC externally and read the result.
      Text
r <- if Bool
useStack
        then forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
init forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> [[Char]] -> [Char] -> IO [Char]
readProcess [Char]
"stack"
                -- Disable reading of .ghci files.
                [[Char]
"ghc", [Char]
"--", [Char]
"-ignore-dot-ghci", 
                -- Evaluation loading the temporal module.
                [Char]
modName forall a. [a] -> [a] -> [a]
++ [Char]
".hs"
                , [Char]
"-e", [Char]
e ] []
        else forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
init forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> [[Char]] -> [Char] -> IO [Char]
readProcess [Char]
"ghc"
                -- Disable reading of .ghci files.
                [[Char]
"-ignore-dot-ghci", 
                -- Evaluation loading the temporal module.
                [Char]
modName forall a. [a] -> [a] -> [a]
++ [Char]
".hs"
                , [Char]
"-e", [Char]
e ] []
      -- If the expression is marked to be memorized, we do so.
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isMemo forall a b. (a -> b) -> a -> b
$ do
         forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify forall a b. (a -> b) -> a -> b
$ \Conf
st -> Conf
st { memoTree :: MemoTree
memoTree = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
t Text
r forall a b. (a -> b) -> a -> b
$ Conf -> MemoTree
memoTree Conf
st }
         [Char] -> Haskintex ()
outputStr [Char]
"-> Result has been memorized."
      -- Return result
      forall (m :: * -> *) a. Monad m => a -> m a
return Text
r
    Just Text
o -> do
      [Char] -> Haskintex ()
outputStr [Char]
"-> Result of the evaluation recovered from memo tree."
      forall (m :: * -> *) a. Monad m => a -> m a
return Text
o

maxLineLength :: Int
maxLineLength :: Int
maxLineLength = Int
60

-- | Break lines longer than 'maxLineLenght'.
layout :: Text -> Text
layout :: Text -> Text
layout = [Text] -> Text
T.unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines
  where
    go :: [Text] -> [Text]
go [] = []
    go (Text
t:[Text]
ts) =
      if Text -> Int
T.length Text
t forall a. Ord a => a -> a -> Bool
> Int
maxLineLength
         then let (Text
l,Text
r) = Int -> Text -> (Text, Text)
T.splitAt Int
maxLineLength Text
t
              in  Text
l forall a. a -> [a] -> [a]
: [Text] -> [Text]
go (Text
rforall a. a -> [a] -> [a]
:[Text]
ts)
         else Text
t forall a. a -> [a] -> [a]
: [Text] -> [Text]
go [Text]
ts

-- Errors

errorString :: InterpreterError -> String
errorString :: InterpreterError -> [Char]
errorString (UnknownError [Char]
e) = [Char]
"Unknown error: " forall a. [a] -> [a] -> [a]
++ [Char]
e
errorString (WontCompile [GhcError]
es) = [Char]
"Compiler error:\n" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [a]
init ([[Char]] -> [Char]
unlines forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GhcError -> [Char]
errMsg [GhcError]
es)
errorString (NotAllowed [Char]
e) = [Char]
"Not allowed:" forall a. [a] -> [a] -> [a]
++ [Char]
e
errorString (GhcException [Char]
e) = [Char]
"GHC exception: " forall a. [a] -> [a] -> [a]
++ [Char]
e

-- Haskintex main function

-- | Run haskintex with the given arguments. For example:
--
-- > haskintex ["-visible","-overwrite","foo.htex"]
--
--   Useful if you want to call /haskintex/ from another program.
--
haskintex :: [String] -> IO ()
haskintex :: [[Char]] -> IO ()
haskintex = forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT Haskintex ()
haskintexmain forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> Conf
readConf

haskintexmain :: Haskintex ()
haskintexmain :: Haskintex ()
haskintexmain = do
  Conf
flags <- forall (m :: * -> *) s. Monad m => StateT s m s
get
  if -- If the help flag is passed, ignore everything else
     -- and just print the help.
     Conf -> Bool
helpFlag Conf
flags
     then forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStr [Char]
help
     else let xs :: [[Char]]
xs = Conf -> [[Char]]
inputs Conf
flags
          in  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
xs
                 then forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStr [Char]
noFiles
                 else do Haskintex ()
memoTreeOpen
                         forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [Char] -> Haskintex ()
haskintexFile [[Char]]
xs
                         Bool
willClean <- Conf -> Bool
memocleanFlag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s. Monad m => StateT s m s
get
                         if Bool
willClean then Haskintex ()
memoTreeClean else Haskintex ()
memoTreeSave

commas :: [String] -> String
commas :: [[Char]] -> [Char]
commas = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
intersperse [Char]
", "

showEnabledFlags :: Haskintex ()
showEnabledFlags :: Haskintex ()
showEnabledFlags = do
  Conf
c <- forall (m :: * -> *) s. Monad m => StateT s m s
get
  [Char] -> Haskintex ()
outputStr forall a b. (a -> b) -> a -> b
$ [Char]
"Enabled flags: "
           forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
commas (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\([Char]
str,Conf -> Bool
f) [[Char]]
xs -> if Conf -> Bool
f Conf
c then [Char]
str forall a. a -> [a] -> [a]
: [[Char]]
xs else [[Char]]
xs) [] [([Char], Conf -> Bool)]
supportedFlags)
           forall a. [a] -> [a] -> [a]
++ [Char]
"."

reportWarnings :: Haskintex ()
reportWarnings :: Haskintex ()
reportWarnings = do
  -- Combination of manual and lhs2tex flags.
  Bool
manFlag <- Conf -> Bool
manualFlag  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s. Monad m => StateT s m s
get
  Bool
lhsFlag <- Conf -> Bool
lhs2texFlag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s. Monad m => StateT s m s
get
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
manFlag Bool -> Bool -> Bool
&& Bool
lhsFlag) forall a b. (a -> b) -> a -> b
$
    [Char] -> Haskintex ()
outputStr [Char]
"Warning: lhs2tex flag is useless in presence of manual flag."

haskintexFile :: FilePath -> Haskintex ()
haskintexFile :: [Char] -> Haskintex ()
haskintexFile [Char]
fp_ = do
  -- If the given file does not exist, try adding '.htex'.
  Bool
b <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> IO Bool
doesFileExist [Char]
fp_
  let fp :: [Char]
fp = if Bool
b then [Char]
fp_ else [Char]
fp_ forall a. [a] -> [a] -> [a]
++ [Char]
".htex"
  -- Report enabled flags
  Haskintex ()
showEnabledFlags
  -- Warnings
  Haskintex ()
reportWarnings
  -- Other unknown flags passed.
  [[Char]]
uFlags <- Conf -> [[Char]]
unknownFlags forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s. Monad m => StateT s m s
get
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
uFlags) forall a b. (a -> b) -> a -> b
$
    [Char] -> Haskintex ()
outputStr forall a b. (a -> b) -> a -> b
$ [Char]
"Unsupported flags: " forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
commas [[Char]]
uFlags forall a. [a] -> [a] -> [a]
++ [Char]
"."
  -- File parsing.
  [Char] -> Haskintex ()
outputStr forall a b. (a -> b) -> a -> b
$ [Char]
"Reading " forall a. [a] -> [a] -> [a]
++ [Char]
fp forall a. [a] -> [a] -> [a]
++ [Char]
"..."
  Text
t <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> IO Text
T.readFile [Char]
fp
  Either ParseError Syntax
pres <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> u -> [Char] -> s -> m (Either ParseError a)
runParserT Parser Syntax
parseSyntax () [Char]
fp Text
t
  case Either ParseError Syntax
pres of
    Left ParseError
err -> [Char] -> Haskintex ()
outputStr forall a b. (a -> b) -> a -> b
$ [Char]
"Reading of " forall a. [a] -> [a] -> [a]
++ [Char]
fp forall a. [a] -> [a] -> [a]
++ [Char]
" failed:\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show ParseError
err
    Right Syntax
s -> do
      -- Zero pass: In case of debugging, write down the parsed AST.
      Bool
dbugFlag <- Conf -> Bool
debugFlag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s. Monad m => StateT s m s
get
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
dbugFlag forall a b. (a -> b) -> a -> b
$ do
        let debugfp :: [Char]
debugfp = ShowS
dropExtension (ShowS
takeFileName [Char]
fp) forall a. [a] -> [a] -> [a]
++ [Char]
".debughtex"
        [Char] -> Haskintex ()
outputStr forall a b. (a -> b) -> a -> b
$ [Char]
"Writing file " forall a. [a] -> [a] -> [a]
++ [Char]
debugfp forall a. [a] -> [a] -> [a]
++ [Char]
" with debugging output..."
        forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
writeFile [Char]
debugfp forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Syntax
s
      -- First pass: Create haskell source from the code obtained with 'extractCode'.
      let modName :: [Char]
modName = ([Char]
"Haskintex_" forall a. [a] -> [a] -> [a]
++) forall a b. (a -> b) -> a -> b
$ ShowS
dropExtension forall a b. (a -> b) -> a -> b
$ ShowS
takeFileName [Char]
fp
      [Char] -> Haskintex ()
outputStr forall a b. (a -> b) -> a -> b
$ [Char]
"Creating Haskell source file " forall a. [a] -> [a] -> [a]
++ [Char]
modName forall a. [a] -> [a] -> [a]
++ [Char]
".hs..."
      let (Text
hsH,Text
hs) = Syntax -> (Text, Text)
extractCode Syntax
s
          moduleHeader :: Text
moduleHeader = [Char] -> Text
pack forall a b. (a -> b) -> a -> b
$ [Char]
"\nmodule " forall a. [a] -> [a] -> [a]
++ [Char]
modName forall a. [a] -> [a] -> [a]
++ [Char]
" where\n\n"
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> Text -> IO ()
T.writeFile ([Char]
modName forall a. [a] -> [a] -> [a]
++ [Char]
".hs") forall a b. (a -> b) -> a -> b
$ Text
hsH forall a. Semigroup a => a -> a -> a
<> Text
moduleHeader forall a. Semigroup a => a -> a -> a
<> Text
hs
      -- Second pass: Evaluate expressions using 'evalCode'.
      [Char] -> Haskintex ()
outputStr forall a b. (a -> b) -> a -> b
$ [Char]
"Evaluating expressions in " forall a. [a] -> [a] -> [a]
++ [Char]
fp forall a. [a] -> [a] -> [a]
++ [Char]
"..."
      Text
l <- [Char] -> Syntax -> Haskintex Text
evalCode [Char]
modName Syntax
s
      -- Write final output.
      let fp' :: [Char]
fp' = ShowS
dropExtension (ShowS
takeFileName [Char]
fp) forall a. [a] -> [a] -> [a]
++ [Char]
".tex"
          writeit :: Haskintex ()
writeit = do [Char] -> Haskintex ()
outputStr forall a b. (a -> b) -> a -> b
$ [Char]
"Writing final file at " forall a. [a] -> [a] -> [a]
++ [Char]
fp' forall a. [a] -> [a] -> [a]
++ [Char]
"..."
                       forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> Text -> IO ()
T.writeFile [Char]
fp' Text
l
      Bool
outFlag <- Conf -> Bool
stdoutFlag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s. Monad m => StateT s m s
get
      Bool
overFlag <- Conf -> Bool
overwriteFlag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s. Monad m => StateT s m s
get
      Bool
nonew <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> IO Bool
doesFileExist [Char]
fp'
      let finalOutput :: Haskintex ()
finalOutput
           | Bool
outFlag = do [Char] -> Haskintex ()
outputStr [Char]
"Sending final output to stdout..."
                          forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStr Text
l
           | Bool
overFlag = Haskintex ()
writeit
           | Bool
nonew = do forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ [Char]
"File " forall a. [a] -> [a] -> [a]
++ [Char]
fp' forall a. [a] -> [a] -> [a]
++ [Char]
" already exists. Overwrite?"
                                     forall a. [a] -> [a] -> [a]
++ [Char]
" (use -overwrite to overwrite by default) "
                        forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hFlush Handle
stdout -- To immediately show the text on Windows systems.
                        [Char]
resp <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO [Char]
getLine
                        if [Char]
resp forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]
"",[Char]
"y",[Char]
"yes"]
                           then Haskintex ()
writeit
                           else [Char] -> Haskintex ()
outputStr [Char]
"No file was written."
           | Bool
otherwise = Haskintex ()
writeit
      Haskintex ()
finalOutput
      -- If the keep flag is not set, remove the haskell source file.
      Bool
kFlag <- Conf -> Bool
keepFlag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s. Monad m => StateT s m s
get
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
kFlag forall a b. (a -> b) -> a -> b
$ do
        [Char] -> Haskintex ()
outputStr forall a b. (a -> b) -> a -> b
$ [Char]
"Removing Haskell source file " forall a. [a] -> [a] -> [a]
++ [Char]
modName forall a. [a] -> [a] -> [a]
++ [Char]
".hs "
                  forall a. [a] -> [a] -> [a]
++ [Char]
"(use -keep to avoid this)..."
        forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
removeFile forall a b. (a -> b) -> a -> b
$ [Char]
modName forall a. [a] -> [a] -> [a]
++ [Char]
".hs"
      -- End.
      [Char] -> Haskintex ()
outputStr forall a b. (a -> b) -> a -> b
$ [Char]
"End of processing of file " forall a. [a] -> [a] -> [a]
++ [Char]
fp forall a. [a] -> [a] -> [a]
++ [Char]
"."

-- MESSAGES

help :: String
help :: [Char]
help = [[Char]] -> [Char]
unlines [
    [Char]
"You are using haskintex version " forall a. [a] -> [a] -> [a]
++ Version -> [Char]
showVersion Version
version forall a. [a] -> [a] -> [a]
++ [Char]
"."
  , [Char]
"http://daniel-diaz.github.io/projects/haskintex"
  , [Char]
""
  , [Char]
"The underlying HaTeX version is " forall a. [a] -> [a] -> [a]
++ Version -> [Char]
showVersion Version
Hatex.version forall a. [a] -> [a] -> [a]
++ [Char]
"."
  , [Char]
""
  , [Char]
"Usage and flags:"
  , [Char]
"Any argument passed to haskintex that starts with '-' will be considered"
  , [Char]
"a flag. Otherwise, it will be considered an input file. Every input file"
  , [Char]
"will be processed with the same set of flags, which will include all the"
  , [Char]
"flags passed in the call. This is the list of flags supported by haskintex:"
  , [Char]
""
  , [Char]
"  -keep       haskintex creates an intermmediate Haskell file before"
  , [Char]
"              evaluating any expressions. By default, this file is "
  , [Char]
"              eliminated after processing the file. Pass this flag to"
  , [Char]
"              keep the file."
  , [Char]
""
  , [Char]
"  -visible    By default, code written inside a writehaskell environment"
  , [Char]
"              is not shown in the LaTeX output. This flag changes the"
  , [Char]
"              default."
  , [Char]
""
  , [Char]
"  -verbose    If this flag is enabled, haskintex will print information"
  , [Char]
"              about its own execution while running."
  , [Char]
""
  , [Char]
"  -manual     By default, Haskell expressions, either from writehaskell "
  , [Char]
"              or evalhaskell, appear in the LaTeX output inside verb or"
  , [Char]
"              verbatim declarations. If this flag is passed, neither verb"
  , [Char]
"              nor verbatim will be used. The code will be written as text "
  , [Char]
"              as it is. The user will decide how to handle it."
  , [Char]
""
  , [Char]
"  -help       This flags cancels any other flag or input file and makes"
  , [Char]
"              the program simply show this help message."
  , [Char]
""
  , [Char]
"  -stdout     Instead of writing the output to a file, send it to the"
  , [Char]
"              standard output stream (stdout)."
  , [Char]
""
  , [Char]
"  -lhs2tex    Instead of using verb or verbatim declarations, format the"
  , [Char]
"              output using the syntax accepted by lhs2TeX."
  , [Char]
""
  , [Char]
"  -overwrite  Overwrite the output file if it already exists. If this flag"
  , [Char]
"              is not set, the program will ask before overwriting."
  , [Char]
""
  , [Char]
"  -debug      Only for debugging purposes. It writes a file with extension"
  , [Char]
"              .debughtex with the AST of the internal representation of the"
  , [Char]
"              input file haskintex uses."
  , [Char]
""
  , [Char]
"  -memo       Unless otherwise specified, every evalhaskell, hatex or iohatex"
  , [Char]
"              command (or environment) will be called with the memo option."
  , [Char]
""
  , [Char]
"  -memoclean  Cleans the memo tree after the execution of haskintex. If "
  , [Char]
"              several files are processed, the memo tree will be cleaned"
  , [Char]
"              after processing all of them."
  , [Char]
""
  , [Char]
"  -autotexy   Apply the function texy from HaTeX to every expression in a hatex"
  , [Char]
"              or iohatex command. This effectively allows the user to write"
  , [Char]
"              expressions in types other than LaTeX and have haskintex to perform"
  , [Char]
"              the required transformation."
  , [Char]
""
  , [Char]
"  -nosandbox  Do not use a sandbox package db even in the presence of one."
  , [Char]
""
  , [Char]
"  -cabaldb    Use local cabal sandbox."
  , [Char]
""
  , [Char]
"  -stackdb    Use local stackage db."
  , [Char]
""
  , [Char]
"Any unsupported flag will be ignored."
  ]

noFiles :: String
noFiles :: [Char]
noFiles = [Char]
"No input file given.\n"