%-------------------------------=  --------------------------------------------
\subsection{Main program}
%-------------------------------=  --------------------------------------------

%if codeOnly || showModuleHeader

> module Main ( main )
> where
>
> import Data.Char ( isSpace )
> import Data.List ( isPrefixOf )
> import System.IO
> import System.Directory ( copyFile )
> import System.Console.GetOpt
> import Text.Regex ( matchRegex, mkRegexWithOpts )
> import System.Environment
> import System.Exit
> import System.Process
> import Control.Arrow
> import Control.Monad
> import Control.Monad.Except
> import Control.Monad.State ( MonadState(..), modify )
> import Prelude hiding ( getContents, pi )
>
> import qualified Version as V
> import TeXCommands
> import TeXParser
> import qualified Verbatim
> import qualified Typewriter
> import qualified Math
> import qualified MathPoly as Poly
> import qualified NewCode
> import Directives
> import Document
> import State
> import StateT
> import qualified FiniteMap as FM
> import Auxiliaries
> import Value hiding ( str )
> import License
>
> import FileNameUtils
> --import Directory

%endif

% - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - -
\subsubsection{Main loop}
% - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - -

> main                          :: IO ()
> main                          =  getArgs >>= main'

> main'                         :: [String] -> IO ()
> main' args                    =  case getOpt Permute (options ++ hiddenOptions) args of
>   (o,n,[])                    -> do hSetEncoding stdin  utf8
>                                     hSetEncoding stdout utf8
>                                     hSetEncoding stderr utf8
>                                     (flags,initdirs,styles)
>                                        <- foldM (\(s,d,x) (sf,df,ns) -> do s' <- sf s
>                                                                            return (s',df d,ns ++ x))
>                                                 (state0,[],[]) o
>                                     case reverse styles of
>                                       []  -> lhs2TeX Poly flags (reverse initdirs) n
>                                           -- ks, 22.11.2005, changed default style to |Poly|
>                                       [Help]        -> quitSuccess (usageInfo uheader options)
>                                       [SearchPath]  -> quitSuccess (init . unlines $ V.searchPath)
>                                       [TeXSearchPath] ->
>                                         quitSuccess (init . unlines $
>                                           ["\\begin{code}"] ++ V.searchPath ++ ["\\end{code}"])
>                                       [Version]     -> quitSuccess programInfo
>                                       [Copying]     -> quitSuccess (programInfo ++ "\n\n" ++ copying)
>                                       [Warranty]    -> quitSuccess (programInfo ++ "\n\n" ++ warranty)
>                                       [Pre] | length n >= 3 -> preprocess flags (reverse initdirs) False n  -- used as preprocessor -pgmF -F
>                                       [Pre,Help] | length n >= 3 -> preprocess flags (reverse initdirs) True n  -- used as literate preprocessor -pgmL
>                                       [s]    -> lhs2TeX s flags (reverse initdirs) n
>                                       _      -> quitError (incompatibleStylesError styles)
>                                     when (output flags /= stdout) (hClose (output flags))
>   (_,_,errs)                  -> do hPutStrLn stderr $ concat errs
>                                     hPutStrLn stderr $ "Trying compatibility mode option handling ..."
>                                     cstyle args
>  where
>    quitSuccess s              =  do hPutStrLn stdout $ s
>                                     exitWith ExitSuccess
>    quitError s                =  do hPutStrLn stderr $ usageInfo (s ++ "\n" ++ uheader) options
>                                     exitFailure
>    incompatibleStylesError ss =  "only one style allowed from: "
>                                     ++ unwords (map (\s -> "--" ++ decode s) ss) ++ "\n"

> type Formatter                =  XIO Exc State ()

> initState                     :: Style -> FilePath -> [FilePath] -> State -> State
> initState sty filePath ep s   =  s { style = sty,
>                                      file = filePath,
>                                      ofile = filePath,
>                                      searchpath = ep,
>                                      toggles = FM.fromList toggles0
>                                    }
>     where toggles0            =  --[(decode CodeOnly, Bool (sty == CodeOnly))]
>                                  [("style", Int (fromEnum sty))]
>                               ++ [("version", Int V.numversion)]
>                               ++ [("pre", Int V.pre)]
>                               ++ [("lang", Int (fromEnum (lang s)))]
>                               ++ [ (decode s', Int (fromEnum s')) | s' <- [(minBound :: Style) .. maxBound] ]
>                               ++ [ (decode s', Int (fromEnum s')) | s' <- [(minBound :: Lang) .. maxBound] ]
>                               -- |++ [ (s, Bool False) || s <- ["underlineKeywords", "spacePreserving", "meta", "array", "latex209", "times", "euler" ] ]|

> preprocess                    :: State -> [Class] -> Bool -> [String] -> IO ()
> preprocess flags dirs lit (f1:f2:f3:_)
>                               =  if (f1 == f2) && not lit
>                                  then copyFile f2 f3
>                                  else do c <- readFile f1
>                                          case matchRegex (mkRegexWithOpts "^%include" True False) c of
>                                            Nothing -> if lit then
>                                                          do h <- openOutputFile f3
>                                                             lhs2TeX NewCode (flags { output = h }) (Directive Include "lhs2TeX.fmt" : dirs) [f1]
>                                                             hClose h
>                                                       else copyFile f2 f3
>                                            Just _  -> -- supposed to be an lhs2TeX file
>                                                       do h <- openOutputFile f3
>                                                          lhs2TeX NewCode (flags { output = h }) dirs [f1]
>                                                          hClose h
> preprocess _ _ _ _            =  error "preprocess: too few arguments"

> lhs2TeX                       :: Style -> State -> [Class] -> [String] -> IO ()
> lhs2TeX s flags dirs files'   =  do (str, file') <- input files'
>                                     expandedpath <- expandPath (searchpath flags)
>                                     toIO (do put (initState s file' expandedpath flags)
>                                              formats (map (No 0) dirs) `catchError` abort
>                                              formatStr (addEndEOF str)
>                                              stopexternals)
>   where   addEndEOF           =  (++"%EOF\n") . unlines . lines

> input                         :: [String] -> IO (String, FilePath)
> input []                      =  do s <- getContents; return (s, "<stdin>")
> input ["-"]                   =  do s <- getContents; return (s, "<stdin>")
> input (filePath : _)          =  chaseFile [] filePath

Converting command line options into directives.

> uheader                       :: String
> uheader                       =  "lhs2TeX [ options ] files\n\nAvailable options:\n"

ks, 20.07.2003: The short option for @--align@ has been changed into @-A@. Otherwise
@-align@ would not trigger compatibility mode, but be interpreted as a valid option
usage.

ks, 24.03.2004: The long option @--verbose@ has been removed for now,
because with some versions of GHC it triggers ambiguity errors with
@--verb@.

> options                       :: [OptDescr (State -> IO State,[Class] -> [Class],[Style])]
> options                       =
>   [ Option ['h','?'] ["help"](NoArg (return, id, [Help]))                                 "get this help"
>   , Option ['v'] [] {- ["verbose"] -}
>                              (NoArg (\s -> return $ s { verbose = True }, id, []))        "be verbose"
>   , Option ['V'] ["version"] (NoArg (return, id, [Version]))                              "show version"
>   , Option []    ["tt"]      (NoArg (return, id, [Typewriter]))                           "typewriter style (deprecated)"
>   , Option []    ["math"]    (NoArg (return, id, [Math]))                                 "math style (deprecated)"
>   , Option []    ["poly"]    (NoArg (return, id, [Poly]))                                 "poly style (default)"
>   , Option []    ["markdown"](NoArg (return, id, [Markdown]))                             "markdown style"
>   , Option []    ["code"]    (NoArg (return, id, [CodeOnly]))                             "code style (deprecated)"
>   , Option []    ["newcode"] (NoArg (return, id, [NewCode]))                              "new code style"
>   , Option []    ["verb"]    (NoArg (return, id, [Verb]))                                 "verbatim (deprecated)"
>   , Option []    ["haskell"] (NoArg (\s -> return $ s { lang = Haskell}, id, []))         "Haskell lexer (default)"
>   , Option []    ["agda"]    (NoArg (\s -> return $ s { lang = Agda}, id, []))            "Agda lexer"
>   , Option []    ["pre"]     (NoArg (return, id, [Pre]))                                  "act as ghc preprocessor"
>   , Option ['o'] ["output"]  (ReqArg (\f -> (\s -> do h <- openOutputFile f
>                                                       return $ s { output = h }, id, [])) "file") "specify output file"
>   , Option []    ["file-directives"]
>                              (NoArg (\s -> return $ s { fldir = True }, id, []))          "generate %file directives"
>   , Option []    ["no-pragmas"]
>                              (NoArg (\s -> return $ s { pragmas = False }, id, []))       "no LINE pragmas"
>   , Option ['A'] ["align"]   (ReqArg (\c -> (return, (Directive Align c:), [])) "col")    "align at <col>"
>   , Option ['i'] ["include"] (ReqArg (\f -> (return, (Directive Include f:), [])) "file") "include <file>"
>   , Option ['l'] ["let"]     (ReqArg (\s -> (return, (Directive Let s:), [])) "equation") "assume <equation>"
>   , Option ['s'] ["set"]     (ReqArg (\s -> (return, (Directive Let (s ++ " = True"):), [])) "flag")  "set <flag>"
>   , Option ['u'] ["unset"]   (ReqArg (\s -> (return, (Directive Let (s ++ " = False"):), [])) "flag") "unset <flag>"
>   , Option ['P'] ["path"]    (ReqArg (\p -> (\s -> return $ s { searchpath = modifySearchPath (searchpath s) p }, id , [])) "path")
>                                                                                       "modify search path"
>   , Option []    ["searchpath"]
>                              (NoArg (return, id, [SearchPath]))                           "show searchpath"
>   , Option []    ["copying"] (NoArg (return, id, [Copying]))                              "display license"
>   , Option []    ["warranty"](NoArg (return, id, [Warranty]))                             "info about warranty"
>   ]
>
> hiddenOptions                 :: [OptDescr (State -> IO State,[Class] -> [Class],[Style])]
> hiddenOptions =
>   [ Option []    ["texsearchpath"]
>                              (NoArg (return, id, [TeXSearchPath]))                        "show searchpath in code environment" ]
>
> formatStr                     :: String -> Formatter
> formatStr str                 =  formats (texparse 1 str) `catchError` abort

Compatibility mode option handling.

> cstyle                        :: [String] -> IO ()
> cstyle args@(('-':a) : x)     =  case encode a of
>   Just sty                    -> cstyle' sty x
>   Nothing                     -> cstyle' Typewriter args
> cstyle args                   =  cstyle' Typewriter args

> cstyle'                       :: Style -> [String] -> IO ()
> cstyle' s args                =  let (dirs,files') = coptions args
>                                  in  lhs2TeX s state0 dirs files'

> coptions                      :: [String] -> ([Class], [String])
> coptions                      =  foldr (<<|) ([], [])
>   where
>   "-align" <<| (ds, s : as)   =  (Directive Align s : ds, as)
>   "-i" <<| (ds, s : as)       =  (Directive Include s : ds, as)
>   "-l" <<| (ds, s : as)       =  (Directive Let s : ds, as)
>   ('-' : 'i' : s) <<| (ds, as)=  (Directive Include s : ds, as)
>   ('-' : 'l' : s) <<| (ds, as)=  (Directive Let s : ds, as)
>   s <<| (ds, as)              =  (ds, s : as)


We abort immediately if an error has occured.

> abort                         :: Exc -> Formatter
> abort (msg, context)          =  do st <- get
>                                     liftIO (hPutStrLn stderr (text st))
>                                     liftIO (exitWith (ExitFailure 1))
>     where text st             =  "*** Error in " ++ at (file st) (lineno st) ++ ": \n"
>                               ++ unlines [ "included from " ++ at f l | (f, l) <- files st ]
>                               ++ msg ++ "\n"
>                               ++ unlines (take 4 (lines context))
>           at f n              =  "file " ++ f ++ " line " ++ show n

% - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - -
\subsubsection{Formatting}
% - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - -

> formats                       :: [Numbered Class] -> Formatter
> formats []                    =  return ()
> formats (No n  (Directive d s) : ts)
>     | conditional d           =  do modify (\st -> st{lineno = n})
>                                     st <- get
>                                     directive (lang st)
>                                               d s (file st,n)
>                                               (conds st) (toggles st) ts
> formats (No n t : ts)         =  do modify (\st -> st{lineno = n})
>                                     format t
>                                     formats ts

> format                        :: Class -> Formatter
> -- |format (Many ('%' : '%' : _))     =  return ()|   -- @%%@-comments used to be removed
> format (Many s)               =  out (Text s)
> format (Inline s)             =  inline s
> format (Command Hs s)         =  inline s
> format (Command (Vrb b) s)    =  out (Verbatim.inline b s)
> format (Command Eval s)       =  do st <- get
>                                     unless (style st `elem` [CodeOnly,NewCode]) $
>                                       do result <- external (map unNL s)
>                                          inline result
> format (Command Perform s)    =  do st <- get
>                                     unless (style st `elem` [CodeOnly,NewCode]) $
>                                       do result <- external (map unNL s)
>                                          modify (\st'@State{file = f', lineno = l'} ->
>                                                    st'{file = "<perform>", files = (f', l') : files st'})
>                                          liftIO (when (verbose st) (hPutStr stderr $ "(" ++ "<perform>"))
>                                          formatStr (addEndNL result)
>                                          modify (\st'@State{files = (f, l) : fs} ->
>                                                    st'{file = f, lineno = l, files = fs})
>                                          liftIO (when (verbose st) (hPutStrLn stderr $ ")"))
>     where
>     addEndNL                  =  (++"\n") . unlines . lines

> format (Environment Haskell_ s)
>                               =  display s
> format (Environment Code s)   =  display s
> format (Environment Spec s)   =  do st <- get
>                                     unless (style st `elem` [CodeOnly,NewCode]) $
>                                       display s
> format (Environment Evaluate s)
>                               =  do st <- get
>                                     unless (style st `elem` [CodeOnly,NewCode]) $
>                                       do result <- external s
>                                          display result
> format (Environment Hide _s)  =  return ()
> format (Environment Ignore _s)=  return ()
> format (Environment (Verbatim b) s)
>                               =  out (Verbatim.display 120 b s)
> format (Directive Format s)   =  do st <- get
>                                     b@(_n,_e) <- fromEither (parseFormat (lang st) s)
>                                     put (st{fmts = FM.add b (fmts st)})
> format (Directive Subst s)    =  do st <- get
>                                     b <- fromEither (parseSubst (lang st) s)
>                                     put (st{subst = FM.add b (subst st)})
> format (Directive Include arg)=  do st <- get
>                                     let d  = path st
>                                     let sp = searchpath st
>                                     modify (\st'@State{file = f', lineno = l'} ->
>                                         st'{file = arg', files = (f', l') : files st', path = d ++ dir arg'})
>                                     -- |d <- liftIO getCurrentDirectory|
>                                     -- |liftIO (setCurrentDirectory (dir f))|
>                                     (str,f) <- liftIO (chaseFile sp (d ++ arg'))
>                                     modify (\st' -> st' { file = f })
>                                     liftIO (when (verbose st) (hPutStr stderr $ "(" ++ f))
>                                     formatStr (addEndNL str)
>                                     -- |liftIO (setCurrentDirectory d)|
>                                     modify (\st'@State{files = (f', l) : fs} ->
>                                         st'{file = f', lineno = l, files = fs, path = d})
>                                     liftIO (when (verbose st) (hPutStrLn stderr $ ")"))
>     where arg'                =  withoutSpaces arg
>           addEndNL            =  (++"\n") . unlines . lines

