b1385d9 · rowtype-yoga/purescript-native

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

on golang help sign in

Move codegen out of make

b1385d9Gary Burgess11 years ago

psc-make/Main.hs+46−7

compare with golang

unifiedsplit

@@ -23,18 +23,23 @@ import Control.Monad.Trans.Except

23import Control.Monad.Reader

24import Control.Monad.Writer

26−import Data.Version (showVersion)

26+import Data.Maybe (fromMaybe)

27+import Data.Time.Clock

27import Data.Traversable (traverse)

28import Data.Traversable (traverse)

29+import Data.Version (showVersion)

30+import qualified Data.Map as M

29import Options.Applicative as Opts

32import Options.Applicative as Opts

31import System.Directory

34import System.Directory

32 (doesFileExist, getModificationTime, createDirectoryIfMissing)

35 (doesFileExist, getModificationTime, createDirectoryIfMissing)

33−import System.FilePath (takeDirectory)

36+import System.FilePath ((</>), takeDirectory)

34import System.Exit (exitSuccess, exitFailure)

37import System.Exit (exitSuccess, exitFailure)

35import System.IO.Error (tryIOError)

38import System.IO.Error (tryIOError)

37import qualified Language.PureScript as P

40import qualified Language.PureScript as P

41+import qualified Language.PureScript.CodeGen.JS as J

42+import qualified Language.PureScript.CoreFn as CoreFn

38import qualified Paths_purescript as Paths

43import qualified Paths_purescript as Paths

@@ -77,6 +82,11 @@ instance P.MonadMake Make where

77 writeFile path text

82 writeFile path text

78 progress = liftIO . putStrLn

83 progress = liftIO . putStrLn

85+-- Traverse (Either e) instance (base 4.7)

86+traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)

87+traverseEither _ (Left x) = pure (Left x)

88+traverseEither f (Right y) = Right <$> f y

89+

80compile :: PSCMakeOptions -> IO ()

90compile :: PSCMakeOptions -> IO ()

81compile (PSCMakeOptions input outputDir opts usePrefix) = do

91compile (PSCMakeOptions input outputDir opts usePrefix) = do

82 modules <- P.parseModulesFromFiles (either (const "") id) <$> readInput (InputOptions (P.optionsNoPrelude opts) input)

92 modules <- P.parseModulesFromFiles (either (const "") id) <$> readInput (InputOptions (P.optionsNoPrelude opts) input)

@@ -85,19 +95,48 @@ compile (PSCMakeOptions input outputDir opts usePrefix) = do

85 print err

95 print err

86 exitFailure

96 exitFailure

87 Right ms -> do

97 Right ms -> do

88− e <- runMake opts $ P.make outputDir ms prefix

98+ e <- runMake opts $ P.make getInputTimestamp getOutputTimestamp readExterns codegen ms

89 case e of

99 case e of

90 Left errs -> do

100 Left errs -> do

91 putStrLn (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)

101 putStrLn (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)

92 exitFailure

102 exitFailure

93 Right (_, warnings) -> do

103 Right (_, warnings) -> do

94− when (P.nonEmpty warnings) $

104+ when (P.nonEmpty warnings) $

95 putStrLn (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings)

105 putStrLn (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings)

96 exitSuccess

106 exitSuccess

97 where

107 where

98− prefix = if usePrefix

108+ prefix = if usePrefix

99− then ["Generated by psc-make version " ++ showVersion Paths.version]

109+ then ["Generated by psc-make version " ++ showVersion Paths.version]

100− else []

110+ else []

111+

112+ filePathMap = M.empty -- M.fromList (map (\(fp, Module _ mn _ _) -> (mn, fp)) ms)

113+

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

115+ getInputTimestamp mn = do

116+ let inputFile = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap

117+ traverseEither P.getTimestamp inputFile

118+

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

120+ getOutputTimestamp mn = do

121+ let filePath = P.runModuleName mn

122+ jsFile = outputDir </> filePath </> "index.js"

123+ externsFile = outputDir </> filePath </> "externs.purs"

124+ min <$> P.getTimestamp jsFile <*> P.getTimestamp externsFile

125+

126+ readExterns :: P.ModuleName -> Make (FilePath, String)

127+ readExterns mn = do

128+ let path = outputDir </> P.runModuleName mn </> "externs.purs"

129+ (path, ) <$> P.readTextFile path

130+

