ghc-mod 3.1.7 → 4.0.0
raw patch · 33 files changed
+1272/−691 lines, 33 filesdep −ghc-pathsnew-component:exe:ghc-modi
Dependencies removed: ghc-paths
Files
- ChangeLog +21/−0
- Language/Haskell/GhcMod.hs +4/−0
- Language/Haskell/GhcMod/Browse.hs +49/−28
- Language/Haskell/GhcMod/CabalApi.hs +37/−40
- Language/Haskell/GhcMod/Check.hs +7/−9
- Language/Haskell/GhcMod/Cradle.hs +86/−38
- Language/Haskell/GhcMod/Debug.hs +29/−15
- Language/Haskell/GhcMod/Doc.hs +1/−1
- Language/Haskell/GhcMod/ErrMsg.hs +39/−27
- Language/Haskell/GhcMod/GHCApi.hs +60/−65
- Language/Haskell/GhcMod/GHCChoice.hs +7/−7
- Language/Haskell/GhcMod/Gap.hs +17/−10
- Language/Haskell/GhcMod/Info.hs +30/−30
- Language/Haskell/GhcMod/Internal.hs +11/−5
- Language/Haskell/GhcMod/Lint.hs +23/−6
- Language/Haskell/GhcMod/List.hs +10/−9
- Language/Haskell/GhcMod/PkgDoc.hs +27/−0
- Language/Haskell/GhcMod/Types.hs +8/−9
- elisp/Makefile +1/−1
- elisp/ghc-check.el +288/−0
- elisp/ghc-command.el +56/−9
- elisp/ghc-comp.el +10/−4
- elisp/ghc-doc.el +32/−46
- elisp/ghc-flymake.el +0/−233
- elisp/ghc-func.el +8/−0
- elisp/ghc-ins-mod.el +72/−35
- elisp/ghc-process.el +98/−0
- elisp/ghc.el +12/−11
- ghc-mod.cabal +17/−6
- src/GHCMod.hs +26/−22
- src/GHCModi.hs +184/−0
- test/CheckSpec.hs +2/−2
- test/DebugSpec.hs +0/−23
ChangeLog view
@@ -1,3 +1,24 @@+2014-04-01 v4.0.0+ * Implementing interactive "ghc-modi" command.+ "check", "find", and "lint" are available.+ * Introducing a concept of project root directory.+ Thanks to this, sandbox without cabal can be used.+ "ghd-mod debug" displays the project root.+ * Syntax error highlighting (C-xC-s) gets much faster+ thanks to ghc-modi. "flymake" was thrown away and+ syntax error highlighting is implemented from a scratch.+ * Resolving the "import hell". You dont' have to type+ "import Foo" anymore. Use M-t or C-cC-m.+ * Inserting "module Foo" (M-t) can insert all paths+ relative to the project root.+ * M-C-d displays a html document even if it is in its sandbox.+ * M-s now merges the same module lines in addition to sorting.+ * A bug fix for hlint support. (@eagletmt)++2014-03-15 v3.1.7+ * Defining ghc-debug for Elisp debugging.+ * Catching up the latest hlint which does not provide --quite.+ 2014-02-07 v3.1.6 * Testing with multi GHC versions. (@eagletmt) * Checking package ID. (@naota)
Language/Haskell/GhcMod.hs view
@@ -22,6 +22,8 @@ , listLanguages , listFlags , debugInfo+ , rootInfo+ , packageDoc -- * Converting the 'Ghc' monad to the 'IO' monad , withGHC , withGHCDummyFile@@ -32,6 +34,7 @@ , typeOf , listMods , debug+ , lint ) where import Language.Haskell.GhcMod.Browse@@ -44,4 +47,5 @@ import Language.Haskell.GhcMod.Lang import Language.Haskell.GhcMod.Lint import Language.Haskell.GhcMod.List+import Language.Haskell.GhcMod.PkgDoc import Language.Haskell.GhcMod.Types
Language/Haskell/GhcMod/Browse.hs view
@@ -1,21 +1,26 @@-module Language.Haskell.GhcMod.Browse (browseModule, browse) where+module Language.Haskell.GhcMod.Browse (+ browseModule+ , browse+ , browseAll)+ where -import Control.Applicative+import Control.Applicative ((<$>)) import Control.Monad (void)-import Data.Char-import Data.List+import Data.Char (isAlpha)+import Data.List (sort) import Data.Maybe (catMaybes) import FastString (mkFastString)-import GHC-import Language.Haskell.GhcMod.Doc (showUnqualifiedPage)+import GHC (Ghc, GhcException(CmdLineError), ModuleInfo, Name, TyThing, DynFlags, Type, TyCon, Module)+import qualified GHC as G+import Language.Haskell.GhcMod.Doc (showUnqualifiedPage, showUnqualifiedOneLine) import Language.Haskell.GhcMod.GHCApi import Language.Haskell.GhcMod.Gap import Language.Haskell.GhcMod.Types-import Name-import Outputable+import Name (getOccString)+import Outputable (ppr, Outputable) import Panic (throwGhcException)-import TyCon-import Type+import TyCon (isAlgTyCon)+import Type (dropForAlls, splitFunTy_maybe, mkFunTy, isPredTy) ---------------------------------------------------------------- @@ -37,10 +42,10 @@ -> Ghc [String] browse opt cradle mdlName = do void $ initializeFlagsWithCradle opt cradle [] False- getModule >>= getModuleInfo >>= listExports+ getModule >>= G.getModuleInfo >>= listExports where- getModule = findModule mdlname mpkgid `gcatch` fallback- mdlname = mkModuleName mdlName+ getModule = G.findModule mdlname mpkgid `G.gcatch` fallback+ mdlname = G.mkModuleName mdlName mpkgid = mkFastString <$> packageId opt listExports Nothing = return [] listExports (Just mdinfo) = processExports opt mdinfo@@ -53,12 +58,11 @@ fallback e = throwGhcException e loadAndFind = do setTargetFiles [mdlName]- checkSlowAndSet- void $ load LoadAllTargets- findModule mdlname Nothing+ void $ G.load G.LoadAllTargets+ G.findModule mdlname Nothing processExports :: Options -> ModuleInfo -> Ghc [String]-processExports opt minfo = mapM (showExport opt minfo) $ removeOps $ modInfoExports minfo+processExports opt minfo = mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo where removeOps | operators opt = id@@ -69,13 +73,13 @@ mtype' <- mtype return $ concat $ catMaybes [mqualified, Just $ formatOp $ getOccString e, mtype'] where- mqualified = (moduleNameString (moduleName $ nameModule e) ++ ".") `justIf` qualified opt+ mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` qualified opt mtype | detailed opt = do- tyInfo <- modInfoLookupName minfo e+ tyInfo <- G.modInfoLookupName minfo e -- If nothing found, load dependent module and lookup global tyResult <- maybe (inOtherModule e) (return . Just) tyInfo- dflag <- getSessionDynFlags+ dflag <- G.getSessionDynFlags return $ do typeName <- tyResult >>= showThing dflag (" :: " ++ typeName) `justIf` detailed opt@@ -85,7 +89,7 @@ | otherwise = "(" ++ nm ++ ")" formatOp "" = error "formatOp" inOtherModule :: Name -> Ghc (Maybe TyThing)- inOtherModule nm = getModuleInfo (nameModule nm) >> lookupGlobalName nm+ inOtherModule nm = G.getModuleInfo (G.nameModule nm) >> G.lookupGlobalName nm justIf :: a -> Bool -> Maybe a justIf x True = Just x justIf _ False = Nothing@@ -97,7 +101,7 @@ showThing' dflag (GtA a) = Just $ formatType dflag a showThing' _ (GtT t) = unwords . toList <$> tyType t where- toList t' = t' : getOccString t : map getOccString (tyConTyVars t)+ toList t' = t' : getOccString t : map getOccString (G.tyConTyVars t) showThing' _ _ = Nothing formatType :: DynFlags -> Type -> String@@ -106,12 +110,12 @@ tyType :: TyCon -> Maybe String tyType typ | isAlgTyCon typ- && not (isNewTyCon typ)- && not (isClassTyCon typ) = Just "data"- | isNewTyCon typ = Just "newtype"- | isClassTyCon typ = Just "class"- | isSynTyCon typ = Just "type"- | otherwise = Nothing+ && not (G.isNewTyCon typ)+ && not (G.isClassTyCon typ) = Just "data"+ | G.isNewTyCon typ = Just "newtype"+ | G.isClassTyCon typ = Just "class"+ | G.isSynTyCon typ = Just "type"+ | otherwise = Nothing removeForAlls :: Type -> Type removeForAlls ty = removeForAlls' ty' tty'@@ -127,3 +131,20 @@ showOutputable :: Outputable a => DynFlags -> a -> String showOutputable dflag = unwords . lines . showUnqualifiedPage dflag . ppr++----------------------------------------------------------------++-- | Browsing all functions in all system/user modules.+browseAll :: DynFlags -> Ghc [(String,String)]+browseAll dflag = do+ ms <- G.packageDbModules True+ is <- mapM G.getModuleInfo ms+ return $ concatMap (toNameModule dflag) (zip ms is)++toNameModule :: DynFlags -> (Module, Maybe ModuleInfo) -> [(String,String)]+toNameModule _ (_,Nothing) = []+toNameModule dflag (m,Just inf) = map (\name -> (toStr name, mdl)) names+ where+ mdl = G.moduleNameString (G.moduleName m)+ names = G.modInfoExports inf+ toStr = showUnqualifiedOneLine dflag . ppr
Language/Haskell/GhcMod/CabalApi.hs view
@@ -19,7 +19,8 @@ import Distribution.Package (Dependency(Dependency) , PackageName(PackageName) , PackageIdentifier(pkgName))-import Distribution.PackageDescription+import Distribution.PackageDescription (PackageDescription, BuildInfo, TestSuite, TestSuiteInterface(..), Executable)+import qualified Distribution.PackageDescription as P import Distribution.PackageDescription.Configuration (finalizePackageDescription) import Distribution.PackageDescription.Parse (readPackageDescription) import Distribution.Simple.Compiler (CompilerId(..), CompilerFlavor(..))@@ -30,23 +31,24 @@ import Distribution.Verbosity (silent) import Distribution.Version (Version) import Language.Haskell.GhcMod.Types+import Language.Haskell.GhcMod.Cradle import System.Directory (doesFileExist)-import System.FilePath+import System.FilePath (dropExtension, takeFileName, (</>)) ---------------------------------------------------------------- -- | Getting necessary 'CompilerOptions' from three information sources. getCompilerOptions :: [GHCOption] -> Cradle -> PackageDescription -> IO CompilerOptions getCompilerOptions ghcopts cradle pkgDesc = do- gopts <- getGHCOptions ghcopts cradle cdir $ head buildInfos+ gopts <- getGHCOptions ghcopts cradle rdir $ head buildInfos return $ CompilerOptions gopts idirs depPkgs where wdir = cradleCurrentDir cradle- Just cdir = cradleCabalDir cradle+ rdir = cradleRootDir cradle Just cfile = cradleCabalFile cradle pkgs = cradlePackages cradle buildInfos = cabalAllBuildInfo pkgDesc- idirs = includeDirectories cdir wdir $ cabalSourceDirs buildInfos+ idirs = includeDirectories rdir wdir $ cabalSourceDirs buildInfos depPkgs = attachPackageIds pkgs $ removeThem problematicPackages $ removeMe cfile $ cabalDependPackages buildInfos ----------------------------------------------------------------@@ -102,61 +104,56 @@ toPkgDesc cid = finalizePackageDescription [] (const True) buildPlatform cid [] nullPkg pd = name == "" where- PackageName name = pkgName (package pd)+ PackageName name = pkgName (P.package pd) ---------------------------------------------------------------- getGHCOptions :: [GHCOption] -> Cradle -> FilePath -> BuildInfo -> IO [GHCOption]-getGHCOptions ghcopts cradle cdir binfo = do- cabalCpp <- cabalCppOptions cdir- let cpps = map ("-optP" ++) $ cppOptions binfo ++ cabalCpp+getGHCOptions ghcopts cradle rdir binfo = do+ cabalCpp <- cabalCppOptions rdir+ let cpps = map ("-optP" ++) $ P.cppOptions binfo ++ cabalCpp return $ ghcopts ++ pkgDb ++ exts ++ [lang] ++ libs ++ libDirs ++ cpps where- pkgDb = cradlePackageDbOpts cradle- lang = maybe "-XHaskell98" (("-X" ++) . display) $ defaultLanguage binfo- libDirs = map ("-L" ++) $ extraLibDirs binfo- exts = map (("-X" ++) . display) $ usedExtensions binfo- libs = map ("-l" ++) $ extraLibs binfo+ pkgDb = userPackageDbOptsForGhc $ cradlePackageDb cradle+ lang = maybe "-XHaskell98" (("-X" ++) . display) $ P.defaultLanguage binfo+ libDirs = map ("-L" ++) $ P.extraLibDirs binfo+ exts = map (("-X" ++) . display) $ P.usedExtensions binfo+ libs = map ("-l" ++) $ P.extraLibs binfo cabalCppOptions :: FilePath -> IO [String] cabalCppOptions dir = do exist <- doesFileExist cabalMacro- if exist then- return ["-include", cabalMacro]+ return $ if exist then+ ["-include", cabalMacro] else- return []+ [] where cabalMacro = dir </> "dist/build/autogen/cabal_macros.h" ---------------------------------------------------------------- --- | Extracting all 'BuildInfo' for libraries, executables, tests and benchmarks.+-- | Extracting all 'BuildInfo' for libraries, executables, and tests. cabalAllBuildInfo :: PackageDescription -> [BuildInfo]-cabalAllBuildInfo pd = libBI ++ execBI ++ testBI ++ benchBI+cabalAllBuildInfo pd = libBI ++ execBI ++ testBI where- libBI = map libBuildInfo $ maybeToList $ library pd- execBI = map buildInfo $ executables pd- testBI = map testBuildInfo $ testSuites pd-#if __GLASGOW_HASKELL__ >= 704- benchBI = map benchmarkBuildInfo $ benchmarks pd-#else- benchBI = []-#endif+ libBI = map P.libBuildInfo $ maybeToList $ P.library pd+ execBI = map P.buildInfo $ P.executables pd+ testBI = map P.testBuildInfo $ P.testSuites pd ---------------------------------------------------------------- -- | Extracting package names of dependency. cabalDependPackages :: [BuildInfo] -> [PackageBaseName]-cabalDependPackages bis = uniqueAndSort $ pkgs+cabalDependPackages bis = uniqueAndSort pkgs where- pkgs = map getDependencyPackageName $ concatMap targetBuildDepends bis+ pkgs = map getDependencyPackageName $ concatMap P.targetBuildDepends bis getDependencyPackageName (Dependency (PackageName nm) _) = nm ---------------------------------------------------------------- -- | Extracting include directories for modules. cabalSourceDirs :: [BuildInfo] -> [IncludeDir]-cabalSourceDirs bis = uniqueAndSort $ concatMap hsSourceDirs bis+cabalSourceDirs bis = uniqueAndSort $ concatMap P.hsSourceDirs bis ---------------------------------------------------------------- @@ -173,7 +170,7 @@ mv <- programFindVersion ghcProgram silent (programName ghcProgram) case mv of Nothing -> throwIO $ userError "ghc not found"- Just v -> return $ v+ Just v -> return v ---------------------------------------------------------------- @@ -181,17 +178,17 @@ -- tests and benchmarks. cabalAllTargets :: PackageDescription -> IO ([String],[String],[String],[String]) cabalAllTargets pd = do- exeTargets <- mapM getExecutableTarget $ executables pd- testTargets <- mapM getTestTarget $ testSuites pd+ exeTargets <- mapM getExecutableTarget $ P.executables pd+ testTargets <- mapM getTestTarget $ P.testSuites pd return (libTargets,concat exeTargets,concat testTargets,benchTargets) where- lib = case library pd of+ lib = case P.library pd of Nothing -> []- Just l -> libModules l+ Just l -> P.libModules l - libTargets = map toModuleString $ lib+ libTargets = map toModuleString lib #if __GLASGOW_HASKELL__ >= 704- benchTargets = map toModuleString $ concatMap benchmarkModules $ benchmarks pd+ benchTargets = map toModuleString $ concatMap P.benchmarkModules $ P.benchmarks pd #else benchTargets = [] #endif@@ -203,15 +200,15 @@ getTestTarget :: TestSuite -> IO [String] getTestTarget ts =- case testInterface ts of+ case P.testInterface ts of (TestSuiteExeV10 _ filePath) -> do- let maybeTests = [p </> e | p <- hsSourceDirs $ testBuildInfo ts, e <- [filePath]]+ let maybeTests = [p </> e | p <- P.hsSourceDirs $ P.testBuildInfo ts, e <- [filePath]] liftIO $ filterM doesFileExist maybeTests (TestSuiteLibV09 _ moduleName) -> return [toModuleString moduleName] (TestSuiteUnsupported _) -> return [] getExecutableTarget :: Executable -> IO [String] getExecutableTarget exe = do- let maybeExes = [p </> e | p <- hsSourceDirs $ buildInfo exe, e <- [modulePath exe]]+ let maybeExes = [p </> e | p <- P.hsSourceDirs $ P.buildInfo exe, e <- [P.modulePath exe]] liftIO $ filterM doesFileExist maybeExes
Language/Haskell/GhcMod/Check.hs view
@@ -1,14 +1,13 @@ module Language.Haskell.GhcMod.Check (checkSyntax, check) where -import Control.Applicative-import Control.Monad-import CoreMonad-import Exception-import GHC+import Control.Applicative ((<$>))+import Control.Monad (void)+import CoreMonad (liftIO)+import GHC (Ghc, LoadHowMuch(LoadAllTargets))+import qualified GHC as G import Language.Haskell.GhcMod.ErrMsg import Language.Haskell.GhcMod.GHCApi import Language.Haskell.GhcMod.Types-import Prelude ---------------------------------------------------------------- @@ -34,13 +33,12 @@ -> [FilePath] -- ^ The target files. -> Ghc [String] check _ _ [] = error "ghc-mod: check: No files given"-check opt cradle fileNames = checkIt `gcatch` handleErrMsg ls+check opt cradle fileNames = checkIt `G.gcatch` handleErrMsg ls where checkIt = do (readLog,_) <- initializeFlagsWithCradle opt cradle options True setTargetFiles fileNames- checkSlowAndSet- void $ load LoadAllTargets+ void $ G.load LoadAllTargets liftIO readLog options | expandSplice opt = "-w:" : ghcOpts opt
Language/Haskell/GhcMod/Cradle.hs view
@@ -5,12 +5,17 @@ , findCradleWithoutSandbox , getPackageDbDir , getPackageDbPackages+ , userPackageDbOptsForGhc+ , userPackageDbOptsForGhcPkg+ , getSandboxDir ) where -import Data.Char (isSpace) import Control.Applicative ((<$>))-import Control.Exception as E (catch, throwIO, SomeException)+import Control.Exception (SomeException(..))+import qualified Control.Exception as E+import Control.Exception.IOChoice ((||>)) import Control.Monad (filterM)+import Data.Char (isSpace) import Data.List (isPrefixOf, isSuffixOf, tails) import Language.Haskell.GhcMod.Types import System.Directory (getCurrentDirectory, getDirectoryContents, doesFileExist)@@ -25,34 +30,46 @@ findCradle :: IO Cradle findCradle = do wdir <- getCurrentDirectory- findCradle' wdir `E.catch` handler wdir- where- handler :: FilePath -> SomeException -> IO Cradle- handler wdir _ = return Cradle {- cradleCurrentDir = wdir- , cradleCabalDir = Nothing- , cradleCabalFile = Nothing- , cradlePackageDbOpts = []- , cradlePackages = []+ cabalCradle wdir ||> sandboxCradle wdir ||> plainCradle wdir++cabalCradle :: FilePath -> IO Cradle+cabalCradle wdir = do+ (rdir,cfile) <- cabalDir wdir+ pkgDbOpts <- getPackageDb rdir+ return Cradle {+ cradleCurrentDir = wdir+ , cradleRootDir = rdir+ , cradleCabalFile = Just cfile+ , cradlePackageDb = pkgDbOpts+ , cradlePackages = [] } -findCradle' :: FilePath -> IO Cradle-findCradle' wdir = do- (cdir,cfile) <- cabalDir wdir- pkgDbOpts <- getPackageDbOpts cdir+sandboxCradle :: FilePath -> IO Cradle+sandboxCradle wdir = do+ rdir <- getSandboxDir wdir+ pkgDbOpts <- getPackageDb rdir return Cradle {- cradleCurrentDir = wdir- , cradleCabalDir = Just cdir- , cradleCabalFile = Just cfile- , cradlePackageDbOpts = pkgDbOpts- , cradlePackages = []+ cradleCurrentDir = wdir+ , cradleRootDir = rdir+ , cradleCabalFile = Nothing+ , cradlePackageDb = pkgDbOpts+ , cradlePackages = [] } +plainCradle :: FilePath -> IO Cradle+plainCradle wdir = return Cradle {+ cradleCurrentDir = wdir+ , cradleRootDir = wdir+ , cradleCabalFile = Nothing+ , cradlePackageDb = Nothing+ , cradlePackages = []+ }+ -- Just for testing findCradleWithoutSandbox :: IO Cradle findCradleWithoutSandbox = do cradle <- findCradle- return cradle { cradlePackageDbOpts = [], cradlePackages = [] }+ return cradle { cradlePackageDb = Nothing, cradlePackages = [] } ---------------------------------------------------------------- @@ -70,7 +87,7 @@ cabalDir dir = do cnts <- getCabalFiles dir case cnts of- [] | dir' == dir -> throwIO $ userError "cabal files not found"+ [] | dir' == dir -> E.throwIO $ userError "cabal files not found" | otherwise -> cabalDir dir' cfile:_ -> return (dir,dir </> cfile) where@@ -96,12 +113,12 @@ pkgDbKeyLen = length pkgDbKey -- | Obtaining GHC options relating to a package db directory-getPackageDbOpts :: FilePath -> IO [GHCOption]-getPackageDbOpts cdir = (sandboxArguments <$> getPkgDb) `E.catch` handler+getPackageDb :: FilePath -> IO (Maybe FilePath)+getPackageDb cdir = (Just <$> getPkgDb) `E.catch` handler where getPkgDb = getPackageDbDir (cdir </> configFile)- handler :: SomeException -> IO [GHCOption]- handler _ = return []+ handler :: SomeException -> IO (Maybe FilePath)+ handler _ = return Nothing -- | Extract a package db directory from the sandbox config file. -- Exception is thrown if the sandbox config file is broken.@@ -112,23 +129,41 @@ return path where parse = head . filter ("package-db:" `isPrefixOf`) . lines- extractValue = fst . break isSpace . dropWhile isSpace . drop pkgDbKeyLen+ extractValue = dropWhileEnd isSpace . dropWhile isSpace . drop pkgDbKeyLen+ -- dropWhileEnd is not provided prior to base 4.5.0.0.+ dropWhileEnd :: (a -> Bool) -> [a] -> [a]+ dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) [] --- | Adding necessary GHC options to the package db.--- Exception is thrown if the string argument is incorrect.+-- | Creating user package db options for GHC. ----- >>> sandboxArguments "/foo/bar/i386-osx-ghc-7.6.3-packages.conf.d"+-- >>> userPackageDbOptsForGhc (Just "/foo/bar/i386-osx-ghc-7.6.3-packages.conf.d") -- ["-no-user-package-db","-package-db","/foo/bar/i386-osx-ghc-7.6.3-packages.conf.d"]--- >>> sandboxArguments "/foo/bar/i386-osx-ghc-7.4.1-packages.conf.d"+-- >>> userPackageDbOptsForGhc (Just "/foo/bar/i386-osx-ghc-7.4.1-packages.conf.d") -- ["-no-user-package-conf","-package-conf","/foo/bar/i386-osx-ghc-7.4.1-packages.conf.d"]-sandboxArguments :: FilePath -> [String]-sandboxArguments pkgDb = [noUserPkgDbOpt, pkgDbOpt, pkgDb]+userPackageDbOptsForGhc :: Maybe FilePath -> [String]+userPackageDbOptsForGhc Nothing = []+userPackageDbOptsForGhc (Just pkgDb) = [noUserPkgDbOpt, pkgDbOpt, pkgDb] where ver = extractGhcVer pkgDb- (pkgDbOpt,noUserPkgDbOpt)- | ver < 706 = ("-package-conf","-no-user-package-conf")- | otherwise = ("-package-db", "-no-user-package-db")+ (noUserPkgDbOpt,pkgDbOpt)+ | ver < 706 = ("-no-user-package-conf", "-package-conf")+ | otherwise = ("-no-user-package-db", "-package-db") +-- | Creating user package db options for ghc-pkg.+--+-- >>> userPackageDbOptsForGhcPkg (Just "/foo/bar/i386-osx-ghc-7.6.3-packages.conf.d")+-- ["--no-user-package-db","--package-db=/foo/bar/i386-osx-ghc-7.6.3-packages.conf.d"]+-- >>> userPackageDbOptsForGhcPkg (Just "/foo/bar/i386-osx-ghc-7.4.1-packages.conf.d")+-- ["--no-user-package-conf","--package-conf=/foo/bar/i386-osx-ghc-7.4.1-packages.conf.d"]+userPackageDbOptsForGhcPkg :: Maybe FilePath -> [String]+userPackageDbOptsForGhcPkg Nothing = []+userPackageDbOptsForGhcPkg (Just pkgDb) = [noUserPkgDbOpt, pkgDbOpt]+ where+ ver = extractGhcVer pkgDb+ (noUserPkgDbOpt,pkgDbOpt)+ | ver < 706 = ("--no-user-package-conf", "--package-conf=" ++ pkgDb)+ | otherwise = ("--no-user-package-db", "--package-db=" ++ pkgDb)+ -- | Extracting GHC version from the path of package db. -- Exception is thrown if the string argument is incorrect. --@@ -154,7 +189,7 @@ listDbPackages :: FilePath -> IO [Package] listDbPackages pkgdir = do files <- filter (".conf" `isSuffixOf`) <$> getDirectoryContents pkgdir- mapM extractPackage $ map (pkgdir </>) files+ mapM (extractPackage . (pkgdir </>)) files extractPackage :: FilePath -> IO Package extractPackage pconf = do@@ -169,7 +204,7 @@ parseId = parse idKey extractId = extract idKeyLength parse key = head . filter (key `isPrefixOf`)- extract keylen = fst . break isSpace . dropWhile isSpace . drop keylen+ extract keylen = takeWhile (not . isSpace) . dropWhile isSpace . drop keylen nameKey :: String nameKey = "name:"@@ -182,3 +217,16 @@ idKeyLength :: Int idKeyLength = length idKey++getSandboxDir :: FilePath -> IO FilePath+getSandboxDir dir = do+ exist <- doesFileExist sfile+ if exist then+ return dir+ else if dir == dir' then+ E.throwIO $ userError "sandbox not found"+ else+ getSandboxDir dir'+ where+ sfile = dir </> configFile+ dir' = takeDirectory dir
Language/Haskell/GhcMod/Debug.hs view
@@ -1,16 +1,15 @@-module Language.Haskell.GhcMod.Debug (debugInfo, debug) where+module Language.Haskell.GhcMod.Debug (debugInfo, debug, rootInfo, root) where -import Control.Applicative-import Control.Exception.IOChoice-import Control.Monad+import Control.Applicative ((<$>))+import Control.Exception.IOChoice ((||>))+import Control.Monad (void)+import CoreMonad (liftIO) import Data.List (intercalate)-import Data.Maybe-import GHC-import GhcMonad (liftIO)+import Data.Maybe (fromMaybe, isJust, fromJust)+import GHC (Ghc) import Language.Haskell.GhcMod.CabalApi import Language.Haskell.GhcMod.GHCApi import Language.Haskell.GhcMod.Types-import Prelude ---------------------------------------------------------------- @@ -32,21 +31,20 @@ liftIO (fromCabalFile ||> return simpleCompilerOption) else return simpleCompilerOption- [fast] <- do- void $ initializeFlagsWithCradle opt cradle gopts True- setTargetFiles [fileName]- pure . canCheckFast <$> depanal [] False+ void $ initializeFlagsWithCradle opt cradle gopts True+ setTargetFiles [fileName] return [- "Current directory: " ++ currentDir+ "Root directory: " ++ rootDir+ , "Current directory: " ++ currentDir , "Cabal file: " ++ cabalFile , "GHC options: " ++ unwords gopts , "Include directories: " ++ unwords incDir- , "Dependent packages: " ++ (intercalate ", " $ map fst pkgs)- , "Fast check: " ++ if fast then "Yes" else "No"+ , "Dependent packages: " ++ intercalate ", " (map fst pkgs) ] where currentDir = cradleCurrentDir cradle mCabalFile = cradleCabalFile cradle+ rootDir = cradleRootDir cradle cabal = isJust mCabalFile cabalFile = fromMaybe "" mCabalFile origGopts = ghcOpts opt@@ -54,3 +52,19 @@ fromCabalFile = parseCabalFile file >>= getCompilerOptions origGopts cradle where file = fromJust mCabalFile++----------------------------------------------------------------++-- | Obtaining root information.+rootInfo :: Options+ -> Cradle+ -> FilePath -- ^ A target file.+ -> IO String+rootInfo opt cradle fileName = withGHC fileName (root opt cradle fileName)++-- | Obtaining root information.+root :: Options+ -> Cradle+ -> FilePath -- ^ A target file.+ -> Ghc String+root _ cradle _ = return $ cradleRootDir cradle ++ "\n"
Language/Haskell/GhcMod/Doc.hs view
@@ -2,7 +2,7 @@ import DynFlags (DynFlags) import Language.Haskell.GhcMod.Gap (withStyle, showDocWith)-import Outputable+import Outputable (SDoc, PprStyle, Depth(AllTheWay), mkUserStyle, alwaysQualify, neverQualify) import Pretty (Mode(..)) ----------------------------------------------------------------
Language/Haskell/GhcMod/ErrMsg.hs view
@@ -6,18 +6,19 @@ , handleErrMsg ) where -import Bag-import Control.Applicative-import Data.IORef-import Data.Maybe-import DynFlags-import ErrUtils-import GHC-import HscTypes+import Bag (Bag, bagToList)+import Control.Applicative ((<$>))+import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)+import Data.Maybe (fromMaybe)+import DynFlags (dopt)+import ErrUtils (ErrMsg, errMsgShortDoc, errMsgExtraInfo)+import GHC (Ghc, DynFlags, SrcSpan, Severity(SevError))+import qualified GHC as G+import HscTypes (SourceError, srcErrorMessages) import Language.Haskell.GhcMod.Doc (showUnqualifiedPage)-import Language.Haskell.GhcMod.Types (LineSeparator(..)) import qualified Language.Haskell.GhcMod.Gap as Gap-import Outputable+import Language.Haskell.GhcMod.Types (LineSeparator(..))+import Outputable (SDoc) import System.FilePath (normalise) ----------------------------------------------------------------@@ -27,24 +28,41 @@ ---------------------------------------------------------------- +type Builder = [String] -> [String]++newtype LogRef = LogRef (IORef Builder)++newLogRef :: IO LogRef+newLogRef = LogRef <$> newIORef id++readAndClearLogRef :: LogRef -> IO [String]+readAndClearLogRef (LogRef ref) = do+ b <- readIORef ref+ writeIORef ref id+ return $! b []++appendLogRef :: DynFlags -> LineSeparator -> LogRef -> a -> Severity -> SrcSpan -> b -> SDoc -> IO ()+appendLogRef df ls (LogRef ref) _ sev src _ msg = do+ let !l = ppMsg src sev df ls msg+ modifyIORef ref (\b -> b . (l:))++----------------------------------------------------------------+ setLogger :: Bool -> DynFlags -> LineSeparator -> IO (DynFlags, LogReader) setLogger False df _ = return (newdf, undefined) where newdf = Gap.setLogAction df $ \_ _ _ _ _ -> return () setLogger True df ls = do- ref <- newIORef [] :: IO (IORef [String])- let newdf = Gap.setLogAction df $ appendLog ref- return (newdf, reverse <$> readIORef ref)- where- appendLog ref _ sev src _ msg = do- let !l = ppMsg src sev df ls msg- modifyIORef ref (l:)+ logref <- newLogRef+ let newdf = Gap.setLogAction df $ appendLogRef df ls logref+ return (newdf, readAndClearLogRef logref) ---------------------------------------------------------------- +-- | Converting 'SourceError' to 'String'. handleErrMsg :: LineSeparator -> SourceError -> Ghc [String] handleErrMsg ls err = do- dflag <- getSessionDynFlags+ dflag <- G.getSessionDynFlags return . errBagToStrList dflag ls . srcErrorMessages $ err errBagToStrList :: DynFlags -> LineSeparator -> Bag ErrMsg -> [String]@@ -60,12 +78,12 @@ ext = showMsg dflag ls (errMsgExtraInfo err) ppMsg :: SrcSpan -> Severity-> DynFlags -> LineSeparator -> SDoc -> String-ppMsg spn sev dflag ls@(LineSeparator lsep) msg = prefix ++ cts ++ lsep+ppMsg spn sev dflag ls msg = prefix ++ cts where cts = showMsg dflag ls msg defaultPrefix- | dopt Opt_D_dump_splices dflag = ""- | otherwise = "Dummy:0:0:"+ | dopt Gap.dumpSplicesFlag dflag = ""+ | otherwise = "Dummy:0:0:Error:" prefix = fromMaybe defaultPrefix $ do (line,col,_,_) <- Gap.getSrcSpan spn file <- normalise <$> Gap.getSrcFile spn@@ -75,12 +93,6 @@ ---------------------------------------------------------------- showMsg :: DynFlags -> LineSeparator -> SDoc -> String-showMsg dflag (LineSeparator [s]) sdoc = replaceNull $ showUnqualifiedPage dflag sdoc- where- replaceNull :: String -> String- replaceNull [] = []- replaceNull ('\n':xs) = s : replaceNull xs- replaceNull (x:xs) = x : replaceNull xs showMsg dflag (LineSeparator lsep) sdoc = replaceNull $ showUnqualifiedPage dflag sdoc where replaceNull [] = []
Language/Haskell/GhcMod/GHCApi.hs view
@@ -6,32 +6,42 @@ , initializeFlags , initializeFlagsWithCradle , setTargetFiles+ , addTargetFiles , getDynamicFlags- , setSlowDynFlags- , checkSlowAndSet- , canCheckFast+ , getSystemLibDir ) where -import Control.Applicative-import Control.Exception-import Control.Monad-import CoreMonad-import Data.Maybe (isJust,fromJust)+import Control.Applicative (Alternative, (<$>))+import Control.Monad (void, forM)+import CoreMonad (liftIO)+import Data.Maybe (isJust, fromJust) import Distribution.PackageDescription (PackageDescription)-import DynFlags-import Exception-import GHC-import GHC.Paths (libdir)+import DynFlags (dopt_set)+import Exception (ghandle, SomeException(..))+import GHC (Ghc, GhcMonad, DynFlags(..), GhcLink(..), HscTarget(..))+import qualified GHC as G import Language.Haskell.GhcMod.CabalApi+import Language.Haskell.GhcMod.Cradle (userPackageDbOptsForGhc) import Language.Haskell.GhcMod.ErrMsg import Language.Haskell.GhcMod.GHCChoice import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Types-import System.Exit-import System.IO+import System.Exit (exitSuccess)+import System.IO (hPutStr, hPrint, stderr)+import System.Process (readProcess) ---------------------------------------------------------------- +-- | Obtaining the directory for system libraries.+getSystemLibDir :: IO (Maybe FilePath)+getSystemLibDir = do+ res <- readProcess "ghc" ["--print-libdir"] []+ return $ case res of+ "" -> Nothing+ dirn -> Just (init dirn)++----------------------------------------------------------------+ -- | Converting the 'Ghc' monad to the 'IO' monad. withGHCDummyFile :: Alternative m => Ghc (m a) -- ^ 'Ghc' actions created by the Ghc utilities. -> IO (m a)@@ -41,9 +51,11 @@ withGHC :: Alternative m => FilePath -- ^ A target file displayed in an error message. -> Ghc (m a) -- ^ 'Ghc' actions created by the Ghc utilities. -> IO (m a)-withGHC file body = ghandle ignore $ runGhc (Just libdir) $ do- dflags <- getSessionDynFlags- defaultCleanupHandler dflags body+withGHC file body = do+ mlibdir <- getSystemLibDir+ ghandle ignore $ G.runGhc mlibdir $ do+ dflags <- G.getSessionDynFlags+ G.defaultCleanupHandler dflags body where ignore :: Alternative m => SomeException -> IO (m a) ignore e = do@@ -63,8 +75,8 @@ -- provided. initializeFlagsWithCradle :: GhcMonad m => Options -> Cradle -> [GHCOption] -> Bool -> m (LogReader, Maybe PackageDescription) initializeFlagsWithCradle opt cradle ghcopts logging- | cabal = withCabal |||> withoutCabal- | otherwise = withoutCabal+ | cabal = withCabal |||> withSandbox+ | otherwise = withSandbox where mCradleFile = cradleCabalFile cradle cabal = isJust mCradleFile@@ -73,11 +85,16 @@ compOpts <- liftIO $ getCompilerOptions ghcopts cradle pkgDesc logger <- initSession CabalPkg opt compOpts logging return (logger, Just pkgDesc)- withoutCabal = do+ withSandbox = do logger <- initSession SingleFile opt compOpts logging return (logger, Nothing) where- compOpts = CompilerOptions ghcopts importDirs []+ pkgDb = userPackageDbOptsForGhc $ cradlePackageDb cradle+ compOpts+ | pkgDb == [] = CompilerOptions ghcopts importDirs []+ | otherwise = CompilerOptions (ghcopts ++ pkgDb) [wdir,rdir] []+ wdir = cradleCurrentDir cradle+ rdir = cradleRootDir cradle ---------------------------------------------------------------- @@ -87,9 +104,9 @@ -> Bool -> m LogReader initSession build opt compOpts logging = do- dflags0 <- getSessionDynFlags+ dflags0 <- G.getSessionDynFlags (dflags1,readLog) <- setupDynamicFlags dflags0- _ <- setSessionDynFlags dflags1+ _ <- G.setSessionDynFlags dflags1 return readLog where cmdOpts = ghcOptions compOpts@@ -108,57 +125,34 @@ -- file or GHC session. initializeFlags :: GhcMonad m => Options -> m () initializeFlags opt = do- dflags0 <- getSessionDynFlags+ dflags0 <- G.getSessionDynFlags dflags1 <- modifyFlagsWithOpts dflags0 $ ghcOpts opt- void $ setSessionDynFlags dflags1+ void $ G.setSessionDynFlags dflags1 ---------------------------------------------------------------- --- FIXME removing Options modifyFlags :: DynFlags -> [IncludeDir] -> [Package] -> Bool -> Build -> DynFlags modifyFlags d0 idirs depPkgs splice build | splice = setSplice d4 | otherwise = d4 where d1 = d0 { importPaths = idirs }- d2 = setFastOrNot d1 Fast+ d2 = d1 {+ ghcLink = LinkInMemory+ , hscTarget = HscInterpreted+ } d3 = Gap.addDevPkgs d2 depPkgs d4 | build == CabalPkg = Gap.setCabalPkg d3 | otherwise = d3 setSplice :: DynFlags -> DynFlags-setSplice dflag = dopt_set dflag Opt_D_dump_splices--------------------------------------------------------------------setFastOrNot :: DynFlags -> CheckSpeed -> DynFlags-setFastOrNot dflags Slow = dflags {- ghcLink = LinkInMemory- , hscTarget = HscInterpreted- }-setFastOrNot dflags Fast = dflags {- ghcLink = NoLink- , hscTarget = HscNothing- }--setSlowDynFlags :: GhcMonad m => m ()-setSlowDynFlags = (flip setFastOrNot Slow <$> getSessionDynFlags)- >>= void . setSessionDynFlags---- | To check TH, a session module graph is necessary.--- "load" sets a session module graph using "depanal".--- But we have to set "-fno-code" to DynFlags before "load".--- So, this is necessary redundancy.-checkSlowAndSet :: GhcMonad m => m ()-checkSlowAndSet = do- fast <- canCheckFast <$> depanal [] False- unless fast setSlowDynFlags+setSplice dflag = dopt_set dflag Gap.dumpSplicesFlag ---------------------------------------------------------------- modifyFlagsWithOpts :: GhcMonad m => DynFlags -> [GHCOption] -> m DynFlags modifyFlagsWithOpts dflags cmdOpts =- tfst <$> parseDynamicFlags dflags (map noLoc cmdOpts)+ tfst <$> G.parseDynamicFlags dflags (map G.noLoc cmdOpts) where tfst (a,_,_) = a @@ -168,19 +162,20 @@ setTargetFiles :: (GhcMonad m) => [FilePath] -> m () setTargetFiles [] = error "ghc-mod: setTargetFiles: No target files given" setTargetFiles files = do- targets <- forM files $ \file -> guessTarget file Nothing- setTargets targets+ targets <- forM files $ \file -> G.guessTarget file Nothing+ G.setTargets targets +-- | Adding the files to the targets.+addTargetFiles :: (GhcMonad m) => [FilePath] -> m ()+addTargetFiles [] = error "ghc-mod: addTargetFiles: No target files given"+addTargetFiles files = do+ targets <- forM files $ \file -> G.guessTarget file Nothing+ mapM_ G.addTarget targets+ ---------------------------------------------------------------- -- | Return the 'DynFlags' currently in use in the GHC session. getDynamicFlags :: IO DynFlags-getDynamicFlags = runGhc (Just libdir) getSessionDynFlags---- | Checking if Template Haskell or quasi quotes are used.--- If not, the process can be faster.-canCheckFast :: ModuleGraph -> Bool-canCheckFast = not . any (hasTHorQQ . ms_hspp_opts)- where- hasTHorQQ :: DynFlags -> Bool- hasTHorQQ dflags = any (`xopt` dflags) [Opt_TemplateHaskell, Opt_QuasiQuotes]+getDynamicFlags = do+ mlibdir <- getSystemLibDir+ G.runGhc mlibdir G.getSessionDynFlags
Language/Haskell/GhcMod/GHCChoice.hs view
@@ -2,21 +2,21 @@ module Language.Haskell.GhcMod.GHCChoice where -import Control.Exception-import CoreMonad-import Exception-import GHC+import Control.Exception (IOException)+import CoreMonad (liftIO)+import qualified Exception as GE+import GHC (Ghc, GhcMonad) ---------------------------------------------------------------- -- | Try the left 'Ghc' action. If 'IOException' occurs, try -- the right 'Ghc' action. (||>) :: Ghc a -> Ghc a -> Ghc a-x ||> y = x `gcatch` (\(_ :: IOException) -> y)+x ||> y = x `GE.gcatch` (\(_ :: IOException) -> y) -- | Go to the next 'Ghc' monad by throwing 'AltGhcgoNext'. goNext :: Ghc a-goNext = liftIO . throwIO $ userError "goNext"+goNext = liftIO . GE.throwIO $ userError "goNext" -- | Run any one 'Ghc' monad. runAnyOne :: [Ghc a] -> Ghc a@@ -27,4 +27,4 @@ -- | Try the left 'GhcMonad' action. If 'IOException' occurs, try -- the right 'GhcMonad' action. (|||>) :: GhcMonad m => m a -> m a -> m a-x |||> y = x `gcatch` (\(_ :: IOException) -> y)+x |||> y = x `GE.gcatch` (\(_ :: IOException) -> y)
Language/Haskell/GhcMod/Gap.hs view
@@ -11,7 +11,6 @@ , setCtx , fOptions , toStringBuffer- , liftIO , showSeverityCaption , setCabalPkg , addDevPkgs@@ -29,14 +28,15 @@ , showDocWith , GapThing(..) , fromTyThing+ , dumpSplicesFlag ) where import Control.Applicative hiding (empty)-import Control.Monad-import CoreSyn-import Data.List-import Data.Maybe-import Data.Time.Clock+import Control.Monad (filterM)+import CoreSyn (CoreExpr)+import Data.List (intersperse)+import Data.Maybe (catMaybes)+import Data.Time.Clock (UTCTime) import DataCon (dataConRepType) import Desugar (deSugarExpr) import DynFlags@@ -69,10 +69,8 @@ import GHC hiding (Instance) #endif -#if __GLASGOW_HASKELL__ >= 702+#if __GLASGOW_HASKELL__ < 702 import CoreMonad (liftIO)-#else-import HscTypes (liftIO) import Pretty #endif @@ -324,7 +322,7 @@ #endif deSugar :: TypecheckedModule -> LHsExpr Id -> HscEnv- -> IO (Maybe CoreSyn.CoreExpr)+ -> IO (Maybe CoreExpr) #if __GLASGOW_HASKELL__ >= 707 deSugar _ e hs_env = snd <$> deSugarExpr hs_env e #else@@ -351,3 +349,12 @@ #endif fromTyThing (ATyCon t) = GtT t fromTyThing _ = GtN++----------------------------------------------------------------++#if __GLASGOW_HASKELL__ >= 707+dumpSplicesFlag :: DumpFlag+#else+dumpSplicesFlag :: DynFlag+#endif+dumpSplicesFlag = Opt_D_dump_splices
Language/Haskell/GhcMod/Info.hs view
@@ -10,22 +10,25 @@ ) where import Control.Applicative ((<$>))-import Control.Monad (void, when)+import Control.Monad (void)+import CoreMonad (liftIO) import CoreUtils (exprType) import Data.Function (on)+--import Data.Generics (Typeable, GenericQ, mkQ) import Data.Generics hiding (typeOf) import Data.List (sortBy) import Data.Maybe (catMaybes, fromMaybe, listToMaybe) import Data.Ord as O import Data.Time.Clock (getCurrentTime)-import GHC+import GHC (Ghc, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), DynFlags, SrcSpan, Type, Located, TypecheckedSource, GenLocated(L), LoadHowMuch(..), TargetId(..))+import qualified GHC as G import GHC.SYB.Utils (Stage(TypeChecker), everythingStaged) import HscTypes (ms_imps) import Language.Haskell.GhcMod.Doc (showUnqualifiedPage, showUnqualifiedOneLine, showQualifiedPage) import Language.Haskell.GhcMod.GHCApi import Language.Haskell.GhcMod.GHCChoice ((||>), goNext)-import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Gap (HasType(..))+import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Types import Outputable (ppr) import TcHsSyn (hsPatType)@@ -56,7 +59,7 @@ inModuleContext Info opt cradle file modstr exprToInfo "Cannot show info" where exprToInfo = do- dflag <- getSessionDynFlags+ dflag <- G.getSessionDynFlags sdoc <- Gap.infoThing expr return $ showUnqualifiedPage dflag sdoc @@ -64,12 +67,12 @@ instance HasType (LHsExpr Id) where getType tcm e = do- hs_env <- getSession- mbe <- Gap.liftIO $ Gap.deSugar tcm e hs_env- return $ (getLoc e, ) <$> CoreUtils.exprType <$> mbe+ hs_env <- G.getSession+ mbe <- liftIO $ Gap.deSugar tcm e hs_env+ return $ (G.getLoc e, ) <$> CoreUtils.exprType <$> mbe instance HasType (LPat Id) where- getType _ (L spn pat) = return $ Just (spn, hsPatType pat)+ getType _ (G.L spn pat) = return $ Just (spn, hsPatType pat) ---------------------------------------------------------------- @@ -95,16 +98,16 @@ inModuleContext Type opt cradle file modstr exprToType errmsg where exprToType = do- modSum <- getModSummary $ mkModuleName modstr- p <- parseModule modSum- tcm@TypecheckedModule{tm_typechecked_source = tcs} <- typecheckModule p+ modSum <- G.getModSummary $ G.mkModuleName modstr+ p <- G.parseModule modSum+ tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p let bs = listifySpans tcs (lineNo, colNo) :: [LHsBind Id] es = listifySpans tcs (lineNo, colNo) :: [LHsExpr Id] ps = listifySpans tcs (lineNo, colNo) :: [LPat Id] bts <- mapM (getType tcm) bs ets <- mapM (getType tcm) es pts <- mapM (getType tcm) ps- dflag <- getSessionDynFlags+ dflag <- G.getSessionDynFlags let sss = map (toTup dflag) $ sortBy (cmp `on` fst) $ catMaybes $ concat [ets, bts, pts] return $ convert opt sss @@ -115,8 +118,8 @@ fourInts = fromMaybe (0,0,0,0) . Gap.getSrcSpan cmp a b- | a `isSubspanOf` b = O.LT- | b `isSubspanOf` a = O.GT+ | a `G.isSubspanOf` b = O.LT+ | b `G.isSubspanOf` a = O.GT | otherwise = O.EQ errmsg = convert opt ([] :: [((Int,Int,Int,Int),String)])@@ -124,7 +127,7 @@ listifySpans :: Typeable a => TypecheckedSource -> (Int, Int) -> [Located a] listifySpans tcs lc = listifyStaged TypeChecker p tcs where- p (L spn _) = isGoodSrcSpan spn && spn `spans` lc+ p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r] listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x]))@@ -135,36 +138,33 @@ ---------------------------------------------------------------- inModuleContext :: Cmd -> Options -> Cradle -> FilePath -> ModuleString -> Ghc String -> String -> Ghc String-inModuleContext cmd opt cradle file modstr action errmsg =+inModuleContext _ opt cradle file modstr action errmsg = valid ||> invalid ||> return errmsg where valid = do void $ initializeFlagsWithCradle opt cradle ["-w:"] False- when (cmd == Info) setSlowDynFlags setTargetFiles [file]- checkSlowAndSet- void $ load LoadAllTargets+ void $ G.load LoadAllTargets doif setContextFromTarget action invalid = do void $ initializeFlagsWithCradle opt cradle ["-w:"] False setTargetBuffer- checkSlowAndSet- void $ load LoadAllTargets+ void $ G.load LoadAllTargets doif setContextFromTarget action setTargetBuffer = do- modgraph <- depanal [mkModuleName modstr] True- dflag <- getSessionDynFlags- let imports = concatMap (map (showQualifiedPage dflag . ppr . unLoc)) $- map ms_imps modgraph ++ map ms_srcimps modgraph+ modgraph <- G.depanal [G.mkModuleName modstr] True+ dflag <- G.getSessionDynFlags+ let imports = concatMap (map (showQualifiedPage dflag . ppr . G.unLoc)) $+ map ms_imps modgraph ++ map G.ms_srcimps modgraph moddef = "module " ++ sanitize modstr ++ " where" header = moddef : imports importsBuf <- Gap.toStringBuffer header- clkTime <- Gap.liftIO getCurrentTime- setTargets [Gap.mkTarget (TargetModule $ mkModuleName modstr)- True- (Just (importsBuf, clkTime))]+ clkTime <- liftIO getCurrentTime+ G.setTargets [Gap.mkTarget (TargetModule $ G.mkModuleName modstr)+ True+ (Just (importsBuf, clkTime))] doif m t = m >>= \ok -> if ok then t else goNext sanitize = fromMaybe "SomeModule" . listToMaybe . words setContextFromTarget :: Ghc Bool-setContextFromTarget = depanal [] False >>= Gap.setCtx+setContextFromTarget = G.depanal [] False >>= Gap.setCtx
Language/Haskell/GhcMod/Internal.hs view
@@ -7,6 +7,9 @@ , Package , IncludeDir , CompilerOptions(..)+ -- * Cradle+ , userPackageDbOptsForGhc+ , userPackageDbOptsForGhcPkg -- * Cabal API , parseCabalFile , getCompilerOptions@@ -14,16 +17,17 @@ , cabalDependPackages , cabalSourceDirs , cabalAllTargets- -- * GHC API- , canCheckFast- -- * Getting 'DynFlags'+ -- * IO+ , getSystemLibDir , getDynamicFlags -- * Initializing 'DynFlags' , initializeFlags , initializeFlagsWithCradle- -- * 'GhcMonad'+ -- * 'Ghc' Monad , setTargetFiles- , checkSlowAndSet+ , addTargetFiles+ , handleErrMsg+ , browseAll -- * 'Ghc' Choice , (||>) , goNext@@ -32,7 +36,9 @@ , (|||>) ) where +import Language.Haskell.GhcMod.Browse import Language.Haskell.GhcMod.CabalApi+import Language.Haskell.GhcMod.Cradle import Language.Haskell.GhcMod.ErrMsg import Language.Haskell.GhcMod.GHCApi import Language.Haskell.GhcMod.GHCChoice
Language/Haskell/GhcMod/Lint.hs view
@@ -1,21 +1,38 @@ module Language.Haskell.GhcMod.Lint where -import Control.Applicative-import Data.List+import Control.Applicative ((<$>))+import Control.Exception (finally)+import Data.List (intercalate)+import GHC.IO.Handle (hDuplicate, hDuplicateTo) import Language.Haskell.GhcMod.Types-import Language.Haskell.HLint+import Language.Haskell.HLint (hlint)+import System.Directory (getTemporaryDirectory, removeFile)+import System.IO (hClose, openTempFile, stdout) -- | Checking syntax of a target file using hlint. -- Warnings and errors are returned. lintSyntax :: Options -> FilePath -- ^ A target file. -> IO String-lintSyntax opt file = pack <$> lint opt file+lintSyntax opt file = pack <$> lint hopts file where LineSeparator lsep = lineSeparator opt pack = unlines . map (intercalate lsep . lines)+ hopts = hlintOpts opt -lint :: Options+-- | Checking syntax of a target file using hlint.+-- Warnings and errors are returned.+lint :: [String] -> FilePath -- ^ A target file. -> IO [String]-lint opt file = map show <$> hlint ([file] ++ hlintOpts opt)+lint hopts file = map show <$> suppressStdout (hlint (file : hopts))++suppressStdout :: IO a -> IO a+suppressStdout f = do+ tmpdir <- getTemporaryDirectory+ (path, handle) <- openTempFile tmpdir "ghc-mod-hlint"+ removeFile path+ dup <- hDuplicate stdout+ hDuplicateTo handle stdout+ hClose handle+ f `finally` hDuplicateTo dup stdout
Language/Haskell/GhcMod/List.hs view
@@ -1,13 +1,14 @@ module Language.Haskell.GhcMod.List (listModules, listMods) where -import Control.Applicative+import Control.Applicative ((<$>)) import Control.Monad (void)-import Data.List-import GHC+import Data.List (nub, sort)+import GHC (Ghc)+import qualified GHC as G import Language.Haskell.GhcMod.GHCApi import Language.Haskell.GhcMod.Types-import Packages-import UniqFM+import Packages (pkgIdMap, exposedModules, sourcePackageId, display)+import UniqFM (eltsUFM) ---------------------------------------------------------------- @@ -23,11 +24,11 @@ listMods :: Options -> Cradle -> Ghc [(String, String)] listMods opt cradle = do void $ initializeFlagsWithCradle opt cradle [] False- getExposedModules <$> getSessionDynFlags+ getExposedModules <$> G.getSessionDynFlags where getExposedModules = concatMap exposedModules'- . eltsUFM . pkgIdMap . pkgState+ . eltsUFM . pkgIdMap . G.pkgState exposedModules' p =- map moduleNameString (exposedModules p)+ map G.moduleNameString (exposedModules p) `zip`- repeat (display $ sourcePackageId p)+ repeat (display $ sourcePackageId p)
+ Language/Haskell/GhcMod/PkgDoc.hs view
@@ -0,0 +1,27 @@+module Language.Haskell.GhcMod.PkgDoc (packageDoc) where++import Control.Applicative ((<$>))+import Language.Haskell.GhcMod.Types+import Language.Haskell.GhcMod.Cradle+import System.Process (readProcess)++-- | Obtaining the package name and the doc path of a module.+packageDoc :: Options+ -> Cradle+ -> ModuleString+ -> IO String+packageDoc _ cradle mdl = pkgDoc cradle mdl++pkgDoc :: Cradle -> String -> IO String+pkgDoc cradle mdl = do+ pkg <- trim <$> readProcess "ghc-pkg" toModuleOpts []+ if pkg == "" then+ return "\n"+ else do+ htmlpath <- readProcess "ghc-pkg" (toDocDirOpts pkg) []+ let ret = pkg ++ " " ++ drop 14 htmlpath+ return ret+ where+ toModuleOpts = ["find-module", mdl, "--simple-output"] ++ userPackageDbOptsForGhcPkg (cradlePackageDb cradle)+ toDocDirOpts pkg = ["field", pkg, "haddock-html"] ++ userPackageDbOptsForGhcPkg (cradlePackageDb cradle)+ trim = takeWhile (`notElem` " \n")
Language/Haskell/GhcMod/Types.hs view
@@ -83,14 +83,15 @@ -- | The environment where this library is used. data Cradle = Cradle { -- | The directory where this library is executed.- cradleCurrentDir :: FilePath- -- | The directory where a cabal file is found.- , cradleCabalDir :: Maybe FilePath+ cradleCurrentDir :: FilePath+ -- | The project root directory.+ , cradleRootDir :: FilePath -- | The file name of the found cabal file.- , cradleCabalFile :: Maybe FilePath- -- | The package db options. ([\"-no-user-package-db\",\"-package-db\",\"\/foo\/bar\/i386-osx-ghc-7.6.3-packages.conf.d\"])- , cradlePackageDbOpts :: [GHCOption]- , cradlePackages :: [Package]+ , cradleCabalFile :: Maybe FilePath+ -- | User package db. (\"\/foo\/bar\/i386-osx-ghc-7.6.3-packages.conf.d\")+ , cradlePackageDb :: Maybe FilePath+ -- | Dependent packages.+ , cradlePackages :: [Package] } deriving (Eq, Show) ----------------------------------------------------------------@@ -112,8 +113,6 @@ -- | Module name. type ModuleString = String--data CheckSpeed = Slow | Fast -- | Option information for GHC data CompilerOptions = CompilerOptions {
elisp/Makefile view
@@ -1,4 +1,4 @@-SRCS = ghc.el ghc-func.el ghc-doc.el ghc-comp.el ghc-flymake.el \+SRCS = ghc.el ghc-func.el ghc-doc.el ghc-comp.el ghc-check.el ghc-process.el \ ghc-command.el ghc-info.el ghc-ins-mod.el ghc-indent.el EMACS = emacs DETECT = xemacs
+ elisp/ghc-check.el view
@@ -0,0 +1,288 @@+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;+;;; ghc-check.el+;;;++;; Author: Kazu Yamamoto <Kazu@Mew.org>+;; Created: Mar 9, 2014++;;; Code:++(require 'ghc-func)+(require 'ghc-process)++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++;; stolen from flymake.el+(defface ghc-face-error+ '((((supports :underline (:style wave)))+ :underline (:style wave :color "orangered"))+ (t+ :inherit error))+ "Face used for marking error lines."+ :group 'ghc)++(defface ghc-face-warn+ '((((supports :underline (:style wave)))+ :underline (:style wave :color "gold"))+ (t+ :inherit warning))+ "Face used for marking warning lines."+ :group 'ghc)++(defvar ghc-check-error-fringe (propertize "!" 'display '(left-fringe exclamation-mark)))++(defvar ghc-check-warning-fringe (propertize "?" 'display '(left-fringe question-mark)))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defun ghc-check-syntax ()+ (interactive)+ (ghc-with-process 'ghc-check-send 'ghc-check-callback))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(ghc-defstruct hilit-info file line msg err)++(defun ghc-check-send ()+ (with-current-buffer ghc-process-original-buffer+ (setq mode-line-process " -:-"))+ (if ghc-check-command+ (let ((opts (ghc-haskell-list-of-string ghc-hlint-options)))+ (if opts+ (concat "lint " opts " " ghc-process-original-file "\n")+ (concat "lint " ghc-process-original-file "\n")))+ (concat "check " ghc-process-original-file "\n")))++(defun ghc-haskell-list-of-string (los)+ (when los+ (concat "["+ (mapconcat (lambda (x) (concat "\"" x "\"")) los ", ")+ "]")))++(defun ghc-check-callback ()+ (let ((regex "^\\([^\n\0]*\\):\\([0-9]+\\):\\([0-9]+\\): *\\(.+\\)")+ info infos)+ (while (re-search-forward regex nil t)+ (let* ((file (match-string 1))+ (line (string-to-number (match-string 2)))+ ;; don't take column to make multiple same errors to a single.+ (msg (match-string 4))+ (err (not (string-match "^Warning" msg)))+ (info (ghc-make-hilit-info+ :file file+ :line line+ :msg msg+ :err err)))+ (unless (member info infos)+ (setq infos (cons info infos)))))+ (setq infos (nreverse infos))+ (cond+ (infos+ (let ((file ghc-process-original-file)+ (buf ghc-process-original-buffer))+ (ghc-check-highlight-original-buffer file buf infos)))+ (t+ (with-current-buffer ghc-process-original-buffer+ (remove-overlays (point-min) (point-max) 'ghc-check t))))+ (with-current-buffer ghc-process-original-buffer+ (let ((len (length infos)))+ (if (= len 0)+ (setq mode-line-process "")+ (let* ((errs (ghc-filter 'ghc-hilit-info-get-err infos))+ (elen (length errs))+ (wlen (- len elen)))+ (setq mode-line-process (format " %d:%d" elen wlen))))))))++(defun ghc-check-highlight-original-buffer (ofile buf infos)+ (with-current-buffer buf+ (remove-overlays (point-min) (point-max) 'ghc-check t)+ (save-excursion+ (goto-char (point-min))+ (dolist (info infos)+ (let ((line (ghc-hilit-info-get-line info))+ (msg (ghc-hilit-info-get-msg info))+ (file (ghc-hilit-info-get-file info))+ (err (ghc-hilit-info-get-err info))+ beg end ovl)+ ;; FIXME: This is the Shlemiel painter's algorithm.+ ;; If this is a bottleneck for a large code, let's fix.+ (goto-char (point-min))+ (cond+ ((string= ofile file)+ (forward-line (1- line))+ (while (eq (char-after) 32) (forward-char))+ (setq beg (point))+ (forward-line)+ (setq end (1- (point))))+ (t+ (setq beg (point))+ (forward-line)+ (setq end (point))))+ (setq ovl (make-overlay beg end))+ (overlay-put ovl 'ghc-check t)+ (overlay-put ovl 'ghc-file file)+ (overlay-put ovl 'ghc-msg msg)+ (let ((echo (ghc-replace-character msg ?\0 ?\n)))+ (overlay-put ovl 'help-echo echo))+ (let ((fringe (if err ghc-check-error-fringe ghc-check-warning-fringe))+ (face (if err 'ghc-face-error 'ghc-face-warn)))+ (overlay-put ovl 'before-string fringe)+ (overlay-put ovl 'face face)))))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defun ghc-display-errors ()+ (interactive)+ (let* ((ovls (ghc-check-overlay-at (point)))+ (errs (mapcar (lambda (ovl) (overlay-get ovl 'ghc-msg)) ovls)))+ (if (null ovls)+ (message "No errors or warnings")+ (ghc-display+ nil+ (lambda ()+ (insert (overlay-get (car ovls) 'ghc-file) "\n\n")+ (mapc (lambda (x) (insert x "\n\n")) errs))))))++(defun ghc-check-overlay-at (p)+ (let ((ovls (overlays-at p)))+ (ghc-filter (lambda (ovl) (overlay-get ovl 'ghc-check)) ovls)))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defun ghc-goto-prev-error ()+ (interactive)+ (let* ((here (point))+ (ovls0 (ghc-check-overlay-at here))+ (end (if ovls0 (overlay-start (car ovls0)) here))+ (ovls1 (overlays-in (point-min) end))+ (ovls2 (ghc-filter (lambda (ovl) (overlay-get ovl 'ghc-check)) ovls1))+ (pnts (mapcar 'overlay-start ovls2)))+ (if pnts (goto-char (apply 'max pnts)))))++(defun ghc-goto-next-error ()+ (interactive)+ (let* ((here (point))+ (ovls0 (ghc-check-overlay-at here))+ (beg (if ovls0 (overlay-end (car ovls0)) here))+ (ovls1 (overlays-in beg (point-max)))+ (ovls2 (ghc-filter (lambda (ovl) (overlay-get ovl 'ghc-check)) ovls1))+ (pnts (mapcar 'overlay-start ovls2)))+ (if pnts (goto-char (apply 'min pnts)))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defun ghc-check-insert-from-warning ()+ (interactive)+ (dolist (data (mapcar (lambda (ovl) (overlay-get ovl 'ghc-msg)) (ghc-check-overlay-at (point))))+ (save-excursion+ (cond+ ((string-match "Inferred type: \\|no type signature:" data)+ (beginning-of-line)+ (insert-before-markers (ghc-extract-type data) "\n"))+ ((string-match "lacks an accompanying binding" data)+ (beginning-of-line)+ (when (looking-at "^\\([^ ]+\\) *::")+ (save-match-data+ (forward-line)+ (if (not (bolp)) (insert "\n")))+ (insert (match-string 1) " = undefined\n")))+ ;; GHC 7.8 uses Unicode for single-quotes.+ ((string-match "Not in scope: type constructor or class `\\([^'\n\0]+\\)'" data)+ (let ((sym (match-string 1 data)))+ (ghc-ins-mod sym)))+ ((string-match "Not in scope: `\\([^'\n\0]+\\)'" data)+ (let ((sym (match-string 1 data)))+ (if (or (string-match "\\." sym) ;; qualified+ (y-or-n-p (format "Import module for %s?" sym)))+ (ghc-ins-mod sym)+ (unless (re-search-forward "^$" nil t)+ (goto-char (point-max))+ (insert "\n"))+ (insert "\n" (ghc-enclose sym) " = undefined\n"))))+ ((string-match "Pattern match(es) are non-exhaustive" data)+ (let* ((fn (ghc-get-function-name))+ (arity (ghc-get-function-arity fn)))+ (ghc-insert-underscore fn arity)))+ ((string-match "Found:\0[ ]*\\([^\0]+\\)\0Why not:\0[ ]*\\([^\0]+\\)" data)+ (let ((old (match-string 1 data))+ (new (match-string 2 data)))+ (beginning-of-line)+ (when (search-forward old nil t)+ (let ((end (point)))+ (search-backward old nil t)+ (delete-region (point) end))+ (insert new))))+ (t+ (message "Nothing was done"))))))++(defun ghc-extract-type (str)+ (with-temp-buffer+ (insert str)+ (goto-char (point-min))+ (when (re-search-forward "Inferred type: \\|no type signature:\\( \\|\0 +\\)?" nil t)+ (delete-region (point-min) (point)))+ (when (re-search-forward " forall [^.]+\\." nil t)+ (replace-match ""))+ (while (re-search-forward "\0 +" nil t)+ (replace-match " "))+ (goto-char (point-min))+ (while (re-search-forward "\\[Char\\]" nil t)+ (replace-match "String"))+ (buffer-substring-no-properties (point-min) (point-max))))++(defun ghc-get-function-name ()+ (save-excursion+ (beginning-of-line)+ (when (looking-at "\\([^ ]+\\) ")+ (match-string 1))))++(defun ghc-get-function-arity (fn)+ (when fn+ (save-excursion+ (let ((regex (format "^%s *::" (regexp-quote fn))))+ (when (re-search-backward regex nil t)+ (ghc-get-function-arity0))))))++(defun ghc-get-function-arity0 ()+ (let ((end (save-excursion (end-of-line) (point)))+ (arity 0))+ (while (search-forward "->" end t)+ (setq arity (1+ arity)))+ arity))++(defun ghc-insert-underscore (fn ar)+ (when fn+ (let ((arity (or ar 1)))+ (save-excursion+ (goto-char (point-max))+ (re-search-backward (format "^%s *::" (regexp-quote fn)))+ (forward-line)+ (re-search-forward "^$" nil t)+ (insert fn)+ (dotimes (i arity)+ (insert " _"))+ (insert " = error \"" fn "\"")))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defun ghc-jump-file ()+ (interactive)+ (let* ((ovl (car (ghc-check-overlay-at 1)))+ (file (if ovl (overlay-get ovl 'ghc-file))))+ (if file (find-file file))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defvar ghc-hlint-options nil "*Hlint options")++(defvar ghc-check-command nil)++(defun ghc-toggle-check-command ()+ (interactive)+ (setq ghc-check-command (not ghc-check-command))+ (if ghc-check-command+ (message "Syntax check with hlint")+ (message "Syntax check with GHC")))++(provide 'ghc-check)
elisp/ghc-command.el view
@@ -8,23 +8,40 @@ ;;; Code: -(require 'ghc-flymake)+(require 'ghc-process)+(require 'ghc-check) (defun ghc-insert-template () (interactive) (cond ((bobp) (ghc-insert-module-template))- ((ghc-flymake-have-errs-p)- (ghc-flymake-insert-from-warning))+ ((ghc-check-overlay-at (point))+ (ghc-check-insert-from-warning)) (t (message "Nothing to be done")))) (defun ghc-insert-module-template ()- (let ((mod (file-name-sans-extension (buffer-name))))- (aset mod 0 (upcase (aref mod 0)))+ (let* ((fullname (file-name-sans-extension (buffer-file-name)))+ (rootdir (ghc-get-project-root))+ (len (length rootdir))+ (name (substring fullname (1+ len)))+ (file (file-name-sans-extension (buffer-name)))+ (case-fold-search nil)+ (mod (if (string-match "^[A-Z]" name)+ (ghc-replace-character name ?/ ?.)+ (if (string-match "^[a-z]" file)+ "Main"+ file))))+ (while (looking-at "^{-#")+ (forward-line)) (insert "module " mod " where\n"))) +;; (defun ghc-capitalize (str)+;; (let ((ret (copy-sequence str)))+;; (aset ret 0 (upcase (aref ret 0)))+;; ret))+ (defun ghc-sort-lines (beg end) (interactive "r") (save-excursion@@ -36,12 +53,42 @@ (lambda () (re-search-forward "^import\\( *qualified\\)? *" nil t) nil)- 'end-of-line)))))+ 'end-of-line))+ (ghc-merge-lines)))) +(defun ghc-merge-lines ()+ (let ((case-fold-search nil))+ (goto-char (point-min))+ (while (not (eolp))+ ;; qualified modlues are not merged at this moment.+ ;; fixme if it is improper.+ (if (looking-at "^import *\\([A-Z][^ \n]+\\) *(\\(.*\\))$")+ (let ((mod (match-string-no-properties 1))+ (syms (match-string-no-properties 2))+ (beg (point)))+ (forward-line)+ (ghc-merge-line beg mod syms))+ (forward-line)))))++(defun ghc-merge-line (beg mod syms)+ (let ((regex (concat "^import *" (regexp-quote mod) " *(\\(.*\\))$"))+ duplicated)+ (while (looking-at regex)+ (setq duplicated t)+ (setq syms (concat syms ", " (match-string-no-properties 1)))+ (forward-line))+ (when duplicated+ (delete-region beg (point))+ (insert "import " mod " (" syms ")\n"))))+ (defun ghc-save-buffer () (interactive)- (if (buffer-modified-p)- (call-interactively 'save-buffer)- (flymake-start-syntax-check)))+ ;; fixme: better way then saving?+ (if ghc-check-command ;; hlint+ (if (buffer-modified-p)+ (call-interactively 'save-buffer))+ (set-buffer-modified-p t)+ (call-interactively 'save-buffer))+ (ghc-check-syntax)) (provide 'ghc-command)
elisp/ghc-comp.el view
@@ -30,6 +30,8 @@ ;; must be sorted (defconst ghc-reserved-keyword '("case" "deriving" "do" "else" "if" "in" "let" "module" "of" "then" "where")) +(defconst ghc-extra-keywords '("ByteString"))+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Local Variables@@ -49,7 +51,7 @@ (defvar ghc-merged-keyword nil) ;; completion for type/func/... (defvar ghc-language-extensions nil) (defvar ghc-option-flags nil)-(defvar ghc-pragma-names '("LANGUAGE" "OPTIONS_GHC"))+(defvar ghc-pragma-names '("LANGUAGE" "OPTIONS_GHC" "INCLUDE" "WARNING" "DEPRECATED" "INLINE" "NOINLINE" "ANN" "LINE" "RULES" "SPECIALIZE" "UNPACK" "SOURCE")) (defconst ghc-keyword-prefix "ghc-keyword-") (defvar ghc-keyword-Prelude nil)@@ -68,6 +70,7 @@ (let* ((syms '(ghc-module-names ghc-language-extensions ghc-option-flags+ ;; hard coded in GHCMod.hs ghc-keyword-Prelude ghc-keyword-Control.Applicative ghc-keyword-Control.Monad@@ -80,6 +83,7 @@ (ghc-set syms vals)) (ghc-add ghc-module-names "qualified") (ghc-add ghc-module-names "hiding")+ ;; hard coded in GHCMod.hs (ghc-merge-keywords '("Prelude" "Control.Applicative" "Control.Monad"@@ -220,7 +224,7 @@ (defun ghc-completion-start-point () (save-excursion (let ((beg (save-excursion (beginning-of-line) (point)))- (regex (if (ghc-module-completion-p) "[ (,`]" "[ (,`.]")))+ (regex (if (ghc-module-completion-p) "[ (,`]" "[\[ (,`.]"))) (if (re-search-backward regex beg t) (1+ (point)) beg))))@@ -257,7 +261,7 @@ (defun ghc-merge-keywords (mods) (setq ghc-loaded-module (append mods ghc-loaded-module)) (let* ((modkeys (mapcar 'ghc-module-keyword ghc-loaded-module))- (keywords (cons ghc-reserved-keyword modkeys))+ (keywords (cons ghc-extra-keywords (cons ghc-reserved-keyword modkeys))) (uniq-sorted (sort (ghc-uniq-lol keywords) 'string<))) (setq ghc-merged-keyword uniq-sorted))) @@ -273,7 +277,9 @@ (ghc-defstruct buffer name file) (defun ghc-buffer-name-file (buf)- (ghc-make-buffer (buffer-name buf) (buffer-file-name buf)))+ (ghc-make-buffer+ :name (buffer-name buf)+ :file (buffer-file-name buf))) (defun ghc-gather-import-modules-all-buffers () (let ((bufs (mapcar 'ghc-buffer-name-file (buffer-list)))
elisp/ghc-doc.el view
@@ -15,61 +15,47 @@ (defun ghc-browse-document (&optional haskell-org) (interactive "P") (let ((mod0 (ghc-extract-module))- (expr0 (ghc-things-at-point)))- (cond- ((and (not mod0) expr0)- (let* ((expr (ghc-read-expression expr0))- (info (ghc-get-info expr0))- (mod (ghc-extact-module-from-info info))- (pkg (ghc-resolve-package-name mod)))- (if (and pkg mod)- (ghc-display-document pkg mod haskell-org expr)- (message "No document found"))))- (t- (let* ((mod (ghc-read-module-name mod0))- (pkg (ghc-resolve-package-name mod)))- (if (and pkg mod)- (ghc-display-document pkg mod haskell-org)- (message "No document found")))))))+ (expr0 (ghc-things-at-point))+ pkg-ver-path mod expr info)+ (if (or mod0 (not expr0))+ (setq mod (ghc-read-module-name mod0))+ (setq expr (ghc-read-expression expr0))+ (setq info (ghc-get-info expr0))+ (setq mod (ghc-extact-module-from-info info)))+ (setq pkg-ver-path (ghc-resolve-document-path mod))+ (if (and pkg-ver-path mod)+ (ghc-display-document pkg-ver-path mod haskell-org expr)+ (message "No document found")))) -(defun ghc-resolve-package-name (mod)+(ghc-defstruct pkg-ver-path pkg ver path)++(defun ghc-resolve-document-path (mod) (with-temp-buffer- (ghc-call-process "ghc-pkg" nil t nil "find-module" "--simple-output" mod)+ (ghc-call-process "ghc-mod" nil t nil "doc" mod) (goto-char (point-min))- (when (re-search-forward "\\([^ ]+\\)-\\([0-9]*\\(\\.[0-9]+\\)*\\)$" nil t)- (ghc-make-pkg-ver+ (when (looking-at "^\\([^ ]+\\)-\\([0-9]*\\(\\.[0-9]+\\)*\\) \\(.*\\)$")+ (ghc-make-pkg-ver-path :pkg (match-string-no-properties 1)- :ver (match-string-no-properties 2)))))--(defun ghc-resolve-document-path (pkg)- (with-temp-buffer- (ghc-call-process "ghc-pkg" nil t nil "field" pkg "haddock-html")- (goto-char (point-max))- (forward-line -1)- (beginning-of-line)- (when (looking-at "^haddock-html: \\([^ \n]+\\)$")- (match-string-no-properties 1))))+ :ver (match-string-no-properties 2)+ :path (match-string-no-properties 4))))) (defconst ghc-doc-local-format "file://%s/%s.html") (defconst ghc-doc-hackage-format "http://hackage.haskell.org/packages/archive/%s/%s/doc/html/%s.html") -(ghc-defstruct pkg-ver pkg ver)--(defun ghc-display-document (pkg-ver mod haskell-org &optional symbol)- (when (and pkg-ver mod)- (let* ((mod- (ghc-replace-character mod ?. ?-))- (pkg (ghc-pkg-ver-get-pkg pkg-ver))- (ver (ghc-pkg-ver-get-ver pkg-ver))- (pkg-with-ver (format "%s-%s" pkg ver))- (path (ghc-resolve-document-path pkg-with-ver))- (local (format ghc-doc-local-format path mod-))- (remote (format ghc-doc-hackage-format pkg ver mod-))- (file (format "%s/%s.html" path mod-))- (url0 (if (or haskell-org (not (file-exists-p file))) remote local))- (url (if symbol (ghc-add-anchor url0 symbol) url0)))- ;; Mac's "open" removes the anchor from "file://", sigh.- (browse-url url))))+(defun ghc-display-document (pkg-ver-path mod haskell-org &optional symbol)+ (let* ((mod- (ghc-replace-character mod ?. ?-))+ (pkg (ghc-pkg-ver-path-get-pkg pkg-ver-path))+ (ver (ghc-pkg-ver-path-get-ver pkg-ver-path))+ (path (ghc-pkg-ver-path-get-path pkg-ver-path))+ (pkg-with-ver (format "%s-%s" pkg ver))+ (local (format ghc-doc-local-format path mod-))+ (remote (format ghc-doc-hackage-format pkg ver mod-))+ (file (format "%s/%s.html" path mod-))+ (url0 (if (or haskell-org (not (file-exists-p file))) remote local))+ (url (if symbol (ghc-add-anchor url0 symbol) url0)))+ ;; Mac's "open" removes the anchor from "file://", sigh.+ (browse-url url))) (defun ghc-add-anchor (url symbol) (let ((case-fold-search nil))
− elisp/ghc-flymake.el
@@ -1,233 +0,0 @@-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;-;;;-;;; ghc-flymake.el-;;;--;; Author: Kazu Yamamoto <Kazu@Mew.org>-;; Created: Mar 12, 2010--;;; Code:--(require 'flymake)-(require 'ghc-func)--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;--(defvar ghc-hlint-options nil "*Hlint options")--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;--(defconst ghc-flymake-allowed-file-name-masks- '("\\.l?hs$" ghc-flymake-init nil ghc-emacs23-later-hack))--(defconst ghc-flymake-err-line-patterns- '("^\\(.*\\):\\([0-9]+\\):\\([0-9]+\\):[ ]*\\(.+\\)" 1 2 3 4))--(add-to-list 'flymake-allowed-file-name-masks- ghc-flymake-allowed-file-name-masks)--(add-to-list 'flymake-err-line-patterns- ghc-flymake-err-line-patterns)--;; flymake of Emacs 23 or later does not display errors-;; if they occurred in other files. So, let's cheat flymake.-(defun ghc-emacs23-later-hack (tmp-file)- (let ((real-name (flymake-get-real-file-name tmp-file))- (hack-name (flymake-get-real-file-name buffer-file-name)))- (unless (string= real-name hack-name)- ;; Change the local variable, line-err-info,- ;; in flymake-parse-err-lines.- (when (boundp 'line-err-info)- (setq line-err-info- (flymake-ler-make-ler- nil- 1- (flymake-ler-type line-err-info)- (concat real-name ": " (flymake-ler-text line-err-info))- (flymake-ler-full-file line-err-info)))))- hack-name))--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;--(defun ghc-flymake-init ()- (list ghc-module-command (ghc-flymake-command (flymake-init-create-temp-buffer-copy 'flymake-create-temp-inplace))))--(defvar ghc-flymake-command nil) ;; nil: check, t: lint--(defun ghc-flymake-command (file)- (if ghc-flymake-command- (let ((hopts (ghc-mapconcat (lambda (x) (list "-h" x)) ghc-hlint-options)))- `(,@hopts "lint" ,file))- `(,@(ghc-make-ghc-options) "check" ,file)))--(defun ghc-flymake-toggle-command ()- (interactive)- (setq ghc-flymake-command (not ghc-flymake-command))- (if ghc-flymake-command- (message "Syntax check with hlint")- (message "Syntax check with GHC")))--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;--(defun ghc-flymake-display-errors ()- (interactive)- (if (not (ghc-flymake-have-errs-p))- (message "No errors or warnings")- (let ((title (ghc-flymake-err-title))- (errs (ghc-flymake-err-list)))- (ghc-display- nil- (lambda ()- (insert title "\n\n")- (mapc (lambda (x) (insert x "\n")) errs))))))--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;--(defun ghc-flymake-jump ()- (interactive)- (if (not (ghc-flymake-have-errs-p))- (message "No errors or warnings")- (let* ((acts (ghc-flymake-act-list))- (act (car acts)))- (if (not act)- (message "No destination")- (eval act)))))--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;--(defun ghc-extract-type (str)- (with-temp-buffer- (insert str)- (goto-char (point-min))- (when (re-search-forward "Inferred type: \\|no type signature:\\( \\|\0 +\\)?" nil t)- (delete-region (point-min) (point)))- (when (re-search-forward " forall [^.]+\\." nil t)- (replace-match ""))- (while (re-search-forward "\0 +" nil t)- (replace-match " "))- (goto-char (point-min))- (while (re-search-forward "\\[Char\\]" nil t)- (replace-match "String"))- (re-search-forward "\0" nil t)- (buffer-substring-no-properties (point-min) (1- (point)))))--(defun ghc-flymake-insert-from-warning ()- (interactive)- (dolist (data (ghc-flymake-err-list))- (save-excursion- (cond- ((string-match "Inferred type: \\|no type signature:" data)- (beginning-of-line)- (insert (ghc-extract-type data) "\n"))- ((string-match "lacks an accompanying binding" data)- (beginning-of-line)- (when (looking-at "^\\([^ ]+\\) *::")- (save-match-data- (forward-line)- (if (not (bolp)) (insert "\n")))- (insert (match-string 1) " = undefined\n")))- ((string-match "Not in scope: `\\([^']+\\)'" data)- (save-match-data- (unless (re-search-forward "^$" nil t)- (goto-char (point-max))- (insert "\n")))- (insert "\n" (match-string 1 data) " = undefined\n"))- ((string-match "Pattern match(es) are non-exhaustive" data)- (let* ((fn (ghc-get-function-name))- (arity (ghc-get-function-arity fn)))- (ghc-insert-underscore fn arity)))- ((string-match "Found:\0[ ]*\\([^\0]+\\)\0Why not:\0[ ]*\\([^\0]+\\)" data)- (let ((old (match-string 1 data))- (new (match-string 2 data)))- (beginning-of-line)- (when (search-forward old nil t)- (let ((end (point)))- (search-backward old nil t)- (delete-region (point) end))- (insert new))))))))--(defun ghc-get-function-name ()- (save-excursion- (beginning-of-line)- (when (looking-at "\\([^ ]+\\) ")- (match-string 1))))--(defun ghc-get-function-arity (fn)- (when fn- (save-excursion- (let ((regex (format "^%s *::" (regexp-quote fn))))- (when (re-search-backward regex nil t)- (ghc-get-function-arity0))))))--(defun ghc-get-function-arity0 ()- (let ((end (save-excursion (end-of-line) (point)))- (arity 0))- (while (search-forward "->" end t)- (setq arity (1+ arity)))- arity))--(defun ghc-insert-underscore (fn ar)- (when fn- (let ((arity (or ar 1)))- (save-excursion- (goto-char (point-max))- (re-search-backward (format "^%s *::" (regexp-quote fn)))- (forward-line)- (re-search-forward "^$" nil t)- (insert fn)- (dotimes (i arity)- (insert " _"))- (insert " = error \"" fn "\"")))))--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;--(defun ghc-flymake-err-get-title (x) (nth 0 x))-(defun ghc-flymake-err-get-errs (x) (nth 1 x))--(defun ghc-flymake-err-get-err-msg (x) (nth 0 x))-(defun ghc-flymake-err-get-err-act (x) (nth 1 x))--(defalias 'ghc-flymake-have-errs-p 'ghc-flymake-data)--(defun ghc-flymake-data ()- (let* ((line-no (line-number-at-pos))- (info (nth 0 (flymake-find-err-info flymake-err-info line-no))))- (flymake-make-err-menu-data-stolen line-no info)))--(defun flymake-make-err-menu-data-stolen (line-no line-err-info-list)- "Make a (menu-title (item-title item-action)*) list with errors/warnings from LINE-ERR-INFO-LIST."- (let* ((menu-items nil))- (when line-err-info-list- (let* ((count (length line-err-info-list))- (menu-item-text nil))- (while (> count 0)- (setq menu-item-text (flymake-ler-text (nth (1- count) line-err-info-list)))- (let* ((file (flymake-ler-file (nth (1- count) line-err-info-list)))- (full-file (flymake-ler-full-file (nth (1- count) line-err-info-list)))- (line (flymake-ler-line (nth (1- count) line-err-info-list))))- (if file- (setq menu-item-text (concat menu-item-text " - " file "(" (format "%d" line) ")")))- (setq menu-items (cons (list menu-item-text- (if file (list 'flymake-goto-file-and-line full-file line) nil))- menu-items)))- (setq count (1- count)))- (flymake-log 3 "created menu-items with %d item(s)" (length menu-items))))- (if menu-items- (let* ((menu-title (format "Line %d: %d error(s), %d warning(s)" line-no- (flymake-get-line-err-count line-err-info-list "e")- (flymake-get-line-err-count line-err-info-list "w"))))- (list menu-title menu-items))- nil)))--(defun ghc-flymake-err-title ()- (ghc-flymake-err-get-title (ghc-flymake-data)))--(defun ghc-flymake-err-list ()- (mapcar 'ghc-flymake-err-get-err-msg (ghc-flymake-err-get-errs (ghc-flymake-data))))--(defun ghc-flymake-act-list ()- (mapcar 'ghc-flymake-err-get-err-act (ghc-flymake-err-get-errs (ghc-flymake-data))))--(provide 'ghc-flymake)
elisp/ghc-func.el view
@@ -197,4 +197,12 @@ (insert (format "%% %s %s\n" cmd (mapconcat 'identity args " "))) (insert-buffer-substring cbuf))))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defun ghc-enclose (expr)+ (let ((case-fold-search nil))+ (if (string-match "^[a-zA-Z0-9_]" expr)+ expr+ (concat "(" expr ")"))))+ (provide 'ghc-func)
elisp/ghc-ins-mod.el view
@@ -6,57 +6,94 @@ ;; Author: Kazu Yamamoto <Kazu@Mew.org> ;; Created: Dec 27, 2011 +(require 'ghc-process)+ ;;; Code: -(defvar ghc-hoogle-command "hoogle")+(defvar ghc-ins-mod-rendezvous nil)+(defvar ghc-ins-mod-results nil) (defun ghc-insert-module () (interactive)- (ghc-executable-find ghc-hoogle-command- (let* ((expr0 (ghc-things-at-point))- (expr (ghc-read-expression expr0)))- (let ((mods (ghc-function-to-modules expr)))- (if (null mods)- (message "No module guessed")- (let* ((first (car mods))- (mod (if (= (length mods) 1)- first- (completing-read "Module name: " mods nil t first))))- (save-excursion- (ghc-goto-module-position)- (insert "import " mod "\n"))))))))+ (let* ((expr0 (ghc-things-at-point))+ (expr (ghc-read-expression expr0)))+ (ghc-ins-mod expr))) +(defvar ghc-preferred-modules '("Control.Applicative"+ "Data.ByteString"+ "Data.Text"+ "Text.Parsec"))++(defun ghc-reorder-modules (mods)+ (catch 'loop+ (dolist (pmod ghc-preferred-modules)+ (if (member pmod mods)+ (throw 'loop (cons pmod (delete pmod mods)))))+ mods))++(defun ghc-ins-mod (expr)+ (let (prefix fun mods)+ (if (not (string-match "^\\([^.]+\\)\\\.\\([^.]+\\)$" expr))+ (setq fun expr)+ (setq prefix (match-string 1 expr))+ (setq fun (match-string 2 expr)))+ (setq mods (ghc-reorder-modules (ghc-function-to-modules fun)))+ (if (null mods)+ (message "No module guessed")+ (let* ((key (or prefix fun))+ (fmt (concat "Module name for \"" key "\" (%s): "))+ (mod (ghc-completing-read fmt mods)))+ (save-excursion+ (ghc-goto-module-position)+ (if prefix+ (insert-before-markers "import qualified " mod " as " prefix "\n")+ (insert-before-markers "import " mod " (" (ghc-enclose expr) ")\n")))))))++(defun ghc-completing-read (fmt lst)+ (let* ((def (car lst))+ (prompt (format fmt def))+ (inp (completing-read prompt lst)))+ (if (string= inp "") def inp)))+ (defun ghc-goto-module-position () (goto-char (point-max)) (if (re-search-backward "^import" nil t) (ghc-goto-empty-line)- (if (re-search-backward "^module" nil t)- (ghc-goto-empty-line)- (goto-char (point-min)))))+ (if (not (re-search-backward "^module" nil t))+ (goto-char (point-min))+ (ghc-goto-empty-line)+ (forward-line)+ (unless (eolp)+ ;; save-excursion is not proper due to insert-before-markers.+ (let ((beg (point)))+ (insert-before-markers "\n")+ (goto-char beg)))))) (defun ghc-goto-empty-line () (unless (re-search-forward "^$" nil t) (forward-line))) -;; To avoid Data.Functor-(defvar ghc-applicative-operators '("<$>" "<$" "<*>" "<**>" "<*" "*>" "<|>"))+(defun ghc-function-to-modules (fun)+ (setq ghc-ins-mod-rendezvous nil)+ (setq ghc-ins-mod-results nil)+ (ghc-with-process+ (lambda () (ghc-ins-mod-send fun))+ 'ghc-ins-mod-callback)+ (while (null ghc-ins-mod-rendezvous)+ (sit-for 0.01))+ ghc-ins-mod-results) -(defun ghc-function-to-modules (fn)- (if (member fn ghc-applicative-operators)- '("Control.Applicative")- (ghc-function-to-modules-hoogle fn)))+(defun ghc-ins-mod-send (fun)+ (concat "find " fun "\n")) -(defun ghc-function-to-modules-hoogle (fn)- (with-temp-buffer- (let* ((fn1 (if (string-match "^[a-zA-Z0-9'_]+$" fn)- fn- (concat "(" fn ")")))- (regex (concat "^\\([a-zA-Z0-9.]+\\) " fn1 " "))- ret)- (ghc-call-process ghc-hoogle-command nil t nil "search" fn1)- (goto-char (point-min))- (while (re-search-forward regex nil t)- (setq ret (cons (match-string 1) ret)))- (nreverse ret))))+(defun ghc-ins-mod-callback ()+ (let (lines line beg)+ (while (not (eobp))+ (setq beg (point))+ (forward-line)+ (setq line (buffer-substring-no-properties beg (1- (point))))+ (setq lines (cons line lines)))+ (setq ghc-ins-mod-rendezvous t)+ (setq ghc-ins-mod-results (nreverse (cdr lines))))) ;; removing "OK" (provide 'ghc-ins-mod)
+ elisp/ghc-process.el view
@@ -0,0 +1,98 @@+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;+;;; ghc-process.el+;;;++;; Author: Kazu Yamamoto <Kazu@Mew.org>+;; Created: Mar 9, 2014++;;; Code:++(require 'ghc-func)++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defvar-local ghc-process-running nil)+(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 ghc-interactive-command "ghc-modi")++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defun ghc-get-project-root ()+ (let ((file (buffer-file-name)))+ (with-temp-buffer+ (ghc-call-process ghc-module-command nil t nil "root" file)+ (goto-char (point-min))+ (when (looking-at "^\\(.*\\)$")+ (match-string-no-properties 1)))))++(defun ghc-with-process (send callback)+ (unless ghc-process-process-name+ (setq ghc-process-process-name (ghc-get-project-root)))+ (when ghc-process-process-name+ (let* ((cbuf (current-buffer))+ (name ghc-process-process-name)+ (buf (get-buffer-create (concat " ghc-modi:" name)))+ (file (buffer-file-name))+ (cpro (get-process name)))+ (with-current-buffer buf+ (unless ghc-process-running+ (setq ghc-process-running t)+ (setq ghc-process-original-buffer cbuf)+ (setq ghc-process-original-file file)+ (setq ghc-process-callback callback)+ (erase-buffer)+ (let ((pro (ghc-get-process cpro name buf))+ (cmd (funcall send)))+ (process-send-string pro cmd)+ (when ghc-debug+ (ghc-with-debug-buffer+ (insert (format "%% %s" cmd))))))))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defun ghc-get-process (cpro name buf)+ (cond+ ((not cpro)+ (ghc-start-process name buf))+ ((not (eq (process-status cpro) 'run))+ (delete-process cpro)+ (ghc-start-process name buf))+ (t cpro)))++(defun ghc-start-process (name buf)+ (let ((pro (start-file-process name buf ghc-interactive-command)))+ (set-process-filter pro 'ghc-process-filter)+ (set-process-query-on-exit-flag pro nil)+ pro))++(defun ghc-process-filter (process string)+ (with-current-buffer (process-buffer process)+ (goto-char (point-max))+ (insert string)+ (forward-line -1)+ (when (looking-at "^\\(OK\\|NG\\)$")+ (goto-char (point-min))+ (funcall ghc-process-callback)+ (when ghc-debug+ (let ((cbuf (current-buffer)))+ (ghc-with-debug-buffer+ (insert-buffer-substring cbuf))))+ (setq ghc-process-running nil))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defun ghc-kill-process ()+ (interactive)+ (let* ((name ghc-process-process-name)+ (cpro (if name (get-process name))))+ (if (not cpro)+ (message "No process")+ (delete-process cpro)+ (message "A process was killed"))))++(provide 'ghc-process)
elisp/ghc.el view
@@ -8,12 +8,10 @@ ;; ;; (autoload 'ghc-init "ghc" nil t) ;; (add-hook 'haskell-mode-hook (lambda () (ghc-init)))-;; Or-;; (add-hook 'haskell-mode-hook (lambda () (ghc-init) (flymake-mode))) ;;; Code: -(defconst ghc-version "3.1.7")+(defconst ghc-version "4.0.0") ;; (eval-when-compile ;; (require 'haskell-mode))@@ -21,7 +19,7 @@ (require 'ghc-comp) (require 'ghc-doc) (require 'ghc-info)-(require 'ghc-flymake)+(require 'ghc-check) (require 'ghc-command) (require 'ghc-ins-mod) (require 'ghc-indent)@@ -50,9 +48,10 @@ (defvar ghc-info-key "\C-c\C-i") (defvar ghc-check-key "\C-x\C-s") (defvar ghc-toggle-key "\C-c\C-c")+(defvar ghc-jump-key "\C-c\C-j") (defvar ghc-module-key "\C-c\C-m") (defvar ghc-expand-key "\C-c\C-e")-(defvar ghc-jump-key "\C-c\C-j")+(defvar ghc-kill-key "\C-c\C-k") (defvar ghc-hoogle-key (format "\C-c%c" (ghc-find-C-h))) (defvar ghc-shallower-key "\C-c<") (defvar ghc-deeper-key "\C-c>")@@ -74,21 +73,23 @@ (define-key haskell-mode-map ghc-type-key 'ghc-show-type) (define-key haskell-mode-map ghc-info-key 'ghc-show-info) (define-key haskell-mode-map ghc-expand-key 'ghc-expand-th)- (define-key haskell-mode-map ghc-jump-key 'ghc-flymake-jump) (define-key haskell-mode-map ghc-import-key 'ghc-import-module)- (define-key haskell-mode-map ghc-previous-key 'flymake-goto-prev-error)- (define-key haskell-mode-map ghc-next-key 'flymake-goto-next-error)- (define-key haskell-mode-map ghc-help-key 'ghc-flymake-display-errors)+ (define-key haskell-mode-map ghc-previous-key 'ghc-goto-prev-error)+ (define-key haskell-mode-map ghc-next-key 'ghc-goto-next-error)+ (define-key haskell-mode-map ghc-help-key 'ghc-display-errors) (define-key haskell-mode-map ghc-insert-key 'ghc-insert-template) (define-key haskell-mode-map ghc-sort-key 'ghc-sort-lines) (define-key haskell-mode-map ghc-check-key 'ghc-save-buffer)- (define-key haskell-mode-map ghc-toggle-key 'ghc-flymake-toggle-command)+ (define-key haskell-mode-map ghc-toggle-key 'ghc-toggle-check-command)+ (define-key haskell-mode-map ghc-jump-key 'ghc-jump-file) (define-key haskell-mode-map ghc-module-key 'ghc-insert-module)+ (define-key haskell-mode-map ghc-kill-key 'ghc-kill-process) (define-key haskell-mode-map ghc-hoogle-key 'haskell-hoogle) (define-key haskell-mode-map ghc-shallower-key 'ghc-make-indent-shallower) (define-key haskell-mode-map ghc-deeper-key 'ghc-make-indent-deeper) (ghc-comp-init)- (setq ghc-initialized t)))+ (setq ghc-initialized t))+ (ghc-check-syntax)) (defun ghc-abbrev-init () (set (make-local-variable 'dabbrev-case-fold-search) nil))
ghc-mod.cabal view
@@ -1,5 +1,5 @@ Name: ghc-mod-Version: 3.1.7+Version: 4.0.0 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> License: BSD3@@ -21,7 +21,7 @@ Build-Type: Simple Data-Dir: elisp Data-Files: Makefile ghc.el ghc-func.el ghc-doc.el ghc-comp.el- ghc-flymake.el ghc-command.el ghc-info.el+ ghc-check.el ghc-process.el ghc-command.el ghc-info.el ghc-ins-mod.el ghc-indent.el ghc-pkg.el Extra-Source-Files: ChangeLog test/data/*.cabal@@ -49,8 +49,8 @@ Language.Haskell.GhcMod.CabalApi Language.Haskell.GhcMod.Check Language.Haskell.GhcMod.Cradle- Language.Haskell.GhcMod.Doc Language.Haskell.GhcMod.Debug+ Language.Haskell.GhcMod.Doc Language.Haskell.GhcMod.ErrMsg Language.Haskell.GhcMod.Flag Language.Haskell.GhcMod.GHCApi@@ -60,13 +60,13 @@ Language.Haskell.GhcMod.Lang Language.Haskell.GhcMod.Lint Language.Haskell.GhcMod.List+ Language.Haskell.GhcMod.PkgDoc Language.Haskell.GhcMod.Types Build-Depends: base >= 4.0 && < 5 , containers , directory , filepath , ghc- , ghc-paths , ghc-syb-utils , hlint >= 1.8.58 , io-choice@@ -93,6 +93,19 @@ , ghc , ghc-mod +Executable ghc-modi+ Default-Language: Haskell2010+ Main-Is: GHCModi.hs+ Other-Modules: Paths_ghc_mod+ GHC-Options: -Wall+ HS-Source-Dirs: src+ Build-Depends: base >= 4.0 && < 5+ , containers+ , directory+ , filepath+ , ghc+ , ghc-mod+ Test-Suite doctest Type: exitcode-stdio-1.0 Default-Language: Haskell2010@@ -111,7 +124,6 @@ BrowseSpec CabalApiSpec CheckSpec- DebugSpec FlagSpec InfoSpec LangSpec@@ -122,7 +134,6 @@ , directory , filepath , ghc- , ghc-paths , ghc-syb-utils , hlint >= 1.7.1 , io-choice
src/GHCMod.hs view
@@ -2,16 +2,16 @@ module Main where -import Control.Applicative-import Control.Exception-import Control.Monad-import Data.Typeable-import Data.Version+import Control.Applicative ((<$>))+import Control.Exception (Exception, Handler(..), ErrorCall(..))+import qualified Control.Exception as E+import Data.Typeable (Typeable)+import Data.Version (showVersion) import Language.Haskell.GhcMod import Paths_ghc_mod-import Prelude-import System.Console.GetOpt-import System.Directory+import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..))+import qualified System.Console.GetOpt as O+import System.Directory (doesFileExist) import System.Environment (getArgs) import System.Exit (exitFailure) import System.IO (hPutStr, hPutStrLn, stdout, stderr, hSetEncoding, utf8)@@ -34,6 +34,8 @@ ++ "\t ghc-mod info" ++ ghcOptHelp ++ "<HaskellFile> <module> <expression>\n" ++ "\t ghc-mod type" ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n" ++ "\t ghc-mod lint [-h opt] <HaskellFile>\n"+ ++ "\t ghc-mod root <HaskellFile>\n"+ ++ "\t ghc-mod doc <module>\n" ++ "\t ghc-mod boot\n" ++ "\t ghc-mod help\n" @@ -68,9 +70,9 @@ parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String]) parseArgs spec argv- = case getOpt Permute spec argv of+ = case O.getOpt Permute spec argv of (o,n,[] ) -> (foldr id defaultOptions o, n)- (_,_,errs) -> throw (CmdArg errs)+ (_,_,errs) -> E.throw (CmdArg errs) ---------------------------------------------------------------- @@ -85,7 +87,7 @@ ---------------------------------------------------------------- main :: IO ()-main = flip catches handlers $ do+main = flip E.catches handlers $ do -- #if __GLASGOW_HASKELL__ >= 611 hSetEncoding stdout utf8 -- #endif@@ -100,30 +102,32 @@ remainingArgs = tail cmdArg nArgs n f = if length remainingArgs == n then f- else throw (TooManyArguments cmdArg0)+ else E.throw (TooManyArguments cmdArg0) res <- case cmdArg0 of- "browse" -> concat <$> mapM (browseModule opt cradle) remainingArgs "list" -> listModules opt cradle+ "lang" -> listLanguages opt+ "flag" -> listFlags opt+ "browse" -> concat <$> mapM (browseModule opt cradle) remainingArgs "check" -> checkSyntax opt cradle remainingArgs "expand" -> checkSyntax opt { expandSplice = True } cradle remainingArgs "debug" -> nArgs 1 $ debugInfo opt cradle cmdArg1- "type" -> nArgs 4 $ typeExpr opt cradle cmdArg1 cmdArg2 (read cmdArg3) (read cmdArg4) "info" -> nArgs 3 infoExpr opt cradle cmdArg1 cmdArg2 cmdArg3+ "type" -> nArgs 4 $ typeExpr opt cradle cmdArg1 cmdArg2 (read cmdArg3) (read cmdArg4) "lint" -> nArgs 1 withFile (lintSyntax opt) cmdArg1- "lang" -> listLanguages opt- "flag" -> listFlags opt+ "root" -> nArgs 1 $ rootInfo opt cradle cmdArg1+ "doc" -> nArgs 1 $ packageDoc opt cradle cmdArg1 "boot" -> do mods <- listModules opt cradle langs <- listLanguages opt flags <- listFlags opt pre <- concat <$> mapM (browseModule opt cradle) preBrowsedModules return $ mods ++ langs ++ flags ++ pre- "help" -> return $ usageInfo usage argspec- cmd -> throw (NoSuchCommand cmd)+ "help" -> return $ O.usageInfo usage argspec+ cmd -> E.throw (NoSuchCommand cmd) putStr res where handlers = [Handler (handleThenExit handler1), Handler (handleThenExit handler2)]- handleThenExit handler = \e -> handler e >> exitFailure+ handleThenExit handler e = handler e >> exitFailure handler1 :: ErrorCall -> IO () handler1 = print -- for debug handler2 :: GHCModError -> IO ()@@ -140,14 +144,14 @@ handler2 (FileNotExist file) = do hPutStrLn stderr $ "\"" ++ file ++ "\" not found" printUsage- printUsage = hPutStrLn stderr $ '\n' : usageInfo usage argspec+ printUsage = hPutStrLn stderr $ '\n' : O.usageInfo usage argspec withFile cmd file = do exist <- doesFileExist file if exist then cmd file- else throw (FileNotExist file)+ else E.throw (FileNotExist file) xs !. idx- | length xs <= idx = throw SafeList+ | length xs <= idx = E.throw SafeList | otherwise = xs !! idx ----------------------------------------------------------------
+ src/GHCModi.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE CPP #-}++-- Commands:+-- check <file>+-- find <symbol>+-- lint [hlint options] <file>+-- the format of hlint options is [String] because they may contain+-- spaces and aslo <file> may contain spaces.+--+-- Session separators:+-- OK -- success+-- NG -- failure++module Main where++#ifndef MIN_VERSION_containers+#define MIN_VERSION_containers 1+#endif++import Control.Applicative ((<$>))+import Control.Concurrent (forkIO, MVar, newEmptyMVar, putMVar, readMVar)+import Control.Exception (SomeException(..))+import qualified Control.Exception as E+import Control.Monad (when, void)+import CoreMonad (liftIO)+import Data.Function (on)+import Data.List (intercalate, groupBy, sort, find)+#if MIN_VERSION_containers(0,5,0)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+#else+import Data.Map (Map)+import qualified Data.Map as M+#endif+import Data.Maybe (fromMaybe)+import Data.Set (Set)+import qualified Data.Set as S+import qualified Exception as GE+import GHC (Ghc, LoadHowMuch(LoadAllTargets), TargetId(TargetFile))+import qualified GHC as G+import HscTypes (SourceError)+import Language.Haskell.GhcMod+import Language.Haskell.GhcMod.Internal+import System.IO (hFlush,stdout)++----------------------------------------------------------------++type DB = Map String [String]+type Logger = IO [String]++----------------------------------------------------------------++-- Running two GHC monad threads disables the handling of+-- C-c since installSignalHandlers is called twice, sigh.++main :: IO ()+main = E.handle handler $ do+ cradle <- findCradle+ mvar <- liftIO newEmptyMVar+ mlibdir <- getSystemLibDir+ void $ forkIO $ setupDB cradle mlibdir opt mvar+ run cradle mlibdir opt $ loop S.empty ls mvar+ where+ opt = defaultOptions+ ls = lineSeparator opt+ LineSeparator lsc = ls+ handler (SomeException e) = do+ putStr "ghc-modi:0:0:"+ let x = intercalate lsc $ lines $ show e+ putStrLn x+ putStrLn "NG"++----------------------------------------------------------------++run :: Cradle -> Maybe FilePath -> Options -> (Logger -> Ghc a) -> IO a+run cradle mlibdir opt body = G.runGhc mlibdir $ do+ (readLog,_) <- initializeFlagsWithCradle opt cradle ["-Wall"] True+ dflags <- G.getSessionDynFlags+ G.defaultCleanupHandler dflags $ body readLog++----------------------------------------------------------------++setupDB :: Cradle -> Maybe FilePath -> Options -> MVar DB -> IO ()+setupDB cradle mlibdir opt mvar = E.handle handler $ do+ sm <- run cradle mlibdir opt $ \_ -> G.getSessionDynFlags >>= browseAll+ let sms = map tieup $ groupBy ((==) `on` fst) $ sort sm+ m = M.fromList sms+ putMVar mvar m+ where+ tieup x = (head (map fst x), map snd x)+ handler (SomeException _) = return ()++----------------------------------------------------------------++loop :: Set FilePath -> LineSeparator -> MVar DB -> Logger -> Ghc ()+loop set ls mvar readLog = do+ cmdArg <- liftIO getLine+ let (cmd,arg') = break (== ' ') cmdArg+ arg = dropWhile (== ' ') arg'+ (msgs,ok,set') <- case cmd of+ "check" -> checkStx set ls readLog arg+ "find" -> findSym set mvar arg+ "lint" -> lintStx set ls arg+ _ -> return ([], False, set)+ mapM_ (liftIO . putStrLn) msgs+ liftIO $ putStrLn $ if ok then "OK" else "NG"+ liftIO $ hFlush stdout+ when ok $ loop set' ls mvar readLog++----------------------------------------------------------------++checkStx :: Set FilePath+ -> LineSeparator+ -> Logger+ -> FilePath+ -> Ghc ([String], Bool, Set FilePath)+checkStx set ls readLog file = do+ let add = not $ S.member file set+ GE.ghandle handler $ do+ mdel <- removeMainTarget+ when add $ addTargetFiles [file]+ void $ G.load LoadAllTargets+ msgs <- liftIO readLog+ let set1 = if add then S.insert file set else set+ set2 = case mdel of+ Nothing -> set1+ Just delfl -> S.delete delfl set1+ return (msgs, True, set2)+ where+ handler :: SourceError -> Ghc ([String], Bool, Set FilePath)+ handler err = do+ errmsgs <- handleErrMsg ls err+ return (errmsgs, False, set)+ removeMainTarget = do+ mx <- find isMain <$> G.getModuleGraph+ case mx of+ Nothing -> return Nothing+ Just x -> do+ let mmainfile = G.ml_hs_file (G.ms_location x)+ -- G.ms_hspp_file x is a temporary file with CPP.+ -- this is a just fake.+ mainfile = fromMaybe (G.ms_hspp_file x) mmainfile+ if mainfile == file then+ return Nothing+ else do+ let target = TargetFile mainfile Nothing+ G.removeTarget target+ return $ Just mainfile+ isMain m = G.moduleNameString (G.moduleName (G.ms_mod m)) == "Main"++findSym :: Set FilePath -> MVar DB -> String+ -> Ghc ([String], Bool, Set FilePath)+findSym set mvar sym = do+ db <- liftIO $ readMVar mvar+ let ret = fromMaybe [] (M.lookup sym db)+ return (ret, True, set)++lintStx :: Set FilePath -> LineSeparator -> FilePath+ -> Ghc ([String], Bool, Set FilePath)+lintStx set (LineSeparator lsep) optFile = liftIO $ E.handle handler $ do+ msgs <- map (intercalate lsep . lines) <$> lint hopts file+ return (msgs, True, set)+ where+ (opt,file) = parseLintOptions optFile+ hopts = if opt == "" then [] else read opt+ -- let's continue the session+ handler (SomeException e) = do+ print e+ return ([], True, set)++-- |+-- >>> parseLintOptions "[\"--ignore=Use camelCase\", \"--ignore=Eta reduce\"] file name"+-- (["--ignore=Use camelCase", "--ignore=Eta reduce"], "file name")+-- >>> parseLintOptions "file name"+-- ([], "file name")+parseLintOptions :: String -> (String, String)+parseLintOptions optFile = case brk (== ']') (dropWhile (/= '[') optFile) of+ ("","") -> ([], optFile)+ (opt',file') -> (opt', dropWhile (== ' ') file')+ where+ brk _ [] = ([],[])+ brk p (x:xs')+ | p x = ([x],xs')+ | otherwise = let (ys,zs) = brk p xs' in (x:ys,zs)
test/CheckSpec.hs view
@@ -15,13 +15,13 @@ withDirectory_ "test/data/ghc-mod-check" $ do cradle <- findCradleWithoutSandbox res <- checkSyntax defaultOptions cradle ["main.hs"]- res `shouldBe` "main.hs:5:1:Warning: Top-level binding with no type signature: main :: IO ()\NUL\n"+ res `shouldBe` "main.hs:5:1:Warning: Top-level binding with no type signature: main :: IO ()\n" it "can check even if a test module imports another test module located at different directory" $ do withDirectory_ "test/data/check-test-subdir" $ do cradle <- findCradleWithoutSandbox res <- checkSyntax defaultOptions cradle ["test/Bar/Baz.hs"]- res `shouldSatisfy` (("test" </> "Foo.hs:3:1:Warning: Top-level binding with no type signature: foo :: [Char]\NUL\n") `isSuffixOf`)+ res `shouldSatisfy` (("test" </> "Foo.hs:3:1:Warning: Top-level binding with no type signature: foo :: [Char]\n") `isSuffixOf`) it "can detect mutually imported modules" $ do withDirectory_ "test/data" $ do
− test/DebugSpec.hs
@@ -1,23 +0,0 @@-module DebugSpec where--import Language.Haskell.GhcMod-import Test.Hspec--import Dir--checkFast :: String -> String -> IO ()-checkFast file ans = withDirectory_ "test/data" $ do- let cradle = Cradle "." Nothing Nothing [] []- res <- debugInfo defaultOptions cradle file- lines res `shouldContain` [ans]--spec :: Spec-spec = do- describe "debug" $ do- it "can check TH" $ do- checkFast "Main.hs" "Fast check: No"- checkFast "Foo.hs" "Fast check: Yes"- checkFast "Bar.hs" "Fast check: No"-- it "can check QuasiQuotes" $ do- checkFast "Baz.hs" "Fast check: No"