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