packages feed

purescript 0.2.9.1 → 0.2.9.2

raw patch · 6 files changed

+250/−219 lines, 6 files

Files

purescript.cabal view
@@ -1,5 +1,5 @@ name: purescript-version: 0.2.9.1+version: 0.2.9.2 cabal-version: >=1.8 build-type: Simple license: MIT@@ -17,29 +17,45 @@     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: Language.PureScript.Options Data.Generics.Extras-                     Language.PureScript Language.PureScript.CodeGen-                     Language.PureScript.CodeGen.Externs Language.PureScript.CodeGen.JS+    exposed-modules: Data.Generics.Extras+                     Language.PureScript.Options+                     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-                     Language.PureScript.Parser Language.PureScript.Parser.Common+                     Language.PureScript.CodeGen.Monad+                     Language.PureScript.CodeGen.Optimize+                     Language.PureScript.Declarations+                     Language.PureScript.Kinds+                     Language.PureScript.Names+                     Language.PureScript.Operators+                     Language.PureScript.Parser+                     Language.PureScript.Parser.Common                      Language.PureScript.Parser.Declarations-                     Language.PureScript.Parser.Kinds Language.PureScript.Parser.State-                     Language.PureScript.Parser.Types Language.PureScript.Parser.Values-                     Language.PureScript.Pretty Language.PureScript.Pretty.Common-                     Language.PureScript.Pretty.JS Language.PureScript.Pretty.Kinds-                     Language.PureScript.Pretty.Types Language.PureScript.Pretty.Values+                     Language.PureScript.Parser.Kinds+                     Language.PureScript.Parser.State+                     Language.PureScript.Parser.Types+                     Language.PureScript.Parser.Values+                     Language.PureScript.Pretty+                     Language.PureScript.Pretty.Common+                     Language.PureScript.Pretty.JS+                     Language.PureScript.Pretty.Kinds+                     Language.PureScript.Pretty.Types+                     Language.PureScript.Pretty.Values                      Language.PureScript.TypeChecker                      Language.PureScript.TypeChecker.Kinds                      Language.PureScript.TypeChecker.Monad                      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.TypeChecker.Types+                     Language.PureScript.Types+                     Language.PureScript.Unknown+                     Language.PureScript.Values+                     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
src/Language/PureScript.hs view
@@ -23,7 +23,6 @@ import Language.PureScript.CodeGen as P import Language.PureScript.TypeChecker as P import Language.PureScript.Pretty as P-import Language.PureScript.Optimize as P import Language.PureScript.Operators as P import Language.PureScript.CaseDeclarations as P import Language.PureScript.TypeDeclarations as P
src/Language/PureScript/CodeGen.hs view
@@ -16,3 +16,4 @@  import Language.PureScript.CodeGen.JS as C import Language.PureScript.CodeGen.Externs as C+import Language.PureScript.CodeGen.Optimize as C
src/Language/PureScript/CodeGen/JS.hs view
@@ -53,9 +53,24 @@            [ JSVariableIntroduction ident (Just (valueToJs opts mp e val)),              setProperty (identToJs ident) (JSVar ident) mp ]          ) vals-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 (ExternMemberDeclaration member ident ty) _+  | returnsFunction ty =+    Just [ JSFunction (Just ident) [Ident "value"] (JSBlock+            [ JSReturn $ JSApp (JSAccessor "bind" (JSAccessor member (JSVar (Ident "value")))) [JSVar (Ident "value")]+            ]),+           setProperty (show ident) (JSVar ident) mp ]+  | otherwise =+    Just [ JSFunction (Just ident) [Ident "value"] (JSBlock+            [ JSReturn $ JSAccessor member (JSVar (Ident "value"))+            ]),+           setProperty (show ident) (JSVar ident) mp ]+  where+  returnsFunction (Function _ ret) = isFunction ret+  returnsFunction (ForAll _ ty') = returnsFunction ty'+  returnsFunction _ = error "Expected function type in declToJs"+  isFunction (Function _ _) = True+  isFunction (ForAll _ ty') = isFunction ty'+  isFunction _ = False declToJs _ mp (DataDeclaration _ _ ctors) _ =   Just $ flip concatMap ctors $ \(pn@(ProperName ctor), maybeTy) ->     let
+ src/Language/PureScript/CodeGen/Optimize.hs view
@@ -0,0 +1,198 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Optimize+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Language.PureScript.CodeGen.Optimize (+    optimize+) where++import Data.Data+import Data.Maybe (fromMaybe)+import Data.Generics++import Language.PureScript.Names+import Language.PureScript.CodeGen.JS.AST+import Language.PureScript.Options++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)+  where+  replace (JSVar var2) | var1 == var2 = js+  replace other = other++replaceIdents :: (Data d) => [(Ident, JS)] -> d -> d+replaceIdents vars = everywhere (mkT replace)+  where+  replace v@(JSVar var) = fromMaybe v $ lookup var vars+  replace other = other++isReassigned :: (Data d) => Ident -> d -> Bool+isReassigned var1 = everything (||) (mkQ False check)+  where+  check :: JS -> Bool+  check (JSAssignment (JSAssignVariable var2) _) | var1 == var2 = True+  check _ = False++isUsed :: (Data d) => Ident -> d -> Bool+isUsed var1 = everything (||) (mkQ False check)+  where+  check :: JS -> Bool+  check (JSVar var2) | var1 == var2 = True+  check (JSAssignment target _) | var1 == targetVariable target = True+  check _ = False+  targetVariable :: JSAssignment -> Ident+  targetVariable (JSAssignVariable var) = var+  targetVariable (JSAssignProperty _ tgt) = targetVariable tgt++shouldInline :: JS -> Bool+shouldInline (JSVar _) = True+shouldInline (JSNumericLiteral _) = True+shouldInline (JSStringLiteral _) = True+shouldInline (JSBooleanLiteral _) = True+shouldInline (JSAccessor _ val) = shouldInline val+shouldInline (JSIndexer index val) = shouldInline index && shouldInline val+shouldInline _ = False++inlineVariables :: JS -> JS+inlineVariables = everywhere (mkT removeFromBlock)+  where+  removeFromBlock :: JS -> JS+  removeFromBlock (JSBlock sts) = JSBlock (go sts)+  removeFromBlock js = js+  go :: [JS] -> [JS]+  go [] = []+  go (JSVariableIntroduction var (Just js) : sts) | shouldInline js && not (isReassigned var sts) = go (replaceIdent var js sts)+  go (s:sts) = s : go sts++removeUnusedVariables :: JS -> JS+removeUnusedVariables = everywhere (mkT removeFromBlock)+  where+  removeFromBlock :: JS -> JS+  removeFromBlock (JSBlock sts) = JSBlock (go sts)+  removeFromBlock js = js+  go :: [JS] -> [JS]+  go [] = []+  go (JSVariableIntroduction var _ : sts) | not (isUsed var sts) = go sts+  go (s:sts) = s : go sts++etaConvert :: JS -> JS+etaConvert = everywhere (mkT convert)+  where+  convert :: JS -> JS+  convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents (JSBlock body)) args)])+    | all shouldInline args = JSBlock (replaceIdents (zip idents args) body)+  convert js = js++unThunk :: JS -> JS+unThunk = everywhere (mkT convert)+  where+  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"+  copyVar :: Ident -> Ident+  copyVar (Ident arg) = Ident $ "__copy_" ++ arg+  copyVar _ = error "Invalid name in copyVar"+  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 (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 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 $+        map (\arg -> JSVariableIntroduction arg (Just (JSVar (copyVar arg)))) allArgs +++        [ 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]
− src/Language/PureScript/Optimize.hs 
@@ -1,198 +0,0 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.Optimize--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |-----------------------------------------------------------------------------------module Language.PureScript.Optimize (-    optimize-) where--import Data.Data-import Data.Maybe (fromMaybe)-import Data.Generics--import Language.PureScript.Names-import Language.PureScript.CodeGen.JS.AST-import Language.PureScript.Options--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)-  where-  replace (JSVar var2) | var1 == var2 = js-  replace other = other--replaceIdents :: (Data d) => [(Ident, JS)] -> d -> d-replaceIdents vars = everywhere (mkT replace)-  where-  replace v@(JSVar var) = fromMaybe v $ lookup var vars-  replace other = other--isReassigned :: (Data d) => Ident -> d -> Bool-isReassigned var1 = everything (||) (mkQ False check)-  where-  check :: JS -> Bool-  check (JSAssignment (JSAssignVariable var2) _) | var1 == var2 = True-  check _ = False--isUsed :: (Data d) => Ident -> d -> Bool-isUsed var1 = everything (||) (mkQ False check)-  where-  check :: JS -> Bool-  check (JSVar var2) | var1 == var2 = True-  check (JSAssignment target _) | var1 == targetVariable target = True-  check _ = False-  targetVariable :: JSAssignment -> Ident-  targetVariable (JSAssignVariable var) = var-  targetVariable (JSAssignProperty _ tgt) = targetVariable tgt--shouldInline :: JS -> Bool-shouldInline (JSVar _) = True-shouldInline (JSNumericLiteral _) = True-shouldInline (JSStringLiteral _) = True-shouldInline (JSBooleanLiteral _) = True-shouldInline (JSAccessor _ val) = shouldInline val-shouldInline (JSIndexer index val) = shouldInline index && shouldInline val-shouldInline _ = False--inlineVariables :: JS -> JS-inlineVariables = everywhere (mkT removeFromBlock)-  where-  removeFromBlock :: JS -> JS-  removeFromBlock (JSBlock sts) = JSBlock (go sts)-  removeFromBlock js = js-  go :: [JS] -> [JS]-  go [] = []-  go (JSVariableIntroduction var (Just js) : sts) | shouldInline js && not (isReassigned var sts) = go (replaceIdent var js sts)-  go (s:sts) = s : go sts--removeUnusedVariables :: JS -> JS-removeUnusedVariables = everywhere (mkT removeFromBlock)-  where-  removeFromBlock :: JS -> JS-  removeFromBlock (JSBlock sts) = JSBlock (go sts)-  removeFromBlock js = js-  go :: [JS] -> [JS]-  go [] = []-  go (JSVariableIntroduction var _ : sts) | not (isUsed var sts) = go sts-  go (s:sts) = s : go sts--etaConvert :: JS -> JS-etaConvert = everywhere (mkT convert)-  where-  convert :: JS -> JS-  convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents (JSBlock body)) args)])-    | all shouldInline args = JSBlock (replaceIdents (zip idents args) body)-  convert js = js--unThunk :: JS -> JS-unThunk = everywhere (mkT convert)-  where-  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"-  copyVar :: Ident -> Ident-  copyVar (Ident arg) = Ident $ "__copy_" ++ arg-  copyVar _ = error "Invalid name in copyVar"-  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 (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 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 $-        map (\arg -> JSVariableIntroduction arg (Just (JSVar (copyVar arg)))) allArgs ++-        [ 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]