Move File Target parser to library #18596

2 files changed, 88 insertions, 72 deletions

diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index f0f66ee264..19df839730 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -29,7 +29,7 @@ module GHC (
         -- * Flags and settings
         DynFlags(..), GeneralFlag(..), Severity(..), Backend(..), gopt,
         GhcMode(..), GhcLink(..),
-        parseDynamicFlags,
+        parseDynamicFlags, parseTargetFiles,
         getSessionDynFlags, setSessionDynFlags,
         getProgramDynFlags, setProgramDynFlags, setLogAction,
         getInteractiveDynFlags, setInteractiveDynFlags,
@@ -334,7 +334,8 @@ import GHC.Types.Avail
 import GHC.Types.SrcLoc
 import GHC.Core
 import GHC.Iface.Tidy
-import GHC.Driver.Phases   ( Phase(..), isHaskellSrcFilename )
+import GHC.Driver.Phases   ( Phase(..), isHaskellSrcFilename
+                           , isSourceFilename, startPhase )
 import GHC.Driver.Finder
 import GHC.Driver.Types
 import GHC.Driver.CmdLine
@@ -387,6 +388,7 @@ import GHC.Data.Maybe
 import System.IO.Error  ( isDoesNotExistError )
 import System.Environment ( getEnv )
 import System.Directory
+import Data.List (isPrefixOf)
 
 
 -- %************************************************************************
@@ -729,6 +731,88 @@ parseDynamicFlags dflags cmdline = do
   dflags2 <- liftIO $ interpretPackageEnv dflags1
   return (dflags2, leftovers, warns)
 
+-- | Parse command line arguments that look like files.
+-- First normalises its arguments and then splits them into source files
+-- and object files.
+-- A source file can be turned into a 'Target' via 'guessTarget'
+parseTargetFiles :: DynFlags -> [String] -> (DynFlags, [(String, Maybe Phase)], [String])
+parseTargetFiles dflags0 fileish_args =
+  let
+    normal_fileish_paths = map normalise_hyp fileish_args
+    (srcs, objs)         = partition_args normal_fileish_paths [] []
+
+    dflags1 = dflags0 { ldInputs = map (FileOption "") objs
+                                   ++ ldInputs dflags0 }
+    {-
+      We split out the object files (.o, .dll) and add them
+      to ldInputs for use by the linker.
+
+      The following things should be considered compilation manager inputs:
+
+       - haskell source files (strings ending in .hs, .lhs or other
+         haskellish extension),
+
+       - module names (not forgetting hierarchical module names),
+
+       - things beginning with '-' are flags that were not recognised by
+         the flag parser, and we want them to generate errors later in
+         checkOptions, so we class them as source files (#5921)
+
+       - and finally we consider everything without an extension to be
+         a comp manager input, as shorthand for a .hs or .lhs filename.
+
+      Everything else is considered to be a linker object, and passed
+      straight through to the linker.
+    -}
+  in (dflags1, srcs, objs)
+
+-- -----------------------------------------------------------------------------
+
+-- | Splitting arguments into source files and object files.  This is where we
+-- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source
+-- file indicating the phase specified by the -x option in force, if any.
+partition_args :: [String] -> [(String, Maybe Phase)] -> [String]
+               -> ([(String, Maybe Phase)], [String])
+partition_args [] srcs objs = (reverse srcs, reverse objs)
+partition_args ("-x":suff:args) srcs objs
+  | "none" <- suff      = partition_args args srcs objs
+  | StopLn <- phase     = partition_args args srcs (slurp ++ objs)
+  | otherwise           = partition_args rest (these_srcs ++ srcs) objs
+        where phase = startPhase suff
+              (slurp,rest) = break (== "-x") args
+              these_srcs = zip slurp (repeat (Just phase))
+partition_args (arg:args) srcs objs
+  | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs
+  | otherwise               = partition_args args srcs (arg:objs)
+
+
+looks_like_an_input :: String -> Bool
+looks_like_an_input m =  isSourceFilename m
+                      || looksLikeModuleName m
+                      || "-" `isPrefixOf` m
+                      || not (hasExtension m)
+
+
+-- | To simplify the handling of filepaths, we normalise all filepaths right
+-- away. Note the asymmetry of FilePath.normalise:
+--    Linux:   p\/q -> p\/q; p\\q -> p\\q
+--    Windows: p\/q -> p\\q; p\\q -> p\\q
+-- #12674: Filenames starting with a hypen get normalised from ./-foo.hs
+-- to -foo.hs. We have to re-prepend the current directory.
+normalise_hyp :: FilePath -> FilePath
+normalise_hyp fp
+  | strt_dot_sl && "-" `isPrefixOf` nfp = cur_dir ++ nfp
+  | otherwise                           = nfp
+  where
+#if defined(mingw32_HOST_OS)
+    strt_dot_sl = "./" `isPrefixOf` fp || ".\\" `isPrefixOf` fp
+#else
+    strt_dot_sl = "./" `isPrefixOf` fp
+#endif
+    cur_dir = '.' : [pathSeparator]
+    nfp = normalise fp
+
+-----------------------------------------------------------------------------
 
 -- | Checks the set of new DynFlags for possibly erroneous option
 -- combinations when invoking 'setSessionDynFlags' and friends, and if
diff --git a/ghc/Main.hs b/ghc/Main.hs
index 122e4dce0c..c079cb6893 100644
--- a/ghc/Main.hs
+++ b/ghc/Main.hs
@@ -16,7 +16,7 @@ module Main (main) where
 
 -- The official GHC API
 import qualified GHC
-import GHC              ( Ghc, GhcMonad(..), Backend (..),
+import GHC              (parseTargetFiles,  Ghc, GhcMonad(..), Backend (..),
                           LoadHowMuch(..) )
 import GHC.Driver.CmdLine
 
@@ -74,7 +74,6 @@ import GHC.Iface.Recomp.Binary ( fingerprintBinMem )
 import System.IO
 import System.Environment
 import System.Exit
-import System.FilePath
 import Control.Monad
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Except (throwE, runExceptT)
@@ -219,29 +218,7 @@ main' postLoadMode dflags0 args flagWarnings = do
 
   liftIO $ showBanner postLoadMode dflags4
 
-  let
-     -- To simplify the handling of filepaths, we normalise all filepaths right
-     -- away. Note the asymmetry of FilePath.normalise:
-     --    Linux:   p/q -> p/q; p\q -> p\q
-     --    Windows: p/q -> p\q; p\q -> p\q
-     -- #12674: Filenames starting with a hypen get normalised from ./-foo.hs
-     -- to -foo.hs. We have to re-prepend the current directory.
-    normalise_hyp fp
-        | strt_dot_sl && "-" `isPrefixOf` nfp = cur_dir ++ nfp
-        | otherwise                           = nfp
-        where
-#if defined(mingw32_HOST_OS)
-          strt_dot_sl = "./" `isPrefixOf` fp || ".\\" `isPrefixOf` fp
-#else
-          strt_dot_sl = "./" `isPrefixOf` fp
-#endif
-          cur_dir = '.' : [pathSeparator]
-          nfp = normalise fp
-    normal_fileish_paths = map (normalise_hyp . unLoc) fileish_args
-    (srcs, objs)         = partition_args normal_fileish_paths [] []
-
-    dflags5 = dflags4 { ldInputs = map (FileOption "") objs
-                                   ++ ldInputs dflags4 }
+  let (dflags5, srcs, objs) = parseTargetFiles dflags4 (map unLoc fileish_args)
 
   -- we've finished manipulating the DynFlags, update the session
   _ <- GHC.setSessionDynFlags dflags5
@@ -289,51 +266,6 @@ ghciUI hsc_env dflags0 srcs maybe_expr = do
   interactiveUI defaultGhciSettings srcs maybe_expr
 #endif
 
--- -----------------------------------------------------------------------------
--- Splitting arguments into source files and object files.  This is where we
--- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source
--- file indicating the phase specified by the -x option in force, if any.
-
-partition_args :: [String] -> [(String, Maybe Phase)] -> [String]
-               -> ([(String, Maybe Phase)], [String])
-partition_args [] srcs objs = (reverse srcs, reverse objs)
-partition_args ("-x":suff:args) srcs objs
-  | "none" <- suff      = partition_args args srcs objs
-  | StopLn <- phase     = partition_args args srcs (slurp ++ objs)
-  | otherwise           = partition_args rest (these_srcs ++ srcs) objs
-        where phase = startPhase suff
-              (slurp,rest) = break (== "-x") args
-              these_srcs = zip slurp (repeat (Just phase))
-partition_args (arg:args) srcs objs
-  | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs
-  | otherwise               = partition_args args srcs (arg:objs)
-
-    {-
-      We split out the object files (.o, .dll) and add them
-      to ldInputs for use by the linker.
-
-      The following things should be considered compilation manager inputs:
-
-       - haskell source files (strings ending in .hs, .lhs or other
-         haskellish extension),
-
-       - module names (not forgetting hierarchical module names),
-
-       - things beginning with '-' are flags that were not recognised by
-         the flag parser, and we want them to generate errors later in
-         checkOptions, so we class them as source files (#5921)
-
-       - and finally we consider everything without an extension to be
-         a comp manager input, as shorthand for a .hs or .lhs filename.
-
-      Everything else is considered to be a linker object, and passed
-      straight through to the linker.
-    -}
-looks_like_an_input :: String -> Bool
-looks_like_an_input m =  isSourceFilename m
-                      || looksLikeModuleName m
-                      || "-" `isPrefixOf` m
-                      || not (hasExtension m)
 
 -- -----------------------------------------------------------------------------
 -- Option sanity checks