a909908 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

Rework psc options for new --main and --module

commita909908b7d1dc0d1b5c692d8e42c8381bf623a66 authorGary Burgess <gary.burgess@gmail.com> dateSat 15 Feb 2014, 20:54 (13 years ago) parent83367bd

8 files changed+33−33

compare with golang

unifiedsplit

psc/Main.hs+7−7 psci/Main.hs+1−1 src/Language/PureScript.hs+11−12 src/Language/PureScript/DeadCodeElimination.hs+3−3 src/Language/PureScript/Options.hs+6−5 src/Language/PureScript/TypeChecker.hs+1−1 src/Language/PureScript/TypeChecker/Types.hs+3−3 tests/Main.hs+1−1

psc/Main.hs+7−7

@@ -86,9 +86,9 @@ magicDo :: Term Bool

8686magicDo = value $ flag $ (optInfo [ "magic-do" ])

8787 { optDoc = "Overload the do keyword to generate efficient code specifically for the Eff monad." }

8888

89−runMain :: Term Bool

90−runMain = value $ flag $ (optInfo [ "run-main" ])

91− { optDoc = "Generate code to run the main method in the Main module." }

89+runMain :: Term (Maybe String)

90+runMain = value $ defaultOpt (Just "Main") Nothing $ (optInfo [ "main" ])

91+ { optDoc = "Generate code to run the main method in the specified module." }

9292

9393noOpts :: Term Bool

9494noOpts = value $ flag $ (optInfo [ "no-opts" ])

@@ -98,12 +98,12 @@ browserNamespace :: Term String

9898browserNamespace = value $ opt "PS" $ (optInfo [ "browser-namespace" ])

9999 { optDoc = "Specify the namespace that PureScript modules will be exported to when running in the browser." }

100100

101−entryPoint :: Term (Maybe String)

102−entryPoint = value $ opt Nothing $ (optInfo [ "entry-point" ])

103− { optDoc = "Specify the module which is the entry point. All code which is not a transitive dependency of this module will be removed." }

101+dceModules :: Term [String]

102+dceModules = value $ optAll [] $ (optInfo [ "m", "module" ])

