ghc-mod 1.10.5 → 1.10.6
raw patch · 17 files changed
+418/−257 lines, 17 filesdep +alternative-iodep +ghc-syb-utils
Dependencies added: alternative-io, ghc-syb-utils
Files
- AA.hs +42/−0
- Browse.hs +1/−0
- Cabal.hs +51/−41
- CabalDev.hs +16/−18
- Check.hs +3/−3
- ErrMsg.hs +8/−22
- Flag.hs +5/−10
- GHCApi.hs +63/−0
- Gap.hs +135/−0
- Info.hs +36/−76
- Lang.hs +2/−8
- List.hs +1/−0
- Types.hs +1/−60
- elisp/ghc-comp.el +10/−4
- elisp/ghc-info.el +12/−9
- elisp/ghc.el +1/−1
- ghc-mod.cabal +31/−5
+ AA.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module AA where++import Control.Applicative+import Control.Exception+import Control.Monad+import CoreMonad+import Data.Typeable+import Exception+import GHC++----------------------------------------------------------------++instance Applicative Ghc where+ pure = return+ (<*>) = ap++instance Alternative Ghc where+ empty = goNext+ x <|> y = x `gcatch` (\(_ :: SomeException) -> y)++----------------------------------------------------------------++{-| Go to the next 'Ghc' monad by throwing 'AltGhcgoNext'.+-}+goNext :: Ghc a+goNext = liftIO $ throwIO AltGhcgoNext++{-| Run any one 'Ghc' monad.+-}+runAnyOne :: [Ghc a] -> Ghc a+runAnyOne = foldr (<|>) goNext++----------------------------------------------------------------++{-| Exception to control 'Alternative' 'Ghc'.+-}+data AltGhcgoNext = AltGhcgoNext deriving (Show, Typeable)++instance Exception AltGhcgoNext
Browse.hs view
@@ -4,6 +4,7 @@ import Data.Char import Data.List import GHC+import GHCApi import Name import Types
Cabal.hs view
@@ -3,14 +3,19 @@ module Cabal (initializeGHC) where import Control.Applicative+import Control.Exception import Control.Monad import CoreMonad import Data.List+import Data.Maybe import Distribution.PackageDescription import Distribution.PackageDescription.Parse (readPackageDescription) import Distribution.Verbosity (silent) import ErrMsg import GHC+import GHCApi+import qualified Gap+import Language.Haskell.Extension import System.Directory import System.FilePath import Types@@ -21,39 +26,46 @@ importDirs = [".","..","../..","../../..","../../../..","../../../../.."] initializeGHC :: Options -> FilePath -> [String] -> Bool -> Ghc (FilePath,LogReader)-initializeGHC opt fileName ghcOptions logging = do- (owdir,mdirfile) <- liftIO getDirs- case mdirfile of- Nothing -> do- logReader <- initSession opt ghcOptions importDirs logging- return (fileName,logReader)- Just (cdir,cfile) -> do- midirs <- parseCabalFile cfile- changeToCabalDirectory cdir- let idirs = case midirs of- [] -> [cdir,owdir]- dirs -> dirs ++ [owdir]- file = ajustFileName fileName owdir cdir- logReader <- initSession opt ghcOptions idirs logging- return (file,logReader)+initializeGHC opt fileName ghcOptions logging = withCabal <|> withoutCabal+ where+ withoutCabal = do+ logReader <- initSession opt ghcOptions importDirs logging+ return (fileName,logReader)+ withCabal = do+ (owdir,cdir,cfile) <- liftIO getDirs+ binfo <- liftIO $ parseCabalFile cfile+ let (idirs',exts',mlang) = extractBuildInfo binfo+ exts = map (addX . Gap.extensionToString) exts'+ lang = maybe "-XHaskell98" (addX . show) mlang+ gopts = ghcOptions ++ exts ++ [lang]+ changeToCabalDirectory cdir+ let idirs = case idirs' of+ [] -> [cdir,owdir]+ dirs -> dirs ++ [owdir]+ file = ajustFileName fileName owdir cdir+ logReader <- initSession opt gopts idirs logging+ return (file,logReader)+ addX = ("-X" ++) ---------------------------------------------------------------- -parseCabalFile :: FilePath -> Ghc [String]+-- Causes error, catched in the upper function.+parseCabalFile :: FilePath -> IO BuildInfo parseCabalFile file = do- cabal <- liftIO $ readPackageDescription silent file- return $ fromLibrary cabal ||| fromExecutable cabal+ cabal <- readPackageDescription silent file+ return . fromJust $ fromLibrary cabal <|> fromExecutable cabal where- [] ||| y = y- x ||| _ = x- fromLibrary c = case condLibrary c of- Nothing -> []- Just lib -> libHsSourceDir lib- libHsSourceDir = hsSourceDirs . libBuildInfo . condTreeData- fromExecutable = execHsSrouceDir . condExecutables- execHsSrouceDir [] = []- execHsSrouceDir (x:_) = hsSourceDirs . buildInfo . condTreeData . snd $ x+ fromLibrary c = libBuildInfo . condTreeData <$> condLibrary c+ fromExecutable c = buildInfo . condTreeData . snd <$> toMaybe (condExecutables c)+ toMaybe [] = Nothing+ toMaybe (x:_) = Just x +-- SourceDirs, Extensions, and Language+extractBuildInfo :: BuildInfo -> ([String],[Extension],Maybe Language)+extractBuildInfo binfo = (hsSourceDirs binfo+ ,oldExtensions binfo+ ,defaultLanguage binfo)+ ---------------------------------------------------------------- ajustFileName :: FilePath -> FilePath -> FilePath -> FilePath@@ -69,25 +81,23 @@ liftIO $ setCurrentDirectory dir workingDirectoryChanged -getDirs :: IO (FilePath, Maybe (FilePath,FilePath))+-- CurrentWorkingDir, CabalDir, CabalFile+getDirs :: IO (FilePath,FilePath,FilePath) getDirs = do wdir <- getCurrentDirectory- mcabdir <- cabalDir wdir- case mcabdir of- Nothing -> return (wdir,Nothing)- jdf -> return (wdir,jdf)+ (cdir,cfile) <- cabalDir wdir+ return (wdir,cdir,cfile) -cabalDir :: FilePath -> IO (Maybe (FilePath,FilePath))+-- Causes error, catched in the upper function.+-- CabalDir, CabalFile+cabalDir :: FilePath -> IO (FilePath,FilePath) cabalDir dir = do cnts <- (filter isCabal <$> getDirectoryContents dir) >>= filterM (\file -> doesFileExist (dir </> file))+ let dir' = takeDirectory dir case cnts of- [] -> do- let dir' = takeDirectory dir- if dir' == dir- then return Nothing- else cabalDir dir'- cfile:_ -> return (Just (dir,dir </> cfile))+ [] | dir' == dir -> throwIO $ userError "No cabal file"+ | otherwise -> cabalDir dir'+ cfile:_ -> return (dir,dir </> cfile) where- isCabal name = ".cabal" `isSuffixOf` name- && length name > 6+ isCabal name = ".cabal" `isSuffixOf` name && length name > 6
CabalDev.hs view
@@ -5,33 +5,31 @@ options ghc-mod uses to check the source. Otherwise just pass it on. -} -import Control.Applicative ((<$>))-import Data.List (find)-import System.FilePath (splitPath,joinPath,(</>))+import Control.Applicative ((<$>),(<|>))+import Control.Exception (throwIO)+import Data.List (find) import System.Directory-import Text.Regex.Posix ((=~))-+import System.FilePath (splitPath,joinPath,(</>))+import Text.Regex.Posix ((=~)) import Types+import Data.Alternative.IO () modifyOptions :: Options -> IO Options-modifyOptions opts =- fmap (has_cdev opts) findCabalDev+modifyOptions opts = found <|> notFound where- has_cdev :: Options -> Maybe String -> Options- has_cdev op Nothing = op- has_cdev op (Just path) = addPath op path+ found = addPath opts <$> findCabalDev+ notFound = return opts -findCabalDev :: IO (Maybe String)-findCabalDev =- getCurrentDirectory >>= searchIt . splitPath+findCabalDev :: IO String+findCabalDev = getCurrentDirectory >>= searchIt . splitPath addPath :: Options -> String -> Options addPath orig_opts path = do let orig_ghcopt = ghcOpts orig_opts orig_opts { ghcOpts = orig_ghcopt ++ ["-package-conf", path] } -searchIt :: [FilePath] -> IO (Maybe FilePath)-searchIt [] = return Nothing+searchIt :: [FilePath] -> IO FilePath+searchIt [] = throwIO $ userError "Not found" searchIt path = do a <- doesDirectoryExist (mpath path) if a then@@ -41,7 +39,7 @@ where mpath a = joinPath a </> "cabal-dev/" -findConf :: FilePath -> IO (Maybe FilePath)+findConf :: FilePath -> IO FilePath findConf path = do- f <- find (=~ "packages.*\\.conf") <$> getDirectoryContents path- return ((path </>) <$> f)+ Just f <- find (=~ "packages.*\\.conf") <$> getDirectoryContents path+ return $ path </> f
Check.hs view
@@ -6,14 +6,14 @@ import ErrMsg import Exception import GHC+import GHCApi import Prelude hiding (catch) import Types ---------------------------------------------------------------- checkSyntax :: Options -> String -> IO String-checkSyntax opt file =- unlines <$> check opt file+checkSyntax opt file = unlines <$> check opt file ---------------------------------------------------------------- @@ -25,4 +25,4 @@ setTargetFile file load LoadAllTargets liftIO readLog- options = ["-Wall","-fno-warn-unused-do-bind", "-XHaskell98"] ++ ghcOpts opt+ options = ["-Wall","-fno-warn-unused-do-bind"] ++ ghcOpts opt
ErrMsg.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}- module ErrMsg ( LogReader , setLogger@@ -9,18 +7,15 @@ import Bag import Control.Applicative import Data.IORef+import Data.Maybe import DynFlags import ErrUtils-import FastString import GHC+import qualified Gap import HscTypes import Outputable import System.FilePath -#if __GLASGOW_HASKELL__ < 702-import Pretty-#endif- ---------------------------------------------------------------- type LogReader = IO [String]@@ -56,27 +51,18 @@ ext = showMsg (errMsgExtraInfo err) defaultUserStyle ppMsg :: SrcSpan -> Message -> PprStyle -> String-#if __GLASGOW_HASKELL__ >= 702-ppMsg (RealSrcSpan src) msg stl-#else-ppMsg src msg stl | isGoodSrcSpan src-#endif- = file ++ ":" ++ line ++ ":" ++ col ++ ":" ++ cts ++ "\0"+ppMsg spn msg stl = fromMaybe def $ do+ (line,col,_,_) <- Gap.getSrcSpan spn+ file <- Gap.getSrcFile spn+ return $ takeFileName file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ cts ++ "\0" where- file = takeFileName $ unpackFS (srcSpanFile src)- line = show (srcSpanStartLine src)- col = show (srcSpanStartCol src)+ def = "ghc-mod:0:0:Probably mutual module import occurred\0" cts = showMsg msg stl-ppMsg _ _ _ = "ghc-mod:0:0:Probably mutual module import occurred\0" ---------------------------------------------------------------- showMsg :: SDoc -> PprStyle -> String-#if __GLASGOW_HASKELL__ >= 702-showMsg d stl = map toNull . renderWithStyle d $ stl-#else-showMsg d stl = map toNull . Pretty.showDocWith PageMode $ d stl-#endif+showMsg d stl = map toNull $ Gap.renderMsg d stl where toNull '\n' = '\0' toNull x = x
Flag.hs view
@@ -2,16 +2,11 @@ module Flag where -import DynFlags import Types+import qualified Gap listFlags :: Options -> IO String-listFlags opt = return $ convert opt- [ "-f" ++ prefix ++ option-#if __GLASGOW_HASKELL__ == 702- | (option,_,_,_) <- fFlags-#else- | (option,_,_) <- fFlags-#endif- , prefix <- ["","no-"]- ]+listFlags opt = return $ convert opt [ "-f" ++ prefix ++ option+ | option <- Gap.fOptions+ , prefix <- ["","no-"]+ ]
+ GHCApi.hs view
@@ -0,0 +1,63 @@+module GHCApi where++import Control.Exception+import Control.Applicative+import CoreMonad+import DynFlags+import ErrMsg+import Exception+import GHC+import GHC.Paths (libdir)+import Types++----------------------------------------------------------------++withGHC :: Alternative m => Ghc (m a) -> IO (m a)+withGHC body = ghandle ignore $ runGhc (Just libdir) $ do+ dflags <- getSessionDynFlags+ defaultCleanupHandler dflags body+ where+ ignore :: Alternative m => SomeException -> IO (m a)+ ignore _ = return empty++----------------------------------------------------------------++initSession0 :: Options -> Ghc [PackageId]+initSession0 opt = getSessionDynFlags >>=+ (>>= setSessionDynFlags) . setGhcFlags opt++initSession :: Options -> [String] -> [FilePath] -> Bool -> Ghc LogReader+initSession opt cmdOpts idirs logging = do+ dflags <- getSessionDynFlags+ let opts = map noLoc cmdOpts+ (dflags',_,_) <- parseDynamicFlags dflags opts+ (dflags'',readLog) <- liftIO . (>>= setLogger logging) . setGhcFlags opt . setFlags dflags' $ idirs+ setSessionDynFlags dflags''+ return readLog++----------------------------------------------------------------++setFlags :: DynFlags -> [FilePath] -> DynFlags+setFlags d idirs = d'+ where+ d' = d {+ packageFlags = ghcPackage : packageFlags d+ , importPaths = idirs+ , ghcLink = NoLink+ , hscTarget = HscInterpreted+ }++ghcPackage :: PackageFlag+ghcPackage = ExposePackage "ghc"++setGhcFlags :: Monad m => Options -> DynFlags -> m DynFlags+setGhcFlags opt flagset =+ do (flagset',_,_) <- parseDynamicFlags flagset (map noLoc (ghcOpts opt))+ return flagset'++----------------------------------------------------------------++setTargetFile :: (GhcMonad m) => String -> m ()+setTargetFile file = do+ target <- guessTarget file Nothing+ setTargets [target]
+ Gap.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE CPP #-}++module Gap (+ supportedExtensions+ , getSrcSpan+ , getSrcFile+ , renderMsg+ , setCtx+ , fOptions+ , toStringBuffer+ , liftIO+ , extensionToString+#if __GLASGOW_HASKELL__ >= 702+#else+ , module Pretty+#endif+ ) where++import AA ()+import Control.Applicative hiding (empty)+import Control.Monad+import DynFlags+import FastString+import GHC+import Language.Haskell.Extension+import Outputable+import StringBuffer++#if __GLASGOW_HASKELL__ >= 702+import CoreMonad (liftIO)+#else+import HscTypes (liftIO)+import Pretty+#endif++{-+pretty :: Outputable a => a -> String+pretty = showSDocForUser neverQualify . ppr++debug :: Outputable a => a -> b -> b+debug x v = trace (pretty x) v+-}++----------------------------------------------------------------+----------------------------------------------------------------++supportedExtensions :: [String]+#if __GLASGOW_HASKELL__ >= 700+supportedExtensions = supportedLanguagesAndExtensions+#else+supportedExtensions = supportedLanguages+#endif++----------------------------------------------------------------+----------------------------------------------------------------++getSrcSpan :: SrcSpan -> Maybe (Int,Int,Int,Int)+#if __GLASGOW_HASKELL__ >= 702+getSrcSpan (RealSrcSpan spn)+#else+getSrcSpan spn | isGoodSrcSpan spn+#endif+ = Just (srcSpanStartLine spn+ , srcSpanStartCol spn+ , srcSpanEndLine spn+ , srcSpanEndCol spn)+getSrcSpan _ = Nothing++getSrcFile :: SrcSpan -> Maybe String+#if __GLASGOW_HASKELL__ >= 702+getSrcFile (RealSrcSpan spn) = Just . unpackFS . srcSpanFile $ spn+#else+getSrcFile spn | isGoodSrcSpan spn = Just . unpackFS . srcSpanFile $ spn+#endif+getSrcFile _ = Nothing++----------------------------------------------------------------++renderMsg :: SDoc -> PprStyle -> String+#if __GLASGOW_HASKELL__ >= 702+renderMsg d stl = renderWithStyle d stl+#else+renderMsg d stl = Pretty.showDocWith PageMode $ d stl+#endif++----------------------------------------------------------------++toStringBuffer :: [String] -> Ghc StringBuffer+#if __GLASGOW_HASKELL__ >= 702+toStringBuffer = return . stringToStringBuffer . unlines+#else+toStringBuffer = liftIO . stringToStringBuffer . unlines+#endif++----------------------------------------------------------------++fOptions :: [String]+#if __GLASGOW_HASKELL__ == 702+fOptions = [option | (option,_,_,_) <- fFlags]+#else+fOptions = [option | (option,_,_) <- fFlags]+#endif++----------------------------------------------------------------+----------------------------------------------------------------++setCtx :: [ModSummary] -> Ghc Bool+#if __GLASGOW_HASKELL__ >= 704+setCtx ms = do+ top <- map (IIModule . ms_mod) <$> filterM isTop ms+ setContext top+ return (not . null $ top)+#else+setCtx ms = do+ top <- map ms_mod <$> filterM isTop ms+ setContext top []+ return (not . null $ top)+#endif+ where+ isTop mos = lookupMod <|> returnFalse+ where+ lookupMod = lookupModule (ms_mod_name mos) Nothing >> return True+ returnFalse = return False++----------------------------------------------------------------+-- This is Cabal, not GHC API++extensionToString :: Extension -> String+#if __GLASGOW_HASKELL__ == 704+extensionToString (EnableExtension ext) = show ext+extensionToString (DisableExtension ext) = show ext -- FIXME+extensionToString (UnknownExtension ext) = ext+#else+extensionToString = show+#endif
Info.hs view
@@ -2,30 +2,29 @@ module Info (infoExpr, typeExpr) where +import AA import Cabal-import Control.Applicative hiding (empty)-import Control.Exception-import Control.Monad+import Control.Applicative import CoreUtils import Data.Function-import Data.Generics as G+import Data.Generics import Data.List import Data.Maybe import Data.Ord as O import Desugar import GHC+import GHC.SYB.Utils+import GHCApi+import qualified Gap import HscTypes import NameSet import Outputable import PprTyThing-import StringBuffer import System.Time import TcRnTypes import Types -#if __GLASGOW_HASKELL__ >= 702-import CoreMonad-#endif+---------------------------------------------------------------- type Expression = String type ModuleString = String@@ -36,7 +35,8 @@ infoExpr opt modstr expr file = (++ "\n") <$> info opt file modstr expr info :: Options -> FilePath -> ModuleString -> FilePath -> IO String-info opt fileName modstr expr = inModuleContext opt fileName modstr exprToInfo+info opt fileName modstr expr =+ inModuleContext opt fileName modstr exprToInfo "Cannot show info" where exprToInfo = infoThing expr @@ -46,63 +46,47 @@ typeExpr opt modstr lineNo colNo file = Info.typeOf opt file modstr lineNo colNo typeOf :: Options -> FilePath -> ModuleString -> Int -> Int -> IO String-typeOf opt fileName modstr lineNo colNo = inModuleContext opt fileName modstr exprToType+typeOf opt fileName modstr lineNo colNo =+ inModuleContext opt fileName modstr exprToType errmsg where exprToType = do modSum <- getModSummary $ mkModuleName modstr p <- parseModule modSum tcm <- typecheckModule p- es <- liftIO $ findExpr tcm lineNo colNo+ let es = findExpr tcm lineNo colNo ts <- catMaybes <$> mapM (getType tcm) es let sss = map toTup $ sortBy (cmp `on` fst) ts return $ convert opt sss toTup :: (SrcSpan, Type) -> ((Int,Int,Int,Int),String)- toTup (spn, typ) = (l spn, pretty typ)+ toTup (spn, typ) = (fourInts spn, pretty typ) - l :: SrcSpan -> (Int,Int,Int,Int)-#if __GLASGOW_HASKELL__ >= 702- l (RealSrcSpan spn)-#else- l spn | isGoodSrcSpan spn-#endif- = (srcSpanStartLine spn, srcSpanStartCol spn- , srcSpanEndLine spn, srcSpanEndCol spn)- l _ = (0,0,0,0)+ fourInts :: SrcSpan -> (Int,Int,Int,Int)+ fourInts = fromMaybe (0,0,0,0) . Gap.getSrcSpan cmp a b | a `isSubspanOf` b = O.LT | b `isSubspanOf` a = O.GT | otherwise = O.EQ -findExpr :: TypecheckedModule -> Int -> Int -> IO [LHsExpr Id]-findExpr tcm line col = do- let src = tm_typechecked_source tcm- ssrc <- everywhereM' sanitize src- return $ listify f ssrc- where- -- It is for GHC's panic!- sanitize :: Data a => a -> IO a- sanitize x = do- mret <- try (evaluate x)- return $ case mret of- Left (SomeException _) -> G.empty- Right ret -> ret+ errmsg = convert opt ([] :: [((Int,Int,Int,Int),String)]) +findExpr :: TypecheckedModule -> Int -> Int -> [LHsExpr Id]+findExpr tcm line col =+ let src = tm_typechecked_source tcm+ in listifyStaged TypeChecker f src+ where f :: LHsExpr Id -> Bool- f (L spn _) = spn `spans` (line, col)+ f (L spn _) = isGoodSrcSpan spn && spn `spans` (line, col) --- | Monadic variation on everywhere'-everywhereM' :: Monad m => GenericM m -> GenericM m-everywhereM' f x = do- x' <- f x- gmapM (everywhereM' f) x'+listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r]+listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x])) getType :: GhcMonad m => TypecheckedModule -> LHsExpr Id -> m (Maybe (SrcSpan, Type)) getType tcm e = do- hs_env <- getSession- (_, mbe) <- liftIO $ deSugarExpr hs_env modu rn_env ty_env e- return $ (getLoc e, ) <$> CoreUtils.exprType <$> mbe+ hs_env <- getSession+ (_, mbe) <- Gap.liftIO $ deSugarExpr hs_env modu rn_env ty_env e+ return $ (getLoc e, ) <$> CoreUtils.exprType <$> mbe where modu = ms_mod $ pm_mod_summary $ tm_parsed_module tcm rn_env = tcg_rdr_env $ fst $ tm_internals_ tcm@@ -140,55 +124,31 @@ ---------------------------------------------------------------- -inModuleContext :: Options -> FilePath -> ModuleString -> Ghc String -> IO String-inModuleContext opt fileName modstr action = withGHC valid+inModuleContext :: Options -> FilePath -> ModuleString -> Ghc String -> String -> IO String+inModuleContext opt fileName modstr action errmsg =+ withGHC (valid <|> invalid <|> return errmsg) where valid = do (file,_) <- initializeGHC opt fileName ["-w"] False setTargetFile file load LoadAllTargets- mif setContextFromTarget action invalid+ doif setContextFromTarget action invalid = do initializeGHC opt fileName ["-w"] False setTargetBuffer load LoadAllTargets- mif setContextFromTarget action (return errorMessage)+ doif setContextFromTarget action setTargetBuffer = do modgraph <- depanal [mkModuleName modstr] True let imports = concatMap (map (showSDoc . ppr . unLoc)) $ map ms_imps modgraph ++ map ms_srcimps modgraph moddef = "module " ++ sanitize modstr ++ " where" header = moddef : imports-#if __GLASGOW_HASKELL__ >= 702- importsBuf = stringToStringBuffer . unlines $ header-#else- importsBuf <- liftIO . stringToStringBuffer . unlines $ header-#endif- clkTime <- liftIO getClockTime+ importsBuf <- Gap.toStringBuffer header+ clkTime <- Gap.liftIO getClockTime setTargets [Target (TargetModule $ mkModuleName modstr) True (Just (importsBuf, clkTime))]- mif m t e = m >>= \ok -> if ok then t else e+ doif m t = m >>= \ok -> if ok then t else goNext sanitize = fromMaybe "SomeModule" . listToMaybe . words- errorMessage = "Couldn't determine type" setContextFromTarget :: Ghc Bool-setContextFromTarget = do- ms <- depanal [] False--#if __GLASGOW_HASKELL__ >= 704- top <- map (IIModule . ms_mod) <$> filterM isTop ms- setContext top-#else- top <- map ms_mod <$> filterM isTop ms- setContext top []-#endif- return (not . null $ top)- where- isTop ms = lookupMod `gcatch` returnFalse- where- lookupMod = lookupModule (ms_mod_name ms) Nothing >> return True- returnFalse = constE $ return False--------------------------------------------------------------------constE :: a -> (SomeException -> a)-constE func = \_ -> func+setContextFromTarget = depanal [] False >>= Gap.setCtx
Lang.hs view
@@ -1,13 +1,7 @@-{-# LANGUAGE CPP #-}- module Lang where -import DynFlags+import qualified Gap import Types listLanguages :: Options -> IO String-#if __GLASGOW_HASKELL__ >= 700-listLanguages opt = return $ convert opt supportedLanguagesAndExtensions-#else-listLanguages opt = return $ convert opt supportedLanguages-#endif+listLanguages opt = return $ convert opt Gap.supportedExtensions
List.hs view
@@ -3,6 +3,7 @@ import Control.Applicative import Data.List import GHC+import GHCApi import Packages import Types import UniqFM
Types.hs view
@@ -2,16 +2,6 @@ module Types where -import Control.Monad-import CoreMonad-import DynFlags-import ErrMsg-import Exception-import GHC-import GHC.Paths (libdir)------------------------------------------------------------------- data OutputStyle = LispStyle | PlainStyle data Options = Options {@@ -22,6 +12,7 @@ } ----------------------------------------------------------------+ convert :: ToString a => Options -> a -> String convert Options{ outputStyle = LispStyle } = toLisp convert Options{ outputStyle = PlainStyle } = toPlain@@ -56,53 +47,3 @@ addNewLine :: String -> String addNewLine = (++ "\n")--------------------------------------------------------------------withGHC :: (MonadPlus m) => Ghc (m a) -> IO (m a)-withGHC body = ghandle ignore $ runGhc (Just libdir) body- where- ignore :: (MonadPlus m) => SomeException -> IO (m a)- ignore _ = return mzero--------------------------------------------------------------------initSession0 :: Options -> Ghc [PackageId]-initSession0 opt = getSessionDynFlags >>=- (>>= setSessionDynFlags) . setGhcFlags opt--initSession :: Options -> [String] -> [FilePath] -> Bool -> Ghc LogReader-initSession opt cmdOpts idirs logging = do- dflags <- getSessionDynFlags- let opts = map noLoc cmdOpts- (dflags',_,_) <- parseDynamicFlags dflags opts- (dflags'',readLog) <- liftIO . (>>= setLogger logging) . setGhcFlags opt . setFlags dflags' $ idirs- setSessionDynFlags dflags''- return readLog--------------------------------------------------------------------setFlags :: DynFlags -> [FilePath] -> DynFlags-setFlags d idirs = d'- where- d' = d {- packageFlags = ghcPackage : packageFlags d- , importPaths = idirs- , ghcLink = NoLink- , hscTarget = HscInterpreted- }--ghcPackage :: PackageFlag-ghcPackage = ExposePackage "ghc"--setGhcFlags :: Monad m => Options -> DynFlags -> m DynFlags-setGhcFlags opt flagset =- do (flagset',_,_) <- parseDynamicFlags flagset (map noLoc (ghcOpts opt))- return flagset'--------------------------------------------------------------------setTargetFile :: (GhcMonad m) => String -> m ()-setTargetFile file = do- target <- guessTarget file Nothing- setTargets [target]
elisp/ghc-comp.el view
@@ -269,13 +269,19 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(ghc-defstruct buffer name file)++(defun ghc-buffer-name-file (buf)+ (ghc-make-buffer (buffer-name buf) (buffer-file-name buf)))+ (defun ghc-gather-import-modules-all-buffers ()- (let ((bufs (mapcar 'buffer-name (buffer-list)))- ret)+ (let ((bufs (mapcar 'ghc-buffer-name-file (buffer-list)))+ ret file) (save-excursion (dolist (buf bufs (ghc-uniq-lol ret))- (when (string-match "\\.hs$" buf)- (set-buffer buf)+ (setq file (ghc-buffer-get-file buf))+ (when (and file (string-match "\\.hs$" file))+ (set-buffer (ghc-buffer-get-name buf)) (ghc-add ret (ghc-gather-import-modules-buffer))))))) (defun ghc-gather-import-modules-buffer ()
elisp/ghc-info.el view
@@ -23,7 +23,7 @@ (let* ((expr0 (ghc-things-at-point)) (expr (if ask (ghc-read-expression expr0) expr0)) (cdir default-directory)- (file (buffer-name))+ (file (buffer-file-name)) (buf (get-buffer-create ghc-error-buffer-name))) (with-current-buffer buf (erase-buffer)@@ -67,20 +67,21 @@ (defun ghc-type-init () (setq ghc-type-overlay (make-overlay 0 0)) (overlay-put ghc-type-overlay 'face 'region)- (ghc-type-set-ix 0)- (ghc-type-set-point 0)+ (ghc-type-clear-overlay) (setq after-change-functions- (cons 'ghc-type-delete-overlay after-change-functions))+ (cons 'ghc-type-clear-overlay after-change-functions)) (set (make-local-variable 'post-command-hook) 'ghc-type-post-command-hook)) -(defun ghc-type-delete-overlay (&optional beg end len)+(defun ghc-type-clear-overlay (&optional beg end len) (when (overlayp ghc-type-overlay)- (delete-overlay ghc-type-overlay)))+ (ghc-type-set-ix 0)+ (ghc-type-set-point 0)+ (move-overlay ghc-type-overlay 0 0))) (defun ghc-type-post-command-hook () (when (and (overlayp ghc-type-overlay) (/= (ghc-type-get-point) (point)))- (ghc-type-delete-overlay)))+ (ghc-type-clear-overlay))) (defun ghc-show-type () (interactive)@@ -95,7 +96,9 @@ (let* ((buf (current-buffer)) (tinfos (ghc-type-get-tinfos modname))) (if (null tinfos)- (message "Cannot guess type")+ (progn+ (ghc-type-clear-overlay)+ (message "Cannot guess type")) (let* ((tinfo (nth (ghc-type-get-ix) tinfos)) (type (ghc-tinfo-get-info tinfo)) (beg-line (ghc-tinfo-get-beg-line tinfo))@@ -120,7 +123,7 @@ (let* ((ln (int-to-string (line-number-at-pos))) (cn (int-to-string (current-column))) (cdir default-directory)- (file (buffer-name)))+ (file (buffer-file-name))) (ghc-read-lisp (lambda () (cd cdir)
elisp/ghc.el view
@@ -16,7 +16,7 @@ ;;; Code: -(defconst ghc-version "1.10.5")+(defconst ghc-version "1.10.6") ;; (eval-when-compile ;; (require 'haskell-mode))
ghc-mod.cabal view
@@ -1,5 +1,5 @@ Name: ghc-mod-Version: 1.10.5+Version: 1.10.6 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> License: BSD3@@ -23,14 +23,40 @@ ghc-flymake.el ghc-command.el ghc-info.el ghc-ins-mod.el Executable ghc-mod Main-Is: GHCMod.hs- Other-Modules: List Browse Cabal CabalDev Check Info Lang Flag Lint Types ErrMsg Paths_ghc_mod+ Other-Modules: AA+ Browse+ Cabal+ CabalDev+ Check+ ErrMsg+ Flag+ GHCApi+ Gap+ Info+ Lang+ Lint+ List+ Paths_ghc_mod+ Types if impl(ghc >= 6.12) GHC-Options: -Wall -fno-warn-unused-do-bind else GHC-Options: -Wall- Build-Depends: base >= 4.0 && < 5, ghc, ghc-paths, transformers, syb,- process, directory, filepath, old-time,- hlint >= 1.7.1, regex-posix, Cabal+ Build-Depends: base >= 4.0 && < 5+ , Cabal+ , alternative-io+ , directory+ , filepath+ , ghc+ , ghc-paths+ , ghc-syb-utils+ , hlint >= 1.7.1+ , old-time+ , process+ , regex-posix+ , syb+ , transformers+ Source-Repository head Type: git Location: git://github.com/kazu-yamamoto/ghc-mod.git