packages feed

purescript 0.3.14 → 0.4.0

raw patch · 9 files changed

+73/−68 lines, 9 files

Files

psc/Main.hs view
@@ -86,9 +86,9 @@ 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." }+runMain :: Term (Maybe String)+runMain = value $ defaultOpt (Just "Main") Nothing $ (optInfo [ "main" ])+     { optDoc = "Generate code to run the main method in the specified module." }  noOpts :: Term Bool noOpts = value $ flag $ (optInfo [ "no-opts" ])@@ -98,12 +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." }+dceModules :: Term [String]+dceModules = value $ optAll [] $ (optInfo [ "m", "module" ])+     { optDoc = "Enables dead code elimination, all code which is not a transitive dependency of a specified module will be removed. This argument can be used multiple times." }  options :: Term P.Options-options = P.Options <$> tco <*> performRuntimeTypeChecks <*> magicDo <*> runMain <*> noOpts <*> browserNamespace <*> entryPoint+options = P.Options <$> tco <*> performRuntimeTypeChecks <*> magicDo <*> runMain <*> noOpts <*> browserNamespace <*> dceModules  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" Nothing+options = P.Options True False True Nothing True "PS" []  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.14+version: 0.4.0 cabal-version: >=1.8 build-type: Simple license: MIT
src/Language/PureScript.hs view
@@ -30,10 +30,10 @@ import Language.PureScript.DeadCodeElimination as P  import Data.List (intercalate)-import Data.Maybe (mapMaybe)+import Data.Maybe (mapMaybe, fromMaybe) import Control.Monad (when, forM) import Control.Monad.State.Lazy-import Control.Applicative ((<$>))+import Control.Applicative ((<$>), (<|>)) import qualified Data.Map as M  -- |@@ -47,9 +47,9 @@ -- --  * Type check, and elaborate values to include type annotations and type class dictionaries. -----  * Regroup values to take into account new value dependencies introduced by elaboration+--  * Regroup values to take into account new value dependencies introduced by elaboration. -----  * Eliminate dead code+--  * Eliminate dead code. -- --  * Generate Javascript, and perform optimization passes. --@@ -61,16 +61,18 @@   desugared <- desugar sorted   (elaborated, env) <- runCheck $ forM desugared $ \(Module moduleName decls) -> do     modify (\s -> s { checkCurrentModule = Just (ModuleName moduleName) })-    Module moduleName <$> typeCheckAll (ModuleName moduleName) decls+    Module moduleName <$> typeCheckAll mainModuleIdent (ModuleName moduleName) decls   regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated-  let entryPoint = optionsEntryPoint opts-  let elim = maybe regrouped (\ep -> eliminateDeadCode env ep regrouped) entryPoint+  let entryPoints = optionsModules opts+  let elim = if null entryPoints then regrouped else eliminateDeadCode env entryPoints regrouped   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)) $-                      Left "Main.main is undefined"-                    return $ js ++ [JSApp (JSAccessor "main" (JSAccessor "Main" (JSVar "_ps"))) []]-                | otherwise -> return js+  js' <- case optionsMain opts of+    Just mainModuleName -> do+      when ((ModuleName (ProperName mainModuleName), Ident "main") `M.notMember` (names env)) $+        Left $ mainModuleName ++ ".main is undefined"+      return $ js ++ [JSApp (JSAccessor "main" (JSAccessor mainModuleName (JSVar "_ps"))) []]+    _ -> return js   return (prettyPrintJS [(wrapExportsContainer opts js')], exts, env)+  where+  mainModuleIdent = ModuleName . ProperName <$> (optionsMain opts)
src/Language/PureScript/DeadCodeElimination.hs view
@@ -30,11 +30,11 @@ -- | -- Eliminate all declarations which are not a transitive dependency of the entry point module ---eliminateDeadCode :: Environment -> String -> [Module] -> [Module]-eliminateDeadCode env entryPoint ms =+eliminateDeadCode :: Environment -> [String] -> [Module] -> [Module]+eliminateDeadCode env entryPoints 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+      entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((ModuleName (ProperName mn), _), _) -> mn `elem` entryPoints) $ declarations   in flip map ms $ \(Module moduleName ds) -> Module moduleName (filter (isUsed (ModuleName moduleName) graph vertexFor entryPointVertices) ds)  type Key = (ModuleName, Either Ident ProperName)
src/Language/PureScript/Options.hs view
@@ -32,9 +32,10 @@     --   , optionsMagicDo :: Bool     -- |-    -- Check the type of Main.main and generate its code+    -- When specified, checks the type of `main` in the module, and generate a call to run main+    -- after the module definitions.      ---  , optionsRunMain :: Bool+  , optionsMain :: Maybe String     -- |     -- Skip all optimizations     --@@ -45,13 +46,13 @@     --   , optionsBrowserNamespace :: String     -- |-    -- The entry point module, for dead code elimination+    -- The modules to keep while enabling dead code elimination     ---  , optionsEntryPoint :: Maybe String+  , optionsModules :: [String]   } deriving Show  -- | -- Default compiler options -- defaultOptions :: Options-defaultOptions = Options False False False False False "PS" Nothing+defaultOptions = Options False False False Nothing False "PS" []
src/Language/PureScript/TypeChecker.hs view
@@ -111,16 +111,16 @@ -- --  * Process module imports ---typeCheckAll :: ModuleName -> [Declaration] -> Check [Declaration]-typeCheckAll _ [] = return []-typeCheckAll moduleName (d@(DataDeclaration name args dctors) : rest) = do+typeCheckAll :: Maybe ModuleName -> ModuleName -> [Declaration] -> Check [Declaration]+typeCheckAll _ _ [] = return []+typeCheckAll mainModuleName moduleName (d@(DataDeclaration name args dctors) : rest) = do   rethrow (("Error in type constructor " ++ show name ++ ":\n") ++) $ do     typeIsNotDefined moduleName name     ctorKind <- kindsOf moduleName name args (concatMap snd dctors)     addDataType moduleName name args dctors ctorKind-  ds <- typeCheckAll moduleName rest+  ds <- typeCheckAll mainModuleName moduleName rest   return $ d : ds-typeCheckAll moduleName (d@(DataBindingGroupDeclaration tys) : rest) = do+typeCheckAll mainModuleName moduleName (d@(DataBindingGroupDeclaration tys) : rest) = do   rethrow ("Error in data binding group:\n" ++) $ do     let syns = mapMaybe toTypeSynonym tys     let dataDecls = mapMaybe toDataDecl tys@@ -131,48 +131,48 @@     forM_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do       typeIsNotDefined moduleName name       addTypeSynonym moduleName name args ty kind-  ds <- typeCheckAll moduleName rest+  ds <- typeCheckAll mainModuleName moduleName rest   return $ d : ds   where   toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty)   toTypeSynonym _ = Nothing   toDataDecl (DataDeclaration nm args dctors) = Just (nm, args, dctors)   toDataDecl _ = Nothing-typeCheckAll moduleName (d@(TypeSynonymDeclaration name args ty) : rest) = do+typeCheckAll mainModuleName moduleName (d@(TypeSynonymDeclaration name args ty) : rest) = do   rethrow (("Error in type synonym " ++ show name ++ ":\n") ++) $ do     typeIsNotDefined moduleName name     kind <- kindsOf moduleName name args [ty]     addTypeSynonym moduleName name args ty kind-  ds <- typeCheckAll moduleName rest+  ds <- typeCheckAll mainModuleName moduleName rest   return $ d : ds-typeCheckAll _ (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"-typeCheckAll moduleName (ValueDeclaration name [] Nothing val : rest) = do+typeCheckAll _ _ (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"+typeCheckAll mainModuleName moduleName (ValueDeclaration name [] Nothing val : rest) = do   d <- rethrow (("Error in declaration " ++ show name ++ ":\n") ++) $ do     valueIsNotDefined moduleName name-    [(_, (val', ty))] <- typesOf moduleName [(name, val)]+    [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]     addValue moduleName name ty     return $ ValueDeclaration name [] Nothing val'-  ds <- typeCheckAll moduleName rest+  ds <- typeCheckAll mainModuleName moduleName rest   return $ d : ds-typeCheckAll _ (ValueDeclaration _ _ _ _ : _) = error "Binders were not desugared"-typeCheckAll moduleName (BindingGroupDeclaration vals : rest) = do+typeCheckAll _ _ (ValueDeclaration _ _ _ _ : _) = error "Binders were not desugared"+typeCheckAll mainModuleName moduleName (BindingGroupDeclaration vals : rest) = do   d <- rethrow (("Error in binding group " ++ show (map fst vals) ++ ":\n") ++) $ do     forM_ (map fst vals) $ \name ->       valueIsNotDefined moduleName name-    tys <- typesOf moduleName vals+    tys <- typesOf mainModuleName moduleName vals     vals' <- forM (zip (map fst vals) (map snd tys)) $ \(name, (val, ty)) -> do       addValue moduleName name ty       return (name, val)     return $ BindingGroupDeclaration vals'-  ds <- typeCheckAll moduleName rest+  ds <- typeCheckAll mainModuleName moduleName rest   return $ d : ds-typeCheckAll moduleName (d@(ExternDataDeclaration name kind) : rest) = do+typeCheckAll mainModuleName moduleName (d@(ExternDataDeclaration name kind) : rest) = do   env <- getEnv   guardWith (show name ++ " is already defined") $ not $ M.member (moduleName, name) (types env)   putEnv $ env { types = M.insert (moduleName, name) (kind, TypeSynonym) (types env) }-  ds <- typeCheckAll moduleName rest+  ds <- typeCheckAll mainModuleName moduleName rest   return $ d : ds-typeCheckAll moduleName (d@(ExternDeclaration importTy name _ ty) : rest) = do+typeCheckAll mainModuleName moduleName (d@(ExternDeclaration importTy name _ ty) : rest) = do   rethrow (("Error in foreign import declaration " ++ show name ++ ":\n") ++) $ do     env <- getEnv     kind <- kindOf moduleName ty@@ -180,14 +180,14 @@     case M.lookup (moduleName, name) (names env) of       Just _ -> throwError $ show name ++ " is already defined"       Nothing -> putEnv (env { names = M.insert (moduleName, name) (qualifyAllUnqualifiedNames moduleName env ty, Extern importTy) (names env) })-  ds <- typeCheckAll moduleName rest+  ds <- typeCheckAll mainModuleName moduleName rest   return $ d : ds-typeCheckAll moduleName (d@(FixityDeclaration _ name) : rest) = do-  ds <- typeCheckAll moduleName rest+typeCheckAll mainModuleName moduleName (d@(FixityDeclaration _ name) : rest) = do+  ds <- typeCheckAll mainModuleName moduleName rest   env <- getEnv   guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (moduleName, Op name) $ names env   return $ d : ds-typeCheckAll currentModule (d@(ImportDeclaration moduleName idents) : rest) = do+typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName idents) : rest) = do   env <- getEnv   rethrow errorMessage $ do     guardWith ("Module " ++ show moduleName ++ " does not exist") $ moduleExists env@@ -199,7 +199,7 @@         shadowIdents (lefts idents') env         shadowTypes (rights idents') env     shadowTypeClassInstances env-  ds <- typeCheckAll currentModule rest+  ds <- typeCheckAll mainModuleName currentModule rest   return $ d : ds   where   errorMessage = (("Error in import declaration " ++ show moduleName ++ ":\n") ++)@@ -243,16 +243,16 @@   constructs (TypeApp (TypeApp t _) ty) pn | t == tyFunction = ty `constructs` pn   constructs (TypeApp ty _) pn = ty `constructs` pn   constructs fn _ = error $ "Invalid arguments to constructs: " ++ show fn-typeCheckAll moduleName (d@(TypeClassDeclaration _ _ _) : rest) = do+typeCheckAll mainModuleName moduleName (d@(TypeClassDeclaration _ _ _) : rest) = do   env <- getEnv-  ds <- typeCheckAll moduleName rest+  ds <- typeCheckAll mainModuleName moduleName rest   return $ qualifyAllUnqualifiedNames moduleName env d : ds-typeCheckAll moduleName (d@(TypeInstanceDeclaration deps className ty _) : rest) = do+typeCheckAll mainModuleName moduleName (d@(TypeInstanceDeclaration deps className ty _) : rest) = do   env <- getEnv   dictName <- Check . lift $ mkDictionaryValueName moduleName className ty   checkTypeClassInstance moduleName ty   forM_ deps $ checkTypeClassInstance moduleName . snd   addTypeClassDictionaries (qualifyAllUnqualifiedNames moduleName env     [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className ty (Just deps) TCDRegular])-  ds <- typeCheckAll moduleName rest+  ds <- typeCheckAll mainModuleName moduleName rest   return $ qualifyAllUnqualifiedNames moduleName env d : ds
src/Language/PureScript/TypeChecker/Types.hs view
@@ -47,6 +47,7 @@ import Data.Generics        (everythingWithContext, mkM, everywhereM, everything, mkT,         something, everywhere, mkQ)+import Data.Generics.Extras  import Language.PureScript.Values import Language.PureScript.Types@@ -163,8 +164,8 @@ -- Infer the types of multiple mutually-recursive values, and return elaborated values including -- type class dictionaries and type annotations. ---typesOf :: ModuleName -> [(Ident, Value)] -> Check [(Ident, (Value, Type))]-typesOf moduleName vals = do+typesOf :: Maybe ModuleName -> ModuleName -> [(Ident, Value)] -> Check [(Ident, (Value, Type))]+typesOf mainModuleName moduleName vals = do   tys <- fmap tidyUp . liftUnify $ do     let     -- Map each declaration to a name/value pair, with an optional type, if the declaration is typed@@ -203,8 +204,8 @@           TypedValue _ val' ty <- bindNames dict' $ infer val           ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)           return (ident, (TypedValue True val' ty, ty))-      -- If run-main is enabled, need to check that Main.main has type Eff eff a for some eff, a-      when (moduleName == ModuleName (ProperName "Main") && fst e == Ident "main") $ do+      -- If --main is enabled, need to check that `main` has type Eff eff a for some eff, a+      when (Just moduleName == mainModuleName && fst e == Ident "main") $ do         [eff, a] <- replicateM 2 fresh         ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName (ProperName "Eff"))) (ProperName "Eff"))) eff) a       -- Make sure unification variables do not escape@@ -249,7 +250,7 @@ -- Replace type class dictionary placeholders with inferred type class dictionaries -- replaceTypeClassDictionaries :: ModuleName -> Value -> Check Value-replaceTypeClassDictionaries mn = everywhereM (mkM go)+replaceTypeClassDictionaries mn = everywhereM' (mkM go)   where   go (TypeClassDictionary constraint dicts) = entails mn dicts constraint   go other = return other@@ -843,7 +844,8 @@   Just moduleName <- checkCurrentModule <$> get   kind <- liftCheck $ kindOf moduleName ty1   guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star-  val' <- subsumes (Just val) ty1 ty2+  ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1+  val' <- subsumes (Just val) ty1' ty2   case val' of     Nothing -> throwError "Unable to check type subsumption"     Just val'' -> do@@ -949,9 +951,9 @@   checkFunctionApplication fn replaced arg checkFunctionApplication' fn u@(TUnknown _) arg = do   arg' <- do-    TypedValue _ v t <- infer arg-    (v', t') <- instantiatePolyTypeWithUnknowns arg t-    return $ TypedValue True v' t'+    TypedValue _ arg' t <- infer arg+    (arg'', t') <- instantiatePolyTypeWithUnknowns arg' t+    return $ TypedValue True arg'' t'   let ty = (\(TypedValue _ _ t) -> t) arg'   ret <- fresh   u =?= function ty ret
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, P.optionsEntryPoint = Just "Main" }) [prelude, inputFile] $ either (return . Just) $ \js -> do+  assert (P.defaultOptions { P.optionsMain = Just "Main", P.optionsNoOptimizations = True, P.optionsModules = ["Main"] }) [prelude, inputFile] $ either (return . Just) $ \js -> do     args <- getArgs     if "--run-js" `elem` args     then do