20e7de4 · rowtype-yoga/purescript-native

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

on golang help sign in

Merge pull request #192 from garyb/master

20e7de4Phil Freeman13 years ago

docs/source/intro.rst+2−2

compare with golang

unifiedsplit

@@ -47,9 +47,9 @@ The following options are supported:

47--tco Perform tail-call elimination on the generated Javascript.

48--no-prelude Do not include the Prelude in the generated Javascript.

49--magic-do Overload the `do` keyword to inline calls to `bind` for the `Eff` monad, to generate more efficient code.

50−--run-main Generate a call to `Main.main` after all other generated Javascript.

50+--main Generate a call to `main` in the specified module after all other generated Javascript. Defaults to `Main` if the option is used but no value is provided.

51+--module If specified, any code which is not referenced transitively from this module will be removed. This argument can be used multiple times.

51--browser-namespace Specify the namespace that PureScript modules will be exported to when running in the browser.

52--browser-namespace Specify the namespace that PureScript modules will be exported to when running in the browser.

52−--entry-point Specify the entry-point module (usually Main). If specified, code which is not referenced transitively from this module will be removed.

54Motivation

55----------

psc/Main.hs+7−7

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

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

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

89−runMain :: Term Bool

89+runMain :: Term (Maybe String)

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

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

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

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

93noOpts :: Term Bool

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

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

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

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

100

101−entryPoint :: Term (Maybe String)

101+dceModules :: Term [String]

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

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

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

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." }

104

105options :: 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

107

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

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

psci/Main.hs+1−1

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

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

37options :: P.Options

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

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

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

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

src/Language/PureScript.hs+15−13

@@ -30,10 +30,10 @@ import Language.PureScript.ModuleDependencies as P

30import Language.PureScript.DeadCodeElimination as P

32import Data.List (intercalate)

33−import Data.Maybe (mapMaybe)

33+import Data.Maybe (mapMaybe, fromMaybe)

34import Control.Monad (when, forM)

35import Control.Monad.State.Lazy

36−import Control.Applicative ((<$>))

36+import Control.Applicative ((<$>), (<|>))

37import qualified Data.Map as M

39-- |

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

47--

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

49--

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.

51--

52−-- * Eliminate dead code

52+-- * Eliminate dead code.

53--

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

55--

@@ -61,16 +61,18 @@ compile opts ms = do

61 desugared <- desugar sorted

62 (elaborated, env) <- runCheck $ forM desugared $ \(Module moduleName decls) -> do

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

64− Module moduleName <$> typeCheckAll (ModuleName moduleName) decls

64+ Module moduleName <$> typeCheckAll mainModuleIdent (ModuleName moduleName) decls

65 regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

66− let entryPoint = optionsEntryPoint opts

66+ let entryPoints = optionsModules opts

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

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

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

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

70− js' <- case () of

70+ js' <- case optionsMain opts of

71− _ | optionsRunMain opts -> do

71+ Just mainModuleName -> do

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

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

73− Left "Main.main is undefined"

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

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

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

75− | otherwise -> return js

75+ _ -> return js

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

77+ where

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

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

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

30-- |

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

32--

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

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

34−eliminateDeadCode env entryPoint ms =

34+eliminateDeadCode env entryPoints ms =

35 let declarations = concatMap (declarationsByModule env) ms

36 (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

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

40type Key = (ModuleName, Either Ident ProperName)

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

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

32 --

33 , optionsMagicDo :: Bool

34 -- |

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.

36 --

37 --

37− , optionsRunMain :: Bool

38+ , optionsMain :: Maybe String

38 -- |

39 -- |

39 -- Skip all optimizations

40 -- Skip all optimizations

40 --

41 --

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

45 --

46 --

46 , optionsBrowserNamespace :: String

47 , optionsBrowserNamespace :: String

47 -- |

48 -- |

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

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

49 --

50 --

50− , optionsEntryPoint :: Maybe String

51+ , optionsModules :: [String]

51 } deriving Show

52 } deriving Show

53-- |

54-- |

54-- Default compiler options

55-- Default compiler options

55--

56--

56defaultOptions :: Options

57defaultOptions :: 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+28−28

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

111--

112-- * Process module imports

113--

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

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

115−typeCheckAll _ [] = return []

115+typeCheckAll _ _ [] = return []

116−typeCheckAll moduleName (d@(DataDeclaration name args dctors) : rest) = do

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

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

