WebBits 0.15 → 1.0

raw patch · 17 files changed

+164/−997 lines, 17 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• LICENSE +23/−11
• WebBits.cabal +10/−25
• src/BrownPLT/Html.hs +0/−14
• src/BrownPLT/Html/Instances.hs +0/−66
• src/BrownPLT/Html/PermissiveParser.hs +0/−492
• src/BrownPLT/Html/PrettyPrint.hs +0/−53
• src/BrownPLT/Html/RawScript.hs +0/−35
• src/BrownPLT/Html/Syntax.hs +0/−86
• src/BrownPLT/JavaScript.hs +0/−3
• src/BrownPLT/JavaScript/Crawl.hs +0/−102
• src/BrownPLT/JavaScript/Environment.hs +9/−3
• src/BrownPLT/JavaScript/HtmlEmbedding.hs +0/−25
• src/BrownPLT/JavaScript/Instances.hs +22/−3
• src/BrownPLT/JavaScript/Lexer.hs +0/−1
• src/BrownPLT/JavaScript/Parser.hs +70/−60
• src/BrownPLT/JavaScript/PrettyPrint.hs +12/−9
• src/BrownPLT/JavaScript/Syntax.hs +18/−9

@@ -1,14 +1,26 @@-Copyright (c) 2007-2008 Arjun Guha and Spiridon Eliopoulos.--WebBits is licensed under the terms of the GNU Lesser General Public License-2.1.+Copyright (c) 2009, Arjun Guha and Spiridon Eliopoulos+All Rights Reserved. -Contains source code derived from HtmlPrag 0.16, Copyright (c) 2003 - 2005 Neil-W. Van Dyke, licensed under the terms of the GNU Lesser General Public License-2.1.+Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met: -Contains source code derived from javascript.plt, Copyright (c) 2008 David-Herman, licensed under the terms of the GNU Lesser General Public License 2.1+    * Redistributions of source code must retain the above copyright notice,+      this list of conditions and the following disclaimer.+    * Redistributions in binary form must reproduce the above copyright +      notice, this list of conditions and the following disclaimer in the +      documentation and/or other materials provided with the distribution.+    * Neither the name of Brown University nor the names of its contributors+      may be used to endorse or promote products derived from this software+      without specific prior written permission. -The tests/ directory contains open-source JavaScript code.  Their licenses-are inline.+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.

@@ -1,8 +1,8 @@ Name:           WebBits-Version:        0.15+Version:        1.0 Cabal-Version:	>= 1.2.3 Copyright:      Copyright (c) 2007-2009 Arjun Guha and Spiridon Eliopoulos-License:        LGPL+License:        BSD3 License-file:   LICENSE Author:         Arjun Guha, Spiridon Eliopoulos Maintainer:     Arjun Guha <arjun@cs.brown.edu>@@ -13,42 +13,27 @@ Synopsis:       JavaScript analysis tools Description: -	WebBits is a collection of libraries for working with JavaScript embeded in-  HTML files.  Highlights include:-  .-	* @BrownPLT.JavaScript.Crawl@ returns all JavaScript in an HTML page, including-     JavaScript from imported script files (@\<script src=...\>@).-  .-  * @BrownPLT.JavaScript.Environment@ annotates JavaScript syntax with its -    static environment and returns a list of free identifiers.-  .-  * @BrownPLT.JavaScript.Parser@ is a JavaScript parser that is largely based on-    JavaScript 1.5.-  .-  * @BrownPLT.Html.Parser@ is a permissive HTML parser.+	WebBits is a collection of libraries for working with JavaScript.   Library   Hs-Source-Dirs:     src   Build-Depends:-    base>=4, mtl>=1.1.0.1, parsec<3.0.0, pretty>=0.1, containers>=0.1, syb>=0.1+    base >= 4 && < 5,+    mtl >= 1.1.0.1,+    parsec < 3.0.0,+    pretty >= 0.1,+    containers >= 0.1,+    syb >= 0.1   ghc-options:     -fwarn-incomplete-patterns   Extensions:     -    Generics TypeSynonymInstances DeriveDataTypeable+    Generics DeriveDataTypeable   Exposed-Modules:-    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

