Merge pull request #320 from serras/master

Do not use dropdown-list + change keybindings + improve checking with typed holes

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

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:"

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

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

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"

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)