@@ -0,0 +1,313 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Make
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
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+{-# LANGUAGE RankNTypes #-}
20+{-# LANGUAGE RecordWildCards #-}
21+{-# LANGUAGE ScopedTypeVariables #-}
22+
23+module Language.PureScript.Make
24+ (
25+ -- * Make API
26+ RebuildPolicy(..)
27+ , MakeActions(..)
28+ , SupplyVar()
29+ , Externs()
30+ , make
31+
32+ -- * Implementation of Make API using files on disk
33+ , Make(..)
34+ , runMake
35+ , buildMakeActions
36+ ) where
37+
38+import Control.Applicative
39+import Control.Arrow ((&&&))
40+import Control.Monad
41+import Control.Monad.Error.Class (MonadError(..))
42+import Control.Monad.Trans.Except
43+import Control.Monad.Reader
44+import Control.Monad.Writer
45+import Control.Monad.Supply
46+import Control.Monad.Supply.Class (fresh)
47+
48+import Data.Function (on)
49+import Data.List (sortBy, groupBy)
50+import Data.Maybe (fromMaybe)
51+import Data.Time.Clock
52+import Data.Traversable (traverse)
53+import Data.Version (showVersion)
54+import qualified Data.Map as M
55+import qualified Data.Set as S
56+
57+import System.Directory
58+ (doesFileExist, getModificationTime, createDirectoryIfMissing)
59+import System.FilePath ((</>), takeDirectory)
60+import System.IO.Error (tryIOError)
61+
62+
63+import Language.PureScript.AST
64+import Language.PureScript.CodeGen.Externs (moduleToPs)
65+import Language.PureScript.Environment
66+import Language.PureScript.Errors
67+import Language.PureScript.Linter
68+import Language.PureScript.ModuleDependencies
69+import Language.PureScript.Names
70+import Language.PureScript.Options
71+import Language.PureScript.Parser
72+import Language.PureScript.Pretty
73+import Language.PureScript.Renamer
74+import Language.PureScript.Sugar
75+import Language.PureScript.TypeChecker
76+import qualified Language.PureScript.Constants as C
77+
78+import qualified Language.PureScript.CodeGen.JS as J
79+import qualified Language.PureScript.CoreFn as CF
80+import qualified Paths_purescript as Paths
81+
82+-- |
83+-- Actions that require implementations when running in "make" mode.
84+--
85+data MakeActions m = MakeActions {
86+ -- |
87+ -- Get the timestamp for the input file(s) for a module. If there are multiple
88+ -- files (.purs and foreign files, for example) the timestamp should be for
89+ -- the most recently modified file.
90+ --
91+ getInputTimestamp :: ModuleName -> m (Either RebuildPolicy (Maybe UTCTime))
92+ -- |
93+ -- Get the timestamp for the output files for a module. This should be the
94+ -- timestamp for the oldest modified file, or Nothing if any of the required
95+ -- output files are missing.
96+ --
97+ , getOutputTimestamp :: ModuleName -> m (Maybe UTCTime)
98+ -- |
99+ -- Read the externs file for a module as a string and also return the actual
100+ -- path for the file.
101+ , readExterns :: ModuleName -> m (FilePath, String)
102+ -- |
103+ -- Run the code generator for the module and write any required output files.
104+ --
105+ , codegen :: CF.Module CF.Ann -> Environment -> SupplyVar -> Externs -> m ()
106+ -- |
107+ -- Respond to a progress update.
108+ --
109+ , progress :: String -> m ()
110+ }
111+
112+-- |
113+-- Generated code for an externs file.
114+--
115+type Externs = String
116+
117+-- |
118+-- A value to be used in the Supply monad.
119+--
120+type SupplyVar = Integer
121+
122+-- |
123+-- Determines when to rebuild a module
124+--
125+data RebuildPolicy
126+ -- | Never rebuild this module
127+ = RebuildNever
128+ -- | Always rebuild this module
129+ | RebuildAlways deriving (Show, Eq, Ord)
130+
131+-- |
132+-- Compiles in "make" mode, compiling each module separately to a js files and an externs file
133+--
134+-- If timestamps have not changed, the externs file can be used to provide the module's types without
135+-- having to typecheck the module again.
136+--
137+make :: forall m. (Functor m, Applicative m, Monad m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
138+ => MakeActions m
139+ -> [(Either RebuildPolicy FilePath, Module)]
140+ -> m Environment
141+make MakeActions{..} ms = do
142+ (sorted, graph) <- sortModules $ map (importPrim . snd) ms
143+ mapM_ lint sorted
144+ toRebuild <- foldM (\s (Module _ moduleName' _ _) -> do
145+ inputTimestamp <- getInputTimestamp moduleName'
146+ outputTimestamp <- getOutputTimestamp moduleName'
147+ return $ case (inputTimestamp, outputTimestamp) of
148+ (Right (Just t1), Just t2) | t1 < t2 -> s
149+ (Left RebuildNever, Just _) -> s
150+ _ -> S.insert moduleName' s) S.empty sorted
151+
152+ marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted
153+ (desugared, nextVar) <- runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)
154+ evalSupplyT nextVar $ go initEnvironment desugared
155+ where
156+
157+ go :: Environment -> [(Bool, Module)] -> SupplyT m Environment
158+ go env [] = return env
159+ go env ((False, m) : ms') = do
160+ (_, env') <- lift . runCheck' env $ typeCheckModule Nothing m
161+ go env' ms'
162+ go env ((True, m@(Module coms moduleName' _ exps)) : ms') = do
163+ lift $ progress $ "Compiling " ++ runModuleName moduleName'
164+ (Module _ _ elaborated _, env') <- lift . runCheck' env $ typeCheckModule Nothing m
165+ regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated
166+ let mod' = Module coms moduleName' regrouped exps
167+ corefn = CF.moduleToCoreFn env' mod'
168+ [renamed] = renameInModules [corefn]
169+ exts = moduleToPs mod' env'
170+ nextVar <- fresh
171+ lift $ codegen renamed env' nextVar exts
172+ go env' ms'
173+
174+ rebuildIfNecessary :: M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]
175+ rebuildIfNecessary _ _ [] = return []
176+ rebuildIfNecessary graph toRebuild (m@(Module _ moduleName' _ _) : ms') | moduleName' `S.member` toRebuild = do
177+ let deps = fromMaybe [] $ moduleName' `M.lookup` graph
178+ toRebuild' = toRebuild `S.union` S.fromList deps
179+ (:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms'
180+ rebuildIfNecessary graph toRebuild (Module _ moduleName' _ _ : ms') = do
181+ (path, externs) <- readExterns moduleName'
182+ externsModules <- fmap (map snd) . alterErrors $ parseModulesFromFiles id [(path, externs)]
183+ case externsModules of
184+ [m'@(Module _ moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'
185+ _ -> throwError . errorMessage . InvalidExternsFile $ path
186+ where
187+ alterErrors = flip catchError $ \(MultipleErrors errs) ->
188+ throwError . MultipleErrors $ flip map errs $ \e -> case e of
189+ SimpleErrorWrapper (ErrorParsingModule err) -> SimpleErrorWrapper (ErrorParsingExterns err)
190+ _ -> e
191+
192+reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]
193+reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]
194+ where
195+ combine :: (Ord a) => [(a, b)] -> M.Map a [b]
196+ combine = M.fromList . map ((fst . head) &&& map snd) . groupBy ((==) `on` fst) . sortBy (compare `on` fst)
197+
198+-- |
199+-- Add an import declaration for a module if it does not already explicitly import it.
200+--
201+addDefaultImport :: ModuleName -> Module -> Module
202+addDefaultImport toImport m@(Module coms mn decls exps) =
203+ if isExistingImport `any` decls || mn == toImport then m
204+ else Module coms mn (ImportDeclaration toImport Implicit Nothing : decls) exps
205+ where
206+ isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True
207+ isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d
208+ isExistingImport _ = False
209+
210+importPrim :: Module -> Module
211+importPrim = addDefaultImport (ModuleName [ProperName C.prim])
212+
213+-- |
214+-- A monad for running make actions
215+--
216+newtype Make a = Make { unMake :: ReaderT Options (WriterT MultipleErrors (ExceptT MultipleErrors IO)) a }
217+ deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)
218+
219+-- |
220+-- Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.
221+--
222+runMake :: Options -> Make a -> IO (Either MultipleErrors (a, MultipleErrors))
223+runMake opts = runExceptT . runWriterT . flip runReaderT opts . unMake
224+
225+makeIO :: (IOError -> ErrorMessage) -> IO a -> Make a
226+makeIO f io = do
227+ e <- liftIO $ tryIOError io
228+ either (throwError . singleError . f) return e
229+
230+-- Traverse (Either e) instance (base 4.7)
231+traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
232+traverseEither _ (Left x) = pure (Left x)
233+traverseEither f (Right y) = Right <$> f y
234+
235+-- |
236+-- A set of make actions that read and write modules from the given directory.
237+--
238+buildMakeActions :: FilePath -- ^ the output directory
239+ -> M.Map ModuleName (Either RebuildPolicy String) -- ^ a map between module names and paths to the file containing the PureScript module
240+ -> M.Map ModuleName (FilePath, ForeignJS) -- ^ a map between module name and the file containing the foreign javascript for the module
241+ -> Bool -- ^ Generate a prefix comment?
242+ -> MakeActions Make
243+buildMakeActions outputDir filePathMap foreigns usePrefix =
244+ MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
245+ where
246+
247+ getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime))
248+ getInputTimestamp mn = do
249+ let path = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap
250+ e1 <- traverseEither getTimestamp path
251+ fPath <- maybe (return Nothing) (getTimestamp . fst) $ M.lookup mn foreigns
252+ return $ fmap (max fPath) e1
253+
254+ getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)
255+ getOutputTimestamp mn = do
256+ let filePath = runModuleName mn
257+ jsFile = outputDir </> filePath </> "index.js"
258+ externsFile = outputDir </> filePath </> "externs.purs"
259+ min <$> getTimestamp jsFile <*> getTimestamp externsFile
260+
261+ readExterns :: ModuleName -> Make (FilePath, String)
262+ readExterns mn = do
263+ let path = outputDir </> runModuleName mn </> "externs.purs"
264+ (path, ) <$> readTextFile path
265+
266+ codegen :: CF.Module CF.Ann -> Environment -> SupplyVar -> Externs -> Make ()
267+ codegen m _ nextVar exts = do
268+ let mn = CF.moduleName m
269+ foreignInclude <- case mn `M.lookup` foreigns of
270+ Just (path, _)
271+ | not $ requiresForeign m -> do
272+ tell $ errorMessage $ UnnecessaryFFIModule mn path
273+ return Nothing
274+ | otherwise -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]
275+ Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn
276+ | otherwise -> return Nothing
277+ pjs <- evalSupplyT nextVar $ prettyPrintJS <$> J.moduleToJs m foreignInclude
278+ let filePath = runModuleName mn
279+ jsFile = outputDir </> filePath </> "index.js"
280+ externsFile = outputDir </> filePath </> "externs.purs"
281+ foreignFile = outputDir </> filePath </> "foreign.js"
282+ prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]
283+ js = unlines $ map ("// " ++) prefix ++ [pjs]
284+ writeTextFile jsFile js
285+ maybe (return ()) (writeTextFile foreignFile . snd) $ mn `M.lookup` foreigns
286+ writeTextFile externsFile exts
287+
288+ requiresForeign :: CF.Module a -> Bool
289+ requiresForeign = not . null . CF.moduleForeign
290+
291+ getTimestamp :: FilePath -> Make (Maybe UTCTime)
292+ getTimestamp path = makeIO (const (SimpleErrorWrapper $ CannotGetFileInfo path)) $ do
293+ exists <- doesFileExist path
294+ traverse (const $ getModificationTime path) $ guard exists
295+
296+ readTextFile :: FilePath -> Make String
297+ readTextFile path = do
298+ verboseErrorsEnabled <- asks optionsVerboseErrors
299+ makeIO (const (SimpleErrorWrapper $ CannotReadFile path)) $ do
300+ when verboseErrorsEnabled $ putStrLn $ "Reading " ++ path
301+ readFile path
302+
303+ writeTextFile :: FilePath -> String -> Make ()
304+ writeTextFile path text = makeIO (const (SimpleErrorWrapper $ CannotWriteFile path)) $ do
305+ mkdirp path
306+ putStrLn $ "Writing " ++ path
307+ writeFile path text
308+ where
309+ mkdirp :: FilePath -> IO ()
310+ mkdirp = createDirectoryIfMissing True . takeDirectory
311+
312+ progress :: String -> Make ()
313+ progress = liftIO . putStrLn