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
|
||||
=> [FilePath] -- ^ The target files.
|
||||
-> GhcModT m (Either String String)
|
||||
check fileNames = overrideGhcUserOptions $ \ghcOpts ->
|
||||
withLogger (setAllWaringFlags . setNoMaxRelevantBindings . Gap.setWarnTypedHoles . Gap.setDeferTypeErrors) $ do
|
||||
_ <- G.setSessionDynFlags =<< addCmdOpts ghcOpts =<< G.getSessionDynFlags
|
||||
setTargetFiles fileNames
|
||||
check fileNames = overrideGhcUserOptions $ \ghcOpts -> do
|
||||
withLoggerTwice
|
||||
setAllWaringFlags
|
||||
(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 (
|
||||
withLogger
|
||||
, withLoggerTwice
|
||||
, checkErrorPrefix
|
||||
) where
|
||||
|
||||
import Bag (Bag, bagToList)
|
||||
import Bag (Bag, bagToList, filterBag, unionBags)
|
||||
import Control.Applicative ((<$>))
|
||||
import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
|
||||
import Data.List (isPrefixOf)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.List (isPrefixOf, find)
|
||||
import Data.Maybe (fromMaybe, isJust)
|
||||
import ErrUtils (ErrMsg, errMsgShortDoc, errMsgExtraInfo)
|
||||
import Exception (ghandle)
|
||||
import GHC (DynFlags, SrcSpan, Severity(SevError))
|
||||
@ -71,20 +72,70 @@ withLogger setDF body = ghandle sourceError $ do
|
||||
where
|
||||
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'.
|
||||
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
|
||||
style <- toGhcModT getStyle
|
||||
ret <- convert' (errBagToStrList dflags style . srcErrorMessages $ err)
|
||||
ret <- convert' (errBagToStrList dflags style err)
|
||||
return $ Left ret
|
||||
|
||||
errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String]
|
||||
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
|
||||
@ -98,22 +149,18 @@ ppMsg :: SrcSpan -> Severity-> DynFlags -> PprStyle -> SDoc -> String
|
||||
ppMsg spn sev dflag style msg = prefix ++ cts
|
||||
where
|
||||
cts = showPage dflag style msg
|
||||
defaultPrefix
|
||||
| Gap.isDumpSplices dflag = ""
|
||||
| otherwise = checkErrorPrefix
|
||||
prefix = fromMaybe defaultPrefix $ do
|
||||
prefix = ppMsgPrefix spn sev dflag style
|
||||
|
||||
ppMsgPrefix :: SrcSpan -> Severity-> DynFlags -> PprStyle -> String
|
||||
ppMsgPrefix spn sev dflag _style =
|
||||
let defaultPrefix
|
||||
| Gap.isDumpSplices dflag = ""
|
||||
| otherwise = checkErrorPrefix
|
||||
in fromMaybe defaultPrefix $ do
|
||||
(line,col,_,_) <- Gap.getSrcSpan spn
|
||||
file <- normalise <$> Gap.getSrcFile spn
|
||||
let severityCaption = Gap.showSeverityCaption sev
|
||||
pref0
|
||||
| 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"
|
||||
return $ file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption
|
||||
|
||||
checkErrorPrefix :: String
|
||||
checkErrorPrefix = "Dummy:0:0:Error:"
|
||||
|
@ -19,7 +19,8 @@
|
||||
((ghc-check-overlay-at (point))
|
||||
(ghc-check-insert-from-warning))
|
||||
(t
|
||||
(message "Nothing to be done"))))
|
||||
(when (null (ghc-try-case-split))
|
||||
(message "Nothing to be done")))))
|
||||
|
||||
(defun ghc-insert-module-template ()
|
||||
(let* ((fullname (file-name-sans-extension (buffer-file-name)))
|
||||
|
@ -125,10 +125,9 @@ unloaded modules are loaded")
|
||||
|
||||
(defun ghc-complete ()
|
||||
(interactive)
|
||||
(when (null (ghc-try-rewrite))
|
||||
(if (ghc-should-scroll)
|
||||
(ghc-scroll-completion-buffer)
|
||||
(ghc-try-complete))))
|
||||
(if (ghc-should-scroll)
|
||||
(ghc-scroll-completion-buffer)
|
||||
(ghc-try-complete)))
|
||||
|
||||
(defun ghc-should-scroll ()
|
||||
(let ((window (ghc-completion-window)))
|
||||
|
@ -11,9 +11,7 @@
|
||||
(require 'ghc-func)
|
||||
(require 'ghc-process)
|
||||
(require 'button)
|
||||
(condition-case nil
|
||||
(require 'dropdown-list)
|
||||
(file-error nil))
|
||||
;(require 'dropdown-list)
|
||||
|
||||
(defvar ghc-auto-info nil)
|
||||
(defvar ghc-auto-buffer nil)
|
||||
@ -35,18 +33,6 @@
|
||||
(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
|
||||
@ -116,38 +102,64 @@
|
||||
(delete-region begin-pos end-pos)
|
||||
(insert msg)))
|
||||
|
||||
;; (defun auto-button (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))))
|
||||
;; Option 1: using button
|
||||
|
||||
;; (define-button-type 'auto-button
|
||||
;; 'follow-link t
|
||||
;; 'help-echo "mouse-2, RET: Insert this completion"
|
||||
;; 'action #'auto-button)
|
||||
(defun ghc-auto-completion-window ()
|
||||
(get-buffer-window ghc-error-buffer-name 0))
|
||||
|
||||
;; (defun ghc-show-auto-messages (info)
|
||||
;; (let ((buf (current-buffer)))
|
||||
;; (setq ghc-auto-info info)
|
||||
;; (setq ghc-auto-buffer buf)
|
||||
;; (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))))))
|
||||
(defun auto-button (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))
|
||||
(quit-restore-window)))
|
||||
|
||||
(define-button-type 'auto-button
|
||||
'follow-link t
|
||||
'help-echo "mouse-2, RET: Insert this completion"
|
||||
'action #'auto-button)
|
||||
|
||||
(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)))))
|
||||
(let ((buf (current-buffer)))
|
||||
(setq ghc-auto-info info)
|
||||
(setq ghc-auto-buffer buf)
|
||||
(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 ()
|
||||
"Try to automatically fill the contents of a hole"
|
||||
|
@ -74,7 +74,7 @@
|
||||
(defvar ghc-shallower-key "\C-c<")
|
||||
(defvar ghc-deeper-key "\C-c>")
|
||||
;(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-auto-key "\C-c\C-a")
|
||||
(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-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-initial-sig-key 'ghc-initial-code-from-signature)
|
||||
(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-prev-hole-key 'ghc-goto-prev-hole)
|
||||
|
Loading…
Reference in New Issue
Block a user