9a784d3 · rowtype-yoga/purescript-native

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

Merge pull request #1354 from purescript/1264

MakeActions changes

commit9a784d3d6e9bd09969d3a99629115f984f15ad4a authorPhil Freeman <paf31@cantab.net> dateMon 10 Aug 2015, 09:39 (11 years ago) parentf2ce44f 6779b70

2 files changed+40−67

compare with golang

unifiedsplit

src/Language/PureScript/Make.hs+30−24 tests/Main.hs+10−43

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

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

2424 (

2525 -- * Make API

2626 RebuildPolicy(..)

27+ , ProgressMessage(..), renderProgressMessage

2728 , MakeActions(..)

28− , SupplyVar()

2929 , Externs()

3030 , make

3131

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

4343import Control.Monad.Reader

4444import Control.Monad.Writer

4545import Control.Monad.Supply

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

4746

4847import Data.Function (on)

4948import Data.List (sortBy, groupBy)

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

7978import qualified Language.PureScript.CoreFn as CF

8079import qualified Paths_purescript as Paths

8180

82−-- |

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

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+

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.

8497--

8598data MakeActions m = MakeActions {

8699 -- |

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

102115 -- |

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

104117 --

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

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

106119 -- |

107120 -- Respond to a progress update.

108121 --

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

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

110123 }

111124

112125-- |

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

114127--

115128type Externs = String

116129

117−-- |

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

119−--

120−type SupplyVar = Integer

121−

122130-- |

123131-- Determines when to rebuild a module

124132--

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

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

161169 go env' ms'

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

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

171+ lift . progress $ CompilingModule moduleName'

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

165173 checkExhaustiveModule env' checked

166174 regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated

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

168176 corefn = CF.moduleToCoreFn env' mod'

169177 [renamed] = renameInModules [corefn]

170178 exts = moduleToPs mod' env'

171− nextVar <- fresh

172− lift $ codegen renamed env' nextVar exts

179+ codegen renamed env' exts

173180 go env' ms'

174181

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

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

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

265272 (path, ) <$> readTextFile path

266273

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

268− codegen m _ nextVar exts = do

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

275+ codegen m _ exts = do

269276 let mn = CF.moduleName m

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

271278 Just (path, _)

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

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

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

277284 | otherwise -> return Nothing

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

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

279286 let filePath = runModuleName mn

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

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

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

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

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

285− verboseErrorsEnabled <- asks optionsVerboseErrors

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

287− writeTextFile jsFile js

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

289− writeTextFile externsFile exts

292+ lift $ do

293+ writeTextFile jsFile js

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

295+ writeTextFile externsFile exts

290296

291297 requiresForeign :: CF.Module a -> Bool

292298 requiresForeign = not . null . CF.moduleForeign

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

307313 mkdirp :: FilePath -> IO ()

308314 mkdirp = createDirectoryIfMissing True . takeDirectory

309315

310− progress :: String -> Make ()

311− progress = liftIO . putStrLn

316+ progress :: ProgressMessage -> Make ()

317+ progress = liftIO . putStrLn . renderProgressMessage

tests/Main.hs+10−43

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

6969modulesDir :: FilePath

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

7171

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

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

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

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

74+ { P.getInputTimestamp = getInputTimestamp

75+ , P.getOutputTimestamp = getOutputTimestamp

76+ }

8077 where

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

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

8279 getInputTimestamp mn

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

8481 | otherwise = return (Left P.RebuildAlways)

8582 where

8683 isSupportModule = flip elem supportModules

8784

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

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

8986 getOutputTimestamp mn = do

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

9188 exists <- liftIO $ doesDirectoryExist filePath

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

9390

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−

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

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

12993 text <- readFile inputFile

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

13195

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

13397

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

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

100+

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

135102compile inputFiles foreigns = runTest $ do

136103 fs <- liftIO $ readInput inputFiles