Initial implementation of case splitting

- It doesn't handle vars correctly yet

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