Start refactoring the flag parsing
authorIan Lynagh <igloo@earth.li>
Thu, 24 Mar 2011 13:28:01 +0000 (13:28 +0000)
committerIan Lynagh <igloo@earth.li>
Thu, 24 Mar 2011 13:28:01 +0000 (13:28 +0000)
C.hs
Common.hs
CrossCodegen.hs
DirectCodegen.hs
Flags.hs [new file with mode: 0644]
Main.hs
hsc2hs.cabal

diff --git a/C.hs b/C.hs
index 13447f0..7676ec7 100644 (file)
--- a/C.hs
+++ b/C.hs
@@ -11,9 +11,12 @@ import Data.List                ( intersperse )
 import HSCParser                ( SourcePos(..), Token(..) )
 
 import Common
+import Flags
+
+outTemplateHeaderCProg :: FilePath -> String
+outTemplateHeaderCProg template = "#include \"" ++ template ++ "\"\n"
 
 outFlagHeaderCProg :: Flag -> String
-outFlagHeaderCProg (Template t)          = "#include \""++t++"\"\n"
 outFlagHeaderCProg (Include  f)          = "#include "++f++"\n"
 outFlagHeaderCProg (Define   n Nothing)  = "#define "++n++" 1\n"
 outFlagHeaderCProg (Define   n (Just v)) = "#define "++n++" "++v++"\n"
index e7ecf94..0a7f1b9 100644 (file)
--- a/Common.hs
+++ b/Common.hs
@@ -19,23 +19,6 @@ import System.Cmd               ( system )
 import System.Exit              ( ExitCode(..), exitWith )
 import System.Directory         ( removeFile )
 
-data Flag
-    = Help
-    | Version
-    | Template  String
-    | Compiler  String
-    | Linker    String
-    | CompFlag  String
-    | LinkFlag  String
-    | NoCompile
-    | CrossCompile
-    | CrossSafe
-    | Include   String
-    | Define    String (Maybe String)
-    | Output    String
-    | KeepFiles
-    | Verbose
-
 die :: String -> IO a
 die s = hPutStr stderr s >> exitWith (ExitFailure 1)
 
index a984ee6..82add4b 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)
+import Data.Maybe (fromMaybe, fromJust)
 import qualified Data.Sequence as S
 import Data.Sequence ((|>),ViewL(..))
 
@@ -39,6 +39,7 @@ import System.Exit              ( ExitCode(..) )
 
 import C
 import Common
+import Flags
 import HSCParser
 
 -- A monad over IO for performing tests; keeps the commandline flags
@@ -60,6 +61,7 @@ data TestMonadEnv = TestMonadEnv {
     testKeepFiles_ :: Bool,
     testGetBaseName_ :: FilePath,
     testGetFlags_ :: [Flag],
+    testGetConfig_ :: Config,
     testGetCompiler_ :: FilePath
 }
 
@@ -78,6 +80,9 @@ testKeepFiles = testKeepFiles_ `fmap` testAsk
 testGetFlags :: TestMonad [Flag]
 testGetFlags = testGetFlags_ `fmap` testAsk
 
+testGetConfig :: TestMonad Config
+testGetConfig = testGetConfig_ `fmap` testAsk
+
 testGetBaseName :: TestMonad FilePath
 testGetBaseName = testGetBaseName_ `fmap` testAsk
 
@@ -251,8 +256,10 @@ outputText output (SourcePos file line) txt =
 -- that autoconf went with.
 checkValidity :: [Token] -> TestMonad ()
 checkValidity input = do
+    config <- testGetConfig
     flags <- testGetFlags
-    let test = concatMap outFlagHeaderCProg flags ++
+    let test = outTemplateHeaderCProg (fromJust $ cTemplate config) ++
+               concatMap outFlagHeaderCProg flags ++
                concatMap (uncurry outValidityCheck) (zip input [0..])
     testLog ("checking for compilation errors") $ do
         success <- makeTest2 (".c",".o") $ \(cFile,oFile) -> do
@@ -479,8 +486,10 @@ outHeaderCProg' _ = ""
 -- and seeing if the compile fails.
 checkConditional :: ZCursor Token -> TestMonad Bool
 checkConditional (ZCursor s@(Special pos key value) above below) = do
+    config <- testGetConfig
     flags <- testGetFlags
