diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -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 }) diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,29 +0,0 @@ -#!/usr/bin/env runhaskell -> import Distribution.Simple -> import qualified Data.List as L -> import System.Directory -> import System.Process (runCommand,waitForProcess) - -> isHaskellFile file = ".lhs" `L.isSuffixOf` file || ".hs" `L.isSuffixOf` file - -> moduleName file = L.takeWhile (/= '.') file - -> testMain _ _ _ _ = do -> files <- getDirectoryContents "tests" -> let testModules = [moduleName f | f <- files, isHaskellFile f] -> let testFuncs = map (++ ".main") testModules -> let testExpr = "sequence [ " ++ concat (L.intersperse "," testFuncs) ++ -> " ] >>= \\cases -> runTestTT (TestList cases)" -> let moduleLine = concat (L.intersperse " " testModules) -> let cmd = "cd tests && ghc -XNoMonomorphismRestriction -fglasgow-exts " ++ -> "-package HUnit -i:../src -e \"" ++ testExpr ++ -> " >> return ()\" " ++ moduleLine -> putStrLn "Testing command is:" -> putStrLn cmd -> putStrLn "\nLoading tests..." -> handle <- runCommand cmd -> waitForProcess handle -> putStrLn "Testing complete. Errors reported above (if any)." - - -> main = defaultMainWithHooks (simpleUserHooks { runTests = testMain }) diff --git a/WebBits.cabal b/WebBits.cabal --- a/WebBits.cabal +++ b/WebBits.cabal @@ -1,7 +1,7 @@ Name: WebBits -Version: 0.11.0 +Version: 0.14.0 Cabal-Version: >= 1.2.3 -Copyright: Copyright (c) 2007-2008 Arjun Guha and Spiridon Eliopoulos +Copyright: Copyright (c) 2007-2009 Arjun Guha and Spiridon Eliopoulos License: LGPL License-file: LICENSE Author: Arjun Guha, Spiridon Eliopoulos @@ -16,16 +16,16 @@ WebBits is a collection of libraries for working with JavaScript embeded in HTML files. Highlights include: . - * @WebBits.JavaScript.Crawl@ returns all JavaScript in an HTML page, including + * @BrownPLT.JavaScript.Crawl@ returns all JavaScript in an HTML page, including JavaScript from imported script files (@\. + -- ") + return (RawScript s) + + +parseFromString :: String -> RawHtml +parseFromString s = case parseHtmlFromString "" s of + Left e -> error (show e) + Right (html,_) -> html diff --git a/src/BrownPLT/Html/Syntax.hs b/src/BrownPLT/Html/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/BrownPLT/Html/Syntax.hs @@ -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) + diff --git a/src/BrownPLT/JavaScript.hs b/src/BrownPLT/JavaScript.hs new file mode 100644 --- /dev/null +++ b/src/BrownPLT/JavaScript.hs @@ -0,0 +1,17 @@ +-- |Re-exports commonly used modules. +module BrownPLT.JavaScript + ( module BrownPLT.JavaScript.Syntax + , module BrownPLT.JavaScript.HtmlEmbedding + , module BrownPLT.JavaScript.Parser + -- JavaScript.Instances exports nothing + , renderStatements + , renderExpression + ) where + + +import BrownPLT.JavaScript.Syntax +import BrownPLT.JavaScript.Parser +import BrownPLT.JavaScript.PrettyPrint +import BrownPLT.JavaScript.HtmlEmbedding + +import BrownPLT.JavaScript.Instances diff --git a/src/BrownPLT/JavaScript/Crawl.hs b/src/BrownPLT/JavaScript/Crawl.hs new file mode 100644 --- /dev/null +++ b/src/BrownPLT/JavaScript/Crawl.hs @@ -0,0 +1,102 @@ +-- |Crawls an HTML page for JavaScript +module BrownPLT.JavaScript.Crawl + ( getPageJavaScript + ) where + +import Control.Monad +import Data.List +import Data.Char (toLower) +import Data.Generics +import System.IO +import Text.ParserCombinators.Parsec.Pos (SourcePos, sourceName) +import Text.ParserCombinators.Parsec(parse,setPosition,incSourceColumn,Column,sourceLine,sourceColumn) + +import BrownPLT.Html.Syntax +import qualified BrownPLT.JavaScript as Js + + +instance Typeable SourcePos where + typeOf _ = + mkTyConApp (mkTyCon "Text.ParserCombinators.Parsec.Pos.SourcePos") [] + + +-- Complete guesswork. It seems to work. +-- This definition is incomplete. +instance Data SourcePos where + -- We treat source locations as opaque. After all, we don't have access to + -- the constructor. + gfoldl k z pos = z pos + toConstr _ = sourcePosConstr1 where + sourcePosConstr1 = mkConstr sourcePosDatatype "SourcePos" [] Prefix + sourcePosDatatype = mkDataType "SourcePos" [sourcePosConstr1] + gunfold = error "gunfold is not defined for SourcePos" + dataTypeOf = error "dataTypeOf is not defined for SourcePos" + + +-- |Returns the source of the script. +scriptSrc:: Js.ParsedJsHtml -> [String] +scriptSrc (Element tag attrs _ _) | (map toLower tag) == "script" = + case attributeValue "src" attrs of -- TODO: Check for type="javascript"? + Just "" -> [] + Just url -> [url] + Nothing -> [] +scriptSrc _ = + [] + + +-- |Returns a list of URIs for external Javascript files referenced in the page. +importedScripts:: Js.ParsedJsHtml -> [String] +importedScripts = everything (++) (mkQ [] scriptSrc) + +-- |Returns the top-level statements of a script. +scriptText :: Js.ParsedJsHtml -> [Js.ParsedStatement] +scriptText (Script (Js.Script _ stmts) _) = stmts +scriptText _ = [] + +eventHandlers :: [String] +eventHandlers = ["onload","onclick"]; +-- ,"onmousemove","onmouseover","onmousedown","onmouseout","onmouseup","onselectstart", "onkeypress"] + +attrScript :: Attribute SourcePos Js.ParsedJavaScript + -> IO [Js.ParsedStatement] +attrScript (Attribute id val loc) | id `elem` eventHandlers = do + let eventId = drop 2 id -- drop the "on" prefix + let scriptText = if "javascript:" `isPrefixOf` val then drop 11 val else val + let eventListenerPrefix = "addEventListener('" ++ eventId ++ "', function(event) { " + let prefixLen = length eventListenerPrefix + let eventListenerText = eventListenerPrefix ++ scriptText ++ " });" + let parser = do + setPosition (incSourceColumn loc (-prefixLen)) + Js.parseExpression + case parse parser (sourceName loc) eventListenerText of + Left err -> do + fail $ "Error parsiing JavaScript in an attribute at " ++ show loc ++ + "\nThe script was:\n\n" ++ eventListenerText + Right e -> return [Js.ExprStmt loc e] +attrScript _ = return [] + +inpageAttrScripts :: Js.ParsedJsHtml -> IO [Js.ParsedStatement] +inpageAttrScripts = everything (liftM2 (++)) (mkQ (return []) attrScript) + +inpageScripts :: Js.ParsedJsHtml -> [Js.ParsedStatement] +inpageScripts = everything (++) (mkQ [] scriptText) + +parseJsFile path = do + text <- readFile path + case Js.parseScriptFromString path text of + Left err -> fail (show err) + Right js -> hPutStrLn stderr ("Read file " ++ path) >> return js + +-- |Given an HTML page, crawls all external Javascript files and returns a list +-- of statements, concatenated from all files. +getPageJavascript:: Js.ParsedJsHtml -> IO [Js.ParsedStatement] +getPageJavascript page = do + let importURIs = importedScripts page + let inpageJs = inpageScripts page + attrScripts <- inpageAttrScripts page + importedScripts <- mapM parseJsFile importURIs + let unScript (Js.Script _ ss) = ss + return $ (concatMap unScript importedScripts ++ attrScripts) ++ inpageJs + +getPageJavaScript:: Js.ParsedJsHtml -> IO [Js.ParsedStatement] -- monomorphism +getPageJavaScript = getPageJavascript diff --git a/src/BrownPLT/JavaScript/Environment.hs b/src/BrownPLT/JavaScript/Environment.hs new file mode 100644 --- /dev/null +++ b/src/BrownPLT/JavaScript/Environment.hs @@ -0,0 +1,146 @@ +module BrownPLT.JavaScript.Environment + ( env + , localVars + , EnvTree (..) + ) where + +import Data.List +import Data.Maybe +import qualified Data.Map as M +import Data.Map (Map) +import qualified Data.Set as S +import Data.Set (Set) +import Text.ParserCombinators.Parsec.Pos (SourcePos) + +import BrownPLT.JavaScript.Syntax + +-- Intermediate data structure that contains locally declared names and +-- all references to identifers. +data Partial = Partial { + partialLocals :: M.Map String SourcePos, + partialReferences :: M.Map String SourcePos, + partialNested :: [Partial] +} + +empty :: Partial +empty = Partial M.empty M.empty [] + +ref :: Id SourcePos -> Partial +ref (Id p v) = Partial M.empty (M.singleton v p) [] + +decl :: Id SourcePos -> Partial +decl (Id p v) = Partial (M.singleton v p) M.empty [] + +nest :: Partial -> Partial +nest partial = Partial M.empty M.empty [partial] + +-- Combine partial results from the same lexical scope. +unions :: [Partial] -> Partial +unions ps = Partial (M.unions (map partialLocals ps)) + (M.unions (map partialReferences ps)) + (concatMap partialNested ps) + +javascript :: JavaScript SourcePos -> Partial +javascript (Script _ ss) = unions (map stmt ss) + +expr :: Expression SourcePos -> Partial +expr e = case e of + StringLit _ _ -> empty + RegexpLit _ _ _ _ -> empty + NumLit _ _ -> empty + IntLit _ _ -> empty + BoolLit _ _ -> empty + NullLit _ -> empty + ArrayLit _ es -> unions (map expr es) + ObjectLit _ props -> unions (map (expr.snd) props) + ThisRef _ -> empty + VarRef _ id -> empty + DotRef _ e _ -> expr e + BracketRef _ e1 e2 -> unions [expr e1, expr e2] + NewExpr _ e1 es -> unions [expr e1, unions $ map expr es] + PostfixExpr _ _ e -> expr e + PrefixExpr _ _ e -> expr e + InfixExpr _ _ e1 e2 -> unions [expr e1, expr e2] + CondExpr _ e1 e2 e3 -> unions [expr e1, expr e2, expr e3] + AssignExpr _ _ (VarRef _ id) e -> unions [ref id, expr e] + AssignExpr _ _ e1 e2 -> unions [expr e1, expr e2] + ParenExpr _ e -> expr e + ListExpr _ es -> unions (map expr es) + CallExpr _ e es -> unions [expr e, unions $ map expr es] + FuncExpr _ args s -> nest $ unions [unions $ map decl args, stmt s] + +caseClause :: CaseClause SourcePos -> Partial +caseClause cc = case cc of + CaseClause _ e ss -> unions [expr e, unions $ map stmt ss] + CaseDefault _ ss -> unions $ map stmt ss + +-- TODO: Verify that this is a declaration and not a reference. +catchClause :: CatchClause SourcePos -> Partial +catchClause (CatchClause _ id s) = unions [decl id, stmt s] + +varDecl :: VarDecl SourcePos -> Partial +varDecl (VarDecl _ id Nothing) = decl id +varDecl (VarDecl _ id (Just e)) = unions [decl id, expr e] + +forInit :: ForInit SourcePos -> Partial +forInit fi = case fi of + NoInit -> empty + VarInit ds -> unions $ map varDecl ds + ExprInit e -> expr e + +forInInit :: ForInInit SourcePos -> Partial +forInInit (ForInVar id) = decl id +forInInit (ForInNoVar id) = ref id + +stmt :: Statement SourcePos -> Partial +stmt s = case s of + BlockStmt _ ss -> unions $ map stmt ss + EmptyStmt _ -> empty + ExprStmt _ e -> expr e + IfStmt _ e s1 s2 -> unions [expr e, stmt s1, stmt s2] + IfSingleStmt _ e s -> unions [expr e, stmt s] + SwitchStmt _ e cases -> unions [expr e, unions $ map caseClause cases] + WhileStmt _ e s -> unions [expr e, stmt s] + DoWhileStmt _ s e -> unions [stmt s, expr e] + BreakStmt _ _ -> empty + ContinueStmt _ _ -> empty + LabelledStmt _ _ s -> stmt s + ForInStmt _ fii e s -> unions [forInInit fii, expr e, stmt s] + ForStmt _ fi me1 me2 s -> + unions [forInit fi, maybe empty expr me1, maybe empty expr me2, stmt s] + TryStmt _ s catches ms -> + unions [stmt s, unions $ map catchClause catches, maybe empty stmt ms] + ThrowStmt _ e -> expr e + ReturnStmt _ me -> maybe empty expr me + WithStmt _ e s -> unions [expr e, stmt s] + VarDeclStmt _ decls -> unions $ map varDecl decls + FunctionStmt _ fnId args s -> + unions [decl fnId, nest $ unions [unions $ map decl args, stmt s]] + +-- |The statically-determinate lexical structure of a JavaScript program. +data EnvTree = EnvTree (M.Map String SourcePos) [EnvTree] + +-- A 'Partial' specifies identifier references in addition to identifier +-- declarations. We descend into a 'Partial', pushing enclosing declarations +-- in to remove references to identifiers declared in the enclosing scope. +-- Any referencs to identifiers not declared in either the current or the +-- enclosing scope are local definitions of global variables. +makeEnvTree :: Map String SourcePos -- ^enclosing environment + -> Partial -- ^local environment and references + -> (EnvTree,Map String SourcePos) + -- ^environment and global definitions +makeEnvTree enclosing (Partial locals references nested) = (tree,globals) where + nestedResults = map (makeEnvTree (locals `M.union` enclosing)) nested + tree = EnvTree locals (map fst nestedResults) + globals' = (references `M.difference` locals) `M.difference` enclosing + globals = M.unions (globals':(map snd nestedResults)) + +env :: Map String SourcePos -- ^browser/testing environment + -> [Statement SourcePos] + -> (EnvTree,Map String SourcePos) +env globals program = makeEnvTree globals (unions $ map stmt program) + +localVars :: [Statement SourcePos] + -> Set String +localVars body = S.fromList (M.keys locals) where + Partial locals _ _ = unions $ map stmt body diff --git a/src/BrownPLT/JavaScript/HtmlEmbedding.hs b/src/BrownPLT/JavaScript/HtmlEmbedding.hs new file mode 100644 --- /dev/null +++ b/src/BrownPLT/JavaScript/HtmlEmbedding.hs @@ -0,0 +1,25 @@ +module BrownPLT.JavaScript.HtmlEmbedding + ( JsHtml + , ParsedJavaScript + , ParsedJsHtml + ) where + +import BrownPLT.Html.Syntax +import BrownPLT.JavaScript.Parser (parseScript) +import BrownPLT.JavaScript.Syntax (JavaScript) +import BrownPLT.JavaScript.PrettyPrint (javaScript) +import Text.ParserCombinators.Parsec (SourcePos) + +type JsHtml a = Html SourcePos (JavaScript a) + +type ParsedJavaScript = JavaScript SourcePos + +type ParsedJsHtml = JsHtml SourcePos + +instance Script ParsedJavaScript where + prettyPrintScript s = javaScript s + parseScriptBlock attrs = parseScript + parseInlineScript = Nothing + parseAttributeScript = Nothing + + diff --git a/src/BrownPLT/JavaScript/Instances.hs b/src/BrownPLT/JavaScript/Instances.hs new file mode 100644 --- /dev/null +++ b/src/BrownPLT/JavaScript/Instances.hs @@ -0,0 +1,294 @@ +-- |Instances of 'Foldable' and 'Traversable' for JavaScript's syntax. +module BrownPLT.JavaScript.Instances + ( -- This module does not export any names. + ) where + +import Prelude hiding (foldr,sequence,mapM) +import qualified Prelude as Prelude + +import Data.Foldable (Foldable(..)) +import Data.Traversable(Traversable(..)) +import Control.Applicative + +import BrownPLT.JavaScript.Syntax + +yfoldr:: Foldable t => (a -> b -> b) -> b -> Maybe (t a) -> b +yfoldr _ b Nothing = b +yfoldr f b (Just t) = foldr f b t + +lfoldr:: Foldable t => (a -> b -> b) -> b -> [t a] -> b +lfoldr f = Prelude.foldr (flip $ foldr f) + +ltraverse:: (Traversable t, Applicative f) => (a -> f b) -> [t a] -> f [t b] +ltraverse _ [] = pure [] +ltraverse f (a:as) = (:) <$> traverse f a <*> ltraverse f as + +ytraverse:: (Traversable t, Applicative f) + => (a -> f b) -> Maybe (t a) -> f (Maybe (t b)) +ytraverse _ Nothing = pure Nothing +ytraverse f (Just t) = Just <$> traverse f t + +instance Functor Id where + fmap f (Id a v) = Id (f a) v + +instance Functor JavaScript where + fmap f (Script a stmts) = Script (f a) (map (fmap f) stmts) + +instance Functor Prop where + fmap f (PropId a id) = PropId (f a) (fmap f id) + fmap f (PropString a s) = PropString (f a) s + fmap f (PropNum a n) = PropNum (f a) n + +instance Functor Expression where + fmap f expression = + case expression of + StringLit a s -> StringLit (f a) s + RegexpLit a s g ci -> RegexpLit (f a) s g ci + NumLit a n -> NumLit (f a) n + IntLit a n -> IntLit (f a) n + BoolLit a b -> BoolLit (f a) b + NullLit a -> NullLit (f a) + ArrayLit a es -> ArrayLit (f a) (map (fmap f) es) + ObjectLit a pes -> ObjectLit (f a) (map f' pes) where + f' (p,e) = (fmap f p, fmap f e) + ThisRef a -> ThisRef (f a) + VarRef a id -> VarRef (f a) (fmap f id) + DotRef a e id -> DotRef (f a) (fmap f e) (fmap f id) + BracketRef a e1 e2 -> BracketRef (f a) (fmap f e1) (fmap f e2) + NewExpr a e es -> NewExpr (f a) (fmap f e) (map (fmap f) es) + PostfixExpr a op e -> PostfixExpr (f a) op (fmap f e) + PrefixExpr a op e -> PrefixExpr (f a) op (fmap f e) + InfixExpr a op e1 e2 -> InfixExpr (f a) op (fmap f e1) (fmap f e2) + CondExpr a e1 e2 e3 -> CondExpr (f a) (fmap f e1) (fmap f e2) (fmap f e3) + AssignExpr a op e1 e2 -> AssignExpr (f a) op (fmap f e1) (fmap f e2) + ParenExpr a e -> ParenExpr (f a) (fmap f e) + ListExpr a es -> ListExpr (f a) (map (fmap f) es) + CallExpr a e es -> CallExpr (f a) (fmap f e) (map (fmap f) es) + FuncExpr a args s -> FuncExpr (f a) (map (fmap f) args) (fmap f s) + +instance Functor CaseClause where + fmap f (CaseClause a e ss) = CaseClause (f a) (fmap f e) (map (fmap f) ss) + fmap f (CaseDefault a ss) = CaseDefault (f a) (map (fmap f) ss) + +instance Functor CatchClause where + fmap f (CatchClause a id s) = CatchClause (f a) (fmap f id) (fmap f s) + +instance Functor VarDecl where + fmap f (VarDecl a id Nothing) = VarDecl (f a) (fmap f id) Nothing + fmap f (VarDecl a id (Just e)) = VarDecl (f a) (fmap f id) (Just $ fmap f e) + +instance Functor ForInit where + fmap f NoInit = NoInit + fmap f (VarInit decls) = VarInit (map (fmap f) decls) + fmap f (ExprInit e) = ExprInit (fmap f e) + +instance Functor ForInInit where + fmap f (ForInVar id) = ForInVar (fmap f id) + fmap f (ForInNoVar id) = ForInNoVar (fmap f id) + +instance Functor Statement where + fmap f s = + case s of + BlockStmt a ss -> BlockStmt (f a) (map (fmap f) ss) + EmptyStmt a -> EmptyStmt (f a) + ExprStmt a e -> ExprStmt (f a) (fmap f e) + IfStmt a e s1 s2 -> IfStmt (f a) (fmap f e) (fmap f s1) (fmap f s2) + IfSingleStmt a e s -> IfSingleStmt (f a) (fmap f e) (fmap f s) + SwitchStmt a e cs -> SwitchStmt (f a) (fmap f e) (map (fmap f) cs) + WhileStmt a e s -> WhileStmt (f a) (fmap f e) (fmap f s) + DoWhileStmt a s e -> DoWhileStmt (f a) (fmap f s) (fmap f e) + BreakStmt a Nothing -> BreakStmt (f a) Nothing + BreakStmt a (Just id) -> BreakStmt (f a) (Just (fmap f id)) + ContinueStmt a yid -> ContinueStmt (f a) (yid >>= return.(fmap f)) + LabelledStmt a id s -> LabelledStmt (f a) (fmap f id) (fmap f s) + ForInStmt a init e s -> ForInStmt (f a) (fmap f init) (fmap f e) + (fmap f s) + ForStmt a init yinc ytest body -> + ForStmt (f a) (fmap f init) (yinc >>= return.(fmap f)) + (ytest >>= return.(fmap f)) (fmap f body) + TryStmt a s cs ys -> + TryStmt (f a) (fmap f s) (map (fmap f) cs) (ys >>= return.(fmap f)) + ThrowStmt a e -> ThrowStmt (f a) (fmap f e) + ReturnStmt a ye -> ReturnStmt (f a) (ye >>= return.(fmap f)) + WithStmt a e s -> WithStmt (f a) (fmap f e) (fmap f s) + VarDeclStmt a ds -> VarDeclStmt (f a) (map (fmap f) ds) + FunctionStmt a id args s -> + FunctionStmt (f a) (fmap f id) (map (fmap f) args) (fmap f s) + +instance Foldable Id where + foldr f b (Id a _) = f a b + +instance Foldable Prop where + foldr f b (PropId a id) = f a (foldr f b id) + foldr f b (PropString a _) = f a b + foldr f b (PropNum a _) = f a b + +instance Foldable Expression where + -- foldr:: (a -> b -> b) -> b -> Expression a -> b + foldr f b e = + case e of + StringLit a _ -> f a b + RegexpLit a _ _ _ -> f a b + NumLit a _ -> f a b + IntLit a _ -> f a b + BoolLit a _ -> f a b + NullLit a -> f a b + ArrayLit a es -> f a (Prelude.foldr (flip $ foldr f) b es) + ObjectLit a pes -> f a (Prelude.foldr f' b pes) where + f' (p,e) b = foldr f (foldr f b e) p + ThisRef a -> f a b + VarRef a id -> f a (foldr f b id) + DotRef a e id -> f a (foldr f (foldr f b id) e) + BracketRef a e1 e2 -> f a (foldr f (foldr f b e2) e1) + NewExpr a e es -> f a (foldr f (Prelude.foldr (flip $ foldr f) b es) e) + PostfixExpr a _ e -> f a $ foldr f b e + PrefixExpr a _ e -> f a $ foldr f b e + InfixExpr a _ e1 e2 -> f a $ foldr f (foldr f b e2) e1 + CondExpr a e1 e2 e3 -> f a $ foldr f (foldr f (foldr f b e3) e2) e1 + AssignExpr a _ e1 e2 -> f a $ foldr f (foldr f b e2) e1 + ParenExpr a e -> f a $ foldr f b e + ListExpr a es -> f a $ Prelude.foldr (flip $ foldr f) b es + CallExpr a e es -> f a $ foldr f (Prelude.foldr (flip $ foldr f) b es) e + FuncExpr a args s -> + f a $ Prelude.foldr (flip $ foldr f) (foldr f b s) args + +instance Foldable CaseClause where + foldr f b (CaseClause a e ss) = + f a $ foldr f (Prelude.foldr (flip $ foldr f) b ss) e + foldr f b (CaseDefault a ss) = f a $ Prelude.foldr (flip $ foldr f) b ss + +instance Foldable CatchClause where + foldr f b (CatchClause a id s) = f a $ foldr f (foldr f b s) id + +instance Foldable VarDecl where + foldr f b (VarDecl a id ye) = f a $ foldr f (yfoldr f b ye) id + +instance Foldable ForInit where + foldr f b NoInit = b + foldr f b (VarInit ds) = Prelude.foldr (flip $ foldr f) b ds + foldr f b (ExprInit e) = foldr f b e + +instance Foldable ForInInit where + foldr f b (ForInVar id) = foldr f b id + foldr f b (ForInNoVar id) = foldr f b id + +instance Foldable Statement where + foldr f b statement = + case statement of + BlockStmt a ss -> f a $ lfoldr f b ss + EmptyStmt a -> f a b + ExprStmt a e -> f a $ foldr f b e + IfStmt a e s1 s2 -> f a $ foldr f (foldr f (foldr f b s2) s1) e + IfSingleStmt a e s -> f a $ foldr f (foldr f b s) e + SwitchStmt a e cs -> f a $ foldr f (lfoldr f b cs) e + WhileStmt a e s -> f a $ foldr f (foldr f b s) e + DoWhileStmt a s e -> f a $ foldr f (foldr f b e) s + BreakStmt a yid -> f a $ yfoldr f b yid + ContinueStmt a yid -> f a $ yfoldr f b yid + LabelledStmt a id s -> f a $ foldr f (foldr f b s) id + ForInStmt a init e s -> f a $ foldr f (foldr f (foldr f b s) e) init + ForStmt a init ye1 ye2 s -> + f a $ foldr f (yfoldr f (yfoldr f (foldr f b s) ye2) ye1) init + TryStmt a s cs ys -> f a $ foldr f (lfoldr f (yfoldr f b ys) cs) s + ThrowStmt a e -> f a $ foldr f b e + ReturnStmt a ys -> f a $ yfoldr f b ys + WithStmt a e s -> f a $ foldr f (foldr f b s) e + VarDeclStmt a ds -> f a $ lfoldr f b ds + FunctionStmt a id args s -> + f a $ lfoldr f (foldr f b s) (id:args) + +instance Traversable Id where + traverse f (Id a v) = Id <$> f a <*> pure v + +instance Traversable Prop where + traverse f (PropId a id) = PropId <$> f a <*> traverse f id + traverse f (PropString a s) = PropString <$> f a <*> pure s + traverse f (PropNum a n) = PropNum <$> f a <*> pure n + +instance Traversable Expression where + traverse f expression = + case expression of + StringLit a s -> StringLit <$> f a <*> pure s + RegexpLit a s g ci -> RegexpLit <$> f a <*> pure s <*> pure g <*> pure ci + NumLit a n -> NumLit <$> f a <*> pure n + IntLit a n -> IntLit <$> f a <*> pure n + BoolLit a b -> BoolLit <$> f a <*> pure b + NullLit a -> NullLit <$> f a + ArrayLit a es -> ArrayLit <$> f a <*> ltraverse f es + ObjectLit a ps -> ObjectLit <$> f a <*> (zip <$> props' <*> es') where + (props,es) = unzip ps + props' = ltraverse f props + es' = ltraverse f es + ThisRef a -> ThisRef <$> f a + VarRef a id -> VarRef <$> f a <*> traverse f id + DotRef a e id -> DotRef <$> f a <*> traverse f e <*> traverse f id + BracketRef a e es -> BracketRef <$> f a <*> traverse f e <*> traverse f es + NewExpr a e es -> NewExpr <$> f a <*> traverse f e <*> ltraverse f es + PostfixExpr a op e -> PostfixExpr <$> f a <*> pure op <*> traverse f e + PrefixExpr a op e -> PrefixExpr <$> f a <*> pure op <*> traverse f e + InfixExpr a op e1 e2 -> InfixExpr <$> f a <*> pure op <*> traverse f e1 + <*> traverse f e2 + CondExpr a e1 e2 e3 -> + CondExpr <$> f a <*> traverse f e1 <*> traverse f e2 <*> traverse f e3 + AssignExpr a op e1 e2 -> AssignExpr <$> f a <*> pure op <*> traverse f e1 + <*> traverse f e2 + ParenExpr a e -> ParenExpr <$> f a <*> traverse f e + ListExpr a es -> ListExpr <$> f a <*> ltraverse f es + CallExpr a e es -> CallExpr <$> f a <*> traverse f e <*> ltraverse f es + FuncExpr a ids s -> FuncExpr <$> f a <*> ltraverse f ids <*> traverse f s + +instance Traversable CaseClause where + traverse f (CaseClause a e ss) = + CaseClause <$> f a <*> traverse f e <*> ltraverse f ss + traverse f (CaseDefault a ss) = + CaseDefault <$> f a <*> ltraverse f ss + +instance Traversable CatchClause where + traverse f (CatchClause a id s) = + CatchClause <$> f a <*> traverse f id <*> traverse f s + +instance Traversable VarDecl where + traverse f (VarDecl a id ye) = + VarDecl <$> f a <*> traverse f id <*> ytraverse f ye + +instance Traversable ForInit where + traverse f NoInit = pure NoInit + traverse f (VarInit ds) = VarInit <$> ltraverse f ds + traverse f (ExprInit e) = ExprInit <$> traverse f e + +instance Traversable ForInInit where + traverse f (ForInVar id) = ForInVar <$> traverse f id + traverse f (ForInNoVar id) = ForInNoVar <$> traverse f id + +instance Traversable Statement where + traverse f statement = + case statement of + BlockStmt a ss -> BlockStmt <$> f a <*> ltraverse f ss + EmptyStmt a -> EmptyStmt <$> f a + ExprStmt a e -> ExprStmt <$> f a <*> traverse f e + IfStmt a e s1 s2 -> + IfStmt <$> f a <*> traverse f e <*> traverse f s1 <*> traverse f s2 + IfSingleStmt a e s -> + IfSingleStmt <$> f a <*> traverse f e <*> traverse f s + SwitchStmt a e cs -> + SwitchStmt <$> f a <*> traverse f e <*> ltraverse f cs + WhileStmt a e s -> WhileStmt <$> f a <*> traverse f e <*> traverse f s + DoWhileStmt a s e -> DoWhileStmt <$> f a <*> traverse f s <*> traverse f e + BreakStmt a yid -> BreakStmt <$> f a <*> ytraverse f yid + ContinueStmt a yid -> ContinueStmt <$> f a <*> ytraverse f yid + LabelledStmt a id s -> + LabelledStmt <$> f a <*> traverse f id <*> traverse f s + ForInStmt a init e s -> + ForInStmt <$> f a <*> traverse f init <*> traverse f e <*> traverse f s + ForStmt a init yinc ytest s -> + ForStmt <$> f a <*> traverse f init <*> ytraverse f yinc + <*> ytraverse f ytest <*> traverse f s + TryStmt a s cs ys -> + TryStmt <$> f a <*> traverse f s <*> ltraverse f cs <*> ytraverse f ys + ThrowStmt a e -> ThrowStmt <$> f a <*> traverse f e + ReturnStmt a ys -> ReturnStmt <$> f a <*> ytraverse f ys + WithStmt a e s -> WithStmt <$> f a <*> traverse f e <*> traverse f s + VarDeclStmt a ds -> VarDeclStmt <$> f a <*> ltraverse f ds + FunctionStmt a id args s -> + FunctionStmt <$> f a <*> traverse f id <*> ltraverse f args + <*> traverse f s diff --git a/src/BrownPLT/JavaScript/Lexer.hs b/src/BrownPLT/JavaScript/Lexer.hs new file mode 100644 --- /dev/null +++ b/src/BrownPLT/JavaScript/Lexer.hs @@ -0,0 +1,64 @@ +{- This isn't a lexer in the sense that it provides a JavaScript token-stream. + - This module provides character-parsers for various JavaScript tokens. + -} +module BrownPLT.JavaScript.Lexer(lexeme,identifier,reserved,operator,reservedOp,charLiteral, + stringLiteral,natural,integer,float,naturalOrFloat, + decimal,hexadecimal,octal,symbol,whiteSpace,parens, + braces,brackets,squares,semi,comma,colon,dot, + identifierStart) where + +import Prelude hiding (lex) +import Text.ParserCombinators.Parsec +import qualified Text.ParserCombinators.Parsec.Token as T + +identifierStart = (letter <|> oneOf "$_") + +javascriptDef = + T.LanguageDef "/*" + "*/" + "//" + False -- no nested comments + {- Adapted from syntax/regexps.ss in Dave's code. -} + identifierStart + (alphaNum <|> oneOf "$_") -- identifier rest + (oneOf "{}<>()~.,?:|&^=!+-*/%!") -- operator start + (oneOf "=<>|&+") -- operator rest + ["break", "case", "catch", "const", "continue", "debugger", + "default", "delete", "do", "else", "enum", "false", "finally", + "for", "function", "if", "instanceof", "in", "let", "new", + "null", "return", "switch", "this", "throw", "true", "try", + "typeof", "var", "void", "while", "with"] + ["|=", "^=", "&=", "<<=", ">>=", ">>>=", "+=", "-=", "*=", "/=", + "%=", "=", ";", ",", "?", ":", "||", "&&", "|", "^", "&", + "===", "==", "=", "!==", "!=", "<<", "<=", "<", ">>>", ">>", + ">=", ">", "++", "--", "+", "-", "*", "/", "%", "!", "~", ".", + "[", "]", "{", "}", "(", ")"," will not try its alternate in parseExpression, and we will fail. + +parseIfStmt:: StatementParser st +parseIfStmt = do + pos <- getPosition + reserved "if" + test <- parseParenExpr "parenthesized test-expression in if statement" + consequent <- parseStatement "true-branch of if statement" + optional semi -- TODO: in spec? + ((do reserved "else" + alternate <- parseStatement + return (IfStmt pos test consequent alternate)) + <|> return (IfSingleStmt pos test consequent)) + +parseSwitchStmt:: StatementParser st +parseSwitchStmt = + let parseDefault = do + pos <- getPosition + reserved "default" + colon + statements <- many parseStatement + return (CaseDefault pos statements) + parseCase = do + pos <- getPosition + reserved "case" + condition <- parseListExpr + colon + actions <- many parseStatement + return (CaseClause pos condition actions) + in do pos <- getPosition + reserved "switch" + test <- parseParenExpr + clauses <- braces $ many $ parseDefault <|> parseCase + return (SwitchStmt pos test clauses) + +parseWhileStmt:: StatementParser st +parseWhileStmt = do + pos <- getPosition + reserved "while" + test <- parseParenExpr "parenthesized test-expression in while loop" + body <- parseStatement + return (WhileStmt pos test body) + +parseDoWhileStmt:: StatementParser st +parseDoWhileStmt = do + pos <- getPosition + reserved "do" + body <- parseBlockStmt + reserved "while" "while at the end of a do block" + test <- parseParenExpr "parenthesized test-expression in do loop" + optional semi + return (DoWhileStmt pos body test) + +parseContinueStmt:: StatementParser st +parseContinueStmt = do + pos <- getPosition + reserved "continue" + pos' <- getPosition + -- Ensure that the identifier is on the same line as 'continue.' + id <- (if (sourceLine pos == sourceLine pos') + then (liftM Just identifier) <|> (return Nothing) + else return Nothing) + return (ContinueStmt pos id) + +parseBreakStmt:: StatementParser st +parseBreakStmt = do + pos <- getPosition + reserved "break" + pos' <- getPosition + -- Ensure that the identifier is on the same line as 'break.' + id <- (if (sourceLine pos == sourceLine pos') + then (liftM Just identifier) <|> (return Nothing) + else return Nothing) + optional semi + return (BreakStmt pos id) + +parseBlockStmt:: StatementParser st +parseBlockStmt = do + pos <- getPosition + statements <- braces (many parseStatement) + return (BlockStmt pos statements) + +parseEmptyStmt:: StatementParser st +parseEmptyStmt = do + pos <- getPosition + semi + return (EmptyStmt pos) + +parseLabelledStmt:: StatementParser st +parseLabelledStmt = do + pos <- getPosition + -- Lookahead for the colon. If we don't see it, we are parsing an identifier + -- for an expression statement. + label <- try (do label <- identifier + colon + return label) + statement <- parseStatement + return (LabelledStmt pos label statement) + +parseExpressionStmt:: StatementParser st +parseExpressionStmt = do + pos <- getPosition + expr <- parseListExpr -- TODO: spec 12.4? + optional semi + return (ExprStmt pos expr) + + +parseForInStmt:: StatementParser st +parseForInStmt = + let parseInit = (reserved "var" >> liftM ForInVar identifier) + <|> (liftM ForInNoVar identifier) + in do pos <- getPosition + -- Lookahead, so that we don't clash with parseForStmt + (init,expr) <- try (do reserved "for" + parens (do init <- parseInit + reserved "in" + expr <- parseExpression + return (init,expr))) + body <- parseStatement + return (ForInStmt pos init expr body) + +parseForStmt:: StatementParser st +parseForStmt = + let parseInit = + (reserved "var" >> liftM VarInit (parseVarDecl `sepBy` comma)) <|> + (liftM ExprInit parseListExpr) <|> + (return NoInit) + in do pos <- getPosition + reserved "for" + reservedOp "(" + init <- parseInit + semi + test <- (liftM Just parseExpression) <|> (return Nothing) + semi + iter <- (liftM Just parseListExpr) <|> (return Nothing) + reservedOp ")" "closing paren" + stmt <- parseStatement + return (ForStmt pos init test iter stmt) + +parseTryStmt:: StatementParser st +parseTryStmt = + let parseCatchClause = do + pos <- getPosition + reserved "catch" + id <- parens identifier + stmt <- parseStatement + return (CatchClause pos id stmt) + in do reserved "try" + pos <- getPosition + guarded <- parseStatement + catches <- many parseCatchClause + finally <- (reserved "finally" >> liftM Just parseStatement) + <|> (return Nothing) + return (TryStmt pos guarded catches finally) + +parseThrowStmt:: StatementParser st +parseThrowStmt = do + pos <- getPosition + reserved "throw" + expr <- parseExpression + optional semi + return (ThrowStmt pos expr) + +parseReturnStmt:: StatementParser st +parseReturnStmt = do + pos <- getPosition + reserved "return" + expr <- (liftM Just parseListExpr) <|> (return Nothing) + optional semi + return (ReturnStmt pos expr) + +parseWithStmt:: StatementParser st +parseWithStmt = do + pos <- getPosition + reserved "with" + context <- parseParenExpr + stmt <- parseStatement + return (WithStmt pos context stmt) + +parseVarDecl = do + pos <- getPosition + id <- identifier + init <- (reservedOp "=" >> liftM Just parseExpression) <|> (return Nothing) + return (VarDecl pos id init) + +parseVarDeclStmt:: StatementParser st +parseVarDeclStmt = do + pos <- getPosition + reserved "var" + decls <- parseVarDecl `sepBy` comma + optional semi + return (VarDeclStmt pos decls) + +parseFunctionStmt:: StatementParser st +parseFunctionStmt = do + pos <- getPosition + name <- try (reserved "function" >> identifier) -- ambiguity with FuncExpr + args <- parens (identifier `sepBy` comma) + body <- parseBlockStmt "function body in { ... }" + return (FunctionStmt pos name args body) + +parseStatement:: StatementParser st +parseStatement = parseIfStmt <|> parseSwitchStmt <|> parseWhileStmt + <|> parseDoWhileStmt <|> parseContinueStmt <|> parseBreakStmt + <|> parseBlockStmt <|> parseEmptyStmt <|> parseForInStmt <|> parseForStmt + <|> parseTryStmt <|> parseThrowStmt <|> parseReturnStmt <|> parseWithStmt + <|> parseVarDeclStmt <|> parseFunctionStmt + -- labelled, expression and the error message always go last, in this order + <|> parseLabelledStmt <|> parseExpressionStmt "statement" + +--}}} + +--{{{ Expressions + +-- References used to construct this stuff: +-- + http://developer.mozilla.org/en/docs/ +-- Core_JavaScript_1.5_Reference:Operators:Operator_Precedence +-- + http://www.mozilla.org/js/language/grammar14.html +-- +-- Aren't expression tables nice? Well, we can't quite use them, because of +-- JavaScript's ternary (?:) operator. We have to use two expression tables. +-- We use one expression table for the assignment operators that bind looser +-- than ?: (assignTable). The terms of assignTable are ternary expressions +-- (parseTernaryExpr). parseTernaryExpr left-factors the left-recursive +-- production for ?:, and is defined over the second expression table, +-- exprTable, which consists of operators that bind tighter than ?:. The terms +-- of exprTable are atomic expressions, parenthesized expressions, functions and +-- array references. + +--{{{ Primary expressions + +parseThisRef:: ExpressionParser st +parseThisRef = do + pos <- getPosition + reserved "this" + return (ThisRef pos) + +parseNullLit:: ExpressionParser st +parseNullLit = do + pos <- getPosition + reserved "null" + return (NullLit pos) + + +parseBoolLit:: ExpressionParser st +parseBoolLit = do + pos <- getPosition + let parseTrueLit = reserved "true" >> return (BoolLit pos True) + parseFalseLit = reserved "false" >> return (BoolLit pos False) + parseTrueLit <|> parseFalseLit + +parseVarRef:: ExpressionParser st +parseVarRef = liftM2 VarRef getPosition identifier + +parseArrayLit:: ExpressionParser st +parseArrayLit = liftM2 ArrayLit getPosition (squares (parseExpression `sepBy` comma)) + +parseFuncExpr = do + pos <- getPosition + reserved "function" + args <- parens (identifier `sepBy` comma) + body <- parseBlockStmt + return $ FuncExpr pos args body + +--{{{ parsing strings + +escapeChars = + [('\'','\''),('\"','\"'),('\\','\\'),('b','\b'),('f','\f'),('n','\n'), + ('r','\r'),('t','\t'),('v','\v'),('/','/'),(' ',' ')] + +allEscapes:: String +allEscapes = map fst escapeChars + +parseEscapeChar = do + c <- oneOf allEscapes + let (Just c') = lookup c escapeChars -- will succeed due to line above + return c' + +parseAsciiHexChar = do + char 'x' + d1 <- hexDigit + d2 <- hexDigit + return ((chr.fst.head.readHex) (d1:d2:"")) + +parseUnicodeHexChar = do + char 'u' + liftM (chr.fst.head.readHex) + (sequence [hexDigit,hexDigit,hexDigit,hexDigit]) + +isWhitespace ch = ch `elem` " \t" + + +-- The endWith argument is either single-quote or double-quote, depending on how +-- we opened the string. +parseStringLit' endWith = + (char endWith >> return "") <|> + (do try (string "\\'") + cs <- parseStringLit' endWith + return $ "'" ++ cs) <|> + (do char '\\' + c <- parseEscapeChar <|> parseAsciiHexChar <|> parseUnicodeHexChar <|> + char '\r' <|> char '\n' + cs <- parseStringLit' endWith + if c == '\r' || c == '\n' + then return (c:(dropWhile isWhitespace cs)) + else return (c:cs)) <|> + (liftM2 (:) anyChar (parseStringLit' endWith)) + +parseStringLit:: ExpressionParser st +parseStringLit = do + pos <- getPosition + -- parseStringLit' takes as an argument the quote-character that opened the + -- string. + str <- lexeme $ (char '\'' >>= parseStringLit') <|> (char '\"' >>= parseStringLit') + -- CRUCIAL: Parsec.Token parsers expect to find their token on the first + -- character, and read whitespaces beyond their tokens. Without 'lexeme' + -- above, expressions like: + -- var s = "string" ; + -- do not parse. + return $ StringLit pos str + +--}}} + +parseRegexpLit:: ExpressionParser st +parseRegexpLit = do + let parseFlags = do + flags <- many (oneOf "mgi") + return $ \f -> f ('g' `elem` flags) ('i' `elem` flags) + let parseEscape = char '\\' >> anyChar + let parseChar = noneOf "/" + let parseRe = (char '/' >> return "") <|> + (do char '\\' + ch <- anyChar -- TOOD: too lenient + rest <- parseRe + return ('\\':ch:rest)) <|> + (liftM2 (:) anyChar parseRe) + pos <- getPosition + char '/' + pat <- parseRe --many1 parseChar + flags <- parseFlags + spaces -- crucial for Parsec.Token parsers + return $ flags (RegexpLit pos pat) + +parseObjectLit:: ExpressionParser st +parseObjectLit = + let parseProp = do + -- Parses a string, identifier or integer as the property name. I + -- apologize for the abstruse style, but it really does make the code + -- much shorter. + name <- (liftM (uncurry PropString) + (liftM (\(StringLit p s) -> (p,s)) parseStringLit)) + <|> (liftM2 PropId getPosition identifier) + <|> (liftM2 PropNum getPosition decimal) + colon + val <- parseAssignExpr + return (name,val) + in do pos <- getPosition + props <- braces (parseProp `sepEndBy` comma) "object literal" + return $ ObjectLit pos props + +--{{{ Parsing numbers. From pg. 17-18 of ECMA-262. + +hexLit = do + try (string "0x") + digits <- many1 (oneOf "0123456789abcdefABCDEF") + [(hex,"")] <- return $ Numeric.readHex digits + return (True, hex) + +-- Creates a decimal value from a whole, fractional and exponent part. +mkDecimal:: Double -> Double -> Int -> Double +mkDecimal w f e = + if (f >= 1.0) + then mkDecimal w (f / 10.0) e + else (w + f) * (10.0 ^^ e) + +exponentPart = do + oneOf "eE" + (char '+' >> decimal) <|> (char '-' >> negate `fmap` decimal) <|> decimal + +--wrap a parser's result in a Just: +jparser p = p >>= (return . Just) + +decLit = + (do whole <- decimal + mfrac <- option Nothing (jparser (char '.' >> decimal)) + mexp <- option Nothing (jparser exponentPart) + if (mfrac == Nothing && mexp == Nothing) + then return (True, fromIntegral whole) + else return (False, mkDecimal (fromIntegral whole) + (fromIntegral (maybe 0 id mfrac)) + (fromIntegral (maybe 0 id mexp)))) <|> + (do frac <- char '.' >> decimal + exp <- option 0 exponentPart + return (False, mkDecimal 0.0 (fromIntegral frac) (fromIntegral exp))) + +parseNumLit:: ExpressionParser st +parseNumLit = do + pos <- getPosition + (isint, num) <- lexeme $ hexLit <|> decLit + notFollowedBy identifierStart "whitespace" + if isint + then return $ IntLit pos (round num) + else return $ NumLit pos num + + +------------------------------------------------------------------------------ +-- Position Helper +------------------------------------------------------------------------------ + +withPos cstr p = do { pos <- getPosition; e <- p; return $ cstr pos e } + +------------------------------------------------------------------------------- +-- Compound Expression Parsers +------------------------------------------------------------------------------- + +dotRef e = (reservedOp "." >> withPos cstr identifier) "property.ref" + where cstr pos key = DotRef pos e key + +funcApp e = (parens $ withPos cstr (parseExpression `sepBy` comma)) "(function application)" + where cstr pos args = CallExpr pos e args + +bracketRef e = (brackets $ withPos cstr parseExpression) "[property-ref]" + where cstr pos key = BracketRef pos e key + +------------------------------------------------------------------------------- +-- Expression Parsers +------------------------------------------------------------------------------- + +parseParenExpr:: ExpressionParser st +parseParenExpr = withPos ParenExpr (parens parseListExpr) + +-- everything above expect functions +parseExprForNew = parseThisRef <|> parseNullLit <|> parseBoolLit <|> parseStringLit + <|> parseArrayLit <|> parseParenExpr <|> parseNewExpr <|> parseNumLit + <|> parseRegexpLit <|> parseObjectLit <|> parseVarRef + +-- all the expression parsers defined above +parseSimpleExpr' = parseThisRef <|> parseNullLit <|> parseBoolLit + <|> parseStringLit <|> parseArrayLit <|> parseParenExpr + <|> parseFuncExpr <|> parseNumLit <|> parseRegexpLit <|> parseObjectLit + <|> parseVarRef + +parseNewExpr = + (do pos <- getPosition + reserved "new" + constructor <- parseSimpleExprForNew Nothing -- right-associativity + arguments <- (try (parens (parseExpression `sepBy` comma))) <|> (return []) + return (NewExpr pos constructor arguments)) <|> + parseSimpleExpr' + +parseSimpleExpr (Just e) = (do + e' <- dotRef e <|> funcApp e <|> bracketRef e + parseSimpleExpr $ Just e') <|> (return e) +parseSimpleExpr Nothing = do + e <- parseNewExpr "expression (3)" + parseSimpleExpr (Just e) + +parseSimpleExprForNew (Just e) = (do + e' <- dotRef e <|> bracketRef e + parseSimpleExprForNew $ Just e') <|> (return e) +parseSimpleExprForNew Nothing = do + e <- parseNewExpr "expression (3)" + parseSimpleExprForNew (Just e) + +--}}} + +makeInfixExpr str constr = Infix parser AssocLeft where + parser:: CharParser st (Expression SourcePos -> Expression SourcePos -> Expression SourcePos) + parser = do + pos <- getPosition + reservedOp str + return (InfixExpr pos constr) -- points-free, returns a function + +makePrefixExpr str constr = Prefix parser where + parser = do + pos <- getPosition + (reservedOp str <|> reserved str) + return (PrefixExpr pos constr) -- points-free, returns a function + +mkPrefix operator constr = Prefix $ do + pos <- getPosition + operator + return (\operand -> PrefixExpr pos constr operand) + +makePostfixExpr str constr = Postfix parser where + parser = do + pos <- getPosition + (reservedOp str <|> reserved str) + return (PostfixExpr pos constr) -- points-free, returns a function + +prefixIncDecExpr = do + pos <- getPosition + op <- optionMaybe $ (reservedOp "++" >> return PrefixInc) <|> + (reservedOp "--" >> return PrefixDec) + case op of + Nothing -> parseSimpleExpr Nothing + Just op -> do + innerExpr <- parseSimpleExpr Nothing -- TODO: must be an l-val, I think + return (PrefixExpr pos op innerExpr) + +-- apparently, expression tables can't handle immediately-nested prefixes + +parsePrefixedExpr = do + pos <- getPosition + op <- optionMaybe $ (reservedOp "!" >> return PrefixLNot) <|> + (reservedOp "~" >> return PrefixBNot) <|> + (try (lexeme $ char '-' >> notFollowedBy (char '-')) >> + return PrefixMinus) <|> + (try (lexeme $ char '+' >> notFollowedBy (char '+')) >> + return PrefixPlus) <|> + (reserved "typeof" >> return PrefixTypeof) <|> + (reserved "void" >> return PrefixVoid) <|> + (reserved "delete" >> return PrefixDelete) + case op of + Nothing -> prefixIncDecExpr -- new is treated as a simple expr + Just op -> do + innerExpr <- parsePrefixedExpr + return (PrefixExpr pos op innerExpr) + +exprTable:: [[Operator Char st ParsedExpression]] +exprTable = + [ + [makePrefixExpr "++" PrefixInc, + makePostfixExpr "++" PostfixInc], + [makePrefixExpr "--" PrefixDec, + makePostfixExpr "--" PostfixDec], + [makeInfixExpr "*" OpMul, makeInfixExpr "/" OpDiv, makeInfixExpr "%" OpMod], + [makeInfixExpr "+" OpAdd, makeInfixExpr "-" OpSub], + [makeInfixExpr "<<" OpLShift, makeInfixExpr ">>" OpSpRShift, + makeInfixExpr ">>>" OpZfRShift], + [makeInfixExpr "<" OpLT, makeInfixExpr "<=" OpLEq, makeInfixExpr ">" OpGT, + makeInfixExpr ">=" OpGEq, + makeInfixExpr "instanceof" OpInstanceof, makeInfixExpr "in" OpIn], + [makeInfixExpr "&" OpBAnd], + [makeInfixExpr "^" OpBXor], + [makeInfixExpr "|" OpBOr], + [makeInfixExpr "&&" OpLAnd], + [makeInfixExpr "||" OpLOr], + [makeInfixExpr "==" OpEq, makeInfixExpr "!=" OpNEq, + makeInfixExpr "===" OpStrictEq, makeInfixExpr "!==" OpStrictNEq] + ] + +parseExpression' = + buildExpressionParser exprTable parsePrefixedExpr "simple expression" + +--{{{ Parsing ternary operators: left factored + +parseTernaryExpr':: CharParser st (ParsedExpression,ParsedExpression) +parseTernaryExpr' = do + reservedOp "?" + l <- parseAssignExpr + colon + r <- parseAssignExpr + return $(l,r) + +parseTernaryExpr:: ExpressionParser st +parseTernaryExpr = do + e <- parseExpression' + e' <- optionMaybe parseTernaryExpr' + case e' of + Nothing -> return e + Just (l,r) -> do p <- getPosition + return $ CondExpr p e l r +--}}} + +-- Parsing assignment operations. +makeAssignExpr str constr = Infix parser AssocRight where + parser:: CharParser st (ParsedExpression -> ParsedExpression -> ParsedExpression) + parser = do + pos <- getPosition + reservedOp str + return (AssignExpr pos constr) + +assignTable:: [[Operator Char st ParsedExpression]] +assignTable = [ + [makeAssignExpr "=" OpAssign, makeAssignExpr "+=" OpAssignAdd, + makeAssignExpr "-=" OpAssignSub, makeAssignExpr "*=" OpAssignMul, + makeAssignExpr "/=" OpAssignDiv, makeAssignExpr "%=" OpAssignMod, + makeAssignExpr "<<=" OpAssignLShift, makeAssignExpr ">>=" OpAssignSpRShift, + makeAssignExpr ">>>=" OpAssignZfRShift, makeAssignExpr "&=" OpAssignBAnd, + makeAssignExpr "^=" OpAssignBXor, makeAssignExpr "|=" OpAssignBOr + ]] + + +parseAssignExpr:: ExpressionParser st +parseAssignExpr = buildExpressionParser assignTable parseTernaryExpr + +parseExpression:: ExpressionParser st +parseExpression = parseAssignExpr + +parseListExpr = + liftM2 ListExpr getPosition (parseAssignExpr `sepBy1` comma) + +--}}} + +parseScript:: CharParser state (JavaScript SourcePos) +parseScript = do + whiteSpace + liftM2 Script getPosition (parseStatement `sepBy` whiteSpace) + +parseJavaScriptFromFile :: MonadIO m => String -> m [Statement SourcePos] +parseJavaScriptFromFile filename = do + chars <- liftIO $ readFile filename + case parse parseScript filename chars of + Left err -> fail (show err) + Right (Script _ stmts) -> return stmts + + +parseScriptFromString :: String -> String + -> Either ParseError (JavaScript SourcePos) +parseScriptFromString src script = parse parseScript src script + +emptyParsedJavaScript = + Script (error "Parser.emptyParsedJavaScript--no annotation") [] + +parseString :: String -> [Statement SourcePos] +parseString str = case parse parseScript "" str of + Left err -> error (show err) + Right (Script _ stmts) -> stmts diff --git a/src/BrownPLT/JavaScript/PrettyPrint.hs b/src/BrownPLT/JavaScript/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/src/BrownPLT/JavaScript/PrettyPrint.hs @@ -0,0 +1,239 @@ +-- |Pretty-printing JavaScript. +module BrownPLT.JavaScript.PrettyPrint + ( stmt + , expr + , javaScript + , renderStatements + , renderExpression + ) where + +import Text.PrettyPrint.HughesPJ +import BrownPLT.JavaScript.Syntax + + +renderStatements :: [Statement a] -> String +renderStatements ss = render (semiSep ss) + + +renderExpression :: Expression a -> String +renderExpression e = render (expr e) + + +-- Displays the statement in { ... }, unless it already is in a block. +inBlock:: (Statement a) -> Doc +inBlock s@(BlockStmt _ ss) = stmt s +inBlock s = lbrace $+$ nest 2 (stmt s) $+$ rbrace + + +-- Displays the expression in ( ... ), unless it already is in parens. +inParens:: (Expression a) -> Doc +inParens e@(ParenExpr _ _) = expr e +inParens e = parens (expr e) + +semiSep :: [Statement a] -> Doc +semiSep ss = vcat $ map (\s -> stmt s <> semi) ss + + +pp (Id _ str) = text str + + +forInit :: ForInit a -> Doc +forInit t = case t of + NoInit -> empty + VarInit vs -> text "var" <+> (cat $ punctuate comma $ (map varDecl vs)) + ExprInit e -> expr e + + +forInInit :: ForInInit a -> Doc +forInInit t = case t of + ForInVar id -> text "var" <+> pp id + ForInNoVar id -> pp id + + +caseClause :: CaseClause a -> Doc +caseClause (CaseClause _ e ss) = + text "case" $+$ expr e <+> colon $$ (nest 2 (semiSep ss)) +caseClause (CaseDefault _ ss) = + text "default:" $$ (nest 2 (semiSep ss)) + + +catchClause :: CatchClause a -> Doc +catchClause (CatchClause _ id s) = text "catch" <+> (parens.pp) id <+> inBlock s + + +varDecl :: VarDecl a -> Doc +varDecl (VarDecl _ id Nothing) = pp id +varDecl (VarDecl _ id (Just e)) = pp id <+> equals <+> expr e + + +stmt :: Statement a -> Doc +stmt s = case s of + BlockStmt _ ss -> lbrace $+$ (nest 2 (semiSep ss)) $$ rbrace + EmptyStmt _ -> semi + ExprStmt _ e -> expr e + IfSingleStmt _ test cons -> text "if" <+> inParens test $$ stmt cons + IfStmt _ test cons alt -> + text "if" <+> inParens test $$ stmt cons $$ text "else" <+> stmt alt + SwitchStmt _ e cases -> + text "switch" <+> inParens e $$ + braces (nest 2 (vcat (map caseClause cases))) + WhileStmt _ test body -> text "while" <+> inParens test $$ (stmt body) + ReturnStmt _ Nothing -> text "return" + ReturnStmt _ (Just e) -> text "return" <+> expr e + DoWhileStmt _ s e -> text "do" $$ (stmt s <+> text "while" <+> inParens e) + BreakStmt _ Nothing -> text "break" + BreakStmt _ (Just label) -> text "break" <+> pp label + ContinueStmt _ Nothing -> text "continue" + ContinueStmt _ (Just label) -> text"continue" <+> pp label + LabelledStmt _ label s -> pp label <> colon $$ stmt s + ForInStmt p init e body -> + text "for" <+> + parens (forInInit init <+> text "in" <+> expr e) $+$ stmt body + ForStmt _ init incr test body -> + text "for" <+> + parens (forInit init <> semi <+> mexpr incr <> semi <+> mexpr test) $$ + stmt body + TryStmt _ stmt catches finally -> + text "try" $$ inBlock stmt $$ (vcat (map catchClause catches)) $$ + ppFinally where + ppFinally = case finally of + Nothing -> empty + Just stmt -> text "finally" <> inBlock stmt + ThrowStmt _ e -> text "throw" <+> expr e + WithStmt _ expr s -> text "with" <+> inParens expr $$ stmt s + VarDeclStmt _ decls -> + text "var" <+> (cat $ punctuate comma (map varDecl decls)) + FunctionStmt _ name args s -> + text "function" <+> pp name <> + (parens $ cat $ punctuate comma (map pp args)) $$ + inBlock s + + +prop :: Prop a -> Doc +prop p = case p of + PropId _ id -> pp id + PropString _ str -> doubleQuotes (text (jsEscape str)) + PropNum _ n -> text (show n) + + +infixOp op = text $ case op of + OpMul -> "*" + OpDiv -> "/" + OpMod -> "%" + OpAdd -> "+" + OpSub -> "-" + OpLShift -> "<<" + OpSpRShift -> ">>" + OpZfRShift -> ">>>" + OpLT -> "<" + OpLEq -> "<=" + OpGT -> ">" + OpGEq -> ">=" + OpIn -> "in" + OpInstanceof -> "instanceof" + OpEq -> "==" + OpNEq -> "!=" + OpStrictEq -> "===" + OpStrictNEq -> "!==" + OpBAnd -> "&" + OpBXor -> "^" + OpBOr -> "|" + OpLAnd -> "&&" + OpLOr -> "||" + + +prefixOp op = text $ case op of + PrefixInc -> "++" + PrefixDec -> "--" + PrefixLNot -> "!" + PrefixBNot -> "~" + PrefixPlus -> "+" + PrefixMinus -> "-" + PrefixTypeof -> "typeof" + PrefixVoid -> "void" + PrefixDelete -> "delete" + + +postfixOp op = text $ case op of + PostfixInc -> "++" + PostfixDec -> "--" + + +assignOp op = text $ case op of + OpAssign -> "=" + OpAssignAdd -> "+=" + OpAssignSub -> "-=" + OpAssignMul -> "*=" + OpAssignDiv -> "/=" + OpAssignMod -> "%=" + OpAssignLShift -> "<<=" + OpAssignSpRShift -> ">>=" + OpAssignZfRShift -> ">>>=" + OpAssignBAnd -> "&=" + OpAssignBXor -> "^=" + OpAssignBOr -> "|=" + + +-- Based on: +-- http://developer.mozilla.org/en/docs/Core_JavaScript_1.5_Guide:Literals +jsEscape:: String -> String +jsEscape "" = "" +jsEscape (ch:chs) = (sel ch) ++ jsEscape chs where + sel '\b' = "\\b" + sel '\f' = "\\f" + sel '\n' = "\\n" + sel '\r' = "\\r" + sel '\t' = "\\t" + sel '\v' = "\\v" + sel '\'' = "\\'" + sel '\"' = "\\\"" + sel '\\' = "\\\\" + sel x = [x] + -- We don't have to do anything about \X, \x and \u escape sequences. + + +expr :: Expression a -> Doc +expr e = case e of + StringLit _ str -> doubleQuotes (text (jsEscape str)) + RegexpLit _ re global ci -> + text "/" <> text re <> text "/" <> g <> i where + g = if global then text "g" else empty + i = if ci then text "i" else empty + NumLit _ n -> text (show n) + IntLit _ n -> text (show n) + BoolLit _ True -> text "true" + BoolLit _ False -> text "false" + NullLit _ -> text "null" + ArrayLit _ es -> brackets $ cat $ punctuate comma (map expr es) + ObjectLit _ xs -> + braces (hsep (punctuate comma (map pp' xs))) where + pp' (n,v) = prop n <> colon <+> expr v + ThisRef _ -> text "this" + VarRef _ id -> pp id + DotRef _ e' id -> expr e' <> text "." <> pp id + BracketRef _ container key -> expr container <> brackets (expr key) + NewExpr _ constr args -> + text "new" <+> expr constr <> + (parens $ cat $ punctuate comma (map expr args)) + PrefixExpr _ op e' -> prefixOp op <+> expr e' + PostfixExpr _ op e' -> expr e' <+> postfixOp op + InfixExpr _ op left right -> expr left <+> infixOp op <+> expr right + CondExpr _ test cons alt -> + expr test <+> text "?" <+> expr cons <+> colon <+> expr alt + AssignExpr _ op l r -> expr l <+> assignOp op <+> expr r + ParenExpr _ e' -> parens (expr e') + ListExpr _ es -> cat $ punctuate comma (map expr es) + CallExpr _ f args -> + expr f <> (parens $ cat $ punctuate comma (map expr args)) + FuncExpr _ args body -> + text "function" <+> + (parens $ cat $ punctuate comma (map pp args)) $$ + inBlock body + + +mexpr :: Maybe (Expression a) -> Doc +mexpr Nothing = empty +mexpr (Just e) = expr e + +javaScript :: JavaScript a -> Doc +javaScript (Script _ ss) = semiSep ss diff --git a/src/BrownPLT/JavaScript/Syntax.hs b/src/BrownPLT/JavaScript/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/BrownPLT/JavaScript/Syntax.hs @@ -0,0 +1,121 @@ +-- |JavaScript's syntax. +module BrownPLT.JavaScript.Syntax(Expression(..),CaseClause(..),Statement(..), + InfixOp(..),CatchClause(..),VarDecl(..),JavaScript(..), + AssignOp(..),Id(..),PrefixOp(..),PostfixOp(..),Prop(..), + ForInit(..),ForInInit(..),unId) where + +import Text.ParserCombinators.Parsec(SourcePos) -- used by data JavaScript +import Data.Generics(Data,Typeable) + +data JavaScript a + -- |A script in tags. This may seem a little silly, + -- but the Flapjax analogue has an inline variant and attribute-inline + -- variant. + = Script a [Statement a] + deriving (Show,Data,Typeable,Eq,Ord) + +data Id a = Id a String deriving (Show,Eq,Ord,Data,Typeable) + +unId :: Id a -> String +unId (Id _ s) = s + +-- http://developer.mozilla.org/en/docs/ +-- Core_JavaScript_1.5_Reference:Operators:Operator_Precedence +data InfixOp = OpLT | OpLEq | OpGT | OpGEq | OpIn | OpInstanceof | OpEq | OpNEq + | OpStrictEq | OpStrictNEq | OpLAnd | OpLOr + | OpMul | OpDiv | OpMod | OpSub | OpLShift | OpSpRShift + | OpZfRShift | OpBAnd | OpBXor | OpBOr | OpAdd + deriving (Show,Data,Typeable,Eq,Ord,Enum) + +data AssignOp = OpAssign | OpAssignAdd | OpAssignSub | OpAssignMul | OpAssignDiv + | OpAssignMod | OpAssignLShift | OpAssignSpRShift | OpAssignZfRShift + | OpAssignBAnd | OpAssignBXor | OpAssignBOr + deriving (Show,Data,Typeable,Eq,Ord) + +data PrefixOp = PrefixInc | PrefixDec | PrefixLNot | PrefixBNot | PrefixPlus + | PrefixMinus | PrefixTypeof | PrefixVoid | PrefixDelete + deriving (Show,Data,Typeable,Eq,Ord) + +data PostfixOp + = PostfixInc | PostfixDec + deriving (Show,Data,Typeable,Eq,Ord) + +data Prop a + = PropId a (Id a) | PropString a String | PropNum a Integer + deriving (Show,Data,Typeable,Eq,Ord) + +data Expression a + = StringLit a String + | RegexpLit a String Bool {- global? -} Bool {- case-insensitive? -} + | NumLit a Double + | IntLit a Int + | BoolLit a Bool + | NullLit a + | ArrayLit a [Expression a] + | ObjectLit a [(Prop a, Expression a)] + | ThisRef a + | VarRef a (Id a) + | DotRef a (Expression a) (Id a) + | BracketRef a (Expression a) {- container -} (Expression a) {- key -} + | NewExpr a (Expression a) {- constructor -} [Expression a] + | PostfixExpr a PostfixOp (Expression a) + | PrefixExpr a PrefixOp (Expression a) + | InfixExpr a InfixOp (Expression a) (Expression a) + | CondExpr a (Expression a) (Expression a) (Expression a) + | AssignExpr a AssignOp (Expression a) (Expression a) + | ParenExpr a (Expression a) + | ListExpr a [Expression a] + | CallExpr a (Expression a) [Expression a] + | FuncExpr a [(Id a)] (Statement a) + deriving (Show,Data,Typeable,Eq,Ord) + +data CaseClause a + = CaseClause a (Expression a) [Statement a] + | CaseDefault a [Statement a] + deriving (Show,Data,Typeable,Eq,Ord) + +data CatchClause a + = CatchClause a (Id a) (Statement a) + deriving (Show,Data,Typeable,Eq,Ord) + +data VarDecl a + = VarDecl a (Id a) (Maybe (Expression a)) + deriving (Show,Data,Typeable,Eq,Ord) + +data ForInit a + = NoInit + | VarInit [VarDecl a] + | ExprInit (Expression a) + deriving (Show,Data,Typeable,Eq,Ord) + +data ForInInit a + = ForInVar (Id a) + | ForInNoVar (Id a) + deriving (Show,Data,Typeable,Eq,Ord) + + +data Statement a + = BlockStmt a [Statement a] + | EmptyStmt a + | ExprStmt a (Expression a) + | IfStmt a (Expression a) (Statement a) (Statement a) + | IfSingleStmt a (Expression a) (Statement a) + | SwitchStmt a (Expression a) [CaseClause a] + | WhileStmt a (Expression a) (Statement a) + | DoWhileStmt a (Statement a) (Expression a) + | BreakStmt a (Maybe (Id a)) + | ContinueStmt a (Maybe (Id a)) + | LabelledStmt a (Id a) (Statement a) + | ForInStmt a (ForInInit a) (Expression a) (Statement a) + | ForStmt a (ForInit a) + (Maybe (Expression a)) -- increment + (Maybe (Expression a)) -- test + (Statement a) -- body + | TryStmt a (Statement a) {-body-} [CatchClause a] {-catches-} + (Maybe (Statement a)) {-finally-} + | ThrowStmt a (Expression a) + | ReturnStmt a (Maybe (Expression a)) + | WithStmt a (Expression a) (Statement a) + | VarDeclStmt a [VarDecl a] + | FunctionStmt a (Id a) {-name-} [(Id a)] {-args-} (Statement a) {-body-} + deriving (Show,Data,Typeable,Eq,Ord) diff --git a/src/WebBits/Common.hs b/src/WebBits/Common.hs deleted file mode 100644 --- a/src/WebBits/Common.hs +++ /dev/null @@ -1,63 +0,0 @@ --- | Defines commonly used datatypes and functions. -module WebBits.Common - ( PrettyPrintable(..) - , L.isPrefixOf - , SourcePos - , sourceName - ) where - -import Data.Map (Map) -import Data.Maybe (catMaybes) -import Data.Char (toLower) -import Control.Applicative -import qualified System.IO as IO -import Control.Monad.State.Strict -import Control.Monad.Identity -import qualified Data.List as L -import Data.Generics hiding (GT) -import qualified Data.Foldable as Foldable -import Data.Foldable (Foldable) -import qualified Data.Traversable as Traversable -import Data.Traversable (Traversable, traverse) -import qualified Text.PrettyPrint.HughesPJ as Pp -import Text.ParserCombinators.Parsec.Pos (SourcePos, initialPos, sourceName) - -lowercase = map toLower - --- | 'PrettyPrintable' makes writing pretty-printing code for large, recursive --- data structures shorter. -class PrettyPrintable a where - pp:: a -> Pp.Doc - -instance PrettyPrintable a => PrettyPrintable (Maybe a) where - pp (Just a) = pp a - pp Nothing = Pp.empty - --------------------------------------------------------------------------------- --- Generics for SourcePos - --- | These definitions allow us to use data structures containing 'SourcePos' --- values with generics. - --- |We make 'SourcePos' an instance of 'Typeable' so that we can use it with --- generics. -instance Typeable SourcePos where - typeOf _ = - mkTyConApp (mkTyCon "Text.ParserCombinators.Parsec.Pos.SourcePos") [] - --- Complete guesswork. It seems to work. -sourcePosDatatype = mkDataType "SourcePos" [sourcePosConstr1] -sourcePosConstr1 = mkConstr sourcePosDatatype "SourcePos" [] Prefix - --- |We make 'SourcePos' an instance of 'Typeable' so that we can use it with --- generics. --- --- This definition is incomplete. -instance Data SourcePos where - -- We treat source locations as opaque. After all, we don't have access to - -- the constructor. - gfoldl k z pos = z pos - toConstr _ = sourcePosConstr1 - gunfold = error "gunfold is not defined for SourcePos" - dataTypeOf = error "dataTypeOf is not defined for SourcePos" - diff --git a/src/WebBits/Data/Zipper.hs b/src/WebBits/Data/Zipper.hs deleted file mode 100644 --- a/src/WebBits/Data/Zipper.hs +++ /dev/null @@ -1,274 +0,0 @@ --- |A zipper for "Data.Tree". -module WebBits.Data.Zipper - ( - -- * Functional zipper - - -- $functionalZipper - - Tree(..) - , Location - , toLocation, fromLocation - , dfsFold - , dfsFoldM - , showTree - - , empty - , up, down, left, right -- Location a -> Location a - , replace - , change - , insertDown, insertLeft, insertRight - , isTop, isChild - , getValue - , subTree - , top - , canGoLeft, canGoRight, canGoUp, canGoDown -- Location a -> Bool - - -- * Imperative tree construction - - -- $treeBuilder - - , ZipperT - - , nest -- Monad m => v -> ZipperT v m a -> ZipperT v m a - , getNode -- Monad m => ZipperT v m v - , setNode -- Monad m => v -> ZipperT v m () - , runZipperT - , evalZipperT - , execZipperT - , shiftLeft, shiftRight -- Monad m => ZipperT v m () - , shiftLeft', shiftRight' -- Monad m => ZipperT v m () - , withCurrentChild -- Monad m => Zipper T v m a -> ZipperT v m a - - ) where - -import Control.Monad -import Control.Monad.State -import Data.Tree (Tree (..), drawTree) - -------------------------------------------------------------------------------- --- Data types! --- - -data Path a - = Top - | Split a [Tree a] (Path a) [Tree a] - -data Location a = Location (Tree a) (Path a) - - -dfsFold :: (w -> v -> w) -- ^transforms a node 'v' using the accumulated - -- value 'w' from the root of the tree to 'v' - -> w -- ^the initial value of the accumulator at the root - -> Tree v - -> Tree w -dfsFold f w (Node v ts) = Node w' (map (dfsFold f w') ts) - where w' = f w v - --- |Similar to 'dfsFold', but the transformation is done in the monad 'm'. The --- sequence of operations is depth-first, left-to-right. -dfsFoldM :: Monad m => (w -> v -> m w) -> w -> Tree v -> m (Tree w) -dfsFoldM f w (Node v ts) = do - w' <- f w v - ts' <- mapM (dfsFoldM f w') ts - return $ Node w' ts' - --- Uses 'Data.Tree.drawShow'. -showTree :: Show a => Tree a -> String -showTree tree = drawTree (fmap show tree) - - -------------------------------------------------------------------------------- --- Combinators! --- - --- $functionalZipper --- These are the core zipper functions. - -empty :: a -> Tree a -empty a = Node a [] - -up :: Location a -> Location a -up (Location _ Top) = error " up of Top" -up (Location t (Split v ls p rs)) = Location (Node v (reverse ls ++ (t:rs))) p - -down :: Location a -> Location a -down (Location (Node v []) _) = error "down of empty" -down (Location (Node v (t:ts)) p) = Location t (Split v [] p ts) - -left :: Location a -> Location a -left (Location t Top) = error "left of top" -left (Location t (Split v [] p rs)) = error "left on leftmost" -left (Location t (Split v (l:ls) p rs)) = Location l (Split v ls p (t:rs)) - -right :: Location a -> Location a -right (Location t Top) = - error "Data.Zipper.right : at the top" -right (Location t (Split v ls p [])) = error "right on rightmost" -right (Location t (Split v ls p (r:rs))) = Location r (Split v (t:ls) p rs) - -replace :: Location a -> Tree a -> Location a -replace (Location _ p) t = Location t p - -change :: Location a -> a -> Location a -change (Location (Node _ cs) p) t = Location (Node t cs) p - -insertDown :: Location a -> Tree a -> Location a -insertDown (Location (Node v ts) p) t = Location (Node v (t:ts)) p - -insertDownRight :: Location a -> Tree a -> Location a -insertDownRight (Location (Node v ts) p) t = - Location t (Split v (reverse ts) p []) - -insertLeft :: Location a -> Tree a -> Location a -insertLeft (Location _ Top) _ = error "insert on top" -insertLeft (Location t (Split v ls p rs)) t' = - Location t (Split v (t':ls) p rs) - -insertRight :: Location a -> Tree a -> Location a -insertRight (Location _ Top) _ = error "insert on top" -insertRight (Location t (Split v ls p rs)) t' = - Location t (Split v ls p (t':rs)) - -isTop :: Location a -> Bool -isTop (Location _ Top) = True -isTop _ = False - -isChild :: Location a -> Bool -isChild = not . isTop - -canGoRight :: Location a -> Bool -canGoRight (Location _ (Split _ _ _ [])) = False -canGoRight (Location _ Top) = False -canGoRight _ = True - -canGoDown :: Location a -> Bool -canGoDown (Location (Node _ []) _) = False -canGoDown _ = True - -canGoLeft :: Location a -> Bool -canGoLeft (Location _ Top) = False -canGoLeft (Location _ (Split _ [] _ _)) = False -canGoLeft _ = True - -canGoUp :: Location a -> Bool -canGoUp (Location _ Top) = False -canGoUp _ = True - -getValue :: Location a -> a -getValue (Location (Node v _) _) = v - -subTree :: Location a -> Tree a -subTree (Location node _) = node - --- |Traverses to the top of the tree. --- --- @ --- up.top = undefined --- top.top = top --- @ -top :: Location a -> Location a -top loc@(Location _ Top) = loc -top loc@(Location _ _) = top (up loc) - -toLocation :: Tree a -> Location a -toLocation t = Location t Top - -fromLocation :: Location a -> Tree a -fromLocation (Location t _) = t - - --- $treeBuilder --- A state monad that carries a zipper. It provides convenient methods to --- imperatively create and update a tree. --- --- The state monad's set method may be used to arbitrarily update the current --- location. However, such updates can break the behavior of nest and --- withCurrentChild. We recommend avoiding StateT.set. - -type ZipperT v m a = StateT (Location v) m a - - -runZipperT :: Monad m => ZipperT v m a -> Location v -> m (a, Tree v) -runZipperT m l = do - (a, Location t Top) <- runStateT m l - return (a,t) - -evalZipperT :: Monad m => ZipperT v m a -> Location v -> m a -evalZipperT m l = do - ~(a, _) <- runStateT m l - return a - -execZipperT :: Monad m => ZipperT v m a -> Location v -> m (Tree v) -execZipperT m l = do - ~(_, Location t Top) <- runStateT m l - return t - --- |Creates a new node as the right-most child of the current node. -nest :: Monad m - => v -- ^value of the new right-most child - -> ZipperT v m a -- ^computation applied to the new child - -> ZipperT v m a -- ^returns the result of the nested computation -nest v m = do - z <- get - put $ insertDownRight z (empty v) - a <- m - z' <- get -- z' is the child of z - put (up z') - return a - -getNode :: Monad m => ZipperT v m v -getNode = do - (Location (Node v _) _) <- get - return v - -setNode :: Monad m => v -> ZipperT v m () -setNode v = do - (Location (Node _ cs) path) <- get - put $ Location (Node v cs) path - -withCurrentChild :: Monad m - => ZipperT v m a -- ^computation to apply to the current child - -> ZipperT v m a -- ^returns the result of the nested - -- computation -withCurrentChild m = do - z <- get - put (down z) - a <- m - z' <- get - put (up z') - return a - -shiftRight :: Monad m => ZipperT v m () -shiftRight = do - z <- get - put (right z) - - -shiftLeft :: Monad m => ZipperT v m () -shiftLeft = do - z <- get - put (left z) - --- |Silently fails to shift right if there is no right-child. -shiftRight' :: Monad m => ZipperT v m () -shiftRight' = do - z <- get - when (hasRight z) - (put (right z)) - --- |Silently fails to shift left if there is no left-child. -shiftLeft' :: Monad m => ZipperT v m () -shiftLeft' = do - z <- get - when (hasLeft z) - (put (left z)) - -hasLeft :: Location a -> Bool -hasLeft (Location _ (Split _ (_:_) _ _)) = True -hasLeft _ = False - -hasRight :: Location a -> Bool -hasRight (Location _ (Split _ _ _ (_:_))) = True -hasRight _ = False - - diff --git a/src/WebBits/Html/Html.hs b/src/WebBits/Html/Html.hs deleted file mode 100644 --- a/src/WebBits/Html/Html.hs +++ /dev/null @@ -1,14 +0,0 @@ --- |Rexports various modules of the HTML library. It's best to use this in lieu --- of selectively importing the following libraries. -module WebBits.Html.Html - ( module WebBits.Html.Syntax - -- PermissiveParser - , html - , parseHtmlFromFile - , parseHtmlFromString - ) where - -import WebBits.Html.Syntax -import WebBits.Html.PermissiveParser -import WebBits.Html.PrettyPrint -- no names, only instances -import WebBits.Html.Instances -- no names, only instances diff --git a/src/WebBits/Html/Instances.hs b/src/WebBits/Html/Instances.hs deleted file mode 100644 --- a/src/WebBits/Html/Instances.hs +++ /dev/null @@ -1,66 +0,0 @@ -module WebBits.Html.Instances() where - -import qualified Prelude as Prelude -import Prelude (Functor,map,fmap) -import qualified Data.List as List -import qualified Data.Char as Char -import Data.Foldable -import Data.Traversable -import Control.Applicative - -import WebBits.Html.Syntax - -ltraverse:: (Traversable t, Applicative f) => (a -> f b) -> [t a] -> f [t b] -ltraverse f [] = pure [] -ltraverse f (x:xs) = pure (:) <*> (traverse f x) <*> ltraverse f xs - -instance Functor (Attribute a) where - fmap f (Attribute id val a) = Attribute id val a - fmap f (AttributeExpr a id script def) = AttributeExpr a id (f script) def - -instance Functor (Html a) where - fmap f (Element id attrs children a) = - Element id (map (fmap f) attrs) (map (fmap f) children) a - fmap f (Text str a) = Text str a - fmap f (Comment str a) = Comment str a - fmap f (HtmlSeq xs) = HtmlSeq (map (fmap f) xs) - fmap f (ProcessingInstruction str a) = ProcessingInstruction str a - fmap f (InlineScript script a def) = InlineScript (f script) a def - fmap f (Script script a) = Script (f script) a - -instance Foldable (Attribute a) where - foldr f x (Attribute id val a) = x - foldr f x (AttributeExpr a id script def) = f script x - -instance Foldable (Html a) where - foldr f x (Element id attrs children a) = - Prelude.foldr (\child x' -> foldr f x' child) x children - foldr f x (Text str a) = x - foldr f x (Comment str a) = x - foldr f x (HtmlSeq ys) = - Prelude.foldr (\child x' -> foldr f x' child) x ys - foldr f x (ProcessingInstruction str a) = x - foldr f x (InlineScript script a def) = f script x - foldr f x (Script script a) = f script x - -instance Traversable (Attribute a) where - traverse f (Attribute id val a) = - pure (Attribute id val a) - traverse f (AttributeExpr a id script def) = - (AttributeExpr a id) <$> (f script) <*> pure def - -instance Traversable (Html a) where - traverse f (Element id attrs children a) = - (Element id) <$> ltraverse f attrs <*> ltraverse f children <*> pure a - traverse f (Text str a) = - pure (Text str a) - traverse f (Comment str a) = - pure (Comment str a) - traverse f (HtmlSeq xs) = - HtmlSeq <$> ltraverse f xs - traverse f (ProcessingInstruction str a) = - pure (ProcessingInstruction str a) - traverse f (InlineScript script a def) = - InlineScript <$> (f script) <*> pure a <*> pure def - traverse f (Script script a) = - Script <$> (f script) <*> pure a diff --git a/src/WebBits/Html/PermissiveParser.hs b/src/WebBits/Html/PermissiveParser.hs deleted file mode 100644 --- a/src/WebBits/Html/PermissiveParser.hs +++ /dev/null @@ -1,492 +0,0 @@ --- |A structure-recovering parser for malformed documents. --- --- Copyright 2007-2008 Arjun Guha. --- Based on HtmlPrag 0.16 Copyright (C) 2003 - 2005 Neil W. Van Dyke. --- --- This program is Free Software; you can redistribute it and/or modify it under --- the terms of the GNU Lesser General Public License as published by the Free --- Software Foundation; either version 2.1 of the License, or (at your option) --- any later version. This program is distributed in the hope that it will be --- useful, but without any warranty; without even the implied warranty of --- merchantability or fitness for a particular purpose. See --- 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 . - -- ") - 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 diff --git a/src/WebBits/Html/Syntax.hs b/src/WebBits/Html/Syntax.hs deleted file mode 100644 --- a/src/WebBits/Html/Syntax.hs +++ /dev/null @@ -1,84 +0,0 @@ --- |Datatypes for HTML parameterized over an annotation type and a script type. -module WebBits.Html.Syntax ( - -- * HTML Data Structures - HtmlId,AttributeValue,Attribute(..),Html(..) - -- * The Script class - , Script(..) - -- * Miscellaneous Functions - , attributeValue,attributeUpdate,attributeSet,isAttributeExpr - ) where - -import Text.ParserCombinators.Parsec(CharParser,SourcePos) -import Data.Generics(Data) -import Data.Typeable(Typeable) - --------------------------------------------------------------------------------- --- Types - -type HtmlId = String -type AttributeValue = String - -data Attribute a s - = Attribute HtmlId AttributeValue a - | AttributeExpr a HtmlId s String - deriving (Show,Eq,Typeable,Data) - -data Html a sc - = Element HtmlId [Attribute a sc] [Html a sc] a - | Text String a - | Comment String a - | HtmlSeq [Html a sc] -- ^must be a non-empty list - | ProcessingInstruction String a - | InlineScript sc a String - | Script sc a - deriving (Show,Eq,Typeable,Data) - --------------------------------------------------------------------------------- --- The Script class - --- |A type 't' of the 'Script' class can be parsed using 'Parsec'. 't' is of --- kind '* -> *', as the parsed AST should be annotated with souce locations --- (see 'Text.ParserCombinators.Parsec.SourcePos'). --- --- The big deal here is that we can embed a parser for some scripting language, --- (e.g. Javascript) into this HTML parser with ease, while preserving source --- locations. The Html datatype is parameterized over a script parser (an --- instance of Script). -class Script t where - parseScriptBlock:: [Attribute SourcePos t] -> CharParser a t - -- An inline script parser, which may be Nothing if the scripting language - -- does not support inline scripts. - parseInlineScript:: Maybe (CharParser a t) - -- A parser for script-expressions defined inline as attribute values. - parseAttributeScript:: Maybe (CharParser a t) - --------------------------------------------------------------------------------- --- HTML navigation - -isAttributeExpr (AttributeExpr _ _ _ _) = True -isAttributeExpr _ = False - --- |Returns the value of the attribute in the list, or 'Nothing' if it doesn't --- exist of the value is an inline-expression. -attributeValue:: HtmlId -> [Attribute a s] -> Maybe String -attributeValue name [] = Nothing -attributeValue name ((AttributeExpr pos name' expr init):rest) = - if name == name' then Nothing - else attributeValue name rest -attributeValue name ((Attribute name' value _):rest) = - if name == name' then Just value - else attributeValue name rest - -attributeSet:: HtmlId -> String -> [Attribute a s] -> [Attribute a s] -attributeSet n v attrs = attributeUpdate n (\_ -> v) attrs - -attributeUpdate:: HtmlId -> (String -> String) -> [Attribute a s] - -> [Attribute a s] -attributeUpdate n f [] = - [Attribute n (f "") (error "attributeUpdate--no value")] -- TODO: undefined?! -attributeUpdate n _ ((AttributeExpr _ _ _ _):_) = - error $ "attributeUpdate: " ++ n ++ " is an expression-attribute." -attributeUpdate n f ((Attribute n' v p):attrs) = - if n' == n then (Attribute n (f v) p):attrs - else (Attribute n' v p):(attributeUpdate n f attrs) - diff --git a/src/WebBits/JavaScript.hs b/src/WebBits/JavaScript.hs deleted file mode 100644 --- a/src/WebBits/JavaScript.hs +++ /dev/null @@ -1,21 +0,0 @@ --- |Re-exports commonly used modules. -module WebBits.JavaScript - ( module WebBits.JavaScript.Syntax - , module WebBits.JavaScript.HtmlEmbedding - , module WebBits.JavaScript.Parser - , module WebBits.JavaScript.Combinators - , module WebBits.Common - , module WebBits.JavaScript.Environment - -- JavaScript.Instances exports nothing - ) where - -import WebBits.Common - -import WebBits.JavaScript.Syntax -import WebBits.JavaScript.Parser -import WebBits.JavaScript.PrettyPrint -import WebBits.JavaScript.HtmlEmbedding -import WebBits.JavaScript.Combinators -import WebBits.JavaScript.Environment - -import WebBits.JavaScript.Instances diff --git a/src/WebBits/JavaScript/Combinators.hs b/src/WebBits/JavaScript/Combinators.hs deleted file mode 100644 --- a/src/WebBits/JavaScript/Combinators.hs +++ /dev/null @@ -1,39 +0,0 @@ -module WebBits.JavaScript.Combinators - ( scriptStatements - , isParenExpr - , syntaxAt - , expressionsAt - , statementsAt - ) where - -import Data.Generics (Data,Typeable, everything, mkQ) -import Text.ParserCombinators.Parsec (SourcePos) -import qualified Data.Foldable as F -import Data.Foldable (Foldable) -import WebBits.JavaScript.Syntax -import WebBits.JavaScript.Instances () -import WebBits.Common () - -scriptStatements:: JavaScript a -> [Statement a] -scriptStatements (Script _ ss) = ss - -isParenExpr (ParenExpr _ _) = True -isParenExpr _ = False - -syntaxAt :: (Data a, Typeable a, Data (t SourcePos), - Typeable (t SourcePos), Foldable t) - => SourcePos -> a -> [t SourcePos] -syntaxAt pos a = everything (++) (mkQ [] isMatch) a where - isMatch stx = case F.find (const True) stx of - Nothing -> [] - Just pos' | pos == pos' -> [stx] - | otherwise -> [] - -expressionsAt :: (Data a, Typeable a) - => SourcePos -> a -> [Expression SourcePos] -expressionsAt = syntaxAt - -statementsAt :: (Data a, Typeable a) - => SourcePos -> a -> [Statement SourcePos] -statementsAt = syntaxAt - diff --git a/src/WebBits/JavaScript/Crawl.hs b/src/WebBits/JavaScript/Crawl.hs deleted file mode 100644 --- a/src/WebBits/JavaScript/Crawl.hs +++ /dev/null @@ -1,80 +0,0 @@ --- |Crawls an HTML page for JavaScript -module WebBits.JavaScript.Crawl - ( getPageJavaScript - ) where - -import WebBits.Common -import Control.Monad -import Data.Char (toLower) -import Data.Generics -import System.IO -import Text.ParserCombinators.Parsec(parse,setPosition,incSourceColumn,Column,sourceLine,sourceColumn) - -import WebBits.Html.Syntax -import qualified WebBits.JavaScript.JavaScript as Js - --- |Returns the source of the script. -scriptSrc:: Js.ParsedJsHtml -> [String] -scriptSrc (Element tag attrs _ _) | (map toLower tag) == "script" = - case attributeValue "src" attrs of -- TODO: Check for type="javascript"? - Just "" -> [] - Just url -> [url] - Nothing -> [] -scriptSrc _ = - [] - --- |Returns a list of URIs for external Javascript files referenced in the page. -importedScripts:: Js.ParsedJsHtml -> [String] -importedScripts = everything (++) (mkQ [] scriptSrc) - --- |Returns the top-level statements of a script. -scriptText :: Js.ParsedJsHtml -> [Js.ParsedStatement] -scriptText (Script (Js.Script _ stmts) _) = stmts -scriptText _ = [] - -eventHandlers :: [String] -eventHandlers = ["onload","onclick"]; --- ,"onmousemove","onmouseover","onmousedown","onmouseout","onmouseup","onselectstart", "onkeypress"] - -attrScript :: Attribute SourcePos Js.ParsedJavaScript - -> IO [Js.ParsedStatement] -attrScript (Attribute id val loc) | id `elem` eventHandlers = do - let eventId = drop 2 id -- drop the "on" prefix - let scriptText = if "javascript:" `isPrefixOf` val then drop 11 val else val - let eventListenerPrefix = "addEventListener('" ++ eventId ++ "', function(event) { " - let prefixLen = length eventListenerPrefix - let eventListenerText = eventListenerPrefix ++ scriptText ++ " });" - let parser = do - setPosition (incSourceColumn loc (-prefixLen)) - Js.parseExpression - case parse parser (sourceName loc) eventListenerText of - Left err -> do - fail $ "Error parsiing JavaScript in an attribute at " ++ show loc ++ - "\nThe script was:\n\n" ++ eventListenerText - Right e -> return [Js.ExprStmt loc e] -attrScript _ = return [] - -inpageAttrScripts :: Js.ParsedJsHtml -> IO [Js.ParsedStatement] -inpageAttrScripts = everything (liftM2 (++)) (mkQ (return []) attrScript) - -inpageScripts :: Js.ParsedJsHtml -> [Js.ParsedStatement] -inpageScripts = everything (++) (mkQ [] scriptText) - -parseJsFile path = do - text <- readFile path - case Js.parseScriptFromString path text of - Left err -> fail (show err) - Right js -> hPutStrLn stderr ("Read file " ++ path) >> return js - --- |Given an HTML page, crawls all external Javascript files and returns a list --- of statements, concatenated from all files. -getPageJavascript:: Js.ParsedJsHtml -> IO [Js.ParsedStatement] -getPageJavascript page = do - let importURIs = importedScripts page - let inpageJs = inpageScripts page - attrScripts <- inpageAttrScripts page - importedScripts <- mapM parseJsFile importURIs - return $ (concatMap Js.scriptStatements importedScripts ++ attrScripts) ++ inpageJs - -getPageJavaScript:: Js.ParsedJsHtml -> IO [Js.ParsedStatement] -- monomorphism -getPageJavaScript = getPageJavascript diff --git a/src/WebBits/JavaScript/Environment.hs b/src/WebBits/JavaScript/Environment.hs deleted file mode 100644 --- a/src/WebBits/JavaScript/Environment.hs +++ /dev/null @@ -1,304 +0,0 @@ -module WebBits.JavaScript.Environment - ( staticEnvironment - , Ann - , LabelledStatement - , LabelledExpression - , Env - ) where - -import Data.Generics hiding (GT) -import Data.Maybe (fromJust) -import qualified Data.Set as S -import WebBits.Data.Zipper (ZipperT,ZipperT) -import qualified Data.Map as M -import qualified WebBits.Data.Zipper as Z -import Control.Monad.State -import qualified Data.Foldable as F -import qualified Data.List as L -import WebBits.JavaScript.JavaScript -import Text.ParserCombinators.Parsec.Pos (SourcePos,initialPos) - ---- --- Add `this' and `arguments' to the formal parameters of all --- functions --- --- TODO: Does a local var x shadow a formal argument x? What about 'arguments'? - -thisStmt :: Statement SourcePos -> Statement SourcePos -thisStmt (FunctionStmt loc id args body) = - FunctionStmt loc id ((Id loc "this"):(Id loc "arguments"):args) body -thisStmt s = s - -thisExpr :: Expression SourcePos -> Expression SourcePos -thisExpr (FuncExpr l args s) = - FuncExpr l ((Id l "this"):(Id l "arguments"):args) s -thisExpr e = e - -removeParens :: Expression SourcePos -> Expression SourcePos -removeParens (ParenExpr _ e) = e -removeParens e = e - -removeSingletons :: Expression SourcePos -> Expression SourcePos -removeSingletons (ListExpr _ [e]) = e -removeSingletons e = e - -explicitThis :: [Statement SourcePos] -> [Statement SourcePos] -explicitThis = everywhere $ (mkT removeSingletons) . (mkT removeParens) - . (mkT thisExpr) . (mkT thisStmt) - --- JavaScript has a global and function scopes. Globals do not need to be --- declared. Any "unbound identifier" in a function is treated as a reference --- to a global. - --- For each FunctionExpr and FunctionStmt, we create a list of locally defined --- identifiers (var x = ...) and free identifiers. - --- We build a tree of "partial environments." Since a variable may be used --- before it is declared locally, we maintain a set of free identifiers and --- narrow the set when appropriate. -type PartialEnv = (Env,S.Set String) - -type Env = M.Map String Int - -emptyPartialEnv :: PartialEnv -emptyPartialEnv = (M.empty,S.empty) - -type RefM a = Z.ZipperT PartialEnv (State Int) a - -nextLabel :: (MonadTrans t, Monad (t (State Int))) => t (State Int) Int -nextLabel = do - l <- lift get - lift $ modify (+1) - return l - -bind :: Id SourcePos -> RefM () -bind (Id _ s) = do - lbl <- nextLabel - (env,freeIds) <- Z.getNode - Z.setNode (M.insert s lbl env, S.delete s freeIds) - -use :: Id SourcePos -> RefM () -use (Id _ s) = do - (env,freeIds) <- Z.getNode - case M.lookup s env of - Just _ -> return () - Nothing -> Z.setNode (env, S.insert s freeIds) - - -buildExpr :: Expression SourcePos -> RefM (Expression SourcePos) -buildExpr (FuncExpr loc args stmt) = do - stmt' <- Z.nest emptyPartialEnv (mapM_ bind args >> buildStmt stmt) - return (FuncExpr loc args stmt') -buildExpr e@(VarRef _ id) = do - use id - return e -buildExpr (AssignExpr loc op (VarRef loc' id) e) = do - use id - e' <- buildExpr e - return (AssignExpr loc op (VarRef loc' id) e') -buildExpr e = - gmapM buildAny e - -buildCatchClause :: CatchClause SourcePos -> RefM (CatchClause SourcePos) -buildCatchClause (CatchClause loc id stmt) = do - bind id - stmt' <- buildStmt stmt - return (CatchClause loc id stmt') - -buildVarDecl :: VarDecl SourcePos -> RefM (VarDecl SourcePos) -buildVarDecl (VarDecl loc id ye) = do - bind id - ye' <- gmapM buildAny ye - return (VarDecl loc id ye') - -buildForInInit :: ForInInit SourcePos -> RefM (ForInInit SourcePos) -buildForInInit e@(ForInVar id) = do - bind id - return e -buildForInInit e@(ForInNoVar id) = do - use id - return e - -buildStmt :: Statement SourcePos -> RefM (Statement SourcePos) -buildStmt (FunctionStmt loc id args stmt) = do - stmt' <- Z.nest emptyPartialEnv (mapM_ bind args >> buildStmt stmt) - return (FunctionStmt loc id args stmt') -buildStmt s = gmapM buildAny s - -buildAny' :: (Data a, Typeable a) => a -> RefM a -buildAny' v = gmapM buildAny v - -buildAny :: GenericM RefM -buildAny = - buildAny' `extM` buildExpr `extM` buildCatchClause `extM` - buildVarDecl `extM` buildForInInit `extM` buildStmt - --- --- buildAny creates a tree of partial environments. We now walk the tree and --- attempt to associate free identifiers with their bindings in enclosing --- scopes. Any remaining free identifiers are globals. --- - -resolveFreeId :: Env -> String -> StateT Env (State Int) Env -resolveFreeId env freeId = case M.lookup freeId env of - Just lbl -> return env -- the free identifier was bound in an enclosing env - Nothing -> do -- this is a global - globals <- get - case M.lookup freeId globals of - Just lbl -> return (M.insert freeId lbl env) -- global already bound - Nothing -> do -- new global - lbl <- nextLabel - put (M.insert freeId lbl globals) - return (M.insert freeId lbl env) - - -completeEnvM' :: Z.Tree PartialEnv -> StateT Env (State Int) (Z.Tree Env) -completeEnvM' pt = Z.dfsFoldM f M.empty pt where - -- the union is left-biased; bindings in env shadow bindings in enclosingEnv - f enclosingEnv (env,freeIds) = - foldM resolveFreeId (M.union env enclosingEnv) (S.elems freeIds) - -completeEnvM :: Z.Tree PartialEnv -> StateT Env (State Int) (Z.Tree Env) -completeEnvM pt = do - tree <- completeEnvM' pt - globals <- get - -- left-biased union: lexicals shadow globals - return (fmap (\lexicals -> M.union lexicals globals) tree) - --- --- completeEnvM creates a tree of environments whose structure is identical to --- the function-nesting structure of the JavaScript source. We walk the tree --- and the code in step and annotate the code with environments. --- - -type Ann = (Env,Int,SourcePos) - -type LabelledStatement = Statement Ann -type LabelledExpression = Expression Ann - --- Necessary for type-checking. gmapM won't let us transform the type of the --- annotation. So, we first inject SourcePos into a trivial Ann. -insertEmptyAnn :: (Functor f) => f SourcePos -> f Ann -insertEmptyAnn = fmap (\loc -> (M.empty,0,loc)) - - -locOf :: F.Foldable t => t SourcePos -> SourcePos -locOf = fromJust . (F.find $ const True) - -labelEnv :: Env -> Z.ZipperT Env (State Int) Env -labelEnv env = Z.getNode - -labelId :: Id Ann -> Z.ZipperT Env (State Int) (Id Ann) -labelId id@(Id (_,_,loc) s) = do - env <- Z.getNode - case M.lookup s env of - Nothing -> fail $ "BUG: unbound identifier while labelling" ++ show id - Just lbl -> return (Id (env,lbl,loc) s) - -labelIdNoVar :: Id Ann -> Z.ZipperT Env (State Int) (Id Ann) -labelIdNoVar (Id (_,_,loc) s) = do - env <- Z.getNode - lbl <- nextLabel - return (Id (env,lbl,loc) s) - -labelProp :: Prop Ann -> Z.ZipperT Env (State Int) (Prop Ann) -labelProp (PropId (_,_,loc) id) = do - env <- Z.getNode - lbl <- nextLabel - id' <- labelIdNoVar id - return (PropId (env,lbl,loc) id') -labelProp e = gmapM labelAny e - - -labelVarDecl :: VarDecl Ann - -> Z.ZipperT Env (State Int) (VarDecl Ann) -labelVarDecl (VarDecl (_,_,loc) id@(Id _ name) rhs) = do - env <- Z.getNode - case M.lookup name env of - Nothing -> fail $ "WebBits bug: unbound id in labelVarDecl (" ++ name ++ ")" - Just lbl' -> case rhs of - Nothing -> return (VarDecl (env,lbl',loc) id Nothing) - Just expr -> do - expr' <- labelExpr expr - return (VarDecl (env,lbl',loc) id (Just expr')) - -labelExpr :: Expression Ann - -> Z.ZipperT Env (State Int) (Expression Ann) -labelExpr (ThisRef (_,_,loc)) = do - env <- Z.getNode - case M.lookup "this" env of - Just lbl -> return $ ThisRef (env,lbl,loc) - Nothing -> fail "BUG: expected to find this in the environment" -labelExpr (DotRef (_,_,loc) expr id) = do - env <- Z.getNode - lbl <- nextLabel - id' <- labelIdNoVar id - expr' <- labelExpr expr - return (DotRef (env,lbl,loc) expr' id') -labelExpr (VarRef (_,_,loc) id@(Id _ name)) = do - env <- Z.getNode - case M.lookup name env of - Nothing -> fail $ "WebBits bug : unbound identifer " ++ name - Just lbl' -> return (VarRef (env,lbl',loc) id) -labelExpr (FuncExpr (_,_,loc) args stmt) = do - env <- Z.getNode - lbl <- nextLabel - args' <- Z.withCurrentChild (mapM labelId args) - stmt' <- Z.withCurrentChild (labelStmt stmt) - Z.shiftRight' - return (FuncExpr (env,lbl,loc) args' stmt') -labelExpr e = gmapM labelAny e - -labelStmt :: Statement Ann - -> Z.ZipperT Env (State Int) (Statement Ann) -labelStmt (BreakStmt (_,_,loc) (Just id)) = do - env <- Z.getNode - lbl <- nextLabel - id' <- labelIdNoVar id - return (BreakStmt (env,lbl,loc) (Just id')) -labelStmt (ContinueStmt (_,_,loc) (Just id)) = do - env <- Z.getNode - lbl <- nextLabel - id' <- labelIdNoVar id - return (ContinueStmt (env,lbl,loc) (Just id')) -labelStmt (LabelledStmt (_,_,loc) id stmt) = do - env <- Z.getNode - lbl <- nextLabel - id' <- labelIdNoVar id - stmt' <- labelStmt stmt - return (LabelledStmt (env,lbl,loc) id' stmt') -labelStmt (FunctionStmt (_,_,loc) id args stmt) = do - env <- Z.getNode - lbl <- nextLabel - args' <- Z.withCurrentChild (mapM labelId args) - stmt' <- Z.withCurrentChild (labelStmt stmt) - Z.shiftRight' - return (FunctionStmt (env,lbl,loc) id args' stmt') -labelStmt e = gmapM labelAny e - -labelAny' :: (Data a, Typeable a) => a -> Z.ZipperT Env (State Int) a -labelAny' a = gmapM labelAny a - -labelAny :: GenericM (Z.ZipperT Env (State Int)) -labelAny a = (labelAny' `extM` labelEnv `extM` labelId `extM` labelProp `extM` - labelExpr `extM` labelStmt `extM` labelVarDecl) a - -topLevelPartialEnv = (M.empty,S.singleton "this") - --- |Annotates each expression with its static environment. In addition, --- a map of free identifiers is returned, along with the next valid label. -staticEnvironment :: [Statement SourcePos] - -> ([Statement Ann],Env,Env,Int) -staticEnvironment stmts = - let stmts' = explicitThis stmts - labelM = do - partialEnvTree <- Z.execZipperT (mapM buildStmt stmts') - (Z.toLocation (Z.Node topLevelPartialEnv [])) - (envTree,freeEnv) <- runStateT (completeEnvM partialEnvTree) M.empty - let globals = M.union freeEnv (Z.rootLabel envTree) - let stmts'' = map insertEmptyAnn stmts' - labelledStmts <- Z.evalZipperT (mapM labelStmt stmts'') - (Z.toLocation envTree) - return (labelledStmts,freeEnv,globals) - ((labelledStmts,freeEnv,globals),nextLabel) = runState labelM 1 - in (labelledStmts,freeEnv,globals,nextLabel) diff --git a/src/WebBits/JavaScript/HtmlEmbedding.hs b/src/WebBits/JavaScript/HtmlEmbedding.hs deleted file mode 100644 --- a/src/WebBits/JavaScript/HtmlEmbedding.hs +++ /dev/null @@ -1,26 +0,0 @@ -module WebBits.JavaScript.HtmlEmbedding - ( JsHtml - , ParsedJavaScript - , ParsedJsHtml - ) where - -import WebBits.Html.Syntax(Html,Script,parseScriptBlock,parseInlineScript, - parseAttributeScript) -import WebBits.JavaScript.Parser(parseScript) -import WebBits.JavaScript.Syntax(JavaScript) ---import JavaScript.PrettyPrint -- for the instance declaration -import Text.ParserCombinators.Parsec (SourcePos) - -type JsHtml a = Html SourcePos (JavaScript a) - -type ParsedJavaScript = JavaScript SourcePos - -type ParsedJsHtml = JsHtml SourcePos - -instance Script ParsedJavaScript where - parseScriptBlock attrs = do - parseScript - parseInlineScript = Nothing - parseAttributeScript = Nothing - - diff --git a/src/WebBits/JavaScript/Instances.hs b/src/WebBits/JavaScript/Instances.hs deleted file mode 100644 --- a/src/WebBits/JavaScript/Instances.hs +++ /dev/null @@ -1,291 +0,0 @@ --- |Instances of 'Foldable' and 'Traversable' for JavaScript's syntax. -module WebBits.JavaScript.Instances - ( -- This module does not export any names. - ) where - -import Prelude hiding (foldr,sequence,mapM) -import qualified Prelude as Prelude - -import Data.Foldable (Foldable(..)) -import Data.Traversable(Traversable(..)) -import Control.Applicative - -import WebBits.JavaScript.Syntax - -yfoldr:: Foldable t => (a -> b -> b) -> b -> Maybe (t a) -> b -yfoldr _ b Nothing = b -yfoldr f b (Just t) = foldr f b t - -lfoldr:: Foldable t => (a -> b -> b) -> b -> [t a] -> b -lfoldr f = Prelude.foldr (flip $ foldr f) - -ltraverse:: (Traversable t, Applicative f) => (a -> f b) -> [t a] -> f [t b] -ltraverse _ [] = pure [] -ltraverse f (a:as) = (:) <$> traverse f a <*> ltraverse f as - -ytraverse:: (Traversable t, Applicative f) - => (a -> f b) -> Maybe (t a) -> f (Maybe (t b)) -ytraverse _ Nothing = pure Nothing -ytraverse f (Just t) = Just <$> traverse f t - -instance Functor Id where - fmap f (Id a v) = Id (f a) v - -instance Functor JavaScript where - fmap f (Script a stmts) = Script (f a) (map (fmap f) stmts) - -instance Functor Prop where - fmap f (PropId a id) = PropId (f a) (fmap f id) - fmap f (PropString a s) = PropString (f a) s - fmap f (PropNum a n) = PropNum (f a) n - -instance Functor Expression where - fmap f expression = - case expression of - StringLit a s -> StringLit (f a) s - RegexpLit a s g ci -> RegexpLit (f a) s g ci - NumLit a n -> NumLit (f a) n - BoolLit a b -> BoolLit (f a) b - NullLit a -> NullLit (f a) - ArrayLit a es -> ArrayLit (f a) (map (fmap f) es) - ObjectLit a pes -> ObjectLit (f a) (map f' pes) where - f' (p,e) = (fmap f p, fmap f e) - ThisRef a -> ThisRef (f a) - VarRef a id -> VarRef (f a) (fmap f id) - DotRef a e id -> DotRef (f a) (fmap f e) (fmap f id) - BracketRef a e1 e2 -> BracketRef (f a) (fmap f e1) (fmap f e2) - NewExpr a e es -> NewExpr (f a) (fmap f e) (map (fmap f) es) - PostfixExpr a op e -> PostfixExpr (f a) op (fmap f e) - PrefixExpr a op e -> PrefixExpr (f a) op (fmap f e) - InfixExpr a op e1 e2 -> InfixExpr (f a) op (fmap f e1) (fmap f e2) - CondExpr a e1 e2 e3 -> CondExpr (f a) (fmap f e1) (fmap f e2) (fmap f e3) - AssignExpr a op e1 e2 -> AssignExpr (f a) op (fmap f e1) (fmap f e2) - ParenExpr a e -> ParenExpr (f a) (fmap f e) - ListExpr a es -> ListExpr (f a) (map (fmap f) es) - CallExpr a e es -> CallExpr (f a) (fmap f e) (map (fmap f) es) - FuncExpr a args s -> FuncExpr (f a) (map (fmap f) args) (fmap f s) - -instance Functor CaseClause where - fmap f (CaseClause a e ss) = CaseClause (f a) (fmap f e) (map (fmap f) ss) - fmap f (CaseDefault a ss) = CaseDefault (f a) (map (fmap f) ss) - -instance Functor CatchClause where - fmap f (CatchClause a id s) = CatchClause (f a) (fmap f id) (fmap f s) - -instance Functor VarDecl where - fmap f (VarDecl a id Nothing) = VarDecl (f a) (fmap f id) Nothing - fmap f (VarDecl a id (Just e)) = VarDecl (f a) (fmap f id) (Just $ fmap f e) - -instance Functor ForInit where - fmap f NoInit = NoInit - fmap f (VarInit decls) = VarInit (map (fmap f) decls) - fmap f (ExprInit e) = ExprInit (fmap f e) - -instance Functor ForInInit where - fmap f (ForInVar id) = ForInVar (fmap f id) - fmap f (ForInNoVar id) = ForInNoVar (fmap f id) - -instance Functor Statement where - fmap f s = - case s of - BlockStmt a ss -> BlockStmt (f a) (map (fmap f) ss) - EmptyStmt a -> EmptyStmt (f a) - ExprStmt a e -> ExprStmt (f a) (fmap f e) - IfStmt a e s1 s2 -> IfStmt (f a) (fmap f e) (fmap f s1) (fmap f s2) - IfSingleStmt a e s -> IfSingleStmt (f a) (fmap f e) (fmap f s) - SwitchStmt a e cs -> SwitchStmt (f a) (fmap f e) (map (fmap f) cs) - WhileStmt a e s -> WhileStmt (f a) (fmap f e) (fmap f s) - DoWhileStmt a s e -> DoWhileStmt (f a) (fmap f s) (fmap f e) - BreakStmt a Nothing -> BreakStmt (f a) Nothing - BreakStmt a (Just id) -> BreakStmt (f a) (Just (fmap f id)) - ContinueStmt a yid -> ContinueStmt (f a) (yid >>= return.(fmap f)) - LabelledStmt a id s -> LabelledStmt (f a) (fmap f id) (fmap f s) - ForInStmt a init e s -> ForInStmt (f a) (fmap f init) (fmap f e) - (fmap f s) - ForStmt a init yinc ytest body -> - ForStmt (f a) (fmap f init) (yinc >>= return.(fmap f)) - (ytest >>= return.(fmap f)) (fmap f body) - TryStmt a s cs ys -> - TryStmt (f a) (fmap f s) (map (fmap f) cs) (ys >>= return.(fmap f)) - ThrowStmt a e -> ThrowStmt (f a) (fmap f e) - ReturnStmt a ye -> ReturnStmt (f a) (ye >>= return.(fmap f)) - WithStmt a e s -> WithStmt (f a) (fmap f e) (fmap f s) - VarDeclStmt a ds -> VarDeclStmt (f a) (map (fmap f) ds) - FunctionStmt a id args s -> - FunctionStmt (f a) (fmap f id) (map (fmap f) args) (fmap f s) - -instance Foldable Id where - foldr f b (Id a _) = f a b - -instance Foldable Prop where - foldr f b (PropId a id) = f a (foldr f b id) - foldr f b (PropString a _) = f a b - foldr f b (PropNum a _) = f a b - -instance Foldable Expression where - -- foldr:: (a -> b -> b) -> b -> Expression a -> b - foldr f b e = - case e of - StringLit a _ -> f a b - RegexpLit a _ _ _ -> f a b - NumLit a _ -> f a b - BoolLit a _ -> f a b - NullLit a -> f a b - ArrayLit a es -> f a (Prelude.foldr (flip $ foldr f) b es) - ObjectLit a pes -> f a (Prelude.foldr f' b pes) where - f' (p,e) b = foldr f (foldr f b e) p - ThisRef a -> f a b - VarRef a id -> f a (foldr f b id) - DotRef a e id -> f a (foldr f (foldr f b id) e) - BracketRef a e1 e2 -> f a (foldr f (foldr f b e2) e1) - NewExpr a e es -> f a (foldr f (Prelude.foldr (flip $ foldr f) b es) e) - PostfixExpr a _ e -> f a $ foldr f b e - PrefixExpr a _ e -> f a $ foldr f b e - InfixExpr a _ e1 e2 -> f a $ foldr f (foldr f b e2) e1 - CondExpr a e1 e2 e3 -> f a $ foldr f (foldr f (foldr f b e3) e2) e1 - AssignExpr a _ e1 e2 -> f a $ foldr f (foldr f b e2) e1 - ParenExpr a e -> f a $ foldr f b e - ListExpr a es -> f a $ Prelude.foldr (flip $ foldr f) b es - CallExpr a e es -> f a $ foldr f (Prelude.foldr (flip $ foldr f) b es) e - FuncExpr a args s -> - f a $ Prelude.foldr (flip $ foldr f) (foldr f b s) args - -instance Foldable CaseClause where - foldr f b (CaseClause a e ss) = - f a $ foldr f (Prelude.foldr (flip $ foldr f) b ss) e - foldr f b (CaseDefault a ss) = f a $ Prelude.foldr (flip $ foldr f) b ss - -instance Foldable CatchClause where - foldr f b (CatchClause a id s) = f a $ foldr f (foldr f b s) id - -instance Foldable VarDecl where - foldr f b (VarDecl a id ye) = f a $ foldr f (yfoldr f b ye) id - -instance Foldable ForInit where - foldr f b NoInit = b - foldr f b (VarInit ds) = Prelude.foldr (flip $ foldr f) b ds - foldr f b (ExprInit e) = foldr f b e - -instance Foldable ForInInit where - foldr f b (ForInVar id) = foldr f b id - foldr f b (ForInNoVar id) = foldr f b id - -instance Foldable Statement where - foldr f b statement = - case statement of - BlockStmt a ss -> f a $ lfoldr f b ss - EmptyStmt a -> f a b - ExprStmt a e -> f a $ foldr f b e - IfStmt a e s1 s2 -> f a $ foldr f (foldr f (foldr f b s2) s1) e - IfSingleStmt a e s -> f a $ foldr f (foldr f b s) e - SwitchStmt a e cs -> f a $ foldr f (lfoldr f b cs) e - WhileStmt a e s -> f a $ foldr f (foldr f b s) e - DoWhileStmt a s e -> f a $ foldr f (foldr f b e) s - BreakStmt a yid -> f a $ yfoldr f b yid - ContinueStmt a yid -> f a $ yfoldr f b yid - LabelledStmt a id s -> f a $ foldr f (foldr f b s) id - ForInStmt a init e s -> f a $ foldr f (foldr f (foldr f b s) e) init - ForStmt a init ye1 ye2 s -> - f a $ foldr f (yfoldr f (yfoldr f (foldr f b s) ye2) ye1) init - TryStmt a s cs ys -> f a $ foldr f (lfoldr f (yfoldr f b ys) cs) s - ThrowStmt a e -> f a $ foldr f b e - ReturnStmt a ys -> f a $ yfoldr f b ys - WithStmt a e s -> f a $ foldr f (foldr f b s) e - VarDeclStmt a ds -> f a $ lfoldr f b ds - FunctionStmt a id args s -> - f a $ lfoldr f (foldr f b s) (id:args) - -instance Traversable Id where - traverse f (Id a v) = Id <$> f a <*> pure v - -instance Traversable Prop where - traverse f (PropId a id) = PropId <$> f a <*> traverse f id - traverse f (PropString a s) = PropString <$> f a <*> pure s - traverse f (PropNum a n) = PropNum <$> f a <*> pure n - -instance Traversable Expression where - traverse f expression = - case expression of - StringLit a s -> StringLit <$> f a <*> pure s - RegexpLit a s g ci -> RegexpLit <$> f a <*> pure s <*> pure g <*> pure ci - NumLit a n -> NumLit <$> f a <*> pure n - BoolLit a b -> BoolLit <$> f a <*> pure b - NullLit a -> NullLit <$> f a - ArrayLit a es -> ArrayLit <$> f a <*> ltraverse f es - ObjectLit a ps -> ObjectLit <$> f a <*> (zip <$> props' <*> es') where - (props,es) = unzip ps - props' = ltraverse f props - es' = ltraverse f es - ThisRef a -> ThisRef <$> f a - VarRef a id -> VarRef <$> f a <*> traverse f id - DotRef a e id -> DotRef <$> f a <*> traverse f e <*> traverse f id - BracketRef a e es -> BracketRef <$> f a <*> traverse f e <*> traverse f es - NewExpr a e es -> NewExpr <$> f a <*> traverse f e <*> ltraverse f es - PostfixExpr a op e -> PostfixExpr <$> f a <*> pure op <*> traverse f e - PrefixExpr a op e -> PrefixExpr <$> f a <*> pure op <*> traverse f e - InfixExpr a op e1 e2 -> InfixExpr <$> f a <*> pure op <*> traverse f e1 - <*> traverse f e2 - CondExpr a e1 e2 e3 -> - CondExpr <$> f a <*> traverse f e1 <*> traverse f e2 <*> traverse f e3 - AssignExpr a op e1 e2 -> AssignExpr <$> f a <*> pure op <*> traverse f e1 - <*> traverse f e2 - ParenExpr a e -> ParenExpr <$> f a <*> traverse f e - ListExpr a es -> ListExpr <$> f a <*> ltraverse f es - CallExpr a e es -> CallExpr <$> f a <*> traverse f e <*> ltraverse f es - FuncExpr a ids s -> FuncExpr <$> f a <*> ltraverse f ids <*> traverse f s - -instance Traversable CaseClause where - traverse f (CaseClause a e ss) = - CaseClause <$> f a <*> traverse f e <*> ltraverse f ss - traverse f (CaseDefault a ss) = - CaseDefault <$> f a <*> ltraverse f ss - -instance Traversable CatchClause where - traverse f (CatchClause a id s) = - CatchClause <$> f a <*> traverse f id <*> traverse f s - -instance Traversable VarDecl where - traverse f (VarDecl a id ye) = - VarDecl <$> f a <*> traverse f id <*> ytraverse f ye - -instance Traversable ForInit where - traverse f NoInit = pure NoInit - traverse f (VarInit ds) = VarInit <$> ltraverse f ds - traverse f (ExprInit e) = ExprInit <$> traverse f e - -instance Traversable ForInInit where - traverse f (ForInVar id) = ForInVar <$> traverse f id - traverse f (ForInNoVar id) = ForInNoVar <$> traverse f id - -instance Traversable Statement where - traverse f statement = - case statement of - BlockStmt a ss -> BlockStmt <$> f a <*> ltraverse f ss - EmptyStmt a -> EmptyStmt <$> f a - ExprStmt a e -> ExprStmt <$> f a <*> traverse f e - IfStmt a e s1 s2 -> - IfStmt <$> f a <*> traverse f e <*> traverse f s1 <*> traverse f s2 - IfSingleStmt a e s -> - IfSingleStmt <$> f a <*> traverse f e <*> traverse f s - SwitchStmt a e cs -> - SwitchStmt <$> f a <*> traverse f e <*> ltraverse f cs - WhileStmt a e s -> WhileStmt <$> f a <*> traverse f e <*> traverse f s - DoWhileStmt a s e -> DoWhileStmt <$> f a <*> traverse f s <*> traverse f e - BreakStmt a yid -> BreakStmt <$> f a <*> ytraverse f yid - ContinueStmt a yid -> ContinueStmt <$> f a <*> ytraverse f yid - LabelledStmt a id s -> - LabelledStmt <$> f a <*> traverse f id <*> traverse f s - ForInStmt a init e s -> - ForInStmt <$> f a <*> traverse f init <*> traverse f e <*> traverse f s - ForStmt a init yinc ytest s -> - ForStmt <$> f a <*> traverse f init <*> ytraverse f yinc - <*> ytraverse f ytest <*> traverse f s - TryStmt a s cs ys -> - TryStmt <$> f a <*> traverse f s <*> ltraverse f cs <*> ytraverse f ys - ThrowStmt a e -> ThrowStmt <$> f a <*> traverse f e - ReturnStmt a ys -> ReturnStmt <$> f a <*> ytraverse f ys - WithStmt a e s -> WithStmt <$> f a <*> traverse f e <*> traverse f s - VarDeclStmt a ds -> VarDeclStmt <$> f a <*> ltraverse f ds - FunctionStmt a id args s -> - FunctionStmt <$> f a <*> traverse f id <*> ltraverse f args - <*> traverse f s diff --git a/src/WebBits/JavaScript/JavaScript.hs b/src/WebBits/JavaScript/JavaScript.hs deleted file mode 100644 --- a/src/WebBits/JavaScript/JavaScript.hs +++ /dev/null @@ -1,19 +0,0 @@ --- |Re-exports commonly used modules. -module WebBits.JavaScript.JavaScript - ( module WebBits.JavaScript.Syntax - , module WebBits.JavaScript.HtmlEmbedding - , module WebBits.JavaScript.Parser - , module WebBits.JavaScript.Combinators - , module WebBits.Common - -- JavaScript.Instances exports nothing - ) where - -import WebBits.Common - -import WebBits.JavaScript.Syntax -import WebBits.JavaScript.Parser -import WebBits.JavaScript.PrettyPrint -import WebBits.JavaScript.HtmlEmbedding -import WebBits.JavaScript.Combinators - -import WebBits.JavaScript.Instances diff --git a/src/WebBits/JavaScript/Lexer.hs b/src/WebBits/JavaScript/Lexer.hs deleted file mode 100644 --- a/src/WebBits/JavaScript/Lexer.hs +++ /dev/null @@ -1,64 +0,0 @@ -{- This isn't a lexer in the sense that it provides a JavaScript token-stream. - - This module provides character-parsers for various JavaScript tokens. - -} -module WebBits.JavaScript.Lexer(lexeme,identifier,reserved,operator,reservedOp,charLiteral, - stringLiteral,natural,integer,float,naturalOrFloat, - decimal,hexadecimal,octal,symbol,whiteSpace,parens, - braces,brackets,squares,semi,comma,colon,dot, - identifierStart) where - -import Prelude hiding (lex) -import Text.ParserCombinators.Parsec -import qualified Text.ParserCombinators.Parsec.Token as T - -identifierStart = (letter <|> oneOf "$_") - -javascriptDef = - T.LanguageDef "/*" - "*/" - "//" - False -- no nested comments - {- Adapted from syntax/regexps.ss in Dave's code. -} - identifierStart - (alphaNum <|> oneOf "$_") -- identifier rest - (oneOf "{}<>()~.,?:|&^=!+-*/%!") -- operator start - (oneOf "=<>|&+") -- operator rest - ["break", "case", "catch", "const", "continue", "debugger", - "default", "delete", "do", "else", "enum", "false", "finally", - "for", "function", "if", "instanceof", "in", "let", "new", - "null", "return", "switch", "this", "throw", "true", "try", - "typeof", "var", "void", "while", "with"] - ["|=", "^=", "&=", "<<=", ">>=", ">>>=", "+=", "-=", "*=", "/=", - "%=", "=", ";", ",", "?", ":", "||", "&&", "|", "^", "&", - "===", "==", "=", "!==", "!=", "<<", "<=", "<", ">>>", ">>", - ">=", ">", "++", "--", "+", "-", "*", "/", "%", "!", "~", ".", - "[", "]", "{", "}", "(", ")"," will not try its alternate in parseExpression, and we will fail. - -parseIfStmt:: StatementParser st -parseIfStmt = do - pos <- getPosition - reserved "if" - test <- parseParenExpr "parenthesized test-expression in if statement" - consequent <- parseStatement "true-branch of if statement" - optional semi -- TODO: in spec? - ((do reserved "else" - alternate <- parseStatement - return (IfStmt pos test consequent alternate)) - <|> return (IfSingleStmt pos test consequent)) - -parseSwitchStmt:: StatementParser st -parseSwitchStmt = - let parseDefault = do - pos <- getPosition - reserved "default" - colon - statements <- many parseStatement - return (CaseDefault pos statements) - parseCase = do - pos <- getPosition - reserved "case" - condition <- parseListExpr - colon - actions <- many parseStatement - return (CaseClause pos condition actions) - in do pos <- getPosition - reserved "switch" - test <- parseParenExpr - clauses <- braces $ many $ parseDefault <|> parseCase - return (SwitchStmt pos test clauses) - -parseWhileStmt:: StatementParser st -parseWhileStmt = do - pos <- getPosition - reserved "while" - test <- parseParenExpr "parenthesized test-expression in while loop" - body <- parseStatement - return (WhileStmt pos test body) - -parseDoWhileStmt:: StatementParser st -parseDoWhileStmt = do - pos <- getPosition - reserved "do" - body <- parseBlockStmt - reserved "while" "while at the end of a do block" - test <- parseParenExpr "parenthesized test-expression in do loop" - optional semi - return (DoWhileStmt pos body test) - -parseContinueStmt:: StatementParser st -parseContinueStmt = do - pos <- getPosition - reserved "continue" - pos' <- getPosition - -- Ensure that the identifier is on the same line as 'continue.' - id <- (if (sourceLine pos == sourceLine pos') - then (liftM Just identifier) <|> (return Nothing) - else return Nothing) - return (ContinueStmt pos id) - -parseBreakStmt:: StatementParser st -parseBreakStmt = do - pos <- getPosition - reserved "break" - pos' <- getPosition - -- Ensure that the identifier is on the same line as 'break.' - id <- (if (sourceLine pos == sourceLine pos') - then (liftM Just identifier) <|> (return Nothing) - else return Nothing) - optional semi - return (BreakStmt pos id) - -parseBlockStmt:: StatementParser st -parseBlockStmt = do - pos <- getPosition - statements <- braces (many parseStatement) - return (BlockStmt pos statements) - -parseEmptyStmt:: StatementParser st -parseEmptyStmt = do - pos <- getPosition - semi - return (EmptyStmt pos) - -parseLabelledStmt:: StatementParser st -parseLabelledStmt = do - pos <- getPosition - -- Lookahead for the colon. If we don't see it, we are parsing an identifier - -- for an expression statement. - label <- try (do label <- identifier - colon - return label) - statement <- parseStatement - return (LabelledStmt pos label statement) - -parseExpressionStmt:: StatementParser st -parseExpressionStmt = do - pos <- getPosition - expr <- parseListExpr -- TODO: spec 12.4? - optional semi - return (ExprStmt pos expr) - - -parseForInStmt:: StatementParser st -parseForInStmt = - let parseInit = (reserved "var" >> liftM ForInVar identifier) - <|> (liftM ForInNoVar identifier) - in do pos <- getPosition - -- Lookahead, so that we don't clash with parseForStmt - (init,expr) <- try (do reserved "for" - parens (do init <- parseInit - reserved "in" - expr <- parseExpression - return (init,expr))) - body <- parseStatement - return (ForInStmt pos init expr body) - -parseForStmt:: StatementParser st -parseForStmt = - let parseInit = - (reserved "var" >> liftM VarInit (parseVarDecl `sepBy` comma)) <|> - (liftM ExprInit parseListExpr) <|> - (return NoInit) - in do pos <- getPosition - reserved "for" - reservedOp "(" - init <- parseInit - semi - test <- (liftM Just parseExpression) <|> (return Nothing) - semi - iter <- (liftM Just parseExpression) <|> (return Nothing) - reservedOp ")" "closing paren" - stmt <- parseStatement - return (ForStmt pos init test iter stmt) - -parseTryStmt:: StatementParser st -parseTryStmt = - let parseCatchClause = do - pos <- getPosition - reserved "catch" - id <- parens identifier - stmt <- parseStatement - return (CatchClause pos id stmt) - in do reserved "try" - pos <- getPosition - guarded <- parseStatement - catches <- many parseCatchClause - finally <- (reserved "finally" >> liftM Just parseStatement) - <|> (return Nothing) - return (TryStmt pos guarded catches finally) - -parseThrowStmt:: StatementParser st -parseThrowStmt = do - pos <- getPosition - reserved "throw" - expr <- parseExpression - optional semi - return (ThrowStmt pos expr) - -parseReturnStmt:: StatementParser st -parseReturnStmt = do - pos <- getPosition - reserved "return" - expr <- (liftM Just parseListExpr) <|> (return Nothing) - optional semi - return (ReturnStmt pos expr) - -parseWithStmt:: StatementParser st -parseWithStmt = do - pos <- getPosition - reserved "with" - context <- parseParenExpr - stmt <- parseStatement - return (WithStmt pos context stmt) - -parseVarDecl = do - pos <- getPosition - id <- identifier - init <- (reservedOp "=" >> liftM Just parseExpression) <|> (return Nothing) - return (VarDecl pos id init) - -parseVarDeclStmt:: StatementParser st -parseVarDeclStmt = do - pos <- getPosition - reserved "var" - decls <- parseVarDecl `sepBy` comma - optional semi - return (VarDeclStmt pos decls) - -parseFunctionStmt:: StatementParser st -parseFunctionStmt = do - pos <- getPosition - name <- try (reserved "function" >> identifier) -- ambiguity with FuncExpr - args <- parens (identifier `sepBy` comma) - body <- parseBlockStmt "function body in { ... }" - return (FunctionStmt pos name args body) - -parseStatement:: StatementParser st -parseStatement = parseIfStmt <|> parseSwitchStmt <|> parseWhileStmt - <|> parseDoWhileStmt <|> parseContinueStmt <|> parseBreakStmt - <|> parseBlockStmt <|> parseEmptyStmt <|> parseForInStmt <|> parseForStmt - <|> parseTryStmt <|> parseThrowStmt <|> parseReturnStmt <|> parseWithStmt - <|> parseVarDeclStmt <|> parseFunctionStmt - -- labelled, expression and the error message always go last, in this order - <|> parseLabelledStmt <|> parseExpressionStmt "statement" - ---}}} - ---{{{ Expressions - --- References used to construct this stuff: --- + http://developer.mozilla.org/en/docs/ --- Core_JavaScript_1.5_Reference:Operators:Operator_Precedence --- + http://www.mozilla.org/js/language/grammar14.html --- --- Aren't expression tables nice? Well, we can't quite use them, because of --- JavaScript's ternary (?:) operator. We have to use two expression tables. --- We use one expression table for the assignment operators that bind looser --- than ?: (assignTable). The terms of assignTable are ternary expressions --- (parseTernaryExpr). parseTernaryExpr left-factors the left-recursive --- production for ?:, and is defined over the second expression table, --- exprTable, which consists of operators that bind tighter than ?:. The terms --- of exprTable are atomic expressions, parenthesized expressions, functions and --- array references. - ---{{{ Primary expressions - -parseThisRef:: ExpressionParser st -parseThisRef = do - pos <- getPosition - reserved "this" - return (ThisRef pos) - -parseNullLit:: ExpressionParser st -parseNullLit = do - pos <- getPosition - reserved "null" - return (NullLit pos) - - -parseBoolLit:: ExpressionParser st -parseBoolLit = do - pos <- getPosition - let parseTrueLit = reserved "true" >> return (BoolLit pos True) - parseFalseLit = reserved "false" >> return (BoolLit pos False) - parseTrueLit <|> parseFalseLit - -parseVarRef:: ExpressionParser st -parseVarRef = liftM2 VarRef getPosition identifier - -parseArrayLit:: ExpressionParser st -parseArrayLit = liftM2 ArrayLit getPosition (squares (parseExpression `sepBy` comma)) - -parseFuncExpr = do - pos <- getPosition - reserved "function" - args <- parens (identifier `sepBy` comma) - body <- parseBlockStmt - return $ FuncExpr pos args body - ---{{{ parsing strings - -escapeChars = - [('\'','\''),('\"','\"'),('\\','\\'),('b','\b'),('f','\f'),('n','\n'), - ('r','\r'),('t','\t'),('v','\v'),('/','/')] - -allEscapes:: String -allEscapes = map fst escapeChars - -parseEscapeChar = do - c <- oneOf allEscapes - let (Just c') = lookup c escapeChars -- will succeed due to line above - return c' - -parseAsciiHexChar = do - char 'x' - d1 <- hexDigit - d2 <- hexDigit - return ((chr.fst.head.readHex) (d1:d2:"")) - -parseUnicodeHexChar = do - char 'u' - liftM (chr.fst.head.readHex) - (sequence [hexDigit,hexDigit,hexDigit,hexDigit]) - -isWhitespace ch = ch `elem` " \t" - - --- The endWith argument is either single-quote or double-quote, depending on how --- we opened the string. -parseStringLit' endWith = - (char endWith >> return "") <|> - (do try (string "\\'") - cs <- parseStringLit' endWith - return $ "'" ++ cs) <|> - (do char '\\' - c <- parseEscapeChar <|> parseAsciiHexChar <|> parseUnicodeHexChar <|> - char '\r' <|> char '\n' - cs <- parseStringLit' endWith - if c == '\r' || c == '\n' - then return (c:(dropWhile isWhitespace cs)) - else return (c:cs)) <|> - (liftM2 (:) anyChar (parseStringLit' endWith)) - -parseStringLit:: ExpressionParser st -parseStringLit = do - pos <- getPosition - -- parseStringLit' takes as an argument the quote-character that opened the - -- string. - str <- lexeme $ (char '\'' >>= parseStringLit') <|> (char '\"' >>= parseStringLit') - -- CRUCIAL: Parsec.Token parsers expect to find their token on the first - -- character, and read whitespaces beyond their tokens. Without 'lexeme' - -- above, expressions like: - -- var s = "string" ; - -- do not parse. - return $ StringLit pos str - ---}}} - -parseRegexpLit:: ExpressionParser st -parseRegexpLit = do - let parseFlags = do - flags <- many (oneOf "mgi") - return $ \f -> f ('g' `elem` flags) ('i' `elem` flags) - let parseEscape = char '\\' >> anyChar - let parseChar = noneOf "/" - let parseRe = (char '/' >> return "") <|> - (do char '\\' - ch <- anyChar -- TOOD: too lenient - rest <- parseRe - return ('\\':ch:rest)) <|> - (liftM2 (:) anyChar parseRe) - pos <- getPosition - char '/' - pat <- parseRe --many1 parseChar - flags <- parseFlags - spaces -- crucial for Parsec.Token parsers - return $ flags (RegexpLit pos pat) - -parseObjectLit:: ExpressionParser st -parseObjectLit = - let parseProp = do - -- Parses a string, identifier or integer as the property name. I - -- apologize for the abstruse style, but it really does make the code - -- much shorter. - name <- (liftM (uncurry PropString) - (liftM (\(StringLit p s) -> (p,s)) parseStringLit)) - <|> (liftM2 PropId getPosition identifier) - <|> (liftM2 PropNum getPosition decimal) - colon - val <- parseAssignExpr - return (name,val) - in do pos <- getPosition - props <- braces (parseProp `sepEndBy` comma) "object literal" - return $ ObjectLit pos props - ---{{{ Parsing numbers. From pg. 17-18 of ECMA-262. - -hexLit = do - try (string "0x") - digits <- many1 (oneOf "0123456789abcdefABCDEF") - [(hex,"")] <- return $ Numeric.readHex digits - return hex - --- Creates a decimal value from a whole, fractional and exponent part. -mkDecimal:: Double -> Double -> Int -> Double -mkDecimal w f e = - if (f >= 1.0) - then mkDecimal w (f / 10.0) e - else (w + f) * (10.0 ^^ e) - -exponentPart = do - oneOf "eE" - (char '+' >> decimal) <|> (char '-' >> negate `fmap` decimal) <|> decimal - -decLit = - (do whole <- decimal - frac <- option 0 (char '.' >> decimal) - exp <- option 0 exponentPart - return $ mkDecimal (fromIntegral whole) (fromIntegral frac) (fromIntegral exp)) <|> - (do frac <- char '.' >> decimal - exp <- option 0 exponentPart - return $ mkDecimal 0.0 (fromIntegral frac) (fromIntegral exp)) - -parseNumLit:: ExpressionParser st -parseNumLit = do - pos <- getPosition - num <- lexeme $ hexLit <|> decLit - notFollowedBy identifierStart "whitespace" - return $ NumLit pos num - ---}}} - ------------------------------------------------------------------------------- --- Position Helper ------------------------------------------------------------------------------- - -withPos cstr p = do { pos <- getPosition; e <- p; return $ cstr pos e } - -------------------------------------------------------------------------------- --- Compound Expression Parsers -------------------------------------------------------------------------------- - -dotRef e = (reservedOp "." >> withPos cstr identifier) "property.ref" - where cstr pos key = DotRef pos e key - -funcApp e = (parens $ withPos cstr (parseExpression `sepBy` comma)) "(function application)" - where cstr pos args = CallExpr pos e args - -bracketRef e = (brackets $ withPos cstr parseExpression) "[property-ref]" - where cstr pos key = BracketRef pos e key - -------------------------------------------------------------------------------- --- Expression Parsers -------------------------------------------------------------------------------- - -parseParenExpr:: ExpressionParser st -parseParenExpr = withPos ParenExpr (parens parseListExpr) - --- everything above expect functions -parseExprForNew = parseThisRef <|> parseNullLit <|> parseBoolLit <|> parseStringLit - <|> parseArrayLit <|> parseParenExpr <|> parseNewExpr <|> parseNumLit - <|> parseRegexpLit <|> parseObjectLit <|> parseVarRef - --- all the expression parsers defined above -parseSimpleExpr' = parseThisRef <|> parseNullLit <|> parseBoolLit - <|> parseStringLit <|> parseArrayLit <|> parseParenExpr - <|> parseFuncExpr <|> parseNumLit <|> parseRegexpLit <|> parseObjectLit - <|> parseVarRef - -parseNewExpr = - (do pos <- getPosition - reserved "new" - constructor <- parseSimpleExprForNew Nothing -- right-associativity - arguments <- (try (parens (parseExpression `sepBy` comma))) <|> (return []) - return (NewExpr pos constructor arguments)) <|> - parseSimpleExpr' - -parseSimpleExpr (Just e) = (do - e' <- dotRef e <|> funcApp e <|> bracketRef e - parseSimpleExpr $ Just e') <|> (return e) -parseSimpleExpr Nothing = do - e <- parseNewExpr "expression (3)" - parseSimpleExpr (Just e) - -parseSimpleExprForNew (Just e) = (do - e' <- dotRef e <|> bracketRef e - parseSimpleExprForNew $ Just e') <|> (return e) -parseSimpleExprForNew Nothing = do - e <- parseNewExpr "expression (3)" - parseSimpleExprForNew (Just e) - ---}}} - -makeInfixExpr str constr = Infix parser AssocLeft where - parser:: CharParser st (Expression SourcePos -> Expression SourcePos -> Expression SourcePos) - parser = do - pos <- getPosition - reservedOp str - return (InfixExpr pos constr) -- points-free, returns a function - -makePrefixExpr str constr = Prefix parser where - parser = do - pos <- getPosition - (reservedOp str <|> reserved str) - return (PrefixExpr pos constr) -- points-free, returns a function - -mkPrefix operator constr = Prefix $ do - pos <- getPosition - operator - return (\operand -> PrefixExpr pos constr operand) - -makePostfixExpr str constr = Postfix parser where - parser = do - pos <- getPosition - (reservedOp str <|> reserved str) - return (PostfixExpr pos constr) -- points-free, returns a function - -prefixIncDecExpr = do - pos <- getPosition - op <- optionMaybe $ (reservedOp "++" >> return PrefixInc) <|> - (reservedOp "--" >> return PrefixDec) - case op of - Nothing -> parseSimpleExpr Nothing - Just op -> do - innerExpr <- parseSimpleExpr Nothing -- TODO: must be an l-val, I think - return (PrefixExpr pos op innerExpr) - --- apparently, expression tables can't handle immediately-nested prefixes - -parsePrefixedExpr = do - pos <- getPosition - op <- optionMaybe $ (reservedOp "!" >> return PrefixLNot) <|> - (reservedOp "~" >> return PrefixBNot) <|> - (try (lexeme $ char '-' >> notFollowedBy (char '-')) >> - return PrefixMinus) <|> - (try (lexeme $ char '+' >> notFollowedBy (char '+')) >> - return PrefixPlus) <|> - (reserved "typeof" >> return PrefixTypeof) <|> - (reserved "void" >> return PrefixVoid) <|> - (reserved "delete" >> return PrefixDelete) - case op of - Nothing -> prefixIncDecExpr -- new is treated as a simple expr - Just op -> do - innerExpr <- parsePrefixedExpr - return (PrefixExpr pos op innerExpr) - -exprTable:: [[Operator Char st ParsedExpression]] -exprTable = - [ - [makePrefixExpr "++" PrefixInc, - makePostfixExpr "++" PostfixInc], - [makePrefixExpr "--" PrefixDec, - makePostfixExpr "--" PostfixDec], - [makeInfixExpr "*" OpMul, makeInfixExpr "/" OpDiv, makeInfixExpr "%" OpMod], - [makeInfixExpr "+" OpAdd, makeInfixExpr "-" OpSub], - [makeInfixExpr "<<" OpLShift, makeInfixExpr ">>" OpSpRShift, - makeInfixExpr ">>>" OpZfRShift], - [makeInfixExpr "<" OpLT, makeInfixExpr "<=" OpLEq, makeInfixExpr ">" OpGT, - makeInfixExpr ">=" OpGEq, - makeInfixExpr "instanceof" OpInstanceof, makeInfixExpr "in" OpIn], - [makeInfixExpr "&" OpBAnd], - [makeInfixExpr "^" OpBXor], - [makeInfixExpr "|" OpBOr], - [makeInfixExpr "&&" OpLAnd], - [makeInfixExpr "||" OpLOr], - [makeInfixExpr "==" OpEq, makeInfixExpr "!=" OpNEq, - makeInfixExpr "===" OpStrictEq, makeInfixExpr "!==" OpStrictNEq] - ] - -parseExpression' = - buildExpressionParser exprTable parsePrefixedExpr "simple expression" - ---{{{ Parsing ternary operators: left factored - -parseTernaryExpr':: CharParser st (ParsedExpression,ParsedExpression) -parseTernaryExpr' = do - reservedOp "?" - l <- parseAssignExpr - colon - r <- parseAssignExpr - return $(l,r) - -parseTernaryExpr:: ExpressionParser st -parseTernaryExpr = do - e <- parseExpression' - e' <- optionMaybe parseTernaryExpr' - case e' of - Nothing -> return e - Just (l,r) -> do p <- getPosition - return $ CondExpr p e l r ---}}} - --- Parsing assignment operations. -makeAssignExpr str constr = Infix parser AssocRight where - parser:: CharParser st (ParsedExpression -> ParsedExpression -> ParsedExpression) - parser = do - pos <- getPosition - reservedOp str - return (AssignExpr pos constr) - -assignTable:: [[Operator Char st ParsedExpression]] -assignTable = [ - [makeAssignExpr "=" OpAssign, makeAssignExpr "+=" OpAssignAdd, - makeAssignExpr "-=" OpAssignSub, makeAssignExpr "*=" OpAssignMul, - makeAssignExpr "/=" OpAssignDiv, makeAssignExpr "%=" OpAssignMod, - makeAssignExpr "<<=" OpAssignLShift, makeAssignExpr ">>=" OpAssignSpRShift, - makeAssignExpr ">>>=" OpAssignZfRShift, makeAssignExpr "&=" OpAssignBAnd, - makeAssignExpr "^=" OpAssignBXor, makeAssignExpr "|=" OpAssignBOr - ]] - - -parseAssignExpr:: ExpressionParser st -parseAssignExpr = buildExpressionParser assignTable parseTernaryExpr - -parseExpression:: ExpressionParser st -parseExpression = parseAssignExpr - -parseListExpr = - liftM2 ListExpr getPosition (parseAssignExpr `sepBy1` comma) - ---}}} - -parseScript:: CharParser state (JavaScript SourcePos) -parseScript = do - whiteSpace - liftM2 Script getPosition (parseStatement `sepBy` whiteSpace) - -parseJavaScriptFromFile :: MonadIO m => String -> m [Statement SourcePos] -parseJavaScriptFromFile filename = do - chars <- liftIO $ readFile filename - case parse parseScript filename chars of - Left err -> fail (show err) - Right (Script _ stmts) -> return stmts - - -parseScriptFromString:: String -> String -> Either ParseError (JavaScript SourcePos) -parseScriptFromString src script = parse parseScript src script - -emptyParsedJavaScript = - Script (error "Parser.emptyParsedJavaScript--no annotation") [] - -parseString :: String -> [Statement SourcePos] -parseString str = case parse parseScript "" str of - Left err -> error (show err) - Right (Script _ stmts) -> stmts diff --git a/src/WebBits/JavaScript/PrettyPrint.hs b/src/WebBits/JavaScript/PrettyPrint.hs deleted file mode 100644 --- a/src/WebBits/JavaScript/PrettyPrint.hs +++ /dev/null @@ -1,261 +0,0 @@ --- |Pretty-printing JavaScript. This module doesn't export any names, but --- importing it declares PrettyPrintable instances for JavaScript.Syntax. -module WebBits.JavaScript.PrettyPrint() where - -import Text.PrettyPrint.HughesPJ -import WebBits.JavaScript.Syntax -import WebBits.JavaScript.Combinators -import WebBits.Common - ---{{{ Helper functions for common printing patterns - --- Displays the statement in { ... }, unless it already is in a block. -inBlock:: (Statement a) -> Doc -inBlock stmt@(BlockStmt _ _) = pp stmt -inBlock stmt = text "{" $+$ pp stmt $+$ text "}" - --- Displays the expression in ( ... ), unless it already is in parens. -inParens:: (Expression a) -> Doc -inParens expr@(ParenExpr _ _) = pp expr -inParens expr = parens (pp expr) - -commaSep:: (PrettyPrintable a) => [a] -> Doc -commaSep = hsep.(punctuate comma).(map pp) - ---}}} - -instance PrettyPrintable (Id a) where - pp (Id _ str) = text str - -instance PrettyPrintable (ForInit a) where - pp NoInit = empty - pp (VarInit vs) = text "var" <+> commaSep vs - pp (ExprInit e) = pp e - -instance PrettyPrintable (ForInInit a) where - pp (ForInVar id) = text "var" <+> pp id - pp (ForInNoVar id) = pp id - ---{{{ Pretty-printing statements - -instance PrettyPrintable (CaseClause a) where - pp (CaseClause _ expr stmts) = - text "case" $+$ pp expr <+> colon $$ (nest 2 (vcat (map pp stmts))) - pp (CaseDefault _ stmts) = - text "default:" $$ (nest 2 (vcat (map pp stmts))) - -instance PrettyPrintable (CatchClause a) where - pp (CatchClause _ id stmt) = - text "catch" <+> (parens.pp) id <+> inBlock stmt - - -instance PrettyPrintable (VarDecl a) where - pp (VarDecl _ id Nothing) = - pp id - pp (VarDecl _ id (Just expr)) = - pp id <+> equals <+> pp expr - -instance PrettyPrintable (Statement a) where - pp (BlockStmt _ stmts) = - text "{" $+$ nest 2 (vcat (map pp stmts)) $+$ text "}" - pp (EmptyStmt _) = - semi - pp (ExprStmt _ expr) = - pp expr <> semi - pp (IfSingleStmt _ test cons) = - text "if" <+> inParens test $$ (nest 2 (pp cons)) - pp (IfStmt _ test cons alt) = - text "if" <+> inParens test $$ (nest 2 $ pp cons) $$ text "else" - $$ (nest 2 $ pp alt) - pp (SwitchStmt _ expr cases) = - text "switch" <+> inParens expr $$ braces (nest 2 (vcat (map pp cases))) - pp (WhileStmt _ test body) = - text "while" <+> inParens test $$ (nest 2 (pp body)) - pp (ReturnStmt _ expr) = - text "return" <+> pp expr <> semi - pp (DoWhileStmt _ stmt expr) = - text "do" $$ (nest 2 (pp stmt <+> text "while" <+> inParens expr)) - pp (BreakStmt _ Nothing) = - text "break;" - pp (BreakStmt _ (Just label)) = - text "break" <+> pp label <> semi - pp (ContinueStmt _ Nothing) = - text "continue;" - pp (ContinueStmt _ (Just label)) = - text"continue" <+> pp label <> semi - pp (LabelledStmt _ label stmt) = - pp label <> colon $$ pp stmt - pp (ForInStmt p init expr body) = - text "for" <+> parens (pp init <+> text "in" <+> pp expr) - $$ (nest 2 (pp body)) - pp (ForStmt _ init incr test body) = - text "for" <+> parens (pp init <> semi <+> pp incr <> semi <+> pp test) - $$ (nest 2 (pp body)) - pp (TryStmt _ stmt catches finally) = - text "try" $$ inBlock stmt $$ (vcat (map pp catches)) $$ ppFinally where - ppFinally = case finally of - Nothing -> empty - Just stmt -> text "finally" <> inBlock stmt - pp (ThrowStmt _ expr) = - text "throw" <+> pp expr <> semi - pp (WithStmt _ expr stmt) | isParenExpr expr = - (text "with" <+> inParens expr $$ pp stmt) - pp (WithStmt _ expr stmt) | otherwise = - (text "with" <+> inParens expr $$ pp stmt) - pp (VarDeclStmt _ decls) = - text "var" <+> commaSep decls <> semi - pp (FunctionStmt _ name args stmt) = - text "function" <+> pp name <> (parens.commaSep) args $$ inBlock stmt - ---}}} - -instance PrettyPrintable (Prop a) where - pp (PropId _ id) = pp id - pp (PropString _ str) = doubleQuotes (text (jsEscape str)) - pp (PropNum _ n) = text (show n) - - ---{{{ infix-operators - -showInfix op = - case op of - OpMul -> "*" - OpDiv -> "/" - OpMod -> "%" - OpAdd -> "+" - OpSub -> "-" - OpLShift -> "<<" - OpSpRShift -> ">>" - OpZfRShift -> ">>>" - OpLT -> "<" - OpLEq -> "<=" - OpGT -> ">" - OpGEq -> ">=" - OpIn -> "in" - OpInstanceof -> "instanceof" - OpEq -> "==" - OpNEq -> "!=" - OpStrictEq -> "===" - OpStrictNEq -> "!==" - OpBAnd -> "&" - OpBXor -> "^" - OpBOr -> "|" - OpLAnd -> "&&" - OpLOr -> "||" - -instance PrettyPrintable InfixOp where - pp op = text (showInfix op) ---}}} - ---{{{ prefix operators - -showPrefix PrefixInc = "++" -showPrefix PrefixDec = "--" -showPrefix PrefixLNot = "!" -showPrefix PrefixBNot = "~" -showPrefix PrefixPlus = "+" -showPrefix PrefixMinus = "-" -showPrefix PrefixTypeof = "typeof" -showPrefix PrefixVoid = "void" -showPrefix PrefixDelete = "delete" - -instance PrettyPrintable PrefixOp where - pp op = text (showPrefix op) - ---}}} - ---{{{ postfix operators - -instance PrettyPrintable PostfixOp where - pp PostfixInc = text "++" - pp PostfixDec = text "--" - ---}}} - ---{{{ assignment operators - -showAssignOp OpAssign = "=" -showAssignOp OpAssignAdd = "+=" -showAssignOp OpAssignSub = "-=" -showAssignOp OpAssignMul = "*=" -showAssignOp OpAssignDiv = "/=" -showAssignOp OpAssignMod = "%=" -showAssignOp OpAssignLShift = "<<=" -showAssignOp OpAssignSpRShift = ">>=" -showAssignOp OpAssignZfRShift = ">>>=" -showAssignOp OpAssignBAnd = "&=" -showAssignOp OpAssignBXor = "^=" -showAssignOp OpAssignBOr = "|=" - -instance PrettyPrintable AssignOp where - pp = text.showAssignOp - ---}}} - ---{{{ expressions - --- Based on: --- http://developer.mozilla.org/en/docs/Core_JavaScript_1.5_Guide:Literals -jsEscape:: String -> String -jsEscape "" = "" -jsEscape (ch:chs) = (sel ch) ++ jsEscape chs where - sel '\b' = "\\b" - sel '\f' = "\\f" - sel '\n' = "\\n" - sel '\r' = "\\r" - sel '\t' = "\\t" - sel '\v' = "\\v" - sel '\'' = "\\'" - sel '\"' = "\\\"" - sel '\\' = "\\\\" - sel x = [x] - -- We don't have to do anything about \X, \x and \u escape sequences. - - -instance PrettyPrintable (Expression a) where - pp (StringLit _ str) = doubleQuotes (text (jsEscape str)) - pp (RegexpLit _ re global ci) = - text "/" <> text re <> text "/" <> g <> i where - g = if global then text "g" else empty - i = if ci then text "i" else empty - pp (NumLit _ n) = text (show n) - pp (BoolLit _ True) = text "true" - pp (BoolLit _ False) = text "false" - pp (NullLit _) = text "null" - pp (ArrayLit _ xs) = - (brackets.commaSep) xs - pp (ObjectLit _ xs) = - braces (hsep (punctuate comma (map pp' xs))) where - pp' (n,v) = pp n <> colon <+> pp v - pp (ThisRef _) = text "this" - pp (VarRef _ id) = pp id - pp (DotRef _ expr id) = - pp expr <> text "." <> pp id - pp (BracketRef _ container key) = - pp container <> brackets (pp key) - pp (NewExpr _ constr args) = - text "new" <+> pp constr <> (parens.commaSep) args - pp (PrefixExpr _ op expr) = - pp op <+> pp expr - pp (PostfixExpr _ op expr) = - pp expr <+> pp op - pp (InfixExpr _ op left right) = - pp left <+> pp op <+> pp right - pp (CondExpr _ test cons alt) = - pp test <+> text "?" <+> pp cons <+> colon <+> pp alt - pp (AssignExpr _ op l r) = - pp l <+> pp op <+> pp r - pp (ParenExpr _ expr) = - parens (pp expr) - pp (ListExpr _ exprs) = commaSep exprs - pp (CallExpr _ f args) = - pp f <> (parens.commaSep) args - pp (FuncExpr _ args body) = - text "function" <+> (parens.commaSep) args $$ inBlock body - -instance PrettyPrintable (JavaScript a) where - pp (Script _ stmts) = - vcat (map pp stmts) - ---}}} - diff --git a/src/WebBits/JavaScript/Syntax.hs b/src/WebBits/JavaScript/Syntax.hs deleted file mode 100644 --- a/src/WebBits/JavaScript/Syntax.hs +++ /dev/null @@ -1,117 +0,0 @@ --- |JavaScript's syntax. -module WebBits.JavaScript.Syntax(Expression(..),CaseClause(..),Statement(..), - InfixOp(..),CatchClause(..),VarDecl(..),JavaScript(..), - AssignOp(..),Id(..),PrefixOp(..),PostfixOp(..),Prop(..), - ForInit(..),ForInInit(..)) where - -import Text.ParserCombinators.Parsec(SourcePos) -- used by data JavaScript -import Data.Generics(Data,Typeable) - -data JavaScript a - -- |A script in 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)