Merge pull request #320 from serras/master
Do not use dropdown-list + change keybindings + improve checking with typed holes
This commit is contained in:
commit
82936bb11e
@ -36,10 +36,14 @@ checkSyntax files = withErrorHandler sessionName $
|
|||||||
check :: IOish m
|
check :: IOish m
|
||||||
=> [FilePath] -- ^ The target files.
|
=> [FilePath] -- ^ The target files.
|
||||||
-> GhcModT m (Either String String)
|
-> GhcModT m (Either String String)
|
||||||
check fileNames = overrideGhcUserOptions $ \ghcOpts ->
|
check fileNames = overrideGhcUserOptions $ \ghcOpts -> do
|
||||||
withLogger (setAllWaringFlags . setNoMaxRelevantBindings . Gap.setWarnTypedHoles . Gap.setDeferTypeErrors) $ do
|
withLoggerTwice
|
||||||
_ <- G.setSessionDynFlags =<< addCmdOpts ghcOpts =<< G.getSessionDynFlags
|
setAllWaringFlags
|
||||||
setTargetFiles fileNames
|
(do _ <- G.setSessionDynFlags =<< addCmdOpts ghcOpts =<< G.getSessionDynFlags
|
||||||
|
setTargetFiles fileNames)
|
||||||
|
(setAllWaringFlags . setNoMaxRelevantBindings . Gap.setWarnTypedHoles)
|
||||||
|
(do _ <- G.setSessionDynFlags =<< addCmdOpts ghcOpts =<< G.getSessionDynFlags
|
||||||
|
setTargetFiles fileNames)
|
||||||
|
|
||||||
----------------------------------------------------------------
|
----------------------------------------------------------------
|
||||||
|
|
||||||
|
@ -2,14 +2,15 @@
|
|||||||
|
|
||||||
module Language.Haskell.GhcMod.Logger (
|
module Language.Haskell.GhcMod.Logger (
|
||||||
withLogger
|
withLogger
|
||||||
|
, withLoggerTwice
|
||||||
, checkErrorPrefix
|
, checkErrorPrefix
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Bag (Bag, bagToList)
|
import Bag (Bag, bagToList, filterBag, unionBags)
|
||||||
import Control.Applicative ((<$>))
|
import Control.Applicative ((<$>))
|
||||||
import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
|
import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
|
||||||
import Data.List (isPrefixOf)
|
import Data.List (isPrefixOf, find)
|
||||||
import Data.Maybe (fromMaybe)
|
import Data.Maybe (fromMaybe, isJust)
|
||||||
import ErrUtils (ErrMsg, errMsgShortDoc, errMsgExtraInfo)
|
import ErrUtils (ErrMsg, errMsgShortDoc, errMsgExtraInfo)
|
||||||
import Exception (ghandle)
|
import Exception (ghandle)
|
||||||
import GHC (DynFlags, SrcSpan, Severity(SevError))
|
import GHC (DynFlags, SrcSpan, Severity(SevError))
|
||||||
@ -71,20 +72,70 @@ withLogger setDF body = ghandle sourceError $ do
|
|||||||
where
|
where
|
||||||
setLogger logref df = Gap.setLogAction df $ appendLogRef df logref
|
setLogger logref df = Gap.setLogAction df $ appendLogRef df logref
|
||||||
|
|
||||||
|
withLoggerTwice :: IOish m
|
||||||
|
=> (DynFlags -> DynFlags)
|
||||||
|
-> GhcModT m ()
|
||||||
|
-> (DynFlags -> DynFlags)
|
||||||
|
-> GhcModT m ()
|
||||||
|
-> GhcModT m (Either String String)
|
||||||
|
withLoggerTwice setDF1 body1 setDF2 body2 = do
|
||||||
|
err1 <- ghandle sourceErrorBag $ do
|
||||||
|
logref <- liftIO newLogRef
|
||||||
|
wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcUserOptions <$> options
|
||||||
|
withDynFlags (setLogger logref . setDF1) $
|
||||||
|
withCmdFlags wflags $ do
|
||||||
|
body1
|
||||||
|
Right <$> readAndClearLogRef logref
|
||||||
|
err2 <- ghandle sourceErrorBag $ do
|
||||||
|
logref <- liftIO newLogRef
|
||||||
|
wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcUserOptions <$> options
|
||||||
|
withDynFlags (setLogger logref . setDF2) $
|
||||||
|
withCmdFlags wflags $ do
|
||||||
|
body2
|
||||||
|
Right <$> readAndClearLogRef logref
|
||||||
|
case (err1, err2) of
|
||||||
|
(Right x, Right _) -> return $ Right x
|
||||||
|
(Left b1, Right _) -> errBagToStr b1
|
||||||
|
(Right _, Left b2) -> errBagToStr b2
|
||||||
|
(Left b1, Left b2) -> do dflags <- G.getSessionDynFlags
|
||||||
|
style <- toGhcModT getStyle
|
||||||
|
let merged = mergeErrors dflags style b1 b2
|
||||||
|
errBagToStr merged
|
||||||
|
where
|
||||||
|
setLogger logref df = Gap.setLogAction df $ appendLogRef df logref
|
||||||
|
|
||||||
----------------------------------------------------------------
|
----------------------------------------------------------------
|
||||||
|
|
||||||
-- | Converting 'SourceError' to 'String'.
|
-- | Converting 'SourceError' to 'String'.
|
||||||
sourceError :: IOish m => SourceError -> GhcModT m (Either String String)
|
sourceError :: IOish m => SourceError -> GhcModT m (Either String String)
|
||||||
sourceError err = do
|
sourceError err = errBagToStr (srcErrorMessages err)
|
||||||
|
|
||||||
|
errBagToStr :: IOish m => Bag ErrMsg -> GhcModT m (Either String String)
|
||||||
|
errBagToStr err = do
|
||||||
dflags <- G.getSessionDynFlags
|
dflags <- G.getSessionDynFlags
|
||||||
style <- toGhcModT getStyle
|
style <- toGhcModT getStyle
|
||||||
ret <- convert' (errBagToStrList dflags style . srcErrorMessages $ err)
|
ret <- convert' (errBagToStrList dflags style err)
|
||||||
return $ Left ret
|
return $ Left ret
|
||||||
|
|
||||||
errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String]
|
errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String]
|
||||||
errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList
|
errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList
|
||||||
|
|
||||||
|
sourceErrorBag :: IOish m => SourceError -> GhcModT m (Either (Bag ErrMsg) String)
|
||||||
|
sourceErrorBag err = return $ Left (srcErrorMessages err)
|
||||||
|
|
||||||
|
mergeErrors :: DynFlags -> PprStyle -> Bag ErrMsg -> Bag ErrMsg -> Bag ErrMsg
|
||||||
|
mergeErrors dflag style b1 b2 =
|
||||||
|
let b1List = bagToList b1
|
||||||
|
findInB1 = \pr2 msg2 err1 ->
|
||||||
|
let pr1 = ppMsgPrefix (Gap.errorMsgSpan err1) G.SevWarning dflag style
|
||||||
|
msg1 = showPage dflag style (errMsgExtraInfo err1)
|
||||||
|
in pr1 == pr2 && msg1 == msg2
|
||||||
|
mustBeB2 = \err2 ->
|
||||||
|
let pr2 = ppMsgPrefix (Gap.errorMsgSpan err2) G.SevWarning dflag style
|
||||||
|
msg2 = showPage dflag style (errMsgExtraInfo err2)
|
||||||
|
in not . isJust $ find (findInB1 pr2 msg2) b1List
|
||||||
|
in b1 `unionBags` filterBag mustBeB2 b2
|
||||||
|
|
||||||
----------------------------------------------------------------
|
----------------------------------------------------------------
|
||||||
|
|
||||||
ppErrMsg :: DynFlags -> PprStyle -> ErrMsg -> String
|
ppErrMsg :: DynFlags -> PprStyle -> ErrMsg -> String
|
||||||
@ -98,22 +149,18 @@ ppMsg :: SrcSpan -> Severity-> DynFlags -> PprStyle -> SDoc -> String
|
|||||||
ppMsg spn sev dflag style msg = prefix ++ cts
|
ppMsg spn sev dflag style msg = prefix ++ cts
|
||||||
where
|
where
|
||||||
cts = showPage dflag style msg
|
cts = showPage dflag style msg
|
||||||
defaultPrefix
|
prefix = ppMsgPrefix spn sev dflag style
|
||||||
|
|
||||||
|
ppMsgPrefix :: SrcSpan -> Severity-> DynFlags -> PprStyle -> String
|
||||||
|
ppMsgPrefix spn sev dflag _style =
|
||||||
|
let defaultPrefix
|
||||||
| Gap.isDumpSplices dflag = ""
|
| Gap.isDumpSplices dflag = ""
|
||||||
| otherwise = checkErrorPrefix
|
| otherwise = checkErrorPrefix
|
||||||
prefix = fromMaybe defaultPrefix $ do
|
in fromMaybe defaultPrefix $ do
|
||||||
(line,col,_,_) <- Gap.getSrcSpan spn
|
(line,col,_,_) <- Gap.getSrcSpan spn
|
||||||
file <- normalise <$> Gap.getSrcFile spn
|
file <- normalise <$> Gap.getSrcFile spn
|
||||||
let severityCaption = Gap.showSeverityCaption sev
|
let severityCaption = Gap.showSeverityCaption sev
|
||||||
pref0
|
return $ file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption
|
||||||
| typeWarning1 `isPrefixOf` cts ||
|
|
||||||
typeWarning2 `isPrefixOf` cts = file ++ ":" ++ show line ++ ":" ++ show col ++ ":"
|
|
||||||
| otherwise = file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption
|
|
||||||
return pref0
|
|
||||||
-- DeferTypeErrors turns a type error to a warning.
|
|
||||||
-- So, let's turns it the error again.
|
|
||||||
typeWarning1 = "Couldn't match expected type"
|
|
||||||
typeWarning2 = "Couldn't match type"
|
|
||||||
|
|
||||||
checkErrorPrefix :: String
|
checkErrorPrefix :: String
|
||||||
checkErrorPrefix = "Dummy:0:0:Error:"
|
checkErrorPrefix = "Dummy:0:0:Error:"
|
||||||
|
@ -19,7 +19,8 @@
|
|||||||
((ghc-check-overlay-at (point))
|
((ghc-check-overlay-at (point))
|
||||||
(ghc-check-insert-from-warning))
|
(ghc-check-insert-from-warning))
|
||||||
(t
|
(t
|
||||||
(message "Nothing to be done"))))
|
(when (null (ghc-try-case-split))
|
||||||
|
(message "Nothing to be done")))))
|
||||||
|
|
||||||
(defun ghc-insert-module-template ()
|
(defun ghc-insert-module-template ()
|
||||||
(let* ((fullname (file-name-sans-extension (buffer-file-name)))
|
(let* ((fullname (file-name-sans-extension (buffer-file-name)))
|
||||||
|
@ -125,10 +125,9 @@ unloaded modules are loaded")
|
|||||||
|
|
||||||
(defun ghc-complete ()
|
(defun ghc-complete ()
|
||||||
(interactive)
|
(interactive)
|
||||||
(when (null (ghc-try-rewrite))
|
|
||||||
(if (ghc-should-scroll)
|
(if (ghc-should-scroll)
|
||||||
(ghc-scroll-completion-buffer)
|
(ghc-scroll-completion-buffer)
|
||||||
(ghc-try-complete))))
|
(ghc-try-complete)))
|
||||||
|
|
||||||
(defun ghc-should-scroll ()
|
(defun ghc-should-scroll ()
|
||||||
(let ((window (ghc-completion-window)))
|
(let ((window (ghc-completion-window)))
|
||||||
|
@ -11,9 +11,7 @@
|
|||||||
(require 'ghc-func)
|
(require 'ghc-func)
|
||||||
(require 'ghc-process)
|
(require 'ghc-process)
|
||||||
(require 'button)
|
(require 'button)
|
||||||
(condition-case nil
|
;(require 'dropdown-list)
|
||||||
(require 'dropdown-list)
|
|
||||||
(file-error nil))
|
|
||||||
|
|
||||||
(defvar ghc-auto-info nil)
|
(defvar ghc-auto-info nil)
|
||||||
(defvar ghc-auto-buffer nil)
|
(defvar ghc-auto-buffer nil)
|
||||||
@ -35,18 +33,6 @@
|
|||||||
(insert (ghc-sinfo-get-info info)) )
|
(insert (ghc-sinfo-get-info info)) )
|
||||||
)
|
)
|
||||||
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
;;;
|
|
||||||
;;; Combined rewriting
|
|
||||||
;;;
|
|
||||||
|
|
||||||
(defun ghc-try-rewrite ()
|
|
||||||
"Try to apply initial code generation and case splitting"
|
|
||||||
(interactive)
|
|
||||||
(when (null (ghc-try-initial-code-from-signature))
|
|
||||||
(ghc-try-case-split)))
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;;;
|
;;;
|
||||||
;;; Case splitting
|
;;; Case splitting
|
||||||
@ -116,38 +102,64 @@
|
|||||||
(delete-region begin-pos end-pos)
|
(delete-region begin-pos end-pos)
|
||||||
(insert msg)))
|
(insert msg)))
|
||||||
|
|
||||||
;; (defun auto-button (button)
|
;; Option 1: using button
|
||||||
;; (let ((text (buffer-substring (button-start button) (button-end button))))
|
|
||||||
;; (with-current-buffer ghc-auto-buffer
|
|
||||||
;; (ghc-perform-rewriting-auto ghc-auto-info text))))
|
|
||||||
|
|
||||||
;; (define-button-type 'auto-button
|
(defun ghc-auto-completion-window ()
|
||||||
;; 'follow-link t
|
(get-buffer-window ghc-error-buffer-name 0))
|
||||||
;; 'help-echo "mouse-2, RET: Insert this completion"
|
|
||||||
;; 'action #'auto-button)
|
|
||||||
|
|
||||||
;; (defun ghc-show-auto-messages (info)
|
(defun auto-button (button)
|
||||||
;; (let ((buf (current-buffer)))
|
(let ((text (buffer-substring (button-start button) (button-end button))))
|
||||||
;; (setq ghc-auto-info info)
|
(with-current-buffer ghc-auto-buffer
|
||||||
;; (setq ghc-auto-buffer buf)
|
(ghc-perform-rewriting-auto ghc-auto-info text))
|
||||||
;; (ghc-display nil
|
(quit-restore-window)))
|
||||||
;; (lambda ()
|
|
||||||
;; (insert "Possible completions:\n")
|
(define-button-type 'auto-button
|
||||||
;; (mapc
|
'follow-link t
|
||||||
;; (lambda (x)
|
'help-echo "mouse-2, RET: Insert this completion"
|
||||||
;; (let* ((ins1 (insert "- "))
|
'action #'auto-button)
|
||||||
;; (pos-begin (point))
|
|
||||||
;; (ins (insert x))
|
|
||||||
;; (pos-end (point))
|
|
||||||
;; (ins3 (insert "\n")))
|
|
||||||
;; (make-button pos-begin pos-end :type 'auto-button)))
|
|
||||||
;; (ghc-sinfo-get-info info))))))
|
|
||||||
|
|
||||||
(defun ghc-show-auto-messages (info)
|
(defun ghc-show-auto-messages (info)
|
||||||
(let* ((completions (ghc-sinfo-get-info info))
|
(let ((buf (current-buffer)))
|
||||||
(selected (dropdown-list completions)))
|
(setq ghc-auto-info info)
|
||||||
(when selected
|
(setq ghc-auto-buffer buf)
|
||||||
(ghc-perform-rewriting-auto info (nth selected completions)))))
|
(ghc-display nil
|
||||||
|
(lambda ()
|
||||||
|
(insert "Possible completions:\n")
|
||||||
|
(mapc
|
||||||
|
(lambda (x)
|
||||||
|
(let* (; (ins1 (insert "- "))
|
||||||
|
(pos-begin (point))
|
||||||
|
(ins (insert x))
|
||||||
|
(pos-end (point))
|
||||||
|
(ins3 (insert "\n")))
|
||||||
|
(make-button pos-begin pos-end :type 'auto-button)))
|
||||||
|
(ghc-sinfo-get-info info))))
|
||||||
|
(select-window (ghc-auto-completion-window))))
|
||||||
|
|
||||||
|
;; Option 2: using dropdown-list
|
||||||
|
|
||||||
|
;; (defun ghc-show-auto-messages (info)
|
||||||
|
;; (let* ((completions (ghc-sinfo-get-info info))
|
||||||
|
;; (selected (dropdown-list completions)))
|
||||||
|
;; (when selected
|
||||||
|
;; (ghc-perform-rewriting-auto info (nth selected completions)))))
|
||||||
|
|
||||||
|
;; Option 3: using minibuffer
|
||||||
|
|
||||||
|
;; (defvar ghc-auto-completion-buffer-name "*Djinn Completions*")
|
||||||
|
|
||||||
|
;; (defun ghc-auto-completion-window ()
|
||||||
|
;; (get-buffer-window ghc-auto-completion-buffer-name 0))
|
||||||
|
|
||||||
|
;; (defun ghc-show-auto-messages (info)
|
||||||
|
;; (let* ((completions (ghc-sinfo-get-info info))
|
||||||
|
;; (buf (generate-new-buffer "djinn-completion-temp")))
|
||||||
|
;; (with-current-buffer
|
||||||
|
;; (progn
|
||||||
|
;; (with-output-to-temp-buffer ghc-auto-completion-buffer-name
|
||||||
|
;; (display-completion-list completions))
|
||||||
|
;; (select-window (ghc-auto-completion-window))
|
||||||
|
;; (buffer-string)))))
|
||||||
|
|
||||||
(defun ghc-auto ()
|
(defun ghc-auto ()
|
||||||
"Try to automatically fill the contents of a hole"
|
"Try to automatically fill the contents of a hole"
|
||||||
|
@ -74,7 +74,7 @@
|
|||||||
(defvar ghc-shallower-key "\C-c<")
|
(defvar ghc-shallower-key "\C-c<")
|
||||||
(defvar ghc-deeper-key "\C-c>")
|
(defvar ghc-deeper-key "\C-c>")
|
||||||
;(defvar ghc-case-split-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-initial-sig-key "\C-u\et")
|
||||||
(defvar ghc-refine-key "\C-c\C-f")
|
(defvar ghc-refine-key "\C-c\C-f")
|
||||||
(defvar ghc-auto-key "\C-c\C-a")
|
(defvar ghc-auto-key "\C-c\C-a")
|
||||||
(defvar ghc-prev-hole-key "\C-c\ep")
|
(defvar ghc-prev-hole-key "\C-c\ep")
|
||||||
@ -112,7 +112,7 @@
|
|||||||
(define-key haskell-mode-map ghc-shallower-key 'ghc-make-indent-shallower)
|
(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-deeper-key 'ghc-make-indent-deeper)
|
||||||
;(define-key haskell-mode-map ghc-case-split-key 'ghc-case-split)
|
;(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-initial-sig-key 'ghc-initial-code-from-signature)
|
||||||
(define-key haskell-mode-map ghc-refine-key 'ghc-refine)
|
(define-key haskell-mode-map ghc-refine-key 'ghc-refine)
|
||||||
(define-key haskell-mode-map ghc-auto-key 'ghc-auto)
|
(define-key haskell-mode-map ghc-auto-key 'ghc-auto)
|
||||||
(define-key haskell-mode-map ghc-prev-hole-key 'ghc-goto-prev-hole)
|
(define-key haskell-mode-map ghc-prev-hole-key 'ghc-goto-prev-hole)
|
||||||
|
Loading…
Reference in New Issue
Block a user