Merge pull request #296 from serras/master

Add refinement and better support for typed holes in Emacs mode

Language/Haskell/GhcMod.hs

@@ -35,6 +35,7 @@ module Language.Haskell.GhcMod (
   , types
   , splits
   , sig
+  , refine
   , modules
   , languages
   , flags

Language/Haskell/GhcMod/CaseSplit.hs

@@ -5,18 +5,20 @@ module Language.Haskell.GhcMod.CaseSplit (
   ) where
 
 import CoreMonad (liftIO)
-import Data.List (find, intercalate)
+import Data.Function (on)
+import Data.List (find, intercalate, sortBy)
+import Data.Maybe (isJust)
 import qualified Data.Text as T
 import qualified Data.Text.IO as T (readFile)
 import qualified DataCon as Ty
 import Exception (ghandle, SomeException(..))
-import GHC (GhcMonad, LHsBind, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))
+import GHC (GhcMonad, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))
 import qualified GHC as G
 import Language.Haskell.GhcMod.Convert
 import qualified Language.Haskell.GhcMod.Gap as Gap
 import Language.Haskell.GhcMod.Monad
 import Language.Haskell.GhcMod.SrcUtils
-import Outputable (PprStyle)
+import Outputable (ppr, PprStyle)
 import qualified TyCon as Ty
 import qualified Type as Ty
 
@@ -24,7 +26,8 @@ import qualified Type as Ty
 -- CASE SPLITTING
 ----------------------------------------------------------------
 
-data SplitInfo = SplitInfo G.Name (SrcSpan,Type) (SrcSpan, Type) [SrcSpan]
+data SplitInfo = SplitInfo G.Name SrcSpan (SrcSpan, Type) [SrcSpan]
+               | TySplitInfo G.Name SrcSpan (SrcSpan, Ty.Kind)
 data SplitToTextInfo = SplitToTextInfo { sVarName     :: String
                                        , sBindingSpan :: SrcSpan
                                        , sVarSpan     :: SrcSpan
@@ -42,8 +45,13 @@ splits file lineNo colNo = ghandle handler body
     body = inModuleContext file $ \dflag style -> do
         opt <- options
         modSum <- Gap.fileModSummary file
-        whenFound' opt (getSrcSpanTypeForSplit modSum lineNo colNo) $
+        whenFound' opt (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> case x of
-          \(SplitInfo varName (bndLoc,_) (varLoc,varT) _matches) -> do
+          (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)
+          (TySplitInfo varName bndLoc (varLoc,varT)) -> do
              let varName' = showName dflag style varName  -- Convert name to string
              text <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $
                                                 getTyCons dflag style varName varT)
@@ -55,20 +63,26 @@ splits file lineNo colNo = ghandle handler body
 
 getSrcSpanTypeForSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo)
 getSrcSpanTypeForSplit modSum lineNo colNo = do
+  fn <- getSrcSpanTypeForFnSplit modSum lineNo colNo
+  if isJust fn
+     then return fn
+     else getSrcSpanTypeForTypeSplit modSum lineNo colNo
+
+-- 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
     tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
-    let bs:_ = listifySpans tcs (lineNo, colNo) :: [LHsBind Id]
+    let varPat  = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (LPat Id)
-        varPat  = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (LPat Id)
         match:_ = listifyParsedSpans pms (lineNo, colNo) :: [Gap.GLMatch]
     case varPat of
       Nothing  -> return Nothing
       Just varPat' -> do
         varT <- Gap.getType tcm varPat'  -- Finally we get the type of the var
-        bsT  <- Gap.getType tcm bs
+        case varT of
-        case (varT, bsT) of
+          Just varT' ->
-          (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) )
+            in return $ Just (SplitInfo (getPatternVarName varPat') matchL varT' (map G.getLoc rhsLs) )
           _ -> return Nothing
 
 isPatternVar :: LPat Id -> Bool
@@ -77,7 +91,11 @@ isPatternVar _                  = False
 
 getPatternVarName :: LPat Id -> G.Name
 getPatternVarName (L _ (G.VarPat vName)) = G.getName vName
-getPatternVarName _                      = error "This should never happend"
+getPatternVarName _                      = error "This should never happened"
+
+-- TODO: Information for a type family case split
+getSrcSpanTypeForTypeSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo)
+getSrcSpanTypeForTypeSplit _modSum _lineNo _colNo = return Nothing
 
 ----------------------------------------------------------------
 -- b. Code for getting the possible constructors

