Merge pull request purescript#1358 from purescript/1246

paf31 · paf31 · commit d87bf074a5ea · 2015-08-11T19:46:34.000-07:00
Fix purescript#1246
diff --git a/psc/Main.hs b/psc/Main.hs
@@ -84,7 +84,7 @@ readInput InputOptions{..} = forM ioInputFiles $ \inFile -> (Right inFile, ) <$>
 parseInputs :: (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m)
             => [(Either P.RebuildPolicy FilePath, String)]
             -> [(FilePath, P.ForeignJS)]
-            -> m ([(Either P.RebuildPolicy FilePath, P.Module)], M.Map P.ModuleName (FilePath, P.ForeignJS))
+            -> m ([(Either P.RebuildPolicy FilePath, P.Module)], M.Map P.ModuleName FilePath)
 parseInputs modules foreigns =
   (,) <$> P.parseModulesFromFiles (either (const "") id) modules
       <*> P.parseForeignModulesFromFiles foreigns
diff --git a/psci/Types.hs b/psci/Types.hs
@@ -35,7 +35,7 @@ data PSCiState = PSCiState
   { psciImportedFilenames   :: [FilePath]
   , psciImportedModules     :: [ImportedModule]
   , psciLoadedModules       :: [(Either P.RebuildPolicy FilePath, P.Module)]
-  , psciForeignFiles        :: M.Map P.ModuleName (FilePath, P.ForeignJS)
+  , psciForeignFiles        :: M.Map P.ModuleName FilePath
   , psciLetBindings         :: [P.Declaration]
   , psciNodeFlags           :: [String]
   }
@@ -91,7 +91,7 @@ updateLets ds st = st { psciLetBindings = psciLetBindings st ++ ds }
 -- |
 -- Updates the state to have more let bindings.
 --
-updateForeignFiles :: M.Map P.ModuleName (FilePath, P.ForeignJS) -> PSCiState -> PSCiState
+updateForeignFiles :: M.Map P.ModuleName FilePath -> PSCiState -> PSCiState
 updateForeignFiles fs st = st { psciForeignFiles = psciForeignFiles st `M.union` fs }
 
 -- |
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
@@ -59,7 +59,6 @@ import System.Directory
 import System.FilePath ((</>), takeDirectory)
 import System.IO.Error (tryIOError)
 
-
 import Language.PureScript.AST
 import Language.PureScript.CodeGen.Externs (moduleToPs)
 import Language.PureScript.Environment
@@ -245,8 +244,8 @@ traverseEither f (Right y) = Right <$> f y
 -- A set of make actions that read and write modules from the given directory.
 --
 buildMakeActions :: FilePath -- ^ the output directory
-                 -> M.Map ModuleName (Either RebuildPolicy String) -- ^ a map between module names and paths to the file containing the PureScript module
-                 -> M.Map ModuleName (FilePath, ForeignJS) -- ^ a map between module name and the file containing the foreign javascript for the module
+                 -> M.Map ModuleName (Either RebuildPolicy FilePath) -- ^ a map between module names and paths to the file containing the PureScript module
+                 -> M.Map ModuleName FilePath -- ^ a map between module name and the file containing the foreign javascript for the module
                  -> Bool -- ^ Generate a prefix comment?
                  -> MakeActions Make
 buildMakeActions outputDir filePathMap foreigns usePrefix =
@@ -257,7 +256,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
   getInputTimestamp mn = do
     let path = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap
     e1 <- traverseEither getTimestamp path
-    fPath <- maybe (return Nothing) (getTimestamp . fst) $ M.lookup mn foreigns
+    fPath <- maybe (return Nothing) getTimestamp $ M.lookup mn foreigns
     return $ fmap (max fPath) e1
 
   getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)
@@ -276,7 +275,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
   codegen m _ exts = do
     let mn = CF.moduleName m
     foreignInclude <- case mn `M.lookup` foreigns of
-      Just (path, _)
+      Just path
         | not $ requiresForeign m -> do
             tell $ errorMessage $ UnnecessaryFFIModule mn path
             return Nothing