131+ codegen :: CoreFn.Module CoreFn.Ann -> String -> P.Environment -> Integer -> Make ()

132+ codegen m exts env nextVar = do

133+ let filePath = P.runModuleName $ CoreFn.moduleName m

134+ jsFile = outputDir </> filePath </> "index.js"

135+ externsFile = outputDir </> filePath </> "externs.purs"

136+ pjs <- P.evalSupplyT nextVar $ P.prettyPrintJS <$> J.moduleToJs m Nothing

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

138+ P.writeTextFile jsFile js

139+ P.writeTextFile externsFile exts

101

140

102mkdirp :: FilePath -> IO ()

141mkdirp :: FilePath -> IO ()

103mkdirp = createDirectoryIfMissing True . takeDirectory

142mkdirp = createDirectoryIfMissing True . takeDirectory

purescript.cabal+1−1

@@ -155,7 +155,7 @@ executable psc

155executable psc-make

156 build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,

157 mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any,

158− transformers -any, transformers-compat -any

158+ time -any, transformers -any, transformers-compat -any

159 main-is: Main.hs

160 buildable: True

161 hs-source-dirs: psc-make

src/Language/PureScript.hs+20−48

@@ -41,8 +41,7 @@ import Control.Monad

41import Control.Monad.Error.Class (MonadError(..))

42import Control.Monad.Reader

43import Control.Monad.Writer

44−

44+import Control.Monad.Supply.Class (fresh)

45−import System.FilePath ((</>))

47import Language.PureScript.AST as P

46import Language.PureScript.AST as P

48import Language.PureScript.Comments as P

47import Language.PureScript.Comments as P

@@ -144,11 +143,6 @@ data RebuildPolicy

144 -- | Always rebuild this module

143 -- | Always rebuild this module

145 | RebuildAlways deriving (Show, Eq, Ord)

144 | RebuildAlways deriving (Show, Eq, Ord)

146

145

147−-- Traverse (Either e) instance (base 4.7)

148−traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)

149−traverseEither _ (Left x) = pure (Left x)

150−traverseEither f (Right y) = Right <$> f y

151−

152-- |

146-- |

153-- Compiles in "make" mode, compiling each module separately to a js files and an externs file

147-- Compiles in "make" mode, compiling each module separately to a js files and an externs file

154--

148--

@@ -156,67 +150,46 @@ traverseEither f (Right y) = Right <$> f y

156-- having to typecheck the module again.

150-- having to typecheck the module again.

157--

151--

158make :: forall m. (Functor m, Applicative m, Monad m, MonadMake m)

152make :: forall m. (Functor m, Applicative m, Monad m, MonadMake m)

159− => FilePath -> [(Either RebuildPolicy FilePath, Module)] -> [String] -> m Environment

153+ => (ModuleName -> m (Either RebuildPolicy (Maybe UTCTime)))

160−make outputDir ms prefix = do

154+ -> (ModuleName -> m (Maybe UTCTime))

155+ -> (ModuleName -> m (FilePath, String))

156+ -> (CoreFn.Module CoreFn.Ann -> String -> Environment -> Integer -> m ())

157+ -> [(Either RebuildPolicy FilePath, Module)]

158+ -> m Environment

159+make getInputTimestamp getOutputTimestamp readExterns codegen ms = do

161 noPrelude <- asks optionsNoPrelude

160 noPrelude <- asks optionsNoPrelude

162 unless noPrelude (checkPreludeIsDefined (map snd ms))

161 unless noPrelude (checkPreludeIsDefined (map snd ms))

163− let filePathMap = M.fromList (map (\(fp, Module _ mn _ _) -> (mn, fp)) ms)

164−

165 (sorted, graph) <- sortModules $ map importPrim $ if noPrelude then map snd ms else map (importPrelude . snd) ms

162 (sorted, graph) <- sortModules $ map importPrim $ if noPrelude then map snd ms else map (importPrelude . snd) ms

166−

167 mapM_ lint sorted

163 mapM_ lint sorted

168−

