WebBits 0.11.0 → 0.14.0

raw patch · 37 files changed

+2482/−3008 lines, 37 filessetup-changedPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Setup.hs +37/−0
• Setup.lhs +0/−29
• WebBits.cabal +23/−19
• src/BrownPLT/Html.hs +14/−0
• src/BrownPLT/Html/Instances.hs +66/−0
• src/BrownPLT/Html/PermissiveParser.hs +492/−0
• src/BrownPLT/Html/PrettyPrint.hs +53/−0
• src/BrownPLT/Html/RawScript.hs +35/−0
• src/BrownPLT/Html/Syntax.hs +86/−0
• src/BrownPLT/JavaScript.hs +17/−0
• src/BrownPLT/JavaScript/Crawl.hs +102/−0
• src/BrownPLT/JavaScript/Environment.hs +146/−0
• src/BrownPLT/JavaScript/HtmlEmbedding.hs +25/−0
• src/BrownPLT/JavaScript/Instances.hs +294/−0
• src/BrownPLT/JavaScript/Lexer.hs +64/−0
• src/BrownPLT/JavaScript/Parser.hs +668/−0
• src/BrownPLT/JavaScript/PrettyPrint.hs +239/−0
• src/BrownPLT/JavaScript/Syntax.hs +121/−0
• src/WebBits/Common.hs +0/−63
• src/WebBits/Data/Zipper.hs +0/−274
• src/WebBits/Html/Html.hs +0/−14
• src/WebBits/Html/Instances.hs +0/−66
• src/WebBits/Html/PermissiveParser.hs +0/−492
• src/WebBits/Html/PrettyPrint.hs +0/−54
• src/WebBits/Html/RawScript.hs +0/−34
• src/WebBits/Html/Syntax.hs +0/−84
• src/WebBits/JavaScript.hs +0/−21
• src/WebBits/JavaScript/Combinators.hs +0/−39
• src/WebBits/JavaScript/Crawl.hs +0/−80
• src/WebBits/JavaScript/Environment.hs +0/−304
• src/WebBits/JavaScript/HtmlEmbedding.hs +0/−26
• src/WebBits/JavaScript/Instances.hs +0/−291
• src/WebBits/JavaScript/JavaScript.hs +0/−19
• src/WebBits/JavaScript/Lexer.hs +0/−64
• src/WebBits/JavaScript/Parser.hs +0/−657
• src/WebBits/JavaScript/PrettyPrint.hs +0/−261
• src/WebBits/JavaScript/Syntax.hs +0/−117

@@ -0,0 +1,37 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+import qualified Data.List as L+import System.Directory+import qualified Data.Char as Ch+import System.Process (runCommand,waitForProcess)++isHaskellFile file = ".lhs" `L.isSuffixOf` file || ".hs" `L.isSuffixOf` file++moduleName file = L.takeWhile  (/= '.') file++isRequested :: [String] -> String -> Bool+isRequested requestedTests test = +  (map Ch.toLower test) `elem` (map (map Ch.toLower) requestedTests)++testMain args _ _ _ = do+  files <- getDirectoryContents "tests"+  let testFiles = filter isHaskellFile files+  let testModules = if null args+                      then map moduleName testFiles+                      else filter (isRequested args) (map moduleName testFiles)+  let testFuncs = map (++ ".main") testModules+  let testExpr = "sequence [ " ++ concat (L.intersperse "," testFuncs) ++ +                 " ] >>= \\cases -> runTestTT (TestList cases)"+  let moduleLine = concat (L.intersperse " " testModules)+  let cmd = "cd tests && ghc  -XNoMonomorphismRestriction -fglasgow-exts " +++            "-package HUnit -package parsec-2.1.0.1 -i:../src -e \"" ++ +            testExpr ++ " >> return ()\" " ++ moduleLine+  putStrLn "Testing command is:"+  putStrLn cmd+  putStrLn "\nLoading tests..."+  handle <- runCommand cmd+  waitForProcess handle+  putStrLn "Testing complete.  Errors reported above (if any)."+++main = defaultMainWithHooks (simpleUserHooks { runTests = testMain })

@@ -1,29 +0,0 @@-#!/usr/bin/env runhaskell-> import Distribution.Simple-> import qualified Data.List as L-> import System.Directory-> import System.Process (runCommand,waitForProcess)--> isHaskellFile file = ".lhs" `L.isSuffixOf` file || ".hs" `L.isSuffixOf` file--> moduleName file = L.takeWhile  (/= '.') file--> testMain _ _ _ _ = do->   files <- getDirectoryContents "tests"->   let testModules = [moduleName f | f <- files, isHaskellFile f]->   let testFuncs = map (++ ".main") testModules->   let testExpr = "sequence [ " ++ concat (L.intersperse "," testFuncs) ++ ->                  " ] >>= \\cases -> runTestTT (TestList cases)"->   let moduleLine = concat (L.intersperse " " testModules)->   let cmd = "cd tests && ghc  -XNoMonomorphismRestriction -fglasgow-exts " ++->             "-package HUnit -i:../src -e \"" ++ testExpr ++ ->             " >> return ()\" " ++ moduleLine->   putStrLn "Testing command is:"->   putStrLn cmd->   putStrLn "\nLoading tests..."->   handle <- runCommand cmd->   waitForProcess handle->   putStrLn "Testing complete.  Errors reported above (if any)."- --> main = defaultMainWithHooks (simpleUserHooks { runTests = testMain })

@@ -1,7 +1,7 @@ Name:           WebBits-Version:        0.11.0+Version:        0.14.0 Cabal-Version:	>= 1.2.3-Copyright:      Copyright (c) 2007-2008 Arjun Guha and Spiridon Eliopoulos+Copyright:      Copyright (c) 2007-2009 Arjun Guha and Spiridon Eliopoulos License:        LGPL License-file:   LICENSE Author:         Arjun Guha, Spiridon Eliopoulos@@ -16,16 +16,16 @@ 	WebBits is a collection of libraries for working with JavaScript embeded in   HTML files.  Highlights include:   .-	* @WebBits.JavaScript.Crawl@ returns all JavaScript in an HTML page, including+	* @BrownPLT.JavaScript.Crawl@ returns all JavaScript in an HTML page, including      JavaScript from imported script files (@\<script src=...\>@).   .-  * @WebBits.JavaScript.Environment@ annotates JavaScript syntax with its static-    environment and returns a list of free identifiers.+  * @BrownPLT.JavaScript.Environment@ annotates JavaScript syntax with its +    static environment and returns a list of free identifiers.   .-  * @WebBits.JavaScript.Parser@ is a JavaScript parser that is largely based on+  * @BrownPLT.JavaScript.Parser@ is a JavaScript parser that is largely based on     JavaScript 1.5.   .-  * @WebBits.Html.Parser@ is a permissive HTML parser.+  * @BrownPLT.Html.Parser@ is a permissive HTML parser.   Library   Hs-Source-Dirs:@@ -35,16 +35,20 @@   ghc-options:     -fwarn-incomplete-patterns   Extensions:     -    Generics Rank2Types MultiParamTypeClasses FunctionalDependencies-    TypeSynonymInstances FlexibleInstances FlexibleContexts-    DeriveDataTypeable NoMonomorphismRestriction RelaxedPolyRec+    Generics TypeSynonymInstances DeriveDataTypeable   Exposed-Modules:-    WebBits.Data.Zipper-    WebBits.Html.Html WebBits.Html.Syntax WebBits.Html.PermissiveParser-    WebBits.Html.PrettyPrint WebBits.Html.Instances WebBits.Common-    WebBits.Html.RawScript WebBits.JavaScript.Combinators-    WebBits.JavaScript.HtmlEmbedding WebBits.JavaScript.Instances-    WebBits.JavaScript.JavaScript WebBits.JavaScript.Lexer -    WebBits.JavaScript.Parser WebBits.JavaScript.PrettyPrint-    WebBits.JavaScript.Syntax WebBits.JavaScript.Environment-    WebBits.JavaScript.Crawl WebBits.JavaScript+    BrownPLT.Html+    BrownPLT.Html.Syntax+    BrownPLT.Html.PermissiveParser+    BrownPLT.Html.PrettyPrint +    BrownPLT.Html.Instances+    BrownPLT.Html.RawScript+    BrownPLT.JavaScript +    BrownPLT.JavaScript.HtmlEmbedding +    BrownPLT.JavaScript.Instances+    BrownPLT.JavaScript.Lexer +    BrownPLT.JavaScript.Parser+    BrownPLT.JavaScript.PrettyPrint+    BrownPLT.JavaScript.Syntax +    BrownPLT.JavaScript.Crawl+    BrownPLT.JavaScript.Environment

@@ -0,0 +1,14 @@+-- |Rexports various modules of the HTML library.  It's best to use this in lieu+-- of selectively importing the following libraries.+module BrownPLT.Html+  ( module BrownPLT.Html.Syntax+  -- PermissiveParser+  , renderHtml+  , parseHtmlFromFile+  , parseHtmlFromString+  ) where+  +import BrownPLT.Html.Syntax+import BrownPLT.Html.PermissiveParser+import BrownPLT.Html.PrettyPrint -- no names, only instances+import BrownPLT.Html.Instances -- no names, only instances

@@ -0,0 +1,66 @@+module BrownPLT.Html.Instances() where++import qualified Prelude as Prelude+import Prelude (Functor,map,fmap)+import qualified Data.List as List+import qualified Data.Char as Char+import Data.Foldable+import Data.Traversable+import Control.Applicative++import BrownPLT.Html.Syntax++ltraverse:: (Traversable t, Applicative f) => (a -> f b) -> [t a] -> f [t b]+ltraverse f [] = pure []+ltraverse f (x:xs) = pure (:) <*> (traverse f x) <*> ltraverse f xs++instance Functor (Attribute a) where+  fmap f (Attribute id val a)            = Attribute id val a+  fmap f (AttributeExpr a id script def) = AttributeExpr a id (f script) def++instance Functor (Html a) where+  fmap f (Element id attrs children a) = +    Element id (map (fmap f) attrs) (map (fmap f) children) a+  fmap f (Text str a)                  = Text str a+  fmap f (Comment str a)               = Comment str a+  fmap f (HtmlSeq xs)                  = HtmlSeq (map (fmap f) xs)+  fmap f (ProcessingInstruction str a) = ProcessingInstruction str a+  fmap f (InlineScript script a def)   = InlineScript (f script) a def+  fmap f (Script script a)             = Script (f script) a++instance Foldable (Attribute a) where+  foldr f x (Attribute id val a)          = x+  foldr f x (AttributeExpr a id script def) = f script x++instance Foldable (Html a) where+  foldr f x (Element id attrs children a) =+    Prelude.foldr  (\child x' -> foldr f x' child) x children  +  foldr f x (Text str a)                  = x+  foldr f x (Comment str a)               = x+  foldr f x (HtmlSeq ys)                  = +    Prelude.foldr (\child x' -> foldr f x' child) x ys+  foldr f x (ProcessingInstruction str a) = x+  foldr f x (InlineScript script a def)   = f script x+  foldr f x (Script script a)             = f script x++instance Traversable (Attribute a) where+  traverse f (Attribute id val a)            =+    pure (Attribute id val a)+  traverse f (AttributeExpr a id script def) =+    (AttributeExpr a id) <$> (f script) <*> pure def++instance Traversable (Html a) where+  traverse f (Element id attrs children a) = +    (Element id) <$> ltraverse f attrs  <*> ltraverse f children <*> pure a+  traverse f (Text str a)                  = +    pure (Text str a)+  traverse f (Comment str a)               = +    pure (Comment str a)+  traverse f (HtmlSeq xs)                  = +    HtmlSeq <$> ltraverse f xs+  traverse f (ProcessingInstruction str a) = +    pure (ProcessingInstruction str a)+  traverse f (InlineScript script a def)   =+    InlineScript <$> (f script) <*> pure a <*> pure def+  traverse f (Script script a)             = +    Script <$> (f script) <*> pure a

@@ -0,0 +1,492 @@+-- |A structure-recovering parser for malformed documents.+--+-- Copyright 2007-2008 Arjun Guha.+-- Based on HtmlPrag 0.16 Copyright (C) 2003 - 2005 Neil W. Van Dyke.  +--+-- This program is Free Software; you can redistribute it and/or modify it under+-- the terms of the GNU Lesser General Public License as published by the Free+-- Software Foundation; either version 2.1 of the License, or (at your option)+-- any later version.  This program is distributed in the hope that it will be+-- useful, but without any warranty; without even the implied warranty of+-- merchantability or fitness for a particular purpose.  See +-- <http://www.gnu.org/copyleft/lesser.html> for details.  For other license+-- options and consulting, contact the author.+module BrownPLT.Html.PermissiveParser+  ( html+  , parseHtmlFromFile+  , parseHtmlFromString+  -- tokenizer is exported primarily for testing+  , tokens+  , Token+  ) where++import Control.Monad+import Text.ParserCombinators.Parsec hiding (token,tokens)+import qualified Text.ParserCombinators.Parsec as Parsec+import Data.Char (toLower)+import Data.List (intersperse)++import qualified BrownPLT.Html.Syntax as Html+import BrownPLT.Html.Syntax (HtmlId,Attribute,Script(..))++type ParsedHtml s = Html.Html SourcePos s+type ParsedAttribute s = Html.Attribute SourcePos s++--------------------------------------------------------------------------------+-- Parsers generate warnings++data Warning = StringWarning SourcePos String++instance Show Warning where+  show (StringWarning p s) = "Warning parsing HTML: " ++ s+  showList [] s = s+  showList (x:xs) s = show x ++ ('\n':showList xs s)++warn:: String -> GenParser tok [Warning] ()+warn s = do+  p <- getPosition+  updateState ((StringWarning p s):)++noWarnings:: [Warning]+noWarnings = []+  ++-- A structure-recovering parser for malformed documents, derived from+-- Neil W. Van Dyke's htmlprag library for PLT Scheme++-- The elements in the list can legally enclose the 1st element of the pair.+parentConstraints:: [(HtmlId,[HtmlId])]+parentConstraints =+  [("area",["map"]),+   ("body",["html"]),+   ("caption", ["table"]),+   ("colgroup", ["table"]),+   ("dd", ["dl"]),+   ("dt", ["dl"]),+   ("frame", ["frameset"]),+   ("head", ["html"]),+   ("isindex", ["head"]),+   ("li", ["dir", "menu", "ol", "ul"]),+   ("meta", ["head"]),+   ("noframes", ["frameset"]),+   ("option", ["select"]),+   ("p", ["body", "td", "th"]),+   ("param", ["applet"]),+   ("tbody", ["table"]),+   ("td", ["tr"]),+   ("th", ["tr"]),+   ("thead", ["table"]),+   ("title", ["head"]),+   ("tr", ["table", "tbody", "thead"])]++-- |List of HTML elements that are empty.+emptyElements:: [HtmlId]+emptyElements = +  ["area", "base", "br", "frame", "hr", "img", "input", "isindex", "keygen", +   "link", "meta", "object", "param", "spacer", "wbr"]++isLegalChildOf:: HtmlId -> HtmlId -> Bool+isLegalChildOf child parent =+  case lookup child parentConstraints of+    Nothing             -> True+    (Just legalParents) -> parent `elem` legalParents+    +isEmptyElement:: HtmlId -> Bool+isEmptyElement element = element `elem` emptyElements++--}}}++--------------------------------------------------------------------------------+-- Parses an HTML file into a stream of tokens.++-- The auxillary parsing functions return values of this type.+data Script s  => Token s+  = Text SourcePos String+  | EntityToken SourcePos String+  | EntityInt SourcePos Int+  | Tag SourcePos HtmlId [Attribute SourcePos s] Bool {-closed?-}+  | Script SourcePos s+  | Inline SourcePos s String+  | EndTag SourcePos HtmlId+  | Comment SourcePos String+  | DoctypeToken SourcePos String String String (Maybe String)+++token:: Script s => Bool -> [Attribute SourcePos s] +     -> CharParser [Warning] (Token s)+token expectedScript prevAttrs = case expectedScript of+  True  -> (liftM2 Script getPosition (parseScriptBlock prevAttrs)) +             <?> "expected a script after a <script> tag"+  False -> doctype <|> comment <|> tag <|> endTag <|> inlineScript <|> entity +             <|> text++tokens:: Script s => CharParser [Warning] [Token s]+tokens = (eof >> return []) <|> tokens' where+  tokens' = do +    t <- token False []+    case t of+      (Tag _ "script" attrs False) -> do s <- token True attrs+                                         ts <- tokens+                                         return (t:s:ts)+      _ -> tokens >>= return.(t:)++--------------------------------------------------------------------------------+-- Parsers for various components of HTML++qname:: CharParser st String+qname = do+  x <- letter+  xs <- many (noneOf "/*=<>\"\'  \v\f\t\r\n")+  return (x:xs)++-- |We do not permit spaces between the hyphens and the right-angle in the+-- terminating '-->'.+comment:: Script s => CharParser st (Token s) +comment =+  let notDoubleHyphen = try (char '-' >> notFollowedBy (char '-') >> return '-')+      notHyphen = noneOf "-"+    in do try (string "<!--")+          pos <- getPosition+          msg <- many (notHyphen <|> notDoubleHyphen)+          string "-->"+          return (Comment pos msg)++endTag:: Script s => CharParser [Warning] (Token s)+endTag  = do+  pos <- getPosition+  string "</"+  name <- qname <?> "closing tag\'s name"+  junk <- manyTill anyChar (char '>') -- permits junk between tag name and '>'+  unless (null junk) (warn $ "extra characters: " ++ junk ++ +                             "; assuming tag name is " ++ name)+  return (EndTag pos name)+  +doctype:: Script s => CharParser [Warning] (Token s)+doctype = do+  p <- getPosition+  try (string "<!DOCTYPE")+  spaces+  top <- qname <?> "top-element name"+  spaces+  avail <- qname <?> "availability"+  spaces+  regEtc <- quotedString <?> "registration, etc."+  spaces+  uri <- optionMaybe quotedString+  spaces+  string ">"+  return (DoctypeToken p top avail regEtc uri)+  +entity:: Script s => CharParser [Warning] (Token s)+entity = do+  char '&'+  pos <- getPosition+  name <- many alphaNum <|> (char '#' >> many1 digit)+  when (null name) (warn "no identifer or number after &")+  (char ';' >> return ()) <|> (warn "expected semi-colon after entity") +  return (EntityToken pos name)+  +notScript:: CharParser a Char+notScript = try (char '{' >> notFollowedBy (char '!') >> return '{')++-- Parses raw text, upto an opening angle-bracket ('<').+text:: Script s => CharParser st (Token s)+text = do+  pos  <- getPosition+  cs <- many1 (noneOf "<{" <|> notScript) -- Doesn't consume the terminating angle bracket.+  return (Text pos cs)++-- Strings that are either double-quoted or single-quoted.  Note that HTML+-- strings contain no escape sequences.+quotedString:: CharParser a String+quotedString =+  (char '"' >> manyTill anyChar (char '"')) <|>+  (char '\'' >> manyTill anyChar (char '\'')) <?>+  "quoted string (double-quotes or single quotes)"++-- Parses text to the right of a triple-stick in an inline expression.  We have+-- to ensure that if we read a `!,' it isn't immediately followed by `}.'+initText =+  let notEnd = try (char '!' >> notFollowedBy (char '}') >> return '!')+    in many1 (notEnd <|> noneOf "!")++scriptValue:: Script s => CharParser a (s,String)+scriptValue =+  case parseAttributeScript of+    Nothing -> fail "attribute-script parser not defined"+    (Just parser) -> do string "{!"+                        script <- parser+                        init <- (string "!}" >> return "")  <|> +                                (string "|||" >> initText >>= +                                 (\s -> string "!}" >> return s))+                        return (script,init)++number:: CharParser a String+number = many1 digit++-- +nonquotedAttribute:: CharParser [Warning]  String+nonquotedAttribute = do+  x <- alphaNum <|> oneOf "_"+  xs <- many (noneOf "/*=<>\"\'  \v\f\t\r\n")+  warn $ "non-quoted attribute value: " ++ (x:xs)+  return (x:xs)+++attribute:: Script s => CharParser [Warning] (Html.Attribute SourcePos s)+attribute = do+  pos  <- getPosition+  name <- qname <?> "attribute name"+  spaces+  value <- (do char '='+               spaces+               (liftM Right scriptValue)+                 <|> (liftM Left (quotedString <|> nonquotedAttribute)) +                 <?> "attribute value")+           <|> (return $ Left "") -- Unspecified values are empty values.+  case value of+    (Left v)      -> return $ Html.Attribute name v pos+    (Right (s,d)) -> return $ Html.AttributeExpr pos name s d++-- Takes the name of the immediately-enclosing parent tag as an argument.+tag:: Script s => CharParser [Warning] (Token s)+tag = do+  try (char '<' >> notFollowedBy (char '/'))+  pos <- getPosition+  name <- qname <?>  "opening tag\'s name"+  spaces+  attributes <- (attribute `sepEndBy` spaces)+  (char '>' >> return (Tag pos name attributes False))+    <|> (string "/>" >> return (Tag pos name attributes True))+    <?> "end of tag (i.e. \">\")"+++-- Parses an inline (curly-banged) script, if an inline-script parser has been+-- specified (i.e. not Nothing).  Two-character lookahead for the ``{!,'' after+-- which control is passed to the inline script parser.  Once control returns,+-- the parser expects to see the closing ``!}.''+inlineScript:: Script s => CharParser a (Token s)+inlineScript =+  case parseInlineScript of+    Nothing -> fail "no inline script parser specified." -- TODO: appropriate?+    (Just parser) -> do string "{!" <?> "{! script !}"+                        pos <- getPosition+                        script <- parser+                        spaces+                        init <- (string "!}" >> return "") <|>+                                (string "|||" >> initText >>= +                                 (\s -> string "!}" >> return s))+                        return $ Inline pos script init+++-- Parses a stream of tokens, with a script parser, s and returns values of +-- type a.+type TokenParser s a = GenParser (Token s) [Warning] a++instance Script s => Show (Token s) where+  show = tokenShow++tokenShow token = case token of+  (Text _ s)        -> s+  (EntityToken _ s) -> "&" ++ s ++ ";"+  (EntityInt _ n)   -> "&#" ++ show n ++ ";"+  (Tag _ id attrs closed) -> +    "<" ++ id ++ " ... " ++ closing where+      closing = if closed then "/>" else ">"+  (Script _ s)  -> "/* script body omitted */"+  (Inline _ s _)-> "{! /* script */ !}"+  (EndTag _ id) -> "</" ++ show id ++ ">"+  (Comment _ s) -> "<!-- " ++ show s ++ " -->"+  (DoctypeToken _ top avail desc Nothing) ->+    "<!DOCTYPE " ++ top ++ " " ++ avail ++ " " ++ show desc ++ ">"+  (DoctypeToken _ top avail desc (Just uri)) ->+    "<!DOCTYPE " ++ top ++ " " ++ avail ++ " " ++ show desc ++ " " +      ++ show uri ++ ">" ++tokenPos tok = case tok of+  (Text p _) -> p+  (EntityToken p _) -> p+  (EntityInt p _) -> p+  (Tag p _ _ _) -> p+  (Script p _) -> p+  (Inline p _ _) -> p+  (EndTag p _) -> p+  (Comment p _) -> p+  (DoctypeToken p _ _ _ _) -> p+    +textToken :: Script s => TokenParser s (ParsedHtml s)+textToken = Parsec.token tokenShow tokenPos $ \t -> case t of+  Text _ s -> Just (Html.Text s (tokenPos t))+  otherwise -> Nothing+             +entityToken :: Script s => TokenParser s (ParsedHtml s)+entityToken =+  Parsec.token tokenShow tokenPos+    (\t -> case t of+             (EntityToken p s) -> Just (Html.Text ("&" ++ s ++ ";") p)+             (EntityInt p n) -> Just (Html.Text ("&#" ++ show n ++ ";") p)+             otherwise -> Nothing)+           +commentToken :: Script s => TokenParser s (ParsedHtml s)+commentToken = +  Parsec.token tokenShow tokenPos+    (\t -> case t of+             (Comment _ s) -> Just (Html.Comment s (tokenPos t))+             otherwise -> Nothing)++scriptToken :: Script s => TokenParser s (ParsedHtml s) +scriptToken = +  Parsec.token tokenShow tokenPos+    (\t -> case t of+             (Script p s) -> Just (Html.Script s p)+             otherwise    -> Nothing)++inlineToken :: Script s => TokenParser s (ParsedHtml s)+inlineToken = +  Parsec.token tokenShow tokenPos+    (\t -> case t of+             (Inline p s d) -> Just (Html.InlineScript s p d)+             otherwise    -> Nothing)+             +endToken :: Script s => TokenParser s HtmlId+endToken = +  Parsec.token tokenShow tokenPos+    (\t -> case t of+             (EndTag p s) -> Just s+             otherwise    -> Nothing)++tagToken :: Script s => TokenParser s (Token s)+tagToken = +  Parsec.token tokenShow tokenPos+  (\t -> case t of+           (Tag p id attrs closed) -> Just t+           otherwise               -> Nothing)++doctypeToken :: Script s => TokenParser s (Token s)+doctypeToken = Parsec.token tokenShow tokenPos $ \t -> case t of+  DoctypeToken _ _ _ _ _ -> Just t+  otherwise -> Nothing++--------------------------------------------------------------------------------+-- HTML fragments++-- |An HTML fragment represents an HTML element with a sequence of children.+data HtmlFragment s = Fragment {+  fragmentPosition   :: SourcePos,+  fragmentName       :: HtmlId,+  fragmentAttributes :: [ParsedAttribute s],+  fragmentChildren   :: [ParsedHtml s]+}++closeFragment:: HtmlFragment s -> ParsedHtml s+closeFragment (Fragment p htmlId attrs children) =  +  Html.Element htmlId attrs (reverse children) p++appendChildToFragment child fragment =+  fragment { fragmentChildren = child : (fragmentChildren fragment) }+             +atomic :: Script s => TokenParser s (ParsedHtml s)+atomic =+  textToken <|> commentToken <|> scriptToken <|> inlineToken <|> entityToken+++maybeClose :: Script s => [HtmlFragment s] -> TokenParser s [HtmlFragment s] +maybeClose es = do+  htmlId <- endToken+  let close [] = do +        warn $ "unmatched closing tag \"" ++ htmlId ++ "\"; ignoring"+        return es+      close (e:e2:es) | fragmentName e == htmlId = do+        return $ (appendChildToFragment (closeFragment e) e2) : es+      close (e:e2:es) | otherwise = +        let e2' = appendChildToFragment (closeFragment e) e2+          in close (e2':es)+      close [e] | fragmentName e == htmlId = do+        return [e]+      close [e] | otherwise = do+        warn $ "unmatched closing tag \"" ++ htmlId ++ "\"; ignoring"+        return [e]+    in close es++open :: Script s => [HtmlFragment s] -> TokenParser s [HtmlFragment s]+open [] = fail "PermissiveParser.open: invalid state (1)"+open (e:es) = do+  (Tag p id attrs isClosed) <- tagToken+  case isClosed of+    True -> return $ (appendChildToFragment (Html.Element id attrs [] p) e) : es+    False ->+      case isEmptyElement id of+        True -> do warn $ "empty-element, \"" ++ id +                            ++ "\" was not immediately closed"+                   return $ (appendChildToFragment (Html.Element id attrs [] p)+                               e) : es+        False -> do+          let fragment = Fragment p id attrs []+              -- If we reach the root, simply make 'fragment' a child.+          let insert [root] = [fragment,root]+              -- The <html> element is the only child of the root.  This+              -- catches all other elements and makes them children of <html>.+              insert [html,root] = [fragment,html,root]+              insert (e1:e2:es) | id `isLegalChildOf` (fragmentName e1) =+                fragment:e1:e2:es+              insert (e1:e2:es) | otherwise =+                insert $ (appendChildToFragment (closeFragment e1) e2):es +              insert [] = fail "PermissiveParser.open: invalid state (2)"+          return $ insert (e:es)++structured es = do+  maybeClose es <|> open es++html' :: Script s => [HtmlFragment s] -> TokenParser s [HtmlFragment s]+html' [] = fail "PermissiveParser.html': invalid state (1)"+html' (e:es) =+  (do a <- atomic+      html' $ (appendChildToFragment a e):es) <|>+  (structured (e:es) >>= html') <|>+  (return (e:es))++parseRoot = Fragment (error "parseRoot: position is meaningless") +                     "DOCROOT"  (error "parseRoot: attributes are meaningless")+                     []++html :: Script s => CharParser [Warning] (Html.Html SourcePos s)+html = do+  let parser = do+        -- optional doctypeToken -- ignored+        fragments <- html' [parseRoot]+        case fragments of+          [fragment] -> case closeFragment fragment of +                          Html.Element _ _ (c:_) _ -> do+                            ws <- getState+                            return (ws,head [c])+                          otherwise -> fail "root element not found"+          otherwise -> fail "no root / multiple roots"+  toks <- tokens -- a stream of HTML entities+  pos <- Parsec.getPosition+  warnings <- Parsec.getState+  case Parsec.runParser parser warnings (Parsec.sourceName pos) toks of+    Left e -> fail  $ "unparsable HTML: " ++ (show e)+    Right (ws,html) -> Parsec.setState ws >> return html ++htmlWithWarnings :: Script s +                 => CharParser [Warning] (Html.Html SourcePos s,[Warning])+htmlWithWarnings = do+  h <- html+  ws <- getState+  return (h,ws)++parseHtmlFromString :: Script s => String -> String -> Either Parsec.ParseError (Html.Html SourcePos s,[Warning])+parseHtmlFromString sourceName sourceText = +  case Parsec.runParser htmlWithWarnings noWarnings sourceName sourceText of+    Left err -> Left err+    Right (html,ws) -> Right (html,ws) ++parseHtmlFromFile :: Script s +                  => String +                  -> IO (Either Parsec.ParseError +                                (Html.Html SourcePos s,[Warning]))+parseHtmlFromFile filename = do+  chars <- readFile filename+  case Parsec.runParser htmlWithWarnings noWarnings filename chars of+    Left err -> return (Left err)+    Right (html,ws) -> return $ Right (html,ws)

