Initial implementation of case splitting

- It doesn't handle vars correctly yet

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