Language/Haskell/GhcMod/Check.hs

@@ -34,7 +34,9 @@ checkSyntax files = withErrorHandler sessionName $
 check :: IOish m
       => [FilePath]  -- ^ The target files.
       -> GhcModT m (Either String String)
-check fileNames = withLogger setAllWaringFlags $ setTargetFiles fileNames
+check fileNames =
+  withLogger (setAllWaringFlags . setNoMaxRelevantBindings) $
+    setTargetFiles fileNames
 
 ----------------------------------------------------------------
 

Language/Haskell/GhcMod/DynFlags.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+
 module Language.Haskell.GhcMod.DynFlags where
 
 import Control.Applicative ((<$>))
@@ -109,3 +111,11 @@ allWarningFlags = unsafePerformIO $
         return $ G.warningFlags df'
 
 ----------------------------------------------------------------
+
+-- | Set 'DynFlags' equivalent to "-fno-max-relevant-bindings".
+setNoMaxRelevantBindings :: DynFlags -> DynFlags
+#if __GLASGOW_HASKELL__ >= 708
+setNoMaxRelevantBindings df = df { maxRelevantBinds = Nothing }
+#else
+setNoMaxRelevantBindings = id
+#endif

Language/Haskell/GhcMod/FillSig.hs

@@ -2,10 +2,13 @@
 
 module Language.Haskell.GhcMod.FillSig (
     sig
+  , refine
   ) where
 
 import Data.Char (isSymbol)
-import Data.List (find)
+import Data.Function (on)
+import Data.List (find, sortBy)
+import Data.Maybe (isJust)
 import Exception (ghandle, SomeException(..))
 import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))
 import qualified GHC as G
@@ -13,6 +16,7 @@ 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 CoreMonad (liftIO)
 import Outputable (PprStyle)
 import qualified Type as Ty
@@ -27,9 +31,17 @@ import qualified Language.Haskell.Exts.Annotated as HE
 -- Possible signatures we can find: function or instance
 data SigInfo = Signature SrcSpan [G.RdrName] (G.HsType G.RdrName)
              | InstanceDecl SrcSpan G.Class
+             | TyFamDecl SrcSpan G.RdrName TyFamType {- True if closed -} [G.RdrName]
 
 -- Signature for fallback operation via haskell-src-exts
 data HESigInfo = HESignature HE.SrcSpan [HE.Name HE.SrcSpanInfo] (HE.Type HE.SrcSpanInfo)
+               | HEFamSignature HE.SrcSpan TyFamType (HE.Name HE.SrcSpanInfo) [HE.Name HE.SrcSpanInfo]
+
+data TyFamType = Closed | Open | Data
+initialTyFamString :: TyFamType -> (String, String)
+initialTyFamString Closed = ("instance", "")
+initialTyFamString Open   = ("function", "type instance ")
+initialTyFamString Data   = ("function", "data instance ")
 
 -- | Create a initial body from a signature.
 sig :: IOish m
@@ -48,14 +60,20 @@ sig file lineNo colNo = ghandle handler body
           InstanceDecl loc cls ->
              ("instance", fourInts loc, map (\x -> initialBody dflag style (G.idType x) x)
                                             (Ty.classMethods cls))
+          TyFamDecl loc name flavour vars ->
+            let (rTy, initial) = initialTyFamString flavour
+             in (rTy, fourInts loc, [initial ++ initialFamBody dflag style name vars])
 
     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) $
