[Add support for dumping intermediate forms in HTML
John Meacham <john@repetae.net>**20050421121201] hunk ./ANSI.hs 1
---  $Id: ANSI.hs,v 1.1 2002/08/13 17:20:52 john Exp john $
-
--- Copyright (c) 2002 John Meacham (john@foo.net)
--- 
--- Permission is hereby granted, free of charge, to any person obtaining a
--- copy of this software and associated documentation files (the
--- "Software"), to deal in the Software without restriction, including
--- without limitation the rights to use, copy, modify, merge, publish,
--- distribute, sublicense, and/or sell copies of the Software, and to
--- permit persons to whom the Software is furnished to do so, subject to
--- the following conditions:
--- 
--- The above copyright notice and this permission notice shall be included
--- in all copies or substantial portions of the Software.
--- 
--- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
--- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
--- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
--- IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
--- CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
--- TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
--- SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-
-module ANSI(
-    move,
-    clrToEOL,
-    clrFromBOL,
-    clrLine,
-    clrToEOS,
-    clrFrombos,
-    clrScreen,
-    attrClear,
-    attrBold,
-    attrUnderline,
-    attrBlink,
-    attrReverse,
-    cursorOn,
-    cursorOff,
-    attrFG,
-    attrBG,
-    attr
-) where
-
---import Prelude((++), show, Int, String)
-import List
-
-move ::  Int -> Int -> String
-move x y = "\27[" ++ (show y) ++ ";" ++ (show x) ++ ";H"
-clrToEOL = "\27[K" 
-clrFromBOL = "\27[1K" 
-clrLine = "\27[2K" 
-clrToEOS = "\27[J" 
-clrFrombos = "\27[1J" 
-clrScreen = "\27[2J" 
-attrClear = "\27[0m" 
-attrBold = "\27[1m" 
-attrUnderline = "\27[4m" 
-attrBlink = "\27[5m" 
-attrReverse = "\27[7m" 
-cursorOn = "\27[?25h" 
-cursorOff = "\27[?25l" 
-attrFG :: Int -> String
-attrFG c =  "\27[3" ++ (show c) ++ "m"
-attrBG :: Int -> String
-attrBG c =  "\27[4" ++ (show c) ++ "m"
-attr :: [Int] -> String
-attr cs = "\27[" ++ concat (intersperse ";" $ map show cs) ++ "m"
rmfile ./ANSI.hs
hunk ./E/Pretty.hs 3
+import Atom(Atom,fromAtom)
+import Atom(intToAtom)
+import Char
+import Doc.Attr
+import Doc.DocLike
+import Doc.PPrint
+import Doc.Pretty
hunk ./E/Pretty.hs 12
-import Doc.Pretty
-import Doc.DocLike
-import Unparse
-import qualified Doc.Chars as UC
-import ANSI
-import Options
-import Char
+import FreeVars
hunk ./E/Pretty.hs 15
+import Options
hunk ./E/Pretty.hs 17
+import qualified Doc.Chars as UC
+import qualified FlagDump as FD
+import Unparse
hunk ./E/Pretty.hs 21
-import Atom(intToAtom)
-import FreeVars
-import Atom(Atom,fromAtom,toAtom)
-import Doc.PPrint
hunk ./E/Pretty.hs 30
-    
hunk ./E/Pretty.hs 31
+
hunk ./E/Pretty.hs 50
-data PrettyOpt = PrettyOpt { 
-    optExpanded :: Bool, 
-    optColors :: Bool, 
-    optNames :: Int -> Doc 
+data PrettyOpt = PrettyOpt {
+    optExpanded :: Bool,
+    optColors :: Bool,
+    optNames :: Int -> Doc
hunk ./E/Pretty.hs 61
-ePrettyEx e = (eDoc e prettyOpt { optExpanded = True}) 
-ePrettyN m e = (eDoc e prettyOpt { optNames = pName m}) 
-ePrettyNEx m e = (eDoc e prettyOpt { optExpanded = True, optNames = pName m}) 
+ePrettyEx e = (eDoc e prettyOpt { optExpanded = True})
+ePrettyN m e = (eDoc e prettyOpt { optNames = pName m})
+ePrettyNEx m e = (eDoc e prettyOpt { optExpanded = True, optNames = pName m})
hunk ./E/Pretty.hs 67
-        
+
hunk ./E/Pretty.hs 69
-pName nm = \i -> case IM.lookup i m of {Just d -> d ; Nothing -> text ('x':show i)} where 
+pName nm = \i -> case IM.lookup i m of {Just d -> d ; Nothing -> text ('x':show i)} where
hunk ./E/Pretty.hs 73
--}        
+-}
hunk ./E/Pretty.hs 78
-        TypeVal -> text $ UC.uArrow ++ show n 
-        _ -> text $ show n 
+        TypeVal -> text $ UC.uArrow ++ show n
+        _ -> text $ show n
hunk ./E/Pretty.hs 87
+attr = if dump FD.Html then html else ansi
+
hunk ./E/Pretty.hs 90
-bold doc = oob attrBold <> doc <> oob attrClear
+bold = attrBold (attr oob)
hunk ./E/Pretty.hs 92
-color :: Int -> Doc -> Doc
-color 1 doc = oob (attr [1]) <> doc <> oob (attr [0])
-color c doc = oob (attr [c]) <> doc <> oob (attr [39])
+--bold doc = oob attrBold <> doc <> oob attrClear
hunk ./E/Pretty.hs 95
-    
+--color :: Int -> Doc -> Doc
+--color 1 doc = oob (attr [1]) <> doc <> oob (attr [0])
+--color c doc = oob (attr [c]) <> doc <> oob (attr [39])
+
+
+
hunk ./E/Pretty.hs 102
-    unparseCat  =  (<>) 
-    unparseSpace  =  (<>) 
-    unparseGroup  = parens 
+    unparseCat  =  (<>)
+    unparseSpace  =  (<>)
+    unparseGroup  = parens
hunk ./E/Pretty.hs 113
-    retOp x = col 92 x
+    retOp x = col "lightgreen" x
hunk ./E/Pretty.hs 116
-    bc = bold' . char 
-    col n x = if colors then  (color n x) else x
+    bc = bold' . char
+    col n x = if colors then  (attrColor (attr oob) n x) else x
hunk ./E/Pretty.hs 120
-    symbol x = atom (col 1 x)
-    
+    --symbol x = atom (col 1 x)
+    symbol x = atom (bold' x)
+
hunk ./E/Pretty.hs 126
-    prettylit pbind (LitInt c t) | t == tChar = atom $ (col 94 (text (show $ chr $ fromIntegral  c)))
-    prettylit pbind (LitInt i _) = atom $ (col 94 (text $ show i)) 
+    prettylit pbind (LitInt c t) | t == tChar = atom $ (col "blue" (text (show $ chr $ fromIntegral  c)))
+    prettylit pbind (LitInt i _) = atom $ (col "blue" (text $ show i))
hunk ./E/Pretty.hs 129
-    prettylit pbind (LitCons s es _) | Just n <- isTup (snd $ (snd $ fromName s :: (String,String))), n == length es = atom $ tupled (map (unparse . pbind) es) 
+    prettylit pbind (LitCons s es _) | Just n <- isTup (snd $ (snd $ fromName s :: (String,String))), n == length es = atom $ tupled (map (unparse . pbind) es)
hunk ./E/Pretty.hs 132
-    prettylit pbind (LitCons s es _) | not expanded = foldl app  (atom $ text (snd $ fromName s)) ( map pbind es) 
+    prettylit pbind (LitCons s es _) | not expanded = foldl app  (atom $ text (snd $ fromName s)) ( map pbind es)
hunk ./E/Pretty.hs 138
-    app = bop (L,100) (text " ") 
+    app = bop (L,100) (text " ")
hunk ./E/Pretty.hs 144
-        e | Just s <- toString e -> atom $ text $ show s
-        e | Just xs <- toList e -> atom $ list (map (unparse . prettye) xs) 
+        e | Just s <- toString e -> atom $ col "blue" (text $ show s)
+        e | Just xs <- toList e -> atom $ list (map (unparse . prettye) xs)
hunk ./E/Pretty.hs 161
-            bg' = map ((<> bc ';') . unparse . prettydecl ) bg 
+            bg' = map ((<> bc ';') . unparse . prettydecl ) bg
hunk ./E/Pretty.hs 166
-            alts' = map  ((<> bc ';') . prettyalt b) alts ++ dcase 
+            alts' = map  ((<> bc ';') . prettyalt b) alts ++ dcase
hunk ./FlagDump.flags 3
-!Front End 
-renamed code after uniqueness renaming 
-parsed  parsed code 
-derived show generated derived instances 
+!Front End
+renamed code after uniqueness renaming
+parsed  parsed code
+derived show generated derived instances
hunk ./FlagDump.flags 9
-scc-modules show strongly connected modules in dependency order 
+scc-modules show strongly connected modules in dependency order
hunk ./FlagDump.flags 22
-all-dcons show unified data constructor table 
+all-dcons show unified data constructor table
hunk ./FlagDump.flags 37
-optimization-stats show combined stats of optimization passes 
+optimization-stats show combined stats of optimization passes
hunk ./FlagDump.flags 42
-tags list of all tags and their types 
+tags list of all tags and their types
hunk ./FlagDump.flags 48
-!General 
+!General
hunk ./FlagDump.flags 53
+html use html escape codes in output
hunk ./Grin/Show.hs 10
-import ANSI
hunk ./Grin/Show.hs 14
+import Doc.Attr
hunk ./Grin/Show.hs 16
+import qualified FlagDump as FD
+import Options
hunk ./Grin/Show.hs 30
+attr = if dump FD.Html then html else ansi
hunk ./Grin/Show.hs 32
-color :: Int -> Doc -> Doc
-color 1 doc = oob (attr [1]) <> doc <> oob (attr [0])
-color c doc = oob (attr [c]) <> doc <> oob (attr [39])
+bold :: Doc -> Doc
+bold = attrBold (attr oob)
+color n x = attrColor (attr oob) n x
hunk ./Grin/Show.hs 36
-operator = color 1 . text
-keyword = color 1 . text 
+--color :: Int -> Doc -> Doc
+--color 1 doc = oob (attr [1]) <> doc <> oob (attr [0])
+--color c doc = oob (attr [c]) <> doc <> oob (attr [39])
+
+operator = bold . text
+keyword = bold . text 
hunk ./Grin/Show.hs 43
-func = color 92 . text
-prim = color 91 . text
+func = color "lightgreen" . text
+prim = color "red" . text
hunk ./Main.hs 12
+import Control.Exception
hunk ./Main.hs 19
-import qualified E.CPR
-import qualified Info
hunk ./Main.hs 46
+import qualified E.CPR
hunk ./Main.hs 53
+import qualified Info
hunk ./Main.hs 68
-main = runMain $ do
+bracketHtml action = do
+    pn <- System.getProgName
+    as <- System.getArgs 
+    wdump FD.Html $ putStrLn $ "<html><head><title>" ++ (unwords (pn:as)) ++ "</title><meta http-equiv=\"Content-Type\" content=\"text/html; charset=utf-8\"></head><body style=\"background: black; color: lightgrey\"><pre>"
+    action `finally` (wdump FD.Html $ putStrLn "</pre></body></html>")
+
+main = runMain $ bracketHtml $ do