summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-02-16 02:02:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-02-16 02:02:00 (GMT)
commit2d2180046aae6303965fd8be7349b428539caf5e (patch)
tree02641ca5f1e5e349cc06516ee2dde153cdff6d3d
parent000e7234cea556c39a8b58530676dde3a59d90aa (diff)
version 0.4.00.4.0
-rw-r--r--psc/Main.hs14
-rw-r--r--psci/Main.hs2
-rw-r--r--purescript.cabal2
-rw-r--r--src/Language/PureScript.hs28
-rw-r--r--src/Language/PureScript/DeadCodeElimination.hs6
-rw-r--r--src/Language/PureScript/Options.hs11
-rw-r--r--src/Language/PureScript/TypeChecker.hs56
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs20
-rw-r--r--tests/Main.hs2
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