Skip to content

Commit 330bab9

Browse files
garybgaryb
committed
Parse foreign files for // module X.Y.Z comment
1 parent 8d394d9 commit 330bab9

3 files changed

Lines changed: 76 additions & 34 deletions

File tree

‎psc/Foreign.hs‎

Lines changed: 36 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,36 @@
1+
-----------------------------------------------------------------------------
2+
--
3+
-- Module : Foreign
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>, Gary Burgess <gary.burgess@gmail.com>
8+
-- Stability : experimental
9+
-- Portability :
10+
--
11+
-- |
12+
--
13+
-----------------------------------------------------------------------------
14+
15+
module Foreign (parseForeignModulesFromFiles) where
16+
17+
import Control.Applicative ((*>), (<*))
18+
import Control.Monad (forM, msum)
19+
import qualified Data.Map as M
20+
import qualified Language.PureScript as P
21+
import qualified Text.Parsec as PS
22+
23+
parseForeignModulesFromFiles :: [(FilePath, String)] -> Either String (M.Map P.ModuleName String)
24+
parseForeignModulesFromFiles files = do
25+
foreigns <- forM files $ \(path, file) -> do
26+
case findModuleName (lines file) of
27+
Just name -> Right (name, file)
28+
Nothing -> Left $ "Could not find a module definition comment in " ++ path
29+
return $ M.fromList foreigns
30+
31+
findModuleName :: [String] -> Maybe P.ModuleName
32+
findModuleName = msum . map parseComment
33+
where
34+
parseComment :: String -> Maybe P.ModuleName
35+
parseComment s = either (const Nothing) Just $
36+
P.lex "" s >>= P.runTokenParser "" (P.symbol' "//" *> P.reserved "module" *> P.moduleName <* PS.eof)

‎psc/Main.hs‎

Lines changed: 38 additions & 33 deletions
Original file line numberDiff line numberDiff line change
@@ -36,14 +36,16 @@ import Options.Applicative as Opts
3636
import System.Directory (createDirectoryIfMissing)
3737
import System.Exit (exitSuccess, exitFailure)
3838
import System.FilePath (takeDirectory)
39-
import System.IO (hPrint, hPutStrLn, stderr)
39+
import System.IO (hPutStrLn, stderr)
4040

4141
import qualified Data.Map as M
4242
import qualified Language.PureScript as P
43-
import qualified Language.PureScript.Constants as C
4443
import qualified Language.PureScript.CodeGen.JS as J
44+
import qualified Language.PureScript.Constants as C
4545
import qualified Paths_purescript as Paths
4646

47+
import Foreign
48+
4749
data PSCOptions = PSCOptions
4850
{ pscInput :: [FilePath]
4951
, pscForeignInput :: [FilePath]
@@ -72,13 +74,15 @@ runPSC opts rwe = runWriterT (runReaderT rwe opts)
7274

7375
compile :: PSCOptions -> IO ()
7476
compile (PSCOptions input inputForeign opts stdin output externs usePrefix) = do
75-
modules <- P.parseModulesFromFiles (fromMaybe "") <$> readInput (InputOptions (P.optionsNoPrelude opts) stdin input)
76-
case modules of
77+
let prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]
78+
moduleFiles <- readInput (InputOptions (P.optionsNoPrelude opts) stdin input)
79+
foreignFiles <- forM inputForeign (\inFile -> (inFile,) <$> readFile inFile)
80+
case parseInputs moduleFiles foreignFiles of
7781
Left err -> do
78-
hPrint stderr err
82+
hPutStrLn stderr err
7983
exitFailure
80-
Right ms ->
81-
case runPSC opts (compileJS (map snd ms) M.empty) of
84+
Right (ms, foreigns) ->
85+
case runPSC opts (compileJS (map snd ms) M.empty prefix) of
8286
Left errs -> do
8387
hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)
8488
exitFailure
@@ -92,32 +96,33 @@ compile (PSCOptions input inputForeign opts stdin output externs usePrefix) = do
9296
Just path -> mkdirp path >> writeFile path exts
9397
Nothing -> return ()
9498
exitSuccess
99+
100+
parseInputs :: [(Maybe FilePath, String)] -> [(FilePath, String)] -> Either String ([(Maybe FilePath, P.Module)], M.Map P.ModuleName String)
101+
parseInputs modules foreigns =
102+
(,) <$> either (Left . show) Right (P.parseModulesFromFiles (fromMaybe "") modules)
103+
<*> parseForeignModulesFromFiles foreigns
104+
105+
compileJS :: forall m. (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m, MonadReader (P.Options P.Compile) m)
106+
=> [P.Module] -> M.Map P.ModuleName String -> [String] -> m (String, String)
107+
compileJS ms foreigns prefix = do
108+
(modulesToCodeGen, exts, env, nextVar) <- P.compile ms
109+
js <- concat <$> evalSupplyT nextVar (traverse J.moduleToJs modulesToCodeGen)
110+
js' <- generateMain env js
111+
let pjs = unlines $ map ("// " ++) prefix ++ [P.prettyPrintJS js']
112+
return (pjs, exts)
113+
95114
where
96-
prefix = if usePrefix
97-
then ["Generated by psc version " ++ showVersion Paths.version]
98-
else []
99-
100-
compileJS :: forall m. (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m, MonadReader (P.Options P.Compile) m)
101-
=> [P.Module] -> M.Map P.ModuleName String -> m (String, String)
102-
compileJS ms foreigns = do
103-
(modulesToCodeGen, exts, env, nextVar) <- P.compile ms
104-
js <- concat <$> evalSupplyT nextVar (traverse J.moduleToJs modulesToCodeGen)
105-
js' <- generateMain env js
106-
let pjs = unlines $ map ("// " ++) prefix ++ [P.prettyPrintJS js']
107-
return (pjs, exts)
108-
109-
where
110-
111-
generateMain :: P.Environment -> [J.JS] -> m [J.JS]
112-
generateMain env js = do
113-
mainName <- asks P.optionsMain
114-
additional <- asks P.optionsAdditional
115-
case P.moduleNameFromString <$> mainName of
116-
Just mmi -> do
117-
when ((mmi, P.Ident C.main) `M.notMember` P.names env) $
118-
throwError . P.errorMessage $ P.NameIsUndefined (P.Ident C.main)
119-
return $ js ++ [J.mainCall mmi (P.browserNamespace additional)]
120-
_ -> return js
115+
116+
generateMain :: P.Environment -> [J.JS] -> m [J.JS]
117+
generateMain env js = do
118+
mainName <- asks P.optionsMain
119+
additional <- asks P.optionsAdditional
120+
case P.moduleNameFromString <$> mainName of
121+
Just mmi -> do
122+
when ((mmi, P.Ident C.main) `M.notMember` P.names env) $
123+
throwError . P.errorMessage $ P.NameIsUndefined (P.Ident C.main)
124+
return $ js ++ [J.mainCall mmi (P.browserNamespace additional)]
125+
_ -> return js
121126

122127
mkdirp :: FilePath -> IO ()
123128
mkdirp = createDirectoryIfMissing True . takeDirectory
@@ -199,7 +204,7 @@ inputForeignFile :: Parser FilePath
199204
inputForeignFile = strOption $
200205
short 'f'
201206
<> long "ffi"
202-
<> help "The input .purs file(s)"
207+
<> help "The input .js file(s) providing foreign import implementations"
203208

204209
outputFile :: Parser (Maybe FilePath)
205210
outputFile = optional . strOption $

‎purescript.cabal‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -44,6 +44,7 @@ library
4444
bytestring -any,
4545
text -any,
4646
split -any
47+
4748
exposed-modules: Language.PureScript
4849
Language.PureScript.AST
4950
Language.PureScript.AST.Binders
@@ -147,7 +148,7 @@ executable psc
147148
main-is: Main.hs
148149
buildable: True
149150
hs-source-dirs: psc
150-
other-modules:
151+
other-modules: Foreign
151152
ghc-options: -Wall -O2 -fno-warn-unused-do-bind
152153

153154
executable psc-make

0 commit comments

Comments
 (0)