Merge remote-tracking branch 'upstream/master' into interactive-shell-syntax

Language/Haskell/GhcMod/DynFlags.hs

@@ -25,8 +25,8 @@ setDebugLogger put df = do
 -- * Friendly to foreign export
 -- * Not friendly to -XTemplateHaskell and -XPatternSynonyms
 -- * Uses little memory
-setModeSimple :: DynFlags -> DynFlags
+setHscNothing :: DynFlags -> DynFlags
-setModeSimple df = df {
+setHscNothing df = df {
     ghcMode   = CompManager
   , ghcLink   = NoLink
   , hscTarget = HscNothing
@@ -37,8 +37,8 @@ setModeSimple df = df {
 -- * Not friendly to foreign export
 -- * Friendly to -XTemplateHaskell and -XPatternSynonyms
 -- * Uses lots of memory
-setModeIntelligent :: DynFlags -> DynFlags
+setHscInterpreted :: DynFlags -> DynFlags
-setModeIntelligent df = df {
+setHscInterpreted df = df {
     ghcMode   = CompManager
   , ghcLink   = LinkInMemory
   , hscTarget = HscInterpreted

Language/Haskell/GhcMod/Internal.hs

@@ -17,7 +17,6 @@ module Language.Haskell.GhcMod.Internal (
   -- * Environment, state and logging
   , GhcModEnv(..)
   , GhcModState
-  , CompilerMode(..)
   , GhcModLog
   , GmLog(..)
   , GmLogLevel(..)
@@ -34,8 +33,6 @@ module Language.Haskell.GhcMod.Internal (
   -- ** Accessing 'GhcModEnv' and 'GhcModState'
   , options
   , cradle
-  , getCompilerMode
-  , setCompilerMode
   , targetGhcOptions
   , withOptions
   -- * 'GhcModError'

Language/Haskell/GhcMod/Monad/Types.hs

@@ -36,7 +36,6 @@ module Language.Haskell.GhcMod.Monad.Types (
   , defaultGhcModState
   , GmGhcSession(..)
   , GmComponent(..)
-  , CompilerMode(..)
   -- * Accessing 'GhcModEnv', 'GhcModState' and 'GhcModLog'
   , GmLogLevel(..)
   , GhcModLog(..)
@@ -50,8 +49,6 @@ module Language.Haskell.GhcMod.Monad.Types (
   , options
   , outputOpts
   , withOptions
-  , getCompilerMode
-  , setCompilerMode
   , getMMappedFiles
   , setMMappedFiles
   , addMMappedFile
@@ -549,12 +546,6 @@ outputOpts = gmoOptions `liftM` gmoAsk
 cradle :: GmEnv m => m Cradle
 cradle = gmCradle `liftM` gmeAsk
 
-getCompilerMode :: GmState m => m CompilerMode
-getCompilerMode = gmCompilerMode `liftM` gmsGet
-
-setCompilerMode :: GmState m => CompilerMode -> m ()
-setCompilerMode mode = (\s -> gmsPut s { gmCompilerMode = mode } ) =<< gmsGet
-
 getMMappedFiles :: GmState m => m FileMappingMap
 getMMappedFiles = gmMMappedFiles `liftM` gmsGet
 

Language/Haskell/GhcMod/Target.hs

@@ -143,7 +143,7 @@ runGmlTWith efnmns' mdf wrapper action = do
                   | otherwise = setEmptyLogger
 
     initSession opts' $
-        setModeSimple >>> setLogger >>> mdf
+        setHscNothing >>> setLogger >>> mdf
 
     mappedStrs <- getMMappedFilePaths
     let targetStrs = mappedStrs ++ map moduleNameString mns ++ cfns
@@ -430,20 +430,24 @@ loadTargets opts targetStrs = do
 
     setTargets targets
 
-    mode <- getCompilerMode
+    mg <- depanal [] False
-    if mode == Intelligent
+
-      then loadTargets' Intelligent
+    let interp = needsHscInterpreted mg
-      else do
+    target <- hscTarget <$> getSessionDynFlags
-        mdls <- depanal [] False
+    when (interp && target /= HscInterpreted) $ do
-        let fallback = needsFallback mdls
+      resetTargets targets
-        if fallback then do
+      _ <- setSessionDynFlags . setHscInterpreted =<< getSessionDynFlags
-            resetTargets targets
+      gmLog GmInfo "loadTargets" $ text "Target needs interpeter, switching to LinkInMemory/HscInterpreted. Perfectly normal if anything is using TemplateHaskell, QuasiQuotes or PatternSynonyms."
-            setIntelligent
+
-            gmLog GmInfo "loadTargets" $
+    target' <- hscTarget <$> getSessionDynFlags
-                text "Target needs interpeter, switching to LinkInMemory/HscInterpreted. Perfectly normal if anything is using TemplateHaskell, QuasiQuotes or PatternSynonyms."
+
-            loadTargets' Intelligent
+    case target' of
-          else
+      HscNothing -> do
-            loadTargets' Simple
+        void $ load LoadAllTargets
+        mapM_ (parseModule >=> typecheckModule >=> desugarModule) mg
+      HscInterpreted -> do
+        void $ load LoadAllTargets
+      _ -> error ("loadTargets: unsupported hscTarget")
 
     gmLog GmDebug "loadTargets" $ text "Loading done"
 
@@ -455,30 +459,16 @@ loadTargets opts targetStrs = do
       return $ Target tid taoc src
     relativize tgt = return tgt
 
-    loadTargets' Simple = do
-        void $ load LoadAllTargets
-        mapM_ (parseModule >=> typecheckModule >=> desugarModule) =<< getModuleGraph
-
-    loadTargets' Intelligent = do
-        df <- getSessionDynFlags
-        void $ setSessionDynFlags (setModeIntelligent df)
-        void $ load LoadAllTargets
-
     resetTargets targets' = do
         setTargets []
         void $ load LoadAllTargets
         setTargets targets'
 
-    setIntelligent = do
-        newdf <- setModeIntelligent <$> getSessionDynFlags
-        void $ setSessionDynFlags newdf
-        setCompilerMode Intelligent
-
     showTargetId (Target (TargetModule s) _ _) = moduleNameString s
     showTargetId (Target (TargetFile s _) _ _) = s
 
-needsFallback :: ModuleGraph -> Bool
+needsHscInterpreted :: ModuleGraph -> Bool
-needsFallback = any $ \ms ->
+needsHscInterpreted = any $ \ms ->
                 let df = ms_hspp_opts ms in
                    Opt_TemplateHaskell `xopt` df
                 || Opt_QuasiQuotes     `xopt` df

Language/Haskell/GhcMod/Types.hs

@@ -199,16 +199,13 @@ data GhcModCaches = GhcModCaches {
 
 data GhcModState = GhcModState {
       gmGhcSession   :: !(Maybe GmGhcSession)
-    , gmCompilerMode :: !CompilerMode
     , gmCaches       :: !GhcModCaches
     , gmMMappedFiles :: !FileMappingMap
     }
 
-data CompilerMode = Simple | Intelligent deriving (Eq,Show,Read)
-
 defaultGhcModState :: GhcModState
 defaultGhcModState =
-    GhcModState n Simple (GhcModCaches n n n n) Map.empty
+    GhcModState n (GhcModCaches n n n n) Map.empty
  where n = Nothing
 
 ----------------------------------------------------------------

README.md

@@ -1,5 +1,5 @@
 # Happy Haskell Programming
-[![Build Status](https://travis-ci.org/kazu-yamamoto/ghc-mod.png)](https://travis-ci.org/kazu-yamamoto/ghc-mod)
+[![Build Status](https://travis-ci.org/kazu-yamamoto/ghc-mod.svg?branch=master)](https://travis-ci.org/kazu-yamamoto/ghc-mod)
 
 Please read: [http://www.mew.org/~kazu/proj/ghc-mod/](http://www.mew.org/~kazu/proj/ghc-mod/)
 

elisp/ghc-comp.el

@@ -101,7 +101,7 @@ unloaded modules are loaded")
 (defun ghc-boot (n)
   (prog2
       (message "Initializing...")
-      (ghc-sync-process "boot\n" n nil 'skip-map-file)
+      (ghc-sync-process "boot\n" n)
     (message "Initializing...done")))
 
 (defun ghc-load-modules (mods)

elisp/ghc-info.el

@@ -111,13 +111,7 @@
 	 (cn (int-to-string (1+ (current-column))))
 	 (file (buffer-file-name))
 	 (cmd (format "type %s %s %s\n" file ln cn)))
-    (ghc-sync-process cmd nil 'ghc-type-fix-string)))
+    (ghc-sync-process cmd nil)))
-
-(defun ghc-type-fix-string ()
-  (save-excursion
-    (goto-char (point-min))
-    (while (search-forward "[Char]" nil t)
-      (replace-match "String"))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;

elisp/ghc-process.el

@@ -1,3 +1,4 @@
+;;; -*- lexical-binding: t -*-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
 ;;; ghc-process.el
@@ -21,8 +22,6 @@
 (defvar-local ghc-process-process-name nil)
 (defvar-local ghc-process-original-buffer nil)
 (defvar-local ghc-process-original-file nil)
-(defvar-local ghc-process-callback nil)
-(defvar-local ghc-process-hook nil)
 (defvar-local ghc-process-root nil)
 
 (defvar ghc-command "ghc-mod")
@@ -35,12 +34,12 @@
 (defun ghc-get-project-root ()
   (ghc-run-ghc-mod '("root")))
 
-(defun ghc-with-process (cmd callback &optional hook1 hook2 skip-map-file)
+(defun ghc-with-process (cmd async-after-callback &optional sync-before-hook)
   (unless ghc-process-process-name
     (setq ghc-process-process-name (ghc-get-project-root)))
   (when (and ghc-process-process-name (not ghc-process-running))
     (setq ghc-process-running t)
-    (if hook1 (funcall hook1))
+    (if sync-before-hook (funcall sync-before-hook))
     (let* ((cbuf (current-buffer))
 	   (name ghc-process-process-name)
 	   (root (file-name-as-directory ghc-process-process-name))
@@ -52,14 +51,13 @@
       (ghc-with-current-buffer buf
         (setq ghc-process-original-buffer cbuf)
 	(setq ghc-process-original-file file)
-	(setq ghc-process-hook hook2)
 	(setq ghc-process-root root)
 	(let ((pro (ghc-get-process cpro name buf root))
 	      (map-cmd (format "map-file %s\n" file)))
-	  ;; map-file
+;	       (unmap-cmd (format "unmap-file %s\n" file)))
-	  (unless skip-map-file
+	  (when (buffer-modified-p (current-buffer))
 	    (setq ghc-process-file-mapping t)
-	    (setq ghc-process-callback nil)
+	    (setq ghc-process-async-after-callback nil)
 	    (erase-buffer)
 	    (when ghc-debug
 	      (ghc-with-debug-buffer
@@ -79,12 +77,21 @@
 	       (setq ghc-process-running nil)
 	       (setq ghc-process-file-mapping nil))))
 	  ;; command
-	  (setq ghc-process-callback callback)
+	  (setq ghc-process-async-after-callback async-after-callback)
 	  (erase-buffer)
 	  (when ghc-debug
 	    (ghc-with-debug-buffer
 	     (insert (format "%% %s" cmd))))
 	  (process-send-string pro cmd)
+
+	  ;;; this needs to be done asyncrounously after the command actually
+	  ;;; finished, gah
+	  ;; (when do-map-file
+	  ;;   (when ghc-debug
+	  ;;	 (ghc-with-debug-buffer
+	  ;;	  (insert (format "%% %s" unmap-cmd))))
+	  ;;   (process-send-string pro unmap-cmd))
+
 	  pro)))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -166,13 +173,12 @@
 	 ((looking-at "^OK$")
 	  (delete-region (point) (point-max))
 	  (setq ghc-process-file-mapping nil)
-	  (when ghc-process-callback
+	  (when ghc-process-async-after-callback
-	    (if ghc-process-hook (funcall ghc-process-hook))
 	    (goto-char (point-min))
-	    (funcall ghc-process-callback 'ok)
+	    (funcall ghc-process-async-after-callback 'ok)
 	    (setq ghc-process-running nil)))
 	 ((looking-at "^NG ")
-	  (funcall ghc-process-callback 'ng)
+	  (funcall ghc-process-async-after-callback 'ng)
 	  (setq ghc-process-running nil)))))))
 
 (defun ghc-process-sentinel (_process _event)
@@ -185,12 +191,12 @@
 (defvar ghc-process-num-of-results nil)
 (defvar ghc-process-results nil)
 
-(defun ghc-sync-process (cmd &optional n hook skip-map-file)
+(defun ghc-sync-process (cmd &optional n)
   (unless ghc-process-running
     (setq ghc-process-rendezvous nil)
     (setq ghc-process-results nil)
     (setq ghc-process-num-of-results (or n 1))
-    (let ((pro (ghc-with-process cmd 'ghc-process-callback nil hook skip-map-file)))
+    (let ((pro (ghc-with-process cmd 'ghc-sync-process-callback nil)))
       ;; ghc-process-running is now t.
       ;; But if the process exits abnormally, it is set to nil.
       (condition-case nil
@@ -201,7 +207,7 @@
 	 (setq ghc-process-running nil))))
     ghc-process-results))
 
-(defun ghc-process-callback (status)
+(defun ghc-sync-process-callback (status)
   (cond
    ((eq status 'ok)
     (let* ((n ghc-process-num-of-results)

hackage-metadata/ghc-mod-5.3.0.0.cabal

@@ -1,4 +1,4 @@
-X-Revision: 2
+X-Revision: 3
 Name:                   ghc-mod
 Version:                5.3.0.0
 Author:                 Kazu Yamamoto <kazu@iij.ad.jp>,
@@ -134,7 +134,7 @@ Library
                       , bytestring        < 0.11
                       , cereal            < 0.5 && >= 0.4
                       , containers        < 0.6
-                      , cabal-helper      < 0.7 && >= 0.6.1.0
+                      , cabal-helper      < 0.6 && >= 0.5.1.0
                       , deepseq           < 1.5
                       , directory         < 1.3
                       , filepath          < 1.5

src/GHCMod/Options/DocUtils.hs

@@ -23,7 +23,8 @@ module GHCMod.Options.DocUtils (
 ) where
 
 import Options.Applicative
-import Data.Monoid (Monoid) -- for ghc<7.10
+import Data.Monoid
+import Prelude
 
 infixl 6 <||>
 infixr 7 <$$>