packages feed

purescript 0.3.13.1 → 0.3.14

raw patch · 13 files changed

+151/−35 lines, 13 files

Files

psc/Main.hs view
@@ -98,8 +98,12 @@ browserNamespace = value $ opt "PS" $ (optInfo [ "browser-namespace" ])      { optDoc = "Specify the namespace that PureScript modules will be exported to when running in the browser." } +entryPoint :: Term (Maybe String)+entryPoint = value $ opt Nothing $ (optInfo [ "entry-point" ])+     { optDoc = "Specify the module which is the entry point. All code which is not a transitive dependency of this module will be removed." }+ options :: Term P.Options-options = P.Options <$> tco <*> performRuntimeTypeChecks <*> magicDo <*> runMain <*> noOpts <*> browserNamespace+options = P.Options <$> tco <*> performRuntimeTypeChecks <*> magicDo <*> runMain <*> noOpts <*> browserNamespace <*> entryPoint  stdInOrInputFiles :: FilePath -> Term (Maybe [FilePath]) stdInOrInputFiles prelude = combine <$> useStdIn <*> (not <$> noPrelude) <*> inputFiles
psci/Main.hs view
@@ -35,7 +35,7 @@ getPreludeFilename = Paths.getDataFileName "prelude/prelude.purs"  options :: P.Options-options = P.Options True False True True True "PS"+options = P.Options True False True True True "PS" Nothing  completion :: [P.Module] -> CompletionFunc IO completion ms = completeWord Nothing " \t\n\r" findCompletions
purescript.cabal view
@@ -1,5 +1,5 @@ name: purescript-version: 0.3.13.1+version: 0.3.14 cabal-version: >=1.8 build-type: Simple license: MIT@@ -27,6 +27,7 @@                      Language.PureScript.Types                      Language.PureScript.Values                      Language.PureScript.Scope+                     Language.PureScript.DeadCodeElimination                      Language.PureScript.Sugar                      Language.PureScript.ModuleDependencies                      Language.PureScript.Sugar.CaseDeclarations
src/Language/PureScript.hs view
@@ -27,8 +27,10 @@ import Language.PureScript.Sugar as P import Language.PureScript.Options as P import Language.PureScript.ModuleDependencies as P+import Language.PureScript.DeadCodeElimination as P  import Data.List (intercalate)+import Data.Maybe (mapMaybe) import Control.Monad (when, forM) import Control.Monad.State.Lazy import Control.Applicative ((<$>))@@ -47,6 +49,8 @@ -- --  * Regroup values to take into account new value dependencies introduced by elaboration --+--  * Eliminate dead code+-- --  * Generate Javascript, and perform optimization passes. -- --  * Pretty-print the generated Javascript@@ -59,8 +63,10 @@     modify (\s -> s { checkCurrentModule = Just (ModuleName moduleName) })     Module moduleName <$> typeCheckAll (ModuleName moduleName) decls   regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated-  let js = map (flip (moduleToJs opts) env) $ regrouped-  let exts = intercalate "\n" . map (flip moduleToPs env) $ regrouped+  let entryPoint = optionsEntryPoint opts+  let elim = maybe regrouped (\ep -> eliminateDeadCode env ep regrouped) entryPoint+  let js = mapMaybe (flip (moduleToJs opts) env) elim+  let exts = intercalate "\n" . map (flip moduleToPs env) $ elim   js' <- case () of               _ | optionsRunMain opts -> do                     when ((ModuleName (ProperName "Main"), Ident "main") `M.notMember` (names env)) $
src/Language/PureScript/CodeGen/JS.hs view
@@ -51,11 +51,13 @@ -- Generate code in the simplified Javascript intermediate representation for all declarations in a -- module. ---moduleToJs :: Options -> Module -> Environment -> JS+moduleToJs :: Options -> Module -> Environment -> Maybe JS moduleToJs opts (Module pname@(ProperName name) decls) env =-  JSAssignment (JSAccessor name (JSVar "_ps")) $ JSApp (JSFunction Nothing ["module"]-                      (JSBlock $ jsDecls ++ [JSReturn $ JSVar "module"]))-          [(JSBinary Or (JSAccessor name (JSVar "_ps")) (JSObjectLiteral []))]+  case jsDecls of+    [] -> Nothing+    _ -> Just $ JSAssignment (JSAccessor name (JSVar "_ps")) $+           JSApp (JSFunction Nothing ["module"] (JSBlock $ jsDecls ++ [JSReturn $ JSVar "module"]))+                 [(JSBinary Or (JSAccessor name (JSVar "_ps")) (JSObjectLiteral []))]   where   jsDecls = (concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts (ModuleName pname) decl env) (decls))
src/Language/PureScript/CodeGen/Optimize.hs view
@@ -261,6 +261,7 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)   where   fnName = "__do"+   convert :: JS -> JS   convert (JSApp (JSApp ret [val]) []) | isReturn ret = val   convert (JSApp (JSApp bind [m]) [JSFunction Nothing ["_"] (JSBlock [JSReturn ret])]) | isBind bind =@@ -268,24 +269,33 @@   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 (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict effDict = True   isBind _ = False+   isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict effDict = True   isReturn _ = False-  isBindPoly (JSAccessor prop (JSVar "Prelude")) | prop == identToJs (Op ">>=") = True-  isBindPoly (JSIndexer (JSStringLiteral ">>=") (JSVar "Prelude")) = True++  isBindPoly (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) | prop == identToJs (Op ">>=") = True+  isBindPoly (JSIndexer (JSStringLiteral ">>=") (JSAccessor "Prelude" (JSVar "_ps"))) = True   isBindPoly _ = False-  isRetPoly (JSAccessor "$return" (JSVar "Prelude")) = True++  isRetPoly (JSAccessor "$return" (JSAccessor "Prelude" (JSVar "_ps"))) = True+  isRetPoly (JSIndexer (JSStringLiteral "return") (JSAccessor "Prelude" (JSVar "_ps"))) = True   isRetPoly _ = False+   prelude = ModuleName (ProperName "Prelude")   effModule = ModuleName (ProperName "Eff")+   Right (Ident effDictName) = mkDictionaryValueName     effModule     (Qualified (Just prelude) (ProperName "Monad"))     (TypeConstructor (Qualified (Just effModule) (ProperName "Eff")))-  isEffDict (JSVar ident) | ident == effDictName = True-  isEffDict (JSAccessor prop (JSVar "Eff")) | prop == effDictName = True++  isEffDict (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == effDictName = True+  isEffDict (JSApp (JSAccessor prop (JSAccessor "Eff" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == effDictName = True   isEffDict _ = False+   undo :: JS -> JS   undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body   undo other = other@@ -306,8 +316,8 @@   convert :: JS -> JS   convert (JSApp (JSApp op [x]) [y]) | isOp op = f x y   convert other = other-  isOp (JSAccessor longForm (JSVar "Prelude")) | longForm == identToJs (Op op) = True-  isOp (JSIndexer (JSStringLiteral op') (JSVar "Prelude")) | op == op' = True+  isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar "_ps"))) | longForm == identToJs (Op op) = True+  isOp (JSIndexer (JSStringLiteral op') (JSAccessor "Prelude" (JSVar "_ps"))) | op == op' = True   isOp _ = False  inlineCommonOperators :: JS -> JS@@ -350,8 +360,8 @@     convert :: JS -> JS     convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict className classTy dict = JSBinary op x y     convert other = other-    isOp (JSAccessor longForm (JSVar "Prelude")) | longForm == identToJs (Op opString) = True-    isOp (JSIndexer (JSStringLiteral op') (JSVar "Prelude")) | opString == op' = True+    isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar ps))) | longForm == identToJs (Op opString) = True+    isOp (JSIndexer (JSStringLiteral op') (JSAccessor "Prelude" (JSVar "_ps"))) | opString == op' = True     isOp _ = False   binaryFunction :: String -> String -> Type -> BinaryOperator -> JS -> JS   binaryFunction fnName className classTy op = everywhere (mkT convert)@@ -359,7 +369,7 @@     convert :: JS -> JS     convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict className classTy dict = JSBinary op x y     convert other = other-    isOp (JSAccessor fnName' (JSVar "Prelude")) | fnName == fnName' = True+    isOp (JSAccessor fnName' (JSAccessor "Prelude" (JSVar "_ps"))) | fnName == fnName' = True     isOp _ = False   unary :: String -> String -> Type -> UnaryOperator -> JS -> JS   unary fnName className classTy op = everywhere (mkT convert)@@ -367,12 +377,12 @@     convert :: JS -> JS     convert (JSApp (JSApp fn [dict]) [x]) | isOp fn && isOpDict className classTy dict = JSUnary op x     convert other = other-    isOp (JSAccessor fnName' (JSVar "Prelude")) | fnName' == fnName = True+    isOp (JSAccessor fnName' (JSAccessor "Prelude" (JSVar "_ps"))) | fnName' == fnName = True     isOp _ = False-  isOpDict className ty (JSAccessor prop (JSVar "Prelude")) | prop == dictName = True+  isOpDict className ty (JSApp (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == dictName = True     where     Right (Ident dictName) = mkDictionaryValueName-      (ModuleName (ProperName "Prelude"))+      (ModuleName (ProperName "Prim"))       (Qualified (Just (ModuleName (ProperName "Prelude"))) (ProperName className))       ty   isOpDict _ _ _ = False
+ src/Language/PureScript/DeadCodeElimination.hs view
@@ -0,0 +1,76 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.DeadCodeElimination+-- Copyright   :  (c) 2014 Phil Freeman+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Language.PureScript.DeadCodeElimination (+  eliminateDeadCode+) where++import Data.Data+import Data.List+import Data.Graph+import Data.Generics+import Data.Maybe (mapMaybe)++import Language.PureScript.Names+import Language.PureScript.Values+import Language.PureScript.Declarations+import Language.PureScript.TypeChecker.Monad++-- |+-- Eliminate all declarations which are not a transitive dependency of the entry point module+--+eliminateDeadCode :: Environment -> String -> [Module] -> [Module]+eliminateDeadCode env entryPoint ms =+  let declarations = concatMap (declarationsByModule env) ms+      (graph, _, vertexFor) = graphFromEdges $ map (\(key, deps) -> (key, key, deps)) declarations+      entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((ModuleName (ProperName mn), _), _) -> mn == entryPoint) $ declarations+  in flip map ms $ \(Module moduleName ds) -> Module moduleName (filter (isUsed (ModuleName moduleName) graph vertexFor entryPointVertices) ds)++type Key = (ModuleName, Either Ident ProperName)++declarationsByModule :: Environment -> Module -> [(Key, [Key])]+declarationsByModule env (Module moduleName ds) = concatMap go $ ds+  where+  go :: Declaration -> [(Key, [Key])]+  go d@(ValueDeclaration name _ _ _) = [((ModuleName moduleName, Left name), dependencies env (ModuleName moduleName) d)]+  go (DataDeclaration _ _ dctors) = map (\(name, _) -> ((ModuleName moduleName, Right name), [])) dctors+  go (ExternDeclaration _ name _ _) = [((ModuleName moduleName, Left name), [])]+  go d@(BindingGroupDeclaration names) = map (\(name, _) -> ((ModuleName moduleName, Left name), dependencies env (ModuleName moduleName) d)) names+  go (DataBindingGroupDeclaration ds) = concatMap go ds+  go _ = []++dependencies :: (Data d) => Environment -> ModuleName -> d -> [Key]+dependencies env moduleName = nub . everything (++) (mkQ [] values)+  where+  values :: Value -> [Key]+  values (Var ident) = let (mn, name) = canonicalize moduleName env ident in [(mn, Left name)]+  values (Constructor pn) = let (mn, name) = canonicalizeDataConstructor moduleName env pn in [(mn, Right name)]+  values _ = []++isUsed :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Declaration -> Bool+isUsed moduleName graph vertexFor entryPointVertices (ValueDeclaration name _ _ _) =+  let Just v' = vertexFor (moduleName, Left name)+  in any (\v -> path graph v v') entryPointVertices+isUsed moduleName graph vertexFor entryPointVertices (DataDeclaration _ _ dctors) =+  any (\(pn, _) -> let Just v' = vertexFor (moduleName, Right pn)+                   in any (\v -> path graph v v') entryPointVertices) dctors+isUsed moduleName graph vertexFor entryPointVertices (ExternDeclaration _ name _ _) =+  let Just v' = vertexFor (moduleName, Left name)+  in any (\v -> path graph v v') entryPointVertices+isUsed moduleName graph vertexFor entryPointVertices (BindingGroupDeclaration ds) =+  any (\(name, _) -> let Just v' = vertexFor (moduleName, Left name)+                     in any (\v -> path graph v v') entryPointVertices) ds+isUsed moduleName graph vertexFor entryPointVertices (DataBindingGroupDeclaration ds) =+  any (isUsed moduleName graph vertexFor entryPointVertices) ds+isUsed _ _ _ _ _ = True
src/Language/PureScript/Names.hs view
@@ -18,6 +18,7 @@ module Language.PureScript.Names where  import Data.Data+import Data.Function (on)  -- | -- Names for value identifiers@@ -34,12 +35,23 @@   -- |   -- An escaped name   ---  | Escaped String deriving (Eq, Ord, Data, Typeable)+  | Escaped String deriving (Data, Typeable)  instance Show Ident where   show (Ident s) = s   show (Op op) = '(':op ++ ")"   show (Escaped s) = s++instance Eq Ident where+  Ident s1   == Ident s2   = s1 == s2+  Op s1      == Op s2      = s1 == s2+  Escaped s1 == Escaped s2 = s1 == s2+  Ident s1   == Escaped s2 = s1 == s2+  Escaped s1 == Ident s2   = s1 == s2+  _          == _          = False++instance Ord Ident where+  compare = compare `on` show  -- | -- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.
src/Language/PureScript/Options.hs view
@@ -44,10 +44,14 @@     -- browser.     --   , optionsBrowserNamespace :: String+    -- |+    -- The entry point module, for dead code elimination+    --+  , optionsEntryPoint :: Maybe String   } deriving Show  -- | -- Default compiler options -- defaultOptions :: Options-defaultOptions = Options False False False False False "PS"+defaultOptions = Options False False False False False "PS" Nothing
src/Language/PureScript/Parser/Common.hs view
@@ -319,7 +319,7 @@ -- Parse an identifier in backticks or an operator -- parseIdentInfix :: P.Parsec String ParseState (Qualified Ident)-parseIdentInfix = (P.between tick tick (parseQualified (Ident <$> identifier))) <|> parseQualified (Op <$> operator)+parseIdentInfix = (P.between tick tick (parseQualified (Ident <$> identifier))) <|> Qualified Nothing <$> (Op <$> operator)  -- | -- Mark the current indentation level
src/Language/PureScript/Sugar/Operators.hs view
@@ -58,7 +58,11 @@ customOperatorTable :: M.Map (Qualified Ident) Fixity -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]] customOperatorTable fixities =   let-    applyUserOp name t1 t2 = App (App (Var name) t1) t2+    -- We make the assumption here that infix operators are not qualified. The parser currently enforces this.+    -- The fixity map can therefore map from module name/ident pairs to fixities, where the module name is the name+    -- of the module imported into, not from. This is useful in matchOp, but here we have to discard the module name to+    -- make sure that the generated code is correct.+    applyUserOp (Qualified _ name) t1 t2 = App (App (Var (Qualified Nothing name)) t1) t2     userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) . M.toList $ fixities     sorted = reverse $ sortBy (compare `on` (\(_, _, p, _) -> p)) userOps     groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted@@ -107,7 +111,4 @@   let m' = M.fromList (map (\(i, fixity) -> (Qualified (Just moduleName) i, fixity)) fs)   collectFixities (M.union m' m) moduleName rest collectFixities m moduleName (_:ds) = collectFixities m moduleName ds--globalOp :: String -> Qualified Ident-globalOp = Qualified Nothing . Op
src/Language/PureScript/TypeChecker/Monad.hs view
@@ -224,11 +224,11 @@ -- | -- Canonicalize a data constructor by resolving any aliases introduced by module imports ---canonicalizeDataConstructor :: ModuleName -> Environment -> Qualified ProperName -> (ModuleName, Ident)-canonicalizeDataConstructor _ _ (Qualified (Just mn) i) = (mn, Ident $ show i)-canonicalizeDataConstructor mn env (Qualified Nothing i) = case (mn, i) `M.lookup` dataConstructors env of-  Just (_, Alias mn' i') -> (mn', i')-  _ -> (mn, Ident $ show i)+canonicalizeDataConstructor :: ModuleName -> Environment -> Qualified ProperName -> (ModuleName, ProperName)+canonicalizeDataConstructor _ _ (Qualified (Just mn) pn) = (mn, pn)+canonicalizeDataConstructor mn env (Qualified Nothing pn) = case (mn, pn) `M.lookup` dataConstructors env of+  Just (_, Alias mn' (Ident pn')) -> (mn', ProperName pn')+  _ -> (mn, pn)  -- | -- State required for type checking:
tests/Main.hs view
@@ -66,7 +66,7 @@ assertCompiles inputFile = do   putStrLn $ "assert " ++ inputFile ++ " compiles successfully"   prelude <- preludeFilename-  assert (P.defaultOptions { P.optionsRunMain = True, P.optionsNoOptimizations = True }) [prelude, inputFile] $ either (return . Just) $ \js -> do+  assert (P.defaultOptions { P.optionsRunMain = True, P.optionsNoOptimizations = True, P.optionsEntryPoint = Just "Main" }) [prelude, inputFile] $ either (return . Just) $ \js -> do     args <- getArgs     if "--run-js" `elem` args     then do