@@ -0,0 +1,53 @@+-- |Pretty-printer for HTML.  This modules exports no names.  It only defines+-- instances of 'PrettyPrintable' for HTML. +module BrownPLT.Html.PrettyPrint+  ( html+  , renderHtml+  ) where++import qualified Data.List as List+import qualified Data.Char as Char+import Text.PrettyPrint.HughesPJ++import BrownPLT.Html.Syntax++renderHtml :: Script s => Html a s -> String+renderHtml = render.html++vert [] = empty+vert [doc] = doc+vert (doc:docs) = doc <> text "<!--" $+$+                  text "-->" <> vert docs++attr :: Script s => Attribute a s -> Doc+attr a = case a of+  Attribute name value _ ->+    text name <> equals <> doubleQuotes (text value)+  AttributeExpr _ n v "" ->+    text n <> equals <> text "{!" <+> prettyPrintScript v <+> text "!}"+  AttributeExpr _ n v d ->+    text n <> equals <> text "{!" <+> prettyPrintScript v <+> text "|||" <+> +    text d <+> text "!}"++html :: Script s => Html a s -> Doc+html x = case x of+  -- The <script> tag must be terminated by </script>.+  -- <script lang= src= /> doesn't work.+  Element name attrs children _ ->+    -- WARNING: Spacing is very sensitive+    text "<" <> text name <+> hsep (map attr attrs) <> text ">"  -- opening+      $$ (nest 2 (vcat (map html children)))                     -- body+      $$ text "</" <> text name <> text ">"                    -- closing+  -- Horizontally aligned material that is vertically represented in source.+  HtmlSeq xs -> vert (map html xs)+  Text str _ -> text (skipWs str) where+    skipWs str = List.dropWhile Char.isSpace str+  Comment str _ -> text "<!--" <+> text str <+> text "-->"+  ProcessingInstruction str _ -> text "<?" <> text str <> text ">"+  Script s _ -> prettyPrintScript s+  InlineScript script _ "" ->+    text "{!" <+> prettyPrintScript script <+> text "!}"+  InlineScript script _ init -> +    text "{!" <+> prettyPrintScript script <+> text "|||" <+> +    text init <+> text "!}"+

@@ -0,0 +1,35 @@+module BrownPLT.Html.RawScript+  ( RawScript (..)+  , parseFromFile+  , parseFromString+  , RawHtml+  ) where++import Data.Generics (Data, Typeable)+import Text.PrettyPrint.HughesPJ (text)+import Text.ParserCombinators.Parsec+import BrownPLT.Html.Syntax+import BrownPLT.Html.PermissiveParser++type RawHtml = Html SourcePos RawScript+++data RawScript = RawScript String deriving (Show,Eq,Typeable,Data)+++instance Script RawScript where++  prettyPrintScript (RawScript s) = text s+  parseInlineScript = Nothing+  +  parseAttributeScript = Nothing+  +  parseScriptBlock _ = do+    s <- manyTill anyChar (string "</script>")+    return (RawScript s)+    ++parseFromString :: String -> RawHtml+parseFromString s = case parseHtmlFromString "" s of+  Left e -> error (show e)+  Right (html,_) -> html

@@ -0,0 +1,86 @@+-- |Datatypes for HTML parameterized over an annotation type and a script type.+module BrownPLT.Html.Syntax +  (+  -- * HTML Data Structures+    HtmlId,AttributeValue, Attribute (..), Html (..)+  -- * The Script class+  , Script (..)+  -- * Miscellaneous Functions+  , attributeValue, attributeUpdate, attributeSet, isAttributeExpr+  ) where++import Text.ParserCombinators.Parsec (CharParser, SourcePos)+import Text.PrettyPrint.HughesPJ (Doc)+import Data.Generics (Data, Typeable)++--------------------------------------------------------------------------------+-- Types++type HtmlId = String+type AttributeValue = String++data Attribute a s+  = Attribute HtmlId AttributeValue a+  | AttributeExpr a HtmlId s String+  deriving (Show,Eq,Typeable,Data)++data Html a sc+  = Element HtmlId [Attribute a sc] [Html a sc] a+  | Text String a+  | Comment String a+  | HtmlSeq [Html a sc] -- ^must be a non-empty list+  | ProcessingInstruction String a+  | InlineScript sc a String+  | Script sc a+  deriving (Show,Eq,Typeable,Data)+  +--------------------------------------------------------------------------------+-- The Script class++-- |A type 't' of the 'Script' class can be parsed using 'Parsec'.  't' is of+-- kind '* -> *', as the parsed AST should be annotated with souce locations+-- (see 'Text.ParserCombinators.Parsec.SourcePos').+--+-- The big deal here is that we can embed a parser for some scripting language,+-- (e.g. Javascript) into this HTML parser with ease, while preserving source+-- locations.  The Html datatype is parameterized over a script parser (an+-- instance of Script).+class Script t where+  prettyPrintScript :: t -> Doc+  parseScriptBlock:: [Attribute SourcePos t] -> CharParser a t+  -- An inline script parser, which may be Nothing if the scripting language+  -- does not support inline scripts.+  parseInlineScript:: Maybe (CharParser a t)+  -- A parser for script-expressions defined inline as attribute values.+  parseAttributeScript:: Maybe (CharParser a t)+  +--------------------------------------------------------------------------------+-- HTML navigation++isAttributeExpr (AttributeExpr _ _ _ _) = True+isAttributeExpr _                       = False++-- |Returns the value of the attribute in the list, or 'Nothing' if it doesn't+-- exist of the value is an inline-expression.+attributeValue:: HtmlId -> [Attribute a s] -> Maybe String+attributeValue name [] = Nothing+attributeValue name ((AttributeExpr pos name' expr init):rest) =+  if name == name' then Nothing+                   else attributeValue name rest+attributeValue name ((Attribute name' value _):rest) =+  if name == name' then Just value+                   else attributeValue name rest++attributeSet:: HtmlId -> String -> [Attribute a s]  -> [Attribute a s]+attributeSet n v attrs = attributeUpdate n (\_ -> v) attrs++attributeUpdate:: HtmlId -> (String -> String) -> [Attribute a s] +               -> [Attribute a s]+attributeUpdate n f [] = +  [Attribute n (f "") (error "attributeUpdate--no value")] -- TODO: undefined?!+attributeUpdate n _ ((AttributeExpr _ _ _ _):_) =+  error $ "attributeUpdate: " ++ n ++ " is an expression-attribute."+attributeUpdate n f ((Attribute n' v p):attrs) =+  if n' == n then (Attribute n (f v) p):attrs+             else (Attribute n' v p):(attributeUpdate n f attrs)+

@@ -0,0 +1,17 @@+-- |Re-exports commonly used modules.+module BrownPLT.JavaScript+  ( module BrownPLT.JavaScript.Syntax+  , module BrownPLT.JavaScript.HtmlEmbedding+  , module BrownPLT.JavaScript.Parser+  -- JavaScript.Instances exports nothing+  , renderStatements+  , renderExpression+  ) where+++import BrownPLT.JavaScript.Syntax+import BrownPLT.JavaScript.Parser+import BrownPLT.JavaScript.PrettyPrint+import BrownPLT.JavaScript.HtmlEmbedding++import BrownPLT.JavaScript.Instances

@@ -0,0 +1,102 @@+-- |Crawls an HTML page for JavaScript+module BrownPLT.JavaScript.Crawl +  ( getPageJavaScript+  ) where++import Control.Monad+import Data.List+import Data.Char (toLower)+import Data.Generics+import System.IO+import Text.ParserCombinators.Parsec.Pos (SourcePos, sourceName)+import Text.ParserCombinators.Parsec(parse,setPosition,incSourceColumn,Column,sourceLine,sourceColumn)++import BrownPLT.Html.Syntax+import qualified BrownPLT.JavaScript as Js+++instance Typeable SourcePos where+  typeOf _  = +    mkTyConApp (mkTyCon "Text.ParserCombinators.Parsec.Pos.SourcePos") []++ +-- Complete guesswork.  It seems to work.+-- This definition is incomplete.+instance Data SourcePos where+  -- We treat source locations as opaque.  After all, we don't have access to+  -- the constructor.+  gfoldl k z pos = z pos+  toConstr _ = sourcePosConstr1 where+    sourcePosConstr1 = mkConstr sourcePosDatatype "SourcePos" [] Prefix+    sourcePosDatatype = mkDataType "SourcePos" [sourcePosConstr1]+  gunfold   = error "gunfold is not defined for SourcePos"+  dataTypeOf = error "dataTypeOf is not defined for SourcePos"+++-- |Returns the source of the script.+scriptSrc:: Js.ParsedJsHtml -> [String]+scriptSrc (Element tag attrs _ _) | (map toLower tag) == "script" =+  case attributeValue "src" attrs of -- TODO: Check for type="javascript"?+    Just ""  -> []+    Just url -> [url]+    Nothing  -> []+scriptSrc _ =+  []+++-- |Returns a list of URIs for external Javascript files referenced in the page.+importedScripts:: Js.ParsedJsHtml -> [String]+importedScripts = everything (++) (mkQ [] scriptSrc)++-- |Returns the top-level statements of a script.+scriptText :: Js.ParsedJsHtml -> [Js.ParsedStatement]+scriptText (Script (Js.Script _ stmts) _) = stmts+scriptText _ = []++eventHandlers :: [String]+eventHandlers = ["onload","onclick"]; +-- ,"onmousemove","onmouseover","onmousedown","onmouseout","onmouseup","onselectstart", "onkeypress"]++attrScript :: Attribute SourcePos Js.ParsedJavaScript +           -> IO [Js.ParsedStatement]+attrScript (Attribute id val loc) | id `elem` eventHandlers = do+  let eventId = drop 2 id -- drop the "on" prefix+  let scriptText = if "javascript:" `isPrefixOf` val then drop 11 val else val+  let eventListenerPrefix = "addEventListener('" ++ eventId ++ "', function(event) { "+  let prefixLen = length eventListenerPrefix+  let eventListenerText = eventListenerPrefix ++ scriptText ++ " });"+  let parser = do+        setPosition (incSourceColumn loc (-prefixLen))+        Js.parseExpression+  case parse parser (sourceName loc) eventListenerText of+    Left err -> do+      fail $ "Error parsiing JavaScript in an attribute at " ++ show loc +++             "\nThe script was:\n\n" ++ eventListenerText+    Right e -> return [Js.ExprStmt loc e]+attrScript _ = return []++inpageAttrScripts :: Js.ParsedJsHtml -> IO [Js.ParsedStatement]+inpageAttrScripts = everything (liftM2 (++)) (mkQ (return []) attrScript)++inpageScripts :: Js.ParsedJsHtml -> [Js.ParsedStatement]+inpageScripts = everything (++) (mkQ [] scriptText)++parseJsFile path = do+  text <- readFile path+  case Js.parseScriptFromString path text of+    Left err -> fail (show err)+    Right js -> hPutStrLn stderr ("Read file " ++ path) >> return js++-- |Given an HTML page, crawls all external Javascript files and returns a list+-- of statements, concatenated from all files.+getPageJavascript:: Js.ParsedJsHtml -> IO [Js.ParsedStatement]+getPageJavascript page = do+  let importURIs = importedScripts page+  let inpageJs   = inpageScripts page+  attrScripts <- inpageAttrScripts page+  importedScripts <- mapM parseJsFile importURIs+  let unScript (Js.Script _ ss) = ss+  return $ (concatMap unScript importedScripts ++ attrScripts) ++ inpageJs++getPageJavaScript:: Js.ParsedJsHtml -> IO [Js.ParsedStatement] -- monomorphism+getPageJavaScript = getPageJavascript

@@ -0,0 +1,146 @@+module BrownPLT.JavaScript.Environment+  ( env+  , localVars+  , EnvTree (..)+  ) where++import Data.List+import Data.Maybe+import qualified Data.Map as M+import Data.Map (Map)+import qualified Data.Set as S+import Data.Set (Set)+import Text.ParserCombinators.Parsec.Pos (SourcePos)++import BrownPLT.JavaScript.Syntax++-- Intermediate data structure that contains locally declared names and+-- all references to identifers.+data Partial = Partial {+  partialLocals :: M.Map String SourcePos,+  partialReferences :: M.Map String SourcePos,+  partialNested :: [Partial]+}++empty :: Partial+empty = Partial M.empty M.empty []++ref :: Id SourcePos -> Partial+ref (Id p v) = Partial M.empty (M.singleton v p) []++decl :: Id SourcePos -> Partial+decl (Id p v) = Partial (M.singleton v p) M.empty []++nest :: Partial -> Partial+nest partial = Partial M.empty M.empty [partial]++-- Combine partial results from the same lexical scope.+unions :: [Partial] -> Partial+unions ps = Partial (M.unions (map partialLocals ps))+                    (M.unions (map partialReferences ps))+                    (concatMap partialNested ps)++javascript :: JavaScript SourcePos -> Partial+javascript (Script _ ss) = unions (map stmt ss)++expr :: Expression SourcePos -> Partial+expr e = case e of+  StringLit _ _ -> empty+  RegexpLit _ _ _ _ -> empty+  NumLit _ _ -> empty+  IntLit _ _ -> empty+  BoolLit _ _ -> empty+  NullLit _ -> empty+  ArrayLit _ es -> unions (map expr es)+  ObjectLit _ props -> unions (map (expr.snd) props)+  ThisRef _ -> empty+  VarRef _ id -> empty+  DotRef _ e _ -> expr e+  BracketRef _ e1 e2 -> unions [expr e1, expr e2]+  NewExpr _ e1 es -> unions [expr e1, unions $ map expr es]+  PostfixExpr _ _ e -> expr e+  PrefixExpr _ _ e -> expr e+  InfixExpr _ _ e1 e2 -> unions [expr e1, expr e2]+  CondExpr _ e1 e2 e3 -> unions [expr e1, expr e2, expr e3]+  AssignExpr _ _ (VarRef _ id) e -> unions [ref id, expr e]+  AssignExpr _ _ e1 e2 -> unions [expr e1, expr e2]+  ParenExpr _ e -> expr e+  ListExpr _ es -> unions (map expr es)+  CallExpr _ e es -> unions [expr e, unions $ map expr es]+  FuncExpr _ args s -> nest $ unions [unions $ map decl args, stmt s]++caseClause :: CaseClause SourcePos -> Partial+caseClause cc = case cc of+  CaseClause _ e ss -> unions [expr e, unions $ map stmt ss]+  CaseDefault _ ss -> unions $ map stmt ss++-- TODO: Verify that this is a declaration and not a reference.+catchClause :: CatchClause SourcePos -> Partial+catchClause (CatchClause _ id s) = unions [decl id, stmt s]++varDecl :: VarDecl SourcePos -> Partial+varDecl (VarDecl _ id Nothing) = decl id+varDecl (VarDecl _ id (Just e)) = unions [decl id, expr e]+ +forInit :: ForInit SourcePos -> Partial+forInit fi = case fi of+  NoInit -> empty+  VarInit ds -> unions $ map varDecl ds+  ExprInit e -> expr e ++forInInit :: ForInInit SourcePos -> Partial+forInInit (ForInVar id) = decl id+forInInit (ForInNoVar id) = ref id+  +stmt :: Statement SourcePos -> Partial+stmt s = case s of+  BlockStmt _ ss -> unions $ map stmt ss+  EmptyStmt _ -> empty+  ExprStmt _ e -> expr e+  IfStmt _ e s1 s2 -> unions [expr e, stmt s1, stmt s2]+  IfSingleStmt _ e s -> unions [expr e, stmt s]+  SwitchStmt _ e cases -> unions [expr e, unions $ map caseClause cases]+  WhileStmt _ e s -> unions [expr e, stmt s]+  DoWhileStmt _ s e -> unions [stmt s, expr e]+  BreakStmt _ _ -> empty+  ContinueStmt _ _ -> empty+  LabelledStmt _ _ s -> stmt s+  ForInStmt _ fii e s -> unions [forInInit fii, expr e, stmt s]+  ForStmt _ fi  me1 me2 s -> +    unions [forInit fi, maybe empty expr me1, maybe empty expr me2, stmt s]+  TryStmt _ s catches ms ->+    unions [stmt s, unions $ map catchClause catches, maybe empty stmt ms]+  ThrowStmt _ e -> expr e+  ReturnStmt _ me -> maybe empty expr me+  WithStmt _ e s -> unions [expr e, stmt s]+  VarDeclStmt _ decls -> unions $ map varDecl decls+  FunctionStmt _ fnId args s ->+    unions [decl fnId, nest $ unions [unions $ map decl args, stmt s]]++-- |The statically-determinate lexical structure of a JavaScript program.+data EnvTree = EnvTree (M.Map String SourcePos) [EnvTree]++-- A 'Partial' specifies identifier references in addition to identifier+-- declarations.  We descend into a 'Partial', pushing enclosing declarations+-- in to remove references to identifiers declared in the enclosing scope.+-- Any referencs to identifiers not declared in either the current or the+-- enclosing scope are local definitions of global variables.+makeEnvTree :: Map String SourcePos -- ^enclosing environment+            -> Partial -- ^local environment and references+            -> (EnvTree,Map String SourcePos) +            -- ^environment and global definitions+makeEnvTree enclosing (Partial locals references nested) = (tree,globals) where+  nestedResults = map (makeEnvTree (locals `M.union` enclosing)) nested+  tree = EnvTree locals (map fst nestedResults)+  globals' = (references `M.difference` locals) `M.difference` enclosing+  globals = M.unions (globals':(map snd nestedResults))++env :: Map String SourcePos -- ^browser/testing environment+    -> [Statement SourcePos] +    -> (EnvTree,Map String SourcePos)+env globals program = makeEnvTree globals (unions $ map stmt program)++localVars :: [Statement SourcePos]+          -> Set String+localVars body = S.fromList (M.keys locals) where+  Partial locals _ _ = unions $ map stmt body

@@ -0,0 +1,25 @@+module BrownPLT.JavaScript.HtmlEmbedding+  ( JsHtml+  , ParsedJavaScript+  , ParsedJsHtml+  ) where++import BrownPLT.Html.Syntax+import BrownPLT.JavaScript.Parser (parseScript)+import BrownPLT.JavaScript.Syntax (JavaScript)+import BrownPLT.JavaScript.PrettyPrint (javaScript)+import Text.ParserCombinators.Parsec (SourcePos)++type JsHtml a = Html SourcePos (JavaScript a)++type ParsedJavaScript = JavaScript SourcePos++type ParsedJsHtml = JsHtml SourcePos++instance Script ParsedJavaScript where+  prettyPrintScript s = javaScript s+  parseScriptBlock attrs = parseScript+  parseInlineScript = Nothing+  parseAttributeScript = Nothing+    +  

