Merge remote-tracking branch 'kazu/master'

ChangeLog

@@ -1,3 +1,10 @@
+2014-08-24 v5.0.1.1
+        * Fix CaseSplitting faliure when using "fancy types" (see #336)
+        * Print error information in "spec" test suite when using `extract`
+
+2014-08-20 v5.0.1
+        * Fix missing file in "Data-Files"
+
 2014-08-20 v5.0.0
 	* ghc-mod consumes much less memory than ghc-mod-4.1.
 	* @serras brought the results of Google Summer code

Language/Haskell/GhcMod.hs

@@ -15,10 +15,10 @@ module Language.Haskell.GhcMod (
   , GhcPkgDb
   , Symbol
   , SymbolDb
+  , GhcModError(..)
   -- * Monad Types
   , GhcModT
   , IOish
-  , GhcModError(..)
   -- * Monad utilities
   , runGhcModT
   , withOptions

Language/Haskell/GhcMod/CaseSplit.hs

@@ -69,10 +69,10 @@ getSrcSpanTypeForSplit modSum lineNo colNo = do
 -- Information for a function case split
 getSrcSpanTypeForFnSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo)
 getSrcSpanTypeForFnSplit modSum lineNo colNo = do
-    p@ParsedModule{pm_parsed_source = pms} <- G.parseModule modSum
+    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:_ = listifyParsedSpans pms (lineNo, colNo) :: [Gap.GLMatch]
+        match:_ = listifySpans tcs (lineNo, colNo) :: [Gap.GLMatchI]
     case varPat of
       Nothing  -> return Nothing
       Just varPat' -> do

Language/Haskell/GhcMod/Gap.hs

@@ -37,6 +37,7 @@ module Language.Haskell.GhcMod.Gap (
   , benchmarkTargets
   , toModuleString
   , GLMatch
+  , GLMatchI
   , getClass
   , occName
   , setFlags
@@ -437,8 +438,10 @@ toModuleString mn = fromFilePath $ M.toFilePath mn
 
 #if __GLASGOW_HASKELL__ >= 708
 type GLMatch = LMatch RdrName (LHsExpr RdrName)
+type GLMatchI = LMatch Id (LHsExpr Id)
 #else
 type GLMatch = LMatch RdrName
+type GLMatchI = LMatch Id
 #endif
 
 getClass :: [LInstDecl Name] -> Maybe (Name, SrcSpan)

ghc-mod.cabal

@@ -1,5 +1,5 @@
 Name:                   ghc-mod
-Version:                5.0.1
+Version:                5.0.1.1
 Author:                 Kazu Yamamoto <kazu@iij.ad.jp>
                         Daniel Gröber <dxld@darkboxed.org>
                         Alejandro Serrano <trupill@gmail.com>
@@ -117,6 +117,9 @@ Library
   else
     Build-Depends:      convertible
                       , Cabal >= 1.10 && < 1.17
+  if impl(ghc <= 7.4.2)
+    -- Only used to constrain random to a version that still works with GHC 7.4
+    Build-Depends:      random <= 1.0.1.1
 
 Executable ghc-mod
   Default-Language:     Haskell2010

test/CaseSplitSpec.hs

@@ -0,0 +1,20 @@
+module CaseSplitSpec where
+
+import Language.Haskell.GhcMod
+import Test.Hspec
+import TestUtils
+import Dir
+
+main :: IO ()
+main = do
+  hspec spec
+
+spec :: Spec
+spec = do
+    describe "case split" $ do
+        it "does not blow up on HsWithBndrs panic" $ do
+            withDirectory_ "test/data/case-split" $ do
+                res <- runD $ splits "Vect.hs" 24 10
+                res `shouldBe` "24 1 24 30"++
+                        " \"mlAppend Nil y = _mlAppend_body\NUL"++
+                           "mlAppend (Cons x1 x2) y = _mlAppend_body\"\n"

test/TestUtils.hs

@@ -22,10 +22,12 @@ isolateCradle action =
  where
     modifyEnv e = e { gmCradle = (gmCradle e) { cradlePkgDbStack = [GlobalDb] } }
 
-extract :: IO (Either e a, w) -> IO a
+extract :: Show e => IO (Either e a, w) -> IO a
 extract action = do
-  (Right a, _) <- action
-  return a
+  (r,_) <- action
+  case r of
+    Right a ->  return a
+    Left e -> error $ show e
 
 runIsolatedGhcMod :: Options -> GhcModT IO a -> IO a
 runIsolatedGhcMod opt action = do

test/data/case-split/Vect.hs

@@ -0,0 +1,24 @@
+{-# LANGUAGE DataKinds, TypeFamilies, TypeOperators, GADTs, KindSignatures #-}
+
+module Vect where
+
+data Nat = Z | S Nat
+
+type family   (n :: Nat) :+ (m :: Nat) :: Nat
+type instance Z :+ m = m
+type instance S n :+ m = S (n :+ m)
+
+data Vect :: Nat -> * -> * where
+  VNil :: Vect Z a
+  (:::) :: a -> Vect n a -> Vect (S n) a
+
+vAppend :: Vect n a -> Vect m a -> Vect (n :+ m) a
+vAppend x y = _vAppend_body
+
+lAppend :: [a] -> [a] -> [a]
+lAppend x y = _lAppend_body
+
+data MyList a = Nil | Cons a (MyList a)
+
+mlAppend :: MyList a -> MyList a -> MyList a
+mlAppend x y = _mlAppend_body