summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-01-10 04:02:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-01-10 04:02:00 (GMT)
commit5bf0423ba6bf0b30eb0891ea9bcf37706b1af380 (patch)
treed9bfea0b601e6c7e825be96c629faa57c6012005
parent19b538d42bd5af7f8d4979b752ce3101da19740d (diff)
version 0.2.90.2.9
-rw-r--r--purescript.cabal15
-rw-r--r--src/Language/PureScript.hs7
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs120
-rw-r--r--src/Language/PureScript/CodeGen/JS/AST.hs6
-rw-r--r--src/Language/PureScript/Optimize.hs95
-rw-r--r--src/Language/PureScript/Options.hs23
-rw-r--r--src/Language/PureScript/Pretty/JS.hs13
-rw-r--r--src/Main.hs19
-rw-r--r--tests/Main.hs2
9 files changed, 237 insertions, 63 deletions
diff --git a/purescript.cabal b/purescript.cabal
index 7c2327c..88a3f88 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.2.7
+version: 0.2.9
cabal-version: >=1.8
build-type: Simple
license: MIT
@@ -17,9 +17,10 @@ library
build-depends: base >=4 && <5, cmdtheline -any, containers -any,
directory -any, filepath -any, mtl -any, parsec -any, syb -any,
transformers -any, utf8-string -any
- exposed-modules: Data.Generics.Extras Language.PureScript
- Language.PureScript.CodeGen Language.PureScript.CodeGen.Externs
- Language.PureScript.CodeGen.JS Language.PureScript.CodeGen.JS.AST
+ exposed-modules: Language.PureScript.Options Data.Generics.Extras
+ Language.PureScript Language.PureScript.CodeGen
+ Language.PureScript.CodeGen.Externs Language.PureScript.CodeGen.JS
+ Language.PureScript.CodeGen.JS.AST
Language.PureScript.CodeGen.Monad Language.PureScript.Declarations
Language.PureScript.Kinds Language.PureScript.Names
Language.PureScript.Operators Language.PureScript.Optimize
@@ -36,11 +37,9 @@ library
Language.PureScript.TypeChecker.Synonyms
Language.PureScript.TypeChecker.Types Language.PureScript.Types
Language.PureScript.Unknown Language.PureScript.Values Main
- Language.PureScript.CaseDeclarations
- Language.PureScript.DoNotation
+ Language.PureScript.CaseDeclarations Language.PureScript.DoNotation
Language.PureScript.TypeDeclarations
- Language.PureScript.BindingGroups
- Language.PureScript.Scope
+ Language.PureScript.BindingGroups Language.PureScript.Scope
exposed: True
buildable: True
hs-source-dirs: src
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index 67fa706..bea407a 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -29,12 +29,13 @@ import Language.PureScript.CaseDeclarations as P
import Language.PureScript.TypeDeclarations as P
import Language.PureScript.BindingGroups as P
import Language.PureScript.DoNotation as P
+import Language.PureScript.Options as P
import Data.List (intercalate)
import Control.Monad (forM_, (>=>))
-compile :: [Module] -> Either String (String, String, Environment)
-compile ms = do
+compile :: Options -> [Module] -> Either String (String, String, Environment)
+compile opts ms = do
bracketted <- rebracket ms
desugared <- desugarDo
>=> desugarCasesModule
@@ -42,6 +43,6 @@ compile ms = do
>=> (return . createBindingGroupsModule)
$ bracketted
(_, env) <- runCheck $ forM_ desugared $ \(Module moduleName decls) -> typeCheckAll (ModuleName moduleName) decls
- let js = prettyPrintJS . map optimize . concatMap (flip moduleToJs env) $ desugared
+ let js = prettyPrintJS . map (optimize opts) . concatMap (flip (moduleToJs opts) env) $ desugared
let exts = intercalate "\n" . map (flip moduleToPs env) $ desugared
return (js, exts, env)
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 596e2b8..d9426b0 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -30,31 +30,33 @@ import Language.PureScript.Scope
import Language.PureScript.Declarations
import Language.PureScript.Pretty.Common
import Language.PureScript.CodeGen.Monad
+import Language.PureScript.Options
import Language.PureScript.CodeGen.JS.AST as AST
import Language.PureScript.TypeChecker.Monad (NameKind(..))
+import Language.PureScript.Types
-moduleToJs :: Module -> Environment -> [JS]
-moduleToJs (Module pname@(ProperName name) decls) env =
+moduleToJs :: Options -> Module -> Environment -> [JS]
+moduleToJs opts (Module pname@(ProperName name) decls) env =
[ JSVariableIntroduction (Ident name) Nothing
, JSApp (JSFunction Nothing [Ident name]
- (JSBlock (concat $ mapMaybe (\decl -> declToJs (ModuleName pname) decl env) decls)))
+ (JSBlock (concat $ mapMaybe (\decl -> declToJs opts (ModuleName pname) decl env) decls)))
[JSAssignment (JSAssignVariable (Ident name))
(JSBinary Or (JSVar (Ident name)) (JSObjectLiteral []))]
]
-declToJs :: ModuleName -> Declaration -> Environment -> Maybe [JS]
-declToJs mp (ValueDeclaration ident _ _ val) e =
- Just [ JSVariableIntroduction ident (Just (valueToJs mp e val)),
+declToJs :: Options -> ModuleName -> Declaration -> Environment -> Maybe [JS]
+declToJs opts mp (ValueDeclaration ident _ _ val) e =
+ Just [ JSVariableIntroduction ident (Just (valueToJs opts mp e val)),
setProperty (identToJs ident) (JSVar ident) mp ]
-declToJs mp (BindingGroupDeclaration vals) e =
+declToJs opts mp (BindingGroupDeclaration vals) e =
Just $ concatMap (\(ident, val) ->
- [ JSVariableIntroduction ident (Just (valueToJs mp e val)),
+ [ JSVariableIntroduction ident (Just (valueToJs opts mp e val)),
setProperty (identToJs ident) (JSVar ident) mp ]
) vals
-declToJs mp (ExternMemberDeclaration member ident _) _ =
+declToJs _ mp (ExternMemberDeclaration member ident _) _ =
Just [ JSFunction (Just ident) [Ident "value"] (JSBlock [JSReturn (JSAccessor member (JSVar (Ident "value")))]),
setProperty (show ident) (JSVar ident) mp ]
-declToJs mp (DataDeclaration _ _ ctors) _ =
+declToJs _ mp (DataDeclaration _ _ ctors) _ =
Just $ flip concatMap ctors $ \(pn@(ProperName ctor), maybeTy) ->
let
ctorJs =
@@ -65,31 +67,61 @@ declToJs mp (DataDeclaration _ _ ctors) _ =
(JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn)))
, ("value", JSVar (Ident "value")) ])])
in [ ctorJs, setProperty ctor (JSVar (Ident ctor)) mp ]
-declToJs _ _ _ = Nothing
+declToJs _ _ _ _ = Nothing
setProperty :: String -> JS -> ModuleName -> JS
setProperty prop val (ModuleName (ProperName moduleName)) = JSAssignment (JSAssignProperty prop (JSAssignVariable (Ident moduleName))) val
-valueToJs :: ModuleName -> Environment -> Value -> JS
-valueToJs _ _ (NumericLiteral n) = JSNumericLiteral n
-valueToJs _ _ (StringLiteral s) = JSStringLiteral s
-valueToJs _ _ (BooleanLiteral b) = JSBooleanLiteral b
-valueToJs m e (ArrayLiteral xs) = JSArrayLiteral (map (valueToJs m e) xs)
-valueToJs m e (ObjectLiteral ps) = JSObjectLiteral (map (second (valueToJs m e)) ps)
-valueToJs m e (ObjectUpdate o ps) = JSApp (JSAccessor "extend" (JSVar (Ident "Object"))) [ valueToJs m e o, JSObjectLiteral (map (second (valueToJs m e)) ps)]
-valueToJs _ _ (Constructor name) = qualifiedToJS runProperName name
-valueToJs m e (Block sts) = JSApp (JSFunction Nothing [] (JSBlock (map (statementToJs m e) sts))) []
-valueToJs m e (Case values binders) = runGen (bindersToJs m e binders (map (valueToJs m e) values))
-valueToJs m e (IfThenElse cond th el) = JSConditional (valueToJs m e cond) (valueToJs m e th) (valueToJs m e el)
-valueToJs m e (Accessor prop val) = JSAccessor prop (valueToJs m e val)
-valueToJs m e (Indexer index val) = JSIndexer (valueToJs m e index) (valueToJs m e val)
-valueToJs m e (App val args) = JSApp (valueToJs m e val) (map (valueToJs m e) args)
-valueToJs m e (Abs args val) = JSFunction Nothing args (JSBlock [JSReturn (valueToJs m e val)])
-valueToJs m e (Unary op val) = JSUnary op (valueToJs m e val)
-valueToJs m e (Binary op v1 v2) = JSBinary op (valueToJs m e v1) (valueToJs m e v2)
-valueToJs m e (Var ident) = varToJs m e ident
-valueToJs m e (TypedValue val _) = valueToJs m e val
-valueToJs _ _ _ = error "Invalid argument to valueToJs"
+valueToJs :: Options -> ModuleName -> Environment -> Value -> JS
+valueToJs _ _ _ (NumericLiteral n) = JSNumericLiteral n
+valueToJs _ _ _ (StringLiteral s) = JSStringLiteral s
+valueToJs _ _ _ (BooleanLiteral b) = JSBooleanLiteral b
+valueToJs opts m e (ArrayLiteral xs) = JSArrayLiteral (map (valueToJs opts m e) xs)
+valueToJs opts m e (ObjectLiteral ps) = JSObjectLiteral (map (second (valueToJs opts m e)) ps)
+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)]
+valueToJs _ _ _ (Constructor name) = qualifiedToJS runProperName name
+valueToJs opts m e (Block sts) = JSApp (JSFunction Nothing [] (JSBlock (map (statementToJs opts m e) sts))) []
+valueToJs opts m e (Case values binders) = runGen (bindersToJs opts m e binders (map (valueToJs opts m e) values))
+valueToJs opts m e (IfThenElse cond th el) = JSConditional (valueToJs opts m e cond) (valueToJs opts m e th) (valueToJs opts m e el)
+valueToJs opts m e (Accessor prop val) = JSAccessor prop (valueToJs opts m e val)
+valueToJs opts m e (Indexer index val) = JSIndexer (valueToJs opts m e index) (valueToJs opts m e val)
+valueToJs opts m e (App val args) = JSApp (valueToJs opts m e val) (map (valueToJs opts m e) args)
+valueToJs opts m e (Abs args val) = JSFunction Nothing args (JSBlock [JSReturn (valueToJs opts m e val)])
+valueToJs opts m e (TypedValue (Abs args val) ty) | optionsPerformRuntimeTypeChecks opts = JSFunction Nothing args (JSBlock $ runtimeTypeChecks args ty ++ [JSReturn (valueToJs opts m e val)])
+valueToJs opts m e (Unary op val) = JSUnary op (valueToJs opts m e val)
+valueToJs opts m e (Binary op v1 v2) = JSBinary op (valueToJs opts m e v1) (valueToJs opts m e v2)
+valueToJs _ m e (Var ident) = varToJs m e ident
+valueToJs opts m e (TypedValue val _) = valueToJs opts m e val
+valueToJs _ _ _ _ = error "Invalid argument to valueToJs"
+
+runtimeTypeChecks :: [Ident] -> Type -> [JS]
+runtimeTypeChecks args ty =
+ let
+ argTys = getFunctionArgumentTypes ty
+ in
+ concat $ zipWith argumentCheck (map JSVar args) argTys
+ where
+ getFunctionArgumentTypes :: Type -> [Type]
+ getFunctionArgumentTypes (Function funArgs _) = funArgs
+ getFunctionArgumentTypes (ForAll _ ty') = getFunctionArgumentTypes ty'
+ getFunctionArgumentTypes _ = []
+ argumentCheck :: JS -> Type -> [JS]
+ argumentCheck val Number = [typeCheck val "number"]
+ argumentCheck val String = [typeCheck val "string"]
+ argumentCheck val Boolean = [typeCheck val "boolean"]
+ argumentCheck val (Array _) = [arrayCheck val]
+ argumentCheck val (Object row) =
+ let
+ (pairs, _) = rowToList row
+ in
+ typeCheck val "object" : concatMap (\(prop, ty') -> argumentCheck (JSAccessor prop val) ty') pairs
+ argumentCheck val (Function _ _) = [typeCheck val "function"]
+ argumentCheck val (ForAll _ ty') = argumentCheck val ty'
+ argumentCheck _ _ = []
+ typeCheck :: JS -> String -> JS
+ typeCheck js ty' = JSIfElse (JSBinary NotEqualTo (JSTypeOf js) (JSStringLiteral ty')) (JSBlock [JSThrow (JSStringLiteral $ ty' ++ " expected")]) Nothing
+ arrayCheck :: JS -> JS
+ arrayCheck js = JSIfElse (JSUnary Not (JSApp (JSAccessor "isArray" (JSVar (Ident "Array"))) [js])) (JSBlock [JSThrow (JSStringLiteral "Array expected")]) Nothing
varToJs :: ModuleName -> Environment -> Qualified Ident -> JS
varToJs m e qual@(Qualified _ ident) = case M.lookup (qualify m qual) (names e) of
@@ -107,17 +139,17 @@ qualifiedToJS :: (a -> String) -> Qualified a -> JS
qualifiedToJS f (Qualified (Just (ModuleName (ProperName m))) a) = JSAccessor (f a) (JSVar (Ident m))
qualifiedToJS f (Qualified Nothing a) = JSVar (Ident (f a))
-bindersToJs :: ModuleName -> Environment -> [([Binder], Maybe Guard, Value)] -> [JS] -> Gen JS
-bindersToJs m e binders vals = do
+bindersToJs :: Options -> ModuleName -> Environment -> [([Binder], Maybe Guard, Value)] -> [JS] -> Gen JS
+bindersToJs opts m e binders vals = do
setNextName $ firstUnusedName (binders, vals)
valNames <- replicateM (length vals) fresh
- jss <- forM binders $ \(bs, grd, result) -> go valNames [JSReturn (valueToJs m e result)] bs grd
+ jss <- forM binders $ \(bs, grd, result) -> go valNames [JSReturn (valueToJs opts m e result)] bs grd
return $ JSApp (JSFunction Nothing (map Ident valNames) (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))
vals
where
go :: [String] -> [JS] -> [Binder] -> Maybe Guard -> Gen [JS]
go _ done [] Nothing = return done
- go _ done [] (Just cond) = return [JSIfElse (valueToJs m e cond) (JSBlock done) Nothing]
+ go _ done [] (Just cond) = return [JSIfElse (valueToJs opts m e cond) (JSBlock done) Nothing]
go (v:vs) done' (b:bs) grd = do
done'' <- go vs done' bs grd
binderToJs m e v done'' b
@@ -175,16 +207,16 @@ binderToJs m e varName done (NamedBinder ident binder) = do
js <- binderToJs m e varName done binder
return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : js)
-statementToJs :: ModuleName -> Environment -> Statement -> JS
-statementToJs m e (VariableIntroduction ident value) = JSVariableIntroduction ident (Just (valueToJs m e value))
-statementToJs m e (Assignment target value) = JSAssignment (JSAssignVariable target) (valueToJs m e value)
-statementToJs m e (While cond sts) = JSWhile (valueToJs m e cond) (JSBlock (map (statementToJs m e) sts))
-statementToJs m e (For ident start end sts) = JSFor ident (valueToJs m e start) (valueToJs m e end) (JSBlock (map (statementToJs m e) sts))
-statementToJs m e (If ifst) = ifToJs ifst
+statementToJs :: Options -> ModuleName -> Environment -> Statement -> JS
+statementToJs opts m e (VariableIntroduction ident value) = JSVariableIntroduction ident (Just (valueToJs opts m e value))
+statementToJs opts m e (Assignment target value) = JSAssignment (JSAssignVariable target) (valueToJs opts m e value)
+statementToJs opts m e (While cond sts) = JSWhile (valueToJs opts m e cond) (JSBlock (map (statementToJs opts m e) sts))
+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))
+statementToJs opts m e (If ifst) = ifToJs ifst
where
ifToJs :: IfStatement -> JS
- ifToJs (IfStatement cond thens elses) = JSIfElse (valueToJs m e cond) (JSBlock (map (statementToJs m e) thens)) (fmap elseToJs elses)
+ ifToJs (IfStatement cond thens elses) = JSIfElse (valueToJs opts m e cond) (JSBlock (map (statementToJs opts m e) thens)) (fmap elseToJs elses)
elseToJs :: ElseStatement -> JS
- elseToJs (Else sts) = JSBlock (map (statementToJs m e) sts)
+ elseToJs (Else sts) = JSBlock (map (statementToJs opts m e) sts)
elseToJs (ElseIf elif) = ifToJs elif
-statementToJs m e (Return value) = JSReturn (valueToJs m e value)
+statementToJs opts m e (Return value) = JSReturn (valueToJs opts m e value)
diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs
index ee8ad50..0a239d5 100644
--- a/src/Language/PureScript/CodeGen/JS/AST.hs
+++ b/src/Language/PureScript/CodeGen/JS/AST.hs
@@ -42,7 +42,11 @@ data JS
| JSFor Ident JS JS JS
| JSIfElse JS JS (Maybe JS)
| JSReturn JS
- | JSThrow JS deriving (Show, Data, Typeable)
+ | JSThrow JS
+ | JSTypeOf JS
+ | JSLabel String JS
+ | JSBreak String
+ | JSContinue String deriving (Show, Data, Typeable)
data JSAssignment
= JSAssignVariable Ident
diff --git a/src/Language/PureScript/Optimize.hs b/src/Language/PureScript/Optimize.hs
index b9e2790..366fd67 100644
--- a/src/Language/PureScript/Optimize.hs
+++ b/src/Language/PureScript/Optimize.hs
@@ -22,9 +22,16 @@ import Data.Generics
import Language.PureScript.Names
import Language.PureScript.CodeGen.JS.AST
+import Language.PureScript.Options
-optimize :: JS -> JS
-optimize = removeUnusedVariables . unThunk . etaConvert . inlineVariables
+optimize :: Options -> JS -> JS
+optimize opts =
+ collapseNestedBlocks
+ . tco opts
+ . removeUnusedVariables
+ . unThunk
+ . etaConvert
+ . inlineVariables
replaceIdent :: (Data d) => Ident -> JS -> d -> d
replaceIdent var1 js = everywhere (mkT replace)
@@ -101,3 +108,87 @@ unThunk = everywhere (mkT convert)
convert :: JS -> JS
convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) [])]) = JSBlock body
convert js = js
+
+tco :: Options -> JS -> JS
+tco opts | optionsTco opts = tco'
+ | otherwise = id
+
+tco' :: JS -> JS
+tco' = everywhere (mkT convert)
+ where
+ tcoLabel :: String
+ tcoLabel = "tco"
+ tcoVar :: Ident -> Ident
+ tcoVar (Ident arg) = Ident $ "__tco_" ++ arg
+ tcoVar _ = error "Invalid name in tcoVar"
+ convert :: JS -> JS
+ convert js@(JSVariableIntroduction name (Just fn@(JSFunction Nothing _ _))) =
+ let
+ (argss, body', replace) = collectAllFunctionArgs [] id fn
+ in case () of
+ _ | isTailCall name body' ->
+ let
+ allArgs = reverse $ concat argss
+ in
+ JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))
+ | otherwise -> js
+ convert js = js
+ collectAllFunctionArgs :: [[Ident]] -> (JS -> JS) -> JS -> ([[Ident]], JS, JS -> JS)
+ collectAllFunctionArgs allArgs f (JSFunction Nothing args (JSBlock (body@(JSReturn _):_))) =
+ collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction Nothing args (JSBlock [b]))) body
+ collectAllFunctionArgs allArgs f (JSReturn (JSFunction Nothing args (JSBlock [body]))) =
+ collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction Nothing args (JSBlock [b])))) body
+ collectAllFunctionArgs allArgs f (JSReturn (JSFunction Nothing args body@(JSBlock _))) =
+ (args : allArgs, body, \b -> f (JSReturn (JSFunction Nothing args b)))
+ collectAllFunctionArgs allArgs f body = (allArgs, body, f)
+ isTailCall :: Ident -> JS -> Bool
+ isTailCall ident js =
+ let
+ numSelfCalls = everything (+) (mkQ 0 countSelfCalls) js
+ numSelfCallsInTailPosition = everything (+) (mkQ 0 countSelfCallsInTailPosition) js
+ numSelfCallsUnderFunctions = everything (+) (mkQ 0 countSelfCallsUnderFunctions) js
+ in
+ numSelfCalls > 0
+ && numSelfCalls == numSelfCallsInTailPosition
+ && numSelfCallsUnderFunctions == 0
+ where
+ countSelfCalls :: JS -> Int
+ countSelfCalls (JSApp (JSVar ident') _) | ident == ident' = 1
+ countSelfCalls _ = 0
+ countSelfCallsInTailPosition :: JS -> Int
+ countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1
+ countSelfCallsInTailPosition _ = 0
+ countSelfCallsUnderFunctions (JSFunction _ _ js') = everything (+) (mkQ 0 countSelfCalls) js'
+ countSelfCallsUnderFunctions _ = 0
+ toLoop :: Ident -> [Ident] -> JS -> JS
+ toLoop ident allArgs js = JSBlock
+ [ JSLabel tcoLabel $ JSWhile (JSBooleanLiteral True) (JSBlock [ everywhere (mkT loopify) js ]) ]
+ where
+ loopify :: JS -> JS
+ loopify (JSReturn ret) | isSelfCall ident ret =
+ let
+ allArgumentValues = concat $ collectSelfCallArgs [] ret
+ in
+ JSBlock $ zipWith (\val arg ->
+ JSVariableIntroduction (tcoVar arg) (Just val)) allArgumentValues allArgs
+ ++ map (\arg ->
+ JSAssignment (JSAssignVariable arg) (JSVar (tcoVar arg))) allArgs
+ ++ [ JSContinue tcoLabel ]
+ loopify other = other
+ collectSelfCallArgs :: [[JS]] -> JS -> [[JS]]
+ collectSelfCallArgs allArgumentValues (JSApp fn args') = collectSelfCallArgs (args' : allArgumentValues) fn
+ collectSelfCallArgs allArgumentValues _ = allArgumentValues
+ isSelfCall :: Ident -> JS -> Bool
+ isSelfCall ident (JSApp (JSVar ident') _) | ident == ident' = True
+ isSelfCall ident (JSApp fn _) = isSelfCall ident fn
+ isSelfCall _ _ = False
+
+collapseNestedBlocks :: JS -> JS
+collapseNestedBlocks = everywhere (mkT collapse)
+ where
+ collapse :: JS -> JS
+ collapse (JSBlock sts) = JSBlock (concatMap go sts)
+ collapse js = js
+ go :: JS -> [JS]
+ go (JSBlock sts) = sts
+ go s = [s]
diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs
new file mode 100644
index 0000000..778e3e1
--- /dev/null
+++ b/src/Language/PureScript/Options.hs
@@ -0,0 +1,23 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Options
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module Language.PureScript.Options where
+
+data Options = Options
+ { optionsTco :: Bool
+ , optionsPerformRuntimeTypeChecks :: Bool
+ } deriving Show
+
+defaultOptions :: Options
+defaultOptions = Options False False
diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs
index 1f07652..7a3c933 100644
--- a/src/Language/PureScript/Pretty/JS.hs
+++ b/src/Language/PureScript/Pretty/JS.hs
@@ -118,6 +118,12 @@ literals = mkPattern' match
[ return "throw "
, prettyPrintJS' value
]
+ match (JSBreak lbl) = return $ "break " ++ lbl
+ match (JSContinue lbl) = return $ "continue " ++ lbl
+ match (JSLabel lbl js) = fmap concat $ sequence
+ [ return $ lbl ++ ": "
+ , prettyPrintJS' js
+ ]
match _ = mzero
targetToJs :: JSAssignment -> String
@@ -156,6 +162,12 @@ app = mkPattern' match
return (intercalate ", " jss, val)
match _ = mzero
+typeOf :: Pattern PrinterState JS ((), JS)
+typeOf = mkPattern match
+ where
+ match (JSTypeOf val) = Just ((), val)
+ match _ = Nothing
+
unary :: UnaryOperator -> String -> Operator PrinterState JS String
unary op str = Wrap match (++)
where
@@ -202,6 +214,7 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue
, [ binary LessThanOrEqualTo "<=" ]
, [ binary GreaterThan ">" ]
, [ binary GreaterThanOrEqualTo ">=" ]
+ , [ Wrap typeOf $ \_ s -> "typeof " ++ s ]
, [ unary Not "!" ]
, [ unary BitwiseNot "~" ]
, [ unary Negate "-" ]
diff --git a/src/Main.hs b/src/Main.hs
index 13bcee5..f6e4e29 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -28,15 +28,15 @@ readInput (Just input) = fmap (fmap concat . sequence) $ forM input $ \inputFile
text <- U.readFile inputFile
return $ P.runIndentParser P.parseModules text
-compile :: Maybe [FilePath] -> Maybe FilePath -> Maybe FilePath -> IO ()
-compile input output externs = do
+compile :: P.Options -> Maybe [FilePath] -> Maybe FilePath -> Maybe FilePath -> IO ()
+compile opts input output externs = do
modules <- readInput input
case modules of
Left err -> do
U.print err
exitFailure
Right ms ->
- case P.compile ms of
+ case P.compile opts ms of
Left err -> do
U.putStrLn err
exitFailure
@@ -65,6 +65,17 @@ externsFile :: Term (Maybe FilePath)
externsFile = value $ opt Nothing $ (optInfo [ "e", "externs" ])
{ optDoc = "The output .e.ps file" }
+tco :: Term Bool
+tco = value $ flag $ (optInfo [ "tco" ])
+ { optDoc = "Perform tail call optimizations" }
+
+performRuntimeTypeChecks :: Term Bool
+performRuntimeTypeChecks = value $ flag $ (optInfo [ "runtime-type-checks" ])
+ { optDoc = "Generate runtime type checks" }
+
+options :: Term P.Options
+options = P.Options <$> tco <*> performRuntimeTypeChecks
+
stdInOrInputFiles :: Term (Maybe [FilePath])
stdInOrInputFiles = combine <$> useStdIn <*> inputFiles
where
@@ -72,7 +83,7 @@ stdInOrInputFiles = combine <$> useStdIn <*> inputFiles
combine True _ = Nothing
term :: Term (IO ())
-term = compile <$> stdInOrInputFiles <*> outputFile <*> externsFile
+term = compile <$> options <*> stdInOrInputFiles <*> outputFile <*> externsFile
termInfo :: TermInfo
termInfo = defTI
diff --git a/tests/Main.hs b/tests/Main.hs
index e165933..d008b74 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -32,7 +32,7 @@ compile inputFile = do
Left parseError -> do
return (Left $ show parseError)
Right ms -> do
- case P.compile ms of
+ case P.compile P.defaultOptions ms of
Left typeError -> do
return (Left typeError)
Right (_, _, env) -> do