diff --git a/Browse.hs b/Browse.hs --- a/Browse.hs +++ b/Browse.hs @@ -25,7 +25,7 @@ browse :: Options -> String -> IO [String] browse opt mdlName = withGHC $ do - initSession0 opt + _ <- initSession0 opt maybeNamesToStrings <$> lookupModuleInfo where lookupModuleInfo = findModule (mkModuleName mdlName) Nothing >>= getModuleInfo diff --git a/CabalDev.hs b/CabalDev.hs --- a/CabalDev.hs +++ b/CabalDev.hs @@ -37,9 +37,10 @@ searchIt :: [FilePath] -> IO FilePath searchIt [] = throwIO $ userError "Not found" searchIt path = do - a <- doesDirectoryExist (mpath path) - if a then - findConf (mpath path) + let cabalDir = mpath path + exist <- doesDirectoryExist cabalDir + if exist then + findConf cabalDir else searchIt $ init path where diff --git a/Check.hs b/Check.hs --- a/Check.hs +++ b/Check.hs @@ -7,7 +7,7 @@ import Exception import GHC import GHCApi -import Prelude hiding (catch) +import Prelude import Types ---------------------------------------------------------------- @@ -23,8 +23,8 @@ checkIt = do (file,readLog) <- initializeGHC opt fileName options True setTargetFile file - load LoadAllTargets + _ <- load LoadAllTargets liftIO readLog options | expandSplice opt = ["-w:"] ++ ghcOpts opt - | otherwise = ["-Wall","-fno-warn-unused-do-bind"] ++ ghcOpts opt + | otherwise = ["-Wall"] ++ ghcOpts opt diff --git a/ErrMsg.hs b/ErrMsg.hs --- a/ErrMsg.hs +++ b/ErrMsg.hs @@ -24,13 +24,13 @@ setLogger :: Bool -> DynFlags -> IO (DynFlags, LogReader) setLogger False df = return (newdf, undefined) where - newdf = df { log_action = \_ _ _ _ -> return () } + newdf = Gap.setLogAction df $ \_ _ _ _ _ -> return () setLogger True df = do ref <- newIORef [] :: IO (IORef [String]) - let newdf = df { log_action = appendLog ref } + let newdf = Gap.setLogAction df $ appendLog ref return (newdf, reverse <$> readIORef ref) where - appendLog ref _ src stl msg = modifyIORef ref (\ls -> ppMsg src msg stl : ls) + appendLog ref _ _ src stl msg = modifyIORef ref (\ls -> ppMsg src msg stl : ls) ---------------------------------------------------------------- @@ -49,7 +49,7 @@ msg = errMsgShortDoc err ext = showMsg (errMsgExtraInfo err) defaultUserStyle -ppMsg :: SrcSpan -> Message -> PprStyle -> String +ppMsg :: SrcSpan -> SDoc -> PprStyle -> String ppMsg spn msg stl = fromMaybe def $ do (line,col,_,_) <- Gap.getSrcSpan spn file <- Gap.getSrcFile spn diff --git a/GHCApi.hs b/GHCApi.hs --- a/GHCApi.hs +++ b/GHCApi.hs @@ -37,7 +37,7 @@ let opts = map noLoc cmdOpts (dflags',_,_) <- parseDynamicFlags dflags opts (dflags'',readLog) <- liftIO . (>>= setLogger logging) . setGhcFlags opt . setFlags opt dflags' $ idirs - setSessionDynFlags dflags'' + _ <- setSessionDynFlags dflags'' return readLog ---------------------------------------------------------------- diff --git a/Gap.hs b/Gap.hs --- a/Gap.hs +++ b/Gap.hs @@ -1,7 +1,13 @@ {-# LANGUAGE CPP #-} module Gap ( - supportedExtensions + Gap.ClsInst + , mkTarget + , showDocForUser + , showDoc + , styleDoc + , setLogAction + , supportedExtensions , getSrcSpan , getSrcFile , renderMsg @@ -18,7 +24,9 @@ import Control.Applicative hiding (empty) import Control.Monad +import Data.Time.Clock import DynFlags +import ErrUtils import FastString import GHC import GHCChoice @@ -26,6 +34,11 @@ import Outputable import StringBuffer +import qualified InstEnv +import qualified Pretty +import qualified StringBuffer as SB + + #if __GLASGOW_HASKELL__ >= 702 import CoreMonad (liftIO) #else @@ -33,6 +46,11 @@ import Pretty #endif +#if __GLASGOW_HASKELL__ < 706 +import Control.Arrow +import Data.Convertible +#endif + {- pretty :: Outputable a => a -> String pretty = showSDocForUser neverQualify . ppr @@ -43,7 +61,57 @@ ---------------------------------------------------------------- ---------------------------------------------------------------- +-- +#if __GLASGOW_HASKELL__ >= 706 +type ClsInst = InstEnv.ClsInst +#else +type ClsInst = InstEnv.Instance +#endif +mkTarget :: TargetId -> Bool -> Maybe (SB.StringBuffer, UTCTime) -> Target +#if __GLASGOW_HASKELL__ >= 706 +mkTarget = Target +#else +mkTarget tid allowObjCode = Target tid allowObjCode . (fmap . second) convert +#endif + +---------------------------------------------------------------- +---------------------------------------------------------------- + +showDocForUser :: PrintUnqualified -> SDoc -> String +#if __GLASGOW_HASKELL__ >= 706 +showDocForUser = showSDocForUser tracingDynFlags +#else +showDocForUser = showSDocForUser +#endif + +showDoc :: SDoc -> String +#if __GLASGOW_HASKELL__ >= 706 +showDoc = showSDoc tracingDynFlags +#else +showDoc = showSDoc +#endif + +styleDoc :: PprStyle -> SDoc -> Pretty.Doc +#if __GLASGOW_HASKELL__ >= 706 +styleDoc = withPprStyleDoc tracingDynFlags +#else +styleDoc = withPprStyleDoc +#endif + +setLogAction :: DynFlags + -> (DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()) + -> DynFlags +setLogAction df f = +#if __GLASGOW_HASKELL__ >= 706 + df { log_action = f } +#else + df { log_action = f df } +#endif + +---------------------------------------------------------------- +---------------------------------------------------------------- + supportedExtensions :: [String] #if __GLASGOW_HASKELL__ >= 700 supportedExtensions = supportedLanguagesAndExtensions @@ -77,7 +145,9 @@ ---------------------------------------------------------------- renderMsg :: SDoc -> PprStyle -> String -#if __GLASGOW_HASKELL__ >= 702 +#if __GLASGOW_HASKELL__ >= 706 +renderMsg d stl = renderWithStyle tracingDynFlags d stl +#elif __GLASGOW_HASKELL__ >= 702 renderMsg d stl = renderWithStyle d stl #else renderMsg d stl = Pretty.showDocWith PageMode $ d stl @@ -111,7 +181,12 @@ setCtx :: [ModSummary] -> Ghc Bool #if __GLASGOW_HASKELL__ >= 704 setCtx ms = do - top <- map (IIModule . ms_mod) <$> filterM isTop ms +#if __GLASGOW_HASKELL__ >= 706 + let modName = IIModule . moduleName . ms_mod +#else + let modName = IIModule . ms_mod +#endif + top <- map modName <$> filterM isTop ms setContext top return (not . null $ top) #else diff --git a/Info.hs b/Info.hs --- a/Info.hs +++ b/Info.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TupleSections, FlexibleInstances, TypeSynonymInstances #-} +{-# LANGUAGE Rank2Types #-} module Info (infoExpr, typeExpr) where @@ -10,6 +11,7 @@ import Data.List import Data.Maybe import Data.Ord as O +import Data.Time.Clock import Desugar import GHC import GHC.SYB.Utils @@ -21,7 +23,6 @@ import Outputable import PprTyThing import Pretty (showDocWith, Mode(OneLineMode)) -import System.Time import TcRnTypes import TcHsSyn (hsPatType) import Types @@ -106,7 +107,7 @@ listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x])) pretty :: Type -> String -pretty = showDocWith OneLineMode . withPprStyleDoc (mkUserStyle neverQualify AllTheWay) . pprTypeForUser False +pretty = showDocWith OneLineMode . Gap.styleDoc (mkUserStyle neverQualify AllTheWay) . pprTypeForUser False ---------------------------------------------------------------- -- from ghc/InteractiveUI.hs @@ -117,7 +118,7 @@ mb_stuffs <- mapM getInfo names let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs) unqual <- getPrintUnqual - return $ showSDocForUser unqual $ vcat (intersperse (text "") $ map (pprInfo False) filtered) + return $ Gap.showDocForUser unqual $ vcat (intersperse (text "") $ map (pprInfo False) filtered) filterOutChildren :: (a -> TyThing) -> [a] -> [a] filterOutChildren get_thing xs @@ -125,7 +126,7 @@ where implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)] -pprInfo :: PrintExplicitForalls -> (TyThing, GHC.Fixity, [Instance]) -> SDoc +pprInfo :: PrintExplicitForalls -> (TyThing, GHC.Fixity, [Gap.ClsInst]) -> SDoc pprInfo pefas (thing, fixity, insts) = pprTyThingInContextLoc pefas thing $$ show_fixity fixity @@ -144,22 +145,24 @@ valid = do (file,_) <- initializeGHC opt fileName ["-w"] False setTargetFile file - load LoadAllTargets + _ <- load LoadAllTargets doif setContextFromTarget action invalid = do - initializeGHC opt fileName ["-w"] False + _ <- initializeGHC opt fileName ["-w"] False setTargetBuffer - load LoadAllTargets + _ <- load LoadAllTargets doif setContextFromTarget action setTargetBuffer = do modgraph <- depanal [mkModuleName modstr] True - let imports = concatMap (map (showSDoc . ppr . unLoc)) $ + let imports = concatMap (map (Gap.showDoc . ppr . unLoc)) $ map ms_imps modgraph ++ map ms_srcimps modgraph moddef = "module " ++ sanitize modstr ++ " where" header = moddef : imports importsBuf <- Gap.toStringBuffer header - clkTime <- Gap.liftIO getClockTime - setTargets [Target (TargetModule $ mkModuleName modstr) True (Just (importsBuf, clkTime))] + clkTime <- Gap.liftIO getCurrentTime + setTargets [Gap.mkTarget (TargetModule $ mkModuleName modstr) + True + (Just (importsBuf, clkTime))] doif m t = m >>= \ok -> if ok then t else goNext sanitize = fromMaybe "SomeModule" . listToMaybe . words diff --git a/List.hs b/List.hs --- a/List.hs +++ b/List.hs @@ -15,7 +15,7 @@ list :: Options -> IO [String] list opt = withGHC $ do - initSession0 opt + _ <- initSession0 opt getExposedModules <$> getSessionDynFlags where getExposedModules = map moduleNameString diff --git a/elisp/ghc-command.el b/elisp/ghc-command.el --- a/elisp/ghc-command.el +++ b/elisp/ghc-command.el @@ -41,7 +41,7 @@ (defun ghc-save-buffer () (interactive) (if (buffer-modified-p) - (save-buffer) + (call-interactively 'save-buffer) (flymake-start-syntax-check))) (provide 'ghc-command) diff --git a/elisp/ghc-comp.el b/elisp/ghc-comp.el --- a/elisp/ghc-comp.el +++ b/elisp/ghc-comp.el @@ -95,7 +95,7 @@ ;;; (defun ghc-boot (n) - (if (not (ghc-which ghc-module-command)) + (if (not (executable-find ghc-module-command)) (message "%s not found" ghc-module-command) (ghc-read-lisp-list (lambda () @@ -105,7 +105,7 @@ n))) (defun ghc-load-modules (mods) - (if (not (ghc-which ghc-module-command)) + (if (not (executable-find ghc-module-command)) (message "%s not found" ghc-module-command) (ghc-read-lisp-list (lambda () diff --git a/elisp/ghc-func.el b/elisp/ghc-func.el --- a/elisp/ghc-func.el +++ b/elisp/ghc-func.el @@ -49,17 +49,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun ghc-which (cmd) - (catch 'loop - (dolist (suffix '("" ".exe")) - (let ((cmds (concat cmd suffix))) - (dolist (dir exec-path) - (let ((path (expand-file-name cmds dir))) - (if (file-exists-p path) - (throw 'loop path)))))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (defun ghc-uniq-lol (lol) (let ((hash (make-hash-table :test 'equal)) ret) diff --git a/elisp/ghc-indent.el b/elisp/ghc-indent.el --- a/elisp/ghc-indent.el +++ b/elisp/ghc-indent.el @@ -12,24 +12,10 @@ (defun ghc-make-indent-shallower (beg end) (interactive "r") - (let ((n ghc-indent-offset)) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (goto-char beg) - (while (not (eobp)) - (delete-region (point) (+ (point) n)) - (forward-line)))))) + (indent-rigidly (region-beginning) (region-end) (- ghc-indent-offset))) (defun ghc-make-indent-deeper (beg end) (interactive "r") - (let ((indent (make-string ghc-indent-offset 32))) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (goto-char beg) - (while (not (eobp)) - (insert indent) - (forward-line)))))) + (indent-rigidly (region-beginning) (region-end) ghc-indent-offset)) (provide 'ghc-indent) diff --git a/elisp/ghc-info.el b/elisp/ghc-info.el --- a/elisp/ghc-info.el +++ b/elisp/ghc-info.el @@ -70,7 +70,7 @@ (defun ghc-show-type () (interactive) - (if (not (ghc-which ghc-module-command)) + (if (not (executable-find ghc-module-command)) (message "%s not found" ghc-module-command) (let ((modname (or (ghc-find-module-name) "Main"))) (ghc-show-type0 modname)))) @@ -134,7 +134,7 @@ (defun ghc-display-information (cmds fontify) (interactive) - (if (not (ghc-which ghc-module-command)) + (if (not (executable-find ghc-module-command)) (message "%s not found" ghc-module-command) (ghc-display fontify diff --git a/elisp/ghc-ins-mod.el b/elisp/ghc-ins-mod.el --- a/elisp/ghc-ins-mod.el +++ b/elisp/ghc-ins-mod.el @@ -12,7 +12,7 @@ (defun ghc-insert-module () (interactive) - (if (not (ghc-which ghc-hoogle-command)) + (if (not (executable-find ghc-hoogle-command)) (message "\"%s\" not found" ghc-hoogle-command) (let* ((expr0 (ghc-things-at-point)) (expr (ghc-read-expression expr0))) diff --git a/ghc-mod.cabal b/ghc-mod.cabal --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -1,5 +1,5 @@ Name: ghc-mod -Version: 1.11.0 +Version: 1.11.1 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -42,12 +42,10 @@ List Paths_ghc_mod Types - if impl(ghc >= 6.12) - GHC-Options: -Wall -fno-warn-unused-do-bind - else - GHC-Options: -Wall + GHC-Options: -Wall Build-Depends: base >= 4.0 && < 5 , Cabal + , convertible , directory , filepath , ghc @@ -59,6 +57,7 @@ , process , regex-posix , syb + , time , transformers Source-Repository head