ks, 25.01.2003: I added the above function at the suggestion of NAD, but
I am not completely sure if this is the right thing to do. Maybe we should
strip blank lines from the end of a file as well, maybe we should do nothing
at all. Hard to say what people think is intuitive. Anyway, the reason why
I added it is this: if an %include directive is immediately followed
by another line and the included file does not end in a blank line, then
there will not be a single space between the last character of the included
file and the first character of the following line. It would be possible
to split a TeX control sequence over two different files that way. Seems
strange. So we add a newline, or even two if none has been there before,
to make sure that exactly one linebreak ends up in the output, but not
more, as a double newline is interpreted as a \par by TeX, and that might
also not be desired.

> format (Directive Begin _)    =  modify (\st -> st{stack = fmts st : stack st})
> format (Directive End _)      =  do st <- get
>                                     when (null (stack st)) $
>                                       do liftIO (hPutStrLn stderr $ "unbalanced %} in line "
>                                                                       ++ show (lineno st))
>                                          modify (\st' -> st'{stack = [fmts st']})
>                                     modify (\st'@State{stack = d:ds} -> st'{fmts = d, stack = ds})

ks, 11.09.03: added exception handling for unbalanced grouping

\Todo{|toggles| should be saved, as well.}

> format (Directive Let s)      =  do st <- get
>                                     t <- fromEither (define (lang st) (toggles st) s)
>                                     put st{toggles = FM.add t (toggles st)}
> format (Directive Align s)
>     | all isSpace s           =  modify (\st -> st{align = Nothing, stacks  = ([], [])})
>     | otherwise               =  modify (\st -> st{align = Just (read s), stacks  = ([], [])})

\NB @%align@ also resets the left identation stacks.

Also, the @poly@ directives @%separation@ and @%latency@ reset
the corresponding indentation stack |pstack|.

> format (Directive Separation s )
>                               =  modify (\st -> st{separation = read s, pstack = []})
> format (Directive Latency s)  =  modify (\st -> st{latency = read s, pstack = []})

> format (Directive File s)     =  modify (\st -> st{file = withoutSpaces s})
> format (Directive Options s)  =  modify (\st -> st{opts = trim' s})
>     where trim'               =  dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse

> format (Error exc)            =  throwError exc
> format _                      =  impossible "format"

Printing documents.
%{
%format d1
%format d2

> eject                         :: Doc -> Formatter
> eject Empty                   =  return ()
> eject (Text s)                =  do  st <- get
>                                      let (ls,enl) = checkNLs 0 s
>                                      when (fldir st && not (null s) && atnewline st && (ofile st /= file st || olineno st /= lineno st)) $
>                                        do  liftIO (hPutStr (output st) ("%file " ++ show (lineno st) ++ " " ++ show (file st) ++ "\n"))
>                                            put (st { ofile = file st, olineno = lineno st })
>
>                                      liftIO (hPutStr (output st) s)
>                                      modify (\st' -> st' { olineno = olineno st' + ls, atnewline = enl (atnewline st')})
>     where
>     checkNLs n ('\n':[])      =  (n+1,const True)
>     checkNLs n (_:[])         =  (n,const False)
>     checkNLs n []             =  (n,id)
>     checkNLs n ('\n':xs)      =  checkNLs (n+1) xs
>     checkNLs n (_:xs)         =  checkNLs n xs
> eject (d1 :^: d2)             =  eject d1 >> eject d2
> eject (Embedded s)            =  formatStr s
> eject (Sub s ds)              =  do st <- get; substitute (subst st)
>     where
>     substitute d              =  case FM.lookup s d of
>         Nothing               -> throwError (undef s, "")
>         Just sub              -> eject (sub ds)
>
> undef                         :: String -> String
> undef s                       =  "`" ++ s ++ "' is not defined;\n\
>                                  \perhaps you forgot to include \"polycode.fmt\" (or \"lhs2TeX.fmt\")?"

%}

% - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - -
\subsubsection{Style dependent formatting}
% - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - -

> out                           :: Doc -> Formatter
> out d                         =  do st <- get; eject (select (style st))
>     where select CodeOnly     =  Empty
>           select NewCode      =  Empty
>           select _            =  d

> inline, display               :: String -> Formatter
> inline s                      =  do st <- get
>                                     d <- fromEither (select (style st) st)
>                                     eject d
>   where select Verb _st       =  Right (Verbatim.inline False s)
>         select Typewriter st  =  Typewriter.inline (lang st) (fmts st) s
>         select Math st        =  Math.inline (lang st) (fmts st) (isTrue (toggles st) auto) s
>         select Poly st        =  Poly.inline (lang st) (fmts st) (isTrue (toggles st) auto) s
>         select Markdown st    =  NewCode.inline (lang st) (fmts st) s
>         select CodeOnly _st   =  return Empty
>         select NewCode _st    =  return Empty   -- generate PRAGMA or something?
>         select _ _            =  impossible "inline.select"

> display s                     =  do st <- get
>                                     (d, st') <- fromEither (select (style st) st)
>                                     put st'
>                                     eject d
>   where select Verb st        =  return (Verbatim.display 120 False s, st)
>         select Typewriter st  =  do d <- Typewriter.display (lang st) (fmts st) s; return (d, st)
>         select Math st        =  do (d, sts) <- Math.display (lang st) (fmts st) (isTrue (toggles st) auto) (stacks st) (align st) s
>                                     return (d, st{stacks = sts})
>         select Poly st        =  do (d, pstack') <- Poly.display (lang st) (lineno st + 1) (fmts st) (isTrue (toggles st) auto) (separation st) (latency st) (pstack st) s
>                                     return (d, st{pstack = pstack'})
>         select NewCode st     =  do d <- NewCode.display (lang st) (fmts st) s
>                                     let p = sub'pragma $ Text ("LINE " ++ show (lineno st + 1) ++ " " ++ show (takeFileName $ file st))
>                                     return ((if pragmas st then ((p <<>> sub'nl) <<>>) else id) d, st)
>         select Markdown st    =  do d <- NewCode.display (lang st) (fmts st) s
>                                     return (d, st)
>         select CodeOnly st    =  return (Text (trim s), st)
>         select _ _            =  impossible "display.select"

> auto                          :: String
> auto                          =  "autoSpacing"
> isTrue                        :: Toggles -> String -> Bool
> isTrue togs s                 =  bool (value togs s)

Delete leading and trailing blank line (only the first!).

> trim                          :: String -> String
> trim                          =  skip' >>> reverse >>> skip' >>> reverse
>     where
>     skip'                     :: String -> String
>     skip' ""                  =  ""
>     skip' s | all isSpace t   =  u
>            | otherwise        =  s
>            where (t, u)       =  breakAfter (== '\n') s

% - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - -
\subsubsection{Conditional directives}
% - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - -

A stack of Boolean values holds the conditions of
@%if@-directives.  Perhaps surpsingly, each @%if@ gives rise
to \emph{two} entries; if @%elif@ is not used the second entry is
always |True|, otherwise it holds the negation of all previous
conditions of the current @%if@-chain.

ks, 16.08.2004: At the end of the input, we might want to check for unbalanced if's or
groups.

> directive                     :: Lang -> Directive -> String
>                               -> (FilePath,LineNo) -> [CondInfo] -> Toggles
>                               -> [Numbered Class] -> Formatter
> directive lang' d0 s0 (f0,l0) stack' togs ts
>                               =  dir' d0 s0 stack'
>   where
>   dir' If s bs                =  do b <- fromEither (eval lang' togs s)
>                                     skipOrFormat ((f0, l0, bool b, True) : bs) ts
>   dir' Elif s ((f,l,b2,b1):bs)=  do b <- fromEither (eval lang' togs s)
>                                     skipOrFormat ((f, l, bool b, not b2 && b1) : bs) ts
>   dir' Else _ ((f,l,b2,b1):bs)=  skipOrFormat ((f, l, not b2 && b1, True) : bs) ts
>   dir' Endif _ ((_f,_l,_b2,_b1):bs)=  skipOrFormat bs ts
>   dir' EOF _ []               =  return ()  -- nothing left to do
>   dir' EOF s bs               =  throwError (init $ unlines (map unBalancedIf bs), s)
>   dir' d s _                  =  throwError ("spurious %" ++ decode d, s)

> skipOrFormat                  :: [CondInfo] -> [Numbered Class] -> Formatter
> skipOrFormat stack' ts        =  do  modify (\st -> st{conds = stack'})
>                                      if andS stack'  then formats ts
>                                                      else skip ts

> andS                          :: [CondInfo] -> Bool
> andS                          =  all (\(_,_,x,y) -> x && y)

> unBalancedIf                  :: CondInfo -> String
> unBalancedIf (f,l,_,_)        =  "%if at " ++ f ++ " line " ++ show l ++ " not closed"

> skip                          :: [Numbered Class] -> Formatter
> skip []                       =  return ()
> skip ts@(No _n (Directive d _s) : _)
>     | conditional d           =  formats ts
> skip (_t : ts)                =  skip ts

% - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - -
\subsubsection{Active commands}
% - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - -

ks, 23.10.2003: extended to work with @ghci@, too.
ks, 03.01.2004: fixed to work with @ghci-6.2@, hopefully without breaking
@hugs@ or old @ghci@ compatibility.

New, 26.01.2006: we're now starting an external process @ghci@ or @hugs@
using the System.Process library. The process is then reused for subsequent
computations, which should dramatically improve compilation time for
documents that make extensive use of @\eval@ and @\perform@.

The function |external| can be used to call the process. It is discouraged
to call any programs except @ghci@ or @hugs@, because we make a number of
assumptions about the program being called. Input is the expression to evaluate.
Output is the result in string form.

> external                      :: String -> XIO Exc State String
> external expr                 =  do st <- get
>                                     let os  =  opts st
>                                         f   =  file st
>                                         ex  =  externals st
>                                         ghcimode       =  "ghci" `isPrefixOf` os
>                                         cmd
>                                           | ghcimode   =  os ++ " -v0 -ignore-dot-ghci " ++ f
>                                           | otherwise  =  (if null os then "hugs " else os ++ " ") ++ f
>                                         script         =  "putStrLn " ++ show magic ++ "\n"
>                                                             ++ expr ++ "\n"
>                                                             ++ "putStrLn " ++ show magic ++ "\n"
>                                     pi <- case FM.lookup f ex of
>                                             Just pi  ->  return pi
>                                             Nothing  ->  -- start new external process
>                                                          liftIO $ do
>                                                            when (verbose st) $
>                                                              hPutStrLn stderr $ "Starting external process: " ++ cmd
>                                                            runInteractiveCommand cmd
>                                     put (st {externals = FM.add (f,pi) ex})
>                                     let (pin,pout,_,_) = pi
>                                     liftIO $ do
>                                       -- hPutStrLn stderr ("sending: " ++ script)
>                                       hPutStr pin script
>                                       hFlush pin
>                                       extract' pout

This function can be used to stop all external processes by sending the
@:q@ command to them.

> stopexternals                 :: Formatter
> stopexternals                 =  do st <- get
>                                     let ex   =  externals st
>                                         pis  =  map (ex FM.!) (FM.keys ex)
>                                     when (not . null $ pis) $ liftIO $ do
>                                       when (verbose st) $
>                                         hPutStrLn stderr $ "Stopping external processes."
>                                       mapM_ (\(pin,_,_,pid) -> do  hPutStrLn pin ":q"
>                                                                    hFlush pin
>                                                                    waitForProcess pid) pis

To extract the answer from @ghci@'s or @hugs@' output
we use a simple technique which should work in
most cases: we print the string |magic| before and after
the expression we are interested in. We assume that everything
that appears before the first occurrence of |magic| on the same
line is the prompt, and everything between the first |magic|
and the second |magic| plus prompt is the result we look for.

> magic                         :: String
> magic                         =  "!@#$^&*"
>
> extract'                      :: Handle -> IO String
> extract' h                    =  fmap (extract . unlines) (readMagic 2)
>     where readMagic           :: Int -> IO [String]
>           readMagic 0         =  return []
>           readMagic n         =  do  l <- hGetLine h
>                                      -- hPutStrLn stderr ("received: " ++ l)
>                                      let n'  |  (null . snd . breaks (isPrefixOf magic)) l  =  n
>                                              |  otherwise                                   =  n - 1
>                                      fmap (l:) (readMagic n')

> extract                       :: String -> String
> extract s                     =  v
>     where (t, u)              =  breaks (isPrefixOf magic) s
>           -- t contains everything up to magic, u starts with magic
>           -- |u'                      =  tail (dropWhile (/='\n') u)|
>           pre                 =  reverse . takeWhile (/='\n') . reverse $ t
>           prelength           =  if null pre then 0 else length pre + 1
>           -- pre contains the prefix of magic on the same line
>           u'                  =  drop (length magic + prelength) u
>           -- we drop the magic string, plus the newline, plus the prefix
>           (v, _)              =  breaks (isPrefixOf (pre ++ magic)) u'
>           -- we look for the next occurrence of prefix plus magic

% - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - -
\subsubsection{Reading files}
% - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - -

> dir                           :: FilePath -> FilePath
> dir filePath
>     | null d                  =  ""
>     | otherwise               =  reverse d
>     where d                   =  dropWhile (/= '/') (reverse filePath)

