git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Runtime type checks for basic types
commit0ca3eaaf63956b5a7643ceebf6d8627575afcc9b authorPhil Freeman <paf31@cantab.net> dateWed 8 Jan 2014, 15:39 (13 years ago) parent1fc813f
9 files changed+154−63
compare with golang
unifiedsplit
purescript.cabal+7−8 src/Language/PureScript.hs+4−3 src/Language/PureScript/CodeGen/JS.hs+76−44 src/Language/PureScript/CodeGen/JS/AST.hs+2−1 src/Language/PureScript/Optimize.hs+19−2 src/Language/PureScript/Options.hs+23 src/Language/PureScript/Pretty/JS.hs+7 src/Main.hs+15−4 tests/Main.hs+1−1
purescript.cabal+7−8
@@ -1,5 +1,5 @@
11name: purescript
2−version: 0.2.7
2+version: 0.2.8
33cabal-version: >=1.8
44build-type: Simple
55license: MIT
@@ -17,9 +17,10 @@ library
1717 build-depends: base >=4 && <5, cmdtheline -any, containers -any,
1818 directory -any, filepath -any, mtl -any, parsec -any, syb -any,
1919 transformers -any, utf8-string -any
20− exposed-modules: Data.Generics.Extras Language.PureScript
21− Language.PureScript.CodeGen Language.PureScript.CodeGen.Externs
22− Language.PureScript.CodeGen.JS Language.PureScript.CodeGen.JS.AST
20+ exposed-modules: Language.PureScript.Options Data.Generics.Extras
21+ Language.PureScript Language.PureScript.CodeGen
22+ Language.PureScript.CodeGen.Externs Language.PureScript.CodeGen.JS
23+ Language.PureScript.CodeGen.JS.AST
2324 Language.PureScript.CodeGen.Monad Language.PureScript.Declarations
2425 Language.PureScript.Kinds Language.PureScript.Names
2526 Language.PureScript.Operators Language.PureScript.Optimize
@@ -36,11 +37,9 @@ library
3637 Language.PureScript.TypeChecker.Synonyms
3738 Language.PureScript.TypeChecker.Types Language.PureScript.Types
3839 Language.PureScript.Unknown Language.PureScript.Values Main
39− Language.PureScript.CaseDeclarations
40− Language.PureScript.DoNotation
40+ Language.PureScript.CaseDeclarations Language.PureScript.DoNotation
4141 Language.PureScript.TypeDeclarations
42− Language.PureScript.BindingGroups
43− Language.PureScript.Scope
42+ Language.PureScript.BindingGroups Language.PureScript.Scope
4443 exposed: True
4544 buildable: True
4645 hs-source-dirs: src
src/Language/PureScript.hs+4−3
@@ -29,12 +29,13 @@ import Language.PureScript.CaseDeclarations as P
2929import Language.PureScript.TypeDeclarations as P
3030import Language.PureScript.BindingGroups as P
3131import Language.PureScript.DoNotation as P
32+import Language.PureScript.Options as P
3233
3334import Data.List (intercalate)
3435import Control.Monad (forM_, (>=>))
3536
36−compile :: [Module] -> Either String (String, String, Environment)
37−compile ms = do
37+compile :: Options -> [Module] -> Either String (String, String, Environment)
38+compile opts ms = do
3839 bracketted <- rebracket ms
3940 desugared <- desugarDo
4041 >=> desugarCasesModule
@@ -42,6 +43,6 @@ compile ms = do
4243 >=> (return . createBindingGroupsModule)
4344 $ bracketted
4445 (_, env) <- runCheck $ forM_ desugared $ \(Module moduleName decls) -> typeCheckAll (ModuleName moduleName) decls
45− let js = prettyPrintJS . map optimize . concatMap (flip moduleToJs env) $ desugared
46+ let js = prettyPrintJS . map (optimize opts) . concatMap (flip (moduleToJs opts) env) $ desugared
4647 let exts = intercalate "\n" . map (flip moduleToPs env) $ desugared
4748 return (js, exts, env)
src/Language/PureScript/CodeGen/JS.hs+76−44
@@ -30,31 +30,33 @@ import Language.PureScript.Scope
3030import Language.PureScript.Declarations
3131import Language.PureScript.Pretty.Common
3232import Language.PureScript.CodeGen.Monad
33+import Language.PureScript.Options
3334import Language.PureScript.CodeGen.JS.AST as AST
3435import Language.PureScript.TypeChecker.Monad (NameKind(..))
36+import Language.PureScript.Types
3537
36−moduleToJs :: Module -> Environment -> [JS]
37−moduleToJs (Module pname@(ProperName name) decls) env =
38+moduleToJs :: Options -> Module -> Environment -> [JS]
39+moduleToJs opts (Module pname@(ProperName name) decls) env =
3840 [ JSVariableIntroduction (Ident name) Nothing
3941 , JSApp (JSFunction Nothing [Ident name]
40− (JSBlock (concat $ mapMaybe (\decl -> declToJs (ModuleName pname) decl env) decls)))
42+ (JSBlock (concat $ mapMaybe (\decl -> declToJs opts (ModuleName pname) decl env) decls)))
4143 [JSAssignment (JSAssignVariable (Ident name))
4244 (JSBinary Or (JSVar (Ident name)) (JSObjectLiteral []))]
4345 ]
4446
45−declToJs :: ModuleName -> Declaration -> Environment -> Maybe [JS]
46−declToJs mp (ValueDeclaration ident _ _ val) e =
47− Just [ JSVariableIntroduction ident (Just (valueToJs mp e val)),
47+declToJs :: Options -> ModuleName -> Declaration -> Environment -> Maybe [JS]
48+declToJs opts mp (ValueDeclaration ident _ _ val) e =
49+ Just [ JSVariableIntroduction ident (Just (valueToJs opts mp e val)),
4850 setProperty (identToJs ident) (JSVar ident) mp ]
49−declToJs mp (BindingGroupDeclaration vals) e =
51+declToJs opts mp (BindingGroupDeclaration vals) e =
5052 Just $ concatMap (\(ident, val) ->
51− [ JSVariableIntroduction ident (Just (valueToJs mp e val)),
53+ [ JSVariableIntroduction ident (Just (valueToJs opts mp e val)),
5254 setProperty (identToJs ident) (JSVar ident) mp ]
5355 ) vals
54−declToJs mp (ExternMemberDeclaration member ident _) _ =
56+declToJs _ mp (ExternMemberDeclaration member ident _) _ =
5557 Just [ JSFunction (Just ident) [Ident "value"] (JSBlock [JSReturn (JSAccessor member (JSVar (Ident "value")))]),
5658 setProperty (show ident) (JSVar ident) mp ]
57−declToJs mp (DataDeclaration _ _ ctors) _ =
59+declToJs _ mp (DataDeclaration _ _ ctors) _ =
5860 Just $ flip concatMap ctors $ \(pn@(ProperName ctor), maybeTy) ->
5961 let
6062 ctorJs =
@@ -65,31 +67,61 @@ declToJs mp (DataDeclaration _ _ ctors) _ =
6567 (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn)))
6668 , ("value", JSVar (Ident "value")) ])])
6769 in [ ctorJs, setProperty ctor (JSVar (Ident ctor)) mp ]
68−declToJs _ _ _ = Nothing
70+declToJs _ _ _ _ = Nothing
6971
7072setProperty :: String -> JS -> ModuleName -> JS
7173setProperty prop val (ModuleName (ProperName moduleName)) = JSAssignment (JSAssignProperty prop (JSAssignVariable (Ident moduleName))) val
7274
73−valueToJs :: ModuleName -> Environment -> Value -> JS
74−valueToJs _ _ (NumericLiteral n) = JSNumericLiteral n
75−valueToJs _ _ (StringLiteral s) = JSStringLiteral s
76−valueToJs _ _ (BooleanLiteral b) = JSBooleanLiteral b
77−valueToJs m e (ArrayLiteral xs) = JSArrayLiteral (map (valueToJs m e) xs)
78−valueToJs m e (ObjectLiteral ps) = JSObjectLiteral (map (second (valueToJs m e)) ps)
79−valueToJs m e (ObjectUpdate o ps) = JSApp (JSAccessor "extend" (JSVar (Ident "Object"))) [ valueToJs m e o, JSObjectLiteral (map (second (valueToJs m e)) ps)]
80−valueToJs _ _ (Constructor name) = qualifiedToJS runProperName name
81−valueToJs m e (Block sts) = JSApp (JSFunction Nothing [] (JSBlock (map (statementToJs m e) sts))) []
82−valueToJs m e (Case values binders) = runGen (bindersToJs m e binders (map (valueToJs m e) values))
83−valueToJs m e (IfThenElse cond th el) = JSConditional (valueToJs m e cond) (valueToJs m e th) (valueToJs m e el)
84−valueToJs m e (Accessor prop val) = JSAccessor prop (valueToJs m e val)
85−valueToJs m e (Indexer index val) = JSIndexer (valueToJs m e index) (valueToJs m e val)
86−valueToJs m e (App val args) = JSApp (valueToJs m e val) (map (valueToJs m e) args)
87−valueToJs m e (Abs args val) = JSFunction Nothing args (JSBlock [JSReturn (valueToJs m e val)])
88−valueToJs m e (Unary op val) = JSUnary op (valueToJs m e val)
89−valueToJs m e (Binary op v1 v2) = JSBinary op (valueToJs m e v1) (valueToJs m e v2)
90−valueToJs m e (Var ident) = varToJs m e ident
91−valueToJs m e (TypedValue val _) = valueToJs m e val
92−valueToJs _ _ _ = error "Invalid argument to valueToJs"
75+valueToJs :: Options -> ModuleName -> Environment -> Value -> JS
76+valueToJs _ _ _ (NumericLiteral n) = JSNumericLiteral n
77+valueToJs _ _ _ (StringLiteral s) = JSStringLiteral s
78+valueToJs _ _ _ (BooleanLiteral b) = JSBooleanLiteral b
79+valueToJs opts m e (ArrayLiteral xs) = JSArrayLiteral (map (valueToJs opts m e) xs)
80+valueToJs opts m e (ObjectLiteral ps) = JSObjectLiteral (map (second (valueToJs opts m e)) ps)
81+valueToJs opts m e (ObjectUpdate o ps) = JSApp (JSAccessor "extend" (JSVar (Ident "Object"))) [ valueToJs opts m e o, JSObjectLiteral (map (second (valueToJs opts m e)) ps)]
82+valueToJs _ _ _ (Constructor name) = qualifiedToJS runProperName name
83+valueToJs opts m e (Block sts) = JSApp (JSFunction Nothing [] (JSBlock (map (statementToJs opts m e) sts))) []
84+valueToJs opts m e (Case values binders) = runGen (bindersToJs opts m e binders (map (valueToJs opts m e) values))
85+valueToJs opts m e (IfThenElse cond th el) = JSConditional (valueToJs opts m e cond) (valueToJs opts m e th) (valueToJs opts m e el)
86+valueToJs opts m e (Accessor prop val) = JSAccessor prop (valueToJs opts m e val)
87+valueToJs opts m e (Indexer index val) = JSIndexer (valueToJs opts m e index) (valueToJs opts m e val)
88+valueToJs opts m e (App val args) = JSApp (valueToJs opts m e val) (map (valueToJs opts m e) args)
89+valueToJs opts m e (Abs args val) = JSFunction Nothing args (JSBlock [JSReturn (valueToJs opts m e val)])
90+valueToJs opts m e (TypedValue (Abs args val) ty) | optionsPerformRuntimeTypeChecks opts = JSFunction Nothing args (JSBlock $ runtimeTypeChecks args ty ++ [JSReturn (valueToJs opts m e val)])
91+valueToJs opts m e (Unary op val) = JSUnary op (valueToJs opts m e val)
92+valueToJs opts m e (Binary op v1 v2) = JSBinary op (valueToJs opts m e v1) (valueToJs opts m e v2)
93+valueToJs _ m e (Var ident) = varToJs m e ident
94+valueToJs opts m e (TypedValue val _) = valueToJs opts m e val
95+valueToJs _ _ _ _ = error "Invalid argument to valueToJs"
96+
97+runtimeTypeChecks :: [Ident] -> Type -> [JS]
98+runtimeTypeChecks args ty =
99+ let
100+ argTys = getFunctionArgumentTypes ty
101+ in
102+ concat $ zipWith argumentCheck (map JSVar args) argTys
103+ where
104+ getFunctionArgumentTypes :: Type -> [Type]
105+ getFunctionArgumentTypes (Function funArgs _) = funArgs
106+ getFunctionArgumentTypes (ForAll _ ty') = getFunctionArgumentTypes ty'
107+ getFunctionArgumentTypes _ = []
108+ argumentCheck :: JS -> Type -> [JS]
109+ argumentCheck val Number = [typeCheck val "number"]
110+ argumentCheck val String = [typeCheck val "string"]
111+ argumentCheck val Boolean = [typeCheck val "boolean"]
112+ argumentCheck val (Array _) = [arrayCheck val]
113+ argumentCheck val (Object row) =
114+ let
115+ (pairs, _) = rowToList row
116+ in
117+ typeCheck val "object" : concatMap (\(prop, ty') -> argumentCheck (JSAccessor prop val) ty') pairs
118+ argumentCheck val (Function _ _) = [typeCheck val "function"]
119+ argumentCheck val (ForAll _ ty') = argumentCheck val ty'
120+ argumentCheck _ _ = []
121+ typeCheck :: JS -> String -> JS
122+ typeCheck js ty' = JSIfElse (JSBinary NotEqualTo (JSTypeOf js) (JSStringLiteral ty')) (JSBlock [JSThrow (JSStringLiteral $ ty' ++ " expected")]) Nothing
123+ arrayCheck :: JS -> JS
124+ arrayCheck js = JSIfElse (JSUnary Not (JSApp (JSAccessor "isArray" (JSVar (Ident "Array"))) [js])) (JSBlock [JSThrow (JSStringLiteral "Array expected")]) Nothing
93125
94126varToJs :: ModuleName -> Environment -> Qualified Ident -> JS
95127varToJs m e qual@(Qualified _ ident) = case M.lookup (qualify m qual) (names e) of
@@ -107,17 +139,17 @@ qualifiedToJS :: (a -> String) -> Qualified a -> JS
107139qualifiedToJS f (Qualified (Just (ModuleName (ProperName m))) a) = JSAccessor (f a) (JSVar (Ident m))
108140qualifiedToJS f (Qualified Nothing a) = JSVar (Ident (f a))
109141
110−bindersToJs :: ModuleName -> Environment -> [([Binder], Maybe Guard, Value)] -> [JS] -> Gen JS
111−bindersToJs m e binders vals = do
142+bindersToJs :: Options -> ModuleName -> Environment -> [([Binder], Maybe Guard, Value)] -> [JS] -> Gen JS
143+bindersToJs opts m e binders vals = do
112144 setNextName $ firstUnusedName (binders, vals)
113145 valNames <- replicateM (length vals) fresh
114− jss <- forM binders $ \(bs, grd, result) -> go valNames [JSReturn (valueToJs m e result)] bs grd
146+ jss <- forM binders $ \(bs, grd, result) -> go valNames [JSReturn (valueToJs opts m e result)] bs grd
115147 return $ JSApp (JSFunction Nothing (map Ident valNames) (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))
116148 vals
117149 where
118150 go :: [String] -> [JS] -> [Binder] -> Maybe Guard -> Gen [JS]
119151 go _ done [] Nothing = return done
120− go _ done [] (Just cond) = return [JSIfElse (valueToJs m e cond) (JSBlock done) Nothing]
152+ go _ done [] (Just cond) = return [JSIfElse (valueToJs opts m e cond) (JSBlock done) Nothing]
121153 go (v:vs) done' (b:bs) grd = do
122154 done'' <- go vs done' bs grd
123155 binderToJs m e v done'' b
@@ -175,16 +207,16 @@ binderToJs m e varName done (NamedBinder ident binder) = do
175207 js <- binderToJs m e varName done binder
176208 return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : js)
177209
178−statementToJs :: ModuleName -> Environment -> Statement -> JS
179−statementToJs m e (VariableIntroduction ident value) = JSVariableIntroduction ident (Just (valueToJs m e value))
180−statementToJs m e (Assignment target value) = JSAssignment (JSAssignVariable target) (valueToJs m e value)
181−statementToJs m e (While cond sts) = JSWhile (valueToJs m e cond) (JSBlock (map (statementToJs m e) sts))
182−statementToJs m e (For ident start end sts) = JSFor ident (valueToJs m e start) (valueToJs m e end) (JSBlock (map (statementToJs m e) sts))
183−statementToJs m e (If ifst) = ifToJs ifst
210+statementToJs :: Options -> ModuleName -> Environment -> Statement -> JS
211+statementToJs opts m e (VariableIntroduction ident value) = JSVariableIntroduction ident (Just (valueToJs opts m e value))
212+statementToJs opts m e (Assignment target value) = JSAssignment (JSAssignVariable target) (valueToJs opts m e value)
213+statementToJs opts m e (While cond sts) = JSWhile (valueToJs opts m e cond) (JSBlock (map (statementToJs opts m e) sts))
214+statementToJs opts m e (For ident start end sts) = JSFor ident (valueToJs opts m e start) (valueToJs opts m e end) (JSBlock (map (statementToJs opts m e) sts))
215+statementToJs opts m e (If ifst) = ifToJs ifst
184216 where
185217 ifToJs :: IfStatement -> JS
186− ifToJs (IfStatement cond thens elses) = JSIfElse (valueToJs m e cond) (JSBlock (map (statementToJs m e) thens)) (fmap elseToJs elses)
218+ ifToJs (IfStatement cond thens elses) = JSIfElse (valueToJs opts m e cond) (JSBlock (map (statementToJs opts m e) thens)) (fmap elseToJs elses)
187219 elseToJs :: ElseStatement -> JS
188− elseToJs (Else sts) = JSBlock (map (statementToJs m e) sts)
220+ elseToJs (Else sts) = JSBlock (map (statementToJs opts m e) sts)
189221 elseToJs (ElseIf elif) = ifToJs elif
190−statementToJs m e (Return value) = JSReturn (valueToJs m e value)
222+statementToJs opts m e (Return value) = JSReturn (valueToJs opts m e value)
src/Language/PureScript/CodeGen/JS/AST.hs+2−1
@@ -42,7 +42,8 @@ data JS
4242 | JSFor Ident JS JS JS
4343 | JSIfElse JS JS (Maybe JS)
4444 | JSReturn JS
45− | JSThrow JS deriving (Show, Data, Typeable)
45+ | JSThrow JS
46+ | JSTypeOf JS deriving (Show, Data, Typeable)
4647
4748data JSAssignment
4849 = JSAssignVariable Ident
src/Language/PureScript/Optimize.hs+19−2
@@ -22,9 +22,10 @@ import Data.Generics
2222
2323import Language.PureScript.Names
2424import Language.PureScript.CodeGen.JS.AST
25+import Language.PureScript.Options
2526
26−optimize :: JS -> JS
27−optimize = removeUnusedVariables . unThunk . etaConvert . inlineVariables
27+optimize :: Options -> JS -> JS
28+optimize opts = tco opts . removeUnusedVariables . unThunk . etaConvert . inlineVariables
2829
2930replaceIdent :: (Data d) => Ident -> JS -> d -> d
3031replaceIdent var1 js = everywhere (mkT replace)
@@ -101,3 +102,19 @@ unThunk = everywhere (mkT convert)
101102 convert :: JS -> JS
102103 convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) [])]) = JSBlock body
103104 convert js = js
105+
106+tco :: Options -> JS -> JS
107+tco opts | optionsTco opts = tco'
108+ | otherwise = id
109+
110+tco' :: JS -> JS
111+tco' = everywhere (mkT convert)
112+ where
113+ convert :: JS -> JS
114+ convert (JSVariableIntroduction name (Just (JSFunction Nothing args body)))
115+ | isTailCall name body = (JSVariableIntroduction name (Just (JSFunction Nothing args (toLoop name args body))))
116+ convert js = js
117+ isTailCall :: Ident -> JS -> Bool
118+ isTailCall _ _ = False
119+ toLoop :: Ident -> [Ident] -> JS -> JS
120+ toLoop = undefined
src/Language/PureScript/Options.hsnew file+23
@@ -0,0 +1,23 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Options
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.PureScript.Options where
16+
17+data Options = Options
18+ { optionsTco :: Bool
19+ , optionsPerformRuntimeTypeChecks :: Bool
20+ } deriving Show
21+
22+defaultOptions :: Options
23+defaultOptions = Options False False
src/Language/PureScript/Pretty/JS.hs+7
@@ -156,6 +156,12 @@ app = mkPattern' match
156156 return (intercalate ", " jss, val)
157157 match _ = mzero
158158
159+typeOf :: Pattern PrinterState JS ((), JS)
160+typeOf = mkPattern match
161+ where
162+ match (JSTypeOf val) = Just ((), val)
163+ match _ = Nothing
164+
159165unary :: UnaryOperator -> String -> Operator PrinterState JS String
160166unary op str = Wrap match (++)
161167 where
@@ -202,6 +208,7 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue
202208 , [ binary LessThanOrEqualTo "<=" ]
203209 , [ binary GreaterThan ">" ]
204210 , [ binary GreaterThanOrEqualTo ">=" ]
211+ , [ Wrap typeOf $ \_ s -> "typeof " ++ s ]
205212 , [ unary Not "!" ]
206213 , [ unary BitwiseNot "~" ]
207214 , [ unary Negate "-" ]
src/Main.hs+15−4
@@ -28,15 +28,15 @@ readInput (Just input) = fmap (fmap concat . sequence) $ forM input $ \inputFile
2828 text <- U.readFile inputFile
2929 return $ P.runIndentParser P.parseModules text
3030
31−compile :: Maybe [FilePath] -> Maybe FilePath -> Maybe FilePath -> IO ()
32−compile input output externs = do
31+compile :: P.Options -> Maybe [FilePath] -> Maybe FilePath -> Maybe FilePath -> IO ()
32+compile opts input output externs = do
3333 modules <- readInput input
3434 case modules of
3535 Left err -> do
3636 U.print err
3737 exitFailure
3838 Right ms ->
39− case P.compile ms of
39+ case P.compile opts ms of
4040 Left err -> do
4141 U.putStrLn err
4242 exitFailure
@@ -65,6 +65,17 @@ externsFile :: Term (Maybe FilePath)
6565externsFile = value $ opt Nothing $ (optInfo [ "e", "externs" ])
6666 { optDoc = "The output .e.ps file" }
6767
68+tco :: Term Bool
69+tco = value $ flag $ (optInfo [ "tco" ])
70+ { optDoc = "Perform tail call optimizations" }
71+
72+performRuntimeTypeChecks :: Term Bool
73+performRuntimeTypeChecks = value $ flag $ (optInfo [ "runtime-type-checks" ])
74+ { optDoc = "Generate runtime type checks" }
75+
76+options :: Term P.Options
77+options = P.Options <$> tco <*> performRuntimeTypeChecks
78+
6879stdInOrInputFiles :: Term (Maybe [FilePath])
6980stdInOrInputFiles = combine <$> useStdIn <*> inputFiles
7081 where
@@ -72,7 +83,7 @@ stdInOrInputFiles = combine <$> useStdIn <*> inputFiles
7283 combine True _ = Nothing
7384
7485term :: Term (IO ())
75−term = compile <$> stdInOrInputFiles <*> outputFile <*> externsFile
86+term = compile <$> options <*> stdInOrInputFiles <*> outputFile <*> externsFile
7687
7788termInfo :: TermInfo
7889termInfo = defTI
tests/Main.hs+1−1
@@ -32,7 +32,7 @@ compile inputFile = do
3232 Left parseError -> do
3333 return (Left $ show parseError)
3434 Right ms -> do
35− case P.compile ms of
35+ case P.compile P.defaultOptions ms of
3636 Left typeError -> do
3737 return (Left typeError)
3838 Right (_, _, env) -> do