118 typeIsNotDefined moduleName name

119 ctorKind <- kindsOf moduleName name args (concatMap snd dctors)

120 addDataType moduleName name args dctors ctorKind

121− ds <- typeCheckAll moduleName rest

121+ ds <- typeCheckAll mainModuleName moduleName rest

122 return $ d : ds

123−typeCheckAll moduleName (d@(DataBindingGroupDeclaration tys) : rest) = do

123+typeCheckAll mainModuleName moduleName (d@(DataBindingGroupDeclaration tys) : rest) = do

124 rethrow ("Error in data binding group:\n" ++) $ do

125 let syns = mapMaybe toTypeSynonym tys

126 let dataDecls = mapMaybe toDataDecl tys

@@ -131,48 +131,48 @@ typeCheckAll moduleName (d@(DataBindingGroupDeclaration tys) : rest) = do

131 forM_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do

132 typeIsNotDefined moduleName name

133 addTypeSynonym moduleName name args ty kind

134− ds <- typeCheckAll moduleName rest

134+ ds <- typeCheckAll mainModuleName moduleName rest

135 return $ d : ds

136 where

137 toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty)

138 toTypeSynonym _ = Nothing

139 toDataDecl (DataDeclaration nm args dctors) = Just (nm, args, dctors)

140 toDataDecl _ = Nothing

141−typeCheckAll moduleName (d@(TypeSynonymDeclaration name args ty) : rest) = do

141+typeCheckAll mainModuleName moduleName (d@(TypeSynonymDeclaration name args ty) : rest) = do

142 rethrow (("Error in type synonym " ++ show name ++ ":\n") ++) $ do

143 typeIsNotDefined moduleName name

144 kind <- kindsOf moduleName name args [ty]

145 addTypeSynonym moduleName name args ty kind

146− ds <- typeCheckAll moduleName rest

146+ ds <- typeCheckAll mainModuleName moduleName rest

147 return $ d : ds