@@ -0,0 +1,294 @@+-- |Instances of 'Foldable' and 'Traversable' for JavaScript's syntax.+module BrownPLT.JavaScript.Instances+  ( -- This module does not export any names.+  ) where++import Prelude hiding (foldr,sequence,mapM)+import qualified Prelude as Prelude++import Data.Foldable (Foldable(..))+import Data.Traversable(Traversable(..))+import Control.Applicative++import BrownPLT.JavaScript.Syntax++yfoldr:: Foldable t => (a -> b -> b) -> b -> Maybe (t a) -> b+yfoldr _ b Nothing = b+yfoldr f b (Just t) = foldr f b t++lfoldr:: Foldable t => (a -> b -> b) -> b -> [t a] -> b+lfoldr f = Prelude.foldr (flip $ foldr f)++ltraverse:: (Traversable t, Applicative f) => (a -> f b) -> [t a] -> f [t b]+ltraverse _ [] = pure []+ltraverse f (a:as) = (:) <$> traverse f a <*> ltraverse f as++ytraverse:: (Traversable t, Applicative f) +         => (a -> f b) -> Maybe (t a) -> f (Maybe (t b))+ytraverse _ Nothing = pure Nothing+ytraverse f (Just t) = Just <$> traverse f t++instance Functor Id where+  fmap f (Id a v) = Id (f a) v++instance Functor JavaScript where+  fmap f (Script a stmts) = Script (f a) (map (fmap f) stmts)+  +instance Functor Prop where+  fmap f (PropId a id) = PropId (f a) (fmap f id)+  fmap f (PropString a s) = PropString (f a) s+  fmap f (PropNum a n) = PropNum (f a) n++instance Functor Expression where+  fmap f expression = +    case expression of+      StringLit a s -> StringLit (f a) s+      RegexpLit a s g ci -> RegexpLit (f a) s g ci+      NumLit a n -> NumLit (f a) n+      IntLit a n -> IntLit (f a) n+      BoolLit a b -> BoolLit (f a) b+      NullLit a -> NullLit (f a)+      ArrayLit a es -> ArrayLit (f a) (map (fmap f) es)+      ObjectLit a pes -> ObjectLit (f a) (map f' pes) where+        f' (p,e) = (fmap f p, fmap f e)+      ThisRef a -> ThisRef (f a)+      VarRef a id -> VarRef (f a) (fmap f id)+      DotRef a e id -> DotRef (f a) (fmap f e) (fmap f id)+      BracketRef a e1 e2 -> BracketRef (f a) (fmap f e1) (fmap f e2)+      NewExpr a e es -> NewExpr (f a) (fmap f e) (map (fmap f) es)+      PostfixExpr a op e -> PostfixExpr (f a) op (fmap f e)+      PrefixExpr a op e -> PrefixExpr (f a) op (fmap f e)+      InfixExpr a op e1 e2 -> InfixExpr (f a) op (fmap f e1) (fmap f e2)+      CondExpr a e1 e2 e3 -> CondExpr (f a) (fmap f e1) (fmap f e2) (fmap f e3)+      AssignExpr a op e1 e2 -> AssignExpr (f a) op (fmap f e1) (fmap f e2)+      ParenExpr a e -> ParenExpr (f a) (fmap f e)+      ListExpr a es -> ListExpr (f a) (map (fmap f) es)+      CallExpr a e es -> CallExpr (f a) (fmap f e) (map (fmap f) es)+      FuncExpr a args s -> FuncExpr (f a) (map (fmap f) args) (fmap f s)++instance Functor CaseClause where+  fmap f (CaseClause a e ss) = CaseClause (f a) (fmap f e) (map (fmap f) ss)+  fmap f (CaseDefault a ss) = CaseDefault (f a) (map (fmap f) ss)+  +instance Functor CatchClause where+  fmap f (CatchClause a id s) = CatchClause (f a) (fmap f id) (fmap f s)++instance Functor VarDecl where+  fmap f (VarDecl a id Nothing) = VarDecl (f a) (fmap f id) Nothing+  fmap f (VarDecl a id (Just e)) = VarDecl (f a) (fmap f id) (Just $ fmap f e)+  +instance Functor ForInit where+  fmap f NoInit = NoInit+  fmap f (VarInit decls) = VarInit (map (fmap f) decls)+  fmap f (ExprInit e) = ExprInit (fmap f e)++instance Functor ForInInit where+  fmap f (ForInVar id) = ForInVar (fmap f id)+  fmap f (ForInNoVar id) = ForInNoVar (fmap f id)+  +instance Functor Statement where+  fmap f s = +    case s of+      BlockStmt a ss -> BlockStmt (f a) (map (fmap f) ss)+      EmptyStmt a -> EmptyStmt (f a)+      ExprStmt a e -> ExprStmt (f a) (fmap f e)+      IfStmt a e s1 s2 -> IfStmt (f a) (fmap f e) (fmap f s1) (fmap f s2)+      IfSingleStmt a e s -> IfSingleStmt (f a) (fmap f e) (fmap f s)+      SwitchStmt a e cs -> SwitchStmt (f a) (fmap f e) (map (fmap f) cs)+      WhileStmt a e s -> WhileStmt (f a) (fmap f e) (fmap f s)+      DoWhileStmt a s e -> DoWhileStmt (f a) (fmap f s) (fmap f e)+      BreakStmt a Nothing -> BreakStmt (f a) Nothing+      BreakStmt a (Just id) -> BreakStmt (f a) (Just (fmap f id))+      ContinueStmt a yid -> ContinueStmt (f a) (yid >>= return.(fmap f))+      LabelledStmt a id s -> LabelledStmt (f a) (fmap f id) (fmap f s)+      ForInStmt a init e s -> ForInStmt (f a) (fmap f init) (fmap f e)+                                (fmap f s)+      ForStmt a init yinc ytest body -> +        ForStmt (f a) (fmap f init) (yinc >>= return.(fmap f))+          (ytest >>= return.(fmap f)) (fmap f body)+      TryStmt a s cs ys -> +        TryStmt (f a) (fmap f s) (map (fmap f) cs) (ys >>= return.(fmap f))+      ThrowStmt a e -> ThrowStmt (f a) (fmap f e)+      ReturnStmt a ye -> ReturnStmt (f a) (ye >>= return.(fmap f))+      WithStmt a e s -> WithStmt (f a) (fmap f e) (fmap f s)+      VarDeclStmt a ds -> VarDeclStmt (f a) (map (fmap f) ds)+      FunctionStmt a id args s -> +        FunctionStmt (f a) (fmap f id) (map (fmap f) args) (fmap f s)++instance Foldable Id where+  foldr f b (Id a _) = f a b++instance Foldable Prop where+  foldr f b (PropId a id) = f a (foldr f b id)+  foldr f b (PropString a _) = f a b+  foldr f b (PropNum a _) = f a b+        +instance Foldable Expression where+  -- foldr:: (a -> b -> b) -> b -> Expression a -> b+  foldr f b e =+    case e of+      StringLit a _ -> f a b+      RegexpLit a _ _ _ -> f a b+      NumLit a _ -> f a b+      IntLit a _ -> f a b+      BoolLit a _ -> f a b+      NullLit a -> f a b+      ArrayLit a es -> f a (Prelude.foldr (flip $ foldr f) b es)+      ObjectLit a pes -> f a (Prelude.foldr f' b pes) where+        f' (p,e) b = foldr f (foldr f b e) p+      ThisRef a -> f a b+      VarRef a id -> f a (foldr f b id)+      DotRef a e id -> f a (foldr f (foldr f b id) e)+      BracketRef a e1 e2 -> f a (foldr f (foldr f b e2) e1)+      NewExpr a e es -> f a (foldr f (Prelude.foldr (flip $ foldr f) b es) e)+      PostfixExpr a _ e -> f a $ foldr f b e+      PrefixExpr a _ e -> f a $ foldr f b e+      InfixExpr a _ e1 e2 -> f a $ foldr f (foldr f b e2) e1+      CondExpr a e1 e2 e3 -> f a $ foldr f (foldr f (foldr f b e3) e2) e1+      AssignExpr a _ e1 e2 -> f a $ foldr f (foldr f b e2) e1+      ParenExpr a e -> f a $ foldr f b e+      ListExpr a es -> f a $ Prelude.foldr (flip $ foldr f) b es+      CallExpr a e es -> f a $ foldr f (Prelude.foldr (flip $ foldr f) b es) e+      FuncExpr a args s -> +        f a $ Prelude.foldr (flip $ foldr f) (foldr f b s) args++instance Foldable CaseClause where+  foldr f b (CaseClause a e ss) = +    f a $ foldr f (Prelude.foldr (flip $ foldr f) b ss) e+  foldr f b (CaseDefault a ss) = f a $ Prelude.foldr (flip $ foldr f) b ss+  +instance Foldable CatchClause where+  foldr f b (CatchClause a id s) = f a $ foldr f (foldr f b s) id++instance Foldable VarDecl where+  foldr f b (VarDecl a id ye) = f a $ foldr f (yfoldr f b ye) id++instance Foldable ForInit where+  foldr f b NoInit = b+  foldr f b (VarInit ds) = Prelude.foldr (flip $ foldr f) b ds+  foldr f b (ExprInit e) = foldr f b e++instance Foldable ForInInit where+ foldr f b (ForInVar id) = foldr f b id+ foldr f b (ForInNoVar id) = foldr f b id++instance Foldable Statement where+  foldr f b statement =+    case statement of+      BlockStmt a ss -> f a $ lfoldr f b ss+      EmptyStmt a -> f a b+      ExprStmt a e -> f a $ foldr f b e+      IfStmt a e s1 s2 -> f a $ foldr f (foldr f (foldr f b s2) s1) e+      IfSingleStmt a e s -> f a $ foldr f (foldr f b s) e+      SwitchStmt a e cs -> f a $ foldr f (lfoldr f b cs) e+      WhileStmt a e s -> f a $ foldr f (foldr f b s) e+      DoWhileStmt a s e -> f a $ foldr f (foldr f b e) s+      BreakStmt a yid -> f a $ yfoldr f b yid+      ContinueStmt a yid -> f a $ yfoldr f b yid+      LabelledStmt a id s -> f a $ foldr f (foldr f b s) id+      ForInStmt a init e s -> f a $ foldr f (foldr f (foldr f b s) e) init+      ForStmt a init ye1 ye2 s ->+        f a $ foldr f (yfoldr f (yfoldr f (foldr f b s) ye2) ye1) init+      TryStmt a s cs ys -> f a $ foldr f (lfoldr f (yfoldr f b ys) cs) s+      ThrowStmt a e -> f a $ foldr f b e+      ReturnStmt a ys -> f a $ yfoldr f b ys+      WithStmt a e s -> f a $ foldr f (foldr f b s) e+      VarDeclStmt a ds -> f a $ lfoldr f b ds+      FunctionStmt a id args s ->+        f a $ lfoldr f (foldr f b s) (id:args)++instance Traversable Id where+  traverse f (Id a v) = Id <$> f a <*> pure v++instance Traversable Prop where+  traverse f (PropId a id) = PropId <$> f a <*> traverse f id+  traverse f (PropString a s) = PropString <$> f a <*> pure s+  traverse f (PropNum a n) = PropNum <$> f a <*> pure n+  +instance Traversable Expression where+  traverse f expression =+    case expression of+      StringLit a s -> StringLit <$> f a <*> pure s+      RegexpLit a s g ci -> RegexpLit <$> f a <*> pure s <*> pure g <*> pure ci+      NumLit a n -> NumLit <$> f a <*> pure n+      IntLit a n -> IntLit <$> f a <*> pure n+      BoolLit a b -> BoolLit <$> f a <*> pure b+      NullLit a -> NullLit <$> f a+      ArrayLit a es -> ArrayLit <$> f a <*> ltraverse f es+      ObjectLit a ps -> ObjectLit <$> f a <*>  (zip <$> props' <*> es') where+        (props,es) = unzip ps+        props' = ltraverse f props+        es' = ltraverse f es+      ThisRef a -> ThisRef <$> f a+      VarRef a id -> VarRef <$> f a <*> traverse f id+      DotRef a e id -> DotRef <$> f a <*> traverse f e <*> traverse f id+      BracketRef a e es -> BracketRef <$> f a <*> traverse f e <*> traverse f es+      NewExpr a e es -> NewExpr <$> f a <*> traverse f e <*> ltraverse f es+      PostfixExpr a op e -> PostfixExpr <$> f a <*> pure op <*> traverse f e+      PrefixExpr a op e -> PrefixExpr <$> f a <*> pure op <*> traverse f e+      InfixExpr a op e1 e2 -> InfixExpr <$> f a <*> pure op <*> traverse f e1+                                <*> traverse f e2+      CondExpr a e1 e2 e3 ->+        CondExpr <$> f a <*> traverse f e1 <*> traverse f e2 <*> traverse f e3+      AssignExpr a op e1 e2 -> AssignExpr <$> f a <*> pure op <*> traverse f e1+        <*> traverse f e2+      ParenExpr a e -> ParenExpr <$> f a <*> traverse f e+      ListExpr a es -> ListExpr <$> f a <*> ltraverse f es+      CallExpr a e es -> CallExpr <$> f a <*> traverse f e <*> ltraverse f es+      FuncExpr a ids s -> FuncExpr <$> f a <*> ltraverse f ids <*> traverse f s++instance Traversable CaseClause where+  traverse f (CaseClause a e ss) =+    CaseClause <$> f a <*> traverse f e <*> ltraverse f ss+  traverse f (CaseDefault a ss) = +    CaseDefault <$> f a <*> ltraverse f ss++instance Traversable CatchClause where+  traverse f (CatchClause a id s) = +    CatchClause <$> f a <*> traverse f id <*> traverse f s+    +instance Traversable VarDecl where+  traverse f (VarDecl a id ye) =+    VarDecl <$> f a <*> traverse f id <*> ytraverse f ye++instance Traversable ForInit where+  traverse f NoInit = pure NoInit+  traverse f (VarInit ds) = VarInit <$> ltraverse f ds+  traverse f (ExprInit e) = ExprInit <$> traverse f e++instance Traversable ForInInit where+ traverse f (ForInVar id) = ForInVar <$> traverse f id+ traverse f (ForInNoVar id) = ForInNoVar <$> traverse f id++instance Traversable Statement where+  traverse f statement =+    case statement of+      BlockStmt a ss -> BlockStmt <$> f a <*> ltraverse f ss+      EmptyStmt a -> EmptyStmt <$> f a+      ExprStmt a e -> ExprStmt <$> f a <*> traverse f e+      IfStmt a e s1 s2 ->+        IfStmt <$> f a <*> traverse f e <*> traverse f s1 <*> traverse f s2+      IfSingleStmt a e s ->+        IfSingleStmt <$> f a <*> traverse f e <*> traverse f s+      SwitchStmt a e cs ->+        SwitchStmt <$> f a <*> traverse f e <*> ltraverse f cs+      WhileStmt a e s -> WhileStmt <$> f a <*> traverse f e <*> traverse f s+      DoWhileStmt a s e -> DoWhileStmt <$> f a <*> traverse f s <*> traverse f e+      BreakStmt a yid -> BreakStmt <$> f a <*> ytraverse f yid+      ContinueStmt a yid -> ContinueStmt <$> f a <*> ytraverse f yid+      LabelledStmt a id s -> +        LabelledStmt <$> f a <*> traverse f id <*> traverse f s+      ForInStmt a init e s ->+        ForInStmt <$> f a <*> traverse f init <*> traverse f e <*> traverse f s+      ForStmt a init yinc ytest s ->+        ForStmt <$> f a <*> traverse f init <*> ytraverse f yinc +          <*> ytraverse f ytest <*> traverse f s+      TryStmt a s cs ys ->+        TryStmt <$> f a <*> traverse f s <*> ltraverse f cs <*> ytraverse f ys+      ThrowStmt a e -> ThrowStmt <$> f a <*> traverse f e+      ReturnStmt a ys -> ReturnStmt <$> f a <*> ytraverse f ys+      WithStmt a e s -> WithStmt <$> f a <*> traverse f e <*> traverse f s+      VarDeclStmt a ds -> VarDeclStmt <$> f a <*> ltraverse f ds+      FunctionStmt a id args s ->+        FunctionStmt <$> f a <*> traverse f id <*> ltraverse f args +          <*> traverse f s 

@@ -0,0 +1,64 @@+{- This isn't a lexer in the sense that it provides a JavaScript token-stream.+ - This module provides character-parsers for various JavaScript tokens.+ -}+module BrownPLT.JavaScript.Lexer(lexeme,identifier,reserved,operator,reservedOp,charLiteral,+                        stringLiteral,natural,integer,float,naturalOrFloat,+                        decimal,hexadecimal,octal,symbol,whiteSpace,parens,+                        braces,brackets,squares,semi,comma,colon,dot,+                        identifierStart) where++import Prelude hiding (lex)+import Text.ParserCombinators.Parsec+import qualified Text.ParserCombinators.Parsec.Token as T++identifierStart = (letter <|> oneOf "$_")++javascriptDef =+  T.LanguageDef "/*"+                "*/"+                "//"+                False -- no nested comments+                {- Adapted from syntax/regexps.ss in Dave's code. -}+                identifierStart+                (alphaNum <|> oneOf "$_") -- identifier rest+                (oneOf "{}<>()~.,?:|&^=!+-*/%!") -- operator start+                (oneOf "=<>|&+") -- operator rest+                ["break", "case", "catch", "const", "continue", "debugger", +                 "default", "delete", "do", "else", "enum", "false", "finally",+                 "for", "function", "if", "instanceof", "in", "let", "new", +                 "null", "return", "switch", "this", "throw", "true", "try", +                 "typeof", "var", "void", "while", "with"]+                ["|=", "^=", "&=", "<<=", ">>=", ">>>=", "+=", "-=", "*=", "/=", +                 "%=", "=", ";", ",", "?", ":", "||", "&&", "|", "^", "&", +                 "===", "==", "=", "!==", "!=", "<<", "<=", "<", ">>>", ">>", +                 ">=", ">", "++", "--", "+", "-", "*", "/", "%", "!", "~", ".", +                 "[", "]", "{", "}", "(", ")","</","instanceof"]+                 True -- case-sensitive+            +lex = T.makeTokenParser javascriptDef++-- everything but commaSep and semiSep+identifier = T.identifier	 lex+reserved = T.reserved	 lex+operator = T.operator	 lex+reservedOp = T.reservedOp lex	+charLiteral = T.charLiteral lex	+stringLiteral = T.stringLiteral lex	+natural = T.natural lex	+integer = T.integer lex	+float = T.float lex	+naturalOrFloat = T.naturalOrFloat lex	+decimal = T.decimal lex	+hexadecimal = T.hexadecimal lex	+octal = T.octal lex	+symbol = T.symbol lex	+whiteSpace = T.whiteSpace lex	+parens = T.parens	 lex+braces = T.braces	 lex+squares = T.squares lex	+semi = T.semi	 lex+comma = T.comma	 lex+colon = T.colon lex	+dot = T.dot lex+brackets = T.brackets lex+lexeme = T.lexeme lex