@@ -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 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

@@ -1,66 +0,0 @@-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

@@ -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 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)

@@ -1,53 +0,0 @@--- |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 "!}"-

@@ -1,35 +0,0 @@-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

@@ -1,86 +0,0 @@--- |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)-

@@ -1,7 +1,6 @@ -- |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@@ -12,6 +11,4 @@ import BrownPLT.JavaScript.Syntax import BrownPLT.JavaScript.Parser import BrownPLT.JavaScript.PrettyPrint-import BrownPLT.JavaScript.HtmlEmbedding- import BrownPLT.JavaScript.Instances

@@ -1,102 +0,0 @@--- |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

@@ -43,6 +43,13 @@ javascript :: JavaScript SourcePos -> Partial javascript (Script _ ss) = unions (map stmt ss) ++lvalue :: LValue SourcePos -> Partial+lvalue lv = case lv of+  LVar p x -> ref (Id p x)+  LDot _ e _ -> expr e+  LBracket _ e1 e2 -> unions [expr e1, expr e2]+ expr :: Expression SourcePos -> Partial expr e = case e of   StringLit _ _ -> empty@@ -58,12 +65,11 @@   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]+  AssignExpr _ _ lv e -> unions [lvalue lv, expr e]+  UnaryAssignExpr _ _ lv -> lvalue lv   ParenExpr _ e -> expr e   ListExpr _ es -> unions (map expr es)   CallExpr _ e es -> unions [expr e, unions $ map expr es]

@@ -1,25 +0,0 @@-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-    -  

@@ -39,6 +39,12 @@   fmap f (PropString a s) = PropString (f a) s   fmap f (PropNum a n) = PropNum (f a) n +instance Functor LValue where+  fmap f lv = case lv of+    LVar a x -> LVar (f a) x+    LDot a e x -> LDot (f a) (fmap f e) x+    LBracket a e1 e2 -> LBracket (f a) (fmap f e1) (fmap f e2) + instance Functor Expression where   fmap f expression =      case expression of@@ -56,11 +62,11 @@       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)+      UnaryAssignExpr a op e -> UnaryAssignExpr (f a) op (fmap f e)       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)@@ -122,6 +128,12 @@   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 LValue where+  foldr f b (LVar a x) = f a b+  foldr f b (LDot a e x) = f a (foldr f b e)+  foldr f b (LBracket a e1 e2) = f a (foldr f (foldr f b e2) e1)+          instance Foldable Expression where   -- foldr:: (a -> b -> b) -> b -> Expression a -> b@@ -141,11 +153,11 @@       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+      UnaryAssignExpr a _ lv -> f a (foldr f b lv)       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@@ -204,6 +216,12 @@   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 LValue where+  traverse f lv = case lv of+    LVar a x -> LVar <$> f a <*> pure x+    LDot a e x -> LDot <$> f a <*> traverse f e <*> pure x+    LBracket a e1 e2 -> LBracket <$> f a <*> traverse f e1 <*> traverse f e2    instance Traversable Expression where   traverse f expression =@@ -224,7 +242,6 @@       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@@ -232,6 +249,8 @@         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+      UnaryAssignExpr a op e ->+        UnaryAssignExpr <$> f a <*> pure op <*> traverse f e       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

