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)
+    let varPat = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (LPat Id)
-        match:_ = listifySpans tcs (lineNo, colNo) :: [Gap.GLMatchI]
+        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
+      replaced    = map (replaceVarWithTyCon bindingText difference sVN) sT
-   in T.unpack $ T.intercalate (T.pack "\n") replaced
+      -- 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)
+findCabalFile :: FilePath -> IO (Maybe FilePath)
-findCabalFiles directory = do
+findCabalFile directory = do
-    -- Look for cabal files in all parent directories of @dir@
+    -- 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]
+   takeExtension' p = if takeFileName p == takeExtension p
-makeAbsolute dir fs = (dir </>) `map` fs
+                        then ""
+                        else takeExtension p
 
 zipMapM :: Monad m => (a -> m c) -> [a] -> m [(a,c)]
 zipMapM f as = mapM (\a -> liftM (a,) $ f a) as

elisp/ghc-info.el

@@ -127,7 +127,7 @@
 (defun ghc-expand-th ()
   (interactive)
   (let* ((file (buffer-file-name))
-	 (cmds (list "expand" file "-b" "\n"))
+	 (cmds (list "expand" file))
 	 (source (ghc-run-ghc-mod cmds)))
     (when source
       (ghc-display

ghc-mod.cabal

@@ -34,6 +34,7 @@ Extra-Source-Files:     ChangeLog
                         test/data/broken-cabal/cabal.sandbox.config.in
                         test/data/broken-sandbox/*.cabal
                         test/data/broken-sandbox/cabal.sandbox.config
+                        test/data/case-split/*.hs
                         test/data/cabal-flags/*.cabal
                         test/data/check-test-subdir/*.cabal
                         test/data/check-test-subdir/src/Check/Test/*.hs

test/CabalApiSpec.hs

@@ -3,7 +3,6 @@
 module CabalApiSpec where
 
 import Control.Applicative
-import Data.Maybe
 import Language.Haskell.GhcMod.CabalApi
 import Language.Haskell.GhcMod.Cradle
 import Language.Haskell.GhcMod.Types
@@ -35,7 +34,8 @@ spec = do
             cwd <- getCurrentDirectory
             withDirectory "test/data/subdir1/subdir2" $ \dir -> do
                 crdl <- findCradle
-                pkgDesc <- runD $ parseCabalFile crdl $ fromJust $ cradleCabalFile crdl
+                let Just cabalFile = cradleCabalFile crdl
+                pkgDesc <- runD $ parseCabalFile crdl cabalFile
                 res <- runD $ getCompilerOptions [] crdl pkgDesc
                 let res' = res {
                         ghcOptions  = ghcOptions res

test/CaseSplitSpec.hs

@@ -18,3 +18,24 @@ spec = do
                 res `shouldBe` "24 1 24 30"++
                         " \"mlAppend Nil y = _mlAppend_body\NUL"++
                            "mlAppend (Cons x1 x2) y = _mlAppend_body\"\n"
+
+        it "works with case expressions" $ do
+            withDirectory_ "test/data/case-split" $ do
+                res <- runD $ splits "Vect.hs" 28 20
+                res `shouldBe` "28 19 28 39"++
+                        " \"Nil -> _mlAppend_body\NUL"++
+                        "                  (Cons x'1 x'2) -> _mlAppend_body\"\n"
+
+        it "works with where clauses" $ do
+            withDirectory_ "test/data/case-split" $ do
+                res <- runD $ splits "Vect.hs" 34 17
+                res `shouldBe` "34 5 34 43"++
+                        " \"mlReverse' Nil accum = _mlReverse_body\NUL"++
+                        "    mlReverse' (Cons xs'1 xs'2) accum = _mlReverse_body\"\n"
+
+        it "works with let bindings" $ do
+            withDirectory_ "test/data/case-split" $ do
+                res <- runD $ splits "Vect.hs" 38 33
+                res `shouldBe` "38 21 38 59"++
+                        " \"mlReverse' Nil accum = _mlReverse_body\NUL"++
+                        "                    mlReverse' (Cons xs'1 xs'2) accum = _mlReverse_body\"\n"

test/PathsAndFilesSpec.hs

@@ -8,6 +8,7 @@ import Language.Haskell.GhcMod.GhcPkg
 #endif
 
 import System.Directory
+import System.Environment
 import System.FilePath ((</>))
 import Test.Hspec
 
@@ -28,3 +29,14 @@ spec = do
 
         it "returns Nothing if the sandbox config file is broken" $ do
             getSandboxDb "test/data/broken-sandbox" `shouldReturn` Nothing
+
+    describe "getCabalFiles" $ do
+        it "doesn't think $HOME/.cabal is a cabal file" $ do
+            (getCabalFiles =<< getEnv "HOME") `shouldReturn` []
+
+    describe "findCabalFile" $ do
+        it "works" $ do
+            findCabalFile "test/data" `shouldReturn` Just "test/data/cabalapi.cabal"
+
+        it "finds cabal files in parent directories" $ do
+            findCabalFile "test/data/subdir1/subdir2" `shouldReturn` Just "test/data/cabalapi.cabal"

test/data/case-split/Vect.hs

@@ -22,3 +22,18 @@ data MyList a = Nil | Cons a (MyList a)
 
 mlAppend :: MyList a -> MyList a -> MyList a
 mlAppend x y = _mlAppend_body
+
+mlAppend2 :: MyList a -> MyList a -> MyList a
+mlAppend2 x y = case x of
+                  x' -> _mlAppend_body
+
+mlReverse :: MyList a -> MyList a
+mlReverse xs = mlReverse' xs Nil
+  where
+    mlReverse' :: MyList a -> MyList a -> MyList a
+    mlReverse' xs' accum = _mlReverse_body
+
+mlReverse2 :: MyList a -> MyList a
+mlReverse2 xs = let mlReverse' :: MyList a -> MyList a -> MyList a
+                    mlReverse' xs' accum = _mlReverse_body
+                 in mlReverse' xs Nil