diff --git a/DeclarationGraph.hs b/DeclarationGraph.hs index 28ba5dc..ca7f015 100644 --- a/DeclarationGraph.hs +++ b/DeclarationGraph.hs @@ -29,8 +29,8 @@ -- -- (getDeclarationGraph -- (label --- (jsastListWSMakeSourceFragments --- (getJSASTWithSource +-- (astListWSMakeSourceFragments +-- (getASTWithSource -- (parseTree -- program -- file) @@ -67,7 +67,7 @@ ) where -import LabelJSAST +import LabelAST import ParseJS import ResolveSourceFragments import System.Environment @@ -79,8 +79,8 @@ import TypeRules -- Will it be useful when it comes time to compile? Should I alter it to use the unique identifiers? data ParentFunction = ParentFunDecl ASTChild - | ParentFunExpr ExprChild - | ParentGlobal [ASTChild] + | ParentFunExpr ASTChild + | ParentGlobal ASTChild | TopLevel deriving (Show) @@ -330,21 +330,21 @@ mapFunExprGetAllRules [] rules = rules -- new scope when entered. Each node includes the type rules gathered from within that block. The -- rules are expressed with unique identifiers so that they can later be extracted from the tree and -- placed in a set without identifier collisions occuring. -getDeclarationGraph :: [ASTChild] -> SourceFragment -> FunctionRules +getDeclarationGraph :: ASTChild -> SourceFragment -> FunctionRules -- Make a dummy global function, with all global level functions and variables declared in the -- "body" of the global function. -getDeclarationGraph jsastLab fragment = +getDeclarationGraph astLab fragment = FunctionRules GlobalID - (mapASTChildRules jsastLab dIDs) - (mapASTGetFR jsastLab (ParentGlobal jsastLab) dIDs) - (mapASTGetFER jsastLab (ParentGlobal jsastLab) dIDs) - (concat $ map astGetVarDecs jsastLab) + (astChildRules astLab dIDs) + (astGetFunRules astLab (ParentGlobal astLab) dIDs) + (astGetFunExprRules astLab (ParentGlobal astLab) dIDs) + dIDs fragment TopLevel where -- Get identifiers for everything declared at the global level. - dIDs = (concat $ map astGetVarDecs jsastLab) + dIDs = (astGetVarDecs astLab) -- Find all indentifiers declared in the signature and body of a function. @@ -359,7 +359,7 @@ funDecGetVarDecs (LabFunctionDeclaration var args body, n, sourceFragment) = -- Find all indentifiers declared in the signature and body of a function expression. -funExprGetVarDecs :: ExprChild -> [DeclaredIdentifier] +funExprGetVarDecs :: ASTChild -> [DeclaredIdentifier] funExprGetVarDecs (LabFunctionExpression mv args body, n, sourceFragment) = -- Add the name of the function expression, if it has one. (listID (funExprMakeLabel thisFun)) @@ -417,18 +417,19 @@ mapASTGetFER ast parent dIDs = mfr a = astGetFunExprRules a parent dIDs --- Map exprGetFunExprRules over a list of labelled Expression nodes. -mapExpGetFER :: [ExprChild] -> ParentFunction -> [DeclaredIdentifier] -> [FunctionExpressionRules] +-- Map astGetFunExprRules over a list of labelled Expression nodes. +mapExpGetFER :: [ASTChild] -> ParentFunction -> [DeclaredIdentifier] -> [FunctionExpressionRules] mapExpGetFER exList parent dIDs = concat $ map gfe exList where - gfe ex = exprGetFunExprRules ex parent dIDs + gfe ex = astGetFunExprRules ex parent dIDs -- Make FunctionRules from an labelled AST node. For most inputs, with the exception of -- LabFunctionDeclaration, LabReturn and LabStatement, just process the body recursively. astGetFunRules :: ASTChild -> ParentFunction -> [DeclaredIdentifier] -> [FunctionRules] -astGetFunRules (LabBlock astList, n, sourceFragment) parent dIDs = (mapASTGetFR astList parent dIDs) +-- FIXME: Uncomment this and fix it (second field is not a list any more) +-- astGetFunRules (LabBlock astList, n, sourceFragment) parent dIDs = (mapASTGetFR astList parent dIDs) astGetFunRules (LabFunctionBody astList, n, sourceFragment) parent dIDs = (mapASTGetFR astList parent dIDs) -- For a FunctionDeclaration we add a new FunctionRules. astGetFunRules (LabFunctionDeclaration (fid, x) args body, n, sourceFragment) parent dIDs = @@ -486,11 +487,16 @@ astGetFunRules (LabReturn ex, n, sourceFragment) parent dIDs = [] -- function declaration. Return nothing. astGetFunRules (LabStatement ex, n, sourceFragment) parent dIDs = [] +-- Make FunctionExpressionRules from an Expression. All of these, with the exception of +-- LabFunctionExpression, either return nothing (when they don't contain any fields that could +-- contain a function expression), or recursively process any expression or value fields. +-- astGetFunExprRules :: ASTChild -> ParentFunction -> [DeclaredIdentifier] -> [FunctionExpressionRules] -- Make FunctionExpressionRules from an AST. An ASTChild can't immediately represent a function -- expression. Recursively process all child ASTs and expressions. astGetFunExprRules :: ASTChild -> ParentFunction -> [DeclaredIdentifier] -> [FunctionExpressionRules] -astGetFunExprRules (LabBlock astList, n, sourceFragment) parent dIDs = (mapASTGetFER astList parent dIDs) +-- FIXME: Uncomment this and fix it (second field is not a list any more) +-- astGetFunExprRules (LabBlock astList, n, sourceFragment) parent dIDs = (mapASTGetFER astList parent dIDs) astGetFunExprRules (LabFunctionBody astList, n, sourceFragment) parent dIDs = (mapASTGetFER astList parent dIDs) astGetFunExprRules (LabFunctionDeclaration fid args body, n, sourceFragment) parent dIDs = [] astGetFunExprRules (LabLabelled label body, n, sourceFragment) parent dIDs = astGetFunExprRules body parent dIDs @@ -506,30 +512,31 @@ astGetFunExprRules (LabFor varEx test count body, n, sourceFragment) parent dIDs ++ (getMaybeFunExprRules count parent dIDs) astGetFunExprRules (LabForIn varList obj body, n, sourceFragment) parent dIDs = (astGetFunExprRules body parent dIDs) - ++ (exprGetFunExprRules obj parent dIDs) + ++ (astGetFunExprRules obj parent dIDs) astGetFunExprRules (LabForVarIn varEx obj body, n, sourceFragment) parent dIDs = (astGetFunExprRules body parent dIDs) - ++ (exprGetFunExprRules obj parent dIDs) - ++ (exprGetFunExprRules varEx parent dIDs) + ++ (astGetFunExprRules obj parent dIDs) + ++ (astGetFunExprRules varEx parent dIDs) astGetFunExprRules (LabWhile test body, n, sourceFragment) parent dIDs = (astGetFunExprRules body parent dIDs) - ++ (exprGetFunExprRules test parent dIDs) + ++ (astGetFunExprRules test parent dIDs) astGetFunExprRules (LabDoWhile body test, n, sourceFragment) parent dIDs = (astGetFunExprRules body parent dIDs) - ++ (exprGetFunExprRules test parent dIDs) + ++ (astGetFunExprRules test parent dIDs) astGetFunExprRules (LabIf test body, n, sourceFragment) parent dIDs = (astGetFunExprRules body parent dIDs) - ++ (exprGetFunExprRules test parent dIDs) + ++ (astGetFunExprRules test parent dIDs) astGetFunExprRules (LabIfElse test bodyT bodyF, n, sourceFragment) parent dIDs = (astGetFunExprRules bodyT parent dIDs) ++ (astGetFunExprRules bodyF parent dIDs) - ++ (exprGetFunExprRules test parent dIDs) + ++ (astGetFunExprRules test parent dIDs) astGetFunExprRules (LabSwitch ident cases, n, sourceFragment) parent dIDs = (astGetFunExprRules cases parent dIDs) - ++ (exprGetFunExprRules ident parent dIDs) -astGetFunExprRules (LabCase ex body, n, sourceFragment) parent dIDs = - (astGetFunExprRules body parent dIDs) - ++ (exprGetFunExprRules ex parent dIDs) + ++ (astGetFunExprRules ident parent dIDs) +-- FIXME: Uncomment this and fix it (body is a list now) +-- astGetFunExprRules (LabCase ex body, n, sourceFragment) parent dIDs = +-- (astGetFunExprRules body parent dIDs) +-- ++ (astGetFunExprRules ex parent dIDs) astGetFunExprRules (LabDefault body, n, sourceFragment) parent dIDs = astGetFunExprRules body parent dIDs astGetFunExprRules (LabTry body catches, n, sourceFragment) parent dIDs = (astGetFunExprRules body parent dIDs) @@ -538,65 +545,50 @@ astGetFunExprRules (LabCatch var mTest body, n, sourceFragment) parent dIDs = (astGetFunExprRules body parent dIDs) ++ (getMaybeFunExprRules mTest parent dIDs) astGetFunExprRules (LabFinally body, n, sourceFragment) parent dIDs = astGetFunExprRules body parent dIDs -astGetFunExprRules (LabReturn ex, n, sourceFragment) parent dIDs = exprGetFunExprRules ex parent dIDs -astGetFunExprRules (LabStatement ex, n, sourceFragment) parent dIDs = exprGetFunExprRules ex parent dIDs - - --- Does this make sense with the rules code that handles members of objects and arrays? --- --- TODO: Search object and array literals for function expressions. -valueGetFunExprRules :: ValueChild -> ParentFunction -> [DeclaredIdentifier] -> [FunctionExpressionRules] -valueGetFunExprRules (LabObject ex, n) parent dIDs = mapExpGetFER ex parent dIDs -valueGetFunExprRules (LabArray els, n) parent dIDs = mapExpGetFER els parent dIDs -valueGetFunExprRules _ _ _ = [] - - --- Make FunctionExpressionRules from an Expression. All of these, with the exception of --- LabFunctionExpression, either return nothing (when they don't contain any fields that could --- contain a function expression), or recursively process any expression or value fields. -exprGetFunExprRules :: ExprChild -> ParentFunction -> [DeclaredIdentifier] -> [FunctionExpressionRules] -exprGetFunExprRules (LabList expList, n, sourceFragment) parent dIDs = mapExpGetFER expList parent dIDs -exprGetFunExprRules (LabBinary op ex1 ex2, n, sourceFragment) parent dIDs = - (exprGetFunExprRules ex1 parent dIDs) - ++ (exprGetFunExprRules ex2 parent dIDs) -exprGetFunExprRules (LabUnaryPost op ex, n, sourceFragment) parent dIDs = exprGetFunExprRules ex parent dIDs -exprGetFunExprRules (LabUnaryPre op ex, n, sourceFragment) parent dIDs = exprGetFunExprRules ex parent dIDs -exprGetFunExprRules (LabTernary ex1 ex2 ex3, n, sourceFragment) parent dIDs = - (exprGetFunExprRules ex1 parent dIDs) - ++ (exprGetFunExprRules ex2 parent dIDs) - ++ (exprGetFunExprRules ex3 parent dIDs) -exprGetFunExprRules (LabAssignment op ex1 ex2, n, sourceFragment) parent dIDs = - (exprGetFunExprRules ex1 parent dIDs) - ++ (exprGetFunExprRules ex2 parent dIDs) -exprGetFunExprRules (LabIdentifier var, n, sourceFragment) parent dIDs = [] -exprGetFunExprRules (LabReference ex1 ex2, n, sourceFragment) parent dIDs = - (exprGetFunExprRules ex1 parent dIDs) - ++ (exprGetFunExprRules ex2 parent dIDs) -exprGetFunExprRules (LabIndex ex1 ex2, n, sourceFragment) parent dIDs = - (exprGetFunExprRules ex1 parent dIDs) - ++ (exprGetFunExprRules ex2 parent dIDs) +astGetFunExprRules (LabReturn ex, n, sourceFragment) parent dIDs = astGetFunExprRules ex parent dIDs +astGetFunExprRules (LabStatement ex, n, sourceFragment) parent dIDs = astGetFunExprRules ex parent dIDs +astGetFunExprRules (LabList expList, n, sourceFragment) parent dIDs = mapExpGetFER expList parent dIDs +astGetFunExprRules (LabBinary op ex1 ex2, n, sourceFragment) parent dIDs = + (astGetFunExprRules ex1 parent dIDs) + ++ (astGetFunExprRules ex2 parent dIDs) +astGetFunExprRules (LabUnaryPost op ex, n, sourceFragment) parent dIDs = astGetFunExprRules ex parent dIDs +astGetFunExprRules (LabUnaryPre op ex, n, sourceFragment) parent dIDs = astGetFunExprRules ex parent dIDs +astGetFunExprRules (LabTernary ex1 ex2 ex3, n, sourceFragment) parent dIDs = + (astGetFunExprRules ex1 parent dIDs) + ++ (astGetFunExprRules ex2 parent dIDs) + ++ (astGetFunExprRules ex3 parent dIDs) +astGetFunExprRules (LabAssignment op ex1 ex2, n, sourceFragment) parent dIDs = + (astGetFunExprRules ex1 parent dIDs) + ++ (astGetFunExprRules ex2 parent dIDs) +astGetFunExprRules (LabIdentifier var, n, sourceFragment) parent dIDs = [] +astGetFunExprRules (LabReference ex1 ex2, n, sourceFragment) parent dIDs = + (astGetFunExprRules ex1 parent dIDs) + ++ (astGetFunExprRules ex2 parent dIDs) +astGetFunExprRules (LabIndex ex1 ex2, n, sourceFragment) parent dIDs = + (astGetFunExprRules ex1 parent dIDs) + ++ (astGetFunExprRules ex2 parent dIDs) -- TODO: Needs to deal with objects and arrays, whose members can be function expressions. -- -- TODO: Is this already done in the code that handles values? -- -- FIXME: What is going on here vv --- exprGetFunExprRules (LabValue (LabOjbect ex, r), n) parent dIDs = [] --- exprGetFunExprRules (LabValue (LabArray ex, r), n) parent dIDs = [] -exprGetFunExprRules (LabValue val, n, sourceFragment) parent dIDs = valueGetFunExprRules val parent dIDs -exprGetFunExprRules (LabPropNameValue var ex, n, sourceFragment) parent dIDs = exprGetFunExprRules ex parent dIDs -exprGetFunExprRules (LabCall ex1 ex2, n, sourceFragment) parent dIDs = - (exprGetFunExprRules ex1 parent dIDs) - ++ (exprGetFunExprRules ex2 parent dIDs) -exprGetFunExprRules (LabArguments args, n, sourceFragment) parent dIDs = mapExpGetFER args parent dIDs -exprGetFunExprRules (LabParenExpression ex, n, sourceFragment) parent dIDs = exprGetFunExprRules ex parent dIDs -exprGetFunExprRules (LabBreak var, n, sourceFragment) parent dIDs = [] -exprGetFunExprRules (LabContinue var, n, sourceFragment) parent dIDs = [] -exprGetFunExprRules (LabThrow ex, n, sourceFragment) parent dIDs = exprGetFunExprRules ex parent dIDs -exprGetFunExprRules (LabCallExpression ex1 op ex2, n, sourceFragment) parent dIDs = - (exprGetFunExprRules ex1 parent dIDs) - ++ (exprGetFunExprRules ex2 parent dIDs) +-- astGetFunExprRules (LabValue (LabOjbect ex, r), n) parent dIDs = [] +-- astGetFunExprRules (LabValue (LabArray ex, r), n) parent dIDs = [] +astGetFunExprRules (LabValue val, n, sourceFragment) parent dIDs = valueGetFunExprRules val parent dIDs +astGetFunExprRules (LabPropNameValue var ex, n, sourceFragment) parent dIDs = astGetFunExprRules ex parent dIDs +astGetFunExprRules (LabCall ex1 ex2, n, sourceFragment) parent dIDs = + (astGetFunExprRules ex1 parent dIDs) + ++ (astGetFunExprRules ex2 parent dIDs) +astGetFunExprRules (LabArguments args, n, sourceFragment) parent dIDs = mapExpGetFER args parent dIDs +astGetFunExprRules (LabParenExpression ex, n, sourceFragment) parent dIDs = astGetFunExprRules ex parent dIDs +astGetFunExprRules (LabBreak var, n, sourceFragment) parent dIDs = [] +astGetFunExprRules (LabContinue var, n, sourceFragment) parent dIDs = [] +astGetFunExprRules (LabThrow ex, n, sourceFragment) parent dIDs = astGetFunExprRules ex parent dIDs +astGetFunExprRules (LabCallExpression ex1 op ex2, n, sourceFragment) parent dIDs = + (astGetFunExprRules ex1 parent dIDs) + ++ (astGetFunExprRules ex2 parent dIDs) -- For a LabFunctionExpression we add a new FunctionExpressionRules. -exprGetFunExprRules (LabFunctionExpression mv vls body, n, sourceFragment) parent dIDs = +astGetFunExprRules (LabFunctionExpression mv vls body, n, sourceFragment) parent dIDs = -- Make a new FunctionExpressionRules. [FunctionExpressionRules -- Include the name of the function expression, if it has one. @@ -627,81 +619,40 @@ exprGetFunExprRules (LabFunctionExpression mv vls body, n, sourceFragment) paren getMaybeID (Just fid) = Just (FunctionID fid) -- This function expression's parent AST. newParent = ParentFunExpr thisExpr -exprGetFunExprRules (LabVarDeclaration var mex, n, sourceFragment) parent dIDs = +astGetFunExprRules (LabVarDeclaration var mex, n, sourceFragment) parent dIDs = getMaybeFunExprRules mex parent dIDs -exprGetFunExprRules (LabNew ex, n, sourceFragment) parent dIDs = exprGetFunExprRules ex parent dIDs +astGetFunExprRules (LabNew ex, n, sourceFragment) parent dIDs = astGetFunExprRules ex parent dIDs --- Make FunctionExpressionRules from Maybe ExprChild. -getMaybeFunExprRules :: (Maybe ExprChild) -> ParentFunction -> [DeclaredIdentifier] -> [FunctionExpressionRules] -getMaybeFunExprRules Nothing parent dIDs = [] -getMaybeFunExprRules (Just ex) parent dIDs = exprGetFunExprRules ex parent dIDs +-- Does this make sense with the rules code that handles members of objects and arrays? +-- +-- TODO: Search object and array literals for function expressions. +valueGetFunExprRules :: ValueChild -> ParentFunction -> [DeclaredIdentifier] -> [FunctionExpressionRules] +valueGetFunExprRules (LabObject ex, n) parent dIDs = mapExpGetFER ex parent dIDs +valueGetFunExprRules (LabArray els, n) parent dIDs = mapExpGetFER els parent dIDs +valueGetFunExprRules _ _ _ = [] --- Find all identifiers declared in an Expression. All of these, with the exception of --- LabVarDeclaration, return nothing or recursively process any expression fields recursively. --- --- NOTE: Argument lists declare variables (see testargscope.js). DONE - see funDecGetVarDecs. --- --- TODO: Possibly need to do the same for ForIn. -exprGetVarDecs :: ExprChild -> [DeclaredIdentifier] -exprGetVarDecs (LabList ex, n, sourceFragment) = concat $ map exprGetVarDecs ex -exprGetVarDecs (LabBinary op ex1 ex2, n, sourceFragment) = - (exprGetVarDecs ex1) - ++ (exprGetVarDecs ex2) -exprGetVarDecs (LabUnaryPost op ex, n, sourceFragment) = exprGetVarDecs ex -exprGetVarDecs (LabUnaryPre op ex, n, sourceFragment) = exprGetVarDecs ex -exprGetVarDecs (LabTernary ex1 ex2 ex3, n, sourceFragment) = - (exprGetVarDecs ex1) - ++ (exprGetVarDecs ex2) - ++ (exprGetVarDecs ex3) -exprGetVarDecs (LabAssignment op ex1 ex2, n, sourceFragment) = - (exprGetVarDecs ex1) - ++ (exprGetVarDecs ex2) -exprGetVarDecs (LabIdentifier var, n, sourceFragment) = [] -exprGetVarDecs (LabReference ex1 ex2, n, sourceFragment) = - (exprGetVarDecs ex1) - ++ (exprGetVarDecs ex2) -exprGetVarDecs (LabIndex ex1 ex2, n, sourceFragment) = - (exprGetVarDecs ex1) - ++ (exprGetVarDecs ex2) -exprGetVarDecs (LabValue val, n, sourceFragment) = [] -exprGetVarDecs (LabPropNameValue var ex, n, sourceFragment) = exprGetVarDecs ex -exprGetVarDecs (LabCall ex1 ex2, n, sourceFragment) = - (exprGetVarDecs ex1) - ++ (exprGetVarDecs ex2) -exprGetVarDecs (LabArguments ex, n, sourceFragment) = concat $ map exprGetVarDecs ex -exprGetVarDecs (LabParenExpression ex, n, sourceFragment) = exprGetVarDecs ex -exprGetVarDecs (LabBreak mv, n, sourceFragment) = [] -exprGetVarDecs (LabContinue mv, n, sourceFragment) = [] -exprGetVarDecs (LabThrow ex, n, sourceFragment) = exprGetVarDecs ex -exprGetVarDecs (LabCallExpression ex1 op ex2, n, sourceFragment) = - (exprGetVarDecs ex1) - ++ (exprGetVarDecs ex2) --- A function expression doesn't declare anything that is relevant at this scope. -exprGetVarDecs (LabFunctionExpression mv var body, n, sourceFragment) = [] --- Return the unique identifier for the variable being declared and recursively process the --- expression field. -exprGetVarDecs (LabVarDeclaration (var, x) mex, n, sourceFragment) = - [varDecMakeLabel thisVarDec] - ++ (maybeExprGetVarDecs mex) - where - -- Name the (Haskell Land) argument. - thisVarDec = (LabVarDeclaration (var, x) mex, n, sourceFragment) -exprGetVarDecs (LabNew ex, n, sourceFragment) = exprGetVarDecs ex +-- Make FunctionExpressionRules from Maybe ASTChild. +getMaybeFunExprRules :: (Maybe ASTChild) -> ParentFunction -> [DeclaredIdentifier] -> [FunctionExpressionRules] +getMaybeFunExprRules maybeASTChild parent dIDs = + maybeToProperList (\astChild -> astGetFunExprRules astChild parent dIDs) maybeASTChild --- Find variable declarations in a Maybe ExprChild. -maybeExprGetVarDecs :: (Maybe ExprChild) -> [DeclaredIdentifier] -maybeExprGetVarDecs Nothing = [] -maybeExprGetVarDecs (Just ex) = exprGetVarDecs ex +-- Find variable declarations in a Maybe ASTChild. +maybeExprGetVarDecs :: (Maybe ASTChild) -> [DeclaredIdentifier] +maybeExprGetVarDecs maybeASTChild = maybeToProperList astGetVarDecs maybeASTChild --- Find all identifiers declared in a JSAST. All of these, with the exception of --- LabFunctionDeclaration and LabLabelled, return nothing or recursively process any AST or --- expression fields. +-- Find all identifiers declared in a AST. All of these, with the exception of +-- LabFunctionDeclaration, LabLabelled and LabVarDeclaration, return nothing or recursively process +-- any AST or expression fields. +-- +-- NOTE: Argument lists declare variables (see testargscope.js). DONE - see funDecGetVarDecs. +-- TODO: Possibly need to do the same for ForIn. astGetVarDecs :: ASTChild -> [DeclaredIdentifier] -astGetVarDecs (LabBlock body, n, sourceFragment) = concat $ map astGetVarDecs body +-- FIXME: Uncomment this and fix it (second field is not a list any more) +-- astGetVarDecs (LabBlock body, n, sourceFragment) = concat $ map astGetVarDecs body astGetVarDecs (LabFunctionBody body, n, sourceFragment) = concat $ map astGetVarDecs body -- Add the name of the function. Definitions of functions don't declare any variables that are -- relevant at this scope. @@ -716,7 +667,7 @@ astGetVarDecs (LabLabelled (var, x) body, n, sourceFragment) = where thisLabelled = (LabLabelled (var, x) body, n, sourceFragment) astGetVarDecs (LabForVar ex mex1 mex2 body, n, sourceFragment) = - (concat $ map exprGetVarDecs ex) + (concat $ map astGetVarDecs ex) ++ (maybeExprGetVarDecs mex1) ++ (maybeExprGetVarDecs mex2) ++ (astGetVarDecs body) @@ -726,30 +677,30 @@ astGetVarDecs (LabFor mex1 mex2 mex3 body, n, sourceFragment) = ++ (maybeExprGetVarDecs mex3) ++ (astGetVarDecs body) astGetVarDecs (LabForIn vars ex body, n, sourceFragment) = - (exprGetVarDecs ex) + (astGetVarDecs ex) ++ (astGetVarDecs body) astGetVarDecs (LabForVarIn ex1 ex2 body, n, sourceFragment) = - (exprGetVarDecs ex1) - ++ (exprGetVarDecs ex2) + (astGetVarDecs ex1) + ++ (astGetVarDecs ex2) ++ (astGetVarDecs body) astGetVarDecs (LabWhile ex body, n, sourceFragment) = - (exprGetVarDecs ex) + (astGetVarDecs ex) ++ (astGetVarDecs body) astGetVarDecs (LabDoWhile body ex, n, sourceFragment) = (astGetVarDecs body) - ++ (exprGetVarDecs ex) + ++ (astGetVarDecs ex) astGetVarDecs (LabIf ex body, n, sourceFragment) = - (exprGetVarDecs ex) + (astGetVarDecs ex) ++ (astGetVarDecs body) astGetVarDecs (LabIfElse ex bodyT bodyF, n, sourceFragment) = - (exprGetVarDecs ex) + (astGetVarDecs ex) ++ (astGetVarDecs bodyT) ++ (astGetVarDecs bodyF) astGetVarDecs (LabSwitch ex cases, n, sourceFragment) = - (exprGetVarDecs ex) + (astGetVarDecs ex) ++ (astGetVarDecs cases) astGetVarDecs (LabCase ex body, n, sourceFragment) = - (exprGetVarDecs ex) + (astGetVarDecs ex) ++ (astGetVarDecs body) astGetVarDecs (LabDefault body, n, sourceFragment) = astGetVarDecs body astGetVarDecs (LabTry body catchClause, n, sourceFragment) = @@ -759,5 +710,51 @@ astGetVarDecs (LabCatch var mex body, n, sourceFragment) = (maybeExprGetVarDecs mex) ++ (astGetVarDecs body) astGetVarDecs (LabFinally body, n, sourceFragment) = astGetVarDecs body -astGetVarDecs (LabReturn ex, n, sourceFragment) = exprGetVarDecs ex -astGetVarDecs (LabStatement ex, n, sourceFragment) = exprGetVarDecs ex +astGetVarDecs (LabReturn ex, n, sourceFragment) = astGetVarDecs ex +astGetVarDecs (LabStatement ex, n, sourceFragment) = astGetVarDecs ex +astGetVarDecs (LabList ex, n, sourceFragment) = concat $ map astGetVarDecs ex +astGetVarDecs (LabStatementList ex, n, sourceFragment) = concat $ map astGetVarDecs ex +astGetVarDecs (LabExpression ex, n, sourceFragment) = concat $ map astGetVarDecs ex +astGetVarDecs (LabBinary op ex1 ex2, n, sourceFragment) = + (astGetVarDecs ex1) + ++ (astGetVarDecs ex2) +astGetVarDecs (LabUnaryPost op ex, n, sourceFragment) = astGetVarDecs ex +astGetVarDecs (LabUnaryPre op ex, n, sourceFragment) = astGetVarDecs ex +astGetVarDecs (LabTernary ex1 ex2 ex3, n, sourceFragment) = + (astGetVarDecs ex1) + ++ (astGetVarDecs ex2) + ++ (astGetVarDecs ex3) +astGetVarDecs (LabAssignment op ex1 ex2, n, sourceFragment) = + (astGetVarDecs ex1) + ++ (astGetVarDecs ex2) +astGetVarDecs (LabIdentifier var, n, sourceFragment) = [] +astGetVarDecs (LabReference ex1 ex2, n, sourceFragment) = + (astGetVarDecs ex1) + ++ (astGetVarDecs ex2) +astGetVarDecs (LabIndex ex1 ex2, n, sourceFragment) = + (astGetVarDecs ex1) + ++ (astGetVarDecs ex2) +astGetVarDecs (LabValue val, n, sourceFragment) = [] +astGetVarDecs (LabPropNameValue var ex, n, sourceFragment) = astGetVarDecs ex +astGetVarDecs (LabCall ex1 ex2, n, sourceFragment) = + (astGetVarDecs ex1) + ++ (astGetVarDecs ex2) +astGetVarDecs (LabArguments ex, n, sourceFragment) = concat $ map astGetVarDecs ex +astGetVarDecs (LabParenExpression ex, n, sourceFragment) = astGetVarDecs ex +astGetVarDecs (LabBreak mv, n, sourceFragment) = [] +astGetVarDecs (LabContinue mv, n, sourceFragment) = [] +astGetVarDecs (LabThrow ex, n, sourceFragment) = astGetVarDecs ex +astGetVarDecs (LabCallExpression ex1 op ex2, n, sourceFragment) = + (astGetVarDecs ex1) + ++ (astGetVarDecs ex2) +-- A function expression doesn't declare anything that is relevant at this scope. +astGetVarDecs (LabFunctionExpression mv var body, n, sourceFragment) = [] +-- Return the unique identifier for the variable being declared and recursively process the +-- expression field. +astGetVarDecs (LabVarDeclaration (var, x) mex, n, sourceFragment) = + [varDecMakeLabel thisVarDec] + ++ (maybeExprGetVarDecs mex) + where + -- Name the (Haskell Land) argument. + thisVarDec = (LabVarDeclaration (var, x) mex, n, sourceFragment) +astGetVarDecs (LabNew ex, n, sourceFragment) = astGetVarDecs ex diff --git a/LabelAST.hs b/LabelAST.hs new file mode 100644 index 0000000..9ef05b7 --- /dev/null +++ b/LabelAST.hs @@ -0,0 +1,507 @@ + +-- Copyright 2014 Google Inc. All rights reserved. + +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at + +-- http://www.apache.org/licenses/LICENSE-2.0 + +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + + +-- This module takes a AST and gives each vertex a unique integer label. The label counter is simply +-- threaded through the tree. Traversal is depth first. It's all fairly straight-forward. +-- +-- Top level function is +-- (label (astListWSMakeSourceFragments (getASTWithSource (parseTree program file) file) span)) + + +module LabelAST +( ASTChild +, ASTLabel +, IndexChild +, LabelledAST(..) +, LabelledPropertyName(..) +, LabelledValue(..) +, OpChild +, PropertyNameChild +, ValueChild +, VarChild +, childGetLabel +, childGetSource +, childWSGetLabel +, label +) where + + +import ParseJS +import ResolveSourceFragments +import System.Environment + + +-- A type for the labels. +type ASTLabel = Int + + +-- A Variable and a label. +type VarChild = (Variable, ASTLabel) + + +-- An Operator and a label. +type OpChild = (Operator, ASTLabel) + + +-- An Index and a label. +type IndexChild = (Index, ASTLabel) + + +-- A VarChild or IndexChild wrapped in a LabelledPropertyName, and a label. Added long after the +-- original code was written. +-- +-- TODO: Test. +type PropertyNameChild = (LabelledPropertyName, ASTLabel) + + +-- A value wrapped as a LabelledValue, and a label. Most LabelledValues contain only the value and +-- no label. +type ValueChild = (LabelledValue, ASTLabel) + + +-- A LabelledExpression (which is a labelled subtree) and a label. +-- type ASTChild = (LabelledExpression, ASTLabel, SourceFragment) + + +-- A LabelledAST (which is a labelled subree) an a label. +-- TODO: Rename to LabelledAST && rename LabelledAST to LabAST (or LAST). +type ASTChild = (LabelledAST, ASTLabel, SourceFragment) + + +-- A wrapper for a VarChild or IndexChild that identifies it as a name for a an object property. +data LabelledPropertyName = + LabIndexProperty IndexChild + | LabVariableProperty VarChild deriving (Show) + + +-- A labelled representation of a literal. LabelledValues representing primitives contain only the +-- value and no label. LabelledValues representing objects and arrays are labelled recursively. +-- LabUndefined and LabNull have no value or label. +data LabelledValue = + LabArray [ASTChild] + | LabBool Bool + | LabDQString String + | LabFloat Double + | LabInt Int + | LabNull + | LabObject [ASTChild] + | LabString String + | LabUndefined deriving (Show) + + +-- A recursively labelled subrtree, rooted at a LabelledAST. +data LabelledAST = + LabBlock ASTChild + | LabCase ASTChild ASTChild + | LabCatch VarChild (Maybe ASTChild) ASTChild + | LabDefault ASTChild + | LabDoWhile ASTChild ASTChild + | LabFinally ASTChild + | LabFor (Maybe ASTChild) (Maybe ASTChild) (Maybe ASTChild) ASTChild + | LabForIn [VarChild] ASTChild ASTChild + | LabForVar [ASTChild] (Maybe ASTChild) (Maybe ASTChild) ASTChild + | LabForVarIn ASTChild ASTChild ASTChild + | LabFunctionBody [ASTChild] + | LabFunctionDeclaration VarChild [VarChild] ASTChild + | LabIf ASTChild ASTChild + | LabIfElse ASTChild ASTChild ASTChild + | LabLabelled VarChild ASTChild + | LabReturn ASTChild + | LabStatement ASTChild + | LabSwitch ASTChild ASTChild + | LabTry ASTChild ASTChild + | LabWhile ASTChild ASTChild + + | LabArguments [ASTChild] + | LabAssignment OpChild ASTChild ASTChild + | LabBinary OpChild ASTChild ASTChild + | LabBreak (Maybe VarChild) + | LabCall ASTChild ASTChild + | LabCallExpression ASTChild OpChild ASTChild + | LabContinue (Maybe VarChild) + | LabExpression [ASTChild] + | LabFunctionExpression (Maybe VarChild) [VarChild] ASTChild + | LabIdentifier VarChild + | LabIndex ASTChild ASTChild + | LabList [ASTChild] + | LabNew ASTChild + | LabParenExpression ASTChild + | LabPropNameValue PropertyNameChild ASTChild + | LabReference ASTChild ASTChild + | LabStatementList [ASTChild] + | LabTernary ASTChild ASTChild ASTChild + | LabThrow ASTChild + | LabUnaryPost OpChild ASTChild + | LabUnaryPre OpChild ASTChild + | LabValue ValueChild + | LabVarDeclaration VarChild (Maybe ASTChild) deriving (Show) + + +-- Takes an unlabelled AST and labels the whole thing. +label :: ASTWithSourceFragment -> ASTChild +-- label list = labelASTList list 0 +label ast = labelAST ast 0 + + +-- Extract the ASTLabel from a VarChild, IndexChild etc. +childGetLabel :: (a, ASTLabel) -> ASTLabel +childGetLabel (child, lab) = lab + +-- Extract the ASTLabel from a ASTChild, ASTChild etc. +childWSGetLabel :: (a, ASTLabel, b) -> ASTLabel +childWSGetLabel (_, lab, _) = lab + +childGetSource :: (a, b, SourceFragment) -> SourceFragment +childGetSource (_, _, sf) = sf + +-- Extract the labels from a list of VarChild, IndexChild etc. +listGetLabels :: [(a, ASTLabel)] -> [ASTLabel] +listGetLabels [] = [] +listGetLabels (c:cs) = ((childGetLabel c):(listGetLabels cs)) + +-- Extract the labels from a list of ASTChild, ASTChild etc. +listWSGetLabels :: [(a, ASTLabel, b)] -> [ASTLabel] +listWSGetLabels [] = [] +listWSGetLabels (c:cs) = ((childWSGetLabel c):(listWSGetLabels cs)) + + +-- Find the greater of the label on a Maybe *Child and a given value. +maxMaybeLabel :: (Maybe (a, ASTLabel)) -> ASTLabel -> ASTLabel +-- If the Maybe *Child is nothing then the given value is the greatest. +maxMaybeLabel maybeASTChild label = + maybe label (\astChild -> max (childGetLabel astChild) label) maybeASTChild + + +-- Find the greater of the label on a Maybe *Child and a given value. +maxMaybeWSLabel :: (Maybe (a, ASTLabel, b)) -> ASTLabel -> ASTLabel +-- If the Maybe *Child is nothing then the given value is the greatest. +maxMaybeWSLabel maybeASTChild label = + maybe label (\astChild -> max (childWSGetLabel astChild) label) maybeASTChild + +-- Label a list of Varialbes. +labelVarList :: [Variable] -> ASTLabel -> [VarChild] +labelVarList [] _ = [] +labelVarList (v:vx) n = (v, n + 1):(labelVarList vx (n + 1)) + + +-- Label a list of Expressions. +labelExpressionList :: [ASTWithSourceFragment] -> ASTLabel -> [ASTChild] +labelExpressionList [] _ = [] +labelExpressionList (e:ex) n = + let (le, m, sf) = labelAST e n in ((le, m, sf):(labelExpressionList ex m)) + + +-- Label a list of ASTs. +labelASTList :: [ASTWithSourceFragment] -> ASTLabel -> [ASTChild] +labelASTList [] _ = [] +labelASTList (a:ax) n = + let (la, m, sf) = labelAST a n in ((la, m, sf):(labelASTList ax m)) + + +-- Label a Varialble. +labelVariable :: Variable -> ASTLabel -> VarChild +labelVariable var n = (var, n + 1) + + +-- -- Label a Maybe Variable if it is not Nothing. +-- labelMaybeVar :: (Maybe Variable) -> ASTLabel -> (Maybe VarChild) +-- labelMaybeVar maybeVar label = maybe Nothing (\var -> Just $ labelVariable var label) maybeVar + +-- Label a Maybe Variable if it is not Nothing. +labelMaybeVar :: (Maybe Variable) -> ASTLabel -> (Maybe VarChild) +labelMaybeVar maybeVar label = maybeVar >>= (\var -> Just $ labelVariable var label) + +-- Label an Operator. +labelOperator :: Operator -> ASTLabel -> OpChild +labelOperator op n = (op, n + 1) + + +-- Label an Index. +labelIndex :: Index -> ASTLabel -> IndexChild +labelIndex ix n = (ix, n + 1) + + +-- Label a PropertyName. +-- +-- TODO: Unit test? +labelPropertyName :: PropertyName -> ASTLabel -> PropertyNameChild +labelPropertyName (IndexProperty ix) n = + (LabIndexProperty field1, (childGetLabel field1) + 1) + where + field1 = labelIndex ix n +labelPropertyName (VariableProperty var) n = + (LabVariableProperty field1, (childGetLabel field1) + 1) + where + field1 = labelVariable var n + + +-- Label a Value. Recursively process any child fields. +labelValue :: ValueWithSourceFragment -> ASTLabel -> ValueChild +labelValue (WSInt i) n = (LabInt i, n + 1) +labelValue (WSFloat x) n = (LabFloat x, n + 1) +labelValue (WSString s) n = (LabString s, n + 1) +labelValue (WSBool b) n = (LabBool b, n + 1) +labelValue (WSDQString s) n = (LabDQString s, n + 1) +labelValue (WSObject props) n = + (LabObject field1, (maximum ((listWSGetLabels field1) ++ [n])) + 1) + where + field1 = labelExpressionList props n +labelValue (WSArray el) n = + (LabArray field1, (maximum ((listWSGetLabels field1) ++ [n])) + 1) + where + field1 = labelExpressionList el n +labelValue (WSUndefined) n = (LabUndefined, n + 1) +labelValue (WSNull) n = (LabNull, n + 1) + + +-- Label a Maybe Expression if it is not Nothing. +-- FIXME: Replace with monad operations. +labelMaybeAST :: (Maybe ASTWithSourceFragment) -> ASTLabel -> (Maybe ASTChild) +labelMaybeAST maybeAST label = maybeAST >>= (\ast -> Just $ labelAST ast label) + + +-- Label a AST. Recursively process any child fields. +labelAST :: ASTWithSourceFragment -> ASTLabel -> ASTChild +-- FIXME: WSBlock handler changed in a rush after child changed from a list to just one node. Double +-- check it. +labelAST (AWSF (WSBlock body) sourceFragment) n = + ((LabBlock field1), (childWSGetLabel field1) + 1, sourceFragment) + where + field1 = labelAST body n +labelAST (AWSF (WSFunctionBody astList) sourceFragment) n = + ((LabFunctionBody field1), (maximum ((listWSGetLabels field1) ++ [n])) + 1, sourceFragment) + where + field1 = labelASTList astList n +labelAST (AWSF (WSFunctionDeclaration var args body) sourceFragment) n = + ((LabFunctionDeclaration field1 field2 field3), (childWSGetLabel field3) + 1, sourceFragment) + where + field1 = labelVariable var n + field2 = labelVarList args (childGetLabel field1) + field3 = labelAST body $ maximum ((listGetLabels field2) ++ [childGetLabel field1]) +labelAST (AWSF (WSLabelled var body) sourceFragment) n = + ((LabLabelled field1 field2), (childWSGetLabel field2) + 1, sourceFragment) + where + field1 = labelVariable var n + field2 = labelAST body (childGetLabel field1) +labelAST (AWSF (WSForVar ex1 ex2 ex3 body) sourceFragment) n = + ((LabForVar field1 field2 field3 field4), (childWSGetLabel field4) + 1, sourceFragment) + where + field1 = labelExpressionList ex1 n + field2 = labelMaybeAST ex2 $ maximum ((listWSGetLabels field1) ++ [n]) + field3 = + labelMaybeAST ex3 $ maximum ((listWSGetLabels field1) ++ [maxMaybeWSLabel field2 n]) + field4 = + labelAST + body + $ maximum + ((listWSGetLabels field1) + ++ [maxMaybeWSLabel field2 n] + ++ [maxMaybeWSLabel field3 n]) +labelAST (AWSF (WSFor ex1 ex2 ex3 body) sourceFragment) n = + ((LabFor field1 field2 field3 field4), (childWSGetLabel field4) + 1, sourceFragment) + where + field1 = labelMaybeAST ex1 n + field2 = labelMaybeAST ex2 (maxMaybeWSLabel field1 n) + field3 = + labelMaybeAST ex3 $ max (maxMaybeWSLabel field1 n) (maxMaybeWSLabel field2 n) + field4 = + labelAST + body + $ maximum + ([maxMaybeWSLabel field1 n] + ++ [maxMaybeWSLabel field2 n] + ++ [maxMaybeWSLabel field3 n]) +labelAST (AWSF (WSForIn vars ex body) sourceFragment) n = + ((LabForIn field1 field2 field3), (childWSGetLabel field3) + 1, sourceFragment) + where + field1 = labelVarList vars n + field2 = labelAST ex $ maximum ((listGetLabels field1) ++ [n]) + field3 = labelAST body (childWSGetLabel field2) +labelAST (AWSF (WSForVarIn ex1 ex2 body) sourceFragment) n = + ((LabForVarIn field1 field2 field3), (childWSGetLabel field3) + 1, sourceFragment) + where + field1 = labelAST ex1 n + field2 = labelAST ex2 (childWSGetLabel field1) + field3 = labelAST body (childWSGetLabel field2) +labelAST (AWSF (WSWhile ex body) sourceFragment) n = + ((LabWhile field1 field2), (childWSGetLabel field2) + 1, sourceFragment) + where + field1 = labelAST ex n + field2 = labelAST body (childWSGetLabel field1) +labelAST (AWSF (WSDoWhile body ex) sourceFragment) n = + ((LabDoWhile field1 field2), (childWSGetLabel field2) + 1, sourceFragment) + where + field1 = labelAST body n + field2 = labelAST ex (childWSGetLabel field1) +labelAST (AWSF (WSIf ex body) sourceFragment) n = + ((LabIf field1 field2), (childWSGetLabel field2) + 1, sourceFragment) + where + field1 = labelAST ex n + field2 = labelAST body (childWSGetLabel field1) +labelAST (AWSF (WSIfElse ex bodyT bodyF) sourceFragment) n = + ((LabIfElse field1 field2 field3), (childWSGetLabel field3) + 1, sourceFragment) + where + field1 = labelAST ex n + field2 = labelAST bodyT (childWSGetLabel field1) + field3 = labelAST bodyF (childWSGetLabel field2) +-- FIXME: Uncomment this and fix it (second field is a list now) +-- labelAST (AWSF (WSSwitch ex cs) sourceFragment) n = +-- ((LabSwitch field1 field2), (childWSGetLabel field2) + 1, sourceFragment) +-- where +-- field1 = labelAST ex n +-- field2 = labelAST cs (childWSGetLabel field1) +labelAST (AWSF (WSCase ex body) sourceFragment) n = + ((LabCase field1 field2), (childWSGetLabel field2) + 1, sourceFragment) + where + field1 = labelAST ex n + field2 = labelAST body (childWSGetLabel field1) +labelAST (AWSF (WSDefault body) sourceFragment) n = + ((LabDefault field1), (childWSGetLabel field1) + 1, sourceFragment) + where + field1 = labelAST body n +-- FIXME: Uncomment this and fix it (second field is a list now) +-- labelAST (AWSF (WSTry body ctch) sourceFragment) n = +-- ((LabTry field1 field2), (childWSGetLabel field2) + 1, sourceFragment) +-- where +-- field1 = labelAST body n +-- field2 = labelAST ctch (childWSGetLabel field1) +labelAST (AWSF (WSCatch var ex body) sourceFragment) n = + ((LabCatch field1 field2 field3), (childWSGetLabel field3) + 1, sourceFragment) + where + field1 = labelVariable var n + field2 = labelMaybeAST ex (childGetLabel field1) + field3 = labelAST body (maxMaybeWSLabel field2 (childGetLabel field1)) +labelAST (AWSF (WSFinally body) sourceFragment) n = + ((LabFinally field1), (childWSGetLabel field1) + 1, sourceFragment) + where + field1 = labelAST body n +labelAST (AWSF (WSReturn ex) sourceFragment) n = + ((LabReturn field1), (childWSGetLabel field1) + 1, sourceFragment) + where + field1 = labelAST ex n +labelAST (AWSF (WSStatement ex) sourceFragment) n = + ((LabStatement field1), (childWSGetLabel field1) + 1, sourceFragment) + where + field1 = labelAST ex n +labelAST (AWSF (WSList ex) sourceFragment) n = + ((LabList (field1)), (maximum ((listWSGetLabels field1) ++ [n])) + 1, sourceFragment) + where + field1 = labelExpressionList ex n +labelAST (AWSF (WSExpression ex) sourceFragment) n = + ((LabExpression (field1)), (maximum ((listWSGetLabels field1) ++ [n])) + 1, sourceFragment) + where + field1 = labelExpressionList ex n +labelAST (AWSF (WSStatementList ex) sourceFragment) n = + ((LabStatementList (field1)), (maximum ((listWSGetLabels field1) ++ [n])) + 1, sourceFragment) + where + field1 = labelExpressionList ex n +labelAST (AWSF (WSBinary op ex1 ex2) sourceFragment) n = + ((LabBinary field1 field2 field3), (childWSGetLabel field3) + 1, sourceFragment) + where + field1 = labelOperator op n + field2 = labelAST ex1 (childGetLabel field1) + field3 = labelAST ex2 (childWSGetLabel field2) +labelAST (AWSF (WSUnaryPost op ex) sourceFragment) n = + ((LabUnaryPost field1 field2), (childWSGetLabel field2) + 1, sourceFragment) + where + field1 = labelOperator op n + field2 = labelAST ex (childGetLabel field1) +labelAST (AWSF (WSUnaryPre op ex) sourceFragment) n = + ((LabUnaryPre field1 field2), (childWSGetLabel field2) + 1, sourceFragment) + where + field1 = labelOperator op n + field2 = labelAST ex (childGetLabel field1) +labelAST (AWSF (WSTernary ex1 ex2 ex3) sourceFragment) n = + ((LabTernary field1 field2 field3), (childWSGetLabel field3) + 1, sourceFragment) + where + field1 = labelAST ex1 n + field2 = labelAST ex2 (childWSGetLabel field1) + field3 = labelAST ex3 (childWSGetLabel field2) +labelAST (AWSF (WSAssignment op ex1 ex2) sourceFragment) n = + ((LabAssignment field1 field2 field3), (childWSGetLabel field3) + 1, sourceFragment) + where + field1 = labelOperator op n + field2 = labelAST ex1 (childGetLabel field1) + field3 = labelAST ex2 (childWSGetLabel field2) +labelAST (AWSF (WSIdentifier ident) sourceFragment) n = + ((LabIdentifier field1), (childGetLabel field1) + 1, sourceFragment) + where + field1 = labelVariable ident n +labelAST (AWSF (WSReference ex1 ex2) sourceFragment) n = + ((LabReference field1 field2), (childWSGetLabel field2) + 1, sourceFragment) + where + field1 = labelAST ex1 n + field2 = labelAST ex2 (childWSGetLabel field1) +labelAST (AWSF (WSIndex ex1 ex2) sourceFragment) n = + ((LabIndex field1 field2), (childWSGetLabel field2) + 1, sourceFragment) + where + field1 = labelAST ex1 n + field2 = labelAST ex2 (childWSGetLabel field1) +labelAST (AWSF (WSValue val) sourceFragment) n = + ((LabValue field1), (childGetLabel field1) + 1, sourceFragment) + where + field1 = labelValue val n +labelAST (AWSF (WSPropNameValue name ex) sourceFragment) n = + ((LabPropNameValue field1 field2), (childWSGetLabel field2) + 1, sourceFragment) + where + field1 = labelPropertyName name n + field2 = labelAST ex (childGetLabel field1) +labelAST (AWSF (WSCall ex1 ex2) sourceFragment) n = + ((LabCall field1 field2), (childWSGetLabel field2) + 1, sourceFragment) + where + field1 = labelAST ex1 n + field2 = labelAST ex2 (childWSGetLabel field1) +labelAST (AWSF (WSArguments args) sourceFragment) n = + ((LabArguments (field1)), (maximum ((listWSGetLabels field1) ++ [n])) + 1, sourceFragment) + where + field1 = labelExpressionList args n +labelAST (AWSF (WSParenExpression ex) sourceFragment) n = + ((LabParenExpression field1), (childWSGetLabel field1) + 1, sourceFragment) + where + field1 = labelAST ex n +labelAST (AWSF (WSBreak vars) sourceFragment) n = + ((LabBreak field1), (maxMaybeLabel field1 n) + 1, sourceFragment) + where + field1 = labelMaybeVar vars n +labelAST (AWSF (WSContinue vars) sourceFragment) n = + ((LabContinue field1), (maxMaybeLabel field1 n) + 1, sourceFragment) + where + field1 = labelMaybeVar vars n +labelAST (AWSF (WSThrow ex) sourceFragment) n = + ((LabThrow field1), (childWSGetLabel field1) + 1, sourceFragment) + where + field1 = labelAST ex n +labelAST (AWSF (WSCallExpression ex1 op ex2) sourceFragment) n = + ((LabCallExpression field1 field2 field3), (childWSGetLabel field3) + 1, sourceFragment) + where + field1 = labelAST ex1 n + field2 = labelOperator op (childWSGetLabel field1) + field3 = labelAST ex2 (childGetLabel field2) +labelAST (AWSF (WSFunctionExpression var vars ast) sourceFragment) n = + ((LabFunctionExpression field1 field2 field3), (childWSGetLabel field3) + 1, sourceFragment) + where + field1 = labelMaybeVar var n + field2 = labelVarList vars (maxMaybeLabel field1 n) + field3 = labelAST ast (maximum ((listGetLabels field2) ++ [n])) +labelAST (AWSF (WSVarDeclaration var ex) sourceFragment) n = + ((LabVarDeclaration field1 field2), (maxMaybeWSLabel field2 (childGetLabel field1)) + 1, sourceFragment) + where + field1 = labelVariable var n + field2 = labelMaybeAST ex (childGetLabel field1) +labelAST (AWSF (WSNew ex) sourceFragment) n = + ((LabNew field1), (childWSGetLabel field1) + 1, sourceFragment) + where + field1 = labelAST ex n diff --git a/LabelJSAST.hs b/LabelJSAST.hs deleted file mode 100644 index 0b994b1..0000000 --- a/LabelJSAST.hs +++ /dev/null @@ -1,500 +0,0 @@ - --- Copyright 2014 Google Inc. All rights reserved. - --- Licensed under the Apache License, Version 2.0 (the "License"); --- you may not use this file except in compliance with the License. --- You may obtain a copy of the License at - --- http://www.apache.org/licenses/LICENSE-2.0 - --- Unless required by applicable law or agreed to in writing, software --- distributed under the License is distributed on an "AS IS" BASIS, --- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. --- See the License for the specific language governing permissions and --- limitations under the License. - - --- This module takes a JSAST and gives each vertex a unique integer label. The label counter is simply --- threaded through the tree. Traversal is depth first. It's all fairly straight-forward. --- --- Top level function is --- (label (jsastListWSMakeSourceFragments (getJSASTWithSource (parseTree program file) file) span)) - - -module LabelJSAST -( ASTChild -, ExprChild -, IndexChild -, JSASTLabel -, LabelledExpression(..) -, LabelledJSAST(..) -, LabelledPropertyName(..) -, LabelledValue(..) -, OpChild -, PropertyNameChild -, ValueChild -, VarChild -, childGetLabel -, childGetSource -, childWSGetLabel -, label -) where - - -import ParseJS -import ResolveSourceFragments -import System.Environment - - --- A type for the labels. -type JSASTLabel = Int - - --- A Variable and a label. -type VarChild = (Variable, JSASTLabel) - - --- An Operator and a label. -type OpChild = (Operator, JSASTLabel) - - --- An Index and a label. -type IndexChild = (Index, JSASTLabel) - - --- A VarChild or IndexChild wrapped in a LabelledPropertyName, and a label. Added long after the --- original code was written. --- --- TODO: Test. -type PropertyNameChild = (LabelledPropertyName, JSASTLabel) - - --- A value wrapped as a LabelledValue, and a label. Most LabelledValues contain only the value and --- no label. -type ValueChild = (LabelledValue, JSASTLabel) - - --- A LabelledExpression (which is a labelled subtree) and a label. -type ExprChild = (LabelledExpression, JSASTLabel, SourceFragment) - - --- A LabelledJSAST (which is a labelled subree) an a label. -type ASTChild = (LabelledJSAST, JSASTLabel, SourceFragment) - - --- A wrapper for a VarChild or IndexChild that identifies it as a name for a an object property. -data LabelledPropertyName = - LabIndexProperty IndexChild - | LabVariableProperty VarChild deriving (Show) - - --- A labelled representation of a literal. LabelledValues representing primitives contain only the --- value and no label. LabelledValues representing objects and arrays are labelled recursively. --- LabUndefined and LabNull have no value or label. -data LabelledValue = - LabArray [ExprChild] - | LabBool Bool - | LabDQString String - | LabFloat Double - | LabInt Int - | LabNull - | LabObject [ExprChild] - | LabString String - | LabUndefined deriving (Show) - - --- FIXME: Some of these contain Maybe *Child values. "Nothing" has no label. Is that a problem? --- --- A recursively labelled subtree, rooted at a LabelledExpression. -data LabelledExpression = - LabArguments [ExprChild] - | LabAssignment OpChild ExprChild ExprChild - | LabBinary OpChild ExprChild ExprChild - | LabBreak (Maybe VarChild) - | LabCall ExprChild ExprChild - | LabCallExpression ExprChild OpChild ExprChild - | LabContinue (Maybe VarChild) - | LabFunctionExpression (Maybe VarChild) [VarChild] ASTChild - | LabIdentifier VarChild - | LabIndex ExprChild ExprChild - | LabList [ExprChild] - | LabNew ExprChild - | LabParenExpression ExprChild - | LabPropNameValue PropertyNameChild ExprChild - | LabReference ExprChild ExprChild - | LabTernary ExprChild ExprChild ExprChild - | LabThrow ExprChild - | LabUnaryPost OpChild ExprChild - | LabUnaryPre OpChild ExprChild - | LabValue ValueChild - | LabVarDeclaration VarChild (Maybe ExprChild) deriving (Show) - - --- A recursively labelled subrtree, rooted at a LabelledJSAST. -data LabelledJSAST = - LabBlock [ASTChild] - | LabCase ExprChild ASTChild - | LabCatch VarChild (Maybe ExprChild) ASTChild - | LabDefault ASTChild - | LabDoWhile ASTChild ExprChild - | LabFinally ASTChild - | LabFor (Maybe ExprChild) (Maybe ExprChild) (Maybe ExprChild) ASTChild - | LabForIn [VarChild] ExprChild ASTChild - | LabForVar [ExprChild] (Maybe ExprChild) (Maybe ExprChild) ASTChild - | LabForVarIn ExprChild ExprChild ASTChild - | LabFunctionBody [ASTChild] - | LabFunctionDeclaration VarChild [VarChild] ASTChild - | LabIf ExprChild ASTChild - | LabIfElse ExprChild ASTChild ASTChild - | LabLabelled VarChild ASTChild - | LabReturn ExprChild - | LabStatement ExprChild - | LabSwitch ExprChild ASTChild - | LabTry ASTChild ASTChild - | LabWhile ExprChild ASTChild deriving (Show) - - --- Takes an unlabelled AST and labels the whole thing. -label :: [JSASTWithSourceFragment] -> [ASTChild] -label list = labelJSASTList list 0 - - --- Extract the JSASTLabel from a VarChild, IndexChild etc. -childGetLabel :: (a, JSASTLabel) -> JSASTLabel -childGetLabel (child, lab) = lab - --- Extract the JSASTLabel from a ASTChild, ExprChild etc. -childWSGetLabel :: (a, JSASTLabel, b) -> JSASTLabel -childWSGetLabel (_, lab, _) = lab - -childGetSource :: (a, b, SourceFragment) -> SourceFragment -childGetSource (_, _, sf) = sf - --- Extract the labels from a list of VarChild, IndexChild etc. -listGetLabels :: [(a, JSASTLabel)] -> [JSASTLabel] -listGetLabels [] = [] -listGetLabels (c:cs) = ((childGetLabel c):(listGetLabels cs)) - --- Extract the labels from a list of ASTChild, ExprChild etc. -listWSGetLabels :: [(a, JSASTLabel, b)] -> [JSASTLabel] -listWSGetLabels [] = [] -listWSGetLabels (c:cs) = ((childWSGetLabel c):(listWSGetLabels cs)) - - --- Find the greater of the label on a Maybe *Child and a given value. -maxMaybeLabel :: (Maybe (a, JSASTLabel)) -> JSASTLabel -> JSASTLabel --- If the Maybe *Child is nothing then the given value is the greatest. -maxMaybeLabel Nothing v = v -maxMaybeLabel (Just e) v = max (childGetLabel e) v - - --- Find the greater of the label on a Maybe *Child and a given value. -maxMaybeWSLabel :: (Maybe (a, JSASTLabel, b)) -> JSASTLabel -> JSASTLabel --- If the Maybe *Child is nothing then the given value is the greatest. -maxMaybeWSLabel Nothing v = v -maxMaybeWSLabel (Just e) v = max (childWSGetLabel e) v - --- Label a list of Varialbes. -labelVarList :: [Variable] -> JSASTLabel -> [VarChild] -labelVarList [] _ = [] -labelVarList (v:vx) n = (v, n + 1):(labelVarList vx (n + 1)) - - --- Label a list of Expressions. -labelExpressionList :: [ExprWithSourceFragment] -> JSASTLabel -> [ExprChild] -labelExpressionList [] _ = [] -labelExpressionList (e:ex) n = - let (le, m, sf) = labelExpression e n in ((le, m, sf):(labelExpressionList ex m)) - - --- Label a list of JSASTs. -labelJSASTList :: [JSASTWithSourceFragment] -> JSASTLabel -> [ASTChild] -labelJSASTList [] _ = [] -labelJSASTList (a:ax) n = - let (la, m, sf) = labelJSAST a n in ((la, m, sf):(labelJSASTList ax m)) - - --- Label a Varialble. -labelVariable :: Variable -> JSASTLabel -> VarChild -labelVariable var n = (var, n + 1) - - --- Label a Maybe Variable if it is not Nothing. -labelMaybeVar :: (Maybe Variable) -> JSASTLabel -> (Maybe VarChild) -labelMaybeVar Nothing n = Nothing -labelMaybeVar (Just var) n = Just (labelVariable var n) - - --- Label an Operator. -labelOperator :: Operator -> JSASTLabel -> OpChild -labelOperator op n = (op, n + 1) - - --- Label an Index. -labelIndex :: Index -> JSASTLabel -> IndexChild -labelIndex ix n = (ix, n + 1) - - --- Label a PropertyName. --- --- TODO: Unit test? -labelPropertyName :: PropertyName -> JSASTLabel -> PropertyNameChild -labelPropertyName (IndexProperty ix) n = - (LabIndexProperty field1, (childGetLabel field1) + 1) - where - field1 = labelIndex ix n -labelPropertyName (VariableProperty var) n = - (LabVariableProperty field1, (childGetLabel field1) + 1) - where - field1 = labelVariable var n - - --- Label a Value. Recursively process any child fields. -labelValue :: ValueWithSourceFragment -> JSASTLabel -> ValueChild -labelValue (WSInt i) n = (LabInt i, n + 1) -labelValue (WSFloat x) n = (LabFloat x, n + 1) -labelValue (WSString s) n = (LabString s, n + 1) -labelValue (WSBool b) n = (LabBool b, n + 1) -labelValue (WSDQString s) n = (LabDQString s, n + 1) -labelValue (WSObject props) n = - (LabObject field1, (maximum ((listWSGetLabels field1) ++ [n])) + 1) - where - field1 = labelExpressionList props n -labelValue (WSArray el) n = - (LabArray field1, (maximum ((listWSGetLabels field1) ++ [n])) + 1) - where - field1 = labelExpressionList el n -labelValue (WSUndefined) n = (LabUndefined, n + 1) -labelValue (WSNull) n = (LabNull, n + 1) - - --- Label an Expression. Recursively process any child fields. -labelExpression :: ExprWithSourceFragment -> JSASTLabel -> ExprChild -labelExpression (EWSF (WSList ex) sourceFragment) n = - ((LabList (field1)), (maximum ((listWSGetLabels field1) ++ [n])) + 1, sourceFragment) - where - field1 = labelExpressionList ex n -labelExpression (EWSF (WSBinary op ex1 ex2) sourceFragment) n = - ((LabBinary field1 field2 field3), (childWSGetLabel field3) + 1, sourceFragment) - where - field1 = labelOperator op n - field2 = labelExpression ex1 (childGetLabel field1) - field3 = labelExpression ex2 (childWSGetLabel field2) -labelExpression (EWSF (WSUnaryPost op ex) sourceFragment) n = - ((LabUnaryPost field1 field2), (childWSGetLabel field2) + 1, sourceFragment) - where - field1 = labelOperator op n - field2 = labelExpression ex (childGetLabel field1) -labelExpression (EWSF (WSUnaryPre op ex) sourceFragment) n = - ((LabUnaryPre field1 field2), (childWSGetLabel field2) + 1, sourceFragment) - where - field1 = labelOperator op n - field2 = labelExpression ex (childGetLabel field1) -labelExpression (EWSF (WSTernary ex1 ex2 ex3) sourceFragment) n = - ((LabTernary field1 field2 field3), (childWSGetLabel field3) + 1, sourceFragment) - where - field1 = labelExpression ex1 n - field2 = labelExpression ex2 (childWSGetLabel field1) - field3 = labelExpression ex3 (childWSGetLabel field2) -labelExpression (EWSF (WSAssignment op ex1 ex2) sourceFragment) n = - ((LabAssignment field1 field2 field3), (childWSGetLabel field3) + 1, sourceFragment) - where - field1 = labelOperator op n - field2 = labelExpression ex1 (childGetLabel field1) - field3 = labelExpression ex2 (childWSGetLabel field2) -labelExpression (EWSF (WSIdentifier ident) sourceFragment) n = - ((LabIdentifier field1), (childGetLabel field1) + 1, sourceFragment) - where - field1 = labelVariable ident n -labelExpression (EWSF (WSReference ex1 ex2) sourceFragment) n = - ((LabReference field1 field2), (childWSGetLabel field2) + 1, sourceFragment) - where - field1 = labelExpression ex1 n - field2 = labelExpression ex2 (childWSGetLabel field1) -labelExpression (EWSF (WSIndex ex1 ex2) sourceFragment) n = - ((LabIndex field1 field2), (childWSGetLabel field2) + 1, sourceFragment) - where - field1 = labelExpression ex1 n - field2 = labelExpression ex2 (childWSGetLabel field1) -labelExpression (EWSF (WSValue val) sourceFragment) n = - ((LabValue field1), (childGetLabel field1) + 1, sourceFragment) - where - field1 = labelValue val n -labelExpression (EWSF (WSPropNameValue name ex) sourceFragment) n = - ((LabPropNameValue field1 field2), (childWSGetLabel field2) + 1, sourceFragment) - where - field1 = labelPropertyName name n - field2 = labelExpression ex (childGetLabel field1) -labelExpression (EWSF (WSCall ex1 ex2) sourceFragment) n = - ((LabCall field1 field2), (childWSGetLabel field2) + 1, sourceFragment) - where - field1 = labelExpression ex1 n - field2 = labelExpression ex2 (childWSGetLabel field1) -labelExpression (EWSF (WSArguments args) sourceFragment) n = - ((LabArguments (field1)), (maximum ((listWSGetLabels field1) ++ [n])) + 1, sourceFragment) - where - field1 = labelExpressionList args n -labelExpression (EWSF (WSParenExpression ex) sourceFragment) n = - ((LabParenExpression field1), (childWSGetLabel field1) + 1, sourceFragment) - where - field1 = labelExpression ex n -labelExpression (EWSF (WSBreak vars) sourceFragment) n = - ((LabBreak field1), (maxMaybeLabel field1 n) + 1, sourceFragment) - where - field1 = labelMaybeVar vars n -labelExpression (EWSF (WSContinue vars) sourceFragment) n = - ((LabContinue field1), (maxMaybeLabel field1 n) + 1, sourceFragment) - where - field1 = labelMaybeVar vars n -labelExpression (EWSF (WSThrow ex) sourceFragment) n = - ((LabThrow field1), (childWSGetLabel field1) + 1, sourceFragment) - where - field1 = labelExpression ex n -labelExpression (EWSF (WSCallExpression ex1 op ex2) sourceFragment) n = - ((LabCallExpression field1 field2 field3), (childWSGetLabel field3) + 1, sourceFragment) - where - field1 = labelExpression ex1 n - field2 = labelOperator op (childWSGetLabel field1) - field3 = labelExpression ex2 (childGetLabel field2) -labelExpression (EWSF (WSFunctionExpression var vars ast) sourceFragment) n = - ((LabFunctionExpression field1 field2 field3), (childWSGetLabel field3) + 1, sourceFragment) - where - field1 = labelMaybeVar var n - field2 = labelVarList vars (maxMaybeLabel field1 n) - field3 = labelJSAST ast (maximum ((listGetLabels field2) ++ [n])) -labelExpression (EWSF (WSVarDeclaration var ex) sourceFragment) n = - ((LabVarDeclaration field1 field2), (maxMaybeWSLabel field2 (childGetLabel field1)) + 1, sourceFragment) - where - field1 = labelVariable var n - field2 = labelMaybeExpression ex (childGetLabel field1) -labelExpression (EWSF (WSNew ex) sourceFragment) n = - ((LabNew field1), (childWSGetLabel field1) + 1, sourceFragment) - where - field1 = labelExpression ex n - - --- Label a Maybe Expression if it is not Nothing. -labelMaybeExpression :: (Maybe ExprWithSourceFragment) -> JSASTLabel -> (Maybe ExprChild) -labelMaybeExpression Nothing n = Nothing -labelMaybeExpression (Just ex) n = Just $ labelExpression ex n - - --- Label a JSAST. Recursively process any child fields. -labelJSAST :: JSASTWithSourceFragment -> JSASTLabel -> ASTChild -labelJSAST (AWSF (WSBlock jsastLs) sourceFragment) n = - ((LabBlock field1), (maximum ((listWSGetLabels field1) ++ [n])) + 1, sourceFragment) - where - field1 = labelJSASTList jsastLs n -labelJSAST (AWSF (WSFunctionBody jsastLs) sourceFragment) n = - ((LabFunctionBody field1), (maximum ((listWSGetLabels field1) ++ [n])) + 1, sourceFragment) - where - field1 = labelJSASTList jsastLs n -labelJSAST (AWSF (WSFunctionDeclaration var args body) sourceFragment) n = - ((LabFunctionDeclaration field1 field2 field3), (childWSGetLabel field3) + 1, sourceFragment) - where - field1 = labelVariable var n - field2 = labelVarList args (childGetLabel field1) - field3 = labelJSAST body $ maximum ((listGetLabels field2) ++ [childGetLabel field1]) -labelJSAST (AWSF (WSLabelled var body) sourceFragment) n = - ((LabLabelled field1 field2), (childWSGetLabel field2) + 1, sourceFragment) - where - field1 = labelVariable var n - field2 = labelJSAST body (childGetLabel field1) -labelJSAST (AWSF (WSForVar ex1 ex2 ex3 body) sourceFragment) n = - ((LabForVar field1 field2 field3 field4), (childWSGetLabel field4) + 1, sourceFragment) - where - field1 = labelExpressionList ex1 n - field2 = labelMaybeExpression ex2 $ maximum ((listWSGetLabels field1) ++ [n]) - field3 = - labelMaybeExpression ex3 $ maximum ((listWSGetLabels field1) ++ [maxMaybeWSLabel field2 n]) - field4 = - labelJSAST - body - $ maximum - ((listWSGetLabels field1) - ++ [maxMaybeWSLabel field2 n] - ++ [maxMaybeWSLabel field3 n]) -labelJSAST (AWSF (WSFor ex1 ex2 ex3 body) sourceFragment) n = - ((LabFor field1 field2 field3 field4), (childWSGetLabel field4) + 1, sourceFragment) - where - field1 = labelMaybeExpression ex1 n - field2 = labelMaybeExpression ex2 (maxMaybeWSLabel field1 n) - field3 = - labelMaybeExpression ex3 $ max (maxMaybeWSLabel field1 n) (maxMaybeWSLabel field2 n) - field4 = - labelJSAST - body - $ maximum - ([maxMaybeWSLabel field1 n] - ++ [maxMaybeWSLabel field2 n] - ++ [maxMaybeWSLabel field3 n]) -labelJSAST (AWSF (WSForIn vars ex body) sourceFragment) n = - ((LabForIn field1 field2 field3), (childWSGetLabel field3) + 1, sourceFragment) - where - field1 = labelVarList vars n - field2 = labelExpression ex $ maximum ((listGetLabels field1) ++ [n]) - field3 = labelJSAST body (childWSGetLabel field2) -labelJSAST (AWSF (WSForVarIn ex1 ex2 body) sourceFragment) n = - ((LabForVarIn field1 field2 field3), (childWSGetLabel field3) + 1, sourceFragment) - where - field1 = labelExpression ex1 n - field2 = labelExpression ex2 (childWSGetLabel field1) - field3 = labelJSAST body (childWSGetLabel field2) -labelJSAST (AWSF (WSWhile ex body) sourceFragment) n = - ((LabWhile field1 field2), (childWSGetLabel field2) + 1, sourceFragment) - where - field1 = labelExpression ex n - field2 = labelJSAST body (childWSGetLabel field1) -labelJSAST (AWSF (WSDoWhile body ex) sourceFragment) n = - ((LabDoWhile field1 field2), (childWSGetLabel field2) + 1, sourceFragment) - where - field1 = labelJSAST body n - field2 = labelExpression ex (childWSGetLabel field1) -labelJSAST (AWSF (WSIf ex body) sourceFragment) n = - ((LabIf field1 field2), (childWSGetLabel field2) + 1, sourceFragment) - where - field1 = labelExpression ex n - field2 = labelJSAST body (childWSGetLabel field1) -labelJSAST (AWSF (WSIfElse ex bodyT bodyF) sourceFragment) n = - ((LabIfElse field1 field2 field3), (childWSGetLabel field3) + 1, sourceFragment) - where - field1 = labelExpression ex n - field2 = labelJSAST bodyT (childWSGetLabel field1) - field3 = labelJSAST bodyF (childWSGetLabel field2) -labelJSAST (AWSF (WSSwitch ex cs) sourceFragment) n = - ((LabSwitch field1 field2), (childWSGetLabel field2) + 1, sourceFragment) - where - field1 = labelExpression ex n - field2 = labelJSAST cs (childWSGetLabel field1) -labelJSAST (AWSF (WSCase ex body) sourceFragment) n = - ((LabCase field1 field2), (childWSGetLabel field2) + 1, sourceFragment) - where - field1 = labelExpression ex n - field2 = labelJSAST body (childWSGetLabel field1) -labelJSAST (AWSF (WSDefault body) sourceFragment) n = - ((LabDefault field1), (childWSGetLabel field1) + 1, sourceFragment) - where - field1 = labelJSAST body n -labelJSAST (AWSF (WSTry body ctch) sourceFragment) n = - ((LabTry field1 field2), (childWSGetLabel field2) + 1, sourceFragment) - where - field1 = labelJSAST body n - field2 = labelJSAST ctch (childWSGetLabel field1) -labelJSAST (AWSF (WSCatch var ex body) sourceFragment) n = - ((LabCatch field1 field2 field3), (childWSGetLabel field3) + 1, sourceFragment) - where - field1 = labelVariable var n - field2 = labelMaybeExpression ex (childGetLabel field1) - field3 = labelJSAST body (maxMaybeWSLabel field2 (childGetLabel field1)) -labelJSAST (AWSF (WSFinally body) sourceFragment) n = - ((LabFinally field1), (childWSGetLabel field1) + 1, sourceFragment) - where - field1 = labelJSAST body n -labelJSAST (AWSF (WSReturn ex) sourceFragment) n = - ((LabReturn field1), (childWSGetLabel field1) + 1, sourceFragment) - where - field1 = labelExpression ex n -labelJSAST (AWSF (WSStatement ex) sourceFragment) n = - ((LabStatement field1), (childWSGetLabel field1) + 1, sourceFragment) - where - field1 = labelExpression ex n diff --git a/Main.hs b/Main.hs index 874affd..05f7d51 100644 --- a/Main.hs +++ b/Main.hs @@ -12,15 +12,13 @@ -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -- See the License for the specific language governing permissions and -- limitations under the License. --- Module takes a JSAST and gives each vertex a unique integer label. The label counter is simply --- threaded through the tree. Traversal is depth first. It's all fairly straight-forward. -- The methods in the pipeline are: -- ParseJS.parseTree - NEEDS PRETTY PRINT --- ParseJS.getJSASTWithSource - NEEDS PRETTY PRINT --- ResolveJSASTSourceFragments.jsastListWSMakeSourceFragments --- LabelJSAST.label +-- ParseJS.getASTWithSource - NEEDS PRETTY PRINT +-- ResolveASTSourceFragments.astListWSMakeSourceFragments +-- LabelAST.label -- DeclarationGraph.getDeclarationGraph - NEEDS PRETTY PRINT -- DeclarationGraph.graphGetAllRules (optional) - TYPES NEED PRETTY PRINT -- DeclarationGraph.cleanFunctionRules (optional) @@ -34,7 +32,7 @@ main import DeclarationGraph -import LabelJSAST +import LabelAST import Language.JavaScript.Parser import ParseJS import PrettyPrint @@ -51,12 +49,12 @@ main = do pr <- readFile infile putStrLn "" -- ***************** - putStrLn "" - putStrLn "Print the stripped parse tree" - printParseTreeStripped $ jsnGetNode $ parseTree pr infile - putStrLn "" - putStrLn "Print the raw parse tree" - putStrLn $ show $ parse pr infile + -- putStrLn "" + -- putStrLn "Print the stripped parse tree" + -- printParseTreeStripped $ jsnGetNode $ parseTree pr infile + -- putStrLn "" + -- putStrLn "Print the raw parse tree" + -- putStrLn $ show $ parse pr infile -- ***************** -- PRETTY PRINTED -- Prints declared functions and function expressions, and the identifiers @@ -69,10 +67,10 @@ main = do -- **PRETTY PRINTED** -- Prints the rules, indented base on their scope, with optional source code, and an optional -- list of the identifiers that are visible at that each scope. - putStrLn "" - putStrLn "Pretty print cleaned function rules with identifiers" - putStr "Top Level:" - printCleanedRulesList ((makeCleanedFunctionRules pr infile):[]) (makeIndent "") False True + -- putStrLn "" + -- putStrLn "Pretty print cleaned function rules with identifiers" + -- putStr "Top Level:" + -- printCleanedRulesList ((makeCleanedFunctionRules pr infile):[]) (makeIndent "") False True -- PRETTY PRINTED (could be improved with pretty printing for types) -- Print all the rules, optionally with source code. @@ -89,39 +87,39 @@ main = do -- PRETTY PRINTED -- Print the cleaned ATS. -- putStrLn "" - -- putStrLn "Pretty print labelled JSAST without labels or source fragments" - -- mapPrintASTChild (makeLabelledJSAST pr infile) (makeIndent "") False False + -- putStrLn "Pretty print labelled AST without labels or source fragments" + -- mapPrintASTChild (makeLabelledAST pr infile) (makeIndent "") False False -- PRETTY PRINTED -- Print the cleaned ATS with labels. -- putStrLn "" - -- putStrLn "Pretty print labelled JSAST with labels" - -- mapPrintASTChild (makeLabelledJSAST pr infile) (makeIndent "") False True + -- putStrLn "Pretty print labelled AST with labels" + -- mapPrintASTChild (makeLabelledAST pr infile) (makeIndent "") False True -- PRETTY PRINTED -- Print the cleaned ATS with source. -- putStrLn "" - -- putStrLn "Pretty print labelled JSAST with source fragments" - -- mapPrintASTChild (makeLabelledJSAST pr infile) (makeIndent "") True False + -- putStrLn "Pretty print labelled AST with source fragments" + -- mapPrintASTChild (makeLabelledAST pr infile) (makeIndent "") True False -- **PRETTY PRINTED** -- Print the cleaned ATS with labels and source. - putStrLn "" - putStrLn "Pretty print labelled JSAST with labels and source fragments" - mapPrintASTChild (makeLabelledJSAST pr infile) (makeIndent "") True True + -- putStrLn "" + -- putStrLn "Pretty print labelled AST with labels and source fragments" + -- printASTChild (makeLabelledAST pr infile) (makeIndent "") True True -- **PRETTY PRINTED** - -- Pretty print the JSASTWithSourceFragment with source fragments + -- Pretty print the ASTWithSourceFragment with source fragments putStrLn "" - putStrLn "Pretty print JSASTWithSourceFragment with source fragments" - mapPrintASTWS (makeJSASTWithSourceFragments pr infile) (makeIndent "") True + putStrLn "Pretty print ASTWithSourceFragment with source fragments" + printASTWS (makeASTWithSourceFragments pr infile) (makeIndent "") True -- **PRETTY PRINTED** - -- Pretty print the JSASTWithSourceFragment without source fragments + -- Pretty print the ASTWithSourceFragment without source fragments putStrLn "" - putStrLn "Pretty print JSASTWithSourceFragment without source fragments" - mapPrintASTWS (makeJSASTWithSourceFragments pr infile) (makeIndent "") False + putStrLn "Pretty print ASTWithSourceFragment without source fragments" + printASTWS (makeASTWithSourceFragments pr infile) (makeIndent "") False - -- Prints the first JSAST (pre-labels). + -- Prints the first AST (pre-labels). -- putStrLn "" - -- putStrLn "Print the the original JSAST" - -- mapM_ print (makeJSAST pr infile) + -- putStrLn "Print the the original AST" + -- mapM_ print (makeAST pr infile) -- Rudimentary. Prints the parse tree using Language.JavaScript's showStripped function. Prints -- one top-level parse tree node per line. @@ -151,20 +149,18 @@ makeAllRules input fileName = graphGetAllRules $ makeDeclarationGraph input file makeDeclarationGraph :: String -> SourceFileName -> FunctionRules makeDeclarationGraph input fileName = getDeclarationGraph - (makeLabelledJSAST input fileName) + (makeLabelledAST input fileName) (fileName, 1, 1, ((length $ lines input) + 1), 1) -makeLabelledJSAST :: String -> SourceFileName -> [ASTChild] -makeLabelledJSAST input fileName = label $ makeJSASTWithSourceFragments input fileName +makeLabelledAST :: String -> SourceFileName -> ASTChild +makeLabelledAST input fileName = label $ makeASTWithSourceFragments input fileName --- FIXME: Passing the file name here might mean that we don't need to thread it through the whole --- AST. -makeJSASTWithSourceFragments :: String -> SourceFileName -> [JSASTWithSourceFragment] -makeJSASTWithSourceFragments input fileName = - jsastListWSMakeSourceFragments (makeJSAST input fileName) (SpanPoint fileName ((length $ lines input) + 1) 1) +makeASTWithSourceFragments :: String -> SourceFileName -> ASTWithSourceFragment +makeASTWithSourceFragments input fileName = + astWSMakeSourceFragment (makeAST input fileName) (SpanPoint fileName ((length $ lines input) + 1) 1) -makeJSAST :: String -> SourceFileName -> ([JSASTWithSourceSpan], SourceFileName) -makeJSAST input fileName = getJSASTWithSource (parseTree input fileName) fileName +makeAST :: String -> SourceFileName -> (ASTWithSourceSpan, SourceFileName) +makeAST input fileName = getASTWithSource (parseTree input fileName) fileName diff --git a/ParseJS.hs b/ParseJS.hs index db67bb6..6e70997 100644 --- a/ParseJS.hs +++ b/ParseJS.hs @@ -12,8 +12,6 @@ -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -- See the License for the specific language governing permissions and -- limitations under the License. --- Module takes a JSAST and gives each vertex a unique integer label. The label counter is simply --- threaded through the tree. Traversal is depth first. It's all fairly straight-forward. -- This module parses a JavaScript source file using the Language.Javascript.Parser library (Version @@ -32,16 +30,14 @@ -- JSWith -- -- --- Top level function is (getJSASTWithSource (parseTree program file) file) +-- Top level function is (getASTWithSource (parseTree program file) file) -- module ParseJS -( Expression(..) -, ExprWithSourceSpan(..) -, Index -, JSAST(..) -, JSASTWithSourceSpan(..) +( Index +, AST(..) +, ASTWithSourceSpan(..) , Operator , PropertyName(..) , SourceFileName @@ -49,25 +45,14 @@ module ParseJS , Variable , jsnGetNode , parseTree -, getJSASTWithSource +, getASTWithSource ) where import Control.Monad.State import Data.Functor.Identity -import Data.List - ( delete - , find - , intercalate - , nub - ,(\\) - ) -import Data.Maybe - ( catMaybes - , fromJust - , isJust - , mapMaybe - ) +import Data.List (dropWhileEnd, groupBy) +import Data.Maybe (listToMaybe) import Language.JavaScript.Parser (parse) import Language.JavaScript.Parser.AST @@ -95,8 +80,9 @@ data PropertyName = -- Represent literal values. +-- TODO: Rename these from JSX to ASTX data Value = - JSArray [ExprWithSourceSpan] + JSArray [ASTWithSourceSpan] | JSBool Bool -- TODO: Double quote strings are never treated differently to normal strings and should be -- merged with JSString when pipeline is complete. @@ -105,92 +91,87 @@ data Value = | JSInt Int | JSNull -- Objects contain a list of PropNameValues. - | JSObject [ExprWithSourceSpan] + | JSObject [ASTWithSourceSpan] | JSString String | JSUndefined deriving (Show) --- Represent, approximately, source elements that are expressions. None of these contain JSAST --- fields except for FunctionExpression. --- --- TODO: Can FunctionExpression be moved into JSAST? (probably not). -data Expression = - Arguments [ExprWithSourceSpan] - | Assignment Operator ExprWithSourceSpan ExprWithSourceSpan - | Binary Operator ExprWithSourceSpan ExprWithSourceSpan +-- Represent a node in the AST +data AST = + Block ASTWithSourceSpan + | Case ASTWithSourceSpan ASTWithSourceSpan + | Catch Variable (Maybe ASTWithSourceSpan) ASTWithSourceSpan + | Default ASTWithSourceSpan + | DoWhile ASTWithSourceSpan ASTWithSourceSpan + | Finally ASTWithSourceSpan + | For + (Maybe ASTWithSourceSpan) + (Maybe ASTWithSourceSpan) + (Maybe ASTWithSourceSpan) + ASTWithSourceSpan + | ForIn [Variable] ASTWithSourceSpan ASTWithSourceSpan + | ForVar + [ASTWithSourceSpan] + (Maybe ASTWithSourceSpan) + (Maybe ASTWithSourceSpan) + ASTWithSourceSpan + | ForVarIn ASTWithSourceSpan ASTWithSourceSpan ASTWithSourceSpan + | FunctionBody [ASTWithSourceSpan] + | FunctionDeclaration Variable [Variable] ASTWithSourceSpan + | If ASTWithSourceSpan ASTWithSourceSpan + | IfElse ASTWithSourceSpan ASTWithSourceSpan ASTWithSourceSpan + | Labelled Variable ASTWithSourceSpan + | Return ASTWithSourceSpan + | Switch ASTWithSourceSpan [ASTWithSourceSpan] + | Try ASTWithSourceSpan [ASTWithSourceSpan] + | While ASTWithSourceSpan ASTWithSourceSpan + + | Arguments [ASTWithSourceSpan] + | Assignment Operator ASTWithSourceSpan ASTWithSourceSpan + | Binary Operator ASTWithSourceSpan ASTWithSourceSpan | Break (Maybe Variable) - | Call ExprWithSourceSpan ExprWithSourceSpan + | Call ASTWithSourceSpan ASTWithSourceSpan -- In Language.JavaScript, a call expression is an expression that calls - or accesses a -- property of - a function call. (E.g. foo()(); foo().bar;) -- -- This program treats foo()() as a Call within a Call (I think that is a sufficient -- description for our purposes). - | CallExpression ExprWithSourceSpan Operator ExprWithSourceSpan + | CallExpression ASTWithSourceSpan Operator ASTWithSourceSpan | Continue (Maybe Variable) + -- TODO: Needs comment to explain what it is. + -- TODO: New type. Needs to be handled in the Rules. + -- Was called "List". + | Expression [ASTWithSourceSpan] -- A function definition on the right hand side of some statement. - | FunctionExpression (Maybe Variable) [Variable] JSASTWithSourceSpan + | FunctionExpression (Maybe Variable) [Variable] ASTWithSourceSpan | Identifier Variable -- An index into a structure using square brackets. - | Index ExprWithSourceSpan ExprWithSourceSpan + | Index ASTWithSourceSpan ASTWithSourceSpan + | New ASTWithSourceSpan -- TODO: Needs comment to explain what it is. - | List [ExprWithSourceSpan] - | New ExprWithSourceSpan - -- TODO: Needs comment to explain what it is. - | ParenExpression ExprWithSourceSpan + | ParenExpression ASTWithSourceSpan -- A property of an object. - | PropNameValue PropertyName ExprWithSourceSpan + | PropNameValue PropertyName ASTWithSourceSpan -- A reference into a structure using a dot. - | Reference ExprWithSourceSpan ExprWithSourceSpan - | Ternary ExprWithSourceSpan ExprWithSourceSpan ExprWithSourceSpan - | Throw ExprWithSourceSpan - | UnaryPost Operator ExprWithSourceSpan - | UnaryPre Operator ExprWithSourceSpan + | Reference ASTWithSourceSpan ASTWithSourceSpan + -- TODO: Needs comment to explain what it is. + -- TODO: New type. Needs to be handled in the Rules. + -- Was called "List". + | StatementList [ASTWithSourceSpan] + | Ternary ASTWithSourceSpan ASTWithSourceSpan ASTWithSourceSpan + | Throw ASTWithSourceSpan + | UnaryPost Operator ASTWithSourceSpan + | UnaryPre Operator ASTWithSourceSpan | Value Value - | VarDeclaration Variable (Maybe ExprWithSourceSpan) deriving (Show) + | VarDeclaration Variable (Maybe ASTWithSourceSpan) + deriving (Show) --- Represent source elements which include a "block" or "body" and thus make logical non-terminal --- nodes for an abstract syntax tree. --- --- TODO: Also includes a type for return expressions (Return) and a wrapper for instances of the --- Expression data type (Statement). Can they be moved into Expression? (probably not). -data JSAST = - Block [JSASTWithSourceSpan] - | Case ExprWithSourceSpan JSASTWithSourceSpan - | Catch Variable (Maybe ExprWithSourceSpan) JSASTWithSourceSpan - | Default JSASTWithSourceSpan - | DoWhile JSASTWithSourceSpan ExprWithSourceSpan - | Finally JSASTWithSourceSpan - | For - (Maybe ExprWithSourceSpan) - (Maybe ExprWithSourceSpan) - (Maybe ExprWithSourceSpan) - JSASTWithSourceSpan - | ForIn [Variable] ExprWithSourceSpan JSASTWithSourceSpan - | ForVar - [ExprWithSourceSpan] - (Maybe ExprWithSourceSpan) - (Maybe ExprWithSourceSpan) - JSASTWithSourceSpan - | ForVarIn ExprWithSourceSpan ExprWithSourceSpan JSASTWithSourceSpan - | FunctionBody [JSASTWithSourceSpan] - | FunctionDeclaration Variable [Variable] JSASTWithSourceSpan - | If ExprWithSourceSpan JSASTWithSourceSpan - | IfElse ExprWithSourceSpan JSASTWithSourceSpan JSASTWithSourceSpan - | Labelled Variable JSASTWithSourceSpan - | Return ExprWithSourceSpan - | Statement ExprWithSourceSpan - | Switch ExprWithSourceSpan JSASTWithSourceSpan - | Try JSASTWithSourceSpan JSASTWithSourceSpan - | While ExprWithSourceSpan JSASTWithSourceSpan deriving (Show) - +data ASTWithSourceSpan = AWSS AST SrcSpan deriving (Show) -data JSASTWithSourceSpan = AWSS JSAST SrcSpan deriving (Show) -data ExprWithSourceSpan = EWSS Expression SrcSpan deriving (Show) - -getJSASTWithSource :: JSNode -> SourceFileName -> ([JSASTWithSourceSpan], SourceFileName) -getJSASTWithSource jsn fileName = ((toJSAST jsn), fileName) +getASTWithSource :: JSNode -> SourceFileName -> (ASTWithSourceSpan, SourceFileName) +getASTWithSource jsn fileName = ((toAST jsn), fileName) -- Parse JavaScript source code. @@ -206,373 +187,410 @@ jsnGetSource :: JSNode -> SrcSpan jsnGetSource (NS _ srcSpan) = srcSpan --- Make a List or a ParenExpression from a Statement JSNode. -jsnToListExp :: JSNode -> ExprWithSourceSpan -jsnToListExp jsn = - statementToListExp $ toJSAST jsn - where - statementToListExp :: [JSASTWithSourceSpan] -> ExprWithSourceSpan - statementToListExp [AWSS (Statement expr) _] = expr +jsIdentifierGetString :: Node -> String +jsIdentifierGetString (JSIdentifier jsid) = jsid --- Extract a (Maybe List), a (Maybe ParenExpression) or Nothing. Assumes that the first parameter is --- always a singleton list or empty. -jsnToMaybeListExp :: [JSNode] -> Maybe ExprWithSourceSpan -jsnToMaybeListExp (jsn:[]) = Just $ jsnToListExp jsn -jsnToMaybeListExp [] = Nothing +-- FIXME: So far only used in one place. Remove? +properListToMaybe :: ([a] -> b) -> [a] -> Maybe b +properListToMaybe _ [] = Nothing +properListToMaybe f list = Just $ f list -identifierGetString :: Node -> String -identifierGetString (JSIdentifier jsid) = jsid +listToMaybeExpression :: [JSNode] -> Maybe ASTWithSourceSpan +listToMaybeExpression jsnList = properListToMaybe listToASTExpression jsnList - -toJSASTVarDeclaration :: JSNode -> ExprWithSourceSpan -toJSASTVarDeclaration (NS (JSVarDecl name value) srcSpan) = - EWSS - (VarDeclaration - (identifierGetString $ jsnGetNode name) - (maybeValue value)) - srcSpan - where - maybeValue :: [JSNode] -> Maybe ExprWithSourceSpan - maybeValue [] = Nothing - maybeValue val = Just $ listToJSASTExpression val +-- listToMaybeExpression :: [JSNode] -> Maybe ASTWithSourceSpan +-- listToMaybeExpression [] = Nothing +-- listToMaybeExpression jsnList = Just $ listToASTExpression jsnList -- Some parser nodes contain lists of JSNodes that represent whole expressions. This function takes -- such a list of Nodes and builds a single expression. -listToJSASTExpression :: [JSNode] -> ExprWithSourceSpan -listToJSASTExpression [item] = makeJSASTExpression item -listToJSASTExpression [(NS (JSUnary operator) srcSpan), (NS (JSDecimal x) _)] +-- FIXME: Probably semicolons can come through here, or empty lists. +listToASTExpression :: [JSNode] -> ASTWithSourceSpan +listToASTExpression [item] = toAST item +listToASTExpression [(NS (JSUnary operator) srcSpan), (NS (JSDecimal x) _)] | (operator == "-") = - if (elem '.' x) then - EWSS (Value xFloat) srcSpan - else - EWSS (Value xInt) srcSpan + if (elem '.' x) + then + AWSS (Value xFloat) srcSpan + else + AWSS (Value xInt) srcSpan where xFloat = JSFloat (-1 * (read x)) xInt = JSInt (-1 * (read x)) -listToJSASTExpression ((NS (JSUnary operator) srcSpan):x) +listToASTExpression ((NS (JSUnary operator) srcSpan):x) | elem operator ["-", "+", "--", "++", "!", "typeof ", "delete ", "~"] = - EWSS + AWSS (UnaryPre operator - (listToJSASTExpression x)) + (listToASTExpression x)) srcSpan -listToJSASTExpression ((NS (JSLiteral "new ") srcSpan):x) = - EWSS (New (listToJSASTExpression x)) srcSpan -listToJSASTExpression [x, (NS (JSArguments args) srcSpan)] = - EWSS +listToASTExpression ((NS (JSLiteral "new ") srcSpan):x) = + AWSS (New (listToASTExpression x)) srcSpan +listToASTExpression [x, (NS (JSArguments args) srcSpan)] = + AWSS (Call - (makeJSASTExpression x) - (toJSASTArguments args srcSpan)) + (toAST x) + (toAST (NS (JSArguments args) srcSpan))) (jsnGetSource x) -listToJSASTExpression list | (isCallExpression $ last list) = - getJSASTCallExpression list +-- To handle the case where the last element in the list is a (JSCallExpression "[]" exp) or a +-- (JSCallExpression "." exp). +listToASTExpression list | (isCallExpression $ last list) = + AWSS + (CallExpression + (listToASTExpression (init list)) + (callExpOperator $ jsnGetNode $ last list) + (callExpProperty $ jsnGetNode $ last list)) + (jsnGetSource $ head list) where isCallExpression :: JSNode -> Bool isCallExpression (NS (JSCallExpression "." _) _) = True isCallExpression (NS (JSCallExpression "[]" _) _) = True isCallExpression _ = False -listToJSASTExpression list | (isParenCallExp $ last list) = - getJSASTCall list + callExpOperator :: Node -> Operator + callExpOperator (JSCallExpression operator _) = operator + -- FIXME: This assumes that the expression list can only ever be singleton. Verify. + callExpProperty :: Node -> ASTWithSourceSpan + callExpProperty (JSCallExpression _ [member]) = toAST member +-- To handle the case where the last element of a list is a (JSCallExpression "()" [JSArguments +-- _]) I don't know if the second field can be anything other than a singleton list containing a +-- JSArguments but for now I'm just going to hope not. +-- +-- TODO: Find out what values the arguments list can have. +listToASTExpression list | (isParenCallExp $ last list) = + AWSS + (Call + (listToASTExpression (init list)) + (getArgs $ jsnGetNode $ last list)) + (jsnGetSource $ head list) where isParenCallExp :: JSNode -> Bool isParenCallExp (NS (JSCallExpression "()" _) _) = True isParenCallExp _ = False + getArgs :: Node -> ASTWithSourceSpan + getArgs (JSCallExpression _ [args]) = toAST args -- FIXME: Anything else is assumed to be an assignment. Verify that that assumption is correct. -listToJSASTExpression list = - getJSASTAssignment list [] +listToASTExpression list = + getASTAssignment list [] where isAssignmentOperator :: String -> Bool isAssignmentOperator op | elem op ["=", "+=", "-=", "*=", "/=", "%=", "<<=", ">>=", ">>>=", "&=", "^=", "|="] = True | otherwise = False - getJSASTAssignment :: [JSNode] -> [JSNode] -> ExprWithSourceSpan - getJSASTAssignment ((NS (JSOperator op) srcSpan):xs) preCurrent + getASTAssignment :: [JSNode] -> [JSNode] -> ASTWithSourceSpan + getASTAssignment ((NS (JSOperator op) srcSpan):xs) preCurrent | (isAssignmentOperator op) = - EWSS + AWSS (Assignment op - (listToJSASTExpression preCurrent) - (listToJSASTExpression xs)) + (listToASTExpression preCurrent) + (listToASTExpression xs)) (jsnGetSource $ head preCurrent) - getJSASTAssignment (x:xs) preCurrent = getJSASTAssignment xs (preCurrent ++ [x]) - - -toJSASTArguments :: [[JSNode]] -> SrcSpan -> ExprWithSourceSpan -toJSASTArguments args srcSpan = - EWSS (Arguments (map getJSASTArgument args)) srcSpan - where - getJSASTArgument :: [JSNode] -> ExprWithSourceSpan - getJSASTArgument (item:[]) = makeJSASTExpression item - getJSASTArgument nodes = listToJSASTExpression nodes + getASTAssignment (x:xs) preCurrent = getASTAssignment xs (preCurrent ++ [x]) --- To handle the case where the last element of a list is a (JSCallExpression "()" [JSArguments --- _]) I don't know if the second field can be anything other than a singleton list containing a --- JSArguments but for now I'm just going to hope not. --- --- TODO: Find out what values the arguments list can have. -getJSASTCall :: [JSNode] -> ExprWithSourceSpan -getJSASTCall list = - EWSS - (Call - (listToJSASTExpression (init list)) - (getArgs $ last list)) - (jsnGetSource $ head list) - where - getArgs :: JSNode -> ExprWithSourceSpan - getArgs (NS (JSCallExpression _ [(NS (JSArguments args) srcSpan)]) _) = - toJSASTArguments args srcSpan +toASTVarDeclaration :: JSNode -> ASTWithSourceSpan +toASTVarDeclaration (NS (JSVarDecl name value) srcSpan) = + AWSS + (VarDeclaration + (jsIdentifierGetString $ jsnGetNode name) + (listToMaybeExpression value)) + srcSpan --- To handle the case where the last element in the list is a (JSCallExpression "[]" exp) or a --- (JSCallExpression "." exp). -getJSASTCallExpression :: [JSNode] -> ExprWithSourceSpan -getJSASTCallExpression list = - EWSS - (CallExpression - (listToJSASTExpression (init list)) - (callExpOperator $ jsnGetNode $ last list) - (callExpProperty $ jsnGetNode $ last list)) - (jsnGetSource $ head list) +-- TODO: Check use of this function. Probably used in more places than needed. +filterSemicolons :: [JSNode] -> [JSNode] +filterSemicolons jsnList = + filter isNotSemi jsnList where - callExpOperator :: Node -> Operator - callExpOperator (JSCallExpression operator _) = operator - -- FIXME: This assumes that the expression list can only ever be singleton. Verify. - callExpProperty :: Node -> ExprWithSourceSpan - callExpProperty (JSCallExpression "[]" [expr]) = jsnToListExp expr - callExpProperty (JSCallExpression "." [expr]) = - makeJSASTExpression expr - - -toJSAST :: JSNode -> [JSASTWithSourceSpan] --- These ones return a proper list of JSASTs. (Haskell) Constructors which use one of these to --- fill a field must have a [JSAST] for that field. -toJSAST (NS (JSBlock jsnode) _) = toJSAST jsnode -toJSAST (NS (JSFunctionBody bodyList) _) = concat $ map toJSAST bodyList -toJSAST (NS (JSSourceElements elementsList) _) = concat $ map toJSAST elementsList -toJSAST (NS (JSSourceElementsTop topList) _) = concat $ map toJSAST topList -toJSAST (NS (JSStatementBlock item) _) = toJSAST item -toJSAST (NS (JSStatementList statList) _) = concat $ map toJSAST statList -toJSAST (NS (JSVariables _ varDecs) srcSpan) = - map (\jsn -> AWSS (Statement (toJSASTVarDeclaration jsn)) srcSpan) varDecs --- These ones always return singleton lists. (Haskell) Constructors which use only these to --- fill a field can have a JSAST for that field. -toJSAST (NS (JSBreak [] _) srcSpan) = - [AWSS - (Statement - (EWSS (Break Nothing) srcSpan)) - srcSpan - ] -toJSAST (NS (JSBreak [label] _) srcSpan) = - [AWSS - (Statement - (EWSS (Break (Just $ identifierGetString $ jsnGetNode label)) srcSpan)) - srcSpan - ] -toJSAST (NS (JSCase cs body) srcSpan) = - [AWSS + isNotSemi jsn = not ((jsnGetNode jsn) == (JSLiteral ";")) + + +-- TODO: Remove all of the nested constructors. +-- TODO: Alpha order. +-- TODO: All semicolons have been filtered out. Is that OK? +toAST :: JSNode -> ASTWithSourceSpan +toAST (NS (JSBlock statements) srcSpan) = + AWSS + (Block + (toAST statements)) + srcSpan +toAST (NS (JSFunctionBody bodyList) srcSpan) = + AWSS + (FunctionBody (map toAST (filterSemicolons bodyList))) + srcSpan +-- TODO: Make sure this is handled correctly when making Rules. +toAST (NS (JSSourceElements elementsList) srcSpan) = + AWSS + (StatementList (map toAST (filterSemicolons elementsList))) + srcSpan +-- TODO: Make sure this is handled correctly when making Rules. +toAST (NS (JSSourceElementsTop elementsList) srcSpan) = + AWSS + (StatementList (map toAST (filterSemicolons elementsList))) + srcSpan +toAST (NS (JSStatementBlock statements) srcSpan) = + AWSS + -- FIXME: Not sure if "Block" is the right thing here. + (Block + (toAST statements)) + srcSpan +toAST (NS (JSStatementList statements) srcSpan) = + AWSS + (StatementList (map toAST (filterSemicolons statements))) + srcSpan +-- TODO: Do I need to do anything with the first parameter? +toAST (NS (JSVariables _ varDecs) srcSpan) = + -- FIXME: This doesn't actually come from a JSStatementList in the parser. Should make a + -- "variables" type for this. + AWSS + (StatementList (map toASTVarDeclaration (filterSemicolons varDecs))) + srcSpan +toAST (NS (JSBreak label _) srcSpan) = + AWSS + (Break (liftM (jsIdentifierGetString . jsnGetNode) (listToMaybe label))) + srcSpan +toAST (NS (JSCase cs body) srcSpan) = + AWSS (Case - (jsnToListExp cs) - (AWSS (Block (toJSAST body)) (jsnGetSource body))) + (toAST cs) + -- body is a JSStatementList. + (toAST body)) srcSpan - ] -toJSAST (NS (JSCatch var test body) srcSpan) = - [AWSS +toAST (NS (JSCatch var test body) srcSpan) = + AWSS (Catch - (identifierGetString $ jsnGetNode var) + (jsIdentifierGetString $ jsnGetNode var) (listToMaybeExpression test) - (AWSS (Block (toJSAST body)) (jsnGetSource body))) + -- body is a JSBlock. + (toAST body)) srcSpan - ] - where - listToMaybeExpression :: [JSNode] -> Maybe ExprWithSourceSpan - listToMaybeExpression [] = Nothing - listToMaybeExpression jsn = Just $ listToJSASTExpression jsn -toJSAST (NS (JSContinue [item]) srcSpan) = - [AWSS - (Statement - (EWSS (Continue Nothing) srcSpan)) - srcSpan - ] -toJSAST (NS (JSContinue [label, semi]) srcSpan) = - [AWSS - (Statement - (EWSS (Continue (Just $ identifierGetString $ jsnGetNode label)) srcSpan)) - srcSpan - ] -toJSAST (NS (JSDefault body) srcSpan) = - [AWSS +-- TODO: In a JSContinue we always have either a list contiaining just a literal semicolon, or list +-- with a value and a literal semicolon. +toAST (NS (JSContinue label) srcSpan) = + AWSS + (Continue (liftM (jsIdentifierGetString . jsnGetNode) (listToMaybe $ filterSemicolons label))) + srcSpan +toAST (NS (JSDefault body) srcSpan) = + AWSS (Default - (AWSS (Block (toJSAST body)) (jsnGetSource body))) + -- body is a JSStatementList. + (toAST body)) srcSpan - ] -toJSAST (NS (JSDoWhile body test semi) srcSpan) = - [AWSS +toAST (NS (JSDoWhile body test semi) srcSpan) = + AWSS (DoWhile - (AWSS (Block (toJSAST body)) (jsnGetSource body)) - (jsnToListExp test)) + -- body is a JSStatementBlock. + (toAST body) + (toAST test)) srcSpan - ] -- TODO: Comment on where JSExpressions come from. -toJSAST (NS (JSExpression jsnList) srcSpan) = - [AWSS - (Statement - (EWSS - (List (map listToJSASTExpression (getSublists jsnList []))) - (jsnGetSource $ head jsnList))) - srcSpan - ] +toAST (NS (JSExpression jsnList) srcSpan) = + AWSS + (Expression (map listToASTExpression (getSublists jsnList []))) + srcSpan where -- A JSExpression contains a list of JSNodes, separated by . These need to be -- seperated (basically the s need to be stripped). getSublists :: [JSNode] -> [JSNode] -> [[JSNode]] getSublists ((NS (JSLiteral ",") _):rest) current = [current] ++ (getSublists rest []) + getSublists ((NS (JSLiteral ";") _):[]) current = [current] getSublists (node:rest) current = getSublists rest (current ++ [node]) getSublists [] current = [current] -toJSAST (NS (JSFinally body) srcSpan) = - [AWSS +toAST (NS (JSFinally body) srcSpan) = + AWSS (Finally - (AWSS (Block (toJSAST body)) (jsnGetSource body))) + -- body is a JSBlock. + (toAST body)) srcSpan - ] -- JSFor occurs when no varibles are declared in the loop (although they may be re-assigned). -toJSAST (NS (JSFor vars test count body) srcSpan) = - [AWSS +toAST (NS (JSFor vars test count body) srcSpan) = + AWSS (For - (jsnToMaybeListExp vars) - (jsnToMaybeListExp test) - (jsnToMaybeListExp count) - (AWSS (Block (toJSAST body)) (jsnGetSource body))) + (liftM toAST (listToMaybe vars)) + (liftM toAST (listToMaybe test)) + (liftM toAST (listToMaybe count)) + -- body is a JSStatementBlock. + (toAST body)) srcSpan - ] -- JSForIn occurs when no variables are declared inside the for statement, and the loop iterates -- over some object (e.g. an array) -toJSAST (NS (JSForIn vars obj body) srcSpan) = - [AWSS +toAST (NS (JSForIn vars obj body) srcSpan) = + AWSS (ForIn - (map (identifierGetString . jsnGetNode) vars) - (jsnToListExp obj) - (AWSS (Block (toJSAST body)) (jsnGetSource body))) + (map (jsIdentifierGetString . jsnGetNode) vars) + (toAST obj) + -- body is a JSStatementBlock. + (toAST body)) srcSpan - ] -- JSForVar occurs in the case that variables are declared in the loop statement. -toJSAST (NS (JSForVar vars test count body) srcSpan) = - [AWSS +toAST (NS (JSForVar vars test count body) srcSpan) = + AWSS (ForVar - (map toJSASTVarDeclaration vars) - (jsnToMaybeListExp test) - (jsnToMaybeListExp count) - (AWSS (Block (toJSAST body)) (jsnGetSource body))) + (map toASTVarDeclaration vars) + (liftM toAST (listToMaybe test)) + (liftM toAST (listToMaybe count)) + -- body is a JSStatementBlock. + (toAST body)) srcSpan - ] -- JSForVarIn occurs when variables are declared inside the for statement and the loop iterates over -- some object (e.g. an array) -toJSAST (NS (JSForVarIn var obj body) srcSpan) = - [AWSS +toAST (NS (JSForVarIn var obj body) srcSpan) = + AWSS (ForVarIn - (toJSASTVarDeclaration var) - (jsnToListExp obj) - (AWSS (Block (toJSAST body)) (jsnGetSource body))) + (toASTVarDeclaration var) + (toAST obj) + -- body is a JSStatementBlock. + (toAST body)) srcSpan - ] -toJSAST (NS (JSFunction name inputs body) srcSpan) = - [AWSS +toAST (NS (JSFunction name args body) srcSpan) = + AWSS (FunctionDeclaration - (identifierGetString $ jsnGetNode name) - (map (identifierGetString . jsnGetNode) inputs) - (AWSS (FunctionBody (toJSAST body)) (jsnGetSource body))) + (jsIdentifierGetString $ jsnGetNode name) + (map (jsIdentifierGetString . jsnGetNode) args) + (toAST body)) srcSpan - ] -toJSAST (NS (JSIf test body) srcSpan) = - [AWSS +toAST (NS (JSIf test body) srcSpan) = + AWSS (If - (jsnToListExp test) - (AWSS (Block (toJSAST body)) (jsnGetSource body))) + (toAST test) + -- body is a JSStatementBlock. + (toAST body)) srcSpan - ] -toJSAST (NS (JSIfElse test trueBody falseBody) srcSpan) = - [AWSS +toAST (NS (JSIfElse test trueBody falseBody) srcSpan) = + AWSS (IfElse - (jsnToListExp test) - (AWSS (Block (toJSAST trueBody)) (jsnGetSource trueBody)) - (AWSS (Block (toJSAST falseBody)) (jsnGetSource falseBody))) + (toAST test) + (toAST trueBody) + (toAST falseBody)) srcSpan - ] -- TODO: Comment on what a JSLabelled is. -toJSAST (NS (JSLabelled label body) srcSpan) = - [AWSS +toAST (NS (JSLabelled label body) srcSpan) = + AWSS (Labelled - (identifierGetString $ jsnGetNode label) - (AWSS (Block (toJSAST body)) (jsnGetSource body))) + (jsIdentifierGetString $ jsnGetNode label) + -- Body can be anything. + (toAST body)) srcSpan - ] -- FIXME: Not 100% sure that this is safe. -- TODO: Comment on where these come from. -toJSAST (NS (JSLiteral ";") srcSpan) = [] -toJSAST (NS (JSReturn [item]) srcSpan) = - [AWSS - (Return - (EWSS (Value JSUndefined) srcSpan)) +-- FIXME: What do we do with this!!?? Do I need it? +-- toAST (NS (JSLiteral ";") srcSpan) = [] +toAST (NS (JSPropertyNameandValue name value) srcSpan) = + AWSS + (PropNameValue + (getPropertyName $ jsnGetNode name) + -- Value can be a proper list of JSNodes, eg. var o = { p: x = 2 }; + (listToASTExpression value)) srcSpan - ] -toJSAST (NS (JSReturn [val, semi]) srcSpan) = - [AWSS + where + getPropertyName :: Node -> PropertyName + getPropertyName (JSIdentifier n) = VariableProperty n + getPropertyName (JSDecimal n) = IndexProperty (read n) +toAST (NS (JSReturn value) srcSpan) = + AWSS (Return - (jsnToListExp val)) + (returnValue $ filterSemicolons value)) srcSpan - ] -toJSAST (NS (JSSwitch var cases) srcSpan) = - [AWSS + where + -- The list in a JSReturn is always either a singleton list containing a semicolon, or a + -- 2-list containing a JSNode (representing the value to be returned) and a semicolon. + returnValue :: [JSNode] -> ASTWithSourceSpan + returnValue [] = AWSS (Value JSUndefined) srcSpan + returnValue [val] = toAST val +toAST (NS (JSSwitch var cases) srcSpan) = + AWSS (Switch - (jsnToListExp var) - -- TODO: Check the source span for the block. - (AWSS - (Block - (concat $ map toJSAST cases)) - (jsnGetSource $ head cases))) - srcSpan - ] -toJSAST (NS (JSThrow expr) srcSpan) = - [AWSS - (Statement - (EWSS (Throw (toJSASTExpression expr)) srcSpan)) - srcSpan - ] + (toAST var) + (map toAST cases)) + srcSpan +toAST (NS (JSThrow expr) srcSpan) = + AWSS + (Throw (toASTExpression expr)) + srcSpan where - toJSASTExpression :: JSNode -> ExprWithSourceSpan - toJSASTExpression (NS (JSExpression ex) _) = listToJSASTExpression ex -toJSAST (NS (JSTry body catchClause) srcSpan) = - [AWSS + toASTExpression :: JSNode -> ASTWithSourceSpan + toASTExpression (NS (JSExpression ex) _) = listToASTExpression ex +toAST (NS (JSTry body catchClause) srcSpan) = + AWSS (Try - (AWSS - (Block - (toJSAST body)) - (jsnGetSource body)) - -- TODO: Check the source span for the catch block. - (AWSS (Block - (concat $ map toJSAST catchClause)) - (jsnGetSource $ head catchClause))) - srcSpan - ] -toJSAST (NS (JSWhile test body) srcSpan) = - [AWSS + -- body is a JSBlock. + (toAST body) + -- Each of these is a JSCatch or a JSFinally. + -- FIXME: Can there every be semicolons? + (map toAST (filterSemicolons catchClause))) + srcSpan +toAST (NS (JSWhile test body) srcSpan) = + AWSS (While - (jsnToListExp test) - (AWSS (Block (toJSAST body)) (jsnGetSource body))) + (toAST test) + -- body is a JSStatementBlock. + (toAST body)) + srcSpan +toAST (NS (JSArguments args) srcSpan) = + AWSS + (Arguments + (map listToASTExpression args)) + srcSpan +toAST (NS (JSExpressionBinary operator left right) srcSpan) = + AWSS + (Binary + operator + (listToASTExpression left) + (listToASTExpression right)) + srcSpan +toAST (NS (JSExpressionParen expr) srcSpan) = + AWSS + (ParenExpression + (toAST expr)) + srcSpan +toAST (NS (JSExpressionPostfix operator variable) srcSpan) = + AWSS + (UnaryPost + operator + (listToASTExpression variable)) srcSpan - ] --- Anything else is assumed to be a statement. -toJSAST jsn = - [AWSS - (Statement - (makeJSASTExpression jsn)) - (jsnGetSource jsn) - ] +toAST (NS (JSExpressionTernary expr ifTrue ifFalse) srcSpan) = + AWSS + (Ternary + (listToASTExpression expr) + (listToASTExpression ifTrue) + (listToASTExpression ifFalse)) + srcSpan +toAST (NS (JSFunctionExpression name args body) srcSpan) = + AWSS + (FunctionExpression + (liftM (jsIdentifierGetString . jsnGetNode) (listToMaybe name)) + (map (jsIdentifierGetString . jsnGetNode) args) + (toAST body)) + srcSpan +toAST (NS (JSIdentifier "undefined") srcSpan) = + AWSS (Value JSUndefined) srcSpan +toAST (NS (JSIdentifier identifier) srcSpan) = + AWSS (Identifier identifier) srcSpan +toAST (NS (JSLiteral "null") srcSpan) = + AWSS (Value JSNull) srcSpan +toAST (NS (JSLiteral "this") srcSpan) = + AWSS (Identifier "this") srcSpan +toAST (NS (JSMemberDot pre post) srcSpan) = + AWSS + (Reference + (listToASTExpression pre) + (toAST post)) + srcSpan +toAST (NS (JSMemberSquare pre post) srcSpan) = + AWSS + (Index + (listToASTExpression pre) + (toAST post)) + srcSpan +-- Anything left unmatched here is assumed to be a literal value. +toAST val = + AWSS (Value (toASTValue val)) (jsnGetSource val) -- These functions are used to process array literals. @@ -613,154 +631,92 @@ toJSAST jsn = -- -- [1,,2] -- JSArrayLiteral [ JSDecimal \"1\", JSElision [], JSElision [], JSDecimal \"2\" ] +isComma :: JSNode -> Bool +isComma (NS (JSLiteral ",") _) = True +isComma _ = False + + +isElision :: JSNode -> Bool +isElision (NS (JSElision _) _) = True +isElision _ = False + +-- FIXME: The source spans for a group of undefineds will all come out the same. There +-- is no obvious way to fix this (without fixing the parser). +processArray :: [JSNode] -> SrcSpan -> [[JSNode]] +processArray array nearestSpan = + (processLeadingElisions array nearestSpan) + ++ (processTail (dropWhileEnd isComma $ dropWhile isElision array) nearestSpan) --- Some elisions have SpanEmpty so we need to use the last non-empty SpanPoint. -getNearestSrcSpan :: SrcSpan -> SrcSpan -> SrcSpan -getNearestSrcSpan (SpanEmpty) s = s -getNearestSrcSpan s _ = s - - --- Takes the parse tree representation of an array literal, deals with elisions at the start of the --- array, then processes what's left. -processArray :: [JSNode] -> [[JSNode]] -> SrcSpan -> [[JSNode]] -processArray [] current _ = current -processArray ((NS (JSElision es) srcSpan):rest) current nearestSpan = - processArray - rest - (current ++ [[NS (JSIdentifier "undefined") (getNearestSrcSpan srcSpan nearestSpan)]]) - (getNearestSrcSpan srcSpan nearestSpan) -processArray jsa current nearestSpan = (arrayGetElements jsa current nearestSpan) - - --- Process the remainder an array literal after any leading commas have been processed. --- FIXME: Try to improve source spans. -arrayGetElements :: [JSNode] -> [[JSNode]] -> SrcSpan -> [[JSNode]] --- Ignore one trailing comma at the end of the array. -arrayGetElements [(NS (JSLiteral ",") _)] current _ = current --- A single elision at the end of the parsed array occurs when there are two commas at the end of --- the array or when the array is equal to [,] -arrayGetElements [(NS (JSElision e) srcSpan)] current nearestSpan = - current ++ [[(NS (JSIdentifier "undefined") (getNearestSrcSpan srcSpan nearestSpan))]] -arrayGetElements [item] current nearestSpan = current ++ [[item]] --- Two elisions in a row (that aren't at the beginning of the array) indicates one undefined entry, --- then a comma seperator, then the next entry. -arrayGetElements ((NS (JSElision _) srcSpan1):(NS (JSElision e) srcSpan2):rest) current nearestSpan = - arrayGetElements - ((NS (JSElision e) srcSpan2):rest) - (current - ++ [[NS (JSIdentifier "undefined") (getNearestSrcSpan srcSpan1 nearestSpan)]]) - (getNearestSrcSpan srcSpan1 nearestSpan) --- One elision and then a non-elision entry indicates a comma seperator and then the entry. -arrayGetElements ((NS (JSElision _) srcSpan):rest) current nearestSpan = - arrayGetElements rest current (getNearestSrcSpan srcSpan nearestSpan) -arrayGetElements (jsn:rest) current nearestSpan = - arrayGetElements - rest - (current ++ [[jsn]]) - (getNearestSrcSpan (jsnGetSource jsn) nearestSpan) + +processLeadingElisions :: [JSNode] -> SrcSpan -> [[JSNode]] +processLeadingElisions arr nearestSpan = + [[NS (JSIdentifier "undefined") nearestSpan] | el <- (takeWhile isElision arr)] + + +processTail :: [JSNode] -> SrcSpan -> [[JSNode]] +processTail [] _ = [] +processTail arr nearestSpan = + filter (not . null) (processTailElisions (groupBy equateElisions arr) nearestSpan) + where + equateElisions :: JSNode -> JSNode -> Bool + equateElisions l r + | (isElision l) && (isElision r) = True + | (not $ isElision l) && (not $ isElision r) = True + | otherwise = False + +-- Delete one elision per group of elisions, except at the end of the array. +-- Then break the groups of elisions up into singleton lists, and replace +-- elisions with undefineds. +-- +-- [[a, b], [EL, EL, EL], [c], [EL]] -> [[a, b], [UD], [UD], [c], [UD]] +processTailElisions :: [[JSNode]] -> SrcSpan -> [[JSNode]] +processTailElisions [ls] ns = + if (isElision $ head ls) + then [[NS (JSIdentifier "undefined") ns] | el <- ls] + else [ls] +processTailElisions (ls:others) ns = + if (isElision $ head ls) + then + [[NS (JSIdentifier "undefined") ns] | el <- drop 1 ls] + ++ (processTailElisions others ns) + else [ls] ++ (processTailElisions others (jsnGetSource $ last ls)) -- Takes a Node that represents a literal value and makes an AST node for that value. -toJSASTValue :: JSNode -> Value -toJSASTValue (NS (JSArrayLiteral arr) srcSpan) = +toASTValue :: JSNode -> Value +toASTValue (NS (JSArrayLiteral arr) srcSpan) = + -- We call listToASTExpression on the sublists of the output from processArray because a + -- sublist of the parsed array isn't necessarily a sublist of the actual array (in the JS + -- source code). For example + -- + -- [y = 10, 3]; + -- + -- Produces + -- + -- JSArrayLiteral + -- [ + -- JSIdentifier \"y\", + -- JSOperator \"=\", + -- JSDecimal \"10\", + -- JSElision [], + -- JSDecimal \"3\" + -- ] + -- + -- Which is processed to + -- TODO: Check this. + -- [[JSIdentifier \"y\", JSOperator \"=\", JSDecimal \"10\"], [JSDecimal \"3\"]] JSArray - (map listToJSASTExpression (processArray arr [] srcSpan)) -toJSASTValue (NS (JSDecimal s) _) = - if elem '.' s then - JSFloat (read s) - else - JSInt (read s) -toJSASTValue (NS (JSLiteral "false") _) = JSBool False -toJSASTValue (NS (JSLiteral "true") _) = JSBool True --- TODO: Refactor this? (already done once but still kinda crazy) -toJSASTValue (NS (JSObjectLiteral list) _) = - JSObject - (map toJSASTPropNameValue list) - where - -- Takes a JSNode that represents a property of an object and produdes a PropNameValue - -- Expression. - toJSASTPropNameValue :: JSNode -> ExprWithSourceSpan - toJSASTPropNameValue - (NS (JSPropertyNameandValue (NS (JSIdentifier name) _) value) srcSpan) = - EWSS - (PropNameValue - (VariableProperty name) - (listToJSASTExpression value)) - srcSpan - toJSASTPropNameValue - (NS (JSPropertyNameandValue (NS (JSDecimal index) _) value) srcSpan) = - EWSS - (PropNameValue - (IndexProperty (read index)) - (listToJSASTExpression value)) - srcSpan -toJSASTValue (NS (JSStringLiteral '"' s) _) = JSDQString s -toJSASTValue (NS (JSStringLiteral _ s) _) = JSString s - - -makeJSASTExpression :: JSNode -> ExprWithSourceSpan -makeJSASTExpression (NS (JSArguments args) srcSpan) = - toJSASTArguments args srcSpan -makeJSASTExpression (NS (JSExpressionBinary operator left right) srcSpan) = - EWSS - (Binary - operator - (listToJSASTExpression left) - (listToJSASTExpression right)) - srcSpan -makeJSASTExpression (NS (JSExpressionParen expr) srcSpan) = - EWSS - (ParenExpression - (jsnToListExp expr)) - srcSpan -makeJSASTExpression (NS (JSExpressionPostfix operator variable) srcSpan) = - EWSS - (UnaryPost - operator - (listToJSASTExpression variable)) - srcSpan -makeJSASTExpression (NS (JSExpressionTernary expr ifTrue ifFalse) srcSpan) = - EWSS - (Ternary - (listToJSASTExpression expr) - (listToJSASTExpression ifTrue) - (listToJSASTExpression ifFalse)) - srcSpan -makeJSASTExpression (NS (JSFunctionExpression [] args body) srcSpan) = - EWSS - (FunctionExpression - Nothing - (map (identifierGetString . jsnGetNode) args) - (AWSS (FunctionBody (toJSAST body)) (jsnGetSource body))) - srcSpan -makeJSASTExpression (NS (JSFunctionExpression [name] args body) srcSpan) = - EWSS - (FunctionExpression - (Just $ identifierGetString $ jsnGetNode name) - (map (identifierGetString . jsnGetNode) args) - (AWSS (FunctionBody (toJSAST body)) (jsnGetSource body))) - srcSpan -makeJSASTExpression (NS (JSIdentifier "undefined") srcSpan) = - EWSS (Value JSUndefined) srcSpan -makeJSASTExpression (NS (JSIdentifier identifier) srcSpan) = - EWSS (Identifier identifier) srcSpan -makeJSASTExpression (NS (JSLiteral "null") srcSpan) = - EWSS (Value JSNull) srcSpan -makeJSASTExpression (NS (JSLiteral "this") srcSpan) = - EWSS (Identifier "this") srcSpan -makeJSASTExpression (NS (JSMemberDot pre post) srcSpan) = - EWSS - (Reference - (listToJSASTExpression pre) - (makeJSASTExpression post)) - srcSpan -makeJSASTExpression (NS (JSMemberSquare pre post) srcSpan) = - EWSS - (Index - (listToJSASTExpression pre) - (jsnToListExp post)) - srcSpan --- Anything left unmatched here is assumed to be a literal value. -makeJSASTExpression val = - EWSS (Value (toJSASTValue val)) (jsnGetSource val) + (map listToASTExpression (processArray arr srcSpan)) +toASTValue (NS (JSDecimal s) _) = + if elem '.' s + then + JSFloat (read s) + else + JSInt (read s) +toASTValue (NS (JSLiteral "false") _) = JSBool False +toASTValue (NS (JSLiteral "true") _) = JSBool True +-- FIXME: Can there ever be semicolons in the list? +toASTValue (NS (JSObjectLiteral list) _) = JSObject (map toAST (filterSemicolons list)) +toASTValue (NS (JSStringLiteral '"' s) _) = JSDQString s +toASTValue (NS (JSStringLiteral _ s) _) = JSString s diff --git a/PrettyPrint.hs b/PrettyPrint.hs index c4e0d05..d0552ee 100644 --- a/PrettyPrint.hs +++ b/PrettyPrint.hs @@ -20,16 +20,16 @@ -- Top level functions are: -- -- mapPrintASTWS - -- (jsastListWSMakeSourceFragments - -- (getJSASTWithSource (parseTree program file) file) + -- (astListWSMakeSourceFragments + -- (getASTWithSource (parseTree program file) file) -- span) -- padding -- printSrc -- -- mapPrintASTChild -- (label --- jsastListWSMakeSourceFragments --- (getJSASTWithSource (parseTree program file) file) +-- (astListWSMakeSourceFragments +-- (getASTWithSource (parseTree program file) file) -- span)) -- padding -- printSrc @@ -49,7 +49,7 @@ -- -- TODO: -- ParseJS.parseTree (JSNode) --- ParseJS.getJSASTWithSource (JSASTWithSource*Span*) +-- ParseJS.getASTWithSource (ASTWithSource*Span*) -- DeclarationGraph.getDeclarationGraph (FunctionRules) - Might not be useful. -- DeclarationGraph.graphGetAllRules (Rule Type Type Maybe SourceFragment) would -- look better with pretty-printed Types. @@ -57,8 +57,8 @@ module PrettyPrint ( makeIndent -, mapPrintASTWS -, mapPrintASTChild +, printASTChild +, printASTWS , printCleanedElementList , printCleanedRulesList , printParseTreeStripped @@ -69,7 +69,7 @@ module PrettyPrint import Data.Char import Data.List import DeclarationGraph -import LabelJSAST +import LabelAST import Language.JavaScript.Parser import ParseJS import ResolveSourceFragments @@ -77,7 +77,7 @@ import System.Environment import TypeRules --- TODO: Consider turn combinations of these into macros, to make function calls less confusing. +-- TODO: Consider turning combinations of these into macros, to make function calls less confusing. type SourceFlag = Bool type LabFlag = Bool type LineFlag = Bool @@ -87,12 +87,12 @@ makeIndent :: String -> String makeIndent s = s ++ "..." -printStrAndLabel :: String -> JSASTLabel -> LabFlag -> IO() +printStrAndLabel :: String -> ASTLabel -> LabFlag -> IO() printStrAndLabel str lab False = putStr str printStrAndLabel str lab True = putStr (str ++ " <" ++ (show lab) ++ ">") -printLnStrAndLabel :: String -> JSASTLabel -> LabFlag -> IO() +printLnStrAndLabel :: String -> ASTLabel -> LabFlag -> IO() printLnStrAndLabel str lab printLab = do printStrAndLabel str lab printLab putStrLn "" @@ -241,45 +241,56 @@ mapPrintASTChild children padding printSrc printLab = printChild c = printASTChild c padding printSrc printLab +-- FIXME: Print the "Just". See maybePrintVarChild +maybePrintASTChild :: Maybe ASTChild -> String -> SourceFlag -> LabFlag -> IO() +maybePrintASTChild (Just expr) padding printSrc printLab = + printASTChild expr padding printSrc printLab +-- FIXME: Nothings have no label. Is that a problem? +-- TODO: Print the source fragment +maybePrintASTChild Nothing padding _ _ = putStrLn (padding ++ " Nothing") + + -- TODO: Still need to do: +-- LabBreak (Maybe VarChild) +-- LabContinue (Maybe VarChild) -- LabDefault ASTChild --- LabDoWhile ASTChild ExprChild +-- LabDoWhile ASTChild ASTChild -- LabFinally ASTChild --- LabFor (Maybe ExprChild) (Maybe ExprChild) (Maybe ExprChild) ASTChild --- LabForIn [VarChild] ExprChild ASTChild +-- LabFor (Maybe ASTChild) (Maybe ASTChild) (Maybe ASTChild) ASTChild +-- LabForIn [VarChild] ASTChild ASTChild -- LabLabelled VarChild ASTChild printASTChild :: ASTChild -> String -> SourceFlag -> LabFlag -> IO() printASTChild ((LabBlock children), lab, sourceFragment) padding printSrc printLab = do printLnStrAndLabel (padding ++ " LabBlock") lab printLab printSource sourceFragment padding printSrc - mapPrintASTChild children (makeIndent padding) printSrc printLab + printASTChild children (makeIndent padding) printSrc printLab printASTChild ((LabCase val child), lab, sourceFragment) padding printSrc printLab = do printLnStrAndLabel (padding ++ " LabCase") lab printLab printSource sourceFragment padding printSrc let p = makeIndent padding - printExprChild val p printSrc printLab + printASTChild val p printSrc printLab printASTChild child p printSrc printLab printASTChild ((LabCatch var expr child), lab, sourceFragment) padding printSrc printLab = do printLnStrAndLabel (padding ++ " LabCatch") lab printLab printSource sourceFragment padding printSrc let p = makeIndent padding printVarChild var p printLab True - maybePrintExprChild expr p printSrc printLab + maybePrintASTChild expr p printSrc printLab printASTChild child p printSrc printLab printASTChild ((LabForVar decs cond expr child), lab, sourceFragment) padding printSrc printLab = do printLnStrAndLabel (padding ++ " LabForVar") lab printLab printSource sourceFragment padding printSrc let p = makeIndent padding - mapPrintExprChild decs p printSrc printLab - maybePrintExprChild cond p printSrc printLab - maybePrintExprChild expr p printSrc printLab + mapPrintASTChild decs p printSrc printLab + maybePrintASTChild cond p printSrc printLab + maybePrintASTChild expr p printSrc printLab printASTChild child p printSrc printLab printASTChild ((LabForVarIn var obj child), lab, sourceFragment) padding printSrc printLab = do printLnStrAndLabel (padding ++ " LabForVarIn") lab printLab printSource sourceFragment padding printSrc let p = makeIndent padding - printExprChild var p printSrc printLab - printExprChild obj p printSrc printLab + printASTChild var p printSrc printLab + printASTChild obj p printSrc printLab printASTChild child p printSrc printLab printASTChild ((LabFunctionBody children), lab, sourceFragment) padding printSrc printLab = do printLnStrAndLabel (padding ++ " LabFunctionBody") lab printLab @@ -297,28 +308,28 @@ printASTChild ((LabIf cond child), lab, sourceFragment) padding printSrc printLa printLnStrAndLabel (padding ++ " LabIf") lab printLab printSource sourceFragment padding printSrc let p = makeIndent padding - printExprChild cond p printSrc printLab + printASTChild cond p printSrc printLab printASTChild child p printSrc printLab printASTChild ((LabIfElse cond childTrue childFalse), lab, sourceFragment) padding printSrc printLab = do printLnStrAndLabel (padding ++ " LabIfElse") lab printLab printSource sourceFragment padding printSrc let p = makeIndent padding - printExprChild cond p printSrc printLab + printASTChild cond p printSrc printLab printASTChild childTrue p printSrc printLab printASTChild childFalse p printSrc printLab printASTChild ((LabReturn expr), lab, sourceFragment) padding printSrc printLab = do printLnStrAndLabel (padding ++ " LabReturn") lab printLab printSource sourceFragment padding printSrc - printExprChild expr (makeIndent padding) printSrc printLab + printASTChild expr (makeIndent padding) printSrc printLab printASTChild ((LabStatement expr), lab, sourceFragment) padding printSrc printLab = do printLnStrAndLabel (padding ++ " LabStatement") lab printLab printSource sourceFragment padding printSrc - printExprChild expr (makeIndent padding) printSrc printLab + printASTChild expr (makeIndent padding) printSrc printLab printASTChild ((LabSwitch var child), lab, sourceFragment) padding printSrc printLab = do printLnStrAndLabel (padding ++ " LabSwitch") lab printLab printSource sourceFragment padding printSrc let p = makeIndent padding - printExprChild var p printSrc printLab + printASTChild var p printSrc printLab printASTChild child p printSrc printLab printASTChild ((LabTry tryChild catchChild), lab, sourceFragment) padding printSrc printLab = do printLnStrAndLabel (padding ++ " LabTry") lab printLab @@ -330,57 +341,40 @@ printASTChild ((LabWhile cond child), lab, sourceFragment) padding printSrc prin printLnStrAndLabel (padding ++ " LabWhile") lab printLab printSource sourceFragment padding printSrc let p = makeIndent padding - printExprChild cond p printSrc printLab + printASTChild cond p printSrc printLab printASTChild child p printSrc printLab -printASTChild (n, lab, sourceFragment) padding printSrc printLab = do - printLnStrAndLabel (padding ++ " OTHER ASTCHILD") lab printLab - printSource sourceFragment padding printSrc - putStrLn ((makeIndent padding) ++ " " ++ (show n)) - - -mapPrintExprChild :: [ExprChild] -> String -> SourceFlag -> LabFlag -> IO() -mapPrintExprChild children padding printSrc printLab = - mapM_ printChild children - where - printChild c = printExprChild c padding printSrc printLab - - --- TODO: Still need to do --- LabBreak (Maybe VarChild) --- LabContinue (Maybe VarChild) -printExprChild :: ExprChild -> String -> SourceFlag -> LabFlag -> IO() -printExprChild ((LabArguments exprs), lab, sourceFragment) padding printSrc printLab = do +printASTChild ((LabArguments exprs), lab, sourceFragment) padding printSrc printLab = do printLnStrAndLabel (padding ++ " LabArguments") lab printLab printSource sourceFragment padding printSrc - mapPrintExprChild exprs (makeIndent padding) printSrc printLab -printExprChild ((LabAssignment op expr1 expr2), lab, sourceFragment) padding printSrc printLab = do + mapPrintASTChild exprs (makeIndent padding) printSrc printLab +printASTChild ((LabAssignment op expr1 expr2), lab, sourceFragment) padding printSrc printLab = do printLnStrAndLabel (padding ++ " LabAssignment") lab printLab printSource sourceFragment padding printSrc let p = makeIndent padding printOpChild op p printLab True - printExprChild expr1 p printSrc printLab - printExprChild expr2 p printSrc printLab -printExprChild ((LabBinary op expr1 expr2), lab, sourceFragment) padding printSrc printLab = do + printASTChild expr1 p printSrc printLab + printASTChild expr2 p printSrc printLab +printASTChild ((LabBinary op expr1 expr2), lab, sourceFragment) padding printSrc printLab = do printLnStrAndLabel (padding ++ " LabBinary") lab printLab printSource sourceFragment padding printSrc let p = makeIndent padding printOpChild op p printLab True - printExprChild expr1 p printSrc printLab - printExprChild expr2 p printSrc printLab -printExprChild ((LabCall fid args), lab, sourceFragment) padding printSrc printLab = do + printASTChild expr1 p printSrc printLab + printASTChild expr2 p printSrc printLab +printASTChild ((LabCall fid args), lab, sourceFragment) padding printSrc printLab = do printLnStrAndLabel (padding ++ " LabCall") lab printLab printSource sourceFragment padding printSrc let p = makeIndent padding - printExprChild fid p printSrc printLab - printExprChild args p printSrc printLab -printExprChild ((LabCallExpression call op expr), lab, sourceFragment) padding printSrc printLab = do + printASTChild fid p printSrc printLab + printASTChild args p printSrc printLab +printASTChild ((LabCallExpression call op expr), lab, sourceFragment) padding printSrc printLab = do printLnStrAndLabel (padding ++ " LabCallExpression") lab printLab printSource sourceFragment padding printSrc let p = makeIndent padding - printExprChild call p printSrc printLab + printASTChild call p printSrc printLab printOpChild op p printLab True - printExprChild expr p printSrc printLab -printExprChild ((LabFunctionExpression vChild args child), lab, sourceFragment) padding printSrc printLab = do + printASTChild expr p printSrc printLab +printASTChild ((LabFunctionExpression vChild args child), lab, sourceFragment) padding printSrc printLab = do printStrAndLabel (padding ++ " LabFunctionExpression") lab printLab maybePrintVarChild vChild "" printLab False putStr " [" @@ -388,98 +382,89 @@ printExprChild ((LabFunctionExpression vChild args child), lab, sourceFragment) putStrLn " ]" printSource sourceFragment padding printSrc printASTChild child (makeIndent padding) printSrc printLab -printExprChild ((LabIdentifier var), lab, sourceFragment) padding printSrc printLab = do +printASTChild ((LabIdentifier var), lab, sourceFragment) padding printSrc printLab = do printStrAndLabel (padding ++ " LabIdentifier") lab printLab printVarChild var "" printLab True printSource sourceFragment padding printSrc -printExprChild ((LabIndex obj prop), lab, sourceFragment) padding printSrc printLab = do +printASTChild ((LabIndex obj prop), lab, sourceFragment) padding printSrc printLab = do printLnStrAndLabel (padding ++ " LabIndex") lab printLab printSource sourceFragment padding printSrc let p = makeIndent padding - printExprChild obj p printSrc printLab - printExprChild prop p printSrc printLab -printExprChild ((LabList exprs), lab, sourceFragment) padding printSrc printLab = do + printASTChild obj p printSrc printLab + printASTChild prop p printSrc printLab +printASTChild ((LabList exprs), lab, sourceFragment) padding printSrc printLab = do printLnStrAndLabel (padding ++ " LabList") lab printLab printSource sourceFragment padding printSrc - mapPrintExprChild exprs (makeIndent padding) printSrc printLab -printExprChild ((LabNew cons), lab, sourceFragment) padding printSrc printLab = do + mapPrintASTChild exprs (makeIndent padding) printSrc printLab +printASTChild ((LabNew cons), lab, sourceFragment) padding printSrc printLab = do printLnStrAndLabel (padding ++ " LabNew") lab printLab printSource sourceFragment padding printSrc let p = makeIndent padding - printExprChild cons p printSrc printLab -printExprChild ((LabParenExpression child), lab, sourceFragment) padding printSrc printLab = do + printASTChild cons p printSrc printLab +printASTChild ((LabParenExpression child), lab, sourceFragment) padding printSrc printLab = do printLnStrAndLabel (padding ++ " LabParenExpression") lab printLab printSource sourceFragment padding printSrc - printExprChild child (makeIndent padding) printSrc printLab -printExprChild ((LabPropNameValue prop expr), lab, sourceFragment) padding printSrc printLab = do + printASTChild child (makeIndent padding) printSrc printLab +printASTChild ((LabPropNameValue prop expr), lab, sourceFragment) padding printSrc printLab = do printLnStrAndLabel (padding ++ " LabPropNameValue") lab printLab printSource sourceFragment padding printSrc let p = makeIndent padding printPropertyNameChild prop p printLab - printExprChild expr p printSrc printLab -printExprChild ((LabReference obj prop), lab, sourceFragment) padding printSrc printLab = do + printASTChild expr p printSrc printLab +printASTChild ((LabReference obj prop), lab, sourceFragment) padding printSrc printLab = do printLnStrAndLabel (padding ++ " LabReference") lab printLab printSource sourceFragment padding printSrc let p = makeIndent padding - printExprChild obj p printSrc printLab - printExprChild prop p printSrc printLab -printExprChild ((LabTernary cond exprTrue exprFalse), lab, sourceFragment) padding printSrc printLab = do + printASTChild obj p printSrc printLab + printASTChild prop p printSrc printLab +printASTChild ((LabTernary cond exprTrue exprFalse), lab, sourceFragment) padding printSrc printLab = do printLnStrAndLabel (padding ++ " LabTernary") lab printLab printSource sourceFragment padding printSrc let p = makeIndent padding - printExprChild cond p printSrc printLab - printExprChild exprTrue p printSrc printLab - printExprChild exprFalse p printSrc printLab -printExprChild ((LabThrow child), lab, sourceFragment) padding printSrc printLab = do + printASTChild cond p printSrc printLab + printASTChild exprTrue p printSrc printLab + printASTChild exprFalse p printSrc printLab +printASTChild ((LabThrow child), lab, sourceFragment) padding printSrc printLab = do printLnStrAndLabel (padding ++ " LabThrow") lab printLab printSource sourceFragment padding printSrc let p = makeIndent padding - printExprChild child p printSrc printLab -printExprChild ((LabUnaryPost op expr), lab, sourceFragment) padding printSrc printLab = do + printASTChild child p printSrc printLab +printASTChild ((LabUnaryPost op expr), lab, sourceFragment) padding printSrc printLab = do printLnStrAndLabel (padding ++ " LabUnaryPost") lab printLab printSource sourceFragment padding printSrc let p = makeIndent padding printOpChild op p printLab True - printExprChild expr p printSrc printLab -printExprChild ((LabUnaryPre op expr), lab, sourceFragment) padding printSrc printLab = do + printASTChild expr p printSrc printLab +printASTChild ((LabUnaryPre op expr), lab, sourceFragment) padding printSrc printLab = do printLnStrAndLabel (padding ++ " LabUnaryPre") lab printLab printSource sourceFragment padding printSrc let p = makeIndent padding printOpChild op p printLab True - printExprChild expr p printSrc printLab -printExprChild ((LabValue (LabObject props, objLab)), lab, sourceFragment) padding printSrc printLab = do + printASTChild expr p printSrc printLab +printASTChild ((LabValue (LabObject props, objLab)), lab, sourceFragment) padding printSrc printLab = do printLnStrAndLabel (padding ++ " LabValue") lab printLab printSource sourceFragment padding printSrc printValueChild (LabObject props, objLab) (makeIndent padding) printSrc printLab True -printExprChild ((LabValue (LabArray elems, arLab)), lab, sourceFragment) padding printSrc printLab = do +printASTChild ((LabValue (LabArray elems, arLab)), lab, sourceFragment) padding printSrc printLab = do printLnStrAndLabel (padding ++ " LabValue") lab printLab printSource sourceFragment padding printSrc printValueChild (LabArray elems, arLab) (makeIndent padding) printSrc printLab True -printExprChild ((LabValue val), lab, sourceFragment) padding printSrc printLab = do +printASTChild ((LabValue val), lab, sourceFragment) padding printSrc printLab = do printStrAndLabel (padding ++ " LabValue") lab printLab printValueChild val (makeIndent padding) printSrc printLab True printSource sourceFragment padding printSrc -printExprChild ((LabVarDeclaration var expr), lab, sourceFragment) padding printSrc printLab = do +printASTChild ((LabVarDeclaration var expr), lab, sourceFragment) padding printSrc printLab = do printLnStrAndLabel (padding ++ " LabVarDeclaration") lab printLab printSource sourceFragment padding printSrc let p = makeIndent padding printVarChild var p printLab True - maybePrintExprChild expr p printSrc printLab -printExprChild (n, lab, sourceFragment) padding printSrc printLab = do - printLnStrAndLabel (padding ++ " OTHER EXPRCHILD") lab printLab + maybePrintASTChild expr p printSrc printLab +printASTChild (n, lab, sourceFragment) padding printSrc printLab = do + printLnStrAndLabel (padding ++ " OTHER ASTCHILD") lab printLab printSource sourceFragment padding printSrc putStrLn ((makeIndent padding) ++ " " ++ (show n)) --- FIXME: Print the "Just". See maybePrintVarChild -maybePrintExprChild :: Maybe ExprChild -> String -> SourceFlag -> LabFlag -> IO() -maybePrintExprChild (Just expr) padding printSrc printLab = - printExprChild expr padding printSrc printLab --- FIXME: Nothings have no label. Is that a problem? --- TODO: Print the source fragment -maybePrintExprChild Nothing padding _ _ = putStrLn (padding ++ " Nothing") - - mapPrintVarChild :: [VarChild] -> String -> LabFlag -> LineFlag -> IO() mapPrintVarChild children padding printLab printLine = mapM_ printChild children @@ -487,13 +472,6 @@ mapPrintVarChild children padding printLab printLine = printChild c = printVarChild c padding printLab printLine -printVarChild :: VarChild -> String -> LabFlag -> LineFlag -> IO() -printVarChild (var, lab) padding printLab True = - printLnStrAndLabel (padding ++ " \"" ++ var ++ "\"") lab printLab -printVarChild (var, lab) padding printLab False = - printStrAndLabel (padding ++ " \"" ++ var ++ "\"") lab printLab - - maybePrintVarChild :: Maybe VarChild -> String -> LabFlag -> LineFlag -> IO() maybePrintVarChild (Just var) padding printLab False = do putStr (padding ++ " Just") @@ -508,6 +486,13 @@ maybePrintVarChild Nothing padding printLab True = putStrLn (padding ++ " \"Nothing\"") +printVarChild :: VarChild -> String -> LabFlag -> LineFlag -> IO() +printVarChild (var, lab) padding printLab True = + printLnStrAndLabel (padding ++ " \"" ++ var ++ "\"") lab printLab +printVarChild (var, lab) padding printLab False = + printStrAndLabel (padding ++ " \"" ++ var ++ "\"") lab printLab + + printIndexChild :: IndexChild -> String -> LabFlag -> LineFlag -> IO() printIndexChild (index, lab) padding printLab True = printLnStrAndLabel (padding ++ " \"" ++ (show index) ++ "\"") lab printLab @@ -543,7 +528,7 @@ printLabelledValue (LabArray elems) padding printSrc printLab False = do -- TODO: Print the source? let p = makeIndent padding putStrLn (p ++ " [") - mapPrintExprChild elems p printSrc printLab + mapPrintASTChild elems p printSrc printLab putStr (p ++ " ]") printLabelledValue (LabBool val) padding _ _ False = putStr (" LabBool " ++ (show val)) @@ -558,7 +543,7 @@ printLabelledValue (LabNull) padding _ _ False = printLabelledValue (LabObject exprs) padding printSrc printLab _ = do putStrLn (padding ++ " LabObject") -- TODO: Print the source? - mapPrintExprChild exprs (makeIndent padding) printSrc printLab + mapPrintASTChild exprs (makeIndent padding) printSrc printLab printLabelledValue (LabString val) padding _ _ False = putStr (" LabString " ++ (show val)) printLabelledValue (LabUndefined) padding _ _ False = @@ -577,7 +562,7 @@ printSource sourceFragment padding printSrc = else return() -mapPrintASTWS :: [JSASTWithSourceFragment] -> String -> SourceFlag -> IO() +mapPrintASTWS :: [ASTWithSourceFragment] -> String -> SourceFlag -> IO() mapPrintASTWS [] padding _ = putStrLn (padding ++ " []") mapPrintASTWS nodes padding printSrc = @@ -586,45 +571,55 @@ mapPrintASTWS nodes padding printSrc = printAST n = printASTWS n padding printSrc +-- FIXME: Print the "Just". See maybePrintVarChild +maybePrintASTWS :: Maybe ASTWithSourceFragment -> String -> SourceFlag -> IO() +maybePrintASTWS (Just expr) padding printSrc = + printASTWS expr padding printSrc +maybePrintASTWS Nothing padding _ = putStrLn (padding ++ " Nothing") + + +-- TODO: Remove all use of printLnStrAndLabel/printStrAndLabel. -- TODO: Still need to do: --- WSDefault JSASTWithSourceFragment --- WSDoWhile JSASTWithSourceFragment ExprWithSourceFragment --- WSFinally JSASTWithSourceFragment --- WSFor (Maybe ExprWithSourceFragment) (Maybe ExprWithSourceFragment) (Maybe ExprWithSourceFragment) JSASTWithSourceFragment --- WSForIn [Variable] ExprWithSourceFragment JSASTWithSourceFragment --- WSLabelled Variable JSASTWithSourceFragment -printASTWS :: JSASTWithSourceFragment -> String -> SourceFlag -> IO() +-- WSBreak (Maybe Variable) +-- WSContinue (Maybe Variable) +-- WSDefault ASTWithSourceFragment +-- WSDoWhile ASTWithSourceFragment ASTWithSourceFragment +-- WSFinally ASTWithSourceFragment +-- WSFor (Maybe ASTWithSourceFragment) (Maybe ASTWithSourceFragment) (Maybe ASTWithSourceFragment) ASTWithSourceFragment +-- WSForIn [Variable] ASTWithSourceFragment ASTWithSourceFragment +-- WSLabelled Variable ASTWithSourceFragment +printASTWS :: ASTWithSourceFragment -> String -> SourceFlag -> IO() printASTWS (AWSF (WSBlock list) sourceFragment) padding printSrc = do putStrLn (padding ++ " Block") printSource sourceFragment padding printSrc - mapPrintASTWS list (makeIndent padding) printSrc + printASTWS list (makeIndent padding) printSrc printASTWS (AWSF (WSCase val body) sourceFragment) padding printSrc = do putStrLn (padding ++ " Case") printSource sourceFragment padding printSrc let p = makeIndent padding - printExprWS val p printSrc + printASTWS val p printSrc printASTWS body p printSrc printASTWS (AWSF (WSCatch var expr body) sourceFragment) padding printSrc = do putStrLn (padding ++ " Catch") printSource sourceFragment padding printSrc let p = makeIndent padding printVariable var p True - maybePrintExprWS expr p printSrc + maybePrintASTWS expr p printSrc printASTWS body p printSrc printASTWS (AWSF (WSForVar decs cond expr body) sourceFragment) padding printSrc = do putStrLn (padding ++ " ForVar") printSource sourceFragment padding printSrc let p = makeIndent padding - mapPrintExprWS decs p printSrc - maybePrintExprWS cond p printSrc - maybePrintExprWS expr p printSrc + mapPrintASTWS decs p printSrc + maybePrintASTWS cond p printSrc + maybePrintASTWS expr p printSrc printASTWS body p printSrc printASTWS (AWSF (WSForVarIn var obj body) sourceFragment) padding printSrc = do putStrLn (padding ++ " ForVarIn") printSource sourceFragment padding printSrc let p = makeIndent padding - printExprWS var p printSrc - printExprWS obj p printSrc + printASTWS var p printSrc + printASTWS obj p printSrc printASTWS body p printSrc printASTWS (AWSF (WSFunctionBody list) sourceFragment) padding printSrc = do putStrLn (padding ++ " FunctionBody") @@ -642,93 +637,77 @@ printASTWS (AWSF (WSIf cond body) sourceFragment) padding printSrc = do putStrLn (padding ++ " If") printSource sourceFragment padding printSrc let p = makeIndent padding - printExprWS cond p printSrc + printASTWS cond p printSrc printASTWS body p printSrc printASTWS (AWSF (WSIfElse cond bodyTrue bodyFalse) sourceFragment) padding printSrc = do putStrLn (padding ++ " IfElse") printSource sourceFragment padding printSrc let p = makeIndent padding - printExprWS cond p printSrc + printASTWS cond p printSrc printASTWS bodyTrue p printSrc printASTWS bodyFalse p printSrc printASTWS (AWSF (WSReturn expr) sourceFragment) padding printSrc = do putStrLn (padding ++ " Return") printSource sourceFragment padding printSrc - printExprWS expr (makeIndent padding) printSrc + printASTWS expr (makeIndent padding) printSrc printASTWS (AWSF (WSStatement expr) sourceFragment) padding printSrc = do putStrLn (padding ++ " Statement") printSource sourceFragment padding printSrc - printExprWS expr (makeIndent padding) printSrc + printASTWS expr (makeIndent padding) printSrc printASTWS (AWSF (WSSwitch var body) sourceFragment) padding printSrc = do putStrLn (padding ++ " Switch") printSource sourceFragment padding printSrc let p = makeIndent padding - printExprWS var p printSrc - printASTWS body p printSrc + printASTWS var p printSrc + mapPrintASTWS body p printSrc printASTWS (AWSF (WSTry tryBody catchBody) sourceFragment) padding printSrc = do putStrLn (padding ++ " Try") printSource sourceFragment padding printSrc let p = makeIndent padding printASTWS tryBody p printSrc - printASTWS catchBody p printSrc + mapPrintASTWS catchBody p printSrc printASTWS (AWSF (WSWhile cond body) sourceFragment) padding printSrc = do putStrLn (padding ++ " While") printSource sourceFragment padding printSrc let p = makeIndent padding - printExprWS cond p printSrc + printASTWS cond p printSrc printASTWS body p printSrc -printASTWS (AWSF node sourceFragment) padding printSrc = do - putStrLn (padding ++ " OTHER JSAST") - printSource sourceFragment padding printSrc - putStrLn ((makeIndent padding) ++ " " ++ (show node)) - - -mapPrintExprWS :: [ExprWithSourceFragment] -> String -> SourceFlag -> IO() -mapPrintExprWS [] padding _ = - putStrLn (padding ++ " []") -mapPrintExprWS exprs padding printSrc = - mapM_ printExpr exprs - where - printExpr e = printExprWS e padding printSrc - - --- TODO: Remove all use of printLnStrAndLabel/printStrAndLabel. --- TODO: Still need to do --- WSBreak (Maybe Variable) --- WSContinue (Maybe Variable) -printExprWS :: ExprWithSourceFragment -> String -> SourceFlag -> IO() -printExprWS (EWSF (WSArguments exprs) sourceFragment) padding printSrc = do +printASTWS (AWSF (WSArguments exprs) sourceFragment) padding printSrc = do putStrLn (padding ++ " Arguments") printSource sourceFragment padding printSrc - mapPrintExprWS exprs (makeIndent padding) printSrc -printExprWS (EWSF (WSAssignment op expr1 expr2) sourceFragment) padding printSrc = do + mapPrintASTWS exprs (makeIndent padding) printSrc +printASTWS (AWSF (WSAssignment op expr1 expr2) sourceFragment) padding printSrc = do putStrLn (padding ++ " Assignment") printSource sourceFragment padding printSrc let p = makeIndent padding printOperator op p True - printExprWS expr1 p printSrc - printExprWS expr2 p printSrc -printExprWS (EWSF (WSBinary op expr1 expr2) sourceFragment) padding printSrc = do + printASTWS expr1 p printSrc + printASTWS expr2 p printSrc +printASTWS (AWSF (WSBinary op expr1 expr2) sourceFragment) padding printSrc = do putStrLn (padding ++ " Binary") printSource sourceFragment padding printSrc let p = makeIndent padding printOperator op p True - printExprWS expr1 p printSrc - printExprWS expr2 p printSrc -printExprWS (EWSF (WSCall fid args) sourceFragment) padding printSrc = do + printASTWS expr1 p printSrc + printASTWS expr2 p printSrc +printASTWS (AWSF (WSCall fid args) sourceFragment) padding printSrc = do putStrLn (padding ++ " Call") printSource sourceFragment padding printSrc let p = makeIndent padding - printExprWS fid p printSrc - printExprWS args p printSrc -printExprWS (EWSF (WSCallExpression call op expr) sourceFragment) padding printSrc = do + printASTWS fid p printSrc + printASTWS args p printSrc +printASTWS (AWSF (WSCallExpression call op expr) sourceFragment) padding printSrc = do putStrLn (padding ++ " CallExpression") printSource sourceFragment padding printSrc let p = makeIndent padding - printExprWS call p printSrc + printASTWS call p printSrc printOperator op p True - printExprWS expr p printSrc -printExprWS (EWSF (WSFunctionExpression var args body) sourceFragment) padding printSrc = do + printASTWS expr p printSrc +printASTWS (AWSF (WSExpression exprs) sourceFragment) padding printSrc = do + putStrLn (padding ++ " Expression") + printSource sourceFragment padding printSrc + mapPrintASTWS exprs (makeIndent padding) printSrc +printASTWS (AWSF (WSFunctionExpression var args body) sourceFragment) padding printSrc = do putStr (padding ++ " FunctionExpression") maybePrintVariable var "" False putStr " [" @@ -736,86 +715,83 @@ printExprWS (EWSF (WSFunctionExpression var args body) sourceFragment) padding p putStrLn " ]" printSource sourceFragment padding printSrc printASTWS body (makeIndent padding) printSrc -printExprWS (EWSF (WSIdentifier var) sourceFragment) padding printSrc = do +printASTWS (AWSF (WSIdentifier var) sourceFragment) padding printSrc = do putStr (padding ++ " Identifier") printVariable var "" True printSource sourceFragment padding printSrc -printExprWS (EWSF (WSIndex obj prop) sourceFragment) padding printSrc = do +printASTWS (AWSF (WSIndex obj prop) sourceFragment) padding printSrc = do putStrLn (padding ++ " Index") printSource sourceFragment padding printSrc let p = makeIndent padding - printExprWS obj p printSrc - printExprWS prop p printSrc -printExprWS (EWSF (WSList exprs) sourceFragment) padding printSrc = do + printASTWS obj p printSrc + printASTWS prop p printSrc +printASTWS (AWSF (WSList exprs) sourceFragment) padding printSrc = do putStrLn (padding ++ " List") printSource sourceFragment padding printSrc - mapPrintExprWS exprs (makeIndent padding) printSrc -printExprWS (EWSF (WSNew cons) sourceFragment) padding printSrc = do + mapPrintASTWS exprs (makeIndent padding) printSrc +printASTWS (AWSF (WSNew cons) sourceFragment) padding printSrc = do putStrLn (padding ++ " New") printSource sourceFragment padding printSrc let p = makeIndent padding - printExprWS cons p printSrc -printExprWS (EWSF (WSParenExpression child) sourceFragment) padding printSrc = do + printASTWS cons p printSrc +printASTWS (AWSF (WSParenExpression child) sourceFragment) padding printSrc = do putStrLn (padding ++ " ParenExpression") printSource sourceFragment padding printSrc - printExprWS child (makeIndent padding) printSrc -printExprWS (EWSF (WSPropNameValue prop expr) sourceFragment) padding printSrc = do + printASTWS child (makeIndent padding) printSrc +printASTWS (AWSF (WSPropNameValue prop expr) sourceFragment) padding printSrc = do putStrLn (padding ++ " PropNameValue") printSource sourceFragment padding printSrc let p = makeIndent padding printPropertyName prop p - printExprWS expr p printSrc -printExprWS (EWSF (WSReference obj prop) sourceFragment) padding printSrc = do + printASTWS expr p printSrc +printASTWS (AWSF (WSReference obj prop) sourceFragment) padding printSrc = do putStrLn (padding ++ " Reference") printSource sourceFragment padding printSrc let p = makeIndent padding - printExprWS obj p printSrc - printExprWS prop p printSrc -printExprWS (EWSF (WSTernary cond exprTrue exprFalse) sourceFragment) padding printSrc = do + printASTWS obj p printSrc + printASTWS prop p printSrc +printASTWS (AWSF (WSStatementList exprs) sourceFragment) padding printSrc = do + putStrLn (padding ++ " StatementList") + printSource sourceFragment padding printSrc + mapPrintASTWS exprs (makeIndent padding) printSrc +printASTWS (AWSF (WSTernary cond exprTrue exprFalse) sourceFragment) padding printSrc = do putStrLn (padding ++ " Ternary") printSource sourceFragment padding printSrc let p = makeIndent padding - printExprWS cond p printSrc - printExprWS exprTrue p printSrc - printExprWS exprFalse p printSrc -printExprWS (EWSF (WSThrow child) sourceFragment) padding printSrc = do + printASTWS cond p printSrc + printASTWS exprTrue p printSrc + printASTWS exprFalse p printSrc +printASTWS (AWSF (WSThrow child) sourceFragment) padding printSrc = do putStrLn (padding ++ " Throw") printSource sourceFragment padding printSrc let p = makeIndent padding - printExprWS child p printSrc -printExprWS (EWSF (WSUnaryPost op expr) sourceFragment) padding printSrc = do + printASTWS child p printSrc +printASTWS (AWSF (WSUnaryPost op expr) sourceFragment) padding printSrc = do putStrLn (padding ++ " UnaryPost") printSource sourceFragment padding printSrc let p = makeIndent padding printOperator op p True - printExprWS expr p printSrc -printExprWS (EWSF (WSUnaryPre op expr) sourceFragment) padding printSrc = do + printASTWS expr p printSrc +printASTWS (AWSF (WSUnaryPre op expr) sourceFragment) padding printSrc = do putStrLn (padding ++ " UnaryPre") printSource sourceFragment padding printSrc let p = makeIndent padding printOperator op p True - printExprWS expr p printSrc -printExprWS (EWSF (WSValue val) sourceFragment) padding printSrc = do + printASTWS expr p printSrc +printASTWS (AWSF (WSValue val) sourceFragment) padding printSrc = do putStr (padding ++ " Value") printValueWS val (makeIndent padding) printSrc True printSource sourceFragment padding printSrc -printExprWS (EWSF (WSVarDeclaration var expr) sourceFragment) padding printSrc = do +printASTWS (AWSF (WSVarDeclaration var expr) sourceFragment) padding printSrc = do putStrLn (padding ++ " VarDeclaration") printSource sourceFragment padding printSrc let p = makeIndent padding printVariable var p True - maybePrintExprWS expr p printSrc -printExprWS (EWSF n sourceFragment) padding printSrc = do + maybePrintASTWS expr p printSrc +printASTWS (AWSF node sourceFragment) padding printSrc = do + putStrLn (padding ++ " OTHER AST") printSource sourceFragment padding printSrc - putStrLn (padding ++ " OTHER EXPRESSION") - putStrLn ((makeIndent padding) ++ " " ++ (show n)) - - --- FIXME: Print the "Just". See maybePrintVarChild -maybePrintExprWS :: Maybe ExprWithSourceFragment -> String -> SourceFlag -> IO() -maybePrintExprWS (Just expr) padding printSrc = - printExprWS expr padding printSrc -maybePrintExprWS Nothing padding _ = putStrLn (padding ++ " Nothing") + putStrLn ((makeIndent padding) ++ " " ++ (show node)) -- TODO: probably remove this. It doesn't do very much. @@ -883,7 +859,7 @@ printValueWS (WSArray elems) padding printSrc False = do putStrLn (padding ++ " Array") let p = makeIndent padding putStrLn (p ++ " [") - mapPrintExprWS elems p printSrc + mapPrintASTWS elems p printSrc putStr (p ++ " ]") printValueWS (WSBool val) padding _ False = putStr (" Bool " ++ (show val)) @@ -898,7 +874,7 @@ printValueWS (WSNull) padding _ False = printValueWS (WSObject exprs) padding printSrc _ = do putStrLn "" putStrLn (padding ++ " Object") - mapPrintExprWS exprs (makeIndent padding) printSrc + mapPrintASTWS exprs (makeIndent padding) printSrc printValueWS (WSString val) padding _ False = putStr (" String " ++ (show val)) printValueWS (WSUndefined) padding _ False = diff --git a/ResolveSourceFragments.hs b/ResolveSourceFragments.hs index 75dbc37..3d91edf 100644 --- a/ResolveSourceFragments.hs +++ b/ResolveSourceFragments.hs @@ -12,8 +12,6 @@ -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -- See the License for the specific language governing permissions and -- limitations under the License. --- Module takes a JSAST and gives each vertex a unique integer label. The label counter is simply --- threaded through the tree. Traversal is depth first. It's all fairly straight-forward. -- This module takes an AST containing SrcSpans from the original AST (output from @@ -28,20 +26,19 @@ -- run, so I doubt this issue will be a problem in real-world usage. -- -- Top level function is --- (jsastListWSMakeSourceFragments (getJSASTWithSource (parseTree program file) file) span) +-- (astListWSMakeSourceFragments (getASTWithSource (parseTree program file) file) span) module ResolveSourceFragments -( ExprWithSourceFragment(..) -, ExprWSF(..) -, JSASTWithSourceFragment(..) -, JSASTWSF(..) +( ASTWithSourceFragment(..) +, ASTWithSF(..) , SourceFragment(..) , ValueWithSourceFragment(..) -, jsastListWSMakeSourceFragments -, jsastMakeSourceFragment +, astWSMakeSourceFragment +, astMakeSourceFragment ) where +import Control.Monad.State import Language.JavaScript.Parser import ParseJS import System.Environment @@ -53,107 +50,109 @@ type Col = Int -- (FileName, StartRow, StartCol, EndRow, EndCol) type SourceFragment = (String, Row, Col, Row, Col) --- Represent literal values. data ValueWithSourceFragment = - WSArray [ExprWithSourceFragment] + WSArray [ASTWithSourceFragment] | WSBool Bool - -- Double quote strings are never treated differently to normal strings. - -- TODO: Should be merged with JSString | WSDQString String | WSFloat Double | WSInt Int | WSNull - -- TODO: Comment on what the expressions can be. - | WSObject [ExprWithSourceFragment] + | WSObject [ASTWithSourceFragment] | WSString String | WSUndefined deriving (Show) -data ExprWSF = - WSArguments [ExprWithSourceFragment] - | WSAssignment Operator ExprWithSourceFragment ExprWithSourceFragment - | WSBinary Operator ExprWithSourceFragment ExprWithSourceFragment + +data ASTWithSF = + WSBlock ASTWithSourceFragment + | WSCase ASTWithSourceFragment ASTWithSourceFragment + | WSCatch Variable (Maybe ASTWithSourceFragment) ASTWithSourceFragment + | WSDefault ASTWithSourceFragment + | WSDoWhile ASTWithSourceFragment ASTWithSourceFragment + | WSFinally ASTWithSourceFragment + | WSFor (Maybe ASTWithSourceFragment) (Maybe ASTWithSourceFragment) (Maybe ASTWithSourceFragment) ASTWithSourceFragment + | WSForIn [Variable] ASTWithSourceFragment ASTWithSourceFragment + | WSForVar [ASTWithSourceFragment] (Maybe ASTWithSourceFragment) (Maybe ASTWithSourceFragment) ASTWithSourceFragment + | WSForVarIn ASTWithSourceFragment ASTWithSourceFragment ASTWithSourceFragment + | WSFunctionBody [ASTWithSourceFragment] + | WSFunctionDeclaration Variable [Variable] ASTWithSourceFragment + | WSIf ASTWithSourceFragment ASTWithSourceFragment + | WSIfElse ASTWithSourceFragment ASTWithSourceFragment ASTWithSourceFragment + | WSLabelled Variable ASTWithSourceFragment + | WSReturn ASTWithSourceFragment + -- TODO: Delete this. It's just here to make things compile so I can test something. + | WSStatement ASTWithSourceFragment + -- TODO: Delete this. It's just here to make things compile so I can test something. + | WSList [ASTWithSourceFragment] + | WSSwitch ASTWithSourceFragment [ASTWithSourceFragment] + | WSTry ASTWithSourceFragment [ASTWithSourceFragment] + | WSWhile ASTWithSourceFragment ASTWithSourceFragment + + | WSArguments [ASTWithSourceFragment] + | WSAssignment Operator ASTWithSourceFragment ASTWithSourceFragment + | WSBinary Operator ASTWithSourceFragment ASTWithSourceFragment | WSBreak (Maybe Variable) - | WSCall ExprWithSourceFragment ExprWithSourceFragment - | WSCallExpression ExprWithSourceFragment Operator ExprWithSourceFragment + | WSCall ASTWithSourceFragment ASTWithSourceFragment + | WSCallExpression ASTWithSourceFragment Operator ASTWithSourceFragment | WSContinue (Maybe Variable) - | WSFunctionExpression (Maybe Variable) [Variable] JSASTWithSourceFragment + -- Was called "WSList". + | WSExpression [ASTWithSourceFragment] + | WSFunctionExpression (Maybe Variable) [Variable] ASTWithSourceFragment | WSIdentifier Variable - | WSIndex ExprWithSourceFragment ExprWithSourceFragment - | WSList [ExprWithSourceFragment] - | WSNew ExprWithSourceFragment - | WSParenExpression ExprWithSourceFragment - | WSPropNameValue PropertyName ExprWithSourceFragment - | WSReference ExprWithSourceFragment ExprWithSourceFragment - | WSTernary ExprWithSourceFragment ExprWithSourceFragment ExprWithSourceFragment - | WSThrow ExprWithSourceFragment - | WSUnaryPost Operator ExprWithSourceFragment - | WSUnaryPre Operator ExprWithSourceFragment + | WSIndex ASTWithSourceFragment ASTWithSourceFragment + | WSNew ASTWithSourceFragment + | WSParenExpression ASTWithSourceFragment + | WSPropNameValue PropertyName ASTWithSourceFragment + | WSReference ASTWithSourceFragment ASTWithSourceFragment + -- Was called "List". + | WSStatementList [ASTWithSourceFragment] + | WSTernary ASTWithSourceFragment ASTWithSourceFragment ASTWithSourceFragment + | WSThrow ASTWithSourceFragment + | WSUnaryPost Operator ASTWithSourceFragment + | WSUnaryPre Operator ASTWithSourceFragment | WSValue ValueWithSourceFragment - | WSVarDeclaration Variable (Maybe ExprWithSourceFragment) deriving (Show) - -data JSASTWSF = - WSBlock [JSASTWithSourceFragment] - | WSCase ExprWithSourceFragment JSASTWithSourceFragment - | WSCatch Variable (Maybe ExprWithSourceFragment) JSASTWithSourceFragment - | WSDefault JSASTWithSourceFragment - | WSDoWhile JSASTWithSourceFragment ExprWithSourceFragment - | WSFinally JSASTWithSourceFragment - | WSFor (Maybe ExprWithSourceFragment) (Maybe ExprWithSourceFragment) (Maybe ExprWithSourceFragment) JSASTWithSourceFragment - | WSForIn [Variable] ExprWithSourceFragment JSASTWithSourceFragment - | WSForVar [ExprWithSourceFragment] (Maybe ExprWithSourceFragment) (Maybe ExprWithSourceFragment) JSASTWithSourceFragment - | WSForVarIn ExprWithSourceFragment ExprWithSourceFragment JSASTWithSourceFragment - | WSFunctionBody [JSASTWithSourceFragment] - | WSFunctionDeclaration Variable [Variable] JSASTWithSourceFragment - | WSIf ExprWithSourceFragment JSASTWithSourceFragment - | WSIfElse ExprWithSourceFragment JSASTWithSourceFragment JSASTWithSourceFragment - | WSLabelled Variable JSASTWithSourceFragment - | WSReturn ExprWithSourceFragment - | WSStatement ExprWithSourceFragment - | WSSwitch ExprWithSourceFragment JSASTWithSourceFragment - | WSTry JSASTWithSourceFragment JSASTWithSourceFragment - | WSWhile ExprWithSourceFragment JSASTWithSourceFragment deriving (Show) - - -data JSASTWithSourceFragment = - AWSF JSASTWSF SourceFragment deriving (Show) -data ExprWithSourceFragment = - EWSF ExprWSF SourceFragment deriving (Show) + | WSVarDeclaration Variable (Maybe ASTWithSourceFragment) deriving (Show) --- nextSpan is the list's parent's next sibling (or the end of the file, if the parent has no next --- sibling) -jsastListWSMakeSourceFragments :: ([JSASTWithSourceSpan], SourceFileName) -> SrcSpan -> [JSASTWithSourceFragment] -jsastListWSMakeSourceFragments (list, fileName) nextSpan = - jsastListMakeSourceFragments list fileName nextSpan +data ASTWithSourceFragment = + AWSF ASTWithSF SourceFragment deriving (Show) --- nextSpan is the list's parent's next sibling (or the end of the file, if the parent has no next --- sibling) -jsastListMakeSourceFragments :: [JSASTWithSourceSpan] -> SourceFileName -> SrcSpan -> [JSASTWithSourceFragment] -jsastListMakeSourceFragments (x:y:z) fileName nextSpan = - (jsastMakeSourceFragment x fileName (jsastGetSpan y)):(jsastListMakeSourceFragments (y:z) fileName nextSpan) -jsastListMakeSourceFragments (x:[]) fileName nextSpan = [jsastMakeSourceFragment x fileName nextSpan] -jsastListMakeSourceFragments [] _ nextSpan = [] +astGetSpan :: ASTWithSourceSpan -> SrcSpan +astGetSpan (AWSS _ srcSpan) = srcSpan -jsastGetSpan :: JSASTWithSourceSpan -> SrcSpan -jsastGetSpan (AWSS _ srcSpan) = srcSpan - +-- nextSpan is the list's parent's next sibling (or the end of the file, if the parent has no next +-- sibling) +-- astListWSMakeSourceFragments :: ([ASTWithSourceSpan], SourceFileName) -> SrcSpan -> [ASTWithSourceFragment] +-- astListWSMakeSourceFragments (list, fileName) nextSpan = +-- astListMakeSourceFragments list fileName nextSpan -exprGetSpan :: ExprWithSourceSpan -> SrcSpan -exprGetSpan (EWSS _ srcSpan) = srcSpan +astWSMakeSourceFragment :: (ASTWithSourceSpan, SourceFileName) -> SrcSpan -> ASTWithSourceFragment +astWSMakeSourceFragment (ast, fileName) nextSpan = + astMakeSourceFragment ast fileName nextSpan -maybeExprGetSpan :: Maybe ExprWithSourceSpan -> Maybe SrcSpan -maybeExprGetSpan (Just (EWSS _ srcSpan)) = Just srcSpan -maybeExprGetSpan Nothing = Nothing +-- nextSpan is the list's parent's next sibling (or the end of the file, if the parent has no next +-- sibling) +astListMakeSourceFragments :: [ASTWithSourceSpan] -> SourceFileName -> SrcSpan -> [ASTWithSourceFragment] +astListMakeSourceFragments (x:y:z) fileName nextSpan = + (astMakeSourceFragment x fileName (astGetSpan y)):(astListMakeSourceFragments (y:z) fileName nextSpan) +astListMakeSourceFragments (x:[]) fileName nextSpan = [astMakeSourceFragment x fileName nextSpan] +astListMakeSourceFragments [] _ _ = [] -exprListMakeSourceFragments :: [ExprWithSourceSpan] -> SourceFileName -> SrcSpan -> [ExprWithSourceFragment] -exprListMakeSourceFragments (x:y:z) fileName nextSpan = - (exprMakeSourceFragment x fileName (exprGetSpan y)):(exprListMakeSourceFragments (y:z) fileName nextSpan) -exprListMakeSourceFragments (x:[]) fileName nextSpan = [exprMakeSourceFragment x fileName nextSpan] -exprListMakeSourceFragments [] _ _ = [] +valueMakeSourceFragment :: Value -> SourceFileName -> SrcSpan -> ValueWithSourceFragment +valueMakeSourceFragment (JSArray list) fileName nextSpan = + WSArray (astListMakeSourceFragments list fileName nextSpan) +valueMakeSourceFragment (JSBool val) _ _ = WSBool val +valueMakeSourceFragment (JSDQString val) _ _ = WSDQString val +valueMakeSourceFragment (JSFloat val) _ _ = WSFloat val +valueMakeSourceFragment (JSInt val) _ _ = WSInt val +valueMakeSourceFragment JSNull _ _ = WSNull +valueMakeSourceFragment (JSObject list) fileName nextSpan = + WSObject (astListMakeSourceFragments list fileName nextSpan) +valueMakeSourceFragment (JSString val) _ _ = WSString val +valueMakeSourceFragment JSUndefined _ _ = WSUndefined makeSourceFragment :: SrcSpan -> SrcSpan -> SourceFileName -> SourceFragment @@ -161,227 +160,208 @@ makeSourceFragment (SpanPoint _ startRow startCol) (SpanPoint _ nextRow nextCol) (fileName, startRow, startCol, nextRow, nextCol) +maybeASTMakeSourceFragment :: Maybe ASTWithSourceSpan -> SourceFileName -> SrcSpan -> Maybe ASTWithSourceFragment +maybeASTMakeSourceFragment maybeAST fileName srcSpan = + liftM (\m -> astMakeSourceFragment m fileName srcSpan) maybeAST + + -- Here nextSpan is just the end of this fragment -- Still to do --- WSCase ExprWithSourceFragment JSASTWithSourceFragment --- WSCatch Variable (Maybe ExprWithSourceFragment) JSASTWithSourceFragment --- WSDefault JSASTWithSourceFragment --- WSDoWhile JSASTWithSourceFragment ExprWithSourceFragment --- WSFinally JSASTWithSourceFragment --- WSForIn [Variable] ExprWithSourceFragment JSASTWithSourceFragment --- WSIf ExprWithSourceFragment JSASTWithSourceFragment --- WSIfElse ExprWithSourceFragment JSASTWithSourceFragment JSASTWithSourceFragment --- WSLabelled Variable JSASTWithSourceFragment --- WSSwitch ExprWithSourceFragment JSASTWithSourceFragment --- WSTry JSASTWithSourceFragment JSASTWithSourceFragment --- WSWhile ExprWithSourceFragment JSASTWithSourceFragment -jsastMakeSourceFragment :: JSASTWithSourceSpan -> SourceFileName -> SrcSpan -> JSASTWithSourceFragment --- jsastMakeSourceFragment (AWSS () srcSpan) fileName nextSpan = +-- WSCase ASTWithSourceFragment ASTWithSourceFragment +-- WSCatch Variable (Maybe ASTWithSourceFragment) ASTWithSourceFragment +-- WSDefault ASTWithSourceFragment +-- WSDoWhile ASTWithSourceFragment ASTWithSourceFragment +-- WSFinally ASTWithSourceFragment +-- WSForIn [Variable] ASTWithSourceFragment ASTWithSourceFragment +-- WSIfElse ASTWithSourceFragment ASTWithSourceFragment ASTWithSourceFragment +-- WSLabelled Variable ASTWithSourceFragment +-- WSSwitch ASTWithSourceFragment ASTWithSourceFragment +-- WSTry ASTWithSourceFragment ASTWithSourceFragment +-- WSWhile ASTWithSourceFragment ASTWithSourceFragment +-- +-- WSBreak (Maybe Variable) +-- WSContinue (Maybe Variable) +-- WSNew ASTWithSourceFragment +-- WSParenExpression ASTWithSourceFragment +-- WSTernary ASTWithSourceFragment ASTWithSourceFragment ASTWithSourceFragment +-- WSThrow ASTWithSourceFragment +astMakeSourceFragment :: ASTWithSourceSpan -> SourceFileName -> SrcSpan -> ASTWithSourceFragment +-- astMakeSourceFragment (AWSS () srcSpan) fileName nextSpan = -- AWSF -- (WS...) -- (makeSourceFragment srcSpan nextSpan fileName) -jsastMakeSourceFragment (AWSS (Block list) srcSpan) fileName nextSpan = +astMakeSourceFragment (AWSS (Block body) srcSpan) fileName nextSpan = AWSF - (WSBlock (jsastListMakeSourceFragments list fileName nextSpan)) + (WSBlock (astMakeSourceFragment body fileName nextSpan)) + (makeSourceFragment srcSpan nextSpan fileName) +astMakeSourceFragment (AWSS (Expression body) srcSpan) fileName nextSpan = + AWSF + (WSExpression (astListMakeSourceFragments body fileName nextSpan)) (makeSourceFragment srcSpan nextSpan fileName) -- FIXME: These two share a lot of code. Merge them? -jsastMakeSourceFragment (AWSS (For vars cond expr body) srcSpan) fileName nextSpan = +astMakeSourceFragment (AWSS (For vars cond expr body) srcSpan) fileName nextSpan = AWSF (WSFor - (maybeExprMakeSourceFragment vars fileName varsNextSpan) - (maybeExprMakeSourceFragment cond fileName condNextSpan) - (maybeExprMakeSourceFragment expr fileName (jsastGetSpan body)) - (jsastMakeSourceFragment body fileName nextSpan)) + (maybeASTMakeSourceFragment vars fileName varsNextSpan) + (maybeASTMakeSourceFragment cond fileName condNextSpan) + (maybeASTMakeSourceFragment expr fileName (astGetSpan body)) + (astMakeSourceFragment body fileName nextSpan)) (makeSourceFragment srcSpan nextSpan fileName) where justSpanGetSpan (Just ss) = ss - condSrcSpan = maybeExprGetSpan cond - exprSrcSpan = maybeExprGetSpan expr + condSrcSpan = liftM astGetSpan cond + exprSrcSpan = liftM astGetSpan expr varsNextSpan = if (not (condSrcSpan == Nothing)) then justSpanGetSpan condSrcSpan else if (not (exprSrcSpan == Nothing)) then justSpanGetSpan exprSrcSpan else - jsastGetSpan body + astGetSpan body condNextSpan = if (not (exprSrcSpan == Nothing)) then justSpanGetSpan exprSrcSpan else - jsastGetSpan body -jsastMakeSourceFragment (AWSS (ForVar vars cond expr body) srcSpan) fileName nextSpan = + astGetSpan body +astMakeSourceFragment (AWSS (ForVar vars cond expr body) srcSpan) fileName nextSpan = AWSF (WSForVar - (exprListMakeSourceFragments vars fileName varsNextSpan) - (maybeExprMakeSourceFragment cond fileName condNextSpan) - (maybeExprMakeSourceFragment expr fileName (jsastGetSpan body)) - (jsastMakeSourceFragment body fileName nextSpan)) + (astListMakeSourceFragments vars fileName varsNextSpan) + (maybeASTMakeSourceFragment cond fileName condNextSpan) + (maybeASTMakeSourceFragment expr fileName (astGetSpan body)) + (astMakeSourceFragment body fileName nextSpan)) (makeSourceFragment srcSpan nextSpan fileName) where justSpanGetSpan (Just ss) = ss - condSrcSpan = maybeExprGetSpan cond - exprSrcSpan = maybeExprGetSpan expr + condSrcSpan = liftM astGetSpan cond + exprSrcSpan = liftM astGetSpan expr varsNextSpan = if (not (condSrcSpan == Nothing)) then justSpanGetSpan condSrcSpan else if (not (exprSrcSpan == Nothing)) then justSpanGetSpan exprSrcSpan else - jsastGetSpan body + astGetSpan body condNextSpan = if (not (exprSrcSpan == Nothing)) then justSpanGetSpan exprSrcSpan else - jsastGetSpan body -jsastMakeSourceFragment (AWSS (ForVarIn var obj body) srcSpan) fileName nextSpan = + astGetSpan body +astMakeSourceFragment (AWSS (ForVarIn var obj body) srcSpan) fileName nextSpan = AWSF (WSForVarIn - (exprMakeSourceFragment var fileName (exprGetSpan obj)) - (exprMakeSourceFragment obj fileName (jsastGetSpan body)) - (jsastMakeSourceFragment body fileName nextSpan)) + (astMakeSourceFragment var fileName (astGetSpan obj)) + (astMakeSourceFragment obj fileName (astGetSpan body)) + (astMakeSourceFragment body fileName nextSpan)) (makeSourceFragment srcSpan nextSpan fileName) -jsastMakeSourceFragment (AWSS (FunctionBody list) srcSpan) fileName nextSpan = +astMakeSourceFragment (AWSS (FunctionBody list) srcSpan) fileName nextSpan = AWSF (WSFunctionBody - (jsastListMakeSourceFragments list fileName nextSpan)) + (astListMakeSourceFragments list fileName nextSpan)) (makeSourceFragment srcSpan nextSpan fileName) -jsastMakeSourceFragment (AWSS (FunctionDeclaration var args body) srcSpan) fileName nextSpan = +astMakeSourceFragment (AWSS (FunctionDeclaration var args body) srcSpan) fileName nextSpan = AWSF (WSFunctionDeclaration var args -- The body is the last child of the function declaration,so it has the same end point. - (jsastMakeSourceFragment body fileName nextSpan)) + (astMakeSourceFragment body fileName nextSpan)) (makeSourceFragment srcSpan nextSpan fileName) -jsastMakeSourceFragment (AWSS (Return expr) srcSpan) fileName nextSpan = +astMakeSourceFragment (AWSS (If expr body) srcSpan) fileName nextSpan = + AWSF + (WSIf + (astMakeSourceFragment expr fileName (astGetSpan body)) + (astMakeSourceFragment body fileName nextSpan)) + (makeSourceFragment srcSpan nextSpan fileName) +astMakeSourceFragment (AWSS (Return expr) srcSpan) fileName nextSpan = AWSF - (WSReturn (exprMakeSourceFragment expr fileName nextSpan)) + (WSReturn (astMakeSourceFragment expr fileName nextSpan)) (makeSourceFragment srcSpan nextSpan fileName) -jsastMakeSourceFragment (AWSS (Statement expr) srcSpan) fileName nextSpan = +-- WSStatementList [ASTWithSourceFragment] +astMakeSourceFragment (AWSS (StatementList body) srcSpan) fileName nextSpan = AWSF - (WSStatement (exprMakeSourceFragment expr fileName nextSpan)) + (WSStatementList (astListMakeSourceFragments body fileName nextSpan)) (makeSourceFragment srcSpan nextSpan fileName) - - -valueMakeSourceFragment :: Value -> SourceFileName -> SrcSpan -> ValueWithSourceFragment -valueMakeSourceFragment (JSArray list) fileName nextSpan = - WSArray (exprListMakeSourceFragments list fileName nextSpan) -valueMakeSourceFragment (JSBool val) _ _ = WSBool val - -- Double quote strings are never treated differently to normal strings. - -- TODO: Should be merged with JSString -valueMakeSourceFragment (JSDQString val) _ _ = WSDQString val -valueMakeSourceFragment (JSFloat val) _ _ = WSFloat val -valueMakeSourceFragment (JSInt val) _ _ = WSInt val -valueMakeSourceFragment JSNull _ _ = WSNull -valueMakeSourceFragment (JSObject list) fileName nextSpan = - WSObject (exprListMakeSourceFragments list fileName nextSpan) -valueMakeSourceFragment (JSString val) _ _ = WSString val -valueMakeSourceFragment JSUndefined _ _ = WSUndefined - - -maybeExprMakeSourceFragment :: Maybe ExprWithSourceSpan -> SourceFileName -> SrcSpan -> Maybe ExprWithSourceFragment -maybeExprMakeSourceFragment (Just exprWithSourceSpan) fileName srcSpan = - Just (exprMakeSourceFragment exprWithSourceSpan fileName srcSpan) -maybeExprMakeSourceFragment Nothing _ _ = Nothing - - --- Still to do --- WSBreak (Maybe Variable) --- WSContinue (Maybe Variable) --- WSNew ExprWithSourceFragment --- WSParenExpression ExprWithSourceFragment --- WSTernary ExprWithSourceFragment ExprWithSourceFragment ExprWithSourceFragment --- WSThrow ExprWithSourceFragment -exprMakeSourceFragment :: ExprWithSourceSpan -> SourceFileName -> SrcSpan -> ExprWithSourceFragment --- exprMakeSourceFragment (EWSS () srcSpan) fileName nextSpan = --- EWSF --- (WS...) --- (makeSourceFragment srcSpan nextSpan fileName) -exprMakeSourceFragment (EWSS (Arguments list) srcSpan) fileName nextSpan = - EWSF +astMakeSourceFragment (AWSS (Arguments list) srcSpan) fileName nextSpan = + AWSF (WSArguments - (exprListMakeSourceFragments list fileName nextSpan)) + (astListMakeSourceFragments list fileName nextSpan)) (makeSourceFragment srcSpan nextSpan fileName) -exprMakeSourceFragment (EWSS (Assignment op expr1 expr2) srcSpan) fileName nextSpan = - EWSF +astMakeSourceFragment (AWSS (Assignment op expr1 expr2) srcSpan) fileName nextSpan = + AWSF (WSAssignment op - (exprMakeSourceFragment expr1 fileName (exprGetSpan expr2)) - (exprMakeSourceFragment expr2 fileName nextSpan)) + (astMakeSourceFragment expr1 fileName (astGetSpan expr2)) + (astMakeSourceFragment expr2 fileName nextSpan)) (makeSourceFragment srcSpan nextSpan fileName) -exprMakeSourceFragment (EWSS (Binary op expr1 expr2) srcSpan) fileName nextSpan = - EWSF +astMakeSourceFragment (AWSS (Binary op expr1 expr2) srcSpan) fileName nextSpan = + AWSF (WSBinary op - (exprMakeSourceFragment expr1 fileName (exprGetSpan expr2)) - (exprMakeSourceFragment expr2 fileName nextSpan)) + (astMakeSourceFragment expr1 fileName (astGetSpan expr2)) + (astMakeSourceFragment expr2 fileName nextSpan)) (makeSourceFragment srcSpan nextSpan fileName) -exprMakeSourceFragment (EWSS (Call expr1 expr2) srcSpan) fileName nextSpan = - EWSF +astMakeSourceFragment (AWSS (Call expr1 expr2) srcSpan) fileName nextSpan = + AWSF (WSCall - (exprMakeSourceFragment expr1 fileName (exprGetSpan expr2)) - (exprMakeSourceFragment expr2 fileName nextSpan)) + (astMakeSourceFragment expr1 fileName (astGetSpan expr2)) + (astMakeSourceFragment expr2 fileName nextSpan)) (makeSourceFragment srcSpan nextSpan fileName) -exprMakeSourceFragment (EWSS (CallExpression expr op callExpr) srcSpan) fileName nextSpan = - EWSF +astMakeSourceFragment (AWSS (CallExpression expr op callExpr) srcSpan) fileName nextSpan = + AWSF (WSCallExpression - (exprMakeSourceFragment expr fileName (exprGetSpan callExpr)) + (astMakeSourceFragment expr fileName (astGetSpan callExpr)) op - (exprMakeSourceFragment callExpr fileName nextSpan)) + (astMakeSourceFragment callExpr fileName nextSpan)) (makeSourceFragment srcSpan nextSpan fileName) -exprMakeSourceFragment (EWSS (FunctionExpression name args body) srcSpan) fileName nextSpan = - EWSF +astMakeSourceFragment (AWSS (FunctionExpression name args body) srcSpan) fileName nextSpan = + AWSF (WSFunctionExpression name args - (jsastMakeSourceFragment body fileName nextSpan)) + (astMakeSourceFragment body fileName nextSpan)) (makeSourceFragment srcSpan nextSpan fileName) -exprMakeSourceFragment (EWSS (Identifier var) srcSpan) fileName nextSpan = - EWSF +astMakeSourceFragment (AWSS (Identifier var) srcSpan) fileName nextSpan = + AWSF (WSIdentifier var) (makeSourceFragment srcSpan nextSpan fileName) -exprMakeSourceFragment (EWSS (Index expr1 expr2) srcSpan) fileName nextSpan = - EWSF +astMakeSourceFragment (AWSS (Index expr1 expr2) srcSpan) fileName nextSpan = + AWSF (WSIndex - (exprMakeSourceFragment expr1 fileName (exprGetSpan expr2)) - (exprMakeSourceFragment expr2 fileName nextSpan)) - (makeSourceFragment srcSpan nextSpan fileName) -exprMakeSourceFragment (EWSS (List list) srcSpan) fileName nextSpan = - EWSF - (WSList - (exprListMakeSourceFragments list fileName nextSpan)) + (astMakeSourceFragment expr1 fileName (astGetSpan expr2)) + (astMakeSourceFragment expr2 fileName nextSpan)) (makeSourceFragment srcSpan nextSpan fileName) -exprMakeSourceFragment (EWSS (PropNameValue name expr) srcSpan) fileName nextSpan = - EWSF +astMakeSourceFragment (AWSS (PropNameValue name expr) srcSpan) fileName nextSpan = + AWSF (WSPropNameValue name - (exprMakeSourceFragment expr fileName nextSpan)) + (astMakeSourceFragment expr fileName nextSpan)) (makeSourceFragment srcSpan nextSpan fileName) -exprMakeSourceFragment (EWSS (Reference expr1 expr2) srcSpan) fileName nextSpan = - EWSF +astMakeSourceFragment (AWSS (Reference expr1 expr2) srcSpan) fileName nextSpan = + AWSF (WSReference - (exprMakeSourceFragment expr1 fileName (exprGetSpan expr2)) - (exprMakeSourceFragment expr2 fileName nextSpan)) + (astMakeSourceFragment expr1 fileName (astGetSpan expr2)) + (astMakeSourceFragment expr2 fileName nextSpan)) (makeSourceFragment srcSpan nextSpan fileName) -exprMakeSourceFragment (EWSS (UnaryPost op expr) srcSpan) fileName nextSpan = - EWSF +astMakeSourceFragment (AWSS (UnaryPost op expr) srcSpan) fileName nextSpan = + AWSF (WSUnaryPost op - (exprMakeSourceFragment expr fileName nextSpan)) + (astMakeSourceFragment expr fileName nextSpan)) (makeSourceFragment srcSpan nextSpan fileName) -exprMakeSourceFragment (EWSS (UnaryPre op expr) srcSpan) fileName nextSpan = - EWSF +astMakeSourceFragment (AWSS (UnaryPre op expr) srcSpan) fileName nextSpan = + AWSF (WSUnaryPre op - (exprMakeSourceFragment expr fileName nextSpan)) + (astMakeSourceFragment expr fileName nextSpan)) (makeSourceFragment srcSpan nextSpan fileName) -exprMakeSourceFragment (EWSS (Value val) srcSpan) fileName nextSpan = - EWSF +astMakeSourceFragment (AWSS (Value val) srcSpan) fileName nextSpan = + AWSF (WSValue (valueMakeSourceFragment val fileName nextSpan)) (makeSourceFragment srcSpan nextSpan fileName) -exprMakeSourceFragment (EWSS (VarDeclaration var expr) srcSpan) fileName nextSpan = - EWSF +astMakeSourceFragment (AWSS (VarDeclaration var expr) srcSpan) fileName nextSpan = + AWSF (WSVarDeclaration var - (maybeExprMakeSourceFragment expr fileName nextSpan)) + (maybeASTMakeSourceFragment expr fileName nextSpan)) (makeSourceFragment srcSpan nextSpan fileName) diff --git a/TypeRules.hs b/TypeRules.hs index 883832c..8daa615 100644 --- a/TypeRules.hs +++ b/TypeRules.hs @@ -12,8 +12,6 @@ -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -- See the License for the specific language governing permissions and -- limitations under the License. --- Module takes a JSAST and gives each vertex a unique integer label. The label counter is simply --- threaded through the tree. Traversal is depth first. It's all fairly straight-forward. -- This module generates type constraints (also called "type rules" or just "rules" throughout this @@ -42,11 +40,13 @@ module TypeRules , funExprMakeLabel , labelledMakeLabel , mapASTChildRules +, maybeToProperList , varDecMakeLabel ) where - -import LabelJSAST +import Control.Monad.State +import Data.Maybe (maybeToList) +import LabelAST import ParseJS import ResolveSourceFragments @@ -119,7 +119,7 @@ data Type = | IntIfArrayType Type | IntType -- A type variable, basically. - | Meta JSASTLabel + | Meta ASTLabel | NullType | NumType -- An ObjectType contains a list of properties. @@ -163,15 +163,12 @@ data DeclaredIdentifier = DeclaredIdentifier Variable IdentifierLabel deriving ( -- as the DeclaredIdentifiers need to be made more than once in some cases -- ************************************************************************************************* -- TODO: Move these into a module? -funExprMakeLabel :: ExprChild -> (Maybe DeclaredIdentifier) -funExprMakeLabel (LabFunctionExpression mv vls body, n, sourceFragment) = - maybeID mv n - where - maybeID Nothing _ = Nothing - maybeID (Just (ident, _)) x = Just (DeclaredIdentifier ident (IDLabel x)) +funExprMakeLabel :: ASTChild -> (Maybe DeclaredIdentifier) +funExprMakeLabel (LabFunctionExpression maybeFunName _ _, lab, _) = + liftM (\varChild -> DeclaredIdentifier (fst varChild) (IDLabel lab)) maybeFunName -varDecMakeLabel :: ExprChild -> DeclaredIdentifier +varDecMakeLabel :: ASTChild -> DeclaredIdentifier varDecMakeLabel (LabVarDeclaration (var, x) mex, n, sourceFragment) = DeclaredIdentifier var (IDLabel n) funDecMakeLabel :: ASTChild -> DeclaredIdentifier @@ -186,30 +183,34 @@ argMakeLabel :: VarChild -> DeclaredIdentifier argMakeLabel (var, n) = DeclaredIdentifier var (IDLabel n) ---------------------------------------------------------------------------------------------------- +maybeToProperList :: (a -> [b]) -> (Maybe a) -> [b] +maybeToProperList _ Nothing = [] +maybeToProperList f (Just x) = f x --- Extract the value (strip label) from a VarChild, ExprChild, ValueChild or ASTChild. -childGetValue :: (a, JSASTLabel) -> a + +-- Extract the value (strip label) from a VarChild, ASTChild, ValueChild or ASTChild. +childGetValue :: (a, ASTLabel) -> a childGetValue (val, lab) = val --- Create a Meta type from the label on a VarChild, ExprChild, ValueChild or ASTChild. -childToMeta :: (a, JSASTLabel) -> Type +-- Create a Meta type from the label on a VarChild, ASTChild, ValueChild or ASTChild. +childToMeta :: (a, ASTLabel) -> Type childToMeta ch = Meta (childGetLabel ch) --- Create a Meta type from the label on a VarChild, ExprChild, ValueChild or ASTChild. -childWSToMeta :: (a, JSASTLabel, b) -> Type + +-- Create a Meta type from the label on a VarChild, ASTChild, ValueChild or ASTChild. +childWSToMeta :: (a, ASTLabel, b) -> Type childWSToMeta ch = Meta (childWSGetLabel ch) + -- Generate rules from a Maybe VarChild maybeVarChildRules :: (Maybe VarChild) -> [DeclaredIdentifier] -> [Rule] -maybeVarChildRules (Just vc) dIDs = varChildRules vc dIDs -maybeVarChildRules Nothing _ = [] +maybeVarChildRules maybeVarChild dIDs = maybeToProperList (\varChild -> varChildRules varChild dIDs) maybeVarChild --- Generate rules from a Maybe ExprChild -maybeExprChildRules :: (Maybe ExprChild) -> [DeclaredIdentifier] -> [Rule] -maybeExprChildRules (Just ec) dIDs = exprChildRules ec dIDs -maybeExprChildRules Nothing _ = [] +-- Generate rules from a Maybe ASTChild +maybeASTChildRules :: (Maybe ASTChild) -> [DeclaredIdentifier] -> [Rule] +maybeASTChildRules maybeASTChild dIDs = maybeToProperList (\astChild -> astChildRules astChild dIDs) maybeASTChild -- Generate rules from a VarChild list @@ -220,14 +221,6 @@ mapVarChildRules var dIDs = mapVarChildRules' v = varChildRules v dIDs --- Generate rules from an ExprChild list -mapExprChildRules :: [ExprChild] -> [DeclaredIdentifier] -> [Rule] -mapExprChildRules ex dIDs = - concat $ map mapExprChildRules' ex - where - mapExprChildRules' e = exprChildRules e dIDs - - -- Gernerate rules from an ASTChild list mapASTChildRules :: [ASTChild] -> [DeclaredIdentifier] -> [Rule] mapASTChildRules ast dIDs = @@ -287,15 +280,15 @@ valueChildRules (LabObject members, x) dIDs = -- The whole reference expression has the same type as the value of the property. ++ [Rule (Meta n) (childWSToMeta ex) Nothing] -- Recursively process value of property. - ++ (exprChildRules ex dIDs) + ++ (astChildRules ex dIDs) -- Make a rule for the array. Make rules for the elements in the array. Make rules for the values of -- the elements in the array. -- --- TODO: Make sure that exprChildRules always binds n to something meaningfull (n is the bridge from +-- TODO: Make sure that astChildRules always binds n to something meaningfull (n is the bridge from -- the element to the expression that is its value). valueChildRules (LabArray elements, x) dIDs = [Rule (Meta x) (ArrayType (elemTypes elements [] 0)) Nothing] - ++ (mapExprChildRules elements dIDs) + ++ (mapASTChildRules elements dIDs) ++ (elemTypeRules elements [] 0) where -- We know that the property name is an index because this is an array (not actually true @@ -322,465 +315,60 @@ valueChildRules (LabNull, x) dIDs = [Rule (Meta x) NullType Nothing] -- Generate rules from an expression. -- --- TODO: Go through and give the parameters for exprChildRules meaningfull names! -exprChildRules :: ExprChild -> [DeclaredIdentifier] -> [Rule] --- The type of a list of expressions is the same as the type of the last expression in the list. --- --- FIXME: Not 100% sure that that is accurate. -exprChildRules (LabList expList, n, sourceFragment) dIDs = - [Rule (Meta n) (childWSToMeta $ last expList) (Just sourceFragment)] - ++ (mapExprChildRules expList dIDs) --- The '+' operator has unique behavior. The type of the expression depends on the types of both --- operands. There is a custom type - PlusType - for this operator and the '+=' operator. -exprChildRules (LabBinary ("+", _) ex1 ex2, n, sourceFragment) dIDs = - [Rule (Meta n) (PlusType (childWSToMeta ex1) (childWSToMeta ex2)) (Just sourceFragment)] - ++ [Rule (PlusType (childWSToMeta ex1) (childWSToMeta ex2)) (Meta n) (Just sourceFragment)] - ++ (exprChildRules ex1 dIDs) - ++ (exprChildRules ex2 dIDs) --- These operators only act on numbers. If both operands are of integer type then the expression is --- of integer type. If both operands are of the weaker NumType then the expression has type NumType. --- If either of the operands has type float then the expression has type float. -exprChildRules (LabBinary (op, _) ex1 ex2, n, sourceFragment) dIDs | elem op ["-", "%", "*"] = - [Rule (childWSToMeta ex1) NumType (Just sourceFragment)] - ++ [Rule (childWSToMeta ex2) NumType (Just sourceFragment)] - ++ [Rule (Meta n) (IntAndInt (childWSToMeta ex1) (childWSToMeta ex2)) (Just sourceFragment)] - ++ (exprChildRules ex1 dIDs) - ++ (exprChildRules ex2 dIDs) --- '/' only operates on numbers. The whole expression has type float. -exprChildRules (LabBinary ("/", _) ex1 ex2, n, sourceFragment) dIDs = - [Rule (childWSToMeta ex1) NumType (Just sourceFragment)] - ++ [Rule (childWSToMeta ex2) NumType (Just sourceFragment)] - ++ [Rule (Meta n) FloatType (Just sourceFragment)] - ++ (exprChildRules ex1 dIDs) - ++ (exprChildRules ex2 dIDs) --- Bitwise binary operators act only on numbers (which are cast to integers). The type of the --- expression is integer. -exprChildRules (LabBinary (op, _) ex1 ex2, n, sourceFragment) dIDs | elem op ["&", "|", "^"] = - [Rule (Meta n) IntType (Just sourceFragment)] - ++ [Rule (childWSToMeta ex1) NumType (Just sourceFragment)] - ++ [Rule (childWSToMeta ex2) NumType (Just sourceFragment)] - ++ (exprChildRules ex1 dIDs) - ++ (exprChildRules ex2 dIDs) --- Bitwise shift operators act only one numbers (which are cast to integers). The type of the --- expression is integer. + + + +-- Remove the LabList wrapper on singleton lists and remove parentheses from expressions. -- --- FIXME: Pre-define these operator lists somewhere so that these signatures aren't so long -exprChildRules (LabBinary (op, _) ex1 ex2, n, sourceFragment) dIDs | elem op ["<<", ">>", ">>>"] = - [Rule (Meta n) IntType (Just sourceFragment)] - ++ [Rule (childWSToMeta ex1) NumType (Just sourceFragment)] - ++ [Rule (childWSToMeta ex2) NumType (Just sourceFragment)] - ++ (exprChildRules ex1 dIDs) - ++ (exprChildRules ex2 dIDs) --- The type of a comparison expression is Bool. -exprChildRules (LabBinary (op, _) ex1 ex2, n, sourceFragment) dIDs - | elem op ["==", "!=", "===", "!==", ">", "<", ">=", "<="] = - [Rule (Meta n) BoolType (Just sourceFragment)] - ++ (exprChildRules ex1 dIDs) - ++ (exprChildRules ex2 dIDs) --- The type of a binary logic expression is Bool. JavaScript's interpretation of various expressions --- when cast to boolean is complex. What we want to do with it depends on what we want to do with --- the compiler. -exprChildRules (LabBinary (op, _) ex1 ex2, n, sourceFragment) dIDs | elem op ["&&", "||"] = - [Rule (Meta n) BoolType (Just sourceFragment)] - ++ (exprChildRules ex1 dIDs) - ++ (exprChildRules ex2 dIDs) --- Tye type of an in expression is bool. --- TODO: Added in 2014. Revisit. -exprChildRules (LabBinary (" in ", _) ex1 ex2, n, sourceFragment) dIDs = - [Rule (Meta n) BoolType (Just sourceFragment)] - -- For type safety, ex1 must be an object or array; but it doesn't have to contain ex2. I - -- might need to introduce another type to represent this properly. - ++ - (if ((isIntLiteral ex2) || (isStringLiteral ex2)) then - [Rule (childWSToMeta ex1) (AtLeastObjectType []) (Just sourceFragment)] +-- FIXME: This is used badly in some places. +removeUselessParenAndList :: ASTChild -> ASTChild +removeUselessParenAndList (LabList [ex], _, _) = removeUselessParenAndList ex +removeUselessParenAndList (LabParenExpression ex, _, _) = removeUselessParenAndList ex +removeUselessParenAndList ex = ex - else - [Rule (childWSToMeta ex1) (AtLeastObjectType []) (Just sourceFragment)] - -- If the object is not an array then type inference on the object and all of its members - -- must fail. - ++ [Rule (childWSToMeta ex1) (CorruptIfObjectType (childWSToMeta ex1)) (Just sourceFragment)] - -- If the object is an array then the index must have reference type (because we are, for - -- now, disregarding the case where the user references a property of the array other than - -- an element.) - ++ [Rule (childWSToMeta ex2) (IntIfArrayType (childWSToMeta ex1)) (Just sourceFragment)]) - ++ (exprChildRules ex1 dIDs) - ++ (exprChildRules ex2 dIDs) --- The type of a "instanceof" expression is bool. --- TODO: Added in 2014. Revisit. -exprChildRules (LabBinary (" instanceof ", _) ex1 ex2, n, sourceFragment) dIDs = - [Rule (Meta n) BoolType (Just sourceFragment)] - -- FIXME: If ex2 isn't a function then JS throws a TypeError. There should be a Rule equating - -- ex2 with Function, but there isn't at this stage. Might need to introduce a new Type for - -- this. - ++ (exprChildRules ex1 dIDs) - ++ (exprChildRules ex2 dIDs) --- Postfix '++' or '--' only operate on numbers. They type of the expression is number (integer if --- ex is integer and float if ex is float). -exprChildRules (LabUnaryPost op ex, n, sourceFragment) dIDs = - [Rule (childWSToMeta ex) NumType (Just sourceFragment)] - ++ [Rule (Meta n) (childWSToMeta ex) (Just sourceFragment)] - ++ (exprChildRules ex dIDs) --- These only operate on numbers. The type of the expression is the type of ex. -exprChildRules (LabUnaryPre (op, _) ex, n, sourceFragment) dIDs | elem op ["++", "--", "-", "+"] = - [Rule (childWSToMeta ex) NumType (Just sourceFragment)] - ++ [Rule (Meta n) (childWSToMeta ex) (Just sourceFragment)] - ++ (exprChildRules ex dIDs) --- The type of a not expression is bool. -exprChildRules (LabUnaryPre ("!", _) ex, n, sourceFragment) dIDs = - [Rule (Meta n) BoolType (Just sourceFragment)] - ++ (exprChildRules ex dIDs) --- The type of a "typeof" expression is string. --- TODO: Added in 2014. Revisit. -exprChildRules (LabUnaryPre ("typeof ", _) ex, n, sourceFragment) dIDs = - [Rule (Meta n) StringType (Just sourceFragment)] - ++ (exprChildRules ex dIDs) --- The type of the condition in a ternary expression is bool. They type of the whole expression is --- the type of the two optional expressions. If they don't have the same type then type inference on --- the expression fails. -exprChildRules (LabTernary ex1 ex2 ex3, n, sourceFragment) dIDs = - [boolRule ex1] - ++ [Rule (Meta n) (childWSToMeta ex2) (Just sourceFragment)] - ++ [Rule (Meta n) (childWSToMeta ex3) (Just sourceFragment)] - ++ (exprChildRules ex1 dIDs) - ++ (exprChildRules ex2 dIDs) - ++ (exprChildRules ex3 dIDs) --- They type of an assignment expression is the type of the value that is being assigned to the --- variable. The type of the variable is the type if its assigned value. -exprChildRules (LabAssignment ("=", _) ex1 ex2, n, sourceFragment) dIDs = - [Rule (Meta n) (childWSToMeta ex2) (Just sourceFragment)] - ++ [Rule (childWSToMeta ex1) (childWSToMeta ex2) (Just sourceFragment)] - ++ (exprChildRules ex1 dIDs) - ++ (exprChildRules ex2 dIDs) --- Similar to the '+' operator. This introduces a horrible cycle but I don't think I can avoid it, --- because the new type of the variable depends on its old type. The unification algorith will have --- to handle it. -exprChildRules (LabAssignment ("+=", _) ex1 ex2, n, sourceFragment) dIDs = - [Rule (Meta n) (PlusType (childWSToMeta ex1) (childWSToMeta ex2)) (Just sourceFragment)] - ++ [Rule (childWSToMeta ex1) (Meta n) (Just sourceFragment)] - ++ (exprChildRules ex1 dIDs) - ++ (exprChildRules ex2 dIDs) --- Similar to the '-', '*' and '%' operators. This also introduces a cycle, but I don't think I can --- avoid it, as the new type of the variable depends on its old type. The unification algorithm will --- have to handle it. -exprChildRules (LabAssignment (op, _) ex1 ex2, n, sourceFragment) dIDs | elem op ["-=", "*=", "%="] = - [Rule (Meta n) (IntAndInt (childWSToMeta ex1) (childWSToMeta ex2)) (Just sourceFragment)] - ++ [Rule (childWSToMeta ex1) (Meta n) (Just sourceFragment)] - ++ [Rule (childWSToMeta ex2) NumType (Just sourceFragment)] - ++ (exprChildRules ex1 dIDs) - ++ (exprChildRules ex2 dIDs) --- Similar to the '/' operator. -exprChildRules (LabAssignment (op, _) ex1 ex2, n, sourceFragment) dIDs | elem op ["/="] = - [Rule (Meta n) FloatType (Just sourceFragment)] - ++ [Rule (childWSToMeta ex1) FloatType (Just sourceFragment)] - ++ [Rule (childWSToMeta ex2) NumType (Just sourceFragment)] - ++ (exprChildRules ex1 dIDs) - ++ (exprChildRules ex2 dIDs) --- Bitwise operator assignments. See bitwise operators above. -exprChildRules (LabAssignment op ex1 ex2, n, sourceFragment) dIDs = - [Rule (Meta n) IntType (Just sourceFragment)] - ++ [Rule (childWSToMeta ex1) NumType (Just sourceFragment)] - ++ [Rule (childWSToMeta ex2) NumType (Just sourceFragment)] - ++ (exprChildRules ex1 dIDs) - ++ (exprChildRules ex2 dIDs) --- The type of an identifier is the same as the type of the variable it contains and vice versa. -exprChildRules (LabIdentifier var, n, sourceFragment) dIDs = - [Rule (Meta n) (childToMeta var) (Just sourceFragment)] - ++ [Rule (childToMeta var) (Meta n) (Just sourceFragment)] - ++ (varChildRules var dIDs) --- The type of a reference statement equals reference type and the type of that reference type --- equals the type of the statement. -exprChildRules (LabReference ex1 ex2, n, sourceFragment) dIDs = - [Rule (Meta n) (ReferenceType (childWSToMeta ex1) (getPropName ex2)) (Just sourceFragment)] - ++ [Rule (ReferenceType (childWSToMeta ex1) (getPropName ex2)) (Meta n) (Just sourceFragment)] - -- The object must contain the property being referenced. - ++ [Rule (childWSToMeta ex1) (AtLeastObjectType [(getPropName ex2)]) (Just sourceFragment)] - ++ (exprChildRules ex1 dIDs) + +-- Return true if the expression is an integer literal. +isIntLiteral :: ASTChild -> Bool +-- This use of removeUselssParenAndList is fine. +isIntLiteral ex = + isIntLiteral' $ removeUselessParenAndList ex where - getPropName (LabIdentifier (prop, q), r, sf) = VariableProperty prop --- An index represents a reference to a property of an object or an element of an array using square --- bracket notation. There is no way to differentiate between the two using local static analysis. -exprChildRules (LabIndex ex1 ex2, n, sourceFragment) dIDs = - (exprChildRules ex1 dIDs) - -- I don't really want to require the index to be an int literal or a string literal.In the case - -- of arrays, we don't care about the types of particular elements, we justcare that all - -- elements have the same type. Of course this is not the case for objects,since we need to know - -- which property of the object we are modifying so we can check itstype (i.e. the *value* of - -- the index matters). + isIntLiteral' (LabValue (LabInt i, _), _, _) = True + isIntLiteral' _ = False - -- Having said that, accesses to previously non-existent elements of arrays after their creation - -- simply "creates" the element (returns undefined on reads and adds the element the the array - -- on writes, I'm pretty sure). If we define the type of an array to be array-type plus its size - -- plus the type of its elements then adding elements to arrays after creation is not type safe. - -- If we define the type of an array to be array-type plus the type of its elements then adding - -- elements to an array after creation is type safe (provided sub- operations are type safe; - -- e.g. the types of the elements remains homogeneous). Both are legitimate definitions. If we - -- use the first definition then we require the user to define the array at its creation, which - -- translates easily to C (as C doesn't automatically cope with dynamic arrays); but it means - -- that we can't allow indexing of the array via anything but an integer literal. If we use the - -- second definition then our C needs to implement dynamically expanding arrays; growing the - -- array to accomodate any index that comes up during execution and filling any un- assigned - -- elements to undefined. But it also means that we can support loops over arrays rather than - -- failing type inference on the array whenever the user tries to loop over it. A big win! This - -- is why this project needs a precise definition of type safety. - -- Shane says that we should support dynamic arrays with elements that are all of the same type - -- or undefined. For now I will just assume that all arrays have static size. I will also ignore - -- the Array constructor for now and only deal with literally defined arrays. +-- Extract the actual integer value from an integer literal expression. +getIntLiteral :: ASTChild -> Int +-- This use of removeUselssParenAndList is fine. +getIntLiteral ex = + getIntLiteral' $ removeUselessParenAndList ex + where + getIntLiteral' (LabValue (LabInt i, _), _, _) = i - -- TODO: To make this work I will need to differentiate between references into arrays and - -- references into objects. - -- TODO: Also need to do something with the type of the index. Basically if the thing we're - -- indexing into is an array then the index must be of type int. For the moment we will ignore - -- (as in, pretend it can't happen) references to properties of array objects, other than - -- elements of the array, using square brackets. +-- Return true if the expression in a string literal. +isStringLiteral :: ASTChild -> Bool +-- This use of removeUselssParenAndList is fine. +isStringLiteral ex = + isStringLiteral' $ removeUselessParenAndList ex + where + isStringLiteral' (LabValue (LabString s, _), _, _) = True + isStringLiteral' (LabValue (LabDQString s, _), _, _) = True + isStringLiteral' _ = False - -- If the index is an integer literal then the statement has type ReferenceType and the - -- reference has the same type as the statement. - ++ - (if (isIntLiteral ex2) then - [Rule (Meta n) (ReferenceType (childWSToMeta ex1) (IndexProperty $ getIntLiteral ex2)) (Just sourceFragment)] - ++ [Rule (ReferenceType (childWSToMeta ex1) (IndexProperty $ getIntLiteral ex2)) (Meta n) (Just sourceFragment)] - -- The object or array must contain the member being referenced. - ++ [Rule (childWSToMeta ex1) (AtLeastObjectType [(IndexProperty $ getIntLiteral ex2)]) (Just sourceFragment)] - -- If the index is a string literal then the statement has type ReferenceType and the reference - -- has the same type as the statement. - else if (isStringLiteral ex2) then - [Rule - (Meta n) - (ReferenceType (childWSToMeta ex1) (VariableProperty $ getStringLiteral ex2)) - (Just sourceFragment) - ] - ++ - [Rule - (ReferenceType (childWSToMeta ex1) (VariableProperty $ getStringLiteral ex2)) - (Meta n) - (Just sourceFragment) - ] - ++ - -- The object or array must contain the member being referenced. - [Rule - (childWSToMeta ex1) - (AtLeastObjectType [(VariableProperty $ getStringLiteral ex2)]) - (Just sourceFragment) - ] - -- If the index is not an integer or sting literal then we cannot determine its value. - else - -- Record the type of the reference, even though we don't know which property it is. In the - -- case that the object is an array, all such rules must relate references to elements of - -- that array to the same type. - [Rule (Meta n) (ReferenceType (childWSToMeta ex1) (UnknownProperty)) (Just sourceFragment)] - ++ [Rule (ReferenceType (childWSToMeta ex1) (UnknownProperty)) (Meta n) (Just sourceFragment)] - -- If the object is not an array then type inference on the object and all of its members - -- must fail. - ++ [Rule (childWSToMeta ex1) (CorruptIfObjectType (childWSToMeta ex1)) (Just sourceFragment)] - -- If the object is an array then the index must have reference type (because we are, for - -- now, disregarding the case where the user references a property of the array other than - -- an element.) - ++ [Rule (childWSToMeta ex2) (IntIfArrayType (childWSToMeta ex1)) (Just sourceFragment)] - -- FIXME: Does this need to be outside the "if"? - ++ (exprChildRules ex2 dIDs)) --- The type of a LabValue is the type of the value it contains. -exprChildRules (LabValue val, n, sourceFragment) dIDs = - [Rule (Meta n) (childToMeta val) (Just sourceFragment)] - ++ (valueChildRules val dIDs) --- The type of a function call is the EvaluationType , --- where fun has type --- . --- is equal to (i.e. should unify with) y. -exprChildRules (LabCall ex1 ex2, n, sourceFragment) dIDs = - [Rule (Meta n) (EvaluationType (childWSToMeta ex1)) (Just sourceFragment)] - -- The arguments passed to the function when calling it should match the parameters in the - -- function definition. - ++ [Rule (ArgumentsIDType (childWSToMeta ex1)) (ArgumentsType (argsToMeta ex2)) (Just sourceFragment)] - ++ (exprChildRules ex1 dIDs) - ++ (exprChildRules ex2 dIDs) + +-- Extract the actual string value from a string literal expression. +getStringLiteral :: ASTChild -> String +-- This use of removeUselssParenAndList is fine. +getStringLiteral ex = + getStringLiteral' $ removeUselessParenAndList ex where - argsToMeta (LabArguments args, n, sf) = map childWSToMeta args --- TODO: Do I need to bind n to something? (is it ever a link in the chain?) Not much to say about --- arguments. --- --- TODO: Does this even get called? -exprChildRules (LabArguments args, n, sourceFragment) dIDs = mapExprChildRules args dIDs --- The type of a ParenExpression is they type of the expression it contains. -exprChildRules (LabParenExpression ex, n, sourceFragment) dIDs = - [Rule (Meta n) (childWSToMeta ex) (Just sourceFragment)] - ++ [Rule (childWSToMeta ex) (Meta n) (Just sourceFragment)] - ++ (exprChildRules ex dIDs) --- TODO: Do I need to bind n to something? (is it ever a link in the chain?) --- --- Not much to say about break statments. They don't really have a type and I don't think that they --- can be used on the RHS of an assignment, nor can they be returned or return anything (in the --- normal sense). -exprChildRules (LabBreak var, n, sourceFragment) dIDs = maybeVarChildRules var dIDs --- TODO: Do I need to bind n to something? (is it ever a link in the chain?) --- --- Not much to say about continue statments. They don't really have a type and I don't think that --- they can be used on the RHS of an assignment, nor can they be returned or return anything (in the --- normal sense). -exprChildRules (LabContinue var, n, sourceFragment) dIDs = maybeVarChildRules var dIDs --- TODO: Do I need to bind n to something? (is it ever a link in the chain?) --- --- Not much to say about throw statments. They don't really have a type and I don't think that they --- can be used on the RHS of an assignment, nor can they be returned or return anything (in the --- normal sense). -exprChildRules (LabThrow ex, n, sourceFragment) dIDs = (exprChildRules ex dIDs) --- A CallExpression is a reference to a property of an evaluation of a function that returns an --- object. -exprChildRules (LabCallExpression ex1 (".", _) ex2, n, sourceFragment) dIDs = - -- The type of the statement is ReferenceType and the type of that reference is the type of the - -- statement. - [Rule (Meta n) (ReferenceType (childWSToMeta ex1) (getPropName ex2)) (Just sourceFragment)] - ++ [Rule (ReferenceType (childWSToMeta ex1) (getPropName ex2)) (Meta n) (Just sourceFragment)] - -- The object must containt the property being reference. - ++ [Rule (childWSToMeta ex1) (AtLeastObjectType [(getPropName ex2)]) (Just sourceFragment)] - ++ (exprChildRules ex1 dIDs) - where - -- Assuming that property names appear here as identifiers. - -- - -- FIXME: Not sure if correct. - getPropName (LabIdentifier (prop, q), r, sf) = VariableProperty prop --- A CallExpression is a reference to a property of an evaluation of a function that returns an --- object. -exprChildRules (LabCallExpression ex1 ("[]", _) ex2, n, sourceFragment) dIDs = - (exprChildRules ex1 dIDs) - ++ - -- If the index is an integer literal then the type of the statment is ReferenceType and the - -- type of that reference is the type of they statement. - (if (isIntLiteral $ ex2) then - [Rule (Meta n) (ReferenceType (childWSToMeta ex1) (IndexProperty (getIntLiteral ex2))) (Just sourceFragment)] - ++ [Rule (ReferenceType (childWSToMeta ex1) (IndexProperty (getIntLiteral ex2))) (Meta n) (Just sourceFragment)] - -- The object must contain the property being referenced. - ++ [Rule (childWSToMeta ex1) (AtLeastObjectType [(IndexProperty (getIntLiteral ex2))]) (Just sourceFragment)] - -- If the index is a string literal then the type of the statment is ReferenceType and the type - -- of that reference is the type of they statement. - else if (isStringLiteral ex2) then - [Rule - (Meta n) - (ReferenceType (childWSToMeta ex1) (VariableProperty (getStringLiteral ex2))) - (Just sourceFragment) - ] - ++ - [Rule - (ReferenceType (childWSToMeta ex1) (VariableProperty (getStringLiteral ex2))) - (Meta n) - (Just sourceFragment) - ] - ++ - -- The object must contain the property being referenced. - [Rule - (childWSToMeta ex1) - (AtLeastObjectType [(VariableProperty (getStringLiteral ex2))]) - (Just sourceFragment) - ] - -- If the type of the index is not an int or string literal then we cannot know its value and - -- thus type inference on the object fails. - else - [Rule (Meta n) AmbiguousType (Just sourceFragment)] - ++ [Rule (childWSToMeta ex1) AmbiguousType (Just sourceFragment)] - ++ (exprChildRules ex2 dIDs)) --- The type of the statment is functionType. A FunctionType includes an ArgumentsIDType, a --- ReturnType and a ConstructorType. -exprChildRules (LabFunctionExpression mv vls body, n, sourceFragment) dIDs = - [Rule - (Meta n) - (FunctionType - (ArgumentsIDType (Meta n)) - (ReturnType (childWSToMeta body)) - (ConstructorType (childWSToMeta body))) - (Just sourceFragment) - ] - -- Make a rule for the types of the arguments. - ++ [Rule - (ArgumentsIDType (Meta n)) - (ArgumentsType (map (makeIDType . argMakeLabel) vls)) - (Just sourceFragment) - ] - -- Make rules for the name of the function expression if it has one. - ++ (nameRule mv (funExprMakeLabel thisFunEx) n) - where - thisFunEx = (LabFunctionExpression mv vls body, n, sourceFragment) - nameRule Nothing _ _= [] - nameRule _ Nothing _ = [] - nameRule (Just (name, x)) (Just d) y = - [Rule (Meta x) (makeIDType d) (Just sourceFragment)] - ++ [Rule (makeIDType d) (Meta y) (Just sourceFragment)] - makeIDType (DeclaredIdentifier ident lab) = IdentifierType ident lab --- Variable declarations. -exprChildRules (LabVarDeclaration var mex, n, sourceFragment) dIDs = - -- The type of the statement equals the type of mex if mex is not Nothing. - (maybeMetaRule n mex) - -- The type of the variable is equal to the type of mex if mex is not Nothing. - ++ (maybeMetaRule (childGetLabel var) mex) - ++ (varChildRules var dIDs) - ++ (maybeExprChildRules mex dIDs) - where - maybeMetaRule x Nothing = [Rule (Meta x) UndefType (Just sourceFragment)] - maybeMetaRule x (Just expr) = [Rule (Meta x) (childWSToMeta expr) (Just sourceFragment)] --- The type of a 'new' statment is they instantiation type of the function (constructor) that it --- calls. -exprChildRules (LabNew (LabCall ex1 ex2, p, sourceFragment1), n, sourceFragment2) dIDs = - [Rule (Meta n) (InstantiationType (childWSToMeta ex1)) (Just sourceFragment2)] - -- The types of the arguments that the constructor is called with must match the types of the - -- arguments in its definition. - ++ [Rule (ArgumentsIDType (childWSToMeta ex1)) (ArgumentsType (argsToMeta ex2)) (Just sourceFragment1)] - ++ (exprChildRules ex1 dIDs) - ++ (exprChildRules ex2 dIDs) - where - argsToMeta (LabArguments args, n, sf) = map childWSToMeta args - - --- Remove the LabList wrapper on singleton lists and remove parentheses from expressions. --- --- FIXME: This is used badly in some places. -removeUselessParenAndList :: ExprChild -> ExprChild -removeUselessParenAndList (LabList [ex], _, _) = removeUselessParenAndList ex -removeUselessParenAndList (LabParenExpression ex, _, _) = removeUselessParenAndList ex -removeUselessParenAndList ex = ex - - --- Return true if the expression is an integer literal. -isIntLiteral :: ExprChild -> Bool --- This use of removeUselssParenAndList is fine. -isIntLiteral ex = - isIntLiteral' $ removeUselessParenAndList ex - where - isIntLiteral' (LabValue (LabInt i, _), _, _) = True - isIntLiteral' _ = False - - --- Extract the actual integer value from an integer literal expression. -getIntLiteral :: ExprChild -> Int --- This use of removeUselssParenAndList is fine. -getIntLiteral ex = - getIntLiteral' $ removeUselessParenAndList ex - where - getIntLiteral' (LabValue (LabInt i, _), _, _) = i - - --- Return true if the expression in a string literal. -isStringLiteral :: ExprChild -> Bool --- This use of removeUselssParenAndList is fine. -isStringLiteral ex = - isStringLiteral' $ removeUselessParenAndList ex - where - isStringLiteral' (LabValue (LabString s, _), _, _) = True - isStringLiteral' (LabValue (LabDQString s, _), _, _) = True - isStringLiteral' _ = False - - --- Extract the actual string value from a string literal expression. -getStringLiteral :: ExprChild -> String --- This use of removeUselssParenAndList is fine. -getStringLiteral ex = - getStringLiteral' $ removeUselessParenAndList ex - where - getStringLiteral' (LabValue (LabString s, _), _, _) = s - getStringLiteral' (LabValue (LabDQString s, _), _, _) = s - - --- Returns true if the ASTChild is a Statement containing an . False +-- otherwise. -- -- Here I assume that calling removeUselessParenAndList is ok. But I should allow the user to do -- {this.x = a, this.y = b;} which I think _might_ give us a LabList containing two simple @@ -800,7 +388,7 @@ isSimpleAssignment _ = False -- Takes a Statement containing an [(PropertyName, Type)] +getPropertyNameType :: ASTChild -> [(PropertyName, Type)] getPropertyNameType (LabReference _ (LabIdentifier (prop, _), _, _), n, _) = [(VariableProperty prop, Meta n)] getPropertyNameType (LabIndex (LabIdentifier (obj, _), _, _) prop, n, _) = @@ -897,7 +485,7 @@ hasUnassignedProps ast list = False -- If a statement in the block is a Return, or anything that has a Block field (except for a -- function declaration or a function expression) then we make a rule matching the type of the whole -- block to the type of that statment. -blockRules :: [ASTChild] -> JSASTLabel -> SourceFragment -> [Rule] +blockRules :: [ASTChild] -> ASTLabel -> SourceFragment -> [Rule] blockRules block n fragment = concat $ map getBlockRule block where @@ -916,7 +504,7 @@ blockRules block n fragment = -- these? -- -- TODO: Consider allowing simple inner-block returns and top-level returns. -funBodyRules :: [ASTChild] -> JSASTLabel -> SourceFragment -> [Rule] +funBodyRules :: [ASTChild] -> ASTLabel -> SourceFragment -> [Rule] funBodyRules block n fragment = -- If there is no return type at the top level of scope of the block then relate the type of the -- block to UndefType and process all child ASTs in the block. If a child AST other than a @@ -971,34 +559,37 @@ funBodyRules block n fragment = -- ) -- ) -- ] -constructorRules :: [ASTChild] -> JSASTLabel -> SourceFragment -> [Rule] +constructorRules :: [ASTChild] -> ASTLabel -> SourceFragment -> [Rule] constructorRules block n fragment = [Rule (ConstructorType (Meta n)) (ObjectType (concat $ map getAssignedProperty block)) (Just fragment)] -- Make a rule for ASTs that have the same type as their body (a block) -bodyRule :: ASTChild -> JSASTLabel -> Rule +bodyRule :: ASTChild -> ASTLabel -> Rule bodyRule body n = Rule (Meta n) (childWSToMeta body) (Just $ childGetSource body) -- Make a rule for expressions that have Boolean type -boolRule :: ExprChild -> Rule +boolRule :: ASTChild -> Rule boolRule (LabList ex, n, sourceFragment) = Rule (childWSToMeta $ last ex) BoolType (Just sourceFragment) boolRule ex = Rule (childWSToMeta ex) BoolType (Just $ childGetSource ex) --- Make a list of rules from a Maybe ExprChild of Boolean type. -maybeBoolRule :: (Maybe ExprChild) -> [Rule] -maybeBoolRule (Just t) = [boolRule t] -maybeBoolRule Nothing = [] +-- Make a list of rules from a Maybe ASTChild of Boolean type. +maybeBoolRule :: (Maybe ASTChild) -> [Rule] +maybeBoolRule astChild = map boolRule (maybeToList astChild) -- Generate rules from an AST +-- +-- TODO: Go through and give the meaningful names to parameters in the +-- ones that used to be expressionChildRules. astChildRules :: ASTChild -> [DeclaredIdentifier] -> [Rule] -- The type of the block is equal to the type of anything it returns (blockRules). -astChildRules (LabBlock astList, n, sourceFragment) dIDs = - (mapASTChildRules astList dIDs) - ++ (blockRules astList n sourceFragment) +-- FIXME: Uncomment this and fix it (field is not a list any more) +-- astChildRules (LabBlock astList, n, sourceFragment) dIDs = +-- (mapASTChildRules astList dIDs) +-- ++ (blockRules astList n sourceFragment) -- The evaluation type of a function body is the same as the type of anything it returns. It also -- has a construtor type - the type of the object that the function makes when is instantiated. astChildRules (LabFunctionBody astList, n, sourceFragment) dIDs = @@ -1041,17 +632,17 @@ astChildRules (LabLabelled label body, n, sourceFragment) dIDs = astChildRules (LabForVar varEx test count body, n, sourceFragment) dIDs = [bodyRule body n] ++ (maybeBoolRule test) - ++ (mapExprChildRules varEx dIDs) - ++ (maybeExprChildRules test dIDs) - ++ (maybeExprChildRules count dIDs) + ++ (mapASTChildRules varEx dIDs) + ++ (maybeASTChildRules test dIDs) + ++ (maybeASTChildRules count dIDs) ++ (astChildRules body dIDs) -- They type of a for loop is the type of its body. The test has boolean type. astChildRules (LabFor varEx test count body, n, sourceFragment) dIDs = [bodyRule body n] ++ (maybeBoolRule test) - ++ (maybeExprChildRules varEx dIDs) - ++ (maybeExprChildRules test dIDs) - ++ (maybeExprChildRules count dIDs) + ++ (maybeASTChildRules varEx dIDs) + ++ (maybeASTChildRules test dIDs) + ++ (maybeASTChildRules count dIDs) ++ (astChildRules body dIDs) -- TODO: More to do here. -- @@ -1059,33 +650,33 @@ astChildRules (LabFor varEx test count body, n, sourceFragment) dIDs = astChildRules (LabForIn varList obj body, n, sourceFragment) dIDs = [bodyRule body n] ++ (mapVarChildRules varList dIDs) - ++ (exprChildRules obj dIDs) + ++ (astChildRules obj dIDs) ++ (astChildRules body dIDs) -- TODO: More to do here. -- -- They type of a for loop is the type of its body. astChildRules (LabForVarIn varEx obj body, n, sourceFragment) dIDs = [bodyRule body n] - ++ (exprChildRules varEx dIDs) - ++ (exprChildRules obj dIDs) + ++ (astChildRules varEx dIDs) + ++ (astChildRules obj dIDs) ++ (astChildRules body dIDs) -- The type of a while loop is the type of its body. The type of the test is boolean. astChildRules (LabWhile test body, n, sourceFragment) dIDs = [bodyRule body n] ++ [boolRule test] - ++ (exprChildRules test dIDs) + ++ (astChildRules test dIDs) ++ (astChildRules body dIDs) -- The type of a do-while loop is the type of its body. They type of the test is bool. astChildRules (LabDoWhile body test, n, sourceFragment) dIDs = [bodyRule body n] ++ [boolRule test] - ++ (exprChildRules test dIDs) + ++ (astChildRules test dIDs) ++ (astChildRules body dIDs) -- The type of an if construct is they type of its body. The type of the test is boolean. astChildRules (LabIf test body, n, sourceFragment) dIDs = [bodyRule body n] ++ [boolRule test] - ++ (exprChildRules test dIDs) + ++ (astChildRules test dIDs) ++ (astChildRules body dIDs) -- The type of an if-else construct is they type of both of its body blocks (they must have the same -- type for type inference on the construct to succeed). They type of the test is boolean. @@ -1093,7 +684,7 @@ astChildRules (LabIfElse test bodyT bodyF, n, sourceFragment) dIDs = [bodyRule bodyT n] ++ [bodyRule bodyF n] ++ [boolRule test] - ++ (exprChildRules test dIDs) + ++ (astChildRules test dIDs) ++ (astChildRules bodyT dIDs) ++ (astChildRules bodyF dIDs) -- The type of a switch statment is the type of all of its cases (which in turn have the type of @@ -1101,7 +692,7 @@ astChildRules (LabIfElse test bodyT bodyF, n, sourceFragment) dIDs = -- succeed. astChildRules (LabSwitch ident cases, n, sourceFragment) dIDs = [bodyRule cases n] - ++ (exprChildRules ident dIDs) + ++ (astChildRules ident dIDs) ++ (astChildRules cases dIDs) -- The type of a case in a switch statement is the same as the type of its body. -- @@ -1109,7 +700,7 @@ astChildRules (LabSwitch ident cases, n, sourceFragment) dIDs = -- this. astChildRules (LabCase ex body, n, sourceFragment) dIDs = [bodyRule body n] - ++ (exprChildRules ex dIDs) + ++ (astChildRules ex dIDs) ++ (astChildRules body dIDs) -- The type of a default statment is the same as the type of its body. astChildRules (LabDefault body, n, sourceFragment) dIDs = @@ -1129,7 +720,7 @@ astChildRules (LabCatch var mTest body, n, sourceFragment) dIDs = [bodyRule body n] ++ (maybeBoolRule mTest) ++ (varChildRules var dIDs) - ++ (maybeExprChildRules mTest dIDs) + ++ (maybeASTChildRules mTest dIDs) ++ (astChildRules body dIDs) -- The type of a finally statement is the same as the type of its body. astChildRules (LabFinally body, n, sourceFragment) dIDs = @@ -1138,9 +729,425 @@ astChildRules (LabFinally body, n, sourceFragment) dIDs = -- They type of a return statement is they same as the type of the expression it returns. astChildRules (LabReturn ex, n, sourceFragment) dIDs = [Rule (Meta n) (childWSToMeta ex) (Just sourceFragment)] - ++ (exprChildRules ex dIDs) + ++ (astChildRules ex dIDs) -- They type of an instance of the Statment data type is the same as the type of the expression it -- contains. astChildRules (LabStatement ex, n, sourceFragment) dIDs = [Rule (Meta n) (childWSToMeta ex) (Just sourceFragment)] - ++ (exprChildRules ex dIDs) + ++ (astChildRules ex dIDs) +-- The type of a list of expressions is the same as the type of the last expression in the list. +-- +-- FIXME: Not 100% sure that that is accurate. +astChildRules (LabList expList, n, sourceFragment) dIDs = + [Rule (Meta n) (childWSToMeta $ last expList) (Just sourceFragment)] + ++ (mapASTChildRules expList dIDs) +-- The type of a list of expressions is the same as the type of the last expression in the list. +-- +-- FIXME: Not 100% sure that that is accurate. +astChildRules (LabExpression expList, n, sourceFragment) dIDs = + [Rule (Meta n) (childWSToMeta $ last expList) (Just sourceFragment)] + ++ (mapASTChildRules expList dIDs) +-- The type of a list of expressions is the same as the type of the last expression in the list. +-- +-- FIXME: Not 100% sure that that is accurate. +astChildRules (LabStatementList expList, n, sourceFragment) dIDs = + [Rule (Meta n) (childWSToMeta $ last expList) (Just sourceFragment)] + ++ (mapASTChildRules expList dIDs) +-- The '+' operator has unique behavior. The type of the expression depends on the types of both +-- operands. There is a custom type - PlusType - for this operator and the '+=' operator. +astChildRules (LabBinary ("+", _) ex1 ex2, n, sourceFragment) dIDs = + [Rule (Meta n) (PlusType (childWSToMeta ex1) (childWSToMeta ex2)) (Just sourceFragment)] + ++ [Rule (PlusType (childWSToMeta ex1) (childWSToMeta ex2)) (Meta n) (Just sourceFragment)] + ++ (astChildRules ex1 dIDs) + ++ (astChildRules ex2 dIDs) +-- These operators only act on numbers. If both operands are of integer type then the expression is +-- of integer type. If both operands are of the weaker NumType then the expression has type NumType. +-- If either of the operands has type float then the expression has type float. +astChildRules (LabBinary (op, _) ex1 ex2, n, sourceFragment) dIDs | elem op ["-", "%", "*"] = + [Rule (childWSToMeta ex1) NumType (Just sourceFragment)] + ++ [Rule (childWSToMeta ex2) NumType (Just sourceFragment)] + ++ [Rule (Meta n) (IntAndInt (childWSToMeta ex1) (childWSToMeta ex2)) (Just sourceFragment)] + ++ (astChildRules ex1 dIDs) + ++ (astChildRules ex2 dIDs) +-- '/' only operates on numbers. The whole expression has type float. +astChildRules (LabBinary ("/", _) ex1 ex2, n, sourceFragment) dIDs = + [Rule (childWSToMeta ex1) NumType (Just sourceFragment)] + ++ [Rule (childWSToMeta ex2) NumType (Just sourceFragment)] + ++ [Rule (Meta n) FloatType (Just sourceFragment)] + ++ (astChildRules ex1 dIDs) + ++ (astChildRules ex2 dIDs) +-- Bitwise binary operators act only on numbers (which are cast to integers). The type of the +-- expression is integer. +astChildRules (LabBinary (op, _) ex1 ex2, n, sourceFragment) dIDs | elem op ["&", "|", "^"] = + [Rule (Meta n) IntType (Just sourceFragment)] + ++ [Rule (childWSToMeta ex1) NumType (Just sourceFragment)] + ++ [Rule (childWSToMeta ex2) NumType (Just sourceFragment)] + ++ (astChildRules ex1 dIDs) + ++ (astChildRules ex2 dIDs) +-- Bitwise shift operators act only one numbers (which are cast to integers). The type of the +-- expression is integer. +-- +-- FIXME: Pre-define these operator lists somewhere so that these signatures aren't so long +astChildRules (LabBinary (op, _) ex1 ex2, n, sourceFragment) dIDs | elem op ["<<", ">>", ">>>"] = + [Rule (Meta n) IntType (Just sourceFragment)] + ++ [Rule (childWSToMeta ex1) NumType (Just sourceFragment)] + ++ [Rule (childWSToMeta ex2) NumType (Just sourceFragment)] + ++ (astChildRules ex1 dIDs) + ++ (astChildRules ex2 dIDs) +-- The type of a comparison expression is Bool. +astChildRules (LabBinary (op, _) ex1 ex2, n, sourceFragment) dIDs + | elem op ["==", "!=", "===", "!==", ">", "<", ">=", "<="] = + [Rule (Meta n) BoolType (Just sourceFragment)] + ++ (astChildRules ex1 dIDs) + ++ (astChildRules ex2 dIDs) +-- The type of a binary logic expression is Bool. JavaScript's interpretation of various expressions +-- when cast to boolean is complex. What we want to do with it depends on what we want to do with +-- the compiler. +astChildRules (LabBinary (op, _) ex1 ex2, n, sourceFragment) dIDs | elem op ["&&", "||"] = + [Rule (Meta n) BoolType (Just sourceFragment)] + ++ (astChildRules ex1 dIDs) + ++ (astChildRules ex2 dIDs) +-- Tye type of an in expression is bool. +-- TODO: Added in 2014. Revisit. +astChildRules (LabBinary (" in ", _) ex1 ex2, n, sourceFragment) dIDs = + [Rule (Meta n) BoolType (Just sourceFragment)] + -- For type safety, ex1 must be an object or array; but it doesn't have to contain ex2. I + -- might need to introduce another type to represent this properly. + ++ + (if ((isIntLiteral ex2) || (isStringLiteral ex2)) then + [Rule (childWSToMeta ex1) (AtLeastObjectType []) (Just sourceFragment)] + + else + [Rule (childWSToMeta ex1) (AtLeastObjectType []) (Just sourceFragment)] + -- If the object is not an array then type inference on the object and all of its members + -- must fail. + ++ [Rule (childWSToMeta ex1) (CorruptIfObjectType (childWSToMeta ex1)) (Just sourceFragment)] + -- If the object is an array then the index must have reference type (because we are, for + -- now, disregarding the case where the user references a property of the array other than + -- an element.) + ++ [Rule (childWSToMeta ex2) (IntIfArrayType (childWSToMeta ex1)) (Just sourceFragment)]) + ++ (astChildRules ex1 dIDs) + ++ (astChildRules ex2 dIDs) +-- The type of a "instanceof" expression is bool. +-- TODO: Added in 2014. Revisit. +astChildRules (LabBinary (" instanceof ", _) ex1 ex2, n, sourceFragment) dIDs = + [Rule (Meta n) BoolType (Just sourceFragment)] + -- FIXME: If ex2 isn't a function then JS throws a TypeError. There should be a Rule equating + -- ex2 with Function, but there isn't at this stage. Might need to introduce a new Type for + -- this. + ++ (astChildRules ex1 dIDs) + ++ (astChildRules ex2 dIDs) +-- Postfix '++' or '--' only operate on numbers. They type of the expression is number (integer if +-- ex is integer and float if ex is float). +astChildRules (LabUnaryPost op ex, n, sourceFragment) dIDs = + [Rule (childWSToMeta ex) NumType (Just sourceFragment)] + ++ [Rule (Meta n) (childWSToMeta ex) (Just sourceFragment)] + ++ (astChildRules ex dIDs) +-- These only operate on numbers. The type of the expression is the type of ex. +astChildRules (LabUnaryPre (op, _) ex, n, sourceFragment) dIDs | elem op ["++", "--", "-", "+"] = + [Rule (childWSToMeta ex) NumType (Just sourceFragment)] + ++ [Rule (Meta n) (childWSToMeta ex) (Just sourceFragment)] + ++ (astChildRules ex dIDs) +-- The type of a not expression is bool. +astChildRules (LabUnaryPre ("!", _) ex, n, sourceFragment) dIDs = + [Rule (Meta n) BoolType (Just sourceFragment)] + ++ (astChildRules ex dIDs) +-- The type of a "typeof" expression is string. +-- TODO: Added in 2014. Revisit. +astChildRules (LabUnaryPre ("typeof ", _) ex, n, sourceFragment) dIDs = + [Rule (Meta n) StringType (Just sourceFragment)] + ++ (astChildRules ex dIDs) +-- The type of the condition in a ternary expression is bool. They type of the whole expression is +-- the type of the two optional expressions. If they don't have the same type then type inference on +-- the expression fails. +astChildRules (LabTernary ex1 ex2 ex3, n, sourceFragment) dIDs = + [boolRule ex1] + ++ [Rule (Meta n) (childWSToMeta ex2) (Just sourceFragment)] + ++ [Rule (Meta n) (childWSToMeta ex3) (Just sourceFragment)] + ++ (astChildRules ex1 dIDs) + ++ (astChildRules ex2 dIDs) + ++ (astChildRules ex3 dIDs) +-- They type of an assignment expression is the type of the value that is being assigned to the +-- variable. The type of the variable is the type if its assigned value. +astChildRules (LabAssignment ("=", _) ex1 ex2, n, sourceFragment) dIDs = + [Rule (Meta n) (childWSToMeta ex2) (Just sourceFragment)] + ++ [Rule (childWSToMeta ex1) (childWSToMeta ex2) (Just sourceFragment)] + ++ (astChildRules ex1 dIDs) + ++ (astChildRules ex2 dIDs) +-- Similar to the '+' operator. This introduces a horrible cycle but I don't think I can avoid it, +-- because the new type of the variable depends on its old type. The unification algorith will have +-- to handle it. +astChildRules (LabAssignment ("+=", _) ex1 ex2, n, sourceFragment) dIDs = + [Rule (Meta n) (PlusType (childWSToMeta ex1) (childWSToMeta ex2)) (Just sourceFragment)] + ++ [Rule (childWSToMeta ex1) (Meta n) (Just sourceFragment)] + ++ (astChildRules ex1 dIDs) + ++ (astChildRules ex2 dIDs) +-- Similar to the '-', '*' and '%' operators. This also introduces a cycle, but I don't think I can +-- avoid it, as the new type of the variable depends on its old type. The unification algorithm will +-- have to handle it. +astChildRules (LabAssignment (op, _) ex1 ex2, n, sourceFragment) dIDs | elem op ["-=", "*=", "%="] = + [Rule (Meta n) (IntAndInt (childWSToMeta ex1) (childWSToMeta ex2)) (Just sourceFragment)] + ++ [Rule (childWSToMeta ex1) (Meta n) (Just sourceFragment)] + ++ [Rule (childWSToMeta ex2) NumType (Just sourceFragment)] + ++ (astChildRules ex1 dIDs) + ++ (astChildRules ex2 dIDs) +-- Similar to the '/' operator. +astChildRules (LabAssignment (op, _) ex1 ex2, n, sourceFragment) dIDs | elem op ["/="] = + [Rule (Meta n) FloatType (Just sourceFragment)] + ++ [Rule (childWSToMeta ex1) FloatType (Just sourceFragment)] + ++ [Rule (childWSToMeta ex2) NumType (Just sourceFragment)] + ++ (astChildRules ex1 dIDs) + ++ (astChildRules ex2 dIDs) +-- Bitwise operator assignments. See bitwise operators above. +astChildRules (LabAssignment op ex1 ex2, n, sourceFragment) dIDs = + [Rule (Meta n) IntType (Just sourceFragment)] + ++ [Rule (childWSToMeta ex1) NumType (Just sourceFragment)] + ++ [Rule (childWSToMeta ex2) NumType (Just sourceFragment)] + ++ (astChildRules ex1 dIDs) + ++ (astChildRules ex2 dIDs) +-- The type of an identifier is the same as the type of the variable it contains and vice versa. +astChildRules (LabIdentifier var, n, sourceFragment) dIDs = + [Rule (Meta n) (childToMeta var) (Just sourceFragment)] + ++ [Rule (childToMeta var) (Meta n) (Just sourceFragment)] + ++ (varChildRules var dIDs) +-- The type of a reference statement equals reference type and the type of that reference type +-- equals the type of the statement. +astChildRules (LabReference ex1 ex2, n, sourceFragment) dIDs = + [Rule (Meta n) (ReferenceType (childWSToMeta ex1) (getPropName ex2)) (Just sourceFragment)] + ++ [Rule (ReferenceType (childWSToMeta ex1) (getPropName ex2)) (Meta n) (Just sourceFragment)] + -- The object must contain the property being referenced. + ++ [Rule (childWSToMeta ex1) (AtLeastObjectType [(getPropName ex2)]) (Just sourceFragment)] + ++ (astChildRules ex1 dIDs) + where + getPropName (LabIdentifier (prop, q), r, sf) = VariableProperty prop +-- An index represents a reference to a property of an object or an element of an array using square +-- bracket notation. There is no way to differentiate between the two using local static analysis. +astChildRules (LabIndex ex1 ex2, n, sourceFragment) dIDs = + (astChildRules ex1 dIDs) + -- I don't really want to require the index to be an int literal or a string literal.In the case + -- of arrays, we don't care about the types of particular elements, we justcare that all + -- elements have the same type. Of course this is not the case for objects,since we need to know + -- which property of the object we are modifying so we can check itstype (i.e. the *value* of + -- the index matters). + + -- Having said that, accesses to previously non-existent elements of arrays after their creation + -- simply "creates" the element (returns undefined on reads and adds the element the the array + -- on writes, I'm pretty sure). If we define the type of an array to be array-type plus its size + -- plus the type of its elements then adding elements to arrays after creation is not type safe. + -- If we define the type of an array to be array-type plus the type of its elements then adding + -- elements to an array after creation is type safe (provided sub- operations are type safe; + -- e.g. the types of the elements remains homogeneous). Both are legitimate definitions. If we + -- use the first definition then we require the user to define the array at its creation, which + -- translates easily to C (as C doesn't automatically cope with dynamic arrays); but it means + -- that we can't allow indexing of the array via anything but an integer literal. If we use the + -- second definition then our C needs to implement dynamically expanding arrays; growing the + -- array to accomodate any index that comes up during execution and filling any un- assigned + -- elements to undefined. But it also means that we can support loops over arrays rather than + -- failing type inference on the array whenever the user tries to loop over it. A big win! This + -- is why this project needs a precise definition of type safety. + + -- Shane says that we should support dynamic arrays with elements that are all of the same type + -- or undefined. For now I will just assume that all arrays have static size. I will also ignore + -- the Array constructor for now and only deal with literally defined arrays. + + -- TODO: To make this work I will need to differentiate between references into arrays and + -- references into objects. + + -- TODO: Also need to do something with the type of the index. Basically if the thing we're + -- indexing into is an array then the index must be of type int. For the moment we will ignore + -- (as in, pretend it can't happen) references to properties of array objects, other than + -- elements of the array, using square brackets. + + -- If the index is an integer literal then the statement has type ReferenceType and the + -- reference has the same type as the statement. + ++ + (if (isIntLiteral ex2) then + [Rule (Meta n) (ReferenceType (childWSToMeta ex1) (IndexProperty $ getIntLiteral ex2)) (Just sourceFragment)] + ++ [Rule (ReferenceType (childWSToMeta ex1) (IndexProperty $ getIntLiteral ex2)) (Meta n) (Just sourceFragment)] + -- The object or array must contain the member being referenced. + ++ [Rule (childWSToMeta ex1) (AtLeastObjectType [(IndexProperty $ getIntLiteral ex2)]) (Just sourceFragment)] + -- If the index is a string literal then the statement has type ReferenceType and the reference + -- has the same type as the statement. + else if (isStringLiteral ex2) then + [Rule + (Meta n) + (ReferenceType (childWSToMeta ex1) (VariableProperty $ getStringLiteral ex2)) + (Just sourceFragment) + ] + ++ + [Rule + (ReferenceType (childWSToMeta ex1) (VariableProperty $ getStringLiteral ex2)) + (Meta n) + (Just sourceFragment) + ] + ++ + -- The object or array must contain the member being referenced. + [Rule + (childWSToMeta ex1) + (AtLeastObjectType [(VariableProperty $ getStringLiteral ex2)]) + (Just sourceFragment) + ] + -- If the index is not an integer or sting literal then we cannot determine its value. + else + -- Record the type of the reference, even though we don't know which property it is. In the + -- case that the object is an array, all such rules must relate references to elements of + -- that array to the same type. + [Rule (Meta n) (ReferenceType (childWSToMeta ex1) (UnknownProperty)) (Just sourceFragment)] + ++ [Rule (ReferenceType (childWSToMeta ex1) (UnknownProperty)) (Meta n) (Just sourceFragment)] + -- If the object is not an array then type inference on the object and all of its members + -- must fail. + ++ [Rule (childWSToMeta ex1) (CorruptIfObjectType (childWSToMeta ex1)) (Just sourceFragment)] + -- If the object is an array then the index must have reference type (because we are, for + -- now, disregarding the case where the user references a property of the array other than + -- an element.) + ++ [Rule (childWSToMeta ex2) (IntIfArrayType (childWSToMeta ex1)) (Just sourceFragment)] + -- FIXME: Does this need to be outside the "if"? + ++ (astChildRules ex2 dIDs)) +-- The type of a LabValue is the type of the value it contains. +astChildRules (LabValue val, n, sourceFragment) dIDs = + [Rule (Meta n) (childToMeta val) (Just sourceFragment)] + ++ (valueChildRules val dIDs) +-- The type of a function call is the EvaluationType , +-- where fun has type +-- . +-- is equal to (i.e. should unify with) y. +astChildRules (LabCall ex1 ex2, n, sourceFragment) dIDs = + [Rule (Meta n) (EvaluationType (childWSToMeta ex1)) (Just sourceFragment)] + -- The arguments passed to the function when calling it should match the parameters in the + -- function definition. + ++ [Rule (ArgumentsIDType (childWSToMeta ex1)) (ArgumentsType (argsToMeta ex2)) (Just sourceFragment)] + ++ (astChildRules ex1 dIDs) + ++ (astChildRules ex2 dIDs) + where + argsToMeta (LabArguments args, n, sf) = map childWSToMeta args +-- TODO: Do I need to bind n to something? (is it ever a link in the chain?) Not much to say about +-- arguments. +-- +-- TODO: Does this even get called? +astChildRules (LabArguments args, n, sourceFragment) dIDs = mapASTChildRules args dIDs +-- The type of a ParenExpression is they type of the expression it contains. +astChildRules (LabParenExpression ex, n, sourceFragment) dIDs = + [Rule (Meta n) (childWSToMeta ex) (Just sourceFragment)] + ++ [Rule (childWSToMeta ex) (Meta n) (Just sourceFragment)] + ++ (astChildRules ex dIDs) +-- TODO: Do I need to bind n to something? (is it ever a link in the chain?) +-- +-- Not much to say about break statments. They don't really have a type and I don't think that they +-- can be used on the RHS of an assignment, nor can they be returned or return anything (in the +-- normal sense). +astChildRules (LabBreak var, n, sourceFragment) dIDs = maybeVarChildRules var dIDs +-- TODO: Do I need to bind n to something? (is it ever a link in the chain?) +-- +-- Not much to say about continue statments. They don't really have a type and I don't think that +-- they can be used on the RHS of an assignment, nor can they be returned or return anything (in the +-- normal sense). +astChildRules (LabContinue var, n, sourceFragment) dIDs = maybeVarChildRules var dIDs +-- TODO: Do I need to bind n to something? (is it ever a link in the chain?) +-- +-- Not much to say about throw statments. They don't really have a type and I don't think that they +-- can be used on the RHS of an assignment, nor can they be returned or return anything (in the +-- normal sense). +astChildRules (LabThrow ex, n, sourceFragment) dIDs = (astChildRules ex dIDs) +-- A CallExpression is a reference to a property of an evaluation of a function that returns an +-- object. +astChildRules (LabCallExpression ex1 (".", _) ex2, n, sourceFragment) dIDs = + -- The type of the statement is ReferenceType and the type of that reference is the type of the + -- statement. + [Rule (Meta n) (ReferenceType (childWSToMeta ex1) (getPropName ex2)) (Just sourceFragment)] + ++ [Rule (ReferenceType (childWSToMeta ex1) (getPropName ex2)) (Meta n) (Just sourceFragment)] + -- The object must containt the property being reference. + ++ [Rule (childWSToMeta ex1) (AtLeastObjectType [(getPropName ex2)]) (Just sourceFragment)] + ++ (astChildRules ex1 dIDs) + where + -- Assuming that property names appear here as identifiers. + -- + -- FIXME: Not sure if correct. + getPropName (LabIdentifier (prop, q), r, sf) = VariableProperty prop +-- A CallExpression is a reference to a property of an evaluation of a function that returns an +-- object. +astChildRules (LabCallExpression ex1 ("[]", _) ex2, n, sourceFragment) dIDs = + (astChildRules ex1 dIDs) + ++ + -- If the index is an integer literal then the type of the statment is ReferenceType and the + -- type of that reference is the type of they statement. + (if (isIntLiteral $ ex2) then + [Rule (Meta n) (ReferenceType (childWSToMeta ex1) (IndexProperty (getIntLiteral ex2))) (Just sourceFragment)] + ++ [Rule (ReferenceType (childWSToMeta ex1) (IndexProperty (getIntLiteral ex2))) (Meta n) (Just sourceFragment)] + -- The object must contain the property being referenced. + ++ [Rule (childWSToMeta ex1) (AtLeastObjectType [(IndexProperty (getIntLiteral ex2))]) (Just sourceFragment)] + -- If the index is a string literal then the type of the statment is ReferenceType and the type + -- of that reference is the type of they statement. + else if (isStringLiteral ex2) then + [Rule + (Meta n) + (ReferenceType (childWSToMeta ex1) (VariableProperty (getStringLiteral ex2))) + (Just sourceFragment) + ] + ++ + [Rule + (ReferenceType (childWSToMeta ex1) (VariableProperty (getStringLiteral ex2))) + (Meta n) + (Just sourceFragment) + ] + ++ + -- The object must contain the property being referenced. + [Rule + (childWSToMeta ex1) + (AtLeastObjectType [(VariableProperty (getStringLiteral ex2))]) + (Just sourceFragment) + ] + -- If the type of the index is not an int or string literal then we cannot know its value and + -- thus type inference on the object fails. + else + [Rule (Meta n) AmbiguousType (Just sourceFragment)] + ++ [Rule (childWSToMeta ex1) AmbiguousType (Just sourceFragment)] + ++ (astChildRules ex2 dIDs)) +-- The type of the statment is functionType. A FunctionType includes an ArgumentsIDType, a +-- ReturnType and a ConstructorType. +astChildRules (LabFunctionExpression mv vls body, n, sourceFragment) dIDs = + [Rule + (Meta n) + (FunctionType + (ArgumentsIDType (Meta n)) + (ReturnType (childWSToMeta body)) + (ConstructorType (childWSToMeta body))) + (Just sourceFragment) + ] + -- Make a rule for the types of the arguments. + ++ [Rule + (ArgumentsIDType (Meta n)) + (ArgumentsType (map (makeIDType . argMakeLabel) vls)) + (Just sourceFragment) + ] + -- Make rules for the name of the function expression if it has one. + ++ (nameRule mv (funExprMakeLabel thisFunEx) n) + where + thisFunEx = (LabFunctionExpression mv vls body, n, sourceFragment) + nameRule Nothing _ _= [] + nameRule _ Nothing _ = [] + nameRule (Just (name, x)) (Just d) y = + [Rule (Meta x) (makeIDType d) (Just sourceFragment)] + ++ [Rule (makeIDType d) (Meta y) (Just sourceFragment)] + makeIDType (DeclaredIdentifier ident lab) = IdentifierType ident lab +-- Variable declarations. +astChildRules (LabVarDeclaration var mex, n, sourceFragment) dIDs = + -- The type of the statement equals the type of mex if mex is not Nothing. + (maybeMetaRule n mex) + -- The type of the variable is equal to the type of mex if mex is not Nothing. + ++ (maybeMetaRule (childGetLabel var) mex) + ++ (varChildRules var dIDs) + ++ (maybeASTChildRules mex dIDs) + where + maybeMetaRule x Nothing = [Rule (Meta x) UndefType (Just sourceFragment)] + maybeMetaRule x (Just expr) = [Rule (Meta x) (childWSToMeta expr) (Just sourceFragment)] +-- The type of a 'new' statment is they instantiation type of the function (constructor) that it +-- calls. +astChildRules (LabNew (LabCall ex1 ex2, p, sourceFragment1), n, sourceFragment2) dIDs = + [Rule (Meta n) (InstantiationType (childWSToMeta ex1)) (Just sourceFragment2)] + -- The types of the arguments that the constructor is called with must match the types of the + -- arguments in its definition. + ++ [Rule (ArgumentsIDType (childWSToMeta ex1)) (ArgumentsType (argsToMeta ex2)) (Just sourceFragment1)] + ++ (astChildRules ex1 dIDs) + ++ (astChildRules ex2 dIDs) + where + argsToMeta (LabArguments args, n, sf) = map childWSToMeta args diff --git a/build.sh b/build.sh new file mode 100755 index 0000000..2de8b24 --- /dev/null +++ b/build.sh @@ -0,0 +1,4 @@ +#!/bin/bash +cd ~/code/JSTypeInference/JSTypeInference/haskell/source +ghc -o ../out/Main Main.hs -outputdir "../out" +