@@ -18,7 +18,6 @@                 "*/"                 "//"                 False -- no nested comments-                {- Adapted from syntax/regexps.ss in Dave's code. -}                 identifierStart                 (alphaNum <|> oneOf "$_") -- identifier rest                 (oneOf "{}<>()~.,?:|&^=!+-*/%!") -- operator start

@@ -12,7 +12,7 @@   , parseStatement   , StatementParser   , ExpressionParser-  , parseAssignExpr+  , assignExpr   ) where  import BrownPLT.JavaScript.Lexer hiding (identifier)@@ -401,7 +401,7 @@                 <|> (liftM2 PropId getPosition identifier)                 <|> (liftM2 PropNum getPosition decimal)         colon-        val <- parseAssignExpr+        val <- assignExpr         return (name,val)     in do pos <- getPosition           props <- braces (parseProp `sepEndBy` comma) <?> "object literal"@@ -520,35 +520,8 @@     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) <|> @@ -561,7 +534,7 @@                       (reserved "void" >> return PrefixVoid) <|>                       (reserved "delete" >> return PrefixDelete)   case op of-    Nothing -> prefixIncDecExpr  -- new is treated as a simple expr+    Nothing -> unaryAssignExpr     Just op -> do       innerExpr <- parsePrefixedExpr       return (PrefixExpr pos op innerExpr)@@ -569,10 +542,6 @@ 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,@@ -588,18 +557,53 @@    [makeInfixExpr "==" OpEq, makeInfixExpr "!=" OpNEq,     makeInfixExpr "===" OpStrictEq, makeInfixExpr "!==" OpStrictNEq]     ]-  + parseExpression' =    buildExpressionParser exprTable parsePrefixedExpr <?> "simple expression" ---{{{ Parsing ternary operators: left factored+asLValue :: SourcePos+         -> Expression SourcePos +         -> CharParser st (LValue SourcePos)+asLValue p' e = case e of+  VarRef p (Id _ x) -> return (LVar p x)+  DotRef p e (Id _ x) -> return (LDot p e x)+  BracketRef p e1 e2 -> return (LBracket p e1 e2)+  otherwise -> fail $ "expeceted l-value at " ++ show p' +lvalue :: CharParser st (LValue SourcePos)+lvalue = do+  p <- getPosition+  e <- parseSimpleExpr Nothing+  asLValue p e+++unaryAssignExpr :: CharParser st ParsedExpression+unaryAssignExpr = do+  p <- getPosition+  let prefixInc = do+        reservedOp "++"+        liftM (UnaryAssignExpr p PrefixInc) lvalue+  let prefixDec = do+        reservedOp "--"+        liftM (UnaryAssignExpr p PrefixDec) lvalue+  let postfixInc e = do+        reservedOp "++"+        liftM (UnaryAssignExpr p PostfixInc) (asLValue p e)+  let postfixDec e = do+        reservedOp "--"+        liftM (UnaryAssignExpr p PostfixDec) (asLValue p e)+  let other = do+        e <- parseSimpleExpr Nothing+        postfixInc e <|> postfixDec e <|> return e+  prefixInc <|> prefixDec <|> other++ parseTernaryExpr':: CharParser st (ParsedExpression,ParsedExpression) parseTernaryExpr' = do     reservedOp "?"-    l <- parseAssignExpr+    l <- assignExpr     colon-    r <- parseAssignExpr+    r <- assignExpr     return $(l,r)  parseTernaryExpr:: ExpressionParser st@@ -610,37 +614,43 @@     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-  ]]+assignOp :: CharParser st AssignOp+assignOp = +  (reservedOp "=" >> return OpAssign) <|>+  (reservedOp "+=" >> return OpAssignAdd) <|>+  (reservedOp "-=" >> return OpAssignSub) <|>+  (reservedOp "*=" >> return OpAssignMul) <|>+  (reservedOp "/=" >> return OpAssignDiv) <|>+  (reservedOp "%=" >> return OpAssignMod) <|>+  (reservedOp "<<=" >> return OpAssignLShift) <|>+  (reservedOp ">>=" >> return OpAssignSpRShift) <|>+  (reservedOp ">>>=" >> return OpAssignZfRShift) <|>+  (reservedOp "&=" >> return OpAssignBAnd) <|>+  (reservedOp "^=" >> return OpAssignBXor) <|>+  (reservedOp "|=" >> return OpAssignBOr)  -parseAssignExpr:: ExpressionParser st-parseAssignExpr = buildExpressionParser assignTable parseTernaryExpr  +assignExpr :: ExpressionParser st+assignExpr = do+  p <- getPosition+  lhs <- parseTernaryExpr+  let assign = do+        op <- assignOp+        lhs <- asLValue p lhs+        rhs <- assignExpr+        return (AssignExpr p op lhs rhs)+  assign <|> (return lhs) + parseExpression:: ExpressionParser st-parseExpression = parseAssignExpr+parseExpression = assignExpr + parseListExpr =-  liftM2 ListExpr getPosition (parseAssignExpr `sepBy1` comma)+  liftM2 ListExpr getPosition (assignExpr `sepBy1` comma) ---}}}  parseScript:: CharParser state (JavaScript SourcePos) parseScript = do

