@@ -13,7 +13,7 @@
1313--
1414-----------------------------------------------------------------------------
1515
16−module Language.PureScript (module P, compile) where
16+module Language.PureScript (module P, compile, MonadMake(..), make) where
1717
1818import Language.PureScript.Values as P
1919import Language.PureScript.Types as P
@@ -34,10 +34,12 @@ import Language.PureScript.DeadCodeElimination as P
3434import qualified Language.PureScript.Constants as C
3535
3636import Data.List (intercalate)
37−import Data.Maybe (mapMaybe)
37+import Data.Time.Clock
38+import Data.Maybe (fromMaybe, mapMaybe)
3839import Control.Monad.State.Lazy
3940import Control.Applicative ((<$>), (<*>), pure)
4041import qualified Data.Map as M
42+import System.FilePath (pathSeparator)
4143
4244-- |
4345-- Compile a collection of modules
@@ -72,12 +74,110 @@ compile opts ms = do
7274 let modulesToCodeGen = if null codeGenModules then elim else filter (\(Module mn _ _) -> mn `elem` codeGenModules) elim
7375 let js = mapMaybe (flip (moduleToJs opts) env) modulesToCodeGen
7476 let exts = intercalate "\n" . map (`moduleToPs` env) $ modulesToCodeGen
75− js' <- case mainModuleIdent of
77+ js' <- generateMain env opts js
78+ return (prettyPrintJS [wrapExportsContainer opts js'], exts, env)
79+ where
80+ mainModuleIdent = moduleNameFromString <$> optionsMain opts
81+
82+generateMain :: Environment -> Options -> [JS] -> Either String [JS]
83+generateMain env opts js =
84+ case moduleNameFromString <$> optionsMain opts of
7685 Just mmi -> do
7786 when ((mmi, Ident C.main) `M.notMember` names env) $
7887 Left $ show mmi ++ "." ++ C.main ++ " is undefined"
7988 return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar C._ps))) []]
8089 _ -> return js
81− return (prettyPrintJS [wrapExportsContainer opts js'], exts, env)
90+
91+-- |
92+-- A type class which collects the IO actions we need to be able to run in "make" mode
93+--
94+class MonadMake m where
95+ -- |
96+ -- Get a file timestamp
97+ --
98+ getTimestamp :: FilePath -> m (Maybe UTCTime)
99+
100+ -- |
101+ -- Read a file as a string
102+ --
103+ readTextFile :: FilePath -> m String
104+
105+ -- |
106+ -- Write a text file
107+ --
108+ writeTextFile :: FilePath -> String -> m ()
109+
110+ -- |
111+ -- Report an error
112+ --
113+ liftError :: Either String a -> m a
114+
115+
116+-- |
117+-- Compiles in "make" mode, compiling each module separately to a js files and an externs file
118+--
119+-- If timestamps have not changed, the externs file can be used to provide the module's types without
120+-- having to typecheck the module again.
121+--
122+make :: (Functor m, Monad m, MonadMake m) => Options -> [(FilePath, Module)] -> m ()
123+make opts ms = do
124+ let filePathMap = M.fromList (map (\(fp, (Module mn _ _)) -> (mn, fp)) ms)
125+
126+ sorted <- liftError $ sortModules (map snd ms)
127+
128+ marked <- forM sorted $ \m@(Module moduleName' _ _) -> do
129+ let filePath = toFileName moduleName'
130+
131+ jsFile = "js" ++ pathSeparator : filePath ++ ".js"
132+ externsFile = "externs" ++ pathSeparator : filePath ++ ".externs"
133+ inputFile = fromMaybe (error "Input file is undefined in make") $ M.lookup moduleName' filePathMap
134+
135+ jsTimestamp <- getTimestamp jsFile
136+ externsTimestamp <- getTimestamp externsFile
137+ inputTimestamp <- getTimestamp inputFile
138+
139+ case inputTimestamp < min jsTimestamp externsTimestamp of
140+ True -> do
141+ externs <- readTextFile externsFile
142+ externsModules <- liftError . either (Left . show) Right $ P.runIndentParser externsFile P.parseModules externs
143+ case externsModules of
144+ [m'@(Module moduleName'' _ _)] | moduleName' == moduleName'' -> return (True, m')
145+ _ -> liftError . Left $ "Externs file " ++ externsFile ++ " was invalid"
146+ False -> return (False, m)
147+
148+ desugared <- liftError $ zip (map fst marked) <$> desugar (map snd marked)
149+
150+ go initEnvironment desugared
151+
82152 where
83− mainModuleIdent = moduleNameFromString <$> optionsMain opts
153+ go :: (Functor m, Monad m, MonadMake m) => Environment -> [(Bool, Module)] -> m ()
154+ go _ [] = return ()
155+ go env ((True, Module moduleName' typings _) : ms') = do
156+ (_, env') <- liftError . runCheck' env $ do
157+ modify (\s -> s { checkCurrentModule = Just moduleName' })
158+ typeCheckAll Nothing moduleName' typings
159+
160+ go env' ms'
161+ go env ((False, Module moduleName' decls exps) : ms') = do
162+ let filePath = toFileName moduleName'
163+ jsFile = "js" ++ pathSeparator : filePath ++ ".js"
164+ externsFile = "externs" ++ pathSeparator : filePath ++ ".externs"
165+
166+ (elaborated, env') <- liftError . runCheck' env $ do
167+ modify (\s -> s { checkCurrentModule = Just moduleName' })
168+ typeCheckAll Nothing moduleName' decls
169+
170+ regrouped <- liftError . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
171+
172+ let mod' = Module moduleName' regrouped exps
173+ js = moduleToJs opts mod' env'
174+ exts = moduleToPs mod' env'
175+ js' = maybe "" (prettyPrintJS . return . wrapExportsContainer opts . return) js
176+
177+ writeTextFile jsFile js'
178+ writeTextFile externsFile exts
179+
180+ go env' ms'
181+
182+ toFileName :: ModuleName -> FilePath
183+ toFileName (ModuleName ps) = intercalate [pathSeparator] . map runProperName $ ps