9a784d3 · rowtype-yoga/purescript-native

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

on golang help sign in

Merge pull request #1354 from purescript/1264

9a784d3Phil Freeman11 years ago

src/Language/PureScript/Make.hs+30−24

compare with golang

unifiedsplit

@@ -24,8 +24,8 @@ module Language.PureScript.Make

24 (

25 -- * Make API

26 RebuildPolicy(..)

27+ , ProgressMessage(..), renderProgressMessage

27 , MakeActions(..)

28 , MakeActions(..)

28− , SupplyVar()

29 , Externs()

30 , make

@@ -43,7 +43,6 @@ import Control.Monad.Trans.Except

43import Control.Monad.Reader

44import Control.Monad.Writer

45import Control.Monad.Supply

46−import Control.Monad.Supply.Class (fresh)

48import Data.Function (on)

47import Data.Function (on)

49import Data.List (sortBy, groupBy)

48import Data.List (sortBy, groupBy)

@@ -79,8 +78,22 @@ import qualified Language.PureScript.CodeGen.JS as J

79import qualified Language.PureScript.CoreFn as CF

78import qualified Language.PureScript.CoreFn as CF

80import qualified Paths_purescript as Paths

79import qualified Paths_purescript as Paths

82−-- |

81+-- | Progress messages from the make process

82+data ProgressMessage

83+ = CompilingModule ModuleName

84+ deriving (Show, Eq, Ord)

85+

86+-- | Render a progress message

87+renderProgressMessage :: ProgressMessage -> String

88+renderProgressMessage (CompilingModule mn) = "Compiling " ++ runModuleName mn

89+

83−-- Actions that require implementations when running in "make" mode.

90+-- | Actions that require implementations when running in "make" mode.

91+--

92+-- This type exists to make two things abstract:

93+--

94+-- * The particular backend being used (Javascript, C++11, etc.)

95+--

96+-- * The details of how files are read/written etc.

84--

97--

85data MakeActions m = MakeActions {

98data MakeActions m = MakeActions {

86 -- |

99 -- |

@@ -102,11 +115,11 @@ data MakeActions m = MakeActions {

102 -- |

115 -- |

103 -- Run the code generator for the module and write any required output files.

116 -- Run the code generator for the module and write any required output files.

104 --

117 --

105− , codegen :: CF.Module CF.Ann -> Environment -> SupplyVar -> Externs -> m ()

118+ , codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT m ()

106 -- |

119 -- |

107 -- Respond to a progress update.

120 -- Respond to a progress update.

108 --

121 --

109− , progress :: String -> m ()

122+ , progress :: ProgressMessage -> m ()

110 }

123 }

111

124

112-- |

125-- |

@@ -114,11 +127,6 @@ data MakeActions m = MakeActions {

114--

127--

115type Externs = String

128type Externs = String

116

129

117−-- |

118−-- A value to be used in the Supply monad.

119−--

120−type SupplyVar = Integer

121−

122-- |

130-- |

123-- Determines when to rebuild a module

131-- Determines when to rebuild a module

124--

132--

@@ -160,7 +168,7 @@ make MakeActions{..} ms = do

160 (_, env') <- lift . runCheck' env $ typeCheckModule Nothing m

168 (_, env') <- lift . runCheck' env $ typeCheckModule Nothing m

161 go env' ms'

169 go env' ms'

162 go env ((True, m@(Module coms moduleName' _ exps)) : ms') = do

170 go env ((True, m@(Module coms moduleName' _ exps)) : ms') = do

163− lift $ progress $ "Compiling " ++ runModuleName moduleName'

171+ lift . progress $ CompilingModule moduleName'

164 (checked@(Module _ _ elaborated _), env') <- lift . runCheck' env $ typeCheckModule Nothing m

172 (checked@(Module _ _ elaborated _), env') <- lift . runCheck' env $ typeCheckModule Nothing m

165 checkExhaustiveModule env' checked

173 checkExhaustiveModule env' checked

166 regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated

174 regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated

@@ -168,8 +176,7 @@ make MakeActions{..} ms = do

168 corefn = CF.moduleToCoreFn env' mod'

176 corefn = CF.moduleToCoreFn env' mod'

169 [renamed] = renameInModules [corefn]

177 [renamed] = renameInModules [corefn]

170 exts = moduleToPs mod' env'

178 exts = moduleToPs mod' env'

171− nextVar <- fresh

172− lift $ codegen renamed env' nextVar exts

179+ codegen renamed env' exts

173 go env' ms'

180 go env' ms'

174

181

175 rebuildIfNecessary :: M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]

182 rebuildIfNecessary :: M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]

@@ -264,8 +271,8 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =

264 let path = outputDir </> runModuleName mn </> "externs.purs"

271 let path = outputDir </> runModuleName mn </> "externs.purs"

265 (path, ) <$> readTextFile path

272 (path, ) <$> readTextFile path

266

273

267− codegen :: CF.Module CF.Ann -> Environment -> SupplyVar -> Externs -> Make ()

274+ codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT Make ()

268− codegen m _ nextVar exts = do

275+ codegen m _ exts = do

269 let mn = CF.moduleName m

276 let mn = CF.moduleName m

270 foreignInclude <- case mn `M.lookup` foreigns of

277 foreignInclude <- case mn `M.lookup` foreigns of

271 Just (path, _)

278 Just (path, _)

@@ -275,18 +282,17 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =

275 | otherwise -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]

282 | otherwise -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]

276 Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn

283 Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn

277 | otherwise -> return Nothing

284 | otherwise -> return Nothing

278− pjs <- evalSupplyT nextVar $ prettyPrintJS <$> J.moduleToJs m foreignInclude

285+ pjs <- prettyPrintJS <$> J.moduleToJs m foreignInclude

279 let filePath = runModuleName mn

286 let filePath = runModuleName mn

280 jsFile = outputDir </> filePath </> "index.js"

287 jsFile = outputDir </> filePath </> "index.js"

281 externsFile = outputDir </> filePath </> "externs.purs"

288 externsFile = outputDir </> filePath </> "externs.purs"

282 foreignFile = outputDir </> filePath </> "foreign.js"

289 foreignFile = outputDir </> filePath </> "foreign.js"

283 prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]

290 prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]

284 js = unlines $ map ("// " ++) prefix ++ [pjs]

291 js = unlines $ map ("// " ++) prefix ++ [pjs]

285− verboseErrorsEnabled <- asks optionsVerboseErrors

292+ lift $ do

286− when verboseErrorsEnabled $ progress $ "Writing " ++ jsFile

287− writeTextFile jsFile js

293+ writeTextFile jsFile js

288− maybe (return ()) (writeTextFile foreignFile . snd) $ mn `M.lookup` foreigns

294+ maybe (return ()) (writeTextFile foreignFile . snd) $ mn `M.lookup` foreigns

289− writeTextFile externsFile exts

295+ writeTextFile externsFile exts

290

296

291 requiresForeign :: CF.Module a -> Bool

297 requiresForeign :: CF.Module a -> Bool

292 requiresForeign = not . null . CF.moduleForeign

298 requiresForeign = not . null . CF.moduleForeign

@@ -307,5 +313,5 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =

307 mkdirp :: FilePath -> IO ()

313 mkdirp :: FilePath -> IO ()

308 mkdirp = createDirectoryIfMissing True . takeDirectory

314 mkdirp = createDirectoryIfMissing True . takeDirectory

309

315

310− progress :: String -> Make ()

316+ progress :: ProgressMessage -> Make ()

311− progress = liftIO . putStrLn

317+ progress = liftIO . putStrLn . renderProgressMessage

tests/Main.hs+10−43

@@ -69,61 +69,25 @@ import Text.Parsec (ParseError)

69modulesDir :: FilePath

70modulesDir = ".test_modules" </> "node_modules"

72−newtype Test a = Test { unTest :: ReaderT P.Options (WriterT P.MultipleErrors (ExceptT P.MultipleErrors IO)) a }

73− deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadWriter P.MultipleErrors, MonadReader P.Options)

74−

75−runTest :: Test a -> IO (Either P.MultipleErrors a)

76−runTest = runExceptT . fmap fst . runWriterT . flip runReaderT P.defaultOptions . unTest

77−

78−makeActions :: M.Map P.ModuleName (FilePath, P.ForeignJS) -> P.MakeActions Test

72+makeActions :: M.Map P.ModuleName (FilePath, P.ForeignJS) -> P.MakeActions P.Make

79−makeActions foreigns = P.MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress

73+makeActions foreigns = (P.buildMakeActions modulesDir (error "makeActions: input file map was read.") foreigns False)

74+ { P.getInputTimestamp = getInputTimestamp

75+ , P.getOutputTimestamp = getOutputTimestamp

76+ }

80 where

77 where

81− getInputTimestamp :: P.ModuleName -> Test (Either P.RebuildPolicy (Maybe UTCTime))

78+ getInputTimestamp :: P.ModuleName -> P.Make (Either P.RebuildPolicy (Maybe UTCTime))

82 getInputTimestamp mn

79 getInputTimestamp mn

83 | isSupportModule (P.runModuleName mn) = return (Left P.RebuildNever)

80 | isSupportModule (P.runModuleName mn) = return (Left P.RebuildNever)

84 | otherwise = return (Left P.RebuildAlways)

81 | otherwise = return (Left P.RebuildAlways)

85 where

82 where

86 isSupportModule = flip elem supportModules

83 isSupportModule = flip elem supportModules

88− getOutputTimestamp :: P.ModuleName -> Test (Maybe UTCTime)

85+ getOutputTimestamp :: P.ModuleName -> P.Make (Maybe UTCTime)

89 getOutputTimestamp mn = do

86 getOutputTimestamp mn = do

90 let filePath = modulesDir </> P.runModuleName mn

87 let filePath = modulesDir </> P.runModuleName mn

91 exists <- liftIO $ doesDirectoryExist filePath

88 exists <- liftIO $ doesDirectoryExist filePath

92 return (if exists then Just (error "getOutputTimestamp: read timestamp") else Nothing)

89 return (if exists then Just (error "getOutputTimestamp: read timestamp") else Nothing)

94− readExterns :: P.ModuleName -> Test (FilePath, String)

95− readExterns mn = do

96− let filePath = modulesDir </> P.runModuleName mn </> "externs.purs"

97− (filePath, ) <$> readTextFile filePath

98−

99− codegen :: CF.Module CF.Ann -> P.Environment -> P.SupplyVar -> P.Externs -> Test ()

100− codegen m _ nextVar exts = do

101− let mn = CF.moduleName m

102− foreignInclude <- case (CF.moduleName m `M.lookup` foreigns, CF.moduleForeign m) of

103− (Just _, []) -> error "Unnecessary foreign module"

104− (Just path, _) -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]

105− (Nothing, []) -> return Nothing

106− (Nothing, _) -> error "Missing foreign module"

107− pjs <- P.evalSupplyT nextVar $ P.prettyPrintJS <$> J.moduleToJs m foreignInclude

108− let filePath = P.runModuleName $ CF.moduleName m

109− jsFile = modulesDir </> filePath </> "index.js"

110− externsFile = modulesDir </> filePath </> "externs.purs"

111− foreignFile = modulesDir </> filePath </> "foreign.js"

112− writeTextFile jsFile pjs

113− maybe (return ()) (writeTextFile foreignFile . snd) $ CF.moduleName m `M.lookup` foreigns

114− writeTextFile externsFile exts

115−

116− readTextFile :: FilePath -> Test String

117− readTextFile path = liftIO $ readFile path

118−

119− writeTextFile :: FilePath -> String -> Test ()

120− writeTextFile path text = liftIO $ do

121− createDirectoryIfMissing True (takeDirectory path)

122− writeFile path text

123−

124− progress :: String -> Test ()

125− progress = liftIO . putStrLn

126−

127readInput :: [FilePath] -> IO [(FilePath, String)]

91readInput :: [FilePath] -> IO [(FilePath, String)]

128readInput inputFiles = forM inputFiles $ \inputFile -> do

92readInput inputFiles = forM inputFiles $ \inputFile -> do

129 text <- readFile inputFile

93 text <- readFile inputFile

@@ -131,6 +95,9 @@ readInput inputFiles = forM inputFiles $ \inputFile -> do

131

132type TestM = WriterT [(FilePath, String)] IO

96type TestM = WriterT [(FilePath, String)] IO

133

98+runTest :: P.Make a -> IO (Either P.MultipleErrors a)

99+runTest = fmap (fmap fst) . P.runMake P.defaultOptions

100+

134compile :: [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> IO (Either P.MultipleErrors P.Environment)

101compile :: [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> IO (Either P.MultipleErrors P.Environment)

135compile inputFiles foreigns = runTest $ do

102compile inputFiles foreigns = runTest $ do

136 fs <- liftIO $ readInput inputFiles

103 fs <- liftIO $ readInput inputFiles