+      whenFound opt (getSignatureFromHE file lineNo colNo) $ \x -> case x of
-        \(HESignature loc names ty) ->
+        HESignature loc names ty ->
-           ("function", fourIntsHE loc, map (initialBody undefined undefined ty) names)
+          ("function", fourIntsHE loc, map (initialBody undefined undefined ty) names)
+        HEFamSignature loc flavour name vars ->
+          let (rTy, initial) = initialTyFamString flavour
+           in (rTy, fourIntsHE loc, [initial ++ initialFamBody undefined undefined name vars])
 
 ----------------------------------------------------------------
 -- a. Code for getting the information
@@ -73,9 +91,37 @@ getSignature modSum lineNo colNo = do
         -- We found an instance declaration
         TypecheckedModule{tm_renamed_source = Just tcs
                          ,tm_checked_module_info = minfo} <- G.typecheckModule p
-        case Gap.getClass $ listifyRenamedSpans tcs (lineNo, colNo) of
+        let lst = listifyRenamedSpans tcs (lineNo, colNo)
+        case Gap.getClass lst of
             Just (clsName,loc) -> obtainClassInfo minfo clsName loc
-            Nothing            -> return Nothing
+            _                  -> return Nothing
+#if __GLASGOW_HASKELL__ >= 708
+      [L loc (G.TyClD (G.FamDecl (G.FamilyDecl info (L _ name) (G.HsQTvs _ vars) _)))] -> do
+#elif __GLASGOW_HASKELL__ >= 706
+      [L loc (G.TyClD (G.TyFamily info (L _ name) (G.HsQTvs _ vars) _))] -> do
+#else
+      [L loc (G.TyClD (G.TyFamily info (L _ name) vars _))] -> do
+#endif
+#if __GLASGOW_HASKELL__ >= 708
+        let flavour = case info of
+                        G.ClosedTypeFamily _ -> Closed
+                        G.OpenTypeFamily     -> Open
+                        G.DataFamily         -> Data
+#else
+        let flavour = case info of  -- Closed type families where introduced in GHC 7.8
+                        G.TypeFamily -> Open
+                        G.DataFamily -> Data
+#endif
+#if __GLASGOW_HASKELL__ >= 706
+            getTyFamVarName = \x -> case x of
+                                      L _ (G.UserTyVar n)     -> n
+                                      L _ (G.KindedTyVar n _) -> n
+#else
+            getTyFamVarName = \x -> case x of  -- In GHC 7.4, HsTyVarBndr's have an extra arg
+                                      L _ (G.UserTyVar n _)     -> n
+                                      L _ (G.KindedTyVar n _ _) -> n
+#endif
+         in return $ Just (TyFamDecl loc name flavour $ map getTyFamVarName vars)
       _ -> return Nothing
   where obtainClassInfo :: GhcMonad m => G.ModuleInfo -> G.Name -> SrcSpan -> m (Maybe SigInfo)
         obtainClassInfo minfo clsName loc = do
@@ -90,35 +136,62 @@ 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
+               decl <- find (typeSigInRangeHE lineNo colNo) mdecls
-               return $ HESignature s names ty
+               case decl of 
+                 HE.TypeSig (HE.SrcSpanInfo s _) names ty -> return $ HESignature s names ty
+                 HE.TypeFamDecl (HE.SrcSpanInfo s _) (HE.DHead _ name tys) _ ->
+                   return $ HEFamSignature s Open name (map cleanTyVarBind tys)
+                 HE.DataFamDecl (HE.SrcSpanInfo s _) _ (HE.DHead _ name tys) _ ->
+                   return $ HEFamSignature s Open name (map cleanTyVarBind tys)
              _ -> Nothing
+  where cleanTyVarBind (HE.KindedVar _ n _) = n
+        cleanTyVarBind (HE.UnkindedVar _ n) = n
 
 ----------------------------------------------------------------
 -- 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
+data FnArg = FnArgFunction | FnArgNormal | FnExplicitName String
 
 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 =
