--- /dev/null
+ghcroot = /usr/local/brian/ghc
+pwd = $(shell pwd)
+ghc = $(ghcroot)/compiler/ghc-inplace -fallow-undecidable-instances -fallow-overlapping-instances
+ghc += -fglasgow-exts -cpp -hidir $(pwd)/build/hi -i$(pwd)/build/hi -odir $(pwd)/build/class/
+ghclibs = $(ghcroot)/rts/HSrts.jar:$(ghcroot)/libraries/base/HSbase.jar:$(ghcroot)/libraries/stm/HSstm.jar
+
+java = java -Xmx800m
+java += $(profile) -cp $(ghclibs):lib/edu.berkeley.sbp.jar:build/class
+
+run: build/class/Main.class build/class/Tib.class
+ $(java) HaskellHelper xt html
+
+install: build/class/Main.class build/class/Tib.class
+ $(java) HaskellHelper xt/ ~/www/
+
+install2: build/class/Main.class build/class/Tib.class
+# $(java) HaskellHelper xt/slipway/ ~/www/slipway/
+# $(java) HaskellHelper xt/research/ ~/www/research/
+# $(java) HaskellHelper xt/research.cs.berkeley.edu/ ~/www/research.cs.berkeley.edu/
+# $(java) HaskellHelper xt/random/ ~/www/random/
+# $(java) HaskellHelper xt/otherpeople/ ~/www/otherpeople/
+# $(java) HaskellHelper xt/sbp ~/www/sbp
+ $(java) HaskellHelper xt/software/wix ~/www/software/wix
+# $(java) HaskellHelper xt/thoughts ~/www/thoughts
+# $(java) HaskellHelper xt2 ~/
+
+docs:
+ $(java) HaskellHelper xt2/docs/ ~/docs/
+
+debug: build/class/Main.class build/class/Tib.class
+ $(java) -Dsbp.verbose=true HaskellHelper xt html
+
+wix.jar: build/class/Main.class build/class/Tib.class
+ rm -rf tmp
+ mkdir tmp
+ cd build/class; for A in $(ghcroot)/rts/HSrts.jar $(ghcroot)/libraries/base/HSbase.jar $(ghcroot)/libraries/stm/HSstm.jar ../../lib/edu.berkeley.sbp.jar; \
+ do jar xvf $$A; done
+ echo 'Main-Class: HaskellHelper' > build/manifest
+ cd build/class; jar cvmf ../manifest ../../wix.jar .
+
+build/class/Tib.class: $(shell find src -name \*.java)
+ javac -d build/class -cp lib/edu.berkeley.sbp.jar $(shell find src -name \*.java)
+
+build/class/Main.class: $(shell find src -name \*.lhs)
+ mkdir -p build/class/Text/PrettyPrint
+ mkdir -p build/hi
+ cd src; $(ghc) -c -java Util.lhs
+ cd src; $(ghc) -c -java Text/PrettyPrint/Leijen.hs
+ cd src; $(ghc) -c -java SBP.lhs
+ cd src; $(ghc) -c -java FromTree.lhs
+ cd src; $(ghc) -c -java Doc.lhs
+ cd src; $(ghc) -c -java Html.lhs
+ cd src; $(ghc) -c -java Wix.lhs
+ cd src; $(ghc) -c -java Main.lhs
+
+clean:; rm -rf build
\ No newline at end of file
--- /dev/null
+\begin{code}
+module Doc
+where
+import Numeric
+import Data.Bits
+import Data.Char
+import SBP
+import Util
+import FromTree
+import qualified Text.PrettyPrint.Leijen as PP
+
+data Doc = Doc Header [Section]
+data Header = Header -- not yet specified
+
+data Section = Section
+ Int -- heading level
+ [Text] -- title
+ [Paragraph] -- content
+
+data Paragraph = Blockquote [Paragraph]
+ | P [Text]
+ | OL [[Paragraph]] -- list of items; each item is a [Paragraph]
+ | UL [[Paragraph]]
+ | HR
+
+data Style = TT | Underline | Superscript | Subscript
+ | Strikethrough | Italic | Bold | Highlight
+
+data Text = WS
+ | Chars String
+ | Quotes [Text]
+ | GlyphText Glyph
+ | Math String
+ | Command String [Text]
+ | Verbatim String
+ | Link [Text] URL
+ | Footnote [Text]
+ | Styled Style [Text]
+ | Keyword [Text]
+ | SubPar [Paragraph]
+
+data Glyph = Euro | CircleR | CircleC | TradeMark | ServiceMark
+ | Emdash | Ellipsis | Cent | Daggar | DoubleDaggar
+ | Clover | Flat | Sharp | Natural | CheckMark | XMark
+ | LeftArrow | DoubleLeftArrow | DoubleRightArrow
+ | DoubleLeftRightArrow | LeftRightArrow | Degree
+
+data Login = Login String (Maybe String)
+data URL = URLPath String
+ | Email String Host
+ | URL { url_method :: String,
+ url_login :: Maybe Login,
+ url_host :: Host,
+ url_port :: Maybe Int,
+ url_path :: String,
+ url_ref :: Maybe String }
+data Host = IP Int Int Int Int
+ | DNS [String]
+
+-- Doc ------------------------------------------------------------------------------
+
+instance PP.Pretty Doc where
+ pretty _ = PP.text $ "<not implemented>"
+
+instance FromTree Doc where
+ fromTree (Tree "Doc" [a,b] _) = Doc Header $ fromTree b
+ fromTree t = error $ "unable to create Doc from " ++ (show t)
+
+-- Section ------------------------------------------------------------------------------
+
+instance FromTree Section where
+ fromTree (Tree "Section" ((Tree "SectionHeader" [(Tree "=" e _),c] _):p) _) =
+ Section ((length e)-1) (fromTree c) $ concatMap fromTree p
+ fromTree t = error $ "couldnt Section.FromTree on " ++ (show t)
+
+-- Paragraph ------------------------------------------------------------------------------
+
+instance FromTrees [Paragraph] where
+ fromTrees ts = consolidate $ concatMap fromTree ts
+instance FromTree [Paragraph] where
+ fromTree t = consolidate $ fromTree' t
+ where
+ fromTree' (Tree "Verbatim" [ident,v] _) = [P [(Verbatim $ unindent ident $ unverbate v)]]
+ fromTree' (Tree "TextParagraph" [(Tree _ text _)] _) = [P $ concatMap fromTree text]
+ fromTree' (Tree "Pars" pars _) = concatMap fromTree pars
+ fromTree' (Tree "HR" _ _) = [HR]
+ fromTree' (Tree "OL" a _) = [OL $ map (\(Tree "LI" x _) -> fromTrees x) a]
+ fromTree' (Tree "UL" a _) = [UL $ map (\(Tree "LI" x _) -> fromTrees x) a]
+ fromTree' (Tree "" _ _) = []
+ fromTree' (Tree "Blockquote" pars _) = [Blockquote $ fromTrees pars]
+ fromTree' t = error $ "unable to create [Paragraph] from " ++ (show t)
+
+consolidate [] = []
+consolidate [a] = [a]
+consolidate ((OL []):x) = consolidate x
+consolidate ((UL []):x) = consolidate x
+consolidate ((OL a):(OL b):x) = consolidate ((OL $ a++b):x)
+consolidate ((UL a):(UL b):x) = consolidate ((UL $ a++b):x)
+consolidate (a:b) = a:(consolidate b)
+
+-- Verbatim ------------------------------------------------------------------------------
+
+unverbate (Tree "Verbatim" x _) = concatMap unverbate x
+unverbate (Tree "VerbatimBrace" [x,y] _) = (unverbate x)++" "++(unverbate y)
+unverbate (Tree t [] _) = t
+
+unindent (Tree "I" indent _) v = unindent' ((length indent)+1) v
+ where
+ unindent' i ('\n':x) = '\n':(unindent' i (drop' i x))
+ unindent' i (a:b) = a:(unindent' i b)
+ unindent' i [] = []
+ drop' 0 x = x
+ drop' n x@('\n':r) = x
+ drop' n [] = []
+ drop' n (a:b) = drop' (n-1) b
+
+-- Text ------------------------------------------------------------------------------
+
+instance FromTree [Text] where
+ fromTree (Tree "Word" chars _) = [Chars $ concatMap fromTree chars]
+ fromTree (Tree "Ordinal" x _) = [Command "ordinal" $ [Chars (show x)]]
+ fromTree (Tree "Fraction" [n,d] _) = [Command "fraction" $ [(Chars (show n)), (Chars (show d))]]
+ fromTree (Tree "WS" _ _) = [WS]
+ fromTree (Tree "Quotes" [x] _) = [Quotes $ fromTree x]
+ fromTree (Tree "Pars" y _) = [SubPar $ fromTrees y]
+ fromTree (Tree "Command" [x,y] _) = [Command (fromTree x) (fromTree y)]
+ fromTree (Tree "Command" [x] _) = [Command (fromTree x) []]
+ fromTree (Tree "Link" [word,link] _) = [Link (fromTree word) (fromTree link)]
+ fromTree (Tree "Footnote" x _) = [Footnote $ concatMap fromTree x]
+ fromTree (Tree "Keyword" x _) = [Keyword $ concatMap fromTree x]
+ fromTree (Tree "Math" x _) = [Math $ fromTrees x]
+ fromTree (Tree "TT" x _) = [Styled TT $ concatMap fromTree x]
+ fromTree (Tree "Italic" [x] _) = [Styled Italic $ fromTree x]
+ fromTree (Tree "Bold" [x] _) = [Styled Bold $ fromTree x]
+ fromTree (Tree "Highlight" [x] _) = [Styled Highlight $ fromTree x]
+ fromTree (Tree "Strikethrough" x _) = [Styled Strikethrough $ concatMap fromTree x]
+ fromTree (Tree "Superscript" x _) = [Styled Superscript $ concatMap fromTree x]
+ fromTree (Tree "Subscript" x _) = [Styled Subscript $ concatMap fromTree x]
+ fromTree (Tree "Underline" x _) = [Styled Underline $ concatMap fromTree x]
+ fromTree (Tree "(e)" _ _) = [GlyphText Euro]
+ fromTree (Tree "(r)" _ _) = [GlyphText CircleR]
+ fromTree (Tree "(c)" _ _) = [GlyphText CircleC]
+ fromTree (Tree "(tm)" _ _) = [GlyphText TradeMark]
+ fromTree (Tree "--" _ _) = [GlyphText Emdash]
+ fromTree (Tree "<-" _ _) = [GlyphText LeftArrow]
+ fromTree (Tree "<=" _ _) = [GlyphText DoubleLeftArrow]
+ fromTree (Tree "=>" _ _) = [GlyphText DoubleRightArrow]
+ fromTree (Tree "<=>" _ _) = [GlyphText DoubleLeftRightArrow]
+ fromTree (Tree "<->" _ _) = [GlyphText LeftRightArrow]
+ fromTree (Tree "^o" _ _) = [GlyphText Degree]
+ fromTree (Tree "..." _ _) = [GlyphText Ellipsis]
+ fromTree (Tree "Text" t _) = concatMap fromTree t
+ fromTree (Tree "" [] _) = []
+ fromTree t = error $ "unable to create [Text] from " ++ (show t)
+
+-- URLs ------------------------------------------------------------------------------
+
+instance Show Login where
+ show (Login name Nothing) = name
+ show (Login name (Just pass)) = name++":"++(urlEscape pass)
+
+instance Show URL where
+ show (URLPath up) = up
+ show (Email s h) = "mailto:" ++ s ++ "@" ++ (show h)
+ show (URL { url_method=m, url_login=l, url_host=h, url_port=port, url_path=path, url_ref=ref }) =
+ m++"://"++
+ (case l of
+ Nothing -> ""
+ (Just log) -> (show log)++"@")
+ ++(show h)
+ ++"/"
+ ++(urlEscape path)
+ ++(case ref of
+ Nothing -> ""
+ (Just []) -> ""
+ (Just j) -> "#"++(urlEscape j))
+
+instance FromTree URL where
+ fromTree (Tree "URL" stuff _) = fromTrees stuff
+ fromTree (Tree "Email" [(Tree "username" un _),host] _) = Email (fromTrees un) (fromTree host)
+ fromTree (Tree "Path" stuff _) = URLPath $ map fromUrlChar stuff
+ where
+ fromUrlChar (Tree "%" [(Tree a [] _),(Tree b [] _)] _) = chr $ (fst $ head $ readHex (a++b))
+ fromUrlChar (Tree [c] [] _) = c
+ fromUrlChar t = error $ "could not parse as an url char: " ++ (show t)
+
+fromTreeChildren (Tree _ c _) = fromTrees c
+instance FromTrees URL where
+ fromTrees (method:login:host:port:rest) =
+ URL { url_method = fromTreeChildren method,
+ url_host = fromTree host,
+ url_login = Nothing,
+ url_port = case port of { (Tree "Port" port _) -> Just $ fromTrees port; _ -> Nothing },
+ url_path = case rest of { ((Tree "Path" p _):_) -> fromTrees p; _ -> "" },
+ url_ref = case rest of { (_:(Tree "Path" r _):_) -> Just $ fromTrees r; _ -> Nothing }
+ }
+ fromTrees x = error $ show x
+
+instance Show Host where
+ show (IP a b c d) = (show a)++"."++(show b)++"."++(show c)++"."++(show d)
+ show (DNS host) = join "." host
+
+instance FromTree Host where
+ fromTree (Tree "IP" (a:b:c:d:[]) _) =
+ IP (fromTreeChildren a) (fromTreeChildren b) (fromTreeChildren c) (fromTreeChildren d)
+ fromTree (Tree "DNS" parts _) = DNS $ map (\(Tree _ c _) -> fromTrees c) parts
+
+urlEscape s = concatMap urlEscapeChar s
+ where
+ -- non-alphanumerics which may appear unescaped
+ urlEscapeChar '$' = "$"
+ urlEscapeChar '-' = "-"
+ urlEscapeChar '_' = "_"
+ urlEscapeChar '.' = "."
+ urlEscapeChar '!' = "!"
+ urlEscapeChar '*' = "*"
+ urlEscapeChar '\'' = "\'"
+ urlEscapeChar '(' = "("
+ urlEscapeChar ')' = ")"
+ urlEscapeChar ',' = ","
+
+ -- technically these aren't allowed by RFC, but we include them anyways
+ urlEscapeChar '/' = "/"
+ urlEscapeChar ';' = ";"
+ urlEscapeChar '&' = "&"
+ urlEscapeChar '=' = "="
+ urlEscapeChar '$' = "$"
+
+ -- FIXME: this will wind up "disencoding" a %-encoded question mark
+ urlEscapeChar '?' = "?"
+
+ urlEscapeChar c | c >= 'a' && c <= 'z' = [c]
+ | c >= 'A' && c <= 'Z' = [c]
+ | c >= '0' && c <= '9' = [c]
+
+ -- encoded
+ | otherwise = '%':d1:d2:[]
+ where i = ord c
+ d1 = head $ showHex ((i .&. 0xff) `shiftR` 4) ""
+ d2 = head $ showHex ((i .&. 0x0f)) ""
+
+\end{code}
--- /dev/null
+\begin{code}
+module FromTree
+where
+import SBP
+
+class FromTree a where
+ fromTree :: Tree -> a
+class FromTrees a where
+ fromTrees :: [Tree] -> a
+instance FromTree a => FromTree [a] where
+ fromTree (Tree _ c _) = map fromTree c
+instance FromTree a => FromTrees [a] where
+ fromTrees c = map fromTree c
+
+instance FromTree String where
+ fromTree (Tree h c _) = h++(concatMap fromTree c)
+instance FromTrees String where
+ fromTrees ts = concatMap (fromTree :: Tree -> String) ts
+
+instance FromTree Int where
+ fromTree t = read $ fromTree t
+instance FromTrees Int where
+ fromTrees t = read $ fromTrees t
+
+\end{code}
--- /dev/null
+// Copyright 2006 all rights reserved; see LICENSE file for BSD-style license
+
+import edu.berkeley.sbp.*;
+import edu.berkeley.sbp.misc.*;
+import edu.berkeley.sbp.util.*;
+import edu.berkeley.sbp.meta.*;
+import edu.berkeley.sbp.chr.*;
+import java.io.*;
+
+public class HaskellHelper {
+ public static boolean isNull(Object o) { return o==null; }
+
+ private static CharParser parser = null;
+ static {
+ synchronized(HaskellHelper.class) {
+ if (parser == null) {
+ try {
+ // FIXME: bundle this into the jarfile
+ File grammarFile = new File("src/wix.g");
+ Tree<String> res = new CharParser(MetaGrammar.newInstance())
+ .parse(new FileInputStream(grammarFile)).expand1();
+ Union grammar = GrammarAST.buildFromAST(res, "s", new File[] {
+ new File(grammarFile.getParent())
+ });
+ parser = new CharParser(grammar);
+ } catch (Exception e) {
+ throw new RuntimeException(e);
+ }
+ }
+ }
+ }
+
+ public static Tree help(String targetFile) throws Throwable {
+ Tree ret = null;
+ try {
+ Reader r = new InputStreamReader(new FileInputStream(targetFile));
+ Input input = new CharInput(new IndentingReader(r, CharAtom.left, CharAtom.right));
+ ret = parser.parse(input).expand1();
+ } catch (Throwable e) {
+ e.printStackTrace();
+ throw e;
+ }
+ if (ret==null) throw new NullPointerException("CharParser returned null");
+ return ret;
+ }
+
+ public static void main(String[] argv) throws Throwable {
+ if (argv.length != 2) {
+ System.out.println("usage: java -jar wix.jar [-v] <indir> <outdir>");
+ // FIXME: implement this
+ System.out.println(" | java -jar wix.jar [-v] <infile>.wix");
+ System.out.println("");
+ // FIXME: implement these
+ System.out.println(" -v print text as it is parsed (sbp.verbose=true)");
+ System.out.println(" -vv like -v, but also dump parse tree");
+ System.out.println(" -vvv like -vv, but also dump wix tree");
+ System.exit(-1);
+ return;
+ }
+ File indir = new File(argv[0]);
+ File outdir = new File(argv[1]);
+ process(indir, "", outdir);
+ }
+
+ private static void process(File indir, String suffix, File outdir) throws Throwable {
+ File f = new File(indir.getAbsolutePath()+suffix);
+ if (!f.exists()) return;
+ if (f.isDirectory()) {
+ for (String s : f.list())
+ process(indir, suffix + File.separatorChar + s, outdir);
+ return;
+ }
+ if (f.getPath().endsWith(".wix")) {
+ System.out.println();
+ String out = "== " + suffix + " ";
+ while(out.length() < 75) out+="=";
+ System.out.println(ANSI.yellow(out));
+ Class.forName("Main").
+ getMethod("main", new Class[] { String[].class }).
+ invoke(null, new Object[] { new String[] { f.getAbsolutePath() } });
+ String outPath = outdir.getAbsolutePath()+suffix;
+ outPath = outPath.substring(0, outPath.length()-".wix".length())+".html";
+ new File(new File(outPath).getParent()).mkdirs();
+ PrintWriter pw = new PrintWriter(new OutputStreamWriter(new FileOutputStream(outPath+"+")));
+ pw.println(ret);
+ pw.flush();
+ pw.close();
+ File dest = new File(outPath);
+ if (dest.exists()) {
+ try {
+ Process p = Runtime.getRuntime().exec(new String[] {
+ "diff",
+ "-Bub",
+ dest.getAbsolutePath(),
+ new File(outPath+"+").getAbsolutePath()
+ });
+ BufferedReader br = new BufferedReader(new InputStreamReader(p.getInputStream()));
+ br.readLine();
+ br.readLine();
+ for(String s = br.readLine(); s != null; s = br.readLine()) {
+ if (s.startsWith("+")) System.out.println(ANSI.green(s));
+ else if (s.startsWith("-")) System.out.println(ANSI.red(s));
+ /*else System.out.println(ANSI.blue(s));*/
+ }
+ p.waitFor();
+ } catch (Exception e) {
+ e.printStackTrace();
+ }
+ }
+ new File(outPath+"+").renameTo(dest);
+ }
+ }
+
+ public static Object ret;
+ public static void putBack(String o) { ret = o; }
+}
--- /dev/null
+\begin{code}
+module Html
+where
+import SBP
+import FromTree
+import Doc
+import List(isSuffixOf,isPrefixOf)
+
+-- FIXME: use pretty-printing when asked to for better display
+
+class ToHtml a where
+ toHtml :: a -> String
+instance ToHtml a => ToHtml [a] where
+ toHtml x = concatMap toHtml x
+
+style =
+ "\n<style>\n"++
+ " h1, h2, h3, h4 { font-family: 'Trebuchet MS', arial, verdana, sans-serif; width: 100% }\n"++
+ " h1 { font-size: 20pt; border-top: black 1px solid; }\n"++
+ " h2 { font-size: 16pt; border-top: silver 1px solid; }\n"++
+ " h3 { font-size: 12pt; }\n"++
+ " TH, TD, P, LI, DIV, SPAN {\n"++
+ " font-family: verdana, arial, sans-serif;\n"++
+ " font-size: 12px; \n"++
+ " text-decoration:none; \n"++
+ " }\n"++
+ " LI { margin-top: 5px; }\n"++
+ " body { color: #333333; }\n"++
+ " blockquote { font-style: italic; width: 100% }\n"++
+ " div.warn { border: 1px solid red; background-color: #fbb; color: white; }\n"++
+ " td.warn { color: black; }\n"++
+ " div.announce { border: 1px solid green; background-color: #bfb; color: white; }\n"++
+ " td.announce { color: black; }\n"++
+ " div.footer {\n"++
+ " color: gray;\n"++
+ " border-top: 1px solid silver;\n"++
+ " font-size: 10px;\n"++
+ " }\n"++
+ " table.blockquote { margin: 5px; border: 1px #e6ddcb solid; background-color: #fbf2e0; width: 100% }\n"++
+ " a:link { text-decoration: none; color: blue; border-bottom:1px dotted; }\n"++
+ " a:visited { text-decoration: none; color: purple; border-bottom:1px dotted; }\n"++
+ " a:active { text-decoration: none; color: red; border-bottom:1px solid; }\n"++
+ " a:hover { text-decoration: none; border-bottom:1px solid; }\n"++
+ " table.footer { border-top: silver solid 1px; }\n"++
+ " span.signature { color: #bbb; }\n"++
+ " .signature a:link { color: #bbb; }\n"++
+ " .signature a:visited { color: #bbb; }\n"++
+ " .signature a:hover { color: blue; border-bottom: 1px solid blue; }\n"++
+ " span.highlight { background: yellow; color: black; padding: 3px }\n"++
+ " div.pre {\n"++
+ " text-align: left;\n"++
+ " font-family: monospace;\n"++
+ " border-style: solid;\n"++
+ " border-width: 2px 2px 2px 2px;\n"++
+ " border-color: #6666aa;\n"++
+ " color: #FFFFFF;\n"++
+ " background-color: #000000;\n"++
+ " margin-right: 25px;\n"++
+ " margin-left: 25px;\n"++
+ " padding: 10px;\n"++
+ " }\n"++
+ "</style>\n"
+
+
+instance ToHtml Doc where
+ toHtml (Doc h secs) =
+ "<!-- This document was AUTOMATICALLY GENERATED from wix source -->\n"++
+ "<!-- it is probably not a wise idea to edit it directly -->\n\n"++
+ "<html>\n"++
+ "<head>\n"++
+ style++
+ --FIXME: title tag
+ "</head>\n"++
+ "<body>\n"++ -- tell jsmath we will escape stuff manually
+
+ -- FIXME: only put this in if math appears on the page
+ "<script> jsMath = { showFontWarnings: false } </script>\n"++
+ "<script src='/jsmath/easy/load.js'></script>\n"++
+ "<span id='tex2math_off'></span>\n"++
+ "<NOSCRIPT> <DIV STYLE='color:#CC0000; text-align:center'> <B>Warning: <A HREF='http://www.math.union.edu/locate/jsMath'>jsMath</A> requires JavaScript to process the mathematics on this page.<BR> If your browser supports JavaScript, be sure it is enabled.</B> </DIV> <HR> </NOSCRIPT>\n"++
+
+ "<center><table><tr><td width=600>\n"++
+ (toHtml secs) ++
+ "<br><br>\n"++
+ "<table width=100% class=footer><tr><td align=left>"++
+ "<img src=/images/print.icon.png></td>"++
+ "<td align=right><span class='signature'>rendered from "++
+ "<a href=http://www.megacz.com/software/wix>"++
+ "W<span style='vertical-align:-20%'>I</span>X</a></span></div></td></tr></table>\n"++
+ "</td></tr></table></center>\n"++
+ "</body></html>"
+
+instance ToHtml Section where
+ toHtml (Section level header paragraphs) =
+ "\n<h"++(show (level+1))++">\n"++
+ (toHtml header)++
+ "\n</h"++(show (level+1))++">\n"++
+ (toHtml paragraphs)
+stag t body = "\n<"++t++">\n"++body++"\n</"++t++">\n"
+tag t body = "<"++t++">"++body++"</"++t++">"
+
+instance ToHtml Paragraph where
+ toHtml (Blockquote t) = "\n<table class=blockquote border=0 cellpadding=5px>\n"
+ ++"<tr><td valign=top><image src=/images/blockquote.png></td>\n"
+ ++"<td class=warn>\n"
+ ++(toHtml t)
+ ++"</td></tr></table>\n"
+ toHtml HR = stag "hr" []
+ toHtml (OL t) = stag "ol" $ concatMap (\x -> stag "li" $ concatMap toHtml x) t
+ toHtml (UL t) = stag "ul" $ concatMap (\x -> stag "li" $ concatMap toHtml x) t
+ toHtml (P t) = stag "p" $ toHtml t
+
+
+link ref body = "<a href='"++ref++"'>"++icon++body++"</a>"
+ where
+ icon = if ".pdf" `isSuffixOf` ref then "<img "++img++" src=/images/pdf.icon.png> "
+ else if "mailto:" `isPrefixOf` ref then "<img "++img++" src=/images/email.icon.png> "
+ else ""
+ img = "style='vertical-align: text-bottom;' border=0 "
+-- margin-bottom: -2px; padding-bottom: 2px; border-bottom: 1px blue solid;
+
+instance ToHtml Text where
+ toHtml WS = " "
+ toHtml (Chars s) = toHtml s
+
+ -- directional quotes: see http://www.dwheeler.com/essays/quotes-in-html.html
+ toHtml (Quotes x) = "“"++(toHtml x)++"”"
+ toHtml (Verbatim x) = pre x
+ toHtml (Link t ref) = link (show ref) (toHtml t)
+ toHtml (Command "url" y) = "<tt>"++(link (toHtml y) (toHtml y))++"</tt>"
+ toHtml (Command "WiX" y) = "W<span style='vertical-align:-20%'>I</span>X"
+ toHtml (Command "TeX" y) = "T<span style='vertical-align:-20%'>E</span>X"
+-- u'1/2' : u'\u00BD',
+-- u'1/4' : u'\u00BC',
+-- u'3/4' : u'\u00BE',
+-- u'1/3' : u'\u2153',
+-- u'2/3' : u'\u2154',
+-- u'1/5' : u'\u2155',
+-- u'2/5' : u'\u2156',
+-- u'3/5' : u'\u2157',
+-- u'4/5' : u'\u2158',
+-- u'1/6' : u'\u2159',
+-- u'5/6' : u'\u215A',
+-- u'1/8' : u'\u215B',
+-- u'3/8' : u'\u215C',
+-- u'5/8' : u'\u215D',
+-- u'7/8' : u'\u215E',
+
+ toHtml (Styled Underline x) = tag "u" $ toHtml x
+ toHtml (Styled TT x) = tag "tt" $ toHtml x
+ toHtml (Styled Italic x) = tag "i" $ toHtml x
+ toHtml (Styled Strikethrough x) = tag "strike" $ toHtml x
+ toHtml (Styled Superscript x) = tag "sup" $ toHtml x
+ toHtml (Styled Subscript x) = tag "sub" $ toHtml x
+ toHtml (Styled Bold x) = tag "b" $ toHtml x
+ toHtml (Styled Highlight x) = "<span class=highlight>"++(toHtml x)++"</span>"
+
+ toHtml (Keyword x) = tag "tt" $ toHtml x
+ toHtml (SubPar x) = stag "p" $ concatMap toHtml x
+
+ toHtml (Command "red" y) = "<font color=red>"++(toHtml y)++"</font>"
+ toHtml (Command "orange" y) = "<font color=orange>"++(toHtml y)++"</font>"
+ toHtml (Command "green" y) = "<font color=green>"++(toHtml y)++"</font>"
+ toHtml (Command "sc" y) = "<sc>"++(toHtml y)++"</sc>"
+ toHtml (Command "image" y) = "<img src='"++(toHtml y)++"'/>"
+ toHtml (Command "image3" y) = "<img width=200px src='"++(toHtml y)++"'/>"
+ toHtml (Command "image4" y) = "<center><img width=550px src='"++(toHtml y)++"'/></center>"
+ toHtml (Command "warn" y) = "\n<div class=warn>\n<table border=0 cellpadding=5px>\n"
+ ++"<tr><td valign=top><image src=/images/warn.png></td>\n"
+ ++"<td class=warn>\n"
+ ++(toHtml y)
+ ++"</td></tr></table></div>\n"
+ toHtml (Command "announce" y) = "\n<div class=announce>\n<table border=0 cellpadding=5px>\n"
+ ++"<tr><td valign=top></td>\n"
+ ++"<td class=warn>\n"
+ ++(toHtml y)
+ ++"</td></tr></table></div>\n"
+ toHtml (Command "br" _) = "\n<br/>\n"
+ toHtml (Command "cent" _) = "½"
+ toHtml (Command "euro" _) = "€"
+ toHtml (Command "ordinal" x) = (toHtml x)++"<sup>"++"th"++"</sup>"
+ -- FIXME: use "unicode vulgar fractions" here
+ toHtml (Command "fraction" [n,d]) = "<sup>"++(toHtml n)++"</sup>"++"/"++"<sub>"++(toHtml d)++"</sub>"
+ toHtml (Command "rfc" x) = "<tt><a href=http://tools.ietf.org/html/rfc"++(toHtml x)++">RFC"++(toHtml x)++"</a></tt>"
+
+ -- FIXME: add div as well (for display-mode math)
+ toHtml (Math m) = "<span class=math>" ++ (toHtml m) ++ "</span>"
+ toHtml (Footnote x) = error $ "footnotes not supported"
+
+ toHtml (GlyphText Euro) = "€"
+ toHtml (GlyphText CircleR) = "¢"
+ toHtml (GlyphText CircleC) = "®"
+ toHtml (GlyphText TradeMark) = "™"
+ toHtml (GlyphText ServiceMark) = "™"
+ toHtml (GlyphText Emdash) = "—"
+ toHtml (GlyphText Ellipsis) = "…"
+ toHtml (GlyphText Cent) = "½"
+ toHtml (GlyphText Daggar) = "†"
+ toHtml (GlyphText DoubleDaggar) = "‡"
+ toHtml (GlyphText Clover) = "⌘"
+ toHtml (GlyphText Flat) = "⋖"
+ toHtml (GlyphText Natural) = "⋗"
+ toHtml (GlyphText Sharp) = "⋘"
+ toHtml (GlyphText CheckMark) = "✓"
+ toHtml (GlyphText XMark) = "✗"
+ toHtml (GlyphText LeftArrow) = "&#;" -- FIXME
+ toHtml (GlyphText DoubleLeftArrow) = "&#;" -- FIXME
+ toHtml (GlyphText DoubleRightArrow) = "&#;" -- FIXME
+ toHtml (GlyphText DoubleLeftRightArrow) = "&#;" -- FIXME
+ toHtml (GlyphText LeftRightArrow) = "&#;" -- FIXME
+ toHtml (GlyphText Degree) = "&#;" -- FIXME
+
+ toHtml (Command ('k':'e':'y':'s':'t':'r':'o':'k':'e':':':k) _) =
+ "&#x"++(case k of
+ "command" -> "2318"
+ "shift" -> "21E7"
+ "option" -> "2325"
+ "control" -> "2303"
+ "capslock" -> "21EA"
+ "apple" -> "F8FF"
+ )++";"
+ toHtml (Command x y) = error $ "unsupported command "++(show x)
+
+instance ToHtml String where
+ toHtml s = concatMap htmlEscapeChar s
+ where
+ htmlEscapeChar '<' = "<"
+ htmlEscapeChar '>' = ">"
+ htmlEscapeChar '&' = "&"
+ htmlEscapeChar '\'' = "'"
+ htmlEscapeChar '\"' = """
+ htmlEscapeChar c = [c]
+
+pre x = "\n<div class=pre>"++ (pre' x) ++ "\n</div>\n"
+ where
+ pre' (' ':b) = " "++(pre' b)
+ pre' ('\n':b) = "<br/>\n"++(pre' b)
+ pre' (a:b) = a:(pre' b)
+ pre' [] = []
+\end{code}
--- /dev/null
+\begin{code}
+module Main
+where
+import Wix(main')
+import System
+
+main = do x <- getArgs
+ main' (head x) 0
+
+\end{code}
--- /dev/null
+\begin{code}
+--
+-- These bindings are highly experimental and subject to change
+-- without notice. You've been warned.
+--
+module SBP(Tree(Tree),Location(Location),Region(Region),parseFile,prettyPrintTree,coalesceFlatHeadlessNodes)
+where
+
+#if defined(java_HOST_OS)
+import Foreign
+import Foreign.Java
+#define CONCAT(x,y) x/**/y
+#define DEFINE_OBJECT(s,name) \
+data CONCAT(name,_); \
+type name = JObject CONCAT(name,_); \
+foreign import jvm s CONCAT(_,name) :: JClass; \
+instance JType_ CONCAT(name,_) where jClass_ _ = CONCAT(_,name);
+#else
+import Header_Java;
+import Class_HaskellHelper;
+import Class_java_lang_Object;
+import Class_java_lang_Class;
+import Class_java_lang_String;
+import Class_edu_berkeley_sbp_Tree;
+import Header_edu_berkeley_sbp_Tree;
+import JVM_HaskellHelper;
+import Header_HaskellHelper;
+import TypedString;
+import JVMBridge;
+import JavaText;
+import JavaTypes;
+import Data.Int;
+import Invocation;
+#endif
+--import Text.PrettyPrint.HughesPJ
+import Text.PrettyPrint.Leijen
+
+data Location = Location Int Int
+data Region = Region Location Location
+
+data Tree = Tree String [Tree] Region
+instance Show Tree
+ where
+ show t@(Tree _ _ _) = show $ prettyPrintTree $ t
+
+coalesceFlatHeadlessNodes t@(Tree s children r)
+ | s==[], flat t = Tree (concat $ map (\(Tree s _ _) -> s) children) [] r
+ | otherwise = Tree s (map coalesceFlatHeadlessNodes children) r
+ where
+ flat (Tree _ children _) = not (any id $ map notFlatComponent children)
+ notFlatComponent (Tree _ [] _) = False
+ notFlatComponent (Tree _ _ _) = True
+
+fsep = fillSep
+prettyPrintTree (Tree "" [] _) = empty
+prettyPrintTree (Tree s [] _) = text s
+prettyPrintTree (Tree [] children _) = prettyPrintTreeList children
+prettyPrintTree (Tree s children _) = (text (s++":")) <$$> (prettyPrintTreeList children)
+prettyPrintTreeList [] = text "{}"
+prettyPrintTreeList children
+ | allsingles children = text $ "\"" ++ (concatMap (\(Tree s _ _) -> s) children) ++ "\""
+ | otherwise = hang 2 $
+ (text "{")
+ <+>
+ (group
+ ((fsep $ map (group . prettyPrintTree) children)
+ <+>
+ (text "}")))
+allsingles = all (\(Tree s c _) -> (length s)==1 && (length c)==0)
+
+nullRegion = (Region (Location 0 0) (Location 0 0))
+
+
+
+------------------------------------------------------------------------------
+#if defined(java_HOST_OS)
+foreign import jvm type "edu.berkeley.sbp.Tree" JTree#
+data JTree = JTree JTree#
+foreign import jvm type "java.lang.Object" Object#
+data Object = Object Object#
+foreign import jvm safe "edu.berkeley.sbp.misc.RegressionTests.main" regressionTests :: IO ()
+foreign import jvm safe "HaskellHelper.help" haskellHelper :: JString -> IO JTree
+foreign import jvm safe "HaskellHelper.isNull" isNull :: Object -> IO Bool
+foreign import jvm safe "getHead" getHead :: JTree -> IO Object
+foreign import jvm safe "child" getChild :: JTree -> Int32 -> IO JTree
+foreign import jvm safe "size" size :: JTree -> IO Int32
+foreign import jvm safe "toString" jtoString :: Object -> IO JString
+
+toString o = do isn <- isNull o
+ if isn then return ""
+ else do str <- jtoString o
+ return (unpackJString str)
+
+
+haskify :: JTree -> IO Tree
+haskify t =
+ do head <- getHead t
+ str <- toString head
+ numChildren <- size t
+ children <- if numChildren == 0
+ then do return []
+ else do children <- mapM (\i -> getChild t i)
+ $ take (fromIntegral numChildren)
+ $ iterate (+1) 0
+ h <- mapM haskify children
+ return h
+ return $ Tree str children nullRegion
+
+parseFile ::
+ String -> -- file to be parsed
+ IO Tree
+
+parseFile f = do f' <- packJString f
+ tree <- haskellHelper f'
+ x <- haskify tree
+ return x
+
+------------------------------------------------------------------------------
+#else
+ -- Why do I need this?
+ instance SubJavaClassMarker
+ Header_edu_berkeley_sbp_Tree.Class_Jedu_berkeley_sbp_Tree
+ Header_HaskellHelper.Class_Jedu_berkeley_sbp_Tree
+
+ parseFile ::
+ [String] -> -- class path
+ String -> -- grammar *.g file
+ String -> -- file to be parsed
+ IO Tree
+
+ parseFile classPath grammarFile inputFile =
+ runJVM classPath
+ ((do class_JHaskellHelper
+ s1 <- new_JString_ArrayJchar $ toJavaString grammarFile
+ s2 <- new_JString_ArrayJchar $ toJavaString inputFile
+ tree <- main_JHaskellHelper_JString_JString (s1, s2)
+ t <- haskifyTree tree
+ return t
+ ) :: JVM Tree)
+
+ haskifyTree t =
+ ((do class_JHaskellHelper
+ class_JTree
+ head <- getHead_JTree t ()
+ isNull <- getIsNothing head
+ str <- if isNull then (return "") else (toString_JObject ((castTLRef head) :: Jjava_lang_Object) () >>= getStringUTF >>= \x -> return (showUTF8 x))
+ numChildren <- size_JTree t()
+ children <- if numChildren == 0
+ then do return []
+ else do children <- mapM (\i -> child_JTree_Jint t ((fromIntegral i)::Int32))
+ $ take (fromIntegral numChildren)
+ $ iterate (+1) 0
+ h <- mapM (\c -> haskifyTree (castTLRef c)) children
+ return h
+ return $ Tree str children nullRegion
+ ) :: JVM Tree)
+
+#endif
+\end{code}
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Text.PrettyPrint.Leijen
+-- Copyright : Daan Leijen (c) 2000, http://www.cs.uu.nl/~daan
+-- License : BSD-style (see the file LICENSE)
+--
+-- Maintainer : stefanor@cox.net
+-- Stability : provisional
+-- Portability : portable
+--
+-- Pretty print module based on Philip Wadler's \"prettier printer\"
+--
+-- @
+-- \"A prettier printer\"
+-- Draft paper, April 1997, revised March 1998.
+-- <http://cm.bell-labs.com/cm/cs/who/wadler/papers/prettier/prettier.ps>
+-- @
+--
+-- PPrint is an implementation of the pretty printing combinators
+-- described by Philip Wadler (1997). In their bare essence, the
+-- combinators of Wadler are not expressive enough to describe some
+-- commonly occurring layouts. The PPrint library adds new primitives
+-- to describe these layouts and works well in practice.
+--
+-- The library is based on a single way to concatenate documents,
+-- which is associative and has both a left and right unit. This
+-- simple design leads to an efficient and short implementation. The
+-- simplicity is reflected in the predictable behaviour of the
+-- combinators which make them easy to use in practice.
+--
+-- A thorough description of the primitive combinators and their
+-- implementation can be found in Philip Wadler's paper
+-- (1997). Additions and the main differences with his original paper
+-- are:
+--
+-- * The nil document is called empty.
+--
+-- * The above combinator is called '<$>'. The operator '</>' is used
+-- for soft line breaks.
+--
+-- * There are three new primitives: 'align', 'fill' and
+-- 'fillBreak'. These are very useful in practice.
+--
+-- * Lots of other useful combinators, like 'fillSep' and 'list'.
+--
+-- * There are two renderers, 'renderPretty' for pretty printing and
+-- 'renderCompact' for compact output. The pretty printing algorithm
+-- also uses a ribbon-width now for even prettier output.
+--
+-- * There are two displayers, 'displayS' for strings and 'displayIO' for
+-- file based output.
+--
+-- * There is a 'Pretty' class.
+--
+-- * The implementation uses optimised representations and strictness
+-- annotations.
+--
+-- Full documentation available at <http://www.cs.uu.nl/~daan/download/pprint/pprint.html>.
+-----------------------------------------------------------
+module Text.PrettyPrint.Leijen (
+ -- * Documents
+ Doc, putDoc, hPutDoc,
+
+ -- * Basic combinators
+ empty, char, text, (<>), nest, line, linebreak, group, softline,
+ softbreak,
+
+ -- * Alignment
+ --
+ -- The combinators in this section can not be described by Wadler's
+ -- original combinators. They align their output relative to the
+ -- current output position - in contrast to @nest@ which always
+ -- aligns to the current nesting level. This deprives these
+ -- combinators from being \`optimal\'. In practice however they
+ -- prove to be very useful. The combinators in this section should
+ -- be used with care, since they are more expensive than the other
+ -- combinators. For example, @align@ shouldn't be used to pretty
+ -- print all top-level declarations of a language, but using @hang@
+ -- for let expressions is fine.
+ align, hang, indent, encloseSep, list, tupled, semiBraces,
+
+ -- * Operators
+ (<+>), (<$>), (</>), (<$$>), (<//>),
+
+ -- * List combinators
+ hsep, vsep, fillSep, sep, hcat, vcat, fillCat, cat, punctuate,
+
+ -- * Fillers
+ fill, fillBreak,
+
+ -- * Bracketing combinators
+ enclose, squotes, dquotes, parens, angles, braces, brackets,
+
+ -- * Character documents
+ lparen, rparen, langle, rangle, lbrace, rbrace, lbracket, rbracket,
+ squote, dquote, semi, colon, comma, space, dot, backslash, equals,
+
+ -- * Primitive type documents
+ string, int, integer, float, double, rational,
+
+ -- * Pretty class
+ Pretty(..),
+
+ -- * Rendering
+ SimpleDoc(..), renderPretty, renderCompact, displayS, displayIO
+
+ -- * Undocumented
+ , bool
+
+ , column, nesting, width
+
+ ) where
+
+import System.IO (Handle,hPutStr,hPutChar,stdout)
+
+infixr 5 </>,<//>,<$>,<$$>
+infixr 6 <>,<+>
+
+
+-----------------------------------------------------------
+-- list, tupled and semiBraces pretty print a list of
+-- documents either horizontally or vertically aligned.
+-----------------------------------------------------------
+
+
+-- | The document @(list xs)@ comma separates the documents @xs@ and
+-- encloses them in square brackets. The documents are rendered
+-- horizontally if that fits the page. Otherwise they are aligned
+-- vertically. All comma separators are put in front of the elements.
+list :: [Doc] -> Doc
+list = encloseSep lbracket rbracket comma
+
+-- | The document @(tupled xs)@ comma separates the documents @xs@ and
+-- encloses them in parenthesis. The documents are rendered
+-- horizontally if that fits the page. Otherwise they are aligned
+-- vertically. All comma separators are put in front of the elements.
+tupled :: [Doc] -> Doc
+tupled = encloseSep lparen rparen comma
+
+
+-- | The document @(semiBraces xs)@ separates the documents @xs@ with
+-- semi colons and encloses them in braces. The documents are rendered
+-- horizontally if that fits the page. Otherwise they are aligned
+-- vertically. All semi colons are put in front of the elements.
+semiBraces :: [Doc] -> Doc
+semiBraces = encloseSep lbrace rbrace semi
+
+-- | The document @(encloseSep l r sep xs)@ concatenates the documents
+-- @xs@ separated by @sep@ and encloses the resulting document by @l@
+-- and @r@. The documents are rendered horizontally if that fits the
+-- page. Otherwise they are aligned vertically. All separators are put
+-- in front of the elements. For example, the combinator 'list' can be
+-- defined with @encloseSep@:
+--
+-- > list xs = encloseSep lbracket rbracket comma xs
+-- > test = text "list" <+> (list (map int [10,200,3000]))
+--
+-- Which is layed out with a page width of 20 as:
+--
+-- @
+-- list [10,200,3000]
+-- @
+--
+-- But when the page width is 15, it is layed out as:
+--
+-- @
+-- list [10
+-- ,200
+-- ,3000]
+-- @
+encloseSep :: Doc -> Doc -> Doc -> [Doc] -> Doc
+encloseSep left right sep ds
+ = case ds of
+ [] -> left <> right
+ [d] -> left <> d <> right
+ _ -> align (cat (zipWith (<>) (left : repeat sep) ds) <> right)
+
+
+-----------------------------------------------------------
+-- punctuate p [d1,d2,...,dn] => [d1 <> p,d2 <> p, ... ,dn]
+-----------------------------------------------------------
+
+
+-- | @(punctuate p xs)@ concatenates all documents in @xs@ with
+-- document @p@ except for the last document.
+--
+-- > someText = map text ["words","in","a","tuple"]
+-- > test = parens (align (cat (punctuate comma someText)))
+--
+-- This is layed out on a page width of 20 as:
+--
+-- @
+-- (words,in,a,tuple)
+-- @
+--
+-- But when the page width is 15, it is layed out as:
+--
+-- @
+-- (words,
+-- in,
+-- a,
+-- tuple)
+-- @
+--
+-- (If you want put the commas in front of their elements instead of
+-- at the end, you should use 'tupled' or, in general, 'encloseSep'.)
+punctuate :: Doc -> [Doc] -> [Doc]
+punctuate p [] = []
+punctuate p [d] = [d]
+punctuate p (d:ds) = (d <> p) : punctuate p ds
+
+
+-----------------------------------------------------------
+-- high-level combinators
+-----------------------------------------------------------
+
+
+-- | The document @(sep xs)@ concatenates all documents @xs@ either
+-- horizontally with @(\<+\>)@, if it fits the page, or vertically with
+-- @(\<$\>)@.
+--
+-- > sep xs = group (vsep xs)
+sep :: [Doc] -> Doc
+sep = group . vsep
+
+-- | The document @(fillSep xs)@ concatenates documents @xs@
+-- horizontally with @(\<+\>)@ as long as its fits the page, than
+-- inserts a @line@ and continues doing that for all documents in
+-- @xs@.
+--
+-- > fillSep xs = foldr (\<\/\>) empty xs
+fillSep :: [Doc] -> Doc
+fillSep = fold (</>)
+
+-- | The document @(hsep xs)@ concatenates all documents @xs@
+-- horizontally with @(\<+\>)@.
+hsep :: [Doc] -> Doc
+hsep = fold (<+>)
+
+
+-- | The document @(vsep xs)@ concatenates all documents @xs@
+-- vertically with @(\<$\>)@. If a 'group' undoes the line breaks
+-- inserted by @vsep@, all documents are separated with a space.
+--
+-- > someText = map text (words ("text to lay out"))
+-- >
+-- > test = text "some" <+> vsep someText
+--
+-- This is layed out as:
+--
+-- @
+-- some text
+-- to
+-- lay
+-- out
+-- @
+--
+-- The 'align' combinator can be used to align the documents under
+-- their first element
+--
+-- > test = text "some" <+> align (vsep someText)
+--
+-- Which is printed as:
+--
+-- @
+-- some text
+-- to
+-- lay
+-- out
+-- @
+vsep :: [Doc] -> Doc
+vsep = fold (<$>)
+
+-- | The document @(cat xs)@ concatenates all documents @xs@ either
+-- horizontally with @(\<\>)@, if it fits the page, or vertically with
+-- @(\<$$\>)@.
+--
+-- > cat xs = group (vcat xs)
+cat :: [Doc] -> Doc
+cat = group . vcat
+
+-- | The document @(fillCat xs)@ concatenates documents @xs@
+-- horizontally with @(\<\>)@ as long as its fits the page, than inserts
+-- a @linebreak@ and continues doing that for all documents in @xs@.
+--
+-- > fillCat xs = foldr (\<\/\/\>) empty xs
+fillCat :: [Doc] -> Doc
+fillCat = fold (<//>)
+
+-- | The document @(hcat xs)@ concatenates all documents @xs@
+-- horizontally with @(\<\>)@.
+hcat :: [Doc] -> Doc
+hcat = fold (<>)
+
+-- | The document @(vcat xs)@ concatenates all documents @xs@
+-- vertically with @(\<$$\>)@. If a 'group' undoes the line breaks
+-- inserted by @vcat@, all documents are directly concatenated.
+vcat :: [Doc] -> Doc
+vcat = fold (<$$>)
+
+fold f [] = empty
+fold f ds = foldr1 f ds
+
+-- | The document @(x \<\> y)@ concatenates document @x@ and document
+-- @y@. It is an associative operation having 'empty' as a left and
+-- right unit. (infixr 6)
+(<>) :: Doc -> Doc -> Doc
+x <> y = x `beside` y
+
+-- | The document @(x \<+\> y)@ concatenates document @x@ and @y@ with a
+-- @space@ in between. (infixr 6)
+(<+>) :: Doc -> Doc -> Doc
+x <+> y = x <> space <> y
+
+-- | The document @(x \<\/\> y)@ concatenates document @x@ and @y@ with a
+-- 'softline' in between. This effectively puts @x@ and @y@ either
+-- next to each other (with a @space@ in between) or underneath each
+-- other. (infixr 5)
+(</>) :: Doc -> Doc -> Doc
+x </> y = x <> softline <> y
+
+-- | The document @(x \<\/\/\> y)@ concatenates document @x@ and @y@ with
+-- a 'softbreak' in between. This effectively puts @x@ and @y@ either
+-- right next to each other or underneath each other. (infixr 5)
+(<//>) :: Doc -> Doc -> Doc
+x <//> y = x <> softbreak <> y
+
+-- | The document @(x \<$\> y)@ concatenates document @x@ and @y@ with a
+-- 'line' in between. (infixr 5)
+(<$>) :: Doc -> Doc -> Doc
+x <$> y = x <> line <> y
+
+-- | The document @(x \<$$\> y)@ concatenates document @x@ and @y@ with
+-- a @linebreak@ in between. (infixr 5)
+(<$$>) :: Doc -> Doc -> Doc
+x <$$> y = x <> linebreak <> y
+
+-- | The document @softline@ behaves like 'space' if the resulting
+-- output fits the page, otherwise it behaves like 'line'.
+--
+-- > softline = group line
+softline :: Doc
+softline = group line
+
+-- | The document @softbreak@ behaves like 'empty' if the resulting
+-- output fits the page, otherwise it behaves like 'line'.
+--
+-- > softbreak = group linebreak
+softbreak :: Doc
+softbreak = group linebreak
+
+-- | Document @(squotes x)@ encloses document @x@ with single quotes
+-- \"'\".
+squotes :: Doc -> Doc
+squotes = enclose squote squote
+
+-- | Document @(dquotes x)@ encloses document @x@ with double quotes
+-- '\"'.
+dquotes :: Doc -> Doc
+dquotes = enclose dquote dquote
+
+-- | Document @(braces x)@ encloses document @x@ in braces, \"{\" and
+-- \"}\".
+braces :: Doc -> Doc
+braces = enclose lbrace rbrace
+
+-- | Document @(parens x)@ encloses document @x@ in parenthesis, \"(\"
+-- and \")\".
+parens :: Doc -> Doc
+parens = enclose lparen rparen
+
+-- | Document @(angles x)@ encloses document @x@ in angles, \"\<\" and
+-- \"\>\".
+angles :: Doc -> Doc
+angles = enclose langle rangle
+
+-- | Document @(brackets x)@ encloses document @x@ in square brackets,
+-- \"[\" and \"]\".
+brackets :: Doc -> Doc
+brackets = enclose lbracket rbracket
+
+-- | The document @(enclose l r x)@ encloses document @x@ between
+-- documents @l@ and @r@ using @(\<\>)@.
+--
+-- > enclose l r x = l <> x <> r
+enclose :: Doc -> Doc -> Doc -> Doc
+enclose l r x = l <> x <> r
+
+-- | The document @lparen@ contains a left parenthesis, \"(\".
+lparen :: Doc
+lparen = char '('
+-- | The document @rparen@ contains a right parenthesis, \")\".
+rparen :: Doc
+rparen = char ')'
+-- | The document @langle@ contains a left angle, \"\<\".
+langle :: Doc
+langle = char '<'
+-- | The document @rangle@ contains a right angle, \">\".
+rangle :: Doc
+rangle = char '>'
+-- | The document @lbrace@ contains a left brace, \"{\".
+lbrace :: Doc
+lbrace = char '{'
+-- | The document @rbrace@ contains a right brace, \"}\".
+rbrace :: Doc
+rbrace = char '}'
+-- | The document @lbracket@ contains a left square bracket, \"[\".
+lbracket :: Doc
+lbracket = char '['
+-- | The document @rbracket@ contains a right square bracket, \"]\".
+rbracket :: Doc
+rbracket = char ']'
+
+
+-- | The document @squote@ contains a single quote, \"'\".
+squote :: Doc
+squote = char '\''
+-- | The document @dquote@ contains a double quote, '\"'.
+dquote :: Doc
+dquote = char '"'
+-- | The document @semi@ contains a semi colon, \";\".
+semi :: Doc
+semi = char ';'
+-- | The document @colon@ contains a colon, \":\".
+colon :: Doc
+colon = char ':'
+-- | The document @comma@ contains a comma, \",\".
+comma :: Doc
+comma = char ','
+-- | The document @space@ contains a single space, \" \".
+--
+-- > x <+> y = x <> space <> y
+space :: Doc
+space = char ' '
+-- | The document @dot@ contains a single dot, \".\".
+dot :: Doc
+dot = char '.'
+-- | The document @backslash@ contains a back slash, \"\\\".
+backslash :: Doc
+backslash = char '\\'
+-- | The document @equals@ contains an equal sign, \"=\".
+equals :: Doc
+equals = char '='
+
+
+-----------------------------------------------------------
+-- Combinators for prelude types
+-----------------------------------------------------------
+
+-- string is like "text" but replaces '\n' by "line"
+
+-- | The document @(string s)@ concatenates all characters in @s@
+-- using @line@ for newline characters and @char@ for all other
+-- characters. It is used instead of 'text' whenever the text contains
+-- newline characters.
+string :: String -> Doc
+string "" = empty
+string ('\n':s) = line <> string s
+string s = case (span (/='\n') s) of
+ (xs,ys) -> text xs <> string ys
+
+bool :: Bool -> Doc
+bool b = text (show b)
+
+-- | The document @(int i)@ shows the literal integer @i@ using
+-- 'text'.
+int :: Int -> Doc
+int i = text (show i)
+
+-- | The document @(integer i)@ shows the literal integer @i@ using
+-- 'text'.
+integer :: Integer -> Doc
+integer i = text (show i)
+
+-- | The document @(float f)@ shows the literal float @f@ using
+-- 'text'.
+float :: Float -> Doc
+float f = text (show f)
+
+-- | The document @(double d)@ shows the literal double @d@ using
+-- 'text'.
+double :: Double -> Doc
+double d = text (show d)
+
+-- | The document @(rational r)@ shows the literal rational @r@ using
+-- 'text'.
+rational :: Rational -> Doc
+rational r = text (show r)
+
+
+-----------------------------------------------------------
+-- overloading "pretty"
+-----------------------------------------------------------
+
+-- | The member @prettyList@ is only used to define the @instance Pretty
+-- a => Pretty [a]@. In normal circumstances only the @pretty@ function
+-- is used.
+class Pretty a where
+ pretty :: a -> Doc
+ prettyList :: [a] -> Doc
+ prettyList = list . map pretty
+
+instance Pretty a => Pretty [a] where
+ pretty = prettyList
+
+instance Pretty Doc where
+ pretty = id
+
+instance Pretty () where
+ pretty () = text "()"
+
+instance Pretty Bool where
+ pretty b = bool b
+
+instance Pretty Char where
+ pretty c = char c
+ prettyList s = string s
+
+instance Pretty Int where
+ pretty i = int i
+
+instance Pretty Integer where
+ pretty i = integer i
+
+instance Pretty Float where
+ pretty f = float f
+
+instance Pretty Double where
+ pretty d = double d
+
+
+--instance Pretty Rational where
+-- pretty r = rational r
+
+instance (Pretty a,Pretty b) => Pretty (a,b) where
+ pretty (x,y) = tupled [pretty x, pretty y]
+
+instance (Pretty a,Pretty b,Pretty c) => Pretty (a,b,c) where
+ pretty (x,y,z)= tupled [pretty x, pretty y, pretty z]
+
+instance Pretty a => Pretty (Maybe a) where
+ pretty Nothing = empty
+ pretty (Just x) = pretty x
+
+
+
+-----------------------------------------------------------
+-- semi primitive: fill and fillBreak
+-----------------------------------------------------------
+
+-- | The document @(fillBreak i x)@ first renders document @x@. It
+-- than appends @space@s until the width is equal to @i@. If the
+-- width of @x@ is already larger than @i@, the nesting level is
+-- increased by @i@ and a @line@ is appended. When we redefine @ptype@
+-- in the previous example to use @fillBreak@, we get a useful
+-- variation of the previous output:
+--
+-- > ptype (name,tp)
+-- > = fillBreak 6 (text name) <+> text "::" <+> text tp
+--
+-- The output will now be:
+--
+-- @
+-- let empty :: Doc
+-- nest :: Int -> Doc -> Doc
+-- linebreak
+-- :: Doc
+-- @
+fillBreak :: Int -> Doc -> Doc
+fillBreak f x = width x (\w ->
+ if (w > f) then nest f linebreak
+ else text (spaces (f - w)))
+
+
+-- | The document @(fill i x)@ renders document @x@. It than appends
+-- @space@s until the width is equal to @i@. If the width of @x@ is
+-- already larger, nothing is appended. This combinator is quite
+-- useful in practice to output a list of bindings. The following
+-- example demonstrates this.
+--
+-- > types = [("empty","Doc")
+-- > ,("nest","Int -> Doc -> Doc")
+-- > ,("linebreak","Doc")]
+-- >
+-- > ptype (name,tp)
+-- > = fill 6 (text name) <+> text "::" <+> text tp
+-- >
+-- > test = text "let" <+> align (vcat (map ptype types))
+--
+-- Which is layed out as:
+--
+-- @
+-- let empty :: Doc
+-- nest :: Int -> Doc -> Doc
+-- linebreak :: Doc
+-- @
+fill :: Int -> Doc -> Doc
+fill f d = width d (\w ->
+ if (w >= f) then empty
+ else text (spaces (f - w)))
+
+width :: Doc -> (Int -> Doc) -> Doc
+width d f = column (\k1 -> d <> column (\k2 -> f (k2 - k1)))
+
+
+-----------------------------------------------------------
+-- semi primitive: Alignment and indentation
+-----------------------------------------------------------
+
+-- | The document @(indent i x)@ indents document @x@ with @i@ spaces.
+--
+-- > test = indent 4 (fillSep (map text
+-- > (words "the indent combinator indents these words !")))
+--
+-- Which lays out with a page width of 20 as:
+--
+-- @
+-- the indent
+-- combinator
+-- indents these
+-- words !
+-- @
+indent :: Int -> Doc -> Doc
+indent i d = hang i (text (spaces i) <> d)
+
+-- | The hang combinator implements hanging indentation. The document
+-- @(hang i x)@ renders document @x@ with a nesting level set to the
+-- current column plus @i@. The following example uses hanging
+-- indentation for some text:
+--
+-- > test = hang 4 (fillSep (map text
+-- > (words "the hang combinator indents these words !")))
+--
+-- Which lays out on a page with a width of 20 characters as:
+--
+-- @
+-- the hang combinator
+-- indents these
+-- words !
+-- @
+--
+-- The @hang@ combinator is implemented as:
+--
+-- > hang i x = align (nest i x)
+hang :: Int -> Doc -> Doc
+hang i d = align (nest i d)
+
+-- | The document @(align x)@ renders document @x@ with the nesting
+-- level set to the current column. It is used for example to
+-- implement 'hang'.
+--
+-- As an example, we will put a document right above another one,
+-- regardless of the current nesting level:
+--
+-- > x $$ y = align (x <$> y)
+--
+-- > test = text "hi" <+> (text "nice" $$ text "world")
+--
+-- which will be layed out as:
+--
+-- @
+-- hi nice
+-- world
+-- @
+align :: Doc -> Doc
+align d = column (\k ->
+ nesting (\i -> nest (k - i) d)) --nesting might be negative :-)
+
+
+
+-----------------------------------------------------------
+-- Primitives
+-----------------------------------------------------------
+
+-- | The abstract data type @Doc@ represents pretty documents.
+--
+-- @Doc@ is an instance of the 'Show' class. @(show doc)@ pretty
+-- prints document @doc@ with a page width of 100 characters and a
+-- ribbon width of 40 characters.
+--
+-- > show (text "hello" <$> text "world")
+--
+-- Which would return the string \"hello\\nworld\", i.e.
+--
+-- @
+-- hello
+-- world
+-- @
+data Doc = Empty
+ | Char Char -- invariant: char is not '\n'
+ | Text !Int String -- invariant: text doesn't contain '\n'
+ | Line !Bool -- True <=> when undone by group, do not insert a space
+ | Cat Doc Doc
+ | Nest !Int Doc
+ | Union Doc Doc -- invariant: first lines of first doc longer than the first lines of the second doc
+ | Column (Int -> Doc)
+ | Nesting (Int -> Doc)
+
+
+-- | The data type @SimpleDoc@ represents rendered documents and is
+-- used by the display functions.
+--
+-- The @Int@ in @SText@ contains the length of the string. The @Int@
+-- in @SLine@ contains the indentation for that line. The library
+-- provides two default display functions 'displayS' and
+-- 'displayIO'. You can provide your own display function by writing a
+-- function from a @SimpleDoc@ to your own output format.
+data SimpleDoc = SEmpty
+ | SChar Char SimpleDoc
+ | SText !Int String SimpleDoc
+ | SLine !Int SimpleDoc
+
+
+-- | The empty document is, indeed, empty. Although @empty@ has no
+-- content, it does have a \'height\' of 1 and behaves exactly like
+-- @(text \"\")@ (and is therefore not a unit of @\<$\>@).
+empty :: Doc
+empty = Empty
+
+-- | The document @(char c)@ contains the literal character @c@. The
+-- character shouldn't be a newline (@'\n'@), the function 'line'
+-- should be used for line breaks.
+char :: Char -> Doc
+char '\n' = line
+char c = Char c
+
+-- | The document @(text s)@ contains the literal string @s@. The
+-- string shouldn't contain any newline (@'\n'@) characters. If the
+-- string contains newline characters, the function 'string' should be
+-- used.
+text :: String -> Doc
+text "" = Empty
+text s = Text (length s) s
+
+-- | The @line@ document advances to the next line and indents to the
+-- current nesting level. Document @line@ behaves like @(text \" \")@
+-- if the line break is undone by 'group'.
+line :: Doc
+line = Line False
+
+-- | The @linebreak@ document advances to the next line and indents to
+-- the current nesting level. Document @linebreak@ behaves like
+-- 'empty' if the line break is undone by 'group'.
+linebreak :: Doc
+linebreak = Line True
+
+beside x y = Cat x y
+
+-- | The document @(nest i x)@ renders document @x@ with the current
+-- indentation level increased by i (See also 'hang', 'align' and
+-- 'indent').
+--
+-- > nest 2 (text "hello" <$> text "world") <$> text "!"
+--
+-- outputs as:
+--
+-- @
+-- hello
+-- world
+-- !
+-- @
+nest :: Int -> Doc -> Doc
+nest i x = Nest i x
+
+column, nesting :: (Int -> Doc) -> Doc
+column f = Column f
+nesting f = Nesting f
+
+-- | The @group@ combinator is used to specify alternative
+-- layouts. The document @(group x)@ undoes all line breaks in
+-- document @x@. The resulting line is added to the current line if
+-- that fits the page. Otherwise, the document @x@ is rendered without
+-- any changes.
+group :: Doc -> Doc
+group x = Union (flatten x) x
+
+flatten :: Doc -> Doc
+flatten (Cat x y) = Cat (flatten x) (flatten y)
+flatten (Nest i x) = Nest i (flatten x)
+flatten (Line break) = if break then Empty else Text 1 " "
+flatten (Union x y) = flatten x
+flatten (Column f) = Column (flatten . f)
+flatten (Nesting f) = Nesting (flatten . f)
+flatten other = other --Empty,Char,Text
+
+
+
+-----------------------------------------------------------
+-- Renderers
+-----------------------------------------------------------
+
+-----------------------------------------------------------
+-- renderPretty: the default pretty printing algorithm
+-----------------------------------------------------------
+
+-- list of indentation/document pairs; saves an indirection over [(Int,Doc)]
+data Docs = Nil
+ | Cons !Int Doc Docs
+
+
+-- | This is the default pretty printer which is used by 'show',
+-- 'putDoc' and 'hPutDoc'. @(renderPretty ribbonfrac width x)@ renders
+-- document @x@ with a page width of @width@ and a ribbon width of
+-- @(ribbonfrac * width)@ characters. The ribbon width is the maximal
+-- amount of non-indentation characters on a line. The parameter
+-- @ribbonfrac@ should be between @0.0@ and @1.0@. If it is lower or
+-- higher, the ribbon width will be 0 or @width@ respectively.
+renderPretty :: Float -> Int -> Doc -> SimpleDoc
+renderPretty rfrac w x
+ = best 0 0 (Cons 0 x Nil)
+ where
+ -- r :: the ribbon width in characters
+ r = max 0 (min w (round (fromIntegral w * rfrac)))
+
+ -- best :: n = indentation of current line
+ -- k = current column
+ -- (ie. (k >= n) && (k - n == count of inserted characters)
+ best n k Nil = SEmpty
+ best n k (Cons i d ds)
+ = case d of
+ Empty -> best n k ds
+ Char c -> let k' = k+1 in seq k' (SChar c (best n k' ds))
+ Text l s -> let k' = k+l in seq k' (SText l s (best n k' ds))
+ Line _ -> SLine i (best i i ds)
+ Cat x y -> best n k (Cons i x (Cons i y ds))
+ Nest j x -> let i' = i+j in seq i' (best n k (Cons i' x ds))
+ Union x y -> nicest n k (best n k (Cons i x ds))
+ (best n k (Cons i y ds))
+
+ Column f -> best n k (Cons i (f k) ds)
+ Nesting f -> best n k (Cons i (f i) ds)
+
+ --nicest :: r = ribbon width, w = page width,
+ -- n = indentation of current line, k = current column
+ -- x and y, the (simple) documents to chose from.
+ -- precondition: first lines of x are longer than the first lines of y.
+ nicest n k x y | fits width x = x
+ | otherwise = y
+ where
+ width = min (w - k) (r - k + n)
+
+
+fits w x | w < 0 = False
+fits w SEmpty = True
+fits w (SChar c x) = fits (w - 1) x
+fits w (SText l s x) = fits (w - l) x
+fits w (SLine i x) = True
+
+
+-----------------------------------------------------------
+-- renderCompact: renders documents without indentation
+-- fast and fewer characters output, good for machines
+-----------------------------------------------------------
+
+
+-- | @(renderCompact x)@ renders document @x@ without adding any
+-- indentation. Since no \'pretty\' printing is involved, this
+-- renderer is very fast. The resulting output contains fewer
+-- characters than a pretty printed version and can be used for output
+-- that is read by other programs.
+renderCompact :: Doc -> SimpleDoc
+renderCompact x
+ = scan 0 [x]
+ where
+ scan k [] = SEmpty
+ scan k (d:ds) = case d of
+ Empty -> scan k ds
+ Char c -> let k' = k+1 in seq k' (SChar c (scan k' ds))
+ Text l s -> let k' = k+l in seq k' (SText l s (scan k' ds))
+ Line _ -> SLine 0 (scan 0 ds)
+ Cat x y -> scan k (x:y:ds)
+ Nest j x -> scan k (x:ds)
+ Union x y -> scan k (y:ds)
+ Column f -> scan k (f k:ds)
+ Nesting f -> scan k (f 0:ds)
+
+
+
+-----------------------------------------------------------
+-- Displayers: displayS and displayIO
+-----------------------------------------------------------
+
+
+-- | @(displayS simpleDoc)@ takes the output @simpleDoc@ from a
+-- rendering function and transforms it to a 'ShowS' type (for use in
+-- the 'Show' class).
+--
+-- > showWidth :: Int -> Doc -> String
+-- > showWidth w x = displayS (renderPretty 0.4 w x) ""
+displayS :: SimpleDoc -> ShowS
+displayS SEmpty = id
+displayS (SChar c x) = showChar c . displayS x
+displayS (SText l s x) = showString s . displayS x
+displayS (SLine i x) = showString ('\n':indentation i) . displayS x
+
+
+-- | @(displayIO handle simpleDoc)@ writes @simpleDoc@ to the file
+-- handle @handle@. This function is used for example by 'hPutDoc':
+--
+-- > hPutDoc handle doc = displayIO handle (renderPretty 0.4 100 doc)
+displayIO :: Handle -> SimpleDoc -> IO ()
+displayIO handle simpleDoc
+ = display simpleDoc
+ where
+ display SEmpty = return ()
+ display (SChar c x) = do{ hPutChar handle c; display x}
+ display (SText l s x) = do{ hPutStr handle s; display x}
+ display (SLine i x) = do{ hPutStr handle ('\n':indentation i); display x}
+
+
+-----------------------------------------------------------
+-- default pretty printers: show, putDoc and hPutDoc
+-----------------------------------------------------------
+instance Show Doc where
+ showsPrec d doc = displayS (renderPretty 0.4 80 doc)
+
+-- | The action @(putDoc doc)@ pretty prints document @doc@ to the
+-- standard output, with a page width of 100 characters and a ribbon
+-- width of 40 characters.
+--
+-- > main :: IO ()
+-- > main = do{ putDoc (text "hello" <+> text "world") }
+--
+-- Which would output
+--
+-- @
+-- hello world
+-- @
+putDoc :: Doc -> IO ()
+putDoc doc = hPutDoc stdout doc
+
+-- | @(hPutDoc handle doc)@ pretty prints document @doc@ to the file
+-- handle @handle@ with a page width of 100 characters and a ribbon
+-- width of 40 characters.
+--
+-- > main = do{ handle <- openFile "MyFile" WriteMode
+-- > ; hPutDoc handle (vcat (map text
+-- > ["vertical","text"]))
+-- > ; hClose handle
+-- > }
+hPutDoc :: Handle -> Doc -> IO ()
+hPutDoc handle doc = displayIO handle (renderPretty 0.4 80 doc)
+
+
+
+-----------------------------------------------------------
+-- insert spaces
+-- "indentation" used to insert tabs but tabs seem to cause
+-- more trouble than they solve :-)
+-----------------------------------------------------------
+spaces n | n <= 0 = ""
+ | otherwise = replicate n ' '
+
+indentation n = spaces n
+
+--indentation n | n >= 8 = '\t' : indentation (n-8)
+-- | otherwise = spaces n
+
+-- LocalWords: PPrint combinators Wadler Wadler's encloseSep
--- /dev/null
+\begin{code}
+module Util where
+
+join x [] = []
+join x [a] = a
+join x (a:b:c) = a++x++(join x (b:c))
+\end{code}
--- /dev/null
+\begin{code}
+module Wix(main')
+where
+import SBP
+import FromTree
+import Doc
+import Html
+import Foreign.Java
+import qualified Text.PrettyPrint.Leijen as PP
+
+process :: String -> IO String
+process file = do t <- parseFile file
+ return
+ $ toHtml
+ $ ((fromTree $ coalesceFlatHeadlessNodes t) :: Doc)
+
+foreign import jvm safe "HaskellHelper.putBack" putBack :: JString -> IO ()
+
+main' file verbosity =
+ do t <- parseFile file
+ if verbosity > 0
+ then
+ putStrLn $ (PP.displayS
+ $ PP.renderPretty (0.9) 80
+ $ prettyPrintTree (coalesceFlatHeadlessNodes t))
+ ""
+ else
+ return ()
+ doc <- return ((fromTree $ coalesceFlatHeadlessNodes t) :: Doc)
+ if verbosity > 1
+ then
+ putStrLn $ (PP.displayS
+ $ PP.renderPretty (0.9) 80
+ $ PP.pretty doc)
+ ""
+ else
+ return ()
+ js <- packJString $ toHtml doc
+ putBack js
+
+\end{code}
+
+
+
+
--- /dev/null
+
+// productions which match indentation-balanced text regions; that is,
+// regions in which the indentation level of all parts of the region
+// is strictly non-negative relative to the start of the region.
+
+// A region which is indentation-balanced: no prefix of the region
+// contains more outdents than indents.
+Balanced! = Balanced ~[>><<]
+ | Balanced >> Balanced <<
+ | ()
+
+// A region which is unbalanced: some prefix has more outdents than
+// indents. May be faster to match than (~~Balanced).
+UnBalanced! = <<
+ | ~[>><<] UnBalanced
+ | >> UnBalanced UnBalanced
--- /dev/null
+alpha = [a-zA-Z]
+alphanum = alpha | digit
+digit = [0-9]
+Int:: = digit++
+escaped = lf:: "\\n"
+ | cr:: "\\r"
+ | "\\" ~[nr]
--- /dev/null
+// URLs //////////////////////////////////////////////////////////////////////////////
+
+#import tokens.g as tok
+
+// "public" /////////////////////////////////////////////////////////////////////
+
+Path:: = urlchar+
+Email:: = username "@" Host
+URL:: = method "://" Login Host Port (()|"/"|"/" Path) (()|"#"|"#" Path)
+ -> (~(urlc|[%\#]) | avoidOnUrlTail)
+
+// An url must not end with these characters if it appears "bare"
+// inline within a text block (ie without braces surrounding it).
+// This ensures that punctuation doesn't "stick" to the end of the url.
+avoidOnUrlTail = [,.;)!]
+
+// "private" ////////////////////////////////////////////////////////////////////
+
+Login:: = username "@"
+ | username ":" password "@"
+ | ()
+Host = IP:: tok.digit "." tok.digit "." tok.digit "." tok.digit
+ | DNS:: (part:: [a-zA-Z0-9\-]++) ++/ "."
+Port:: = (":" `tok.Int)?
+
+username:: = [a-zA-Z0-9;/?:&=$\-_.+]++
+password:: = [a-zA-Z0-9;/?:&=$\-_.+]++
+method:: = [+\-.a-z0-9]+
+urlchar = urlc
+ | "%":: "%" [0-9] [0-9]
+urlc = [a-zA-Z0-9;/?:&=$\-_.+]
+ | [@~,] // technically illegal (RFC1738)
--- /dev/null
+// WiX Grammar //////////////////////////////////////////////////////////////////////////////
+
+#import url.g as url
+#import indent.g as indent
+
+//#import tokens.g as tokens // disabled until transinclusion bug is fixed
+
+s = Doc
+
+Doc:: = Header Body
+Header:: = () // not yet specified
+Body:: = Section */ br
+
+// multi-line header by indenting second line?
+Section:: = SectionHeader
+ | SectionHeader (nl|br) >> Pars <<
+ > SectionHeader (nl|br) Pars
+SectionHeader:: = (^"=" [=]++) ws (Text &~ ... "\n" ...)
+
+Pars:: = (Par <<* & indent.Balanced &~ "=" ...) */ br
+
+// An "unbalanced" paragraph (may need trailing outdents to balance)
+Par = NonTextParagraph
+ > TextParagraph
+
+TextParagraph:: = Text
+
+NonTextParagraph = UL:: `("":: ("*" BBullet nl)*) "*" UBullet
+ | OL:: `("":: (tok.Int! [.\)]! BBullet nl)*) tok.Int! [.\)]! UBullet
+ | Blockquote:: "\"\"" ws >> Pars
+ | HR:: "---" "-"*
+ | Verbatim:: "\\pre" " "* "\n" (I:: [ ]*) >> Verbatim <<
+
+// a "balanced bullet"
+BBullet = (UBullet <<*) & indent.Balanced
+
+// an "unbalanced bullet"
+UBullet = whitespace (LI:: Par */ br)
+ & ~[\n]* ("\n" [ \r\n]* >> ...)?
+
+Verbatim = VerbatimBrace:: Verbatim >> Verbatim <<
+ | Verbatim:: Verbatim ~[>><<]
+ | Verbatim:: ()
+
+// note that Text and TextWS are left-recursive because this is more
+// efficient in LR parsers
+
+// text followed by optional whitespace
+TextWS = ()
+ | Text
+ | Text:: `Text (WS:: whitespace)
+
+Text:: = `Text nl >> (Pars:: NonTextParagraph)
+ > `TextWS (Link:: Atom "->" ws href)
+ > `TextWS styled
+ > `TextWS Ordinal
+ | `TextWS Fraction
+ > `TextWS Atom
+ | `TextWS (Command:: "\\" ("":: [a-zA-Z0-9:]++ &~ "pre") Block)
+ | `TextWS (Command:: "\\" ("":: [a-zA-Z0-9:]++ &~ "pre") -> ~"{")
+ | `TextWS (Quotes:: "\"" (Text &~ ... "\"" ...) "\"")
+ | `TextWS glyph
+ > `TextWS (Word:: sym)
+ > `Text (WS:: br) >> (Pars -> <<) // subparagraph
+
+href = url.Email
+ > url.URL &~ ... url.avoidOnUrlTail
+ > url.Path &~ ... url.avoidOnUrlTail
+ | "{" ws url.Email ws "}"
+ > "{" ws url.URL ws "}"
+ > "{" ws url.Path ws "}"
+ // > Citation:: "[" tok.alphanum++ "]"
+
+Atom = Word | Block
+Block = "{" ws TextWS "}"
+Word:: = tok.alphanum++
+Fraction:: = ("":: [0-9]+) "/" ("":: [0-9]+)
+Ordinal:: = `("":: [0-9]*) ( [1] "st"
+ | [2] "nd"
+ | [3] "rd"
+ | [04-9] "th" )
+
+styled = Underline:: "__" Text "__"
+ | Footnote:: "((" Text "))"
+ | TT:: "[[" ws (Text &~ ... "]]" ...) ws "]]"
+ | Strikethrough:: "!!" Text "!!"
+ | Superscript:: "^^" Atom
+ | Subscript:: ",," Atom
+ | Bold:: "++" (Text &~ ... "++" ...) "++"
+ | Highlight:: "##" (Text &~ ... "##" ...) "##"
+ | Math:: "$$" (~[$] | ([$] -> ~[$]))+ "$$"
+ | Keyword:: "!" Atom
+ | Italic:: "**" (Text &~ ... "**" ...) "**"
+
+glyph = ^"(e)" | ^"(r)" | ^"(c)" | ^"(tm)" | ^"--"
+ | ^"..." | ^"<-" | ^"<=" | ^"=>" | ^"<->"
+ | ^"<=>" | ^"<-" | ^"^o"
+ // ^"->"
+
+// Chars ///////////////////////////////////////////////////////////////
+
+sym = "\\" ~tok.alphanum
+ | ~(tok.alphanum | [\r\n \\{}>><<])
+
+hws! = [ \r>>]
+ws! = (hws* "\n")? hws* -> ~[ \n\r]
+whitespace! = hws+ -> ~[ \n\r]
+ | hws* "\n" hws* -> ~[ \n\r]
+
+// these don't include indents-as-whitespace
+nl! = [ \r]* "\n" [ \r]* -> ~[ \n\r]
+br! = [ \r]* "\n" [ \r]* "\n" [ \r\n]* -> ~[ \n\r]
+
+
projects / wix.git / commitdiff