purescript 0.2.11.1 → 0.2.13

raw patch · 5 files changed

+56/−13 lines, 5 files

Files

• purescript.cabal +1/−1
• src/Language/PureScript.hs +10/−3
• src/Language/PureScript/CodeGen/Optimize.hs +33/−7
• src/Language/PureScript/Options.hs +3/−1
• src/Main.hs +9/−1

@@ -1,5 +1,5 @@ name: purescript-version: 0.2.11.1+version: 0.2.13 cabal-version: >=1.8 build-type: Simple license: MIT

@@ -27,12 +27,19 @@ 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)

@@ -28,6 +28,7 @@ optimize opts =   collapseNestedBlocks   . tco opts+  . magicDo opts   . removeUnusedVariables   . unThunk   . etaConvert@@ -133,7 +134,7 @@   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 @@         | 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 =@@ -194,6 +197,29 @@   isSelfCall ident (JSApp (JSVar ident') _) | ident == ident' = True   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)

@@ -17,7 +17,9 @@ 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

@@ -82,8 +82,16 @@ 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