packages feed

WebBits (empty) → 0.9

raw patch · 21 files changed

+3005/−0 lines, 21 filesdep +basedep +containersdep +mtlbuild-type:Customsetup-changed

Dependencies added: base, containers, mtl, parsec, pretty

Files

+ LICENSE view
@@ -0,0 +1,8 @@+Copyright (c) 2007-2008 Arjun Guha and Spiridon Eliopoulos.++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.++WebBits is licensed under the terms of the GNU Lesser General Public License+2.1.
+ Setup.lhs view
@@ -0,0 +1,31 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> import qualified Data.List as L+> import System.Directory+> import System.Process (runCommand,waitForProcess)++> isHaskellFile file = ".lhs" `L.isSuffixOf` file || ".hs" `L.isSuffixOf` file++> moduleName file = "Test." ++ m where+>   m = L.takeWhile (\ch -> ch /= '.') file++> testMain _ _ _ _ = do+>   files <- getDirectoryContents "src/Test"+>   let tests = filter isHaskellFile files+>   let testModules = map moduleName tests+>   let testFuncs = map (++ ".main") testModules+>   let testExpr = "sequence [ " ++ concat (L.intersperse "," testFuncs) ++ +>                  " ] >>= \\cases -> runTestTT (TestList cases)"+>   let moduleLine = concat (L.intersperse " " testModules)+>   let cmd = "cd src && ghc  -fno-monomorphism-restriction -fglasgow-exts " +++>             "-package HUnit -e \"" ++ testExpr ++ " >> return ()\" " ++ +>             moduleLine+>   putStrLn "Testing command is:"+>   putStrLn cmd+>   putStrLn "\nLoading tests..."+>   handle <- runCommand cmd+>   waitForProcess handle+>   putStrLn "Testing complete.  Errors reported above (if any)."+ ++> main = defaultMainWithHooks (simpleUserHooks { runTests = testMain })
+ WebBits.cabal view
@@ -0,0 +1,50 @@+Name:           WebBits+Version:        0.9+Cabal-Version:	>= 1.2+Copyright:      Copyright (c) 2007-2008 Arjun Guha and Spiridon Eliopoulos+License:        LGPL+License-file:   LICENSE+Author:         Arjun Guha, Spiridon Eliopoulos+Maintainer:     Arjun Guha <arjun@cs.brown.edu>+Homepage:       http://www.cs.brown.edu/research/plt/+Stability:      provisional+Category:       Tools+Build-Type:     Custom+Synopsis:       JavaScript analysis tools+Description:++	WebBits is a collection of libraries for working with JavaScript embeded in+  HTML files.  Highlights include:++	"WebBits.JavaScript.Crawl" returns all JavaScript in an HTML page, including+  JavaScript from imported script files ("<script src=...>").++  "WebBits.JavaScript.Environment" annotates JavaScript syntax with its static+  environment and returns a list of free identifiers.++  "WebBits.JavaScript.Parser" is a JavaScript parser that is largely based on+  JavaScript 1.5.++  "WebBits.Html.Parser" is a permissive HTML parser.+ +Library+  Hs-Source-Dirs:+    src+  Build-Depends:+    base, mtl, parsec, pretty, containers+  ghc-options:+    -fwarn-incomplete-patterns -fglasgow-exts+  Extensions:     +    Generics Rank2Types MultiParamTypeClasses FunctionalDependencies+    TypeSynonymInstances FlexibleInstances FlexibleContexts+    DeriveDataTypeable NoMonomorphismRestriction+  Exposed-Modules:+    WebBits.Data.Zipper+    WebBits.Html.Html WebBits.Html.Syntax WebBits.Html.PermissiveParser+    WebBits.Html.PrettyPrint WebBits.Html.Instances WebBits.Common+    WebBits.Html.RawScript WebBits.JavaScript.Combinators+    WebBits.JavaScript.HtmlEmbedding WebBits.JavaScript.Instances+    WebBits.JavaScript.JavaScript WebBits.JavaScript.Lexer +    WebBits.JavaScript.Parser WebBits.JavaScript.PrettyPrint+    WebBits.JavaScript.Syntax WebBits.JavaScript.Environment+    WebBits.JavaScript.Crawl
+ src/WebBits/Common.hs view
@@ -0,0 +1,63 @@+-- | Defines commonly used datatypes and functions.+module WebBits.Common+  ( PrettyPrintable(..)+  , L.isPrefixOf+  , SourcePos+  , sourceName+  ) where++import Data.Map (Map)+import Data.Maybe (catMaybes)+import Data.Char (toLower)+import Control.Applicative+import qualified System.IO as IO+import Control.Monad.State.Strict+import Control.Monad.Identity+import qualified Data.List as L+import Data.Generics hiding (GT)+import qualified Data.Foldable as Foldable+import Data.Foldable (Foldable)+import qualified Data.Traversable as Traversable+import Data.Traversable (Traversable, traverse)+import qualified Text.PrettyPrint.HughesPJ as Pp+import Text.ParserCombinators.Parsec.Pos (SourcePos, initialPos, sourceName)++lowercase = map toLower++-- | 'PrettyPrintable' makes writing pretty-printing code for large, recursive+-- data structures shorter.+class PrettyPrintable a where+  pp:: a -> Pp.Doc+  +instance PrettyPrintable a => PrettyPrintable (Maybe a) where+  pp (Just a) = pp a+  pp Nothing  = Pp.empty++--------------------------------------------------------------------------------+-- Generics for SourcePos++-- | These definitions allow us to use data structures containing 'SourcePos'+-- values with generics.++-- |We make 'SourcePos' an instance of 'Typeable' so that we can use it with+-- generics.+instance Typeable SourcePos where+  typeOf _  = +    mkTyConApp (mkTyCon "Text.ParserCombinators.Parsec.Pos.SourcePos") []+    +-- Complete guesswork.  It seems to work.+sourcePosDatatype = mkDataType "SourcePos" [sourcePosConstr1]+sourcePosConstr1 = mkConstr sourcePosDatatype "SourcePos" [] Prefix++-- |We make 'SourcePos' an instance of 'Typeable' so that we can use it with+-- generics.+--+-- This definition is incomplete.+instance Data SourcePos where+  -- We treat source locations as opaque.  After all, we don't have access to+  -- the constructor.+  gfoldl k z pos = z pos+  toConstr _ = sourcePosConstr1+  gunfold   = error "gunfold is not defined for SourcePos"+  dataTypeOf = error "dataTypeOf is not defined for SourcePos"+
+ src/WebBits/Data/Zipper.hs view
@@ -0,0 +1,274 @@+-- |A zipper for "Data.Tree".+module WebBits.Data.Zipper+  ( +  -- * Functional zipper+  +  -- $functionalZipper+  +    Tree(..)+  , Location+  , toLocation, fromLocation  +  , dfsFold +  , dfsFoldM+  , showTree++  , empty+  , up, down, left, right -- Location a -> Location a+  , replace+  , change+  , insertDown, insertLeft, insertRight+  , isTop, isChild+  , getValue+  , subTree+  , top+  , canGoLeft, canGoRight, canGoUp, canGoDown -- Location a -> Bool+  +  -- * Imperative tree construction+  +  -- $treeBuilder+  +  , ZipperT++  , nest                  -- Monad m => v -> ZipperT v m a -> ZipperT v m a+  , getNode               -- Monad m => ZipperT v m v+  , setNode               -- Monad m => v -> ZipperT v m ()+  , runZipperT+  , evalZipperT+  , execZipperT+  , shiftLeft, shiftRight   -- Monad m => ZipperT v m ()+  , shiftLeft', shiftRight' -- Monad m => ZipperT v m ()+  , withCurrentChild        -- Monad m => Zipper T v m a -> ZipperT v m a+  +  ) where++import Control.Monad+import Control.Monad.State+import Data.Tree (Tree (..), drawTree)++-------------------------------------------------------------------------------+-- Data types!+--++data Path a+  = Top+  | Split a [Tree a] (Path a) [Tree a]++data Location a = Location (Tree a) (Path a)+++dfsFold :: (w -> v -> w) -- ^transforms a node 'v' using the accumulated+                         -- value 'w' from the root of the tree to 'v'+        -> w             -- ^the initial value of the accumulator at the root+        -> Tree v +        -> Tree w+dfsFold f w (Node v ts) = Node w' (map (dfsFold f w') ts)+  where w' = f w v++-- |Similar to 'dfsFold', but the transformation is done in the monad 'm'.  The+-- sequence of operations is depth-first, left-to-right.+dfsFoldM :: Monad m => (w -> v -> m w) -> w -> Tree v -> m (Tree w)+dfsFoldM f w (Node v ts) = do+  w'  <- f w v+  ts' <- mapM (dfsFoldM f w') ts+  return $ Node w' ts'++-- Uses 'Data.Tree.drawShow'.+showTree :: Show a => Tree a -> String+showTree tree =  drawTree (fmap show tree)+  ++-------------------------------------------------------------------------------+-- Combinators!+--++-- $functionalZipper+-- These are the core zipper functions.++empty :: a -> Tree a+empty a = Node a []++up :: Location a -> Location a+up (Location _ Top)               = error " up of Top"+up (Location t (Split v ls p rs)) = Location (Node v (reverse ls ++ (t:rs))) p++down :: Location a -> Location a+down (Location (Node v []) _)     = error "down of empty"+down (Location (Node v (t:ts)) p) = Location t (Split v [] p ts)++left :: Location a -> Location a+left (Location t Top)                   = error "left of top"+left (Location t (Split v [] p rs))     = error "left on leftmost"+left (Location t (Split v (l:ls) p rs)) = Location l (Split v ls p (t:rs))++right :: Location a -> Location a+right (Location t Top) = +  error "Data.Zipper.right : at the top"+right (Location t (Split v ls p []))     = error "right on rightmost"+right (Location t (Split v ls p (r:rs))) = Location r (Split v (t:ls) p rs)++replace :: Location a -> Tree a ->  Location a+replace (Location _ p) t = Location t p++change :: Location a -> a -> Location a+change (Location (Node _ cs) p) t = Location (Node t cs) p++insertDown :: Location a -> Tree a -> Location a+insertDown (Location (Node v ts) p) t = Location (Node v (t:ts)) p++insertDownRight :: Location a -> Tree a -> Location a+insertDownRight (Location (Node v ts) p) t = +  Location t (Split v (reverse ts) p [])++insertLeft :: Location a -> Tree a -> Location a+insertLeft (Location _ Top) _                = error "insert on top"+insertLeft (Location t (Split v ls p rs)) t' =+  Location t (Split v (t':ls) p rs)++insertRight :: Location a -> Tree a -> Location a+insertRight (Location _ Top) _                = error "insert on top"+insertRight (Location t (Split v ls p rs)) t' = +  Location t (Split v ls p (t':rs))++isTop :: Location a -> Bool+isTop (Location _ Top) = True+isTop _                = False++isChild :: Location a -> Bool+isChild = not . isTop++canGoRight :: Location a -> Bool+canGoRight (Location _ (Split _ _ _ [])) = False+canGoRight (Location _ Top) = False+canGoRight _ = True++canGoDown :: Location a -> Bool+canGoDown (Location (Node _ []) _) = False+canGoDown _                        = True++canGoLeft :: Location a -> Bool+canGoLeft (Location _ Top)              = False+canGoLeft (Location _ (Split _ [] _ _)) = False+canGoLeft _                             = True++canGoUp :: Location a -> Bool+canGoUp (Location _ Top) = False+canGoUp _                = True++getValue :: Location a -> a+getValue (Location (Node v _) _) = v++subTree :: Location a -> Tree a+subTree (Location node _) = node++-- |Traverses to the top of the tree.+--+-- @+-- up.top = undefined+-- top.top = top+-- @+top :: Location a -> Location a+top loc@(Location _ Top) = loc+top loc@(Location _ _) = top (up loc)++toLocation :: Tree a -> Location a+toLocation t = Location t Top++fromLocation :: Location a -> Tree a+fromLocation (Location t _) = t+++-- $treeBuilder+-- A state monad that carries a zipper.  It provides convenient methods to+-- imperatively create and update a tree.+--+-- The state monad's set method may be used to arbitrarily update the current+-- location.  However, such updates can break the behavior of nest and+-- withCurrentChild.  We recommend avoiding StateT.set.++type ZipperT v m a = StateT (Location v) m a+++runZipperT :: Monad m => ZipperT v m a -> Location v -> m (a, Tree v)+runZipperT m l = do+  (a, Location t Top) <- runStateT m l+  return (a,t)++evalZipperT :: Monad m => ZipperT v m a -> Location v -> m a+evalZipperT m l = do+  ~(a, _) <- runStateT m l+  return a++execZipperT :: Monad m => ZipperT v m a -> Location v -> m (Tree v)+execZipperT m l = do+  ~(_, Location t Top) <- runStateT m l+  return t++-- |Creates a new node as the right-most child of the current node.+nest :: Monad m +     => v -- ^value of the new right-most child +     -> ZipperT v m a -- ^computation applied to the new child +     -> ZipperT v m a -- ^returns the result of the nested computation+nest v m = do+  z <- get +  put $ insertDownRight z (empty v)+  a <- m+  z' <- get -- z' is the child of z +  put (up z')+  return a+  +getNode :: Monad m => ZipperT v m v+getNode = do+  (Location (Node v _) _)  <- get+  return v+  +setNode :: Monad m => v -> ZipperT v m ()+setNode v = do+  (Location (Node _ cs) path) <- get+  put $ Location (Node v cs) path++withCurrentChild :: Monad m +                 => ZipperT v m a -- ^computation to apply to the current child +                 -> ZipperT v m a -- ^returns the result of the nested +                                  -- computation+withCurrentChild m = do+  z <- get+  put (down z)+  a <- m+  z' <- get+  put (up z')+  return a++shiftRight :: Monad m => ZipperT v m ()+shiftRight = do+  z <- get+  put (right z)++  +shiftLeft :: Monad m => ZipperT v m ()+shiftLeft = do+  z <- get+  put (left z)++-- |Silently fails to shift right if there is no right-child.+shiftRight' :: Monad m => ZipperT v m ()+shiftRight' = do+  z <- get+  when (hasRight z)+       (put (right z))++-- |Silently fails to shift left if there is no left-child.+shiftLeft' :: Monad m => ZipperT v m ()+shiftLeft' = do+  z <- get+  when (hasLeft z)+       (put (left z))++hasLeft :: Location a -> Bool+hasLeft (Location _ (Split _ (_:_) _ _)) = True+hasLeft _                                = False++hasRight :: Location a -> Bool+hasRight (Location _ (Split _ _ _ (_:_))) = True+hasRight _                                = False++
+ src/WebBits/Html/Html.hs view
@@ -0,0 +1,14 @@+-- |Rexports various modules of the HTML library.  It's best to use this in lieu+-- of selectively importing the following libraries.+module WebBits.Html.Html+  ( module WebBits.Html.Syntax+  -- PermissiveParser+  , html+  , parseHtmlFromFile+  , parseHtmlFromString+  ) where+  +import WebBits.Html.Syntax+import WebBits.Html.PermissiveParser+import WebBits.Html.PrettyPrint -- no names, only instances+import WebBits.Html.Instances -- no names, only instances
+ src/WebBits/Html/Instances.hs view
@@ -0,0 +1,66 @@+module WebBits.Html.Instances() where++import qualified Prelude as Prelude+import Prelude (Functor,map,fmap)+import qualified Data.List as List+import qualified Data.Char as Char+import Data.Foldable+import Data.Traversable+import Control.Applicative++import WebBits.Html.Syntax++ltraverse:: (Traversable t, Applicative f) => (a -> f b) -> [t a] -> f [t b]+ltraverse f [] = pure []+ltraverse f (x:xs) = pure (:) <*> (traverse f x) <*> ltraverse f xs++instance Functor (Attribute a) where+  fmap f (Attribute id val a)            = Attribute id val a+  fmap f (AttributeExpr a id script def) = AttributeExpr a id (f script) def++instance Functor (Html a) where+  fmap f (Element id attrs children a) = +    Element id (map (fmap f) attrs) (map (fmap f) children) a+  fmap f (Text str a)                  = Text str a+  fmap f (Comment str a)               = Comment str a+  fmap f (HtmlSeq xs)                  = HtmlSeq (map (fmap f) xs)+  fmap f (ProcessingInstruction str a) = ProcessingInstruction str a+  fmap f (InlineScript script a def)   = InlineScript (f script) a def+  fmap f (Script script a)             = Script (f script) a++instance Foldable (Attribute a) where+  foldr f x (Attribute id val a)          = x+  foldr f x (AttributeExpr a id script def) = f script x++instance Foldable (Html a) where+  foldr f x (Element id attrs children a) =+    Prelude.foldr  (\child x' -> foldr f x' child) x children  +  foldr f x (Text str a)                  = x+  foldr f x (Comment str a)               = x+  foldr f x (HtmlSeq ys)                  = +    Prelude.foldr (\child x' -> foldr f x' child) x ys+  foldr f x (ProcessingInstruction str a) = x+  foldr f x (InlineScript script a def)   = f script x+  foldr f x (Script script a)             = f script x++instance Traversable (Attribute a) where+  traverse f (Attribute id val a)            =+    pure (Attribute id val a)+  traverse f (AttributeExpr a id script def) =+    (AttributeExpr a id) <$> (f script) <*> pure def++instance Traversable (Html a) where+  traverse f (Element id attrs children a) = +    (Element id) <$> ltraverse f attrs  <*> ltraverse f children <*> pure a+  traverse f (Text str a)                  = +    pure (Text str a)+  traverse f (Comment str a)               = +    pure (Comment str a)+  traverse f (HtmlSeq xs)                  = +    HtmlSeq <$> ltraverse f xs+  traverse f (ProcessingInstruction str a) = +    pure (ProcessingInstruction str a)+  traverse f (InlineScript script a def)   =+    InlineScript <$> (f script) <*> pure a <*> pure def+  traverse f (Script script a)             = +    Script <$> (f script) <*> pure a
+ src/WebBits/Html/PermissiveParser.hs view
@@ -0,0 +1,492 @@+-- |A structure-recovering parser for malformed documents.+--+-- Copyright 2007-2008 Arjun Guha.+-- Based on HtmlPrag 0.16 Copyright (C) 2003 - 2005 Neil W. Van Dyke.  +--+-- This program is Free Software; you can redistribute it and/or modify it under+-- the terms of the GNU Lesser General Public License as published by the Free+-- Software Foundation; either version 2.1 of the License, or (at your option)+-- any later version.  This program is distributed in the hope that it will be+-- useful, but without any warranty; without even the implied warranty of+-- merchantability or fitness for a particular purpose.  See +-- <http://www.gnu.org/copyleft/lesser.html> for details.  For other license+-- options and consulting, contact the author.+module WebBits.Html.PermissiveParser+  ( html+  , parseHtmlFromFile+  , parseHtmlFromString+  -- tokenizer is exported primarily for testing+  , tokens+  , Token+  ) where++import Control.Monad+import Text.ParserCombinators.Parsec hiding (token,tokens)+import qualified Text.ParserCombinators.Parsec as Parsec+import Data.Char (toLower)+import Data.List (intersperse)++import qualified WebBits.Html.Syntax as Html+import WebBits.Html.Syntax (HtmlId,Attribute,Script(..))++type ParsedHtml s = Html.Html SourcePos s+type ParsedAttribute s = Html.Attribute SourcePos s++--------------------------------------------------------------------------------+-- Parsers generate warnings++data Warning = StringWarning SourcePos String++instance Show Warning where+  show (StringWarning p s) = "Warning parsing HTML: " ++ s+  showList [] s = s+  showList (x:xs) s = show x ++ ('\n':showList xs s)++warn:: String -> GenParser tok [Warning] ()+warn s = do+  p <- getPosition+  updateState ((StringWarning p s):)++noWarnings:: [Warning]+noWarnings = []+  ++-- A structure-recovering parser for malformed documents, derived from+-- Neil W. Van Dyke's htmlprag library for PLT Scheme++-- The elements in the list can legally enclose the 1st element of the pair.+parentConstraints:: [(HtmlId,[HtmlId])]+parentConstraints =+  [("area",["map"]),+   ("body",["html"]),+   ("caption", ["table"]),+   ("colgroup", ["table"]),+   ("dd", ["dl"]),+   ("dt", ["dl"]),+   ("frame", ["frameset"]),+   ("head", ["html"]),+   ("isindex", ["head"]),+   ("li", ["dir", "menu", "ol", "ul"]),+   ("meta", ["head"]),+   ("noframes", ["frameset"]),+   ("option", ["select"]),+   ("p", ["body", "td", "th"]),+   ("param", ["applet"]),+   ("tbody", ["table"]),+   ("td", ["tr"]),+   ("th", ["tr"]),+   ("thead", ["table"]),+   ("title", ["head"]),+   ("tr", ["table", "tbody", "thead"])]++-- |List of HTML elements that are empty.+emptyElements:: [HtmlId]+emptyElements = +  ["area", "base", "br", "frame", "hr", "img", "input", "isindex", "keygen", +   "link", "meta", "object", "param", "spacer", "wbr"]++isLegalChildOf:: HtmlId -> HtmlId -> Bool+isLegalChildOf child parent =+  case lookup child parentConstraints of+    Nothing             -> True+    (Just legalParents) -> parent `elem` legalParents+    +isEmptyElement:: HtmlId -> Bool+isEmptyElement element = element `elem` emptyElements++--}}}++--------------------------------------------------------------------------------+-- Parses an HTML file into a stream of tokens.++-- The auxillary parsing functions return values of this type.+data Script s  => Token s+  = Text SourcePos String+  | EntityToken SourcePos String+  | EntityInt SourcePos Int+  | Tag SourcePos HtmlId [Attribute SourcePos s] Bool {-closed?-}+  | Script SourcePos s+  | Inline SourcePos s String+  | EndTag SourcePos HtmlId+  | Comment SourcePos String+  | DoctypeToken SourcePos String String String (Maybe String)+++token:: Script s => Bool -> [Attribute SourcePos s] +     -> CharParser [Warning] (Token s)+token expectedScript prevAttrs = case expectedScript of+  True  -> (liftM2 Script getPosition (parseScriptBlock prevAttrs)) +             <?> "expected a script after a <script> tag"+  False -> doctype <|> comment <|> tag <|> endTag <|> inlineScript <|> entity +             <|> text++tokens:: Script s => CharParser [Warning] [Token s]+tokens = (eof >> return []) <|> tokens' where+  tokens' = do +    t <- token False []+    case t of+      (Tag _ "script" attrs False) -> do s <- token True attrs+                                         ts <- tokens+                                         return (t:s:ts)+      _ -> tokens >>= return.(t:)++--------------------------------------------------------------------------------+-- Parsers for various components of HTML++qname:: CharParser st String+qname = do+  x <- letter+  xs <- many (noneOf "/*=<>\"\'  \v\f\t\r\n")+  return (x:xs)++-- |We do not permit spaces between the hyphens and the right-angle in the+-- terminating '-->'.+comment:: Script s => CharParser st (Token s) +comment =+  let notDoubleHyphen = try (char '-' >> notFollowedBy (char '-') >> return '-')+      notHyphen = noneOf "-"+    in do try (string "<!--")+          pos <- getPosition+          msg <- many (notHyphen <|> notDoubleHyphen)+          string "-->"+          return (Comment pos msg)++endTag:: Script s => CharParser [Warning] (Token s)+endTag  = do+  pos <- getPosition+  string "</"+  name <- qname <?> "closing tag\'s name"+  junk <- manyTill anyChar (char '>') -- permits junk between tag name and '>'+  unless (null junk) (warn $ "extra characters: " ++ junk ++ +                             "; assuming tag name is " ++ name)+  return (EndTag pos name)+  +doctype:: Script s => CharParser [Warning] (Token s)+doctype = do+  p <- getPosition+  try (string "<!DOCTYPE")+  spaces+  top <- qname <?> "top-element name"+  spaces+  avail <- qname <?> "availability"+  spaces+  regEtc <- quotedString <?> "registration, etc."+  spaces+  uri <- optionMaybe quotedString+  spaces+  string ">"+  return (DoctypeToken p top avail regEtc uri)+  +entity:: Script s => CharParser [Warning] (Token s)+entity = do+  char '&'+  pos <- getPosition+  name <- many alphaNum <|> (char '#' >> many1 digit)+  when (null name) (warn "no identifer or number after &")+  (char ';' >> return ()) <|> (warn "expected semi-colon after entity") +  return (EntityToken pos name)+  +notScript:: CharParser a Char+notScript = try (char '{' >> notFollowedBy (char '!') >> return '{')++-- Parses raw text, upto an opening angle-bracket ('<').+text:: Script s => CharParser st (Token s)+text = do+  pos  <- getPosition+  cs <- many1 (noneOf "<{" <|> notScript) -- Doesn't consume the terminating angle bracket.+  return (Text pos cs)++-- Strings that are either double-quoted or single-quoted.  Note that HTML+-- strings contain no escape sequences.+quotedString:: CharParser a String+quotedString =+  (char '"' >> manyTill anyChar (char '"')) <|>+  (char '\'' >> manyTill anyChar (char '\'')) <?>+  "quoted string (double-quotes or single quotes)"++-- Parses text to the right of a triple-stick in an inline expression.  We have+-- to ensure that if we read a `!,' it isn't immediately followed by `}.'+initText =+  let notEnd = try (char '!' >> notFollowedBy (char '}') >> return '!')+    in many1 (notEnd <|> noneOf "!")++scriptValue:: Script s => CharParser a (s,String)+scriptValue =+  case parseAttributeScript of+    Nothing -> fail "attribute-script parser not defined"+    (Just parser) -> do string "{!"+                        script <- parser+                        init <- (string "!}" >> return "")  <|> +                                (string "|||" >> initText >>= +                                 (\s -> string "!}" >> return s))+                        return (script,init)++number:: CharParser a String+number = many1 digit++-- +nonquotedAttribute:: CharParser [Warning]  String+nonquotedAttribute = do+  x <- alphaNum <|> oneOf "_"+  xs <- many (noneOf "/*=<>\"\'  \v\f\t\r\n")+  warn $ "non-quoted attribute value: " ++ (x:xs)+  return (x:xs)+++attribute:: Script s => CharParser [Warning] (Html.Attribute SourcePos s)+attribute = do+  pos  <- getPosition+  name <- qname <?> "attribute name"+  spaces+  value <- (do char '='+               spaces+               (liftM Right scriptValue)+                 <|> (liftM Left (quotedString <|> nonquotedAttribute)) +                 <?> "attribute value")+           <|> (return $ Left "") -- Unspecified values are empty values.+  case value of+    (Left v)      -> return $ Html.Attribute name v pos+    (Right (s,d)) -> return $ Html.AttributeExpr pos name s d++-- Takes the name of the immediately-enclosing parent tag as an argument.+tag:: Script s => CharParser [Warning] (Token s)+tag = do+  try (char '<' >> notFollowedBy (char '/'))+  pos <- getPosition+  name <- qname <?>  "opening tag\'s name"+  spaces+  attributes <- (attribute `sepEndBy` spaces)+  (char '>' >> return (Tag pos name attributes False))+    <|> (string "/>" >> return (Tag pos name attributes True))+    <?> "end of tag (i.e. \">\")"+++-- Parses an inline (curly-banged) script, if an inline-script parser has been+-- specified (i.e. not Nothing).  Two-character lookahead for the ``{!,'' after+-- which control is passed to the inline script parser.  Once control returns,+-- the parser expects to see the closing ``!}.''+inlineScript:: Script s => CharParser a (Token s)+inlineScript =+  case parseInlineScript of+    Nothing -> fail "no inline script parser specified." -- TODO: appropriate?+    (Just parser) -> do string "{!" <?> "{! script !}"+                        pos <- getPosition+                        script <- parser+                        spaces+                        init <- (string "!}" >> return "") <|>+                                (string "|||" >> initText >>= +                                 (\s -> string "!}" >> return s))+                        return $ Inline pos script init+++-- Parses a stream of tokens, with a script parser, s and returns values of +-- type a.+type TokenParser s a = GenParser (Token s) [Warning] a++instance Script s => Show (Token s) where+  show = tokenShow++tokenShow token = case token of+  (Text _ s)        -> s+  (EntityToken _ s) -> "&" ++ s ++ ";"+  (EntityInt _ n)   -> "&#" ++ show n ++ ";"+  (Tag _ id attrs closed) -> +    "<" ++ id ++ " ... " ++ closing where+      closing = if closed then "/>" else ">"+  (Script _ s)  -> "/* script body omitted */"+  (Inline _ s _)-> "{! /* script */ !}"+  (EndTag _ id) -> "</" ++ show id ++ ">"+  (Comment _ s) -> "<!-- " ++ show s ++ " -->"+  (DoctypeToken _ top avail desc Nothing) ->+    "<!DOCTYPE " ++ top ++ " " ++ avail ++ " " ++ show desc ++ ">"+  (DoctypeToken _ top avail desc (Just uri)) ->+    "<!DOCTYPE " ++ top ++ " " ++ avail ++ " " ++ show desc ++ " " +      ++ show uri ++ ">" ++tokenPos tok = case tok of+  (Text p _) -> p+  (EntityToken p _) -> p+  (EntityInt p _) -> p+  (Tag p _ _ _) -> p+  (Script p _) -> p+  (Inline p _ _) -> p+  (EndTag p _) -> p+  (Comment p _) -> p+  (DoctypeToken p _ _ _ _) -> p+    +textToken :: Script s => TokenParser s (ParsedHtml s)+textToken = Parsec.token tokenShow tokenPos $ \t -> case t of+  Text _ s -> Just (Html.Text s (tokenPos t))+  otherwise -> Nothing+             +entityToken :: Script s => TokenParser s (ParsedHtml s)+entityToken =+  Parsec.token tokenShow tokenPos+    (\t -> case t of+             (EntityToken p s) -> Just (Html.Text ("&" ++ s ++ ";") p)+             (EntityInt p n) -> Just (Html.Text ("&#" ++ show n ++ ";") p)+             otherwise -> Nothing)+           +commentToken :: Script s => TokenParser s (ParsedHtml s)+commentToken = +  Parsec.token tokenShow tokenPos+    (\t -> case t of+             (Comment _ s) -> Just (Html.Comment s (tokenPos t))+             otherwise -> Nothing)++scriptToken :: Script s => TokenParser s (ParsedHtml s) +scriptToken = +  Parsec.token tokenShow tokenPos+    (\t -> case t of+             (Script p s) -> Just (Html.Script s p)+             otherwise    -> Nothing)++inlineToken :: Script s => TokenParser s (ParsedHtml s)+inlineToken = +  Parsec.token tokenShow tokenPos+    (\t -> case t of+             (Inline p s d) -> Just (Html.InlineScript s p d)+             otherwise    -> Nothing)+             +endToken :: Script s => TokenParser s HtmlId+endToken = +  Parsec.token tokenShow tokenPos+    (\t -> case t of+             (EndTag p s) -> Just s+             otherwise    -> Nothing)++tagToken :: Script s => TokenParser s (Token s)+tagToken = +  Parsec.token tokenShow tokenPos+  (\t -> case t of+           (Tag p id attrs closed) -> Just t+           otherwise               -> Nothing)++doctypeToken :: Script s => TokenParser s (Token s)+doctypeToken = Parsec.token tokenShow tokenPos $ \t -> case t of+  DoctypeToken _ _ _ _ _ -> Just t+  otherwise -> Nothing++--------------------------------------------------------------------------------+-- HTML fragments++-- |An HTML fragment represents an HTML element with a sequence of children.+data HtmlFragment s = Fragment {+  fragmentPosition   :: SourcePos,+  fragmentName       :: HtmlId,+  fragmentAttributes :: [ParsedAttribute s],+  fragmentChildren   :: [ParsedHtml s]+}++closeFragment:: HtmlFragment s -> ParsedHtml s+closeFragment (Fragment p htmlId attrs children) =  +  Html.Element htmlId attrs (reverse children) p++appendChildToFragment child fragment =+  fragment { fragmentChildren = child : (fragmentChildren fragment) }+             +atomic :: Script s => TokenParser s (ParsedHtml s)+atomic =+  textToken <|> commentToken <|> scriptToken <|> inlineToken <|> entityToken+++maybeClose :: Script s => [HtmlFragment s] -> TokenParser s [HtmlFragment s] +maybeClose es = do+  htmlId <- endToken+  let close [] = do +        warn $ "unmatched closing tag \"" ++ htmlId ++ "\"; ignoring"+        return es+      close (e:e2:es) | fragmentName e == htmlId = do+        return $ (appendChildToFragment (closeFragment e) e2) : es+      close (e:e2:es) | otherwise = +        let e2' = appendChildToFragment (closeFragment e) e2+          in close (e2':es)+      close [e] | fragmentName e == htmlId = do+        return [e]+      close [e] | otherwise = do+        warn $ "unmatched closing tag \"" ++ htmlId ++ "\"; ignoring"+        return [e]+    in close es++open :: Script s => [HtmlFragment s] -> TokenParser s [HtmlFragment s]+open [] = fail "PermissiveParser.open: invalid state (1)"+open (e:es) = do+  (Tag p id attrs isClosed) <- tagToken+  case isClosed of+    True -> return $ (appendChildToFragment (Html.Element id attrs [] p) e) : es+    False ->+      case isEmptyElement id of+        True -> do warn $ "empty-element, \"" ++ id +                            ++ "\" was not immediately closed"+                   return $ (appendChildToFragment (Html.Element id attrs [] p)+                               e) : es+        False -> do+          let fragment = Fragment p id attrs []+              -- If we reach the root, simply make 'fragment' a child.+          let insert [root] = [fragment,root]+              -- The <html> element is the only child of the root.  This+              -- catches all other elements and makes them children of <html>.+              insert [html,root] = [fragment,html,root]+              insert (e1:e2:es) | id `isLegalChildOf` (fragmentName e1) =+                fragment:e1:e2:es+              insert (e1:e2:es) | otherwise =+                insert $ (appendChildToFragment (closeFragment e1) e2):es +              insert [] = fail "PermissiveParser.open: invalid state (2)"+          return $ insert (e:es)++structured es = do+  maybeClose es <|> open es++html' :: Script s => [HtmlFragment s] -> TokenParser s [HtmlFragment s]+html' [] = fail "PermissiveParser.html': invalid state (1)"+html' (e:es) =+  (do a <- atomic+      html' $ (appendChildToFragment a e):es) <|>+  (structured (e:es) >>= html') <|>+  (return (e:es))++parseRoot = Fragment (error "parseRoot: position is meaningless") +                     "DOCROOT"  (error "parseRoot: attributes are meaningless")+                     []++html :: Script s => CharParser [Warning] (Html.Html SourcePos s)+html = do+  let parser = do+        -- optional doctypeToken -- ignored+        fragments <- html' [parseRoot]+        case fragments of+          [fragment] -> case closeFragment fragment of +                          Html.Element _ _ (c:_) _ -> do+                            ws <- getState+                            return (ws,head [c])+                          otherwise -> fail "root element not found"+          otherwise -> fail "no root / multiple roots"+  toks <- tokens -- a stream of HTML entities+  pos <- Parsec.getPosition+  warnings <- Parsec.getState+  case Parsec.runParser parser warnings (Parsec.sourceName pos) toks of+    Left e -> fail  $ "unparsable HTML: " ++ (show e)+    Right (ws,html) -> Parsec.setState ws >> return html ++htmlWithWarnings :: Script s +                 => CharParser [Warning] (Html.Html SourcePos s,[Warning])+htmlWithWarnings = do+  h <- html+  ws <- getState+  return (h,ws)++parseHtmlFromString :: Script s => String -> String -> Either Parsec.ParseError (Html.Html SourcePos s,[Warning])+parseHtmlFromString sourceName sourceText = +  case Parsec.runParser htmlWithWarnings noWarnings sourceName sourceText of+    Left err -> Left err+    Right (html,ws) -> Right (html,ws) ++parseHtmlFromFile :: Script s +                  => String +                  -> IO (Either Parsec.ParseError +                                (Html.Html SourcePos s,[Warning]))+parseHtmlFromFile filename = do+  chars <- readFile filename+  case Parsec.runParser htmlWithWarnings noWarnings filename chars of+    Left err -> return (Left err)+    Right (html,ws) -> return $ Right (html,ws)
+ src/WebBits/Html/PrettyPrint.hs view
@@ -0,0 +1,54 @@+-- |Pretty-printer for HTML.  This modules exports no names.  It only defines+-- instances of 'PrettyPrintable' for HTML. +module WebBits.Html.PrettyPrint+  ( -- this module exports no names+  ) where++import qualified Data.List as List+import qualified Data.Char as Char+import Text.PrettyPrint.HughesPJ++import WebBits.Common (PrettyPrintable(..))++import WebBits.Html.Syntax++vert [] = empty+vert [doc] = doc+vert (doc:docs) = doc <> text "<!--" $+$+                  text "-->" <> vert docs++instance PrettyPrintable s => PrettyPrintable (Attribute a s) where+  pp (Attribute name value _) =+    text name <> equals <> doubleQuotes (text value)+  pp (AttributeExpr _ n v "") =+    text n <> equals <> text "{!" <+> pp v <+> text "!}"+  pp (AttributeExpr _ n v d) =+    text n <> equals <> text "{!" <+> pp v <+> text "|||" <+> text d +      <+> text "!}"++instance PrettyPrintable s => PrettyPrintable (Html a s) where+  -- The <script> tag must be terminated by </script>.+  -- <script lang= src= /> doesn't work.+  -- pp (Element name attrs [] _) =+  --   text "<" <> text name <+> hsep (map pp attrs) <+> text "/>"+  pp (Element name attrs children _) =+    -- WARNING: Spacing is very sensitive+    text "<" <> text name <+> hsep (map pp attrs) <> text ">"  -- opening+      $$ (nest 2 (vcat (map pp children)))                     -- body+      $$ text "</" <> text name <> text ">"                    -- closing+  -- Horizontally aligned material that is vertically represented in source.+  pp (HtmlSeq xs) = vert (map pp xs)+  pp (Text str _) =+    text (skipWs str) where+      skipWs str = List.dropWhile Char.isSpace str+  pp (Comment str _) =+    text "<!--" <+> text str <+> text "-->"+  pp (ProcessingInstruction str _) =+    text "<?" <> text str <> text ">"+  pp (Script script _) =+    pp script+  pp (InlineScript script _ "") =+    text "{!" <+> pp script <+> text "!}"+  pp (InlineScript script _ init) =+    text "{!" <+> pp script <+> text "|||" <+> text init <+> text "!}"+
+ src/WebBits/Html/RawScript.hs view
@@ -0,0 +1,34 @@+module WebBits.Html.RawScript+  ( RawScript (..)+  , parseFromFile+  , parseFromString+  , RawHtml+  ) where++import Data.Generics (Data)+import Data.Generics (Typeable)+import Text.PrettyPrint.HughesPJ (text)+import Text.ParserCombinators.Parsec+import WebBits.Common+import WebBits.Html.Html++type RawHtml = Html SourcePos RawScript++data RawScript = RawScript String deriving (Show,Eq,Typeable,Data)++instance Script RawScript where+  parseInlineScript = Nothing+  +  parseAttributeScript = Nothing+  +  parseScriptBlock _ = do+    s <- manyTill anyChar (string "</script>")+    return (RawScript s)+    +instance PrettyPrintable RawScript where+  pp (RawScript s) = text s++parseFromString :: String -> RawHtml+parseFromString s = case parseHtmlFromString "" s of+  Left e -> error (show e)+  Right (html,_) -> html
+ src/WebBits/Html/Syntax.hs view
@@ -0,0 +1,84 @@+-- |Datatypes for HTML parameterized over an annotation type and a script type.
+module WebBits.Html.Syntax (
+  -- * HTML Data Structures
+    HtmlId,AttributeValue,Attribute(..),Html(..)
+  -- * The Script class
+  , Script(..)
+  -- * Miscellaneous Functions
+  , attributeValue,attributeUpdate,attributeSet,isAttributeExpr
+  ) where
+
+import Text.ParserCombinators.Parsec(CharParser,SourcePos)
+import Data.Generics(Data)
+import Data.Typeable(Typeable)
+
+--------------------------------------------------------------------------------
+-- Types
+
+type HtmlId = String
+type AttributeValue = String
+
+data Attribute a s
+  = Attribute HtmlId AttributeValue a
+  | AttributeExpr a HtmlId s String
+  deriving (Show,Eq,Typeable,Data)
+
+data Html a sc
+  = Element HtmlId [Attribute a sc] [Html a sc] a
+  | Text String a
+  | Comment String a
+  | HtmlSeq [Html a sc] -- ^must be a non-empty list
+  | ProcessingInstruction String a
+  | InlineScript sc a String
+  | Script sc a
+  deriving (Show,Eq,Typeable,Data)
+  
+--------------------------------------------------------------------------------
+-- The Script class
+
+-- |A type 't' of the 'Script' class can be parsed using 'Parsec'.  't' is of
+-- kind '* -> *', as the parsed AST should be annotated with souce locations
+-- (see 'Text.ParserCombinators.Parsec.SourcePos').
+--
+-- The big deal here is that we can embed a parser for some scripting language,
+-- (e.g. Javascript) into this HTML parser with ease, while preserving source
+-- locations.  The Html datatype is parameterized over a script parser (an
+-- instance of Script).
+class Script t where
+  parseScriptBlock:: [Attribute SourcePos t] -> CharParser a t
+  -- An inline script parser, which may be Nothing if the scripting language
+  -- does not support inline scripts.
+  parseInlineScript:: Maybe (CharParser a t)
+  -- A parser for script-expressions defined inline as attribute values.
+  parseAttributeScript:: Maybe (CharParser a t)
+  
+--------------------------------------------------------------------------------
+-- HTML navigation
+
+isAttributeExpr (AttributeExpr _ _ _ _) = True
+isAttributeExpr _                       = False
+
+-- |Returns the value of the attribute in the list, or 'Nothing' if it doesn't
+-- exist of the value is an inline-expression.
+attributeValue:: HtmlId -> [Attribute a s] -> Maybe String
+attributeValue name [] = Nothing
+attributeValue name ((AttributeExpr pos name' expr init):rest) =
+  if name == name' then Nothing
+                   else attributeValue name rest
+attributeValue name ((Attribute name' value _):rest) =
+  if name == name' then Just value
+                   else attributeValue name rest
+
+attributeSet:: HtmlId -> String -> [Attribute a s]  -> [Attribute a s]
+attributeSet n v attrs = attributeUpdate n (\_ -> v) attrs
+
+attributeUpdate:: HtmlId -> (String -> String) -> [Attribute a s] 
+               -> [Attribute a s]
+attributeUpdate n f [] = 
+  [Attribute n (f "") (error "attributeUpdate--no value")] -- TODO: undefined?!
+attributeUpdate n _ ((AttributeExpr _ _ _ _):_) =
+  error $ "attributeUpdate: " ++ n ++ " is an expression-attribute."
+attributeUpdate n f ((Attribute n' v p):attrs) =
+  if n' == n then (Attribute n (f v) p):attrs
+             else (Attribute n' v p):(attributeUpdate n f attrs)
+
+ src/WebBits/JavaScript/Combinators.hs view
@@ -0,0 +1,39 @@+module WebBits.JavaScript.Combinators +  ( scriptStatements+  , isParenExpr+  , syntaxAt+  , expressionsAt+  , statementsAt+  ) where++import Data.Generics (Data,Typeable, everything, mkQ)+import Text.ParserCombinators.Parsec (SourcePos)+import qualified Data.Foldable as F+import Data.Foldable (Foldable)+import WebBits.JavaScript.Syntax+import WebBits.JavaScript.Instances ()+import WebBits.Common () ++scriptStatements:: JavaScript a -> [Statement a]+scriptStatements (Script _ ss) = ss++isParenExpr (ParenExpr _ _) = True+isParenExpr _               = False++syntaxAt :: (Data a, Typeable a, Data (t SourcePos), +             Typeable (t SourcePos), Foldable t)+         => SourcePos -> a -> [t SourcePos]+syntaxAt pos a = everything (++) (mkQ [] isMatch) a where+  isMatch stx = case F.find (const True) stx of+    Nothing -> []+    Just pos' | pos == pos' -> [stx]+              | otherwise   -> []++expressionsAt :: (Data a, Typeable a) +              => SourcePos -> a -> [Expression SourcePos]+expressionsAt = syntaxAt++statementsAt :: (Data a, Typeable a) +              => SourcePos -> a -> [Statement SourcePos]+statementsAt = syntaxAt+
+ src/WebBits/JavaScript/Crawl.hs view
@@ -0,0 +1,80 @@+-- |Crawls an HTML page for JavaScript+module WebBits.JavaScript.Crawl +  ( getPageJavaScript+  ) where++import WebBits.Common+import Control.Monad+import Data.Char (toLower)+import Data.Generics+import System.IO+import Text.ParserCombinators.Parsec(parse,setPosition,incSourceColumn,Column,sourceLine,sourceColumn)++import WebBits.Html.Syntax+import qualified WebBits.JavaScript.JavaScript as Js++-- |Returns the source of the script.+scriptSrc:: Js.ParsedJsHtml -> [String]+scriptSrc (Element tag attrs _ _) | (map toLower tag) == "script" =+  case attributeValue "src" attrs of -- TODO: Check for type="javascript"?+    Just ""  -> []+    Just url -> [url]+    Nothing  -> []+scriptSrc _ =+  []++-- |Returns a list of URIs for external Javascript files referenced in the page.+importedScripts:: Js.ParsedJsHtml -> [String]+importedScripts = everything (++) (mkQ [] scriptSrc)++-- |Returns the top-level statements of a script.+scriptText :: Js.ParsedJsHtml -> [Js.ParsedStatement]+scriptText (Script (Js.Script _ stmts) _) = stmts+scriptText _ = []++eventHandlers :: [String]+eventHandlers = ["onload","onclick"]; +-- ,"onmousemove","onmouseover","onmousedown","onmouseout","onmouseup","onselectstart", "onkeypress"]++attrScript :: Attribute SourcePos Js.ParsedJavaScript +           -> IO [Js.ParsedStatement]+attrScript (Attribute id val loc) | id `elem` eventHandlers = do+  let eventId = drop 2 id -- drop the "on" prefix+  let scriptText = if "javascript:" `isPrefixOf` val then drop 11 val else val+  let eventListenerPrefix = "addEventListener('" ++ eventId ++ "', function(event) { "+  let prefixLen = length eventListenerPrefix+  let eventListenerText = eventListenerPrefix ++ scriptText ++ " });"+  let parser = do+        setPosition (incSourceColumn loc (-prefixLen))+        Js.parseExpression+  case parse parser (sourceName loc) eventListenerText of+    Left err -> do+      fail $ "Error parsiing JavaScript in an attribute at " ++ show loc +++             "\nThe script was:\n\n" ++ eventListenerText+    Right e -> return [Js.ExprStmt loc e]+attrScript _ = return []++inpageAttrScripts :: Js.ParsedJsHtml -> IO [Js.ParsedStatement]+inpageAttrScripts = everything (liftM2 (++)) (mkQ (return []) attrScript)++inpageScripts :: Js.ParsedJsHtml -> [Js.ParsedStatement]+inpageScripts = everything (++) (mkQ [] scriptText)++parseJsFile path = do+  text <- readFile path+  case Js.parseScriptFromString path text of+    Left err -> fail (show err)+    Right js -> hPutStrLn stderr ("Read file " ++ path) >> return js++-- |Given an HTML page, crawls all external Javascript files and returns a list+-- of statements, concatenated from all files.+getPageJavascript:: Js.ParsedJsHtml -> IO [Js.ParsedStatement]+getPageJavascript page = do+  let importURIs = importedScripts page+  let inpageJs   = inpageScripts page+  attrScripts <- inpageAttrScripts page+  importedScripts <- mapM parseJsFile importURIs+  return $ (concatMap Js.scriptStatements importedScripts ++ attrScripts) ++ inpageJs++getPageJavaScript:: Js.ParsedJsHtml -> IO [Js.ParsedStatement] -- monomorphism+getPageJavaScript = getPageJavascript
+ src/WebBits/JavaScript/Environment.hs view
@@ -0,0 +1,282 @@+module WebBits.JavaScript.Environment +  ( staticEnvironment+  , Ann+  , LabelledStatement+  , LabelledExpression+  , Env+  ) where++import Data.Generics hiding (GT)+import Data.Maybe (fromJust)+import qualified Data.Set as S+import WebBits.Data.Zipper (ZipperT,ZipperT)+import qualified Data.Map as M+import qualified WebBits.Data.Zipper as Z+import Control.Monad.State+import qualified Data.Foldable as F+import qualified Data.List as L+import WebBits.JavaScript.JavaScript+import Text.ParserCombinators.Parsec.Pos (SourcePos,initialPos)++---+-- Add `this' and `arguments' to the formal parameters of all +-- functions +--+-- TODO: Does a local var x shadow a formal argument x?  What about 'arguments'?++thisStmt :: Statement SourcePos -> Statement SourcePos+thisStmt (FunctionStmt loc id args body) = +  FunctionStmt loc id ((Id loc "this"):(Id loc "arguments"):args) body+thisStmt s = s++thisExpr :: Expression SourcePos -> Expression SourcePos+thisExpr (FuncExpr l args s) = +  FuncExpr l ((Id l "this"):(Id l "arguments"):args) s+thisExpr e = e++removeParens :: Expression SourcePos -> Expression SourcePos+removeParens (ParenExpr _ e) = e+removeParens e = e++removeSingletons :: Expression SourcePos -> Expression SourcePos+removeSingletons (ListExpr _ [e]) = e+removeSingletons e = e++explicitThis :: [Statement SourcePos] -> [Statement SourcePos]+explicitThis = everywhere $ (mkT removeSingletons) . (mkT removeParens) +  . (mkT thisExpr) . (mkT thisStmt)++-- JavaScript has a global and function scopes.  Globals do not need to be+-- declared.  Any "unbound identifier" in a function is treated as a reference+-- to a global.++-- For each FunctionExpr and FunctionStmt, we create a list of locally defined+-- identifiers (var x = ...) and free identifiers.++-- We build a tree of "partial environments."  Since a variable may be used+-- before it is declared locally, we maintain a set of free identifiers and+-- narrow the set when appropriate.+type PartialEnv = (Env,S.Set String)++type Env = M.Map String Int++emptyPartialEnv :: PartialEnv+emptyPartialEnv = (M.empty,S.empty)++type RefM a = Z.ZipperT PartialEnv (State Int) a++nextLabel :: (MonadTrans t, Monad (t (State Int))) => t (State Int) Int+nextLabel = do+  l <- lift get+  lift $ modify (+1)+  return l +  +bind :: Id SourcePos -> RefM ()+bind (Id _ s) = do+  lbl <- nextLabel+  (env,freeIds) <- Z.getNode+  Z.setNode (M.insert s lbl env, S.delete s freeIds)+  +use :: Id SourcePos -> RefM ()+use (Id _ s) = do+  (env,freeIds) <- Z.getNode+  case M.lookup s env of+    Just _ -> return ()+    Nothing -> Z.setNode (env, S.insert s freeIds)+  ++buildExpr :: Expression SourcePos -> RefM (Expression SourcePos)+buildExpr (FuncExpr loc args stmt) = do+  stmt' <- Z.nest emptyPartialEnv (mapM_ bind args >> buildStmt stmt)+  return (FuncExpr loc args stmt')+buildExpr e@(VarRef _ id) = do+  use id+  return e+buildExpr (AssignExpr loc op (VarRef loc' id) e) = do+  use id+  e' <- buildExpr e+  return (AssignExpr loc op (VarRef loc' id) e')+buildExpr e =+  gmapM buildAny e++buildCatchClause :: CatchClause SourcePos -> RefM (CatchClause SourcePos)+buildCatchClause (CatchClause loc id stmt) = do+  bind id+  stmt' <- buildStmt stmt+  return (CatchClause loc id stmt')+  +buildVarDecl :: VarDecl SourcePos -> RefM (VarDecl SourcePos)+buildVarDecl (VarDecl loc id ye) = do+  bind id+  ye' <- gmapM buildAny ye+  return (VarDecl loc id ye')++buildForInInit :: ForInInit SourcePos -> RefM (ForInInit SourcePos)+buildForInInit e@(ForInVar id) = do+  bind id+  return e+buildForInInit e@(ForInNoVar id) = do+  use id+  return e+  +buildStmt :: Statement SourcePos -> RefM (Statement SourcePos)+buildStmt (FunctionStmt loc id args stmt) = do+  stmt' <- Z.nest emptyPartialEnv (mapM_ bind args >> buildStmt stmt)+  return (FunctionStmt loc id args stmt')+buildStmt s = gmapM buildAny s++buildAny' :: (Data a, Typeable a) => a -> RefM a+buildAny' v = gmapM buildAny v++buildAny :: GenericM RefM+buildAny =+  buildAny' `extM` buildExpr `extM` buildCatchClause `extM`+    buildVarDecl `extM` buildForInInit `extM` buildStmt++--+-- buildAny creates a tree of partial environments.  We now walk the tree and+-- attempt to associate free identifiers with their bindings in enclosing+-- scopes.  Any remaining free identifiers are globals.+--++resolveFreeId :: Env -> String -> StateT Env (State Int) Env+resolveFreeId env freeId = case M.lookup freeId env of+  Just lbl -> return env -- the free identifier was bound in an enclosing env+  Nothing  -> do -- this is a global +    globals <- get+    case M.lookup freeId globals of+      Just lbl -> return (M.insert freeId lbl env) -- global already bound+      Nothing -> do -- new global+        lbl <- nextLabel+        put (M.insert freeId lbl globals)+        return (M.insert freeId lbl env)+++completeEnvM' :: Z.Tree PartialEnv -> StateT Env (State Int) (Z.Tree Env)+completeEnvM' pt = Z.dfsFoldM f M.empty pt where+  -- the union is left-biased; bindings in env shadow bindings in enclosingEnv+  f enclosingEnv (env,freeIds) = +    foldM resolveFreeId (M.union env enclosingEnv) (S.elems freeIds) ++completeEnvM :: Z.Tree PartialEnv -> StateT Env (State Int) (Z.Tree Env)+completeEnvM pt = do+  tree <- completeEnvM' pt+  globals <- get+  -- left-biased union: lexicals shadow globals+  return (fmap (\lexicals -> M.union lexicals globals) tree)++--+-- completeEnvM creates a tree of environments whose structure is identical to+-- the function-nesting structure of the JavaScript source.  We walk the tree+-- and the code in step and annotate the code with environments.+--++type Ann = (Env,Int,SourcePos)++type LabelledStatement = Statement Ann+type LabelledExpression = Expression Ann++-- Necessary for type-checking.  gmapM won't let us transform the type of the+-- annotation.  So, we first inject SourcePos into a trivial Ann.+insertEmptyAnn :: (Functor f) => f SourcePos -> f Ann+insertEmptyAnn = fmap (\loc -> (M.empty,0,loc))+++locOf :: F.Foldable t => t SourcePos -> SourcePos+locOf = fromJust . (F.find $ const True)++labelEnv :: Env -> Z.ZipperT Env (State Int) Env+labelEnv env = Z.getNode++labelId :: Id Ann -> Z.ZipperT Env (State Int) (Id Ann)+labelId id@(Id (_,_,loc) s) = do+  env <- Z.getNode+  case M.lookup s env of+    Nothing -> fail $ "BUG: unbound identifier while labelling" ++ show id+    Just lbl -> return (Id (env,lbl,loc) s)+    +labelIdNoVar :: Id Ann -> Z.ZipperT Env (State Int) (Id Ann)+labelIdNoVar (Id (_,_,loc) s) = do+  env <- Z.getNode+  lbl <- nextLabel+  return (Id (env,lbl,loc) s)++labelProp :: Prop Ann -> Z.ZipperT Env (State Int) (Prop Ann)+labelProp (PropId (_,_,loc) id) = do+  env <- Z.getNode+  lbl <- nextLabel+  id' <- labelIdNoVar id+  return (PropId (env,lbl,loc) id')+labelProp e = gmapM labelAny e++labelExpr :: Expression Ann +          -> Z.ZipperT Env (State Int) (Expression Ann)+labelExpr (ThisRef (_,_,loc)) = do+  env <- Z.getNode+  lbl <- M.lookup "this" env+  return (ThisRef (env,lbl,loc))+labelExpr (DotRef (_,_,loc) expr id) = do+  env <- Z.getNode+  lbl <- nextLabel+  id' <- labelIdNoVar id+  expr' <- labelExpr expr+  return (DotRef (env,lbl,loc) expr' id')+labelExpr (FuncExpr (_,_,loc) args stmt) = do+  env <- Z.getNode+  lbl <- nextLabel+  args' <- Z.withCurrentChild (mapM labelId args)+  stmt' <- Z.withCurrentChild (labelStmt stmt)+  Z.shiftRight'+  return (FuncExpr (env,lbl,loc) args' stmt')+labelExpr e = gmapM labelAny e+  +labelStmt :: Statement Ann+          -> Z.ZipperT Env (State Int) (Statement Ann)+labelStmt (BreakStmt (_,_,loc) (Just id)) = do+  env <- Z.getNode+  lbl <- nextLabel+  id' <- labelIdNoVar id+  return (BreakStmt (env,lbl,loc) (Just id'))+labelStmt (ContinueStmt (_,_,loc) (Just id)) = do+  env <- Z.getNode+  lbl <- nextLabel+  id' <- labelIdNoVar id+  return (ContinueStmt (env,lbl,loc) (Just id'))+labelStmt (LabelledStmt (_,_,loc) id stmt) = do+  env <- Z.getNode+  lbl <- nextLabel+  id' <- labelIdNoVar id+  stmt' <- labelStmt stmt+  return (LabelledStmt (env,lbl,loc) id' stmt')  +labelStmt (FunctionStmt (_,_,loc) id args stmt) = do+  env <- Z.getNode+  lbl <- nextLabel+  args' <- Z.withCurrentChild (mapM labelId args)+  stmt' <- Z.withCurrentChild (labelStmt stmt)+  Z.shiftRight'+  return (FunctionStmt (env,lbl,loc) id args' stmt')+labelStmt e = gmapM labelAny e++labelAny' :: (Data a, Typeable a) => a -> Z.ZipperT Env (State Int) a+labelAny' a = gmapM labelAny a++labelAny :: GenericM (Z.ZipperT Env (State Int)) +labelAny a = (labelAny' `extM` labelEnv `extM` labelId `extM` labelProp `extM`+  labelExpr `extM` labelStmt) a++-- |Annotates each expression with its static environment.  In addition,+-- a map of free identifiers is returned, along with the next valid label.+staticEnvironment :: [Statement SourcePos] +                  -> ([Statement Ann],Env,Int)+staticEnvironment stmts =+  let stmts' = explicitThis stmts+      labelM = do+        partialEnvTree <- Z.execZipperT (mapM buildStmt stmts')+                            (Z.toLocation (Z.Node emptyPartialEnv []))+        (envTree,globals) <- runStateT (completeEnvM partialEnvTree) M.empty+        let stmts'' = map insertEmptyAnn stmts' +        labelledStmts <- Z.evalZipperT (mapM labelStmt stmts'') +                                       (Z.toLocation envTree)+        return (labelledStmts,globals)+      ((labelledStmts,globals),nextLabel) = runState labelM 0+    in (labelledStmts,globals,nextLabel)
+ src/WebBits/JavaScript/HtmlEmbedding.hs view
@@ -0,0 +1,26 @@+module WebBits.JavaScript.HtmlEmbedding+  ( JsHtml+  , ParsedJavaScript+  , ParsedJsHtml+  ) where++import WebBits.Html.Syntax(Html,Script,parseScriptBlock,parseInlineScript,+                   parseAttributeScript)+import WebBits.JavaScript.Parser(parseScript)+import WebBits.JavaScript.Syntax(JavaScript)+--import JavaScript.PrettyPrint -- for the instance declaration+import Text.ParserCombinators.Parsec (SourcePos)++type JsHtml a = Html SourcePos (JavaScript a)++type ParsedJavaScript = JavaScript SourcePos++type ParsedJsHtml = JsHtml SourcePos++instance Script ParsedJavaScript where+  parseScriptBlock attrs = do+    parseScript+  parseInlineScript = Nothing+  parseAttributeScript = Nothing+    +
+ src/WebBits/JavaScript/Instances.hs view
@@ -0,0 +1,291 @@+-- |Instances of 'Foldable' and 'Traversable' for JavaScript's syntax.+module WebBits.JavaScript.Instances+  ( -- This module does not export any names.+  ) where++import Prelude hiding (foldr,sequence,mapM)+import qualified Prelude as Prelude++import Data.Foldable (Foldable(..))+import Data.Traversable(Traversable(..))+import Control.Applicative++import WebBits.JavaScript.Syntax++yfoldr:: Foldable t => (a -> b -> b) -> b -> Maybe (t a) -> b+yfoldr _ b Nothing = b+yfoldr f b (Just t) = foldr f b t++lfoldr:: Foldable t => (a -> b -> b) -> b -> [t a] -> b+lfoldr f = Prelude.foldr (flip $ foldr f)++ltraverse:: (Traversable t, Applicative f) => (a -> f b) -> [t a] -> f [t b]+ltraverse _ [] = pure []+ltraverse f (a:as) = (:) <$> traverse f a <*> ltraverse f as++ytraverse:: (Traversable t, Applicative f) +         => (a -> f b) -> Maybe (t a) -> f (Maybe (t b))+ytraverse _ Nothing = pure Nothing+ytraverse f (Just t) = Just <$> traverse f t++instance Functor Id where+  fmap f (Id a v) = Id (f a) v++instance Functor JavaScript where+  fmap f (Script a stmts) = Script (f a) (map (fmap f) stmts)+  +instance Functor Prop where+  fmap f (PropId a id) = PropId (f a) (fmap f id)+  fmap f (PropString a s) = PropString (f a) s+  fmap f (PropNum a n) = PropNum (f a) n++instance Functor Expression where+  fmap f expression = +    case expression of+      StringLit a s -> StringLit (f a) s+      RegexpLit a s g ci -> RegexpLit (f a) s g ci+      NumLit a n -> NumLit (f a) n+      BoolLit a b -> BoolLit (f a) b+      NullLit a -> NullLit (f a)+      ArrayLit a es -> ArrayLit (f a) (map (fmap f) es)+      ObjectLit a pes -> ObjectLit (f a) (map f' pes) where+        f' (p,e) = (fmap f p, fmap f e)+      ThisRef a -> ThisRef (f a)+      VarRef a id -> VarRef (f a) (fmap f id)+      DotRef a e id -> DotRef (f a) (fmap f e) (fmap f id)+      BracketRef a e1 e2 -> BracketRef (f a) (fmap f e1) (fmap f e2)+      NewExpr a e es -> NewExpr (f a) (fmap f e) (map (fmap f) es)+      PostfixExpr a op e -> PostfixExpr (f a) op (fmap f e)+      PrefixExpr a op e -> PrefixExpr (f a) op (fmap f e)+      InfixExpr a op e1 e2 -> InfixExpr (f a) op (fmap f e1) (fmap f e2)+      CondExpr a e1 e2 e3 -> CondExpr (f a) (fmap f e1) (fmap f e2) (fmap f e3)+      AssignExpr a op e1 e2 -> AssignExpr (f a) op (fmap f e1) (fmap f e2)+      ParenExpr a e -> ParenExpr (f a) (fmap f e)+      ListExpr a es -> ListExpr (f a) (map (fmap f) es)+      CallExpr a e es -> CallExpr (f a) (fmap f e) (map (fmap f) es)+      FuncExpr a args s -> FuncExpr (f a) (map (fmap f) args) (fmap f s)++instance Functor CaseClause where+  fmap f (CaseClause a e ss) = CaseClause (f a) (fmap f e) (map (fmap f) ss)+  fmap f (CaseDefault a ss) = CaseDefault (f a) (map (fmap f) ss)+  +instance Functor CatchClause where+  fmap f (CatchClause a id s) = CatchClause (f a) (fmap f id) (fmap f s)++instance Functor VarDecl where+  fmap f (VarDecl a id Nothing) = VarDecl (f a) (fmap f id) Nothing+  fmap f (VarDecl a id (Just e)) = VarDecl (f a) (fmap f id) (Just $ fmap f e)+  +instance Functor ForInit where+  fmap f NoInit = NoInit+  fmap f (VarInit decls) = VarInit (map (fmap f) decls)+  fmap f (ExprInit e) = ExprInit (fmap f e)++instance Functor ForInInit where+  fmap f (ForInVar id) = ForInVar (fmap f id)+  fmap f (ForInNoVar id) = ForInNoVar (fmap f id)+  +instance Functor Statement where+  fmap f s = +    case s of+      BlockStmt a ss -> BlockStmt (f a) (map (fmap f) ss)+      EmptyStmt a -> EmptyStmt (f a)+      ExprStmt a e -> ExprStmt (f a) (fmap f e)+      IfStmt a e s1 s2 -> IfStmt (f a) (fmap f e) (fmap f s1) (fmap f s2)+      IfSingleStmt a e s -> IfSingleStmt (f a) (fmap f e) (fmap f s)+      SwitchStmt a e cs -> SwitchStmt (f a) (fmap f e) (map (fmap f) cs)+      WhileStmt a e s -> WhileStmt (f a) (fmap f e) (fmap f s)+      DoWhileStmt a s e -> DoWhileStmt (f a) (fmap f s) (fmap f e)+      BreakStmt a Nothing -> BreakStmt (f a) Nothing+      BreakStmt a (Just id) -> BreakStmt (f a) (Just (fmap f id))+      ContinueStmt a yid -> ContinueStmt (f a) (yid >>= return.(fmap f))+      LabelledStmt a id s -> LabelledStmt (f a) (fmap f id) (fmap f s)+      ForInStmt a init e s -> ForInStmt (f a) (fmap f init) (fmap f e)+                                (fmap f s)+      ForStmt a init yinc ytest body -> +        ForStmt (f a) (fmap f init) (yinc >>= return.(fmap f))+          (ytest >>= return.(fmap f)) (fmap f body)+      TryStmt a s cs ys -> +        TryStmt (f a) (fmap f s) (map (fmap f) cs) (ys >>= return.(fmap f))+      ThrowStmt a e -> ThrowStmt (f a) (fmap f e)+      ReturnStmt a ye -> ReturnStmt (f a) (ye >>= return.(fmap f))+      WithStmt a e s -> WithStmt (f a) (fmap f e) (fmap f s)+      VarDeclStmt a ds -> VarDeclStmt (f a) (map (fmap f) ds)+      FunctionStmt a id args s -> +        FunctionStmt (f a) (fmap f id) (map (fmap f) args) (fmap f s)++instance Foldable Id where+  foldr f b (Id a _) = f a b++instance Foldable Prop where+  foldr f b (PropId a id) = f a (foldr f b id)+  foldr f b (PropString a _) = f a b+  foldr f b (PropNum a _) = f a b+        +instance Foldable Expression where+  -- foldr:: (a -> b -> b) -> b -> Expression a -> b+  foldr f b e =+    case e of+      StringLit a _ -> f a b+      RegexpLit a _ _ _ -> f a b+      NumLit a _ -> f a b+      BoolLit a _ -> f a b+      NullLit a -> f a b+      ArrayLit a es -> f a (Prelude.foldr (flip $ foldr f) b es)+      ObjectLit a pes -> f a (Prelude.foldr f' b pes) where+        f' (p,e) b = foldr f (foldr f b e) p+      ThisRef a -> f a b+      VarRef a id -> f a (foldr f b id)+      DotRef a e id -> f a (foldr f (foldr f b id) e)+      BracketRef a e1 e2 -> f a (foldr f (foldr f b e2) e1)+      NewExpr a e es -> f a (foldr f (Prelude.foldr (flip $ foldr f) b es) e)+      PostfixExpr a _ e -> f a $ foldr f b e+      PrefixExpr a _ e -> f a $ foldr f b e+      InfixExpr a _ e1 e2 -> f a $ foldr f (foldr f b e2) e1+      CondExpr a e1 e2 e3 -> f a $ foldr f (foldr f (foldr f b e3) e2) e1+      AssignExpr a _ e1 e2 -> f a $ foldr f (foldr f b e2) e1+      ParenExpr a e -> f a $ foldr f b e+      ListExpr a es -> f a $ Prelude.foldr (flip $ foldr f) b es+      CallExpr a e es -> f a $ foldr f (Prelude.foldr (flip $ foldr f) b es) e+      FuncExpr a args s -> +        f a $ Prelude.foldr (flip $ foldr f) (foldr f b s) args++instance Foldable CaseClause where+  foldr f b (CaseClause a e ss) = +    f a $ foldr f (Prelude.foldr (flip $ foldr f) b ss) e+  foldr f b (CaseDefault a ss) = f a $ Prelude.foldr (flip $ foldr f) b ss+  +instance Foldable CatchClause where+  foldr f b (CatchClause a id s) = f a $ foldr f (foldr f b s) id++instance Foldable VarDecl where+  foldr f b (VarDecl a id ye) = f a $ foldr f (yfoldr f b ye) id++instance Foldable ForInit where+  foldr f b NoInit = b+  foldr f b (VarInit ds) = Prelude.foldr (flip $ foldr f) b ds+  foldr f b (ExprInit e) = foldr f b e++instance Foldable ForInInit where+ foldr f b (ForInVar id) = foldr f b id+ foldr f b (ForInNoVar id) = foldr f b id++instance Foldable Statement where+  foldr f b statement =+    case statement of+      BlockStmt a ss -> f a $ lfoldr f b ss+      EmptyStmt a -> f a b+      ExprStmt a e -> f a $ foldr f b e+      IfStmt a e s1 s2 -> f a $ foldr f (foldr f (foldr f b s2) s1) e+      IfSingleStmt a e s -> f a $ foldr f (foldr f b s) e+      SwitchStmt a e cs -> f a $ foldr f (lfoldr f b cs) e+      WhileStmt a e s -> f a $ foldr f (foldr f b s) e+      DoWhileStmt a s e -> f a $ foldr f (foldr f b e) s+      BreakStmt a yid -> f a $ yfoldr f b yid+      ContinueStmt a yid -> f a $ yfoldr f b yid+      LabelledStmt a id s -> f a $ foldr f (foldr f b s) id+      ForInStmt a init e s -> f a $ foldr f (foldr f (foldr f b s) e) init+      ForStmt a init ye1 ye2 s ->+        f a $ foldr f (yfoldr f (yfoldr f (foldr f b s) ye2) ye1) init+      TryStmt a s cs ys -> f a $ foldr f (lfoldr f (yfoldr f b ys) cs) s+      ThrowStmt a e -> f a $ foldr f b e+      ReturnStmt a ys -> f a $ yfoldr f b ys+      WithStmt a e s -> f a $ foldr f (foldr f b s) e+      VarDeclStmt a ds -> f a $ lfoldr f b ds+      FunctionStmt a id args s ->+        f a $ lfoldr f (foldr f b s) (id:args)++instance Traversable Id where+  traverse f (Id a v) = Id <$> f a <*> pure v++instance Traversable Prop where+  traverse f (PropId a id) = PropId <$> f a <*> traverse f id+  traverse f (PropString a s) = PropString <$> f a <*> pure s+  traverse f (PropNum a n) = PropNum <$> f a <*> pure n+  +instance Traversable Expression where+  traverse f expression =+    case expression of+      StringLit a s -> StringLit <$> f a <*> pure s+      RegexpLit a s g ci -> RegexpLit <$> f a <*> pure s <*> pure g <*> pure ci+      NumLit a n -> NumLit <$> f a <*> pure n+      BoolLit a b -> BoolLit <$> f a <*> pure b+      NullLit a -> NullLit <$> f a+      ArrayLit a es -> ArrayLit <$> f a <*> ltraverse f es+      ObjectLit a ps -> ObjectLit <$> f a <*>  (zip <$> props' <*> es') where+        (props,es) = unzip ps+        props' = ltraverse f props+        es' = ltraverse f es+      ThisRef a -> ThisRef <$> f a+      VarRef a id -> VarRef <$> f a <*> traverse f id+      DotRef a e id -> DotRef <$> f a <*> traverse f e <*> traverse f id+      BracketRef a e es -> BracketRef <$> f a <*> traverse f e <*> traverse f es+      NewExpr a e es -> NewExpr <$> f a <*> traverse f e <*> ltraverse f es+      PostfixExpr a op e -> PostfixExpr <$> f a <*> pure op <*> traverse f e+      PrefixExpr a op e -> PrefixExpr <$> f a <*> pure op <*> traverse f e+      InfixExpr a op e1 e2 -> InfixExpr <$> f a <*> pure op <*> traverse f e1+                                <*> traverse f e2+      CondExpr a e1 e2 e3 ->+        CondExpr <$> f a <*> traverse f e1 <*> traverse f e2 <*> traverse f e3+      AssignExpr a op e1 e2 -> AssignExpr <$> f a <*> pure op <*> traverse f e1+        <*> traverse f e2+      ParenExpr a e -> ParenExpr <$> f a <*> traverse f e+      ListExpr a es -> ListExpr <$> f a <*> ltraverse f es+      CallExpr a e es -> CallExpr <$> f a <*> traverse f e <*> ltraverse f es+      FuncExpr a ids s -> FuncExpr <$> f a <*> ltraverse f ids <*> traverse f s++instance Traversable CaseClause where+  traverse f (CaseClause a e ss) =+    CaseClause <$> f a <*> traverse f e <*> ltraverse f ss+  traverse f (CaseDefault a ss) = +    CaseDefault <$> f a <*> ltraverse f ss++instance Traversable CatchClause where+  traverse f (CatchClause a id s) = +    CatchClause <$> f a <*> traverse f id <*> traverse f s+    +instance Traversable VarDecl where+  traverse f (VarDecl a id ye) =+    VarDecl <$> f a <*> traverse f id <*> ytraverse f ye++instance Traversable ForInit where+  traverse f NoInit = pure NoInit+  traverse f (VarInit ds) = VarInit <$> ltraverse f ds+  traverse f (ExprInit e) = ExprInit <$> traverse f e++instance Traversable ForInInit where+ traverse f (ForInVar id) = ForInVar <$> traverse f id+ traverse f (ForInNoVar id) = ForInNoVar <$> traverse f id++instance Traversable Statement where+  traverse f statement =+    case statement of+      BlockStmt a ss -> BlockStmt <$> f a <*> ltraverse f ss+      EmptyStmt a -> EmptyStmt <$> f a+      ExprStmt a e -> ExprStmt <$> f a <*> traverse f e+      IfStmt a e s1 s2 ->+        IfStmt <$> f a <*> traverse f e <*> traverse f s1 <*> traverse f s2+      IfSingleStmt a e s ->+        IfSingleStmt <$> f a <*> traverse f e <*> traverse f s+      SwitchStmt a e cs ->+        SwitchStmt <$> f a <*> traverse f e <*> ltraverse f cs+      WhileStmt a e s -> WhileStmt <$> f a <*> traverse f e <*> traverse f s+      DoWhileStmt a s e -> DoWhileStmt <$> f a <*> traverse f s <*> traverse f e+      BreakStmt a yid -> BreakStmt <$> f a <*> ytraverse f yid+      ContinueStmt a yid -> ContinueStmt <$> f a <*> ytraverse f yid+      LabelledStmt a id s -> +        LabelledStmt <$> f a <*> traverse f id <*> traverse f s+      ForInStmt a init e s ->+        ForInStmt <$> f a <*> traverse f init <*> traverse f e <*> traverse f s+      ForStmt a init yinc ytest s ->+        ForStmt <$> f a <*> traverse f init <*> ytraverse f yinc +          <*> ytraverse f ytest <*> traverse f s+      TryStmt a s cs ys ->+        TryStmt <$> f a <*> traverse f s <*> ltraverse f cs <*> ytraverse f ys+      ThrowStmt a e -> ThrowStmt <$> f a <*> traverse f e+      ReturnStmt a ys -> ReturnStmt <$> f a <*> ytraverse f ys+      WithStmt a e s -> WithStmt <$> f a <*> traverse f e <*> traverse f s+      VarDeclStmt a ds -> VarDeclStmt <$> f a <*> ltraverse f ds+      FunctionStmt a id args s ->+        FunctionStmt <$> f a <*> traverse f id <*> ltraverse f args +          <*> traverse f s
+ src/WebBits/JavaScript/JavaScript.hs view
@@ -0,0 +1,17 @@+-- |Re-exports commonly used modules.+module WebBits.JavaScript.JavaScript+  ( module WebBits.JavaScript.Syntax+  , module WebBits.JavaScript.HtmlEmbedding+  , module WebBits.JavaScript.Parser+  , module WebBits.JavaScript.Combinators+  -- JavaScript.Instances exports nothing+  ) where++-- +import WebBits.JavaScript.Syntax+import WebBits.JavaScript.Parser+import WebBits.JavaScript.PrettyPrint+import WebBits.JavaScript.HtmlEmbedding+import WebBits.JavaScript.Combinators++import WebBits.JavaScript.Instances
+ src/WebBits/JavaScript/Lexer.hs view
@@ -0,0 +1,63 @@+{- This isn't a lexer in the sense that it provides a JavaScript token-stream.
+ - This module provides character-parsers for various JavaScript tokens.
+ -}
+module WebBits.JavaScript.Lexer(identifier,reserved,operator,reservedOp,charLiteral,
+                        stringLiteral,natural,integer,float,naturalOrFloat,
+                        decimal,hexadecimal,octal,symbol,whiteSpace,parens,
+                        braces,brackets,squares,semi,comma,colon,dot,
+                        identifierStart) where
+
+import Prelude hiding (lex)
+import Text.ParserCombinators.Parsec
+import qualified Text.ParserCombinators.Parsec.Token as T
+
+identifierStart = (letter <|> oneOf "$_")
+
+javascriptDef =
+  T.LanguageDef "/*"
+                "*/"
+                "//"
+                False -- no nested comments
+                {- Adapted from syntax/regexps.ss in Dave's code. -}
+                identifierStart
+                (alphaNum <|> oneOf "$_") -- identifier rest
+                (oneOf "{}<>()~.,?:|&^=!+-*/%!") -- operator start
+                (oneOf "=<>|&+") -- operator rest
+                ["break", "case", "catch", "const", "continue", "debugger", 
+                 "default", "delete", "do", "else", "enum", "false", "finally",
+                 "for", "function", "if", "instanceof", "in", "let", "new", 
+                 "null", "return", "switch", "this", "throw", "true", "try", 
+                 "typeof", "var", "void", "while", "with"]
+                ["|=", "^=", "&=", "<<=", ">>=", ">>>=", "+=", "-=", "*=", "/=", 
+                 "%=", "=", ";", ",", "?", ":", "||", "&&", "|", "^", "&", 
+                 "===", "==", "=", "!==", "!=", "<<", "<=", "<", ">>>", ">>", 
+                 ">=", ">", "++", "--", "+", "-", "*", "/", "%", "!", "~", ".", 
+                 "[", "]", "{", "}", "(", ")","</","instanceof"]
+                 True -- case-sensitive
+            
+lex = T.makeTokenParser javascriptDef
+
+-- everything but commaSep and semiSep
+identifier = T.identifier	 lex
+reserved = T.reserved	 lex
+operator = T.operator	 lex
+reservedOp = T.reservedOp lex	
+charLiteral = T.charLiteral lex	
+stringLiteral = T.stringLiteral lex	
+natural = T.natural lex	
+integer = T.integer lex	
+float = T.float lex	
+naturalOrFloat = T.naturalOrFloat lex	
+decimal = T.decimal lex	
+hexadecimal = T.hexadecimal lex	
+octal = T.octal lex	
+symbol = T.symbol lex	
+whiteSpace = T.whiteSpace lex	
+parens = T.parens	 lex
+braces = T.braces	 lex
+squares = T.squares lex	
+semi = T.semi	 lex
+comma = T.comma	 lex
+colon = T.colon lex	
+dot = T.dot lex
+brackets = T.brackets lex
+ src/WebBits/JavaScript/Parser.hs view
@@ -0,0 +1,659 @@+module WebBits.JavaScript.Parser(parseScript,parseExpression,parseStatement
+   , parseScriptFromString
+   , emptyParsedJavaScript
+   , ParsedStatement
+   , ParsedExpression
+   , parseJavaScriptFromFile
+   , parseSimpleExpr'
+   ) where
+
+import WebBits.JavaScript.Lexer hiding (identifier)
+import qualified WebBits.JavaScript.Lexer as Lexer
+import WebBits.JavaScript.Syntax
+import Text.ParserCombinators.Parsec
+import Text.ParserCombinators.Parsec.Expr
+import Control.Monad(liftM,liftM2)
+import Control.Monad.Trans (MonadIO,liftIO)
+import Numeric(readDec,readOct,readHex)
+import Data.Char(chr)
+
+-- We parameterize the parse tree over source-locations.
+type ParsedExpr = Expression SourcePos
+type ParsedStmt = Statement SourcePos
+
+type ParsedStatement = Statement SourcePos
+type ParsedExpression = Expression SourcePos
+
+
+-- These parsers can store some arbitrary state
+type StatementParser state = CharParser state ParsedStmt
+type ExpressionParser state = CharParser state ParsedExpr
+
+identifier =
+  liftM2 Id getPosition Lexer.identifier
+
+--{{{ Statements
+
+-- Keep in mind that Token.reserved parsers (exported from the lexer) do not
+-- consume any input on failure.  Note that all statements (expect for labelled
+-- and expression statements) begin with a reserved-word.  If we fail to parse
+-- this reserved-word, no input is consumed.  Hence, we can have the massive or
+-- block that is parseExpression.  Note that if the reserved-word is parsed, it 
+-- must be whatever statement the reserved-word indicates.  If we fail after the
+-- reserved-word, we truly have a syntax error.  Since input has been consumed,
+-- <|> will not try its alternate in parseExpression, and we will fail.
+
+parseIfStmt:: StatementParser st  
+parseIfStmt = do
+  pos <- getPosition
+  reserved "if"
+  test <- parseParenExpr <?> "parenthesized test-expression in if statement"
+  consequent <- parseStatement <?> "true-branch of if statement"
+  optional semi -- TODO: in spec?
+  ((do reserved "else"
+       alternate <- parseStatement
+       return (IfStmt pos test consequent alternate))
+    <|> return (IfSingleStmt pos test consequent))
+
+parseSwitchStmt:: StatementParser st
+parseSwitchStmt =
+  let parseDefault = do
+        pos <- getPosition
+        reserved "default"
+        colon
+        statements <- many parseStatement
+        return (CaseDefault pos statements)
+      parseCase = do
+         pos <- getPosition
+         reserved "case"
+         condition <- parseListExpr
+         colon
+         actions <- many parseStatement
+         return (CaseClause pos condition actions)
+    in do pos <- getPosition
+          reserved "switch"
+          test <- parseParenExpr
+          clauses <- braces $ many $ parseDefault <|> parseCase
+          return (SwitchStmt pos test clauses)
+
+parseWhileStmt:: StatementParser st
+parseWhileStmt = do
+  pos <- getPosition
+  reserved "while"
+  test <- parseParenExpr <?> "parenthesized test-expression in while loop"
+  body <- parseStatement
+  return (WhileStmt pos test body)
+
+parseDoWhileStmt:: StatementParser st
+parseDoWhileStmt = do
+  pos <- getPosition
+  reserved "do"
+  body <- parseStatement
+  reserved "while"
+  test <- parseParenExpr <?> "parenthesized test-expression in do loop"
+  optional semi
+  return (DoWhileStmt pos body test)
+
+parseContinueStmt:: StatementParser st
+parseContinueStmt = do
+  pos <- getPosition
+  reserved "continue"
+  pos' <- getPosition
+  -- Ensure that the identifier is on the same line as 'continue.'
+  id <- (if (sourceLine pos == sourceLine pos')
+           then (liftM Just identifier) <|> (return Nothing)
+           else return Nothing)
+  return (ContinueStmt pos id)
+
+parseBreakStmt:: StatementParser st
+parseBreakStmt = do
+  pos <- getPosition
+  reserved "break"
+  pos' <- getPosition
+  -- Ensure that the identifier is on the same line as 'break.'
+  id <- (if (sourceLine pos == sourceLine pos')
+           then (liftM Just identifier) <|> (return Nothing)
+           else return Nothing)
+  optional semi           
+  return (BreakStmt pos id)
+
+parseBlockStmt:: StatementParser st
+parseBlockStmt = do
+  pos <- getPosition
+  statements <- braces (many parseStatement)
+  return (BlockStmt pos statements)
+
+parseEmptyStmt:: StatementParser st 
+parseEmptyStmt = do
+  pos <- getPosition
+  semi
+  return (EmptyStmt pos)
+
+parseLabelledStmt:: StatementParser st
+parseLabelledStmt = do
+  pos <- getPosition
+  -- Lookahead for the colon.  If we don't see it, we are parsing an identifier
+  -- for an expression statement.
+  label <- try (do label <- identifier
+                   colon
+                   return label)
+  statement <- parseStatement
+  return (LabelledStmt pos label statement)
+
+parseExpressionStmt:: StatementParser st
+parseExpressionStmt = do
+  pos <- getPosition
+  expr <- parseListExpr -- TODO: spec 12.4?
+  optional semi
+  return (ExprStmt pos expr)
+
+
+parseForInStmt:: StatementParser st
+parseForInStmt =
+  let parseInit = (reserved "var" >> liftM ForInVar identifier)
+                  <|> (liftM ForInNoVar identifier)
+    in do pos <- getPosition
+          -- Lookahead, so that we don't clash with parseForStmt
+          (init,expr) <- try (do reserved "for"
+                                 parens (do init <- parseInit
+                                            reserved "in"
+                                            expr <- parseExpression
+                                            return (init,expr)))
+          body <- parseStatement
+          return (ForInStmt pos init expr body) 
+
+parseForStmt:: StatementParser st
+parseForStmt =
+  let parseInit =
+        (reserved "var" >> liftM VarInit (parseVarDecl `sepBy` comma)) <|>
+        (liftM ExprInit parseListExpr) <|>
+        (return NoInit)
+    in do pos <- getPosition
+          reserved "for"
+          reservedOp "("
+          init <- parseInit
+          semi
+          test <- (liftM Just parseExpression) <|> (return Nothing)
+          semi
+          iter <- (liftM Just parseExpression) <|> (return Nothing)
+          reservedOp ")" <?> "closing paren"
+          stmt <- parseStatement
+          return (ForStmt pos init test iter stmt)
+
+parseTryStmt:: StatementParser st
+parseTryStmt =
+  let parseCatchClause = do
+        pos <- getPosition
+        reserved "catch"
+        id <- parens identifier
+        stmt <- parseStatement
+        return (CatchClause pos id stmt)
+    in do reserved "try"
+          pos <- getPosition
+          guarded <- parseStatement
+          catches <- many parseCatchClause
+          finally <- (reserved "finally" >> liftM Just parseStatement) 
+                      <|> (return Nothing)
+          return (TryStmt pos guarded catches finally)
+
+parseThrowStmt:: StatementParser st
+parseThrowStmt = do
+  pos <- getPosition
+  reserved "throw"
+  expr <- parseExpression
+  optional semi
+  return (ThrowStmt pos expr)
+
+parseReturnStmt:: StatementParser st
+parseReturnStmt = do
+  pos <- getPosition
+  reserved "return"
+  expr <- (liftM Just parseListExpr) <|> (return Nothing)
+  optional semi
+  return (ReturnStmt pos expr)
+
+parseWithStmt:: StatementParser st
+parseWithStmt = do
+  pos <- getPosition
+  reserved "with"
+  context <- parseParenExpr
+  stmt <- parseStatement
+  return (WithStmt pos context stmt)
+
+parseVarDecl = do
+  pos <- getPosition
+  id <- identifier
+  init <- (reservedOp "=" >> liftM Just parseExpression) <|> (return Nothing)
+  return (VarDecl pos id init)
+
+parseVarDeclStmt:: StatementParser st
+parseVarDeclStmt = do 
+  pos <- getPosition
+  reserved "var"
+  decls <- parseVarDecl `sepBy` comma
+  optional semi
+  return (VarDeclStmt pos decls)
+
+parseFunctionStmt:: StatementParser st
+parseFunctionStmt = do
+  pos <- getPosition
+  name <- try (reserved "function" >> identifier) -- ambiguity with FuncExpr
+  args <- parens (identifier `sepBy` comma)
+  body <- parseBlockStmt <?> "function body in { ... }"
+  return (FunctionStmt pos name args body)
+
+parseStatement:: StatementParser st
+parseStatement = parseIfStmt <|> parseSwitchStmt <|> parseWhileStmt 
+  <|> parseDoWhileStmt <|> parseContinueStmt <|> parseBreakStmt 
+  <|> parseBlockStmt <|> parseEmptyStmt <|> parseForInStmt <|> parseForStmt
+  <|> parseTryStmt <|> parseThrowStmt <|> parseReturnStmt <|> parseWithStmt 
+  <|> parseVarDeclStmt  <|> parseFunctionStmt
+  -- labelled, expression and the error message always go last, in this order
+  <|> parseLabelledStmt <|> parseExpressionStmt <?> "statement"
+
+--}}}
+
+--{{{ Expressions
+
+-- References used to construct this stuff:
+-- + http://developer.mozilla.org/en/docs/
+--     Core_JavaScript_1.5_Reference:Operators:Operator_Precedence
+-- + http://www.mozilla.org/js/language/grammar14.html
+--
+-- Aren't expression tables nice?  Well, we can't quite use them, because of 
+-- JavaScript's ternary (?:) operator.  We have to use two expression tables.
+-- We use one expression table for the assignment operators that bind looser 
+-- than ?: (assignTable).  The terms of assignTable are ternary expressions 
+-- (parseTernaryExpr).  parseTernaryExpr left-factors the left-recursive
+-- production for ?:, and is defined over the second expression table, 
+-- exprTable, which consists of operators that bind tighter than ?:.  The terms
+-- of exprTable are atomic expressions, parenthesized expressions, functions and
+-- array references.
+
+--{{{ Primary expressions
+
+parseThisRef:: ExpressionParser st
+parseThisRef = do
+  pos <- getPosition
+  reserved "this"
+  return (ThisRef pos)
+
+parseNullLit:: ExpressionParser st
+parseNullLit = do
+  pos <- getPosition
+  reserved "null"
+  return (NullLit pos)
+
+
+parseBoolLit:: ExpressionParser st
+parseBoolLit =
+  let parseTrueLit = do
+        pos <- getPosition
+        reserved "true"
+        return (BoolLit pos True)
+      parseFalseLit = do
+        pos <- getPosition
+        reserved "false"
+        return (BoolLit pos False)
+    in parseTrueLit <|> parseFalseLit
+
+parseVarRef:: ExpressionParser st
+parseVarRef = liftM2 VarRef getPosition identifier
+
+parseArrayLit:: ExpressionParser st
+parseArrayLit = liftM2 ArrayLit getPosition (squares (parseExpression `sepBy` comma))
+  
+parseFuncExpr = do
+  pos <- getPosition
+  reserved "function"
+  args <- parens (identifier `sepBy` comma)
+  body <- parseBlockStmt
+  return $ FuncExpr pos args body
+
+--{{{ parsing strings
+
+escapeChars =
+ [('\'','\''),('\"','\"'),('\\','\\'),('b','\b'),('f','\f'),('n','\n'),
+  ('r','\r'),('t','\t'),('v','\v'),('/','/')]
+
+allEscapes:: String
+allEscapes = map fst escapeChars
+
+parseEscapeChar = do
+  c <- oneOf allEscapes
+  (Just c') <- return $ lookup c escapeChars
+  return c'
+
+parseAsciiHexChar = do
+  char 'x'
+  d1 <- hexDigit
+  d2 <- hexDigit
+  return ((chr.fst.head.readHex) (d1:d2:""))
+
+parseUnicodeHexChar = do
+  char 'u'
+  liftM (chr.fst.head.readHex) 
+        (sequence [hexDigit,hexDigit,hexDigit,hexDigit])
+        
+isWhitespace ch = ch `elem` " \t"
+
+-- The endWith argument is either single-quote or double-quote, depending on how
+-- we opened the string.
+parseStringLit' endWith =
+  (char endWith >> return "") <|>
+  (do try (string "\\'")
+      cs <- parseStringLit' endWith
+      return $ "'" ++ cs) <|>
+  (do char '\\'
+      c <- (parseEscapeChar <|> parseAsciiHexChar <|> parseUnicodeHexChar <|> char '\r' <|> char '\n')
+      cs <- parseStringLit' endWith
+      -- TODO: Leading whitespace on the new line is probably meant to be ignored.
+      if c == '\r' || c == '\n' then return (c:(dropWhile isWhitespace cs)) else return cs) <|>
+   (liftM2 (:) anyChar (parseStringLit' endWith))
+
+parseStringLit:: ExpressionParser st
+parseStringLit = do
+  pos <- getPosition
+  -- parseStringLit' takes as an argument the quote-character that opened the
+  -- string.
+  str <- (char '\'' >>= parseStringLit') <|> (char '\"' >>= parseStringLit')
+  -- CRUCIAL: Parsec.Token parsers expect to find their token on the first
+  -- character, and read whitespaces beyond their tokens.  Without this,
+  -- expressions like:
+  --   var s = "string"   ;
+  -- do not parse.
+  spaces 
+  return (StringLit pos str)
+
+--}}}
+
+parseRegexpLit:: ExpressionParser st
+parseRegexpLit = do
+  let parseFlags = do
+        flags <- many (oneOf "mgi")
+        return $ \f -> f ('g' `elem` flags) ('i' `elem` flags) 
+  let parseEscape = char '\\' >> anyChar
+  let parseChar = noneOf "/"
+  let parseRe = (char '/' >> return "") <|> (char '\\' >> liftM2 (:) anyChar parseRe) <|> (liftM2 (:) anyChar parseRe)
+  pos <- getPosition
+  char '/'
+  pat <- parseRe --many1 parseChar
+  flags <- parseFlags
+  spaces -- crucial for Parsec.Token parsers
+  return $ flags (RegexpLit pos pat)
+          
+parseObjectLit:: ExpressionParser st
+parseObjectLit =
+  let parseProp = do
+        -- Parses a string, identifier or integer as the property name.  I
+        -- apologize for the abstruse style, but it really does make the code
+        -- much shorter.
+        name <- (liftM (uncurry PropString) 
+                       (liftM (\(StringLit p s) -> (p,s)) parseStringLit))
+                <|> (liftM2 PropId getPosition identifier)
+                <|> (liftM2 PropNum getPosition decimal)
+        colon
+        val <- parseAssignExpr
+        return (name,val)
+    in do pos <- getPosition
+          props <- braces (parseProp `sepBy` comma) <?> "object literal"
+          return $ ObjectLit pos props
+
+--{{{ Parsing numbers.  From pg. 17-18 of ECMA-262.
+
+hexLit = do
+  try (string "0x")
+  digits <- many1 (oneOf "0123456789abcdefABCDEF")
+  [(hex,"")] <- return $ Numeric.readHex digits
+  return hex
+
+decimalDigit = oneOf "0123456789"
+
+-- Creates a decimal value from a whole, fractional and exponent part.
+mkDecimal:: Double -> Double -> Int -> Double
+mkDecimal w f e =
+  if (f >= 1.0)
+    then mkDecimal w (f / 10.0) e
+    else (w+f) * (10.0^e)
+
+decimalInteger = do
+  xs <- many1 decimalDigit
+  spaces
+  return $ (fst.head.readDec) xs
+
+{-  (try (char '0' >> spaces >> return 0)) <|>
+  (do xs <- many1 decimalDigit
+      return $ (fst.head.readDec) xs) -}
+
+exponentPart = do
+  oneOf "eE"
+  ((char '+' >> many1 decimalDigit >>= return.fst.head.readDec) <|> 
+   (char '-' >> many1 decimalDigit >>= return.negate.fst.head.readDec) <|>
+   (many1 decimalDigit >>= return.fst.head.readDec))
+  
+decLit =
+  (do whole <- decimalInteger
+      frac <- option 0 (char '.' >> decimalInteger)
+      exp <- option 0  exponentPart
+      return $ mkDecimal (fromIntegral whole) (fromIntegral frac) exp) <|>
+  (do frac <- char '.' >> decimalInteger
+      exp <- option 0  exponentPart
+      return $ mkDecimal 0.0 (fromIntegral frac) exp)
+
+parseNumLit:: ExpressionParser st
+parseNumLit = 
+  liftM2 NumLit getPosition
+    (do x <- hexLit <|> decLit
+        (notFollowedBy identifierStart <?> "whitespace") 
+        spaces
+        return x)
+
+--}}}
+
+parseParenExpr:: ExpressionParser st
+parseParenExpr = do
+  pos <- getPosition
+  expr <- parens parseListExpr
+  return (ParenExpr pos expr)
+
+-- everything above expect functions
+parseExprForNew = parseThisRef <|> parseNullLit <|> parseBoolLit <|> parseStringLit 
+  <|> parseArrayLit <|> parseParenExpr <|> parseNewExpr <|> parseNumLit 
+  <|> parseRegexpLit <|> parseObjectLit <|> parseVarRef
+
+-- all the expression parsers defined above
+parseSimpleExpr' = parseThisRef <|> parseNullLit <|> parseBoolLit 
+  <|> parseStringLit <|> parseArrayLit <|> parseParenExpr
+  <|> parseFuncExpr <|> parseNumLit <|> parseRegexpLit <|> parseObjectLit
+  <|> parseVarRef
+
+parseNewExpr =
+  (do pos <- getPosition
+      reserved "new"
+      constructor <- parseSimpleExprForNew Nothing -- right-associativity
+      arguments <- (try (parens (parseExpression `sepBy` comma))) <|> (return [])
+      return (NewExpr pos constructor arguments)) <|>
+  parseSimpleExpr'
+
+parseSimpleExpr (Just e) =
+  ((do reservedOp "." <?> "property.ref"
+       pos <- getPosition
+       key <- identifier
+       parseSimpleExpr $ Just (DotRef pos e key)) <|>
+   (do pos <- getPosition
+       reservedOp "(" <?> "(function application)" 
+       args <- parseExpression `sepBy` comma
+       --reservedOp ")"
+       spaces   -- This hack is needed as the token parser parses ")+", ")-",
+       char ')' -- etc. as a single token.
+       spaces
+       parseSimpleExpr $ Just (CallExpr pos e args)) <|>
+   (do reservedOp "[" <?> "[property-ref]"
+       pos <- getPosition
+       key <- parseExpression <?> "expression (2)"
+       char ']'
+       spaces
+       --reservedOp "]"
+       parseSimpleExpr $ Just (BracketRef pos e key)) <|>
+   (return e))
+parseSimpleExpr Nothing = do
+  e <- parseNewExpr <?> "expression (3)"
+  parseSimpleExpr (Just e)
+  
+parseSimpleExprForNew (Just e) =
+  ((do reservedOp "." <?> "property.ref"
+       pos <- getPosition
+       key <- identifier
+       parseSimpleExprForNew $ Just (DotRef pos e key)) <|>
+   (do reservedOp "[" <?> "[property-ref]"
+       pos <- getPosition
+       key <- parseExpression <?> "expression (2)"
+       char ']'
+       spaces
+       --reservedOp "]"
+       parseSimpleExprForNew $ Just (BracketRef pos e key)) <|>
+   (return e))
+parseSimpleExprForNew Nothing = do
+  e <- parseNewExpr <?> "expression (3)"
+  parseSimpleExprForNew (Just e)
+    
+--}}}
+
+makeInfixExpr str constr = Infix parser AssocLeft where
+  parser:: CharParser st (Expression SourcePos -> Expression SourcePos -> Expression SourcePos)
+  parser = do
+    pos <- getPosition
+    reservedOp str
+    return (InfixExpr pos constr)  -- points-free, returns a function
+
+makePrefixExpr str constr = Prefix parser where
+  parser = do
+    pos <- getPosition
+    (reservedOp str <|> reserved str)
+    return (PrefixExpr pos constr) -- points-free, returns a function
+    
+mkPrefix operator constr = Prefix $ do
+  pos <- getPosition
+  operator
+  return (\operand -> PrefixExpr pos constr operand)
+
+makePostfixExpr str constr = Postfix parser where
+  parser = do
+    pos <- getPosition
+    (reservedOp str <|> reserved str)
+    return (PostfixExpr pos constr) -- points-free, returns a function
+
+-- apparently, expression tables can't handle multiple prefixes (which makes sense, since chaining ++ and -- doesn't 
+-- make any sense)
+parsePrefixedExpr = do
+  pos <- getPosition 
+  op <- optionMaybe $ (reservedOp "!" >> return PrefixLNot) <|> (reservedOp "~" >> return PrefixBNot)
+  case op of
+    Nothing -> parseSimpleExpr Nothing  -- new is treated as a simple expr
+    Just op -> do
+      innerExpr <- parsePrefixedExpr
+      return (PrefixExpr pos op innerExpr)
+    
+exprTable:: [[Operator Char st ParsedExpr]]
+exprTable = 
+  [
+   [makePrefixExpr "++" PrefixInc,
+    makePostfixExpr "++" PostfixInc],
+   [makePrefixExpr "--" PrefixDec,
+    makePostfixExpr "--" PostfixDec],
+   -- What we really need here is a good, old-fashioned lexer.
+   [mkPrefix (try $ char '+' >> notFollowedBy (char '+')) PrefixPlus,
+    mkPrefix (try $ char '-' >> notFollowedBy (char '-')) PrefixMinus],
+    -- makePrefixExpr "-" PrefixMinus],
+   [makePrefixExpr "typeof" PrefixTypeof,
+    makePrefixExpr "void" PrefixVoid,
+    makePrefixExpr "delete" PrefixDelete],
+    
+   [makeInfixExpr "*" OpMul, makeInfixExpr "/" OpDiv, makeInfixExpr "%" OpMod],
+   [makeInfixExpr "+" OpAdd, makeInfixExpr "-" OpSub],
+   [makeInfixExpr "<<" OpLShift, makeInfixExpr ">>" OpSpRShift,
+    makeInfixExpr ">>>" OpZfRShift],
+   [makeInfixExpr "<" OpLT, makeInfixExpr "<=" OpLEq, makeInfixExpr ">" OpGT,
+    makeInfixExpr ">=" OpGEq, 
+    makeInfixExpr "instanceof" OpInstanceof, makeInfixExpr "in" OpIn],
+   [makeInfixExpr "&" OpBAnd], 
+   [makeInfixExpr "^" OpBXor], 
+   [makeInfixExpr "|" OpBOr],
+   [makeInfixExpr "&&" OpLAnd],
+   [makeInfixExpr "||" OpLOr],  
+   [makeInfixExpr "==" OpEq, makeInfixExpr "!=" OpNEq,
+    makeInfixExpr "===" OpStrictEq, makeInfixExpr "!==" OpStrictNEq]
+    ]
+  
+parseExpression' = 
+  buildExpressionParser exprTable parsePrefixedExpr <?> "simple expression"
+
+--{{{ Parsing ternary operators: left factored
+
+parseTernaryExpr':: CharParser st (Maybe (ParsedExpr,ParsedExpr))
+parseTernaryExpr' =
+  (do reservedOp "?"
+      l <- parseTernaryExpr
+      colon
+      r <- parseTernaryExpr
+      return $ Just (l,r)) <|>
+  (return Nothing)
+
+parseTernaryExpr:: ExpressionParser st
+parseTernaryExpr = do
+  e <- parseExpression'
+  e' <- parseTernaryExpr'
+  case e' of
+    Nothing -> return e
+    Just (l,r) -> do p <- getPosition
+                     return $ CondExpr p e l r
+--}}}
+
+-- Parsing assignment operations.
+makeAssignExpr str constr = Infix parser AssocRight where
+  parser:: CharParser st (ParsedExpr -> ParsedExpr -> ParsedExpr)
+  parser = do
+    pos <- getPosition
+    reservedOp str
+    return (AssignExpr pos constr)
+
+assignTable:: [[Operator Char st ParsedExpr]]
+assignTable = [
+  [makeAssignExpr "=" OpAssign, makeAssignExpr "+=" OpAssignAdd, 
+    makeAssignExpr "-=" OpAssignSub, makeAssignExpr "*=" OpAssignMul,
+    makeAssignExpr "/=" OpAssignDiv, makeAssignExpr "%=" OpAssignMod,
+    makeAssignExpr "<<=" OpAssignLShift, makeAssignExpr ">>=" OpAssignSpRShift,
+    makeAssignExpr ">>>=" OpAssignZfRShift, makeAssignExpr "&=" OpAssignBAnd,
+    makeAssignExpr "^=" OpAssignBXor, makeAssignExpr "|=" OpAssignBOr
+  ]]
+
+
+parseAssignExpr:: ExpressionParser st
+parseAssignExpr = buildExpressionParser assignTable parseTernaryExpr  
+
+parseExpression:: ExpressionParser st
+parseExpression = parseAssignExpr
+
+parseListExpr =
+  liftM2 ListExpr getPosition (parseAssignExpr `sepBy1` comma)
+
+--}}}
+
+parseScript:: CharParser state (JavaScript SourcePos)
+parseScript = do
+  whiteSpace
+  liftM2 Script getPosition (parseStatement `sepBy` whiteSpace)
+  
+parseJavaScriptFromFile :: MonadIO m => String -> m [Statement SourcePos]
+parseJavaScriptFromFile filename = do
+  chars <- liftIO $ readFile filename
+  case parse parseScript filename chars of
+    Left err               -> fail (show err)
+    Right (Script _ stmts) -> return stmts
+
+
+parseScriptFromString:: String -> String -> Either ParseError (JavaScript SourcePos)
+parseScriptFromString src script = parse parseScript src script
+
+emptyParsedJavaScript = 
+  Script (error "Parser.emptyParsedJavaScript--no annotation") []
+ src/WebBits/JavaScript/PrettyPrint.hs view
@@ -0,0 +1,261 @@+-- |Pretty-printing JavaScript.  This module doesn't export any names, but+-- importing it declares PrettyPrintable instances for JavaScript.Syntax.+module WebBits.JavaScript.PrettyPrint() where++import Text.PrettyPrint.HughesPJ+import WebBits.JavaScript.Syntax+import WebBits.JavaScript.Combinators+import WebBits.Common++--{{{ Helper functions for common printing patterns++-- Displays the statement in { ... }, unless it already is in a block.+inBlock:: (Statement a) -> Doc+inBlock stmt@(BlockStmt _ _) = pp stmt+inBlock stmt                 = text "{" $+$ pp stmt $+$ text "}"++-- Displays the expression in ( ... ), unless it already is in parens.+inParens:: (Expression a) -> Doc+inParens expr@(ParenExpr _ _) = pp expr+inParens expr                 = parens (pp expr)++commaSep:: (PrettyPrintable a) => [a] -> Doc+commaSep = hsep.(punctuate comma).(map pp)++--}}}++instance PrettyPrintable (Id a) where+  pp (Id _ str) = text str++instance PrettyPrintable (ForInit a) where+  pp NoInit         = empty+  pp (VarInit vs) = text "var" <+> commaSep vs +  pp (ExprInit e) = pp e+  +instance PrettyPrintable (ForInInit a) where+  pp (ForInVar id)   = text "var" <+> pp id+  pp (ForInNoVar id) = pp id++--{{{ Pretty-printing statements++instance PrettyPrintable (CaseClause a) where+  pp (CaseClause _ expr stmts) =+    pp expr <+> colon $$ (nest 2 (vcat (map pp stmts)))+  pp (CaseDefault _ stmts) =+    text "default:" $$ (nest 2 (vcat (map pp stmts)))++instance PrettyPrintable (CatchClause a) where+  pp (CatchClause _ id stmt) =+    text "catch" <+> (parens.pp) id <+> pp stmt+++instance PrettyPrintable (VarDecl a) where+  pp (VarDecl _ id Nothing) =+    pp id+  pp (VarDecl _ id (Just expr)) =+    pp id <+> equals <+> pp expr++instance PrettyPrintable (Statement a) where+  pp (BlockStmt _ stmts) =+    text "{" $+$ nest 2 (vcat (map pp stmts)) $+$ text "}"+  pp (EmptyStmt _) =+    semi+  pp (ExprStmt _ expr) =+    pp expr <> semi+  pp (IfSingleStmt _ test cons) =+    text "if" <+> inParens test $$ (nest 2 (pp cons))+  pp (IfStmt _ test cons alt) =+    text "if" <+> inParens test $$ (nest 2 $ pp cons) $$ text "else"+      $$ (nest 2 $ pp alt)+  pp (SwitchStmt _ expr cases) =+    text "switch" <+> inParens expr $$ braces (nest 2 (vcat (map pp cases)))+  pp (WhileStmt _ test body) =+    text "while" <+> inParens test $$ (nest 2 (pp body))+  pp (ReturnStmt _ expr) =+    text "return" <+> pp expr <> semi+  pp (DoWhileStmt _ stmt expr) =+    text "do" $$ (nest 2 (pp stmt <+> inParens expr))+  pp (BreakStmt _ Nothing) =+    text "break;"+  pp (BreakStmt _ (Just label)) =+    text "break" <+> pp label <> semi+  pp (ContinueStmt _ Nothing) =+    text "continue;"+  pp (ContinueStmt _ (Just label)) =+    text"continue" <+> pp label <> semi+  pp (LabelledStmt _ label stmt) =+    pp label <> colon $$ pp stmt+  pp (ForInStmt p init expr body) =+    text "for" <+> parens (pp init <+> text "in" <+> pp expr)+      $$ (nest 2 (pp body))+  pp (ForStmt _ init incr test body) =+    text "for" <+> parens (pp init <> semi <+> pp incr <> semi <+> pp test)+      $$ (nest 2 (pp body))+  pp (TryStmt _ stmt catches finally) =+    (text "try" $$ pp stmt $$ (vcat (map pp catches)) $$ ppFinally) where+      ppFinally = +        case finally of+          Nothing -> empty+	  (Just stmt) -> text "finally" <> pp stmt+  pp (ThrowStmt _ expr) =+    text "throw" <+> pp expr <> semi+  pp (WithStmt _ expr stmt) | isParenExpr expr =+    (text "with" <+> inParens expr $$ pp stmt)+  pp (WithStmt _ expr stmt) | otherwise =+      (text "with" <+> inParens expr $$ pp stmt)+  pp (VarDeclStmt _ decls) =+    text "var" <+> commaSep decls <> semi+  pp (FunctionStmt _ name args stmt) =+    text "function" <+> pp name <> (parens.commaSep) args $$ inBlock stmt++--}}}++instance PrettyPrintable (Prop a) where+  pp (PropId _ id) = pp id+  pp (PropString _ str) = text str+  pp (PropNum _ n) = text (show n)+++--{{{ infix-operators++showInfix op =+  case op of+    OpMul -> "*"+    OpDiv -> "/"+    OpMod -> "%" +    OpAdd -> "+" +    OpSub -> "-"+    OpLShift -> "<<"+    OpSpRShift -> ">>"+    OpZfRShift -> ">>>"+    OpLT -> "<"+    OpLEq -> "<="+    OpGT -> ">"+    OpGEq -> ">="+    OpIn -> "in"+    OpInstanceof -> "instanceof"+    OpEq -> "=="+    OpNEq -> "!="+    OpStrictEq -> "==="+    OpStrictNEq -> "!=="+    OpBAnd -> "&"+    OpBXor -> "^"+    OpBOr -> "|"+    OpLAnd -> "&&"+    OpLOr -> "||"++instance PrettyPrintable InfixOp where+  pp op = text (showInfix op)+--}}}++--{{{ prefix operators++showPrefix PrefixInc = "++"+showPrefix PrefixDec = "--"+showPrefix PrefixLNot = "!"+showPrefix PrefixBNot = "~"+showPrefix PrefixPlus = "+"+showPrefix PrefixMinus = "-"+showPrefix PrefixTypeof = "typeof"+showPrefix PrefixVoid = "void"+showPrefix PrefixDelete = "delete"++instance PrettyPrintable PrefixOp where+  pp op = text (showPrefix op)++--}}}++--{{{ postfix operators++instance PrettyPrintable PostfixOp where+  pp PostfixInc = text "++"+  pp PostfixDec = text "--"++--}}}++--{{{ assignment operators++showAssignOp OpAssign = "="+showAssignOp OpAssignAdd = "+="+showAssignOp OpAssignSub = "-="+showAssignOp OpAssignMul = "*="+showAssignOp OpAssignDiv = "/="+showAssignOp OpAssignMod = "%="+showAssignOp OpAssignLShift = "<<="+showAssignOp OpAssignSpRShift = ">>="+showAssignOp OpAssignZfRShift = ">>>="+showAssignOp OpAssignBAnd = "&="+showAssignOp OpAssignBXor = "^="+showAssignOp OpAssignBOr = "|="++instance PrettyPrintable AssignOp where+  pp = text.showAssignOp++--}}}++--{{{ expressions++-- Based on:+--   http://developer.mozilla.org/en/docs/Core_JavaScript_1.5_Guide:Literals+jsEscape:: String -> String+jsEscape str =+  if str == ""  then "" else (sel (head str)) ++ (jsEscape (tail str)) where+    sel '\b' = "\\b"+    sel '\f' = "\\f"+    sel '\n' = "\\n"+    sel '\r' = "\\r"+    sel '\t' = "\\t"+    sel '\v' = "\\v"+    sel '\'' = "\\'"+    sel '\"' = "\\\""+    sel x    = [x]+    -- We don't have to do anything about \X, \x and \u escape sequences.++  +instance PrettyPrintable (Expression a) where+  pp (StringLit _ str) = doubleQuotes (text (jsEscape str))+  pp (RegexpLit _ re global ci) =+    text "/" <> text re <> text "/" <> g <> i where+      g = if global then text "g" else empty+      i = if ci then text "i" else empty+  pp (NumLit _ n) =  text (show n)+  pp (BoolLit _ True) = text "true"+  pp (BoolLit _ False) = text "false"+  pp (NullLit _) = text "null"+  pp (ArrayLit _ xs) = +    (brackets.commaSep) xs+  pp (ObjectLit _ xs) = +    braces (hsep (punctuate comma (map pp' xs))) where+      pp' (n,v) = pp n <> colon <+> pp v+  pp (ThisRef _) = text "this"+  pp (VarRef _ id) = pp id+  pp (DotRef _ expr id) =+    pp expr <> text "." <> pp id+  pp (BracketRef _ container key) =+    pp container <> brackets (pp key)+  pp (NewExpr _ constr args) =+    text "new" <+> pp constr <> (parens.commaSep) args+  pp (PrefixExpr _ op expr) =+    pp op <+> pp expr+  pp (PostfixExpr _ op expr) =+    pp expr <+> pp op+  pp (InfixExpr _ op left right) = +    pp left <+> pp op <+> pp right+  pp (CondExpr _ test cons alt) =+    inParens test <+> text "?" <+> inParens cons <+> colon <+> inParens alt+  pp (AssignExpr _ op l r) =+    pp l <+> pp op <+> pp r+  pp (ParenExpr _ expr) =+    parens (pp expr)+  pp (ListExpr _ exprs) = commaSep exprs+  pp (CallExpr _ f args) =+    pp f <> (parens.commaSep) args+  pp (FuncExpr _ args body) =+    text "function" <+> (parens.commaSep) args $$ inBlock body++instance PrettyPrintable (JavaScript a) where+  pp (Script _ stmts) =+    vcat (map pp stmts)++--}}}+
+ src/WebBits/JavaScript/Syntax.hs view
@@ -0,0 +1,117 @@+-- |JavaScript's syntax.
+module WebBits.JavaScript.Syntax(Expression(..),CaseClause(..),Statement(..),
+         InfixOp(..),CatchClause(..),VarDecl(..),JavaScript(..),
+         AssignOp(..),Id(..),PrefixOp(..),PostfixOp(..),Prop(..),
+         ForInit(..),ForInInit(..)) where
+
+import Text.ParserCombinators.Parsec(SourcePos) -- used by data JavaScript
+import Data.Generics(Data,Typeable)
+
+data JavaScript a
+  -- |A script in <script> ... </script> tags.  This may seem a little silly,
+  -- but the Flapjax analogue has an inline variant and attribute-inline 
+  -- variant.
+  = Script a [Statement a] 
+  deriving (Show,Data,Typeable,Eq,Ord)
+
+data Id a = Id a String deriving (Show,Eq,Ord,Data,Typeable)
+
+-- http://developer.mozilla.org/en/docs/
+--   Core_JavaScript_1.5_Reference:Operators:Operator_Precedence
+data InfixOp = OpLT | OpLEq | OpGT | OpGEq  | OpIn  | OpInstanceof | OpEq | OpNEq
+             | OpStrictEq | OpStrictNEq | OpLAnd | OpLOr 
+             | OpMul | OpDiv | OpMod  | OpSub | OpLShift | OpSpRShift
+             | OpZfRShift | OpBAnd | OpBXor | OpBOr | OpAdd
+    deriving (Show,Data,Typeable,Eq,Ord,Enum)
+
+data AssignOp = OpAssign | OpAssignAdd | OpAssignSub | OpAssignMul | OpAssignDiv
+  | OpAssignMod | OpAssignLShift | OpAssignSpRShift | OpAssignZfRShift
+  | OpAssignBAnd | OpAssignBXor | OpAssignBOr
+  deriving (Show,Data,Typeable,Eq,Ord)
+
+data PrefixOp = PrefixInc | PrefixDec | PrefixLNot | PrefixBNot | PrefixPlus
+  | PrefixMinus | PrefixTypeof | PrefixVoid | PrefixDelete
+  deriving (Show,Data,Typeable,Eq,Ord)
+  
+data PostfixOp 
+  = PostfixInc | PostfixDec
+  deriving (Show,Data,Typeable,Eq,Ord)
+  
+data Prop a 
+  = PropId a (Id a) | PropString a String | PropNum a Integer
+  deriving (Show,Data,Typeable,Eq,Ord)
+
+data Expression a
+  = StringLit a String
+  | RegexpLit a String Bool {- global? -} Bool {- case-insensitive? -}
+  | NumLit a Double -- pg. 5 of ECMA-262
+  | BoolLit a Bool
+  | NullLit a
+  | ArrayLit a [Expression a]
+  | ObjectLit a [(Prop a, Expression a)]
+  | ThisRef a
+  | VarRef a (Id a)
+  | DotRef a (Expression a) (Id a)
+  | BracketRef a (Expression a) {- container -} (Expression a) {- key -}
+  | NewExpr a (Expression a) {- constructor -} [Expression a]
+  | PostfixExpr a PostfixOp (Expression a)
+  | PrefixExpr a PrefixOp (Expression a)
+  | InfixExpr a InfixOp (Expression a) (Expression a)
+  | CondExpr a (Expression a) (Expression a) (Expression a)
+  | AssignExpr a AssignOp (Expression a) (Expression a)
+  | ParenExpr a (Expression a)
+  | ListExpr a [Expression a]
+  | CallExpr a (Expression a) [Expression a]
+  | FuncExpr a [(Id a)] (Statement a)
+  deriving (Show,Data,Typeable,Eq,Ord)
+
+data CaseClause a 
+  = CaseClause a (Expression a) [Statement a]
+  | CaseDefault a [Statement a]
+  deriving (Show,Data,Typeable,Eq,Ord)
+  
+data CatchClause a 
+  = CatchClause a (Id a) (Statement a) 
+  deriving (Show,Data,Typeable,Eq,Ord)
+
+data VarDecl a 
+  = VarDecl a (Id a) (Maybe (Expression a)) 
+  deriving (Show,Data,Typeable,Eq,Ord)
+  
+data ForInit a
+  = NoInit
+  | VarInit [VarDecl a]
+  | ExprInit (Expression a)
+  deriving (Show,Data,Typeable,Eq,Ord)
+
+data ForInInit a
+ = ForInVar (Id a)
+ | ForInNoVar (Id a)
+ deriving (Show,Data,Typeable,Eq,Ord)
+  
+  
+data Statement a
+  = BlockStmt a [Statement a]
+  | EmptyStmt a
+  | ExprStmt a (Expression a)
+  | IfStmt a (Expression a) (Statement a) (Statement a)
+  | IfSingleStmt a (Expression a) (Statement a)
+  | SwitchStmt a (Expression a) [CaseClause a]
+  | WhileStmt a (Expression a) (Statement a)
+  | DoWhileStmt a (Statement a) (Expression a)
+  | BreakStmt a (Maybe (Id a))
+  | ContinueStmt a (Maybe (Id a))
+  | LabelledStmt a (Id a) (Statement a)
+  | ForInStmt a (ForInInit a) (Expression a) (Statement a)
+  | ForStmt a (ForInit a)        
+              (Maybe (Expression a)) -- increment
+              (Maybe (Expression a)) -- test
+              (Statement a)          -- body
+  | TryStmt a (Statement a) {-body-} [CatchClause a] {-catches-}
+      (Maybe (Statement a)) {-finally-}
+  | ThrowStmt a (Expression a)
+  | ReturnStmt a (Maybe (Expression a))
+  | WithStmt a (Expression a) (Statement a)
+  | VarDeclStmt a [VarDecl a]
+  | FunctionStmt a (Id a) {-name-} [(Id a)] {-args-} (Statement a) {-body-}
+  deriving (Show,Data,Typeable,Eq,Ord)