Support where clauses, let bindings and case expressions in case splitting (fixes #395)

Language/Haskell/GhcMod/CaseSplit.hs

@@ -72,7 +72,7 @@ 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]
+        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

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/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/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