@@ -1,127 +0,0 @@
1−-----------------------------------------------------------------------------
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
13−-----------------------------------------------------------------------------
15−{-# LANGUAGE DataKinds #-}
16−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
17−{-# LANGUAGE TupleSections #-}
21−import Data.List (isPrefixOf)
22−import Data.Maybe (fromMaybe)
23−import Data.Time.Clock
24−import Data.Traversable (traverse)
25−import qualified Data.Map as M
27−import Control.Applicative
29−import Control.Monad.Error.Class (MonadError(..))
30−import Control.Monad.IO.Class (MonadIO, liftIO)
31−import Control.Monad.Reader (MonadReader, ReaderT, runReaderT)
32−import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
33−import Control.Monad.Writer (MonadWriter, WriterT, runWriterT, tell)
35−import System.Directory (getModificationTime, doesFileExist)
36−import System.FilePath ((</>), pathSeparator)
37−import System.IO.Error (tryIOError)
39−import qualified Language.PureScript as P
40−import qualified Language.PureScript.CodeGen.JS as J
41−import qualified Language.PureScript.CoreFn as CF
46−options = P.Options False False Nothing False False False Nothing
48−modulesDir :: FilePath
49−modulesDir = ".psci_modules" ++ pathSeparator : "node_modules"
51−newtype Make a = Make { unMake :: ReaderT P.Options (WriterT P.MultipleErrors (ExceptT P.MultipleErrors IO)) a }
52− deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadWriter P.MultipleErrors, MonadReader P.Options)
54−runMake :: Make a -> IO (Either P.MultipleErrors a)
55−runMake = runExceptT . fmap fst . runWriterT . flip runReaderT options . unMake
57−makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a
59− e <- liftIO $ tryIOError io
60− either (throwError . P.singleError . f) return e
62−-- Traverse (Either e) instance (base 4.7)
63−traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
64−traverseEither _ (Left x) = pure (Left x)
65−traverseEither f (Right y) = Right <$> f y
67−buildMakeActions :: M.Map P.ModuleName (Either P.RebuildPolicy String)
68− -> M.Map P.ModuleName P.ForeignJS
69− -> P.MakeActions Make
70−buildMakeActions filePathMap foreigns =
71− P.MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
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
79− getOutputTimestamp :: P.ModuleName -> Make (Maybe UTCTime)
80− getOutputTimestamp mn = do
81− let filePath = P.runModuleName mn
82− jsFile = modulesDir </> filePath </> "index.js"
83− externsFile = modulesDir </> filePath </> "externs.purs"
84− min <$> getTimestamp jsFile <*> getTimestamp externsFile
86− readExterns :: P.ModuleName -> Make (FilePath, String)
88− let path = modulesDir </> P.runModuleName mn </> "externs.purs"
89− (path, ) <$> readTextFile path
91− codegen :: CF.Module CF.Ann -> P.Environment -> P.SupplyVar -> P.Externs -> Make ()
92− codegen m _ nextVar exts = do
93− let mn = CF.moduleName m
94− foreignInclude <- case CF.moduleName m `M.lookup` foreigns of
96− | not $ requiresForeign m -> do tell $ P.errorMessage $ P.UnnecessaryFFIModule mn path
98− | otherwise -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]
99− Nothing | requiresForeign m -> throwError . P.errorMessage $ P.MissingFFIModule mn
100− | otherwise -> return Nothing
101− pjs <- P.evalSupplyT nextVar $ P.prettyPrintJS <$> J.moduleToJs m foreignInclude
102− let filePath = P.runModuleName $ CF.moduleName m
103− jsFile = modulesDir </> filePath </> "index.js"
104− externsFile = modulesDir </> filePath </> "externs.purs"
105− foreignFile = modulesDir </> filePath </> "foreign.js"
106− writeTextFile jsFile pjs
107− maybe (return ()) (writeTextFile foreignFile) $ CF.moduleName m `M.lookup` foreigns
108− writeTextFile externsFile exts
110− requiresForeign :: CF.Module a -> Bool
111− requiresForeign = not . null . CF.moduleForeign
113− getTimestamp :: FilePath -> Make (Maybe UTCTime)
114− getTimestamp path = makeIO (const (P.SimpleErrorWrapper $ P.CannotGetFileInfo path)) $ do
115− exists <- doesFileExist path
116− traverse (const $ getModificationTime path) $ guard exists
118− readTextFile :: FilePath -> Make String
119− readTextFile path = makeIO (const (P.SimpleErrorWrapper $ P.CannotReadFile path)) $ readFile path
121− writeTextFile :: FilePath -> String -> Make ()
122− writeTextFile path text = makeIO (const (P.SimpleErrorWrapper $ P.CannotWriteFile path)) $ do
126− progress :: String -> Make ()
127− progress s = unless ("Compiling $PSCI" `isPrefixOf` s) $ liftIO . putStrLn $ s