From c887f38536febf68b305131b20f5061d98dac777 Mon Sep 17 00:00:00 2001 From: rjwright Date: Mon, 21 Jul 2014 15:39:48 +1000 Subject: [PATCH 01/20] Line length --- ParseJS.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/ParseJS.hs b/ParseJS.hs index db67bb6..1d8ae95 100644 --- a/ParseJS.hs +++ b/ParseJS.hs @@ -645,12 +645,13 @@ arrayGetElements [(NS (JSElision e) srcSpan)] current 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) +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) From f234be8bdace406e53081ff3aefca885561736b2 Mon Sep 17 00:00:00 2001 From: rjwright Date: Mon, 21 Jul 2014 18:17:22 +1000 Subject: [PATCH 02/20] Replaced pattern matches for Maybes with listToMaybe etc. --- ParseJS.hs | 105 ++++++++++++++++---------------------- ResolveSourceFragments.hs | 9 +++- 2 files changed, 51 insertions(+), 63 deletions(-) diff --git a/ParseJS.hs b/ParseJS.hs index 1d8ae95..b920288 100644 --- a/ParseJS.hs +++ b/ParseJS.hs @@ -66,6 +66,7 @@ import Data.Maybe ( catMaybes , fromJust , isJust + , listToMaybe , mapMaybe ) import Language.JavaScript.Parser (parse) @@ -206,7 +207,14 @@ jsnGetSource :: JSNode -> SrcSpan jsnGetSource (NS _ srcSpan) = srcSpan --- Make a List or a ParenExpression from a Statement JSNode. +-- Statement is basically a JSAST wrapper for an Expression. If the original parse tree Node was a +-- JSExpression, then we will get a (Statement List [Expression]). Some of our data types want a +-- JSAST and some want an Expression. This function is for getting a List out of a (Statement List +-- [Expression]) JSAST node. +-- +-- This is an artifact of trying to have Expressions as terminal (or near-terminal) nodes in the +-- AST, and thus wanting Expressions to contain other Expressions. I think JSAST and Expression +-- should be merged, however. Then, this function can probably go. jsnToListExp :: JSNode -> ExprWithSourceSpan jsnToListExp jsn = statementToListExp $ toJSAST jsn @@ -215,28 +223,13 @@ jsnToListExp jsn = statementToListExp [AWSS (Statement expr) _] = expr --- 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 - - identifierGetString :: Node -> String identifierGetString (JSIdentifier jsid) = jsid -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 ExprWithSourceSpan +listToMaybeExpression [] = Nothing +listToMaybeExpression jsn = Just $ listToJSASTExpression jsn -- Some parser nodes contain lists of JSNodes that represent whole expressions. This function takes @@ -310,6 +303,15 @@ toJSASTArguments args srcSpan = getJSASTArgument nodes = listToJSASTExpression nodes +toJSASTVarDeclaration :: JSNode -> ExprWithSourceSpan +toJSASTVarDeclaration (NS (JSVarDecl name value) srcSpan) = + EWSS + (VarDeclaration + (identifierGetString $ jsnGetNode name) + (listToMaybeExpression value)) + srcSpan + + -- 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. @@ -361,16 +363,12 @@ 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) = +toJSAST (NS (JSBreak label _) srcSpan) = [AWSS (Statement - (EWSS (Break (Just $ identifierGetString $ jsnGetNode label)) srcSpan)) + (EWSS + (Break (liftM (identifierGetString . jsnGetNode) (listToMaybe label))) + srcSpan)) srcSpan ] toJSAST (NS (JSCase cs body) srcSpan) = @@ -388,20 +386,12 @@ toJSAST (NS (JSCatch var test body) srcSpan) = (AWSS (Block (toJSAST body)) (jsnGetSource 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) = +-- TODO: In a JSContinue we always have either a list contiaining just a literal semicolon, or list +-- with a value and a literal semicolon. +toJSAST (NS (JSContinue label) srcSpan) = [AWSS (Statement - (EWSS (Continue (Just $ identifierGetString $ jsnGetNode label)) srcSpan)) + (EWSS (Continue (liftM (identifierGetString . jsnGetNode) (listToMaybe $ init label))) srcSpan)) srcSpan ] toJSAST (NS (JSDefault body) srcSpan) = @@ -444,9 +434,9 @@ toJSAST (NS (JSFinally body) srcSpan) = toJSAST (NS (JSFor vars test count body) srcSpan) = [AWSS (For - (jsnToMaybeListExp vars) - (jsnToMaybeListExp test) - (jsnToMaybeListExp count) + (liftM jsnToListExp (listToMaybe vars)) + (liftM jsnToListExp (listToMaybe test)) + (liftM jsnToListExp (listToMaybe count)) (AWSS (Block (toJSAST body)) (jsnGetSource body))) srcSpan ] @@ -465,8 +455,8 @@ toJSAST (NS (JSForVar vars test count body) srcSpan) = [AWSS (ForVar (map toJSASTVarDeclaration vars) - (jsnToMaybeListExp test) - (jsnToMaybeListExp count) + (liftM jsnToListExp (listToMaybe test)) + (liftM jsnToListExp (listToMaybe count)) (AWSS (Block (toJSAST body)) (jsnGetSource body))) srcSpan ] @@ -514,18 +504,18 @@ toJSAST (NS (JSLabelled label 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) = +toJSAST (NS (JSReturn value) srcSpan) = [AWSS (Return - (EWSS (Value JSUndefined) srcSpan)) - srcSpan - ] -toJSAST (NS (JSReturn [val, semi]) srcSpan) = - [AWSS - (Return - (jsnToListExp val)) + (returnValue value)) srcSpan ] + 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] -> ExprWithSourceSpan + returnValue [semi] = EWSS (Value JSUndefined) srcSpan + returnValue [val, semi] = jsnToListExp val toJSAST (NS (JSSwitch var cases) srcSpan) = [AWSS (Switch @@ -728,17 +718,10 @@ makeJSASTExpression (NS (JSExpressionTernary expr ifTrue ifFalse) srcSpan) = (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) = +makeJSASTExpression (NS (JSFunctionExpression name args body) srcSpan) = EWSS (FunctionExpression - (Just $ identifierGetString $ jsnGetNode name) + (liftM (identifierGetString . jsnGetNode) (listToMaybe name)) (map (identifierGetString . jsnGetNode) args) (AWSS (FunctionBody (toJSAST body)) (jsnGetSource body))) srcSpan diff --git a/ResolveSourceFragments.hs b/ResolveSourceFragments.hs index 75dbc37..512289d 100644 --- a/ResolveSourceFragments.hs +++ b/ResolveSourceFragments.hs @@ -168,8 +168,7 @@ makeSourceFragment (SpanPoint _ startRow startCol) (SpanPoint _ nextRow nextCol) -- WSDefault JSASTWithSourceFragment -- WSDoWhile JSASTWithSourceFragment ExprWithSourceFragment -- WSFinally JSASTWithSourceFragment --- WSForIn [Variable] ExprWithSourceFragment JSASTWithSourceFragment --- WSIf ExprWithSourceFragment JSASTWithSourceFragment + -- WSForIn [Variable] ExprWithSourceFragment JSASTWithSourceFragment -- WSIfElse ExprWithSourceFragment JSASTWithSourceFragment JSASTWithSourceFragment -- WSLabelled Variable JSASTWithSourceFragment -- WSSwitch ExprWithSourceFragment JSASTWithSourceFragment @@ -253,6 +252,12 @@ jsastMakeSourceFragment (AWSS (FunctionDeclaration var args body) srcSpan) fileN -- The body is the last child of the function declaration,so it has the same end point. (jsastMakeSourceFragment body fileName nextSpan)) (makeSourceFragment srcSpan nextSpan fileName) +jsastMakeSourceFragment (AWSS (If expr body) srcSpan) fileName nextSpan = + AWSF + (WSIf + (exprMakeSourceFragment expr fileName (jsastGetSpan body)) + (jsastMakeSourceFragment body fileName nextSpan)) + (makeSourceFragment srcSpan nextSpan fileName) jsastMakeSourceFragment (AWSS (Return expr) srcSpan) fileName nextSpan = AWSF (WSReturn (exprMakeSourceFragment expr fileName nextSpan)) From 37e6911abefd74861a0ea8b5759b9d1a161a75a2 Mon Sep 17 00:00:00 2001 From: rjwright Date: Mon, 21 Jul 2014 18:50:24 +1000 Subject: [PATCH 03/20] Renamed JSAST to AST. --- DeclarationGraph.hs | 20 +- LabelJSAST.hs => LabelAST.hs | 168 ++++++++--------- Main.hs | 60 +++--- ParseJS.hs | 356 +++++++++++++++++------------------ PrettyPrint.hs | 34 ++-- ResolveSourceFragments.hs | 152 ++++++++------- TypeRules.hs | 20 +- 7 files changed, 401 insertions(+), 409 deletions(-) rename LabelJSAST.hs => LabelAST.hs (77%) diff --git a/DeclarationGraph.hs b/DeclarationGraph.hs index 28ba5dc..2731e3f 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 @@ -333,18 +333,18 @@ mapFunExprGetAllRules [] rules = rules 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) + (mapASTChildRules astLab dIDs) + (mapASTGetFR astLab (ParentGlobal astLab) dIDs) + (mapASTGetFER astLab (ParentGlobal astLab) dIDs) + (concat $ map astGetVarDecs astLab) fragment TopLevel where -- Get identifiers for everything declared at the global level. - dIDs = (concat $ map astGetVarDecs jsastLab) + dIDs = (concat $ map astGetVarDecs astLab) -- Find all indentifiers declared in the signature and body of a function. @@ -697,7 +697,7 @@ maybeExprGetVarDecs Nothing = [] maybeExprGetVarDecs (Just ex) = exprGetVarDecs ex --- Find all identifiers declared in a JSAST. All of these, with the exception of +-- Find all identifiers declared in a AST. All of these, with the exception of -- LabFunctionDeclaration and LabLabelled, return nothing or recursively process any AST or -- expression fields. astGetVarDecs :: ASTChild -> [DeclaredIdentifier] diff --git a/LabelJSAST.hs b/LabelAST.hs similarity index 77% rename from LabelJSAST.hs rename to LabelAST.hs index 0b994b1..6223339 100644 --- a/LabelJSAST.hs +++ b/LabelAST.hs @@ -14,20 +14,20 @@ -- limitations under the License. --- This module takes a JSAST and gives each vertex a unique integer label. The label counter is simply +-- 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 (jsastListWSMakeSourceFragments (getJSASTWithSource (parseTree program file) file) span)) +-- (label (astListWSMakeSourceFragments (getASTWithSource (parseTree program file) file) span)) -module LabelJSAST +module LabelAST ( ASTChild , ExprChild , IndexChild -, JSASTLabel +, ASTLabel , LabelledExpression(..) -, LabelledJSAST(..) +, LabelledAST(..) , LabelledPropertyName(..) , LabelledValue(..) , OpChild @@ -47,39 +47,39 @@ import System.Environment -- A type for the labels. -type JSASTLabel = Int +type ASTLabel = Int -- A Variable and a label. -type VarChild = (Variable, JSASTLabel) +type VarChild = (Variable, ASTLabel) -- An Operator and a label. -type OpChild = (Operator, JSASTLabel) +type OpChild = (Operator, ASTLabel) -- An Index and a label. -type IndexChild = (Index, JSASTLabel) +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, JSASTLabel) +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, JSASTLabel) +type ValueChild = (LabelledValue, ASTLabel) -- A LabelledExpression (which is a labelled subtree) and a label. -type ExprChild = (LabelledExpression, JSASTLabel, SourceFragment) +type ExprChild = (LabelledExpression, ASTLabel, SourceFragment) --- A LabelledJSAST (which is a labelled subree) an a label. -type ASTChild = (LabelledJSAST, JSASTLabel, SourceFragment) +-- A LabelledAST (which is a labelled subree) an a label. +type ASTChild = (LabelledAST, ASTLabel, SourceFragment) -- A wrapper for a VarChild or IndexChild that identifies it as a name for a an object property. @@ -130,8 +130,8 @@ data LabelledExpression = | LabVarDeclaration VarChild (Maybe ExprChild) deriving (Show) --- A recursively labelled subrtree, rooted at a LabelledJSAST. -data LabelledJSAST = +-- A recursively labelled subrtree, rooted at a LabelledAST. +data LabelledAST = LabBlock [ASTChild] | LabCase ExprChild ASTChild | LabCatch VarChild (Maybe ExprChild) ASTChild @@ -155,90 +155,90 @@ data LabelledJSAST = -- Takes an unlabelled AST and labels the whole thing. -label :: [JSASTWithSourceFragment] -> [ASTChild] -label list = labelJSASTList list 0 +label :: [ASTWithSourceFragment] -> [ASTChild] +label list = labelASTList list 0 --- Extract the JSASTLabel from a VarChild, IndexChild etc. -childGetLabel :: (a, JSASTLabel) -> JSASTLabel +-- Extract the ASTLabel from a VarChild, IndexChild etc. +childGetLabel :: (a, ASTLabel) -> ASTLabel childGetLabel (child, lab) = lab --- Extract the JSASTLabel from a ASTChild, ExprChild etc. -childWSGetLabel :: (a, JSASTLabel, b) -> JSASTLabel +-- Extract the ASTLabel from a ASTChild, ExprChild 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, JSASTLabel)] -> [JSASTLabel] +listGetLabels :: [(a, ASTLabel)] -> [ASTLabel] listGetLabels [] = [] listGetLabels (c:cs) = ((childGetLabel c):(listGetLabels cs)) -- Extract the labels from a list of ASTChild, ExprChild etc. -listWSGetLabels :: [(a, JSASTLabel, b)] -> [JSASTLabel] +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, JSASTLabel)) -> JSASTLabel -> JSASTLabel +maxMaybeLabel :: (Maybe (a, ASTLabel)) -> ASTLabel -> ASTLabel -- 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 +maxMaybeWSLabel :: (Maybe (a, ASTLabel, b)) -> ASTLabel -> ASTLabel -- 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 :: [Variable] -> ASTLabel -> [VarChild] labelVarList [] _ = [] labelVarList (v:vx) n = (v, n + 1):(labelVarList vx (n + 1)) -- Label a list of Expressions. -labelExpressionList :: [ExprWithSourceFragment] -> JSASTLabel -> [ExprChild] +labelExpressionList :: [ExprWithSourceFragment] -> ASTLabel -> [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 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 -> JSASTLabel -> VarChild +labelVariable :: Variable -> ASTLabel -> VarChild labelVariable var n = (var, n + 1) -- Label a Maybe Variable if it is not Nothing. -labelMaybeVar :: (Maybe Variable) -> JSASTLabel -> (Maybe VarChild) +labelMaybeVar :: (Maybe Variable) -> ASTLabel -> (Maybe VarChild) labelMaybeVar Nothing n = Nothing labelMaybeVar (Just var) n = Just (labelVariable var n) -- Label an Operator. -labelOperator :: Operator -> JSASTLabel -> OpChild +labelOperator :: Operator -> ASTLabel -> OpChild labelOperator op n = (op, n + 1) -- Label an Index. -labelIndex :: Index -> JSASTLabel -> IndexChild +labelIndex :: Index -> ASTLabel -> IndexChild labelIndex ix n = (ix, n + 1) -- Label a PropertyName. -- -- TODO: Unit test? -labelPropertyName :: PropertyName -> JSASTLabel -> PropertyNameChild +labelPropertyName :: PropertyName -> ASTLabel -> PropertyNameChild labelPropertyName (IndexProperty ix) n = (LabIndexProperty field1, (childGetLabel field1) + 1) where @@ -250,7 +250,7 @@ labelPropertyName (VariableProperty var) n = -- Label a Value. Recursively process any child fields. -labelValue :: ValueWithSourceFragment -> JSASTLabel -> ValueChild +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) @@ -269,7 +269,7 @@ labelValue (WSNull) n = (LabNull, n + 1) -- Label an Expression. Recursively process any child fields. -labelExpression :: ExprWithSourceFragment -> JSASTLabel -> ExprChild +labelExpression :: ExprWithSourceFragment -> ASTLabel -> ExprChild labelExpression (EWSF (WSList ex) sourceFragment) n = ((LabList (field1)), (maximum ((listWSGetLabels field1) ++ [n])) + 1, sourceFragment) where @@ -361,7 +361,7 @@ labelExpression (EWSF (WSFunctionExpression var vars ast) sourceFragment) n = where field1 = labelMaybeVar var n field2 = labelVarList vars (maxMaybeLabel field1 n) - field3 = labelJSAST ast (maximum ((listGetLabels field2) ++ [n])) + field3 = labelAST ast (maximum ((listGetLabels field2) ++ [n])) labelExpression (EWSF (WSVarDeclaration var ex) sourceFragment) n = ((LabVarDeclaration field1 field2), (maxMaybeWSLabel field2 (childGetLabel field1)) + 1, sourceFragment) where @@ -374,33 +374,33 @@ labelExpression (EWSF (WSNew ex) sourceFragment) n = -- Label a Maybe Expression if it is not Nothing. -labelMaybeExpression :: (Maybe ExprWithSourceFragment) -> JSASTLabel -> (Maybe ExprChild) +labelMaybeExpression :: (Maybe ExprWithSourceFragment) -> ASTLabel -> (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 = +-- Label a AST. Recursively process any child fields. +labelAST :: ASTWithSourceFragment -> ASTLabel -> ASTChild +labelAST (AWSF (WSBlock astList) sourceFragment) n = ((LabBlock field1), (maximum ((listWSGetLabels field1) ++ [n])) + 1, sourceFragment) where - field1 = labelJSASTList jsastLs n -labelJSAST (AWSF (WSFunctionBody jsastLs) sourceFragment) n = + field1 = labelASTList astList n +labelAST (AWSF (WSFunctionBody astList) sourceFragment) n = ((LabFunctionBody field1), (maximum ((listWSGetLabels field1) ++ [n])) + 1, sourceFragment) where - field1 = labelJSASTList jsastLs n -labelJSAST (AWSF (WSFunctionDeclaration var args body) sourceFragment) n = + 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 = labelJSAST body $ maximum ((listGetLabels field2) ++ [childGetLabel field1]) -labelJSAST (AWSF (WSLabelled var body) sourceFragment) n = + 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 = labelJSAST body (childGetLabel field1) -labelJSAST (AWSF (WSForVar ex1 ex2 ex3 body) sourceFragment) 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 @@ -408,13 +408,13 @@ labelJSAST (AWSF (WSForVar ex1 ex2 ex3 body) sourceFragment) n = field3 = labelMaybeExpression ex3 $ maximum ((listWSGetLabels field1) ++ [maxMaybeWSLabel field2 n]) field4 = - labelJSAST + labelAST body $ maximum ((listWSGetLabels field1) ++ [maxMaybeWSLabel field2 n] ++ [maxMaybeWSLabel field3 n]) -labelJSAST (AWSF (WSFor ex1 ex2 ex3 body) sourceFragment) n = +labelAST (AWSF (WSFor ex1 ex2 ex3 body) sourceFragment) n = ((LabFor field1 field2 field3 field4), (childWSGetLabel field4) + 1, sourceFragment) where field1 = labelMaybeExpression ex1 n @@ -422,79 +422,79 @@ labelJSAST (AWSF (WSFor ex1 ex2 ex3 body) sourceFragment) n = field3 = labelMaybeExpression ex3 $ max (maxMaybeWSLabel field1 n) (maxMaybeWSLabel field2 n) field4 = - labelJSAST + labelAST body $ maximum ([maxMaybeWSLabel field1 n] ++ [maxMaybeWSLabel field2 n] ++ [maxMaybeWSLabel field3 n]) -labelJSAST (AWSF (WSForIn vars ex body) sourceFragment) n = +labelAST (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 = + field3 = labelAST body (childWSGetLabel field2) +labelAST (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 = + field3 = labelAST body (childWSGetLabel field2) +labelAST (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 = + field2 = labelAST body (childWSGetLabel field1) +labelAST (AWSF (WSDoWhile body ex) sourceFragment) n = ((LabDoWhile field1 field2), (childWSGetLabel field2) + 1, sourceFragment) where - field1 = labelJSAST body n + field1 = labelAST body n field2 = labelExpression ex (childWSGetLabel field1) -labelJSAST (AWSF (WSIf ex body) sourceFragment) n = +labelAST (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 = + field2 = labelAST body (childWSGetLabel field1) +labelAST (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 = + field2 = labelAST bodyT (childWSGetLabel field1) + field3 = labelAST bodyF (childWSGetLabel field2) +labelAST (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 = + field2 = labelAST cs (childWSGetLabel field1) +labelAST (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 = + field2 = labelAST body (childWSGetLabel field1) +labelAST (AWSF (WSDefault body) sourceFragment) n = ((LabDefault field1), (childWSGetLabel field1) + 1, sourceFragment) where - field1 = labelJSAST body n -labelJSAST (AWSF (WSTry body ctch) sourceFragment) n = + field1 = labelAST body n +labelAST (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 = + 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 = labelMaybeExpression ex (childGetLabel field1) - field3 = labelJSAST body (maxMaybeWSLabel field2 (childGetLabel field1)) -labelJSAST (AWSF (WSFinally body) sourceFragment) n = + field3 = labelAST body (maxMaybeWSLabel field2 (childGetLabel field1)) +labelAST (AWSF (WSFinally body) sourceFragment) n = ((LabFinally field1), (childWSGetLabel field1) + 1, sourceFragment) where - field1 = labelJSAST body n -labelJSAST (AWSF (WSReturn ex) sourceFragment) n = + field1 = labelAST body n +labelAST (AWSF (WSReturn ex) sourceFragment) n = ((LabReturn field1), (childWSGetLabel field1) + 1, sourceFragment) where field1 = labelExpression ex n -labelJSAST (AWSF (WSStatement ex) sourceFragment) n = +labelAST (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..fcefad2 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 @@ -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 "Pretty print labelled AST with labels and source fragments" + mapPrintASTChild (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" + mapPrintASTWS (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" + mapPrintASTWS (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,20 @@ 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 = + astListWSMakeSourceFragments (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 b920288..11e9b58 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,7 +30,7 @@ -- JSWith -- -- --- Top level function is (getJSASTWithSource (parseTree program file) file) +-- Top level function is (getASTWithSource (parseTree program file) file) -- @@ -40,8 +38,8 @@ module ParseJS ( Expression(..) , ExprWithSourceSpan(..) , Index -, JSAST(..) -, JSASTWithSourceSpan(..) +, AST(..) +, ASTWithSourceSpan(..) , Operator , PropertyName(..) , SourceFileName @@ -49,7 +47,7 @@ module ParseJS , Variable , jsnGetNode , parseTree -, getJSASTWithSource +, getASTWithSource ) where @@ -111,10 +109,10 @@ data Value = | JSUndefined deriving (Show) --- Represent, approximately, source elements that are expressions. None of these contain JSAST +-- Represent, approximately, source elements that are expressions. None of these contain AST -- fields except for FunctionExpression. -- --- TODO: Can FunctionExpression be moved into JSAST? (probably not). +-- TODO: Can FunctionExpression be moved into AST? (probably not). data Expression = Arguments [ExprWithSourceSpan] | Assignment Operator ExprWithSourceSpan ExprWithSourceSpan @@ -129,7 +127,7 @@ data Expression = | CallExpression ExprWithSourceSpan Operator ExprWithSourceSpan | Continue (Maybe Variable) -- 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 @@ -155,43 +153,43 @@ data Expression = -- -- 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 +data AST = + Block [ASTWithSourceSpan] + | Case ExprWithSourceSpan ASTWithSourceSpan + | Catch Variable (Maybe ExprWithSourceSpan) ASTWithSourceSpan + | Default ASTWithSourceSpan + | DoWhile ASTWithSourceSpan ExprWithSourceSpan + | Finally ASTWithSourceSpan | For (Maybe ExprWithSourceSpan) (Maybe ExprWithSourceSpan) (Maybe ExprWithSourceSpan) - JSASTWithSourceSpan - | ForIn [Variable] ExprWithSourceSpan JSASTWithSourceSpan + ASTWithSourceSpan + | ForIn [Variable] ExprWithSourceSpan ASTWithSourceSpan | 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 + ASTWithSourceSpan + | ForVarIn ExprWithSourceSpan ExprWithSourceSpan ASTWithSourceSpan + | FunctionBody [ASTWithSourceSpan] + | FunctionDeclaration Variable [Variable] ASTWithSourceSpan + | If ExprWithSourceSpan ASTWithSourceSpan + | IfElse ExprWithSourceSpan ASTWithSourceSpan ASTWithSourceSpan + | Labelled Variable ASTWithSourceSpan | Return ExprWithSourceSpan | Statement ExprWithSourceSpan - | Switch ExprWithSourceSpan JSASTWithSourceSpan - | Try JSASTWithSourceSpan JSASTWithSourceSpan - | While ExprWithSourceSpan JSASTWithSourceSpan deriving (Show) + | Switch ExprWithSourceSpan ASTWithSourceSpan + | Try ASTWithSourceSpan ASTWithSourceSpan + | While ExprWithSourceSpan ASTWithSourceSpan deriving (Show) -data JSASTWithSourceSpan = AWSS JSAST SrcSpan deriving (Show) +data ASTWithSourceSpan = AWSS AST 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. @@ -207,19 +205,19 @@ jsnGetSource :: JSNode -> SrcSpan jsnGetSource (NS _ srcSpan) = srcSpan --- Statement is basically a JSAST wrapper for an Expression. If the original parse tree Node was a +-- Statement is basically a AST wrapper for an Expression. If the original parse tree Node was a -- JSExpression, then we will get a (Statement List [Expression]). Some of our data types want a --- JSAST and some want an Expression. This function is for getting a List out of a (Statement List --- [Expression]) JSAST node. +-- AST and some want an Expression. This function is for getting a List out of a (Statement List +-- [Expression]) AST node. -- -- This is an artifact of trying to have Expressions as terminal (or near-terminal) nodes in the --- AST, and thus wanting Expressions to contain other Expressions. I think JSAST and Expression +-- AST, and thus wanting Expressions to contain other Expressions. I think AST and Expression -- should be merged, however. Then, this function can probably go. jsnToListExp :: JSNode -> ExprWithSourceSpan jsnToListExp jsn = - statementToListExp $ toJSAST jsn + statementToListExp $ toAST jsn where - statementToListExp :: [JSASTWithSourceSpan] -> ExprWithSourceSpan + statementToListExp :: [ASTWithSourceSpan] -> ExprWithSourceSpan statementToListExp [AWSS (Statement expr) _] = expr @@ -229,14 +227,14 @@ identifierGetString (JSIdentifier jsid) = jsid listToMaybeExpression :: [JSNode] -> Maybe ExprWithSourceSpan listToMaybeExpression [] = Nothing -listToMaybeExpression jsn = Just $ listToJSASTExpression jsn +listToMaybeExpression jsn = Just $ listToASTExpression jsn -- 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) _)] +listToASTExpression :: [JSNode] -> ExprWithSourceSpan +listToASTExpression [item] = makeASTExpression item +listToASTExpression [(NS (JSUnary operator) srcSpan), (NS (JSDecimal x) _)] | (operator == "-") = if (elem '.' x) then EWSS (Value xFloat) srcSpan @@ -245,66 +243,66 @@ listToJSASTExpression [(NS (JSUnary operator) srcSpan), (NS (JSDecimal x) _)] 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 (UnaryPre operator - (listToJSASTExpression x)) + (listToASTExpression x)) srcSpan -listToJSASTExpression ((NS (JSLiteral "new ") srcSpan):x) = - EWSS (New (listToJSASTExpression x)) srcSpan -listToJSASTExpression [x, (NS (JSArguments args) srcSpan)] = +listToASTExpression ((NS (JSLiteral "new ") srcSpan):x) = + EWSS (New (listToASTExpression x)) srcSpan +listToASTExpression [x, (NS (JSArguments args) srcSpan)] = EWSS (Call - (makeJSASTExpression x) - (toJSASTArguments args srcSpan)) + (makeASTExpression x) + (toASTArguments args srcSpan)) (jsnGetSource x) -listToJSASTExpression list | (isCallExpression $ last list) = - getJSASTCallExpression list +listToASTExpression list | (isCallExpression $ last list) = + getASTCallExpression list where isCallExpression :: JSNode -> Bool isCallExpression (NS (JSCallExpression "." _) _) = True isCallExpression (NS (JSCallExpression "[]" _) _) = True isCallExpression _ = False -listToJSASTExpression list | (isParenCallExp $ last list) = - getJSASTCall list +listToASTExpression list | (isParenCallExp $ last list) = + getASTCall list where isParenCallExp :: JSNode -> Bool isParenCallExp (NS (JSCallExpression "()" _) _) = True isParenCallExp _ = False -- 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] -> ExprWithSourceSpan + getASTAssignment ((NS (JSOperator op) srcSpan):xs) preCurrent | (isAssignmentOperator op) = EWSS (Assignment op - (listToJSASTExpression preCurrent) - (listToJSASTExpression xs)) + (listToASTExpression preCurrent) + (listToASTExpression xs)) (jsnGetSource $ head preCurrent) - getJSASTAssignment (x:xs) preCurrent = getJSASTAssignment xs (preCurrent ++ [x]) + getASTAssignment (x:xs) preCurrent = getASTAssignment xs (preCurrent ++ [x]) -toJSASTArguments :: [[JSNode]] -> SrcSpan -> ExprWithSourceSpan -toJSASTArguments args srcSpan = - EWSS (Arguments (map getJSASTArgument args)) srcSpan +toASTArguments :: [[JSNode]] -> SrcSpan -> ExprWithSourceSpan +toASTArguments args srcSpan = + EWSS (Arguments (map getASTArgument args)) srcSpan where - getJSASTArgument :: [JSNode] -> ExprWithSourceSpan - getJSASTArgument (item:[]) = makeJSASTExpression item - getJSASTArgument nodes = listToJSASTExpression nodes + getASTArgument :: [JSNode] -> ExprWithSourceSpan + getASTArgument (item:[]) = makeASTExpression item + getASTArgument nodes = listToASTExpression nodes -toJSASTVarDeclaration :: JSNode -> ExprWithSourceSpan -toJSASTVarDeclaration (NS (JSVarDecl name value) srcSpan) = +toASTVarDeclaration :: JSNode -> ExprWithSourceSpan +toASTVarDeclaration (NS (JSVarDecl name value) srcSpan) = EWSS (VarDeclaration (identifierGetString $ jsnGetNode name) @@ -317,26 +315,26 @@ toJSASTVarDeclaration (NS (JSVarDecl name value) srcSpan) = -- 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 = +getASTCall :: [JSNode] -> ExprWithSourceSpan +getASTCall list = EWSS (Call - (listToJSASTExpression (init list)) + (listToASTExpression (init list)) (getArgs $ last list)) (jsnGetSource $ head list) where getArgs :: JSNode -> ExprWithSourceSpan getArgs (NS (JSCallExpression _ [(NS (JSArguments args) srcSpan)]) _) = - toJSASTArguments args srcSpan + toASTArguments args 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 = +getASTCallExpression :: [JSNode] -> ExprWithSourceSpan +getASTCallExpression list = EWSS (CallExpression - (listToJSASTExpression (init list)) + (listToASTExpression (init list)) (callExpOperator $ jsnGetNode $ last list) (callExpProperty $ jsnGetNode $ last list)) (jsnGetSource $ head list) @@ -347,23 +345,23 @@ getJSASTCallExpression list = 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 + makeASTExpression expr + + +toAST :: JSNode -> [ASTWithSourceSpan] +-- These ones return a proper list of ASTs. (Haskell) Constructors which use one of these to +-- fill a field must have a [AST] for that field. +toAST (NS (JSBlock jsnode) _) = toAST jsnode +toAST (NS (JSFunctionBody bodyList) _) = concat $ map toAST bodyList +toAST (NS (JSSourceElements elementsList) _) = concat $ map toAST elementsList +toAST (NS (JSSourceElementsTop topList) _) = concat $ map toAST topList +toAST (NS (JSStatementBlock item) _) = toAST item +toAST (NS (JSStatementList statList) _) = concat $ map toAST statList +toAST (NS (JSVariables _ varDecs) srcSpan) = + map (\jsn -> AWSS (Statement (toASTVarDeclaration 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 label _) srcSpan) = +-- fill a field can have a AST for that field. +toAST (NS (JSBreak label _) srcSpan) = [AWSS (Statement (EWSS @@ -371,48 +369,48 @@ toJSAST (NS (JSBreak label _) srcSpan) = srcSpan)) srcSpan ] -toJSAST (NS (JSCase cs body) srcSpan) = +toAST (NS (JSCase cs body) srcSpan) = [AWSS (Case (jsnToListExp cs) - (AWSS (Block (toJSAST body)) (jsnGetSource body))) + (AWSS (Block (toAST body)) (jsnGetSource body))) srcSpan ] -toJSAST (NS (JSCatch var test body) srcSpan) = +toAST (NS (JSCatch var test body) srcSpan) = [AWSS (Catch (identifierGetString $ jsnGetNode var) (listToMaybeExpression test) - (AWSS (Block (toJSAST body)) (jsnGetSource body))) + (AWSS (Block (toAST body)) (jsnGetSource body))) srcSpan ] -- TODO: In a JSContinue we always have either a list contiaining just a literal semicolon, or list -- with a value and a literal semicolon. -toJSAST (NS (JSContinue label) srcSpan) = +toAST (NS (JSContinue label) srcSpan) = [AWSS (Statement (EWSS (Continue (liftM (identifierGetString . jsnGetNode) (listToMaybe $ init label))) srcSpan)) srcSpan ] -toJSAST (NS (JSDefault body) srcSpan) = +toAST (NS (JSDefault body) srcSpan) = [AWSS (Default - (AWSS (Block (toJSAST body)) (jsnGetSource body))) + (AWSS (Block (toAST body)) (jsnGetSource body))) srcSpan ] -toJSAST (NS (JSDoWhile body test semi) srcSpan) = +toAST (NS (JSDoWhile body test semi) srcSpan) = [AWSS (DoWhile - (AWSS (Block (toJSAST body)) (jsnGetSource body)) + (AWSS (Block (toAST body)) (jsnGetSource body)) (jsnToListExp test)) srcSpan ] -- TODO: Comment on where JSExpressions come from. -toJSAST (NS (JSExpression jsnList) srcSpan) = +toAST (NS (JSExpression jsnList) srcSpan) = [AWSS (Statement (EWSS - (List (map listToJSASTExpression (getSublists jsnList []))) + (List (map listToASTExpression (getSublists jsnList []))) (jsnGetSource $ head jsnList))) srcSpan ] @@ -424,87 +422,87 @@ toJSAST (NS (JSExpression jsnList) srcSpan) = [current] ++ (getSublists rest []) getSublists (node:rest) current = getSublists rest (current ++ [node]) getSublists [] current = [current] -toJSAST (NS (JSFinally body) srcSpan) = +toAST (NS (JSFinally body) srcSpan) = [AWSS (Finally - (AWSS (Block (toJSAST body)) (jsnGetSource body))) + (AWSS (Block (toAST body)) (jsnGetSource 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) = +toAST (NS (JSFor vars test count body) srcSpan) = [AWSS (For (liftM jsnToListExp (listToMaybe vars)) (liftM jsnToListExp (listToMaybe test)) (liftM jsnToListExp (listToMaybe count)) - (AWSS (Block (toJSAST body)) (jsnGetSource body))) + (AWSS (Block (toAST body)) (jsnGetSource 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) = +toAST (NS (JSForIn vars obj body) srcSpan) = [AWSS (ForIn (map (identifierGetString . jsnGetNode) vars) (jsnToListExp obj) - (AWSS (Block (toJSAST body)) (jsnGetSource body))) + (AWSS (Block (toAST body)) (jsnGetSource body))) srcSpan ] -- JSForVar occurs in the case that variables are declared in the loop statement. -toJSAST (NS (JSForVar vars test count body) srcSpan) = +toAST (NS (JSForVar vars test count body) srcSpan) = [AWSS (ForVar - (map toJSASTVarDeclaration vars) + (map toASTVarDeclaration vars) (liftM jsnToListExp (listToMaybe test)) (liftM jsnToListExp (listToMaybe count)) - (AWSS (Block (toJSAST body)) (jsnGetSource body))) + (AWSS (Block (toAST body)) (jsnGetSource 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) = +toAST (NS (JSForVarIn var obj body) srcSpan) = [AWSS (ForVarIn - (toJSASTVarDeclaration var) + (toASTVarDeclaration var) (jsnToListExp obj) - (AWSS (Block (toJSAST body)) (jsnGetSource body))) + (AWSS (Block (toAST body)) (jsnGetSource body))) srcSpan ] -toJSAST (NS (JSFunction name inputs body) srcSpan) = +toAST (NS (JSFunction name inputs body) srcSpan) = [AWSS (FunctionDeclaration (identifierGetString $ jsnGetNode name) (map (identifierGetString . jsnGetNode) inputs) - (AWSS (FunctionBody (toJSAST body)) (jsnGetSource body))) + (AWSS (FunctionBody (toAST body)) (jsnGetSource body))) srcSpan ] -toJSAST (NS (JSIf test body) srcSpan) = +toAST (NS (JSIf test body) srcSpan) = [AWSS (If (jsnToListExp test) - (AWSS (Block (toJSAST body)) (jsnGetSource body))) + (AWSS (Block (toAST body)) (jsnGetSource body))) srcSpan ] -toJSAST (NS (JSIfElse test trueBody falseBody) srcSpan) = +toAST (NS (JSIfElse test trueBody falseBody) srcSpan) = [AWSS (IfElse (jsnToListExp test) - (AWSS (Block (toJSAST trueBody)) (jsnGetSource trueBody)) - (AWSS (Block (toJSAST falseBody)) (jsnGetSource falseBody))) + (AWSS (Block (toAST trueBody)) (jsnGetSource trueBody)) + (AWSS (Block (toAST falseBody)) (jsnGetSource falseBody))) srcSpan ] -- TODO: Comment on what a JSLabelled is. -toJSAST (NS (JSLabelled label body) srcSpan) = +toAST (NS (JSLabelled label body) srcSpan) = [AWSS (Labelled (identifierGetString $ jsnGetNode label) - (AWSS (Block (toJSAST body)) (jsnGetSource body))) + (AWSS (Block (toAST body)) (jsnGetSource body))) srcSpan ] -- FIXME: Not 100% sure that this is safe. -- TODO: Comment on where these come from. -toJSAST (NS (JSLiteral ";") srcSpan) = [] -toJSAST (NS (JSReturn value) srcSpan) = +toAST (NS (JSLiteral ";") srcSpan) = [] +toAST (NS (JSReturn value) srcSpan) = [AWSS (Return (returnValue value)) @@ -516,51 +514,51 @@ toJSAST (NS (JSReturn value) srcSpan) = returnValue :: [JSNode] -> ExprWithSourceSpan returnValue [semi] = EWSS (Value JSUndefined) srcSpan returnValue [val, semi] = jsnToListExp val -toJSAST (NS (JSSwitch var cases) srcSpan) = +toAST (NS (JSSwitch var cases) srcSpan) = [AWSS (Switch (jsnToListExp var) -- TODO: Check the source span for the block. (AWSS (Block - (concat $ map toJSAST cases)) + (concat $ map toAST cases)) (jsnGetSource $ head cases))) srcSpan ] -toJSAST (NS (JSThrow expr) srcSpan) = +toAST (NS (JSThrow expr) srcSpan) = [AWSS (Statement - (EWSS (Throw (toJSASTExpression expr)) srcSpan)) + (EWSS (Throw (toASTExpression expr)) srcSpan)) srcSpan ] where - toJSASTExpression :: JSNode -> ExprWithSourceSpan - toJSASTExpression (NS (JSExpression ex) _) = listToJSASTExpression ex -toJSAST (NS (JSTry body catchClause) srcSpan) = + toASTExpression :: JSNode -> ExprWithSourceSpan + toASTExpression (NS (JSExpression ex) _) = listToASTExpression ex +toAST (NS (JSTry body catchClause) srcSpan) = [AWSS (Try (AWSS (Block - (toJSAST body)) + (toAST body)) (jsnGetSource body)) -- TODO: Check the source span for the catch block. (AWSS (Block - (concat $ map toJSAST catchClause)) + (concat $ map toAST catchClause)) (jsnGetSource $ head catchClause))) srcSpan ] -toJSAST (NS (JSWhile test body) srcSpan) = +toAST (NS (JSWhile test body) srcSpan) = [AWSS (While (jsnToListExp test) - (AWSS (Block (toJSAST body)) (jsnGetSource body))) + (AWSS (Block (toAST body)) (jsnGetSource body))) srcSpan ] -- Anything else is assumed to be a statement. -toJSAST jsn = +toAST jsn = [AWSS (Statement - (makeJSASTExpression jsn)) + (makeASTExpression jsn)) (jsnGetSource jsn) ] @@ -620,7 +618,7 @@ processArray ((NS (JSElision es) srcSpan):rest) current nearestSpan = rest (current ++ [[NS (JSIdentifier "undefined") (getNearestSrcSpan srcSpan nearestSpan)]]) (getNearestSrcSpan srcSpan nearestSpan) -processArray jsa current nearestSpan = (arrayGetElements jsa current nearestSpan) +processArray jsArray current nearestSpan = arrayGetElements jsArray current nearestSpan -- Process the remainder an array literal after any leading commas have been processed. @@ -653,98 +651,98 @@ arrayGetElements (jsn:rest) current nearestSpan = -- 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) = JSArray - (map listToJSASTExpression (processArray arr [] srcSpan)) -toJSASTValue (NS (JSDecimal s) _) = + (map listToASTExpression (processArray arr [] srcSpan)) +toASTValue (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 +toASTValue (NS (JSLiteral "false") _) = JSBool False +toASTValue (NS (JSLiteral "true") _) = JSBool True -- TODO: Refactor this? (already done once but still kinda crazy) -toJSASTValue (NS (JSObjectLiteral list) _) = +toASTValue (NS (JSObjectLiteral list) _) = JSObject - (map toJSASTPropNameValue list) + (map toASTPropNameValue list) where -- Takes a JSNode that represents a property of an object and produdes a PropNameValue -- Expression. - toJSASTPropNameValue :: JSNode -> ExprWithSourceSpan - toJSASTPropNameValue + toASTPropNameValue :: JSNode -> ExprWithSourceSpan + toASTPropNameValue (NS (JSPropertyNameandValue (NS (JSIdentifier name) _) value) srcSpan) = EWSS (PropNameValue (VariableProperty name) - (listToJSASTExpression value)) + (listToASTExpression value)) srcSpan - toJSASTPropNameValue + toASTPropNameValue (NS (JSPropertyNameandValue (NS (JSDecimal index) _) value) srcSpan) = EWSS (PropNameValue (IndexProperty (read index)) - (listToJSASTExpression value)) + (listToASTExpression value)) srcSpan -toJSASTValue (NS (JSStringLiteral '"' s) _) = JSDQString s -toJSASTValue (NS (JSStringLiteral _ s) _) = JSString s +toASTValue (NS (JSStringLiteral '"' s) _) = JSDQString s +toASTValue (NS (JSStringLiteral _ s) _) = JSString s -makeJSASTExpression :: JSNode -> ExprWithSourceSpan -makeJSASTExpression (NS (JSArguments args) srcSpan) = - toJSASTArguments args srcSpan -makeJSASTExpression (NS (JSExpressionBinary operator left right) srcSpan) = +makeASTExpression :: JSNode -> ExprWithSourceSpan +makeASTExpression (NS (JSArguments args) srcSpan) = + toASTArguments args srcSpan +makeASTExpression (NS (JSExpressionBinary operator left right) srcSpan) = EWSS (Binary operator - (listToJSASTExpression left) - (listToJSASTExpression right)) + (listToASTExpression left) + (listToASTExpression right)) srcSpan -makeJSASTExpression (NS (JSExpressionParen expr) srcSpan) = +makeASTExpression (NS (JSExpressionParen expr) srcSpan) = EWSS (ParenExpression (jsnToListExp expr)) srcSpan -makeJSASTExpression (NS (JSExpressionPostfix operator variable) srcSpan) = +makeASTExpression (NS (JSExpressionPostfix operator variable) srcSpan) = EWSS (UnaryPost operator - (listToJSASTExpression variable)) + (listToASTExpression variable)) srcSpan -makeJSASTExpression (NS (JSExpressionTernary expr ifTrue ifFalse) srcSpan) = +makeASTExpression (NS (JSExpressionTernary expr ifTrue ifFalse) srcSpan) = EWSS (Ternary - (listToJSASTExpression expr) - (listToJSASTExpression ifTrue) - (listToJSASTExpression ifFalse)) + (listToASTExpression expr) + (listToASTExpression ifTrue) + (listToASTExpression ifFalse)) srcSpan -makeJSASTExpression (NS (JSFunctionExpression name args body) srcSpan) = +makeASTExpression (NS (JSFunctionExpression name args body) srcSpan) = EWSS (FunctionExpression (liftM (identifierGetString . jsnGetNode) (listToMaybe name)) (map (identifierGetString . jsnGetNode) args) - (AWSS (FunctionBody (toJSAST body)) (jsnGetSource body))) + (AWSS (FunctionBody (toAST body)) (jsnGetSource body))) srcSpan -makeJSASTExpression (NS (JSIdentifier "undefined") srcSpan) = +makeASTExpression (NS (JSIdentifier "undefined") srcSpan) = EWSS (Value JSUndefined) srcSpan -makeJSASTExpression (NS (JSIdentifier identifier) srcSpan) = +makeASTExpression (NS (JSIdentifier identifier) srcSpan) = EWSS (Identifier identifier) srcSpan -makeJSASTExpression (NS (JSLiteral "null") srcSpan) = +makeASTExpression (NS (JSLiteral "null") srcSpan) = EWSS (Value JSNull) srcSpan -makeJSASTExpression (NS (JSLiteral "this") srcSpan) = +makeASTExpression (NS (JSLiteral "this") srcSpan) = EWSS (Identifier "this") srcSpan -makeJSASTExpression (NS (JSMemberDot pre post) srcSpan) = +makeASTExpression (NS (JSMemberDot pre post) srcSpan) = EWSS (Reference - (listToJSASTExpression pre) - (makeJSASTExpression post)) + (listToASTExpression pre) + (makeASTExpression post)) srcSpan -makeJSASTExpression (NS (JSMemberSquare pre post) srcSpan) = +makeASTExpression (NS (JSMemberSquare pre post) srcSpan) = EWSS (Index - (listToJSASTExpression pre) + (listToASTExpression pre) (jsnToListExp post)) srcSpan -- Anything left unmatched here is assumed to be a literal value. -makeJSASTExpression val = - EWSS (Value (toJSASTValue val)) (jsnGetSource val) +makeASTExpression val = + EWSS (Value (toASTValue val)) (jsnGetSource val) diff --git a/PrettyPrint.hs b/PrettyPrint.hs index c4e0d05..e1c10de 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. @@ -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 @@ -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 "" @@ -577,7 +577,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 = @@ -587,13 +587,13 @@ mapPrintASTWS nodes padding printSrc = -- 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() +-- WSDefault ASTWithSourceFragment +-- WSDoWhile ASTWithSourceFragment ExprWithSourceFragment +-- WSFinally ASTWithSourceFragment +-- WSFor (Maybe ExprWithSourceFragment) (Maybe ExprWithSourceFragment) (Maybe ExprWithSourceFragment) ASTWithSourceFragment +-- WSForIn [Variable] ExprWithSourceFragment ASTWithSourceFragment +-- WSLabelled Variable ASTWithSourceFragment +printASTWS :: ASTWithSourceFragment -> String -> SourceFlag -> IO() printASTWS (AWSF (WSBlock list) sourceFragment) padding printSrc = do putStrLn (padding ++ " Block") printSource sourceFragment padding printSrc @@ -678,7 +678,7 @@ printASTWS (AWSF (WSWhile cond body) sourceFragment) padding printSrc = do printExprWS cond p printSrc printASTWS body p printSrc printASTWS (AWSF node sourceFragment) padding printSrc = do - putStrLn (padding ++ " OTHER JSAST") + putStrLn (padding ++ " OTHER AST") printSource sourceFragment padding printSrc putStrLn ((makeIndent padding) ++ " " ++ (show node)) diff --git a/ResolveSourceFragments.hs b/ResolveSourceFragments.hs index 512289d..0b17342 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,17 +26,17 @@ -- 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(..) +, ASTWSF(..) , SourceFragment(..) , ValueWithSourceFragment(..) -, jsastListWSMakeSourceFragments -, jsastMakeSourceFragment +, astListWSMakeSourceFragments +, astMakeSourceFragment ) where @@ -76,7 +74,7 @@ data ExprWSF = | WSCall ExprWithSourceFragment ExprWithSourceFragment | WSCallExpression ExprWithSourceFragment Operator ExprWithSourceFragment | WSContinue (Maybe Variable) - | WSFunctionExpression (Maybe Variable) [Variable] JSASTWithSourceFragment + | WSFunctionExpression (Maybe Variable) [Variable] ASTWithSourceFragment | WSIdentifier Variable | WSIndex ExprWithSourceFragment ExprWithSourceFragment | WSList [ExprWithSourceFragment] @@ -91,53 +89,53 @@ data ExprWSF = | 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 +data ASTWSF = + WSBlock [ASTWithSourceFragment] + | WSCase ExprWithSourceFragment ASTWithSourceFragment + | WSCatch Variable (Maybe ExprWithSourceFragment) ASTWithSourceFragment + | WSDefault ASTWithSourceFragment + | WSDoWhile ASTWithSourceFragment ExprWithSourceFragment + | WSFinally ASTWithSourceFragment + | WSFor (Maybe ExprWithSourceFragment) (Maybe ExprWithSourceFragment) (Maybe ExprWithSourceFragment) ASTWithSourceFragment + | WSForIn [Variable] ExprWithSourceFragment ASTWithSourceFragment + | WSForVar [ExprWithSourceFragment] (Maybe ExprWithSourceFragment) (Maybe ExprWithSourceFragment) ASTWithSourceFragment + | WSForVarIn ExprWithSourceFragment ExprWithSourceFragment ASTWithSourceFragment + | WSFunctionBody [ASTWithSourceFragment] + | WSFunctionDeclaration Variable [Variable] ASTWithSourceFragment + | WSIf ExprWithSourceFragment ASTWithSourceFragment + | WSIfElse ExprWithSourceFragment ASTWithSourceFragment ASTWithSourceFragment + | WSLabelled Variable ASTWithSourceFragment | WSReturn ExprWithSourceFragment | WSStatement ExprWithSourceFragment - | WSSwitch ExprWithSourceFragment JSASTWithSourceFragment - | WSTry JSASTWithSourceFragment JSASTWithSourceFragment - | WSWhile ExprWithSourceFragment JSASTWithSourceFragment deriving (Show) + | WSSwitch ExprWithSourceFragment ASTWithSourceFragment + | WSTry ASTWithSourceFragment ASTWithSourceFragment + | WSWhile ExprWithSourceFragment ASTWithSourceFragment deriving (Show) -data JSASTWithSourceFragment = - AWSF JSASTWSF SourceFragment deriving (Show) +data ASTWithSourceFragment = + AWSF ASTWSF SourceFragment deriving (Show) data ExprWithSourceFragment = EWSF ExprWSF 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) -jsastListWSMakeSourceFragments :: ([JSASTWithSourceSpan], SourceFileName) -> SrcSpan -> [JSASTWithSourceFragment] -jsastListWSMakeSourceFragments (list, fileName) nextSpan = - jsastListMakeSourceFragments list fileName nextSpan +astListWSMakeSourceFragments :: ([ASTWithSourceSpan], SourceFileName) -> SrcSpan -> [ASTWithSourceFragment] +astListWSMakeSourceFragments (list, fileName) nextSpan = + astListMakeSourceFragments list fileName nextSpan -- 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 = [] +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 [] _ nextSpan = [] -jsastGetSpan :: JSASTWithSourceSpan -> SrcSpan -jsastGetSpan (AWSS _ srcSpan) = srcSpan +astGetSpan :: ASTWithSourceSpan -> SrcSpan +astGetSpan (AWSS _ srcSpan) = srcSpan exprGetSpan :: ExprWithSourceSpan -> SrcSpan @@ -163,34 +161,34 @@ makeSourceFragment (SpanPoint _ startRow startCol) (SpanPoint _ nextRow nextCol) -- 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 --- 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 ExprWithSourceFragment ASTWithSourceFragment +-- WSCatch Variable (Maybe ExprWithSourceFragment) ASTWithSourceFragment +-- WSDefault ASTWithSourceFragment +-- WSDoWhile ASTWithSourceFragment ExprWithSourceFragment +-- WSFinally ASTWithSourceFragment + -- WSForIn [Variable] ExprWithSourceFragment ASTWithSourceFragment +-- WSIfElse ExprWithSourceFragment ASTWithSourceFragment ASTWithSourceFragment +-- WSLabelled Variable ASTWithSourceFragment +-- WSSwitch ExprWithSourceFragment ASTWithSourceFragment +-- WSTry ASTWithSourceFragment ASTWithSourceFragment +-- WSWhile ExprWithSourceFragment 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 list) srcSpan) fileName nextSpan = AWSF - (WSBlock (jsastListMakeSourceFragments list fileName nextSpan)) + (WSBlock (astListMakeSourceFragments list 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)) + (maybeExprMakeSourceFragment expr fileName (astGetSpan body)) + (astMakeSourceFragment body fileName nextSpan)) (makeSourceFragment srcSpan nextSpan fileName) where justSpanGetSpan (Just ss) = ss @@ -202,19 +200,19 @@ jsastMakeSourceFragment (AWSS (For vars cond expr body) srcSpan) fileName nextSp 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)) + (maybeExprMakeSourceFragment expr fileName (astGetSpan body)) + (astMakeSourceFragment body fileName nextSpan)) (makeSourceFragment srcSpan nextSpan fileName) where justSpanGetSpan (Just ss) = ss @@ -226,43 +224,43 @@ jsastMakeSourceFragment (AWSS (ForVar vars cond expr body) srcSpan) fileName nex 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)) + (exprMakeSourceFragment 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 (If expr body) srcSpan) fileName nextSpan = +astMakeSourceFragment (AWSS (If expr body) srcSpan) fileName nextSpan = AWSF (WSIf - (exprMakeSourceFragment expr fileName (jsastGetSpan body)) - (jsastMakeSourceFragment body fileName nextSpan)) + (exprMakeSourceFragment expr fileName (astGetSpan body)) + (astMakeSourceFragment body fileName nextSpan)) (makeSourceFragment srcSpan nextSpan fileName) -jsastMakeSourceFragment (AWSS (Return expr) srcSpan) fileName nextSpan = +astMakeSourceFragment (AWSS (Return expr) srcSpan) fileName nextSpan = AWSF (WSReturn (exprMakeSourceFragment expr fileName nextSpan)) (makeSourceFragment srcSpan nextSpan fileName) -jsastMakeSourceFragment (AWSS (Statement expr) srcSpan) fileName nextSpan = +astMakeSourceFragment (AWSS (Statement expr) srcSpan) fileName nextSpan = AWSF (WSStatement (exprMakeSourceFragment expr fileName nextSpan)) (makeSourceFragment srcSpan nextSpan fileName) @@ -339,7 +337,7 @@ exprMakeSourceFragment (EWSS (FunctionExpression name args body) srcSpan) fileNa (WSFunctionExpression name args - (jsastMakeSourceFragment body fileName nextSpan)) + (astMakeSourceFragment body fileName nextSpan)) (makeSourceFragment srcSpan nextSpan fileName) exprMakeSourceFragment (EWSS (Identifier var) srcSpan) fileName nextSpan = EWSF diff --git a/TypeRules.hs b/TypeRules.hs index 883832c..dc9e58e 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 @@ -46,7 +44,7 @@ module TypeRules ) where -import LabelJSAST +import LabelAST import ParseJS import ResolveSourceFragments @@ -119,7 +117,7 @@ data Type = | IntIfArrayType Type | IntType -- A type variable, basically. - | Meta JSASTLabel + | Meta ASTLabel | NullType | NumType -- An ObjectType contains a list of properties. @@ -188,16 +186,16 @@ argMakeLabel (var, n) = DeclaredIdentifier var (IDLabel n) -- Extract the value (strip label) from a VarChild, ExprChild, ValueChild or ASTChild. -childGetValue :: (a, JSASTLabel) -> a +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 +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 +childWSToMeta :: (a, ASTLabel, b) -> Type childWSToMeta ch = Meta (childWSGetLabel ch) -- Generate rules from a Maybe VarChild @@ -897,7 +895,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 +914,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,13 +969,13 @@ 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) From 23ea22b9b369819cf6778c8d3984d79604ae005f Mon Sep 17 00:00:00 2001 From: rjwright Date: Mon, 21 Jul 2014 20:23:59 +1000 Subject: [PATCH 04/20] Started work on merging Expression and JSAST into one type (AST). Also changed toAST to return just one ASTWithSourceSpan, and started removing nested constructors from this function. Each call to toAST should construct an ASTWithSourceSpan node and recursively call toAST on its children. --- ParseJS.hs | 534 ++++++++++++++++++++++++++++------------------------- 1 file changed, 287 insertions(+), 247 deletions(-) diff --git a/ParseJS.hs b/ParseJS.hs index 11e9b58..e7c2b1f 100644 --- a/ParseJS.hs +++ b/ParseJS.hs @@ -35,9 +35,7 @@ module ParseJS -( Expression(..) -, ExprWithSourceSpan(..) -, Index +( Index , AST(..) , ASTWithSourceSpan(..) , Operator @@ -95,7 +93,7 @@ data PropertyName = -- Represent literal values. 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. @@ -104,7 +102,7 @@ data Value = | JSInt Int | JSNull -- Objects contain a list of PropNameValues. - | JSObject [ExprWithSourceSpan] + | JSObject [ASTWithSourceSpan] | JSString String | JSUndefined deriving (Show) @@ -113,82 +111,113 @@ data Value = -- fields except for FunctionExpression. -- -- TODO: Can FunctionExpression be moved into AST? (probably not). -data Expression = - Arguments [ExprWithSourceSpan] - | Assignment Operator ExprWithSourceSpan ExprWithSourceSpan - | Binary Operator ExprWithSourceSpan ExprWithSourceSpan +-- data Expression = +-- Arguments [ASTWithSourceSpan] +-- | Assignment Operator ASTWithSourceSpan ASTWithSourceSpan +-- | Binary Operator ASTWithSourceSpan ASTWithSourceSpan +-- | Break (Maybe Variable) +-- | 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 ASTWithSourceSpan Operator ASTWithSourceSpan +-- | Continue (Maybe Variable) +-- -- A function definition on the right hand side of some statement. +-- | FunctionExpression (Maybe Variable) [Variable] ASTWithSourceSpan +-- | Identifier Variable +-- -- An index into a structure using square brackets. +-- | Index ASTWithSourceSpan ASTWithSourceSpan +-- -- TODO: Needs comment to explain what it is. +-- | List [ASTWithSourceSpan] +-- | New ASTWithSourceSpan +-- -- TODO: Needs comment to explain what it is. +-- | ParenExpression ASTWithSourceSpan +-- -- A property of an object. +-- | PropNameValue PropertyName ASTWithSourceSpan +-- -- A reference into a structure using a dot. +-- | Reference ASTWithSourceSpan ASTWithSourceSpan +-- | Ternary ASTWithSourceSpan ASTWithSourceSpan ASTWithSourceSpan +-- | Throw ASTWithSourceSpan +-- | UnaryPost Operator ASTWithSourceSpan +-- | UnaryPre Operator ASTWithSourceSpan +-- | Value Value +-- | VarDeclaration Variable (Maybe ASTWithSourceSpan) deriving (Show) + + +-- 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 + | Statement ASTWithSourceSpan + -- FIXME: I'm not sure if this should be represented as a list or not. + | 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) -- A function definition on the right hand side of some statement. | FunctionExpression (Maybe Variable) [Variable] ASTWithSourceSpan | Identifier Variable -- An index into a structure using square brackets. - | Index ExprWithSourceSpan ExprWithSourceSpan + | Index ASTWithSourceSpan ASTWithSourceSpan -- TODO: Needs comment to explain what it is. - | List [ExprWithSourceSpan] - | New ExprWithSourceSpan + | List [ASTWithSourceSpan] + | New ASTWithSourceSpan -- 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 + | Ternary ASTWithSourceSpan ASTWithSourceSpan ASTWithSourceSpan + | Throw ASTWithSourceSpan + | UnaryPost Operator ASTWithSourceSpan + | UnaryPre Operator ASTWithSourceSpan | Value Value - | VarDeclaration Variable (Maybe ExprWithSourceSpan) 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 AST = - Block [ASTWithSourceSpan] - | Case ExprWithSourceSpan ASTWithSourceSpan - | Catch Variable (Maybe ExprWithSourceSpan) ASTWithSourceSpan - | Default ASTWithSourceSpan - | DoWhile ASTWithSourceSpan ExprWithSourceSpan - | Finally ASTWithSourceSpan - | For - (Maybe ExprWithSourceSpan) - (Maybe ExprWithSourceSpan) - (Maybe ExprWithSourceSpan) - ASTWithSourceSpan - | ForIn [Variable] ExprWithSourceSpan ASTWithSourceSpan - | ForVar - [ExprWithSourceSpan] - (Maybe ExprWithSourceSpan) - (Maybe ExprWithSourceSpan) - ASTWithSourceSpan - | ForVarIn ExprWithSourceSpan ExprWithSourceSpan ASTWithSourceSpan - | FunctionBody [ASTWithSourceSpan] - | FunctionDeclaration Variable [Variable] ASTWithSourceSpan - | If ExprWithSourceSpan ASTWithSourceSpan - | IfElse ExprWithSourceSpan ASTWithSourceSpan ASTWithSourceSpan - | Labelled Variable ASTWithSourceSpan - | Return ExprWithSourceSpan - | Statement ExprWithSourceSpan - | Switch ExprWithSourceSpan ASTWithSourceSpan - | Try ASTWithSourceSpan ASTWithSourceSpan - | While ExprWithSourceSpan ASTWithSourceSpan deriving (Show) + | VarDeclaration Variable (Maybe ASTWithSourceSpan) + deriving (Show) data ASTWithSourceSpan = AWSS AST SrcSpan deriving (Show) -data ExprWithSourceSpan = EWSS Expression SrcSpan deriving (Show) +-- data ASTWithSourceSpan = AWSS Expression SrcSpan deriving (Show) -getASTWithSource :: JSNode -> SourceFileName -> ([ASTWithSourceSpan], SourceFileName) +getASTWithSource :: JSNode -> SourceFileName -> (ASTWithSourceSpan, SourceFileName) getASTWithSource jsn fileName = ((toAST jsn), fileName) @@ -213,49 +242,49 @@ jsnGetSource (NS _ srcSpan) = srcSpan -- This is an artifact of trying to have Expressions as terminal (or near-terminal) nodes in the -- AST, and thus wanting Expressions to contain other Expressions. I think AST and Expression -- should be merged, however. Then, this function can probably go. -jsnToListExp :: JSNode -> ExprWithSourceSpan +jsnToListExp :: JSNode -> ASTWithSourceSpan jsnToListExp jsn = statementToListExp $ toAST jsn where - statementToListExp :: [ASTWithSourceSpan] -> ExprWithSourceSpan - statementToListExp [AWSS (Statement expr) _] = expr + statementToListExp :: ASTWithSourceSpan -> ASTWithSourceSpan + statementToListExp (AWSS (Statement expr) _) = expr identifierGetString :: Node -> String identifierGetString (JSIdentifier jsid) = jsid -listToMaybeExpression :: [JSNode] -> Maybe ExprWithSourceSpan +listToMaybeExpression :: [JSNode] -> Maybe ASTWithSourceSpan listToMaybeExpression [] = Nothing listToMaybeExpression jsn = Just $ listToASTExpression jsn -- Some parser nodes contain lists of JSNodes that represent whole expressions. This function takes -- such a list of Nodes and builds a single expression. -listToASTExpression :: [JSNode] -> ExprWithSourceSpan -listToASTExpression [item] = makeASTExpression item +listToASTExpression :: [JSNode] -> ASTWithSourceSpan +listToASTExpression [item] = toAST item listToASTExpression [(NS (JSUnary operator) srcSpan), (NS (JSDecimal x) _)] | (operator == "-") = if (elem '.' x) then - EWSS (Value xFloat) srcSpan + AWSS (Value xFloat) srcSpan else - EWSS (Value xInt) srcSpan + AWSS (Value xInt) srcSpan where xFloat = JSFloat (-1 * (read x)) xInt = JSInt (-1 * (read x)) listToASTExpression ((NS (JSUnary operator) srcSpan):x) | elem operator ["-", "+", "--", "++", "!", "typeof ", "delete ", "~"] = - EWSS + AWSS (UnaryPre operator (listToASTExpression x)) srcSpan listToASTExpression ((NS (JSLiteral "new ") srcSpan):x) = - EWSS (New (listToASTExpression x)) srcSpan + AWSS (New (listToASTExpression x)) srcSpan listToASTExpression [x, (NS (JSArguments args) srcSpan)] = - EWSS + AWSS (Call - (makeASTExpression x) + (toAST x) (toASTArguments args srcSpan)) (jsnGetSource x) listToASTExpression list | (isCallExpression $ last list) = @@ -280,10 +309,10 @@ listToASTExpression list = | elem op ["=", "+=", "-=", "*=", "/=", "%=", "<<=", ">>=", ">>>=", "&=", "^=", "|="] = True | otherwise = False - getASTAssignment :: [JSNode] -> [JSNode] -> ExprWithSourceSpan + getASTAssignment :: [JSNode] -> [JSNode] -> ASTWithSourceSpan getASTAssignment ((NS (JSOperator op) srcSpan):xs) preCurrent | (isAssignmentOperator op) = - EWSS + AWSS (Assignment op (listToASTExpression preCurrent) @@ -292,18 +321,18 @@ listToASTExpression list = getASTAssignment (x:xs) preCurrent = getASTAssignment xs (preCurrent ++ [x]) -toASTArguments :: [[JSNode]] -> SrcSpan -> ExprWithSourceSpan +toASTArguments :: [[JSNode]] -> SrcSpan -> ASTWithSourceSpan toASTArguments args srcSpan = - EWSS (Arguments (map getASTArgument args)) srcSpan + AWSS (Arguments (map getASTArgument args)) srcSpan where - getASTArgument :: [JSNode] -> ExprWithSourceSpan - getASTArgument (item:[]) = makeASTExpression item + getASTArgument :: [JSNode] -> ASTWithSourceSpan + getASTArgument (item:[]) = toAST item getASTArgument nodes = listToASTExpression nodes -toASTVarDeclaration :: JSNode -> ExprWithSourceSpan +toASTVarDeclaration :: JSNode -> ASTWithSourceSpan toASTVarDeclaration (NS (JSVarDecl name value) srcSpan) = - EWSS + AWSS (VarDeclaration (identifierGetString $ jsnGetNode name) (listToMaybeExpression value)) @@ -315,24 +344,24 @@ toASTVarDeclaration (NS (JSVarDecl name value) srcSpan) = -- JSArguments but for now I'm just going to hope not. -- -- TODO: Find out what values the arguments list can have. -getASTCall :: [JSNode] -> ExprWithSourceSpan +getASTCall :: [JSNode] -> ASTWithSourceSpan getASTCall list = - EWSS + AWSS (Call (listToASTExpression (init list)) (getArgs $ last list)) (jsnGetSource $ head list) where - getArgs :: JSNode -> ExprWithSourceSpan + getArgs :: JSNode -> ASTWithSourceSpan getArgs (NS (JSCallExpression _ [(NS (JSArguments args) srcSpan)]) _) = toASTArguments args srcSpan -- To handle the case where the last element in the list is a (JSCallExpression "[]" exp) or a -- (JSCallExpression "." exp). -getASTCallExpression :: [JSNode] -> ExprWithSourceSpan +getASTCallExpression :: [JSNode] -> ASTWithSourceSpan getASTCallExpression list = - EWSS + AWSS (CallExpression (listToASTExpression (init list)) (callExpOperator $ jsnGetNode $ last list) @@ -342,78 +371,104 @@ getASTCallExpression list = callExpOperator :: Node -> Operator callExpOperator (JSCallExpression operator _) = operator -- FIXME: This assumes that the expression list can only ever be singleton. Verify. - callExpProperty :: Node -> ExprWithSourceSpan + callExpProperty :: Node -> ASTWithSourceSpan callExpProperty (JSCallExpression "[]" [expr]) = jsnToListExp expr callExpProperty (JSCallExpression "." [expr]) = - makeASTExpression expr - - -toAST :: JSNode -> [ASTWithSourceSpan] --- These ones return a proper list of ASTs. (Haskell) Constructors which use one of these to --- fill a field must have a [AST] for that field. -toAST (NS (JSBlock jsnode) _) = toAST jsnode -toAST (NS (JSFunctionBody bodyList) _) = concat $ map toAST bodyList -toAST (NS (JSSourceElements elementsList) _) = concat $ map toAST elementsList -toAST (NS (JSSourceElementsTop topList) _) = concat $ map toAST topList -toAST (NS (JSStatementBlock item) _) = toAST item -toAST (NS (JSStatementList statList) _) = concat $ map toAST statList + toAST expr + + +-- TODO: Remove all of the nested "Block" constructors etc. +toAST :: JSNode -> ASTWithSourceSpan +toAST (NS (JSBlock statements) srcSpan) = + AWSS + (Block + (toAST statements)) + srcSpan +toAST (NS (JSFunctionBody bodyList) srcSpan) = + AWSS + (FunctionBody (map toAST bodyList)) + srcSpan +-- FIXME: Wrapping this in a List seems wrong. +toAST (NS (JSSourceElements elementsList) srcSpan) = + AWSS + (List (map toAST elementsList)) + srcSpan +toAST (NS (JSSourceElementsTop elementsList) srcSpan) = + AWSS + (List (map toAST 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 + (List (map toAST statements)) + srcSpan +-- TODO: Do I need to do anything with the first parameter? toAST (NS (JSVariables _ varDecs) srcSpan) = - map (\jsn -> AWSS (Statement (toASTVarDeclaration jsn)) srcSpan) varDecs + -- FIXME: We might want to make a "variables" type for this. It depends on how we handle getting + -- the return value of such a list. + AWSS + (List (map toASTVarDeclaration varDecs)) + srcSpan -- These ones always return singleton lists. (Haskell) Constructors which use only these to -- fill a field can have a AST for that field. toAST (NS (JSBreak label _) srcSpan) = - [AWSS + AWSS + -- FIXME: Why is this wrapped in a "Statement"? (Statement - (EWSS + (AWSS (Break (liftM (identifierGetString . jsnGetNode) (listToMaybe label))) srcSpan)) srcSpan - ] toAST (NS (JSCase cs body) srcSpan) = - [AWSS + AWSS (Case (jsnToListExp cs) - (AWSS (Block (toAST body)) (jsnGetSource body))) + -- body is a JSStatementList. + (toAST body)) srcSpan - ] toAST (NS (JSCatch var test body) srcSpan) = - [AWSS + AWSS (Catch (identifierGetString $ jsnGetNode var) (listToMaybeExpression test) - (AWSS (Block (toAST body)) (jsnGetSource body))) + -- body is a JSBlock. + (toAST body)) srcSpan - ] -- 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 + AWSS + -- FIXME: Why is this wrapped in a "Statement"? (Statement - (EWSS (Continue (liftM (identifierGetString . jsnGetNode) (listToMaybe $ init label))) srcSpan)) + (AWSS (Continue (liftM (identifierGetString . jsnGetNode) (listToMaybe $ init label))) srcSpan)) srcSpan - ] toAST (NS (JSDefault body) srcSpan) = - [AWSS + AWSS (Default - (AWSS (Block (toAST body)) (jsnGetSource body))) + -- body is a JSStatementList. + (toAST body)) srcSpan - ] toAST (NS (JSDoWhile body test semi) srcSpan) = - [AWSS + AWSS (DoWhile - (AWSS (Block (toAST body)) (jsnGetSource body)) + -- body is a JSStatementBlock. + (toAST body) (jsnToListExp test)) srcSpan - ] -- TODO: Comment on where JSExpressions come from. toAST (NS (JSExpression jsnList) srcSpan) = - [AWSS + AWSS + -- FIXME: Why is this wrapped in a "Statement"? (Statement - (EWSS + (AWSS (List (map listToASTExpression (getSublists jsnList []))) (jsnGetSource $ head jsnList))) srcSpan - ] where -- A JSExpression contains a list of JSNodes, separated by . These need to be -- seperated (basically the s need to be stripped). @@ -423,145 +478,189 @@ toAST (NS (JSExpression jsnList) srcSpan) = getSublists (node:rest) current = getSublists rest (current ++ [node]) getSublists [] current = [current] toAST (NS (JSFinally body) srcSpan) = - [AWSS + AWSS (Finally - (AWSS (Block (toAST 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). toAST (NS (JSFor vars test count body) srcSpan) = - [AWSS + AWSS (For (liftM jsnToListExp (listToMaybe vars)) (liftM jsnToListExp (listToMaybe test)) (liftM jsnToListExp (listToMaybe count)) - (AWSS (Block (toAST body)) (jsnGetSource body))) + -- 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) toAST (NS (JSForIn vars obj body) srcSpan) = - [AWSS + AWSS (ForIn (map (identifierGetString . jsnGetNode) vars) (jsnToListExp obj) - (AWSS (Block (toAST body)) (jsnGetSource body))) + -- body is a JSStatementBlock. + (toAST body)) srcSpan - ] -- JSForVar occurs in the case that variables are declared in the loop statement. toAST (NS (JSForVar vars test count body) srcSpan) = - [AWSS + AWSS (ForVar (map toASTVarDeclaration vars) (liftM jsnToListExp (listToMaybe test)) (liftM jsnToListExp (listToMaybe count)) - (AWSS (Block (toAST body)) (jsnGetSource body))) + -- 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) toAST (NS (JSForVarIn var obj body) srcSpan) = - [AWSS + AWSS (ForVarIn (toASTVarDeclaration var) (jsnToListExp obj) - (AWSS (Block (toAST body)) (jsnGetSource body))) + -- body is a JSStatementBlock. + (toAST body)) srcSpan - ] toAST (NS (JSFunction name inputs body) srcSpan) = - [AWSS + AWSS (FunctionDeclaration (identifierGetString $ jsnGetNode name) (map (identifierGetString . jsnGetNode) inputs) - (AWSS (FunctionBody (toAST body)) (jsnGetSource body))) + (toAST body)) srcSpan - ] toAST (NS (JSIf test body) srcSpan) = - [AWSS + AWSS (If (jsnToListExp test) - (AWSS (Block (toAST body)) (jsnGetSource body))) + -- body is a JSStatementBlock. + (toAST body)) srcSpan - ] toAST (NS (JSIfElse test trueBody falseBody) srcSpan) = - [AWSS + AWSS (IfElse (jsnToListExp test) - (AWSS (Block (toAST trueBody)) (jsnGetSource trueBody)) - (AWSS (Block (toAST falseBody)) (jsnGetSource falseBody))) + (toAST trueBody) + (toAST falseBody)) srcSpan - ] -- TODO: Comment on what a JSLabelled is. toAST (NS (JSLabelled label body) srcSpan) = - [AWSS + AWSS (Labelled (identifierGetString $ jsnGetNode label) - (AWSS (Block (toAST body)) (jsnGetSource body))) + -- Body can be anything. + (toAST body)) srcSpan - ] -- FIXME: Not 100% sure that this is safe. -- TODO: Comment on where these come from. -toAST (NS (JSLiteral ";") srcSpan) = [] +-- FIXME: What do we do with this!!?? Do I need it? +-- toAST (NS (JSLiteral ";") srcSpan) = [] toAST (NS (JSReturn value) srcSpan) = - [AWSS + AWSS (Return (returnValue value)) srcSpan - ] 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] -> ExprWithSourceSpan - returnValue [semi] = EWSS (Value JSUndefined) srcSpan + returnValue :: [JSNode] -> ASTWithSourceSpan + returnValue [semi] = AWSS (Value JSUndefined) srcSpan returnValue [val, semi] = jsnToListExp val toAST (NS (JSSwitch var cases) srcSpan) = - [AWSS + AWSS (Switch (jsnToListExp var) - -- TODO: Check the source span for the block. - (AWSS - (Block - (concat $ map toAST cases)) - (jsnGetSource $ head cases))) + (map toAST cases)) srcSpan - ] toAST (NS (JSThrow expr) srcSpan) = - [AWSS + AWSS + -- FIXME: Why is this wrapped in a "Statement"? (Statement - (EWSS (Throw (toASTExpression expr)) srcSpan)) + (AWSS (Throw (toASTExpression expr)) srcSpan)) srcSpan - ] where - toASTExpression :: JSNode -> ExprWithSourceSpan + toASTExpression :: JSNode -> ASTWithSourceSpan toASTExpression (NS (JSExpression ex) _) = listToASTExpression ex toAST (NS (JSTry body catchClause) srcSpan) = - [AWSS + AWSS (Try - (AWSS - (Block - (toAST body)) - (jsnGetSource body)) - -- TODO: Check the source span for the catch block. - (AWSS (Block - (concat $ map toAST catchClause)) - (jsnGetSource $ head catchClause))) - srcSpan - ] + -- body is a JSBlock. + (toAST body) + -- Each of these is a JSCatch or a JSFinally. + (map toAST catchClause)) + srcSpan toAST (NS (JSWhile test body) srcSpan) = - [AWSS + AWSS (While (jsnToListExp test) - (AWSS (Block (toAST body)) (jsnGetSource body))) + -- body is a JSStatementBlock. + (toAST body)) srcSpan - ] -- Anything else is assumed to be a statement. -toAST jsn = - [AWSS - (Statement - (makeASTExpression jsn)) - (jsnGetSource jsn) - ] - +-- toAST jsn = +-- [AWSS +-- (Statement +-- (toAST jsn)) +-- (jsnGetSource jsn) +-- ] +-- toAST :: JSNode -> ASTWithSourceSpan +toAST (NS (JSArguments args) srcSpan) = toASTArguments args srcSpan +toAST (NS (JSExpressionBinary operator left right) srcSpan) = + AWSS + (Binary + operator + (listToASTExpression left) + (listToASTExpression right)) + srcSpan +toAST (NS (JSExpressionParen expr) srcSpan) = + AWSS + (ParenExpression + (jsnToListExp expr)) + srcSpan +toAST (NS (JSExpressionPostfix operator variable) srcSpan) = + AWSS + (UnaryPost + operator + (listToASTExpression variable)) + srcSpan +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 (identifierGetString . jsnGetNode) (listToMaybe name)) + (map (identifierGetString . 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) + (jsnToListExp 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. -- @@ -669,17 +768,17 @@ toASTValue (NS (JSObjectLiteral list) _) = where -- Takes a JSNode that represents a property of an object and produdes a PropNameValue -- Expression. - toASTPropNameValue :: JSNode -> ExprWithSourceSpan + toASTPropNameValue :: JSNode -> ASTWithSourceSpan toASTPropNameValue (NS (JSPropertyNameandValue (NS (JSIdentifier name) _) value) srcSpan) = - EWSS + AWSS (PropNameValue (VariableProperty name) (listToASTExpression value)) srcSpan toASTPropNameValue (NS (JSPropertyNameandValue (NS (JSDecimal index) _) value) srcSpan) = - EWSS + AWSS (PropNameValue (IndexProperty (read index)) (listToASTExpression value)) @@ -687,62 +786,3 @@ toASTValue (NS (JSObjectLiteral list) _) = toASTValue (NS (JSStringLiteral '"' s) _) = JSDQString s toASTValue (NS (JSStringLiteral _ s) _) = JSString s - -makeASTExpression :: JSNode -> ExprWithSourceSpan -makeASTExpression (NS (JSArguments args) srcSpan) = - toASTArguments args srcSpan -makeASTExpression (NS (JSExpressionBinary operator left right) srcSpan) = - EWSS - (Binary - operator - (listToASTExpression left) - (listToASTExpression right)) - srcSpan -makeASTExpression (NS (JSExpressionParen expr) srcSpan) = - EWSS - (ParenExpression - (jsnToListExp expr)) - srcSpan -makeASTExpression (NS (JSExpressionPostfix operator variable) srcSpan) = - EWSS - (UnaryPost - operator - (listToASTExpression variable)) - srcSpan -makeASTExpression (NS (JSExpressionTernary expr ifTrue ifFalse) srcSpan) = - EWSS - (Ternary - (listToASTExpression expr) - (listToASTExpression ifTrue) - (listToASTExpression ifFalse)) - srcSpan -makeASTExpression (NS (JSFunctionExpression name args body) srcSpan) = - EWSS - (FunctionExpression - (liftM (identifierGetString . jsnGetNode) (listToMaybe name)) - (map (identifierGetString . jsnGetNode) args) - (AWSS (FunctionBody (toAST body)) (jsnGetSource body))) - srcSpan -makeASTExpression (NS (JSIdentifier "undefined") srcSpan) = - EWSS (Value JSUndefined) srcSpan -makeASTExpression (NS (JSIdentifier identifier) srcSpan) = - EWSS (Identifier identifier) srcSpan -makeASTExpression (NS (JSLiteral "null") srcSpan) = - EWSS (Value JSNull) srcSpan -makeASTExpression (NS (JSLiteral "this") srcSpan) = - EWSS (Identifier "this") srcSpan -makeASTExpression (NS (JSMemberDot pre post) srcSpan) = - EWSS - (Reference - (listToASTExpression pre) - (makeASTExpression post)) - srcSpan -makeASTExpression (NS (JSMemberSquare pre post) srcSpan) = - EWSS - (Index - (listToASTExpression pre) - (jsnToListExp post)) - srcSpan --- Anything left unmatched here is assumed to be a literal value. -makeASTExpression val = - EWSS (Value (toASTValue val)) (jsnGetSource val) From c3ffc7dbc4da892995f194326203fbf0381d63b7 Mon Sep 17 00:00:00 2001 From: rjwright Date: Mon, 21 Jul 2014 20:53:28 +1000 Subject: [PATCH 05/20] More on merging Expression and JSAST. Doesn't build. Removed the Statement and List types. Added Expression and StatementList types. Need to add a Variables type. --- ParseJS.hs | 137 ++++++++++++++--------------------------------------- 1 file changed, 36 insertions(+), 101 deletions(-) diff --git a/ParseJS.hs b/ParseJS.hs index e7c2b1f..fa7c5b2 100644 --- a/ParseJS.hs +++ b/ParseJS.hs @@ -107,45 +107,6 @@ data Value = | JSUndefined deriving (Show) --- Represent, approximately, source elements that are expressions. None of these contain AST --- fields except for FunctionExpression. --- --- TODO: Can FunctionExpression be moved into AST? (probably not). --- data Expression = --- Arguments [ASTWithSourceSpan] --- | Assignment Operator ASTWithSourceSpan ASTWithSourceSpan --- | Binary Operator ASTWithSourceSpan ASTWithSourceSpan --- | Break (Maybe Variable) --- | 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 ASTWithSourceSpan Operator ASTWithSourceSpan --- | Continue (Maybe Variable) --- -- A function definition on the right hand side of some statement. --- | FunctionExpression (Maybe Variable) [Variable] ASTWithSourceSpan --- | Identifier Variable --- -- An index into a structure using square brackets. --- | Index ASTWithSourceSpan ASTWithSourceSpan --- -- TODO: Needs comment to explain what it is. --- | List [ASTWithSourceSpan] --- | New ASTWithSourceSpan --- -- TODO: Needs comment to explain what it is. --- | ParenExpression ASTWithSourceSpan --- -- A property of an object. --- | PropNameValue PropertyName ASTWithSourceSpan --- -- A reference into a structure using a dot. --- | Reference ASTWithSourceSpan ASTWithSourceSpan --- | Ternary ASTWithSourceSpan ASTWithSourceSpan ASTWithSourceSpan --- | Throw ASTWithSourceSpan --- | UnaryPost Operator ASTWithSourceSpan --- | UnaryPre Operator ASTWithSourceSpan --- | Value Value --- | VarDeclaration Variable (Maybe ASTWithSourceSpan) deriving (Show) - - -- Represent a node in the AST data AST = Block ASTWithSourceSpan @@ -172,8 +133,6 @@ data AST = | IfElse ASTWithSourceSpan ASTWithSourceSpan ASTWithSourceSpan | Labelled Variable ASTWithSourceSpan | Return ASTWithSourceSpan - | Statement ASTWithSourceSpan - -- FIXME: I'm not sure if this should be represented as a list or not. | Switch ASTWithSourceSpan [ASTWithSourceSpan] | Try ASTWithSourceSpan [ASTWithSourceSpan] | While ASTWithSourceSpan ASTWithSourceSpan @@ -190,13 +149,19 @@ data AST = -- description for our purposes). | 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] ASTWithSourceSpan | Identifier Variable -- An index into a structure using square brackets. | Index ASTWithSourceSpan ASTWithSourceSpan -- TODO: Needs comment to explain what it is. - | List [ASTWithSourceSpan] + -- Was called "List". + -- TODO: New type. Needs to be handled in the Rules. + | StatementList [ASTWithSourceSpan] | New ASTWithSourceSpan -- TODO: Needs comment to explain what it is. | ParenExpression ASTWithSourceSpan @@ -234,22 +199,6 @@ jsnGetSource :: JSNode -> SrcSpan jsnGetSource (NS _ srcSpan) = srcSpan --- Statement is basically a AST wrapper for an Expression. If the original parse tree Node was a --- JSExpression, then we will get a (Statement List [Expression]). Some of our data types want a --- AST and some want an Expression. This function is for getting a List out of a (Statement List --- [Expression]) AST node. --- --- This is an artifact of trying to have Expressions as terminal (or near-terminal) nodes in the --- AST, and thus wanting Expressions to contain other Expressions. I think AST and Expression --- should be merged, however. Then, this function can probably go. -jsnToListExp :: JSNode -> ASTWithSourceSpan -jsnToListExp jsn = - statementToListExp $ toAST jsn - where - statementToListExp :: ASTWithSourceSpan -> ASTWithSourceSpan - statementToListExp (AWSS (Statement expr) _) = expr - - identifierGetString :: Node -> String identifierGetString (JSIdentifier jsid) = jsid @@ -372,7 +321,7 @@ getASTCallExpression list = callExpOperator (JSCallExpression operator _) = operator -- FIXME: This assumes that the expression list can only ever be singleton. Verify. callExpProperty :: Node -> ASTWithSourceSpan - callExpProperty (JSCallExpression "[]" [expr]) = jsnToListExp expr + callExpProperty (JSCallExpression "[]" [expr]) = toAST expr callExpProperty (JSCallExpression "." [expr]) = toAST expr @@ -388,14 +337,15 @@ toAST (NS (JSFunctionBody bodyList) srcSpan) = AWSS (FunctionBody (map toAST bodyList)) srcSpan --- FIXME: Wrapping this in a List seems wrong. +-- TODO: Make sure this is handled correctly when making Rules. toAST (NS (JSSourceElements elementsList) srcSpan) = AWSS - (List (map toAST elementsList)) + (StatementList (map toAST elementsList)) srcSpan +-- TODO: Make sure this is handled correctly when making Rules. toAST (NS (JSSourceElementsTop elementsList) srcSpan) = AWSS - (List (map toAST elementsList)) + (StatementList (map toAST elementsList)) srcSpan toAST (NS (JSStatementBlock statements) srcSpan) = AWSS @@ -405,29 +355,23 @@ toAST (NS (JSStatementBlock statements) srcSpan) = srcSpan toAST (NS (JSStatementList statements) srcSpan) = AWSS - (List (map toAST statements)) + (StatementList (map toAST statements)) srcSpan -- TODO: Do I need to do anything with the first parameter? toAST (NS (JSVariables _ varDecs) srcSpan) = - -- FIXME: We might want to make a "variables" type for this. It depends on how we handle getting - -- the return value of such a list. + -- FIXME: This doesn't actually come from a JSStatementList in the parser. Should make a + -- "variables" type for this. AWSS - (List (map toASTVarDeclaration varDecs)) + (StatementList (map toASTVarDeclaration varDecs)) srcSpan --- These ones always return singleton lists. (Haskell) Constructors which use only these to --- fill a field can have a AST for that field. toAST (NS (JSBreak label _) srcSpan) = AWSS - -- FIXME: Why is this wrapped in a "Statement"? - (Statement - (AWSS - (Break (liftM (identifierGetString . jsnGetNode) (listToMaybe label))) - srcSpan)) + (Break (liftM (identifierGetString . jsnGetNode) (listToMaybe label))) srcSpan toAST (NS (JSCase cs body) srcSpan) = AWSS (Case - (jsnToListExp cs) + (toAST cs) -- body is a JSStatementList. (toAST body)) srcSpan @@ -443,9 +387,7 @@ toAST (NS (JSCatch var test body) srcSpan) = -- with a value and a literal semicolon. toAST (NS (JSContinue label) srcSpan) = AWSS - -- FIXME: Why is this wrapped in a "Statement"? - (Statement - (AWSS (Continue (liftM (identifierGetString . jsnGetNode) (listToMaybe $ init label))) srcSpan)) + (Continue (liftM (identifierGetString . jsnGetNode) (listToMaybe $ init label))) srcSpan toAST (NS (JSDefault body) srcSpan) = AWSS @@ -458,16 +400,12 @@ toAST (NS (JSDoWhile body test semi) srcSpan) = (DoWhile -- body is a JSStatementBlock. (toAST body) - (jsnToListExp test)) + (toAST test)) srcSpan -- TODO: Comment on where JSExpressions come from. toAST (NS (JSExpression jsnList) srcSpan) = AWSS - -- FIXME: Why is this wrapped in a "Statement"? - (Statement - (AWSS - (List (map listToASTExpression (getSublists jsnList []))) - (jsnGetSource $ head jsnList))) + (Expression (map listToASTExpression (getSublists jsnList []))) srcSpan where -- A JSExpression contains a list of JSNodes, separated by . These need to be @@ -487,9 +425,9 @@ toAST (NS (JSFinally body) srcSpan) = toAST (NS (JSFor vars test count body) srcSpan) = AWSS (For - (liftM jsnToListExp (listToMaybe vars)) - (liftM jsnToListExp (listToMaybe test)) - (liftM jsnToListExp (listToMaybe count)) + (liftM toAST (listToMaybe vars)) + (liftM toAST (listToMaybe test)) + (liftM toAST (listToMaybe count)) -- body is a JSStatementBlock. (toAST body)) srcSpan @@ -499,7 +437,7 @@ toAST (NS (JSForIn vars obj body) srcSpan) = AWSS (ForIn (map (identifierGetString . jsnGetNode) vars) - (jsnToListExp obj) + (toAST obj) -- body is a JSStatementBlock. (toAST body)) srcSpan @@ -508,8 +446,8 @@ toAST (NS (JSForVar vars test count body) srcSpan) = AWSS (ForVar (map toASTVarDeclaration vars) - (liftM jsnToListExp (listToMaybe test)) - (liftM jsnToListExp (listToMaybe count)) + (liftM toAST (listToMaybe test)) + (liftM toAST (listToMaybe count)) -- body is a JSStatementBlock. (toAST body)) srcSpan @@ -519,7 +457,7 @@ toAST (NS (JSForVarIn var obj body) srcSpan) = AWSS (ForVarIn (toASTVarDeclaration var) - (jsnToListExp obj) + (toAST obj) -- body is a JSStatementBlock. (toAST body)) srcSpan @@ -533,14 +471,14 @@ toAST (NS (JSFunction name inputs body) srcSpan) = toAST (NS (JSIf test body) srcSpan) = AWSS (If - (jsnToListExp test) + (toAST test) -- body is a JSStatementBlock. (toAST body)) srcSpan toAST (NS (JSIfElse test trueBody falseBody) srcSpan) = AWSS (IfElse - (jsnToListExp test) + (toAST test) (toAST trueBody) (toAST falseBody)) srcSpan @@ -566,18 +504,16 @@ toAST (NS (JSReturn value) srcSpan) = -- 2-list containing a JSNode (representing the value to be returned) and a semicolon. returnValue :: [JSNode] -> ASTWithSourceSpan returnValue [semi] = AWSS (Value JSUndefined) srcSpan - returnValue [val, semi] = jsnToListExp val + returnValue [val, semi] = toAST val toAST (NS (JSSwitch var cases) srcSpan) = AWSS (Switch - (jsnToListExp var) + (toAST var) (map toAST cases)) srcSpan toAST (NS (JSThrow expr) srcSpan) = AWSS - -- FIXME: Why is this wrapped in a "Statement"? - (Statement - (AWSS (Throw (toASTExpression expr)) srcSpan)) + (Throw (toASTExpression expr)) srcSpan where toASTExpression :: JSNode -> ASTWithSourceSpan @@ -593,7 +529,7 @@ toAST (NS (JSTry body catchClause) srcSpan) = toAST (NS (JSWhile test body) srcSpan) = AWSS (While - (jsnToListExp test) + (toAST test) -- body is a JSStatementBlock. (toAST body)) srcSpan @@ -616,7 +552,7 @@ toAST (NS (JSExpressionBinary operator left right) srcSpan) = toAST (NS (JSExpressionParen expr) srcSpan) = AWSS (ParenExpression - (jsnToListExp expr)) + (toAST expr)) srcSpan toAST (NS (JSExpressionPostfix operator variable) srcSpan) = AWSS @@ -656,7 +592,7 @@ toAST (NS (JSMemberSquare pre post) srcSpan) = AWSS (Index (listToASTExpression pre) - (jsnToListExp post)) + (toAST post)) srcSpan -- Anything left unmatched here is assumed to be a literal value. toAST val = @@ -785,4 +721,3 @@ toASTValue (NS (JSObjectLiteral list) _) = srcSpan toASTValue (NS (JSStringLiteral '"' s) _) = JSDQString s toASTValue (NS (JSStringLiteral _ s) _) = JSString s - From 585ed1bb88ce89e8261a269fee77718cb5c45401 Mon Sep 17 00:00:00 2001 From: rjwright Date: Tue, 22 Jul 2014 18:45:23 +1000 Subject: [PATCH 06/20] More work on merging JSAST and Expression. This is a WIP. It compiles now, but only because I commented out some things. --- DeclarationGraph.hs | 307 +++++------ LabelAST.hs | 386 +++++++------- Main.hs | 24 +- ParseJS.hs | 183 +++---- PrettyPrint.hs | 368 +++++++------- ResolveSourceFragments.hs | 347 ++++++------- TypeRules.hs | 1013 +++++++++++++++++++------------------ 7 files changed, 1307 insertions(+), 1321 deletions(-) diff --git a/DeclarationGraph.hs b/DeclarationGraph.hs index 2731e3f..5518ad1 100644 --- a/DeclarationGraph.hs +++ b/DeclarationGraph.hs @@ -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 astLab fragment = FunctionRules GlobalID - (mapASTChildRules astLab dIDs) - (mapASTGetFR astLab (ParentGlobal astLab) dIDs) - (mapASTGetFER astLab (ParentGlobal astLab) dIDs) - (concat $ map astGetVarDecs astLab) + (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 astLab) + 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 = @@ -490,7 +491,8 @@ astGetFunRules (LabStatement ex, n, sourceFragment) parent dIDs = [] -- 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 +508,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 +541,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 +615,48 @@ 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 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] + --- Find variable declarations in a Maybe ExprChild. -maybeExprGetVarDecs :: (Maybe ExprChild) -> [DeclaredIdentifier] +-- Make FunctionExpressionRules from Maybe ASTChild. +getMaybeFunExprRules :: (Maybe ASTChild) -> ParentFunction -> [DeclaredIdentifier] -> [FunctionExpressionRules] +getMaybeFunExprRules Nothing parent dIDs = [] +getMaybeFunExprRules (Just ex) parent dIDs = astGetFunExprRules ex parent dIDs + + +-- Find variable declarations in a Maybe ASTChild. +maybeExprGetVarDecs :: (Maybe ASTChild) -> [DeclaredIdentifier] maybeExprGetVarDecs Nothing = [] -maybeExprGetVarDecs (Just ex) = exprGetVarDecs ex +maybeExprGetVarDecs (Just ex) = astGetVarDecs ex -- Find all identifiers declared in a AST. All of these, with the exception of --- LabFunctionDeclaration and LabLabelled, return nothing or recursively process any AST or --- expression fields. +-- 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 +671,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 +681,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 +714,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 index 6223339..72061c8 100644 --- a/LabelAST.hs +++ b/LabelAST.hs @@ -23,10 +23,8 @@ module LabelAST ( ASTChild -, ExprChild -, IndexChild , ASTLabel -, LabelledExpression(..) +, IndexChild , LabelledAST(..) , LabelledPropertyName(..) , LabelledValue(..) @@ -75,10 +73,11 @@ type ValueChild = (LabelledValue, ASTLabel) -- A LabelledExpression (which is a labelled subtree) and a label. -type ExprChild = (LabelledExpression, ASTLabel, SourceFragment) +-- 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) @@ -92,78 +91,76 @@ data LabelledPropertyName = -- value and no label. LabelledValues representing objects and arrays are labelled recursively. -- LabUndefined and LabNull have no value or label. data LabelledValue = - LabArray [ExprChild] + LabArray [ASTChild] | LabBool Bool | LabDQString String | LabFloat Double | LabInt Int | LabNull - | LabObject [ExprChild] + | LabObject [ASTChild] | 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 LabelledAST. data LabelledAST = - LabBlock [ASTChild] - | LabCase ExprChild ASTChild - | LabCatch VarChild (Maybe ExprChild) ASTChild + LabBlock ASTChild + | LabCase ASTChild ASTChild + | LabCatch VarChild (Maybe ASTChild) ASTChild | LabDefault ASTChild - | LabDoWhile ASTChild ExprChild + | LabDoWhile ASTChild ASTChild | 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 + | 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 ExprChild ASTChild - | LabIfElse ExprChild ASTChild ASTChild + | LabIf ASTChild ASTChild + | LabIfElse ASTChild ASTChild ASTChild | LabLabelled VarChild ASTChild - | LabReturn ExprChild - | LabStatement ExprChild - | LabSwitch ExprChild ASTChild + | LabReturn ASTChild + | LabStatement ASTChild + | LabSwitch ASTChild ASTChild | LabTry ASTChild ASTChild - | LabWhile ExprChild ASTChild deriving (Show) + | 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 :: 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, ExprChild etc. +-- Extract the ASTLabel from a ASTChild, ASTChild etc. childWSGetLabel :: (a, ASTLabel, b) -> ASTLabel childWSGetLabel (_, lab, _) = lab @@ -175,7 +172,7 @@ listGetLabels :: [(a, ASTLabel)] -> [ASTLabel] listGetLabels [] = [] listGetLabels (c:cs) = ((childGetLabel c):(listGetLabels cs)) --- Extract the labels from a list of ASTChild, ExprChild etc. +-- Extract the labels from a list of ASTChild, ASTChild etc. listWSGetLabels :: [(a, ASTLabel, b)] -> [ASTLabel] listWSGetLabels [] = [] listWSGetLabels (c:cs) = ((childWSGetLabel c):(listWSGetLabels cs)) @@ -201,10 +198,10 @@ labelVarList (v:vx) n = (v, n + 1):(labelVarList vx (n + 1)) -- Label a list of Expressions. -labelExpressionList :: [ExprWithSourceFragment] -> ASTLabel -> [ExprChild] +labelExpressionList :: [ASTWithSourceFragment] -> ASTLabel -> [ASTChild] labelExpressionList [] _ = [] labelExpressionList (e:ex) n = - let (le, m, sf) = labelExpression e n in ((le, m, sf):(labelExpressionList ex m)) + let (le, m, sf) = labelAST e n in ((le, m, sf):(labelExpressionList ex m)) -- Label a list of ASTs. @@ -268,123 +265,21 @@ labelValue (WSUndefined) n = (LabUndefined, n + 1) labelValue (WSNull) n = (LabNull, n + 1) --- Label an Expression. Recursively process any child fields. -labelExpression :: ExprWithSourceFragment -> ASTLabel -> 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 = labelAST 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) -> ASTLabel -> (Maybe ExprChild) -labelMaybeExpression Nothing n = Nothing -labelMaybeExpression (Just ex) n = Just $ labelExpression ex n +-- FIXME: Replace with monad operations. +labelMaybeAST :: (Maybe ASTWithSourceFragment) -> ASTLabel -> (Maybe ASTChild) +labelMaybeAST Nothing n = Nothing +labelMaybeAST (Just ex) n = Just $ labelAST ex n -- Label a AST. Recursively process any child fields. labelAST :: ASTWithSourceFragment -> ASTLabel -> ASTChild -labelAST (AWSF (WSBlock astList) sourceFragment) n = - ((LabBlock field1), (maximum ((listWSGetLabels field1) ++ [n])) + 1, sourceFragment) +-- 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 = labelASTList astList n + field1 = labelAST body n labelAST (AWSF (WSFunctionBody astList) sourceFragment) n = ((LabFunctionBody field1), (maximum ((listWSGetLabels field1) ++ [n])) + 1, sourceFragment) where @@ -404,9 +299,9 @@ labelAST (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]) + field2 = labelMaybeAST ex2 $ maximum ((listWSGetLabels field1) ++ [n]) field3 = - labelMaybeExpression ex3 $ maximum ((listWSGetLabels field1) ++ [maxMaybeWSLabel field2 n]) + labelMaybeAST ex3 $ maximum ((listWSGetLabels field1) ++ [maxMaybeWSLabel field2 n]) field4 = labelAST body @@ -417,10 +312,10 @@ labelAST (AWSF (WSForVar ex1 ex2 ex3 body) sourceFragment) n = labelAST (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) + field1 = labelMaybeAST ex1 n + field2 = labelMaybeAST ex2 (maxMaybeWSLabel field1 n) field3 = - labelMaybeExpression ex3 $ max (maxMaybeWSLabel field1 n) (maxMaybeWSLabel field2 n) + labelMaybeAST ex3 $ max (maxMaybeWSLabel field1 n) (maxMaybeWSLabel field2 n) field4 = labelAST body @@ -432,59 +327,61 @@ labelAST (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]) + 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 = labelExpression ex1 n - field2 = labelExpression ex2 (childWSGetLabel field1) + 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 = labelExpression ex n + 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 = labelExpression ex (childWSGetLabel field1) + field2 = labelAST ex (childWSGetLabel field1) labelAST (AWSF (WSIf ex body) sourceFragment) n = ((LabIf field1 field2), (childWSGetLabel field2) + 1, sourceFragment) where - field1 = labelExpression ex n + 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 = labelExpression ex n + field1 = labelAST ex n field2 = labelAST bodyT (childWSGetLabel field1) field3 = labelAST bodyF (childWSGetLabel field2) -labelAST (AWSF (WSSwitch ex cs) sourceFragment) n = - ((LabSwitch field1 field2), (childWSGetLabel field2) + 1, sourceFragment) - where - field1 = labelExpression ex n - field2 = labelAST cs (childWSGetLabel field1) +-- 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 = labelExpression ex n + 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 -labelAST (AWSF (WSTry body ctch) sourceFragment) n = - ((LabTry field1 field2), (childWSGetLabel field2) + 1, sourceFragment) - where - field1 = labelAST body n - field2 = labelAST ctch (childWSGetLabel field1) +-- 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 = labelMaybeExpression ex (childGetLabel field1) + field2 = labelMaybeAST ex (childGetLabel field1) field3 = labelAST body (maxMaybeWSLabel field2 (childGetLabel field1)) labelAST (AWSF (WSFinally body) sourceFragment) n = ((LabFinally field1), (childWSGetLabel field1) + 1, sourceFragment) @@ -493,8 +390,117 @@ labelAST (AWSF (WSFinally body) sourceFragment) n = labelAST (AWSF (WSReturn ex) sourceFragment) n = ((LabReturn field1), (childWSGetLabel field1) + 1, sourceFragment) where - field1 = labelExpression ex n + field1 = labelAST ex n labelAST (AWSF (WSStatement ex) sourceFragment) n = ((LabStatement field1), (childWSGetLabel field1) + 1, sourceFragment) where - field1 = labelExpression ex n + 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/Main.hs b/Main.hs index fcefad2..9a6cd7d 100644 --- a/Main.hs +++ b/Main.hs @@ -67,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. @@ -103,18 +103,18 @@ main = do -- Print the cleaned ATS with labels and source. putStrLn "" putStrLn "Pretty print labelled AST with labels and source fragments" - mapPrintASTChild (makeLabelledAST pr infile) (makeIndent "") True True + printASTChild (makeLabelledAST pr infile) (makeIndent "") True True -- **PRETTY PRINTED** -- Pretty print the ASTWithSourceFragment with source fragments putStrLn "" putStrLn "Pretty print ASTWithSourceFragment with source fragments" - mapPrintASTWS (makeASTWithSourceFragments pr infile) (makeIndent "") True + printASTWS (makeASTWithSourceFragments pr infile) (makeIndent "") True -- **PRETTY PRINTED** -- Pretty print the ASTWithSourceFragment without source fragments putStrLn "" putStrLn "Pretty print ASTWithSourceFragment without source fragments" - mapPrintASTWS (makeASTWithSourceFragments pr infile) (makeIndent "") False + printASTWS (makeASTWithSourceFragments pr infile) (makeIndent "") False -- Prints the first AST (pre-labels). -- putStrLn "" @@ -153,16 +153,14 @@ makeDeclarationGraph input fileName = (fileName, 1, 1, ((length $ lines input) + 1), 1) -makeLabelledAST :: String -> SourceFileName -> [ASTChild] +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. -makeASTWithSourceFragments :: String -> SourceFileName -> [ASTWithSourceFragment] +makeASTWithSourceFragments :: String -> SourceFileName -> ASTWithSourceFragment makeASTWithSourceFragments input fileName = - astListWSMakeSourceFragments (makeAST input fileName) (SpanPoint fileName ((length $ lines input) + 1) 1) + astWSMakeSourceFragment (makeAST input fileName) (SpanPoint fileName ((length $ lines input) + 1) 1) -makeAST :: String -> SourceFileName -> ([ASTWithSourceSpan], SourceFileName) +makeAST :: String -> SourceFileName -> (ASTWithSourceSpan, SourceFileName) makeAST input fileName = getASTWithSource (parseTree input fileName) fileName diff --git a/ParseJS.hs b/ParseJS.hs index fa7c5b2..fdec75c 100644 --- a/ParseJS.hs +++ b/ParseJS.hs @@ -92,6 +92,7 @@ data PropertyName = -- Represent literal values. +-- TODO: Rename these from JSX to ASTX data Value = JSArray [ASTWithSourceSpan] | JSBool Bool @@ -158,10 +159,6 @@ data AST = | Identifier Variable -- An index into a structure using square brackets. | Index ASTWithSourceSpan ASTWithSourceSpan - -- TODO: Needs comment to explain what it is. - -- Was called "List". - -- TODO: New type. Needs to be handled in the Rules. - | StatementList [ASTWithSourceSpan] | New ASTWithSourceSpan -- TODO: Needs comment to explain what it is. | ParenExpression ASTWithSourceSpan @@ -169,6 +166,10 @@ data AST = | PropNameValue PropertyName ASTWithSourceSpan -- A reference into a structure using a dot. | 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 @@ -179,7 +180,6 @@ data AST = data ASTWithSourceSpan = AWSS AST SrcSpan deriving (Show) --- data ASTWithSourceSpan = AWSS Expression SrcSpan deriving (Show) getASTWithSource :: JSNode -> SourceFileName -> (ASTWithSourceSpan, SourceFileName) @@ -210,6 +210,7 @@ listToMaybeExpression jsn = Just $ listToASTExpression jsn -- Some parser nodes contain lists of JSNodes that represent whole expressions. This function takes -- such a list of Nodes and builds a single expression. +-- 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) _)] @@ -236,6 +237,8 @@ listToASTExpression [x, (NS (JSArguments args) srcSpan)] = (toAST x) (toASTArguments args srcSpan)) (jsnGetSource x) +-- To handle the case where the last element in the list is a (JSCallExpression "[]" exp) or a +-- (JSCallExpression "." exp). listToASTExpression list | (isCallExpression $ last list) = getASTCallExpression list where @@ -243,12 +246,40 @@ listToASTExpression list | (isCallExpression $ last list) = isCallExpression (NS (JSCallExpression "." _) _) = True isCallExpression (NS (JSCallExpression "[]" _) _) = True isCallExpression _ = False + getASTCallExpression :: [JSNode] -> ASTWithSourceSpan + getASTCallExpression ls = + AWSS + (CallExpression + (listToASTExpression (init ls)) + (callExpOperator $ jsnGetNode $ last ls) + (callExpProperty $ jsnGetNode $ last ls)) + (jsnGetSource $ head ls) + 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 _ [expr]) = toAST expr +-- 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) = getASTCall list where isParenCallExp :: JSNode -> Bool isParenCallExp (NS (JSCallExpression "()" _) _) = True isParenCallExp _ = False + getASTCall :: [JSNode] -> ASTWithSourceSpan + getASTCall ls = + AWSS + (Call + (listToASTExpression (init ls)) + (getArgs $ last ls)) + (jsnGetSource $ head ls) + getArgs :: JSNode -> ASTWithSourceSpan + getArgs (NS (JSCallExpression _ [(NS (JSArguments args) srcSpan)]) _) = + toASTArguments args srcSpan -- FIXME: Anything else is assumed to be an assignment. Verify that that assumption is correct. listToASTExpression list = getASTAssignment list [] @@ -287,46 +318,17 @@ toASTVarDeclaration (NS (JSVarDecl name value) srcSpan) = (listToMaybeExpression value)) srcSpan - --- 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. -getASTCall :: [JSNode] -> ASTWithSourceSpan -getASTCall list = - AWSS - (Call - (listToASTExpression (init list)) - (getArgs $ last list)) - (jsnGetSource $ head list) - where - getArgs :: JSNode -> ASTWithSourceSpan - getArgs (NS (JSCallExpression _ [(NS (JSArguments args) srcSpan)]) _) = - toASTArguments args srcSpan - - --- To handle the case where the last element in the list is a (JSCallExpression "[]" exp) or a --- (JSCallExpression "." exp). -getASTCallExpression :: [JSNode] -> ASTWithSourceSpan -getASTCallExpression list = - AWSS - (CallExpression - (listToASTExpression (init list)) - (callExpOperator $ jsnGetNode $ last list) - (callExpProperty $ jsnGetNode $ last list)) - (jsnGetSource $ head list) +-- TODO: Check use of this. 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 -> ASTWithSourceSpan - callExpProperty (JSCallExpression "[]" [expr]) = toAST expr - callExpProperty (JSCallExpression "." [expr]) = - toAST expr + isNotSemi jsn = not ((jsnGetNode jsn) == (JSLiteral ";")) --- TODO: Remove all of the nested "Block" constructors etc. +-- TODO: Remove all of the nested constructors. +-- TODO: Alpha order. +-- TODO: Have filtered all semicolons. Is that OK? toAST :: JSNode -> ASTWithSourceSpan toAST (NS (JSBlock statements) srcSpan) = AWSS @@ -335,17 +337,17 @@ toAST (NS (JSBlock statements) srcSpan) = srcSpan toAST (NS (JSFunctionBody bodyList) srcSpan) = AWSS - (FunctionBody (map toAST bodyList)) + (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 elementsList)) + (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 elementsList)) + (StatementList (map toAST (filterSemicolons elementsList))) srcSpan toAST (NS (JSStatementBlock statements) srcSpan) = AWSS @@ -355,14 +357,14 @@ toAST (NS (JSStatementBlock statements) srcSpan) = srcSpan toAST (NS (JSStatementList statements) srcSpan) = AWSS - (StatementList (map toAST statements)) + (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 varDecs)) + (StatementList (map toASTVarDeclaration (filterSemicolons varDecs))) srcSpan toAST (NS (JSBreak label _) srcSpan) = AWSS @@ -413,6 +415,7 @@ toAST (NS (JSExpression jsnList) srcSpan) = 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] toAST (NS (JSFinally body) srcSpan) = @@ -461,11 +464,11 @@ toAST (NS (JSForVarIn var obj body) srcSpan) = -- body is a JSStatementBlock. (toAST body)) srcSpan -toAST (NS (JSFunction name inputs body) srcSpan) = +toAST (NS (JSFunction name args body) srcSpan) = AWSS (FunctionDeclaration (identifierGetString $ jsnGetNode name) - (map (identifierGetString . jsnGetNode) inputs) + (map (identifierGetString . jsnGetNode) args) (toAST body)) srcSpan toAST (NS (JSIf test body) srcSpan) = @@ -494,6 +497,17 @@ toAST (NS (JSLabelled label body) srcSpan) = -- TODO: Comment on where these come from. -- 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) + -- This can be a proper list of JSNodes, eg. var o = { p: x = 2 }; + (listToASTExpression value)) + srcSpan + where + getPropertyName :: Node -> PropertyName + getPropertyName (JSIdentifier n) = VariableProperty n + getPropertyName (JSDecimal n) = IndexProperty (read n) toAST (NS (JSReturn value) srcSpan) = AWSS (Return @@ -524,7 +538,8 @@ toAST (NS (JSTry body catchClause) srcSpan) = -- body is a JSBlock. (toAST body) -- Each of these is a JSCatch or a JSFinally. - (map toAST catchClause)) + -- FIXME: Can there every be semicolons? + (map toAST (filterSemicolons catchClause))) srcSpan toAST (NS (JSWhile test body) srcSpan) = AWSS @@ -533,14 +548,6 @@ toAST (NS (JSWhile test body) srcSpan) = -- body is a JSStatementBlock. (toAST body)) srcSpan --- Anything else is assumed to be a statement. --- toAST jsn = --- [AWSS --- (Statement --- (toAST jsn)) --- (jsnGetSource jsn) --- ] --- toAST :: JSNode -> ASTWithSourceSpan toAST (NS (JSArguments args) srcSpan) = toASTArguments args srcSpan toAST (NS (JSExpressionBinary operator left right) srcSpan) = AWSS @@ -653,19 +660,20 @@ processArray ((NS (JSElision es) srcSpan):rest) current nearestSpan = rest (current ++ [[NS (JSIdentifier "undefined") (getNearestSrcSpan srcSpan nearestSpan)]]) (getNearestSrcSpan srcSpan nearestSpan) -processArray jsArray current nearestSpan = arrayGetElements jsArray current nearestSpan +-- processArray jsArray current nearestSpan = arrayGetElements jsArray current nearestSpan +processArray jsArray current nearestSpan = current ++ (arrayGetElements jsArray [] 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]] +arrayGetElements [] current nearestSpan = current -- 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 @@ -676,18 +684,43 @@ arrayGetElements ++ [[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 ((NS (JSElision _) srcSpan):(jsn):rest) current nearestSpan = + arrayGetElements rest (current ++ [[jsn]]) (getNearestSrcSpan srcSpan nearestSpan) +arrayGetElements (jsn:rest) [] nearestSpan = + arrayGetElements + rest + [[jsn]] + (getNearestSrcSpan (jsnGetSource jsn) nearestSpan) arrayGetElements (jsn:rest) current nearestSpan = arrayGetElements rest - (current ++ [[jsn]]) + ((init current) ++ [(last current) ++ [jsn]]) (getNearestSrcSpan (jsnGetSource jsn) nearestSpan) -- Takes a Node that represents a literal value and makes an AST node for that value. 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 listToASTExpression (processArray arr [] srcSpan)) toASTValue (NS (JSDecimal s) _) = @@ -697,27 +730,7 @@ toASTValue (NS (JSDecimal s) _) = JSInt (read s) toASTValue (NS (JSLiteral "false") _) = JSBool False toASTValue (NS (JSLiteral "true") _) = JSBool True --- TODO: Refactor this? (already done once but still kinda crazy) -toASTValue (NS (JSObjectLiteral list) _) = - JSObject - (map toASTPropNameValue list) - where - -- Takes a JSNode that represents a property of an object and produdes a PropNameValue - -- Expression. - toASTPropNameValue :: JSNode -> ASTWithSourceSpan - toASTPropNameValue - (NS (JSPropertyNameandValue (NS (JSIdentifier name) _) value) srcSpan) = - AWSS - (PropNameValue - (VariableProperty name) - (listToASTExpression value)) - srcSpan - toASTPropNameValue - (NS (JSPropertyNameandValue (NS (JSDecimal index) _) value) srcSpan) = - AWSS - (PropNameValue - (IndexProperty (read index)) - (listToASTExpression value)) - srcSpan +-- 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 e1c10de..d0552ee 100644 --- a/PrettyPrint.hs +++ b/PrettyPrint.hs @@ -57,8 +57,8 @@ module PrettyPrint ( makeIndent -, mapPrintASTWS -, mapPrintASTChild +, printASTChild +, printASTWS , printCleanedElementList , printCleanedRulesList , printParseTreeStripped @@ -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 @@ -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 = @@ -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: +-- WSBreak (Maybe Variable) +-- WSContinue (Maybe Variable) -- WSDefault ASTWithSourceFragment --- WSDoWhile ASTWithSourceFragment ExprWithSourceFragment +-- WSDoWhile ASTWithSourceFragment ASTWithSourceFragment -- WSFinally ASTWithSourceFragment --- WSFor (Maybe ExprWithSourceFragment) (Maybe ExprWithSourceFragment) (Maybe ExprWithSourceFragment) ASTWithSourceFragment --- WSForIn [Variable] ExprWithSourceFragment 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 AST") - 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 0b17342..3d91edf 100644 --- a/ResolveSourceFragments.hs +++ b/ResolveSourceFragments.hs @@ -29,17 +29,16 @@ -- (astListWSMakeSourceFragments (getASTWithSource (parseTree program file) file) span) module ResolveSourceFragments -( ExprWithSourceFragment(..) -, ExprWSF(..) -, ASTWithSourceFragment(..) -, ASTWSF(..) +( ASTWithSourceFragment(..) +, ASTWithSF(..) , SourceFragment(..) , ValueWithSourceFragment(..) -, astListWSMakeSourceFragments +, astWSMakeSourceFragment , astMakeSourceFragment ) where +import Control.Monad.State import Language.JavaScript.Parser import ParseJS import System.Environment @@ -51,78 +50,86 @@ 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 - | WSBreak (Maybe Variable) - | WSCall ExprWithSourceFragment ExprWithSourceFragment - | WSCallExpression ExprWithSourceFragment Operator ExprWithSourceFragment - | WSContinue (Maybe Variable) - | 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 - | WSValue ValueWithSourceFragment - | WSVarDeclaration Variable (Maybe ExprWithSourceFragment) deriving (Show) -data ASTWSF = - WSBlock [ASTWithSourceFragment] - | WSCase ExprWithSourceFragment ASTWithSourceFragment - | WSCatch Variable (Maybe ExprWithSourceFragment) ASTWithSourceFragment +data ASTWithSF = + WSBlock ASTWithSourceFragment + | WSCase ASTWithSourceFragment ASTWithSourceFragment + | WSCatch Variable (Maybe ASTWithSourceFragment) ASTWithSourceFragment | WSDefault ASTWithSourceFragment - | WSDoWhile ASTWithSourceFragment ExprWithSourceFragment + | WSDoWhile ASTWithSourceFragment ASTWithSourceFragment | WSFinally ASTWithSourceFragment - | WSFor (Maybe ExprWithSourceFragment) (Maybe ExprWithSourceFragment) (Maybe ExprWithSourceFragment) ASTWithSourceFragment - | WSForIn [Variable] ExprWithSourceFragment ASTWithSourceFragment - | WSForVar [ExprWithSourceFragment] (Maybe ExprWithSourceFragment) (Maybe ExprWithSourceFragment) ASTWithSourceFragment - | WSForVarIn ExprWithSourceFragment ExprWithSourceFragment 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 ExprWithSourceFragment ASTWithSourceFragment - | WSIfElse ExprWithSourceFragment ASTWithSourceFragment ASTWithSourceFragment + | WSIf ASTWithSourceFragment ASTWithSourceFragment + | WSIfElse ASTWithSourceFragment ASTWithSourceFragment ASTWithSourceFragment | WSLabelled Variable ASTWithSourceFragment - | WSReturn ExprWithSourceFragment - | WSStatement ExprWithSourceFragment - | WSSwitch ExprWithSourceFragment ASTWithSourceFragment - | WSTry ASTWithSourceFragment ASTWithSourceFragment - | WSWhile ExprWithSourceFragment ASTWithSourceFragment deriving (Show) + | 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 ASTWithSourceFragment ASTWithSourceFragment + | WSCallExpression ASTWithSourceFragment Operator ASTWithSourceFragment + | WSContinue (Maybe Variable) + -- Was called "WSList". + | WSExpression [ASTWithSourceFragment] + | WSFunctionExpression (Maybe Variable) [Variable] ASTWithSourceFragment + | WSIdentifier Variable + | 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 ASTWithSourceFragment) deriving (Show) data ASTWithSourceFragment = - AWSF ASTWSF SourceFragment deriving (Show) -data ExprWithSourceFragment = - EWSF ExprWSF SourceFragment deriving (Show) + AWSF ASTWithSF SourceFragment deriving (Show) + + +astGetSpan :: ASTWithSourceSpan -> SrcSpan +astGetSpan (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 +-- astListWSMakeSourceFragments :: ([ASTWithSourceSpan], SourceFileName) -> SrcSpan -> [ASTWithSourceFragment] +-- astListWSMakeSourceFragments (list, fileName) nextSpan = +-- astListMakeSourceFragments list fileName nextSpan + +astWSMakeSourceFragment :: (ASTWithSourceSpan, SourceFileName) -> SrcSpan -> ASTWithSourceFragment +astWSMakeSourceFragment (ast, fileName) nextSpan = + astMakeSourceFragment ast fileName nextSpan -- nextSpan is the list's parent's next sibling (or the end of the file, if the parent has no next @@ -131,27 +138,21 @@ astListMakeSourceFragments :: [ASTWithSourceSpan] -> SourceFileName -> SrcSpan - 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 [] _ nextSpan = [] - - -astGetSpan :: ASTWithSourceSpan -> SrcSpan -astGetSpan (AWSS _ srcSpan) = srcSpan +astListMakeSourceFragments [] _ _ = [] -exprGetSpan :: ExprWithSourceSpan -> SrcSpan -exprGetSpan (EWSS _ srcSpan) = srcSpan - - -maybeExprGetSpan :: Maybe ExprWithSourceSpan -> Maybe SrcSpan -maybeExprGetSpan (Just (EWSS _ srcSpan)) = Just srcSpan -maybeExprGetSpan Nothing = Nothing - - -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 @@ -159,41 +160,57 @@ 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 ASTWithSourceFragment --- WSCatch Variable (Maybe ExprWithSourceFragment) ASTWithSourceFragment +-- WSCase ASTWithSourceFragment ASTWithSourceFragment +-- WSCatch Variable (Maybe ASTWithSourceFragment) ASTWithSourceFragment -- WSDefault ASTWithSourceFragment --- WSDoWhile ASTWithSourceFragment ExprWithSourceFragment +-- WSDoWhile ASTWithSourceFragment ASTWithSourceFragment -- WSFinally ASTWithSourceFragment - -- WSForIn [Variable] ExprWithSourceFragment ASTWithSourceFragment --- WSIfElse ExprWithSourceFragment ASTWithSourceFragment ASTWithSourceFragment +-- WSForIn [Variable] ASTWithSourceFragment ASTWithSourceFragment +-- WSIfElse ASTWithSourceFragment ASTWithSourceFragment ASTWithSourceFragment -- WSLabelled Variable ASTWithSourceFragment --- WSSwitch ExprWithSourceFragment ASTWithSourceFragment +-- WSSwitch ASTWithSourceFragment ASTWithSourceFragment -- WSTry ASTWithSourceFragment ASTWithSourceFragment --- WSWhile ExprWithSourceFragment 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) -astMakeSourceFragment (AWSS (Block list) srcSpan) fileName nextSpan = +astMakeSourceFragment (AWSS (Block body) srcSpan) fileName nextSpan = AWSF - (WSBlock (astListMakeSourceFragments 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? astMakeSourceFragment (AWSS (For vars cond expr body) srcSpan) fileName nextSpan = AWSF (WSFor - (maybeExprMakeSourceFragment vars fileName varsNextSpan) - (maybeExprMakeSourceFragment cond fileName condNextSpan) - (maybeExprMakeSourceFragment expr fileName (astGetSpan body)) + (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 @@ -209,15 +226,15 @@ astMakeSourceFragment (AWSS (For vars cond expr body) srcSpan) fileName nextSpan astMakeSourceFragment (AWSS (ForVar vars cond expr body) srcSpan) fileName nextSpan = AWSF (WSForVar - (exprListMakeSourceFragments vars fileName varsNextSpan) - (maybeExprMakeSourceFragment cond fileName condNextSpan) - (maybeExprMakeSourceFragment expr fileName (astGetSpan body)) + (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 @@ -233,8 +250,8 @@ astMakeSourceFragment (AWSS (ForVar vars cond expr body) srcSpan) fileName nextS astMakeSourceFragment (AWSS (ForVarIn var obj body) srcSpan) fileName nextSpan = AWSF (WSForVarIn - (exprMakeSourceFragment var fileName (exprGetSpan obj)) - (exprMakeSourceFragment obj fileName (astGetSpan body)) + (astMakeSourceFragment var fileName (astGetSpan obj)) + (astMakeSourceFragment obj fileName (astGetSpan body)) (astMakeSourceFragment body fileName nextSpan)) (makeSourceFragment srcSpan nextSpan fileName) astMakeSourceFragment (AWSS (FunctionBody list) srcSpan) fileName nextSpan = @@ -253,138 +270,98 @@ astMakeSourceFragment (AWSS (FunctionDeclaration var args body) srcSpan) fileNam astMakeSourceFragment (AWSS (If expr body) srcSpan) fileName nextSpan = AWSF (WSIf - (exprMakeSourceFragment expr fileName (astGetSpan body)) + (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) -astMakeSourceFragment (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 (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 dc9e58e..b52b383 100644 --- a/TypeRules.hs +++ b/TypeRules.hs @@ -161,7 +161,7 @@ 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 :: ASTChild -> (Maybe DeclaredIdentifier) funExprMakeLabel (LabFunctionExpression mv vls body, n, sourceFragment) = maybeID mv n where @@ -169,7 +169,7 @@ funExprMakeLabel (LabFunctionExpression mv vls body, n, sourceFragment) = maybeID (Just (ident, _)) x = Just (DeclaredIdentifier ident (IDLabel x)) -varDecMakeLabel :: ExprChild -> DeclaredIdentifier +varDecMakeLabel :: ASTChild -> DeclaredIdentifier varDecMakeLabel (LabVarDeclaration (var, x) mex, n, sourceFragment) = DeclaredIdentifier var (IDLabel n) funDecMakeLabel :: ASTChild -> DeclaredIdentifier @@ -185,16 +185,16 @@ argMakeLabel (var, n) = DeclaredIdentifier var (IDLabel n) ---------------------------------------------------------------------------------------------------- --- Extract the value (strip label) from a VarChild, ExprChild, ValueChild or ASTChild. +-- 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. +-- 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. +-- Create a Meta type from the label on a VarChild, ASTChild, ValueChild or ASTChild. childWSToMeta :: (a, ASTLabel, b) -> Type childWSToMeta ch = Meta (childWSGetLabel ch) @@ -204,10 +204,10 @@ maybeVarChildRules (Just vc) dIDs = varChildRules vc dIDs maybeVarChildRules Nothing _ = [] --- 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 (Just ec) dIDs = astChildRules ec dIDs +maybeASTChildRules Nothing _ = [] -- Generate rules from a VarChild list @@ -218,12 +218,12 @@ 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 +-- Generate rules from an ASTChild list +-- mapASTChildRules :: [ASTChild] -> [DeclaredIdentifier] -> [Rule] +-- mapASTChildRules ex dIDs = +-- concat $ map mapASTChildRules' ex +-- where +-- mapASTChildRules' e = astChildRules e dIDs -- Gernerate rules from an ASTChild list @@ -285,15 +285,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 @@ -320,470 +320,65 @@ 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?) + getStringLiteral' (LabValue (LabString s, _), _, _) = s + getStringLiteral' (LabValue (LabDQString s, _), _, _) = s + + +-- Returns true if the ASTChild is a Statement containing an 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 and returns ex1. -assignmentGetVar :: ASTChild -> ExprChild +assignmentGetVar :: ASTChild -> ASTChild assignmentGetVar (LabStatement ex, _, _) = assignmentGetVar' $ removeUselessParenAndList ex where @@ -823,7 +418,7 @@ assignmentGetVar (LabStatement ex, _, _) = -- type inference to fail on that function, both as a constructor and as a function. -- -- TODO: Revisit this (ha!) -isPropertyReference :: ExprChild -> Bool +isPropertyReference :: ASTChild -> Bool isPropertyReference (LabReference (LabIdentifier ("this", _),_, _) _, _, _) = True isPropertyReference (LabIndex (LabIdentifier ("this", _), _, _) _, _, _) = True isPropertyReference _ = False @@ -845,7 +440,7 @@ isPropRefAssignment ast = -- Takes an expression which is a reference to a property and returns the name of the property -- paired with the type of its value. -getPropertyNameType :: ExprChild -> [(PropertyName, Type)] +getPropertyNameType :: ASTChild -> [(PropertyName, Type)] getPropertyNameType (LabReference _ (LabIdentifier (prop, _), _, _), n, _) = [(VariableProperty prop, Meta n)] getPropertyNameType (LabIndex (LabIdentifier (obj, _), _, _) prop, n, _) = @@ -980,23 +575,27 @@ 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] +-- Make a list of rules from a Maybe ASTChild of Boolean type. +maybeBoolRule :: (Maybe ASTChild) -> [Rule] maybeBoolRule (Just t) = [boolRule t] maybeBoolRule Nothing = [] -- 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 = @@ -1039,17 +638,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. -- @@ -1057,33 +656,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. @@ -1091,7 +690,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 @@ -1099,7 +698,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. -- @@ -1107,7 +706,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 = @@ -1127,7 +726,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 = @@ -1136,9 +735,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 From 5221675d4647dbbf077969e17fb6bcde4d0981c5 Mon Sep 17 00:00:00 2001 From: rjwright Date: Tue, 22 Jul 2014 19:13:14 +1000 Subject: [PATCH 07/20] Removed some unneeded code. --- ParseJS.hs | 56 ++++++++++++++++++++++-------------------------------- 1 file changed, 23 insertions(+), 33 deletions(-) diff --git a/ParseJS.hs b/ParseJS.hs index fdec75c..369c9b1 100644 --- a/ParseJS.hs +++ b/ParseJS.hs @@ -235,51 +235,44 @@ listToASTExpression [x, (NS (JSArguments args) srcSpan)] = AWSS (Call (toAST x) - (toASTArguments args srcSpan)) + (toAST (NS (JSArguments args) srcSpan))) (jsnGetSource x) -- To handle the case where the last element in the list is a (JSCallExpression "[]" exp) or a -- (JSCallExpression "." exp). listToASTExpression list | (isCallExpression $ last list) = - getASTCallExpression 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 - getASTCallExpression :: [JSNode] -> ASTWithSourceSpan - getASTCallExpression ls = - AWSS - (CallExpression - (listToASTExpression (init ls)) - (callExpOperator $ jsnGetNode $ last ls) - (callExpProperty $ jsnGetNode $ last ls)) - (jsnGetSource $ head ls) 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 _ [expr]) = toAST expr + 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) = - getASTCall list + AWSS + (Call + (listToASTExpression (init list)) + (getArgs $ jsnGetNode $ last list)) + (jsnGetSource $ head list) where isParenCallExp :: JSNode -> Bool isParenCallExp (NS (JSCallExpression "()" _) _) = True isParenCallExp _ = False - getASTCall :: [JSNode] -> ASTWithSourceSpan - getASTCall ls = - AWSS - (Call - (listToASTExpression (init ls)) - (getArgs $ last ls)) - (jsnGetSource $ head ls) - getArgs :: JSNode -> ASTWithSourceSpan - getArgs (NS (JSCallExpression _ [(NS (JSArguments args) srcSpan)]) _) = - toASTArguments args srcSpan + getArgs :: Node -> ASTWithSourceSpan + getArgs (JSCallExpression _ [args]) = toAST args -- FIXME: Anything else is assumed to be an assignment. Verify that that assumption is correct. listToASTExpression list = getASTAssignment list [] @@ -301,15 +294,6 @@ listToASTExpression list = getASTAssignment (x:xs) preCurrent = getASTAssignment xs (preCurrent ++ [x]) -toASTArguments :: [[JSNode]] -> SrcSpan -> ASTWithSourceSpan -toASTArguments args srcSpan = - AWSS (Arguments (map getASTArgument args)) srcSpan - where - getASTArgument :: [JSNode] -> ASTWithSourceSpan - getASTArgument (item:[]) = toAST item - getASTArgument nodes = listToASTExpression nodes - - toASTVarDeclaration :: JSNode -> ASTWithSourceSpan toASTVarDeclaration (NS (JSVarDecl name value) srcSpan) = AWSS @@ -318,6 +302,7 @@ toASTVarDeclaration (NS (JSVarDecl name value) srcSpan) = (listToMaybeExpression value)) srcSpan + -- TODO: Check use of this. Probably used in more places than needed. filterSemicolons :: [JSNode] -> [JSNode] filterSemicolons jsnList = @@ -328,7 +313,7 @@ filterSemicolons jsnList = -- TODO: Remove all of the nested constructors. -- TODO: Alpha order. --- TODO: Have filtered all semicolons. Is that OK? +-- TODO: All semicolons have been filtered out. Is that OK? toAST :: JSNode -> ASTWithSourceSpan toAST (NS (JSBlock statements) srcSpan) = AWSS @@ -548,7 +533,11 @@ toAST (NS (JSWhile test body) srcSpan) = -- body is a JSStatementBlock. (toAST body)) srcSpan -toAST (NS (JSArguments args) srcSpan) = toASTArguments args srcSpan +toAST (NS (JSArguments args) srcSpan) = + AWSS + (Arguments + (map listToASTExpression args)) + srcSpan toAST (NS (JSExpressionBinary operator left right) srcSpan) = AWSS (Binary @@ -605,6 +594,7 @@ toAST (NS (JSMemberSquare pre post) srcSpan) = toAST val = AWSS (Value (toASTValue val)) (jsnGetSource val) + -- These functions are used to process array literals. -- -- The way that the parser (Grammar5.y) handles commas in arrays seems strange to me. A single comma From 1d3b6c31700dfb6801daef9ad47f515b993efd51 Mon Sep 17 00:00:00 2001 From: rjwright Date: Thu, 24 Jul 2014 20:59:20 +1000 Subject: [PATCH 08/20] Changed approach to sublisting arrays. Nearly done, just need to sort out leading elisions stuff. --- Main.hs | 24 +++---- ParseJS.hs | 190 +++++++++++++++++++++++++++++++++++++---------------- 2 files changed, 146 insertions(+), 68 deletions(-) diff --git a/Main.hs b/Main.hs index 9a6cd7d..bedf8f4 100644 --- a/Main.hs +++ b/Main.hs @@ -49,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 @@ -101,15 +101,15 @@ main = do -- mapPrintASTChild (makeLabelledAST pr infile) (makeIndent "") True False -- **PRETTY PRINTED** -- Print the cleaned ATS with labels and source. - putStrLn "" - putStrLn "Pretty print labelled AST with labels and source fragments" - printASTChild (makeLabelledAST 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 ASTWithSourceFragment with source fragments - putStrLn "" - putStrLn "Pretty print ASTWithSourceFragment with source fragments" - printASTWS (makeASTWithSourceFragments pr infile) (makeIndent "") True + -- putStrLn "" + -- putStrLn "Pretty print ASTWithSourceFragment with source fragments" + -- printASTWS (makeASTWithSourceFragments pr infile) (makeIndent "") True -- **PRETTY PRINTED** -- Pretty print the ASTWithSourceFragment without source fragments putStrLn "" diff --git a/ParseJS.hs b/ParseJS.hs index 369c9b1..2f07cf7 100644 --- a/ParseJS.hs +++ b/ParseJS.hs @@ -54,6 +54,7 @@ import Data.Functor.Identity import Data.List ( delete , find + , groupBy , intercalate , nub ,(\\) @@ -215,10 +216,11 @@ listToASTExpression :: [JSNode] -> ASTWithSourceSpan listToASTExpression [item] = toAST item listToASTExpression [(NS (JSUnary operator) srcSpan), (NS (JSDecimal x) _)] | (operator == "-") = - if (elem '.' x) then - AWSS (Value xFloat) srcSpan - else - AWSS (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)) @@ -303,7 +305,7 @@ toASTVarDeclaration (NS (JSVarDecl name value) srcSpan) = srcSpan --- TODO: Check use of this. Probably used in more places than needed. +-- TODO: Check use of this function. Probably used in more places than needed. filterSemicolons :: [JSNode] -> [JSNode] filterSemicolons jsnList = filter isNotSemi jsnList @@ -374,7 +376,7 @@ toAST (NS (JSCatch var test body) srcSpan) = -- with a value and a literal semicolon. toAST (NS (JSContinue label) srcSpan) = AWSS - (Continue (liftM (identifierGetString . jsnGetNode) (listToMaybe $ init label))) + (Continue (liftM (identifierGetString . jsnGetNode) (listToMaybe $ filterSemicolons label))) srcSpan toAST (NS (JSDefault body) srcSpan) = AWSS @@ -486,7 +488,7 @@ toAST (NS (JSPropertyNameandValue name value) srcSpan) = AWSS (PropNameValue (getPropertyName $ jsnGetNode name) - -- This can be a proper list of JSNodes, eg. var o = { p: x = 2 }; + -- Value can be a proper list of JSNodes, eg. var o = { p: x = 2 }; (listToASTExpression value)) srcSpan where @@ -496,14 +498,14 @@ toAST (NS (JSPropertyNameandValue name value) srcSpan) = toAST (NS (JSReturn value) srcSpan) = AWSS (Return - (returnValue value)) + (returnValue $ filterSemicolons value)) srcSpan 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 [semi] = AWSS (Value JSUndefined) srcSpan - returnValue [val, semi] = toAST val + returnValue [] = AWSS (Value JSUndefined) srcSpan + returnValue [val] = toAST val toAST (NS (JSSwitch var cases) srcSpan) = AWSS (Switch @@ -641,51 +643,125 @@ 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 jsArray current nearestSpan = arrayGetElements jsArray current nearestSpan -processArray jsArray current nearestSpan = current ++ (arrayGetElements jsArray [] nearestSpan) +-- -- 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 jsArray current nearestSpan = arrayGetElements jsArray current nearestSpan +-- processArray jsArray current nearestSpan = current ++ (arrayGetElements jsArray [] 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]] -arrayGetElements [] current nearestSpan = current --- 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))]] --- 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):(jsn):rest) current nearestSpan = - arrayGetElements rest (current ++ [[jsn]]) (getNearestSrcSpan srcSpan nearestSpan) -arrayGetElements (jsn:rest) [] nearestSpan = - arrayGetElements - rest - [[jsn]] - (getNearestSrcSpan (jsnGetSource jsn) nearestSpan) -arrayGetElements (jsn:rest) current nearestSpan = - arrayGetElements - rest - ((init current) ++ [(last current) ++ [jsn]]) - (getNearestSrcSpan (jsnGetSource jsn) nearestSpan) +-- arrayGetElements :: [JSNode] -> [[JSNode]] -> SrcSpan -> [[JSNode]] +-- arrayGetElements [] current nearestSpan = current +-- -- 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))]] +-- -- 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):(jsn):rest) current nearestSpan = +-- arrayGetElements rest (current ++ [[jsn]]) (getNearestSrcSpan srcSpan nearestSpan) +-- arrayGetElements (jsn:rest) [] nearestSpan = +-- arrayGetElements +-- rest +-- [[jsn]] +-- (getNearestSrcSpan (jsnGetSource jsn) nearestSpan) +-- arrayGetElements (jsn:rest) current nearestSpan = +-- arrayGetElements +-- rest +-- ((init current) ++ [(last current) ++ [jsn]]) +-- (getNearestSrcSpan (jsnGetSource jsn) nearestSpan) + + +-- 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 jsArray current nearestSpan = current ++ (sublists jsArray) + +isElision (NS (JSElision _) _) = True +isElision _ = False + +processArray :: [JSNode] -> SrcSpan -> [[JSNode]] +processArray [] _ = [] +processArray list nearestSpan = + if (null leadingElisions) + then + (sublists (drop (length $ processLeadingElisions list nearestSpan) list)) + else + [leadingElisions] ++ (sublists (drop (length $ processLeadingElisions list nearestSpan) list)) + where + leadingElisions = processLeadingElisions list nearestSpan + +processLeadingElisions :: [JSNode] -> SrcSpan -> [JSNode] +processLeadingElisions [] _ = [] +processLeadingElisions list nearestSpan = + [(NS (JSIdentifier "undefined") (getNearestSrcSpan (jsnGetSource el) nearestSpan)) | el <- (takeWhile isElision list)] + +sublists :: [JSNode] -> [[JSNode]] +sublists list = + seperateUndefineds + $ mapElisionsToUndefined + $ breakAtElision + $ stripTrailingComma list + +-- if the last thing is a JSLiteral "," just drop it +stripTrailingComma :: [JSNode] -> [JSNode] +stripTrailingComma [] = [] +stripTrailingComma list = if ((jsnGetNode $ last list) == (JSLiteral ",")) then init list else list + +-- walking through the list, if we see an elision and then a non elision, replace the elision with a +-- "break" +breakAtElision :: [JSNode] -> [[JSNode]] +breakAtElision [] = [] +breakAtElision list = + filter (not . null) (map killElisions (init $ groupBy compareElements list) ++ [(last $ groupBy compareElements list)]) +killElisions ((NS (JSElision _) _):rest) = rest +killElisions ls = ls +compareElements (NS (JSElision _) _) (NS (JSElision _) _) = True +compareElements (NS (JSElision _) _) _ = False +compareElements _ (NS (JSElision _) _) = False +compareElements _ _ = True + +-- walking through the broken-up list, replace any remaining elisions with "undefined" +mapElisionsToUndefined :: [[JSNode]] -> [[JSNode]] +mapElisionsToUndefined list = map (map elisionToUndefined) list +elisionToUndefined (NS (JSElision _) srcSpan) = NS (JSIdentifier "undefined") srcSpan +elisionToUndefined n = n + +-- break up lists of undefineds +-- [[x, y, z], [undef, undef, undef]] +-- map seperateIfUndefined: [[[x, y, z]], [[undef], [undef], [undef]]] +-- concat [[[x, y, z]], [[undef], [undef], [undef]]]: [[x, y, z], [undef], [undef], [undef]] +seperateUndefineds :: [[JSNode]] -> [[JSNode]] +seperateUndefineds list = concat $ map seperateIfUndefined list +seperateIfUndefined ((NS (JSIdentifier "undefined") srcSpan):[]) = + [[(NS (JSIdentifier "undefined") srcSpan)]] +seperateIfUndefined ((NS (JSIdentifier "undefined") srcSpan):rest) = + [[(NS (JSIdentifier "undefined") srcSpan)]] ++ (seperateIfUndefined rest) +seperateIfUndefined ls = [ls] -- Takes a Node that represents a literal value and makes an AST node for that value. @@ -712,12 +788,14 @@ toASTValue (NS (JSArrayLiteral arr) srcSpan) = -- TODO: Check this. -- [[JSIdentifier \"y\", JSOperator \"=\", JSDecimal \"10\"], [JSDecimal \"3\"]] JSArray - (map listToASTExpression (processArray arr [] srcSpan)) + (map listToASTExpression (processArray arr srcSpan)) + -- (map listToASTExpression (processArray arr [] srcSpan)) toASTValue (NS (JSDecimal s) _) = - if elem '.' s then - JSFloat (read s) - else - JSInt (read 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? From 97057e1da3cbb2a8ad4988b178bd2d3f6bb7424b Mon Sep 17 00:00:00 2001 From: rjwright Date: Wed, 30 Jul 2014 15:58:14 +1000 Subject: [PATCH 09/20] Got leading elisions working with new array processing code. --- ParseJS.hs | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/ParseJS.hs b/ParseJS.hs index 2f07cf7..264d988 100644 --- a/ParseJS.hs +++ b/ParseJS.hs @@ -706,19 +706,20 @@ isElision _ = False processArray :: [JSNode] -> SrcSpan -> [[JSNode]] processArray [] _ = [] -processArray list nearestSpan = - if (null leadingElisions) - then - (sublists (drop (length $ processLeadingElisions list nearestSpan) list)) - else - [leadingElisions] ++ (sublists (drop (length $ processLeadingElisions list nearestSpan) list)) - where - leadingElisions = processLeadingElisions list nearestSpan +processArray list nearestSpan + | null leadingElisions = + (sublists (drop (length $ processLeadingElisions list nearestSpan) list)) + | (length leadingElisions) == (length list) = + leadingElisions + | otherwise = + leadingElisions ++ (sublists (drop (length $ processLeadingElisions list nearestSpan) list)) + where + leadingElisions = processLeadingElisions list nearestSpan -processLeadingElisions :: [JSNode] -> SrcSpan -> [JSNode] +processLeadingElisions :: [JSNode] -> SrcSpan -> [[JSNode]] processLeadingElisions [] _ = [] processLeadingElisions list nearestSpan = - [(NS (JSIdentifier "undefined") (getNearestSrcSpan (jsnGetSource el) nearestSpan)) | el <- (takeWhile isElision list)] + [[(NS (JSIdentifier "undefined") (getNearestSrcSpan (jsnGetSource el) nearestSpan))] | el <- (takeWhile isElision list)] sublists :: [JSNode] -> [[JSNode]] sublists list = From 1afaa411722e4417603ae1e05b8c71f08ec4f16b Mon Sep 17 00:00:00 2001 From: rjwright Date: Wed, 30 Jul 2014 18:29:15 +1000 Subject: [PATCH 10/20] Working on compacting array processing code --- ParseJS.hs | 79 ++++++++++++++++++++++++++++-------------------------- 1 file changed, 41 insertions(+), 38 deletions(-) diff --git a/ParseJS.hs b/ParseJS.hs index 264d988..b69729e 100644 --- a/ParseJS.hs +++ b/ParseJS.hs @@ -53,6 +53,8 @@ import Control.Monad.State import Data.Functor.Identity import Data.List ( delete + , deleteBy + , dropWhileEnd , find , groupBy , intercalate @@ -704,65 +706,66 @@ getNearestSrcSpan s _ = s isElision (NS (JSElision _) _) = True isElision _ = False +-- FIXME: Source spans could be better processArray :: [JSNode] -> SrcSpan -> [[JSNode]] processArray [] _ = [] processArray list nearestSpan | null leadingElisions = - (sublists (drop (length $ processLeadingElisions list nearestSpan) list)) + (sublists (drop (length $ leadingElisions) list)) + -- FIXME: remove this case (or the empty list case)? | (length leadingElisions) == (length list) = leadingElisions | otherwise = - leadingElisions ++ (sublists (drop (length $ processLeadingElisions list nearestSpan) list)) + leadingElisions ++ (sublists (drop (length $ leadingElisions) list)) where - leadingElisions = processLeadingElisions list nearestSpan - -processLeadingElisions :: [JSNode] -> SrcSpan -> [[JSNode]] -processLeadingElisions [] _ = [] -processLeadingElisions list nearestSpan = - [[(NS (JSIdentifier "undefined") (getNearestSrcSpan (jsnGetSource el) nearestSpan))] | el <- (takeWhile isElision list)] + leadingElisions = + [[(NS (JSIdentifier "undefined") (getNearestSrcSpan (jsnGetSource el) nearestSpan))] | el <- (takeWhile isElision list)] sublists :: [JSNode] -> [[JSNode]] sublists list = - seperateUndefineds - $ mapElisionsToUndefined + elisionsToUndefineds + -- $ seperateElisions $ breakAtElision - $ stripTrailingComma list - --- if the last thing is a JSLiteral "," just drop it -stripTrailingComma :: [JSNode] -> [JSNode] -stripTrailingComma [] = [] -stripTrailingComma list = if ((jsnGetNode $ last list) == (JSLiteral ",")) then init list else list + $ dropWhileEnd (((==) (JSLiteral ",")) . jsnGetNode) list --- walking through the list, if we see an elision and then a non elision, replace the elision with a --- "break" +-- Seperate elisions from non-elisions. breakAtElision :: [JSNode] -> [[JSNode]] breakAtElision [] = [] breakAtElision list = - filter (not . null) (map killElisions (init $ groupBy compareElements list) ++ [(last $ groupBy compareElements list)]) -killElisions ((NS (JSElision _) _):rest) = rest -killElisions ls = ls -compareElements (NS (JSElision _) _) (NS (JSElision _) _) = True -compareElements (NS (JSElision _) _) _ = False -compareElements _ (NS (JSElision _) _) = False -compareElements _ _ = True - --- walking through the broken-up list, replace any remaining elisions with "undefined" -mapElisionsToUndefined :: [[JSNode]] -> [[JSNode]] -mapElisionsToUndefined list = map (map elisionToUndefined) list -elisionToUndefined (NS (JSElision _) srcSpan) = NS (JSIdentifier "undefined") srcSpan -elisionToUndefined n = n + filter (not . null) (separateElisions $ groupBy compareElements list) + where + compareElements l r + | (isElision l) && (isElision r) = True + | (not $ isElision l) && (not $ isElision r) = True + | otherwise = False + -- We delete one elision per group of elisions, except at the end of the array. Then break + -- the groups up into singleton lists. + -- [[a, b], [el, el, el], [c], [el]] -> [[a, b], [el, el], [c], [el]] + separateElisions [ls] = + if (isElision $ head ls) + then groupBy (\_ _ -> False) ls + else [ls] + separateElisions (ls:others) = + if (isElision $ head ls) + then (groupBy (\_ _ -> False) (drop 1 ls)) ++ (separateElisions others) + else [ls] ++ (separateElisions others) -- break up lists of undefineds -- [[x, y, z], [undef, undef, undef]] -- map seperateIfUndefined: [[[x, y, z]], [[undef], [undef], [undef]]] -- concat [[[x, y, z]], [[undef], [undef], [undef]]]: [[x, y, z], [undef], [undef], [undef]] -seperateUndefineds :: [[JSNode]] -> [[JSNode]] -seperateUndefineds list = concat $ map seperateIfUndefined list -seperateIfUndefined ((NS (JSIdentifier "undefined") srcSpan):[]) = - [[(NS (JSIdentifier "undefined") srcSpan)]] -seperateIfUndefined ((NS (JSIdentifier "undefined") srcSpan):rest) = - [[(NS (JSIdentifier "undefined") srcSpan)]] ++ (seperateIfUndefined rest) -seperateIfUndefined ls = [ls] +-- seperateElisions :: [[JSNode]] -> [[JSNode]] +-- seperateElisions list = concat $ map seperateIfElision list +-- seperateIfElision [jsn] | isElision jsn = [[jsn]] +-- seperateIfElision (jsn:rest) | isElision jsn = [[jsn]] ++ (seperateIfElision rest) +-- seperateIfElision ls = [ls] + +-- walking through the broken-up list, replace any remaining elisions with "undefined" +elisionsToUndefineds :: [[JSNode]] -> [[JSNode]] +elisionsToUndefineds list = + map (map elToUndefined) list + where + elToUndefined n = if isElision n then NS (JSIdentifier "undefined") (jsnGetSource n) else n -- Takes a Node that represents a literal value and makes an AST node for that value. From b47966efcc32840c3f15bbc5fe4de9a29de1b88d Mon Sep 17 00:00:00 2001 From: rjwright Date: Wed, 30 Jul 2014 18:36:32 +1000 Subject: [PATCH 11/20] Further compacting --- ParseJS.hs | 47 +++++++++++++++++++++++------------------------ 1 file changed, 23 insertions(+), 24 deletions(-) diff --git a/ParseJS.hs b/ParseJS.hs index b69729e..2085d3f 100644 --- a/ParseJS.hs +++ b/ParseJS.hs @@ -723,15 +723,16 @@ processArray list nearestSpan sublists :: [JSNode] -> [[JSNode]] sublists list = - elisionsToUndefineds - -- $ seperateElisions - $ breakAtElision - $ dropWhileEnd (((==) (JSLiteral ",")) . jsnGetNode) list + breakAtElisions + $ dropWhileEnd (((==) (JSLiteral ",")) . jsnGetNode) list + -- elisionsToUndefineds + -- $ breakAtElisions + -- $ dropWhileEnd (((==) (JSLiteral ",")) . jsnGetNode) list -- Seperate elisions from non-elisions. -breakAtElision :: [JSNode] -> [[JSNode]] -breakAtElision [] = [] -breakAtElision list = +breakAtElisions :: [JSNode] -> [[JSNode]] +breakAtElisions [] = [] +breakAtElisions list = filter (not . null) (separateElisions $ groupBy compareElements list) where compareElements l r @@ -741,31 +742,29 @@ breakAtElision list = -- We delete one elision per group of elisions, except at the end of the array. Then break -- the groups up into singleton lists. -- [[a, b], [el, el, el], [c], [el]] -> [[a, b], [el, el], [c], [el]] + -- separateElisions [ls] = + -- if (isElision $ head ls) + -- then [[el] | el <- ls] + -- else [ls] + -- separateElisions (ls:others) = + -- if (isElision $ head ls) + -- then [[el] | el <- drop 1 ls] ++ (separateElisions others) + -- else [ls] ++ (separateElisions others) separateElisions [ls] = if (isElision $ head ls) - then groupBy (\_ _ -> False) ls + then [[NS (JSIdentifier "undefined") (jsnGetSource el)] | el <- ls] else [ls] separateElisions (ls:others) = if (isElision $ head ls) - then (groupBy (\_ _ -> False) (drop 1 ls)) ++ (separateElisions others) + then [[NS (JSIdentifier "undefined") (jsnGetSource el)] | el <- drop 1 ls] ++ (separateElisions others) else [ls] ++ (separateElisions others) --- break up lists of undefineds --- [[x, y, z], [undef, undef, undef]] --- map seperateIfUndefined: [[[x, y, z]], [[undef], [undef], [undef]]] --- concat [[[x, y, z]], [[undef], [undef], [undef]]]: [[x, y, z], [undef], [undef], [undef]] --- seperateElisions :: [[JSNode]] -> [[JSNode]] --- seperateElisions list = concat $ map seperateIfElision list --- seperateIfElision [jsn] | isElision jsn = [[jsn]] --- seperateIfElision (jsn:rest) | isElision jsn = [[jsn]] ++ (seperateIfElision rest) --- seperateIfElision ls = [ls] - -- walking through the broken-up list, replace any remaining elisions with "undefined" -elisionsToUndefineds :: [[JSNode]] -> [[JSNode]] -elisionsToUndefineds list = - map (map elToUndefined) list - where - elToUndefined n = if isElision n then NS (JSIdentifier "undefined") (jsnGetSource n) else n +-- elisionsToUndefineds :: [[JSNode]] -> [[JSNode]] +-- elisionsToUndefineds list = +-- map (map elToUndefined) list +-- where +-- elToUndefined n = if isElision n then NS (JSIdentifier "undefined") (jsnGetSource n) else n -- Takes a Node that represents a literal value and makes an AST node for that value. From 0e950f9588d8cca3e3607debefbec511b55bdfb7 Mon Sep 17 00:00:00 2001 From: rjwright Date: Wed, 30 Jul 2014 19:09:07 +1000 Subject: [PATCH 12/20] Done cleaning up array processing code --- ParseJS.hs | 55 ++++++++++++++++-------------------------------------- 1 file changed, 16 insertions(+), 39 deletions(-) diff --git a/ParseJS.hs b/ParseJS.hs index 2085d3f..a3d3e37 100644 --- a/ParseJS.hs +++ b/ParseJS.hs @@ -703,36 +703,28 @@ getNearestSrcSpan s _ = s -- (getNearestSrcSpan srcSpan nearestSpan) -- processArray jsArray current nearestSpan = current ++ (sublists jsArray) + isElision (NS (JSElision _) _) = True isElision _ = False + -- FIXME: Source spans could be better processArray :: [JSNode] -> SrcSpan -> [[JSNode]] -processArray [] _ = [] -processArray list nearestSpan - | null leadingElisions = - (sublists (drop (length $ leadingElisions) list)) - -- FIXME: remove this case (or the empty list case)? - | (length leadingElisions) == (length list) = - leadingElisions - | otherwise = - leadingElisions ++ (sublists (drop (length $ leadingElisions) list)) +processArray list nearestSpan = + leadingElisions ++ (processElisions $ stripTrailingComma rest) where leadingElisions = - [[(NS (JSIdentifier "undefined") (getNearestSrcSpan (jsnGetSource el) nearestSpan))] | el <- (takeWhile isElision list)] - -sublists :: [JSNode] -> [[JSNode]] -sublists list = - breakAtElisions - $ dropWhileEnd (((==) (JSLiteral ",")) . jsnGetNode) list - -- elisionsToUndefineds - -- $ breakAtElisions - -- $ dropWhileEnd (((==) (JSLiteral ",")) . jsnGetNode) list - --- Seperate elisions from non-elisions. -breakAtElisions :: [JSNode] -> [[JSNode]] -breakAtElisions [] = [] -breakAtElisions list = + [[NS (JSIdentifier "undefined") (getNearestSrcSpan (jsnGetSource el) nearestSpan)] | el <- (takeWhile isElision list)] + rest = drop (length leadingElisions) list + + +stripTrailingComma :: [JSNode] -> [JSNode] +stripTrailingComma list = dropWhileEnd (((==) (JSLiteral ",")) . jsnGetNode) list + + +processElisions :: [JSNode] -> [[JSNode]] +processElisions [] = [] +processElisions list = filter (not . null) (separateElisions $ groupBy compareElements list) where compareElements l r @@ -740,16 +732,8 @@ breakAtElisions list = | (not $ isElision l) && (not $ isElision r) = True | otherwise = False -- We delete one elision per group of elisions, except at the end of the array. Then break - -- the groups up into singleton lists. + -- the groups of elisions up into singleton lists, and replace elisions with undefineds. -- [[a, b], [el, el, el], [c], [el]] -> [[a, b], [el, el], [c], [el]] - -- separateElisions [ls] = - -- if (isElision $ head ls) - -- then [[el] | el <- ls] - -- else [ls] - -- separateElisions (ls:others) = - -- if (isElision $ head ls) - -- then [[el] | el <- drop 1 ls] ++ (separateElisions others) - -- else [ls] ++ (separateElisions others) separateElisions [ls] = if (isElision $ head ls) then [[NS (JSIdentifier "undefined") (jsnGetSource el)] | el <- ls] @@ -759,13 +743,6 @@ breakAtElisions list = then [[NS (JSIdentifier "undefined") (jsnGetSource el)] | el <- drop 1 ls] ++ (separateElisions others) else [ls] ++ (separateElisions others) --- walking through the broken-up list, replace any remaining elisions with "undefined" --- elisionsToUndefineds :: [[JSNode]] -> [[JSNode]] --- elisionsToUndefineds list = --- map (map elToUndefined) list --- where --- elToUndefined n = if isElision n then NS (JSIdentifier "undefined") (jsnGetSource n) else n - -- Takes a Node that represents a literal value and makes an AST node for that value. toASTValue :: JSNode -> Value From 97ef1ca4412ddc2f87a94d1a197be543d36fc808 Mon Sep 17 00:00:00 2001 From: rjwright Date: Wed, 30 Jul 2014 19:13:10 +1000 Subject: [PATCH 13/20] Small changes. Need to fix source spans in processElisions. --- ParseJS.hs | 75 ++++++------------------------------------------------ 1 file changed, 8 insertions(+), 67 deletions(-) diff --git a/ParseJS.hs b/ParseJS.hs index a3d3e37..400e54a 100644 --- a/ParseJS.hs +++ b/ParseJS.hs @@ -638,90 +638,29 @@ toAST val = -- [1,,2] -- JSArrayLiteral [ JSDecimal \"1\", JSElision [], JSElision [], JSDecimal \"2\" ] - -- 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 jsArray current nearestSpan = arrayGetElements jsArray current nearestSpan --- processArray jsArray current nearestSpan = current ++ (arrayGetElements jsArray [] 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]] --- arrayGetElements [] current nearestSpan = current --- -- 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))]] --- -- 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):(jsn):rest) current nearestSpan = --- arrayGetElements rest (current ++ [[jsn]]) (getNearestSrcSpan srcSpan nearestSpan) --- arrayGetElements (jsn:rest) [] nearestSpan = --- arrayGetElements --- rest --- [[jsn]] --- (getNearestSrcSpan (jsnGetSource jsn) nearestSpan) --- arrayGetElements (jsn:rest) current nearestSpan = --- arrayGetElements --- rest --- ((init current) ++ [(last current) ++ [jsn]]) --- (getNearestSrcSpan (jsnGetSource jsn) nearestSpan) - - --- 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 jsArray current nearestSpan = current ++ (sublists jsArray) - - isElision (NS (JSElision _) _) = True isElision _ = False --- FIXME: Source spans could be better processArray :: [JSNode] -> SrcSpan -> [[JSNode]] processArray list nearestSpan = leadingElisions ++ (processElisions $ stripTrailingComma rest) where leadingElisions = - [[NS (JSIdentifier "undefined") (getNearestSrcSpan (jsnGetSource el) nearestSpan)] | el <- (takeWhile isElision list)] + [[NS (JSIdentifier "undefined") (getNearestSrcSpan (jsnGetSource el) nearestSpan)] + | el <- (takeWhile isElision list)] rest = drop (length leadingElisions) list + stripTrailingComma :: [JSNode] -> [JSNode] + stripTrailingComma list = dropWhileEnd (((==) (JSLiteral ",")) . jsnGetNode) list -stripTrailingComma :: [JSNode] -> [JSNode] -stripTrailingComma list = dropWhileEnd (((==) (JSLiteral ",")) . jsnGetNode) list - - +-- FIXME: Source spans could be better processElisions :: [JSNode] -> [[JSNode]] processElisions [] = [] processElisions list = @@ -740,7 +679,9 @@ processElisions list = else [ls] separateElisions (ls:others) = if (isElision $ head ls) - then [[NS (JSIdentifier "undefined") (jsnGetSource el)] | el <- drop 1 ls] ++ (separateElisions others) + then + [[NS (JSIdentifier "undefined") (jsnGetSource el)] | el <- drop 1 ls] + ++ (separateElisions others) else [ls] ++ (separateElisions others) From 08105459ea3986544362dfd0e15c4bed3b6ee5d6 Mon Sep 17 00:00:00 2001 From: rjwright Date: Thu, 31 Jul 2014 16:04:30 +1000 Subject: [PATCH 14/20] Improved source spans for elisions in arrays. Still not perfect though. --- Main.hs | 6 +++--- ParseJS.hs | 47 +++++++++++++++++++++++------------------------ 2 files changed, 26 insertions(+), 27 deletions(-) diff --git a/Main.hs b/Main.hs index bedf8f4..05f7d51 100644 --- a/Main.hs +++ b/Main.hs @@ -107,9 +107,9 @@ main = do -- **PRETTY PRINTED** -- Pretty print the ASTWithSourceFragment with source fragments - -- putStrLn "" - -- putStrLn "Pretty print ASTWithSourceFragment with source fragments" - -- printASTWS (makeASTWithSourceFragments pr infile) (makeIndent "") True + putStrLn "" + putStrLn "Pretty print ASTWithSourceFragment with source fragments" + printASTWS (makeASTWithSourceFragments pr infile) (makeIndent "") True -- **PRETTY PRINTED** -- Pretty print the ASTWithSourceFragment without source fragments putStrLn "" diff --git a/ParseJS.hs b/ParseJS.hs index 400e54a..53eb03e 100644 --- a/ParseJS.hs +++ b/ParseJS.hs @@ -52,14 +52,8 @@ module ParseJS import Control.Monad.State import Data.Functor.Identity import Data.List - ( delete - , deleteBy - , dropWhileEnd - , find + ( dropWhileEnd , groupBy - , intercalate - , nub - ,(\\) ) import Data.Maybe ( catMaybes @@ -639,9 +633,9 @@ toAST val = -- JSArrayLiteral [ JSDecimal \"1\", JSElision [], JSElision [], JSDecimal \"2\" ] -- 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 +getNearestSrcSpan :: JSNode -> SrcSpan -> SrcSpan +getNearestSrcSpan (NS _ SpanEmpty) s = s +getNearestSrcSpan s _ = jsnGetSource s isElision (NS (JSElision _) _) = True @@ -650,21 +644,23 @@ isElision _ = False processArray :: [JSNode] -> SrcSpan -> [[JSNode]] processArray list nearestSpan = - leadingElisions ++ (processElisions $ stripTrailingComma rest) + leadingElisions ++ (processElisions (stripTrailingComma rest) nearestSpanForRest) where leadingElisions = - [[NS (JSIdentifier "undefined") (getNearestSrcSpan (jsnGetSource el) nearestSpan)] + [[NS (JSIdentifier "undefined") (getNearestSrcSpan el nearestSpan)] | el <- (takeWhile isElision list)] rest = drop (length leadingElisions) list + nearestSpanForRest + | null leadingElisions = nearestSpan + | otherwise = getNearestSrcSpan (last $ last leadingElisions) nearestSpan stripTrailingComma :: [JSNode] -> [JSNode] stripTrailingComma list = dropWhileEnd (((==) (JSLiteral ",")) . jsnGetNode) list --- FIXME: Source spans could be better -processElisions :: [JSNode] -> [[JSNode]] -processElisions [] = [] -processElisions list = - filter (not . null) (separateElisions $ groupBy compareElements list) +processElisions :: [JSNode] -> SrcSpan -> [[JSNode]] +processElisions [] _ = [] +processElisions list nearestSpan = + filter (not . null) (separateElisions (groupBy compareElements list) nearestSpan) where compareElements l r | (isElision l) && (isElision r) = True @@ -673,16 +669,20 @@ processElisions list = -- We 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], [el, el], [c], [el]] - separateElisions [ls] = + -- + -- FIXME: The source spans for undefineds will all come out as the same one. There + -- is no obvious way to fix this (without fixing the parser). + separateElisions :: [[JSNode]] -> SrcSpan -> [[JSNode]] + separateElisions [ls] ns = if (isElision $ head ls) - then [[NS (JSIdentifier "undefined") (jsnGetSource el)] | el <- ls] + then [[NS (JSIdentifier "undefined") ns] | el <- ls] else [ls] - separateElisions (ls:others) = + separateElisions (ls:others) ns = if (isElision $ head ls) then - [[NS (JSIdentifier "undefined") (jsnGetSource el)] | el <- drop 1 ls] - ++ (separateElisions others) - else [ls] ++ (separateElisions others) + [[NS (JSIdentifier "undefined") ns] | el <- drop 1 ls] + ++ (separateElisions others ns) + else [ls] ++ (separateElisions others (getNearestSrcSpan (last ls) ns)) -- Takes a Node that represents a literal value and makes an AST node for that value. @@ -710,7 +710,6 @@ toASTValue (NS (JSArrayLiteral arr) srcSpan) = -- [[JSIdentifier \"y\", JSOperator \"=\", JSDecimal \"10\"], [JSDecimal \"3\"]] JSArray (map listToASTExpression (processArray arr srcSpan)) - -- (map listToASTExpression (processArray arr [] srcSpan)) toASTValue (NS (JSDecimal s) _) = if elem '.' s then From 6ea69569077aa15c4ed8ea02ccbcce92b02684a2 Mon Sep 17 00:00:00 2001 From: rjwright Date: Thu, 31 Jul 2014 16:22:43 +1000 Subject: [PATCH 15/20] Removed overly complicated code for source spans with elisions. --- ParseJS.hs | 35 +++++++++++++++-------------------- 1 file changed, 15 insertions(+), 20 deletions(-) diff --git a/ParseJS.hs b/ParseJS.hs index 53eb03e..0c2e2de 100644 --- a/ParseJS.hs +++ b/ParseJS.hs @@ -196,8 +196,8 @@ jsnGetSource :: JSNode -> SrcSpan jsnGetSource (NS _ srcSpan) = srcSpan -identifierGetString :: Node -> String -identifierGetString (JSIdentifier jsid) = jsid +jsIdentifierGetString :: Node -> String +jsIdentifierGetString (JSIdentifier jsid) = jsid listToMaybeExpression :: [JSNode] -> Maybe ASTWithSourceSpan @@ -296,7 +296,7 @@ toASTVarDeclaration :: JSNode -> ASTWithSourceSpan toASTVarDeclaration (NS (JSVarDecl name value) srcSpan) = AWSS (VarDeclaration - (identifierGetString $ jsnGetNode name) + (jsIdentifierGetString $ jsnGetNode name) (listToMaybeExpression value)) srcSpan @@ -351,7 +351,7 @@ toAST (NS (JSVariables _ varDecs) srcSpan) = srcSpan toAST (NS (JSBreak label _) srcSpan) = AWSS - (Break (liftM (identifierGetString . jsnGetNode) (listToMaybe label))) + (Break (liftM (jsIdentifierGetString . jsnGetNode) (listToMaybe label))) srcSpan toAST (NS (JSCase cs body) srcSpan) = AWSS @@ -363,7 +363,7 @@ toAST (NS (JSCase cs body) srcSpan) = toAST (NS (JSCatch var test body) srcSpan) = AWSS (Catch - (identifierGetString $ jsnGetNode var) + (jsIdentifierGetString $ jsnGetNode var) (listToMaybeExpression test) -- body is a JSBlock. (toAST body)) @@ -372,7 +372,7 @@ toAST (NS (JSCatch var test body) srcSpan) = -- with a value and a literal semicolon. toAST (NS (JSContinue label) srcSpan) = AWSS - (Continue (liftM (identifierGetString . jsnGetNode) (listToMaybe $ filterSemicolons label))) + (Continue (liftM (jsIdentifierGetString . jsnGetNode) (listToMaybe $ filterSemicolons label))) srcSpan toAST (NS (JSDefault body) srcSpan) = AWSS @@ -422,7 +422,7 @@ toAST (NS (JSFor vars test count body) srcSpan) = toAST (NS (JSForIn vars obj body) srcSpan) = AWSS (ForIn - (map (identifierGetString . jsnGetNode) vars) + (map (jsIdentifierGetString . jsnGetNode) vars) (toAST obj) -- body is a JSStatementBlock. (toAST body)) @@ -450,8 +450,8 @@ toAST (NS (JSForVarIn var obj body) srcSpan) = toAST (NS (JSFunction name args body) srcSpan) = AWSS (FunctionDeclaration - (identifierGetString $ jsnGetNode name) - (map (identifierGetString . jsnGetNode) args) + (jsIdentifierGetString $ jsnGetNode name) + (map (jsIdentifierGetString . jsnGetNode) args) (toAST body)) srcSpan toAST (NS (JSIf test body) srcSpan) = @@ -472,7 +472,7 @@ toAST (NS (JSIfElse test trueBody falseBody) srcSpan) = toAST (NS (JSLabelled label body) srcSpan) = AWSS (Labelled - (identifierGetString $ jsnGetNode label) + (jsIdentifierGetString $ jsnGetNode label) -- Body can be anything. (toAST body)) srcSpan @@ -564,8 +564,8 @@ toAST (NS (JSExpressionTernary expr ifTrue ifFalse) srcSpan) = toAST (NS (JSFunctionExpression name args body) srcSpan) = AWSS (FunctionExpression - (liftM (identifierGetString . jsnGetNode) (listToMaybe name)) - (map (identifierGetString . jsnGetNode) args) + (liftM (jsIdentifierGetString . jsnGetNode) (listToMaybe name)) + (map (jsIdentifierGetString . jsnGetNode) args) (toAST body)) srcSpan toAST (NS (JSIdentifier "undefined") srcSpan) = @@ -644,15 +644,9 @@ isElision _ = False processArray :: [JSNode] -> SrcSpan -> [[JSNode]] processArray list nearestSpan = - leadingElisions ++ (processElisions (stripTrailingComma rest) nearestSpanForRest) + [[NS (JSIdentifier "undefined") nearestSpan] | el <- (takeWhile isElision list)] + ++ (processElisions (stripTrailingComma $ dropWhile isElision list) nearestSpan) where - leadingElisions = - [[NS (JSIdentifier "undefined") (getNearestSrcSpan el nearestSpan)] - | el <- (takeWhile isElision list)] - rest = drop (length leadingElisions) list - nearestSpanForRest - | null leadingElisions = nearestSpan - | otherwise = getNearestSrcSpan (last $ last leadingElisions) nearestSpan stripTrailingComma :: [JSNode] -> [JSNode] stripTrailingComma list = dropWhileEnd (((==) (JSLiteral ",")) . jsnGetNode) list @@ -662,6 +656,7 @@ processElisions [] _ = [] processElisions list nearestSpan = filter (not . null) (separateElisions (groupBy compareElements list) nearestSpan) where + compareElements :: JSNode -> JSNode -> Bool compareElements l r | (isElision l) && (isElision r) = True | (not $ isElision l) && (not $ isElision r) = True From ec74c70d8625a8a10ddc7652eb7e118450b678dd Mon Sep 17 00:00:00 2001 From: rjwright Date: Thu, 31 Jul 2014 17:11:45 +1000 Subject: [PATCH 16/20] Further cleanup of processArray. --- ParseJS.hs | 84 ++++++++++++++++++++++++++---------------------------- 1 file changed, 40 insertions(+), 44 deletions(-) diff --git a/ParseJS.hs b/ParseJS.hs index 0c2e2de..12c1f17 100644 --- a/ParseJS.hs +++ b/ParseJS.hs @@ -632,52 +632,48 @@ toAST val = -- [1,,2] -- JSArrayLiteral [ JSDecimal \"1\", JSElision [], JSElision [], JSDecimal \"2\" ] --- Some elisions have SpanEmpty so we need to use the last non-empty SpanPoint. -getNearestSrcSpan :: JSNode -> SrcSpan -> SrcSpan -getNearestSrcSpan (NS _ SpanEmpty) s = s -getNearestSrcSpan s _ = jsnGetSource s - - -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 list nearestSpan = - [[NS (JSIdentifier "undefined") nearestSpan] | el <- (takeWhile isElision list)] - ++ (processElisions (stripTrailingComma $ dropWhile isElision list) nearestSpan) +processArray array nearestSpan = + (processLeadingElisions array) + ++ (processTail (dropWhileEnd isComma $ dropWhile isElision array) nearestSpan) where - stripTrailingComma :: [JSNode] -> [JSNode] - stripTrailingComma list = dropWhileEnd (((==) (JSLiteral ",")) . jsnGetNode) list - - -processElisions :: [JSNode] -> SrcSpan -> [[JSNode]] -processElisions [] _ = [] -processElisions list nearestSpan = - filter (not . null) (separateElisions (groupBy compareElements list) nearestSpan) - where - compareElements :: JSNode -> JSNode -> Bool - compareElements l r - | (isElision l) && (isElision r) = True - | (not $ isElision l) && (not $ isElision r) = True - | otherwise = False - -- We 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], [el, el], [c], [el]] - -- - -- FIXME: The source spans for undefineds will all come out as the same one. There - -- is no obvious way to fix this (without fixing the parser). - separateElisions :: [[JSNode]] -> SrcSpan -> [[JSNode]] - separateElisions [ls] ns = - if (isElision $ head ls) - then [[NS (JSIdentifier "undefined") ns] | el <- ls] - else [ls] - separateElisions (ls:others) ns = - if (isElision $ head ls) - then - [[NS (JSIdentifier "undefined") ns] | el <- drop 1 ls] - ++ (separateElisions others ns) - else [ls] ++ (separateElisions others (getNearestSrcSpan (last ls) ns)) + isComma :: JSNode -> Bool + isComma (NS (JSLiteral ",") _) = True + isComma _ = False + isElision :: JSNode -> Bool + isElision (NS (JSElision _) _) = True + isElision _ = False + processLeadingElisions :: [JSNode] -> [[JSNode]] + processLeadingElisions arr = + [[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. From deb23dbaa94c730369b339ebb7276c93248e5577 Mon Sep 17 00:00:00 2001 From: rjwright Date: Fri, 1 Aug 2014 14:57:23 +1000 Subject: [PATCH 17/20] moved array processing helper functions to top level. --- ParseJS.hs | 80 +++++++++++++++++++++++++++++------------------------- 1 file changed, 43 insertions(+), 37 deletions(-) diff --git a/ParseJS.hs b/ParseJS.hs index 12c1f17..2f6c8e9 100644 --- a/ParseJS.hs +++ b/ParseJS.hs @@ -631,49 +631,55 @@ toAST val = -- -- [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) + (processLeadingElisions array nearestSpan) ++ (processTail (dropWhileEnd isComma $ dropWhile isElision array) nearestSpan) - where - isComma :: JSNode -> Bool - isComma (NS (JSLiteral ",") _) = True - isComma _ = False - isElision :: JSNode -> Bool - isElision (NS (JSElision _) _) = True - isElision _ = False - processLeadingElisions :: [JSNode] -> [[JSNode]] - processLeadingElisions arr = - [[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)) + + +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. From 1cd910bb3235693d1c02d5e93b40cd7f6c5aa842 Mon Sep 17 00:00:00 2001 From: rjwright Date: Tue, 12 Aug 2014 16:33:23 +1000 Subject: [PATCH 18/20] Added maybeToProperList and properListToMaybe. Haven't finished using them. --- ParseJS.hs | 13 +++++++++++-- TypeRules.hs | 21 +++++++++++++-------- 2 files changed, 24 insertions(+), 10 deletions(-) diff --git a/ParseJS.hs b/ParseJS.hs index 2f6c8e9..faac554 100644 --- a/ParseJS.hs +++ b/ParseJS.hs @@ -199,10 +199,18 @@ jsnGetSource (NS _ srcSpan) = srcSpan jsIdentifierGetString :: Node -> String jsIdentifierGetString (JSIdentifier jsid) = jsid +-- maybeToWholeList + +properListToMaybe :: ([a] -> b) -> [a] -> Maybe b +properListToMaybe _ [] = Nothing +properListToMaybe f list = Just $ f list listToMaybeExpression :: [JSNode] -> Maybe ASTWithSourceSpan -listToMaybeExpression [] = Nothing -listToMaybeExpression jsn = Just $ listToASTExpression jsn +listToMaybeExpression jsnList = properListToMaybe listToASTExpression jsnList + +-- 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 @@ -635,6 +643,7 @@ isComma :: JSNode -> Bool isComma (NS (JSLiteral ",") _) = True isComma _ = False + isElision :: JSNode -> Bool isElision (NS (JSElision _) _) = True isElision _ = False diff --git a/TypeRules.hs b/TypeRules.hs index b52b383..986da3f 100644 --- a/TypeRules.hs +++ b/TypeRules.hs @@ -43,7 +43,7 @@ module TypeRules , varDecMakeLabel ) where - +import Control.Monad.State import LabelAST import ParseJS import ResolveSourceFragments @@ -162,11 +162,8 @@ data DeclaredIdentifier = DeclaredIdentifier Variable IdentifierLabel deriving ( -- ************************************************************************************************* -- TODO: Move these into a module? funExprMakeLabel :: ASTChild -> (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 (LabFunctionExpression maybeFunName _ _, lab, _) = + liftM (\varChild -> DeclaredIdentifier (fst varChild) (IDLabel lab)) maybeFunName varDecMakeLabel :: ASTChild -> DeclaredIdentifier @@ -198,10 +195,18 @@ childToMeta ch = Meta (childGetLabel ch) childWSToMeta :: (a, ASTLabel, b) -> Type childWSToMeta ch = Meta (childWSGetLabel ch) +maybeToProperList :: (a -> [b]) -> (Maybe a) -> [b] +maybeToProperList _ Nothing = [] +maybeToProperList f (Just x) = f x + -- 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 VarChild +-- maybeVarChildRules :: (Maybe VarChild) -> [DeclaredIdentifier] -> [Rule] +-- maybeVarChildRules (Just vc) dIDs = varChildRules vc dIDs +-- maybeVarChildRules Nothing _ = [] -- Generate rules from a Maybe ASTChild From c853da55e6f3da1a5d9515ca02a9ffe2f1dda548 Mon Sep 17 00:00:00 2001 From: rjwright Date: Tue, 12 Aug 2014 22:50:13 +1000 Subject: [PATCH 19/20] More playing with Maybes. Can probably be a lot better now I know how to use >>=. --- DeclarationGraph.hs | 18 +++++++----------- LabelAST.hs | 19 ++++++++++--------- ParseJS.hs | 16 ++++------------ TypeRules.hs | 29 +++++++++-------------------- 4 files changed, 30 insertions(+), 52 deletions(-) diff --git a/DeclarationGraph.hs b/DeclarationGraph.hs index 5518ad1..ca7f015 100644 --- a/DeclarationGraph.hs +++ b/DeclarationGraph.hs @@ -487,6 +487,10 @@ 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. @@ -629,23 +633,15 @@ valueGetFunExprRules (LabArray els, n) parent dIDs = mapExpGetFER els parent dID 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. --- astGetFunExprRules :: ASTChild -> ParentFunction -> [DeclaredIdentifier] -> [FunctionExpressionRules] - - - -- Make FunctionExpressionRules from Maybe ASTChild. getMaybeFunExprRules :: (Maybe ASTChild) -> ParentFunction -> [DeclaredIdentifier] -> [FunctionExpressionRules] -getMaybeFunExprRules Nothing parent dIDs = [] -getMaybeFunExprRules (Just ex) parent dIDs = astGetFunExprRules ex parent dIDs +getMaybeFunExprRules maybeASTChild parent dIDs = + maybeToProperList (\astChild -> astGetFunExprRules astChild parent dIDs) maybeASTChild -- Find variable declarations in a Maybe ASTChild. maybeExprGetVarDecs :: (Maybe ASTChild) -> [DeclaredIdentifier] -maybeExprGetVarDecs Nothing = [] -maybeExprGetVarDecs (Just ex) = astGetVarDecs ex +maybeExprGetVarDecs maybeASTChild = maybeToProperList astGetVarDecs maybeASTChild -- Find all identifiers declared in a AST. All of these, with the exception of diff --git a/LabelAST.hs b/LabelAST.hs index 72061c8..9ef05b7 100644 --- a/LabelAST.hs +++ b/LabelAST.hs @@ -181,15 +181,15 @@ 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 Nothing v = v -maxMaybeLabel (Just e) v = max (childGetLabel e) v +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 Nothing v = v -maxMaybeWSLabel (Just e) v = max (childWSGetLabel e) v +maxMaybeWSLabel maybeASTChild label = + maybe label (\astChild -> max (childWSGetLabel astChild) label) maybeASTChild -- Label a list of Varialbes. labelVarList :: [Variable] -> ASTLabel -> [VarChild] @@ -216,11 +216,13 @@ 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 Nothing n = Nothing -labelMaybeVar (Just var) n = Just (labelVariable var n) - +labelMaybeVar maybeVar label = maybeVar >>= (\var -> Just $ labelVariable var label) -- Label an Operator. labelOperator :: Operator -> ASTLabel -> OpChild @@ -268,8 +270,7 @@ 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 Nothing n = Nothing -labelMaybeAST (Just ex) n = Just $ labelAST ex n +labelMaybeAST maybeAST label = maybeAST >>= (\ast -> Just $ labelAST ast label) -- Label a AST. Recursively process any child fields. diff --git a/ParseJS.hs b/ParseJS.hs index faac554..6e70997 100644 --- a/ParseJS.hs +++ b/ParseJS.hs @@ -51,17 +51,8 @@ module ParseJS import Control.Monad.State import Data.Functor.Identity -import Data.List - ( dropWhileEnd - , groupBy - ) -import Data.Maybe - ( catMaybes - , fromJust - , isJust - , listToMaybe - , mapMaybe - ) +import Data.List (dropWhileEnd, groupBy) +import Data.Maybe (listToMaybe) import Language.JavaScript.Parser (parse) import Language.JavaScript.Parser.AST @@ -199,12 +190,13 @@ jsnGetSource (NS _ srcSpan) = srcSpan jsIdentifierGetString :: Node -> String jsIdentifierGetString (JSIdentifier jsid) = jsid --- maybeToWholeList +-- FIXME: So far only used in one place. Remove? properListToMaybe :: ([a] -> b) -> [a] -> Maybe b properListToMaybe _ [] = Nothing properListToMaybe f list = Just $ f list + listToMaybeExpression :: [JSNode] -> Maybe ASTWithSourceSpan listToMaybeExpression jsnList = properListToMaybe listToASTExpression jsnList diff --git a/TypeRules.hs b/TypeRules.hs index 986da3f..8daa615 100644 --- a/TypeRules.hs +++ b/TypeRules.hs @@ -40,10 +40,12 @@ module TypeRules , funExprMakeLabel , labelledMakeLabel , mapASTChildRules +, maybeToProperList , varDecMakeLabel ) where import Control.Monad.State +import Data.Maybe (maybeToList) import LabelAST import ParseJS import ResolveSourceFragments @@ -181,6 +183,10 @@ 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, ASTChild, ValueChild or ASTChild. childGetValue :: (a, ASTLabel) -> a @@ -191,28 +197,20 @@ childGetValue (val, lab) = val childToMeta :: (a, ASTLabel) -> Type childToMeta ch = Meta (childGetLabel ch) + -- Create a Meta type from the label on a VarChild, ASTChild, ValueChild or ASTChild. childWSToMeta :: (a, ASTLabel, b) -> Type childWSToMeta ch = Meta (childWSGetLabel ch) -maybeToProperList :: (a -> [b]) -> (Maybe a) -> [b] -maybeToProperList _ Nothing = [] -maybeToProperList f (Just x) = f x -- Generate rules from a Maybe VarChild maybeVarChildRules :: (Maybe VarChild) -> [DeclaredIdentifier] -> [Rule] maybeVarChildRules maybeVarChild dIDs = maybeToProperList (\varChild -> varChildRules varChild dIDs) maybeVarChild --- -- Generate rules from a Maybe VarChild --- maybeVarChildRules :: (Maybe VarChild) -> [DeclaredIdentifier] -> [Rule] --- maybeVarChildRules (Just vc) dIDs = varChildRules vc dIDs --- maybeVarChildRules Nothing _ = [] - -- Generate rules from a Maybe ASTChild maybeASTChildRules :: (Maybe ASTChild) -> [DeclaredIdentifier] -> [Rule] -maybeASTChildRules (Just ec) dIDs = astChildRules ec dIDs -maybeASTChildRules Nothing _ = [] +maybeASTChildRules maybeASTChild dIDs = maybeToProperList (\astChild -> astChildRules astChild dIDs) maybeASTChild -- Generate rules from a VarChild list @@ -223,14 +221,6 @@ mapVarChildRules var dIDs = mapVarChildRules' v = varChildRules v dIDs --- Generate rules from an ASTChild list --- mapASTChildRules :: [ASTChild] -> [DeclaredIdentifier] -> [Rule] --- mapASTChildRules ex dIDs = --- concat $ map mapASTChildRules' ex --- where --- mapASTChildRules' e = astChildRules e dIDs - - -- Gernerate rules from an ASTChild list mapASTChildRules :: [ASTChild] -> [DeclaredIdentifier] -> [Rule] mapASTChildRules ast dIDs = @@ -587,8 +577,7 @@ boolRule ex = Rule (childWSToMeta ex) BoolType (Just $ childGetSource ex) -- Make a list of rules from a Maybe ASTChild of Boolean type. maybeBoolRule :: (Maybe ASTChild) -> [Rule] -maybeBoolRule (Just t) = [boolRule t] -maybeBoolRule Nothing = [] +maybeBoolRule astChild = map boolRule (maybeToList astChild) -- Generate rules from an AST From c49771b31f17eaeecb5fe24910b209a7d40be0bd Mon Sep 17 00:00:00 2001 From: rjwright Date: Thu, 9 Oct 2014 15:10:26 +1100 Subject: [PATCH 20/20] Added build file --- build.sh | 4 ++++ 1 file changed, 4 insertions(+) create mode 100755 build.sh 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" +