lhs2tex 1.20 → 1.21
raw patch · 32 files changed
+537/−462 lines, 32 filesdep ~mtlsetup-changed
Dependency ranges changed: mtl
Files
- CHANGELOG +0/−8
- CHANGELOG.md +8/−0
- INSTALL +8/−7
- Makefile +2/−2
- Setup.hs +1/−1
- configure +12/−12
- doc/Guide2.lhs +1/−1
- doc/Guide2.pdf binary
- doc/Implicit.lhs +1/−1
- doc/RawSearchPath.lhs +7/−6
- lhs2TeX.fmt.lit +5/−1
- lhs2TeX.sty.lit +1/−1
- lhs2tex.cabal +5/−3
- src/Auxiliaries.lhs +7/−25
- src/Directives.lhs +53/−33
- src/Document.lhs +42/−6
- src/FileNameUtils.lhs +6/−3
- src/FiniteMap.lhs +10/−10
- src/HsLexer.lhs +30/−26
- src/Main.lhs +79/−79
- src/Math.lhs +46/−40
- src/MathCommon.lhs +16/−16
- src/MathPoly.lhs +77/−79
- src/NewCode.lhs +24/−9
- src/Parser.lhs +6/−9
- src/StateT.lhs +8/−8
- src/TeXCommands.lhs +2/−3
- src/TeXParser.lhs +43/−42
- src/Typewriter.lhs +7/−9
- src/Value.lhs +21/−16
- src/Verbatim.lhs +6/−6
- src/Version.lhs.in +3/−0
− CHANGELOG
@@ -1,8 +0,0 @@-Changes (w.r.t. lhs2TeX 1.16)--------------------------------* Cabal-1.10 support--* Fix for file permissions problem of installed files--* Several improvements to the documentation
+ CHANGELOG.md view
@@ -0,0 +1,8 @@+* lhs2tex-1.21++- Some code refactoring.+- Experimental markdown mode.+- Improved output when using deprecated modes (#59).+- Compatibility with ghc-8.4 (#69).+- Fix in the formatting directives parser (#64).+
INSTALL view
@@ -32,7 +32,7 @@ Unpack the archive. Assume that it has been unpacked into directory "/somewhere". Then say -cd /somewhere/lhs2TeX-1.20+cd /somewhere/lhs2TeX-1.21 ./configure make make install@@ -48,17 +48,18 @@ lhs2TeX binary. The default search path is as follows: .-{HOME}/lhs2tex-1.20//+{HOME}/lhs2tex-1.21// {HOME}/lhs2tex// {HOME}/lhs2TeX//-{HOME}/.lhs2tex-1.20//+{HOME}/.lhs2tex-1.21// {HOME}/.lhs2tex// {HOME}/.lhs2TeX// {LHS2TEX}//-/usr/local/share/lhs2tex-1.20//-/usr/local/lib/lhs2tex-1.20//-/usr/share/lhs2tex-1.20//-/usr/lib/lhs2tex-1.20//+/usr/local/share/lhs2tex-1.21//+/usr/local/share/lhs2tex-1.21//+/usr/local/lib/lhs2tex-1.21//+/usr/share/lhs2tex-1.21//+/usr/lib/lhs2tex-1.21// /usr/local/share/lhs2tex// /usr/local/lib/lhs2tex// /usr/share/lhs2tex//
Makefile view
@@ -175,7 +175,7 @@ $(INSTALL) -m 644 Makefile common.mk config.mk.in $(DISTDIR) $(INSTALL) -m 644 lhs2TeX.1.in $(DISTDIR) $(INSTALL) -m 755 configure mkinstalldirs install-sh $(DISTDIR)- $(INSTALL) -m 644 TODO AUTHORS LICENSE CHANGELOG $(DISTDIR)+ $(INSTALL) -m 644 TODO AUTHORS LICENSE CHANGELOG.md $(DISTDIR) cat INSTALL | sed -e "s/@ProgramVersion@/$(PACKAGE_VERSION)/" \ > $(DISTDIR)/INSTALL chmod 644 $(DISTDIR)/INSTALL@@ -205,7 +205,7 @@ $(INSTALL) -m 644 Makefile common.mk config.mk.in $(DISTDIR) $(INSTALL) -m 644 lhs2TeX.1.in $(DISTDIR) $(INSTALL) -m 755 configure mkinstalldirs install-sh $(DISTDIR)- $(INSTALL) -m 644 TODO AUTHORS LICENSE CHANGELOG $(DISTDIR)+ $(INSTALL) -m 644 TODO AUTHORS LICENSE CHANGELOG.md $(DISTDIR) cat INSTALL | sed -e "s/@ProgramVersion@/$(PACKAGE_VERSION)/" \ > $(DISTDIR)/INSTALL chmod 644 $(DISTDIR)/INSTALL
Setup.hs view
@@ -34,7 +34,7 @@ minPolytableVersion = [0,8,2] shortversion = show (numversion `div` 100) ++ "." ++ show (numversion `mod` 100) version = shortversion ++ if ispre then "pre" ++ show pre else ""-numversion = 120+numversion = 121 ispre = False pre = 1
configure view
@@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles.-# Generated by GNU Autoconf 2.69 for lhs2tex 1.20.+# Generated by GNU Autoconf 2.69 for lhs2tex 1.21. # # # Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc.@@ -576,8 +576,8 @@ # Identity of this package. PACKAGE_NAME='lhs2tex' PACKAGE_TARNAME='lhs2tex'-PACKAGE_VERSION='1.20'-PACKAGE_STRING='lhs2tex 1.20'+PACKAGE_VERSION='1.21'+PACKAGE_STRING='lhs2tex 1.21' PACKAGE_BUGREPORT='' PACKAGE_URL='' @@ -1203,7 +1203,7 @@ # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF-\`configure' configures lhs2tex 1.20 to adapt to many kinds of systems.+\`configure' configures lhs2tex 1.21 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1264,7 +1264,7 @@ if test -n "$ac_init_help"; then case $ac_init_help in- short | recursive ) echo "Configuration of lhs2tex 1.20:";;+ short | recursive ) echo "Configuration of lhs2tex 1.21:";; esac cat <<\_ACEOF @@ -1342,7 +1342,7 @@ test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF-lhs2tex configure 1.20+lhs2tex configure 1.21 generated by GNU Autoconf 2.69 Copyright (C) 2012 Free Software Foundation, Inc.@@ -1359,7 +1359,7 @@ This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by lhs2tex $as_me 1.20, which was+It was created by lhs2tex $as_me 1.21, which was generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@@@ -1708,9 +1708,9 @@ -VERSION="1.20"-SHORTVERSION="1.20"-NUMVERSION=120+VERSION="1.21"+SHORTVERSION="1.21"+NUMVERSION=121 PRE=1 @@ -3347,7 +3347,7 @@ # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log="-This file was extended by lhs2tex $as_me 1.20, which was+This file was extended by lhs2tex $as_me 1.21, which was generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES@@ -3400,7 +3400,7 @@ cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\-lhs2tex config.status 1.20+lhs2tex config.status 1.21 configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\"
doc/Guide2.lhs view
@@ -954,7 +954,7 @@ \end{colorsurround} % In the first line there are no parentheses to drop. In the second-line, the parentheses around the arguments @a@ and @b@ are dropped, as+line, the parentheses around the arguments @a@ and @c@ are dropped, as are the parentheses around the function @ptest@. In the third line, the source has double parentheses around each argument as well as the function. One set of parentheses are dropped in each case, except for
doc/Guide2.pdf view
binary file changed (347178 → 347055 bytes)
doc/Implicit.lhs view
@@ -7,4 +7,4 @@ %format omega' |[omega, omega13, omega', omega13']|\par %format omega13'-|[omega, omega13, omega13']|+|[omega, omega13, omega', omega13']|
doc/RawSearchPath.lhs view
@@ -1,16 +1,17 @@ \begin{code} .-{HOME}/lhs2tex-1.20//+{HOME}/lhs2tex-1.21// {HOME}/lhs2tex// {HOME}/lhs2TeX//-{HOME}/.lhs2tex-1.20//+{HOME}/.lhs2tex-1.21// {HOME}/.lhs2tex// {HOME}/.lhs2TeX// {LHS2TEX}//-/usr/local/share/lhs2tex-1.20//-/usr/local/lib/lhs2tex-1.20//-/usr/share/lhs2tex-1.20//-/usr/lib/lhs2tex-1.20//+/usr/local/share/lhs2tex-1.21//+/usr/local/share/lhs2tex-1.21//+/usr/local/lib/lhs2tex-1.21//+/usr/share/lhs2tex-1.21//+/usr/lib/lhs2tex-1.21// /usr/local/share/lhs2tex// /usr/local/lib/lhs2tex// /usr/share/lhs2tex//
lhs2TeX.fmt.lit view
@@ -207,7 +207,7 @@ %-------------------------------= -------------------------------------------- \begin{code}-%elif style == newcode+%elif (style == newcode) || (style == markdown) %subst comment a = "-- " a %subst nested a = "{- " a " -}" %subst code a = a "'n"@@ -227,6 +227,10 @@ %subst backquoted a = "`" a "`" %subst char a = "''" a "''" %subst string a = "'d" a "'d"+%if style == markdown+%subst inline a = "`" a "`"+%subst code a = "```'n" a "'n```'n"+%endif \end{code} %-------------------------------= --------------------------------------------
lhs2TeX.sty.lit view
@@ -10,7 +10,7 @@ %let lhs2tex_lhs2tex_sty_read = True %include lhs2TeX.fmt %-%if style /= newcode+%if (style /= newcode) && (style /= markdown) % \makeatletter \@@ifundefined{lhs2tex.lhs2tex.sty.read}%
lhs2tex.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: lhs2tex-version: 1.20+version: 1.21 license: GPL license-file: LICENSE author: Ralf Hinze <ralf.hinze@comlab.ox.ac.uk>, Andres Loeh <lhs2tex@andres-loeh.de>@@ -26,10 +26,11 @@ build-type: Custom tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.1 extra-source-files: AUTHORS- CHANGELOG+ CHANGELOG.md INSTALL TODO doc/*.lhs+ doc/*.lhs.in doc/*.fmt doc/Guide2.lhs doc/Guide2.pdf@@ -73,13 +74,14 @@ main-is: Main.lhs hs-source-dirs: src default-language: Haskell98+ ghc-options: -Wall other-extensions: ScopedTypeVariables NPlusKPatterns GeneralizedNewtypeDeriving TypeSynonymInstances build-depends: base >= 4.2 && < 5, regex-compat,- mtl,+ mtl >= 2.2.1, filepath, directory, process
src/Auxiliaries.lhs view
@@ -4,16 +4,12 @@ %if codeOnly || showModuleHeader -> {-# LANGUAGE TypeSynonymInstances #-}-> {-# LANGUAGE FlexibleInstances #-} > module Auxiliaries ( module Auxiliaries ) > where > > import Data.Char ( isSpace ) > import Control.Arrow ( (>>>), Kleisli(..) ) > import qualified Control.Arrow as A-> import Control.Monad ( MonadPlus(..) )-> import Control.Monad.Error %endif @@ -45,7 +41,7 @@ > merge :: (Ord a) => [a] -> [a] -> [a] > merge [] bs = bs-> merge as@(a : _) [] = as+> merge as@(_a : _) [] = as > merge as@(a : as') bs@(b : bs') > | a <= b = a : merge as' bs > | otherwise = b : merge as bs'@@ -58,20 +54,20 @@ %} > breakAfter :: (a -> Bool) -> [a] -> ([a], [a])-> breakAfter p [] = ([], [])-> breakAfter p (a : as)+> breakAfter _p [] = ([], [])+> breakAfter p (a : as) > | p a = ([a], as) > | otherwise = a <| breakAfter p as > breaks :: ([a] -> Bool) -> [a] -> ([a], [a])-> breaks p [] = ([], [])-> breaks p as@(a : as')+> breaks _p [] = ([], [])+> breaks p as@(a : as') > | p as = ([], as) > | otherwise = a <| breaks p as' > -- isPrefix :: (Eq a) => [a] -> [a] -> Bool > -- p `isPrefix` as = p == take (length p) as- + > withoutSpaces :: String -> String > withoutSpaces s = filter (not . isSpace) s @@ -79,7 +75,7 @@ > group n = repSplit (repeat n) >>> takeWhile (not . null) > repSplit :: [Int] -> [a] -> [[a]]-> repSplit [] xs = []+> repSplit [] _xs = [] > repSplit (n : ns) xs = ys : repSplit ns zs > where (ys, zs) = splitAt n xs @@ -107,10 +103,6 @@ > type Message = String > type Exc = (Message, String) -> instance Error Exc where-> noMsg = ("unknown error", "")-> strMsg s = (s, "")- Reverse Composition. > (<|) :: a -> ([a], b) -> ([a], b)@@ -120,13 +112,3 @@ > impossible name = error ("The `impossible' happened in \"" > ++ name ++ "\"") -% - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - --\subsubsection{Obsolete code}-% - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - ---> command :: String -> String -> String-> command name arg = "\\" ++ name ++ "{" ++ arg ++ "}"->-> environment :: String -> String -> String-> environment name m = "\\begin{" ++ name ++ "}" ++ m-> ++ "\\end{" ++ name ++ "}"
src/Directives.lhs view
@@ -7,13 +7,11 @@ > module Directives ( Formats, parseFormat, Equation, Substs, Subst, parseSubst, Toggles, eval, define, value, nrargs ) > where >-> import Control.Applicative ( many, optional )-> import Control.Monad-> import Data.Char ( isSpace, isAlpha, isDigit )+> import Control.Applicative+> import Data.Char ( isDigit ) > import Data.List > import Parser > import TeXCommands-> import TeXParser > import HsLexer > import FiniteMap ( FiniteMap, (!) ) > import qualified FiniteMap as FM@@ -51,17 +49,20 @@ Format directives. \NB @%format ( = "(\;"@ is legal. > equation :: Lang -> Parser Token (String, Equation)-> equation lang = do (opt, (f, opts, args)) <- optParen lhs-> _ <- varsym lang "="-> r <- many item-> return (f, (opt, opts, args, r))-> `mplus` do f <- item-> _ <- varsym lang "="-> r <- many item-> return (string f, (False, [], [], r))+> equation lang = do (opt, (f, opts, args)) <- optParen lhs+> _ <- varsym lang "="+> r <- many item+> eof+> return (f, (opt, opts, args, r))+> <|> do f <- item+> _ <- varsym lang "="+> r <- many item+> eof+> return (string f, (False, [], [], r)) > -- no RHS, try implicit formatting rules-> `mplus` do f <- satisfy isVarid `mplus` satisfy isConid-> return (string f, (False, [], [], tex f))+> <|> do f <- satisfy isVarid <|> satisfy isConid+> eof+> return (string f, (False, [], [], tex f)) \Todo{@%format `div1`@ funktioniert nicht.} @@ -73,15 +74,16 @@ > tex (Conid s) = subscript Conid s > tex (Qual [] s) = tex s > tex (Qual (m:ms) s) = Conid m : tex (Qual ms s)-> -- ks, 03.09.2003: was "tex (Qual m s) = Conid m : tex s"; +> -- ks, 03.09.2003: was "tex (Qual m s) = Conid m : tex s"; > -- seems strange though ...-> subscript f s +> tex _ = impossible "equation.tex"+> subscript f s > | null t && not (null w) && (null v || head w == '_') > = underscore f s > | otherwise = [f (reverse w) > , TeX False > (Text ((if not (null v)-> then "_{" ++ reverse v ++ "}" +> then "_{" ++ reverse v ++ "}" > else "" > ) ++ reverse t)) > ]@@ -97,7 +99,7 @@ > (if end then [Varid "_"] else []) ks, 02.02.2004: I have added implicit formatting via |underscore|.-The above condition should guarantee that it is (almost) only used in +The above condition should guarantee that it is (almost) only used in cases where previously implicit formatting did not do anything useful. The function |underscore| typesets an identifier such as |a_b_c| as $a_{b_{c}}$. TODO: Instead of hard-coded subscripting a@@ -114,26 +116,29 @@ > where (t, u) = break (== '_') s > tok_u = tokenize lang (tail u) > proc_u = case tok_u of-> Left _ -> [f (tail u)] -- should not happen-> Right t -> t+> Left _ -> [f (tail u)] -- should not happen+> Right t' -> t' > lhs :: Parser Token (String, [Bool], [String])-> lhs = do f <- varid `mplus` conid+> lhs = do f <- varid <|> conid > as <- many (optParen varid) > let (opts, args) = unzip as > return (f, opts, args) > optParen :: Parser Token a -> Parser Token (Bool, a)-> optParen p = do _ <- open'; a <- p; _ <- close'; return (True, a)-> `mplus` do a <- p ; return (False, a)+> optParen p = do _ <- open'; a <- p; _ <- close'; return (True, a)+> <|> do a <- p ; return (False, a) >+> item :: Parser Token Token > item = satisfy (const True) +> convert :: String -> String > convert [] = [] > convert ('"' : '"' : s) = '"' : convert s > convert ('"' : s) = '{' : '-' : '"' : convert' s > convert (c : s) = c : convert s >+> convert' :: String -> String > convert' [] = [] > convert' ('"' : '"' : s) = '"' : convert' s > convert' ('"' : s) = '"' : '-' : '}' : convert s@@ -153,13 +158,14 @@ > substitution lang = do s <- varid > args <- many varid > _ <- varsym lang "="-> rhs <- many (satisfy isVarid `mplus` satisfy isTeX)+> rhs <- many (satisfy isVarid <|> satisfy isTeX) > return (s, subst args rhs) > where > subst :: [String] -> [Token] -> Subst > subst args rhs ds = catenate (map sub rhs) > where sub (TeX _ d) = d > sub (Varid x) = FM.fromList (zip args ds) ! x+> sub _ = impossible "substitution.subst.sub" > -- TODO: The above lookup can fail badly if unknown variables are used on the rhs of a subst. \Todo{unbound variables behandeln.}@@ -168,11 +174,17 @@ lexer, "=" is both a varid and a varsym. This shouldn't matter for Haskell, because "=" will never occur in a Varid constructor. +> varid :: Parser Token String > varid = do x <- satisfy (\ x -> isVarid x && x /= Varid "="); return (string x)++> conid :: Parser Token String > conid = do x <- satisfy isConid; return (string x)++> varsym :: Lang -> String -> Parser Token Token > varsym Agda s = satisfy (\ x -> x == Varsym s || x == Varid s) -- Agda has no symbol/id distinction > varsym Haskell s = satisfy (== (Varsym s)) >+> isTeX :: Token -> Bool > isTeX (TeX _ _) = True > isTeX _ = False @@ -192,17 +204,18 @@ > where > expr = do e1 <- appl > e2 <- optional (do op <- varsym' lang; e <- expr; return (op, e))-> return (maybe e1 (\(op, e2) -> sys2 op e1 e2) e2)+> return (maybe e1 (\(op, e2') -> sys2 op e1 e2') e2) > appl = do f <- optional not' > e <- atom > return (maybe e (\_ -> onBool1 not e) f)-> atom = do Varid x <- satisfy isVarid; return (value togs x)-> `mplus` do _ <- true'; return (Bool True)-> `mplus` do _ <- false'; return (Bool False)-> `mplus` do s <- satisfy isString; return (Str (read (string s)))-> `mplus` do s <- satisfy isNumeral; return (Int (read (string s)))-> `mplus` do _ <- open'; e <- expr; _ <- close'; return e+> atom = do Varid x <- satisfy isVarid; return (value togs x)+> <|> do _ <- true'; return (Bool True)+> <|> do _ <- false'; return (Bool False)+> <|> do s <- satisfy isString; return (Str (read (string s)))+> <|> do s <- satisfy isNumeral; return (Int (read (string s)))+> <|> do _ <- open'; e <- expr; _ <- close'; return e >+> sys2 :: String -> Binary Value > sys2 "&&" = onBool2 (&&) > sys2 "||" = onBool2 (||) > sys2 "==" = onMatching (==) (==) (==)@@ -241,23 +254,30 @@ > open' = satisfy (== (Special '(')) > close' = satisfy (== (Special ')')) +> varsym' :: Lang -> Parser Token String > varsym' lang = do x <- satisfy (isVarsym lang); return (string x)++> isVarsym :: Lang -> Token -> Bool > isVarsym _ (Varsym _) = True > isVarsym Agda (Varid _) = True -- for Agda > isVarsym _ _ = False++> isString :: Token -> Bool > isString (String _) = True > isString _ = False++> isNumeral :: Token -> Bool > isNumeral (Numeral _) = True > isNumeral _ = False Hilfsfunktionen. > parse :: Lang -> Parser Token a -> String -> Either Exc a-> parse lang p str = do ts <- tokenize lang str+> parse lang p str' = do ts <- tokenize lang str' > let ts' = map (\t -> case t of TeX _ x -> TeX False x; _ -> t) . > filter (\t -> catCode t /= White || isTeX t) $ ts > maybe (Left msg) Right (run p ts')-> where msg = ("syntax error in directive", str)+> where msg = ("syntax error in directive", str') Hack: |isTeX t| f"ur |parseSubst|.
src/Document.lhs view
@@ -6,10 +6,11 @@ > module Document ( module Document ) > where+> %endif -> infixr 5 {-"\enskip"-} <> -- same fixity as `|++|'+> infixr 5 {-"\enskip"-} <<>> -- same fixity as `|++|' The pretty printer generate documents of type |Doc|. @@ -23,54 +24,89 @@ |Embedded| is used for embedded pseudo \TeX\ text (eg in comments); |Sub s ds| is used for replacements (eg |Sub "inline" [..]|). -> (<>) :: Doc -> Doc -> Doc-> Empty <> d = d-> d <> Empty = d-> d1 <> d2 = d1 :^: d2+> (<<>>) :: Doc -> Doc -> Doc+> Empty <<>> d = d+> d <<>> Empty = d+> d1 <<>> d2 = d1 :^: d2 > > catenate :: [Doc] -> Doc-> catenate = foldr (<>) Empty+> catenate = foldr (<<>>) Empty Substitution strings. +> sub'thin :: Doc > sub'thin = Sub "thinspace" []+> sub'space :: Doc > sub'space = Sub "space" []+> sub'nl :: Doc > sub'nl = Sub "newline" []+> sub'verbnl :: Doc > sub'verbnl = Sub "verbnl" []+> sub'blankline :: Doc > sub'blankline = Sub "blankline" []+> sub'dummy :: Doc > sub'dummy = Sub "dummy" [] >+> sub'spaces :: Doc -> Doc > sub'spaces a = Sub "spaces" [a]+> sub'special :: Doc -> Doc > sub'special a = Sub "special" [a]+> sub'verb :: Doc -> Doc > sub'verb a = Sub "verb" [a]+> sub'verbatim :: Doc -> Doc > sub'verbatim a = Sub "verbatim" [a]+> sub'inline :: Doc -> Doc > sub'inline a = Sub "inline" [a]+> sub'code :: Doc -> Doc > sub'code a = Sub "code" [a]+> sub'conid :: Doc -> Doc > sub'conid a = Sub "conid" [a]+> sub'varid :: Doc -> Doc > sub'varid a = Sub "varid" [a]+> sub'consym :: Doc -> Doc > sub'consym a = Sub "consym" [a]+> sub'varsym :: Doc -> Doc > sub'varsym a = Sub "varsym" [a]+> sub'backquoted :: Doc -> Doc > sub'backquoted a = Sub "backquoted" [a]+> sub'numeral :: Doc -> Doc > sub'numeral a = Sub "numeral" [a]+> sub'char :: Doc -> Doc > sub'char a = Sub "char" [a]+> sub'string :: Doc -> Doc > sub'string a = Sub "string" [a]+> sub'comment :: Doc -> Doc > sub'comment a = Sub "comment" [a]+> sub'nested :: Doc -> Doc > sub'nested a = Sub "nested" [a]+> sub'pragma :: Doc -> Doc > sub'pragma a = Sub "pragma" [a]+> sub'tex :: Doc -> Doc > sub'tex a = Sub "tex" [a]+> sub'keyword :: Doc -> Doc > sub'keyword a = Sub "keyword" [a]+> sub'column1 :: Doc -> Doc > sub'column1 a = Sub "column1" [a]+> sub'hskip :: Doc -> Doc > sub'hskip a = Sub "hskip" [a]+> sub'phantom :: Doc -> Doc > sub'phantom a = Sub "phantom" [a] >+> sub'column3 :: Doc -> Doc -> Doc -> Doc > sub'column3 a1 a2 a3 = Sub "column3" [a1, a2, a3] Additional substitutions for the new @poly@ formatter. Added by ks, 14.05.2003. +> sub'fromto :: String -> String -> Doc -> Doc > sub'fromto b e a = Sub "fromto" [Text b,Text e,a]+> sub'column :: String -> Doc -> Doc > sub'column n a = Sub "column" [Text n,a]+> sub'centered :: Doc > sub'centered = Sub "centered" []+> sub'left :: Doc > sub'left = Sub "left" []+> sub'dummycol :: Doc > sub'dummycol = Sub "dummycol" []+> sub'indent :: Doc -> Doc > sub'indent n = Sub "indent" [n]
src/FileNameUtils.lhs view
@@ -41,6 +41,7 @@ > -- absPath ps = directorySeparator : relPath ps +> isWindows :: Bool > isWindows = "win" `isPrefixOf` os || "Win" `isPrefixOf` os || "mingw" `isPrefixOf` os > absPath :: FilePath -> FilePath@@ -80,7 +81,7 @@ > (sep,rs') = span isPathSeparator rs > s' = reverse rs' > sep' = reverse sep-> in if null s' +> in if null s' > then return [[head sep']] {- we don't descend from root -} > else if length sep < 2 > then return [s]@@ -99,10 +100,12 @@ > expandEnvironment :: String -> IO [String] > expandEnvironment s = case break (=='{') s of-> (s',"") -> return [s]+> (_s',"") -> return [s] > (s','{':r) -> case break (=='}') r of-> (e,"") -> return [s]+> (_e,"") -> return [s] > (e,'}':r') -> findEnvironment e s' r'+> _ -> impossible "expandEnvironment"+> _ -> impossible "expandEnvironment" > where findEnvironment :: String -> String -> String -> IO [String] > findEnvironment e a o = do er <- try (getEnv e) > return $ either (\ (_ :: IOException) -> [])
src/FiniteMap.lhs view
@@ -32,12 +32,12 @@ > lookup x (Leaf y w) > | x == y = Just w > | otherwise = Nothing-> lookup [] (Node ts w) = w-> lookup (a : x) (Node ts w) = lookupList ts+> lookup [] (Node _ts w) = w+> lookup (a : x) (Node ts _w) = lookupList ts > where > lookupList [] = Nothing-> lookupList ((b, t) : ts) = case compare b a of-> LT -> lookupList ts+> lookupList ((b, t) : ts') = case compare b a of+> LT -> lookupList ts' > EQ -> lookup x t > GT -> Nothing @@ -65,13 +65,13 @@ > LT -> Node [(b, Leaf y w), (a, Leaf x v)] Nothing > EQ -> Node [(a, insert (Leaf y w) x v)] Nothing > GT -> Node [(a, Leaf x v), (b, Leaf y w)] Nothing-> insert (Node ts w) [] v = Node ts (Just v)-> insert (Node ts w) (a : x) v = Node (insList ts) w+> insert (Node ts _w) [] v = Node ts (Just v)+> insert (Node ts w) (a : x) v = Node (insList ts) w > where > insList [] = [(a,Leaf x v)]-> insList ((b, t) : ts) = case compare b a of-> LT -> (b, t) : insList ts-> EQ -> (b, insert t x v) : ts-> GT -> (a, Leaf x v) : (b, t) : ts+> insList ((b, t) : ts') = case compare b a of+> LT -> (b, t) : insList ts'+> EQ -> (b, insert t x v) : ts'+> GT -> (a, Leaf x v) : (b, t) : ts' %}
src/HsLexer.lhs view
@@ -9,8 +9,8 @@ > where > import Data.Char ( isSpace, isUpper, isLower, isDigit, isAlphaNum, isPunctuation ) > import qualified Data.Char ( isSymbol )+> import Control.Applicative > import Control.Monad-> import Control.Monad.Error () > import Document > import Auxiliaries > import TeXCommands ( Lang(..) )@@ -91,38 +91,39 @@ ks, 28.08.2008: New: Agda and Haskell modes. > lexify :: Lang -> [Char] -> Either Exc [Token]-> lexify lang [] = return []-> lexify lang s@(_ : _) = case lex' lang s of+> lexify _lang [] = return []+> lexify lang s@(_ : _) = case lex' lang s of > Nothing -> Left ("lexical error", s) > Just (t, s') -> do ts <- lexify lang s'; return (t : ts) > > lex' :: Lang -> String -> Maybe (Token, String)-> lex' lang "" = Nothing-> lex' lang ('\'' : s) = do let (t, u) = lexLitChar s+> lex' _lang "" = Nothing+> lex' _lang ('\'' : s) = do let (t, u) = lexLitChar s > v <- match "\'" u > return (Char ("'" ++ t ++ "'"), v)-> lex' lang ('"' : s) = do let (t, u) = lexLitStr s+> lex' _lang ('"' : s) = do let (t, u) = lexLitStr s > v <- match "\"" u > return (String ("\"" ++ t ++ "\""), v)-> lex' lang ('-' : '-' : s)+> lex' lang ('-' : '-' : s) > | not (null s') && isSymbol lang (head s') > = case s' of > (c : s'') -> return (varsymid lang ("--" ++ d ++ [c]), s'')+> [] -> impossible "lex'" > | otherwise = return (Comment t, u) > where (d, s') = span (== '-') s > (t, u) = break (== '\n') s'-> lex' lang ('{' : '-' : '"' : s)+> lex' _lang ('{' : '-' : '"' : s) > = do let (t, u) = inlineTeX s > v <- match "\"-}" u > return (TeX True (Text t), v)-> lex' lang ('{' : '-' : '#' : s)+> lex' _lang ('{' : '-' : '#' : s) > = do let (t, u) = nested 0 s > v <- match "#-}" u > return (Pragma t, v)-> lex' lang ('{' : '-' : s) = do let (t, u) = nested 0 s+> lex' _lang ('{' : '-' : s) = do let (t, u) = nested 0 s > v <- match "-}" u > return (Nested t, v)-> lex' lang (c : s)+> lex' lang (c : s) > | isSpace c = let (t, u) = span isSpace s in return (Space (c : t), u) > | isSpecial lang c = Just (Special c, s) > | isUpper c = let (t, u) = span (isIdChar lang) s in return (Conid (c : t), u)@@ -136,34 +137,37 @@ > where > numeral Agda = Varid > numeral Haskell = Numeral-> classify s-> | s `elem` keywords lang-> = Keyword s-> | otherwise = Varid s+> classify s'+> | s' `elem` keywords lang+> = Keyword s'+> | otherwise = Varid s' > > > lexFracExp :: String -> Maybe (String, String)-> lexFracExp s = do t <- match "." s-> (ds, u) <- lexDigits' t-> (e, v) <- lexExp u-> return ('.' : ds ++ e, v)-> `mplus` lexExp s+> lexFracExp s = do t <- match "." s+> (ds, u) <- lexDigits' t+> (e, v) <- lexExp u+> return ('.' : ds ++ e, v)+> <|> lexExp s > > lexExp :: String -> Maybe (String, String) > lexExp (e:s)-> | e `elem` "eE" = do (c : t) <- Just s-> unless (c `elem` "+-") Nothing-> (ds, u) <- lexDigits' t-> return (e : c : ds, u)-> `mplus` do (ds, t) <- lexDigits' s-> return (e : ds, t)+> | e `elem` "eE" = do (c : t) <- Just s+> unless (c `elem` "+-") Nothing+> (ds, u) <- lexDigits' t+> return (e : c : ds, u)+> <|> do (ds, t) <- lexDigits' s+> return (e : ds, t) > lexExp s = Just ("", s) > > lexDigits' :: String -> Maybe (String, String) > lexDigits' s = do (cs@(_ : _), t) <- Just (span isDigit s); return (cs, t) +> varsymid :: Lang -> String -> Token > varsymid Agda = Varid > varsymid Haskell = Varsym+>+> consymid :: Lang -> String -> Token > consymid Agda = Conid > consymid Haskell = Consym
src/Main.lhs view
@@ -18,12 +18,11 @@ > import System.Process > import Control.Arrow > import Control.Monad-> import Control.Monad.Error+> import Control.Monad.Except > import Control.Monad.State ( MonadState(..), modify )-> import Control.Monad.Trans-> import Prelude hiding ( getContents )+> import Prelude hiding ( getContents, pi ) >-> import Version+> import qualified Version as V > import TeXCommands > import TeXParser > import qualified Verbatim@@ -37,7 +36,7 @@ > import StateT > import qualified FiniteMap as FM > import Auxiliaries-> import Value+> import Value hiding ( str ) > import License > > import FileNameUtils@@ -65,7 +64,7 @@ > [] -> lhs2TeX Poly flags (reverse initdirs) n > -- ks, 22.11.2005, changed default style to |Poly| > [Help] -> quitSuccess (usageInfo uheader options)-> [SearchPath] -> quitSuccess (init . unlines $ searchPath)+> [SearchPath] -> quitSuccess (init . unlines $ V.searchPath) > [Version] -> quitSuccess programInfo > [Copying] -> quitSuccess (programInfo ++ "\n\n" ++ copying) > [Warranty] -> quitSuccess (programInfo ++ "\n\n" ++ warranty)@@ -96,11 +95,11 @@ > } > where toggles0 = --[(decode CodeOnly, Bool (sty == CodeOnly))] > [("style", Int (fromEnum sty))]-> ++ [("version", Int numversion)]-> ++ [("pre", Int pre)]+> ++ [("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] ]+> ++ [ (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 ()@@ -121,9 +120,9 @@ > preprocess _ _ _ _ = error "preprocess: too few arguments" > lhs2TeX :: Style -> State -> [Class] -> [String] -> IO ()-> lhs2TeX s flags dirs files = do (str, file) <- input files+> lhs2TeX s flags dirs files' = do (str, file') <- input files' > expandedpath <- expandPath (searchpath flags)-> toIO (do put (initState s file expandedpath flags)+> toIO (do put (initState s file' expandedpath flags) > formats (map (No 0) dirs) `catchError` abort > formatStr (addEndEOF str) > stopexternals)@@ -143,7 +142,7 @@ @-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, +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@. @@ -153,12 +152,13 @@ > , 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"-> , Option [] ["math"] (NoArg (return, id, [Math])) "math style"+> , 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 [] ["code"] (NoArg (return, id, [CodeOnly])) "code style"+> , 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"+> , 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"@@ -193,18 +193,18 @@ > cstyle args = cstyle' Typewriter args > cstyle' :: Style -> [String] -> IO ()-> cstyle' s args = let (dirs,files) = coptions args-> in lhs2TeX s state0 dirs files+> cstyle' s args = let (dirs,files') = coptions args+> in lhs2TeX s state0 dirs files' > coptions :: [String] -> ([Class], [String])-> coptions = foldr (<|) ([], [])+> 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)+> "-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.@@ -248,8 +248,8 @@ > 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})+> 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} ->@@ -258,14 +258,6 @@ > where > addEndNL = (++"\n") . unlines . lines -Remove trailing blank line.--> trim = reverse >>> skip >>> reverse->-> skip s | all isSpace t = u-> | otherwise = s-> where (t, u) = breakAfter (== '\n') s- > format (Environment Haskell_ s) > = display s > format (Environment Code s) = display s@@ -277,12 +269,12 @@ > unless (style st `elem` [CodeOnly,NewCode]) $ > do result <- external s > display result-> format (Environment Hide s) = return ()-> format (Environment Ignore s) = return ()+> 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)+> 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)@@ -290,19 +282,19 @@ > format (Directive Include arg)= do st <- get > let d = path st > let sp = searchpath st-> modify (\st@State{file = f', lineno = l'} ->-> st{file = f, files = (f', l') : files st, path = d ++ dir f})+> 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 ++ f))-> modify (\st -> st { file = 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})+> modify (\st'@State{files = (f', l) : fs} ->+> st'{file = f', lineno = l, files = fs, path = d}) > liftIO (when (verbose st) (hPutStrLn stderr $ ")"))-> where f = withoutSpaces arg+> where arg' = withoutSpaces arg > addEndNL = (++"\n") . unlines . lines ks, 25.01.2003: I added the above function at the suggestion of NAD, but@@ -314,9 +306,9 @@ 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, +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 +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})@@ -324,8 +316,8 @@ > 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})+> 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 @@ -340,7 +332,7 @@ \NB @%align@ also resets the left identation stacks. -Also, the @poly@ directives @%separation@ and @%latency@ reset +Also, the @poly@ directives @%separation@ and @%latency@ reset the corresponding indentation stack |pstack|. > format (Directive Separation s )@@ -348,10 +340,11 @@ > 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 (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. %{@@ -367,7 +360,7 @@ > put (st { ofile = file st, olineno = lineno st }) > > liftIO (hPutStr (output st) s)-> modify (\st -> st { olineno = olineno st + ls, atnewline = enl (atnewline st)})+> modify (\st' -> st' { olineno = olineno st' + ls, atnewline = enl (atnewline st')}) > where > checkNLs n ('\n':[]) = (n+1,const True) > checkNLs n (_:[]) = (n,const False)@@ -384,7 +377,7 @@ > > undef :: String -> String > undef s = "`" ++ s ++ "' is not defined;\n\-> \perhaps you forgot to include \"lhs2TeX.fmt\"?"+> \perhaps you forgot to include \"polycode.fmt\" (or \"lhs2TeX.fmt\")?" %} @@ -402,12 +395,14 @@ > inline s = do st <- get > d <- fromEither (select (style st) st) > eject d-> where select Verb st = Right (Verbatim.inline False s)+> 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 CodeOnly st = return Empty-> select NewCode st = return Empty -- generate PRAGMA or something?+> 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)@@ -421,20 +416,25 @@ > 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)+> 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+> trim = skip' >>> reverse >>> skip' >>> reverse > where-> skip :: String -> String-> skip "" = ""-> skip s | all isSpace t = u+> skip' :: String -> String+> skip' "" = ""+> skip' s | all isSpace t = u > | otherwise = s > where (t, u) = breakAfter (== '\n') s @@ -454,23 +454,23 @@ > directive :: Lang -> Directive -> String > -> (FilePath,LineNo) -> [CondInfo] -> Toggles > -> [Numbered Class] -> Formatter-> directive lang d s (f,l) stack togs ts-> = dir d s stack+> 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 ((f, l, bool b, True) : bs) ts-> dir Elif s ((f,l,b2,b1):bs) = do b <- fromEither (eval lang togs s)+> 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)+> 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+> 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)@@ -480,9 +480,9 @@ > skip :: [Numbered Class] -> Formatter > skip [] = return ()-> skip ts@(No n (Directive d s) : _)+> skip ts@(No _n (Directive d _s) : _) > | conditional d = formats ts-> skip (t : ts) = skip ts+> skip (_t : ts) = skip ts % - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - - \subsubsection{Active commands}@@ -543,7 +543,7 @@ > hFlush pin > waitForProcess pid) pis -To extract the answer from @ghci@'s or @hugs@' output +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
src/Math.lhs view
@@ -10,18 +10,16 @@ > import Prelude hiding ( lines ) > import Data.List ( partition ) > import Numeric ( showFFloat )-> import Control.Applicative ( many )+> import Control.Applicative > import Control.Arrow ( (>>>) )-> import Control.Monad ( MonadPlus(..), (>=>) )+> import Control.Monad ( (>=>) ) > > import Verbatim ( expand, trim )-> import Typewriter ( latex ) > import MathCommon > import Document > import Directives > import HsLexer > import Parser-> import qualified FiniteMap as FM > import Auxiliaries > import TeXCommands ( Lang(..) ) @@ -76,21 +74,21 @@ > > chunk :: (CToken tok) => Parser (Pos tok) (Chunk (Pos tok)) > chunk = do a <- many atom-> as <- many (do s <- sep; a <- many atom; return (Delim s : offside a))+> as <- many (do s <- sep; a' <- many atom; return (Delim s : offside a')) > return (offside a ++ concat as) > where offside [] = [] > -- old: |opt a = [Apply a]| > offside (a : as) = Apply (a : bs) : offside cs > where (bs, cs) = span (\a' -> col' a < col' a') as-> col' (Atom a) = col a-> col' (Paren a _ _) = col a+> col' (Atom a) = poscol a+> col' (Paren a _ _) = poscol a > > atom :: (CToken tok) => Parser (Pos tok) (Atom (Pos tok))-> atom = fmap Atom noSep-> `mplus` do l <- left-> e <- chunk-> r <- right l-> return (Paren l e r)+> atom = fmap Atom noSep+> <|> do l <- left+> e <- chunk+> r <- right l+> return (Paren l e r) Primitive parser. @@ -98,8 +96,10 @@ > sep = satisfy (\t -> catCode t == Sep) > noSep = satisfy (\t -> catCode t == NoSep) > left = satisfy (\t -> case catCode t of Del c -> c `elem` "(["; _-> False)-> right l = satisfy (\c -> case (catCode l, catCode c) of-> (Del o, Del c) -> (o,c) `elem` zip "([" ")]" +>+> right :: (CToken tok) => tok -> Parser tok tok+> right l = satisfy (\c' -> case (catCode l, catCode c') of+> (Del o, Del c) -> (o,c) `elem` zip "([" ")]" > _ -> False) % - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - -@@ -117,11 +117,11 @@ > align :: (CToken tok) => Maybe Int -> [[Pos tok]] -> [Line [Pos tok]] > align c = fmap (maybe Multi split3 c) > where-> split3 i ts = case span (\t -> col t < i) ts of+> split3 i ts = case span (\t -> poscol t < i) ts of > ([], []) -> Blank > ((_ : _), []) -> Multi ts > (us, v : vs)-> | col v == i && isInternal v+> | poscol v == i && isInternal v > -> Three us [v] vs > | null us -> Three [] [] (v : vs) > | otherwise -> Multi ts@@ -135,9 +135,9 @@ > _ -> False > > instance Functor Line where-> fmap f Blank = Blank-> fmap f (Three l c r) = Three (f l) (f c) (f r)-> fmap f (Multi a) = Multi (f a)+> fmap _f Blank = Blank+> fmap f (Three l c r) = Three (f l) (f c) (f r)+> fmap f (Multi a) = Multi (f a) % - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - - \subsubsection{Adding spaces}@@ -149,16 +149,16 @@ after a keyword (hence |before b| really means not immediately after). > addSpaces :: (CToken tok) => [tok] -> [tok]-> addSpaces ts = before False ts+> addSpaces ts0 = before False ts0 > where-> before b [] = []-> before b (t : ts) = case token t of+> before _b [] = []+> before b (t : ts) = case token t of > u | selfSpacing u -> t : before False ts > Special c > | c `elem` ",;([{" -> t : before False ts > Keyword _ -> [ fromToken (TeX False sub'space) | b ] ++ t : after ts > _ -> t : before True ts-> +> > after [] = [] > after (t : ts) = case token t of > u | selfSpacing u -> t : before False ts@@ -187,8 +187,14 @@ > type Stack = [(Col, Doc, [Pos Token])] >-> leftIndent dict auto (lst, rst)-> = loop lst rst+> leftIndent ::+> Formats+> -> Bool+> -> (Stack, Stack)+> -> [Line [Pos Token]]+> -> (Doc, (Stack, Stack))+> leftIndent dict auto (lst0, rst0)+> = loop lst0 rst0 > where > copy d | auto = d > | otherwise = Empty@@ -197,37 +203,37 @@ @::@, @=@ etc~oder ein Operator wie @++@ ist. > loop lst rst [] = (Empty, (lst, rst))-> loop lst rst (l : ls) = case l of+> loop lst rst (l' : ls) = case l' of > Blank -> loop lst rst ls-> Three l c r -> (sub'column3 (copy lskip <> latexs dict l)+> Three l c r -> (sub'column3 (copy lskip <<>> latexs dict l) > (latexs dict c)-> (copy rskip <> latexs dict r) <> sep ls <> rest, st')+> (copy rskip <<>> latexs dict r) <<>> sep' ls <<>> rest, st') > where (lskip, lst') = indent l lst > (rskip, rst') = indent r rst > (rest, st') = loop lst' rst' ls -- does not work: |if null l && null c then rst' else []|-> Multi m -> (sub'column1 (copy lskip <> latexs dict m) <> sep ls <> rest, st')+> Multi m -> (sub'column1 (copy lskip <<>> latexs dict m) <<>> sep' ls <<>> rest, st') > where (lskip, lst') = indent m lst > (rest, st') = loop lst' [] ls >-> sep [] = Empty-> sep (Blank : _ ) = sub'blankline-> sep (_ : _) = sub'nl+> sep' [] = Empty+> sep' (Blank : _ ) = sub'blankline+> sep' (_ : _) = sub'nl > > indent :: [Pos Token] -> Stack -> (Doc, Stack) > indent [] stack = (Empty, stack)-> indent ts@(t : _) [] = (Empty, [(col t, Empty, ts)])+> indent ts@(t : _) [] = (Empty, [(poscol t, Empty, ts)]) > indent ts@(t : _) (top@(c, skip, line) : stack)-> = case compare (col t) c of+> = case compare (poscol t) c of > LT -> indent ts stack > EQ -> (skip, (c, skip, ts) : stack)-> GT -> (skip', (col t, skip', ts) : top : stack)+> GT -> (skip', (poscol t, skip', ts) : top : stack) > where-> skip' = case span (\u -> col u < col t) line of-> (us, v : vs) | col v == col t-> -> skip <> sub'phantom (latexs dict us)+> skip' = case span (\u -> poscol u < poscol t) line of+> (us, v : _vs) | poscol v == poscol t+> -> skip <<>> sub'phantom (latexs dict us) > -- does not work: |(us, _) -> skip ++ [Phantom (fmap token us), Skip (col t - last (c : fmap col us))]|-> _ -> skip <> sub'hskip (Text em)-> where em = showFFloat (Just 2) (0.5 * fromIntegral (col t - c) :: Double) ""+> _ -> skip <<>> sub'hskip (Text em)+> where em = showFFloat (Just 2) (0.5 * fromIntegral (poscol t - c) :: Double) "" M"ussen |v| und |t| zueinander passen? %
src/MathCommon.lhs view
@@ -11,16 +11,16 @@ > import Typewriter ( latex ) > import Document-> import Directives+> import Directives ( Formats ) > import HsLexer > import qualified FiniteMap as FM > import Auxiliaries >-> import Control.Monad+> import Control.Applicative > when :: Monad m => Bool -> (a -> m a) -> (a -> m a) > when True f = f-> when False f = return+> when False _f = return % - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - - \subsubsection{Adding positional information}@@ -29,7 +29,7 @@ > type Row = Int > type Col = Int >-> data Pos a = Pos {row :: !Row, col :: !Col, ann :: a}+> data Pos a = Pos {posrow :: !Row, poscol :: !Col, posann :: a} > deriving (Show) %{@@ -57,8 +57,8 @@ Numbering the list of tokens. > number :: Row -> Col -> [Token] -> [Pos Token]-> number r c [] = []-> number r c (t : ts) = Pos r c t : number r' c' ts+> number _r _c [] = []+> number r c (t : ts) = Pos r c t : number r' c' ts > where (r', c') = count r c (string t) > > count :: Row -> Col -> String -> (Row, Col)@@ -74,7 +74,7 @@ > where > split _ [] = [] > split r ts = us : split (r + 1) vs-> where (us, vs) = span (\t -> row t <= r) ts+> where (us, vs) = span (\t -> posrow t <= r) ts % - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - - \subsubsection{A very simple Haskell Parser}@@ -85,9 +85,9 @@ possible that the explanation is not adequate: A |Chunk| is a sequence of \emph{delimiters} or \emph{applications}. Delimiters-are keywords or operators. Applications are everything else. +are keywords or operators. Applications are everything else. -An |application| is a sequence of atoms that are forming a Haskell +An |application| is a sequence of atoms that are forming a Haskell function application. The list must never be empty, but can contain a single element (for instance, in normal infix expressions such as |2 + 3| this will occur frequently).@@ -135,7 +135,7 @@ > where > eval :: (CToken tok) => [Item (Pos tok)] -> (Mode,[Pos tok]) > eval [e] = eval' e-> eval chunk = (Optional False, concat [ snd (eval' i) | i <- chunk ])+> eval chunk' = (Optional False, concat [ snd (eval' i) | i <- chunk' ]) > > eval' :: (CToken tok) => Item (Pos tok) -> (Mode,[Pos tok]) > eval' (Delim s) = (Optional False, [s])@@ -143,7 +143,7 @@ > eval' (Apply (e : es)) = eval'' False e es > > eval'' :: (CToken tok) => Bool -> Atom (Pos tok) -> [Atom (Pos tok)] -> (Mode,[Pos tok])-> eval'' _ (Atom s) es = case FM.lookup (string (token s) ++ pos2string s) d `mplus` FM.lookup (string (token s)) d of+> eval'' _ (Atom s) es = case FM.lookup (string (token s) ++ pos2string s) d <|> FM.lookup (string (token s)) d of > Nothing -> (Optional False, s : args es) > Just (opt, opts, lhs, rhs)-> (Optional opt, set s (concat (fmap sub rhs)) ++ args bs) > where@@ -161,10 +161,10 @@ inherits the position of the original token. > eval'' opt (Paren l e r) es-> | optional = (Mandatory, set l s ++ args es)+> | isOptional = (Mandatory, set l s ++ args es) > | otherwise = (Optional False, [l] ++ s ++ [r] ++ args es) > where (flag, s) = eval e-> optional = catCode l == Del '(' && not (mandatory e)+> isOptional = catCode l == Del '(' && not (mandatory e) > && case flag of Mandatory -> False; Optional f -> opt || f \NB It is not a good idea to remove parentheses around atoms, because@@ -180,11 +180,11 @@ To support macros of the form @%format Parser (a) = a@. > set :: (CToken tok) => tok -> [tok] -> [tok]-> set s [] = []-> set s (t : ts) = inherit s (token t) : ts+> set _s [] = []+> set s (t : ts) = inherit s (token t) : ts > > mandatory :: (CToken tok) => Chunk tok -> Bool-> mandatory e = False+> mandatory _e = False Code before:
src/MathPoly.lhs view
@@ -14,20 +14,17 @@ > where > > import Prelude hiding ( lines )-> import Data.List ( partition, nub, insert, sort, transpose )-> import Numeric ( showFFloat )-> import Control.Applicative ( many )+> import Data.List ( partition, nub, sort, transpose )+> import Control.Applicative > import Control.Arrow ( (>>>) )-> import Control.Monad ( MonadPlus(..), (>=>) )+> import Control.Monad ( (>=>) ) > > import Verbatim ( expand, trim )-> import Typewriter ( latex ) > import MathCommon > import Document > import Directives > import HsLexer > import Parser-> import qualified FiniteMap as FM > import Auxiliaries > import TeXCommands ( Lang(..) ) > -- import Debug.Trace ( trace )@@ -54,7 +51,7 @@ > display :: Lang -> Int -> Formats -> Bool -> Int -> Int -> Stack > -> String -> Either Exc (Doc, Stack)-> display lang line fmts auto sep lat stack+> display lang line fmts auto sep lat _stack > = lift trim > >=> lift (expand 0) > >=> tokenize lang@@ -69,7 +66,7 @@ > >=> lift (\ts -> (autoalign sep ts,ts)) > -- |>=> lift (\(x,y) -> trace ((unlines $ map show $ y) ++ "\n" ++ show x) (x,y))| > >=> lift (\(cs,ts) -> let ats = align cs sep lat ts-> cs' = [("B",0)] ++ cs +> cs' = [("B",0)] ++ cs > ++ [("E",error "E column")] > in (autocols cs' ats,ats) > )@@ -79,10 +76,10 @@ > >=> return *** lift (\(z,ats) -> leftIndent fmts auto z [] ats) > -- ks, 17.07.2003: i've changed "stack" into "[]" and thereby disabled > -- the global stack for now as it leads to unexepected behaviour-> >=> lift (\(cs,(d,stack)) -> (sub'code (columns cs <> d),stack))+> >=> lift (\(cs,(d,stack)) -> (sub'code (columns cs <<>> d),stack)) > > columns :: [(String,Doc)] -> Doc-> columns = foldr (<>) Empty +> columns = foldr (<<>>) Empty > . map (uncurry sub'column) % - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - -@@ -99,24 +96,24 @@ > > chunk :: (CToken tok) => Int -> Parser (Pos tok) (Chunk (Pos tok)) > chunk d = do a <- many (atom d)-> as <- many (do s <- sep; a <- many (atom d); return (Delim s : offside a))+> as <- many (do s <- csep; a' <- many (atom d); return (Delim s : offside a')) > return (offside a ++ concat as) > where offside [] = [] > -- old: |opt a = [Apply a]| > offside (a : as) = Apply (a : bs) : offside cs > where (bs, cs) = span (\a' -> col' a < col' a') as-> col' (Atom a) = col a-> col' (Paren a _ _) = col a+> col' (Atom a) = poscol a+> col' (Paren a _ _) = poscol a > > atom :: (CToken tok) => Int -> Parser (Pos tok) (Atom (Pos tok))-> atom d = fmap Atom noSep-> `mplus` do l <- left-> e <- chunk (d+1)-> r <- right l-> return (Paren l e r)-> `mplus` if d == 0 then do r <- anyright-> return (Paren (fromToken $ TeX False Empty) [] r)-> else mzero+> atom d = fmap Atom cnoSep+> <|> do l <- left+> e <- chunk (d+1)+> r <- right l+> return (Paren l e r)+> <|> if d == 0 then do r <- anyright+> return (Paren (fromToken $ TeX False Empty) [] r)+> else empty ks, 09.09.2003: Added handling of unbalanced parentheses, surely not in the most elegant way. Both |chunk| and |atom| now take an integer argument@@ -126,16 +123,18 @@ Primitive parser. -> sep, noSep, left, anyright :: (CToken tok) => Parser tok tok-> sep = satisfy (\t -> catCode t == Sep)-> noSep = satisfy (\t -> catCode t == NoSep)+> csep, cnoSep, left, anyright :: (CToken tok) => Parser tok tok+> csep = satisfy (\t -> catCode t == Sep)+> cnoSep = satisfy (\t -> catCode t == NoSep) > left = satisfy (\t -> case catCode t of Del c -> c `elem` "([{"; _ -> False) > anyright = satisfy (\t -> case catCode t of Del c -> c `elem` ")]}"; _ -> False)-> right l = satisfy (\c -> case (catCode l, catCode c) of-> (Del o, Del c) -> (o,c) `elem` zip "([{" ")]}" -> _ -> False)-> `mplus` do eof-> return (fromToken $ TeX False Empty)+>+> right :: (CToken tok) => tok -> Parser tok tok+> right l = satisfy (\c' -> case (catCode l, catCode c') of+> (Del o, Del c) -> (o,c) `elem` zip "([{" ")]}"+> _ -> False)+> <|> do eof+> return (fromToken $ TeX False Empty) ks, 06.09.2003: Modified the |right| parser to accept the end of file, to allow for unbalanced parentheses. This behaviour is not (yet) backported@@ -154,20 +153,20 @@ > autoalign sep toks = map (\x -> (show x,x)) > . nub > . sort-> . concat -> . fmap findCols +> . concat+> . fmap findCols > $ toks > where > findCols :: (CToken tok,Show tok) => [Pos tok] -> [Col]-> findCols ts = case {- |trace (show ts)| -} +> findCols ts = case {- |trace (show ts)| -} > (break (\t -> not . isNotSpace . token $ t) ts) of > (_, []) -> [] -- done-> (_, [v]) -> [] -- last token is whitespace, doesn't matter+> (_, [_v]) -> [] -- last token is whitespace, doesn't matter > (_, v:v':vs)-> | row v' == 0 && col v' == 0+> | posrow v' == 0 && poscol v' == 0 > -> findCols (v:vs) -- skip internal tokens (automatically added spaces) > | length (string (token v)) >= sep-> -> {- |trace ("found: " ++ show (col v')) $| -} col v' : findCols (v':vs)+> -> {- |trace ("found: " ++ show (col v')) $| -} poscol v' : findCols (v':vs) > | otherwise -> {- |trace ("found too short")| -} findCols (v':vs) ks, 21.11.2005: I've fixed a bug that was known to me since long ago, but I never got@@ -183,24 +182,24 @@ > align cs sep lat toks = fmap (\t -> {- |trace (show (map token t) ++ "\n") $| -} > let res = splitn ("B",0) False cs t > in if null [x | x <- t-> , (row x /= 0 || col x /= 0) && isNotSpace (token x)]-> || null res +> , (posrow x /= 0 || poscol x /= 0) && isNotSpace (token x)]+> || null res > then Blank > else Poly res > ) toks > where-> splitn cc ind [] [] = []-> splitn cc ind [] ts = [(cc,ts,ind)]-> splitn cc ind ((n,i):oas) ts= -> case span (\t -> col t < i) ts of+> splitn _cc _ind [] [] = []+> splitn cc ind [] ts = [(cc,ts,ind)]+> splitn cc ind ((n,i):oas) ts=+> case span (\t -> poscol t < i) ts of > ([], vs) -> splitn cc ind oas vs > (us, []) -> [(cc,us,ind)]-> (us, (v:vs)) -> -> let lu = head [ u | u <- reverse us, col u /= 0 || row u /= 0 ]+> (us, (v:vs)) ->+> let lu = head [ u | u <- reverse us, poscol u /= 0 || posrow u /= 0 ] > -- again, we skip automatically added spaces > llu = length (string (token lu)) > in case () of-> _ | (lat /= 0 && isNotSpace (token lu)) || llu < lat || col v /= i+> _ | (lat /= 0 && isNotSpace (token lu)) || llu < lat || poscol v /= i > -- no alignment for this column > -> splitn cc ind oas (us ++ (v:vs)) > | not (isNotSpace (token lu)) && llu >= sep@@ -220,8 +219,8 @@ > _ -> False > > instance Functor Line where-> fmap f Blank = Blank-> fmap f (Poly ls) = Poly (map (\(x,y,z) -> (x,f y,z)) ls)+> fmap _f Blank = Blank+> fmap f (Poly ls) = Poly (map (\(x,y,z) -> (x,f y,z)) ls) % - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - - \subsubsection{Automatically determining centered columns}@@ -235,8 +234,8 @@ > autocols :: (CToken tok, Show tok) => [(String,Int)] -- column info > -> [Line [Pos tok]] -- aligned tokens > -> ([(String,Doc)],[Col]) -- cols+alignment, plus centered columns-> autocols cs ats = (\(x,y) -> (concat x,concat y)) $ unzip -> $ zipWith3 (\(cn,n) ml ai -> +> autocols cs ats = (\(x,y) -> (concat x,concat y)) $ unzip+> $ zipWith3 (\(cn,n) ml ai -> > if ml <= 2 && ai then ([(cn,sub'centered) > ,(cn ++ "E",sub'dummycol) > ],[n])@@ -248,14 +247,16 @@ > maxlengths = {- |trace (show cts) $ |-} map (maximum . map length) cts > anyinternals = map (any (any isInternal)) cts >-> -- deline :: [(String,Int)] -> Line [a] -> [[[a]]]-> deline cs Blank = []-> deline cs (Poly ls) = [decol cs ls]+> deline :: [(String,Int)] -> Line [a] -> [[[a]]]+> deline _cs' Blank = []+> deline cs' (Poly ls) = [decol cs' ls] >-> decol cs [] = replicate (length cs) []-> decol ((cn,_):cs) r@(((cn',_),ts,_):rs)-> | cn' == cn = ts : decol cs rs-> | otherwise = [] : decol cs r+> decol :: [(String, Int)] -> [((String, Int), [a], Bool)] -> [[a]]+> decol cs' [] = replicate (length cs') []+> decol ((cn,_):cs') r@(((cn',_),ts,_):rs)+> | cn' == cn = ts : decol cs' rs+> | otherwise = [] : decol cs' r+> decol _ _ = impossible "autocols.decol" % - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - - \subsubsection{Adding spaces}@@ -267,17 +268,17 @@ after a keyword (hence |before b| really means not immediately after). > addSpaces :: (CToken tok) => [tok] -> [tok]-> addSpaces ts = before False ts+> addSpaces ts0 = before False ts0 > where-> before b [] = []-> before b (t : ts) = case token t of+> before _b [] = []+> before b (t : ts) = case token t of > u | not (isNotSpace u)-> t : before b ts > | selfSpacing u -> t : before False ts > Special c > | c `elem` ",;([{" -> t : before False ts > Keyword _ -> [ fromToken (TeX False sub'space) | b ] ++ t : after ts > _ -> t : before True ts-> +> > after [] = [] > after (t : ts) = case token t of > u | not (isNotSpace u)-> t : after ts@@ -330,49 +331,46 @@ As a final step, the current line is placed on the stack. -> leftIndent :: Formats -> Bool +> leftIndent :: Formats -> Bool > -> [Col] -- centered columns > -> Stack -- current stack > -> [Line [Pos Token]] > -> (Doc, Stack)-> leftIndent dict auto z stack-> = loop True stack+> leftIndent dict _auto z stack0+> = loop True stack0 > where-> copy d | auto = d-> | otherwise = Empty- > loop :: Bool -> Stack -> [Line [Pos Token]] -> (Doc, Stack)-> loop first stack [] = (Empty, stack) -- done-> loop first stack (l:ls) = case l of+> loop _first stack [] = (Empty, stack) -- done+> loop first stack (l:ls) = case l of > Blank -> loop True stack ls -- ignore blank lines > {-| Poly x || trace (show x) False -> undefined |-} > Poly [] -> loop True stack ls -- next line-> Poly (((n,c),[],ind):rs)+> Poly (((_n,_c),[],_ind):rs) > | first -> loop True stack (Poly rs:ls) -- ignore leading blank columns-> Poly p@(((n,c),ts,ind):rs)+> Poly p@(((n,c),ts,_ind):rs) > | first -> -- check indentation > let -- step 1: shrink stack-> rstack = dropWhile (\(rc,_) -> rc >= c) stack+> rstack = dropWhile (\(rc',_) -> rc' >= c) stack > -- step 2: find relevant column > (rn,rc) = findrel (n,c) rstack > -- step 3: place line on stack > fstack = (c,l) : rstack > in mkFromTo fstack rn n rc [fromToken $ TeX False (indent (rn,rc) (n,c))] p ls-> >+> > | c `elem` z -> mkFromTo stack n (n ++ "E") c ts rs ls > -- treat centered lines special-> Poly [((n,c),ts,ind)] -> mkFromTo stack n "E" c ts [] ls+> Poly [((n,c),ts,_ind)] -> mkFromTo stack n "E" c ts [] ls > -- last columns-> Poly (((n,c),ts,ind):rs@(((nn,_),_,_):_))-> -> mkFromTo stack n nn c ts rs ls +> Poly (((n,c),ts,_ind):rs@(((nn,_),_,_):_))+> -> mkFromTo stack n nn c ts rs ls > > mkFromTo :: Stack -> String -> String -> Col -> [Pos Token] -> [((String, Int), [Pos Token], Bool)] -> [Line [Pos Token]] -> (Doc, Stack)-> mkFromTo stack bn en c ts rs ls+> mkFromTo stack bn en _c ts rs ls > | bn == en = -- this can happen at the beginning of a line due to indentation > (rest,stack') > | otherwise = (sub'fromto bn en (latexs dict ts)-> <> (if null rs then sep ls else Empty) <> rest+> <<>> (if null rs then sep ls else Empty) <<>> rest > ,stack' > ) > where@@ -384,8 +382,8 @@ > findrel :: (String,Col) -> Stack -> (String,Col) > findrel (n,c) [] = (n,c) > findrel (n,c) ((_,Blank):r) = findrel (n,c) r -- should never happen-> findrel (n,c) ((_,Poly t):_)-> = case break (\((n',c'),_,_) -> c' > c) t of+> findrel (_n,c) ((_,Poly t):_)+> = case break (\((_n',c'),_,_) -> c' > c) t of > ([],_) -> error "findrel: the impossible happened" > (pre,_) -> let ((rn,rc),_,_) = last pre > in (rn,rc)@@ -395,7 +393,7 @@ > sep (_ : _) = sub'nl > > indent :: (String,Int) -> (String,Int) -> Doc-> indent (n,c) (n',c')+> indent (_n,c) (_n',c') > | c /= c' = sub'indent (Text (show (c' - c))) > | otherwise = Empty
src/NewCode.lhs view
@@ -13,6 +13,7 @@ > module NewCode ( module NewCode ) > where >+> import Control.Arrow ( (>>>) ) > import Control.Monad ( (>=>) ) > import Data.List ( partition ) >@@ -47,6 +48,22 @@ > >=> lift (latexs sub'space sub'nl fmts) > >=> lift sub'code +ks, 2016-08-12:+Since we're now reusing this for markdown mode, we need an |inline| function+after all:++> inline :: Lang -> Formats -> String -> Either Exc Doc+> inline lang fmts = fmap unNL+> >>> tokenize lang+> >=> lift (number 1 1)+> >=> lift (partition (\t -> catCode t /= White))+> >=> exprParse *** return+> >=> lift (substitute fmts False) *** return+> >=> lift (uncurry merge)+> >=> lift (fmap token)+> >=> lift (latexs sub'space sub'nl fmts)+> >=> lift sub'inline+ % - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - - \subsubsection{Encoding} % - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - -@@ -66,11 +83,11 @@ > latex sp nl dict = tex Empty > where > tex _ (Space s) = sub'spaces (convert s)-> tex q (Conid s) = replace q s (sub'conid (q <> convert s))+> tex q (Conid s) = replace q s (sub'conid (q <<>> convert s)) > tex _ (Varid "") = sub'dummy -- HACK-> tex q (Varid s) = replace q s (sub'varid (q <> convert s))-> tex q (Consym s) = replace q s (sub'consym (q <> convert s))-> tex q (Varsym s) = replace q s (sub'varsym (q <> convert s))+> tex q (Varid s) = replace q s (sub'varid (q <<>> convert s))+> tex q (Consym s) = replace q s (sub'consym (q <<>> convert s))+> tex q (Varsym s) = replace q s (sub'varsym (q <<>> convert s)) > tex _ (Numeral s) = replace Empty s (sub'numeral (convert s)) -- NEU > tex _ (Char s) = sub'char (catenate (map conv (init $ tail s))) -- NEW: remove quotes > tex _ (String s) = sub'string (catenate (map conv (init $ tail s))) -- NEW: remove quotes@@ -81,17 +98,15 @@ > tex _ (Keyword s) = replace Empty s (sub'keyword (convert s)) > tex _ (TeX False d) = d > tex _ (TeX True d) = sub'tex d-> tex _ t@(Qual ms t') = replace Empty (string t) (tex (catenate (map (\m -> tex Empty (Conid m) <> Text ".") ms)) t')+> tex _ t@(Qual ms t') = replace Empty (string t) (tex (catenate (map (\m -> tex Empty (Conid m) <<>> Text ".") ms)) t') > tex _ t@(Op t') = replace Empty (string t) (sub'backquoted (tex Empty t'))-> where cmd | isConid t'= sub'consym-> | otherwise = sub'varsym > > replace q s def = case FM.lookup s dict of-> Just (_, _, [], ts) -> q <> catenate (map (tex Empty) ts)+> Just (_, _, [], ts) -> q <<>> catenate (map (tex Empty) ts) > _ -> def \NB the directives @%format a = b@ and @%format b = a@ cause a loop.- + \NB Only nullary macros are applied. Conversion of strings and characters.
src/Parser.lhs view
@@ -7,10 +7,8 @@ > module Parser ( Parser, run, satisfy, lit, lits, wrap, nonnull, eof ) > where >-> import Data.Char ( isSpace )-> import Auxiliaries > import Control.Applicative-> import Control.Monad ( MonadPlus(..), filterM, ap )+> import Control.Monad ( MonadPlus(..), ap, mfilter ) %endif Deterministische Mini-Parser.@@ -19,6 +17,7 @@ %format (unParser (p)) = p %else +> unParser :: Parser tok a -> [tok] -> Maybe (a, [tok]) > unParser (MkParser p) = p %endif@@ -36,7 +35,7 @@ > Nothing -> Nothing > Just (a, rest) -> unParser (k a) rest) > instance MonadPlus (Parser tok) where-> mzero = MkParser (\inp -> Nothing)+> mzero = MkParser (\_inp -> Nothing) > m `mplus` n = MkParser (\inp -> unParser m inp `mplus` unParser n inp) > instance Applicative (Parser tok) where > pure = return@@ -46,9 +45,9 @@ > (<|>) = mplus > > satisfy :: (tok -> Bool) -> Parser tok tok-> satisfy pred = MkParser (\inp -> case inp of-> a : rest | pred a -> Just (a, rest)-> _ -> Nothing)+> satisfy p = MkParser (\inp -> case inp of+> a : rest | p a -> Just (a, rest)+> _ -> Nothing) > > lit :: (Eq tok) => tok -> Parser tok tok > lit c = satisfy (== c)@@ -74,8 +73,6 @@ > > nonnull :: ([tok] -> ([a], [tok])) -> Parser tok [a] > nonnull f = mfilter (not . null) (wrap f)--> mfilter p m = m >>= \a -> if p a then return a else mzero %if False
src/StateT.lhs view
@@ -5,14 +5,13 @@ %if codeOnly || showModuleHeader > {-# LANGUAGE GeneralizedNewtypeDeriving #-}+> {-# OPTIONS_GHC -fno-warn-unused-imports #-} > module StateT ( module StateT ) > where >-> import Control.Applicative-> import Control.Monad.Error+> import Control.Applicative -- only needed for older GHCs+> import Control.Monad.Except > import Control.Monad.State->-> import Auxiliaries %endif @@ -23,7 +22,7 @@ %format unXIO (m) = m %endif -> newtype XIO exc st a = MkXIO (ErrorT exc (StateT st IO) a)+> newtype XIO exc st a = MkXIO (ExceptT exc (StateT st IO) a) > deriving (Functor, Applicative, Monad, MonadIO, MonadState st, MonadError exc) -- XIO exc st a ~= StateT st IO (Either exc a)@@ -31,18 +30,19 @@ %if style /= math +> unXIO :: XIO exc st a -> ExceptT exc (StateT st IO) a > unXIO (MkXIO f) = f %endif \NB The state is preserved upon failure. -> toIO :: Error exc => XIO exc st a -> IO a+> toIO :: XIO exc st a -> IO a > toIO (MkXIO m) = do-> (r, _) <- runStateT (runErrorT m)+> (r, _) <- runStateT (runExceptT m) > (error "no initial state supplied") > case r of Left _ -> error "unhandled error" > Right x -> return x -> fromEither :: Error exc => Either exc a -> XIO exc st a+> fromEither :: Either exc a -> XIO exc st a > fromEither = either throwError return
src/TeXCommands.lhs view
@@ -8,7 +8,6 @@ > where > > import Data.Maybe-> import FiniteMap ( FiniteMap ) > import qualified FiniteMap as FM > import Auxiliaries @@ -16,7 +15,7 @@ These don't really belong into a module named TeXCommands: -> data Style = Version | Help | SearchPath | Copying | Warranty | CodeOnly | NewCode | Verb | Typewriter | Poly | Math | Pre+> data Style = Version | Help | SearchPath | Copying | Warranty | CodeOnly | NewCode | Verb | Typewriter | Poly | Markdown | Math | Pre > deriving (Eq, Show, Enum, Bounded) > data Lang = Haskell | Agda@@ -69,7 +68,7 @@ > class Representation a where > representation :: [(String, a)] > instance Representation Style where-> representation = [ ("tt", Typewriter), ("math", Math), ("poly", Poly),+> representation = [ ("tt", Typewriter), ("math", Math), ("poly", Poly), ("markdown", Markdown), > ("verb", Verb), ("code", CodeOnly), ("newcode",NewCode), > ("pre", Pre), ("version", Version), > ("copying", Copying), ("warranty", Warranty), ("help", Help), ("searchpath", SearchPath) ]
src/TeXParser.lhs view
@@ -72,12 +72,12 @@ > (env, '}' : u) -> case encode env of > Nothing -> cont > Just cmd-> | pred v -> Environment cmd (arg ++ w) : classify x+> | p v -> Environment cmd (arg ++ w) : classify x > | otherwise -> notFound end str : cont > where > end = "\\end{" ++ env ++ "}"-> pred = isPrefixOf end-> (arg, v) = breaks maxLine pred u+> p = isPrefixOf end+> (arg, v) = breaks maxLine p u > (w, x) = blank (drop (length end) v) > _ -> cont @@ -92,8 +92,8 @@ > (cmd, '{' : t) -> case encode cmd of > Nothing -> cont-> Just cmd -> case nested maxChar 0 t of-> (a, '}' : u) -> Command cmd a : classify u+> Just cmd' -> case nested maxChar 0 t of+> (a, '}' : u) -> Command cmd' a : classify u > _ -> notFound "matching `}'" str : cont > ([], '%' : t) -> Many "\\%" : classify t > _ -> cont@@ -141,24 +141,24 @@ curly braces. > nested :: Int -> Int -> String -> (String, String)-> nested n depth s = nest n s+> nested n' depth s' = nest n' s' > where-> nest 0 s = ([], s)-> nest n [] = ([], [])+> nest 0 s = ([], s)+> nest _n [] = ([], []) > nest n ('}' : s) > | depth == 0 = ([], '}' : s) > | otherwise = '}' <| nested (n - 1) (depth - 1) s-> nest n ('{' : s) = '{' <| nested (n - 1) (depth + 1) s-> nest n ('\\' : c : s) = '\\' <| c <| nest (n - 2) s-> nest n (c : s) = c <| nest (n - 1) s+> nest n ('{' : s) = '{' <| nested (n - 1) (depth + 1) s+> nest n ('\\' : c : s) = '\\' <| c <| nest (n - 2) s+> nest n (c : s) = c <| nest (n - 1) s The function |verb n c| recognizes arguments enclosed in |c|. > verb :: Int -> Char -> String -> (String, String)-> verb 0 c s = ([], s)-> verb n c [] = ([], [])+> verb 0 _c s = ([], s)+> verb _n _c [] = ([], []) > verb n c (c' : s)-> | c == c' = ([], c' : s) +> | c == c' = ([], c' : s) > | otherwise = c' <| verb (n - 1) c s The function |inline n| recognizes arguments enclosed in vertical bars@@ -166,28 +166,28 @@ equivalent to |verb n '||'|). > inline :: Int -> String -> (String, String)-> inline 0 s = ([], s)-> inline n [] = ([], [])-> inline n ('|' : '|' : s) = '|' <| inline (n - 2) s-> inline n ('|' : s) = ([], '|' : s) -> inline n (c : s) = c <| inline (n - 1) s+> inline 0 s = ([], s)+> inline _n [] = ([], [])+> inline n ('|' : '|' : s) = '|' <| inline (n - 2) s+> inline _n ('|' : s) = ([], '|' : s)+> inline n (c : s) = c <| inline (n - 1) s > > shortverb :: Int -> String -> (String, String)-> shortverb 0 s = ([], s)-> shortverb n [] = ([], [])-> shortverb n ('@' : '@' : s) = '@' <| shortverb (n - 2) s-> shortverb n ('@' : s) = ([], '@' : s) -> shortverb n (c : s) = c <| shortverb (n - 1) s+> shortverb 0 s = ([], s)+> shortverb _n [] = ([], [])+> shortverb n ('@' : '@' : s) = '@' <| shortverb (n - 2) s+> shortverb _n ('@' : s) = ([], '@' : s)+> shortverb n (c : s) = c <| shortverb (n - 1) s The function |unbird| recognizes code sections marked by bird tracks; |blank| skips the next line if it is blank. > unbird :: Char -> String -> (String, String)-> unbird c [] = ([], [])-> unbird c ('\n' : c' : s)+> unbird _c [] = ([], [])+> unbird c ('\n' : c' : s) > | c == c' = '\n' <| ' ' <| unbird c s-> unbird c ('\n' : s) = '\n' <| blank s-> unbird c (c' : s) = c' <| unbird c s+> unbird _c ('\n' : s) = '\n' <| blank s+> unbird c (c' : s) = c' <| unbird c s > > blank :: String -> (String, String) > blank s | all isSpace t = (t, u)@@ -198,10 +198,10 @@ holds and |x| is as small as possible (but at most of length |n|). > breaks :: Int -> ([a] -> Bool) -> [a] -> ([a], [a])-> breaks n pred [] = ([], [])-> breaks n pred as@(a : as')-> | n == 0 || pred as = ([], as)-> | otherwise = a <| breaks (n - 1) pred as'+> breaks _n _p [] = ([], [])+> breaks n p as@(a : as')+> | n == 0 || p as = ([], as)+> | otherwise = a <| breaks (n - 1) p as' % - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - - \subsubsection{Post processing}@@ -209,14 +209,15 @@ Collaps adjacent |One|'s into a |Many|. -> compress = foldr (<|) []+> compress :: [Class] -> [Class]+> compress = foldr (<<|) [] > where-> One '\n' <| ts = Many "\n" : ts-> Many s@('\n' : _) <| ts = Many s : ts-> One c <| (Many s : ts) = Many (c : s) : ts-> One c <| ts = Many [c] : ts-> Many s <| (Many s' : ts) = Many (s ++ s') : ts-> t <| ts = t : ts+> One '\n' <<| ts = Many "\n" : ts+> Many s@('\n' : _) <<| ts = Many s : ts+> One c <<| (Many s : ts) = Many (c : s) : ts+> One c <<| ts = Many [c] : ts+> Many s <<| (Many s' : ts) = Many (s ++ s') : ts+> t <<| ts = t : ts \NB The first two equations make |compress| incrementel (?); otherwise \[@@ -227,10 +228,10 @@ Adding line numbers. > number :: LineNo -> [Class] -> [Numbered Class]-> number n [] = []-> number n (t : ts) = No n t : number (n + i) ts+> number _n [] = []+> number n (t : ts) = No n t : number (n + i) ts > where i = case t of-> One c -> impossible "number"+> One _c -> impossible "number" > Many s -> newlines s > Inline s -> newlines s > Command _ s -> newlines s
src/Typewriter.lhs view
@@ -45,11 +45,11 @@ > latex sp nl dict = tex Empty > where > tex _ (Space s) = sub'spaces (convert False s)-> tex q (Conid s) = replace q s (sub'conid (q <> convert False s))+> tex q (Conid s) = replace q s (sub'conid (q <<>> convert False s)) > tex _ (Varid "") = sub'dummy -- HACK-> tex q (Varid s) = replace q s (sub'varid (q <> convert False s))-> tex q (Consym s) = replace q s (sub'consym (q <> convert False s))-> tex q (Varsym s) = replace q s (sub'varsym (q <> convert False s))+> tex q (Varid s) = replace q s (sub'varid (q <<>> convert False s))+> tex q (Consym s) = replace q s (sub'consym (q <<>> convert False s))+> tex q (Varsym s) = replace q s (sub'varsym (q <<>> convert False s)) > tex _ (Numeral s) = replace Empty s (sub'numeral (convert True s)) -- NEU > tex _ (Char s) = sub'char (catenate (map conv' (init $ tail s))) -- NEW: remove quotes > tex _ (String s) = sub'string (catenate (map conv' (init $ tail s))) -- NEW: remove quotes@@ -60,17 +60,15 @@ > tex _ (Keyword s) = replace Empty s (sub'keyword (convert False s)) > tex _ (TeX False d) = d > tex _ (TeX True d) = sub'tex d-> tex _ t@(Qual ms t') = replace Empty (string t) (tex (catenate (map (\m -> tex Empty (Conid m) <> Text ".") ms)) t')+> tex _ t@(Qual ms t') = replace Empty (string t) (tex (catenate (map (\m -> tex Empty (Conid m) <<>> Text ".") ms)) t') > tex _ t@(Op t') = replace Empty (string t) (sub'backquoted (tex Empty t'))-> where cmd | isConid t'= sub'consym-> | otherwise = sub'varsym > > replace q s def = case FM.lookup s dict of-> Just (_, _, [], ts) -> q <> catenate (map (tex Empty) ts)+> Just (_, _, [], ts) -> q <<>> catenate (map (tex Empty) ts) > _ -> def \NB the directives @%format a = b@ and @%format b = a@ cause a loop.- + \NB Only nullary macros are applied. Conversion of strings and characters. The Boolean indicates whether we
src/Value.lhs view
@@ -16,19 +16,19 @@ Dynamic conversion routines. -> str :: Value -> String +> str :: Value -> String > str Undef = "" > str (Str s) = s > str (Bool b) = if b then "True" else "" > str (Int i) = show i >-> bool :: Value -> Bool +> bool :: Value -> Bool > bool Undef = False > bool (Str s) = not (null s) > bool (Bool b) = b > bool (Int i) = i /= 0 >-> int :: Value -> Int +> int :: Value -> Int > int Undef = 0 > int (Str s) = case reads s of > [(i, [])] -> i@@ -60,27 +60,32 @@ > type Binary a = a -> a -> a > > onStr2 :: Binary String -> Binary Value-> onStr2 (++) v1 v2 = Str (str v1 ++ str v2)+> onStr2 op v1 v2 = Str (str v1 `op` str v2) > > onBool2 :: Binary Bool -> Binary Value-> onBool2 (||) v1 v2 = Bool (bool v1 || bool v2)+> onBool2 op v1 v2 = Bool (bool v1 `op` bool v2) > > onInt2 :: Binary Int -> Binary Value-> onInt2 (+) v1 v2 = Int (int v1 + int v2)+> onInt2 op v1 v2 = Int (int v1 `op` int v2) %align 41 {\setlength{\lwidth}{5.5cm} -> onMatching f g h Undef (Str s2) = Bool (f (str Undef) s2)-> onMatching f g h (Str s1) Undef = Bool (f s1 (str Undef))-> onMatching f g h (Str s1) (Str s2) = Bool (f s1 s2)-> onMatching f g h Undef (Bool b2) = Bool (g (bool Undef) b2)-> onMatching f g h (Bool b1) Undef = Bool (g b1 (bool Undef))-> onMatching f g h (Bool b1) (Bool b2) = Bool (g b1 b2)-> onMatching f g h Undef (Int i2) = Bool (h (int Undef) i2)-> onMatching f g h (Int i1) Undef = Bool (h i1 (int Undef))-> onMatching f g h (Int i1) (Int i2) = Bool (h i1 i2)-> onMatching _ _ _ _ _ = Bool False+> onMatching ::+> (String -> String -> Bool)+> -> (Bool -> Bool -> Bool)+> -> (Int -> Int -> Bool)+> -> Value -> Value -> Value+> onMatching f _g _h Undef (Str s2) = Bool (f (str Undef) s2)+> onMatching f _g _h (Str s1) Undef = Bool (f s1 (str Undef))+> onMatching f _g _h (Str s1) (Str s2) = Bool (f s1 s2)+> onMatching _f g _h Undef (Bool b2) = Bool (g (bool Undef) b2)+> onMatching _f g _h (Bool b1) Undef = Bool (g b1 (bool Undef))+> onMatching _f g _h (Bool b1) (Bool b2) = Bool (g b1 b2)+> onMatching _f _g h Undef (Int i2) = Bool (h (int Undef) i2)+> onMatching _f _g h (Int i1) Undef = Bool (h i1 (int Undef))+> onMatching _f _g h (Int i1) (Int i2) = Bool (h i1 i2)+> onMatching _ _ _ _ _ = Bool False } %}
src/Verbatim.lhs view
@@ -37,8 +37,8 @@ > >>> sub'verbatim > > splice :: [Doc] -> Doc-> splice ds = Text "~" <> catenate (intersperse nl ds)-> where nl = Text "!" <> sub'verbnl <> Text "!"+> splice ds = Text "~" <<>> catenate (intersperse nl ds)+> where nl = Text "!" <<>> sub'verbnl <<>> Text "!" > > latexs :: Bool -> String -> Doc > latexs b = catenate . map latex@@ -75,9 +75,9 @@ Expanding tabs (assuming a tabulator width of $8$ characters). > expand :: Int -> String -> String-> expand n [] = []-> expand n ('\n' : s) = '\n' : expand 0 s-> expand n ('\t' : s) = replicate (n' - n) ' ' ++ expand n' s+> expand _n [] = []+> expand _n ('\n' : s) = '\n' : expand 0 s+> expand n ('\t' : s) = replicate (n' - n) ' ' ++ expand n' s > where n' = (n + 8) `div` 8 * 8-> expand n (c : s) = c : expand (n + 1) s+> expand n (c : s) = c : expand (n + 1) s
src/Version.lhs.in view
@@ -21,12 +21,14 @@ > pre :: Int > pre = @PRE@ +> isWindows :: Bool > isWindows = "win" `isPrefixOf` os || "Win" `isPrefixOf` os % - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - - \subsubsection{Search path} % - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - - +> searchPath :: [FilePath] > searchPath = "." : > [ deep (joinPath (env "HOME" : [p ++ x])) > | p <- ["","."]@@ -50,6 +52,7 @@ > ,"lhs2TeX" > ] >+> stydir :: FilePath > stydir = replace (replace "@stydir@" "datarootdir" "@datarootdir@") "prefix" "@prefix@" > where replace x w y | ("$" ++ w) `isPrefixOf` x = y ++ drop (length w + 1) x > | ("${" ++ w ++ "}") `isPrefixOf` x = y ++ drop (length w + 3) x