Initial implementation of case splitting

- It doesn't handle vars correctly yet

Language/Haskell/GhcMod.hs

@@ -27,6 +27,7 @@ module Language.Haskell.GhcMod (
   , rootInfo
   , packageDoc
   , findSymbol
+  , splitVar
   ) where
 
 import Language.Haskell.GhcMod.Boot

Language/Haskell/GhcMod/Convert.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleInstances, FlexibleContexts, OverlappingInstances #-}
 
 module Language.Haskell.GhcMod.Convert (convert, convert') where
 
@@ -76,6 +76,18 @@ instance ToString [((Int,Int,Int,Int),String)] where
         toS x = ('(' :) . tupToString opt x . (')' :)
     toPlain opt = inter '\n' . map (tupToString opt)
 
+instance ToString ((Int,Int,Int,Int),String) where
+    toLisp  opt x = ('(' :) . tupToString opt x . (')' :)
+    toPlain opt x = tupToString opt x
+
+instance (ToString a, ToString b) => ToString (a,b) where
+    toLisp  opt (x,y) = toSexp2 $ [toLisp opt x, toLisp opt y]
+    toPlain opt (x,y) = inter '\n' [toPlain opt x, toPlain opt y]
+
+instance (ToString a, ToString b, ToString c) => ToString (a,b,c) where
+    toLisp  opt (x,y,z) = toSexp2 $ [toLisp opt x, toLisp opt y, toLisp opt z]
+    toPlain opt (x,y,z) = inter '\n' [toPlain opt x, toPlain opt y, toPlain opt z]
+
 toSexp1 :: Options -> [String] -> Builder
 toSexp1 opt ss = ('(' :) . inter ' ' (map (quote opt) ss) . (')' :)
 

Language/Haskell/GhcMod/Gap.hs

@@ -23,6 +23,7 @@ module Language.Haskell.GhcMod.Gap (
   , HasType(..)
   , errorMsgSpan
   , typeForUser
+  , nameForUser
   , deSugar
   , showDocWith
   , GapThing(..)
@@ -47,6 +48,7 @@ import HscTypes
 import Language.Haskell.GhcMod.GHCChoice
 import Language.Haskell.GhcMod.Types
 import NameSet
+import OccName
 import Outputable
 import PprTyThing
 import StringBuffer
@@ -337,6 +339,13 @@ typeForUser = pprTypeForUser
 typeForUser = pprTypeForUser False
 #endif
 
+nameForUser :: Name -> SDoc
+#if __GLASGOW_HASKELL__ >= 708
+nameForUser = pprOccName . getOccName
+#else
+nameForUser = pprOccName False . getOccName
+#endif
+
 deSugar :: TypecheckedModule -> LHsExpr Id -> HscEnv
          -> IO (Maybe CoreExpr)
 #if __GLASGOW_HASKELL__ >= 708

Language/Haskell/GhcMod/Ghc.hs

@@ -8,6 +8,7 @@ module Language.Haskell.GhcMod.Ghc (
   , check
   , info
   , types
+  , splits
   , modules
   -- * 'SymMdlDb'
   , Symbol

Language/Haskell/GhcMod/Info.hs

@@ -6,6 +6,8 @@ module Language.Haskell.GhcMod.Info (
   , info
   , typeExpr
   , types
+  , splitVar
+  , splits
   ) where
 
 import Control.Applicative ((<$>))
@@ -13,7 +15,7 @@ import CoreMonad (liftIO)
 import CoreUtils (exprType)
 import Data.Function (on)
 import Data.Generics
-import Data.List (sortBy)
+import Data.List (find, sortBy)
 import Data.Maybe (catMaybes, fromMaybe)
 import Data.Ord as O
 import Exception (ghandle, SomeException(..))
@@ -28,6 +30,9 @@ import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Convert
 import Outputable (PprStyle)
 import TcHsSyn (hsPatType)
+import qualified Type as Ty
+import qualified TyCon as Ty
+import qualified DataCon as Ty
 
 ----------------------------------------------------------------
 
@@ -136,3 +141,92 @@ inModuleContext file action =
         dflag <- G.getSessionDynFlags
         style <- getStyle
         action dflag style
+
+----------------------------------------------------------------
+
+data SplitInfo = SplitInfo (SrcSpan, Type) (SrcSpan, Type)
+
+-- | Splitting a variable in a equation.
+splitVar :: Options
+         -> Cradle
+         -> FilePath     -- ^ A target file.
+         -> Int          -- ^ Line number.
+         -> Int          -- ^ Column number.
+         -> IO String
+splitVar opt cradle file lineNo colNo = withGHC' $ do
+    initializeFlagsWithCradle opt cradle
+    splits opt file lineNo colNo
+
+-- | Splitting a variable in a equation.
+splits :: Options
+       -> FilePath     -- ^ A target file.
+       -> Int          -- ^ Line number.
+       -> Int          -- ^ Column number.
+       -> Ghc String
+splits opt file lineNo colNo = ghandle handler body
+  where
+    body = inModuleContext file $ \dflag style -> do
+        modSum <- Gap.fileModSummary file
+        splitInfo <- getSrcSpanTypeForSplit modSum lineNo colNo
+        case splitInfo of
+          Nothing -> return ""
+          Just (SplitInfo var@(_,varT) eq) -> do
+            return $ convert opt $ (toTup dflag style var, toTup dflag style eq, getTyCons dflag style varT)
+    handler (SomeException _) = return []
+
+getSrcSpanTypeForSplit :: G.ModSummary -> Int -> Int -> Ghc (Maybe SplitInfo)
+getSrcSpanTypeForSplit modSum lineNo colNo = do
+    p <- G.parseModule modSum
+    tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
+    let bs:_ = listifySpans tcs (lineNo, colNo) :: [LHsBind Id]
+        ps = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (LPat Id)
+    case ps of
+      Nothing  -> return Nothing
+      Just ps' -> do bts <- getType tcm bs
+                     pts <- getType tcm ps'
+                     case (bts, pts) of
+                       (Just bI, Just pI) -> return $ Just (SplitInfo pI bI)
+                       _                  -> return Nothing
+
+isPatternVar :: LPat Id -> Bool
+isPatternVar (L _ (G.VarPat _)) = True
+isPatternVar _                  = False
+
+getTyCons :: DynFlags -> PprStyle -> G.Type ->  [String]
+getTyCons dflag style ty | Just (tyCon, _) <- Ty.splitTyConApp_maybe ty =
+  map (getTyCon dflag style) (Ty.tyConDataCons tyCon)
+getTyCons _ _ _ = ["v"]
+
+getTyCon :: DynFlags -> PprStyle -> Ty.DataCon -> String
+getTyCon dflag style dcon =
+  let name = showName dflag style $ Ty.dataConName dcon
+  in if Ty.dataConIsInfix dcon
+     then -- We have an infix constructor
+          case Ty.dataConSourceArity dcon of
+            0 -> name
+            1 -> "v " ++ name
+            n -> "v " ++ name ++ " " ++ newVars (n-1)
+     else case Ty.dataConFieldLabels dcon of
+            []   -> -- We have a non-record constructor
+                    name ++ " " ++ newVars (Ty.dataConSourceArity dcon)
+            flds -> -- We have a record constructor
+                    name ++ " { " ++ showFieldNames dflag style flds ++ " }"
+            
+
+newVar :: String
+newVar = "v"
+
+newVars :: Int -> String
+newVars 0 = ""
+newVars 1 = newVar
+newVars n = newVar ++ " " ++ newVars (n-1) ++ " " ++ newVar
+
+showName :: DynFlags -> PprStyle -> G.Name -> String
+showName dflag style name = showOneLine dflag style $ Gap.nameForUser name
+
+showFieldNames :: DynFlags -> PprStyle -> [G.Name] -> String
+showFieldNames _     _     []      = "" -- This should never happen
+showFieldNames dflag style [first] = let f = showName dflag style first
+                                      in f ++ " = " ++ f
+showFieldNames dflag style (x:xs)  = let f = showName dflag style x
+                                      in f ++ " = " ++ f ++ ", " ++ showFieldNames dflag style xs

src/GHCMod.hs

@@ -38,6 +38,7 @@ usage =    progVersion
         ++ "\t ghc-mod debug" ++ ghcOptHelp ++ "\n"
         ++ "\t ghc-mod info" ++ ghcOptHelp ++ "<HaskellFile> <module> <expression>\n"
         ++ "\t ghc-mod type" ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
+        ++ "\t ghc-mod split" ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
         ++ "\t ghc-mod find <symbol>\n"
         ++ "\t ghc-mod lint [-h opt] <HaskellFile>\n"
         ++ "\t ghc-mod root\n"
@@ -119,6 +120,7 @@ main = flip E.catches handlers $ do
       "debug"   -> debugInfo opt cradle
       "info"    -> nArgs 3 infoExpr opt cradle cmdArg1 cmdArg3
       "type"    -> nArgs 4 $ typeExpr opt cradle cmdArg1 (read cmdArg3) (read cmdArg4)
+      "split"   -> nArgs 4 $ splitVar opt cradle cmdArg1 (read cmdArg3) (read cmdArg4)
       "find"    -> runGhcMod opt $ nArgs 1 $ findSymbol cmdArg1
       "lint"    -> nArgs 1 withFile (lintSyntax opt) cmdArg1
       "root"    -> rootInfo opt cradle

src/GHCModi.hs

@@ -144,6 +144,7 @@ loop opt set mvar = do
         "lint"   -> toGhcMod $ lintStx  opt set arg
         "info"   -> toGhcMod $ showInfo opt set arg
         "type"   -> toGhcMod $ showType opt set arg
+        "split"  -> toGhcMod $ doSplit  opt set arg
         "boot"   -> bootIt set
         "browse" -> browseIt set arg
         "quit"   -> return ("quit", False, set)
@@ -254,6 +255,16 @@ showType opt set fileArg  = do
     ret <- types opt file (read line) (read column)
     return (ret, True, set')
 
+doSplit :: Options
+        -> Set FilePath
+        -> FilePath
+        -> Ghc (String, Bool, Set FilePath)
+doSplit opt set fileArg  = do
+    let [file, line, column] = words fileArg
+    set' <- newFileSet set file
+    ret <- splits opt file (read line) (read column)
+    return (ret, True, set')
+
 ----------------------------------------------------------------
 
 bootIt :: Set FilePath