@@ -143,8 +143,6 @@   prefixOp op = text $ case op of-  PrefixInc -> "++"-  PrefixDec -> "--"   PrefixLNot -> "!"   PrefixBNot -> "~"   PrefixPlus -> "+"@@ -154,11 +152,6 @@   PrefixDelete -> "delete"  -postfixOp op = text $ case op of-  PostfixInc -> "++"-  PostfixDec ->  "--"-- assignOp op = text $ case op of   OpAssign -> "="   OpAssignAdd -> "+="@@ -191,6 +184,12 @@     sel x    = [x]     -- We don't have to do anything about \X, \x and \u escape sequences. ++lvalue :: LValue a -> Doc+lvalue (LVar _ x) = text x+lvalue (LDot _ e x) = expr e <> text "." <> text x+lvalue (LBracket _ e1 e2) = expr e1 <> brackets (expr e2)+   expr :: Expression a -> Doc expr e = case e of @@ -216,11 +215,15 @@     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+  AssignExpr _ op l r ->  lvalue l <+> assignOp op <+> expr r+  UnaryAssignExpr _ op e' -> case op of+    PrefixInc -> text "++" <> lvalue e'+    PrefixDec -> text "--" <> lvalue e'+    PostfixInc -> lvalue e' <> text "++"+    PostfixDec -> lvalue e' <> text "--"   ParenExpr _ e' ->  parens (expr e')   ListExpr _ es ->  cat $ punctuate comma (map expr es)   CallExpr _ f args -> 

@@ -1,8 +1,11 @@ -- |JavaScript's syntax. module BrownPLT.JavaScript.Syntax(Expression(..),CaseClause(..),Statement(..),          InfixOp(..),CatchClause(..),VarDecl(..),JavaScript(..),-         AssignOp(..),Id(..),PrefixOp(..),PostfixOp(..),Prop(..),-         ForInit(..),ForInInit(..),unId) where+         AssignOp(..),Id(..),PrefixOp(..),Prop(..),+         ForInit(..),ForInInit(..),unId+  , UnaryAssignOp (..)+  , LValue (..)+  ) where  import Text.ParserCombinators.Parsec(SourcePos) -- used by data JavaScript import Data.Generics(Data,Typeable)@@ -32,17 +35,23 @@   | OpAssignBAnd | OpAssignBXor | OpAssignBOr   deriving (Show,Data,Typeable,Eq,Ord) -data PrefixOp = PrefixInc | PrefixDec | PrefixLNot | PrefixBNot | PrefixPlus+data UnaryAssignOp+  = PrefixInc | PrefixDec | PostfixInc | PostfixDec+  deriving (Show, Data, Typeable, Eq, Ord)++data PrefixOp = 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 LValue a+  = LVar a String+  | LDot a (Expression a) String+  | LBracket a (Expression a) (Expression a)+  deriving (Show, Eq, Ord, Data, Typeable)   data Expression a   = StringLit a String@@ -58,11 +67,11 @@   | 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)+  | UnaryAssignExpr a UnaryAssignOp (LValue a)   | InfixExpr a InfixOp (Expression a) (Expression a)   | CondExpr a (Expression a) (Expression a) (Expression a)-  | AssignExpr a AssignOp (Expression a) (Expression a)+  | AssignExpr a AssignOp (LValue a) (Expression a)   | ParenExpr a (Expression a)   | ListExpr a [Expression a]   | CallExpr a (Expression a) [Expression a]