-    let test = (concatMap outFlagHeaderCProg flags) ++
+    let test = outTemplateHeaderCProg (fromJust $ cTemplate config) ++
+               (concatMap outFlagHeaderCProg flags) ++
                (concatMap outHeaderCProg' above) ++
                outHeaderCProg' s ++ "#error T\n" ++
                (concatMap outHeaderCProg' below)
@@ -516,8 +525,10 @@ compareConst _ _ = error "compareConst argument isn't a Special"
 -- will generate an error if the array has negative size.
 runCompileBooleanTest :: ZCursor Token -> String -> TestMonad Bool
 runCompileBooleanTest (ZCursor s above below) booleanTest = do
+    config <- testGetConfig
     flags <- testGetFlags
     let test = -- all the surrounding code
+               outTemplateHeaderCProg (fromJust $ cTemplate config) ++
                (concatMap outFlagHeaderCProg flags) ++
                (concatMap outHeaderCProg' above) ++
                outHeaderCProg' s ++
@@ -556,15 +567,15 @@ runCompiler prog args stdoutFile = do
                  ExitFailure _ -> False
 
 -- The main driver for cross-compilation mode
-outputCross :: Bool -> Bool -> FilePath -> [Flag] -> String -> String -> String -> String -> [Token] -> IO ()
-outputCross beVerbose keepFiles compiler flags outName outDir outBase inName toks =
+outputCross :: Config -> String -> String -> String -> String -> [Token] -> IO ()
+outputCross config outName outDir outBase inName toks =
     runTestMonad $ do
         file <- liftTestIO $ openFile outName WriteMode
         (diagnose inName (liftTestIO . hPutStr file) toks
            `testFinally` (liftTestIO $ hClose file))
            `testOnException` (liftTestIO $ removeFile outName) -- cleanup on errors
     where
-    env = TestMonadEnv beVerbose 0 keepFiles (outDir++outBase++"_hsc_test") flags compiler
+    env = TestMonadEnv (cVerbose config) 0 (cKeepFiles config) (outDir++outBase++"_hsc_test") (cFlags config) config (fromJust (cCompiler config))
     runTestMonad x = runTest x env 0 >>= (handleError . fst)
 
     handleError (Left e) = die (e++"\n")
index 4f685aa..6136b0c 100644 (file)
@@ -7,18 +7,22 @@ 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 )
 
 import C
 import Common
+import Flags
 import HSCParser
 
-outputDirect :: [Flag] -> Bool -> Bool -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> String -> [Token] -> IO ()
-outputDirect flags beVerbose keepFiles compiler linker outName outDir outBase name toks = do
+outputDirect :: Config -> FilePath -> FilePath -> FilePath -> String -> [Token] -> IO ()
+outputDirect config outName outDir outBase name toks = do
 
-    let cProgName    = outDir++outBase++"_hsc_make.c"
+    let beVerbose    = cVerbose config
+        flags        = cFlags config
+        cProgName    = outDir++outBase++"_hsc_make.c"
         oProgName    = outDir++outBase++"_hsc_make.o"
         progName     = outDir++outBase++"_hsc_make"
 #if defined(mingw32_HOST_OS) || defined(__CYGWIN32__)
@@ -38,7 +42,7 @@ outputDirect flags beVerbose keepFiles compiler linker outName outDir outBase na
 
     let needsC = any (\(_, key, _) -> key == "def") specials
         needsH = needsC
-        possiblyRemove = if keepFiles
+        possiblyRemove = if cKeepFiles config
                          then flip const
                          else finallyRemove
 
@@ -55,6 +59,7 @@ outputDirect flags beVerbose keepFiles compiler linker outName outDir outBase na
              die (file ++ ":" ++ show line ++ " directive \"" ++ key ++ "\" is not safe for cross-compilation"))
 
     writeBinaryFile cProgName $
+        outTemplateHeaderCProg (fromJust $ cTemplate config)++
         concatMap outFlagHeaderCProg flags++
         concatMap outHeaderCProg specials++
         "\nint main (int argc, char *argv [])\n{\n"++
@@ -68,7 +73,7 @@ outputDirect flags beVerbose keepFiles compiler linker outName outDir outBase na
     when (any (\x -> case x of NoCompile -> True; _ -> False) flags) $
        exitWith ExitSuccess
 
-    rawSystemL ("compiling " ++ cProgName) beVerbose compiler
+    rawSystemL ("compiling " ++ cProgName) beVerbose (fromJust $ cCompiler config)
        (  ["-c"]
         ++ [cProgName]
         ++ ["-o", oProgName]
@@ -76,7 +81,7 @@ outputDirect flags beVerbose keepFiles compiler linker outName outDir outBase na
        )
     possiblyRemove cProgName $ do
 
-      rawSystemL ("linking " ++ oProgName) beVerbose linker
+      rawSystemL ("linking " ++ oProgName) beVerbose (fromJust $ cLinker config)
         (  [oProgName]
         ++ ["-o", progName]
         ++ [f | LinkFlag f <- flags]
diff --git a/Flags.hs b/Flags.hs
new file mode 100644 (file)
index 0000000..5441d4c
--- /dev/null
+++ b/Flags.hs
@@ -0,0 +1,118 @@
+
+module Flags where
+
+import System.Console.GetOpt
+
+data Mode
+    = Help
+    | Version
+    | UseConfig Config
+
+data Config = Config {
+                  cTemplate :: Maybe FilePath,
+                  cCompiler :: Maybe FilePath,
+                  cLinker   :: Maybe FilePath,
+                  cKeepFiles :: Bool,
+                  cCrossCompile :: Bool,
+                  cVerbose :: Bool,
+                  cFlags :: [Flag]
+              }
+
+emptyMode :: Mode
+emptyMode = UseConfig $ Config {
+                            cTemplate = Nothing,
+                            cCompiler = Nothing,
+                            cLinker   = Nothing,
+                            cKeepFiles = False,
+                            cCrossCompile = False,
+                            cVerbose = False,
+                            cFlags = []
+                        }
+
+data Flag
+    = CompFlag  String
+    | LinkFlag  String
+    | NoCompile
+    | CrossSafe
+    | Include   String
+    | Define    String (Maybe String)
+    | Output    String
+    deriving Show
+
+options :: [OptDescr (Mode -> Mode)]
+options = [
+    Option ['o'] ["output"]     (ReqArg (addFlag . Output)     "FILE")
+        "name of main output file",
+    Option ['t'] ["template"]   (ReqArg (withConfig . setTemplate)   "FILE")
+        "template file",
+    Option ['c'] ["cc"]         (ReqArg (withConfig . setCompiler)   "PROG")
+        "C compiler to use",
+    Option ['l'] ["ld"]         (ReqArg (withConfig . setLinker)     "PROG")
+        "linker to use",
+    Option ['C'] ["cflag"]      (ReqArg (addFlag . CompFlag)   "FLAG")
+        "flag to pass to the C compiler",
+    Option ['I'] []             (ReqArg (addFlag . CompFlag . ("-I"++)) "DIR")
+        "passed to the C compiler",
+    Option ['L'] ["lflag"]      (ReqArg (addFlag . LinkFlag)   "FLAG")
+        "flag to pass to the linker",
+    Option ['i'] ["include"]    (ReqArg (addFlag . include)    "FILE")
+        "as if placed in the source",
+    Option ['D'] ["define"]     (ReqArg (addFlag . define) "NAME[=VALUE]")
+        "as if placed in the source",
+    Option []    ["no-compile"] (NoArg  (addFlag NoCompile))
+        "stop after writing *_hsc_make.c",
+    Option ['x'] ["cross-compile"] (NoArg (withConfig $ setCrossCompile True))
+        "activate cross-compilation mode",
+    Option [] ["cross-safe"] (NoArg (addFlag CrossSafe))
+        "restrict .hsc directives to those supported by --cross-compile",
+    Option ['k'] ["keep-files"] (NoArg (withConfig $ setKeepFiles True))
+        "do not remove temporary files",
+    Option ['v'] ["verbose"]    (NoArg  (withConfig $ setVerbose True))
+        "dump commands to stderr",
+    Option ['?'] ["help"]       (NoArg  (setMode Help))
+        "display this help and exit",
+    Option ['V'] ["version"]    (NoArg  (setMode Version))
+        "output version information and exit" ]
+
+addFlag :: Flag -> Mode -> Mode
+addFlag f (UseConfig c) = UseConfig $ c { cFlags = f : cFlags c }
+addFlag _ mode = mode
+
+setMode :: Mode -> Mode -> Mode
+setMode Help           _    = Help
+setMode _              Help = Help
+setMode Version        _    = Version
+setMode (UseConfig {}) _    = error "setMode: UseConfig: Can't happen"
+
+withConfig :: (Config -> Config) -> Mode -> Mode
+withConfig f (UseConfig c) = UseConfig $ f c
+withConfig _ m = m
+
+setTemplate :: FilePath -> Config -> Config
+setTemplate fp c = c { cTemplate = Just fp }
+
+setCompiler :: FilePath -> Config -> Config
+setCompiler fp c = c { cCompiler = Just fp }
+
+setLinker :: FilePath -> Config -> Config
+setLinker fp c = c { cLinker = Just fp }
+
+setKeepFiles :: Bool -> Config -> Config
+setKeepFiles b c = c { cKeepFiles = b }
+
+setCrossCompile :: Bool -> Config -> Config
+setCrossCompile b c = c { cCrossCompile = b }
+
+setVerbose :: Bool -> Config -> Config
+setVerbose v c = c { cVerbose = v }
+
+include :: String -> Flag
+include s@('\"':_) = Include s
+include s@('<' :_) = Include s
+include s          = Include ("\""++s++"\"")
+
+define :: String -> Flag
+define s = case break (== '=') s of
+    (name, [])      -> Define name Nothing
+    (name, _:value) -> Define name (Just value)
+
diff --git a/Main.hs b/Main.hs
index bed632e..2f6c969 100644 (file)
--- a/Main.hs
+++ b/Main.hs
@@ -37,6 +37,7 @@ import Paths_hsc2hs as Main     ( getDataFileName, version )
 import Common
 import CrossCodegen
 import DirectCodegen
+import Flags
 import HSCParser
 
 #ifdef BUILD_NHC
@@ -49,71 +50,21 @@ showVersion = id
 versionString :: String
 versionString = "hsc2hs version " ++ showVersion version ++ "\n"
 
-template_flag :: Flag -> Bool
-template_flag (Template _) = True
-template_flag _                   = False
-
-include :: String -> Flag
-include s@('\"':_) = Include s
-include s@('<' :_) = Include s
-include s          = Include ("\""++s++"\"")
-
-define :: String -> Flag
-define s = case break (== '=') s of
-    (name, [])      -> Define name Nothing
-    (name, _:value) -> Define name (Just value)
-
-options :: [OptDescr Flag]
-options = [
-    Option ['o'] ["output"]     (ReqArg Output     "FILE")
-        "name of main output file",
-    Option ['t'] ["template"]   (ReqArg Template   "FILE")
-        "template file",
-    Option ['c'] ["cc"]         (ReqArg Compiler   "PROG")
-        "C compiler to use",
-    Option ['l'] ["ld"]         (ReqArg Linker     "PROG")
-        "linker to use",
-    Option ['C'] ["cflag"]      (ReqArg CompFlag   "FLAG")
-        "flag to pass to the C compiler",
-    Option ['I'] []             (ReqArg (CompFlag . ("-I"++)) "DIR")
-        "passed to the C compiler",
-    Option ['L'] ["lflag"]      (ReqArg LinkFlag   "FLAG")
-        "flag to pass to the linker",
-    Option ['i'] ["include"]    (ReqArg include    "FILE")
-        "as if placed in the source",
-    Option ['D'] ["define"]     (ReqArg define "NAME[=VALUE]")
-        "as if placed in the source",
-    Option []    ["no-compile"] (NoArg  NoCompile)
-        "stop after writing *_hsc_make.c",
-    Option ['x'] ["cross-compile"] (NoArg CrossCompile)
-        "activate cross-compilation mode",
-    Option [] ["cross-safe"] (NoArg CrossSafe)
-        "restrict .hsc directives to those supported by --cross-compile",
-    Option ['k'] ["keep-files"] (NoArg KeepFiles)
-        "do not remove temporary files",
-    Option ['v'] ["verbose"]    (NoArg  Verbose)
-        "dump commands to stderr",
-    Option ['?'] ["help"]       (NoArg  Help)
-        "display this help and exit",
-    Option ['V'] ["version"]    (NoArg  Version)
-        "output version information and exit" ]
-
 main :: IO ()
 main = do
     prog <- getProgramName
     let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]\n"
         usage = usageInfo header options
     args <- getArgs
-    let (flags, files, errs) = getOpt Permute options args
-    case (files, errs) of
-        (_, _)
-            | any isHelp    flags -> bye usage
-            | any isVersion flags -> bye versionString
-            where
-            isHelp    Help    = True; isHelp    _ = False
-            isVersion Version = True; isVersion _ = False
-        ((_:_), []) -> processFiles flags files usage
-        (_,     _ ) -> die (concat errs ++ usage)
+    let (fs, files, errs) = getOpt Permute options args
+    let mode = foldl (.) id fs emptyMode
+    case mode of
+        Help     -> bye usage
+        Version  -> bye versionString
+        UseConfig config ->
+            case (files, errs) of
+            ((_:_), []) -> processFiles config files usage
+            (_,     _ ) -> die (concat errs ++ usage)
 
 getProgramName :: IO String
 getProgramName = liftM (`withoutSuffix` "-bin") getProgName
@@ -124,17 +75,16 @@ getProgramName = liftM (`withoutSuffix` "-bin") getProgName
 bye :: String -> IO a
 bye s = putStr s >> exitWith ExitSuccess
 
-processFiles :: [Flag] -> [FilePath] -> String -> IO ()
-processFiles flags files usage = do
+processFiles :: Config -> [FilePath] -> String -> IO ()
+processFiles config0 files usage = do
     mb_libdir <- getLibDir
 
     -- If there's no template specified on the commandline, try to locate it
-    flags_w_tpl <- case filter template_flag flags of
-        [_] -> return flags
-        (_:_) -> -- take only the last --template flag on the cmd line
-                 let (before,tpl:after) = break template_flag (reverse flags)
-                 in return $ reverse (before ++ tpl : filter (not.template_flag) after)
-        [] -> do -- If there is no Template flag explicitly specified, try
+    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
@@ -160,49 +110,53 @@ processFiles flags files usage = do
                          incl = path ++ "/include/"
                      exists1 <- doesFileExist templ1
                      if exists1
-                        then return $ Just (Template templ1,
-                                            CompFlag ("-I" ++ incl))
+                        then return $ Just (templ1, CompFlag ("-I" ++ incl))
                         else return Nothing
                  case mb_templ1 of
-                     Just (templ1, incl) -> return (templ1 : flags ++ [incl])
+                     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 (Template templ2 : flags)
+                         if exists2 then return $ config0 {
+                                                      cTemplate = Just templ2
+                                                  }
                                     else die ("No template specified, and template-hsc.h not located.\n\n" ++ usage)
 
-    compiler <- case [c | Compiler c <- flags_w_tpl] of
-        []  -> do
-                  -- 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 inplace_gcc = d ++ "/../mingw/bin/gcc.exe"
-                      b <- doesFileExist inplace_gcc
-                      if b then return inplace_gcc else search_path
-            where
-                search_path = do
-                  mb_path <- findExecutable default_compiler
-                  case mb_path of
-                      Nothing -> die ("Can't find "++default_compiler++"\n")
-                      Just path -> return path
-        cs  -> return (last cs)
-
-    let crossCompiling = not $ null [() | CrossCompile <- flags_w_tpl]
-        beVerbose    = not $ null [() | Verbose <- flags_w_tpl]
-        keepFiles = not $ null [() | KeepFiles <- flags_w_tpl]
-
-    outputter <- if crossCompiling
-          then return (outputCross beVerbose keepFiles compiler flags_w_tpl)
-          else do linker <- case [l | Linker l <- flags_w_tpl] of
-                      []  -> return compiler
-                      ls  -> return (last ls)
-                  return (outputDirect flags_w_tpl beVerbose keepFiles compiler linker)
+    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
 
     forM_ files (\name -> do
-        (outName, outDir, outBase) <- case [f | Output f <- flags_w_tpl] of
+        (outName, outDir, outBase) <- case [f | Output f <- cFlags config3] of
              [] -> if not (null ext) && last ext == 'c'
                       then return (dir++base++init ext,  dir, base)
                       else
@@ -219,7 +173,7 @@ processFiles flags files usage = do
              _ -> onlyOne "output file"
         let file_name = dosifyPath name
         toks <- parseFile file_name
-        outputter outName outDir outBase file_name toks)
+        outputter config3 outName outDir outBase file_name toks)
 
 parseFile :: String -> IO [Token]
 parseFile name
index e2f1e20..7fb4e11 100644 (file)
@@ -31,7 +31,7 @@ Flag base3
 
 Executable hsc2hs
     Main-Is: Main.hs
-    Other-Modules: HSCParser, DirectCodegen, CrossCodegen, Common, C
+    Other-Modules: HSCParser, DirectCodegen, CrossCodegen, Common, C, Flags
     -- needed for ReadP (used by Data.Version)
     Hugs-Options: -98
     Extensions: CPP, ForeignFunctionInterface