version 0.4.00.4.0

9 files changed, 73 insertions, 68 deletions

diff --git a/psc/Main.hs b/psc/Main.hs
index df1eb13..15dc7e2 100644
--- a/psc/Main.hs
+++ b/psc/Main.hs
@@ -86,9 +86,9 @@ 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." }
+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 :: Term String
 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
diff --git a/psci/Main.hs b/psci/Main.hs
index ea30a47..f657a7e 100644
--- a/psci/Main.hs
+++ b/psci/Main.hs
@@ -35,7 +35,7 @@ getPreludeFilename :: IO FilePath
 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
diff --git a/purescript.cabal b/purescript.cabal
index 9474c4f..6142c1c 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
 name: purescript
-version: 0.3.14
+version: 0.4.0
 cabal-version: >=1.8
 build-type: Simple
 license: MIT
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index 0b90583..1ec7ea7 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -30,10 +30,10 @@ import Language.PureScript.ModuleDependencies as P
 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 @@ import qualified Data.Map as M
 --
 --  * 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 @@ compile opts ms = do
   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)
diff --git a/src/Language/PureScript/DeadCodeElimination.hs b/src/Language/PureScript/DeadCodeElimination.hs
index 1c97756..6fb80a7 100644
--- a/src/Language/PureScript/DeadCodeElimination.hs
+++ b/src/Language/PureScript/DeadCodeElimination.hs
@@ -30,11 +30,11 @@ 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 =
+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)
diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs
index 7c7e86c..6d35885 100644
--- a/src/Language/PureScript/Options.hs
+++ b/src/Language/PureScript/Options.hs
@@ -32,9 +32,10 @@ data Options = Options {
     --
   , 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 @@ data Options = Options {
     --
   , 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" []
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index d6f8b47..985ced7 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -111,16 +111,16 @@ checkTypeClassInstance _ _ = throwError "Type class instance must be of the form
 --
 --  * 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 @@ typeCheckAll moduleName (d@(DataBindingGroupDeclaration tys) : rest) = do
     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 @@ typeCheckAll moduleName (d@(ExternDeclaration importTy name _ ty) : rest) = do
     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 @@ typeCheckAll currentModule (d@(ImportDeclaration moduleName idents) : rest) = do
         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 @@ typeCheckAll currentModule (d@(ImportDeclaration moduleName idents) : rest) = do
   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
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 429803e..d020ebe 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -47,6 +47,7 @@ import qualified Data.Data as D
 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 @@ typeConstructorsAreEqual env moduleName = (==) `on` canonicalizeType moduleName
 -- 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 @@ typesOf moduleName vals = do
           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 @@ overTypes f = everywhere (mkT f)
 -- 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 @@ check' (TypedValue checkType val ty1) ty2 = do
   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 (ForAll ident ty _) arg = do
   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
diff --git a/tests/Main.hs b/tests/Main.hs
index c8e4d69..1411c89 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -66,7 +66,7 @@ assertCompiles :: FilePath -> IO ()
 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