packages feed

WebBits-Html (empty) → 1.0

raw patch · 11 files changed

+978/−0 lines, 11 filesdep +WebBitsdep +basedep +containersbuild-type:Customsetup-changed

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

Files

+ LICENSE view
@@ -0,0 +1,14 @@+Copyright (c) 2007-2008 Arjun Guha and Spiridon Eliopoulos.++WebBits is licensed under the terms of the GNU Lesser General Public License+2.1.++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.++Contains source code derived from javascript.plt, Copyright (c) 2008 David+Herman, licensed under the terms of the GNU Lesser General Public License 2.1++The tests/ directory contains open-source JavaScript code.  Their licenses+are inline.
+ Setup.hs view
@@ -0,0 +1,37 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+import qualified Data.List as L+import System.Directory+import qualified Data.Char as Ch+import System.Process (runCommand,waitForProcess)++isHaskellFile file = ".lhs" `L.isSuffixOf` file || ".hs" `L.isSuffixOf` file++moduleName file = L.takeWhile  (/= '.') file++isRequested :: [String] -> String -> Bool+isRequested requestedTests test = +  (map Ch.toLower test) `elem` (map (map Ch.toLower) requestedTests)++testMain args _ _ _ = do+  files <- getDirectoryContents "tests"+  let testFiles = filter isHaskellFile files+  let testModules = if null args+                      then map moduleName testFiles+                      else filter (isRequested args) (map moduleName testFiles)+  let testFuncs = map (++ ".main") testModules+  let testExpr = "sequence [ " ++ concat (L.intersperse "," testFuncs) ++ +                 " ] >>= \\cases -> runTestTT (TestList cases)"+  let moduleLine = concat (L.intersperse " " testModules)+  let cmd = "cd tests && ghc  -XNoMonomorphismRestriction -fglasgow-exts " +++            "-package HUnit -package parsec-2.1.0.1 -i:../src -e \"" ++ +            testExpr ++ " >> return ()\" " ++ moduleLine+  putStrLn "Testing command is:"+  putStrLn cmd+  putStrLn "\nLoading tests..."+  handle <- runCommand cmd+  waitForProcess handle+  putStrLn "Testing complete.  Errors reported above (if any)."+++main = defaultMainWithHooks (simpleUserHooks { runTests = testMain })
+ WebBits-Html.cabal view
@@ -0,0 +1,50 @@+Name:           WebBits-Html+Version:        1.0+Cabal-Version:	>= 1.2.3+Copyright:      Copyright (c) 2007-2009 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:       Language+Build-Type:     Custom+Synopsis:       JavaScript analysis tools+Description:++	WebBits is a collection of libraries for working with JavaScript embeded in+  HTML files.  Highlights include:+  .+	* @BrownPLT.JavaScript.Crawl@ returns all JavaScript in an HTML page, including+     JavaScript from imported script files (@\<script src=...\>@).+  .+  * @BrownPLT.JavaScript.Environment@ annotates JavaScript syntax with its +    static environment and returns a list of free identifiers.+  .+  * @BrownPLT.Html.Parser@ is a permissive HTML parser.+ +Library+  Hs-Source-Dirs:+    src+  Build-Depends:+    base >= 4 && < 5,+    mtl >= 1.1.0.1,+    parsec < 3.0.0,+    pretty >= 0.1,+    containers >= 0.1,+    syb >= 0.1,+    WebBits >= 1.0 && <= 2.0+  ghc-options:+    -fwarn-incomplete-patterns+  Extensions:     +    Generics TypeSynonymInstances DeriveDataTypeable+  Exposed-Modules:+    BrownPLT.Html+    BrownPLT.Html.Syntax+    BrownPLT.Html.PermissiveParser+    BrownPLT.Html.PrettyPrint +    BrownPLT.Html.Instances+    BrownPLT.Html.RawScript+    BrownPLT.JavaScript.HtmlEmbedding +    BrownPLT.JavaScript.Crawl
+ src/BrownPLT/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 BrownPLT.Html+  ( module BrownPLT.Html.Syntax+  -- PermissiveParser+  , renderHtml+  , parseHtmlFromFile+  , parseHtmlFromString+  ) where+  +import BrownPLT.Html.Syntax+import BrownPLT.Html.PermissiveParser+import BrownPLT.Html.PrettyPrint -- no names, only instances+import BrownPLT.Html.Instances -- no names, only instances
+ src/BrownPLT/Html/Instances.hs view
@@ -0,0 +1,66 @@+module BrownPLT.Html.Instances() where++import qualified Prelude as Prelude+import Prelude (Functor,map,fmap)+import qualified Data.List as List+import qualified Data.Char as Char+import Data.Foldable+import Data.Traversable+import Control.Applicative++import BrownPLT.Html.Syntax++ltraverse:: (Traversable t, Applicative f) => (a -> f b) -> [t a] -> f [t b]+ltraverse f [] = pure []+ltraverse f (x:xs) = pure (:) <*> (traverse f x) <*> ltraverse f xs++instance Functor (Attribute a) where+  fmap f (Attribute id val a)            = Attribute id val a+  fmap f (AttributeExpr a id script def) = AttributeExpr a id (f script) def++instance Functor (Html a) where+  fmap f (Element id attrs children a) = +    Element id (map (fmap f) attrs) (map (fmap f) children) a+  fmap f (Text str a)                  = Text str a+  fmap f (Comment str a)               = Comment str a+  fmap f (HtmlSeq xs)                  = HtmlSeq (map (fmap f) xs)+  fmap f (ProcessingInstruction str a) = ProcessingInstruction str a+  fmap f (InlineScript script a def)   = InlineScript (f script) a def+  fmap f (Script script a)             = Script (f script) a++instance Foldable (Attribute a) where+  foldr f x (Attribute id val a)          = x+  foldr f x (AttributeExpr a id script def) = f script x++instance Foldable (Html a) where+  foldr f x (Element id attrs children a) =+    Prelude.foldr  (\child x' -> foldr f x' child) x children  +  foldr f x (Text str a)                  = x+  foldr f x (Comment str a)               = x+  foldr f x (HtmlSeq ys)                  = +    Prelude.foldr (\child x' -> foldr f x' child) x ys+  foldr f x (ProcessingInstruction str a) = x+  foldr f x (InlineScript script a def)   = f script x+  foldr f x (Script script a)             = f script x++instance Traversable (Attribute a) where+  traverse f (Attribute id val a)            =+    pure (Attribute id val a)+  traverse f (AttributeExpr a id script def) =+    (AttributeExpr a id) <$> (f script) <*> pure def++instance Traversable (Html a) where+  traverse f (Element id attrs children a) = +    (Element id) <$> ltraverse f attrs  <*> ltraverse f children <*> pure a+  traverse f (Text str a)                  = +    pure (Text str a)+  traverse f (Comment str a)               = +    pure (Comment str a)+  traverse f (HtmlSeq xs)                  = +    HtmlSeq <$> ltraverse f xs+  traverse f (ProcessingInstruction str a) = +    pure (ProcessingInstruction str a)+  traverse f (InlineScript script a def)   =+    InlineScript <$> (f script) <*> pure a <*> pure def+  traverse f (Script script a)             = +    Script <$> (f script) <*> pure a
+ src/BrownPLT/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 BrownPLT.Html.PermissiveParser+  ( html+  , parseHtmlFromFile+  , parseHtmlFromString+  -- tokenizer is exported primarily for testing+  , tokens+  , Token+  ) where++import Control.Monad+import Text.ParserCombinators.Parsec hiding (token,tokens)+import qualified Text.ParserCombinators.Parsec as Parsec+import Data.Char (toLower)+import Data.List (intersperse)++import qualified BrownPLT.Html.Syntax as Html+import BrownPLT.Html.Syntax (HtmlId,Attribute,Script(..))++type ParsedHtml s = Html.Html SourcePos s+type ParsedAttribute s = Html.Attribute SourcePos s++--------------------------------------------------------------------------------+-- Parsers generate warnings++data Warning = StringWarning SourcePos String++instance Show Warning where+  show (StringWarning p s) = "Warning parsing HTML: " ++ s+  showList [] s = s+  showList (x:xs) s = show x ++ ('\n':showList xs s)++warn:: String -> GenParser tok [Warning] ()+warn s = do+  p <- getPosition+  updateState ((StringWarning p s):)++noWarnings:: [Warning]+noWarnings = []+  ++-- A structure-recovering parser for malformed documents, derived from+-- Neil W. Van Dyke's htmlprag library for PLT Scheme++-- The elements in the list can legally enclose the 1st element of the pair.+parentConstraints:: [(HtmlId,[HtmlId])]+parentConstraints =+  [("area",["map"]),+   ("body",["html"]),+   ("caption", ["table"]),+   ("colgroup", ["table"]),+   ("dd", ["dl"]),+   ("dt", ["dl"]),+   ("frame", ["frameset"]),+   ("head", ["html"]),+   ("isindex", ["head"]),+   ("li", ["dir", "menu", "ol", "ul"]),+   ("meta", ["head"]),+   ("noframes", ["frameset"]),+   ("option", ["select"]),+   ("p", ["body", "td", "th"]),+   ("param", ["applet"]),+   ("tbody", ["table"]),+   ("td", ["tr"]),+   ("th", ["tr"]),+   ("thead", ["table"]),+   ("title", ["head"]),+   ("tr", ["table", "tbody", "thead"])]++-- |List of HTML elements that are empty.+emptyElements:: [HtmlId]+emptyElements = +  ["area", "base", "br", "frame", "hr", "img", "input", "isindex", "keygen", +   "link", "meta", "object", "param", "spacer", "wbr"]++isLegalChildOf:: HtmlId -> HtmlId -> Bool+isLegalChildOf child parent =+  case lookup child parentConstraints of+    Nothing             -> True+    (Just legalParents) -> parent `elem` legalParents+    +isEmptyElement:: HtmlId -> Bool+isEmptyElement element = element `elem` emptyElements++--}}}++--------------------------------------------------------------------------------+-- Parses an HTML file into a stream of tokens.++-- The auxillary parsing functions return values of this type.+data Script s  => Token s+  = Text SourcePos String+  | EntityToken SourcePos String+  | EntityInt SourcePos Int+  | Tag SourcePos HtmlId [Attribute SourcePos s] Bool {-closed?-}+  | Script SourcePos s+  | Inline SourcePos s String+  | EndTag SourcePos HtmlId+  | Comment SourcePos String+  | DoctypeToken SourcePos String String String (Maybe String)+++token:: Script s => Bool -> [Attribute SourcePos s] +     -> CharParser [Warning] (Token s)+token expectedScript prevAttrs = case expectedScript of+  True  -> (liftM2 Script getPosition (parseScriptBlock prevAttrs)) +             <?> "expected a script after a <script> tag"+  False -> doctype <|> comment <|> tag <|> endTag <|> inlineScript <|> entity +             <|> text++tokens:: Script s => CharParser [Warning] [Token s]+tokens = (eof >> return []) <|> tokens' where+  tokens' = do +    t <- token False []+    case t of+      (Tag _ "script" attrs False) -> do s <- token True attrs+                                         ts <- tokens+                                         return (t:s:ts)+      _ -> tokens >>= return.(t:)++--------------------------------------------------------------------------------+-- Parsers for various components of HTML++qname:: CharParser st String+qname = do+  x <- letter+  xs <- many (noneOf "/*=<>\"\'  \v\f\t\r\n")+  return (x:xs)++-- |We do not permit spaces between the hyphens and the right-angle in the+-- terminating '-->'.+comment:: Script s => CharParser st (Token s) +comment =+  let notDoubleHyphen = try (char '-' >> notFollowedBy (char '-') >> return '-')+      notHyphen = noneOf "-"+    in do try (string "<!--")+          pos <- getPosition+          msg <- many (notHyphen <|> notDoubleHyphen)+          string "-->"+          return (Comment pos msg)++endTag:: Script s => CharParser [Warning] (Token s)+endTag  = do+  pos <- getPosition+  string "</"+  name <- qname <?> "closing tag\'s name"+  junk <- manyTill anyChar (char '>') -- permits junk between tag name and '>'+  unless (null junk) (warn $ "extra characters: " ++ junk ++ +                             "; assuming tag name is " ++ name)+  return (EndTag pos name)+  +doctype:: Script s => CharParser [Warning] (Token s)+doctype = do+  p <- getPosition+  try (string "<!DOCTYPE")+  spaces+  top <- qname <?> "top-element name"+  spaces+  avail <- qname <?> "availability"+  spaces+  regEtc <- quotedString <?> "registration, etc."+  spaces+  uri <- optionMaybe quotedString+  spaces+  string ">"+  return (DoctypeToken p top avail regEtc uri)+  +entity:: Script s => CharParser [Warning] (Token s)+entity = do+  char '&'+  pos <- getPosition+  name <- many alphaNum <|> (char '#' >> many1 digit)+  when (null name) (warn "no identifer or number after &")+  (char ';' >> return ()) <|> (warn "expected semi-colon after entity") +  return (EntityToken pos name)+  +notScript:: CharParser a Char+notScript = try (char '{' >> notFollowedBy (char '!') >> return '{')++-- Parses raw text, upto an opening angle-bracket ('<').+text:: Script s => CharParser st (Token s)+text = do+  pos  <- getPosition+  cs <- many1 (noneOf "<{" <|> notScript) -- Doesn't consume the terminating angle bracket.+  return (Text pos cs)++-- Strings that are either double-quoted or single-quoted.  Note that HTML+-- strings contain no escape sequences.+quotedString:: CharParser a String+quotedString =+  (char '"' >> manyTill anyChar (char '"')) <|>+  (char '\'' >> manyTill anyChar (char '\'')) <?>+  "quoted string (double-quotes or single quotes)"++-- Parses text to the right of a triple-stick in an inline expression.  We have+-- to ensure that if we read a `!,' it isn't immediately followed by `}.'+initText =+  let notEnd = try (char '!' >> notFollowedBy (char '}') >> return '!')+    in many1 (notEnd <|> noneOf "!")++scriptValue:: Script s => CharParser a (s,String)+scriptValue =+  case parseAttributeScript of+    Nothing -> fail "attribute-script parser not defined"+    (Just parser) -> do string "{!"+                        script <- parser+                        init <- (string "!}" >> return "")  <|> +                                (string "|||" >> initText >>= +                                 (\s -> string "!}" >> return s))+                        return (script,init)++number:: CharParser a String+number = many1 digit++-- +nonquotedAttribute:: CharParser [Warning]  String+nonquotedAttribute = do+  x <- alphaNum <|> oneOf "_"+  xs <- many (noneOf "/*=<>\"\'  \v\f\t\r\n")+  warn $ "non-quoted attribute value: " ++ (x:xs)+  return (x:xs)+++attribute:: Script s => CharParser [Warning] (Html.Attribute SourcePos s)+attribute = do+  pos  <- getPosition+  name <- qname <?> "attribute name"+  spaces+  value <- (do char '='+               spaces+               (liftM Right scriptValue)+                 <|> (liftM Left (quotedString <|> nonquotedAttribute)) +                 <?> "attribute value")+           <|> (return $ Left "") -- Unspecified values are empty values.+  case value of+    (Left v)      -> return $ Html.Attribute name v pos+    (Right (s,d)) -> return $ Html.AttributeExpr pos name s d++-- Takes the name of the immediately-enclosing parent tag as an argument.+tag:: Script s => CharParser [Warning] (Token s)+tag = do+  try (char '<' >> notFollowedBy (char '/'))+  pos <- getPosition+  name <- qname <?>  "opening tag\'s name"+  spaces+  attributes <- (attribute `sepEndBy` spaces)+  (char '>' >> return (Tag pos name attributes False))+    <|> (string "/>" >> return (Tag pos name attributes True))+    <?> "end of tag (i.e. \">\")"+++-- Parses an inline (curly-banged) script, if an inline-script parser has been+-- specified (i.e. not Nothing).  Two-character lookahead for the ``{!,'' after+-- which control is passed to the inline script parser.  Once control returns,+-- the parser expects to see the closing ``!}.''+inlineScript:: Script s => CharParser a (Token s)+inlineScript =+  case parseInlineScript of+    Nothing -> fail "no inline script parser specified." -- TODO: appropriate?+    (Just parser) -> do string "{!" <?> "{! script !}"+                        pos <- getPosition+                        script <- parser+                        spaces+                        init <- (string "!}" >> return "") <|>+                                (string "|||" >> initText >>= +                                 (\s -> string "!}" >> return s))+                        return $ Inline pos script init+++-- Parses a stream of tokens, with a script parser, s and returns values of +-- type a.+type TokenParser s a = GenParser (Token s) [Warning] a++instance Script s => Show (Token s) where+  show = tokenShow++tokenShow token = case token of+  (Text _ s)        -> s+  (EntityToken _ s) -> "&" ++ s ++ ";"+  (EntityInt _ n)   -> "&#" ++ show n ++ ";"+  (Tag _ id attrs closed) -> +    "<" ++ id ++ " ... " ++ closing where+      closing = if closed then "/>" else ">"+  (Script _ s)  -> "/* script body omitted */"+  (Inline _ s _)-> "{! /* script */ !}"+  (EndTag _ id) -> "</" ++ show id ++ ">"+  (Comment _ s) -> "<!-- " ++ show s ++ " -->"+  (DoctypeToken _ top avail desc Nothing) ->+    "<!DOCTYPE " ++ top ++ " " ++ avail ++ " " ++ show desc ++ ">"+  (DoctypeToken _ top avail desc (Just uri)) ->+    "<!DOCTYPE " ++ top ++ " " ++ avail ++ " " ++ show desc ++ " " +      ++ show uri ++ ">" ++tokenPos tok = case tok of+  (Text p _) -> p+  (EntityToken p _) -> p+  (EntityInt p _) -> p+  (Tag p _ _ _) -> p+  (Script p _) -> p+  (Inline p _ _) -> p+  (EndTag p _) -> p+  (Comment p _) -> p+  (DoctypeToken p _ _ _ _) -> p+    +textToken :: Script s => TokenParser s (ParsedHtml s)+textToken = Parsec.token tokenShow tokenPos $ \t -> case t of+  Text _ s -> Just (Html.Text s (tokenPos t))+  otherwise -> Nothing+             +entityToken :: Script s => TokenParser s (ParsedHtml s)+entityToken =+  Parsec.token tokenShow tokenPos+    (\t -> case t of+             (EntityToken p s) -> Just (Html.Text ("&" ++ s ++ ";") p)+             (EntityInt p n) -> Just (Html.Text ("&#" ++ show n ++ ";") p)+             otherwise -> Nothing)+           +commentToken :: Script s => TokenParser s (ParsedHtml s)+commentToken = +  Parsec.token tokenShow tokenPos+    (\t -> case t of+             (Comment _ s) -> Just (Html.Comment s (tokenPos t))+             otherwise -> Nothing)++scriptToken :: Script s => TokenParser s (ParsedHtml s) +scriptToken = +  Parsec.token tokenShow tokenPos+    (\t -> case t of+             (Script p s) -> Just (Html.Script s p)+             otherwise    -> Nothing)++inlineToken :: Script s => TokenParser s (ParsedHtml s)+inlineToken = +  Parsec.token tokenShow tokenPos+    (\t -> case t of+             (Inline p s d) -> Just (Html.InlineScript s p d)+             otherwise    -> Nothing)+             +endToken :: Script s => TokenParser s HtmlId+endToken = +  Parsec.token tokenShow tokenPos+    (\t -> case t of+             (EndTag p s) -> Just s+             otherwise    -> Nothing)++tagToken :: Script s => TokenParser s (Token s)+tagToken = +  Parsec.token tokenShow tokenPos+  (\t -> case t of+           (Tag p id attrs closed) -> Just t+           otherwise               -> Nothing)++doctypeToken :: Script s => TokenParser s (Token s)+doctypeToken = Parsec.token tokenShow tokenPos $ \t -> case t of+  DoctypeToken _ _ _ _ _ -> Just t+  otherwise -> Nothing++--------------------------------------------------------------------------------+-- HTML fragments++-- |An HTML fragment represents an HTML element with a sequence of children.+data HtmlFragment s = Fragment {+  fragmentPosition   :: SourcePos,+  fragmentName       :: HtmlId,+  fragmentAttributes :: [ParsedAttribute s],+  fragmentChildren   :: [ParsedHtml s]+}++closeFragment:: HtmlFragment s -> ParsedHtml s+closeFragment (Fragment p htmlId attrs children) =  +  Html.Element htmlId attrs (reverse children) p++appendChildToFragment child fragment =+  fragment { fragmentChildren = child : (fragmentChildren fragment) }+             +atomic :: Script s => TokenParser s (ParsedHtml s)+atomic =+  textToken <|> commentToken <|> scriptToken <|> inlineToken <|> entityToken+++maybeClose :: Script s => [HtmlFragment s] -> TokenParser s [HtmlFragment s] +maybeClose es = do+  htmlId <- endToken+  let close [] = do +        warn $ "unmatched closing tag \"" ++ htmlId ++ "\"; ignoring"+        return es+      close (e:e2:es) | fragmentName e == htmlId = do+        return $ (appendChildToFragment (closeFragment e) e2) : es+      close (e:e2:es) | otherwise = +        let e2' = appendChildToFragment (closeFragment e) e2+          in close (e2':es)+      close [e] | fragmentName e == htmlId = do+        return [e]+      close [e] | otherwise = do+        warn $ "unmatched closing tag \"" ++ htmlId ++ "\"; ignoring"+        return [e]+    in close es++open :: Script s => [HtmlFragment s] -> TokenParser s [HtmlFragment s]+open [] = fail "PermissiveParser.open: invalid state (1)"+open (e:es) = do+  (Tag p id attrs isClosed) <- tagToken+  case isClosed of+    True -> return $ (appendChildToFragment (Html.Element id attrs [] p) e) : es+    False ->+      case isEmptyElement id of+        True -> do warn $ "empty-element, \"" ++ id +                            ++ "\" was not immediately closed"+                   return $ (appendChildToFragment (Html.Element id attrs [] p)+                               e) : es+        False -> do+          let fragment = Fragment p id attrs []+              -- If we reach the root, simply make 'fragment' a child.+          let insert [root] = [fragment,root]+              -- The <html> element is the only child of the root.  This+              -- catches all other elements and makes them children of <html>.+              insert [html,root] = [fragment,html,root]+              insert (e1:e2:es) | id `isLegalChildOf` (fragmentName e1) =+                fragment:e1:e2:es+              insert (e1:e2:es) | otherwise =+                insert $ (appendChildToFragment (closeFragment e1) e2):es +              insert [] = fail "PermissiveParser.open: invalid state (2)"+          return $ insert (e:es)++structured es = do+  maybeClose es <|> open es++html' :: Script s => [HtmlFragment s] -> TokenParser s [HtmlFragment s]+html' [] = fail "PermissiveParser.html': invalid state (1)"+html' (e:es) =+  (do a <- atomic+      html' $ (appendChildToFragment a e):es) <|>+  (structured (e:es) >>= html') <|>+  (return (e:es))++parseRoot = Fragment (error "parseRoot: position is meaningless") +                     "DOCROOT"  (error "parseRoot: attributes are meaningless")+                     []++html :: Script s => CharParser [Warning] (Html.Html SourcePos s)+html = do+  let parser = do+        -- optional doctypeToken -- ignored+        fragments <- html' [parseRoot]+        case fragments of+          [fragment] -> case closeFragment fragment of +                          Html.Element _ _ (c:_) _ -> do+                            ws <- getState+                            return (ws,head [c])+                          otherwise -> fail "root element not found"+          otherwise -> fail "no root / multiple roots"+  toks <- tokens -- a stream of HTML entities+  pos <- Parsec.getPosition+  warnings <- Parsec.getState+  case Parsec.runParser parser warnings (Parsec.sourceName pos) toks of+    Left e -> fail  $ "unparsable HTML: " ++ (show e)+    Right (ws,html) -> Parsec.setState ws >> return html ++htmlWithWarnings :: Script s +                 => CharParser [Warning] (Html.Html SourcePos s,[Warning])+htmlWithWarnings = do+  h <- html+  ws <- getState+  return (h,ws)++parseHtmlFromString :: Script s => String -> String -> Either Parsec.ParseError (Html.Html SourcePos s,[Warning])+parseHtmlFromString sourceName sourceText = +  case Parsec.runParser htmlWithWarnings noWarnings sourceName sourceText of+    Left err -> Left err+    Right (html,ws) -> Right (html,ws) ++parseHtmlFromFile :: Script s +                  => String +                  -> IO (Either Parsec.ParseError +                                (Html.Html SourcePos s,[Warning]))+parseHtmlFromFile filename = do+  chars <- readFile filename+  case Parsec.runParser htmlWithWarnings noWarnings filename chars of+    Left err -> return (Left err)+    Right (html,ws) -> return $ Right (html,ws)
+ src/BrownPLT/Html/PrettyPrint.hs view
@@ -0,0 +1,53 @@+-- |Pretty-printer for HTML.  This modules exports no names.  It only defines+-- instances of 'PrettyPrintable' for HTML. +module BrownPLT.Html.PrettyPrint+  ( html+  , renderHtml+  ) where++import qualified Data.List as List+import qualified Data.Char as Char+import Text.PrettyPrint.HughesPJ++import BrownPLT.Html.Syntax++renderHtml :: Script s => Html a s -> String+renderHtml = render.html++vert [] = empty+vert [doc] = doc+vert (doc:docs) = doc <> text "<!--" $+$+                  text "-->" <> vert docs++attr :: Script s => Attribute a s -> Doc+attr a = case a of+  Attribute name value _ ->+    text name <> equals <> doubleQuotes (text value)+  AttributeExpr _ n v "" ->+    text n <> equals <> text "{!" <+> prettyPrintScript v <+> text "!}"+  AttributeExpr _ n v d ->+    text n <> equals <> text "{!" <+> prettyPrintScript v <+> text "|||" <+> +    text d <+> text "!}"++html :: Script s => Html a s -> Doc+html x = case x of+  -- The <script> tag must be terminated by </script>.+  -- <script lang= src= /> doesn't work.+  Element name attrs children _ ->+    -- WARNING: Spacing is very sensitive+    text "<" <> text name <+> hsep (map attr attrs) <> text ">"  -- opening+      $$ (nest 2 (vcat (map html children)))                     -- body+      $$ text "</" <> text name <> text ">"                    -- closing+  -- Horizontally aligned material that is vertically represented in source.+  HtmlSeq xs -> vert (map html xs)+  Text str _ -> text (skipWs str) where+    skipWs str = List.dropWhile Char.isSpace str+  Comment str _ -> text "<!--" <+> text str <+> text "-->"+  ProcessingInstruction str _ -> text "<?" <> text str <> text ">"+  Script s _ -> prettyPrintScript s+  InlineScript script _ "" ->+    text "{!" <+> prettyPrintScript script <+> text "!}"+  InlineScript script _ init -> +    text "{!" <+> prettyPrintScript script <+> text "|||" <+> +    text init <+> text "!}"+
+ src/BrownPLT/Html/RawScript.hs view
@@ -0,0 +1,35 @@+module BrownPLT.Html.RawScript+  ( RawScript (..)+  , parseFromFile+  , parseFromString+  , RawHtml+  ) where++import Data.Generics (Data, Typeable)+import Text.PrettyPrint.HughesPJ (text)+import Text.ParserCombinators.Parsec+import BrownPLT.Html.Syntax+import BrownPLT.Html.PermissiveParser++type RawHtml = Html SourcePos RawScript+++data RawScript = RawScript String deriving (Show,Eq,Typeable,Data)+++instance Script RawScript where++  prettyPrintScript (RawScript s) = text s+  parseInlineScript = Nothing+  +  parseAttributeScript = Nothing+  +  parseScriptBlock _ = do+    s <- manyTill anyChar (string "</script>")+    return (RawScript s)+    ++parseFromString :: String -> RawHtml+parseFromString s = case parseHtmlFromString "" s of+  Left e -> error (show e)+  Right (html,_) -> html
+ src/BrownPLT/Html/Syntax.hs view
@@ -0,0 +1,86 @@+-- |Datatypes for HTML parameterized over an annotation type and a script type.+module BrownPLT.Html.Syntax +  (+  -- * HTML Data Structures+    HtmlId,AttributeValue, Attribute (..), Html (..)+  -- * The Script class+  , Script (..)+  -- * Miscellaneous Functions+  , attributeValue, attributeUpdate, attributeSet, isAttributeExpr+  ) where++import Text.ParserCombinators.Parsec (CharParser, SourcePos)+import Text.PrettyPrint.HughesPJ (Doc)+import Data.Generics (Data, Typeable)++--------------------------------------------------------------------------------+-- Types++type HtmlId = String+type AttributeValue = String++data Attribute a s+  = Attribute HtmlId AttributeValue a+  | AttributeExpr a HtmlId s String+  deriving (Show,Eq,Typeable,Data)++data Html a sc+  = Element HtmlId [Attribute a sc] [Html a sc] a+  | Text String a+  | Comment String a+  | HtmlSeq [Html a sc] -- ^must be a non-empty list+  | ProcessingInstruction String a+  | InlineScript sc a String+  | Script sc a+  deriving (Show,Eq,Typeable,Data)+  +--------------------------------------------------------------------------------+-- The Script class++-- |A type 't' of the 'Script' class can be parsed using 'Parsec'.  't' is of+-- kind '* -> *', as the parsed AST should be annotated with souce locations+-- (see 'Text.ParserCombinators.Parsec.SourcePos').+--+-- The big deal here is that we can embed a parser for some scripting language,+-- (e.g. Javascript) into this HTML parser with ease, while preserving source+-- locations.  The Html datatype is parameterized over a script parser (an+-- instance of Script).+class Script t where+  prettyPrintScript :: t -> Doc+  parseScriptBlock:: [Attribute SourcePos t] -> CharParser a t+  -- An inline script parser, which may be Nothing if the scripting language+  -- does not support inline scripts.+  parseInlineScript:: Maybe (CharParser a t)+  -- A parser for script-expressions defined inline as attribute values.+  parseAttributeScript:: Maybe (CharParser a t)+  +--------------------------------------------------------------------------------+-- HTML navigation++isAttributeExpr (AttributeExpr _ _ _ _) = True+isAttributeExpr _                       = False++-- |Returns the value of the attribute in the list, or 'Nothing' if it doesn't+-- exist of the value is an inline-expression.+attributeValue:: HtmlId -> [Attribute a s] -> Maybe String+attributeValue name [] = Nothing+attributeValue name ((AttributeExpr pos name' expr init):rest) =+  if name == name' then Nothing+                   else attributeValue name rest+attributeValue name ((Attribute name' value _):rest) =+  if name == name' then Just value+                   else attributeValue name rest++attributeSet:: HtmlId -> String -> [Attribute a s]  -> [Attribute a s]+attributeSet n v attrs = attributeUpdate n (\_ -> v) attrs++attributeUpdate:: HtmlId -> (String -> String) -> [Attribute a s] +               -> [Attribute a s]+attributeUpdate n f [] = +  [Attribute n (f "") (error "attributeUpdate--no value")] -- TODO: undefined?!+attributeUpdate n _ ((AttributeExpr _ _ _ _):_) =+  error $ "attributeUpdate: " ++ n ++ " is an expression-attribute."+attributeUpdate n f ((Attribute n' v p):attrs) =+  if n' == n then (Attribute n (f v) p):attrs+             else (Attribute n' v p):(attributeUpdate n f attrs)+
+ src/BrownPLT/JavaScript/Crawl.hs view
@@ -0,0 +1,103 @@+-- |Crawls an HTML page for JavaScript+module BrownPLT.JavaScript.Crawl +  ( getPageJavaScript+  ) where++import Control.Monad+import Data.List+import Data.Char (toLower)+import Data.Generics+import System.IO+import Text.ParserCombinators.Parsec.Pos (SourcePos, sourceName)+import Text.ParserCombinators.Parsec(parse,setPosition,incSourceColumn,Column,sourceLine,sourceColumn)++import BrownPLT.Html.Syntax+import qualified BrownPLT.JavaScript as Js+import BrownPLT.JavaScript.HtmlEmbedding+++instance Typeable SourcePos where+  typeOf _  = +    mkTyConApp (mkTyCon "Text.ParserCombinators.Parsec.Pos.SourcePos") []++ +-- Complete guesswork.  It seems to work.+-- This definition is incomplete.+instance Data SourcePos where+  -- We treat source locations as opaque.  After all, we don't have access to+  -- the constructor.+  gfoldl k z pos = z pos+  toConstr _ = sourcePosConstr1 where+    sourcePosConstr1 = mkConstr sourcePosDatatype "SourcePos" [] Prefix+    sourcePosDatatype = mkDataType "SourcePos" [sourcePosConstr1]+  gunfold   = error "gunfold is not defined for SourcePos"+  dataTypeOf = error "dataTypeOf is not defined for SourcePos"+++-- |Returns the source of the script.+scriptSrc:: 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:: ParsedJsHtml -> [String]+importedScripts = everything (++) (mkQ [] scriptSrc)++-- |Returns the top-level statements of a script.+scriptText :: ParsedJsHtml -> [ParsedStatement]+scriptText (Script (Js.Script _ stmts) _) = stmts+scriptText _ = []++eventHandlers :: [String]+eventHandlers = ["onload","onclick"]; +-- ,"onmousemove","onmouseover","onmousedown","onmouseout","onmouseup","onselectstart", "onkeypress"]++attrScript :: Attribute SourcePos ParsedJavaScript +           -> IO [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 :: ParsedJsHtml -> IO [ParsedStatement]+inpageAttrScripts = everything (liftM2 (++)) (mkQ (return []) attrScript)++inpageScripts :: ParsedJsHtml -> [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:: ParsedJsHtml -> IO [ParsedStatement]+getPageJavascript page = do+  let importURIs = importedScripts page+  let inpageJs   = inpageScripts page+  attrScripts <- inpageAttrScripts page+  importedScripts <- mapM parseJsFile importURIs+  let unScript (Js.Script _ ss) = ss+  return $ (concatMap unScript importedScripts ++ attrScripts) ++ inpageJs++getPageJavaScript:: ParsedJsHtml -> IO [ParsedStatement] -- monomorphism+getPageJavaScript = getPageJavascript
+ src/BrownPLT/JavaScript/HtmlEmbedding.hs view
@@ -0,0 +1,28 @@+module BrownPLT.JavaScript.HtmlEmbedding+  ( JsHtml+  , ParsedJavaScript+  , ParsedJsHtml+  , ParsedStatement+  ) where++import BrownPLT.Html.Syntax+import BrownPLT.JavaScript.Parser (parseScript)+import BrownPLT.JavaScript.Syntax (JavaScript, Statement)+import BrownPLT.JavaScript.PrettyPrint (javaScript)+import Text.ParserCombinators.Parsec (SourcePos)++type JsHtml a = Html SourcePos (JavaScript a)++type ParsedJavaScript = JavaScript SourcePos++type ParsedJsHtml = JsHtml SourcePos++type ParsedStatement = Statement SourcePos++instance Script ParsedJavaScript where+  prettyPrintScript s = javaScript s+  parseScriptBlock attrs = parseScript+  parseInlineScript = Nothing+  parseAttributeScript = Nothing+    +