Skip to content

Commit 911af32

Browse files
garybgaryb
committed
Use real errors rather than error 
1 parent cf17f6e commit 911af32

File tree

6 files changed

+334
-218
lines changed

6 files changed

+334
-218
lines changed

‎psc-make/Main.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -79,7 +79,7 @@ readInput InputOptions{..} = forM ioInputFiles $ \inFile -> (Right inFile, ) <$>
7979
parseInputs :: (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m)
8080
=> [(Either P.RebuildPolicy FilePath, String)]
8181
-> [(FilePath, P.ForeignJS)]
82-
-> m ([(Either P.RebuildPolicy FilePath, P.Module)], M.Map P.ModuleName P.ForeignJS)
82+
-> m ([(Either P.RebuildPolicy FilePath, P.Module)], M.Map P.ModuleName (FilePath, P.ForeignJS))
8383
parseInputs modules foreigns =
8484
(,) <$> P.parseModulesFromFiles (either (const "") id) modules
8585
<*> P.parseForeignModulesFromFiles foreigns

‎psc-make/Make.hs‎

Lines changed: 11 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -64,7 +64,7 @@ traverseEither f (Right y) = Right <$> f y
6464

6565
buildMakeActions :: FilePath
6666
-> M.Map P.ModuleName (Either P.RebuildPolicy String)
67-
-> M.Map P.ModuleName P.ForeignJS
67+
-> M.Map P.ModuleName (FilePath, P.ForeignJS)
6868
-> Bool
6969
-> P.MakeActions Make
7070
buildMakeActions outputDir filePathMap foreigns usePrefix =
@@ -90,20 +90,24 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
9090

9191
codegen :: CF.Module CF.Ann -> P.Environment -> P.SupplyVar -> P.Externs -> Make ()
9292
codegen m _ nextVar exts = do
93-
foreignInclude <- case CF.moduleName m `M.lookup` foreigns of
94-
Just _ | not $ requiresForeign m -> error "Found unnecessary foreign module"
95-
| otherwise -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]
96-
Nothing | requiresForeign m -> error "Foreign module missing"
93+
let mn = CF.moduleName m
94+
foreignInclude <- case mn `M.lookup` foreigns of
95+
Just (path, _)
96+
| not $ requiresForeign m -> do
97+
tell $ P.errorMessage $ P.UnnecessaryFFIModule mn path
98+
return Nothing
99+
| otherwise -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]
100+
Nothing | requiresForeign m -> throwError . P.errorMessage $ P.MissingFFIModule mn
97101
| otherwise -> return Nothing
98102
pjs <- P.evalSupplyT nextVar $ P.prettyPrintJS <$> J.moduleToJs m foreignInclude
99-
let filePath = P.runModuleName $ CF.moduleName m
103+
let filePath = P.runModuleName mn
100104
jsFile = outputDir </> filePath </> "index.js"
101105
externsFile = outputDir </> filePath </> "externs.purs"
102106
foreignFile = outputDir </> filePath </> "foreign.js"
103107
prefix = ["Generated by psc-make version " ++ showVersion Paths.version | usePrefix]
104108
js = unlines $ map ("// " ++) prefix ++ [pjs]
105109
writeTextFile jsFile js
106-
maybe (return ()) (writeTextFile foreignFile) $ CF.moduleName m `M.lookup` foreigns
110+
maybe (return ()) (writeTextFile foreignFile . snd) $ mn `M.lookup` foreigns
107111
writeTextFile externsFile exts
108112

109113
requiresForeign :: CF.Module a -> Bool

‎psc/Main.hs‎

Lines changed: 21 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -25,10 +25,10 @@ import Control.Monad
2525
import Control.Monad.Error.Class (MonadError(..))
2626
import Control.Monad.Reader
2727
import Control.Monad.Supply (evalSupplyT)
28+
import Control.Monad.Supply.Class (MonadSupply())
2829
import Control.Monad.Writer
2930

3031
import Data.Maybe (fromMaybe)
31-
import Data.Traversable (traverse)
3232
import Data.Version (showVersion)
3333

