Merge branch 'master' into release

Language/Haskell/GhcMod/CaseSplit.hs

@@ -71,8 +71,8 @@ getSrcSpanTypeForFnSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe
 getSrcSpanTypeForFnSplit modSum lineNo colNo = do
     p@ParsedModule{pm_parsed_source = _pms} <- G.parseModule modSum
     tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
-    let varPat  = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (LPat Id)
-        match:_ = listifySpans tcs (lineNo, colNo) :: [Gap.GLMatchI]
+    let varPat = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (LPat Id)
+        match  = last $ listifySpans tcs (lineNo, colNo) :: Gap.GLMatchI
     case varPat of
       Nothing  -> return Nothing
       Just varPat' -> do
@@ -188,8 +188,11 @@ getCaseSplitText text (SplitToTextInfo { sVarName = sVN, sBindingSpan = sBS
                                        , sVarSpan = sVS, sTycons = sT })  =
   let bindingText = getBindingText text sBS
       difference  = srcSpanDifference sBS sVS
-      replaced    = concatMap (replaceVarWithTyCon bindingText difference sVN) sT
-   in T.unpack $ T.intercalate (T.pack "\n") replaced
+      replaced    = map (replaceVarWithTyCon bindingText difference sVN) sT
+      -- The newly generated bindings need to be indented to align with the
+      -- original binding.
+      replaced'   = head replaced : map (indentBindingTo sBS) (tail replaced)
+   in T.unpack $ T.intercalate (T.pack "\n") (concat replaced')
 
 getBindingText :: [T.Text] -> SrcSpan -> [T.Text]
 getBindingText text srcSpan =
@@ -220,3 +223,9 @@ replaceVarWithTyCon text (vsl,vsc,_,vec) varname tycon =
                                then T.take vsc line `T.append` tycon'' `T.append` T.drop vec line
                                else T.replicate spacesToAdd (T.pack " ") `T.append` line)
               [0 ..] text
+
+indentBindingTo :: SrcSpan -> [T.Text] -> [T.Text]
+indentBindingTo bndLoc binds =
+  let Just (_,sl,_,_) = Gap.getSrcSpan bndLoc
+      indent      = (T.replicate (sl - 1) (T.pack " ") `T.append`)
+   in indent (head binds) : tail binds

Language/Haskell/GhcMod/Cradle.hs

@@ -32,7 +32,7 @@ cleanupCradle crdl = removeDirectoryRecursive $ cradleTempDir crdl
 
 cabalCradle :: FilePath -> IO Cradle
 cabalCradle wdir = do
-    Just cabalFile <- findCabalFiles wdir
+    Just cabalFile <- findCabalFile wdir
     let cabalDir = takeDirectory cabalFile
     pkgDbStack <- getPackageDbStack cabalDir
     tmpDir <- newTempDir cabalDir

Language/Haskell/GhcMod/Error.hs

@@ -30,8 +30,9 @@ data GhcModError = GMENoMsg
                  -- ^ Launching an operating system process failed. The first
                  -- field is the command.
                  | GMENoCabalFile
+                 -- ^ No cabal file found.
                  | GMETooManyCabalFiles [FilePath]
-                 -- ^ No or too many cabal files found.
+                 -- ^ Too many cabal files found.
                    deriving (Eq,Show,Typeable)
 
 instance Exception GhcModError

Language/Haskell/GhcMod/Monad.hs

@@ -99,7 +99,7 @@ import Control.Monad.Error (Error(..))
 #endif
 import Control.Monad.Journal.Class
 
-import Data.Maybe (fromJust, isJust)
+import Data.Maybe (isJust)
 import Data.IORef (IORef, readIORef, writeIORef, newIORef)
 import System.Directory (getCurrentDirectory)
 
@@ -166,7 +166,7 @@ instance MonadIO m => MonadIO (GhcModT m) where
 
      where
        fromEx :: Exception e => SomeException -> e
-       fromEx = fromJust . fromException
+       fromEx se = let Just e = fromException se in e
        isIOError se =
            case fromException se of
              Just (_ :: IOError) -> True
@@ -221,7 +221,8 @@ initializeFlagsWithCradle opt c
     cabal = isJust mCabalFile
     ghcopts = ghcUserOptions opt
     withCabal = do
-        pkgDesc <- parseCabalFile c $ fromJust mCabalFile
+        let Just cabalFile = mCabalFile
+        pkgDesc <- parseCabalFile c cabalFile
         compOpts <- getCompilerOptions ghcopts c pkgDesc
         initSession CabalPkg opt compOpts
     withSandbox = initSession SingleFile opt compOpts

Language/Haskell/GhcMod/PathsAndFiles.hs

@@ -28,24 +28,32 @@ type FileName = String
 -- is assumed to be the project directory. If only one cabal file exists in this
 -- directory it is returned otherwise @findCabalFiles@ throws 'GMENoCabalFile'
 -- or 'GMETooManyCabalFiles'
-findCabalFiles :: FilePath -> IO (Maybe FilePath)
-findCabalFiles directory = do
-    -- Look for cabal files in all parent directories of @dir@
+findCabalFile :: FilePath -> IO (Maybe FilePath)
+findCabalFile directory = do
+    -- Look for cabal files in @dir@ and all it's parent directories
     dcs <- getCabalFiles `zipMapM` parents directory
     -- Extract first non-empty list, which represents a directory with cabal
     -- files.
-    case find (not . null) $ uncurry makeAbsolute `map` dcs of
+    case find (not . null) $ uncurry appendDir `map` dcs of
       Just []          -> throw $ GMENoCabalFile
       Just cfs@(_:_:_) -> throw $ GMETooManyCabalFiles cfs
       a  -> return $ head <$> a
+ where
+   appendDir :: DirPath -> [FileName] -> [FilePath]
+   appendDir dir fs = (dir </>) `map` fs
 
 -- | @getCabalFiles dir@. Find all files ending in @.cabal@ in @dir@.
 getCabalFiles :: DirPath -> IO [FileName]
 getCabalFiles dir =
-    filter ((==) ".cabal" . takeExtension) <$> getDirectoryContents dir
+    filterM isCabalFile =<< getDirectoryContents dir
+ where
+   isCabalFile f = do
+     exists <- doesFileExist $ dir </> f
+     return (exists && takeExtension' f == ".cabal")
 
-makeAbsolute :: DirPath -> [FileName] -> [FilePath]
-makeAbsolute dir fs = (dir </>) `map` fs
+   takeExtension' p = if takeFileName p == takeExtension p
+                        then ""
+                        else takeExtension p
 
 zipMapM :: Monad m => (a -> m c) -> [a] -> m [(a,c)]
 zipMapM f as = mapM (\a -> liftM (a,) $ f a) as