103+ { 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." }

104104

105105options :: Term P.Options

106−options = P.Options <$> tco <*> performRuntimeTypeChecks <*> magicDo <*> runMain <*> noOpts <*> browserNamespace <*> entryPoint

106+options = P.Options <$> tco <*> performRuntimeTypeChecks <*> magicDo <*> runMain <*> noOpts <*> browserNamespace <*> dceModules

107107

108108stdInOrInputFiles :: FilePath -> Term (Maybe [FilePath])

109109stdInOrInputFiles prelude = combine <$> useStdIn <*> (not <$> noPrelude) <*> inputFiles

psci/Main.hs+1−1

@@ -35,7 +35,7 @@ getPreludeFilename :: IO FilePath

3535getPreludeFilename = Paths.getDataFileName "prelude/prelude.purs"

3636

3737options :: P.Options

38−options = P.Options True False True True True "PS" Nothing

38+options = P.Options True False True Nothing True "PS" []

3939

4040completion :: [P.Module] -> CompletionFunc IO

4141completion ms = completeWord Nothing " \t\n\r" findCompletions

src/Language/PureScript.hs+11−12

@@ -47,9 +47,9 @@ import qualified Data.Map as M

4747--

4848-- * Type check, and elaborate values to include type annotations and type class dictionaries.

4949--

50−-- * Regroup values to take into account new value dependencies introduced by elaboration

50+-- * Regroup values to take into account new value dependencies introduced by elaboration.

5151--

52−-- * Eliminate dead code

52+-- * Eliminate dead code.

5353--

5454-- * Generate Javascript, and perform optimization passes.

5555--

@@ -63,17 +63,16 @@ compile opts ms = do

6363 modify (\s -> s { checkCurrentModule = Just (ModuleName moduleName) })

6464 Module moduleName <$> typeCheckAll mainModuleIdent (ModuleName moduleName) decls

6565 regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

66− let entryPoint = optionsEntryPoint opts <|> if (optionsRunMain opts) then Just "Main" else Nothing

67− let elim = maybe regrouped (\ep -> eliminateDeadCode env ep regrouped) entryPoint

66+ let entryPoints = optionsModules opts

67+ let elim = if null entryPoints then regrouped else eliminateDeadCode env entryPoints regrouped

6868 let js = mapMaybe (flip (moduleToJs opts) env) elim

6969 let exts = intercalate "\n" . map (flip moduleToPs env) $ elim

70− js' <- case () of

71− _ | optionsRunMain opts -> do

72− when ((mainModuleIdent, Ident "main") `M.notMember` (names env)) $

73− Left $ mainModuleName ++ ".main is undefined"

74− return $ js ++ [JSApp (JSAccessor "main" (JSAccessor mainModuleName (JSVar "_ps"))) []]

75− | otherwise -> return js

70+ js' <- case optionsMain opts of

71+ Just mainModuleName -> do

72+ when ((ModuleName (ProperName mainModuleName), Ident "main") `M.notMember` (names env)) $

73+ Left $ mainModuleName ++ ".main is undefined"

74+ return $ js ++ [JSApp (JSAccessor "main" (JSAccessor mainModuleName (JSVar "_ps"))) []]

75+ _ -> return js

7676 return (prettyPrintJS [(wrapExportsContainer opts js')], exts, env)

7777 where

78− mainModuleName = fromMaybe "Main" (optionsEntryPoint opts)

79− mainModuleIdent = ModuleName (ProperName mainModuleName)

78+ mainModuleIdent = ModuleName . ProperName <$> (optionsMain opts)

src/Language/PureScript/DeadCodeElimination.hs+3−3

@@ -30,11 +30,11 @@ import Language.PureScript.TypeChecker.Monad

3030-- |

3131-- Eliminate all declarations which are not a transitive dependency of the entry point module

3232--

33−eliminateDeadCode :: Environment -> String -> [Module] -> [Module]

34−eliminateDeadCode env entryPoint ms =

33+eliminateDeadCode :: Environment -> [String] -> [Module] -> [Module]

34+eliminateDeadCode env entryPoints ms =

3535 let declarations = concatMap (declarationsByModule env) ms

3636 (graph, _, vertexFor) = graphFromEdges $ map (\(key, deps) -> (key, key, deps)) declarations

37− entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((ModuleName (ProperName mn), _), _) -> mn == entryPoint) $ declarations

37+ entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((ModuleName (ProperName mn), _), _) -> mn `elem` entryPoints) $ declarations

3838 in flip map ms $ \(Module moduleName ds) -> Module moduleName (filter (isUsed (ModuleName moduleName) graph vertexFor entryPointVertices) ds)

3939

4040type Key = (ModuleName, Either Ident ProperName)

src/Language/PureScript/Options.hs+6−5

@@ -32,9 +32,10 @@ data Options = Options {

3232 --

3333 , optionsMagicDo :: Bool

3434 -- |

35− -- Check the type of Main.main and generate its code

35+ -- When specified, checks the type of `main` in the module, and generate a call to run main

36+ -- after the module definitions.

3637 --

37− , optionsRunMain :: Bool

38+ , optionsMain :: Maybe String

3839 -- |

3940 -- Skip all optimizations

4041 --

@@ -45,13 +46,13 @@ data Options = Options {

4546 --

4647 , optionsBrowserNamespace :: String

4748 -- |

48− -- The entry point module, for dead code elimination

49+ -- The modules to keep while enabling dead code elimination

4950 --

50− , optionsEntryPoint :: Maybe String

51+ , optionsModules :: [String]

5152 } deriving Show

5253

5354-- |

5455-- Default compiler options

5556--

5657defaultOptions :: Options

57−defaultOptions = Options False False False False False "PS" Nothing

58+defaultOptions = Options False False False Nothing False "PS" []

src/Language/PureScript/TypeChecker.hs+1−1

@@ -111,7 +111,7 @@ checkTypeClassInstance _ _ = throwError "Type class instance must be of the form

111111--

112112-- * Process module imports

113113--

114−typeCheckAll :: ModuleName -> ModuleName -> [Declaration] -> Check [Declaration]

114+typeCheckAll :: Maybe ModuleName -> ModuleName -> [Declaration] -> Check [Declaration]

115115typeCheckAll _ _ [] = return []

116116typeCheckAll mainModuleName moduleName (d@(DataDeclaration name args dctors) : rest) = do

117117 rethrow (("Error in type constructor " ++ show name ++ ":\n") ++) $ do

src/Language/PureScript/TypeChecker/Types.hs+3−3

@@ -163,7 +163,7 @@ typeConstructorsAreEqual env moduleName = (==) `on` canonicalizeType moduleName

163163-- Infer the types of multiple mutually-recursive values, and return elaborated values including

164164-- type class dictionaries and type annotations.

165165--

166−typesOf :: ModuleName -> ModuleName -> [(Ident, Value)] -> Check [(Ident, (Value, Type))]

166+typesOf :: Maybe ModuleName -> ModuleName -> [(Ident, Value)] -> Check [(Ident, (Value, Type))]

167167typesOf mainModuleName moduleName vals = do

168168 tys <- fmap tidyUp . liftUnify $ do

169169 let

@@ -203,8 +203,8 @@ typesOf mainModuleName moduleName vals = do

203203 TypedValue _ val' ty <- bindNames dict' $ infer val

204204 ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)

205205 return (ident, (TypedValue True val' ty, ty))

206− -- If run-main is enabled, need to check that Main.main has type Eff eff a for some eff, a

207− when (moduleName == mainModuleName && fst e == Ident "main") $ do

206+ -- If --main is enabled, need to check that `main` has type Eff eff a for some eff, a

207+ when (Just moduleName == mainModuleName && fst e == Ident "main") $ do

208208 [eff, a] <- replicateM 2 fresh

209209 ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName (ProperName "Eff"))) (ProperName "Eff"))) eff) a

210210 -- Make sure unification variables do not escape

tests/Main.hs+1−1

@@ -66,7 +66,7 @@ assertCompiles :: FilePath -> IO ()

6666assertCompiles inputFile = do

6767 putStrLn $ "assert " ++ inputFile ++ " compiles successfully"

6868 prelude <- preludeFilename

69− assert (P.defaultOptions { P.optionsRunMain = True, P.optionsNoOptimizations = True, P.optionsEntryPoint = Just "Main" }) [prelude, inputFile] $ either (return . Just) $ \js -> do

69+ assert (P.defaultOptions { P.optionsMain = Just "Main", P.optionsNoOptimizations = True, P.optionsModules = ["Main"] }) [prelude, inputFile] $ either (return . Just) $ \js -> do

7070 args <- getArgs

7171 if "--run-js" `elem` args

7272 then do