Make Setup.hs suitable for building in a GHC tree
authorIan Lynagh <igloo@earth.li>
Sat, 7 Apr 2007 17:41:43 +0000 (17:41 +0000)
committerIan Lynagh <igloo@earth.li>
Sat, 7 Apr 2007 17:41:43 +0000 (17:41 +0000)
Setup.hs

index 9a994af..cf84de0 100644 (file)
--- a/Setup.hs
+++ b/Setup.hs
@@ -1,2 +1,59 @@
+
+module Main (main) where
+
+import Data.List
 import Distribution.Simple
-main = defaultMain
+import Distribution.PackageDescription
+import Distribution.PreProcess
+import Distribution.Setup
+import Distribution.Simple.LocalBuildInfo
+import System.Environment
+
+main :: IO ()
+main = do args <- getArgs
+          let (ghcArgs, args') = extractGhcArgs args
+              (_, args'') = extractConfigureArgs args'
+              hooks = defaultUserHooks {
+                  buildHook = add_ghc_options ghcArgs
+                            $ buildHook defaultUserHooks }
+          withArgs args'' $ defaultMainWithHooks hooks
+
+extractGhcArgs :: [String] -> ([String], [String])
+extractGhcArgs = extractPrefixArgs "--ghc-option="
+
+extractConfigureArgs :: [String] -> ([String], [String])
+extractConfigureArgs = extractPrefixArgs "--configure-option="
+
+extractPrefixArgs :: String -> [String] -> ([String], [String])
+extractPrefixArgs prefix args
+ = let f [] = ([], [])
+       f (x:xs) = case f xs of
+                      (wantedArgs, otherArgs) ->
+                          case removePrefix prefix x of
+                              Just wantedArg ->
+                                  (wantedArg:wantedArgs, otherArgs)
+                              Nothing ->
+                                  (wantedArgs, x:otherArgs)
+   in f args
+
+removePrefix :: String -> String -> Maybe String
+removePrefix "" ys = Just ys
+removePrefix (x:xs) (y:ys)
+ | x == y = removePrefix xs ys
+ | otherwise = Nothing
+
+type Hook a = PackageDescription -> LocalBuildInfo -> Maybe UserHooks -> a
+           -> IO ()
+
+add_ghc_options :: [String] -> Hook a -> Hook a
+add_ghc_options args f pd lbi muhs x
+ = do let lib' = case library pd of
+                     Just lib ->
+                         let bi = libBuildInfo lib
+                             opts = options bi ++ [(GHC, args)]
+                             bi' = bi { options = opts }
+                         in lib { libBuildInfo = bi' }
+                     Nothing -> error "Expected a library"
+          pd' = pd { library = Just lib' }
+      f pd' lbi muhs x
+