{-# LANGUAGE OverloadedStrings, CPP #-}
module Haskintex (haskintex) where
import System.Process (readProcess, readCreateProcess, shell)
import System.FilePath
import System.Directory
import System.IO (hFlush,stdout)
import Data.Text (pack,unpack)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Text.Encoding
import Text.Parsec hiding (many,(<|>))
import Text.Parsec.Text ()
import Control.Monad (when,unless,replicateM)
import Control.Monad.Trans.Class
import Control.Monad.Trans.State
import Text.LaTeX hiding (version)
import qualified Text.LaTeX as Hatex
import Text.LaTeX.Base.Syntax
import Control.Applicative
#if !MIN_VERSION_base(4,8,0)
import Data.Foldable (foldMap)
#endif
import Numeric (showFFloat)
import Paths_haskintex (version)
import Data.Version (showVersion)
import Data.List (intersperse, isSuffixOf)
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
import qualified Data.Map as M
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
data Syntax =
WriteLaTeX Text
| WriteHaskell Bool
Bool
Text
| InsertHaTeX Bool
Text
| InsertHaTeXIO Bool
Text
| EvalHaskell Bool
Bool
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
data PackageDB =
CabalSandboxDB
| StackDB
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
isCabalSandboxDB :: PackageDB -> Bool
isCabalSandboxDB :: PackageDB -> Bool
isCabalSandboxDB PackageDB
v = case PackageDB
v of
PackageDB
CabalSandboxDB -> Bool
True
PackageDB
_ -> Bool
False
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
(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
[Char]
_ -> Conf -> [[Char]] -> Conf
go (Conf
c {inputs :: [[Char]]
inputs = Conf -> [[Char]]
inputs Conf
c forall a. [a] -> [a] -> [a]
++ [[Char]
x]}) [[Char]]
xs
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
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 ]
[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 ())
-> Text
-> 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
-> 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
, 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
, 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
, 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
, 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
, 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
, forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
]
type MemoTree = M.Map Text Text
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
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)
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
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
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]
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
-> Bool
-> Text
-> t
-> (t -> Haskintex Text)
-> 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
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
Text
t' <- t -> Haskintex Text
f t
x
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."
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
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."
extractCode :: Syntax -> (Text,Text)
(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
evalCode :: String
-> 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
| 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
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"
[[Char]
"ghc", [Char]
"--", [Char]
"-ignore-dot-ghci",
[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"
[[Char]
"-ignore-dot-ghci",
[Char]
modName forall a. [a] -> [a] -> [a]
++ [Char]
".hs"
, [Char]
"-e", [Char]
e ] []
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."
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
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
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 :: [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
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
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
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"
Haskintex ()
showEnabledFlags
Haskintex ()
reportWarnings
[[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]
"."
[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
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
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
[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
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
[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
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"
[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]
"."
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"