3434
import Options.Applicative as Opts
@@ -83,7 +83,7 @@ compile (PSCOptions input inputForeign opts stdin output externs usePrefix) = do
8383
Right ((ms, foreigns), warnings) -> do
8484
when (P.nonEmpty warnings) $
8585
hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings)
86-
case runPSC opts (compileJS (map snd ms) foreigns prefix) of
86+
case runPSC opts (compileJS ms foreigns prefix) of
8787
Left errs -> do
8888
hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)
8989
exitFailure
@@ -99,33 +99,39 @@ compile (PSCOptions input inputForeign opts stdin output externs usePrefix) = do
9999
exitSuccess
100100

101101
parseInputs :: (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m)
102-
=> [(Maybe FilePath, String)] -> [(FilePath, P.ForeignJS)] -> m ([(Maybe FilePath, P.Module)], M.Map P.ModuleName String)
102+
=> [(Maybe FilePath, String)] -> [(FilePath, P.ForeignJS)] -> m ([P.Module], M.Map P.ModuleName (FilePath, P.ForeignJS))
103103
parseInputs modules foreigns =
104-
(,) <$> P.parseModulesFromFiles (fromMaybe "") modules
104+
(,) <$> (map snd <$> P.parseModulesFromFiles (fromMaybe "") modules)
105105
<*> P.parseForeignModulesFromFiles foreigns
106106

107107
compileJS :: forall m. (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m, MonadReader (P.Options P.Compile) m)
108-
=> [P.Module] -> M.Map P.ModuleName P.ForeignJS -> [String] -> m (String, String)
108+
=> [P.Module] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> [String] -> m (String, String)
109109
compileJS ms foreigns prefix = do
110110
(modulesToCodeGen, env, nextVar, exts) <- P.compile ms
111-
js <- concat <$> evalSupplyT nextVar (traverse codegenModule modulesToCodeGen)
111+
js <- concat <$> evalSupplyT nextVar (P.parU modulesToCodeGen codegenModule)
112112
js' <- generateMain env js
113113
let pjs = unlines $ map ("// " ++) prefix ++ [P.prettyPrintJS js']
114114
return (pjs, exts)
115115

116116
where
117117

118+
codegenModule :: (Functor n, Applicative n, MonadError P.MultipleErrors n, MonadWriter P.MultipleErrors n, MonadReader (P.Options P.Compile) n, MonadSupply n)
119+
=> CF.Module CF.Ann -> n [J.JS]
118120
codegenModule m =
119121
let requiresForeign = not $ null (CF.moduleForeign m)
120-
in case CF.moduleName m `M.lookup` foreigns of
121-
Just js | not requiresForeign -> error "Found unnecessary foreign module"
122-
| otherwise -> J.moduleToJs m $ Just $
123-
J.JSApp (J.JSFunction Nothing [] $
124-
J.JSBlock [ J.JSVariableIntroduction "exports" (Just $ J.JSObjectLiteral [])
125-
, J.JSRaw js
126-
, J.JSReturn (J.JSVar "exports")
127-
]) []
128-
Nothing | requiresForeign -> error "Foreign module missing"
122+
mn = CF.moduleName m
123+
in case mn `M.lookup` foreigns of
124+
Just (path, js)
125+
| not requiresForeign -> do
126+
tell $ P.errorMessage $ P.UnnecessaryFFIModule mn path
127+
J.moduleToJs m Nothing
128+
| otherwise -> J.moduleToJs m $ Just $
129+
J.JSApp (J.JSFunction Nothing [] $
130+
J.JSBlock [ J.JSVariableIntroduction "exports" (Just $ J.JSObjectLiteral [])
131+
, J.JSRaw js
132+
, J.JSReturn (J.JSVar "exports")
133+
]) []
134+
Nothing | requiresForeign -> throwError . P.errorMessage $ P.MissingFFIModule mn
129135
| otherwise -> J.moduleToJs m Nothing
130136

131137
generateMain :: P.Environment -> [J.JS] -> m [J.JS]

0 commit comments

Comments
 (0)