diff --git a/Language/Haskell/GhcMod/Check.hs b/Language/Haskell/GhcMod/Check.hs index ea2e28a..f45015e 100644 --- a/Language/Haskell/GhcMod/Check.hs +++ b/Language/Haskell/GhcMod/Check.hs @@ -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) ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/Logger.hs b/Language/Haskell/GhcMod/Logger.hs index 9e78fb5..846f7cd 100644 --- a/Language/Haskell/GhcMod/Logger.hs +++ b/Language/Haskell/GhcMod/Logger.hs @@ -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:" diff --git a/elisp/ghc-command.el b/elisp/ghc-command.el index dfb7679..cb9b2b9 100644 --- a/elisp/ghc-command.el +++ b/elisp/ghc-command.el @@ -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))) diff --git a/elisp/ghc-comp.el b/elisp/ghc-comp.el index a8f067b..2b26a16 100644 --- a/elisp/ghc-comp.el +++ b/elisp/ghc-comp.el @@ -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))) diff --git a/elisp/ghc-rewrite.el b/elisp/ghc-rewrite.el index 9e021e4..14432f9 100644 --- a/elisp/ghc-rewrite.el +++ b/elisp/ghc-rewrite.el @@ -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" diff --git a/elisp/ghc.el b/elisp/ghc.el index 5a196fb..c541301 100644 --- a/elisp/ghc.el +++ b/elisp/ghc.el @@ -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)