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

This commit is contained in:
Nikolay Yakimov 2015-12-20 13:55:22 +03:00
commit 1c45404f74
11 changed files with 55 additions and 79 deletions

View File

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

View File

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

View File

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

View File

@ -143,7 +143,7 @@ runGmlTWith efnmns' mdf wrapper action = do
| otherwise = setEmptyLogger | otherwise = setEmptyLogger
initSession opts' $ initSession opts' $
setModeSimple >>> setLogger >>> mdf setHscNothing >>> setLogger >>> mdf
mappedStrs <- getMMappedFilePaths mappedStrs <- getMMappedFilePaths
let targetStrs = mappedStrs ++ map moduleNameString mns ++ cfns let targetStrs = mappedStrs ++ map moduleNameString mns ++ cfns
@ -430,20 +430,24 @@ loadTargets opts targetStrs = do
setTargets targets 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
if fallback then do
resetTargets targets resetTargets targets
setIntelligent _ <- setSessionDynFlags . setHscInterpreted =<< getSessionDynFlags
gmLog GmInfo "loadTargets" $ gmLog GmInfo "loadTargets" $ text "Target needs interpeter, switching to LinkInMemory/HscInterpreted. Perfectly normal if anything is using TemplateHaskell, QuasiQuotes or PatternSynonyms."
text "Target needs interpeter, switching to LinkInMemory/HscInterpreted. Perfectly normal if anything is using TemplateHaskell, QuasiQuotes or PatternSynonyms."
loadTargets' Intelligent target' <- hscTarget <$> getSessionDynFlags
else
loadTargets' Simple 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" gmLog GmDebug "loadTargets" $ text "Loading done"
@ -455,30 +459,16 @@ loadTargets opts targetStrs = do
return $ Target tid taoc src return $ Target tid taoc src
relativize tgt = return tgt 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 resetTargets targets' = do
setTargets [] setTargets []
void $ load LoadAllTargets void $ load LoadAllTargets
setTargets targets' setTargets targets'
setIntelligent = do
newdf <- setModeIntelligent <$> getSessionDynFlags
void $ setSessionDynFlags newdf
setCompilerMode Intelligent
showTargetId (Target (TargetModule s) _ _) = moduleNameString s showTargetId (Target (TargetModule s) _ _) = moduleNameString s
showTargetId (Target (TargetFile s _) _ _) = 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 let df = ms_hspp_opts ms in
Opt_TemplateHaskell `xopt` df Opt_TemplateHaskell `xopt` df
|| Opt_QuasiQuotes `xopt` df || Opt_QuasiQuotes `xopt` df

View File

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

View File

@ -1,5 +1,5 @@
# Happy Haskell Programming # 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/) Please read: [http://www.mew.org/~kazu/proj/ghc-mod/](http://www.mew.org/~kazu/proj/ghc-mod/)

View File

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

View File

@ -111,13 +111,7 @@
(cn (int-to-string (1+ (current-column)))) (cn (int-to-string (1+ (current-column))))
(file (buffer-file-name)) (file (buffer-file-name))
(cmd (format "type %s %s %s\n" file ln cn))) (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"))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ;;;

View File

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

View File

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

View File

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