148−typeCheckAll _ (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"

148+typeCheckAll _ _ (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"

149−typeCheckAll moduleName (ValueDeclaration name [] Nothing val : rest) = do

149+typeCheckAll mainModuleName moduleName (ValueDeclaration name [] Nothing val : rest) = do

150 d <- rethrow (("Error in declaration " ++ show name ++ ":\n") ++) $ do

151 valueIsNotDefined moduleName name

152− [(_, (val', ty))] <- typesOf moduleName [(name, val)]

152+ [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]

153 addValue moduleName name ty

154 return $ ValueDeclaration name [] Nothing val'

155− ds <- typeCheckAll moduleName rest

155+ ds <- typeCheckAll mainModuleName moduleName rest

156 return $ d : ds

157−typeCheckAll _ (ValueDeclaration _ _ _ _ : _) = error "Binders were not desugared"

157+typeCheckAll _ _ (ValueDeclaration _ _ _ _ : _) = error "Binders were not desugared"

158−typeCheckAll moduleName (BindingGroupDeclaration vals : rest) = do

158+typeCheckAll mainModuleName moduleName (BindingGroupDeclaration vals : rest) = do

159 d <- rethrow (("Error in binding group " ++ show (map fst vals) ++ ":\n") ++) $ do

160 forM_ (map fst vals) $ \name ->

161 valueIsNotDefined moduleName name

162− tys <- typesOf moduleName vals

162+ tys <- typesOf mainModuleName moduleName vals

163 vals' <- forM (zip (map fst vals) (map snd tys)) $ \(name, (val, ty)) -> do

164 addValue moduleName name ty

165 return (name, val)

166 return $ BindingGroupDeclaration vals'

167− ds <- typeCheckAll moduleName rest

167+ ds <- typeCheckAll mainModuleName moduleName rest

168 return $ d : ds

169−typeCheckAll moduleName (d@(ExternDataDeclaration name kind) : rest) = do

169+typeCheckAll mainModuleName moduleName (d@(ExternDataDeclaration name kind) : rest) = do

170 env <- getEnv

171 guardWith (show name ++ " is already defined") $ not $ M.member (moduleName, name) (types env)

172 putEnv $ env { types = M.insert (moduleName, name) (kind, TypeSynonym) (types env) }

173− ds <- typeCheckAll moduleName rest

173+ ds <- typeCheckAll mainModuleName moduleName rest

174 return $ d : ds

175−typeCheckAll moduleName (d@(ExternDeclaration importTy name _ ty) : rest) = do

175+typeCheckAll mainModuleName moduleName (d@(ExternDeclaration importTy name _ ty) : rest) = do

176 rethrow (("Error in foreign import declaration " ++ show name ++ ":\n") ++) $ do

177 env <- getEnv

178 kind <- kindOf moduleName ty

@@ -180,14 +180,14 @@ typeCheckAll moduleName (d@(ExternDeclaration importTy name _ ty) : rest) = do

180 case M.lookup (moduleName, name) (names env) of

181 Just _ -> throwError $ show name ++ " is already defined"

182 Nothing -> putEnv (env { names = M.insert (moduleName, name) (qualifyAllUnqualifiedNames moduleName env ty, Extern importTy) (names env) })

183− ds <- typeCheckAll moduleName rest

183+ ds <- typeCheckAll mainModuleName moduleName rest

184 return $ d : ds

185−typeCheckAll moduleName (d@(FixityDeclaration _ name) : rest) = do

185+typeCheckAll mainModuleName moduleName (d@(FixityDeclaration _ name) : rest) = do

186− ds <- typeCheckAll moduleName rest

186+ ds <- typeCheckAll mainModuleName moduleName rest

187 env <- getEnv

188 guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (moduleName, Op name) $ names env

189 return $ d : ds

190−typeCheckAll currentModule (d@(ImportDeclaration moduleName idents) : rest) = do

190+typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName idents) : rest) = do

191 env <- getEnv

192 rethrow errorMessage $ do

193 guardWith ("Module " ++ show moduleName ++ " does not exist") $ moduleExists env

@@ -199,7 +199,7 @@ typeCheckAll currentModule (d@(ImportDeclaration moduleName idents) : rest) = do

199 shadowIdents (lefts idents') env

200 shadowTypes (rights idents') env

201 shadowTypeClassInstances env

202− ds <- typeCheckAll currentModule rest

202+ ds <- typeCheckAll mainModuleName currentModule rest

203 return $ d : ds

204 where

205 errorMessage = (("Error in import declaration " ++ show moduleName ++ ":\n") ++)

@@ -243,16 +243,16 @@ typeCheckAll currentModule (d@(ImportDeclaration moduleName idents) : rest) = do

243 constructs (TypeApp (TypeApp t _) ty) pn | t == tyFunction = ty `constructs` pn

244 constructs (TypeApp ty _) pn = ty `constructs` pn

245 constructs fn _ = error $ "Invalid arguments to constructs: " ++ show fn

246−typeCheckAll moduleName (d@(TypeClassDeclaration _ _ _) : rest) = do

246+typeCheckAll mainModuleName moduleName (d@(TypeClassDeclaration _ _ _) : rest) = do

247 env <- getEnv

248− ds <- typeCheckAll moduleName rest

248+ ds <- typeCheckAll mainModuleName moduleName rest

249 return $ qualifyAllUnqualifiedNames moduleName env d : ds

250−typeCheckAll moduleName (d@(TypeInstanceDeclaration deps className ty _) : rest) = do

250+typeCheckAll mainModuleName moduleName (d@(TypeInstanceDeclaration deps className ty _) : rest) = do

251 env <- getEnv

252 dictName <- Check . lift $ mkDictionaryValueName moduleName className ty

253 checkTypeClassInstance moduleName ty

254 forM_ deps $ checkTypeClassInstance moduleName . snd

255 addTypeClassDictionaries (qualifyAllUnqualifiedNames moduleName env

256 [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className ty (Just deps) TCDRegular])

257− ds <- typeCheckAll moduleName rest

257+ ds <- typeCheckAll mainModuleName moduleName rest

258 return $ qualifyAllUnqualifiedNames moduleName env d : ds

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

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

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

164-- type class dictionaries and type annotations.

165--

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

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

167−typesOf moduleName vals = do

167+typesOf mainModuleName moduleName vals = do

168 tys <- fmap tidyUp . liftUnify $ do

169 let

170 -- Map each declaration to a name/value pair, with an optional type, if the declaration is typed

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

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

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

205 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

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

207− when (moduleName == ModuleName (ProperName "Main") && fst e == Ident "main") $ do

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

208 [eff, a] <- replicateM 2 fresh

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

210 -- Make sure unification variables do not escape

tests/Main.hs+1−1

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

66assertCompiles inputFile = do

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

68 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

70 args <- getArgs

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

72 then do