@@ -13,9 +13,10 @@
1313-----------------------------------------------------------------------------
1414
1515{-# LANGUAGE DataKinds #-}
16+{-# LANGUAGE FlexibleContexts #-}
1617{-# LANGUAGE GeneralizedNewtypeDeriving #-}
17−{-# LANGUAGE TupleSections #-}
1818{-# LANGUAGE RecordWildCards #-}
19+{-# LANGUAGE TupleSections #-}
1920
2021module Main where
2122
@@ -38,19 +39,21 @@ import System.Directory
3839 (doesFileExist, getModificationTime, createDirectoryIfMissing)
3940import System.FilePath ((</>), takeDirectory)
4041import System.Exit (exitSuccess, exitFailure)
42+import System.IO (hPutStrLn, stderr)
4143import System.IO.Error (tryIOError)
4244
4345import qualified Language.PureScript as P
4446import qualified Language.PureScript.CodeGen.JS as J
45−import qualified Language.PureScript.CoreFn as CoreFn
47+import qualified Language.PureScript.CoreFn as CF
4648import qualified Paths_purescript as Paths
4749
4850
4951data PSCMakeOptions = PSCMakeOptions
50− { pscmInput :: [FilePath]
51− , pscmOutputDir :: FilePath
52− , pscmOpts :: P.Options P.Make
53− , pscmUsePrefix :: Bool
52+ { pscmInput :: [FilePath]
53+ , pscmForeignInput :: [FilePath]
54+ , pscmOutputDir :: FilePath
55+ , pscmOpts :: P.Options P.Make
56+ , pscmUsePrefix :: Bool
5457 }
5558
5659data InputOptions = InputOptions
@@ -90,20 +93,33 @@ traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
9093traverseEither _ (Left x) = pure (Left x)
9194traverseEither f (Right y) = Right <$> f y
9295
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+
93104compile :: PSCMakeOptions -> IO ()
94−compile (PSCMakeOptions input outputDir opts usePrefix) = do
95− modules <- P.parseModulesFromFiles (either (const "") id) <$> readInput (InputOptions (P.optionsNoPrelude opts) input)
96− case modules of
97− Left err -> print err >> exitFailure
98− Right ms -> do
105+compile (PSCMakeOptions input inputForeign outputDir opts usePrefix) = do
106+ moduleFiles <- readInput (InputOptions (P.optionsNoPrelude opts) input)
107+ foreignFiles <- forM inputForeign (\inFile -> (inFile,) <$> readFile inFile)
108+ case runWriterT (parseInputs moduleFiles foreignFiles) of
109+ Left errs -> do
110+ hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)
111+ exitFailure
112+ Right ((ms, foreigns), warnings) -> do
113+ when (P.nonEmpty warnings) $
114+ hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings)
99115 let filePathMap = M.fromList $ map (\(fp, P.Module _ mn _ _) -> (mn, fp)) ms
100− e <- runMake opts $ P.make (getInputTimestamp filePathMap) getOutputTimestamp readExterns codegen ms
116+ e <- runMake opts $ P.make (getInputTimestamp filePathMap) getOutputTimestamp readExterns (codegen foreigns) ms
101117 case e of
102118 Left errs -> do
103119 putStrLn (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)
104120 exitFailure
105− Right (_, warnings) -> do
106− when (P.nonEmpty warnings) $
121+ Right (_, warnings') -> do
122+ when (P.nonEmpty warnings') $
107123 putStrLn (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings)
108124 exitSuccess
109125 where
@@ -125,15 +141,28 @@ compile (PSCMakeOptions input outputDir opts usePrefix) = do
125141 let path = outputDir </> P.runModuleName mn </> "externs.purs"
126142 (path, ) <$> P.readTextFile path
127143
128− codegen :: CoreFn.Module CoreFn.Ann -> String -> P.Environment -> Integer -> Make ()
129− codegen m exts _ nextVar = do
130− pjs <- P.evalSupplyT nextVar $ P.prettyPrintJS <$> J.moduleToJs m Nothing
131− let filePath = P.runModuleName $ CoreFn.moduleName m
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
132159 jsFile = outputDir </> filePath </> "index.js"
133160 externsFile = outputDir </> filePath </> "externs.purs"
161+ foreignFile = outputDir </> filePath </> "foreign.js"
134162 prefix = ["Generated by psc-make version " ++ showVersion Paths.version | usePrefix]
135163 js = unlines $ map ("// " ++) prefix ++ [pjs]
136164 P.writeTextFile jsFile js
165+ maybe (return ()) (P.writeTextFile foreignFile) $ CF.moduleName m `M.lookup` foreigns
137166 P.writeTextFile externsFile exts
138167
139168mkdirp :: FilePath -> IO ()
@@ -144,6 +173,12 @@ inputFile = strArgument $
144173 metavar "FILE"
145174 <> help "The input .purs file(s)"
146175
176+inputForeignFile :: Parser FilePath
177+inputForeignFile = strOption $
178+ short 'f'
179+ <> long "ffi"
180+ <> help "The input .js file(s) providing foreign import implementations"
181+
147182outputDirectory :: Parser FilePath
148183outputDirectory = strOption $
149184 short 'o'
@@ -203,6 +238,7 @@ options = P.Options <$> noPrelude
203238
204239pscMakeOptions :: Parser PSCMakeOptions
205240pscMakeOptions = PSCMakeOptions <$> many inputFile
241+ <*> many inputForeignFile
206242 <*> outputDirectory
207243 <*> options
208244 <*> (not <$> noPrefix)