Skip to content
This repository
Browse code

* Interesting new feature: when calling ghci/hugs via \eval and \perf…

…orm, we now start only

  process which is then fed with the expressions to evaluate `interactively'. In files which
  contain many \eval and \perform commands, this should dramatically improve execution time
  for lhs2TeX.


git-svn-id: https://subversion.cs.uu.nl/repos/staff.andres.lhs2tex/lhs2TeX/trunk@159 d54a9f6e-e2dc-0310-8252-bfaaff2a01be
  • Loading branch information...
commit 9de89a0bba2e0dfdd19aa16229e9e909bc0a3c99 1 parent 2bccbdd
andres authored
2  FiniteMap.lhs
@@ -4,7 +4,7 @@
4 4
5 5 %if codeOnly || showModuleHeader
6 6
7   -> module FiniteMap ( FiniteMap, empty, fromList, add, lookup, (!))
  7 +> module FiniteMap ( FiniteMap, empty, fromList, add, lookup, (!), keys)
8 8 > where
9 9 > import Prelude hiding ( lookup )
10 10 > import Maybe
121 Main.lhs
@@ -8,7 +8,7 @@
8 8 > where
9 9 >
10 10 > import Char
11   -> import System.IO ( hClose, hPutStr, hPutStrLn, stderr, stdout, openFile, IOMode(..), Handle(..) )
  11 +> import System.IO ( hClose, hPutStr, hPutStrLn, hFlush, hGetLine, stderr, stdout, openFile, IOMode(..), Handle(..) )
12 12 > import System.Directory ( copyFile )
13 13 > import System.Console.GetOpt
14 14 > import Text.Regex ( matchRegex, mkRegexWithOpts )
@@ -16,7 +16,8 @@
16 16 > import Version
17 17 >
18 18 > import Control.Monad
19   -> import Data.List ( isPrefixOf )
  19 +>
  20 +> import System.Process
20 21 >
21 22 > -- import IOExts
22 23 > import TeXCommands
@@ -102,7 +103,8 @@ State.
102 103 > stacks :: (Math.Stack, Math.Stack), -- math: indentation stacks
103 104 > separation :: Int, -- poly: separation
104 105 > latency :: Int, -- poly: latency
105   -> pstack :: Poly.Stack -- poly: indentation stack
  106 +> pstack :: Poly.Stack, -- poly: indentation stack
  107 +> externals :: Externals -- handles for external processes (hugs,ghci)
106 108 > }
107 109
108 110 Initial state.
@@ -118,8 +120,8 @@ Initial state.
118 120 > opts = "",
119 121 > files = [],
120 122 > path = "",
121   -> fmts = FM.fromList [],
122   -> subst = FM.fromList [],
  123 +> fmts = FM.empty,
  124 +> subst = FM.empty,
123 125 > stack = [],
124 126 > conds = [],
125 127 > align = Nothing,
@@ -131,7 +133,8 @@ Initial state.
131 133 > style = error "uninitialized style",
132 134 > file = error "uninitialized filename",
133 135 > ofile = error "uninitialized filename",
134   -> toggles = error "uninitialized toggles"
  136 +> toggles = error "uninitialized toggles",
  137 +> externals = FM.empty
135 138 > }
136 139
137 140 > initState :: Style -> FilePath -> [FilePath] -> State -> State
@@ -170,7 +173,8 @@ Initial state.
170 173 > expandedpath <- expandPath (searchpath flags)
171 174 > toIO (do store (initState s file expandedpath flags)
172 175 > formats (map (No 0) dirs) `handle` abort
173   -> formatStr (addEndEOF str))
  176 +> formatStr (addEndEOF str)
  177 +> stopexternals)
174 178 > where addEndEOF = (++"%EOF\n") . unlines . lines
175 179
176 180 > input :: [String] -> IO (String, FilePath)
@@ -280,15 +284,11 @@ We abort immediately if an error has occured.
280 284 > format (Command (Vrb b) s) = out (Verbatim.inline b s)
281 285 > format (Command Eval s) = do st <- fetch
282 286 > when (not (style st `elem` [CodeOnly,NewCode])) $
283   -> do fromIO $ when (verbose st) $
284   -> hPutStrLn stderr "Calling external command."
285   -> result <- fromIO (hugs (file st) (opts st) (map unNL s))
  287 +> do result <- external (map unNL s)
286 288 > inline result
287 289 > format (Command Perform s) = do st <- fetch
288 290 > when (not (style st `elem` [CodeOnly,NewCode])) $
289   -> do fromIO $ when (verbose st) $
290   -> hPutStrLn stderr "Calling external command."
291   -> result <- fromIO (hugs (file st) (opts st) s)
  291 +> do result <- external s
292 292 > out (Text (trim result))
293 293 > where
294 294
@@ -307,7 +307,7 @@ Remove trailing blank line.
307 307 > display s
308 308 > format (Environment Evaluate s )
309 309 > = do st <- fetch
310   -> result <- fromIO (hugs (file st) (opts st) (map unNL s))
  310 +> result <- external (map unNL s)
311 311 > --fromIO (hPutStrLn stderr result) -- TEST
312 312 > display result
313 313 > format (Environment Hide s) = return ()
@@ -521,34 +521,83 @@ groups.
521 521 \subsubsection{Active commands}
522 522 % - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - -
523 523
524   -A simple here-script is used to call @hugs@. \NB @.script@ and @.out@
525   -are used as intermediate files.
526   -
527 524 ks, 23.10.2003: extended to work with @ghci@, too.
528 525 ks, 03.01.2004: fixed to work with @ghci-6.2@, hopefully without breaking
529 526 @hugs@ or old @ghci@ compatibility.
530 527
531   -> hugs :: FilePath -> String -> String -> IO String
532   -> hugs file opts expr = do writeFile ".script" (if ghcimode then ghciscript else hugsscript)
533   -> system ("chmod u+x .script")
534   -> system ("./.script > .out")
535   -> result <- readFile ".out"
536   -> return (extract result)
537   -> where ghcimode = "ghci" `isPrefixOf` opts
538   -> ghciscript = opts ++ " -ignore-dot-ghci " ++ file ++ " <<!\n"
539   -> ++ "putStrLn " ++ show magic ++ "\n"
540   -> ++ expr ++ "\n"
541   -> ++ "putStrLn " ++ show magic ++ "\n"
542   -> hugsscript = (if null opts then "hugs " else opts) ++ " -p'" ++ magic ++ "' " ++ file ++ " <<!\n" -- |file| instead of |nondir file|
543   -> ++ expr ++ "\n"
544   -
545   -To extract hugs' answer we use a simple technique which should work in
546   -most cases. The hugs prompt is set to the string |magic|; Hugs's
547   -response then lies between the first two occurences of |magic|.
  528 +New, 26.01.2006: we're now starting an external process @ghci@ or @hugs@
  529 +using the System.Process library. The process is then reused for subsequent
  530 +computations, which should dramatically improve compilation time for
  531 +documents that make extensive use of @\eval@ and @\perform@.
  532 +
  533 +> type Externals = FM.FiniteMap Char ProcessInfo
  534 +> type ProcessInfo = (Handle, Handle, Handle, ProcessHandle)
  535 +
  536 +The function |external| can be used to call the process. It is discouraged
  537 +to call any programs except @ghci@ or @hugs@, because we make a number of
  538 +assumptions about the program being called. Input is the expression to evaluate.
  539 +Output is the result in string form.
  540 +
  541 +> external :: String -> XIO Exc State String
  542 +> external expr = do st <- fetch
  543 +> let os = opts st
  544 +> f = file st
  545 +> ex = externals st
  546 +> ghcimode = "ghci" `isPrefix` os
  547 +> cmd
  548 +> | ghcimode = os ++ " -v0 -ignore-dot-ghci " ++ f
  549 +> | otherwise = (if null os then "hugs " else os ++ " ") ++ f
  550 +> script = "putStrLn " ++ show magic ++ "\n"
  551 +> ++ expr ++ "\n"
  552 +> ++ "putStrLn " ++ show magic ++ "\n"
  553 +> pi <- case FM.lookup f ex of
  554 +> Just pi -> return pi
  555 +> Nothing -> -- start new external process
  556 +> fromIO $ do
  557 +> when (verbose st) $
  558 +> hPutStrLn stderr $ "Starting external process: " ++ cmd
  559 +> runInteractiveCommand cmd
  560 +> store (st {externals = FM.add (f,pi) ex})
  561 +> let (pin,pout,_,_) = pi
  562 +> fromIO $ do
  563 +> hPutStr pin script
  564 +> hFlush pin
  565 +> extract' pout
  566 +
  567 +This function can be used to stop all external processes by sending the
  568 +@:q@ command to them.
  569 +
  570 +> stopexternals :: Formatter
  571 +> stopexternals = do st <- fetch
  572 +> let ex = externals st
  573 +> pis = map (ex FM.!) (FM.keys ex)
  574 +> when (not . null $ pis) $ fromIO $ do
  575 +> when (verbose st) $
  576 +> hPutStrLn stderr $ "Stopping external processes."
  577 +> mapM_ (\(pin,_,_,pid) -> do hPutStrLn pin ":q"
  578 +> hFlush pin
  579 +> waitForProcess pid) pis
  580 +
  581 +To extract the answer from @ghci@'s or @hugs@' output
  582 +we use a simple technique which should work in
  583 +most cases: we print the string |magic| before and after
  584 +the expression we are interested in. We assume that everything
  585 +that appears before the first occurrence of |magic| on the same
  586 +line is the prompt, and everything between the first |magic|
  587 +and the second |magic| plus prompt is the result we look for.
548 588
549 589 > magic :: String
550 590 > magic = "!@#$^&*"
551 591 >
  592 +> extract' :: Handle -> IO String
  593 +> extract' h = fmap (extract . unlines) (readMagic 2)
  594 +> where readMagic :: Int -> IO [String]
  595 +> readMagic 0 = return []
  596 +> readMagic n = do l <- hGetLine h
  597 +> let n' | (null . snd . breaks (isPrefix magic)) l = n
  598 +> | otherwise = n - 1
  599 +> fmap (l:) (readMagic n')
  600 +
552 601 > extract :: String -> String
553 602 > extract s = v
554 603 > where (t, u) = breaks (isPrefix magic) s
@@ -562,10 +611,6 @@ response then lies between the first two occurences of |magic|.
562 611 > (v, _) = breaks (isPrefix (pre ++ magic)) u'
563 612 > -- we look for the next occurrence of prefix plus magic
564 613
565   -\NB It is important that hugs does \emph{not} use the @readline@ library.
566   -Added |tail (dropWhile (/='\n') u)| to cope with this! [ks, 15.05.2003:
567   -This situation is unclear to me. It should be clarified.]
568   -
569 614 % - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - -
570 615 \subsubsection{Reading files}
571 616 % - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - -
2  Testsuite/Makefile
@@ -18,7 +18,7 @@ LHS2TEX = ../lhs2TeX
18 18
19 19 %.tex : %.lhs
20 20 # lhs2TeX -verb -i../lhs2TeX.fmt -l'meta = True' $< > $@
21   - $(LHS2TEX) -v --math --align=33 -smeta -i../lhs2TeX.fmt $< > $@
  21 + $(LHS2TEX) -v --math --align=33 -smeta $< > $@
22 22
23 23 %.ps : %.dvi
24 24 $(DVIPS) -D600 -o $@ $<
2  Testsuite/Test.lhs
@@ -9,7 +9,7 @@
9 9
10 10 %-------------------------------= --------------------------------------------
11 11
12   -%include ../lhs2TeX.sty
  12 +%include ../lhs2TeX.fmt
13 13
14 14 %-------------------------------= --------------------------------------------
15 15

0 comments on commit 9de89a0

Please sign in to comment.
Something went wrong with that request. Please try again.