More flag parser refactoring ghc-darcs-git-switchover
authorIan Lynagh <igloo@earth.li>
Thu, 24 Mar 2011 14:16:12 +0000 (14:16 +0000)
committerIan Lynagh <igloo@earth.li>
Thu, 24 Mar 2011 14:16:12 +0000 (14:16 +0000)
CrossCodegen.hs
DirectCodegen.hs
Flags.hs
Main.hs

index 82add4b..6e8855a 100644 (file)
@@ -28,7 +28,7 @@ import Data.Char (toLower,toUpper,isSpace)
 import Control.Exception (assert, onException)
 import Control.Monad (when,liftM,forM)
 import Data.Foldable (concatMap)
-import Data.Maybe (fromMaybe, fromJust)
+import Data.Maybe (fromMaybe)
 import qualified Data.Sequence as S
 import Data.Sequence ((|>),ViewL(..))
 
@@ -258,7 +258,7 @@ checkValidity :: [Token] -> TestMonad ()
 checkValidity input = do
     config <- testGetConfig
     flags <- testGetFlags
-    let test = outTemplateHeaderCProg (fromJust $ cTemplate config) ++
+    let test = outTemplateHeaderCProg (cTemplate config) ++
                concatMap outFlagHeaderCProg flags ++
                concatMap (uncurry outValidityCheck) (zip input [0..])
     testLog ("checking for compilation errors") $ do
@@ -488,7 +488,7 @@ checkConditional :: ZCursor Token -> TestMonad Bool
 checkConditional (ZCursor s@(Special pos key value) above below) = do
     config <- testGetConfig
     flags <- testGetFlags
-    let test = outTemplateHeaderCProg (fromJust $ cTemplate config) ++
+    let test = outTemplateHeaderCProg (cTemplate config) ++
                (concatMap outFlagHeaderCProg flags) ++
                (concatMap outHeaderCProg' above) ++
                outHeaderCProg' s ++ "#error T\n" ++
@@ -528,7 +528,7 @@ runCompileBooleanTest (ZCursor s above below) booleanTest = do
     config <- testGetConfig
     flags <- testGetFlags
     let test = -- all the surrounding code
-               outTemplateHeaderCProg (fromJust $ cTemplate config) ++
+               outTemplateHeaderCProg (cTemplate config) ++
                (concatMap outFlagHeaderCProg flags) ++
                (concatMap outHeaderCProg' above) ++
                outHeaderCProg' s ++
@@ -575,7 +575,7 @@ outputCross config outName outDir outBase inName toks =
            `testFinally` (liftTestIO $ hClose file))
            `testOnException` (liftTestIO $ removeFile outName) -- cleanup on errors
     where
-    env = TestMonadEnv (cVerbose config) 0 (cKeepFiles config) (outDir++outBase++"_hsc_test") (cFlags config) config (fromJust (cCompiler config))
+    env = TestMonadEnv (cVerbose config) 0 (cKeepFiles config) (outDir++outBase++"_hsc_test") (cFlags config) config (cCompiler config)
     runTestMonad x = runTest x env 0 >>= (handleError . fst)
 
     handleError (Left e) = die (e++"\n")
index 1bfd3f1..e09cc86 100644 (file)
@@ -7,7 +7,6 @@ compiled and run; the output of that program is the .hs file.
 -}
 
 import Data.Char                ( isAlphaNum, toUpper )
-import Data.Maybe               ( fromJust )
 import Control.Monad            ( when, forM_ )
 
 import System.Exit              ( ExitCode(..), exitWith )
@@ -59,7 +58,7 @@ outputDirect config outName outDir outBase name toks = do
              die (file ++ ":" ++ show line ++ " directive \"" ++ key ++ "\" is not safe for cross-compilation"))
 
     writeBinaryFile cProgName $
-        outTemplateHeaderCProg (fromJust $ cTemplate config)++
+        outTemplateHeaderCProg (cTemplate config)++
         concatMap outFlagHeaderCProg flags++
         concatMap outHeaderCProg specials++
         "\nint main (int argc, char *argv [])\n{\n"++
@@ -70,7 +69,7 @@ outputDirect config outName outDir outBase name toks = do
 
     when (cNoCompile config) $ exitWith ExitSuccess
 
