Merge branch 'serras-master'

Language/Haskell/GhcMod.hs

@@ -20,6 +20,7 @@ module Language.Haskell.GhcMod (
   , expandTemplate
   , infoExpr
   , typeExpr
+  , fillSig
   , listModules
   , listLanguages
   , listFlags
@@ -27,6 +28,7 @@ module Language.Haskell.GhcMod (
   , rootInfo
   , packageDoc
   , findSymbol
+  , splitVar
   ) where
 
 import Language.Haskell.GhcMod.Boot
@@ -41,4 +43,6 @@ import Language.Haskell.GhcMod.Lang
 import Language.Haskell.GhcMod.Lint
 import Language.Haskell.GhcMod.List
 import Language.Haskell.GhcMod.PkgDoc
+import Language.Haskell.GhcMod.FillSig
+import Language.Haskell.GhcMod.CaseSplit
 import Language.Haskell.GhcMod.Types

Language/Haskell/GhcMod/CabalConfig.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+
 -- | Reading cabal @dist/setup-config@
 module Language.Haskell.GhcMod.CabalConfig (
     CabalConfig
@@ -15,7 +17,11 @@ import qualified Language.Haskell.GhcMod.Cabal18 as C18
 import qualified Control.Exception as E
 import Control.Applicative ((<$>))
 import Control.Monad (mplus)
+#if MIN_VERSION_mtl(2,2,1)
+import Control.Monad.Except ()
+#else
 import Control.Monad.Error ()
+#endif
 import Data.Maybe ()
 import Data.Set ()
 import Data.List (find,tails,isPrefixOf,isInfixOf,nub,stripPrefix)

Language/Haskell/GhcMod/CaseSplit.hs

@@ -0,0 +1,225 @@
+{-# LANGUAGE CPP #-}
+
+module Language.Haskell.GhcMod.CaseSplit (
+    splitVar
+  , splits
+  ) where
+
+import Data.List (find, intercalate)
+import qualified Data.Text as T
+import qualified Data.Text.IO as T (readFile)
+import Exception (ghandle, SomeException(..))
+import GHC (GhcMonad, LHsBind, LHsExpr, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))
+import qualified GHC as G
+import Language.Haskell.GhcMod.GHCApi
+import Language.Haskell.GhcMod.Gap (HasType(..))
+import qualified Language.Haskell.GhcMod.Gap as Gap
+import Language.Haskell.GhcMod.Monad
+import Language.Haskell.GhcMod.SrcUtils
+import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Convert
+import MonadUtils (liftIO)
+import Outputable (PprStyle)
+import qualified Type as Ty
+import qualified TyCon as Ty
+import qualified DataCon as Ty
+
+----------------------------------------------------------------
+-- CASE SPLITTING
+----------------------------------------------------------------
+
+data SplitInfo = SplitInfo G.Name (SrcSpan,Type) (SrcSpan, Type) [SrcSpan]
+data SplitToTextInfo = SplitToTextInfo { sVarName     :: String
+                                       , sBindingSpan :: SrcSpan
+                                       , sVarSpan     :: SrcSpan
+                                       , sTycons      :: [String]
+                                       }
+
+-- | 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 = runGhcMod opt $ do
+    initializeFlagsWithCradle opt cradle
+    splits file lineNo colNo
+
+-- | Splitting a variable in a equation.
+splits :: FilePath     -- ^ A target file.
+       -> Int          -- ^ Line number.
+       -> Int          -- ^ Column number.
+       -> GhcMod String
+splits file lineNo colNo = ghandle handler body
+  where
+    body = inModuleContext file $ \dflag style -> do
+        opt <- options
+        modSum <- Gap.fileModSummary file
+        whenFound' opt (getSrcSpanTypeForSplit modSum lineNo colNo) $
+          \(SplitInfo varName (bndLoc,_) (varLoc,varT) _matches) -> do
+             let varName' = showName dflag style varName  -- Convert name to string
+             text <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $
+                                                getTyCons dflag style varName varT)
+             return (fourInts bndLoc, text)
+    handler (SomeException _) = emptyResult =<< options
+
+----------------------------------------------------------------
+-- a. Code for getting the information of the variable
+
+getSrcSpanTypeForSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo)
+getSrcSpanTypeForSplit modSum lineNo colNo = do
+    p@ParsedModule{pm_parsed_source = pms} <- G.parseModule modSum
+    tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
+    let bs:_ = listifySpans tcs (lineNo, colNo) :: [LHsBind Id]
+        varPat  = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (LPat Id)
+        match:_ = listifyParsedSpans pms (lineNo, colNo)
+#if __GLASGOW_HASKELL__ < 708
+                    :: [G.LMatch G.RdrName]
+#else
+                    :: [G.LMatch G.RdrName (LHsExpr G.RdrName)]
+#endif
+    case varPat of
+      Nothing  -> return Nothing
+      Just varPat' -> do
+        varT <- getType tcm varPat'  -- Finally we get the type of the var
+        bsT  <- getType tcm bs
+        case (varT, bsT) of
+          (Just varT', Just (_,bsT')) ->
+            let (L matchL (G.Match _ _ (G.GRHSs rhsLs _))) = match
+            in return $ Just (SplitInfo (getPatternVarName varPat') (matchL,bsT') varT' (map G.getLoc rhsLs) )
+          _ -> return Nothing
+
+isPatternVar :: LPat Id -> Bool
+isPatternVar (L _ (G.VarPat _)) = True
+isPatternVar _                  = False
+
+getPatternVarName :: LPat Id -> G.Name
+getPatternVarName (L _ (G.VarPat vName)) = G.getName vName
+getPatternVarName _                      = error "This should never happend"
+
+----------------------------------------------------------------
+-- b. Code for getting the possible constructors
+
+getTyCons :: DynFlags -> PprStyle -> G.Name -> G.Type ->  [String]
+getTyCons dflag style name ty | Just (tyCon, _) <- Ty.splitTyConApp_maybe ty =
+  let name' = showName dflag style name  -- Convert name to string
+  in getTyCon dflag style name' tyCon
+getTyCons dflag style name _ = [showName dflag style name]
+
+-- Write cases for one type
+getTyCon :: DynFlags -> PprStyle -> String -> Ty.TyCon -> [String]
+-- 1. Non-matcheable type constructors
+getTyCon _ _ name tyCon | isNotMatcheableTyCon tyCon = [name]
+-- 2. Special cases
+-- 2.1. Tuples
+getTyCon _ _ name tyCon | Ty.isTupleTyCon tyCon =
+  let [uniqueDataCon] = Ty.tyConDataCons tyCon
+      tupleArity = Ty.dataConSourceArity uniqueDataCon
+      -- Deal with both boxed and unboxed tuples
+      isUnboxed = Ty.isUnboxedTupleTyCon tyCon
+      startSign = if isUnboxed then "(#" else "("
+      endSign   = if isUnboxed then "#)" else ")"
+  in [ startSign ++ intercalate "," (map (\n -> name ++ show n) [1 .. tupleArity]) ++ endSign ]
+-- 3. General case
+getTyCon dflag style name tyCon = map (getDataCon dflag style name) (Ty.tyConDataCons tyCon)
+
+-- These type constructors should not be matched against
+isNotMatcheableTyCon :: Ty.TyCon -> Bool
+isNotMatcheableTyCon ty = Ty.isPrimTyCon ty  -- Primitive types, such as Int#
+                       || Ty.isFunTyCon ty   -- Function types
+
+-- Write case for one constructor
+getDataCon :: DynFlags -> PprStyle -> String -> Ty.DataCon -> String
+-- 1. Infix constructors
+getDataCon dflag style vName dcon | Ty.dataConIsInfix dcon =
+  let dName  = showName dflag style $ Ty.dataConName dcon
+  in case Ty.dataConSourceArity dcon of
+       0 -> dName
+       1 -> vName ++ dName
+       n -> if dName == ":" -- Special case for lists
+            then vName ++ ":" ++ vName ++ "s"
+            else newVar vName 1 ++ " " ++ dName ++ " " ++ newVars vName 2 (n-1)
+-- 2. Non-record, non-infix syntax
+getDataCon dflag style vName dcon | [] <- Ty.dataConFieldLabels dcon =
+  let dName  = showName dflag style $ Ty.dataConName dcon
+  in if last dName == '#'  -- Special case for I#, C# and so on
+     then vName
+     else case Ty.dataConSourceArity dcon of
+            0 -> dName
+            _ -> dName ++ " " ++ newVarsSpecialSingleton vName 1 (Ty.dataConSourceArity dcon)
+-- 3. Records
+getDataCon dflag style vName dcon =
+  let dName = showName dflag style $ Ty.dataConName dcon
+      flds  = Ty.dataConFieldLabels dcon
+  in dName ++ " { " ++ showFieldNames dflag style vName flds ++ " }"
+
+-- Create a new variable by adjoining a number
+newVar :: String -> Int -> String
+newVar v n = v ++ show n
+
+-- Create a list of variables which start with the same prefix
+newVars :: String -> Int -> Int -> String
+newVars _ _ 0 = ""
+newVars v s 1 = newVar v s
+newVars v s m = newVar v s ++ " " ++ newVars v (s+1) (m-1)
+
+-- Create a list of variables which start with the same prefix
+-- Special case for a single variable, in which case no number is adjoint
+newVarsSpecialSingleton :: String -> Int -> Int -> String
+newVarsSpecialSingleton v _     1 = v
+newVarsSpecialSingleton v start n = newVars v start n
+
+showFieldNames :: DynFlags -> PprStyle -> String -> [G.Name] -> String
+showFieldNames _     _     _ []      = "" -- This should never happen
+showFieldNames dflag style v (x:xs) = let fName = showName dflag style x
+                                          fAcc  = fName ++ " = " ++ v ++ "_" ++ fName
+                                       in case xs of
+                                            [] -> fAcc
+                                            _  -> fAcc ++ ", " ++ showFieldNames dflag style v xs
+
+----------------------------------------------------------------
+-- c. Code for performing the case splitting
+
+genCaseSplitTextFile :: GhcMonad m => FilePath -> SplitToTextInfo -> m String
+genCaseSplitTextFile file info = liftIO $ do
+  text <- T.readFile file
+  return $ getCaseSplitText (T.lines text) info
+
+getCaseSplitText :: [T.Text] -> SplitToTextInfo -> String
+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
+
+getBindingText :: [T.Text] -> SrcSpan -> [T.Text]
+getBindingText text srcSpan =
+  let Just (sl,sc,el,ec) = Gap.getSrcSpan srcSpan
+      lines_ = drop (sl - 1) $ take el text
+   in if sl == el
+      then -- only one line
+           [T.drop (sc - 1) $ T.take ec $ head lines_]
+      else -- several lines
+            let (first,rest,last_) = (head lines_, tail $ init lines_, last lines_)
+             in (T.drop (sc - 1) first) : rest ++ [T.take ec last_]
+
+srcSpanDifference :: SrcSpan -> SrcSpan -> (Int,Int,Int,Int)
+srcSpanDifference b v =
+  let Just (bsl,bsc,_   ,_)  = Gap.getSrcSpan b
+      Just (vsl,vsc,vel,vec) = Gap.getSrcSpan v
+   in (vsl - bsl, vsc - bsc, vel - bsl, vec - bsc) -- assume variable in one line
+
+replaceVarWithTyCon :: [T.Text] -> (Int,Int,Int,Int) -> String -> String -> [T.Text]
+replaceVarWithTyCon text (vsl,vsc,_,vec) varname tycon = 
+  let tycon'      = if ' ' `elem` tycon || ':' `elem` tycon then "(" ++ tycon ++ ")" else tycon
+      lengthDiff  = length tycon' - length varname
+      tycon''     = T.pack $ if lengthDiff < 0 then tycon' ++ replicate (-lengthDiff) ' ' else tycon'
+      spacesToAdd = if lengthDiff < 0 then 0 else lengthDiff
+   in zipWith (\n line -> if n < vsl
+                          then line  -- before variable starts
+                          else if n == vsl
+                               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

Language/Haskell/GhcMod/Convert.hs

@@ -1,6 +1,6 @@
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleInstances, FlexibleContexts, OverlappingInstances #-}
 
-module Language.Haskell.GhcMod.Convert (convert, convert') where
+module Language.Haskell.GhcMod.Convert (convert, convert', emptyResult, whenFound, whenFound') where
 
 import Language.Haskell.GhcMod.Monad
 import Language.Haskell.GhcMod.Types
@@ -76,12 +76,26 @@ 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 (String, (Int,Int,Int,Int),[String]) where
+    toLisp  opt (s,x,y) = toSexp2 $ [toLisp opt s, ('(' :) . fourIntsToString opt x . (')' :), toLisp opt y]
+    toPlain opt (s,x,y) = inter '\n' [toPlain opt s, fourIntsToString opt x, toPlain opt y]
+
 toSexp1 :: Options -> [String] -> Builder
 toSexp1 opt ss = ('(' :) . inter ' ' (map (quote opt) ss) . (')' :)
 
 toSexp2 :: [Builder] -> Builder
 toSexp2 ss = ('(' :) . (inter ' ' ss) . (')' :)
 
+fourIntsToString :: Options -> (Int,Int,Int,Int) -> Builder
+fourIntsToString _ (a,b,c,d) = (show a ++) . (' ' :)
+                             . (show b ++) . (' ' :)
+                             . (show c ++) . (' ' :)
+                             . (show d ++)
+
 tupToString :: Options -> ((Int,Int,Int,Int),String) -> Builder
 tupToString opt ((a,b,c,d),s) = (show a ++) . (' ' :)
                               . (show b ++) . (' ' :)
@@ -101,3 +115,15 @@ quote opt str = ("\"" ++) .  (quote' str ++) . ("\"" ++)
       | otherwise = x       : quote' xs
 
 ----------------------------------------------------------------
+
+-- Empty result to be returned when no info can be gathered
+emptyResult :: Monad m => Options -> m String
+emptyResult opt = return $ convert opt ([] :: [String])
+
+-- Return an emptyResult when Nothing
+whenFound :: (Monad m, ToString b) => Options -> m (Maybe a) -> (a -> b) -> m String
+whenFound opt from f = maybe (emptyResult opt) (return . convert opt . f) =<< from
+
+-- Return an emptyResult when Nothing, inside a monad
+whenFound' :: (Monad m, ToString b) => Options -> m (Maybe a) -> (a -> m b) -> m String
+whenFound' opt from f = maybe (emptyResult opt) (\x -> do y <- f x ; return (convert opt y)) =<< from

Language/Haskell/GhcMod/Doc.hs

@@ -1,6 +1,6 @@
 module Language.Haskell.GhcMod.Doc where
 
-import GHC (Ghc, DynFlags)
+import GHC (DynFlags, GhcMonad)
 import qualified GHC as G
 import Language.Haskell.GhcMod.Gap (withStyle, showDocWith)
 import Outputable (SDoc, PprStyle, mkUserStyle, Depth(AllTheWay), neverQualify)
@@ -12,7 +12,7 @@ showPage dflag style = showDocWith dflag PageMode . withStyle dflag style
 showOneLine :: DynFlags -> PprStyle -> SDoc -> String
 showOneLine dflag style = showDocWith dflag OneLineMode . withStyle dflag style
 
-getStyle :: Ghc PprStyle
+getStyle :: GhcMonad m => m PprStyle
 getStyle = do
     unqual <- G.getPrintUnqual
     return $ mkUserStyle unqual AllTheWay

Language/Haskell/GhcMod/FillSig.hs

@@ -0,0 +1,223 @@
+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, CPP #-}
+
+module Language.Haskell.GhcMod.FillSig (
+    fillSig
+  , sig
+  ) where
+
+import Data.Char (isSymbol)
+import Data.List (find, intercalate)
+import Exception (ghandle, SomeException(..))
+import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))
+import qualified GHC as G
+import Language.Haskell.GhcMod.GHCApi
+import qualified Language.Haskell.GhcMod.Gap as Gap
+import Language.Haskell.GhcMod.Convert
+import Language.Haskell.GhcMod.Monad
+import Language.Haskell.GhcMod.SrcUtils
+import Language.Haskell.GhcMod.Types
+import MonadUtils (liftIO)
+import Outputable (PprStyle)
+import qualified Type as Ty
+import qualified HsBinds as Ty
+import qualified Class as Ty
+#if __GLASGOW_HASKELL__ >= 706
+import OccName (occName)
+#else
+import OccName (OccName)
+import RdrName (rdrNameOcc)
+#endif
+import qualified Language.Haskell.Exts.Annotated as HE
+
+----------------------------------------------------------------
+-- INTIAL CODE FROM FUNCTION OR INSTANCE SIGNATURE
+----------------------------------------------------------------
+
+-- Possible signatures we can find: function or instance
+data SigInfo = Signature SrcSpan [G.RdrName] (G.HsType G.RdrName)
+             | InstanceDecl SrcSpan G.Class
+
+-- Signature for fallback operation via haskell-src-exts
+data HESigInfo = HESignature HE.SrcSpan [HE.Name HE.SrcSpanInfo] (HE.Type HE.SrcSpanInfo) 
+
+-- | Create a initial body from a signature.
+fillSig :: Options
+        -> Cradle
+        -> FilePath     -- ^ A target file.
+        -> Int          -- ^ Line number.
+        -> Int          -- ^ Column number.
+        -> IO String
+fillSig opt cradle file lineNo colNo = runGhcMod opt $ do
+    initializeFlagsWithCradle opt cradle
+    sig file lineNo colNo
+
+-- | Create a initial body from a signature.
+sig :: FilePath     -- ^ A target file.
+    -> Int          -- ^ Line number.
+    -> Int          -- ^ Column number.
+    -> GhcMod String
+sig file lineNo colNo = ghandle handler body
+  where
+    body = inModuleContext file $ \dflag style -> do
+        opt <- options
+        modSum <- Gap.fileModSummary file
+        whenFound opt (getSignature modSum lineNo colNo) $ \s -> case s of
+          Signature loc names ty ->
+            ("function", fourInts loc, map (initialBody dflag style ty) names)
+          InstanceDecl loc cls -> do
+             ("instance", fourInts loc, map (\x -> initialBody dflag style (G.idType x) x)
+                                            (Ty.classMethods cls))
+            
+    handler (SomeException _) = do
+      opt <- options
+      -- Code cannot be parsed by ghc module
+      -- Fallback: try to get information via haskell-src-exts
+      whenFound opt (getSignatureFromHE file lineNo colNo) $
+        \(HESignature loc names ty) -> 
+           ("function", fourIntsHE loc, map (initialBody undefined undefined ty) names)
+
+----------------------------------------------------------------
+-- a. Code for getting the information
+
+-- Get signature from ghc parsing and typechecking
+getSignature :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SigInfo)
+getSignature modSum lineNo colNo = do
+    p@ParsedModule{pm_parsed_source = ps} <- G.parseModule modSum
+    -- Inspect the parse tree to find the signature
+    case listifyParsedSpans ps (lineNo, colNo) :: [G.LHsDecl G.RdrName] of
+      [L loc (G.SigD (Ty.TypeSig names (L _ ty)))] ->
+        -- We found a type signature
+        return $ Just $ Signature loc (map G.unLoc names) ty
+      [L _ (G.InstD _)] -> do
+        -- We found an instance declaration
+        TypecheckedModule{tm_renamed_source = Just tcs
+                         ,tm_checked_module_info = minfo} <- G.typecheckModule p
+        case listifyRenamedSpans tcs (lineNo, colNo) :: [G.LInstDecl G.Name] of
+          -- Instance declarations of sort 'instance F (G a)'
+#if __GLASGOW_HASKELL__ >= 708
+          [L loc (G.ClsInstD (G.ClsInstDecl {G.cid_poly_ty =
+            (L _ (G.HsForAllTy _ _ _ (L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _))))}))] ->
+#elif __GLASGOW_HASKELL__ >= 706
+          [L loc (G.ClsInstD
+            (L _ (G.HsForAllTy _ _ _ (L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _)))) _ _ _)] ->
+#else
+          [L loc (G.InstDecl
+            (L _ (G.HsForAllTy _ _ _ (L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _)))) _ _ _)] ->
+#endif
+               obtainClassInfo minfo clsName loc
+          -- Instance declarations of sort 'instance F G' (no variables)
+#if __GLASGOW_HASKELL__ >= 708
+          [L loc (G.ClsInstD (G.ClsInstDecl {G.cid_poly_ty =
+            (L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _))}))] ->
+#elif __GLASGOW_HASKELL__ >= 706
+          [L loc (G.ClsInstD
+            (L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _)) _ _ _)] ->
+#else
+          [L loc (G.InstDecl
+            (L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _)) _ _ _)] ->
+#endif
+               obtainClassInfo minfo clsName loc
+          _ -> return Nothing
+      _ -> return Nothing
+  where obtainClassInfo :: GhcMonad m => G.ModuleInfo -> G.Name -> SrcSpan -> m (Maybe SigInfo)
+        obtainClassInfo minfo clsName loc = do
+          tyThing <- G.modInfoLookupName minfo clsName
+          return $ do Ty.ATyCon clsCon <- tyThing  -- In Maybe
+                      cls <- G.tyConClass_maybe clsCon
+                      return $ InstanceDecl loc cls
+
+-- Get signature from haskell-src-exts
+getSignatureFromHE :: GhcMonad m => FilePath -> Int -> Int -> m (Maybe HESigInfo)
+getSignatureFromHE file lineNo colNo = do
+  presult <- liftIO $ HE.parseFile file
+  return $ case presult of
+             HE.ParseOk (HE.Module _ _ _ _ mdecls) -> do
+               HE.TypeSig (HE.SrcSpanInfo s _) names ty <- find (typeSigInRangeHE lineNo colNo) mdecls
+               return $ HESignature s names ty
+             _ -> Nothing
+
+----------------------------------------------------------------
+-- b. Code for generating initial code
+
+-- A list of function arguments, and whether they are functions or normal arguments
+-- is built from either a function signature or an instance signature
+data FnArg = FnArgFunction | FnArgNormal
+
+initialBody :: FnArgsInfo ty name => DynFlags -> PprStyle -> ty -> name -> String
+initialBody dflag style ty name = initialBody' (getFnName dflag style name) (getFnArgs ty)
+
+initialBody' :: String -> [FnArg] -> String
+initialBody' fname args =
+  case initialBodyArgs args infiniteVars infiniteFns of
+    []      -> fname
+    arglist -> if isSymbolName fname
+               then (head arglist) ++ " " ++ fname ++ " " ++ (intercalate " " (tail arglist))
+               else fname ++ " " ++ (intercalate " " arglist)
+  ++ " = " ++ (if isSymbolName fname then "" else '_':fname) ++ "_body"
+
+initialBodyArgs :: [FnArg] -> [String] -> [String] -> [String]
+initialBodyArgs [] _ _ = []
+initialBodyArgs (FnArgFunction:xs) vs (f:fs) = f : initialBodyArgs xs vs fs
+initialBodyArgs (FnArgNormal:xs)   (v:vs) fs = v : initialBodyArgs xs vs fs
+initialBodyArgs _                  _      _  = error "This should never happen" -- Lists are infinite
+
+-- Getting the initial body of function and instances differ
+-- This is because for functions we only use the parsed file
+-- (so the full file doesn't have to be type correct)
+-- but for instances we need to get information about the class
+
+class FnArgsInfo ty name | ty -> name, name -> ty where
+  getFnName :: DynFlags -> PprStyle -> name -> String
+  getFnArgs :: ty -> [FnArg]
+
+instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where
+  getFnName dflag style name = showOccName dflag style $ occName name
+  getFnArgs (G.HsForAllTy _ _ _ (L _ iTy))  = getFnArgs iTy
+  getFnArgs (G.HsParTy (L _ iTy))           = getFnArgs iTy
+  getFnArgs (G.HsFunTy (L _ lTy) (L _ rTy)) = (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy
+    where fnarg = \ty -> case ty of
+                           (G.HsForAllTy _ _ _ (L _ iTy)) -> fnarg iTy
+                           (G.HsParTy (L _ iTy))          -> fnarg iTy
+                           (G.HsFunTy _ _)                -> True
+                           _                              -> False
+  getFnArgs _ = []
+
+#if __GLASGOW_HASKELL__ < 706
+occName :: G.RdrName -> OccName
+occName = rdrNameOcc
+#endif
+
+instance FnArgsInfo (HE.Type HE.SrcSpanInfo) (HE.Name HE.SrcSpanInfo) where
+  getFnName _ _ (HE.Ident  _ s) = s
+  getFnName _ _ (HE.Symbol _ s) = s
+  getFnArgs (HE.TyForall _ _ _ iTy) = getFnArgs iTy
+  getFnArgs (HE.TyParen _ iTy)      = getFnArgs iTy
+  getFnArgs (HE.TyFun _ lTy rTy)    = (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy
+    where fnarg = \ty -> case ty of
+                           (HE.TyForall _ _ _ iTy) -> fnarg iTy
+                           (HE.TyParen _ iTy)      -> fnarg iTy
+                           (HE.TyFun _ _ _)        -> True
+                           _                       -> False
+  getFnArgs _ = []
+
+instance FnArgsInfo Type Id where
+  getFnName dflag style method = showOccName dflag style $ G.getOccName method
+  getFnArgs = getFnArgs' . Ty.dropForAlls
+    where getFnArgs' ty | Just (lTy,rTy) <- Ty.splitFunTy_maybe ty =
+            maybe (if Ty.isPredTy lTy then getFnArgs' rTy else FnArgNormal:getFnArgs' rTy)
+                  (\_ -> FnArgFunction:getFnArgs' rTy)
+                  $ Ty.splitFunTy_maybe lTy
+          getFnArgs' ty | Just (_,iTy) <- Ty.splitForAllTy_maybe ty = getFnArgs' iTy
+          getFnArgs' _ = []
+
+-- Infinite supply of variable and function variable names
+infiniteVars, infiniteFns :: [String]
+infiniteVars = infiniteSupply ["x","y","z","t","u","v","w"]
+infiniteFns  = infiniteSupply ["f","g","h"]
+infiniteSupply :: [String] -> [String]
+infiniteSupply initialSupply = initialSupply ++ concatMap (\n -> map (\v -> v ++ show n) initialSupply) ([1 .. ] :: [Integer])
+
+-- Check whether a String is a symbol name
+isSymbolName :: String -> Bool
+isSymbolName (c:_) = c `elem` "!#$%&*+./<=>?@\\^|-~" || isSymbol c
+isSymbolName []    = error "This should never happen"

Language/Haskell/GhcMod/GHCApi.hs

@@ -19,11 +19,11 @@ import Language.Haskell.GhcMod.GhcPkg
 
 import Control.Applicative ((<$>))
 import Control.Monad (forM, void)
-import CoreMonad (liftIO)
 import Data.Maybe (isJust, fromJust)
 import Exception (ghandle, SomeException(..))
-import GHC (Ghc, GhcMonad, DynFlags(..), GhcLink(..), HscTarget(..), LoadHowMuch(..))
+import GHC (DynFlags(..), GhcLink(..), HscTarget(..), LoadHowMuch(..))
 import qualified GHC as G
+import GhcMonad
 import GHC.Paths (libdir)
 import qualified Language.Haskell.GhcMod.Gap as Gap
 import Language.Haskell.GhcMod.Types

Language/Haskell/GhcMod/GHCChoice.hs

@@ -5,21 +5,21 @@ module Language.Haskell.GhcMod.GHCChoice where
 import Control.Exception (IOException)
 import CoreMonad (liftIO)
 import qualified Exception as GE
-import GHC (Ghc, GhcMonad)
+import GHC (GhcMonad)
 
 ----------------------------------------------------------------
 
 -- | Try the left 'Ghc' action. If 'IOException' occurs, try
 --   the right 'Ghc' action.
-(||>) :: Ghc a -> Ghc a -> Ghc a
+(||>) :: GhcMonad m => m a -> m a -> m a
 x ||> y = x `GE.gcatch` (\(_ :: IOException) -> y)
 
 -- | Go to the next 'Ghc' monad by throwing 'AltGhcgoNext'.
-goNext :: Ghc a
+goNext :: GhcMonad m => m a
 goNext = liftIO . GE.throwIO $ userError "goNext"
 
 -- | Run any one 'Ghc' monad.
-runAnyOne :: [Ghc a] -> Ghc a
+runAnyOne :: GhcMonad m => [m a] -> m a
 runAnyOne = foldr (||>) goNext
 
 ----------------------------------------------------------------

Language/Haskell/GhcMod/Gap.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP #-}
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP, ScopedTypeVariables, RankNTypes #-}
 
 module Language.Haskell.GhcMod.Gap (
     Language.Haskell.GhcMod.Gap.ClsInst
@@ -24,6 +24,8 @@ module Language.Haskell.GhcMod.Gap (
   , HasType(..)
   , errorMsgSpan
   , typeForUser
+  , nameForUser
+  , occNameForUser
   , deSugar
   , showDocWith
   , GapThing(..)
@@ -44,10 +46,12 @@ import Desugar (deSugarExpr)
 import DynFlags
 import ErrUtils
 import FastString
+import GhcMonad
 import HscTypes
 import Language.Haskell.GhcMod.GHCChoice
 import Language.Haskell.GhcMod.Types
 import NameSet
+import OccName
 import Outputable
 import PprTyThing
 import StringBuffer
@@ -148,7 +152,7 @@ getSrcFile _ = Nothing
 
 ----------------------------------------------------------------
 
-toStringBuffer :: [String] -> Ghc StringBuffer
+toStringBuffer :: GhcMonad m => [String] -> m StringBuffer
 #if __GLASGOW_HASKELL__ >= 702
 toStringBuffer = return . stringToStringBuffer . unlines
 #else
@@ -171,13 +175,13 @@ fOptions = [option | (option,_,_,_) <- fFlags]
 ----------------------------------------------------------------
 ----------------------------------------------------------------
 
-fileModSummary :: FilePath -> Ghc ModSummary
+fileModSummary :: GhcMonad m => FilePath -> m ModSummary
 fileModSummary file = do
     mss <- getModuleGraph
     let [ms] = filter (\m -> ml_hs_file (ms_location m) == Just file) mss
     return ms
 
-withContext :: Ghc a -> Ghc a
+withContext :: GhcMonad m => m a -> m a
 withContext action = gbracket setup teardown body
   where
     setup = getContext
@@ -293,7 +297,7 @@ filterOutChildren get_thing xs
   where
     implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
 
-infoThing :: String -> Ghc SDoc
+infoThing :: GhcMonad m => String -> m SDoc
 infoThing str = do
     names <- parseName str
 #if __GLASGOW_HASKELL__ >= 708
@@ -345,6 +349,12 @@ typeForUser = pprTypeForUser
 typeForUser = pprTypeForUser False
 #endif
 
+nameForUser :: Name -> SDoc
+nameForUser = pprOccName . getOccName
+
+occNameForUser :: OccName -> SDoc
+occNameForUser = pprOccName
+
 deSugar :: TypecheckedModule -> LHsExpr Id -> HscEnv
          -> IO (Maybe CoreExpr)
 #if __GLASGOW_HASKELL__ >= 708

Language/Haskell/GhcMod/Ghc.hs

@@ -8,6 +8,8 @@ module Language.Haskell.GhcMod.Ghc (
   , check
   , info
   , types
+  , splits
+  , sig
   , modules
   -- * 'SymMdlDb'
   , Symbol
@@ -24,3 +26,5 @@ import Language.Haskell.GhcMod.Find
 import Language.Haskell.GhcMod.GHCApi
 import Language.Haskell.GhcMod.Info
 import Language.Haskell.GhcMod.List
+import Language.Haskell.GhcMod.FillSig
+import Language.Haskell.GhcMod.CaseSplit

Language/Haskell/GhcMod/Info.hs

@@ -1,6 +1,3 @@
-{-# LANGUAGE TupleSections, FlexibleInstances, Rank2Types #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
 module Language.Haskell.GhcMod.Info (
     infoExpr
   , info
@@ -9,25 +6,20 @@ module Language.Haskell.GhcMod.Info (
   ) where
 
 import Control.Applicative ((<$>))
-import CoreMonad (liftIO)
-import CoreUtils (exprType)
 import Data.Function (on)
-import Data.Generics
 import Data.List (sortBy)
-import Data.Maybe (catMaybes, fromMaybe)
+import Data.Maybe (catMaybes)
-import Data.Ord as O
 import Exception (ghandle, SomeException(..))
-import GHC (Ghc, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), DynFlags, SrcSpan, Type, Located, TypecheckedSource, GenLocated(L))
+import GHC (GhcMonad, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), SrcSpan, Type)
 import qualified GHC as G
-import GHC.SYB.Utils (Stage(TypeChecker), everythingStaged)
+import Language.Haskell.GhcMod.Doc (showPage)
-import Language.Haskell.GhcMod.Doc (showPage, showOneLine, getStyle)
 import Language.Haskell.GhcMod.GHCApi
-import Language.Haskell.GhcMod.Gap (HasType(..), setWarnTypedHoles, setDeferTypeErrors)
+import Language.Haskell.GhcMod.Gap (HasType(..))
 import qualified Language.Haskell.GhcMod.Gap as Gap
+import Language.Haskell.GhcMod.Monad
+import Language.Haskell.GhcMod.SrcUtils
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Convert
-import Outputable (PprStyle)
-import TcHsSyn (hsPatType)
 
 ----------------------------------------------------------------
 
@@ -37,16 +29,17 @@ infoExpr :: Options
          -> FilePath     -- ^ A target file.
          -> Expression   -- ^ A Haskell expression.
          -> IO String
-infoExpr opt cradle file expr = withGHC' $ do
+infoExpr opt cradle file expr = runGhcMod opt $ do
     initializeFlagsWithCradle opt cradle
-    info opt file expr
+    info file expr
 
 -- | Obtaining information of a target expression. (GHCi's info:)
-info :: Options
+info :: FilePath     -- ^ A target file.
-     -> FilePath     -- ^ A target file.
      -> Expression   -- ^ A Haskell expression.
-     -> Ghc String
+     -> GhcMod String
-info opt file expr = convert opt <$> ghandle handler body
+info file expr = do
+    opt <- options
+    convert opt <$> ghandle handler body
   where
     body = inModuleContext file $ \dflag style -> do
         sdoc <- Gap.infoThing expr
@@ -55,17 +48,6 @@ info opt file expr = convert opt <$> ghandle handler body
 
 ----------------------------------------------------------------
 
-instance HasType (LHsExpr Id) where
-    getType tcm e = do
-        hs_env <- G.getSession
-        mbe <- liftIO $ Gap.deSugar tcm e hs_env
-        return $ (G.getLoc e, ) <$> CoreUtils.exprType <$> mbe
-
-instance HasType (LPat Id) where
-    getType _ (G.L spn pat) = return $ Just (spn, hsPatType pat)
-
-----------------------------------------------------------------
-
 -- | Obtaining type of a target expression. (GHCi's type:)
 typeExpr :: Options
          -> Cradle
@@ -73,17 +55,18 @@ typeExpr :: Options
          -> Int          -- ^ Line number.
          -> Int          -- ^ Column number.
          -> IO String
-typeExpr opt cradle file lineNo colNo = withGHC' $ do
+typeExpr opt cradle file lineNo colNo = runGhcMod opt $ do
     initializeFlagsWithCradle opt cradle
-    types opt file lineNo colNo
+    types file lineNo colNo
 
 -- | Obtaining type of a target expression. (GHCi's type:)
-types :: Options
+types :: FilePath     -- ^ A target file.
-      -> FilePath     -- ^ A target file.
       -> Int          -- ^ Line number.
       -> Int          -- ^ Column number.
-      -> Ghc String
+      -> GhcMod String
-types opt file lineNo colNo = convert opt <$> ghandle handler body
+types file lineNo colNo = do
+    opt <- options
+    convert opt <$> ghandle handler body
   where
     body = inModuleContext file $ \dflag style -> do
         modSum <- Gap.fileModSummary file
@@ -91,7 +74,7 @@ types opt file lineNo colNo = convert opt <$> ghandle handler body
         return $ map (toTup dflag style) $ sortBy (cmp `on` fst) srcSpanTypes
     handler (SomeException _) = return []
 
-getSrcSpanType :: G.ModSummary -> Int -> Int -> Ghc [(SrcSpan, Type)]
+getSrcSpanType :: GhcMonad m => G.ModSummary -> Int -> Int -> m [(SrcSpan, Type)]
 getSrcSpanType modSum lineNo colNo = do
     p <- G.parseModule modSum
     tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
@@ -103,36 +86,3 @@ getSrcSpanType modSum lineNo colNo = do
     pts <- mapM (getType tcm) ps
     return $ catMaybes $ concat [ets, bts, pts]
 
-listifySpans :: Typeable a => TypecheckedSource -> (Int, Int) -> [Located a]
-listifySpans tcs lc = listifyStaged TypeChecker p tcs
-  where
-    p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc
-
-listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r]
-listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x]))
-
-cmp :: SrcSpan -> SrcSpan -> Ordering
-cmp a b
-  | a `G.isSubspanOf` b = O.LT
-  | b `G.isSubspanOf` a = O.GT
-  | otherwise           = O.EQ
-
-toTup :: DynFlags -> PprStyle -> (SrcSpan, Type) -> ((Int,Int,Int,Int),String)
-toTup dflag style (spn, typ) = (fourInts spn, pretty dflag style typ)
-
-fourInts :: SrcSpan -> (Int,Int,Int,Int)
-fourInts = fromMaybe (0,0,0,0) . Gap.getSrcSpan
-
-pretty :: DynFlags -> PprStyle -> Type -> String
-pretty dflag style = showOneLine dflag style . Gap.typeForUser
-
-----------------------------------------------------------------
-
-inModuleContext :: FilePath -> (DynFlags -> PprStyle -> Ghc a) -> Ghc a
-inModuleContext file action =
-    withDynFlags (setWarnTypedHoles . setDeferTypeErrors . setNoWaringFlags) $ do
-    setTargetFiles [file]
-    Gap.withContext $ do
-        dflag <- G.getSessionDynFlags
-        style <- getStyle
-        action dflag style

Language/Haskell/GhcMod/SrcUtils.hs

@@ -0,0 +1,97 @@
+{-# LANGUAGE TupleSections, FlexibleInstances, Rank2Types #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Language.Haskell.GhcMod.SrcUtils where
+
+import Control.Applicative ((<$>))
+import CoreUtils (exprType)
+import Data.Generics
+import Data.Maybe (fromMaybe)
+import Data.Ord as O
+import GHC (LHsExpr, LPat, Id, DynFlags, SrcSpan, Type, Located, ParsedSource, RenamedSource, TypecheckedSource, GenLocated(L))
+import GhcMonad
+import qualified GHC as G
+import GHC.SYB.Utils (Stage(..), everythingStaged)
+import Language.Haskell.GhcMod.Doc (showOneLine, getStyle)
+import Language.Haskell.GhcMod.GHCApi
+import Language.Haskell.GhcMod.Gap (HasType(..), setWarnTypedHoles, setDeferTypeErrors)
+import qualified Language.Haskell.GhcMod.Gap as Gap
+import Outputable (PprStyle)
+import TcHsSyn (hsPatType)
+import OccName (OccName)
+import qualified Language.Haskell.Exts.Annotated as HE
+
+----------------------------------------------------------------
+
+instance HasType (LHsExpr Id) where
+    getType tcm e = do
+        hs_env <- G.getSession
+        mbe <- liftIO $ Gap.deSugar tcm e hs_env
+        return $ (G.getLoc e, ) <$> CoreUtils.exprType <$> mbe
+
+instance HasType (LPat Id) where
+    getType _ (G.L spn pat) = return $ Just (spn, hsPatType pat)
+
+----------------------------------------------------------------
+
+listifySpans :: Typeable a => TypecheckedSource -> (Int, Int) -> [Located a]
+listifySpans tcs lc = listifyStaged TypeChecker p tcs
+  where
+    p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc
+
+listifyParsedSpans :: Typeable a => ParsedSource -> (Int, Int) -> [Located a]
+listifyParsedSpans pcs lc = listifyStaged Parser p pcs
+  where
+    p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc
+
+listifyRenamedSpans :: Typeable a => RenamedSource -> (Int, Int) -> [Located a]
+listifyRenamedSpans pcs lc = listifyStaged Renamer p pcs
+  where
+    p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc
+
+listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r]
+listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x]))
+
+cmp :: SrcSpan -> SrcSpan -> Ordering
+cmp a b
+  | a `G.isSubspanOf` b = O.LT
+  | b `G.isSubspanOf` a = O.GT
+  | otherwise           = O.EQ
+
+toTup :: DynFlags -> PprStyle -> (SrcSpan, Type) -> ((Int,Int,Int,Int),String)
+toTup dflag style (spn, typ) = (fourInts spn, pretty dflag style typ)
+
+fourInts :: SrcSpan -> (Int,Int,Int,Int)
+fourInts = fromMaybe (0,0,0,0) . Gap.getSrcSpan
+
+fourIntsHE :: HE.SrcSpan -> (Int,Int,Int,Int)
+fourIntsHE loc = ( HE.srcSpanStartLine loc, HE.srcSpanStartColumn loc
+                 , HE.srcSpanEndLine loc, HE.srcSpanEndColumn loc)
+
+-- Check whether (line,col) is inside a given SrcSpanInfo
+typeSigInRangeHE :: Int -> Int -> HE.Decl HE.SrcSpanInfo -> Bool
+typeSigInRangeHE lineNo colNo (HE.TypeSig (HE.SrcSpanInfo s _)  _ _) =
+  HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo)
+typeSigInRangeHE _  _ _= False
+
+pretty :: DynFlags -> PprStyle -> Type -> String
+pretty dflag style = showOneLine dflag style . Gap.typeForUser
+
+----------------------------------------------------------------
+
+inModuleContext ::GhcMonad m => FilePath -> (DynFlags -> PprStyle -> m a) -> m a
+inModuleContext file action =
+    withDynFlags (setWarnTypedHoles . setDeferTypeErrors . setNoWaringFlags) $ do
+    setTargetFiles [file]
+    Gap.withContext $ do
+        dflag <- G.getSessionDynFlags
+        style <- getStyle
+        action dflag style
+
+----------------------------------------------------------------
+
+showName :: DynFlags -> PprStyle -> G.Name -> String
+showName dflag style name = showOneLine dflag style $ Gap.nameForUser name
+
+showOccName :: DynFlags -> PprStyle -> OccName -> String
+showOccName dflag style name = showOneLine dflag style $ Gap.occNameForUser name

elisp/Makefile

@@ -1,5 +1,5 @@
 SRCS = ghc.el ghc-func.el ghc-doc.el ghc-comp.el ghc-check.el ghc-process.el \
-       ghc-command.el ghc-info.el ghc-ins-mod.el ghc-indent.el
+       ghc-command.el ghc-info.el ghc-ins-mod.el ghc-indent.el ghc-rewrite.el
 EMACS = emacs
 DETECT = xemacs
 

elisp/ghc-rewrite.el

@@ -0,0 +1,77 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; ghc-rewrite.el
+;;;
+
+;; Author:  Alejandro Serrano <trupill@gmail.com>
+;; Created: Jun 17, 2014
+
+;;; Code:
+
+(require 'ghc-func)
+(require 'ghc-process)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Case splitting
+;;;
+
+(ghc-defstruct sinfo beg-line beg-column end-line end-column info)
+
+(defun ghc-case-split ()
+  (interactive)
+  (let ((info (ghc-obtain-case-split)))
+    (if (null info)
+	(message "Cannot split in cases")
+	(let* ((current-line    (line-number-at-pos))
+	       (begin-line      (ghc-sinfo-get-beg-line info))
+	       (begin-line-diff (+ 1 (- begin-line current-line)))
+	       (begin-line-pos  (line-beginning-position begin-line-diff))
+	       (begin-pos       (- (+ begin-line-pos (ghc-sinfo-get-beg-column info)) 1))
+	       (end-line        (ghc-sinfo-get-end-line info))
+	       (end-line-diff   (+ 1 (- end-line current-line)))
+	       (end-line-pos    (line-beginning-position end-line-diff))
+	       (end-pos         (- (+ end-line-pos (ghc-sinfo-get-end-column info)) 1)) )
+	    (delete-region begin-pos end-pos)
+	    (insert (ghc-sinfo-get-info info)) ) )))
+
+(defun ghc-obtain-case-split ()
+  (let* ((ln (int-to-string (line-number-at-pos)))
+	 (cn (int-to-string (1+ (current-column))))
+	 (file (buffer-file-name))
+	 (cmd (format "split %s %s %s\n" file ln cn)))
+    (ghc-sync-process cmd)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Initial code from signature
+;;;
+
+(ghc-defstruct icsinfo sort pos fns)
+
+(defun ghc-initial-code-from-signature ()
+  (interactive)
+  (let ((info (ghc-obtain-initial-code-from-signature)))
+    (if (null info)
+	(message "Cannot obtain initial code")
+	(let* ((ln-current (line-number-at-pos))
+	       (sort (ghc-icsinfo-get-sort info))
+	       (pos (ghc-icsinfo-get-pos info))
+	       (ln-end (ghc-sinfo-get-end-line pos))
+	       (ln-diff (+ 1 (- ln-end ln-current)))
+	       (fns-to-insert (ghc-icsinfo-get-fns info)))
+	  (goto-char (line-end-position ln-diff))
+	  (dolist (fn-to-insert fns-to-insert)
+	    (if (equal sort "function")
+		(newline)
+	        (newline-and-indent))
+	    (insert fn-to-insert))))))
+
+(defun ghc-obtain-initial-code-from-signature ()
+  (let* ((ln (int-to-string (line-number-at-pos)))
+	 (cn (int-to-string (1+ (current-column))))
+	 (file (buffer-file-name))
+	 (cmd (format "sig %s %s %s\n" file ln cn)))
+    (ghc-sync-process cmd)))
+
+(provide 'ghc-rewrite)

elisp/ghc.el

@@ -40,6 +40,7 @@
 (require 'ghc-command)
 (require 'ghc-ins-mod)
 (require 'ghc-indent)
+(require 'ghc-rewrite)
 (require 'dabbrev)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -72,6 +73,8 @@
 (defvar ghc-hoogle-key      (format "\C-c%c" (ghc-find-C-h)))
 (defvar ghc-shallower-key   "\C-c<")
 (defvar ghc-deeper-key      "\C-c>")
+(defvar ghc-case-split-key  "\C-c\C-p")
+(defvar ghc-initial-sig-key "\C-c\C-s")
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
@@ -104,6 +107,8 @@
     (define-key haskell-mode-map ghc-hoogle-key      'haskell-hoogle)
     (define-key haskell-mode-map ghc-shallower-key   'ghc-make-indent-shallower)
     (define-key haskell-mode-map ghc-deeper-key      'ghc-make-indent-deeper)
+    (define-key haskell-mode-map ghc-case-split-key  'ghc-case-split)
+    (define-key haskell-mode-map ghc-initial-sig-key 'ghc-initial-code-from-signature)
     (ghc-comp-init)
     (setq ghc-initialized t))
   (ghc-import-module)

ghc-mod.cabal

@@ -61,11 +61,13 @@ Library
                         Language.Haskell.GhcMod.CabalConfig
                         Language.Haskell.GhcMod.Cabal16
                         Language.Haskell.GhcMod.Cabal18
+                        Language.Haskell.GhcMod.CaseSplit
                         Language.Haskell.GhcMod.Check
                         Language.Haskell.GhcMod.Cradle
                         Language.Haskell.GhcMod.Convert
                         Language.Haskell.GhcMod.Debug
                         Language.Haskell.GhcMod.Doc
+                        Language.Haskell.GhcMod.FillSig
                         Language.Haskell.GhcMod.Find
                         Language.Haskell.GhcMod.Flag
                         Language.Haskell.GhcMod.GHCApi
@@ -81,6 +83,7 @@ Library
                         Language.Haskell.GhcMod.Utils
                         Language.Haskell.GhcMod.Types
                         Language.Haskell.GhcMod.Read
+                        Language.Haskell.GhcMod.SrcUtils
   Build-Depends:        base >= 4.0 && < 5
                       , containers
                       , deepseq
@@ -100,6 +103,8 @@ Library
                       , mtl
                       , monad-control
                       , split
+                      , haskell-src-exts
+                      , text
   if impl(ghc < 7.7)
     Build-Depends:      convertible
                       , Cabal >= 1.10 && < 1.17
@@ -177,6 +182,8 @@ Test-Suite spec
                       , monad-control
                       , hspec >= 1.8.2
                       , split
+                      , haskell-src-exts
+                      , text
   if impl(ghc < 7.7)
     Build-Depends:      convertible
                       , Cabal >= 1.10 && < 1.17

src/GHCMod.hs

@@ -38,6 +38,8 @@ 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 sig" ++ 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 +121,8 @@ 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)
+      "sig"     -> nArgs 4 $ fillSig 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

@@ -31,7 +31,7 @@ import Data.Set (Set)
 import qualified Data.Set as S
 import Data.Typeable (Typeable)
 import Data.Version (showVersion)
-import GHC (Ghc)
+import GHC (GhcMonad)
 import qualified GHC as G
 import Language.Haskell.GhcMod
 import Language.Haskell.GhcMod.Ghc
@@ -142,8 +142,10 @@ loop opt set mvar = do
         "check"  -> checkStx opt set arg
         "find"   -> findSym set arg mvar
         "lint"   -> toGhcMod $ lintStx  opt set arg
-        "info"   -> toGhcMod $ showInfo opt set arg
+        "info"   -> showInfo set arg
-        "type"   -> toGhcMod $ showType opt set arg
+        "type"   -> showType set arg
+        "split"  -> doSplit set arg
+        "sig"    -> doSig set arg
         "boot"   -> bootIt set
         "browse" -> browseIt set arg
         "quit"   -> return ("quit", False, set)
@@ -171,7 +173,7 @@ checkStx _ set file = do
         Right ret -> return (ret, True, set')
         Left ret  -> return (ret, True, set) -- fxime: set
 
-newFileSet :: Set FilePath -> FilePath -> Ghc (Set FilePath)
+newFileSet :: GhcMonad m => Set FilePath -> FilePath -> m (Set FilePath)
 newFileSet set file = do
     let set1
          | S.member file set = set
@@ -181,7 +183,7 @@ newFileSet set file = do
         Nothing       -> set1
         Just mainfile -> S.delete mainfile set1
 
-getModSummaryForMain :: Ghc (Maybe G.ModSummary)
+getModSummaryForMain :: GhcMonad m => m (Maybe G.ModSummary)
 getModSummaryForMain = find isMain <$> G.getModuleGraph
   where
     isMain m = G.moduleNameString (G.moduleName (G.ms_mod m)) == "Main"
@@ -207,8 +209,9 @@ findSym set sym mvar = do
     let ret = lookupSym' opt sym db
     return (ret, True, set)
 
-lintStx :: Options -> Set FilePath -> FilePath
+lintStx :: GhcMonad m
-        -> Ghc (String, Bool, Set FilePath)
+        => Options -> Set FilePath -> FilePath
+        -> m (String, Bool, Set FilePath)
 lintStx opt set optFile = liftIO $ do
     ret <-lintSyntax opt' file
     return (ret, True, set)
@@ -234,24 +237,40 @@ parseLintOptions optFile = case brk (== ']') (dropWhile (/= '[') optFile) of
 
 ----------------------------------------------------------------
 
-showInfo :: Options
+showInfo :: Set FilePath
-         -> Set FilePath
          -> FilePath
-         -> Ghc (String, Bool, Set FilePath)
+         -> GhcMod (String, Bool, Set FilePath)
-showInfo opt set fileArg = do
+showInfo set fileArg = do
     let [file, expr] = words fileArg
     set' <- newFileSet set file
-    ret <- info opt file expr
+    ret <- info file expr
     return (ret, True, set')
 
-showType :: Options
+showType :: Set FilePath
-         -> Set FilePath
          -> FilePath
-         -> Ghc (String, Bool, Set FilePath)
+         -> GhcMod (String, Bool, Set FilePath)
-showType opt set fileArg  = do
+showType set fileArg  = do
     let [file, line, column] = words fileArg
     set' <- newFileSet set file
-    ret <- types opt file (read line) (read column)
+    ret <- types file (read line) (read column)
+    return (ret, True, set')
+
+doSplit :: Set FilePath
+        -> FilePath
+        -> GhcMod (String, Bool, Set FilePath)
+doSplit set fileArg  = do
+    let [file, line, column] = words fileArg
+    set' <- newFileSet set file
+    ret <- splits file (read line) (read column)
+    return (ret, True, set')
+
+doSig :: Set FilePath
+      -> FilePath
+      -> GhcMod (String, Bool, Set FilePath)
+doSig set fileArg  = do
+    let [file, line, column] = words fileArg
+    set' <- newFileSet set file
+    ret <- sig file (read line) (read column)
     return (ret, True, set')
 
 ----------------------------------------------------------------