+initialBody' fname args = initialHead fname args ++ " = "
+                          ++ (if isSymbolName fname then "" else '_':fname) ++ "_body"
+
+initialFamBody :: FnArgsInfo ty name => DynFlags -> PprStyle -> name -> [name] -> String
+initialFamBody dflag style name args = initialHead (getFnName dflag style name)
+                                         (map (\arg -> FnExplicitName (getFnName dflag style arg)) args)
+                                         ++ " = ()"
+
+initialHead :: String -> [FnArg] -> String
+initialHead fname args =
   case initialBodyArgs args infiniteVars infiniteFns of
     []      -> fname
     arglist -> if isSymbolName fname
                then head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)
                else fname ++ " " ++ unwords 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 (FnExplicitName n:xs)  vs fs = n : initialBodyArgs xs vs fs
 initialBodyArgs _                  _      _  = error "This should never happen" -- Lists are infinite
 
+initialHead1 :: String -> [FnArg] -> [String] -> String
+initialHead1 fname args elts =
+  case initialBodyArgs1 args elts of
+    []      -> fname
+    arglist -> if isSymbolName fname
+               then head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)
+               else fname ++ " " ++ unwords arglist
+
+initialBodyArgs1 :: [FnArg] -> [String] -> [String]
+initialBodyArgs1 args elts = take (length args) elts
+
 -- 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)
@@ -174,3 +247,66 @@ infiniteSupply initialSupply = initialSupply ++ concatMap (\n -> map (\v -> v ++
 isSymbolName :: String -> Bool
 isSymbolName (c:_) = c `elem` "!#$%&*+./<=>?@\\^|-~" || isSymbol c
 isSymbolName []    = error "This should never happen"
+
+
+----------------------------------------------------------------
+-- REWRITE A HOLE / UNDEFINED VIA A FUNCTION
+----------------------------------------------------------------
+
+refine :: IOish m
+       => FilePath     -- ^ A target file.
+       -> Int          -- ^ Line number.
+       -> Int          -- ^ Column number.
+       -> Expression   -- ^ A Haskell expression.
+       -> GhcModT m String
+refine file lineNo colNo expr = ghandle handler body
+  where
+    body = inModuleContext file $ \dflag style -> do
+        opt <- options
+        modSum <- Gap.fileModSummary file
+        p <- G.parseModule modSum
+        tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
+        ety <- G.exprType expr
+        whenFound opt (findVar dflag style tcm tcs lineNo colNo) $ \(loc, name, rty, paren) ->
+          let eArgs = getFnArgs ety
+              rArgs = getFnArgs rty
+              diffArgs' = length eArgs - length rArgs
+              diffArgs  = if diffArgs' < 0 then 0 else diffArgs'
+              iArgs = take diffArgs eArgs
+              text = initialHead1 expr iArgs (infinitePrefixSupply name)
+           in (fourInts loc, doParen paren text)
+            
+    handler (SomeException _) = emptyResult =<< options
+
+-- Look for the variable in the specified position
+findVar :: GhcMonad m => DynFlags -> PprStyle
+                      -> G.TypecheckedModule -> G.TypecheckedSource
+                      -> Int -> Int -> m (Maybe (SrcSpan, String, Type, Bool))
+findVar dflag style tcm tcs lineNo colNo =
+  let lst = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo) :: [G.LHsExpr Id]
+  in case lst of
+      e@(L _ (G.HsVar i)):others ->
+        do tyInfo <- Gap.getType tcm e
+           let name = getFnName dflag style i
+           if (name == "undefined" || head name == '_') && isJust tyInfo
+              then let Just (s,t) = tyInfo
+                       b = case others of  -- If inside an App, we need parenthesis
+                             [] -> False
+                             (L _ (G.HsApp (L _ a1) (L _ a2))):_ ->
+                               isSearchedVar i a1 || isSearchedVar i a2
+                             _  -> False
+                    in return $ Just (s, name, t, b)
+              else return Nothing
+      _ -> return Nothing
+
+infinitePrefixSupply :: String -> [String]
+infinitePrefixSupply "undefined" = repeat "undefined"
+infinitePrefixSupply p = map (\n -> p ++ "_" ++ show n) ([1 ..] :: [Integer])
+
+doParen :: Bool -> String -> String
+doParen False s = s
+doParen True  s = if ' ' `elem` s then '(':s ++ ")" else s
+
+isSearchedVar :: Id -> G.HsExpr Id -> Bool
+isSearchedVar i (G.HsVar i2) = i == i2
+isSearchedVar _ _ = False

Language/Haskell/GhcMod/SrcUtils.hs

@@ -72,7 +72,11 @@ fourIntsHE loc = ( HE.srcSpanStartLine loc, HE.srcSpanStartColumn 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 _)  _ _) =
+typeSigInRangeHE lineNo colNo (HE.TypeSig (HE.SrcSpanInfo s _) _ _) =
+  HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo)
+typeSigInRangeHE lineNo colNo (HE.TypeFamDecl (HE.SrcSpanInfo s _) _ _) =
+  HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo)
+typeSigInRangeHE lineNo colNo (HE.DataFamDecl (HE.SrcSpanInfo s _) _ _ _) =
   HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo)
 typeSigInRangeHE _  _ _= False
 

