From b9bd4ebf77b22d2d9061d647d7799ddcc7c51228 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 9 Dec 2015 23:38:31 +0100 Subject: [PATCH 1/5] Fix warning with ghc 7.10 --- src/GHCMod/Options/DocUtils.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/GHCMod/Options/DocUtils.hs b/src/GHCMod/Options/DocUtils.hs index 8132d25..c92a657 100644 --- a/src/GHCMod/Options/DocUtils.hs +++ b/src/GHCMod/Options/DocUtils.hs @@ -25,8 +25,9 @@ module GHCMod.Options.DocUtils ( ) where import Options.Applicative -import Data.Monoid (Monoid) -- for ghc<7.10 +import Data.Monoid import Text.PrettyPrint.ANSI.Leijen as PP hiding ((<>), (<$>), (<$$>), int) +import Prelude desc :: [Doc] -> InfoMod a desc = footerDoc . Just . indent 2 . vsep From e7a186a1035a0b204360698229f974282c5388e2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 4 Dec 2015 01:33:41 +0100 Subject: [PATCH 2/5] elisp: Fix excessive use of map-file We still don't do unmap-file but this should alleviate the problem somewhat since most commands won't actually use map-file. --- elisp/ghc-comp.el | 2 +- elisp/ghc-info.el | 8 +------- elisp/ghc-process.el | 38 ++++++++++++++++++++++---------------- 3 files changed, 24 insertions(+), 24 deletions(-) diff --git a/elisp/ghc-comp.el b/elisp/ghc-comp.el index 700e8e3..20be9a1 100644 --- a/elisp/ghc-comp.el +++ b/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) diff --git a/elisp/ghc-info.el b/elisp/ghc-info.el index abe4356..c10e032 100644 --- a/elisp/ghc-info.el +++ b/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))) - -(defun ghc-type-fix-string () - (save-excursion - (goto-char (point-min)) - (while (search-forward "[Char]" nil t) - (replace-match "String")))) + (ghc-sync-process cmd nil))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; diff --git a/elisp/ghc-process.el b/elisp/ghc-process.el index 2a70b27..257a18e 100644 --- a/elisp/ghc-process.el +++ b/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 - (unless skip-map-file +; (unmap-cmd (format "unmap-file %s\n" 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 - (if ghc-process-hook (funcall ghc-process-hook)) + (when ghc-process-async-after-callback (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) From d25908d3cb1e77c0b09824f5d7068d28a1af3c7d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Tue, 15 Dec 2015 22:59:32 +0100 Subject: [PATCH 3/5] Update 5.3.0.0 metadata --- hackage-metadata/ghc-mod-5.3.0.0.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/hackage-metadata/ghc-mod-5.3.0.0.cabal b/hackage-metadata/ghc-mod-5.3.0.0.cabal index 8a1e949..a9b7ac0 100644 --- a/hackage-metadata/ghc-mod-5.3.0.0.cabal +++ b/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 , @@ -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 From 6de02ea4700a700c1d5950309242ed4d44e357ae Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 16 Dec 2015 00:23:51 +0100 Subject: [PATCH 4/5] Cleanup loadTarget logic --- Language/Haskell/GhcMod/DynFlags.hs | 8 ++-- Language/Haskell/GhcMod/Internal.hs | 3 -- Language/Haskell/GhcMod/Monad/Types.hs | 9 ----- Language/Haskell/GhcMod/Target.hs | 52 +++++++++++--------------- Language/Haskell/GhcMod/Types.hs | 5 +-- 5 files changed, 26 insertions(+), 51 deletions(-) diff --git a/Language/Haskell/GhcMod/DynFlags.hs b/Language/Haskell/GhcMod/DynFlags.hs index f335a7c..4d54ae2 100644 --- a/Language/Haskell/GhcMod/DynFlags.hs +++ b/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 -setModeSimple df = df { +setHscNothing :: DynFlags -> DynFlags +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 -setModeIntelligent df = df { +setHscInterpreted :: DynFlags -> DynFlags +setHscInterpreted df = df { ghcMode = CompManager , ghcLink = LinkInMemory , hscTarget = HscInterpreted diff --git a/Language/Haskell/GhcMod/Internal.hs b/Language/Haskell/GhcMod/Internal.hs index a743768..2aa4e1b 100644 --- a/Language/Haskell/GhcMod/Internal.hs +++ b/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' diff --git a/Language/Haskell/GhcMod/Monad/Types.hs b/Language/Haskell/GhcMod/Monad/Types.hs index 7a51276..eb6baed 100644 --- a/Language/Haskell/GhcMod/Monad/Types.hs +++ b/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 diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index e8b36a2..6818ef0 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/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 - if mode == Intelligent - then loadTargets' Intelligent - else do - mdls <- depanal [] False - let fallback = needsFallback mdls - if fallback then do - resetTargets targets - setIntelligent - gmLog GmInfo "loadTargets" $ - text "Target needs interpeter, switching to LinkInMemory/HscInterpreted. Perfectly normal if anything is using TemplateHaskell, QuasiQuotes or PatternSynonyms." - loadTargets' Intelligent - else - loadTargets' Simple + mg <- depanal [] False + + let interp = needsHscInterpreted mg + target <- hscTarget <$> getSessionDynFlags + when (interp && target /= HscInterpreted) $ do + resetTargets targets + _ <- setSessionDynFlags . setHscInterpreted =<< getSessionDynFlags + gmLog GmInfo "loadTargets" $ text "Target needs interpeter, switching to LinkInMemory/HscInterpreted. Perfectly normal if anything is using TemplateHaskell, QuasiQuotes or PatternSynonyms." + + target' <- hscTarget <$> getSessionDynFlags + + case target' of + HscNothing -> do + 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 -needsFallback = any $ \ms -> +needsHscInterpreted :: ModuleGraph -> Bool +needsHscInterpreted = any $ \ms -> let df = ms_hspp_opts ms in Opt_TemplateHaskell `xopt` df || Opt_QuasiQuotes `xopt` df diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 9f77ed3..b22964e 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/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 ---------------------------------------------------------------- From 2988749b844136148bdd35f239d3f4747813b821 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 16 Dec 2015 21:49:53 +0100 Subject: [PATCH 5/5] README: Use master branch for travis-ci status image --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 40e8361..3466337 100644 --- a/README.md +++ b/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/)