diff --git a/Haskintex.hs b/Haskintex.hs --- a/Haskintex.hs +++ b/Haskintex.hs @@ -12,27 +12,40 @@ import Data.Text (pack,unpack) import qualified Data.Text as T import qualified Data.Text.IO as T +import Data.Text.Encoding -- Parser --- import Data.Attoparsec.Text import Text.Parsec hiding (many,(<|>)) -import Text.Parsec.Text +import Text.Parsec.Text () -- Transformers -import Control.Monad (when,unless) +import Control.Monad (when,unless,replicateM) import Control.Monad.Trans.Class -import Control.Monad.Trans.Reader +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 import Data.Foldable (foldMap) +import Numeric (showFFloat) -- Paths -import Paths_haskintex +import Paths_haskintex (version) import Data.Version (showVersion) -- Lists import Data.List (intersperse) -- GHC -import Language.Haskell.Interpreter +import Language.Haskell.Interpreter hiding (get) +import Data.Typeable +import qualified Language.Haskell.Exts.Pretty as H +import qualified Language.Haskell.Exts.Parser 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 @@ -56,58 +69,148 @@ -- data Syntax = WriteLaTeX Text - | WriteHaskell Bool Bool Text -- First Bool: False for Hidden, True for Visible. - -- Second Bool: True for Header, False for Body. - | InsertHaTeX Text - | InsertHaTeXIO Text - | EvalHaskell Bool Text -- False for Command, True for Environment + | 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 Show -- Show instance for debugging. +-- Configuration + +data Conf = Conf + { keepFlag :: Bool + , visibleFlag :: Bool + , verboseFlag :: Bool + , manualFlag :: Bool + , helpFlag :: Bool + , lhs2texFlag :: Bool + , stdoutFlag :: Bool + , overwriteFlag :: Bool + , debugFlag :: Bool + , memoFlag :: Bool + , memocleanFlag :: Bool + , unknownFlags :: [String] + , inputs :: [FilePath] + , memoTree :: MemoTree + } + +supportedFlags :: [(String,Conf -> Bool)] +supportedFlags = + [ ("keep" , keepFlag) + , ("visible" , visibleFlag) + , ("verbose" , verboseFlag) + , ("manual" , manualFlag) + , ("help" , helpFlag) + , ("lhs2tex" , lhs2texFlag) + , ("stdout" , stdoutFlag) + , ("overwrite" , overwriteFlag) + , ("debug" , debugFlag) + , ("memo" , memoFlag) + , ("memoclean" , memocleanFlag) + ] + +readConf :: [String] -> Conf +readConf = go $ Conf False False False False False False False False False False False [] [] M.empty + where + go c [] = c + go c (x:xs) = + case x of + -- Arguments starting with '-' are considered a flag. + ('-':flag) -> + case flag of + "keep" -> go (c {keepFlag = True}) xs + "visible" -> go (c {visibleFlag = True}) xs + "verbose" -> go (c {verboseFlag = True}) xs + "manual" -> go (c {manualFlag = True}) xs + "help" -> go (c {helpFlag = True}) xs + "lhs2tex" -> go (c {lhs2texFlag = True}) xs + "stdout" -> go (c {stdoutFlag = True}) xs + "overwrite" -> go (c {overwriteFlag = True}) xs + "debug" -> go (c {debugFlag = True}) xs + "memo" -> go (c {memoFlag = True}) xs + "memoclean" -> go (c {memocleanFlag = True}) xs + _ -> go (c {unknownFlags = unknownFlags c ++ [flag]}) xs + -- Otherwise, an input file. + _ -> go (c {inputs = inputs c ++ [x]}) xs + +-- Haskintex monad + +type Haskintex = StateT Conf IO + +outputStr :: String -> Haskintex () +outputStr str = do + b <- verboseFlag <$> get + when b $ lift $ putStrLn str + -- PARSING -parseSyntax :: Bool -> Parser Syntax -parseSyntax v = do - s <- fmap Sequence $ many $ choice $ fmap try [ p_writehaskell v, p_inserthatex, p_inserthatexio , p_evalhaskell, p_writelatex ] +type Parser = ParsecT Text () Haskintex + +parseSyntax :: Parser Syntax +parseSyntax = do + s <- fmap Sequence $ many $ choice [ p_writehaskell, p_inserthatex False , p_inserthatex True , p_evalhaskell, p_writelatex ] eof return s -p_writehaskell :: Bool -> Parser Syntax -p_writehaskell v = do +p_writehaskell :: Parser Syntax +p_writehaskell = do isH <- (try $ string "\\begin{writehaskell}" >> return False) - <|> (string "\\begin{haskellpragmas}" >> return True) + <|> (try $ string "\\begin{haskellpragmas}" >> return True) b <- choice $ fmap try [ string "[hidden]" >> return False , string "[visible]" >> return True - , return v ] -- When no option is given, take the default. + , lift $ visibleFlag <$> get ] -- When no option is given, take the default. h <- manyTill anyChar $ try $ string $ if isH then "\\end{haskellpragmas}" else "\\end{writehaskell}" return $ WriteHaskell b isH $ pack h -p_inserthatex :: Parser Syntax -p_inserthatex = do - _ <- string "\\hatex{" - h <- p_haskell 0 - return $ InsertHaTeX $ pack h +readMemo :: Parser Bool +readMemo = (char '[' *> choice xs <* char ']') <|> lift (memoFlag <$> get) + where + xs = [ string "memo" >> return True + , string "notmemo" >> return False ] -p_inserthatexio :: Parser Syntax -p_inserthatexio = do - _ <- string "\\iohatex{" +processExp :: Text -> Text +processExp t = + case H.parseExp (unpack t) of + H.ParseOk e -> pack $ H.prettyPrint e + _ -> t + +p_inserthatex :: Bool -- False for pure, True for IO + -> Parser Syntax +p_inserthatex isIO = do + -- + let iden = if isIO then "iohatex" else "hatex" + cons = if isIO then InsertHaTeXIO else InsertHaTeX + -- + _ <- try $ string $ '\\' : iden + b <- readMemo + _ <- char '{' h <- p_haskell 0 - return $ InsertHaTeXIO $ pack h + return $ cons b $ processExp $ pack h p_evalhaskell :: Parser Syntax -p_evalhaskell = choice $ fmap try [ p_evalhaskellenv, p_evalhaskellcomm ] +p_evalhaskell = choice [ p_evalhaskellenv, p_evalhaskellcomm ] p_evalhaskellenv :: Parser Syntax p_evalhaskellenv = do - _ <- string "\\begin{evalhaskell}" + _ <- try $ string "\\begin{evalhaskell}" + b <- readMemo h <- manyTill anyChar $ try $ string "\\end{evalhaskell}" - return $ EvalHaskell True $ pack h + return $ EvalHaskell True b $ processExp $ pack h p_evalhaskellcomm :: Parser Syntax p_evalhaskellcomm = do - _ <- string "\\evalhaskell{" + _ <- try $ string "\\evalhaskell" + b <- readMemo + _ <- char '{' h <- p_haskell 0 - return $ EvalHaskell False $ pack h + return $ EvalHaskell False b $ processExp $ pack h p_haskell :: Int -> Parser String p_haskell n = choice [ @@ -146,6 +249,146 @@ , return True ] +---------------------------------------------------------- +---------------------------------------------------------- +-- MEMO TREE + +-- | A 'MemoTree' maps each expression to its reduced form. +type MemoTree = M.Map Text Text + +memoreduce :: Typeable t + => String -- ^ Auxiliar module name + -> Bool -- ^ Is this expression memorized? + -> Text -- ^ Input + -> t -- ^ Type + -> (t -> Haskintex Text) -- ^ Rendering function + -> Haskintex Text +memoreduce modName isMemo t ty f = do + let e = unpack t + outputStr $ "Evaluation (" ++ showsTypeRep (typeRep $ Just t) "" ++ "): " ++ e + memt <- memoTree <$> get + let p = if isMemo then M.lookup t memt else Nothing + case p of + Nothing -> do + let int = do + loadModules [modName] + setTopLevelModules [modName] + setImports ["Prelude"] + interpret e ty + r <- runInterpreter int + case r of + Left err -> do + outputStr $ "Warning: Error while evaluating the expression.\n" + ++ errorString err + return mempty + Right x -> do + -- Render result + t' <- f x + -- If the expression is marked to be memorized, store it in the 'MemoTree'. + when isMemo $ do + modify $ \st -> st { memoTree = M.insert t t' $ memoTree st } + outputStr $ "-> Result has been memorized." + -- Return result + return t' + Just o -> do + outputStr "-> Result of the evaluation recovered from memo tree." + return 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 memt = runPut $ do + putWord16le $ fromIntegral $ M.size memt + mapM_ (\(t,t') -> do + let b = encodeUtf8 t + b' = encodeUtf8 t' + putWord16le $ fromIntegral $ SB.length b + putWord16le $ fromIntegral $ SB.length b' + putByteString b + putByteString b' + ) $ M.toAscList memt + +memoTreeFromBinary :: ByteString -> Either String MemoTree +memoTreeFromBinary b = + case runGetOrFail getMemoTree b of + Left (_,_,err) -> Left err + Right (_,_,memt) -> Right memt + +getMemoTree :: Get MemoTree +getMemoTree = do + n <- fromIntegral <$> getWord16le + fmap M.fromAscList $ replicateM n $ do + l <- getWord16le + l' <- getWord16le + b <- getByteString $ fromIntegral l + b' <- getByteString $ fromIntegral l' + return (decodeUtf8 b, decodeUtf8 b') + +memoTreeOpen :: Haskintex () +memoTreeOpen = do + d <- liftIO $ getAppUserDataDirectory "haskintex" + let fp = d "memotree" + b <- liftIO $ doesFileExist fp + if b then do t <- liftIO $ LB.readFile fp + case memoTreeFromBinary t of + Left err -> do + outputStr $ "Error: memotree failed to read: " ++ err + outputStr "-> Using empty memotree." + modify $ \st -> st { memoTree = M.empty } + Right memt -> do + modify $ \st -> st { memoTree = memt } + let n = LB.length t + kbs :: Double + kbs = fromIntegral n / 1024 + s = if kbs < 1 then show n ++ " Bs" + else showFFloat (Just 2) kbs " KBs" + outputStr $ "Info: memotree loaded (" ++ s ++ ")." + else do outputStr "Info: memotree does not exist." + outputStr "-> Using empty memotree." + modify $ \st -> st { memoTree = M.empty } + +memoTreeSave :: Haskintex () +memoTreeSave = do + memt <- memoTree <$> get + unless (M.null memt) $ do + outputStr "Saving memotree..." + liftIO $ do + d <- getAppUserDataDirectory "haskintex" + createDirectoryIfMissing True d + let fp = d "memotree" + LB.writeFile fp $ memoTreeToBinary memt + outputStr "Info: memotree saved." + +memoTreeClean :: Haskintex () +memoTreeClean = do + d <- liftIO $ getAppUserDataDirectory "haskintex" + let fp = d "memotree" + b <- liftIO $ doesFileExist fp + when b $ do + liftIO $ removeFile fp + outputStr "Info: memotree removed." + +---------------------------------------------------------- + -- PASS 1: Extract code from processed Syntax. extractCode :: Syntax -> (Text,Text) @@ -156,70 +399,57 @@ -- PASS 2: Evaluate Haskell expressions from processed Syntax. evalCode :: String -- ^ Auxiliary module name - -> Bool -- ^ Is manual flag on? - -> Bool -- ^ Is lhs2tex flag on? -> Syntax -> Haskintex Text -evalCode modName mFlag lhsFlag = go +evalCode modName = go where go (WriteLaTeX t) = return t - go (WriteHaskell b _ t) = + go (WriteHaskell b _ t) = do + mFlag <- manualFlag <$> get + lhsFlag <- lhs2texFlag <$> get let f :: Text -> LaTeX f x | not b = mempty | mFlag = raw x | lhsFlag = TeXEnv "code" [] $ raw x | otherwise = verbatim x - in return $ render $ f t - go (InsertHaTeX t) = do - let e = unpack $ T.strip t - int = do - loadModules [modName] - setTopLevelModules [modName] - setImports ["Prelude"] - interpret e (as :: LaTeX) - outputStr $ "Evaluation (LaTeX): " ++ e - r <- runInterpreter int - case r of - Left err -> do - outputStr $ "Warning: Error while evaluating the expression.\n" - ++ errorString err - return mempty - Right l -> return $ render l - go (InsertHaTeXIO t) = do - let e = unpack $ T.strip t - int = do - loadModules [modName] - setTopLevelModules [modName] - setImports ["Prelude"] - interpret e (as :: IO LaTeX) - outputStr $ "Evaluation (IO LaTeX): " ++ e - r <- runInterpreter int - case r of - Left err -> do - outputStr $ "Warning: Error while evaluating the expression.\n" - ++ errorString err - return mempty - Right l -> liftIO $ render <$> l - go (EvalHaskell env t) = + return $ render $ f t + go (InsertHaTeX isMemo t) = memoreduce modName isMemo t (as :: LaTeX) (return . render) + go (InsertHaTeXIO isMemo t) = memoreduce modName isMemo t (as :: IO LaTeX) (liftIO . fmap render) + go (EvalHaskell env isMemo t) = do + mFlag <- manualFlag <$> get + lhsFlag <- lhs2texFlag <$> get let f :: Text -> LaTeX f x | mFlag = raw x -- Manual flag overrides lhs2tex flag behavior | env && lhsFlag = TeXEnv "code" [] $ raw x | lhsFlag = raw $ "|" <> x <> "|" | env = verbatim $ layout x | otherwise = verb x - in (render . f . pack) <$> ghc modName t + (render . f) <$> ghc modName isMemo t go (Sequence xs) = mconcat <$> mapM go xs -ghc :: String -> Text -> Haskintex String -ghc modName e = do - let e' = unpack $ T.strip e - outputStr $ "Evaluation: " ++ e' - lift $ init <$> readProcess "ghc" - -- Disable reading of .ghci files. - [ "-ignore-dot-ghci" - -- Evaluation loading the temporal module. - -- The expression is stripped. - , "-e", e', modName ++ ".hs" - ] [] +ghc :: String -> Bool -> Text -> Haskintex Text +ghc modName isMemo t = do + let e = unpack t + outputStr $ "Evaluation: " ++ e + memt <- memoTree <$> get + let p = if isMemo then M.lookup t memt else Nothing + case p of + Nothing -> do + -- Run GHC externally and read the result. + r <- lift $ pack . init <$> readProcess "ghc" + -- Disable reading of .ghci files. + [ "-ignore-dot-ghci" + -- Evaluation loading the temporal module. + , "-e", e, modName ++ ".hs" + ] [] + -- If the expression is marked to be memorized, we do so. + when isMemo $ do + modify $ \st -> st { memoTree = M.insert t r $ memoTree st } + outputStr "-> Result has been memorized." + -- Return result + return r + Just o -> do + outputStr "-> Result of the evaluation recovered from memo tree." + return o maxLineLength :: Int maxLineLength = 60 @@ -243,78 +473,20 @@ errorString (NotAllowed e) = "Not allowed:" ++ e errorString (GhcException e) = "GHC exception: " ++ e --- Configuration - -data Conf = Conf - { keepFlag :: Bool - , visibleFlag :: Bool - , verboseFlag :: Bool - , manualFlag :: Bool - , helpFlag :: Bool - , lhs2texFlag :: Bool - , stdoutFlag :: Bool - , overwriteFlag :: Bool - , debugFlag :: Bool - , unknownFlags :: [String] - , inputs :: [FilePath] - } - -supportedFlags :: [(String,Conf -> Bool)] -supportedFlags = - [ ("keep" , keepFlag) - , ("visible" , visibleFlag) - , ("verbose" , verboseFlag) - , ("manual" , manualFlag) - , ("help" , helpFlag) - , ("lhs2tex" , lhs2texFlag) - , ("stdout" , stdoutFlag) - , ("overwrite" , overwriteFlag) - , ("debug" , debugFlag) - ] - -readConf :: [String] -> Conf -readConf = go $ Conf False False False False False False False False False [] [] - where - go c [] = c - go c (x:xs) = - case x of - -- Arguments starting with '-' are considered a flag. - ('-':flag) -> - case flag of - "keep" -> go (c {keepFlag = True}) xs - "visible" -> go (c {visibleFlag = True}) xs - "verbose" -> go (c {verboseFlag = True}) xs - "manual" -> go (c {manualFlag = True}) xs - "help" -> go (c {helpFlag = True}) xs - "lhs2tex" -> go (c {lhs2texFlag = True}) xs - "stdout" -> go (c {stdoutFlag = True}) xs - "overwrite" -> go (c {overwriteFlag = True}) xs - "debug" -> go (c {debugFlag = True}) xs - _ -> go (c {unknownFlags = unknownFlags c ++ [flag]}) xs - -- Otherwise, an input file. - _ -> go (c {inputs = inputs c ++ [x]}) xs - --- Haskintex - -type Haskintex = ReaderT Conf IO - -outputStr :: String -> Haskintex () -outputStr str = do - b <- verboseFlag <$> ask - when b $ lift $ putStrLn str +-- 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. --- This function does /not/ do any system call. +-- haskintex :: [String] -> IO () -haskintex = runReaderT haskintexmain . readConf +haskintex = evalStateT haskintexmain . readConf haskintexmain :: Haskintex () haskintexmain = do - flags <- ask + flags <- get if -- If the help flag is passed, ignore everything else -- and just print the help. helpFlag flags @@ -322,14 +494,17 @@ else let xs = inputs flags in if null xs then lift $ putStr noFiles - else mapM_ haskintexFile xs + else do memoTreeOpen + mapM_ haskintexFile xs + willClean <- memocleanFlag <$> get + if willClean then memoTreeClean else memoTreeSave commas :: [String] -> String commas = concat . intersperse ", " showEnabledFlags :: Haskintex () showEnabledFlags = do - c <- ask + c <- get outputStr $ "Enabled flags: " ++ commas (foldr (\(str,f) xs -> if f c then str : xs else xs) [] supportedFlags) ++ "." @@ -337,8 +512,8 @@ reportWarnings :: Haskintex () reportWarnings = do -- Combination of manual and lhs2tex flags. - manFlag <- manualFlag <$> ask - lhsFlag <- lhs2texFlag <$> ask + manFlag <- manualFlag <$> get + lhsFlag <- lhs2texFlag <$> get when (manFlag && lhsFlag) $ outputStr "Warning: lhs2tex flag is useless in presence of manual flag." @@ -352,20 +527,18 @@ -- Warnings reportWarnings -- Other unknown flags passed. - uFlags <- unknownFlags <$> ask + uFlags <- unknownFlags <$> get unless (null uFlags) $ outputStr $ "Unsupported flags: " ++ commas uFlags ++ "." -- File parsing. outputStr $ "Reading " ++ fp ++ "..." - vFlag <- visibleFlag <$> ask t <- lift $ T.readFile fp - -- case parseOnly (parseSyntax vFlag) t of - -- Left err -> outputStr $ "Reading of " ++ fp ++ " failed: " ++ err - case parse (parseSyntax vFlag) fp t of + pres <- runParserT parseSyntax () fp t + case pres of Left err -> outputStr $ "Reading of " ++ fp ++ " failed:\n" ++ show err Right s -> do -- Zero pass: In case of debugging, write down the parsed AST. - dbugFlag <- debugFlag <$> ask + dbugFlag <- debugFlag <$> get when dbugFlag $ do let debugfp = dropExtension (takeFileName fp) ++ ".debughtex" outputStr $ "Writing file " ++ debugfp ++ " with debugging output..." @@ -378,15 +551,13 @@ lift $ T.writeFile (modName ++ ".hs") $ hsH <> moduleHeader <> hs -- Second pass: Evaluate expressions using 'evalCode'. outputStr $ "Evaluating expressions in " ++ fp ++ "..." - mFlag <- manualFlag <$> ask - lhsFlag <- lhs2texFlag <$> ask - l <- evalCode modName mFlag lhsFlag s + l <- evalCode modName s -- Write final output. let fp' = dropExtension (takeFileName fp) ++ ".tex" writeit = do outputStr $ "Writing final file at " ++ fp' ++ "..." lift $ T.writeFile fp' l - outFlag <- stdoutFlag <$> ask - overFlag <- overwriteFlag <$> ask + outFlag <- stdoutFlag <$> get + overFlag <- overwriteFlag <$> get nonew <- lift $ doesFileExist fp' let finalOutput | outFlag = do outputStr "Sending final output to stdout..." @@ -402,7 +573,7 @@ | otherwise = writeit finalOutput -- If the keep flag is not set, remove the haskell source file. - kFlag <- keepFlag <$> ask + kFlag <- keepFlag <$> get unless kFlag $ do outputStr $ "Removing Haskell source file " ++ modName ++ ".hs " ++ "(use -keep to avoid this)..." @@ -417,6 +588,8 @@ "You are using haskintex version " ++ showVersion version ++ "." , "http://daniel-diaz.github.io/projects/haskintex" , "" + , "The underlying HaTeX version is " ++ showVersion Hatex.version ++ "." + , "" , "Usage and flags:" , "Any argument passed to haskintex that starts with '-' will be considered" , "a flag. Otherwise, it will be considered an input file. Every input file" @@ -456,6 +629,13 @@ , " -debug Only for debugging purposes. It writes a file with extension" , " .debughtex with the AST of the internal representation of the" , " input file haskintex uses." + , "" + , " -memo Unless otherwise specified, every evalhaskell, hatex or iohatex" + , " command (or environment) will be called with the memo option." + , "" + , " -memoclean Cleans the memo tree after the execution of haskintex. If " + , " several files are processed, the memo tree will be cleaned" + , " after processing all of them." , "" , "Any unsupported flag will be ignored." ] diff --git a/haskintex.cabal b/haskintex.cabal --- a/haskintex.cabal +++ b/haskintex.cabal @@ -1,5 +1,5 @@ name: haskintex -version: 0.4.1.0 +version: 0.5.0.0 synopsis: Haskell Evaluation inside of LaTeX code. description: The /haskintex/ (Haskell in LaTeX) program is a tool that reads a LaTeX file and evaluates Haskell expressions contained @@ -37,14 +37,19 @@ library default-language: Haskell2010 - build-depends: base == 4.* + build-depends: base >= 4.7 && < 5 , transformers == 0.3.* , text >= 0.11.2.3 && < 2 - , directory >= 1.2.0.0 && < 1.3 - , filepath >= 1.1.0.0 && < 1.4 - , process - , HaTeX >= 3.9.0.0 && < 4 - , parsec >= 3.1.2 && < 3.2 - , hint >= 0.3.3.5 && < 0.5 + , bytestring >= 0.10.4 + , directory >= 1.2.0 && < 1.3 + , filepath >= 1.1.0 && < 1.4 + , process >= 1.2.0 + , HaTeX >= 3.9.0.0 + , parsec >= 3.1.2 + , hint >= 0.3.3 && < 0.5 + , containers >= 0.5.5 + , binary >= 0.7.1 + , haskell-src-exts >= 1.15.0 exposed-modules: Haskintex other-modules: Paths_haskintex + ghc-options: -Wall