hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge pull request #296 from serras/master

Browse Source 
Add refinement and better support for typed holes in Emacs mode
This commit is contained in:
Kazu Yamamoto 2014-08-01 15:14:50 +09:00
commit d1daf6def9
12 changed files with 391 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
Language/Haskell/GhcMod.hs
View File

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

44
Language/Haskell/GhcMod/CaseSplit.hs
View File

@ -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) $
\(SplitInfo varName (bndLoc,_) (varLoc,varT) _matches) -> do
whenFound' opt (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> case x of
(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]
varPat = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (LPat Id)
let 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, bsT) of
(Just varT', Just (_,bsT')) ->
case varT of
Just varT' ->
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

4
Language/Haskell/GhcMod/Check.hs
View File

@ -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
----------------------------------------------------------------

10
Language/Haskell/GhcMod/DynFlags.hs
View File

@ -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

158
Language/Haskell/GhcMod/FillSig.hs
View File

@ -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) $
\(HESignature loc names ty) ->
("function", fourIntsHE loc, map (initialBody undefined undefined ty) names)
whenFound opt (getSignatureFromHE file lineNo colNo) $ \x -> case x of
HESignature loc names ty ->
("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
return $ HESignature s names ty
decl <- find (typeSigInRangeHE lineNo colNo) mdecls
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

6
Language/Haskell/GhcMod/SrcUtils.hs
View File

@ -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

134
elisp/ghc-check.el
View File

@ -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))
(face (if err 'ghc-face-error 'ghc-face-warn)))
(overlay-put ovl 'ghc-hole hole)
(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 ()

4
elisp/ghc-func.el
View File

@ -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))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

51
elisp/ghc-rewrite.el
View File

@ -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))
(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)) ) )))
(ghc-perform-rewriting 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)

10
elisp/ghc.el
View File

@ -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-initial-sig-key "\C-c\C-s")
(defvar ghc-case-split-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)

3
src/GHCMod.hs
View File

@ -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

11
src/GHCModi.hs
View File

@ -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