packages feed

WebBits 0.15 → 2.2

raw patch · 17 files changed

Files

LICENSE view
@@ -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) 2007--2011, Brown University and Claudiu Saftoiu+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.
WebBits.cabal view
@@ -1,54 +1,47 @@ Name:           WebBits-Version:        0.15-Cabal-Version:	>= 1.2.3-Copyright:      Copyright (c) 2007-2009 Arjun Guha and Spiridon Eliopoulos-License:        LGPL+Version:        2.2+Cabal-Version:	>= 1.6+Copyright:      Copyright (c) 2007-2011 Brown University, Claudiu Saftoiu,  Arjun Guha, Spiridon Eliopoulos, Copyright (c) 2012 Arjun Guha and Andrey Chudnov+License:        BSD3 License-file:   LICENSE-Author:         Arjun Guha, Spiridon Eliopoulos-Maintainer:     Arjun Guha <arjun@cs.brown.edu>-Homepage:       http://www.cs.brown.edu/research/plt/+Author:         Arjun Guha, Claudiu Saftoiu, Spiridon Eliopoulos and Andrey Chudnov+Maintainer:     Andrey Chudnov <oss@chudnov.com>+Homepage:       http://github.com/brownplt/webbits+Bug-reports:    http://github.com/brownplt/webbits/issues Stability:      provisional+Tested-with:    GHC==7.0.4, GHC==7.4.1 Category:       Language Build-Type:     Custom Synopsis:       JavaScript analysis tools-Description:+Description:    WebBits is a collection of libraries for working with JavaScript, contains a parser, a pretty-printer and a lexical environment analyser. The original author of the package is the PLT group of Brown University (http:\/\/www.cs.brown.edu\/research\/plt\/). Changes since version 2.1: the syntax of the try-catch-finally statement has been changed in accordance to the ECMAScript specification -- now it only has at most one catch clause. The original test-suite needs updating to support the current test system: patches are welcome. -	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.+Source-repository head+   type: git+   location: git://github.com/brownplt/webbits.git++Source-repository this+   type: git+   location: git://github.com/brownplt/webbits.git+   tag: WebBits-2.2   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.2.0,+    pretty >= 0.1,+    containers >= 0.1,+    syb >= 0.1   ghc-options:     -fwarn-incomplete-patterns   Extensions:     -    Generics TypeSynonymInstances DeriveDataTypeable+    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
− src/BrownPLT/Html.hs 
@@ -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
− src/BrownPLT/Html/Instances.hs 
@@ -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
− src/BrownPLT/Html/PermissiveParser.hs 
@@ -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)
− src/BrownPLT/Html/PrettyPrint.hs 
@@ -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 "!}"-
− src/BrownPLT/Html/RawScript.hs 
@@ -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
− src/BrownPLT/Html/Syntax.hs 
@@ -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)-
src/BrownPLT/JavaScript.hs view
@@ -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,3 @@ import BrownPLT.JavaScript.Syntax import BrownPLT.JavaScript.Parser import BrownPLT.JavaScript.PrettyPrint-import BrownPLT.JavaScript.HtmlEmbedding--import BrownPLT.JavaScript.Instances
− src/BrownPLT/JavaScript/Crawl.hs 
@@ -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
src/BrownPLT/JavaScript/Environment.hs view
@@ -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,16 +65,15 @@   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]-  FuncExpr _ args s -> nest $ unions [unions $ map decl args, stmt s]+  FuncExpr _ _ args s -> nest $ unions [unions $ map decl args, stmt s]  caseClause :: CaseClause SourcePos -> Partial caseClause cc = case cc of@@ -108,8 +114,8 @@   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]+  TryStmt _ s catch ms ->+    unions [stmt s, maybe empty catchClause catch, maybe empty stmt ms]   ThrowStmt _ e -> expr e   ReturnStmt _ me -> maybe empty expr me   WithStmt _ e s -> unions [expr e, stmt s]
− src/BrownPLT/JavaScript/HtmlEmbedding.hs 
@@ -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-    -
− src/BrownPLT/JavaScript/Instances.hs 
@@ -1,294 +0,0 @@--- |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
src/BrownPLT/JavaScript/Lexer.hs view
@@ -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@@ -35,6 +34,7 @@                  "[", "]", "{", "}", "(", ")","</","instanceof"]                  True -- case-sensitive             +lex :: T.TokenParser st lex = T.makeTokenParser javascriptDef  -- everything but commaSep and semiSep
src/BrownPLT/JavaScript/Parser.hs view
@@ -12,7 +12,7 @@   , parseStatement   , StatementParser   , ExpressionParser-  , parseAssignExpr+  , assignExpr   ) where  import BrownPLT.JavaScript.Lexer hiding (identifier)@@ -35,6 +35,7 @@ type StatementParser state = CharParser state ParsedStatement type ExpressionParser state = CharParser state ParsedExpression +identifier :: CharParser st (Id SourcePos) identifier =   liftM2 Id getPosition Lexer.identifier @@ -197,10 +198,10 @@     in do reserved "try"           pos <- getPosition           guarded <- parseStatement-          catches <- many parseCatchClause+          catch <- optionMaybe parseCatchClause           finally <- (reserved "finally" >> liftM Just parseStatement)                        <|> (return Nothing)-          return (TryStmt pos guarded catches finally)+          return (TryStmt pos guarded catch finally)  parseThrowStmt:: StatementParser st parseThrowStmt = do@@ -302,20 +303,21 @@ parseVarRef = liftM2 VarRef getPosition identifier  parseArrayLit:: ExpressionParser st-parseArrayLit = liftM2 ArrayLit getPosition (squares (parseExpression `sepBy` comma))+parseArrayLit = liftM2 ArrayLit getPosition (squares (parseExpression `sepEndBy` comma))    parseFuncExpr = do   pos <- getPosition   reserved "function"+  name <- (identifier >>= return . Just) <|> return Nothing   args <- parens (identifier `sepBy` comma)   body <- parseBlockStmt-  return $ FuncExpr pos args body+  return $ FuncExpr pos name args body  --{{{ parsing strings  escapeChars =  [('\'','\''),('\"','\"'),('\\','\\'),('b','\b'),('f','\f'),('n','\n'),-  ('r','\r'),('t','\t'),('v','\v'),('/','/'),(' ',' ')]+  ('r','\r'),('t','\t'),('v','\v'),('/','/'),(' ',' '),('0','\0')]  allEscapes:: String allEscapes = map fst escapeChars@@ -375,8 +377,10 @@   let parseFlags = do         flags <- many (oneOf "mgi")         return $ \f -> f ('g' `elem` flags) ('i' `elem` flags) -  let parseEscape = char '\\' >> anyChar-  let parseChar = noneOf "/"+  let parseEscape :: CharParser st Char+      parseEscape = char '\\' >> anyChar+  let parseChar :: CharParser st Char+      parseChar = noneOf "/"   let parseRe = (char '/' >> return "") <|>                  (do char '\\'                     ch <- anyChar -- TOOD: too lenient@@ -401,7 +405,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 +524,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,45 +538,98 @@                       (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)  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]+  [ [ makeInfixExpr "==" OpEq+    , makeInfixExpr "!=" OpNEq+    , makeInfixExpr "===" OpStrictEq+    , makeInfixExpr "!==" OpStrictNEq     ]++  , [ makeInfixExpr "||" OpLOr ]++  , [ makeInfixExpr "&&" OpLAnd ]   +  , [ makeInfixExpr "|" OpBOr ]++  , [ makeInfixExpr "^" OpBXor ]++  , [ makeInfixExpr "&" OpBAnd ]++  , [ makeInfixExpr "<" OpLT+    , makeInfixExpr "<=" OpLEq+    , makeInfixExpr ">" OpGT+    , makeInfixExpr ">=" OpGEq+    , makeInfixExpr "instanceof" OpInstanceof+    , makeInfixExpr "in" OpIn+    ]++  , [ makeInfixExpr "<<" OpLShift+    , makeInfixExpr ">>" OpSpRShift+    , makeInfixExpr ">>>" OpZfRShift+    ]++  , [ makeInfixExpr "+" OpAdd+    , makeInfixExpr "-" OpSub+    ]++  , [ makeInfixExpr "*" OpMul+    , makeInfixExpr "/" OpDiv+    , makeInfixExpr "%" OpMod+    ]+  ]+ 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 +640,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
src/BrownPLT/JavaScript/PrettyPrint.hs view
@@ -57,8 +57,10 @@   text "default:" $$ (nest 2 (semiSep ss))  -catchClause :: CatchClause a -> Doc-catchClause (CatchClause _ id s) = text "catch" <+> (parens.pp) id <+> inBlock s+catchClause :: Maybe (CatchClause a) -> Doc+catchClause Nothing = empty+catchClause (Just (CatchClause _ id s)) = +  text "catch" <+> (parens.pp) id <+> inBlock s   varDecl :: VarDecl a -> Doc@@ -93,8 +95,8 @@     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)) $$+  TryStmt _ stmt catch finally ->+    text "try" $$ inBlock stmt $$ catchClause catch $$     ppFinally where         ppFinally = case finally of         Nothing -> empty@@ -143,8 +145,6 @@   prefixOp op = text $ case op of-  PrefixInc -> "++"-  PrefixDec -> "--"   PrefixLNot -> "!"   PrefixBNot -> "~"   PrefixPlus -> "+"@@ -154,11 +154,6 @@   PrefixDelete -> "delete"  -postfixOp op = text $ case op of-  PostfixInc -> "++"-  PostfixDec ->  "--"-- assignOp op = text $ case op of   OpAssign -> "="   OpAssignAdd -> "+="@@ -191,6 +186,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,17 +217,21 @@     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 ->      expr f <> (parens $ cat $ punctuate comma (map expr args))-  FuncExpr _ args body -> -    text "function" <+> +  FuncExpr _ name args body -> +    text "function" <+> text (maybe "" unId name) <+>     (parens $ cat $ punctuate comma (map pp args)) $$      inBlock body
src/BrownPLT/JavaScript/Syntax.hs view
@@ -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,15 +67,16 @@   | 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]-  | FuncExpr a [(Id a)] (Statement a)+  --funcexprs are optionally named+  | FuncExpr a (Maybe (Id a)) [(Id a)] (Statement a)   deriving (Show,Data,Typeable,Eq,Ord)  data CaseClause a @@ -108,10 +118,10 @@   | 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+              (Maybe (Expression a)) -- increment               (Statement a)          -- body-  | TryStmt a (Statement a) {-body-} [CatchClause a] {-catches-}+  | TryStmt a (Statement a) {-body-} (Maybe (CatchClause a))       (Maybe (Statement a)) {-finally-}   | ThrowStmt a (Expression a)   | ReturnStmt a (Maybe (Expression a))