Fix in-tree haddock on Windows

3 files changed, 48 insertions, 11 deletions

diff --git a/Makefile b/Makefile
index 692ccb04..937cee8b 100644
--- a/Makefile
+++ b/Makefile
@@ -1,8 +1,8 @@
 
 TOP=../..
 ENABLE_SHELL_WRAPPERS = YES
-EXTRA_INPLACE_CONFIGURE_FLAGS += --flags=-ghc-paths
-EXTRA_STAGE2_CONFIGURE_FLAGS += --flags=-ghc-paths
+EXTRA_INPLACE_CONFIGURE_FLAGS += --flags=in-ghc-tree
+EXTRA_STAGE2_CONFIGURE_FLAGS += --flags=in-ghc-tree
 
 include $(TOP)/mk/boilerplate.mk
 include $(TOP)/mk/cabal.mk
diff --git a/haddock.cabal b/haddock.cabal
index 5f486bd3..8756592a 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -57,9 +57,9 @@ data-files:
 	html/minus.gif
 	html/plus.gif
 
-flag ghc-paths
-  description: Should we use ghc-paths to find GHC? This is always enabled, except when building in a GHC tree.
-  default: True
+flag in-ghc-tree
+  description: Are we in a GHC tree?
+  default: False
   manual: True
 
 executable haddock
@@ -73,9 +73,11 @@ executable haddock
     containers,
     array
 
-  if flag(ghc-paths)
+  if flag(in-ghc-tree)
+    cpp-options: -DIN_GHC_TREE
+    extensions: ForeignFunctionInterface
+  else
     build-depends: ghc-paths
-    cpp-options: -DGHC_PATHS
 
   if impl(ghc >= 6.9)
     build-depends: Cabal >= 1.5, getopt
diff --git a/src/Main.hs b/src/Main.hs
index 310214c6..3e9d6422 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -33,9 +33,16 @@ import Data.Dynamic
 import Data.Maybe
 import Data.IORef
 import qualified Data.Map as Map
+import Data.Version
 import System.IO
 import System.Exit
 import System.Environment
+import System.FilePath
+#ifdef IN_GHC_TREE
+import Foreign
+import Foreign.C
+import Data.Int
+#endif
 
 import GHC
 #ifdef GHC_PATHS
@@ -140,10 +147,10 @@ main = handleTopExceptions $ do
       let libDir
             | Just dir <- getGhcLibDir flags = dir
             | otherwise =
-#ifdef GHC_PATHS
-                libdir -- from GHC.Paths
+#ifdef IN_GHC_TREE
+                error "No GhcLibDir found"
 #else
-                error "No GhcLibDir"
+                libdir -- from GHC.Paths
 #endif
 
       -- initialize GHC
@@ -200,7 +207,17 @@ render flags interfaces installedIfaces = do
     verbose = Flag_Verbose `elem` flags
 
   libdir <- case [str | Flag_Lib str <- flags] of
-		[] -> getDataDir -- provided by Cabal
+		[] ->
+#ifdef IN_GHC_TREE
+                      do m <- getExecDir
+                         case m of
+                             Nothing -> error "No libdir found"
+                             Just d ->
+                                 return (d </> ".." </> "share"
+                                           </> ("haddock-" ++ showVersion version))
+#else
+                      getDataDir -- provided by Cabal
+#endif
 		fs -> return (last fs)
 
   let css_file = case [str | Flag_CSS str <- flags] of
@@ -350,3 +367,21 @@ getPrologue flags
 		Left err -> throwE err
 		Right doc -> return (Just doc)
 	_otherwise -> throwE "multiple -p/--prologue options"
+
+getExecDir :: IO (Maybe String)
+#if defined(mingw32_HOST_OS)
+getExecDir = allocaArray len $ \buf -> do
+    ret <- getModuleFileName nullPtr buf len
+    if ret == 0
+        then return Nothing
+        else do s <- peekCString buf
+                return (Just (dropFileName s))
+  where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
+
+foreign import stdcall unsafe  "GetModuleFileNameA"
+  getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
+#else
+getExecDir = return Nothing
+#endif
+
+