@@ -0,0 +1,668 @@+module BrownPLT.JavaScript.Parser+  (parseScript+  , parseExpression+  , parseString+  , parseScriptFromString+  , emptyParsedJavaScript+  , ParsedStatement+  , ParsedExpression+  , parseJavaScriptFromFile+  , parseSimpleExpr'+  , parseBlockStmt+  , parseStatement+  , StatementParser+  , ExpressionParser+  , parseAssignExpr+  ) where++import BrownPLT.JavaScript.Lexer hiding (identifier)+import qualified BrownPLT.JavaScript.Lexer as Lexer+import BrownPLT.JavaScript.Syntax+import Text.ParserCombinators.Parsec+import Text.ParserCombinators.Parsec.Expr+import Control.Monad(liftM,liftM2)+import Control.Monad.Trans (MonadIO,liftIO)+import Numeric(readDec,readOct,readHex)+import Data.Char(chr)+import Data.Char++-- We parameterize the parse tree over source-locations.+type ParsedStatement = Statement SourcePos+type ParsedExpression = Expression SourcePos+++-- These parsers can store some arbitrary state+type StatementParser state = CharParser state ParsedStatement+type ExpressionParser state = CharParser state ParsedExpression++identifier =+  liftM2 Id getPosition Lexer.identifier++--{{{ Statements++-- Keep in mind that Token.reserved parsers (exported from the lexer) do not+-- consume any input on failure.  Note that all statements (expect for labelled+-- and expression statements) begin with a reserved-word.  If we fail to parse+-- this reserved-word, no input is consumed.  Hence, we can have the massive or+-- block that is parseExpression.  Note that if the reserved-word is parsed, it +-- must be whatever statement the reserved-word indicates.  If we fail after the+-- reserved-word, we truly have a syntax error.  Since input has been consumed,+-- <|> will not try its alternate in parseExpression, and we will fail.++parseIfStmt:: StatementParser st  +parseIfStmt = do+  pos <- getPosition+  reserved "if"+  test <- parseParenExpr <?> "parenthesized test-expression in if statement"+  consequent <- parseStatement <?> "true-branch of if statement"+  optional semi -- TODO: in spec?+  ((do reserved "else"+       alternate <- parseStatement+       return (IfStmt pos test consequent alternate))+    <|> return (IfSingleStmt pos test consequent))++parseSwitchStmt:: StatementParser st+parseSwitchStmt =+  let parseDefault = do+        pos <- getPosition+        reserved "default"+        colon+        statements <- many parseStatement+        return (CaseDefault pos statements)+      parseCase = do+         pos <- getPosition+         reserved "case"+         condition <- parseListExpr+         colon+         actions <- many parseStatement+         return (CaseClause pos condition actions)+    in do pos <- getPosition+          reserved "switch"+          test <- parseParenExpr+          clauses <- braces $ many $ parseDefault <|> parseCase+          return (SwitchStmt pos test clauses)++parseWhileStmt:: StatementParser st+parseWhileStmt = do+  pos <- getPosition+  reserved "while"+  test <- parseParenExpr <?> "parenthesized test-expression in while loop"+  body <- parseStatement+  return (WhileStmt pos test body)++parseDoWhileStmt:: StatementParser st+parseDoWhileStmt = do+  pos <- getPosition+  reserved "do"+  body <- parseBlockStmt+  reserved "while" <?> "while at the end of a do block"+  test <- parseParenExpr <?> "parenthesized test-expression in do loop"+  optional semi+  return (DoWhileStmt pos body test)++parseContinueStmt:: StatementParser st+parseContinueStmt = do+  pos <- getPosition+  reserved "continue"+  pos' <- getPosition+  -- Ensure that the identifier is on the same line as 'continue.'+  id <- (if (sourceLine pos == sourceLine pos')+           then (liftM Just identifier) <|> (return Nothing)+           else return Nothing)+  return (ContinueStmt pos id)++parseBreakStmt:: StatementParser st+parseBreakStmt = do+  pos <- getPosition+  reserved "break"+  pos' <- getPosition+  -- Ensure that the identifier is on the same line as 'break.'+  id <- (if (sourceLine pos == sourceLine pos')+           then (liftM Just identifier) <|> (return Nothing)+           else return Nothing)+  optional semi           +  return (BreakStmt pos id)++parseBlockStmt:: StatementParser st+parseBlockStmt = do+  pos <- getPosition+  statements <- braces (many parseStatement)+  return (BlockStmt pos statements)++parseEmptyStmt:: StatementParser st +parseEmptyStmt = do+  pos <- getPosition+  semi+  return (EmptyStmt pos)++parseLabelledStmt:: StatementParser st+parseLabelledStmt = do+  pos <- getPosition+  -- Lookahead for the colon.  If we don't see it, we are parsing an identifier+  -- for an expression statement.+  label <- try (do label <- identifier+                   colon+                   return label)+  statement <- parseStatement+  return (LabelledStmt pos label statement)++parseExpressionStmt:: StatementParser st+parseExpressionStmt = do+  pos <- getPosition+  expr <- parseListExpr -- TODO: spec 12.4?+  optional semi+  return (ExprStmt pos expr)+++parseForInStmt:: StatementParser st+parseForInStmt =+  let parseInit = (reserved "var" >> liftM ForInVar identifier)+                  <|> (liftM ForInNoVar identifier)+    in do pos <- getPosition+          -- Lookahead, so that we don't clash with parseForStmt+          (init,expr) <- try (do reserved "for"+                                 parens (do init <- parseInit+                                            reserved "in"+                                            expr <- parseExpression+                                            return (init,expr)))+          body <- parseStatement+          return (ForInStmt pos init expr body) ++parseForStmt:: StatementParser st+parseForStmt =+  let parseInit =+        (reserved "var" >> liftM VarInit (parseVarDecl `sepBy` comma)) <|>+        (liftM ExprInit parseListExpr) <|>+        (return NoInit)+    in do pos <- getPosition+          reserved "for"+          reservedOp "("+          init <- parseInit+          semi+          test <- (liftM Just parseExpression) <|> (return Nothing)+          semi+          iter <- (liftM Just parseListExpr) <|> (return Nothing)+          reservedOp ")" <?> "closing paren"+          stmt <- parseStatement+          return (ForStmt pos init test iter stmt)++parseTryStmt:: StatementParser st+parseTryStmt =+  let parseCatchClause = do+        pos <- getPosition+        reserved "catch"+        id <- parens identifier+        stmt <- parseStatement+        return (CatchClause pos id stmt)+    in do reserved "try"+          pos <- getPosition+          guarded <- parseStatement+          catches <- many parseCatchClause+          finally <- (reserved "finally" >> liftM Just parseStatement) +                      <|> (return Nothing)+          return (TryStmt pos guarded catches finally)++parseThrowStmt:: StatementParser st+parseThrowStmt = do+  pos <- getPosition+  reserved "throw"+  expr <- parseExpression+  optional semi+  return (ThrowStmt pos expr)++parseReturnStmt:: StatementParser st+parseReturnStmt = do+  pos <- getPosition+  reserved "return"+  expr <- (liftM Just parseListExpr) <|> (return Nothing)+  optional semi+  return (ReturnStmt pos expr)++parseWithStmt:: StatementParser st+parseWithStmt = do+  pos <- getPosition+  reserved "with"+  context <- parseParenExpr+  stmt <- parseStatement+  return (WithStmt pos context stmt)++parseVarDecl = do+  pos <- getPosition+  id <- identifier+  init <- (reservedOp "=" >> liftM Just parseExpression) <|> (return Nothing)+  return (VarDecl pos id init)++parseVarDeclStmt:: StatementParser st+parseVarDeclStmt = do +  pos <- getPosition+  reserved "var"+  decls <- parseVarDecl `sepBy` comma+  optional semi+  return (VarDeclStmt pos decls)++parseFunctionStmt:: StatementParser st+parseFunctionStmt = do+  pos <- getPosition+  name <- try (reserved "function" >> identifier) -- ambiguity with FuncExpr+  args <- parens (identifier `sepBy` comma)+  body <- parseBlockStmt <?> "function body in { ... }"+  return (FunctionStmt pos name args body)++parseStatement:: StatementParser st+parseStatement = parseIfStmt <|> parseSwitchStmt <|> parseWhileStmt +  <|> parseDoWhileStmt <|> parseContinueStmt <|> parseBreakStmt +  <|> parseBlockStmt <|> parseEmptyStmt <|> parseForInStmt <|> parseForStmt+  <|> parseTryStmt <|> parseThrowStmt <|> parseReturnStmt <|> parseWithStmt +  <|> parseVarDeclStmt  <|> parseFunctionStmt+  -- labelled, expression and the error message always go last, in this order+  <|> parseLabelledStmt <|> parseExpressionStmt <?> "statement"++--}}}++--{{{ Expressions++-- References used to construct this stuff:+-- + http://developer.mozilla.org/en/docs/+--     Core_JavaScript_1.5_Reference:Operators:Operator_Precedence+-- + http://www.mozilla.org/js/language/grammar14.html+--+-- Aren't expression tables nice?  Well, we can't quite use them, because of +-- JavaScript's ternary (?:) operator.  We have to use two expression tables.+-- We use one expression table for the assignment operators that bind looser +-- than ?: (assignTable).  The terms of assignTable are ternary expressions +-- (parseTernaryExpr).  parseTernaryExpr left-factors the left-recursive+-- production for ?:, and is defined over the second expression table, +-- exprTable, which consists of operators that bind tighter than ?:.  The terms+-- of exprTable are atomic expressions, parenthesized expressions, functions and+-- array references.++--{{{ Primary expressions++parseThisRef:: ExpressionParser st+parseThisRef = do+  pos <- getPosition+  reserved "this"+  return (ThisRef pos)++parseNullLit:: ExpressionParser st+parseNullLit = do+  pos <- getPosition+  reserved "null"+  return (NullLit pos)+++parseBoolLit:: ExpressionParser st+parseBoolLit = do+    pos <- getPosition+    let parseTrueLit  = reserved "true"  >> return (BoolLit pos True)+        parseFalseLit = reserved "false" >> return (BoolLit pos False)+    parseTrueLit <|> parseFalseLit++parseVarRef:: ExpressionParser st+parseVarRef = liftM2 VarRef getPosition identifier++parseArrayLit:: ExpressionParser st+parseArrayLit = liftM2 ArrayLit getPosition (squares (parseExpression `sepBy` comma))+  +parseFuncExpr = do+  pos <- getPosition+  reserved "function"+  args <- parens (identifier `sepBy` comma)+  body <- parseBlockStmt+  return $ FuncExpr pos args body++--{{{ parsing strings++escapeChars =+ [('\'','\''),('\"','\"'),('\\','\\'),('b','\b'),('f','\f'),('n','\n'),+  ('r','\r'),('t','\t'),('v','\v'),('/','/'),(' ',' ')]++allEscapes:: String+allEscapes = map fst escapeChars++parseEscapeChar = do+  c <- oneOf allEscapes+  let (Just c') = lookup c escapeChars -- will succeed due to line above+  return c' ++parseAsciiHexChar = do+  char 'x'+  d1 <- hexDigit+  d2 <- hexDigit+  return ((chr.fst.head.readHex) (d1:d2:""))++parseUnicodeHexChar = do+  char 'u'+  liftM (chr.fst.head.readHex) +        (sequence [hexDigit,hexDigit,hexDigit,hexDigit])+        +isWhitespace ch = ch `elem` " \t"+++-- The endWith argument is either single-quote or double-quote, depending on how+-- we opened the string.+parseStringLit' endWith =+  (char endWith >> return "") <|>+  (do try (string "\\'")+      cs <- parseStringLit' endWith+      return $ "'" ++ cs) <|>+  (do char '\\'+      c <- parseEscapeChar <|> parseAsciiHexChar <|> parseUnicodeHexChar <|> +           char '\r' <|> char '\n'+      cs <- parseStringLit' endWith+      if c == '\r' || c == '\n' +        then return (c:(dropWhile isWhitespace cs)) +        else return (c:cs)) <|>+   (liftM2 (:) anyChar (parseStringLit' endWith))++parseStringLit:: ExpressionParser st+parseStringLit = do+  pos <- getPosition+  -- parseStringLit' takes as an argument the quote-character that opened the+  -- string.+  str <- lexeme $ (char '\'' >>= parseStringLit') <|> (char '\"' >>= parseStringLit')+  -- CRUCIAL: Parsec.Token parsers expect to find their token on the first+  -- character, and read whitespaces beyond their tokens.  Without 'lexeme'+  -- above, expressions like:+  --   var s = "string"   ;+  -- do not parse.+  return $ StringLit pos str++--}}}++parseRegexpLit:: ExpressionParser st+parseRegexpLit = do+  let parseFlags = do+        flags <- many (oneOf "mgi")+        return $ \f -> f ('g' `elem` flags) ('i' `elem` flags) +  let parseEscape = char '\\' >> anyChar+  let parseChar = noneOf "/"+  let parseRe = (char '/' >> return "") <|> +                (do char '\\'+                    ch <- anyChar -- TOOD: too lenient+                    rest <- parseRe+                    return ('\\':ch:rest)) <|> +                (liftM2 (:) anyChar parseRe)+  pos <- getPosition+  char '/'+  pat <- parseRe --many1 parseChar+  flags <- parseFlags+  spaces -- crucial for Parsec.Token parsers+  return $ flags (RegexpLit pos pat)+          +parseObjectLit:: ExpressionParser st+parseObjectLit =+  let parseProp = do+        -- Parses a string, identifier or integer as the property name.  I+        -- apologize for the abstruse style, but it really does make the code+        -- much shorter.+        name <- (liftM (uncurry PropString) +                       (liftM (\(StringLit p s) -> (p,s)) parseStringLit))+                <|> (liftM2 PropId getPosition identifier)+                <|> (liftM2 PropNum getPosition decimal)+        colon+        val <- parseAssignExpr+        return (name,val)+    in do pos <- getPosition+          props <- braces (parseProp `sepEndBy` comma) <?> "object literal"+          return $ ObjectLit pos props++--{{{ Parsing numbers.  From pg. 17-18 of ECMA-262.++hexLit = do+  try (string "0x")+  digits <- many1 (oneOf "0123456789abcdefABCDEF")+  [(hex,"")] <- return $ Numeric.readHex digits+  return (True, hex)++-- Creates a decimal value from a whole, fractional and exponent part.+mkDecimal:: Double -> Double -> Int -> Double+mkDecimal w f e =+  if (f >= 1.0)+    then mkDecimal w (f / 10.0) e+    else (w + f) * (10.0 ^^ e)++exponentPart = do+  oneOf "eE"+  (char '+' >> decimal) <|> (char '-' >> negate `fmap` decimal) <|> decimal++--wrap a parser's result in a Just:+jparser p = p >>= (return . Just) ++decLit = +  (do whole <- decimal+      mfrac <- option Nothing (jparser (char '.' >> decimal))+      mexp <-  option Nothing (jparser exponentPart)+      if (mfrac == Nothing && mexp == Nothing)+        then return (True, fromIntegral whole)+        else return (False, mkDecimal (fromIntegral whole) +                                      (fromIntegral (maybe 0 id mfrac))+                                      (fromIntegral (maybe 0 id mexp)))) <|>+  (do frac <- char '.' >> decimal+      exp <- option 0 exponentPart+      return (False, mkDecimal 0.0 (fromIntegral frac) (fromIntegral exp)))++parseNumLit:: ExpressionParser st+parseNumLit = do+    pos <- getPosition+    (isint, num) <- lexeme $ hexLit <|> decLit+    notFollowedBy identifierStart <?> "whitespace"+    if isint+      then return $ IntLit pos (round num) +      else return $ NumLit pos num+++------------------------------------------------------------------------------+-- Position Helper+------------------------------------------------------------------------------++withPos cstr p = do { pos <- getPosition; e <- p; return $ cstr pos e }++-------------------------------------------------------------------------------+-- Compound Expression Parsers+-------------------------------------------------------------------------------++dotRef e = (reservedOp "." >> withPos cstr identifier) <?> "property.ref"+    where cstr pos key = DotRef pos e key++funcApp e = (parens $ withPos cstr (parseExpression `sepBy` comma)) <?> "(function application)"+    where cstr pos args = CallExpr pos e args++bracketRef e = (brackets $ withPos cstr parseExpression) <?> "[property-ref]"+    where cstr pos key = BracketRef pos e key++-------------------------------------------------------------------------------+-- Expression Parsers+-------------------------------------------------------------------------------++parseParenExpr:: ExpressionParser st+parseParenExpr = withPos ParenExpr (parens parseListExpr)++-- everything above expect functions+parseExprForNew = parseThisRef <|> parseNullLit <|> parseBoolLit <|> parseStringLit +  <|> parseArrayLit <|> parseParenExpr <|> parseNewExpr <|> parseNumLit +  <|> parseRegexpLit <|> parseObjectLit <|> parseVarRef++-- all the expression parsers defined above+parseSimpleExpr' = parseThisRef <|> parseNullLit <|> parseBoolLit +  <|> parseStringLit <|> parseArrayLit <|> parseParenExpr+  <|> parseFuncExpr <|> parseNumLit <|> parseRegexpLit <|> parseObjectLit+  <|> parseVarRef++parseNewExpr =+  (do pos <- getPosition+      reserved "new"+      constructor <- parseSimpleExprForNew Nothing -- right-associativity+      arguments <- (try (parens (parseExpression `sepBy` comma))) <|> (return [])+      return (NewExpr pos constructor arguments)) <|>+  parseSimpleExpr'++parseSimpleExpr (Just e) = (do+    e' <- dotRef e <|> funcApp e <|> bracketRef e+    parseSimpleExpr $ Just e') <|> (return e)+parseSimpleExpr Nothing = do+  e <- parseNewExpr <?> "expression (3)"+  parseSimpleExpr (Just e)++parseSimpleExprForNew (Just e) = (do+    e' <- dotRef e <|> bracketRef e+    parseSimpleExprForNew $ Just e') <|> (return e)+parseSimpleExprForNew Nothing = do+  e <- parseNewExpr <?> "expression (3)"+  parseSimpleExprForNew (Just e)+    +--}}}++makeInfixExpr str constr = Infix parser AssocLeft where+  parser:: CharParser st (Expression SourcePos -> Expression SourcePos -> Expression SourcePos)+  parser = do+    pos <- getPosition+    reservedOp str+    return (InfixExpr pos constr)  -- points-free, returns a function++makePrefixExpr str constr = Prefix parser where+  parser = do+    pos <- getPosition+    (reservedOp str <|> reserved str)+    return (PrefixExpr pos constr) -- points-free, returns a function+    +mkPrefix operator constr = Prefix $ do+  pos <- getPosition+  operator+  return (\operand -> PrefixExpr pos constr operand)++makePostfixExpr str constr = Postfix parser where+  parser = do+    pos <- getPosition+    (reservedOp str <|> reserved str)+    return (PostfixExpr pos constr) -- points-free, returns a function++prefixIncDecExpr = do+  pos <- getPosition+  op <- optionMaybe $ (reservedOp "++" >> return PrefixInc) <|>+                      (reservedOp "--" >> return PrefixDec)+  case op of+    Nothing -> parseSimpleExpr Nothing+    Just op -> do+      innerExpr <- parseSimpleExpr Nothing -- TODO: must be an l-val, I think+      return (PrefixExpr pos op innerExpr)++-- apparently, expression tables can't handle immediately-nested prefixes++parsePrefixedExpr = do+  pos <- getPosition+  op <- optionMaybe $ (reservedOp "!" >> return PrefixLNot) <|> +                      (reservedOp "~" >> return PrefixBNot) <|>+                      (try (lexeme $ char '-' >> notFollowedBy (char '-')) >>+                       return PrefixMinus) <|>+                      (try (lexeme $ char '+' >> notFollowedBy (char '+')) >>+                       return PrefixPlus) <|>+                      (reserved "typeof" >> return PrefixTypeof) <|>+                      (reserved "void" >> return PrefixVoid) <|>+                      (reserved "delete" >> return PrefixDelete)+  case op of+    Nothing -> prefixIncDecExpr  -- new is treated as a simple expr+    Just op -> do+      innerExpr <- parsePrefixedExpr+      return (PrefixExpr pos op innerExpr)++exprTable:: [[Operator Char st ParsedExpression]]+exprTable = +  [+   [makePrefixExpr "++" PrefixInc,+    makePostfixExpr "++" PostfixInc],+   [makePrefixExpr "--" PrefixDec,+    makePostfixExpr "--" PostfixDec],+   [makeInfixExpr "*" OpMul, makeInfixExpr "/" OpDiv, makeInfixExpr "%" OpMod],+   [makeInfixExpr "+" OpAdd, makeInfixExpr "-" OpSub],+   [makeInfixExpr "<<" OpLShift, makeInfixExpr ">>" OpSpRShift,+    makeInfixExpr ">>>" OpZfRShift],+   [makeInfixExpr "<" OpLT, makeInfixExpr "<=" OpLEq, makeInfixExpr ">" OpGT,+    makeInfixExpr ">=" OpGEq, +    makeInfixExpr "instanceof" OpInstanceof, makeInfixExpr "in" OpIn],+   [makeInfixExpr "&" OpBAnd], +   [makeInfixExpr "^" OpBXor], +   [makeInfixExpr "|" OpBOr],+   [makeInfixExpr "&&" OpLAnd],+   [makeInfixExpr "||" OpLOr],  +   [makeInfixExpr "==" OpEq, makeInfixExpr "!=" OpNEq,+    makeInfixExpr "===" OpStrictEq, makeInfixExpr "!==" OpStrictNEq]+    ]+  +parseExpression' = +  buildExpressionParser exprTable parsePrefixedExpr <?> "simple expression"++--{{{ Parsing ternary operators: left factored++parseTernaryExpr':: CharParser st (ParsedExpression,ParsedExpression)+parseTernaryExpr' = do+    reservedOp "?"+    l <- parseAssignExpr+    colon+    r <- parseAssignExpr+    return $(l,r)++parseTernaryExpr:: ExpressionParser st+parseTernaryExpr = do+  e <- parseExpression'+  e' <- optionMaybe parseTernaryExpr'+  case e' of+    Nothing -> return e+    Just (l,r) -> do p <- getPosition+                     return $ CondExpr p e l r+--}}}++-- Parsing assignment operations.+makeAssignExpr str constr = Infix parser AssocRight where+  parser:: CharParser st (ParsedExpression -> ParsedExpression -> ParsedExpression)+  parser = do+    pos <- getPosition+    reservedOp str+    return (AssignExpr pos constr)++assignTable:: [[Operator Char st ParsedExpression]]+assignTable = [+  [makeAssignExpr "=" OpAssign, makeAssignExpr "+=" OpAssignAdd, +    makeAssignExpr "-=" OpAssignSub, makeAssignExpr "*=" OpAssignMul,+    makeAssignExpr "/=" OpAssignDiv, makeAssignExpr "%=" OpAssignMod,+    makeAssignExpr "<<=" OpAssignLShift, makeAssignExpr ">>=" OpAssignSpRShift,+    makeAssignExpr ">>>=" OpAssignZfRShift, makeAssignExpr "&=" OpAssignBAnd,+    makeAssignExpr "^=" OpAssignBXor, makeAssignExpr "|=" OpAssignBOr+  ]]+++parseAssignExpr:: ExpressionParser st+parseAssignExpr = buildExpressionParser assignTable parseTernaryExpr  ++parseExpression:: ExpressionParser st+parseExpression = parseAssignExpr++parseListExpr =+  liftM2 ListExpr getPosition (parseAssignExpr `sepBy1` comma)++--}}}++parseScript:: CharParser state (JavaScript SourcePos)+parseScript = do+  whiteSpace+  liftM2 Script getPosition (parseStatement `sepBy` whiteSpace)+  +parseJavaScriptFromFile :: MonadIO m => String -> m [Statement SourcePos]+parseJavaScriptFromFile filename = do+  chars <- liftIO $ readFile filename+  case parse parseScript filename chars of+    Left err               -> fail (show err)+    Right (Script _ stmts) -> return stmts+++parseScriptFromString :: String -> String +                      -> Either ParseError (JavaScript SourcePos)+parseScriptFromString src script = parse parseScript src script++emptyParsedJavaScript = +  Script (error "Parser.emptyParsedJavaScript--no annotation") []++parseString :: String -> [Statement SourcePos]+parseString str = case parse parseScript "" str of+  Left err -> error (show err)+  Right (Script _ stmts) -> stmts

@@ -0,0 +1,239 @@+-- |Pretty-printing JavaScript.+module BrownPLT.JavaScript.PrettyPrint+  ( stmt+  , expr+  , javaScript+  , renderStatements+  , renderExpression+  ) where++import Text.PrettyPrint.HughesPJ+import BrownPLT.JavaScript.Syntax+++renderStatements :: [Statement a] -> String+renderStatements ss = render (semiSep ss)+++renderExpression :: Expression a -> String+renderExpression e = render (expr e)+++-- Displays the statement in { ... }, unless it already is in a block.+inBlock:: (Statement a) -> Doc+inBlock s@(BlockStmt _ ss) = stmt s+inBlock s                 = lbrace $+$ nest 2 (stmt s) $+$ rbrace+++-- Displays the expression in ( ... ), unless it already is in parens.+inParens:: (Expression a) -> Doc+inParens e@(ParenExpr _ _) = expr e+inParens e                 = parens (expr e)++semiSep :: [Statement a] -> Doc+semiSep ss = vcat $ map (\s -> stmt s <> semi) ss+++pp (Id _ str) = text str+++forInit :: ForInit a -> Doc+forInit t = case t of+  NoInit     -> empty+  VarInit vs -> text "var" <+> (cat $ punctuate comma $ (map varDecl vs))+  ExprInit e -> expr e+  ++forInInit :: ForInInit a -> Doc  +forInInit t = case t of+  ForInVar id   -> text "var" <+> pp id+  ForInNoVar id -> pp id+++caseClause :: CaseClause a -> Doc+caseClause (CaseClause _ e ss) =+  text "case" $+$ expr e <+> colon $$ (nest 2 (semiSep ss))+caseClause (CaseDefault _ ss) =+  text "default:" $$ (nest 2 (semiSep ss))+++catchClause :: CatchClause a -> Doc+catchClause (CatchClause _ id s) = text "catch" <+> (parens.pp) id <+> inBlock s+++varDecl :: VarDecl a -> Doc+varDecl (VarDecl _ id Nothing) = pp id+varDecl (VarDecl _ id (Just e)) = pp id <+> equals <+> expr e+++stmt :: Statement a -> Doc+stmt s = case s of+  BlockStmt _ ss -> lbrace $+$ (nest 2 (semiSep ss)) $$ rbrace+  EmptyStmt _ -> semi+  ExprStmt _ e -> expr e+  IfSingleStmt _ test cons -> text "if" <+> inParens test $$ stmt cons+  IfStmt _ test cons alt ->+    text "if" <+> inParens test $$ stmt cons $$ text "else" <+> stmt alt+  SwitchStmt _ e cases ->+    text "switch" <+> inParens e $$ +    braces (nest 2 (vcat (map caseClause cases)))+  WhileStmt _ test body -> text "while" <+> inParens test $$ (stmt body)+  ReturnStmt _ Nothing -> text "return"+  ReturnStmt _ (Just e) -> text "return" <+> expr e+  DoWhileStmt _ s e -> text "do" $$ (stmt s <+> text "while" <+> inParens e)+  BreakStmt _ Nothing ->  text "break"+  BreakStmt _ (Just label) -> text "break" <+> pp label+  ContinueStmt _ Nothing -> text "continue"+  ContinueStmt _ (Just label) -> text"continue" <+> pp label+  LabelledStmt _ label s -> pp label <> colon $$ stmt s+  ForInStmt p init e body -> +    text "for" <+> +    parens (forInInit init <+> text "in" <+> expr e) $+$ stmt body+  ForStmt _ init incr test body ->+    text "for" <+> +    parens (forInit init <> semi <+> mexpr incr <> semi <+> mexpr test) $$ +    stmt body+  TryStmt _ stmt catches finally ->+    text "try" $$ inBlock stmt $$ (vcat (map catchClause catches)) $$+    ppFinally where +       ppFinally = case finally of+        Nothing -> empty+        Just stmt -> text "finally" <> inBlock stmt+  ThrowStmt _ e -> text "throw" <+> expr e+  WithStmt _ expr s ->  text "with" <+> inParens expr $$ stmt s+  VarDeclStmt _ decls ->+    text "var" <+> (cat $ punctuate comma (map varDecl decls))+  FunctionStmt _ name args s ->+    text "function" <+> pp name <> +    (parens $ cat $ punctuate comma (map pp args)) $$ +    inBlock s+++prop :: Prop a -> Doc+prop p = case p of+  PropId _ id -> pp id+  PropString _ str -> doubleQuotes (text (jsEscape str))+  PropNum _ n -> text (show n)+++infixOp op = text $ case op of+  OpMul -> "*"+  OpDiv -> "/"+  OpMod -> "%" +  OpAdd -> "+" +  OpSub -> "-"+  OpLShift -> "<<"+  OpSpRShift -> ">>"+  OpZfRShift -> ">>>"+  OpLT -> "<"+  OpLEq -> "<="+  OpGT -> ">"+  OpGEq -> ">="+  OpIn -> "in"+  OpInstanceof -> "instanceof"+  OpEq -> "=="+  OpNEq -> "!="+  OpStrictEq -> "==="+  OpStrictNEq -> "!=="+  OpBAnd -> "&"+  OpBXor -> "^"+  OpBOr -> "|"+  OpLAnd -> "&&"+  OpLOr -> "||"+++prefixOp op = text $ case op of+  PrefixInc -> "++"+  PrefixDec -> "--"+  PrefixLNot -> "!"+  PrefixBNot -> "~"+  PrefixPlus -> "+"+  PrefixMinus -> "-"+  PrefixTypeof -> "typeof"+  PrefixVoid -> "void"+  PrefixDelete -> "delete"+++postfixOp op = text $ case op of+  PostfixInc -> "++"+  PostfixDec ->  "--"+++assignOp op = text $ case op of+  OpAssign -> "="+  OpAssignAdd -> "+="+  OpAssignSub -> "-="+  OpAssignMul -> "*="+  OpAssignDiv -> "/="+  OpAssignMod -> "%="+  OpAssignLShift -> "<<="+  OpAssignSpRShift -> ">>="+  OpAssignZfRShift -> ">>>="+  OpAssignBAnd -> "&="+  OpAssignBXor -> "^="+  OpAssignBOr -> "|="+++-- Based on:+--   http://developer.mozilla.org/en/docs/Core_JavaScript_1.5_Guide:Literals+jsEscape:: String -> String+jsEscape "" = ""+jsEscape (ch:chs) = (sel ch) ++ jsEscape chs where+    sel '\b' = "\\b"+    sel '\f' = "\\f"+    sel '\n' = "\\n"+    sel '\r' = "\\r"+    sel '\t' = "\\t"+    sel '\v' = "\\v"+    sel '\'' = "\\'"+    sel '\"' = "\\\""+    sel '\\' = "\\\\"+    sel x    = [x]+    -- We don't have to do anything about \X, \x and \u escape sequences.++ +expr :: Expression a -> Doc+expr e = case e of +  StringLit _ str ->  doubleQuotes (text (jsEscape str))+  RegexpLit _ re global ci -> +    text "/" <> text re <> text "/" <> g <> i where+      g = if global then text "g" else empty+      i = if ci then text "i" else empty+  NumLit _ n ->  text (show n)+  IntLit _ n ->  text (show n)+  BoolLit _ True ->  text "true"+  BoolLit _ False ->  text "false"+  NullLit _ ->  text "null"+  ArrayLit _ es ->  brackets $ cat $ punctuate comma (map expr es)+  ObjectLit _ xs ->  +    braces (hsep (punctuate comma (map pp' xs))) where+      pp' (n,v) =  prop n <> colon <+> expr v+  ThisRef _ ->  text "this"+  VarRef _ id ->  pp id+  DotRef _ e' id -> expr e' <> text "." <> pp id+  BracketRef _ container key -> expr container <> brackets (expr key)+  NewExpr _ constr args -> +    text "new" <+> expr constr <> +    (parens $ cat $ punctuate comma (map expr args))+  PrefixExpr _ op e' -> prefixOp op <+> expr e'+  PostfixExpr _ op e' -> expr e' <+> postfixOp op+  InfixExpr _ op left right -> expr left <+> infixOp op <+> expr right+  CondExpr _ test cons alt -> +    expr test <+> text "?" <+> expr cons <+> colon <+> expr alt+  AssignExpr _ op l r ->  expr l <+> assignOp op <+> expr r+  ParenExpr _ e' ->  parens (expr e')+  ListExpr _ es ->  cat $ punctuate comma (map expr es)+  CallExpr _ f args -> +    expr f <> (parens $ cat $ punctuate comma (map expr args))+  FuncExpr _ args body -> +    text "function" <+> +    (parens $ cat $ punctuate comma (map pp args)) $$ +    inBlock body+++mexpr :: Maybe (Expression a) -> Doc+mexpr Nothing = empty+mexpr (Just e) = expr e++javaScript :: JavaScript a -> Doc+javaScript (Script _ ss) = semiSep ss

@@ -0,0 +1,121 @@+-- |JavaScript's syntax.+module BrownPLT.JavaScript.Syntax(Expression(..),CaseClause(..),Statement(..),+         InfixOp(..),CatchClause(..),VarDecl(..),JavaScript(..),+         AssignOp(..),Id(..),PrefixOp(..),PostfixOp(..),Prop(..),+         ForInit(..),ForInInit(..),unId) where++import Text.ParserCombinators.Parsec(SourcePos) -- used by data JavaScript+import Data.Generics(Data,Typeable)++data JavaScript a+  -- |A script in <script> ... </script> tags.  This may seem a little silly,+  -- but the Flapjax analogue has an inline variant and attribute-inline +  -- variant.+  = Script a [Statement a] +  deriving (Show,Data,Typeable,Eq,Ord)++data Id a = Id a String deriving (Show,Eq,Ord,Data,Typeable)++unId :: Id a -> String+unId (Id _ s) = s++-- http://developer.mozilla.org/en/docs/+--   Core_JavaScript_1.5_Reference:Operators:Operator_Precedence+data InfixOp = OpLT | OpLEq | OpGT | OpGEq  | OpIn  | OpInstanceof | OpEq | OpNEq+             | OpStrictEq | OpStrictNEq | OpLAnd | OpLOr +             | OpMul | OpDiv | OpMod  | OpSub | OpLShift | OpSpRShift+             | OpZfRShift | OpBAnd | OpBXor | OpBOr | OpAdd+    deriving (Show,Data,Typeable,Eq,Ord,Enum)++data AssignOp = OpAssign | OpAssignAdd | OpAssignSub | OpAssignMul | OpAssignDiv+  | OpAssignMod | OpAssignLShift | OpAssignSpRShift | OpAssignZfRShift+  | OpAssignBAnd | OpAssignBXor | OpAssignBOr+  deriving (Show,Data,Typeable,Eq,Ord)++data PrefixOp = PrefixInc | PrefixDec | PrefixLNot | PrefixBNot | PrefixPlus+  | PrefixMinus | PrefixTypeof | PrefixVoid | PrefixDelete+  deriving (Show,Data,Typeable,Eq,Ord)+  +data PostfixOp +  = PostfixInc | PostfixDec+  deriving (Show,Data,Typeable,Eq,Ord)+  +data Prop a +  = PropId a (Id a) | PropString a String | PropNum a Integer+  deriving (Show,Data,Typeable,Eq,Ord)++data Expression a+  = StringLit a String+  | RegexpLit a String Bool {- global? -} Bool {- case-insensitive? -}+  | NumLit a Double+  | IntLit a Int+  | BoolLit a Bool+  | NullLit a+  | ArrayLit a [Expression a]+  | ObjectLit a [(Prop a, Expression a)]+  | ThisRef a+  | VarRef a (Id a)+  | DotRef a (Expression a) (Id a)+  | BracketRef a (Expression a) {- container -} (Expression a) {- key -}+  | NewExpr a (Expression a) {- constructor -} [Expression a]+  | PostfixExpr a PostfixOp (Expression a)+  | PrefixExpr a PrefixOp (Expression a)+  | InfixExpr a InfixOp (Expression a) (Expression a)+  | CondExpr a (Expression a) (Expression a) (Expression a)+  | AssignExpr a AssignOp (Expression a) (Expression a)+  | ParenExpr a (Expression a)+  | ListExpr a [Expression a]+  | CallExpr a (Expression a) [Expression a]+  | FuncExpr a [(Id a)] (Statement a)+  deriving (Show,Data,Typeable,Eq,Ord)++data CaseClause a +  = CaseClause a (Expression a) [Statement a]+  | CaseDefault a [Statement a]+  deriving (Show,Data,Typeable,Eq,Ord)+  +data CatchClause a +  = CatchClause a (Id a) (Statement a) +  deriving (Show,Data,Typeable,Eq,Ord)++data VarDecl a +  = VarDecl a (Id a) (Maybe (Expression a)) +  deriving (Show,Data,Typeable,Eq,Ord)+  +data ForInit a+  = NoInit+  | VarInit [VarDecl a]+  | ExprInit (Expression a)+  deriving (Show,Data,Typeable,Eq,Ord)++data ForInInit a+ = ForInVar (Id a)+ | ForInNoVar (Id a)+ deriving (Show,Data,Typeable,Eq,Ord)+  +  +data Statement a+  = BlockStmt a [Statement a]+  | EmptyStmt a+  | ExprStmt a (Expression a)+  | IfStmt a (Expression a) (Statement a) (Statement a)+  | IfSingleStmt a (Expression a) (Statement a)+  | SwitchStmt a (Expression a) [CaseClause a]+  | WhileStmt a (Expression a) (Statement a)+  | DoWhileStmt a (Statement a) (Expression a)+  | BreakStmt a (Maybe (Id a))+  | ContinueStmt a (Maybe (Id a))+  | LabelledStmt a (Id a) (Statement a)+  | ForInStmt a (ForInInit a) (Expression a) (Statement a)+  | ForStmt a (ForInit a)        +              (Maybe (Expression a)) -- increment+              (Maybe (Expression a)) -- test+              (Statement a)          -- body+  | TryStmt a (Statement a) {-body-} [CatchClause a] {-catches-}+      (Maybe (Statement a)) {-finally-}+  | ThrowStmt a (Expression a)+  | ReturnStmt a (Maybe (Expression a))+  | WithStmt a (Expression a) (Statement a)+  | VarDeclStmt a [VarDecl a]+  | FunctionStmt a (Id a) {-name-} [(Id a)] {-args-} (Statement a) {-body-}+  deriving (Show,Data,Typeable,Eq,Ord)  

@@ -1,63 +0,0 @@--- | Defines commonly used datatypes and functions.-module WebBits.Common-  ( PrettyPrintable(..)-  , L.isPrefixOf-  , SourcePos-  , sourceName-  ) where--import Data.Map (Map)-import Data.Maybe (catMaybes)-import Data.Char (toLower)-import Control.Applicative-import qualified System.IO as IO-import Control.Monad.State.Strict-import Control.Monad.Identity-import qualified Data.List as L-import Data.Generics hiding (GT)-import qualified Data.Foldable as Foldable-import Data.Foldable (Foldable)-import qualified Data.Traversable as Traversable-import Data.Traversable (Traversable, traverse)-import qualified Text.PrettyPrint.HughesPJ as Pp-import Text.ParserCombinators.Parsec.Pos (SourcePos, initialPos, sourceName)--lowercase = map toLower---- | 'PrettyPrintable' makes writing pretty-printing code for large, recursive--- data structures shorter.-class PrettyPrintable a where-  pp:: a -> Pp.Doc-  -instance PrettyPrintable a => PrettyPrintable (Maybe a) where-  pp (Just a) = pp a-  pp Nothing  = Pp.empty------------------------------------------------------------------------------------- Generics for SourcePos---- | These definitions allow us to use data structures containing 'SourcePos'--- values with generics.---- |We make 'SourcePos' an instance of 'Typeable' so that we can use it with--- generics.-instance Typeable SourcePos where-  typeOf _  = -    mkTyConApp (mkTyCon "Text.ParserCombinators.Parsec.Pos.SourcePos") []-    --- Complete guesswork.  It seems to work.-sourcePosDatatype = mkDataType "SourcePos" [sourcePosConstr1]-sourcePosConstr1 = mkConstr sourcePosDatatype "SourcePos" [] Prefix---- |We make 'SourcePos' an instance of 'Typeable' so that we can use it with--- generics.------ This definition is incomplete.-instance Data SourcePos where-  -- We treat source locations as opaque.  After all, we don't have access to-  -- the constructor.-  gfoldl k z pos = z pos-  toConstr _ = sourcePosConstr1-  gunfold   = error "gunfold is not defined for SourcePos"-  dataTypeOf = error "dataTypeOf is not defined for SourcePos"-

@@ -1,274 +0,0 @@--- |A zipper for "Data.Tree".-module WebBits.Data.Zipper-  ( -  -- * Functional zipper-  -  -- $functionalZipper-  -    Tree(..)-  , Location-  , toLocation, fromLocation  -  , dfsFold -  , dfsFoldM-  , showTree--  , empty-  , up, down, left, right -- Location a -> Location a-  , replace-  , change-  , insertDown, insertLeft, insertRight-  , isTop, isChild-  , getValue-  , subTree-  , top-  , canGoLeft, canGoRight, canGoUp, canGoDown -- Location a -> Bool-  -  -- * Imperative tree construction-  -  -- $treeBuilder-  -  , ZipperT--  , nest                  -- Monad m => v -> ZipperT v m a -> ZipperT v m a-  , getNode               -- Monad m => ZipperT v m v-  , setNode               -- Monad m => v -> ZipperT v m ()-  , runZipperT-  , evalZipperT-  , execZipperT-  , shiftLeft, shiftRight   -- Monad m => ZipperT v m ()-  , shiftLeft', shiftRight' -- Monad m => ZipperT v m ()-  , withCurrentChild        -- Monad m => Zipper T v m a -> ZipperT v m a-  -  ) where--import Control.Monad-import Control.Monad.State-import Data.Tree (Tree (..), drawTree)------------------------------------------------------------------------------------ Data types!-----data Path a-  = Top-  | Split a [Tree a] (Path a) [Tree a]--data Location a = Location (Tree a) (Path a)---dfsFold :: (w -> v -> w) -- ^transforms a node 'v' using the accumulated-                         -- value 'w' from the root of the tree to 'v'-        -> w             -- ^the initial value of the accumulator at the root-        -> Tree v -        -> Tree w-dfsFold f w (Node v ts) = Node w' (map (dfsFold f w') ts)-  where w' = f w v---- |Similar to 'dfsFold', but the transformation is done in the monad 'm'.  The--- sequence of operations is depth-first, left-to-right.-dfsFoldM :: Monad m => (w -> v -> m w) -> w -> Tree v -> m (Tree w)-dfsFoldM f w (Node v ts) = do-  w'  <- f w v-  ts' <- mapM (dfsFoldM f w') ts-  return $ Node w' ts'---- Uses 'Data.Tree.drawShow'.-showTree :: Show a => Tree a -> String-showTree tree =  drawTree (fmap show tree)-  ------------------------------------------------------------------------------------ Combinators!------- $functionalZipper--- These are the core zipper functions.--empty :: a -> Tree a-empty a = Node a []--up :: Location a -> Location a-up (Location _ Top)               = error " up of Top"-up (Location t (Split v ls p rs)) = Location (Node v (reverse ls ++ (t:rs))) p--down :: Location a -> Location a-down (Location (Node v []) _)     = error "down of empty"-down (Location (Node v (t:ts)) p) = Location t (Split v [] p ts)--left :: Location a -> Location a-left (Location t Top)                   = error "left of top"-left (Location t (Split v [] p rs))     = error "left on leftmost"-left (Location t (Split v (l:ls) p rs)) = Location l (Split v ls p (t:rs))--right :: Location a -> Location a-right (Location t Top) = -  error "Data.Zipper.right : at the top"-right (Location t (Split v ls p []))     = error "right on rightmost"-right (Location t (Split v ls p (r:rs))) = Location r (Split v (t:ls) p rs)--replace :: Location a -> Tree a ->  Location a-replace (Location _ p) t = Location t p--change :: Location a -> a -> Location a-change (Location (Node _ cs) p) t = Location (Node t cs) p--insertDown :: Location a -> Tree a -> Location a-insertDown (Location (Node v ts) p) t = Location (Node v (t:ts)) p--insertDownRight :: Location a -> Tree a -> Location a-insertDownRight (Location (Node v ts) p) t = -  Location t (Split v (reverse ts) p [])--insertLeft :: Location a -> Tree a -> Location a-insertLeft (Location _ Top) _                = error "insert on top"-insertLeft (Location t (Split v ls p rs)) t' =-  Location t (Split v (t':ls) p rs)--insertRight :: Location a -> Tree a -> Location a-insertRight (Location _ Top) _                = error "insert on top"-insertRight (Location t (Split v ls p rs)) t' = -  Location t (Split v ls p (t':rs))--isTop :: Location a -> Bool-isTop (Location _ Top) = True-isTop _                = False--isChild :: Location a -> Bool-isChild = not . isTop--canGoRight :: Location a -> Bool-canGoRight (Location _ (Split _ _ _ [])) = False-canGoRight (Location _ Top) = False-canGoRight _ = True--canGoDown :: Location a -> Bool-canGoDown (Location (Node _ []) _) = False-canGoDown _                        = True--canGoLeft :: Location a -> Bool-canGoLeft (Location _ Top)              = False-canGoLeft (Location _ (Split _ [] _ _)) = False-canGoLeft _                             = True--canGoUp :: Location a -> Bool-canGoUp (Location _ Top) = False-canGoUp _                = True--getValue :: Location a -> a-getValue (Location (Node v _) _) = v--subTree :: Location a -> Tree a-subTree (Location node _) = node---- |Traverses to the top of the tree.------ @--- up.top = undefined--- top.top = top--- @-top :: Location a -> Location a-top loc@(Location _ Top) = loc-top loc@(Location _ _) = top (up loc)--toLocation :: Tree a -> Location a-toLocation t = Location t Top--fromLocation :: Location a -> Tree a-fromLocation (Location t _) = t----- $treeBuilder--- A state monad that carries a zipper.  It provides convenient methods to--- imperatively create and update a tree.------ The state monad's set method may be used to arbitrarily update the current--- location.  However, such updates can break the behavior of nest and--- withCurrentChild.  We recommend avoiding StateT.set.--type ZipperT v m a = StateT (Location v) m a---runZipperT :: Monad m => ZipperT v m a -> Location v -> m (a, Tree v)-runZipperT m l = do-  (a, Location t Top) <- runStateT m l-  return (a,t)--evalZipperT :: Monad m => ZipperT v m a -> Location v -> m a-evalZipperT m l = do-  ~(a, _) <- runStateT m l-  return a--execZipperT :: Monad m => ZipperT v m a -> Location v -> m (Tree v)-execZipperT m l = do-  ~(_, Location t Top) <- runStateT m l-  return t---- |Creates a new node as the right-most child of the current node.-nest :: Monad m -     => v -- ^value of the new right-most child -     -> ZipperT v m a -- ^computation applied to the new child -     -> ZipperT v m a -- ^returns the result of the nested computation-nest v m = do-  z <- get -  put $ insertDownRight z (empty v)-  a <- m-  z' <- get -- z' is the child of z -  put (up z')-  return a-  -getNode :: Monad m => ZipperT v m v-getNode = do-  (Location (Node v _) _)  <- get-  return v-  -setNode :: Monad m => v -> ZipperT v m ()-setNode v = do-  (Location (Node _ cs) path) <- get-  put $ Location (Node v cs) path--withCurrentChild :: Monad m -                 => ZipperT v m a -- ^computation to apply to the current child -                 -> ZipperT v m a -- ^returns the result of the nested -                                  -- computation-withCurrentChild m = do-  z <- get-  put (down z)-  a <- m-  z' <- get-  put (up z')-  return a--shiftRight :: Monad m => ZipperT v m ()-shiftRight = do-  z <- get-  put (right z)--  -shiftLeft :: Monad m => ZipperT v m ()-shiftLeft = do-  z <- get-  put (left z)---- |Silently fails to shift right if there is no right-child.-shiftRight' :: Monad m => ZipperT v m ()-shiftRight' = do-  z <- get-  when (hasRight z)-       (put (right z))---- |Silently fails to shift left if there is no left-child.-shiftLeft' :: Monad m => ZipperT v m ()-shiftLeft' = do-  z <- get-  when (hasLeft z)-       (put (left z))--hasLeft :: Location a -> Bool-hasLeft (Location _ (Split _ (_:_) _ _)) = True-hasLeft _                                = False--hasRight :: Location a -> Bool-hasRight (Location _ (Split _ _ _ (_:_))) = True-hasRight _                                = False--

@@ -1,14 +0,0 @@--- |Rexports various modules of the HTML library.  It's best to use this in lieu--- of selectively importing the following libraries.-module WebBits.Html.Html-  ( module WebBits.Html.Syntax-  -- PermissiveParser-  , html-  , parseHtmlFromFile-  , parseHtmlFromString-  ) where-  -import WebBits.Html.Syntax-import WebBits.Html.PermissiveParser-import WebBits.Html.PrettyPrint -- no names, only instances-import WebBits.Html.Instances -- no names, only instances

@@ -1,66 +0,0 @@-module WebBits.Html.Instances() where--import qualified Prelude as Prelude-import Prelude (Functor,map,fmap)-import qualified Data.List as List-import qualified Data.Char as Char-import Data.Foldable-import Data.Traversable-import Control.Applicative--import WebBits.Html.Syntax--ltraverse:: (Traversable t, Applicative f) => (a -> f b) -> [t a] -> f [t b]-ltraverse f [] = pure []-ltraverse f (x:xs) = pure (:) <*> (traverse f x) <*> ltraverse f xs--instance Functor (Attribute a) where-  fmap f (Attribute id val a)            = Attribute id val a-  fmap f (AttributeExpr a id script def) = AttributeExpr a id (f script) def--instance Functor (Html a) where-  fmap f (Element id attrs children a) = -    Element id (map (fmap f) attrs) (map (fmap f) children) a-  fmap f (Text str a)                  = Text str a-  fmap f (Comment str a)               = Comment str a-  fmap f (HtmlSeq xs)                  = HtmlSeq (map (fmap f) xs)-  fmap f (ProcessingInstruction str a) = ProcessingInstruction str a-  fmap f (InlineScript script a def)   = InlineScript (f script) a def-  fmap f (Script script a)             = Script (f script) a--instance Foldable (Attribute a) where-  foldr f x (Attribute id val a)          = x-  foldr f x (AttributeExpr a id script def) = f script x--instance Foldable (Html a) where-  foldr f x (Element id attrs children a) =-    Prelude.foldr  (\child x' -> foldr f x' child) x children  -  foldr f x (Text str a)                  = x-  foldr f x (Comment str a)               = x-  foldr f x (HtmlSeq ys)                  = -    Prelude.foldr (\child x' -> foldr f x' child) x ys-  foldr f x (ProcessingInstruction str a) = x-  foldr f x (InlineScript script a def)   = f script x-  foldr f x (Script script a)             = f script x--instance Traversable (Attribute a) where-  traverse f (Attribute id val a)            =-    pure (Attribute id val a)-  traverse f (AttributeExpr a id script def) =-    (AttributeExpr a id) <$> (f script) <*> pure def--instance Traversable (Html a) where-  traverse f (Element id attrs children a) = -    (Element id) <$> ltraverse f attrs  <*> ltraverse f children <*> pure a-  traverse f (Text str a)                  = -    pure (Text str a)-  traverse f (Comment str a)               = -    pure (Comment str a)-  traverse f (HtmlSeq xs)                  = -    HtmlSeq <$> ltraverse f xs-  traverse f (ProcessingInstruction str a) = -    pure (ProcessingInstruction str a)-  traverse f (InlineScript script a def)   =-    InlineScript <$> (f script) <*> pure a <*> pure def-  traverse f (Script script a)             = -    Script <$> (f script) <*> pure a

@@ -1,492 +0,0 @@--- |A structure-recovering parser for malformed documents.------ Copyright 2007-2008 Arjun Guha.--- Based on HtmlPrag 0.16 Copyright (C) 2003 - 2005 Neil W. Van Dyke.  ------ This program is Free Software; you can redistribute it and/or modify it under--- the terms of the GNU Lesser General Public License as published by the Free--- Software Foundation; either version 2.1 of the License, or (at your option)--- any later version.  This program is distributed in the hope that it will be--- useful, but without any warranty; without even the implied warranty of--- merchantability or fitness for a particular purpose.  See --- <http://www.gnu.org/copyleft/lesser.html> for details.  For other license--- options and consulting, contact the author.-module WebBits.Html.PermissiveParser-  ( html-  , parseHtmlFromFile-  , parseHtmlFromString-  -- tokenizer is exported primarily for testing-  , tokens-  , Token-  ) where--import Control.Monad-import Text.ParserCombinators.Parsec hiding (token,tokens)-import qualified Text.ParserCombinators.Parsec as Parsec-import Data.Char (toLower)-import Data.List (intersperse)--import qualified WebBits.Html.Syntax as Html-import WebBits.Html.Syntax (HtmlId,Attribute,Script(..))--type ParsedHtml s = Html.Html SourcePos s-type ParsedAttribute s = Html.Attribute SourcePos s------------------------------------------------------------------------------------- Parsers generate warnings--data Warning = StringWarning SourcePos String--instance Show Warning where-  show (StringWarning p s) = "Warning parsing HTML: " ++ s-  showList [] s = s-  showList (x:xs) s = show x ++ ('\n':showList xs s)--warn:: String -> GenParser tok [Warning] ()-warn s = do-  p <- getPosition-  updateState ((StringWarning p s):)--noWarnings:: [Warning]-noWarnings = []-  ---- A structure-recovering parser for malformed documents, derived from--- Neil W. Van Dyke's htmlprag library for PLT Scheme---- The elements in the list can legally enclose the 1st element of the pair.-parentConstraints:: [(HtmlId,[HtmlId])]-parentConstraints =-  [("area",["map"]),-   ("body",["html"]),-   ("caption", ["table"]),-   ("colgroup", ["table"]),-   ("dd", ["dl"]),-   ("dt", ["dl"]),-   ("frame", ["frameset"]),-   ("head", ["html"]),-   ("isindex", ["head"]),-   ("li", ["dir", "menu", "ol", "ul"]),-   ("meta", ["head"]),-   ("noframes", ["frameset"]),-   ("option", ["select"]),-   ("p", ["body", "td", "th"]),-   ("param", ["applet"]),-   ("tbody", ["table"]),-   ("td", ["tr"]),-   ("th", ["tr"]),-   ("thead", ["table"]),-   ("title", ["head"]),-   ("tr", ["table", "tbody", "thead"])]---- |List of HTML elements that are empty.-emptyElements:: [HtmlId]-emptyElements = -  ["area", "base", "br", "frame", "hr", "img", "input", "isindex", "keygen", -   "link", "meta", "object", "param", "spacer", "wbr"]--isLegalChildOf:: HtmlId -> HtmlId -> Bool-isLegalChildOf child parent =-  case lookup child parentConstraints of-    Nothing             -> True-    (Just legalParents) -> parent `elem` legalParents-    -isEmptyElement:: HtmlId -> Bool-isEmptyElement element = element `elem` emptyElements----}}}------------------------------------------------------------------------------------- Parses an HTML file into a stream of tokens.---- The auxillary parsing functions return values of this type.-data Script s  => Token s-  = Text SourcePos String-  | EntityToken SourcePos String-  | EntityInt SourcePos Int-  | Tag SourcePos HtmlId [Attribute SourcePos s] Bool {-closed?-}-  | Script SourcePos s-  | Inline SourcePos s String-  | EndTag SourcePos HtmlId-  | Comment SourcePos String-  | DoctypeToken SourcePos String String String (Maybe String)---token:: Script s => Bool -> [Attribute SourcePos s] -     -> CharParser [Warning] (Token s)-token expectedScript prevAttrs = case expectedScript of-  True  -> (liftM2 Script getPosition (parseScriptBlock prevAttrs)) -             <?> "expected a script after a <script> tag"-  False -> doctype <|> comment <|> tag <|> endTag <|> inlineScript <|> entity -             <|> text--tokens:: Script s => CharParser [Warning] [Token s]-tokens = (eof >> return []) <|> tokens' where-  tokens' = do -    t <- token False []-    case t of-      (Tag _ "script" attrs False) -> do s <- token True attrs-                                         ts <- tokens-                                         return (t:s:ts)-      _ -> tokens >>= return.(t:)------------------------------------------------------------------------------------- Parsers for various components of HTML--qname:: CharParser st String-qname = do-  x <- letter-  xs <- many (noneOf "/*=<>\"\'  \v\f\t\r\n")-  return (x:xs)---- |We do not permit spaces between the hyphens and the right-angle in the--- terminating '-->'.-comment:: Script s => CharParser st (Token s) -comment =-  let notDoubleHyphen = try (char '-' >> notFollowedBy (char '-') >> return '-')-      notHyphen = noneOf "-"-    in do try (string "<!--")-          pos <- getPosition-          msg <- many (notHyphen <|> notDoubleHyphen)-          string "-->"-          return (Comment pos msg)--endTag:: Script s => CharParser [Warning] (Token s)-endTag  = do-  pos <- getPosition-  string "</"-  name <- qname <?> "closing tag\'s name"-  junk <- manyTill anyChar (char '>') -- permits junk between tag name and '>'-  unless (null junk) (warn $ "extra characters: " ++ junk ++ -                             "; assuming tag name is " ++ name)-  return (EndTag pos name)-  -doctype:: Script s => CharParser [Warning] (Token s)-doctype = do-  p <- getPosition-  try (string "<!DOCTYPE")-  spaces-  top <- qname <?> "top-element name"-  spaces-  avail <- qname <?> "availability"-  spaces-  regEtc <- quotedString <?> "registration, etc."-  spaces-  uri <- optionMaybe quotedString-  spaces-  string ">"-  return (DoctypeToken p top avail regEtc uri)-  -entity:: Script s => CharParser [Warning] (Token s)-entity = do-  char '&'-  pos <- getPosition-  name <- many alphaNum <|> (char '#' >> many1 digit)-  when (null name) (warn "no identifer or number after &")-  (char ';' >> return ()) <|> (warn "expected semi-colon after entity") -  return (EntityToken pos name)-  -notScript:: CharParser a Char-notScript = try (char '{' >> notFollowedBy (char '!') >> return '{')---- Parses raw text, upto an opening angle-bracket ('<').-text:: Script s => CharParser st (Token s)-text = do-  pos  <- getPosition-  cs <- many1 (noneOf "<{" <|> notScript) -- Doesn't consume the terminating angle bracket.-  return (Text pos cs)---- Strings that are either double-quoted or single-quoted.  Note that HTML--- strings contain no escape sequences.-quotedString:: CharParser a String-quotedString =-  (char '"' >> manyTill anyChar (char '"')) <|>-  (char '\'' >> manyTill anyChar (char '\'')) <?>-  "quoted string (double-quotes or single quotes)"---- Parses text to the right of a triple-stick in an inline expression.  We have--- to ensure that if we read a `!,' it isn't immediately followed by `}.'-initText =-  let notEnd = try (char '!' >> notFollowedBy (char '}') >> return '!')-    in many1 (notEnd <|> noneOf "!")--scriptValue:: Script s => CharParser a (s,String)-scriptValue =-  case parseAttributeScript of-    Nothing -> fail "attribute-script parser not defined"-    (Just parser) -> do string "{!"-                        script <- parser-                        init <- (string "!}" >> return "")  <|> -                                (string "|||" >> initText >>= -                                 (\s -> string "!}" >> return s))-                        return (script,init)--number:: CharParser a String-number = many1 digit---- -nonquotedAttribute:: CharParser [Warning]  String-nonquotedAttribute = do-  x <- alphaNum <|> oneOf "_"-  xs <- many (noneOf "/*=<>\"\'  \v\f\t\r\n")-  warn $ "non-quoted attribute value: " ++ (x:xs)-  return (x:xs)---attribute:: Script s => CharParser [Warning] (Html.Attribute SourcePos s)-attribute = do-  pos  <- getPosition-  name <- qname <?> "attribute name"-  spaces-  value <- (do char '='-               spaces-               (liftM Right scriptValue)-                 <|> (liftM Left (quotedString <|> nonquotedAttribute)) -                 <?> "attribute value")-           <|> (return $ Left "") -- Unspecified values are empty values.-  case value of-    (Left v)      -> return $ Html.Attribute name v pos-    (Right (s,d)) -> return $ Html.AttributeExpr pos name s d---- Takes the name of the immediately-enclosing parent tag as an argument.-tag:: Script s => CharParser [Warning] (Token s)-tag = do-  try (char '<' >> notFollowedBy (char '/'))-  pos <- getPosition-  name <- qname <?>  "opening tag\'s name"-  spaces-  attributes <- (attribute `sepEndBy` spaces)-  (char '>' >> return (Tag pos name attributes False))-    <|> (string "/>" >> return (Tag pos name attributes True))-    <?> "end of tag (i.e. \">\")"----- Parses an inline (curly-banged) script, if an inline-script parser has been--- specified (i.e. not Nothing).  Two-character lookahead for the ``{!,'' after--- which control is passed to the inline script parser.  Once control returns,--- the parser expects to see the closing ``!}.''-inlineScript:: Script s => CharParser a (Token s)-inlineScript =-  case parseInlineScript of-    Nothing -> fail "no inline script parser specified." -- TODO: appropriate?-    (Just parser) -> do string "{!" <?> "{! script !}"-                        pos <- getPosition-                        script <- parser-                        spaces-                        init <- (string "!}" >> return "") <|>-                                (string "|||" >> initText >>= -                                 (\s -> string "!}" >> return s))-                        return $ Inline pos script init----- Parses a stream of tokens, with a script parser, s and returns values of --- type a.-type TokenParser s a = GenParser (Token s) [Warning] a--instance Script s => Show (Token s) where-  show = tokenShow--tokenShow token = case token of-  (Text _ s)        -> s-  (EntityToken _ s) -> "&" ++ s ++ ";"-  (EntityInt _ n)   -> "&#" ++ show n ++ ";"-  (Tag _ id attrs closed) -> -    "<" ++ id ++ " ... " ++ closing where-      closing = if closed then "/>" else ">"-  (Script _ s)  -> "/* script body omitted */"-  (Inline _ s _)-> "{! /* script */ !}"-  (EndTag _ id) -> "</" ++ show id ++ ">"-  (Comment _ s) -> "<!-- " ++ show s ++ " -->"-  (DoctypeToken _ top avail desc Nothing) ->-    "<!DOCTYPE " ++ top ++ " " ++ avail ++ " " ++ show desc ++ ">"-  (DoctypeToken _ top avail desc (Just uri)) ->-    "<!DOCTYPE " ++ top ++ " " ++ avail ++ " " ++ show desc ++ " " -      ++ show uri ++ ">" --tokenPos tok = case tok of-  (Text p _) -> p-  (EntityToken p _) -> p-  (EntityInt p _) -> p-  (Tag p _ _ _) -> p-  (Script p _) -> p-  (Inline p _ _) -> p-  (EndTag p _) -> p-  (Comment p _) -> p-  (DoctypeToken p _ _ _ _) -> p-    -textToken :: Script s => TokenParser s (ParsedHtml s)-textToken = Parsec.token tokenShow tokenPos $ \t -> case t of-  Text _ s -> Just (Html.Text s (tokenPos t))-  otherwise -> Nothing-             -entityToken :: Script s => TokenParser s (ParsedHtml s)-entityToken =-  Parsec.token tokenShow tokenPos-    (\t -> case t of-             (EntityToken p s) -> Just (Html.Text ("&" ++ s ++ ";") p)-             (EntityInt p n) -> Just (Html.Text ("&#" ++ show n ++ ";") p)-             otherwise -> Nothing)-           -commentToken :: Script s => TokenParser s (ParsedHtml s)-commentToken = -  Parsec.token tokenShow tokenPos-    (\t -> case t of-             (Comment _ s) -> Just (Html.Comment s (tokenPos t))-             otherwise -> Nothing)--scriptToken :: Script s => TokenParser s (ParsedHtml s) -scriptToken = -  Parsec.token tokenShow tokenPos-    (\t -> case t of-             (Script p s) -> Just (Html.Script s p)-             otherwise    -> Nothing)--inlineToken :: Script s => TokenParser s (ParsedHtml s)-inlineToken = -  Parsec.token tokenShow tokenPos-    (\t -> case t of-             (Inline p s d) -> Just (Html.InlineScript s p d)-             otherwise    -> Nothing)-             -endToken :: Script s => TokenParser s HtmlId-endToken = -  Parsec.token tokenShow tokenPos-    (\t -> case t of-             (EndTag p s) -> Just s-             otherwise    -> Nothing)--tagToken :: Script s => TokenParser s (Token s)-tagToken = -  Parsec.token tokenShow tokenPos-  (\t -> case t of-           (Tag p id attrs closed) -> Just t-           otherwise               -> Nothing)--doctypeToken :: Script s => TokenParser s (Token s)-doctypeToken = Parsec.token tokenShow tokenPos $ \t -> case t of-  DoctypeToken _ _ _ _ _ -> Just t-  otherwise -> Nothing------------------------------------------------------------------------------------- HTML fragments---- |An HTML fragment represents an HTML element with a sequence of children.-data HtmlFragment s = Fragment {-  fragmentPosition   :: SourcePos,-  fragmentName       :: HtmlId,-  fragmentAttributes :: [ParsedAttribute s],-  fragmentChildren   :: [ParsedHtml s]-}--closeFragment:: HtmlFragment s -> ParsedHtml s-closeFragment (Fragment p htmlId attrs children) =  -  Html.Element htmlId attrs (reverse children) p--appendChildToFragment child fragment =-  fragment { fragmentChildren = child : (fragmentChildren fragment) }-             -atomic :: Script s => TokenParser s (ParsedHtml s)-atomic =-  textToken <|> commentToken <|> scriptToken <|> inlineToken <|> entityToken---maybeClose :: Script s => [HtmlFragment s] -> TokenParser s [HtmlFragment s] -maybeClose es = do-  htmlId <- endToken-  let close [] = do -        warn $ "unmatched closing tag \"" ++ htmlId ++ "\"; ignoring"-        return es-      close (e:e2:es) | fragmentName e == htmlId = do-        return $ (appendChildToFragment (closeFragment e) e2) : es-      close (e:e2:es) | otherwise = -        let e2' = appendChildToFragment (closeFragment e) e2-          in close (e2':es)-      close [e] | fragmentName e == htmlId = do-        return [e]-      close [e] | otherwise = do-        warn $ "unmatched closing tag \"" ++ htmlId ++ "\"; ignoring"-        return [e]-    in close es--open :: Script s => [HtmlFragment s] -> TokenParser s [HtmlFragment s]-open [] = fail "PermissiveParser.open: invalid state (1)"-open (e:es) = do-  (Tag p id attrs isClosed) <- tagToken-  case isClosed of-    True -> return $ (appendChildToFragment (Html.Element id attrs [] p) e) : es-    False ->-      case isEmptyElement id of-        True -> do warn $ "empty-element, \"" ++ id -                            ++ "\" was not immediately closed"-                   return $ (appendChildToFragment (Html.Element id attrs [] p)-                               e) : es-        False -> do-          let fragment = Fragment p id attrs []-              -- If we reach the root, simply make 'fragment' a child.-          let insert [root] = [fragment,root]-              -- The <html> element is the only child of the root.  This-              -- catches all other elements and makes them children of <html>.-              insert [html,root] = [fragment,html,root]-              insert (e1:e2:es) | id `isLegalChildOf` (fragmentName e1) =-                fragment:e1:e2:es-              insert (e1:e2:es) | otherwise =-                insert $ (appendChildToFragment (closeFragment e1) e2):es -              insert [] = fail "PermissiveParser.open: invalid state (2)"-          return $ insert (e:es)--structured es = do-  maybeClose es <|> open es--html' :: Script s => [HtmlFragment s] -> TokenParser s [HtmlFragment s]-html' [] = fail "PermissiveParser.html': invalid state (1)"-html' (e:es) =-  (do a <- atomic-      html' $ (appendChildToFragment a e):es) <|>-  (structured (e:es) >>= html') <|>-  (return (e:es))--parseRoot = Fragment (error "parseRoot: position is meaningless") -                     "DOCROOT"  (error "parseRoot: attributes are meaningless")-                     []--html :: Script s => CharParser [Warning] (Html.Html SourcePos s)-html = do-  let parser = do-        -- optional doctypeToken -- ignored-        fragments <- html' [parseRoot]-        case fragments of-          [fragment] -> case closeFragment fragment of -                          Html.Element _ _ (c:_) _ -> do-                            ws <- getState-                            return (ws,head [c])-                          otherwise -> fail "root element not found"-          otherwise -> fail "no root / multiple roots"-  toks <- tokens -- a stream of HTML entities-  pos <- Parsec.getPosition-  warnings <- Parsec.getState-  case Parsec.runParser parser warnings (Parsec.sourceName pos) toks of-    Left e -> fail  $ "unparsable HTML: " ++ (show e)-    Right (ws,html) -> Parsec.setState ws >> return html --htmlWithWarnings :: Script s -                 => CharParser [Warning] (Html.Html SourcePos s,[Warning])-htmlWithWarnings = do-  h <- html-  ws <- getState-  return (h,ws)--parseHtmlFromString :: Script s => String -> String -> Either Parsec.ParseError (Html.Html SourcePos s,[Warning])-parseHtmlFromString sourceName sourceText = -  case Parsec.runParser htmlWithWarnings noWarnings sourceName sourceText of-    Left err -> Left err-    Right (html,ws) -> Right (html,ws) --parseHtmlFromFile :: Script s -                  => String -                  -> IO (Either Parsec.ParseError -                                (Html.Html SourcePos s,[Warning]))-parseHtmlFromFile filename = do-  chars <- readFile filename-  case Parsec.runParser htmlWithWarnings noWarnings filename chars of-    Left err -> return (Left err)-    Right (html,ws) -> return $ Right (html,ws)

@@ -1,54 +0,0 @@--- |Pretty-printer for HTML.  This modules exports no names.  It only defines--- instances of 'PrettyPrintable' for HTML. -module WebBits.Html.PrettyPrint-  ( -- this module exports no names-  ) where--import qualified Data.List as List-import qualified Data.Char as Char-import Text.PrettyPrint.HughesPJ--import WebBits.Common (PrettyPrintable(..))--import WebBits.Html.Syntax--vert [] = empty-vert [doc] = doc-vert (doc:docs) = doc <> text "<!--" $+$-                  text "-->" <> vert docs--instance PrettyPrintable s => PrettyPrintable (Attribute a s) where-  pp (Attribute name value _) =-    text name <> equals <> doubleQuotes (text value)-  pp (AttributeExpr _ n v "") =-    text n <> equals <> text "{!" <+> pp v <+> text "!}"-  pp (AttributeExpr _ n v d) =-    text n <> equals <> text "{!" <+> pp v <+> text "|||" <+> text d -      <+> text "!}"--instance PrettyPrintable s => PrettyPrintable (Html a s) where-  -- The <script> tag must be terminated by </script>.-  -- <script lang= src= /> doesn't work.-  -- pp (Element name attrs [] _) =-  --   text "<" <> text name <+> hsep (map pp attrs) <+> text "/>"-  pp (Element name attrs children _) =-    -- WARNING: Spacing is very sensitive-    text "<" <> text name <+> hsep (map pp attrs) <> text ">"  -- opening-      $$ (nest 2 (vcat (map pp children)))                     -- body-      $$ text "</" <> text name <> text ">"                    -- closing-  -- Horizontally aligned material that is vertically represented in source.-  pp (HtmlSeq xs) = vert (map pp xs)-  pp (Text str _) =-    text (skipWs str) where-      skipWs str = List.dropWhile Char.isSpace str-  pp (Comment str _) =-    text "<!--" <+> text str <+> text "-->"-  pp (ProcessingInstruction str _) =-    text "<?" <> text str <> text ">"-  pp (Script script _) =-    pp script-  pp (InlineScript script _ "") =-    text "{!" <+> pp script <+> text "!}"-  pp (InlineScript script _ init) =-    text "{!" <+> pp script <+> text "|||" <+> text init <+> text "!}"-

@@ -1,34 +0,0 @@-module WebBits.Html.RawScript-  ( RawScript (..)-  , parseFromFile-  , parseFromString-  , RawHtml-  ) where--import Data.Generics (Data)-import Data.Generics (Typeable)-import Text.PrettyPrint.HughesPJ (text)-import Text.ParserCombinators.Parsec-import WebBits.Common-import WebBits.Html.Html--type RawHtml = Html SourcePos RawScript--data RawScript = RawScript String deriving (Show,Eq,Typeable,Data)--instance Script RawScript where-  parseInlineScript = Nothing-  -  parseAttributeScript = Nothing-  -  parseScriptBlock _ = do-    s <- manyTill anyChar (string "</script>")-    return (RawScript s)-    -instance PrettyPrintable RawScript where-  pp (RawScript s) = text s--parseFromString :: String -> RawHtml-parseFromString s = case parseHtmlFromString "" s of-  Left e -> error (show e)-  Right (html,_) -> html

@@ -1,84 +0,0 @@--- |Datatypes for HTML parameterized over an annotation type and a script type.
-module WebBits.Html.Syntax (
-  -- * HTML Data Structures
-    HtmlId,AttributeValue,Attribute(..),Html(..)
-  -- * The Script class
-  , Script(..)
-  -- * Miscellaneous Functions
-  , attributeValue,attributeUpdate,attributeSet,isAttributeExpr
-  ) where
-
-import Text.ParserCombinators.Parsec(CharParser,SourcePos)
-import Data.Generics(Data)
-import Data.Typeable(Typeable)
-
---------------------------------------------------------------------------------
--- Types
-
-type HtmlId = String
-type AttributeValue = String
-
-data Attribute a s
-  = Attribute HtmlId AttributeValue a
-  | AttributeExpr a HtmlId s String
-  deriving (Show,Eq,Typeable,Data)
-
-data Html a sc
-  = Element HtmlId [Attribute a sc] [Html a sc] a
-  | Text String a
-  | Comment String a
-  | HtmlSeq [Html a sc] -- ^must be a non-empty list
-  | ProcessingInstruction String a
-  | InlineScript sc a String
-  | Script sc a
-  deriving (Show,Eq,Typeable,Data)
-  
---------------------------------------------------------------------------------
--- The Script class
-
--- |A type 't' of the 'Script' class can be parsed using 'Parsec'.  't' is of
--- kind '* -> *', as the parsed AST should be annotated with souce locations
--- (see 'Text.ParserCombinators.Parsec.SourcePos').
---
--- The big deal here is that we can embed a parser for some scripting language,
--- (e.g. Javascript) into this HTML parser with ease, while preserving source
--- locations.  The Html datatype is parameterized over a script parser (an
--- instance of Script).
-class Script t where
-  parseScriptBlock:: [Attribute SourcePos t] -> CharParser a t
-  -- An inline script parser, which may be Nothing if the scripting language
-  -- does not support inline scripts.
-  parseInlineScript:: Maybe (CharParser a t)
-  -- A parser for script-expressions defined inline as attribute values.
-  parseAttributeScript:: Maybe (CharParser a t)
-  
---------------------------------------------------------------------------------
--- HTML navigation
-
-isAttributeExpr (AttributeExpr _ _ _ _) = True
-isAttributeExpr _                       = False
-
--- |Returns the value of the attribute in the list, or 'Nothing' if it doesn't
--- exist of the value is an inline-expression.
-attributeValue:: HtmlId -> [Attribute a s] -> Maybe String
-attributeValue name [] = Nothing
-attributeValue name ((AttributeExpr pos name' expr init):rest) =
-  if name == name' then Nothing
-                   else attributeValue name rest
-attributeValue name ((Attribute name' value _):rest) =
-  if name == name' then Just value
-                   else attributeValue name rest
-
-attributeSet:: HtmlId -> String -> [Attribute a s]  -> [Attribute a s]
-attributeSet n v attrs = attributeUpdate n (\_ -> v) attrs
-
-attributeUpdate:: HtmlId -> (String -> String) -> [Attribute a s] 
-               -> [Attribute a s]
-attributeUpdate n f [] = 
-  [Attribute n (f "") (error "attributeUpdate--no value")] -- TODO: undefined?!
-attributeUpdate n _ ((AttributeExpr _ _ _ _):_) =
-  error $ "attributeUpdate: " ++ n ++ " is an expression-attribute."
-attributeUpdate n f ((Attribute n' v p):attrs) =
-  if n' == n then (Attribute n (f v) p):attrs
-             else (Attribute n' v p):(attributeUpdate n f attrs)
-

@@ -1,21 +0,0 @@--- |Re-exports commonly used modules.-module WebBits.JavaScript-  ( module WebBits.JavaScript.Syntax-  , module WebBits.JavaScript.HtmlEmbedding-  , module WebBits.JavaScript.Parser-  , module WebBits.JavaScript.Combinators-  , module WebBits.Common-  , module WebBits.JavaScript.Environment-  -- JavaScript.Instances exports nothing-  ) where--import WebBits.Common--import WebBits.JavaScript.Syntax-import WebBits.JavaScript.Parser-import WebBits.JavaScript.PrettyPrint-import WebBits.JavaScript.HtmlEmbedding-import WebBits.JavaScript.Combinators-import WebBits.JavaScript.Environment--import WebBits.JavaScript.Instances

@@ -1,39 +0,0 @@-module WebBits.JavaScript.Combinators -  ( scriptStatements-  , isParenExpr-  , syntaxAt-  , expressionsAt-  , statementsAt-  ) where--import Data.Generics (Data,Typeable, everything, mkQ)-import Text.ParserCombinators.Parsec (SourcePos)-import qualified Data.Foldable as F-import Data.Foldable (Foldable)-import WebBits.JavaScript.Syntax-import WebBits.JavaScript.Instances ()-import WebBits.Common () --scriptStatements:: JavaScript a -> [Statement a]-scriptStatements (Script _ ss) = ss--isParenExpr (ParenExpr _ _) = True-isParenExpr _               = False--syntaxAt :: (Data a, Typeable a, Data (t SourcePos), -             Typeable (t SourcePos), Foldable t)-         => SourcePos -> a -> [t SourcePos]-syntaxAt pos a = everything (++) (mkQ [] isMatch) a where-  isMatch stx = case F.find (const True) stx of-    Nothing -> []-    Just pos' | pos == pos' -> [stx]-              | otherwise   -> []--expressionsAt :: (Data a, Typeable a) -              => SourcePos -> a -> [Expression SourcePos]-expressionsAt = syntaxAt--statementsAt :: (Data a, Typeable a) -              => SourcePos -> a -> [Statement SourcePos]-statementsAt = syntaxAt-

@@ -1,80 +0,0 @@--- |Crawls an HTML page for JavaScript-module WebBits.JavaScript.Crawl -  ( getPageJavaScript-  ) where--import WebBits.Common-import Control.Monad-import Data.Char (toLower)-import Data.Generics-import System.IO-import Text.ParserCombinators.Parsec(parse,setPosition,incSourceColumn,Column,sourceLine,sourceColumn)--import WebBits.Html.Syntax-import qualified WebBits.JavaScript.JavaScript as Js---- |Returns the source of the script.-scriptSrc:: Js.ParsedJsHtml -> [String]-scriptSrc (Element tag attrs _ _) | (map toLower tag) == "script" =-  case attributeValue "src" attrs of -- TODO: Check for type="javascript"?-    Just ""  -> []-    Just url -> [url]-    Nothing  -> []-scriptSrc _ =-  []---- |Returns a list of URIs for external Javascript files referenced in the page.-importedScripts:: Js.ParsedJsHtml -> [String]-importedScripts = everything (++) (mkQ [] scriptSrc)---- |Returns the top-level statements of a script.-scriptText :: Js.ParsedJsHtml -> [Js.ParsedStatement]-scriptText (Script (Js.Script _ stmts) _) = stmts-scriptText _ = []--eventHandlers :: [String]-eventHandlers = ["onload","onclick"]; --- ,"onmousemove","onmouseover","onmousedown","onmouseout","onmouseup","onselectstart", "onkeypress"]--attrScript :: Attribute SourcePos Js.ParsedJavaScript -           -> IO [Js.ParsedStatement]-attrScript (Attribute id val loc) | id `elem` eventHandlers = do-  let eventId = drop 2 id -- drop the "on" prefix-  let scriptText = if "javascript:" `isPrefixOf` val then drop 11 val else val-  let eventListenerPrefix = "addEventListener('" ++ eventId ++ "', function(event) { "-  let prefixLen = length eventListenerPrefix-  let eventListenerText = eventListenerPrefix ++ scriptText ++ " });"-  let parser = do-        setPosition (incSourceColumn loc (-prefixLen))-        Js.parseExpression-  case parse parser (sourceName loc) eventListenerText of-    Left err -> do-      fail $ "Error parsiing JavaScript in an attribute at " ++ show loc ++-             "\nThe script was:\n\n" ++ eventListenerText-    Right e -> return [Js.ExprStmt loc e]-attrScript _ = return []--inpageAttrScripts :: Js.ParsedJsHtml -> IO [Js.ParsedStatement]-inpageAttrScripts = everything (liftM2 (++)) (mkQ (return []) attrScript)--inpageScripts :: Js.ParsedJsHtml -> [Js.ParsedStatement]-inpageScripts = everything (++) (mkQ [] scriptText)--parseJsFile path = do-  text <- readFile path-  case Js.parseScriptFromString path text of-    Left err -> fail (show err)-    Right js -> hPutStrLn stderr ("Read file " ++ path) >> return js---- |Given an HTML page, crawls all external Javascript files and returns a list--- of statements, concatenated from all files.-getPageJavascript:: Js.ParsedJsHtml -> IO [Js.ParsedStatement]-getPageJavascript page = do-  let importURIs = importedScripts page-  let inpageJs   = inpageScripts page-  attrScripts <- inpageAttrScripts page-  importedScripts <- mapM parseJsFile importURIs-  return $ (concatMap Js.scriptStatements importedScripts ++ attrScripts) ++ inpageJs--getPageJavaScript:: Js.ParsedJsHtml -> IO [Js.ParsedStatement] -- monomorphism-getPageJavaScript = getPageJavascript

@@ -1,304 +0,0 @@-module WebBits.JavaScript.Environment -  ( staticEnvironment-  , Ann-  , LabelledStatement-  , LabelledExpression-  , Env-  ) where--import Data.Generics hiding (GT)-import Data.Maybe (fromJust)-import qualified Data.Set as S-import WebBits.Data.Zipper (ZipperT,ZipperT)-import qualified Data.Map as M-import qualified WebBits.Data.Zipper as Z-import Control.Monad.State-import qualified Data.Foldable as F-import qualified Data.List as L-import WebBits.JavaScript.JavaScript-import Text.ParserCombinators.Parsec.Pos (SourcePos,initialPos)-------- Add `this' and `arguments' to the formal parameters of all --- functions ------ TODO: Does a local var x shadow a formal argument x?  What about 'arguments'?--thisStmt :: Statement SourcePos -> Statement SourcePos-thisStmt (FunctionStmt loc id args body) = -  FunctionStmt loc id ((Id loc "this"):(Id loc "arguments"):args) body-thisStmt s = s--thisExpr :: Expression SourcePos -> Expression SourcePos-thisExpr (FuncExpr l args s) = -  FuncExpr l ((Id l "this"):(Id l "arguments"):args) s-thisExpr e = e--removeParens :: Expression SourcePos -> Expression SourcePos-removeParens (ParenExpr _ e) = e-removeParens e = e--removeSingletons :: Expression SourcePos -> Expression SourcePos-removeSingletons (ListExpr _ [e]) = e-removeSingletons e = e--explicitThis :: [Statement SourcePos] -> [Statement SourcePos]-explicitThis = everywhere $ (mkT removeSingletons) . (mkT removeParens) -  . (mkT thisExpr) . (mkT thisStmt)---- JavaScript has a global and function scopes.  Globals do not need to be--- declared.  Any "unbound identifier" in a function is treated as a reference--- to a global.---- For each FunctionExpr and FunctionStmt, we create a list of locally defined--- identifiers (var x = ...) and free identifiers.---- We build a tree of "partial environments."  Since a variable may be used--- before it is declared locally, we maintain a set of free identifiers and--- narrow the set when appropriate.-type PartialEnv = (Env,S.Set String)--type Env = M.Map String Int--emptyPartialEnv :: PartialEnv-emptyPartialEnv = (M.empty,S.empty)--type RefM a = Z.ZipperT PartialEnv (State Int) a--nextLabel :: (MonadTrans t, Monad (t (State Int))) => t (State Int) Int-nextLabel = do-  l <- lift get-  lift $ modify (+1)-  return l -  -bind :: Id SourcePos -> RefM ()-bind (Id _ s) = do-  lbl <- nextLabel-  (env,freeIds) <- Z.getNode-  Z.setNode (M.insert s lbl env, S.delete s freeIds)-  -use :: Id SourcePos -> RefM ()-use (Id _ s) = do-  (env,freeIds) <- Z.getNode-  case M.lookup s env of-    Just _ -> return ()-    Nothing -> Z.setNode (env, S.insert s freeIds)-  --buildExpr :: Expression SourcePos -> RefM (Expression SourcePos)-buildExpr (FuncExpr loc args stmt) = do-  stmt' <- Z.nest emptyPartialEnv (mapM_ bind args >> buildStmt stmt)-  return (FuncExpr loc args stmt')-buildExpr e@(VarRef _ id) = do-  use id-  return e-buildExpr (AssignExpr loc op (VarRef loc' id) e) = do-  use id-  e' <- buildExpr e-  return (AssignExpr loc op (VarRef loc' id) e')-buildExpr e =-  gmapM buildAny e--buildCatchClause :: CatchClause SourcePos -> RefM (CatchClause SourcePos)-buildCatchClause (CatchClause loc id stmt) = do-  bind id-  stmt' <- buildStmt stmt-  return (CatchClause loc id stmt')-  -buildVarDecl :: VarDecl SourcePos -> RefM (VarDecl SourcePos)-buildVarDecl (VarDecl loc id ye) = do-  bind id-  ye' <- gmapM buildAny ye-  return (VarDecl loc id ye')--buildForInInit :: ForInInit SourcePos -> RefM (ForInInit SourcePos)-buildForInInit e@(ForInVar id) = do-  bind id-  return e-buildForInInit e@(ForInNoVar id) = do-  use id-  return e-  -buildStmt :: Statement SourcePos -> RefM (Statement SourcePos)-buildStmt (FunctionStmt loc id args stmt) = do-  stmt' <- Z.nest emptyPartialEnv (mapM_ bind args >> buildStmt stmt)-  return (FunctionStmt loc id args stmt')-buildStmt s = gmapM buildAny s--buildAny' :: (Data a, Typeable a) => a -> RefM a-buildAny' v = gmapM buildAny v--buildAny :: GenericM RefM-buildAny =-  buildAny' `extM` buildExpr `extM` buildCatchClause `extM`-    buildVarDecl `extM` buildForInInit `extM` buildStmt------- buildAny creates a tree of partial environments.  We now walk the tree and--- attempt to associate free identifiers with their bindings in enclosing--- scopes.  Any remaining free identifiers are globals.-----resolveFreeId :: Env -> String -> StateT Env (State Int) Env-resolveFreeId env freeId = case M.lookup freeId env of-  Just lbl -> return env -- the free identifier was bound in an enclosing env-  Nothing  -> do -- this is a global -    globals <- get-    case M.lookup freeId globals of-      Just lbl -> return (M.insert freeId lbl env) -- global already bound-      Nothing -> do -- new global-        lbl <- nextLabel-        put (M.insert freeId lbl globals)-        return (M.insert freeId lbl env)---completeEnvM' :: Z.Tree PartialEnv -> StateT Env (State Int) (Z.Tree Env)-completeEnvM' pt = Z.dfsFoldM f M.empty pt where-  -- the union is left-biased; bindings in env shadow bindings in enclosingEnv-  f enclosingEnv (env,freeIds) = -    foldM resolveFreeId (M.union env enclosingEnv) (S.elems freeIds) --completeEnvM :: Z.Tree PartialEnv -> StateT Env (State Int) (Z.Tree Env)-completeEnvM pt = do-  tree <- completeEnvM' pt-  globals <- get-  -- left-biased union: lexicals shadow globals-  return (fmap (\lexicals -> M.union lexicals globals) tree)------- completeEnvM creates a tree of environments whose structure is identical to--- the function-nesting structure of the JavaScript source.  We walk the tree--- and the code in step and annotate the code with environments.-----type Ann = (Env,Int,SourcePos)--type LabelledStatement = Statement Ann-type LabelledExpression = Expression Ann---- Necessary for type-checking.  gmapM won't let us transform the type of the--- annotation.  So, we first inject SourcePos into a trivial Ann.-insertEmptyAnn :: (Functor f) => f SourcePos -> f Ann-insertEmptyAnn = fmap (\loc -> (M.empty,0,loc))---locOf :: F.Foldable t => t SourcePos -> SourcePos-locOf = fromJust . (F.find $ const True)--labelEnv :: Env -> Z.ZipperT Env (State Int) Env-labelEnv env = Z.getNode--labelId :: Id Ann -> Z.ZipperT Env (State Int) (Id Ann)-labelId id@(Id (_,_,loc) s) = do-  env <- Z.getNode-  case M.lookup s env of-    Nothing -> fail $ "BUG: unbound identifier while labelling" ++ show id-    Just lbl -> return (Id (env,lbl,loc) s)-    -labelIdNoVar :: Id Ann -> Z.ZipperT Env (State Int) (Id Ann)-labelIdNoVar (Id (_,_,loc) s) = do-  env <- Z.getNode-  lbl <- nextLabel-  return (Id (env,lbl,loc) s)--labelProp :: Prop Ann -> Z.ZipperT Env (State Int) (Prop Ann)-labelProp (PropId (_,_,loc) id) = do-  env <- Z.getNode-  lbl <- nextLabel-  id' <- labelIdNoVar id-  return (PropId (env,lbl,loc) id')-labelProp e = gmapM labelAny e---labelVarDecl :: VarDecl Ann-             -> Z.ZipperT Env (State Int) (VarDecl Ann)-labelVarDecl (VarDecl (_,_,loc) id@(Id _ name) rhs) = do-  env <- Z.getNode-  case M.lookup name env of-    Nothing -> fail $ "WebBits bug: unbound id in labelVarDecl (" ++ name ++ ")"-    Just lbl' -> case rhs of-      Nothing -> return (VarDecl (env,lbl',loc) id Nothing)-      Just expr -> do-        expr' <- labelExpr expr-        return (VarDecl (env,lbl',loc) id (Just expr'))--labelExpr :: Expression Ann -          -> Z.ZipperT Env (State Int) (Expression Ann)-labelExpr (ThisRef (_,_,loc)) = do-  env <- Z.getNode-  case M.lookup "this" env of-    Just lbl -> return $ ThisRef (env,lbl,loc)-    Nothing -> fail "BUG: expected to find this in the environment"-labelExpr (DotRef (_,_,loc) expr id) = do-  env <- Z.getNode-  lbl <- nextLabel-  id' <- labelIdNoVar id-  expr' <- labelExpr expr-  return (DotRef (env,lbl,loc) expr' id')-labelExpr (VarRef (_,_,loc) id@(Id _ name)) = do-  env <- Z.getNode-  case M.lookup name env of-    Nothing -> fail $ "WebBits bug : unbound identifer " ++ name-    Just lbl' -> return (VarRef (env,lbl',loc) id)-labelExpr (FuncExpr (_,_,loc) args stmt) = do-  env <- Z.getNode-  lbl <- nextLabel-  args' <- Z.withCurrentChild (mapM labelId args)-  stmt' <- Z.withCurrentChild (labelStmt stmt)-  Z.shiftRight'-  return (FuncExpr (env,lbl,loc) args' stmt')-labelExpr e = gmapM labelAny e-  -labelStmt :: Statement Ann-          -> Z.ZipperT Env (State Int) (Statement Ann)-labelStmt (BreakStmt (_,_,loc) (Just id)) = do-  env <- Z.getNode-  lbl <- nextLabel-  id' <- labelIdNoVar id-  return (BreakStmt (env,lbl,loc) (Just id'))-labelStmt (ContinueStmt (_,_,loc) (Just id)) = do-  env <- Z.getNode-  lbl <- nextLabel-  id' <- labelIdNoVar id-  return (ContinueStmt (env,lbl,loc) (Just id'))-labelStmt (LabelledStmt (_,_,loc) id stmt) = do-  env <- Z.getNode-  lbl <- nextLabel-  id' <- labelIdNoVar id-  stmt' <- labelStmt stmt-  return (LabelledStmt (env,lbl,loc) id' stmt')  -labelStmt (FunctionStmt (_,_,loc) id args stmt) = do-  env <- Z.getNode-  lbl <- nextLabel-  args' <- Z.withCurrentChild (mapM labelId args)-  stmt' <- Z.withCurrentChild (labelStmt stmt)-  Z.shiftRight'-  return (FunctionStmt (env,lbl,loc) id args' stmt')-labelStmt e = gmapM labelAny e--labelAny' :: (Data a, Typeable a) => a -> Z.ZipperT Env (State Int) a-labelAny' a = gmapM labelAny a--labelAny :: GenericM (Z.ZipperT Env (State Int)) -labelAny a = (labelAny' `extM` labelEnv `extM` labelId `extM` labelProp `extM`-  labelExpr `extM` labelStmt `extM` labelVarDecl) a--topLevelPartialEnv = (M.empty,S.singleton "this")---- |Annotates each expression with its static environment.  In addition,--- a map of free identifiers is returned, along with the next valid label.-staticEnvironment :: [Statement SourcePos] -                  -> ([Statement Ann],Env,Env,Int)-staticEnvironment stmts =-  let stmts' = explicitThis stmts-      labelM = do-        partialEnvTree <- Z.execZipperT (mapM buildStmt stmts')-                            (Z.toLocation (Z.Node topLevelPartialEnv []))-        (envTree,freeEnv) <- runStateT (completeEnvM partialEnvTree) M.empty-        let globals = M.union freeEnv (Z.rootLabel envTree)-        let stmts'' = map insertEmptyAnn stmts' -        labelledStmts <- Z.evalZipperT (mapM labelStmt stmts'') -                                       (Z.toLocation envTree)-        return (labelledStmts,freeEnv,globals)-      ((labelledStmts,freeEnv,globals),nextLabel) = runState labelM 1-    in (labelledStmts,freeEnv,globals,nextLabel)

@@ -1,26 +0,0 @@-module WebBits.JavaScript.HtmlEmbedding-  ( JsHtml-  , ParsedJavaScript-  , ParsedJsHtml-  ) where--import WebBits.Html.Syntax(Html,Script,parseScriptBlock,parseInlineScript,-                   parseAttributeScript)-import WebBits.JavaScript.Parser(parseScript)-import WebBits.JavaScript.Syntax(JavaScript)---import JavaScript.PrettyPrint -- for the instance declaration-import Text.ParserCombinators.Parsec (SourcePos)--type JsHtml a = Html SourcePos (JavaScript a)--type ParsedJavaScript = JavaScript SourcePos--type ParsedJsHtml = JsHtml SourcePos--instance Script ParsedJavaScript where-  parseScriptBlock attrs = do-    parseScript-  parseInlineScript = Nothing-  parseAttributeScript = Nothing-    -  

@@ -1,291 +0,0 @@--- |Instances of 'Foldable' and 'Traversable' for JavaScript's syntax.-module WebBits.JavaScript.Instances-  ( -- This module does not export any names.-  ) where--import Prelude hiding (foldr,sequence,mapM)-import qualified Prelude as Prelude--import Data.Foldable (Foldable(..))-import Data.Traversable(Traversable(..))-import Control.Applicative--import WebBits.JavaScript.Syntax--yfoldr:: Foldable t => (a -> b -> b) -> b -> Maybe (t a) -> b-yfoldr _ b Nothing = b-yfoldr f b (Just t) = foldr f b t--lfoldr:: Foldable t => (a -> b -> b) -> b -> [t a] -> b-lfoldr f = Prelude.foldr (flip $ foldr f)--ltraverse:: (Traversable t, Applicative f) => (a -> f b) -> [t a] -> f [t b]-ltraverse _ [] = pure []-ltraverse f (a:as) = (:) <$> traverse f a <*> ltraverse f as--ytraverse:: (Traversable t, Applicative f) -         => (a -> f b) -> Maybe (t a) -> f (Maybe (t b))-ytraverse _ Nothing = pure Nothing-ytraverse f (Just t) = Just <$> traverse f t--instance Functor Id where-  fmap f (Id a v) = Id (f a) v--instance Functor JavaScript where-  fmap f (Script a stmts) = Script (f a) (map (fmap f) stmts)-  -instance Functor Prop where-  fmap f (PropId a id) = PropId (f a) (fmap f id)-  fmap f (PropString a s) = PropString (f a) s-  fmap f (PropNum a n) = PropNum (f a) n--instance Functor Expression where-  fmap f expression = -    case expression of-      StringLit a s -> StringLit (f a) s-      RegexpLit a s g ci -> RegexpLit (f a) s g ci-      NumLit a n -> NumLit (f a) n-      BoolLit a b -> BoolLit (f a) b-      NullLit a -> NullLit (f a)-      ArrayLit a es -> ArrayLit (f a) (map (fmap f) es)-      ObjectLit a pes -> ObjectLit (f a) (map f' pes) where-        f' (p,e) = (fmap f p, fmap f e)-      ThisRef a -> ThisRef (f a)-      VarRef a id -> VarRef (f a) (fmap f id)-      DotRef a e id -> DotRef (f a) (fmap f e) (fmap f id)-      BracketRef a e1 e2 -> BracketRef (f a) (fmap f e1) (fmap f e2)-      NewExpr a e es -> NewExpr (f a) (fmap f e) (map (fmap f) es)-      PostfixExpr a op e -> PostfixExpr (f a) op (fmap f e)-      PrefixExpr a op e -> PrefixExpr (f a) op (fmap f e)-      InfixExpr a op e1 e2 -> InfixExpr (f a) op (fmap f e1) (fmap f e2)-      CondExpr a e1 e2 e3 -> CondExpr (f a) (fmap f e1) (fmap f e2) (fmap f e3)-      AssignExpr a op e1 e2 -> AssignExpr (f a) op (fmap f e1) (fmap f e2)-      ParenExpr a e -> ParenExpr (f a) (fmap f e)-      ListExpr a es -> ListExpr (f a) (map (fmap f) es)-      CallExpr a e es -> CallExpr (f a) (fmap f e) (map (fmap f) es)-      FuncExpr a args s -> FuncExpr (f a) (map (fmap f) args) (fmap f s)--instance Functor CaseClause where-  fmap f (CaseClause a e ss) = CaseClause (f a) (fmap f e) (map (fmap f) ss)-  fmap f (CaseDefault a ss) = CaseDefault (f a) (map (fmap f) ss)-  -instance Functor CatchClause where-  fmap f (CatchClause a id s) = CatchClause (f a) (fmap f id) (fmap f s)--instance Functor VarDecl where-  fmap f (VarDecl a id Nothing) = VarDecl (f a) (fmap f id) Nothing-  fmap f (VarDecl a id (Just e)) = VarDecl (f a) (fmap f id) (Just $ fmap f e)-  -instance Functor ForInit where-  fmap f NoInit = NoInit-  fmap f (VarInit decls) = VarInit (map (fmap f) decls)-  fmap f (ExprInit e) = ExprInit (fmap f e)--instance Functor ForInInit where-  fmap f (ForInVar id) = ForInVar (fmap f id)-  fmap f (ForInNoVar id) = ForInNoVar (fmap f id)-  -instance Functor Statement where-  fmap f s = -    case s of-      BlockStmt a ss -> BlockStmt (f a) (map (fmap f) ss)-      EmptyStmt a -> EmptyStmt (f a)-      ExprStmt a e -> ExprStmt (f a) (fmap f e)-      IfStmt a e s1 s2 -> IfStmt (f a) (fmap f e) (fmap f s1) (fmap f s2)-      IfSingleStmt a e s -> IfSingleStmt (f a) (fmap f e) (fmap f s)-      SwitchStmt a e cs -> SwitchStmt (f a) (fmap f e) (map (fmap f) cs)-      WhileStmt a e s -> WhileStmt (f a) (fmap f e) (fmap f s)-      DoWhileStmt a s e -> DoWhileStmt (f a) (fmap f s) (fmap f e)-      BreakStmt a Nothing -> BreakStmt (f a) Nothing-      BreakStmt a (Just id) -> BreakStmt (f a) (Just (fmap f id))-      ContinueStmt a yid -> ContinueStmt (f a) (yid >>= return.(fmap f))-      LabelledStmt a id s -> LabelledStmt (f a) (fmap f id) (fmap f s)-      ForInStmt a init e s -> ForInStmt (f a) (fmap f init) (fmap f e)-                                (fmap f s)-      ForStmt a init yinc ytest body -> -        ForStmt (f a) (fmap f init) (yinc >>= return.(fmap f))-          (ytest >>= return.(fmap f)) (fmap f body)-      TryStmt a s cs ys -> -        TryStmt (f a) (fmap f s) (map (fmap f) cs) (ys >>= return.(fmap f))-      ThrowStmt a e -> ThrowStmt (f a) (fmap f e)-      ReturnStmt a ye -> ReturnStmt (f a) (ye >>= return.(fmap f))-      WithStmt a e s -> WithStmt (f a) (fmap f e) (fmap f s)-      VarDeclStmt a ds -> VarDeclStmt (f a) (map (fmap f) ds)-      FunctionStmt a id args s -> -        FunctionStmt (f a) (fmap f id) (map (fmap f) args) (fmap f s)--instance Foldable Id where-  foldr f b (Id a _) = f a b--instance Foldable Prop where-  foldr f b (PropId a id) = f a (foldr f b id)-  foldr f b (PropString a _) = f a b-  foldr f b (PropNum a _) = f a b-        -instance Foldable Expression where-  -- foldr:: (a -> b -> b) -> b -> Expression a -> b-  foldr f b e =-    case e of-      StringLit a _ -> f a b-      RegexpLit a _ _ _ -> f a b-      NumLit a _ -> f a b-      BoolLit a _ -> f a b-      NullLit a -> f a b-      ArrayLit a es -> f a (Prelude.foldr (flip $ foldr f) b es)-      ObjectLit a pes -> f a (Prelude.foldr f' b pes) where-        f' (p,e) b = foldr f (foldr f b e) p-      ThisRef a -> f a b-      VarRef a id -> f a (foldr f b id)-      DotRef a e id -> f a (foldr f (foldr f b id) e)-      BracketRef a e1 e2 -> f a (foldr f (foldr f b e2) e1)-      NewExpr a e es -> f a (foldr f (Prelude.foldr (flip $ foldr f) b es) e)-      PostfixExpr a _ e -> f a $ foldr f b e-      PrefixExpr a _ e -> f a $ foldr f b e-      InfixExpr a _ e1 e2 -> f a $ foldr f (foldr f b e2) e1-      CondExpr a e1 e2 e3 -> f a $ foldr f (foldr f (foldr f b e3) e2) e1-      AssignExpr a _ e1 e2 -> f a $ foldr f (foldr f b e2) e1-      ParenExpr a e -> f a $ foldr f b e-      ListExpr a es -> f a $ Prelude.foldr (flip $ foldr f) b es-      CallExpr a e es -> f a $ foldr f (Prelude.foldr (flip $ foldr f) b es) e-      FuncExpr a args s -> -        f a $ Prelude.foldr (flip $ foldr f) (foldr f b s) args--instance Foldable CaseClause where-  foldr f b (CaseClause a e ss) = -    f a $ foldr f (Prelude.foldr (flip $ foldr f) b ss) e-  foldr f b (CaseDefault a ss) = f a $ Prelude.foldr (flip $ foldr f) b ss-  -instance Foldable CatchClause where-  foldr f b (CatchClause a id s) = f a $ foldr f (foldr f b s) id--instance Foldable VarDecl where-  foldr f b (VarDecl a id ye) = f a $ foldr f (yfoldr f b ye) id--instance Foldable ForInit where-  foldr f b NoInit = b-  foldr f b (VarInit ds) = Prelude.foldr (flip $ foldr f) b ds-  foldr f b (ExprInit e) = foldr f b e--instance Foldable ForInInit where- foldr f b (ForInVar id) = foldr f b id- foldr f b (ForInNoVar id) = foldr f b id--instance Foldable Statement where-  foldr f b statement =-    case statement of-      BlockStmt a ss -> f a $ lfoldr f b ss-      EmptyStmt a -> f a b-      ExprStmt a e -> f a $ foldr f b e-      IfStmt a e s1 s2 -> f a $ foldr f (foldr f (foldr f b s2) s1) e-      IfSingleStmt a e s -> f a $ foldr f (foldr f b s) e-      SwitchStmt a e cs -> f a $ foldr f (lfoldr f b cs) e-      WhileStmt a e s -> f a $ foldr f (foldr f b s) e-      DoWhileStmt a s e -> f a $ foldr f (foldr f b e) s-      BreakStmt a yid -> f a $ yfoldr f b yid-      ContinueStmt a yid -> f a $ yfoldr f b yid-      LabelledStmt a id s -> f a $ foldr f (foldr f b s) id-      ForInStmt a init e s -> f a $ foldr f (foldr f (foldr f b s) e) init-      ForStmt a init ye1 ye2 s ->-        f a $ foldr f (yfoldr f (yfoldr f (foldr f b s) ye2) ye1) init-      TryStmt a s cs ys -> f a $ foldr f (lfoldr f (yfoldr f b ys) cs) s-      ThrowStmt a e -> f a $ foldr f b e-      ReturnStmt a ys -> f a $ yfoldr f b ys-      WithStmt a e s -> f a $ foldr f (foldr f b s) e-      VarDeclStmt a ds -> f a $ lfoldr f b ds-      FunctionStmt a id args s ->-        f a $ lfoldr f (foldr f b s) (id:args)--instance Traversable Id where-  traverse f (Id a v) = Id <$> f a <*> pure v--instance Traversable Prop where-  traverse f (PropId a id) = PropId <$> f a <*> traverse f id-  traverse f (PropString a s) = PropString <$> f a <*> pure s-  traverse f (PropNum a n) = PropNum <$> f a <*> pure n-  -instance Traversable Expression where-  traverse f expression =-    case expression of-      StringLit a s -> StringLit <$> f a <*> pure s-      RegexpLit a s g ci -> RegexpLit <$> f a <*> pure s <*> pure g <*> pure ci-      NumLit a n -> NumLit <$> f a <*> pure n-      BoolLit a b -> BoolLit <$> f a <*> pure b-      NullLit a -> NullLit <$> f a-      ArrayLit a es -> ArrayLit <$> f a <*> ltraverse f es-      ObjectLit a ps -> ObjectLit <$> f a <*>  (zip <$> props' <*> es') where-        (props,es) = unzip ps-        props' = ltraverse f props-        es' = ltraverse f es-      ThisRef a -> ThisRef <$> f a-      VarRef a id -> VarRef <$> f a <*> traverse f id-      DotRef a e id -> DotRef <$> f a <*> traverse f e <*> traverse f id-      BracketRef a e es -> BracketRef <$> f a <*> traverse f e <*> traverse f es-      NewExpr a e es -> NewExpr <$> f a <*> traverse f e <*> ltraverse f es-      PostfixExpr a op e -> PostfixExpr <$> f a <*> pure op <*> traverse f e-      PrefixExpr a op e -> PrefixExpr <$> f a <*> pure op <*> traverse f e-      InfixExpr a op e1 e2 -> InfixExpr <$> f a <*> pure op <*> traverse f e1-                                <*> traverse f e2-      CondExpr a e1 e2 e3 ->-        CondExpr <$> f a <*> traverse f e1 <*> traverse f e2 <*> traverse f e3-      AssignExpr a op e1 e2 -> AssignExpr <$> f a <*> pure op <*> traverse f e1-        <*> traverse f e2-      ParenExpr a e -> ParenExpr <$> f a <*> traverse f e-      ListExpr a es -> ListExpr <$> f a <*> ltraverse f es-      CallExpr a e es -> CallExpr <$> f a <*> traverse f e <*> ltraverse f es-      FuncExpr a ids s -> FuncExpr <$> f a <*> ltraverse f ids <*> traverse f s--instance Traversable CaseClause where-  traverse f (CaseClause a e ss) =-    CaseClause <$> f a <*> traverse f e <*> ltraverse f ss-  traverse f (CaseDefault a ss) = -    CaseDefault <$> f a <*> ltraverse f ss--instance Traversable CatchClause where-  traverse f (CatchClause a id s) = -    CatchClause <$> f a <*> traverse f id <*> traverse f s-    -instance Traversable VarDecl where-  traverse f (VarDecl a id ye) =-    VarDecl <$> f a <*> traverse f id <*> ytraverse f ye--instance Traversable ForInit where-  traverse f NoInit = pure NoInit-  traverse f (VarInit ds) = VarInit <$> ltraverse f ds-  traverse f (ExprInit e) = ExprInit <$> traverse f e--instance Traversable ForInInit where- traverse f (ForInVar id) = ForInVar <$> traverse f id- traverse f (ForInNoVar id) = ForInNoVar <$> traverse f id--instance Traversable Statement where-  traverse f statement =-    case statement of-      BlockStmt a ss -> BlockStmt <$> f a <*> ltraverse f ss-      EmptyStmt a -> EmptyStmt <$> f a-      ExprStmt a e -> ExprStmt <$> f a <*> traverse f e-      IfStmt a e s1 s2 ->-        IfStmt <$> f a <*> traverse f e <*> traverse f s1 <*> traverse f s2-      IfSingleStmt a e s ->-        IfSingleStmt <$> f a <*> traverse f e <*> traverse f s-      SwitchStmt a e cs ->-        SwitchStmt <$> f a <*> traverse f e <*> ltraverse f cs-      WhileStmt a e s -> WhileStmt <$> f a <*> traverse f e <*> traverse f s-      DoWhileStmt a s e -> DoWhileStmt <$> f a <*> traverse f s <*> traverse f e-      BreakStmt a yid -> BreakStmt <$> f a <*> ytraverse f yid-      ContinueStmt a yid -> ContinueStmt <$> f a <*> ytraverse f yid-      LabelledStmt a id s -> -        LabelledStmt <$> f a <*> traverse f id <*> traverse f s-      ForInStmt a init e s ->-        ForInStmt <$> f a <*> traverse f init <*> traverse f e <*> traverse f s-      ForStmt a init yinc ytest s ->-        ForStmt <$> f a <*> traverse f init <*> ytraverse f yinc -          <*> ytraverse f ytest <*> traverse f s-      TryStmt a s cs ys ->-        TryStmt <$> f a <*> traverse f s <*> ltraverse f cs <*> ytraverse f ys-      ThrowStmt a e -> ThrowStmt <$> f a <*> traverse f e-      ReturnStmt a ys -> ReturnStmt <$> f a <*> ytraverse f ys-      WithStmt a e s -> WithStmt <$> f a <*> traverse f e <*> traverse f s-      VarDeclStmt a ds -> VarDeclStmt <$> f a <*> ltraverse f ds-      FunctionStmt a id args s ->-        FunctionStmt <$> f a <*> traverse f id <*> ltraverse f args -          <*> traverse f s 

@@ -1,19 +0,0 @@--- |Re-exports commonly used modules.-module WebBits.JavaScript.JavaScript-  ( module WebBits.JavaScript.Syntax-  , module WebBits.JavaScript.HtmlEmbedding-  , module WebBits.JavaScript.Parser-  , module WebBits.JavaScript.Combinators-  , module WebBits.Common-  -- JavaScript.Instances exports nothing-  ) where--import WebBits.Common--import WebBits.JavaScript.Syntax-import WebBits.JavaScript.Parser-import WebBits.JavaScript.PrettyPrint-import WebBits.JavaScript.HtmlEmbedding-import WebBits.JavaScript.Combinators--import WebBits.JavaScript.Instances

@@ -1,64 +0,0 @@-{- This isn't a lexer in the sense that it provides a JavaScript token-stream.
- - This module provides character-parsers for various JavaScript tokens.
- -}
-module WebBits.JavaScript.Lexer(lexeme,identifier,reserved,operator,reservedOp,charLiteral,
-                        stringLiteral,natural,integer,float,naturalOrFloat,
-                        decimal,hexadecimal,octal,symbol,whiteSpace,parens,
-                        braces,brackets,squares,semi,comma,colon,dot,
-                        identifierStart) where
-
-import Prelude hiding (lex)
-import Text.ParserCombinators.Parsec
-import qualified Text.ParserCombinators.Parsec.Token as T
-
-identifierStart = (letter <|> oneOf "$_")
-
-javascriptDef =
-  T.LanguageDef "/*"
-                "*/"
-                "//"
-                False -- no nested comments
-                {- Adapted from syntax/regexps.ss in Dave's code. -}
-                identifierStart
-                (alphaNum <|> oneOf "$_") -- identifier rest
-                (oneOf "{}<>()~.,?:|&^=!+-*/%!") -- operator start
-                (oneOf "=<>|&+") -- operator rest
-                ["break", "case", "catch", "const", "continue", "debugger", 
-                 "default", "delete", "do", "else", "enum", "false", "finally",
-                 "for", "function", "if", "instanceof", "in", "let", "new", 
-                 "null", "return", "switch", "this", "throw", "true", "try", 
-                 "typeof", "var", "void", "while", "with"]
-                ["|=", "^=", "&=", "<<=", ">>=", ">>>=", "+=", "-=", "*=", "/=", 
-                 "%=", "=", ";", ",", "?", ":", "||", "&&", "|", "^", "&", 
-                 "===", "==", "=", "!==", "!=", "<<", "<=", "<", ">>>", ">>", 
-                 ">=", ">", "++", "--", "+", "-", "*", "/", "%", "!", "~", ".", 
-                 "[", "]", "{", "}", "(", ")","</","instanceof"]
-                 True -- case-sensitive
-            
-lex = T.makeTokenParser javascriptDef
-
--- everything but commaSep and semiSep
-identifier = T.identifier	 lex
-reserved = T.reserved	 lex
-operator = T.operator	 lex
-reservedOp = T.reservedOp lex	
-charLiteral = T.charLiteral lex	
-stringLiteral = T.stringLiteral lex	
-natural = T.natural lex	
-integer = T.integer lex	
-float = T.float lex	
-naturalOrFloat = T.naturalOrFloat lex	
-decimal = T.decimal lex	
-hexadecimal = T.hexadecimal lex	
-octal = T.octal lex	
-symbol = T.symbol lex	
-whiteSpace = T.whiteSpace lex	
-parens = T.parens	 lex
-braces = T.braces	 lex
-squares = T.squares lex	
-semi = T.semi	 lex
-comma = T.comma	 lex
-colon = T.colon lex	
-dot = T.dot lex
-brackets = T.brackets lex
-lexeme = T.lexeme lex

@@ -1,657 +0,0 @@-module WebBits.JavaScript.Parser(parseScript,parseExpression
-   , parseString
-   , parseScriptFromString
-   , emptyParsedJavaScript
-   , ParsedStatement
-   , ParsedExpression
-   , parseJavaScriptFromFile
-   , parseSimpleExpr'
-   , parseBlockStmt
-   , parseStatement
-   , StatementParser
-   , ExpressionParser
-   , parseAssignExpr
-   ) where
-
-import WebBits.JavaScript.Lexer hiding (identifier)
-import qualified WebBits.JavaScript.Lexer as Lexer
-import WebBits.JavaScript.Syntax
-import Text.ParserCombinators.Parsec
-import Text.ParserCombinators.Parsec.Expr
-import Control.Monad(liftM,liftM2)
-import Control.Monad.Trans (MonadIO,liftIO)
-import Numeric(readDec,readOct,readHex)
-import Data.Char(chr)
-import Data.Char
-
--- We parameterize the parse tree over source-locations.
-type ParsedStatement = Statement SourcePos
-type ParsedExpression = Expression SourcePos
-
-
--- These parsers can store some arbitrary state
-type StatementParser state = CharParser state ParsedStatement
-type ExpressionParser state = CharParser state ParsedExpression
-
-identifier =
-  liftM2 Id getPosition Lexer.identifier
-
---{{{ Statements
-
--- Keep in mind that Token.reserved parsers (exported from the lexer) do not
--- consume any input on failure.  Note that all statements (expect for labelled
--- and expression statements) begin with a reserved-word.  If we fail to parse
--- this reserved-word, no input is consumed.  Hence, we can have the massive or
--- block that is parseExpression.  Note that if the reserved-word is parsed, it 
--- must be whatever statement the reserved-word indicates.  If we fail after the
--- reserved-word, we truly have a syntax error.  Since input has been consumed,
--- <|> will not try its alternate in parseExpression, and we will fail.
-
-parseIfStmt:: StatementParser st  
-parseIfStmt = do
-  pos <- getPosition
-  reserved "if"
-  test <- parseParenExpr <?> "parenthesized test-expression in if statement"
-  consequent <- parseStatement <?> "true-branch of if statement"
-  optional semi -- TODO: in spec?
-  ((do reserved "else"
-       alternate <- parseStatement
-       return (IfStmt pos test consequent alternate))
-    <|> return (IfSingleStmt pos test consequent))
-
-parseSwitchStmt:: StatementParser st
-parseSwitchStmt =
-  let parseDefault = do
-        pos <- getPosition
-        reserved "default"
-        colon
-        statements <- many parseStatement
-        return (CaseDefault pos statements)
-      parseCase = do
-         pos <- getPosition
-         reserved "case"
-         condition <- parseListExpr
-         colon
-         actions <- many parseStatement
-         return (CaseClause pos condition actions)
-    in do pos <- getPosition
-          reserved "switch"
-          test <- parseParenExpr
-          clauses <- braces $ many $ parseDefault <|> parseCase
-          return (SwitchStmt pos test clauses)
-
-parseWhileStmt:: StatementParser st
-parseWhileStmt = do
-  pos <- getPosition
-  reserved "while"
-  test <- parseParenExpr <?> "parenthesized test-expression in while loop"
-  body <- parseStatement
-  return (WhileStmt pos test body)
-
-parseDoWhileStmt:: StatementParser st
-parseDoWhileStmt = do
-  pos <- getPosition
-  reserved "do"
-  body <- parseBlockStmt
-  reserved "while" <?> "while at the end of a do block"
-  test <- parseParenExpr <?> "parenthesized test-expression in do loop"
-  optional semi
-  return (DoWhileStmt pos body test)
-
-parseContinueStmt:: StatementParser st
-parseContinueStmt = do
-  pos <- getPosition
-  reserved "continue"
-  pos' <- getPosition
-  -- Ensure that the identifier is on the same line as 'continue.'
-  id <- (if (sourceLine pos == sourceLine pos')
-           then (liftM Just identifier) <|> (return Nothing)
-           else return Nothing)
-  return (ContinueStmt pos id)
-
-parseBreakStmt:: StatementParser st
-parseBreakStmt = do
-  pos <- getPosition
-  reserved "break"
-  pos' <- getPosition
-  -- Ensure that the identifier is on the same line as 'break.'
-  id <- (if (sourceLine pos == sourceLine pos')
-           then (liftM Just identifier) <|> (return Nothing)
-           else return Nothing)
-  optional semi           
-  return (BreakStmt pos id)
-
-parseBlockStmt:: StatementParser st
-parseBlockStmt = do
-  pos <- getPosition
-  statements <- braces (many parseStatement)
-  return (BlockStmt pos statements)
-
-parseEmptyStmt:: StatementParser st 
-parseEmptyStmt = do
-  pos <- getPosition
-  semi
-  return (EmptyStmt pos)
-
-parseLabelledStmt:: StatementParser st
-parseLabelledStmt = do
-  pos <- getPosition
-  -- Lookahead for the colon.  If we don't see it, we are parsing an identifier
-  -- for an expression statement.
-  label <- try (do label <- identifier
-                   colon
-                   return label)
-  statement <- parseStatement
-  return (LabelledStmt pos label statement)
-
-parseExpressionStmt:: StatementParser st
-parseExpressionStmt = do
-  pos <- getPosition
-  expr <- parseListExpr -- TODO: spec 12.4?
-  optional semi
-  return (ExprStmt pos expr)
-
-
-parseForInStmt:: StatementParser st
-parseForInStmt =
-  let parseInit = (reserved "var" >> liftM ForInVar identifier)
-                  <|> (liftM ForInNoVar identifier)
-    in do pos <- getPosition
-          -- Lookahead, so that we don't clash with parseForStmt
-          (init,expr) <- try (do reserved "for"
-                                 parens (do init <- parseInit
-                                            reserved "in"
-                                            expr <- parseExpression
-                                            return (init,expr)))
-          body <- parseStatement
-          return (ForInStmt pos init expr body) 
-
-parseForStmt:: StatementParser st
-parseForStmt =
-  let parseInit =
-        (reserved "var" >> liftM VarInit (parseVarDecl `sepBy` comma)) <|>
-        (liftM ExprInit parseListExpr) <|>
-        (return NoInit)
-    in do pos <- getPosition
-          reserved "for"
-          reservedOp "("
-          init <- parseInit
-          semi
-          test <- (liftM Just parseExpression) <|> (return Nothing)
-          semi
-          iter <- (liftM Just parseExpression) <|> (return Nothing)
-          reservedOp ")" <?> "closing paren"
-          stmt <- parseStatement
-          return (ForStmt pos init test iter stmt)
-
-parseTryStmt:: StatementParser st
-parseTryStmt =
-  let parseCatchClause = do
-        pos <- getPosition
-        reserved "catch"
-        id <- parens identifier
-        stmt <- parseStatement
-        return (CatchClause pos id stmt)
-    in do reserved "try"
-          pos <- getPosition
-          guarded <- parseStatement
-          catches <- many parseCatchClause
-          finally <- (reserved "finally" >> liftM Just parseStatement) 
-                      <|> (return Nothing)
-          return (TryStmt pos guarded catches finally)
-
-parseThrowStmt:: StatementParser st
-parseThrowStmt = do
-  pos <- getPosition
-  reserved "throw"
-  expr <- parseExpression
-  optional semi
-  return (ThrowStmt pos expr)
-
-parseReturnStmt:: StatementParser st
-parseReturnStmt = do
-  pos <- getPosition
-  reserved "return"
-  expr <- (liftM Just parseListExpr) <|> (return Nothing)
-  optional semi
-  return (ReturnStmt pos expr)
-
-parseWithStmt:: StatementParser st
-parseWithStmt = do
-  pos <- getPosition
-  reserved "with"
-  context <- parseParenExpr
-  stmt <- parseStatement
-  return (WithStmt pos context stmt)
-
-parseVarDecl = do
-  pos <- getPosition
-  id <- identifier
-  init <- (reservedOp "=" >> liftM Just parseExpression) <|> (return Nothing)
-  return (VarDecl pos id init)
-
-parseVarDeclStmt:: StatementParser st
-parseVarDeclStmt = do 
-  pos <- getPosition
-  reserved "var"
-  decls <- parseVarDecl `sepBy` comma
-  optional semi
-  return (VarDeclStmt pos decls)
-
-parseFunctionStmt:: StatementParser st
-parseFunctionStmt = do
-  pos <- getPosition
-  name <- try (reserved "function" >> identifier) -- ambiguity with FuncExpr
-  args <- parens (identifier `sepBy` comma)
-  body <- parseBlockStmt <?> "function body in { ... }"
-  return (FunctionStmt pos name args body)
-
-parseStatement:: StatementParser st
-parseStatement = parseIfStmt <|> parseSwitchStmt <|> parseWhileStmt 
-  <|> parseDoWhileStmt <|> parseContinueStmt <|> parseBreakStmt 
-  <|> parseBlockStmt <|> parseEmptyStmt <|> parseForInStmt <|> parseForStmt
-  <|> parseTryStmt <|> parseThrowStmt <|> parseReturnStmt <|> parseWithStmt 
-  <|> parseVarDeclStmt  <|> parseFunctionStmt
-  -- labelled, expression and the error message always go last, in this order
-  <|> parseLabelledStmt <|> parseExpressionStmt <?> "statement"
-
---}}}
-
---{{{ Expressions
-
--- References used to construct this stuff:
--- + http://developer.mozilla.org/en/docs/
---     Core_JavaScript_1.5_Reference:Operators:Operator_Precedence
--- + http://www.mozilla.org/js/language/grammar14.html
---
--- Aren't expression tables nice?  Well, we can't quite use them, because of 
--- JavaScript's ternary (?:) operator.  We have to use two expression tables.
--- We use one expression table for the assignment operators that bind looser 
--- than ?: (assignTable).  The terms of assignTable are ternary expressions 
--- (parseTernaryExpr).  parseTernaryExpr left-factors the left-recursive
--- production for ?:, and is defined over the second expression table, 
--- exprTable, which consists of operators that bind tighter than ?:.  The terms
--- of exprTable are atomic expressions, parenthesized expressions, functions and
--- array references.
-
---{{{ Primary expressions
-
-parseThisRef:: ExpressionParser st
-parseThisRef = do
-  pos <- getPosition
-  reserved "this"
-  return (ThisRef pos)
-
-parseNullLit:: ExpressionParser st
-parseNullLit = do
-  pos <- getPosition
-  reserved "null"
-  return (NullLit pos)
-
-
-parseBoolLit:: ExpressionParser st
-parseBoolLit = do
-    pos <- getPosition
-    let parseTrueLit  = reserved "true"  >> return (BoolLit pos True)
-        parseFalseLit = reserved "false" >> return (BoolLit pos False)
-    parseTrueLit <|> parseFalseLit
-
-parseVarRef:: ExpressionParser st
-parseVarRef = liftM2 VarRef getPosition identifier
-
-parseArrayLit:: ExpressionParser st
-parseArrayLit = liftM2 ArrayLit getPosition (squares (parseExpression `sepBy` comma))
-  
-parseFuncExpr = do
-  pos <- getPosition
-  reserved "function"
-  args <- parens (identifier `sepBy` comma)
-  body <- parseBlockStmt
-  return $ FuncExpr pos args body
-
---{{{ parsing strings
-
-escapeChars =
- [('\'','\''),('\"','\"'),('\\','\\'),('b','\b'),('f','\f'),('n','\n'),
-  ('r','\r'),('t','\t'),('v','\v'),('/','/')]
-
-allEscapes:: String
-allEscapes = map fst escapeChars
-
-parseEscapeChar = do
-  c <- oneOf allEscapes
-  let (Just c') = lookup c escapeChars -- will succeed due to line above
-  return c' 
-
-parseAsciiHexChar = do
-  char 'x'
-  d1 <- hexDigit
-  d2 <- hexDigit
-  return ((chr.fst.head.readHex) (d1:d2:""))
-
-parseUnicodeHexChar = do
-  char 'u'
-  liftM (chr.fst.head.readHex) 
-        (sequence [hexDigit,hexDigit,hexDigit,hexDigit])
-        
-isWhitespace ch = ch `elem` " \t"
-
-
--- The endWith argument is either single-quote or double-quote, depending on how
--- we opened the string.
-parseStringLit' endWith =
-  (char endWith >> return "") <|>
-  (do try (string "\\'")
-      cs <- parseStringLit' endWith
-      return $ "'" ++ cs) <|>
-  (do char '\\'
-      c <- parseEscapeChar <|> parseAsciiHexChar <|> parseUnicodeHexChar <|> 
-           char '\r' <|> char '\n'
-      cs <- parseStringLit' endWith
-      if c == '\r' || c == '\n' 
-        then return (c:(dropWhile isWhitespace cs)) 
-        else return (c:cs)) <|>
-   (liftM2 (:) anyChar (parseStringLit' endWith))
-
-parseStringLit:: ExpressionParser st
-parseStringLit = do
-  pos <- getPosition
-  -- parseStringLit' takes as an argument the quote-character that opened the
-  -- string.
-  str <- lexeme $ (char '\'' >>= parseStringLit') <|> (char '\"' >>= parseStringLit')
-  -- CRUCIAL: Parsec.Token parsers expect to find their token on the first
-  -- character, and read whitespaces beyond their tokens.  Without 'lexeme'
-  -- above, expressions like:
-  --   var s = "string"   ;
-  -- do not parse.
-  return $ StringLit pos str
-
---}}}
-
-parseRegexpLit:: ExpressionParser st
-parseRegexpLit = do
-  let parseFlags = do
-        flags <- many (oneOf "mgi")
-        return $ \f -> f ('g' `elem` flags) ('i' `elem` flags) 
-  let parseEscape = char '\\' >> anyChar
-  let parseChar = noneOf "/"
-  let parseRe = (char '/' >> return "") <|> 
-                (do char '\\'
-                    ch <- anyChar -- TOOD: too lenient
-                    rest <- parseRe
-                    return ('\\':ch:rest)) <|> 
-                (liftM2 (:) anyChar parseRe)
-  pos <- getPosition
-  char '/'
-  pat <- parseRe --many1 parseChar
-  flags <- parseFlags
-  spaces -- crucial for Parsec.Token parsers
-  return $ flags (RegexpLit pos pat)
-          
-parseObjectLit:: ExpressionParser st
-parseObjectLit =
-  let parseProp = do
-        -- Parses a string, identifier or integer as the property name.  I
-        -- apologize for the abstruse style, but it really does make the code
-        -- much shorter.
-        name <- (liftM (uncurry PropString) 
-                       (liftM (\(StringLit p s) -> (p,s)) parseStringLit))
-                <|> (liftM2 PropId getPosition identifier)
-                <|> (liftM2 PropNum getPosition decimal)
-        colon
-        val <- parseAssignExpr
-        return (name,val)
-    in do pos <- getPosition
-          props <- braces (parseProp `sepEndBy` comma) <?> "object literal"
-          return $ ObjectLit pos props
-
---{{{ Parsing numbers.  From pg. 17-18 of ECMA-262.
-
-hexLit = do
-  try (string "0x")
-  digits <- many1 (oneOf "0123456789abcdefABCDEF")
-  [(hex,"")] <- return $ Numeric.readHex digits
-  return hex
-
--- Creates a decimal value from a whole, fractional and exponent part.
-mkDecimal:: Double -> Double -> Int -> Double
-mkDecimal w f e =
-  if (f >= 1.0)
-    then mkDecimal w (f / 10.0) e
-    else (w + f) * (10.0 ^^ e)
-
-exponentPart = do
-  oneOf "eE"
-  (char '+' >> decimal) <|> (char '-' >> negate `fmap` decimal) <|> decimal
-  
-decLit =
-  (do whole <- decimal
-      frac <- option 0 (char '.' >> decimal)
-      exp <- option 0  exponentPart
-      return $ mkDecimal (fromIntegral whole) (fromIntegral frac) (fromIntegral exp)) <|>
-  (do frac <- char '.' >> decimal
-      exp <- option 0  exponentPart
-      return $ mkDecimal 0.0 (fromIntegral frac) (fromIntegral exp))
-
-parseNumLit:: ExpressionParser st
-parseNumLit = do
-    pos <- getPosition
-    num <- lexeme $ hexLit <|> decLit
-    notFollowedBy identifierStart <?> "whitespace"
-    return $ NumLit pos num
-
---}}}
-
-------------------------------------------------------------------------------
--- Position Helper
-------------------------------------------------------------------------------
-
-withPos cstr p = do { pos <- getPosition; e <- p; return $ cstr pos e }
-
--------------------------------------------------------------------------------
--- Compound Expression Parsers
--------------------------------------------------------------------------------
-
-dotRef e = (reservedOp "." >> withPos cstr identifier) <?> "property.ref"
-    where cstr pos key = DotRef pos e key
-
-funcApp e = (parens $ withPos cstr (parseExpression `sepBy` comma)) <?> "(function application)"
-    where cstr pos args = CallExpr pos e args
-
-bracketRef e = (brackets $ withPos cstr parseExpression) <?> "[property-ref]"
-    where cstr pos key = BracketRef pos e key
-
--------------------------------------------------------------------------------
--- Expression Parsers
--------------------------------------------------------------------------------
-
-parseParenExpr:: ExpressionParser st
-parseParenExpr = withPos ParenExpr (parens parseListExpr)
-
--- everything above expect functions
-parseExprForNew = parseThisRef <|> parseNullLit <|> parseBoolLit <|> parseStringLit 
-  <|> parseArrayLit <|> parseParenExpr <|> parseNewExpr <|> parseNumLit 
-  <|> parseRegexpLit <|> parseObjectLit <|> parseVarRef
-
--- all the expression parsers defined above
-parseSimpleExpr' = parseThisRef <|> parseNullLit <|> parseBoolLit 
-  <|> parseStringLit <|> parseArrayLit <|> parseParenExpr
-  <|> parseFuncExpr <|> parseNumLit <|> parseRegexpLit <|> parseObjectLit
-  <|> parseVarRef
-
-parseNewExpr =
-  (do pos <- getPosition
-      reserved "new"
-      constructor <- parseSimpleExprForNew Nothing -- right-associativity
-      arguments <- (try (parens (parseExpression `sepBy` comma))) <|> (return [])
-      return (NewExpr pos constructor arguments)) <|>
-  parseSimpleExpr'
-
-parseSimpleExpr (Just e) = (do
-    e' <- dotRef e <|> funcApp e <|> bracketRef e
-    parseSimpleExpr $ Just e') <|> (return e)
-parseSimpleExpr Nothing = do
-  e <- parseNewExpr <?> "expression (3)"
-  parseSimpleExpr (Just e)
-
-parseSimpleExprForNew (Just e) = (do
-    e' <- dotRef e <|> bracketRef e
-    parseSimpleExprForNew $ Just e') <|> (return e)
-parseSimpleExprForNew Nothing = do
-  e <- parseNewExpr <?> "expression (3)"
-  parseSimpleExprForNew (Just e)
-    
---}}}
-
-makeInfixExpr str constr = Infix parser AssocLeft where
-  parser:: CharParser st (Expression SourcePos -> Expression SourcePos -> Expression SourcePos)
-  parser = do
-    pos <- getPosition
-    reservedOp str
-    return (InfixExpr pos constr)  -- points-free, returns a function
-
-makePrefixExpr str constr = Prefix parser where
-  parser = do
-    pos <- getPosition
-    (reservedOp str <|> reserved str)
-    return (PrefixExpr pos constr) -- points-free, returns a function
-    
-mkPrefix operator constr = Prefix $ do
-  pos <- getPosition
-  operator
-  return (\operand -> PrefixExpr pos constr operand)
-
-makePostfixExpr str constr = Postfix parser where
-  parser = do
-    pos <- getPosition
-    (reservedOp str <|> reserved str)
-    return (PostfixExpr pos constr) -- points-free, returns a function
-
-prefixIncDecExpr = do
-  pos <- getPosition
-  op <- optionMaybe $ (reservedOp "++" >> return PrefixInc) <|>
-                      (reservedOp "--" >> return PrefixDec)
-  case op of
-    Nothing -> parseSimpleExpr Nothing
-    Just op -> do
-      innerExpr <- parseSimpleExpr Nothing -- TODO: must be an l-val, I think
-      return (PrefixExpr pos op innerExpr)
-
--- apparently, expression tables can't handle immediately-nested prefixes
-
-parsePrefixedExpr = do
-  pos <- getPosition
-  op <- optionMaybe $ (reservedOp "!" >> return PrefixLNot) <|> 
-                      (reservedOp "~" >> return PrefixBNot) <|>
-                      (try (lexeme $ char '-' >> notFollowedBy (char '-')) >>
-                       return PrefixMinus) <|>
-                      (try (lexeme $ char '+' >> notFollowedBy (char '+')) >>
-                       return PrefixPlus) <|>
-                      (reserved "typeof" >> return PrefixTypeof) <|>
-                      (reserved "void" >> return PrefixVoid) <|>
-                      (reserved "delete" >> return PrefixDelete)
-  case op of
-    Nothing -> prefixIncDecExpr  -- new is treated as a simple expr
-    Just op -> do
-      innerExpr <- parsePrefixedExpr
-      return (PrefixExpr pos op innerExpr)
-
-exprTable:: [[Operator Char st ParsedExpression]]
-exprTable = 
-  [
-   [makePrefixExpr "++" PrefixInc,
-    makePostfixExpr "++" PostfixInc],
-   [makePrefixExpr "--" PrefixDec,
-    makePostfixExpr "--" PostfixDec],
-   [makeInfixExpr "*" OpMul, makeInfixExpr "/" OpDiv, makeInfixExpr "%" OpMod],
-   [makeInfixExpr "+" OpAdd, makeInfixExpr "-" OpSub],
-   [makeInfixExpr "<<" OpLShift, makeInfixExpr ">>" OpSpRShift,
-    makeInfixExpr ">>>" OpZfRShift],
-   [makeInfixExpr "<" OpLT, makeInfixExpr "<=" OpLEq, makeInfixExpr ">" OpGT,
-    makeInfixExpr ">=" OpGEq, 
-    makeInfixExpr "instanceof" OpInstanceof, makeInfixExpr "in" OpIn],
-   [makeInfixExpr "&" OpBAnd], 
-   [makeInfixExpr "^" OpBXor], 
-   [makeInfixExpr "|" OpBOr],
-   [makeInfixExpr "&&" OpLAnd],
-   [makeInfixExpr "||" OpLOr],  
-   [makeInfixExpr "==" OpEq, makeInfixExpr "!=" OpNEq,
-    makeInfixExpr "===" OpStrictEq, makeInfixExpr "!==" OpStrictNEq]
-    ]
-  
-parseExpression' = 
-  buildExpressionParser exprTable parsePrefixedExpr <?> "simple expression"
-
---{{{ Parsing ternary operators: left factored
-
-parseTernaryExpr':: CharParser st (ParsedExpression,ParsedExpression)
-parseTernaryExpr' = do
-    reservedOp "?"
-    l <- parseAssignExpr
-    colon
-    r <- parseAssignExpr
-    return $(l,r)
-
-parseTernaryExpr:: ExpressionParser st
-parseTernaryExpr = do
-  e <- parseExpression'
-  e' <- optionMaybe parseTernaryExpr'
-  case e' of
-    Nothing -> return e
-    Just (l,r) -> do p <- getPosition
-                     return $ CondExpr p e l r
---}}}
-
--- Parsing assignment operations.
-makeAssignExpr str constr = Infix parser AssocRight where
-  parser:: CharParser st (ParsedExpression -> ParsedExpression -> ParsedExpression)
-  parser = do
-    pos <- getPosition
-    reservedOp str
-    return (AssignExpr pos constr)
-
-assignTable:: [[Operator Char st ParsedExpression]]
-assignTable = [
-  [makeAssignExpr "=" OpAssign, makeAssignExpr "+=" OpAssignAdd, 
-    makeAssignExpr "-=" OpAssignSub, makeAssignExpr "*=" OpAssignMul,
-    makeAssignExpr "/=" OpAssignDiv, makeAssignExpr "%=" OpAssignMod,
-    makeAssignExpr "<<=" OpAssignLShift, makeAssignExpr ">>=" OpAssignSpRShift,
-    makeAssignExpr ">>>=" OpAssignZfRShift, makeAssignExpr "&=" OpAssignBAnd,
-    makeAssignExpr "^=" OpAssignBXor, makeAssignExpr "|=" OpAssignBOr
-  ]]
-
-
-parseAssignExpr:: ExpressionParser st
-parseAssignExpr = buildExpressionParser assignTable parseTernaryExpr  
-
-parseExpression:: ExpressionParser st
-parseExpression = parseAssignExpr
-
-parseListExpr =
-  liftM2 ListExpr getPosition (parseAssignExpr `sepBy1` comma)
-
---}}}
-
-parseScript:: CharParser state (JavaScript SourcePos)
-parseScript = do
-  whiteSpace
-  liftM2 Script getPosition (parseStatement `sepBy` whiteSpace)
-  
-parseJavaScriptFromFile :: MonadIO m => String -> m [Statement SourcePos]
-parseJavaScriptFromFile filename = do
-  chars <- liftIO $ readFile filename
-  case parse parseScript filename chars of
-    Left err               -> fail (show err)
-    Right (Script _ stmts) -> return stmts
-
-
-parseScriptFromString:: String -> String -> Either ParseError (JavaScript SourcePos)
-parseScriptFromString src script = parse parseScript src script
-
-emptyParsedJavaScript = 
-  Script (error "Parser.emptyParsedJavaScript--no annotation") []
-
-parseString :: String -> [Statement SourcePos]
-parseString str = case parse parseScript "" str of
-  Left err -> error (show err)
-  Right (Script _ stmts) -> stmts

@@ -1,261 +0,0 @@--- |Pretty-printing JavaScript.  This module doesn't export any names, but--- importing it declares PrettyPrintable instances for JavaScript.Syntax.-module WebBits.JavaScript.PrettyPrint() where--import Text.PrettyPrint.HughesPJ-import WebBits.JavaScript.Syntax-import WebBits.JavaScript.Combinators-import WebBits.Common----{{{ Helper functions for common printing patterns---- Displays the statement in { ... }, unless it already is in a block.-inBlock:: (Statement a) -> Doc-inBlock stmt@(BlockStmt _ _) = pp stmt-inBlock stmt                 = text "{" $+$ pp stmt $+$ text "}"---- Displays the expression in ( ... ), unless it already is in parens.-inParens:: (Expression a) -> Doc-inParens expr@(ParenExpr _ _) = pp expr-inParens expr                 = parens (pp expr)--commaSep:: (PrettyPrintable a) => [a] -> Doc-commaSep = hsep.(punctuate comma).(map pp)----}}}--instance PrettyPrintable (Id a) where-  pp (Id _ str) = text str--instance PrettyPrintable (ForInit a) where-  pp NoInit         = empty-  pp (VarInit vs) = text "var" <+> commaSep vs -  pp (ExprInit e) = pp e-  -instance PrettyPrintable (ForInInit a) where-  pp (ForInVar id)   = text "var" <+> pp id-  pp (ForInNoVar id) = pp id----{{{ Pretty-printing statements--instance PrettyPrintable (CaseClause a) where-  pp (CaseClause _ expr stmts) =-    text "case" $+$ pp expr <+> colon $$ (nest 2 (vcat (map pp stmts)))-  pp (CaseDefault _ stmts) =-    text "default:" $$ (nest 2 (vcat (map pp stmts)))--instance PrettyPrintable (CatchClause a) where-  pp (CatchClause _ id stmt) =-    text "catch" <+> (parens.pp) id <+> inBlock stmt---instance PrettyPrintable (VarDecl a) where-  pp (VarDecl _ id Nothing) =-    pp id-  pp (VarDecl _ id (Just expr)) =-    pp id <+> equals <+> pp expr--instance PrettyPrintable (Statement a) where-  pp (BlockStmt _ stmts) =-    text "{" $+$ nest 2 (vcat (map pp stmts)) $+$ text "}"-  pp (EmptyStmt _) =-    semi-  pp (ExprStmt _ expr) =-    pp expr <> semi-  pp (IfSingleStmt _ test cons) =-    text "if" <+> inParens test $$ (nest 2 (pp cons))-  pp (IfStmt _ test cons alt) =-    text "if" <+> inParens test $$ (nest 2 $ pp cons) $$ text "else"-      $$ (nest 2 $ pp alt)-  pp (SwitchStmt _ expr cases) =-    text "switch" <+> inParens expr $$ braces (nest 2 (vcat (map pp cases)))-  pp (WhileStmt _ test body) =-    text "while" <+> inParens test $$ (nest 2 (pp body))-  pp (ReturnStmt _ expr) =-    text "return" <+> pp expr <> semi-  pp (DoWhileStmt _ stmt expr) =-    text "do" $$ (nest 2 (pp stmt <+> text "while" <+> inParens expr))-  pp (BreakStmt _ Nothing) =-    text "break;"-  pp (BreakStmt _ (Just label)) =-    text "break" <+> pp label <> semi-  pp (ContinueStmt _ Nothing) =-    text "continue;"-  pp (ContinueStmt _ (Just label)) =-    text"continue" <+> pp label <> semi-  pp (LabelledStmt _ label stmt) =-    pp label <> colon $$ pp stmt-  pp (ForInStmt p init expr body) =-    text "for" <+> parens (pp init <+> text "in" <+> pp expr)-      $$ (nest 2 (pp body))-  pp (ForStmt _ init incr test body) =-    text "for" <+> parens (pp init <> semi <+> pp incr <> semi <+> pp test)-      $$ (nest 2 (pp body))-  pp (TryStmt _ stmt catches finally) =-    text "try" $$ inBlock stmt $$ (vcat (map pp catches)) $$ ppFinally where -      ppFinally = case finally of-        Nothing -> empty-        Just stmt -> text "finally" <> inBlock stmt-  pp (ThrowStmt _ expr) =-    text "throw" <+> pp expr <> semi-  pp (WithStmt _ expr stmt) | isParenExpr expr =-    (text "with" <+> inParens expr $$ pp stmt)-  pp (WithStmt _ expr stmt) | otherwise =-      (text "with" <+> inParens expr $$ pp stmt)-  pp (VarDeclStmt _ decls) =-    text "var" <+> commaSep decls <> semi-  pp (FunctionStmt _ name args stmt) =-    text "function" <+> pp name <> (parens.commaSep) args $$ inBlock stmt----}}}--instance PrettyPrintable (Prop a) where-  pp (PropId _ id) = pp id-  pp (PropString _ str) = doubleQuotes (text (jsEscape str))-  pp (PropNum _ n) = text (show n)-----{{{ infix-operators--showInfix op =-  case op of-    OpMul -> "*"-    OpDiv -> "/"-    OpMod -> "%" -    OpAdd -> "+" -    OpSub -> "-"-    OpLShift -> "<<"-    OpSpRShift -> ">>"-    OpZfRShift -> ">>>"-    OpLT -> "<"-    OpLEq -> "<="-    OpGT -> ">"-    OpGEq -> ">="-    OpIn -> "in"-    OpInstanceof -> "instanceof"-    OpEq -> "=="-    OpNEq -> "!="-    OpStrictEq -> "==="-    OpStrictNEq -> "!=="-    OpBAnd -> "&"-    OpBXor -> "^"-    OpBOr -> "|"-    OpLAnd -> "&&"-    OpLOr -> "||"--instance PrettyPrintable InfixOp where-  pp op = text (showInfix op)---}}}----{{{ prefix operators--showPrefix PrefixInc = "++"-showPrefix PrefixDec = "--"-showPrefix PrefixLNot = "!"-showPrefix PrefixBNot = "~"-showPrefix PrefixPlus = "+"-showPrefix PrefixMinus = "-"-showPrefix PrefixTypeof = "typeof"-showPrefix PrefixVoid = "void"-showPrefix PrefixDelete = "delete"--instance PrettyPrintable PrefixOp where-  pp op = text (showPrefix op)----}}}----{{{ postfix operators--instance PrettyPrintable PostfixOp where-  pp PostfixInc = text "++"-  pp PostfixDec = text "--"----}}}----{{{ assignment operators--showAssignOp OpAssign = "="-showAssignOp OpAssignAdd = "+="-showAssignOp OpAssignSub = "-="-showAssignOp OpAssignMul = "*="-showAssignOp OpAssignDiv = "/="-showAssignOp OpAssignMod = "%="-showAssignOp OpAssignLShift = "<<="-showAssignOp OpAssignSpRShift = ">>="-showAssignOp OpAssignZfRShift = ">>>="-showAssignOp OpAssignBAnd = "&="-showAssignOp OpAssignBXor = "^="-showAssignOp OpAssignBOr = "|="--instance PrettyPrintable AssignOp where-  pp = text.showAssignOp----}}}----{{{ expressions---- Based on:---   http://developer.mozilla.org/en/docs/Core_JavaScript_1.5_Guide:Literals-jsEscape:: String -> String-jsEscape "" = ""-jsEscape (ch:chs) = (sel ch) ++ jsEscape chs where-    sel '\b' = "\\b"-    sel '\f' = "\\f"-    sel '\n' = "\\n"-    sel '\r' = "\\r"-    sel '\t' = "\\t"-    sel '\v' = "\\v"-    sel '\'' = "\\'"-    sel '\"' = "\\\""-    sel '\\' = "\\\\"-    sel x    = [x]-    -- We don't have to do anything about \X, \x and \u escape sequences.--  -instance PrettyPrintable (Expression a) where-  pp (StringLit _ str) = doubleQuotes (text (jsEscape str))-  pp (RegexpLit _ re global ci) =-    text "/" <> text re <> text "/" <> g <> i where-      g = if global then text "g" else empty-      i = if ci then text "i" else empty-  pp (NumLit _ n) =  text (show n)-  pp (BoolLit _ True) = text "true"-  pp (BoolLit _ False) = text "false"-  pp (NullLit _) = text "null"-  pp (ArrayLit _ xs) = -    (brackets.commaSep) xs-  pp (ObjectLit _ xs) = -    braces (hsep (punctuate comma (map pp' xs))) where-      pp' (n,v) = pp n <> colon <+> pp v-  pp (ThisRef _) = text "this"-  pp (VarRef _ id) = pp id-  pp (DotRef _ expr id) =-    pp expr <> text "." <> pp id-  pp (BracketRef _ container key) =-    pp container <> brackets (pp key)-  pp (NewExpr _ constr args) =-    text "new" <+> pp constr <> (parens.commaSep) args-  pp (PrefixExpr _ op expr) =-    pp op <+> pp expr-  pp (PostfixExpr _ op expr) =-    pp expr <+> pp op-  pp (InfixExpr _ op left right) = -    pp left <+> pp op <+> pp right-  pp (CondExpr _ test cons alt) =-    pp test <+> text "?" <+> pp cons <+> colon <+> pp alt-  pp (AssignExpr _ op l r) =-    pp l <+> pp op <+> pp r-  pp (ParenExpr _ expr) =-    parens (pp expr)-  pp (ListExpr _ exprs) = commaSep exprs-  pp (CallExpr _ f args) =-    pp f <> (parens.commaSep) args-  pp (FuncExpr _ args body) =-    text "function" <+> (parens.commaSep) args $$ inBlock body--instance PrettyPrintable (JavaScript a) where-  pp (Script _ stmts) =-    vcat (map pp stmts)----}}}-

@@ -1,117 +0,0 @@--- |JavaScript's syntax.
-module WebBits.JavaScript.Syntax(Expression(..),CaseClause(..),Statement(..),
-         InfixOp(..),CatchClause(..),VarDecl(..),JavaScript(..),
-         AssignOp(..),Id(..),PrefixOp(..),PostfixOp(..),Prop(..),
-         ForInit(..),ForInInit(..)) where
-
-import Text.ParserCombinators.Parsec(SourcePos) -- used by data JavaScript
-import Data.Generics(Data,Typeable)
-
-data JavaScript a
-  -- |A script in <script> ... </script> tags.  This may seem a little silly,
-  -- but the Flapjax analogue has an inline variant and attribute-inline 
-  -- variant.
-  = Script a [Statement a] 
-  deriving (Show,Data,Typeable,Eq,Ord)
-
-data Id a = Id a String deriving (Show,Eq,Ord,Data,Typeable)
-
--- http://developer.mozilla.org/en/docs/
---   Core_JavaScript_1.5_Reference:Operators:Operator_Precedence
-data InfixOp = OpLT | OpLEq | OpGT | OpGEq  | OpIn  | OpInstanceof | OpEq | OpNEq
-             | OpStrictEq | OpStrictNEq | OpLAnd | OpLOr 
-             | OpMul | OpDiv | OpMod  | OpSub | OpLShift | OpSpRShift
-             | OpZfRShift | OpBAnd | OpBXor | OpBOr | OpAdd
-    deriving (Show,Data,Typeable,Eq,Ord,Enum)
-
-data AssignOp = OpAssign | OpAssignAdd | OpAssignSub | OpAssignMul | OpAssignDiv
-  | OpAssignMod | OpAssignLShift | OpAssignSpRShift | OpAssignZfRShift
-  | OpAssignBAnd | OpAssignBXor | OpAssignBOr
-  deriving (Show,Data,Typeable,Eq,Ord)
-
-data PrefixOp = PrefixInc | PrefixDec | PrefixLNot | PrefixBNot | PrefixPlus
-  | PrefixMinus | PrefixTypeof | PrefixVoid | PrefixDelete
-  deriving (Show,Data,Typeable,Eq,Ord)
-  
-data PostfixOp 
-  = PostfixInc | PostfixDec
-  deriving (Show,Data,Typeable,Eq,Ord)
-  
-data Prop a 
-  = PropId a (Id a) | PropString a String | PropNum a Integer
-  deriving (Show,Data,Typeable,Eq,Ord)
-
-data Expression a
-  = StringLit a String
-  | RegexpLit a String Bool {- global? -} Bool {- case-insensitive? -}
-  | NumLit a Double -- pg. 5 of ECMA-262
-  | BoolLit a Bool
-  | NullLit a
-  | ArrayLit a [Expression a]
-  | ObjectLit a [(Prop a, Expression a)]
-  | ThisRef a
-  | VarRef a (Id a)
-  | DotRef a (Expression a) (Id a)
-  | BracketRef a (Expression a) {- container -} (Expression a) {- key -}
-  | NewExpr a (Expression a) {- constructor -} [Expression a]
-  | PostfixExpr a PostfixOp (Expression a)
-  | PrefixExpr a PrefixOp (Expression a)
-  | InfixExpr a InfixOp (Expression a) (Expression a)
-  | CondExpr a (Expression a) (Expression a) (Expression a)
-  | AssignExpr a AssignOp (Expression a) (Expression a)
-  | ParenExpr a (Expression a)
-  | ListExpr a [Expression a]
-  | CallExpr a (Expression a) [Expression a]
-  | FuncExpr a [(Id a)] (Statement a)
-  deriving (Show,Data,Typeable,Eq,Ord)
-
-data CaseClause a 
-  = CaseClause a (Expression a) [Statement a]
-  | CaseDefault a [Statement a]
-  deriving (Show,Data,Typeable,Eq,Ord)
-  
-data CatchClause a 
-  = CatchClause a (Id a) (Statement a) 
-  deriving (Show,Data,Typeable,Eq,Ord)
-
-data VarDecl a 
-  = VarDecl a (Id a) (Maybe (Expression a)) 
-  deriving (Show,Data,Typeable,Eq,Ord)
-  
-data ForInit a
-  = NoInit
-  | VarInit [VarDecl a]
-  | ExprInit (Expression a)
-  deriving (Show,Data,Typeable,Eq,Ord)
-
-data ForInInit a
- = ForInVar (Id a)
- | ForInNoVar (Id a)
- deriving (Show,Data,Typeable,Eq,Ord)
-  
-  
-data Statement a
-  = BlockStmt a [Statement a]
-  | EmptyStmt a
-  | ExprStmt a (Expression a)
-  | IfStmt a (Expression a) (Statement a) (Statement a)
-  | IfSingleStmt a (Expression a) (Statement a)
-  | SwitchStmt a (Expression a) [CaseClause a]
-  | WhileStmt a (Expression a) (Statement a)
-  | DoWhileStmt a (Statement a) (Expression a)
-  | BreakStmt a (Maybe (Id a))
-  | ContinueStmt a (Maybe (Id a))
-  | LabelledStmt a (Id a) (Statement a)
-  | ForInStmt a (ForInInit a) (Expression a) (Statement a)
-  | ForStmt a (ForInit a)        
-              (Maybe (Expression a)) -- increment
-              (Maybe (Expression a)) -- test
-              (Statement a)          -- body
-  | TryStmt a (Statement a) {-body-} [CatchClause a] {-catches-}
-      (Maybe (Statement a)) {-finally-}
-  | ThrowStmt a (Expression a)
-  | ReturnStmt a (Maybe (Expression a))
-  | WithStmt a (Expression a) (Statement a)
-  | VarDeclStmt a [VarDecl a]
-  | FunctionStmt a (Id a) {-name-} [(Id a)] {-args-} (Statement a) {-body-}
-  deriving (Show,Data,Typeable,Eq,Ord)