Skip to content

Commit

Permalink
Typing
Browse files Browse the repository at this point in the history
  • Loading branch information
Chris Eidhof committed May 4, 2009
1 parent b5d8540 commit 22a9a4e
Show file tree
Hide file tree
Showing 6 changed files with 134 additions and 31 deletions.
34 changes: 25 additions & 9 deletions js/Analysis.hs
View file
Expand Up @@ -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))
Expand All @@ -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]
Expand All @@ -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}
Expand Down
13 changes: 13 additions & 0 deletions js/Finals.hs
View file
Expand Up @@ -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
Expand All @@ -52,13 +57,15 @@ 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
init (EmptyStmt a) = labelOf a
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)
Expand All @@ -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

Expand All @@ -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
Expand All @@ -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 _) = []
Expand All @@ -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
Expand Down
49 changes: 39 additions & 10 deletions js/Test.hs
View file
Expand Up @@ -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"
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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)
Expand Down
63 changes: 54 additions & 9 deletions js/Types.hs
View file
Expand Up @@ -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
Expand All @@ -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

Expand Down Expand Up @@ -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]
Expand All @@ -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]
Expand All @@ -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

Expand Down
2 changes: 1 addition & 1 deletion js/dataflowanalysis/Analysis.hs
View file
Expand Up @@ -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]
Expand Down
4 changes: 2 additions & 2 deletions js/dataflowanalysis/Chaotic.hs
View file
Expand Up @@ -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)
Expand Down

0 comments on commit 22a9a4e

Please sign in to comment.