@@ -292,7 +291,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
         js = unlines $ map ("// " ++) prefix ++ [pjs]
     lift $ do
       writeTextFile jsFile js
-      maybe (return ()) (writeTextFile foreignFile . snd) $ mn `M.lookup` foreigns
+      for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)
       writeTextFile externsFile exts
 
   requiresForeign :: CF.Module a -> Bool
diff --git a/src/Language/PureScript/Parser/JS.hs b/src/Language/PureScript/Parser/JS.hs
@@ -37,17 +37,17 @@ type ForeignJS = String
 
 parseForeignModulesFromFiles :: (Functor m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
                              => [(FilePath, ForeignJS)]
-                             -> m (M.Map ModuleName (FilePath, ForeignJS))
+                             -> m (M.Map ModuleName FilePath)
 parseForeignModulesFromFiles files = do
   foreigns <- parU files $ \(path, file) ->
     case findModuleName (lines file) of
-      Just name -> return (name, (path, file))
+      Just name -> return (name, path)
       Nothing -> throwError (errorMessage $ ErrorParsingFFIModule path)
   let grouped = groupBy ((==) `on` fst) $ sortBy (compare `on` fst) foreigns
   forM_ grouped $ \grp ->
     when (length grp > 1) $ do
       let mn = fst (head grp)
-          paths = map (fst . snd) grp
+          paths = map snd grp
       tell $ errorMessage $ MultipleFFIModules mn paths
   return $ M.fromList foreigns
 
diff --git a/tests/Main.hs b/tests/Main.hs
@@ -69,7 +69,7 @@ import Text.Parsec (ParseError)
 modulesDir :: FilePath
 modulesDir = ".test_modules" </> "node_modules"
 
-makeActions :: M.Map P.ModuleName (FilePath, P.ForeignJS) -> P.MakeActions P.Make
+makeActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make
 makeActions foreigns = (P.buildMakeActions modulesDir (error "makeActions: input file map was read.") foreigns False)
                          { P.getInputTimestamp = getInputTimestamp
                          , P.getOutputTimestamp = getOutputTimestamp
@@ -98,14 +98,14 @@ type TestM = WriterT [(FilePath, String)] IO
 runTest :: P.Make a -> IO (Either P.MultipleErrors a)
 runTest = fmap (fmap fst) . P.runMake P.defaultOptions
 
-compile :: [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> IO (Either P.MultipleErrors P.Environment)
+compile :: [FilePath] -> M.Map P.ModuleName FilePath -> IO (Either P.MultipleErrors P.Environment)
 compile inputFiles foreigns = runTest $ do
   fs <- liftIO $ readInput inputFiles
   ms <- P.parseModulesFromFiles id fs
   P.make (makeActions foreigns) (map snd ms)
 
 assert :: [FilePath] ->
-          M.Map P.ModuleName (FilePath, P.ForeignJS) ->
+          M.Map P.ModuleName FilePath ->
           (Either P.MultipleErrors P.Environment -> IO (Maybe String)) ->
           TestM ()
 assert inputFiles foreigns f = do
@@ -115,7 +115,7 @@ assert inputFiles foreigns f = do
     Just err -> tell [(last inputFiles, err)]
     Nothing -> return ()
 
-assertCompiles :: [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> TestM ()
+assertCompiles :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM ()
 assertCompiles inputFiles foreigns = do
   liftIO . putStrLn $ "Assert " ++ last inputFiles ++ " compiles successfully"
   assert inputFiles foreigns $ \e ->
@@ -131,7 +131,7 @@ assertCompiles inputFiles foreigns = do
           Just (ExitFailure _, _, err) -> return $ Just err
           Nothing -> return $ Just "Couldn't find node.js executable"
 
-assertDoesNotCompile :: [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> TestM ()
+assertDoesNotCompile :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM ()
 assertDoesNotCompile inputFiles foreigns = do
   let testFile = last inputFiles
   liftIO . putStrLn $ "Assert " ++ testFile ++ " does not compile"