-    rawSystemL ("compiling " ++ cProgName) beVerbose (fromJust $ cCompiler config)
+    rawSystemL ("compiling " ++ cProgName) beVerbose (cCompiler config)
        (  ["-c"]
         ++ [cProgName]
         ++ ["-o", oProgName]
@@ -78,7 +77,7 @@ outputDirect config outName outDir outBase name toks = do
        )
     possiblyRemove cProgName $ do
 
-      rawSystemL ("linking " ++ oProgName) beVerbose (fromJust $ cLinker config)
+      rawSystemL ("linking " ++ oProgName) beVerbose (cLinker config)
         (  [oProgName]
         ++ ["-o", progName]
         ++ [f | LinkFlag f <- flags]
index db3a5e4..20758fa 100644 (file)
--- a/Flags.hs
+++ b/Flags.hs
@@ -6,31 +6,43 @@ import System.Console.GetOpt
 data Mode
     = Help
     | Version
-    | UseConfig Config
-
-data Config = Config {
-                  cTemplate :: Maybe FilePath,
-                  cCompiler :: Maybe FilePath,
-                  cLinker   :: Maybe FilePath,
-                  cKeepFiles :: Bool,
-                  cNoCompile :: Bool,
-                  cCrossCompile :: Bool,
-                  cCrossSafe :: Bool,
-                  cVerbose :: Bool,
-                  cFlags :: [Flag]
-              }
+    | UseConfig (ConfigM Maybe)
+
+newtype Id a = Id { fromId :: a }
+type Config = ConfigM Id
+
+data ConfigM m = Config {
+                     cmTemplate :: m FilePath,
+                     cmCompiler :: m FilePath,
+                     cmLinker   :: m FilePath,
+                     cKeepFiles :: Bool,
+                     cNoCompile :: Bool,
+                     cCrossCompile :: Bool,
+                     cCrossSafe :: Bool,
+                     cVerbose :: Bool,
+                     cFlags :: [Flag]
+                 }
+
+cTemplate :: ConfigM Id -> FilePath
+cTemplate c = fromId $ cmTemplate c
+
+cCompiler :: ConfigM Id -> FilePath
+cCompiler c = fromId $ cmCompiler c
+
+cLinker :: ConfigM Id -> FilePath
+cLinker c = fromId $ cmLinker c
 
 emptyMode :: Mode
 emptyMode = UseConfig $ Config {
-                            cTemplate = Nothing,
-                            cCompiler = Nothing,
-                            cLinker   = Nothing,
-                            cKeepFiles = False,
-                            cNoCompile = False,
+                            cmTemplate    = Nothing,
+                            cmCompiler    = Nothing,
+                            cmLinker      = Nothing,
+                            cKeepFiles    = False,
+                            cNoCompile    = False,
                             cCrossCompile = False,
-                            cCrossSafe = False,
-                            cVerbose = False,
-                            cFlags = []
+                            cCrossSafe    = False,
+                            cVerbose      = False,
+                            cFlags        = []
                         }
 
 data Flag
@@ -86,32 +98,32 @@ setMode _              Help = Help
 setMode Version        _    = Version
 setMode (UseConfig {}) _    = error "setMode: UseConfig: Can't happen"
 
-withConfig :: (Config -> Config) -> Mode -> Mode
+withConfig :: (ConfigM Maybe -> ConfigM Maybe) -> Mode -> Mode
 withConfig f (UseConfig c) = UseConfig $ f c
 withConfig _ m = m
 
-setTemplate :: FilePath -> Config -> Config
-setTemplate fp c = c { cTemplate = Just fp }
+setTemplate :: FilePath -> ConfigM Maybe -> ConfigM Maybe
+setTemplate fp c = c { cmTemplate = Just fp }
 
-setCompiler :: FilePath -> Config -> Config
-setCompiler fp c = c { cCompiler = Just fp }
+setCompiler :: FilePath -> ConfigM Maybe -> ConfigM Maybe
+setCompiler fp c = c { cmCompiler = Just fp }
 
-setLinker :: FilePath -> Config -> Config
-setLinker fp c = c { cLinker = Just fp }
+setLinker :: FilePath -> ConfigM Maybe -> ConfigM Maybe
+setLinker fp c = c { cmLinker = Just fp }
 
-setKeepFiles :: Bool -> Config -> Config
+setKeepFiles :: Bool -> ConfigM Maybe -> ConfigM Maybe
 setKeepFiles b c = c { cKeepFiles = b }
 
-setNoCompile :: Bool -> Config -> Config
+setNoCompile :: Bool -> ConfigM Maybe -> ConfigM Maybe
 setNoCompile b c = c { cNoCompile = b }
 
-setCrossCompile :: Bool -> Config -> Config
+setCrossCompile :: Bool -> ConfigM Maybe -> ConfigM Maybe
 setCrossCompile b c = c { cCrossCompile = b }
 
-setCrossSafe :: Bool -> Config -> Config
+setCrossSafe :: Bool -> ConfigM Maybe -> ConfigM Maybe
 setCrossSafe b c = c { cCrossSafe = b }
 
-setVerbose :: Bool -> Config -> Config
+setVerbose :: Bool -> ConfigM Maybe -> ConfigM Maybe
 setVerbose v c = c { cVerbose = v }
 
 include :: String -> Flag
diff --git a/Main.hs b/Main.hs
index 2f6c969..c2c281a 100644 (file)
--- a/Main.hs
+++ b/Main.hs
@@ -75,88 +75,31 @@ getProgramName = liftM (`withoutSuffix` "-bin") getProgName
 bye :: String -> IO a
 bye s = putStr s >> exitWith ExitSuccess
 
-processFiles :: Config -> [FilePath] -> String -> IO ()
-processFiles config0 files usage = do
+processFiles :: ConfigM Maybe -> [FilePath] -> String -> IO ()
+processFiles configM files usage = do
     mb_libdir <- getLibDir
 
-    -- If there's no template specified on the commandline, try to locate it
-    config1 <- case cTemplate config0 of
-               Just _ ->
-                   return config0
-               Nothing -> do
-                 -- If there is no Template flag explicitly specified, try
-                 -- to find one. We first look near the executable.  This only
-                 -- works on Win32 or Hugs (getExecDir). If this finds a template
-                 -- file then it's certainly the one we want, even if hsc2hs isn't
-                 -- installed where we told Cabal it would be installed.
-                 --
-                 -- Next we try the location we told Cabal about.
-                 --
-                 -- If neither of the above work, then hopefully we're on Unix and
-                 -- there's a wrapper script which specifies an explicit template flag.
-                 mb_templ1 <-
-                   case mb_libdir of
-                   Nothing   -> return Nothing
-                   Just path -> do
-                   -- Euch, this is horrible. Unfortunately
-                   -- Paths_hsc2hs isn't too useful for a
-                   -- relocatable binary, though.
-                     let 
-#if defined(NEW_GHC_LAYOUT)
-                         templ1 = path ++ "/template-hsc.h"
-#else
-                         templ1 = path ++ "/hsc2hs-" ++ showVersion Main.version ++ "/template-hsc.h"
-#endif
-                         incl = path ++ "/include/"
-                     exists1 <- doesFileExist templ1
-                     if exists1
-                        then return $ Just (templ1, CompFlag ("-I" ++ incl))
-                        else return Nothing
-                 case mb_templ1 of
-                     Just (templ1, incl) ->
-                         return $ config0 {
-                                      cTemplate = Just templ1,
-                                      cFlags = cFlags config0 ++ [incl]
-                                  }
-                     Nothing -> do
-                         templ2 <- getDataFileName "template-hsc.h"
-                         exists2 <- doesFileExist templ2
-                         if exists2 then return $ config0 {
-                                                      cTemplate = Just templ2
-                                                  }
-                                    else die ("No template specified, and template-hsc.h not located.\n\n" ++ usage)
-
-    config2 <- case cCompiler config1 of
-               Just _ -> return config1
-               Nothing ->
-                   do let search_path = do
-                              mb_path <- findExecutable default_compiler
-                              case mb_path of
-                                  Nothing ->
-                                      die ("Can't find "++default_compiler++"\n")
-                                  Just path -> return path
-                      -- if this hsc2hs is part of a GHC installation on
-                      -- Windows, then we should use the mingw gcc that
-                      -- comes with GHC (#3929)
-                      p <- case mb_libdir of
-                           Nothing -> search_path
-                           Just d  ->
-                               do let inplaceGcc = d ++ "/../mingw/bin/gcc.exe"
-                                  b <- doesFileExist inplaceGcc
-                                  if b then return inplaceGcc
-                                       else search_path
-                      return $ config1 {
-                                   cCompiler = Just p
-                               }
-
-    let config3 = case cLinker config2 of
-                  Nothing -> config2 { cLinker = cCompiler config2 }
-                  Just _ -> config2
-
-    let outputter = if cCrossCompile config3 then outputCross else outputDirect
+    (template, extraFlags) <- findTemplate usage mb_libdir configM
+    compiler <- findCompiler mb_libdir configM
+    let linker = case cmLinker configM of
+                 Nothing -> compiler
+                 Just l -> l
+        config = Config {
+                     cmTemplate    = Id template,
+                     cmCompiler    = Id compiler,
+                     cmLinker      = Id linker,
+                     cKeepFiles    = cKeepFiles configM,
+                     cNoCompile    = cNoCompile configM,
+                     cCrossCompile = cCrossCompile configM,
+                     cCrossSafe    = cCrossSafe configM,
+                     cVerbose      = cVerbose configM,
+                     cFlags        = cFlags configM ++ extraFlags
+                 }
+
+    let outputter = if cCrossCompile config then outputCross else outputDirect
 
     forM_ files (\name -> do
-        (outName, outDir, outBase) <- case [f | Output f <- cFlags config3] of
+        (outName, outDir, outBase) <- case [f | Output f <- cFlags config] of
              [] -> if not (null ext) && last ext == 'c'
                       then return (dir++base++init ext,  dir, base)
                       else
@@ -173,7 +116,74 @@ processFiles config0 files usage = do
              _ -> onlyOne "output file"
         let file_name = dosifyPath name
         toks <- parseFile file_name
-        outputter config3 outName outDir outBase file_name toks)
+        outputter config outName outDir outBase file_name toks)
+
+findTemplate :: String -> Maybe FilePath -> ConfigM Maybe
+             -> IO (FilePath, [Flag])
+findTemplate usage mb_libdir config
+ = -- If there's no template specified on the commandline, try to locate it
+   case cmTemplate config of
+   Just t ->
+       return (t, [])
+   Nothing -> do
+     -- If there is no Template flag explicitly specified, try
+     -- to find one. We first look near the executable.  This only
+     -- works on Win32 or Hugs (getExecDir). If this finds a template
+     -- file then it's certainly the one we want, even if hsc2hs isn't
+     -- installed where we told Cabal it would be installed.
+     --
+     -- Next we try the location we told Cabal about.
+     --
+     -- If neither of the above work, then hopefully we're on Unix and
+     -- there's a wrapper script which specifies an explicit template flag.
+     mb_templ1 <-
+       case mb_libdir of
+       Nothing   -> return Nothing
+       Just path -> do
+       -- Euch, this is horrible. Unfortunately
+       -- Paths_hsc2hs isn't too useful for a
+       -- relocatable binary, though.
+         let
+#if defined(NEW_GHC_LAYOUT)
+             templ1 = path ++ "/template-hsc.h"
+#else
+             templ1 = path ++ "/hsc2hs-" ++ showVersion Main.version ++ "/template-hsc.h"
+#endif
+             incl = path ++ "/include/"
+         exists1 <- doesFileExist templ1
+         if exists1
+            then return $ Just (templ1, CompFlag ("-I" ++ incl))
+            else return Nothing
+     case mb_templ1 of
+         Just (templ1, incl) ->
+             return (templ1, [incl])
+         Nothing -> do
+             templ2 <- getDataFileName "template-hsc.h"
+             exists2 <- doesFileExist templ2
+             if exists2 then return (templ2, [])
+                        else die ("No template specified, and template-hsc.h not located.\n\n" ++ usage)
+
+findCompiler :: Maybe FilePath -> ConfigM Maybe -> IO FilePath
+findCompiler mb_libdir config
+ = case cmCompiler config of
+   Just c -> return c
+   Nothing ->
+       do let search_path = do
+                  mb_path <- findExecutable default_compiler
+                  case mb_path of
+                      Nothing ->
+                          die ("Can't find "++default_compiler++"\n")
+                      Just path -> return path
+          -- if this hsc2hs is part of a GHC installation on
+          -- Windows, then we should use the mingw gcc that
+          -- comes with GHC (#3929)
+          case mb_libdir of
+              Nothing -> search_path
+              Just d  ->
+                  do let inplaceGcc = d ++ "/../mingw/bin/gcc.exe"
+                     b <- doesFileExist inplaceGcc
+                     if b then return inplaceGcc
+                          else search_path
 
 parseFile :: String -> IO [Token]
 parseFile name