elisp/ghc-check.el

@@ -10,6 +10,7 @@
 
 (require 'ghc-func)
 (require 'ghc-process)
+(require 'button)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -30,10 +31,20 @@
   "Face used for marking warning lines."
   :group 'ghc)
 
+(defface ghc-face-hole
+  '((((supports :underline (:style wave)))
+     :underline (:style wave :color "purple"))
+    (t
+     :inherit warning))
+  "Face used for marking hole lines."
+  :group 'ghc)
+
 (defvar ghc-check-error-fringe (propertize "!" 'display '(left-fringe exclamation-mark)))
 
 (defvar ghc-check-warning-fringe (propertize "?" 'display '(left-fringe question-mark)))
 
+(defvar ghc-check-hole-fringe (propertize "_" 'display '(left-fringe horizontal-bar)))
+
 (defvar ghc-display-error nil
   "*An action to display errors/warnings for 'M-n' and 'M-p:
 
@@ -42,6 +53,13 @@ nil            does not display errors/warnings.
 'other-buffer  displays errors/warnings in the other buffer.
 ")
 
+(defvar ghc-display-hole 'other-buffer
+  "*An action to display hole information for 'C-c C-j' and 'C-c C-h'
+
+'minibuffer    displays errors/warnings in the minibuffer.
+'other-buffer  displays errors/warnings in the other buffer"
+)
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defun ghc-check-syntax ()
@@ -52,7 +70,7 @@ nil            does not display errors/warnings.
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(ghc-defstruct hilit-info file line msg err)
+(ghc-defstruct hilit-info file line msg err hole coln)
 
 (defun ghc-check-send ()
   (let ((file (buffer-file-name)))
@@ -102,14 +120,19 @@ nil            does not display errors/warnings.
       (when (string-match regex err)
 	(let* ((file (expand-file-name (match-string 1 err))) ;; for Windows
 	       (line (string-to-number (match-string 2 err)))
-	       ;; don't take column to make multiple same errors to a single.
+               (coln (string-to-number (match-string 3 err)))
 	       (msg (match-string 4 err))
 	       (wrn (string-match "^Warning" msg))
+               (hole (save-match-data
+                        (when (string-match "Found hole .\\(_[_[:alnum:]]*\\)." msg)
+                              (match-string 1 msg))))
 	       (info (ghc-make-hilit-info
 		      :file file
 		      :line line
+                      :coln coln
 		      :msg  msg
-		      :err  (not wrn))))
+		      :err  (and (not wrn) (not hole))
+                      :hole hole)))
 	  (unless (member info infos)
 	    (ghc-add infos info)))))))
 
@@ -123,11 +146,19 @@ nil            does not display errors/warnings.
 	      (msg  (ghc-hilit-info-get-msg  info))
 	      (file (ghc-hilit-info-get-file info))
 	      (err  (ghc-hilit-info-get-err  info))