169 toRebuild <- foldM (\s (Module _ moduleName' _ _) -> do

164 toRebuild <- foldM (\s (Module _ moduleName' _ _) -> do

170− let filePath = runModuleName moduleName'

165+ inputTimestamp <- getInputTimestamp moduleName'

171−

166+ outputTimestamp <- getOutputTimestamp moduleName'

172− jsFile = outputDir </> filePath </> "index.js"

173− externsFile = outputDir </> filePath </> "externs.purs"

174− inputFile = fromMaybe (error "Module has no filename in 'make'") $ M.lookup moduleName' filePathMap

175−

176− jsTimestamp <- getTimestamp jsFile

177− externsTimestamp <- getTimestamp externsFile

178− inputTimestamp <- traverseEither getTimestamp inputFile

179−

180− return $ case (inputTimestamp, jsTimestamp, externsTimestamp) of

167+ return $ case (inputTimestamp, outputTimestamp) of

181− (Right (Just t1), Just t2, Just t3) | t1 < min t2 t3 -> s

168+ (Right (Just t1), Just t2) | t1 < t2 -> s

182− (Left RebuildNever, Just _, Just _) -> s

169+ (Left RebuildNever, Just _) -> s

183 _ -> S.insert moduleName' s) S.empty sorted

170 _ -> S.insert moduleName' s) S.empty sorted

184

171

185 marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted

172 marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted

186−

187 (desugared, nextVar) <- runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)

173 (desugared, nextVar) <- runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)

188−

189 evalSupplyT nextVar $ go initEnvironment desugared

174 evalSupplyT nextVar $ go initEnvironment desugared

190−

191 where

175 where

176+

192 go :: Environment -> [(Bool, Module)] -> SupplyT m Environment

177 go :: Environment -> [(Bool, Module)] -> SupplyT m Environment

193 go env [] = return env

178 go env [] = return env

194 go env ((False, m) : ms') = do

179 go env ((False, m) : ms') = do

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

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

196−

197 go env' ms'

181 go env' ms'

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

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

199− let filePath = runModuleName moduleName'

200− jsFile = outputDir </> filePath </> "index.js"

201− externsFile = outputDir </> filePath </> "externs.purs"

202

183

203 lift . progress $ "Compiling " ++ runModuleName moduleName'

184 lift . progress $ "Compiling " ++ runModuleName moduleName'

204−

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

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

206−

207 regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated

186 regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated

208−

209 let mod' = Module coms moduleName' regrouped exps

187 let mod' = Module coms moduleName' regrouped exps

210 corefn = CoreFn.moduleToCoreFn env' mod'

188 corefn = CoreFn.moduleToCoreFn env' mod'

211 [renamed] = renameInModules [corefn]

189 [renamed] = renameInModules [corefn]

212−

190+ let exts = moduleToPs mod' env'

213− pjs <- prettyPrintJS <$> moduleToJs renamed Nothing

191+ nextVar <- fresh

214− let js = unlines $ map ("// " ++) prefix ++ [pjs]

192+ lift $ codegen renamed exts env' nextVar

215− let exts = unlines $ map ("-- " ++) prefix ++ [moduleToPs mod' env']

216−

217− lift $ writeTextFile jsFile js

218− lift $ writeTextFile externsFile exts

219−

220 go env' ms'

193 go env' ms'

221

194

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

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

@@ -226,12 +199,11 @@ make outputDir ms prefix = do

226 toRebuild' = toRebuild `S.union` S.fromList deps

199 toRebuild' = toRebuild `S.union` S.fromList deps

227 (:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms'

200 (:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms'

228 rebuildIfNecessary graph toRebuild (Module _ moduleName' _ _ : ms') = do

201 rebuildIfNecessary graph toRebuild (Module _ moduleName' _ _ : ms') = do

229− let externsFile = outputDir </> runModuleName moduleName' </> "externs.purs"

202+ (path, externs) <- readExterns moduleName'

230− externs <- readTextFile externsFile

231− externsModules <- fmap (map snd) . alterErrors $ P.parseModulesFromFiles id [(externsFile, externs)]

203+ externsModules <- fmap (map snd) . alterErrors $ P.parseModulesFromFiles id [(path, externs)]

232 case externsModules of

204 case externsModules of

233 [m'@(Module _ moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'

205 [m'@(Module _ moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'

234− _ -> throwError . errorMessage . InvalidExternsFile $ externsFile

206+ _ -> throwError . errorMessage . InvalidExternsFile $ path

235 where

207 where

236 alterErrors = flip catchError $ \(MultipleErrors errs) ->

208 alterErrors = flip catchError $ \(MultipleErrors errs) ->

237 throwError . MultipleErrors $ flip map errs $ \e -> case e of

209 throwError . MultipleErrors $ flip map errs $ \e -> case e of