@@ -14,7 +14,6 @@
1414
1515{-# LANGUAGE DataKinds #-}
1616{-# LANGUAGE FlexibleContexts #-}
17−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
1817{-# LANGUAGE RecordWildCards #-}
1918{-# LANGUAGE TupleSections #-}
2019
@@ -23,30 +22,20 @@ module Main where
2322import Control.Applicative
2423import Control.Monad
2524import Control.Monad.Error.Class (MonadError(..))
26−import Control.Monad.Trans.Except
27−import Control.Monad.Reader
2825import Control.Monad.Writer
2926
30−import Data.Maybe (fromMaybe)
31−import Data.Time.Clock
32−import Data.Traversable (traverse)
3327import Data.Version (showVersion)
3428import qualified Data.Map as M
3529
3630import Options.Applicative as Opts
3731
38−import System.Directory
39− (doesFileExist, getModificationTime, createDirectoryIfMissing)
40−import System.FilePath ((</>), takeDirectory)
4132import System.Exit (exitSuccess, exitFailure)
4233import System.IO (hPutStrLn, stderr)
43−import System.IO.Error (tryIOError)
4434
4535import qualified Language.PureScript as P
46−import qualified Language.PureScript.CodeGen.JS as J
47−import qualified Language.PureScript.CoreFn as CF
4836import qualified Paths_purescript as Paths
4937
38+import Make
5039
5140data PSCMakeOptions = PSCMakeOptions
5241 { pscmInput :: [FilePath]
@@ -61,46 +50,6 @@ data InputOptions = InputOptions
6150 , ioInputFiles :: [FilePath]
6251 }
6352
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−
10453compile :: PSCMakeOptions -> IO ()
10554compile (PSCMakeOptions input inputForeign outputDir opts usePrefix) = do
10655 moduleFiles <- readInput (InputOptions (P.optionsNoPrelude opts) input)
@@ -113,60 +62,27 @@ compile (PSCMakeOptions input inputForeign outputDir opts usePrefix) = do
11362 when (P.nonEmpty warnings) $
11463 hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings)
11564 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
11767 case e of
11868 Left errs -> do
11969 putStrLn (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)
12070 exitFailure
12171 Right (_, warnings') -> do
12272 when (P.nonEmpty warnings') $
123− putStrLn (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings)
73+ putStrLn (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings')
12474 exitSuccess
125− where
12675
127− getInputTimestamp :: M.Map P.ModuleName (Either P.RebuildPolicy String) -> P.ModuleName -> Make (Either P.RebuildPolicy (Maybe UTCTime))
128− getInputTimestamp filePathMap mn = do
129− let path = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap
130− traverseEither P.getTimestamp path
131−
132− getOutputTimestamp :: P.ModuleName -> Make (Maybe UTCTime)
133− getOutputTimestamp mn = do
134− let filePath = P.runModuleName mn
135− jsFile = outputDir </> filePath </> "index.js"
136− externsFile = outputDir </> filePath </> "externs.purs"
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
76+readInput :: InputOptions -> IO [(Either P.RebuildPolicy FilePath, String)]
77+readInput InputOptions{..} = forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readFile inFile
78+
79+parseInputs :: (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m)
80+ => [(Either P.RebuildPolicy FilePath, String)]
81+ -> [(FilePath, String)]
82+ -> m ([(Either P.RebuildPolicy FilePath, P.Module)], M.Map P.ModuleName String)
83+parseInputs modules foreigns =
84+ (,) <$> P.parseModulesFromFiles (either (const "") id) modules
85+ <*> P.parseForeignModulesFromFiles foreigns
17086
17187inputFile :: Parser FilePath
17288inputFile = strArgument $