Really fix `newTempDir` on Windows

Language/Haskell/GhcMod/Cradle.hs

@@ -8,12 +8,11 @@ module Language.Haskell.GhcMod.Cradle (
 import Language.Haskell.GhcMod.GhcPkg
 import Language.Haskell.GhcMod.PathsAndFiles
 import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Utils
 
 import Control.Exception.IOChoice ((||>))
-import System.Directory (getCurrentDirectory, removeDirectoryRecursive,
-                         getTemporaryDirectory)
-import System.FilePath (takeDirectory,pathSeparators,splitDrive)
-import System.IO.Temp
+import System.Directory (getCurrentDirectory, removeDirectoryRecursive)
+import System.FilePath (takeDirectory)
 
 
 ----------------------------------------------------------------
@@ -28,15 +27,6 @@ findCradle = findCradle' =<< getCurrentDirectory
 findCradle' :: FilePath -> IO Cradle
 findCradle' dir = cabalCradle dir ||> sandboxCradle dir ||> plainCradle dir
 
-newTempDir :: FilePath -> IO FilePath
-newTempDir dir =
-    flip createTempDirectory uniqPathName =<< getTemporaryDirectory
- where
-   uniqPathName = "ghc-mod" ++ map escapeSlash (snd $ splitDrive dir)
-
-   escapeSlash c | c `elem` pathSeparators = '-'
-   escapeSlash c = c
-
 cleanupCradle :: Cradle -> IO ()
 cleanupCradle crdl = removeDirectoryRecursive $ cradleTempDir crdl
 

Language/Haskell/GhcMod/Utils.hs

@@ -1,11 +1,16 @@
 {-# LANGUAGE CPP #-}
 module Language.Haskell.GhcMod.Utils where
 
+import Control.Arrow
+import Data.Char
 import Language.Haskell.GhcMod.Error
 import MonadUtils (MonadIO, liftIO)
 import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist)
 import System.Exit (ExitCode(..))
 import System.Process (readProcessWithExitCode)
+import System.Directory (getTemporaryDirectory)
+import System.FilePath (splitDrive, joinDrive, pathSeparators)
+import System.IO.Temp (createTempDirectory)
 #ifndef SPEC
 import Control.Applicative ((<$>))
 import System.Environment
@@ -48,6 +53,24 @@ withDirectory_ dir action =
     gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory)
                 (\_ -> liftIO (setCurrentDirectory dir) >> action)
 
+uniqTempDirName :: FilePath -> FilePath
+uniqTempDirName dir =
+    uncurry (++)
+        $ map escapeDriveChar *** map escapePathChar
+        $ splitDrive dir
+ where
+    escapeDriveChar c
+        | isAlphaNum c = c
+        | otherwise = '-'
+
+    escapePathChar c
+        | c `elem` pathSeparators = '-'
+        | otherwise = c
+
+newTempDir :: FilePath -> IO FilePath
+newTempDir dir =
+    flip createTempDirectory (uniqTempDirName dir) =<< getTemporaryDirectory
+
 mightExist :: FilePath -> IO (Maybe FilePath)
 mightExist f = do
   exists <- doesFileExist f