summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-01-11 21:27:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-01-11 21:27:00 (GMT)
commit5f54395c85ed2f8bc3d3f5d04021a94f37c4a385 (patch)
treefea5bca0d6d35346537c12894ab5e7763a95b809
parentc0ea5d653b03b2cb45ecb3eeae60899e51847d41 (diff)
version 0.2.130.2.13
-rw-r--r--purescript.cabal2
-rw-r--r--src/Language/PureScript.hs13
-rw-r--r--src/Language/PureScript/CodeGen/Optimize.hs40
-rw-r--r--src/Language/PureScript/Options.hs4
-rw-r--r--src/Main.hs10
5 files changed, 56 insertions, 13 deletions
diff --git a/purescript.cabal b/purescript.cabal
index dc868db..df2621a 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.2.11.1
+version: 0.2.13
cabal-version: >=1.8
build-type: Simple
license: MIT
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index a104c02..f5994f5 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -27,12 +27,19 @@ import Language.PureScript.Sugar as P
import Language.PureScript.Options as P
import Data.List (intercalate)
-import Control.Monad (forM_)
+import Control.Monad (when, forM_)
+import qualified Data.Map as M
compile :: Options -> [Module] -> Either String (String, String, Environment)
compile opts ms = do
desugared <- desugar ms
(_, env) <- runCheck $ forM_ desugared $ \(Module moduleName decls) -> typeCheckAll (ModuleName moduleName) decls
- let js = prettyPrintJS . concatMap (flip (moduleToJs opts) env) $ desugared
+ let js = concatMap (flip (moduleToJs opts) env) $ desugared
let exts = intercalate "\n" . map (flip moduleToPs env) $ desugared
- return (js, exts, env)
+ js' <- case () of
+ _ | optionsRunMain opts -> do
+ when ((ModuleName (ProperName "Main"), Ident "main") `M.notMember` (names env)) $
+ Left "Main.main is undefined"
+ return $ js ++ [JSApp (JSAccessor "main" (JSVar (Ident "Main"))) []]
+ | otherwise -> return js
+ return (prettyPrintJS js', exts, env)
diff --git a/src/Language/PureScript/CodeGen/Optimize.hs b/src/Language/PureScript/CodeGen/Optimize.hs
index cf35150..0b336bb 100644
--- a/src/Language/PureScript/CodeGen/Optimize.hs
+++ b/src/Language/PureScript/CodeGen/Optimize.hs
@@ -28,6 +28,7 @@ optimize :: Options -> JS -> JS
optimize opts =
collapseNestedBlocks
. tco opts
+ . magicDo opts
. removeUnusedVariables
. unThunk
. etaConvert
@@ -133,7 +134,7 @@ tco' = everywhere (mkT convert)
copyVar (Ident arg) = Ident $ "__copy_" ++ arg
copyVar _ = error "Invalid name in copyVar"
convert :: JS -> JS
- convert js@(JSVariableIntroduction name (Just fn@(JSFunction Nothing _ _))) =
+ convert js@(JSVariableIntroduction name (Just fn@(JSFunction _ _ _))) =
let
(argss, body', replace) = collectAllFunctionArgs [] id fn
in case () of
@@ -145,12 +146,14 @@ tco' = everywhere (mkT convert)
| 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 (map copyVar args) (JSBlock [b]))) body
- collectAllFunctionArgs allArgs f (JSReturn (JSFunction Nothing args (JSBlock [body]))) =
- collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction Nothing (map copyVar args) (JSBlock [b])))) body
- collectAllFunctionArgs allArgs f (JSReturn (JSFunction Nothing args body@(JSBlock _))) =
- (args : allArgs, body, \b -> f (JSReturn (JSFunction Nothing (map copyVar args) b)))
+ collectAllFunctionArgs allArgs f (JSFunction ident args (JSBlock (body@(JSReturn _):_))) =
+ collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction ident (map copyVar args) (JSBlock [b]))) body
+ collectAllFunctionArgs allArgs f (JSFunction ident args body@(JSBlock _)) =
+ (args : allArgs, body, \b -> f (JSFunction ident (map copyVar args) b))
+ collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args (JSBlock [body]))) =
+ collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction ident (map copyVar args) (JSBlock [b])))) body
+ collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args body@(JSBlock _))) =
+ (args : allArgs, body, \b -> f (JSReturn (JSFunction ident (map copyVar args) b)))
collectAllFunctionArgs allArgs f body = (allArgs, body, f)
isTailCall :: Ident -> JS -> Bool
isTailCall ident js =
@@ -195,6 +198,29 @@ tco' = everywhere (mkT convert)
isSelfCall ident (JSApp fn _) = isSelfCall ident fn
isSelfCall _ _ = False
+magicDo :: Options -> JS -> JS
+magicDo opts | optionsMagicDo opts = magicDo'
+ | otherwise = id
+
+magicDo' :: JS -> JS
+magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
+ where
+ fnName = Ident "__do"
+ convert :: JS -> JS
+ convert (JSApp (JSApp ret [val]) []) | isReturn ret = val
+ convert (JSApp (JSApp bind [m]) [JSFunction Nothing [Ident "_"] (JSBlock [JSReturn ret])]) | isBind bind =
+ JSFunction (Just fnName) [] $ JSBlock [ JSApp m [], JSReturn (JSApp ret []) ]
+ convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock [JSReturn ret])]) | isBind bind =
+ JSFunction (Just fnName) [] $ JSBlock [ JSVariableIntroduction arg (Just (JSApp m [])), JSReturn (JSApp ret []) ]
+ convert other = other
+ isBind (JSAccessor "bind" (JSAccessor "eff" (JSVar (Ident "Eff")))) = True
+ isBind _ = False
+ isReturn (JSAccessor "ret" (JSAccessor "eff" (JSVar (Ident "Eff")))) = True
+ isReturn _ = False
+ undo :: JS -> JS
+ undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body
+ undo other = other
+
collapseNestedBlocks :: JS -> JS
collapseNestedBlocks = everywhere (mkT collapse)
where
diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs
index 778e3e1..2065656 100644
--- a/src/Language/PureScript/Options.hs
+++ b/src/Language/PureScript/Options.hs
@@ -17,7 +17,9 @@ module Language.PureScript.Options where
data Options = Options
{ optionsTco :: Bool
, optionsPerformRuntimeTypeChecks :: Bool
+ , optionsMagicDo :: Bool
+ , optionsRunMain :: Bool
} deriving Show
defaultOptions :: Options
-defaultOptions = Options False False
+defaultOptions = Options False False False False
diff --git a/src/Main.hs b/src/Main.hs
index 1505683..8ce229a 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -82,8 +82,16 @@ noPrelude :: Term Bool
noPrelude = value $ flag $ (optInfo [ "no-prelude" ])
{ optDoc = "Omit the Prelude" }
+magicDo :: Term Bool
+magicDo = value $ flag $ (optInfo [ "magic-do" ])
+ { optDoc = "Overload the do keyword to generate efficient code specifically for the Eff monad." }
+
+runMain :: Term Bool
+runMain = value $ flag $ (optInfo [ "run-main" ])
+ { optDoc = "Generate code to run the main method in the Main module." }
+
options :: Term P.Options
-options = P.Options <$> tco <*> performRuntimeTypeChecks
+options = P.Options <$> tco <*> performRuntimeTypeChecks <*> magicDo <*> runMain
stdInOrInputFiles :: FilePath -> Term (Maybe [FilePath])
stdInOrInputFiles prelude = combine <$> useStdIn <*> (not <$> noPrelude) <*> inputFiles