Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Typing

  • Loading branch information...
commit 22a9a4eb207dee77570c6585b20dcad0495f4b2f 1 parent b5d8540
Chris Eidhof authored
View
34 js/Analysis.hs
@@ -7,17 +7,21 @@ import Finals
import Label
import SourcePos
import Types
+import DataFlowAnalysis.Analysis (analyze, scan_analyze)
import DataFlowAnalysis.SemiLattice (bottom)
import Data.Maybe (fromJust)
import qualified Data.Map as M
import Data.List (intercalate)
+import BrownPLT.JavaScript.Parser (parseScriptFromString) -- testing
refBuiltInObject = Ref 1
refBuiltInFunction = Ref 2
-- refBuiltInString
-- ...
-
+myTest x = case parseScriptFromString "" (x ++ ";;") of
+ Left err -> error (show err)
+ Right x -> scan_analyze ana $ label x
ana = createDataFlowAnalyser forward (createMeasureGen (const bottom, transferFunction))
@@ -35,20 +39,32 @@ transferFunction p = f
(n:ms) -> let addrs = maybe [] id $ M.lookup n (types gamma)
in gamma {refs = compose [changeRefs addr ms t | (Reference addr) <- addrs] (refs gamma)}
Just (NewExpr a clas args) -> \gamma -> gamma {refs = M.insert (Ref $ labelOf a) (newObject (constructorName clas) gamma) (refs gamma)}
- Just (FuncExpr a args body) -> let fref = (Ref . labelOf) a
- pref = (Ref . negate . labelOf) a
- in \gamma -> gamma {refs =( M.insert fref (newFunction pref)
+ Just (FuncExpr a args body) -> let fref = (Ref . labelOf) a
+ pref = (Ref . negate . labelOf) a
+ script = Script a [body]
+ anaResult = snd (analyze ana script)
+ (ReturnStmt retLab (Just retExp)) = head'' (body) $ returns script -- todo
+ retContext = fromJust $ M.lookup (labelOf retLab) anaResult
+ returnType = typeOf retContext retExp
+ -- TODO local variables
+ baseType = Function (map toName args) returnType
+ in \gamma -> gamma {refs =( M.insert fref (newFunction pref baseType)
. M.insert pref newPrototype
) (refs gamma) }
compose = foldr (.) id
+toName (Id _ x) = x
+
+-- todo
+head'' _ (x:xs) = x
+head'' e _ = error $ show e
newObject :: String -> Lattice -> Object
newObject clas gamma = Object { valueType = base clas , props = M.empty , prototype = protOf} --TODO PROTOTYPE clas.prototype `mplus` Object.prototype
- where base "String" = Just String
- base "Number" = Just Numeral
- base "Boolean" = Just Boolean
+ where base "String" = Just $ Left String
+ base "Number" = Just $ Left Numeral
+ base "Boolean" = Just $ Left Boolean
base _ = Nothing
protOf = let classobjsaddrs = (maybe [] id $ M.lookup clas (types gamma) ) :: [JsType]
classobjs = [M.lookup classobjaddr (refs gamma) | Reference classobjaddr <- classobjsaddrs] :: [Maybe Object]
@@ -57,8 +73,8 @@ newObject clas gamma = Object { valueType = base clas , props = M.empty , protot
[] -> Nothing
_ -> error $ "newObject ("++clas++") : multiple prototypes. context:" ++ show (gamma, classobjsaddrs, classobjs, prots)
-newFunction :: Ref -> Object
-newFunction protRef = Object {valueType = Just Function, prototype = Just refBuiltInFunction, props = M.singleton "prototype" [Reference protRef]}
+newFunction :: Ref -> FunctionType -> Object
+newFunction protRef baseType = Object {valueType = Just (Right baseType), prototype = Just refBuiltInFunction, props = M.singleton "prototype" [Reference protRef]}
newPrototype :: Object
newPrototype = Object {valueType = Nothing, prototype = Just refBuiltInObject, props = M.empty}
View
13 js/Finals.hs
@@ -39,6 +39,11 @@ news = listify isNewExpr
where isNewExpr (NewExpr _ _ _) = True
isNewExpr _ = False
+returns :: (Data a) => JavaScript a -> [Statement a]
+returns = listify isReturnStmt
+ where isReturnStmt (ReturnStmt _ _) = True
+ isReturnStmt _ = False
+
functiondecls :: (Data a) => JavaScript a -> [Assignment a]
functiondecls = listify isFunctionExpr
where isFunctionExpr (FuncExpr _ _ _) = True
@@ -52,6 +57,7 @@ instance Finals Statement where
finals (IfStmt _ cond e1 e2) = finals e1 `S.union` finals e2
finals (WhileStmt _ cond body) = finals cond
finals (ExprStmt a e) = finals e
+ finals (ReturnStmt a exp) = S.empty
finals x = error $ "This statement is not supported yet: " ++ show x
init (BlockStmt a ls) = labelOf a
@@ -59,6 +65,7 @@ instance Finals Statement where
init (IfStmt _ cond e1 e2) = init cond
init (WhileStmt _ cond body) = init cond
init (ExprStmt _ e) = init e
+ init (ReturnStmt _ (Just e)) = init e
init x = error $ "This statement is not supported yet: " ++ show x
flow (BlockStmt a ls) = flowList (labelOf a) ls ++ (concatMap flow ls)
@@ -72,6 +79,7 @@ instance Finals Statement where
++ [(b, init cond) | b <- S.elems (finals body)]
++ flow cond
++ flow body
+ flow (ReturnStmt a (Just r)) = [(f, labelOf a) | f <- S.elems $ finals r] ++ flow r
flow (ExprStmt _ e) = flow e
flow x = error $ "This flow is not supported yet: " ++ show x
@@ -96,6 +104,7 @@ instance Finals Expression where
finals (DotRef a parent child) = l a
finals (NewExpr a clas vars) = l a -- TODO
finals (FuncExpr a args body) = l a
+ finals (CallExpr a f args) = l a
finals x = error $ "Finals not supported for: " ++ show x
init (StringLit a _) = labelOf a
@@ -112,6 +121,7 @@ instance Finals Expression where
init (DotRef a parent child) = init parent
init (NewExpr a clas _) = labelOf a
init (FuncExpr a args body) = labelOf a
+ init (CallExpr a f args) = init f
init x = error $ "Init not supported for: " ++ show x
flow (StringLit a _) = []
@@ -129,7 +139,10 @@ instance Finals Expression where
flow (DotRef a parent child) = [(f, labelOf a) | f <- S.elems $ finals parent]
flow (ListExpr _ ls) = flowList (init $ head ls) (tail ls) ++ concatMap flow ls
flow (FuncExpr a args body) = []
+ flow (CallExpr a f []) = [(finalF, labelOf a) | finalF <- S.elems $ finals f] ++ flow f
+ flow (CallExpr a f args) = concat [flowList finalF args | finalF <- S.elems $ finals f] ++ flow f ++ concatMap flow args ++ [(f, labelOf a) | f <- S.elems $ finals (last args)]
flow (NewExpr a clas _ ) = [] -- TODO
+ flow x = error $ "Flow not supported for: " ++ show x
finalsOp :: (Show a) => InfixOp -> Expression (Labeled a) -> Expression (Labeled a) -> S.Set Label
View
49 js/Test.hs
@@ -25,9 +25,12 @@ cases = [ ("Simple numbers", "x = 5", at 12 ("x" `hasType`
, objectAssignment
, deepObjectAssignment
, loopObjectAssignment
- , functions
- , prototyping
- , prototypeAccess
+ , idFunction
+ , functionWithGlobalVariable
+ , functionApplication
+ -- , prototyping
+ -- , prototypeAccess
+ -- , functionType
]
simpleObject = ( "Simple object"
@@ -71,14 +74,34 @@ prototypeMerging = ( "Prototype merging"
)
)
-functions = ( "Functions"
- , "MyClass = function(){}"
- , at 17 ( "MyClass" `isReference` 15
- &&& 15 `hasValueType` Function
+idFunction = ( "Identity function"
+ , "f = function (x){ return x; }"
+ , at 22 ( "f" `isReference` 15
+ &&& 15 `hasValueType` (Right $ Function ["x"] [Primitive $ TypeOf "x"])
+ &&& 15 `hasPrototype` refBuiltInFunction
+ )
+ )
+
+functionWithGlobalVariable = ( "Function with a global variable"
+ , "f = function (x){ return y; }"
+ , at 22 ( "f" `isReference` 15
+ &&& 15 `hasValueType` (Right $ Function ["x"] [Primitive $ TypeOf "y"])
+ &&& 15 `hasPrototype` refBuiltInFunction
+ )
+ )
+
+functionApplication = ( "Function application"
+ , "f = function (x){ return x; }; y = f(10)"
+ --, const (return False)
+ , at 31 ( "f" `isReference` 15
+ &&& 15 `hasValueType` (Right $ Function ["x"] [Primitive $ TypeOf "x"])
&&& 15 `hasPrototype` refBuiltInFunction
- )
+ &&& "y" `hasTypes` [numeral]
+ )
)
+-- todo: next: function application with cloning
+
prototyping = ( "Prototyping"
, "MyClass = function(){}; MyClass.prototype.foo = 'hi'; x = new MyClass()"
, at 35 ( "MyClass" `isReference` 15
@@ -98,9 +121,15 @@ prototypeAccess = ( "Prototype access"
)
)
+functionType = ("Polymorphic functions"
+ ,"f = function (x){ return x; }"
+ , at 22 ("x" `hasType` undefined
+ )
+ )
+
testCase (name, prog, cond) = case parseScriptFromString "" (prog ++ ";;") of
Left e -> error $ "Parsing failed for case " ++ prog
- Right x -> case (cond $ snd $ last $ analyze ana $ label x) of
+ Right x -> case (cond $ snd $ analyze ana $ label x) of
Left err -> do putStrLn $ "Test failed: " ++ name ++ ": " ++ intercalate ";" err
print (label x)
Right False -> do putStrLn $ "Test failed: " ++ name
@@ -141,7 +170,7 @@ hasField addr (prop,typ) lat = case M.lookup (Ref addr) (refs lat) of
Nothing -> err $ "No such field: " ++ prop
Just t -> Right (t == [typ])
-hasValueType :: Int -> PrimitiveType -> Lattice -> Err Bool
+hasValueType :: Int -> Either PrimitiveType FunctionType -> Lattice -> Err Bool
hasValueType addr typ lat = case M.lookup (Ref addr) (refs lat) of
Nothing -> err $ "No such reference in (hasValueType) scope : " ++ show addr
Just (Object t _ _ ) -> Right (t == Just typ)
View
63 js/Types.hs
@@ -12,17 +12,23 @@ import Data.List (nub)
import Control.Monad.Reader
import Label
import Debug.Trace (trace)
+import Data.Maybe (isJust, fromJust)
-data PrimitiveType = String | Numeral | Boolean | Null | Function | Undefined
+data PrimitiveType = String | Numeral | Boolean | Null | TypeOf String | Undefined
deriving (Show, Eq, Ord)
-newtype Ref = Ref {address :: Int}
+data Ref = Ref {address :: Int} | Cloned {clonePosition :: Int, originalAddress :: Ref}
+ deriving (Show, Eq, Ord)
+
+data FunctionType = Function { args :: [String]
+ , resultType :: [JsType]
+ }
deriving (Show, Eq, Ord)
data JsType = Primitive PrimitiveType | Reference Ref
deriving (Show, Eq, Ord)
-data Object = Object {valueType :: Maybe PrimitiveType, props :: PropertyMap, prototype :: Maybe Ref}
+data Object = Object {valueType :: Maybe (Either PrimitiveType FunctionType), props :: PropertyMap, prototype :: Maybe Ref}
deriving (Show, Eq)
-- | Function [JsType] JsType | Var TypeVar
@@ -32,7 +38,10 @@ type TypeVar = Int
type PropertyMap = M.Map String [JsType]
class Infer a where
- infer :: a -> StateT TypeVar (Reader Lattice) [JsType]
+ infer :: a -> InferMonad [JsType]
+
+
+type InferMonad a = StateT TypeVar (Reader Lattice) a
typeOf l x = runReader (evalStateT (infer x) 0) l
@@ -69,15 +78,18 @@ instance Show a => Infer (Expression (Labeled a)) where
infer (NewExpr a _ _ ) = return [Reference (Ref $ labelOf a)]
infer (AssignExpr a op l r) = infer r
- infer v@(VarRef a (Id _ n)) = do ctx <- asks types
- case M.lookup n ctx of
- Nothing -> return []
- Just x -> return x
+ infer v@(VarRef a (Id _ n)) = inferVar n
infer (InfixExpr _ op l r) = (map topLevel) <$> infer op -- TODO
infer (ListExpr _ ls) = infer (last ls) -- todo: what's the semantics here?
infer (ParenExpr _ e) = infer e
infer (FuncExpr a args body) = return [Reference (Ref $ labelOf a)]
- infer (DotRef a p (Id _ n)) = do objectType <- infer p -- TODO: we don't do any prototype checking at all
+ infer (CallExpr a f args) = do ctx <- asks types
+ lhs <- infer f
+ argTypes <- mapM infer args
+ typs <- mapM (inferCall (labelOf a) argTypes) lhs -- TODO: do we need all combinations?
+ return $ concat typs
+
+ infer (DotRef a p (Id _ n)) = do objectType <- infer p
refMap <- asks refs
-- todo: this can be more clearly
let mUndefined = maybe [tUndefined]
@@ -94,6 +106,11 @@ instance Show a => Infer (Expression (Labeled a)) where
inferProp (n,e) = do ts <- infer e
return (name n, ts)
+inferVar n = do ctx <- asks types
+ case M.lookup n ctx of
+ Nothing -> return [Primitive $ TypeOf n]
+ Just x -> return x
+
numCond = undefined -- return [Function [Numeral, Numeral] Boolean]
compCond = undefined -- do t <- fresh
--return undefined -- [Function [Var t, Var t] Boolean]
@@ -102,11 +119,39 @@ arith = undefined -- return [Function [Numeral, Numeral] Numeral]
--str = return [Function [String, String] String]
--
+inferCall :: Label -> [[JsType]] -> JsType -> InferMonad [JsType]
+inferCall lab args p@(Primitive (TypeOf _)) = return []
+inferCall lab args p@(Primitive _) = error $ "Exception: inferCall: " ++ show p
+inferCall lab args p@(Reference r) = do refMap <- asks refs
+ case M.lookup r refMap of
+ Nothing -> return [tUndefined]
+ Just o -> case valueType o of
+ Just (Right (Function argNames resultType)) -> do
+ let substList = safeZip argNames args
+ resultT <- mapM (subst lab substList) resultType
+ return $ concat resultT
+ _ -> error $ "Not a function type (inferCall)"
+
+subst :: Label -> [(String, [JsType])] -> JsType -> InferMonad [JsType]
+subst label substList (Primitive (TypeOf x)) | isJust l = return $ fromJust l
+ | otherwise = inferVar x
+ where l = lookup x substList
+subst label substList (Primitive p ) = return [Primitive p]
+subst label substList (Reference r) = return [Reference (Cloned label r)]
+
+
+safeZip [] [] = []
+safeZip (x:xs) (y:ys) = (x,y):(safeZip xs ys)
+safeZip _ _ = error "safeZip: lists of unequal length"
+
topLevel :: JsType -> JsType
topLevel = undefined
-- topLevel (Function args res) = res
-- topLevel x = x
+fromId :: Id a -> String
+fromId (Id _ s) = s
+
name :: Prop a -> String
name (PropId _ (Id _ s)) = s
View
2  js/dataflowanalysis/Analysis.hs
@@ -8,7 +8,7 @@ import DataFlowAnalysis.MonotoneFramework
import DataFlowAnalysis.Chaotic
import DataFlowAnalysis.Program
-analyze :: (Show lat, Program prg, Eq lat, SemiLattice lat) => DataFlowAnalyser prg lat -> prg -> [IterationResult lat]
+analyze :: (Show lat, Program prg, Eq lat, SemiLattice lat) => DataFlowAnalyser prg lat -> prg -> IterationResult lat
analyze analysis = chaotic_solving. (seedEqs `split` equations) .analysis
scan_analyze :: (Show lat, Program prg, Eq lat, SemiLattice lat) => DataFlowAnalyser prg lat -> prg -> [IterationResult lat]
View
4 js/dataflowanalysis/Chaotic.hs
@@ -5,11 +5,11 @@ import qualified Data.Map as M
import DataFlowAnalysis.MonotoneFramework
-chaotic_solving :: (Eq lat) => (IterationResult lat, Equations lat) -> [IterationResult lat]
+chaotic_solving :: (Eq lat) => (IterationResult lat, Equations lat) -> IterationResult lat
chaotic_solving (st,eqs) = fixpoint (chaoticstep eqs) st
fixpoint f x = let x' = f x in
- if x' == x then [x] else x:(fixpoint f x')
+ if x' == x then x else fixpoint f x'
chaoticstep :: Equations lat -> IterationResult lat -> IterationResult lat
chaoticstep (op, cl) x = (appl op, appl cl)
Please sign in to comment.
Something went wrong with that request. Please try again.