+              (hole (ghc-hilit-info-get-hole info))
+              (coln (ghc-hilit-info-get-coln info))
 	      beg end ovl)
 	  ;; FIXME: This is the Shlemiel painter's algorithm.
 	  ;; If this is a bottleneck for a large code, let's fix.
 	  (goto-char (point-min))
 	  (cond
+           ((and (string= ofile file) hole)
+            (forward-line (1- line))
+            (forward-char (1- coln))
+            (setq beg (point))
+            (forward-char (length hole))
+            (setq end (point)))
 	   ((string= ofile file)
 	    (forward-line (1- line))
 	    (while (eq (char-after) 32) (forward-char))
@@ -143,8 +174,9 @@ nil            does not display errors/warnings.
 	  (overlay-put ovl 'ghc-file file)
 	  (overlay-put ovl 'ghc-msg msg)
 	  (overlay-put ovl 'help-echo msg)
-	  (let ((fringe (if err ghc-check-error-fringe ghc-check-warning-fringe))
+          (overlay-put ovl 'ghc-hole hole)
-		(face (if err 'ghc-face-error 'ghc-face-warn)))
+	  (let ((fringe (if err ghc-check-error-fringe (if hole ghc-check-hole-fringe ghc-check-warning-fringe)))
+		(face (if err 'ghc-face-error (if hole 'ghc-face-hole 'ghc-face-warn))))
 	    (overlay-put ovl 'before-string fringe)
 	    (overlay-put ovl 'face face)))))))
 
@@ -195,6 +227,70 @@ nil            does not display errors/warnings.
             (message "%s" errmsg)
           (message "%s\n\n%s" file errmsg))))))
 
+(defun ghc-get-only-holes ()
+  (let ((ovls (ghc-check-overlay-at (point))))
+    (when ovls
+      (let ((msgs (mapcar (lambda (ovl) (overlay-get ovl 'ghc-msg)) ovls))
+	    (file (overlay-get (car ovls) 'ghc-file))
+	    holes)
+	(dolist (msg msgs)
+	  (if (string-match "Found hole" msg)
+	      (ghc-add holes msg)
+	      nil))
+	(ghc-make-file-msgs :file file :msgs holes)))))
+
+;; Based on http://superuser.com/questions/331895/how-to-get-emacs-to-highlight-and-link-file-paths
+(defun find-file-button (button)
+  (let ((text (buffer-substring (button-start button) (button-end button))))
+    (when (string-match "\\(/[^:]*\\):\\([[:digit:]]+\\):\\([[:digit:]]+\\)" text)
+      (let* ((file (match-string 1 text))
+             (line (string-to-number (match-string 2 text)))
+             (coln (string-to-number (match-string 3 text)))
+             (buf  (find-file file)))
+            (with-current-buffer buf 
+               (let* ((this-line (line-number-at-pos))
+                      (diff (- line this-line)))
+                 (beginning-of-line)
+                 (forward-line diff)
+                 (forward-char (1- coln))))))))
+
+(define-button-type 'find-file-button
+  'follow-link t
+  'action #'find-file-button)
+
+(defun buttonize-buffer ()
+  "turn all file paths into buttons"
+  (save-excursion
+    (goto-char (point-min))
+    (while (re-search-forward "/[^ \t:]*:[[:digit:]]+:[[:digit:]]+" nil t)
+      (make-button (match-beginning 0) (match-end 0) :type 'find-file-button))))
+
+(defun ghc-display-holes ()
+  (interactive)
+  (let ((file-msgs (ghc-get-only-holes)))
+    (if (null file-msgs)
+	(message "No holes")
+      (let ((file (ghc-file-msgs-get-file file-msgs))
+	    (msgs (ghc-file-msgs-get-msgs file-msgs)))
+	(ghc-display
+	 nil
+	 (lambda ()
+           (progn
+	     (mapc (lambda (x) (insert x "\n\n")) msgs)
+             (buttonize-buffer)) ))))))
+
+(defun ghc-display-holes-to-minibuf ()
+  (let ((file-msgs (ghc-get-only-holes)))
+    (if (null file-msgs)
+	(message "No holes")
+      (let* ((file (ghc-file-msgs-get-file file-msgs))
+	     (msgs (ghc-file-msgs-get-msgs file-msgs))
+	     (errmsg (mapconcat 'identity msgs "\n"))
+	     (buffile buffer-file-name))
+        (if (string-equal buffile file)
+            (message "%s" errmsg)
+          (message "%s\n\n%s" file errmsg))))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defun ghc-goto-prev-error ()
@@ -223,6 +319,34 @@ nil            does not display errors/warnings.
    ((eq ghc-display-error 'minibuffer) (ghc-display-errors-to-minibuf))
    ((eq ghc-display-error 'other-buffer) (ghc-display-errors))))
 
+(defun ghc-goto-prev-hole ()
+  (interactive)
+  (let* ((here (point))
+         (ovls0 (ghc-check-overlay-at here))
+         (end (if ovls0 (overlay-start (car ovls0)) here))
+         (ovls1 (overlays-in (point-min) end))
+         (ovls2 (ghc-filter (lambda (ovl) (overlay-get ovl 'ghc-check)) ovls1))
+         (ovls3 (ghc-filter (lambda (ovl) (overlay-get ovl 'ghc-hole)) ovls2))
+         (pnts (mapcar 'overlay-start ovls3)))
+    (if pnts (goto-char (apply 'max pnts))))
+  (cond
+   ((eq ghc-display-hole 'minibuffer) (ghc-display-holes-to-minibuf))
+   ((eq ghc-display-hole 'other-buffer) (ghc-display-holes))))
+
+(defun ghc-goto-next-hole ()
+  (interactive)
+  (let* ((here (point))
+         (ovls0 (ghc-check-overlay-at here))
+         (beg (if ovls0 (overlay-end (car ovls0)) here))
+         (ovls1 (overlays-in beg (point-max)))
+         (ovls2 (ghc-filter (lambda (ovl) (overlay-get ovl 'ghc-check)) ovls1))
+         (ovls3 (ghc-filter (lambda (ovl) (overlay-get ovl 'ghc-hole)) ovls2))
+         (pnts (mapcar 'overlay-start ovls3)))
+    (if pnts (goto-char (apply 'min pnts))))
+  (cond
+   ((eq ghc-display-hole 'minibuffer) (ghc-display-holes-to-minibuf))
+   ((eq ghc-display-hole 'other-buffer) (ghc-display-holes))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defun ghc-check-insert-from-warning ()

elisp/ghc-func.el

@@ -156,7 +156,9 @@
             (turn-off-haskell-font-lock)
           (haskell-font-lock-defaults-create)
           (turn-on-haskell-font-lock)))
-      (display-buffer buf))))
+      (display-buffer buf 
+        '((display-buffer-reuse-window
+           display-buffer-pop-up-window))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 

elisp/ghc-rewrite.el

@@ -11,6 +11,23 @@
 (require 'ghc-func)
 (require 'ghc-process)
 
+;; Common code for case splitting and refinement
+
+(defun ghc-perform-rewriting (info)
+  "Replace code with new string obtained from ghc-mod"
+  (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)) )
+  )
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
 ;;; Case splitting
@@ -19,21 +36,12 @@
 (ghc-defstruct sinfo beg-line beg-column end-line end-column info)
 
 (defun ghc-case-split ()
+  "Split the variable at point into its possible constructors"
   (interactive)
   (let ((info (ghc-obtain-case-split)))
     (if (null info)
 	(message "Cannot split in cases")
-	(let* ((current-line    (line-number-at-pos))
+        (ghc-perform-rewriting info)) ))
-	       (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)))
@@ -42,6 +50,26 @@
 	 (cmd (format "split %s %s %s\n" file ln cn)))
     (ghc-sync-process cmd)))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Refinement
+;;;
+
+(defun ghc-refine ()
+  "Refine a hole using a user-specified function"
+  (interactive)
+  (let ((info (ghc-obtain-refine (read-string "Refine with: "))))
+    (if (null info)
+	(message "Cannot refine")
+	(ghc-perform-rewriting info)) ))
+
+(defun ghc-obtain-refine (expr)
+  (let* ((ln (int-to-string (line-number-at-pos)))
+	 (cn (int-to-string (1+ (current-column))))
+	 (file (buffer-file-name))
+	 (cmd (format "refine %s %s %s %s\n" file ln cn expr)))
+    (ghc-sync-process cmd)))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
 ;;; Initial code from signature
@@ -50,6 +78,7 @@
 (ghc-defstruct icsinfo sort pos fns)
 
 (defun ghc-initial-code-from-signature ()
+  "Include initial code from a function signature or instance declaration"
   (interactive)
   (let ((info (ghc-obtain-initial-code-from-signature)))
     (if (null info)

elisp/ghc.el

@@ -73,8 +73,11 @@
 (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-case-split-key  "\C-c\C-s")
-(defvar ghc-initial-sig-key "\C-c\C-s")
+(defvar ghc-initial-sig-key "\C-c\C-g")
+(defvar ghc-refine-key      "\C-c\C-r")
+(defvar ghc-prev-hole-key   "\C-c\ep")
+(defvar ghc-next-hole-key   "\C-c\en")
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
@@ -109,6 +112,9 @@
     (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)
+    (define-key haskell-mode-map ghc-refine-key      'ghc-refine)
+    (define-key haskell-mode-map ghc-prev-hole-key   'ghc-goto-prev-hole)
+    (define-key haskell-mode-map ghc-next-hole-key   'ghc-goto-next-hole)
     (ghc-comp-init)
     (setq ghc-initialized t))
   (ghc-import-module)

src/GHCMod.hs

@@ -40,6 +40,7 @@ usage =    progVersion
         ++ "\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 refine" ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no> <expression>\n"
         ++ "\t ghc-mod find <symbol>\n"
         ++ "\t ghc-mod lint [-h opt] <HaskellFile>\n"
         ++ "\t ghc-mod root\n"
@@ -106,6 +107,7 @@ main = flip E.catches handlers $ do
         cmdArg1 = cmdArg !. 1
         cmdArg3 = cmdArg !. 3
         cmdArg4 = cmdArg !. 4
+        cmdArg5 = cmdArg !. 5
         remainingArgs = tail cmdArg
         nArgs n f = if length remainingArgs == n
                         then f
@@ -122,6 +124,7 @@ main = flip E.catches handlers $ do
       "type"    -> nArgs 4 $ types cmdArg1 (read cmdArg3) (read cmdArg4)
       "split"   -> nArgs 4 $ splits cmdArg1 (read cmdArg3) (read cmdArg4)
       "sig"     -> nArgs 4 $ sig cmdArg1 (read cmdArg3) (read cmdArg4)
+      "refine"  -> nArgs 5 $ refine cmdArg1 (read cmdArg3) (read cmdArg4) cmdArg5
       "find"    -> nArgs 1 $ findSymbol cmdArg1
       "lint"    -> nArgs 1 $ withFile lint cmdArg1
       "root"    -> rootInfo

src/GHCModi.hs

@@ -130,6 +130,7 @@ loop set mvar = do
         "type"   -> showType set arg
         "split"  -> doSplit set arg
         "sig"    -> doSig set arg
+        "refine" -> doRefine set arg
         "boot"   -> bootIt set
         "browse" -> browseIt set arg
         "quit"   -> return ("quit", False, set)
@@ -260,6 +261,16 @@ doSig set fileArg  = do
     ret <- sig file (read line) (read column)
     return (ret, True, set')
 
+doRefine :: IOish m
+         => Set FilePath
+         -> FilePath
+         -> GhcModT m (String, Bool, Set FilePath)
+doRefine set fileArg  = do
+    let [file, line, column, expr] = words fileArg
+    set' <- newFileSet set file
+    ret <- refine file (read line) (read column) expr
+    return (ret, True, set')
+
 ----------------------------------------------------------------
 
 bootIt :: IOish m