8df45c5 · rowtype-yoga/purescript-native

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

on golang help sign in

Use a record for Make actions

8df45c5Gary Burgess11 years ago

psc-make/Main.hs+14−98

compare with golang

unifiedsplit

@@ -14,7 +14,6 @@

15{-# LANGUAGE DataKinds #-}

16{-# LANGUAGE FlexibleContexts #-}

17−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

18{-# LANGUAGE RecordWildCards #-}

17{-# LANGUAGE RecordWildCards #-}

19{-# LANGUAGE TupleSections #-}

18{-# LANGUAGE TupleSections #-}

@@ -23,30 +22,20 @@ module Main where

23import Control.Applicative

22import Control.Applicative

24import Control.Monad

23import Control.Monad

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

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

26−import Control.Monad.Trans.Except

27−import Control.Monad.Reader

28import Control.Monad.Writer

25import Control.Monad.Writer

30−import Data.Maybe (fromMaybe)

31−import Data.Time.Clock

32−import Data.Traversable (traverse)

33import Data.Version (showVersion)

27import Data.Version (showVersion)

34import qualified Data.Map as M

28import qualified Data.Map as M

36import Options.Applicative as Opts

30import Options.Applicative as Opts

38−import System.Directory

39− (doesFileExist, getModificationTime, createDirectoryIfMissing)

40−import System.FilePath ((</>), takeDirectory)

41import System.Exit (exitSuccess, exitFailure)

32import System.Exit (exitSuccess, exitFailure)

42import System.IO (hPutStrLn, stderr)

33import System.IO (hPutStrLn, stderr)

43−import System.IO.Error (tryIOError)

45import qualified Language.PureScript as P

35import qualified Language.PureScript as P

46−import qualified Language.PureScript.CodeGen.JS as J

47−import qualified Language.PureScript.CoreFn as CF

48import qualified Paths_purescript as Paths

36import qualified Paths_purescript as Paths

38+import Make

51data PSCMakeOptions = PSCMakeOptions

40data PSCMakeOptions = PSCMakeOptions

52 { pscmInput :: [FilePath]

41 { pscmInput :: [FilePath]

@@ -61,46 +50,6 @@ data InputOptions = InputOptions

61 , ioInputFiles :: [FilePath]

50 , ioInputFiles :: [FilePath]

62 }

51 }

64−readInput :: InputOptions -> IO [(Either P.RebuildPolicy FilePath, String)]

65−readInput InputOptions{..} = forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readFile inFile

66−

67−newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (WriterT P.MultipleErrors (ExceptT P.MultipleErrors IO)) a }

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

69−

70−runMake :: P.Options P.Make -> Make a -> IO (Either P.MultipleErrors (a, P.MultipleErrors))

71−runMake opts = runExceptT . runWriterT . flip runReaderT opts . unMake

72−

73−makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a

74−makeIO f io = do

75− e <- liftIO $ tryIOError io

76− either (throwError . P.singleError . f) return e

77−

78−instance P.MonadMake Make where

79− getTimestamp path = makeIO (const (P.SimpleErrorWrapper $ P.CannotGetFileInfo path)) $ do

80− exists <- doesFileExist path

81− traverse (const $ getModificationTime path) $ guard exists

82− readTextFile path = makeIO (const (P.SimpleErrorWrapper $ P.CannotReadFile path)) $ do

83− putStrLn $ "Reading " ++ path

84− readFile path

85− writeTextFile path text = makeIO (const (P.SimpleErrorWrapper $ P.CannotWriteFile path)) $ do

86− mkdirp path

87− putStrLn $ "Writing " ++ path

88− writeFile path text

89− progress = liftIO . putStrLn

90−

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

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

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

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

95−

96−parseInputs :: (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m)

97− => [(Either P.RebuildPolicy FilePath, String)]

98− -> [(FilePath, String)]

99− -> m ([(Either P.RebuildPolicy FilePath, P.Module)], M.Map P.ModuleName String)

100−parseInputs modules foreigns =

101− (,) <$> P.parseModulesFromFiles (either (const "") id) modules

102− <*> P.parseForeignModulesFromFiles foreigns

103−

104compile :: PSCMakeOptions -> IO ()

53compile :: PSCMakeOptions -> IO ()

105compile (PSCMakeOptions input inputForeign outputDir opts usePrefix) = do

54compile (PSCMakeOptions input inputForeign outputDir opts usePrefix) = do

106 moduleFiles <- readInput (InputOptions (P.optionsNoPrelude opts) input)

55 moduleFiles <- readInput (InputOptions (P.optionsNoPrelude opts) input)

@@ -113,60 +62,27 @@ compile (PSCMakeOptions input inputForeign outputDir opts usePrefix) = do

113 when (P.nonEmpty warnings) $

62 when (P.nonEmpty warnings) $

114 hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings)

63 hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings)

115 let filePathMap = M.fromList $ map (\(fp, P.Module _ mn _ _) -> (mn, fp)) ms

64 let filePathMap = M.fromList $ map (\(fp, P.Module _ mn _ _) -> (mn, fp)) ms

116− e <- runMake opts $ P.make (getInputTimestamp filePathMap) getOutputTimestamp readExterns (codegen foreigns) ms

65+ makeActions = buildMakeActions outputDir filePathMap foreigns usePrefix

66+ e <- runMake opts $ P.make makeActions ms

117 case e of

67 case e of

118 Left errs -> do

68 Left errs -> do

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

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

120 exitFailure

70 exitFailure

121 Right (_, warnings') -> do

71 Right (_, warnings') -> do

122 when (P.nonEmpty warnings') $

72 when (P.nonEmpty warnings') $

123− putStrLn (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings)

73+ putStrLn (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings')

124 exitSuccess

74 exitSuccess

125− where

126

127− getInputTimestamp :: M.Map P.ModuleName (Either P.RebuildPolicy String) -> P.ModuleName -> Make (Either P.RebuildPolicy (Maybe UTCTime))

76+readInput :: InputOptions -> IO [(Either P.RebuildPolicy FilePath, String)]

128− getInputTimestamp filePathMap mn = do

77+readInput InputOptions{..} = forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readFile inFile

129− let path = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap

78+

130− traverseEither P.getTimestamp path

79+parseInputs :: (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m)

131−

80+ => [(Either P.RebuildPolicy FilePath, String)]

132− getOutputTimestamp :: P.ModuleName -> Make (Maybe UTCTime)

81+ -> [(FilePath, String)]

133− getOutputTimestamp mn = do

82+ -> m ([(Either P.RebuildPolicy FilePath, P.Module)], M.Map P.ModuleName String)

134− let filePath = P.runModuleName mn

83+parseInputs modules foreigns =

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

84+ (,) <$> P.parseModulesFromFiles (either (const "") id) modules

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

85+ <*> P.parseForeignModulesFromFiles foreigns

137− min <$> P.getTimestamp jsFile <*> P.getTimestamp externsFile

138−

139− readExterns :: P.ModuleName -> Make (FilePath, String)

140− readExterns mn = do

141− let path = outputDir </> P.runModuleName mn </> "externs.purs"

142− (path, ) <$> P.readTextFile path

143−

144− codegen :: M.Map P.ModuleName String

145− -> CF.Module CF.Ann

146− -> String

147− -> P.Environment

148− -> Integer

149− -> Make ()

150− codegen foreigns m exts _ nextVar = do

151− let requiresForeign = not $ null (CF.moduleForeign m)

152− foreignInclude <- case CF.moduleName m `M.lookup` foreigns of

153− Just _ | not requiresForeign -> error "Found unnecessary foreign module"

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

155− Nothing | requiresForeign -> error "Foreign module missing"

156− | otherwise -> return Nothing

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

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

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

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

161− foreignFile = outputDir </> filePath </> "foreign.js"

162− prefix = ["Generated by psc-make version " ++ showVersion Paths.version | usePrefix]

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

164− P.writeTextFile jsFile js

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

166− P.writeTextFile externsFile exts

167−

168−mkdirp :: FilePath -> IO ()

169−mkdirp = createDirectoryIfMissing True . takeDirectory

170

171inputFile :: Parser FilePath

87inputFile :: Parser FilePath

172inputFile = strArgument $

88inputFile = strArgument $

psc-make/Make.hsnew file+132

@@ -0,0 +1,132 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Make

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+{-# LANGUAGE DataKinds #-}

16+{-# LANGUAGE FlexibleContexts #-}

17+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

18+{-# LANGUAGE TupleSections #-}

19+

20+module Make

21+ ( Make(..)

22+ , runMake

23+ , buildMakeActions

24+ ) where

25+

26+import Control.Applicative

27+import Control.Monad

28+import Control.Monad.Error.Class (MonadError(..))

29+import Control.Monad.Trans.Except

30+import Control.Monad.Reader

31+import Control.Monad.Writer

32+

33+import Data.Maybe (fromMaybe)

34+import Data.Time.Clock

35+import Data.Traversable (traverse)

36+import Data.Version (showVersion)

37+import qualified Data.Map as M

38+

39+import System.Directory

40+ (doesFileExist, getModificationTime, createDirectoryIfMissing)

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

42+import System.IO.Error (tryIOError)

43+

44+import qualified Language.PureScript as P

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

46+import qualified Language.PureScript.CoreFn as CF

47+import qualified Paths_purescript as Paths

48+

49+newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (WriterT P.MultipleErrors (ExceptT P.MultipleErrors IO)) a }

50+ deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadWriter P.MultipleErrors, MonadReader (P.Options P.Make))

51+

52+runMake :: P.Options P.Make -> Make a -> IO (Either P.MultipleErrors (a, P.MultipleErrors))

53+runMake opts = runExceptT . runWriterT . flip runReaderT opts . unMake

54+

55+makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a

56+makeIO f io = do

57+ e <- liftIO $ tryIOError io

58+ either (throwError . P.singleError . f) return e

59+

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

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

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

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

64+

65+buildMakeActions :: FilePath

66+ -> M.Map P.ModuleName (Either P.RebuildPolicy String)

67+ -> M.Map P.ModuleName String

68+ -> Bool

69+ -> P.MakeActions Make

70+buildMakeActions outputDir filePathMap foreigns usePrefix =

71+ P.MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress

72+ where

73+

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

75+ getInputTimestamp mn = do

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

77+ traverseEither getTimestamp path

78+

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

80+ getOutputTimestamp mn = do

81+ let filePath = P.runModuleName mn

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

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

84+ min <$> getTimestamp jsFile <*> getTimestamp externsFile

85+

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

87+ readExterns mn = do

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

89+ (path, ) <$> readTextFile path

90+

91+ codegen :: CF.Module CF.Ann -> String -> P.Environment -> Integer -> Make ()

92+ codegen m exts _ nextVar = do

93+ foreignInclude <- case CF.moduleName m `M.lookup` foreigns of

94+ Just _ | not $ requiresForeign m -> error "Found unnecessary foreign module"

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

96+ Nothing | requiresForeign m -> error "Foreign module missing"

97+ | otherwise -> return Nothing

98+ pjs <- P.evalSupplyT nextVar $ P.prettyPrintJS <$> J.moduleToJs m foreignInclude

99+ let filePath = P.runModuleName $ CF.moduleName m

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

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

102+ foreignFile = outputDir </> filePath </> "foreign.js"

103+ prefix = ["Generated by psc-make version " ++ showVersion Paths.version | usePrefix]

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

105+ writeTextFile jsFile js

106+ maybe (return ()) (writeTextFile foreignFile) $ CF.moduleName m `M.lookup` foreigns

107+ writeTextFile externsFile exts

108+

109+ requiresForeign :: CF.Module a -> Bool

110+ requiresForeign = not . null . CF.moduleForeign

111+

112+ getTimestamp :: FilePath -> Make (Maybe UTCTime)

113+ getTimestamp path = makeIO (const (P.SimpleErrorWrapper $ P.CannotGetFileInfo path)) $ do

114+ exists <- doesFileExist path

115+ traverse (const $ getModificationTime path) $ guard exists

116+

117+ readTextFile :: FilePath -> Make String

118+ readTextFile path = makeIO (const (P.SimpleErrorWrapper $ P.CannotReadFile path)) $ do

119+ putStrLn $ "Reading " ++ path

120+ readFile path

121+

122+ writeTextFile :: FilePath -> String -> Make ()

123+ writeTextFile path text = makeIO (const (P.SimpleErrorWrapper $ P.CannotWriteFile path)) $ do

124+ mkdirp path

125+ putStrLn $ "Writing " ++ path

126+ writeFile path text

127+ where

128+ mkdirp :: FilePath -> IO ()

129+ mkdirp = createDirectoryIfMissing True . takeDirectory

130+

131+ progress :: String -> Make ()

132+ progress = liftIO . putStrLn

src/Language/PureScript.hs+34−28

@@ -15,6 +15,7 @@

16{-# LANGUAGE DataKinds #-}

17{-# LANGUAGE FlexibleContexts #-}

18+{-# LANGUAGE RecordWildCards #-}

18{-# LANGUAGE ScopedTypeVariables #-}

19{-# LANGUAGE ScopedTypeVariables #-}

20module Language.PureScript

21module Language.PureScript

@@ -22,7 +23,7 @@ module Language.PureScript

22 , compile

23 , compile

23 , compile'

24 , compile'

24 , RebuildPolicy(..)

25 , RebuildPolicy(..)

25− , MonadMake(..)

26+ , MakeActions(..)

26 , make

27 , make

27 , version

28 , version

28 ) where

29 ) where

@@ -113,26 +114,34 @@ compile' env ms = do

113-- |

114-- |

114-- A type class which collects the IO actions we need to be able to run in "make" mode

115-- A type class which collects the IO actions we need to be able to run in "make" mode

115--

116--

116−class (MonadReader (P.Options P.Make) m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MonadMake m where

117+--class (MonadReader (P.Options P.Make) m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MonadMake m where

117− -- |

118+-- -- |

118− -- Get a file timestamp

119+-- -- Get a file timestamp

119− --

120+-- --

120− getTimestamp :: FilePath -> m (Maybe UTCTime)

121+-- getTimestamp :: FilePath -> m (Maybe UTCTime)

121−

122+

122− -- |

123+-- -- |

123− -- Read a file as a string

124+-- -- Read a file as a string

124− --

125+-- --

125− readTextFile :: FilePath -> m String

126+-- readTextFile :: FilePath -> m String

126−

127+

127− -- |

128+-- -- |

128− -- Write a text file

129+-- -- Write a text file

129− --

130+-- --

130− writeTextFile :: FilePath -> String -> m ()

131+-- writeTextFile :: FilePath -> String -> m ()

131−

132+

132− -- |

133+-- -- |

133− -- Respond to a progress update

134+-- -- Respond to a progress update

134− --

135+-- --

135− progress :: String -> m ()

136+-- progress :: String -> m ()

137+

138+data MakeActions m = MakeActions

139+ { getInputTimestamp :: ModuleName -> m (Either RebuildPolicy (Maybe UTCTime))

140+ , getOutputTimestamp :: ModuleName -> m (Maybe UTCTime)

141+ , readExterns :: ModuleName -> m (FilePath, String)

142+ , codegen :: CoreFn.Module CoreFn.Ann -> String -> Environment -> Integer -> m ()

143+ , progress :: String -> m ()

144+ }

136

145

137-- |

146-- |

138-- Determines when to rebuild a module

147-- Determines when to rebuild a module

@@ -149,14 +158,11 @@ data RebuildPolicy

149-- If timestamps have not changed, the externs file can be used to provide the module's types without

158-- If timestamps have not changed, the externs file can be used to provide the module's types without

150-- having to typecheck the module again.

159-- having to typecheck the module again.

151--

160--

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

161+make :: forall m. (Functor m, Applicative m, Monad m, MonadReader (P.Options P.Make) m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

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

162+ => MakeActions m

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

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

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

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

163 -> [(Either RebuildPolicy FilePath, Module)]

158 -> m Environment

164 -> m Environment

159−make getInputTimestamp getOutputTimestamp readExterns codegen ms = do

165+make MakeActions{..} ms = do

160 noPrelude <- asks optionsNoPrelude

166 noPrelude <- asks optionsNoPrelude

161 unless noPrelude (checkPreludeIsDefined (map snd ms))

167 unless noPrelude (checkPreludeIsDefined (map snd ms))

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

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

@@ -181,7 +187,7 @@ make getInputTimestamp getOutputTimestamp readExterns codegen ms = do

181 go env' ms'

187 go env' ms'

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

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

183

189

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

190+ lift $ progress $ "Compiling " ++ runModuleName moduleName'

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

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

186 regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated

192 regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated

187 let mod' = Module coms moduleName' regrouped exps

193 let mod' = Module coms moduleName' regrouped exps