[haddock @ 2004-05-28 20:17:55 by mthomas]

Windows: search for templates in executable directory. Unix: Haddock tries cwd first rather than error if no -l arg.

1 files changed, 40 insertions, 1 deletions

diff --git a/src/Main.hs b/src/Main.hs
index fa128388..96b76f2e 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -51,6 +51,12 @@ import Regex
 import PackedString
 #endif
 
+#if defined(mingw32_HOST_OS)
+import Foreign.Marshal.Array
+import Foreign
+import Foreign.C
+#endif
+
 -----------------------------------------------------------------------------
 -- Top-level stuff
 main :: IO ()
@@ -161,7 +167,10 @@ run flags files = do
 			(t:_) -> Just t
 
   libdir <- case [str | Flag_Lib str <- flags] of
-		[] -> dieMsg "no --lib option"
+		[] -> do maybe_exec_dir <- getBaseDir -- Get directory of executable
+			 case maybe_exec_dir of
+                                       Nothing  -> return "."
+                                       Just dir -> return (dir ++ "\\imports")
 		fs -> return (last fs)
 
   let css_file = case [str | Flag_CSS str <- flags] of
@@ -1125,3 +1134,33 @@ collectInstances mod_ifaces
 type ErrMsg = String
 type ErrMsgM a = Writer [ErrMsg] a
 
+getBaseDir :: IO (Maybe String)
+#if defined(mingw32_HOST_OS)
+getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
+		buf <- mallocArray len
+                ret <- getModuleFileName nullPtr buf len
+                if ret == 0 then free buf >> return Nothing
+                            else do s <- peekCString buf
+                                    free buf
+                                    return (Just (rootDir s))
+  where
+    rootDir s = reverse (dropList "/haddock.exe" (reverse (normalisePath s)))
+
+foreign import stdcall "GetModuleFileNameA" unsafe
+  getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
+#else
+getBaseDir :: IO (Maybe String) = do return Nothing
+#endif
+normalisePath :: String -> String
+-- Just changes '\' to '/'
+
+#if defined(mingw32_HOST_OS)
+normalisePath xs = subst '\\' '/' xs
+subst a b ls = map (\ x -> if x == a then b else x) ls
+#else
+normalisePath xs   = xs
+#endif
+dropList :: [b] -> [a] -> [a]
+dropList [] xs    = xs
+dropList _  xs@[] = xs
+dropList (_:xs) (_:ys) = dropList xs ys