packages feed

ghc-mod 4.0.2 → 4.1.0

raw patch · 48 files changed

+1492/−1111 lines, 48 filesdep +deepseqdep ~hlint

Dependencies added: deepseq

Dependency ranges changed: hlint

Files

ChangeLog view
@@ -1,3 +1,19 @@+2014-04-30 v4.1.0+	* ghc-modi now provides "type", "info", and "boot".+	* ghc-mod now provides "find".+	* Packages, which are specified in a cabal file but not installed,+	  are filtered out. (@DanielG)+	* ghc-mod/ghc-modi treats "-l" properly.+	* ghc-mod obsoletes "-p". Use "ghc-mod browse package:module".+	* M-x ghc-debug has been implemented.+	* "type" and "info" can work even if files contain type errors.+	* "boot" as a new API.++2014-04-07 v4.0.2+	* The ghc-display-error option (@notogawa)+	* Fixing a file bug for Windows (@Kiripon)+	* The -b option for ghc-modi (@yuga)+ 2014-04-03 v4.0.1 	* Displaying a qualified name for one if two unqualified names 	  are conflict.
Language/Haskell/GhcMod.hs view
@@ -13,9 +13,11 @@   , ModuleString   , Expression   -- * 'IO' utilities+  , bootInfo   , browseModule   , checkSyntax   , lintSyntax+  , expandTemplate   , infoExpr   , typeExpr   , listModules@@ -24,25 +26,16 @@   , debugInfo   , rootInfo   , packageDoc-  -- * Converting the 'Ghc' monad to the 'IO' monad-  , withGHC-  , withGHCDummyFile-  -- * 'Ghc' utilities-  , browse-  , check-  , info-  , typeOf-  , listMods-  , debug-  , lint+  , findSymbol   ) where +import Language.Haskell.GhcMod.Boot import Language.Haskell.GhcMod.Browse import Language.Haskell.GhcMod.Check import Language.Haskell.GhcMod.Cradle import Language.Haskell.GhcMod.Debug+import Language.Haskell.GhcMod.Find import Language.Haskell.GhcMod.Flag-import Language.Haskell.GhcMod.GHCApi import Language.Haskell.GhcMod.Info import Language.Haskell.GhcMod.Lang import Language.Haskell.GhcMod.Lint
+ Language/Haskell/GhcMod/Boot.hs view
@@ -0,0 +1,38 @@+module Language.Haskell.GhcMod.Boot where++import Control.Applicative ((<$>))+import CoreMonad (liftIO, liftIO)+import GHC (Ghc)+import Language.Haskell.GhcMod.Browse+import Language.Haskell.GhcMod.Flag+import Language.Haskell.GhcMod.GHCApi+import Language.Haskell.GhcMod.Lang+import Language.Haskell.GhcMod.List+import Language.Haskell.GhcMod.Types++-- | Printing necessary information for front-end booting.+bootInfo :: Options -> Cradle -> IO String+bootInfo opt cradle = withGHC' $ do+    initializeFlagsWithCradle opt cradle+    boot opt++-- | Printing necessary information for front-end booting.+boot :: Options -> Ghc String+boot opt = do+    mods  <- modules opt+    langs <- liftIO $ listLanguages opt+    flags <- liftIO $ listFlags opt+    pre   <- concat <$> mapM (browse opt) preBrowsedModules+    return $ mods ++ langs ++ flags ++ pre++preBrowsedModules :: [String]+preBrowsedModules = [+    "Prelude"+  , "Control.Applicative"+  , "Control.Exception"+  , "Control.Monad"+  , "Data.Char"+  , "Data.List"+  , "Data.Maybe"+  , "System.IO"+  ]
Language/Haskell/GhcMod/Browse.hs view
@@ -5,10 +5,11 @@   where  import Control.Applicative ((<$>))-import Control.Monad (void)+import Control.Exception (SomeException(..)) import Data.Char (isAlpha) import Data.List (sort) import Data.Maybe (catMaybes)+import Exception (ghandle) import FastString (mkFastString) import GHC (Ghc, GhcException(CmdLineError), ModuleInfo, Name, TyThing, DynFlags, Type, TyCon, Module) import qualified GHC as G@@ -18,7 +19,6 @@ import Language.Haskell.GhcMod.Types import Name (getOccString) import Outputable (ppr, Outputable)-import Panic (throwGhcException) import TyCon (isAlgTyCon) import Type (dropForAlls, splitFunTy_maybe, mkFunTy, isPredTy) @@ -31,22 +31,22 @@              -> Cradle              -> ModuleString -- ^ A module name. (e.g. \"Data.List\")              -> IO String-browseModule opt cradle mdlName = convert opt . sort <$> withGHCDummyFile (browse opt cradle mdlName)+browseModule opt cradle pkgmdl = withGHC' $ do+    initializeFlagsWithCradle opt cradle+    browse opt pkgmdl  -- | Getting functions, classes, etc from a module. --   If 'detailed' is 'True', their types are also obtained. --   If 'operators' is 'True', operators are also returned. browse :: Options-       -> Cradle        -> ModuleString -- ^ A module name. (e.g. \"Data.List\")-       -> Ghc [String]-browse opt cradle mdlName = do-    void $ initializeFlagsWithCradle opt cradle [] False-    getModule >>= G.getModuleInfo >>= listExports+       -> Ghc String+browse opt pkgmdl = do+    convert opt . sort <$> (getModule >>= listExports)   where-    getModule = G.findModule mdlname mpkgid `G.gcatch` fallback-    mdlname = G.mkModuleName mdlName-    mpkgid = mkFastString <$> packageId opt+    (mpkg,mdl) = splitPkgMdl pkgmdl+    mdlname = G.mkModuleName mdl+    mpkgid = mkFastString <$> mpkg     listExports Nothing       = return []     listExports (Just mdinfo) = processExports opt mdinfo     -- findModule works only for package modules, moreover,@@ -54,12 +54,24 @@     -- to browse a local module you need to load it first.     -- If CmdLineError is signalled, we assume the user     -- tried browsing a local module.-    fallback (CmdLineError _) = loadAndFind-    fallback e                = throwGhcException e-    loadAndFind = do-      setTargetFiles [mdlName]-      void $ G.load G.LoadAllTargets-      G.findModule mdlname Nothing+    getModule = browsePackageModule `G.gcatch` fallback `G.gcatch` handler+    browsePackageModule = G.findModule mdlname mpkgid >>= G.getModuleInfo+    browseLocalModule = ghandle handler $ do+      setTargetFiles [mdl]+      G.findModule mdlname Nothing >>= G.getModuleInfo+    fallback (CmdLineError _) = browseLocalModule+    fallback _                = return Nothing+    handler (SomeException _) = return Nothing+-- |+--+-- >>> splitPkgMdl "base:Prelude"+-- (Just "base","Prelude")+-- >>> splitPkgMdl "Prelude"+-- (Nothing,"Prelude")+splitPkgMdl :: String -> (Maybe String,String)+splitPkgMdl pkgmdl = case break (==':') pkgmdl of+    (mdl,"")    -> (Nothing,mdl)+    (pkg,_:mdl) -> (Just pkg,mdl)  processExports :: Options -> ModuleInfo -> Ghc [String] processExports opt minfo = mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo
Language/Haskell/GhcMod/CabalApi.hs view
@@ -9,16 +9,19 @@   , cabalAllTargets   ) where +import Language.Haskell.GhcMod.Types+import Language.Haskell.GhcMod.GhcPkg+ import Control.Applicative ((<$>)) import Control.Exception (throwIO) import Control.Monad (filterM) import CoreMonad (liftIO)-import Data.Maybe (maybeToList)+import Data.Maybe (maybeToList, catMaybes) import Data.Set (fromList, toList) import Distribution.ModuleName (ModuleName,toFilePath) import Distribution.Package (Dependency(Dependency)-                           , PackageName(PackageName)-                           , PackageIdentifier(pkgName))+                           , PackageName(PackageName))+import qualified Distribution.Package as C import Distribution.PackageDescription (PackageDescription, BuildInfo, TestSuite, TestSuiteInterface(..), Executable) import qualified Distribution.PackageDescription as P import Distribution.PackageDescription.Configuration (finalizePackageDescription)@@ -30,35 +33,34 @@ import Distribution.Text (display) 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 (dropExtension, takeFileName, (</>))  ----------------------------------------------------------------  -- | Getting necessary 'CompilerOptions' from three information sources.-getCompilerOptions :: [GHCOption] -> Cradle -> PackageDescription -> IO CompilerOptions+getCompilerOptions :: [GHCOption]+                   -> Cradle+                   -> PackageDescription+                   -> IO CompilerOptions getCompilerOptions ghcopts cradle pkgDesc = do     gopts <- getGHCOptions ghcopts cradle rdir $ head buildInfos-    return $ CompilerOptions gopts idirs depPkgs+    dbPkgs <- ghcPkgListEx (cradlePkgDbStack cradle)+    return $ CompilerOptions gopts idirs (depPkgs dbPkgs)   where     wdir       = cradleCurrentDir cradle     rdir       = cradleRootDir    cradle     Just cfile = cradleCabalFile  cradle-    pkgs       = cradlePackages   cradle+    thisPkg    = dropExtension $ takeFileName cfile     buildInfos = cabalAllBuildInfo pkgDesc     idirs      = includeDirectories rdir wdir $ cabalSourceDirs buildInfos-    depPkgs    = attachPackageIds pkgs $ removeThem problematicPackages $ removeMe cfile $ cabalDependPackages buildInfos+    depPkgs ps = attachPackageIds ps+                   $ removeThem (problematicPackages ++ [thisPkg])+                   $ cabalDependPackages buildInfos  ---------------------------------------------------------------- -- Dependent packages -removeMe :: FilePath -> [PackageBaseName] -> [PackageBaseName]-removeMe cabalfile = filter (/= me)-  where-    me = dropExtension $ takeFileName cabalfile- removeThem :: [PackageBaseName] -> [PackageBaseName] -> [PackageBaseName] removeThem badpkgs = filter (`notElem` badpkgs) @@ -68,12 +70,14 @@   ]  attachPackageIds :: [Package] -> [PackageBaseName] -> [Package]-attachPackageIds pkgs = map attachId-  where-    attachId x = case lookup x pkgs of-      Nothing -> (x, Nothing)-      Just p -> (x, p)+attachPackageIds pkgs = catMaybes . fmap (`lookup3` pkgs) +lookup3 :: Eq a => a -> [(a,b,c)] -> Maybe (a,b,c)+lookup3 _ [] = Nothing+lookup3 k (t@(a,_,_):ls)+    | k == a = Just t+    | otherwise = lookup3 k ls+ ---------------------------------------------------------------- -- Include directories for modules @@ -104,7 +108,7 @@     toPkgDesc cid = finalizePackageDescription [] (const True) buildPlatform cid []     nullPkg pd = name == ""       where-        PackageName name = pkgName (P.package pd)+        PackageName name = C.pkgName (P.package pd)  ---------------------------------------------------------------- @@ -114,7 +118,7 @@     let cpps = map ("-optP" ++) $ P.cppOptions binfo ++ cabalCpp     return $ ghcopts ++ pkgDb ++ exts ++ [lang] ++ libs ++ libDirs ++ cpps   where-    pkgDb = userPackageDbOptsForGhc $ cradlePackageDb cradle+    pkgDb = ghcDbStackOpts $ cradlePkgDbStack cradle     lang = maybe "-XHaskell98" (("-X" ++) . display) $ P.defaultLanguage binfo     libDirs = map ("-L" ++) $ P.extraLibDirs binfo     exts = map (("-X" ++) . display) $ P.usedExtensions binfo@@ -134,11 +138,16 @@  -- | Extracting all 'BuildInfo' for libraries, executables, and tests. cabalAllBuildInfo :: PackageDescription -> [BuildInfo]-cabalAllBuildInfo pd = libBI ++ execBI ++ testBI+cabalAllBuildInfo pd = libBI ++ execBI ++ testBI ++ benchBI   where     libBI   = map P.libBuildInfo       $ maybeToList $ P.library pd     execBI  = map P.buildInfo          $ P.executables pd     testBI  = map P.testBuildInfo      $ P.testSuites pd+#if __GLASGOW_HASKELL__ >= 704+    benchBI = map P.benchmarkBuildInfo $ P.benchmarks pd+#else+    benchBI = []+#endif  ---------------------------------------------------------------- @@ -211,4 +220,3 @@     getExecutableTarget exe = do       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,12 +1,15 @@-module Language.Haskell.GhcMod.Check (checkSyntax, check) where+module Language.Haskell.GhcMod.Check (+    checkSyntax+  , check+  , expandTemplate+  , expand+  ) where  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 GHC (Ghc) import Language.Haskell.GhcMod.GHCApi+import qualified Language.Haskell.GhcMod.Gap as Gap+import Language.Haskell.GhcMod.Logger import Language.Haskell.GhcMod.Types  ----------------------------------------------------------------@@ -17,8 +20,10 @@             -> Cradle             -> [FilePath]  -- ^ The target files.             -> IO String-checkSyntax _   _      []    = error "ghc-mod: checkSyntax: No files given"-checkSyntax opt cradle files = unlines <$> withGHC sessionName (check opt cradle files)+checkSyntax _   _      []    = return ""+checkSyntax opt cradle files = withGHC sessionName $ do+    initializeFlagsWithCradle opt cradle+    either id id <$> check opt files   where     sessionName = case files of       [file] -> file@@ -29,18 +34,32 @@ -- | Checking syntax of a target file using GHC. --   Warnings and errors are returned. check :: Options-      -> Cradle       -> [FilePath]  -- ^ The target files.-      -> Ghc [String]-check _   _      []        = error "ghc-mod: check: No files given"-check opt cradle fileNames = checkIt `G.gcatch` handleErrMsg ls+      -> Ghc (Either String String)+check opt fileNames = withLogger opt setAllWaringFlags $+    setTargetFiles fileNames++----------------------------------------------------------------++-- | Expanding Haskell Template.+expandTemplate :: Options+               -> Cradle+               -> [FilePath]  -- ^ The target files.+               -> IO String+expandTemplate _   _      []    = return ""+expandTemplate opt cradle files = withGHC sessionName $ do+    initializeFlagsWithCradle opt cradle+    either id id <$> expand opt files   where-    checkIt = do-        (readLog,_) <- initializeFlagsWithCradle opt cradle options True-        setTargetFiles fileNames-        void $ G.load LoadAllTargets-        liftIO readLog-    options-      | expandSplice opt = "-w:"   : ghcOpts opt-      | otherwise        = "-Wall" : ghcOpts opt-    ls = lineSeparator opt+    sessionName = case files of+      [file] -> file+      _      -> "MultipleFiles"++----------------------------------------------------------------++-- | Expanding Haskell Template.+expand :: Options+      -> [FilePath]  -- ^ The target files.+      -> Ghc (Either String String)+expand opt fileNames = withLogger opt (Gap.setDumpSplices . setNoWaringFlags) $+    setTargetFiles fileNames
Language/Haskell/GhcMod/Cradle.hs view
@@ -1,25 +1,18 @@-{-# LANGUAGE BangPatterns #-}- module Language.Haskell.GhcMod.Cradle (     findCradle   , findCradleWithoutSandbox-  , getPackageDbDir-  , getPackageDbPackages-  , userPackageDbOptsForGhc-  , userPackageDbOptsForGhcPkg-  , getSandboxDir   ) where +import Language.Haskell.GhcMod.Types+import Language.Haskell.GhcMod.GhcPkg+ import Control.Applicative ((<$>))-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 Data.List (isSuffixOf) import System.Directory (getCurrentDirectory, getDirectoryContents, doesFileExist)-import System.FilePath ((</>), takeDirectory, takeFileName)+import System.FilePath ((</>), takeDirectory)  ---------------------------------------------------------------- @@ -35,25 +28,23 @@ cabalCradle :: FilePath -> IO Cradle cabalCradle wdir = do     (rdir,cfile) <- cabalDir wdir-    pkgDbOpts <- getPackageDb rdir+    pkgDbStack <- getPackageDbStack rdir     return Cradle {         cradleCurrentDir = wdir       , cradleRootDir    = rdir       , cradleCabalFile  = Just cfile-      , cradlePackageDb  = pkgDbOpts-      , cradlePackages   = []+      , cradlePkgDbStack = pkgDbStack       }  sandboxCradle :: FilePath -> IO Cradle sandboxCradle wdir = do     rdir <- getSandboxDir wdir-    pkgDbOpts <- getPackageDb rdir+    pkgDbStack <- getPackageDbStack rdir     return Cradle {         cradleCurrentDir = wdir       , cradleRootDir    = rdir       , cradleCabalFile  = Nothing-      , cradlePackageDb  = pkgDbOpts-      , cradlePackages   = []+      , cradlePkgDbStack = pkgDbStack       }  plainCradle :: FilePath -> IO Cradle@@ -61,15 +52,14 @@         cradleCurrentDir = wdir       , cradleRootDir    = wdir       , cradleCabalFile  = Nothing-      , cradlePackageDb  = Nothing-      , cradlePackages   = []+      , cradlePkgDbStack = [GlobalDb]       }  -- Just for testing findCradleWithoutSandbox :: IO Cradle findCradleWithoutSandbox = do     cradle <- findCradle-    return cradle { cradlePackageDb = Nothing, cradlePackages = [] }+    return cradle { cradlePkgDbStack = [GlobalDb]}  ---------------------------------------------------------------- @@ -103,121 +93,6 @@  ---------------------------------------------------------------- -configFile :: String-configFile = "cabal.sandbox.config"--pkgDbKey :: String-pkgDbKey = "package-db:"--pkgDbKeyLen :: Int-pkgDbKeyLen = length pkgDbKey---- | Obtaining GHC options relating to a package db directory-getPackageDb :: FilePath -> IO (Maybe FilePath)-getPackageDb cdir = (Just <$> getPkgDb) `E.catch` handler-  where-    getPkgDb = getPackageDbDir (cdir </> configFile)-    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.-getPackageDbDir :: FilePath -> IO FilePath-getPackageDbDir sconf = do-    -- Be strict to ensure that an error can be caught.-    !path <- extractValue . parse <$> readFile sconf-    return path-  where-    parse = head . filter ("package-db:" `isPrefixOf`) . lines-    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) []---- | Creating user package db options for GHC.------ >>> 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"]--- >>> 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"]-userPackageDbOptsForGhc :: Maybe FilePath -> [String]-userPackageDbOptsForGhc Nothing      = []-userPackageDbOptsForGhc (Just pkgDb) = [noUserPkgDbOpt, pkgDbOpt, pkgDb]-  where-    ver = extractGhcVer pkgDb-    (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.------ >>> extractGhcVer "/foo/bar/i386-osx-ghc-7.6.3-packages.conf.d"--- 706-extractGhcVer :: String -> Int-extractGhcVer dir = ver-  where-    file = takeFileName dir-    findVer = drop 4 . head . filter ("ghc-" `isPrefixOf`) . tails-    (verStr1,_:left) = break (== '.') $ findVer file-    (verStr2,_)      = break (== '.') left-    ver = read verStr1 * 100 + read verStr2---- | Obtaining packages installed in a package db directory.-getPackageDbPackages :: FilePath -> IO [Package]-getPackageDbPackages cdir = (getPkgDb >>= listDbPackages) `E.catch` handler-  where-    getPkgDb = getPackageDbDir (cdir </> configFile)-    handler :: SomeException -> IO [Package]-    handler _ = return []--listDbPackages :: FilePath -> IO [Package]-listDbPackages pkgdir = do-  files <- filter (".conf" `isSuffixOf`) <$> getDirectoryContents pkgdir-  mapM (extractPackage . (pkgdir </>)) files--extractPackage :: FilePath -> IO Package-extractPackage pconf = do-  contents <- lines <$> readFile pconf-  -- Be strict to ensure that an error can be caught.-  let !name = extractName $ parseName contents-      !pid = extractId $ parseId contents-  return (name, Just pid)-  where-    parseName = parse nameKey-    extractName = extract nameKeyLength-    parseId = parse idKey-    extractId = extract idKeyLength-    parse key = head . filter (key `isPrefixOf`)-    extract keylen = takeWhile (not . isSpace) . dropWhile isSpace . drop keylen--nameKey :: String-nameKey = "name:"--idKey :: String-idKey = "id:"--nameKeyLength :: Int-nameKeyLength = length nameKey--idKeyLength :: Int-idKeyLength = length idKey- getSandboxDir :: FilePath -> IO FilePath getSandboxDir dir = do     exist <- doesFileExist sfile@@ -228,5 +103,5 @@       else         getSandboxDir dir'   where-    sfile = dir </> configFile+    sfile = dir </> "cabal.sandbox.config"     dir' = takeDirectory dir
Language/Haskell/GhcMod/Debug.hs view
@@ -1,12 +1,10 @@-module Language.Haskell.GhcMod.Debug (debugInfo, debug, rootInfo, root) where+module Language.Haskell.GhcMod.Debug (debugInfo, rootInfo) where  import Control.Applicative ((<$>)) import Control.Exception.IOChoice ((||>))-import Control.Monad (void) import CoreMonad (liftIO) import Data.List (intercalate) import Data.Maybe (fromMaybe, isJust, fromJust)-import GHC (Ghc) import Language.Haskell.GhcMod.CabalApi import Language.Haskell.GhcMod.GHCApi import Language.Haskell.GhcMod.Types@@ -16,30 +14,22 @@ -- | Obtaining debug information. debugInfo :: Options           -> Cradle-          -> FilePath   -- ^ A target file.           -> IO String-debugInfo opt cradle fileName = unlines <$> withGHC fileName (debug opt cradle fileName)---- | Obtaining debug information.-debug :: Options-      -> Cradle-      -> FilePath     -- ^ A target file.-      -> Ghc [String]-debug opt cradle fileName = do+debugInfo opt cradle = convert opt <$> do     CompilerOptions gopts incDir pkgs <-         if cabal then             liftIO (fromCabalFile ||> return simpleCompilerOption)           else             return simpleCompilerOption-    void $ initializeFlagsWithCradle opt cradle gopts True-    setTargetFiles [fileName]+    mglibdir <- liftIO getSystemLibDir     return [         "Root directory:      " ++ rootDir       , "Current directory:   " ++ currentDir       , "Cabal file:          " ++ cabalFile       , "GHC options:         " ++ unwords gopts       , "Include directories: " ++ unwords incDir-      , "Dependent packages:  " ++ intercalate ", " (map fst pkgs)+      , "Dependent packages:  " ++ intercalate ", " (map showPkg pkgs)+      , "System libraries:    " ++ fromMaybe "" mglibdir       ]   where     currentDir = cradleCurrentDir cradle@@ -49,7 +39,9 @@     cabalFile = fromMaybe "" mCabalFile     origGopts = ghcOpts opt     simpleCompilerOption = CompilerOptions origGopts [] []-    fromCabalFile = parseCabalFile file >>= getCompilerOptions origGopts cradle+    fromCabalFile = do+        pkgDesc <- parseCabalFile file+        getCompilerOptions origGopts cradle pkgDesc       where         file = fromJust mCabalFile @@ -58,13 +50,5 @@ -- | 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"+rootInfo opt cradle = return $ convert opt $ cradleRootDir cradle
Language/Haskell/GhcMod/Doc.hs view
@@ -1,7 +1,6 @@ module Language.Haskell.GhcMod.Doc where -import DynFlags (DynFlags)-import GHC (Ghc)+import GHC (Ghc, DynFlags) import qualified GHC as G import Language.Haskell.GhcMod.Gap (withStyle, showDocWith) import Outputable (SDoc, PprStyle, mkUserStyle, Depth(AllTheWay), neverQualify)
− Language/Haskell/GhcMod/ErrMsg.hs 
@@ -1,101 +0,0 @@-{-# LANGUAGE BangPatterns, CPP #-}--module Language.Haskell.GhcMod.ErrMsg (-    LogReader-  , setLogger-  , handleErrMsg-  ) where--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 (showPage, getStyle)-import qualified Language.Haskell.GhcMod.Gap as Gap-import Language.Haskell.GhcMod.Types (LineSeparator(..))-import Outputable (PprStyle, SDoc)-import System.FilePath (normalise)---------------------------------------------------------------------- | A means to read the log.-type LogReader = IO [String]--------------------------------------------------------------------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 -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()-appendLogRef df ls (LogRef ref) _ sev src style msg = do-        let !l = ppMsg src sev df ls style 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-    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 <- G.getSessionDynFlags-    style <- getStyle-    return . errBagToStrList dflag ls style . srcErrorMessages $ err--errBagToStrList :: DynFlags -> LineSeparator -> PprStyle -> Bag ErrMsg -> [String]-errBagToStrList dflag ls style = map (ppErrMsg dflag ls style) . reverse . bagToList--------------------------------------------------------------------ppErrMsg :: DynFlags -> LineSeparator -> PprStyle -> ErrMsg -> String-ppErrMsg dflag ls style err = ppMsg spn SevError dflag ls style msg ++ ext-   where-     spn = Gap.errorMsgSpan err-     msg = errMsgShortDoc err-     ext = showMsg dflag ls style (errMsgExtraInfo err)--ppMsg :: SrcSpan -> Severity-> DynFlags -> LineSeparator -> PprStyle -> SDoc -> String-ppMsg spn sev dflag ls style msg = prefix ++ cts-  where-    cts  = showMsg dflag ls style msg-    defaultPrefix-      | dopt Gap.dumpSplicesFlag dflag = ""-      | otherwise                      = "Dummy:0:0:Error:"-    prefix = fromMaybe defaultPrefix $ do-        (line,col,_,_) <- Gap.getSrcSpan spn-        file <- normalise <$> Gap.getSrcFile spn-        let severityCaption = Gap.showSeverityCaption sev-        return $ file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption--------------------------------------------------------------------showMsg :: DynFlags -> LineSeparator -> PprStyle -> SDoc -> String-showMsg dflag (LineSeparator lsep) style sdoc = replaceNull $ showPage dflag style sdoc-  where-    replaceNull []        = []-    replaceNull ('\n':xs) = lsep ++ replaceNull xs-    replaceNull (x:xs)    = x : replaceNull xs
+ Language/Haskell/GhcMod/Find.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE CPP, BangPatterns #-}++module Language.Haskell.GhcMod.Find where++import Data.Function (on)+import Data.List (groupBy, sort)+import Data.Maybe (fromMaybe)+import GHC (Ghc)+import qualified GHC as G+import Language.Haskell.GhcMod.Browse (browseAll)+import Language.Haskell.GhcMod.GHCApi+import Language.Haskell.GhcMod.Types++#ifndef MIN_VERSION_containers+#define MIN_VERSION_containers(x,y,z) 1+#endif++#if MIN_VERSION_containers(0,5,0)+import Control.DeepSeq (force)+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 Control.Applicative ((<$>))++-- | Type of key for `SymMdlDb`.+type Symbol = String+-- | Database from 'Symbol' to modules.+newtype SymMdlDb = SymMdlDb (Map Symbol [ModuleString])++-- | Finding modules to which the symbol belong.+findSymbol :: Options -> Cradle -> Symbol -> IO String+findSymbol opt cradle sym = withGHC' $ do+    initializeFlagsWithCradle opt cradle+    lookupSym opt sym <$> getSymMdlDb++-- | Creating 'SymMdlDb'.+getSymMdlDb :: Ghc SymMdlDb+getSymMdlDb = do+    sm <- G.getSessionDynFlags >>= browseAll+#if MIN_VERSION_containers(0,5,0)+    let !sms = force $ map tieup $ groupBy ((==) `on` fst) $ sort sm+        !m = force $ M.fromList sms+#else+    let !sms = map tieup $ groupBy ((==) `on` fst) $ sort sm+        !m = M.fromList sms+#endif+    return (SymMdlDb m)+  where+    tieup x = (head (map fst x), map snd x)++-- | Looking up 'SymMdlDb' with 'Symbol' to find modules.+lookupSym :: Options -> Symbol -> SymMdlDb -> String+lookupSym opt sym (SymMdlDb db) = convert opt $ fromMaybe [] (M.lookup sym db)
Language/Haskell/GhcMod/GHCApi.hs view
@@ -1,33 +1,33 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables, RecordWildCards #-}  module Language.Haskell.GhcMod.GHCApi (     withGHC-  , withGHCDummyFile-  , initializeFlags+  , withGHC'   , initializeFlagsWithCradle   , setTargetFiles-  , addTargetFiles   , getDynamicFlags   , getSystemLibDir+  , withDynFlags+  , setNoWaringFlags+  , setAllWaringFlags   ) where -import Control.Applicative (Alternative, (<$>))-import Control.Monad (void, forM)+import Language.Haskell.GhcMod.CabalApi+import Language.Haskell.GhcMod.GHCChoice+import Language.Haskell.GhcMod.GhcPkg++import Control.Applicative ((<$>))+import Control.Monad (forM, void) import CoreMonad (liftIO) import Data.Maybe (isJust, fromJust)-import Distribution.PackageDescription (PackageDescription)-import DynFlags (dopt_set) import Exception (ghandle, SomeException(..))-import GHC (Ghc, GhcMonad, DynFlags(..), GhcLink(..), HscTarget(..))+import GHC (Ghc, GhcMonad, DynFlags(..), GhcLink(..), HscTarget(..), LoadHowMuch(..)) 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 (exitSuccess) import System.IO (hPutStr, hPrint, stderr)+import System.IO.Unsafe (unsafePerformIO) import System.Process (readProcess)  ----------------------------------------------------------------@@ -43,26 +43,24 @@ ----------------------------------------------------------------  -- | Converting the 'Ghc' monad to the 'IO' monad.-withGHCDummyFile :: Alternative m => Ghc (m a) -- ^ 'Ghc' actions created by the Ghc utilities.-                                  -> IO (m a)-withGHCDummyFile = withGHC "Dummy"---- | Converting the 'Ghc' monad to the 'IO' monad.-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 = do-    mlibdir <- getSystemLibDir-    ghandle ignore $ G.runGhc mlibdir $ do-        dflags <- G.getSessionDynFlags-        G.defaultCleanupHandler dflags body+withGHC :: FilePath  -- ^ A target file displayed in an error message.+        -> Ghc a -- ^ 'Ghc' actions created by the Ghc utilities.+        -> IO a+withGHC file body = ghandle ignore $ withGHC' body   where-    ignore :: Alternative m => SomeException -> IO (m a)+    ignore :: SomeException -> IO a     ignore e = do         hPutStr stderr $ file ++ ":0:0:Error:"         hPrint stderr e         exitSuccess +withGHC' :: Ghc a -> IO a+withGHC' body = do+    mlibdir <- getSystemLibDir+    G.runGhc mlibdir $ do+        dflags <- G.getSessionDynFlags+        G.defaultCleanupHandler dflags body+ ----------------------------------------------------------------  importDirs :: [IncludeDir]@@ -73,104 +71,93 @@ -- | Initialize the 'DynFlags' relating to the compilation of a single -- file or GHC session according to the 'Cradle' and 'Options' -- provided.-initializeFlagsWithCradle :: GhcMonad m =>  Options -> Cradle -> [GHCOption] -> Bool -> m (LogReader, Maybe PackageDescription)-initializeFlagsWithCradle opt cradle ghcopts logging+initializeFlagsWithCradle :: GhcMonad m+        => Options+        -> Cradle+        -> m ()+initializeFlagsWithCradle opt cradle   | cabal     = withCabal |||> withSandbox   | otherwise = withSandbox   where     mCradleFile = cradleCabalFile cradle     cabal = isJust mCradleFile+    ghcopts = ghcOpts opt     withCabal = do         pkgDesc <- liftIO $ parseCabalFile $ fromJust mCradleFile         compOpts <- liftIO $ getCompilerOptions ghcopts cradle pkgDesc-        logger <- initSession CabalPkg opt compOpts logging-        return (logger, Just pkgDesc)-    withSandbox = do-        logger <- initSession SingleFile opt compOpts logging-        return (logger, Nothing)+        initSession CabalPkg opt compOpts+    withSandbox = initSession SingleFile opt compOpts       where-        pkgDb = userPackageDbOptsForGhc $ cradlePackageDb cradle+        pkgOpts = ghcDbStackOpts $ cradlePkgDbStack cradle         compOpts-          | null pkgDb = CompilerOptions ghcopts importDirs []-          | otherwise  = CompilerOptions (ghcopts ++ pkgDb) [wdir,rdir] []+          | null pkgOpts = CompilerOptions ghcopts importDirs []+          | otherwise    = CompilerOptions (ghcopts ++ pkgOpts) [wdir,rdir] []         wdir = cradleCurrentDir cradle         rdir = cradleRootDir    cradle  ---------------------------------------------------------------- -initSession :: GhcMonad m => Build+initSession :: GhcMonad m+            => Build             -> Options             -> CompilerOptions-            -> Bool-            -> m LogReader-initSession build opt compOpts logging = do-    dflags0 <- G.getSessionDynFlags-    (dflags1,readLog) <- setupDynamicFlags dflags0-    _ <- G.setSessionDynFlags dflags1-    return readLog-  where-    cmdOpts = ghcOptions compOpts-    idirs   = includeDirs compOpts-    depPkgs = depPackages compOpts-    ls = lineSeparator opt-    setupDynamicFlags df0 = do-        df1 <- modifyFlagsWithOpts df0 cmdOpts-        let df2 = modifyFlags df1 idirs depPkgs (expandSplice opt) build-        df3 <- modifyFlagsWithOpts df2 $ ghcOpts opt-        liftIO $ setLogger logging df3 ls+            -> m ()+initSession build Options {..} CompilerOptions {..} = do+    df <- G.getSessionDynFlags+    void $ G.setSessionDynFlags =<< (addCmdOpts ghcOptions+      $ setLinkerOptions+      $ setIncludeDirs includeDirs+      $ setBuildEnv build+      $ setEmptyLogger+      $ Gap.addPackageFlags depPackages df) +setEmptyLogger :: DynFlags -> DynFlags+setEmptyLogger df = Gap.setLogAction df $ \_ _ _ _ _ -> return ()+ ---------------------------------------------------------------- --- | Initialize the 'DynFlags' relating to the compilation of a single--- file or GHC session.-initializeFlags :: GhcMonad m => Options -> m ()-initializeFlags opt = do-    dflags0 <- G.getSessionDynFlags-    dflags1 <- modifyFlagsWithOpts dflags0 $ ghcOpts opt-    void $ G.setSessionDynFlags dflags1+-- we don't want to generate object code so we compile to bytecode+-- (HscInterpreted) which implies LinkInMemory+-- HscInterpreted+setLinkerOptions :: DynFlags -> DynFlags+setLinkerOptions df = df {+    ghcLink   = LinkInMemory+  , hscTarget = HscInterpreted+  } -----------------------------------------------------------------+setIncludeDirs :: [IncludeDir] -> DynFlags -> DynFlags+setIncludeDirs idirs df = df { importPaths = idirs } -modifyFlags :: DynFlags -> [IncludeDir] -> [Package] -> Bool -> Build -> DynFlags-modifyFlags d0 idirs depPkgs splice build-  | splice    = setSplice d4-  | otherwise = d4-  where-    d1 = d0 { importPaths = idirs }-    d2 = d1 {-        ghcLink   = LinkInMemory-      , hscTarget = HscInterpreted-      }-    d3 = Gap.addDevPkgs d2 depPkgs-    d4 | build == CabalPkg = Gap.setCabalPkg d3-       | otherwise         = d3+setBuildEnv :: Build -> DynFlags -> DynFlags+setBuildEnv build = setHideAllPackages build . setCabalPackage build -setSplice :: DynFlags -> DynFlags-setSplice dflag = dopt_set dflag Gap.dumpSplicesFlag+-- At the moment with this option set ghc only prints different error messages,+-- suggesting the user to add a hidden package to the build-depends in his cabal+-- file for example+setCabalPackage :: Build -> DynFlags -> DynFlags+setCabalPackage CabalPkg df = Gap.setCabalPkg df+setCabalPackage _ df = df -----------------------------------------------------------------+-- | Enable hiding of all package not explicitly exposed (like Cabal does)+setHideAllPackages :: Build -> DynFlags -> DynFlags+setHideAllPackages CabalPkg df = Gap.setHideAllPackages df+setHideAllPackages _ df = df -modifyFlagsWithOpts :: GhcMonad m => DynFlags -> [GHCOption] -> m DynFlags-modifyFlagsWithOpts dflags cmdOpts =-    tfst <$> G.parseDynamicFlags dflags (map G.noLoc cmdOpts)+-- | Parse command line ghc options and add them to the 'DynFlags' passed+addCmdOpts :: GhcMonad m => [GHCOption] -> DynFlags -> m DynFlags+addCmdOpts cmdOpts df =+    tfst <$> G.parseDynamicFlags df (map G.noLoc cmdOpts)   where     tfst (a,_,_) = a  ---------------------------------------------------------------- --- | Set the files that GHC will load / compile.+-- | Set the files as targets and load them. setTargetFiles :: (GhcMonad m) => [FilePath] -> m ()-setTargetFiles [] = error "ghc-mod: setTargetFiles: No target files given" setTargetFiles files = do     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+    void $ G.load LoadAllTargets  ---------------------------------------------------------------- @@ -179,3 +166,30 @@ getDynamicFlags = do     mlibdir <- getSystemLibDir     G.runGhc mlibdir G.getSessionDynFlags++withDynFlags :: (DynFlags -> DynFlags) -> Ghc a -> Ghc a+withDynFlags setFlag body = G.gbracket setup teardown (\_ -> body)+  where+    setup = do+        dflag <- G.getSessionDynFlags+        void $ G.setSessionDynFlags (setFlag dflag)+        return dflag+    teardown = void . G.setSessionDynFlags++----------------------------------------------------------------++-- | Set 'DynFlags' equivalent to "-w:".+setNoWaringFlags :: DynFlags -> DynFlags+setNoWaringFlags df = df { warningFlags = Gap.emptyWarnFlags}++-- | Set 'DynFlags' equivalent to "-Wall".+setAllWaringFlags :: DynFlags -> DynFlags+setAllWaringFlags df = df { warningFlags = allWarningFlags }++allWarningFlags :: Gap.WarnFlags+allWarningFlags = unsafePerformIO $ do+    mlibdir <- getSystemLibDir+    G.runGhc mlibdir $ do+        df <- G.getSessionDynFlags+        df' <- addCmdOpts ["-Wall"] df+        return $ G.warningFlags df'
Language/Haskell/GhcMod/Gap.hs view
@@ -5,15 +5,18 @@   , mkTarget   , withStyle   , setLogAction-  , supportedExtensions   , getSrcSpan   , getSrcFile-  , setCtx+  , withContext   , fOptions   , toStringBuffer   , showSeverityCaption   , setCabalPkg-  , addDevPkgs+  , setHideAllPackages+  , addPackageFlags+  , setDeferTypeErrors+  , setDumpSplices+  , isDumpSplices   , filterOutChildren   , infoThing   , pprInfo@@ -21,14 +24,12 @@   , errorMsgSpan   , typeForUser   , deSugar-#if __GLASGOW_HASKELL__ >= 702-#else-  , module Pretty-#endif   , showDocWith   , GapThing(..)   , fromTyThing-  , dumpSplicesFlag+  , fileModSummary+  , WarnFlags+  , emptyWarnFlags   ) where  import Control.Applicative hiding (empty)@@ -55,7 +56,8 @@ import qualified InstEnv import qualified Pretty import qualified StringBuffer as SB-#if __GLASGOW_HASKELL__ >= 707++#if __GLASGOW_HASKELL__ >= 708 import FamInstEnv import ConLike (ConLike(..)) import PatSyn (patSynType)@@ -67,18 +69,14 @@ import GHC hiding (ClsInst) #else import GHC hiding (Instance)-#endif--#if __GLASGOW_HASKELL__ < 702-import CoreMonad (liftIO)-import Pretty-#endif--#if __GLASGOW_HASKELL__ < 706 import Control.Arrow hiding ((<+>)) import Data.Convertible #endif +#if __GLASGOW_HASKELL__ >= 704+import qualified Data.IntSet as I (IntSet, empty)+#endif+ ---------------------------------------------------------------- ---------------------------------------------------------------- --@@ -116,7 +114,7 @@ #endif  showDocWith :: DynFlags -> Pretty.Mode -> Pretty.Doc -> String-#if __GLASGOW_HASKELL__ >= 707+#if __GLASGOW_HASKELL__ >= 708 -- Pretty.showDocWith disappeard. -- https://github.com/ghc/ghc/commit/08a3536e4246e323fbcd8040e0b80001950fe9bc showDocWith dflags mode = Pretty.showDoc mode (pprCols dflags)@@ -127,16 +125,6 @@ ---------------------------------------------------------------- ---------------------------------------------------------------- -supportedExtensions :: [String]-#if __GLASGOW_HASKELL__ >= 700-supportedExtensions = supportedLanguagesAndExtensions-#else-supportedExtensions = supportedLanguages-#endif------------------------------------------------------------------------------------------------------------------------------------ getSrcSpan :: SrcSpan -> Maybe (Int,Int,Int,Int) #if __GLASGOW_HASKELL__ >= 702 getSrcSpan (RealSrcSpan spn)@@ -173,41 +161,51 @@ fOptions = [option | (option,_,_) <- fFlags]         ++ [option | (option,_,_) <- fWarningFlags]         ++ [option | (option,_,_) <- fLangFlags]-#elif __GLASGOW_HASKELL__ == 702+#else fOptions = [option | (option,_,_,_) <- fFlags]         ++ [option | (option,_,_,_) <- fWarningFlags]         ++ [option | (option,_,_,_) <- fLangFlags]-#else-fOptions = [option | (option,_,_) <- fFlags] #endif  ---------------------------------------------------------------- ---------------------------------------------------------------- -setCtx :: [ModSummary] -> Ghc Bool+fileModSummary :: FilePath -> Ghc ModSummary+fileModSummary file = do+    mss <- getModuleGraph+    let [ms] = filter (\m -> ml_hs_file (ms_location m) == Just file) mss+    return ms++withContext :: Ghc a -> Ghc a+withContext action = gbracket setup teardown body+  where+    setup = getContext+    teardown = setCtx+    body _ = do+        topImports >>= setCtx+        action+    topImports = do+        mss <- getModuleGraph+        ms <- map modName <$> filterM isTop mss #if __GLASGOW_HASKELL__ >= 704-setCtx ms = do-#if __GLASGOW_HASKELL__ >= 706-    let modName = IIModule . moduleName . ms_mod+        return ms #else-    let modName = IIModule . ms_mod+        return (ms,[]) #endif-    top <- map modName <$> filterM isTop ms-    setContext top-    return (not . null $ top)+    isTop mos = lookupMod mos ||> returnFalse+    lookupMod mos = lookupModule (ms_mod_name mos) Nothing >> return True+    returnFalse = return False+#if __GLASGOW_HASKELL__ >= 706+    modName = IIModule . moduleName . ms_mod+    setCtx = setContext+#elif __GLASGOW_HASKELL__ >= 704+    modName = IIModule . ms_mod+    setCtx = setContext #else-setCtx ms = do-    top <- map ms_mod <$> filterM isTop ms-    setContext top []-    return (not . null $ top)+    modName = ms_mod+    setCtx = uncurry setContext #endif-  where-    isTop mos = lookupMod ||> returnFalse-      where-        lookupMod = lookupModule (ms_mod_name mos) Nothing >> return True-        returnFalse = return False - showSeverityCaption :: Severity -> String #if __GLASGOW_HASKELL__ >= 706 showSeverityCaption SevWarning = "Warning: "@@ -220,7 +218,7 @@ ----------------------------------------------------------------  setCabalPkg :: DynFlags -> DynFlags-#if __GLASGOW_HASKELL__ >= 707+#if __GLASGOW_HASKELL__ >= 708 setCabalPkg dflag = gopt_set dflag Opt_BuildingCabalPackage #else setCabalPkg dflag = dopt_set dflag Opt_BuildingCabalPackage@@ -228,20 +226,38 @@  ---------------------------------------------------------------- -addDevPkgs :: DynFlags -> [Package] -> DynFlags-addDevPkgs df []   = df-addDevPkgs df pkgs = df''+setHideAllPackages :: DynFlags -> DynFlags+#if __GLASGOW_HASKELL__ >= 708+setHideAllPackages df = gopt_set df Opt_HideAllPackages+#else+setHideAllPackages df = dopt_set df Opt_HideAllPackages+#endif++addPackageFlags :: [Package] -> DynFlags -> DynFlags+addPackageFlags pkgs df =+    df { packageFlags = packageFlags df ++ expose `map` pkgs }   where-#if __GLASGOW_HASKELL__ >= 707-    df' = gopt_set df Opt_HideAllPackages+    expose pkg = ExposePackageId $ showPkgId pkg++----------------------------------------------------------------++setDumpSplices :: DynFlags -> DynFlags+setDumpSplices dflag = dopt_set dflag Opt_D_dump_splices++isDumpSplices :: DynFlags -> Bool+isDumpSplices dflag = dopt Opt_D_dump_splices dflag++----------------------------------------------------------------+++setDeferTypeErrors :: DynFlags -> DynFlags+#if __GLASGOW_HASKELL__ >= 708+setDeferTypeErrors dflag = gopt_set dflag Opt_DeferTypeErrors+#elif __GLASGOW_HASKELL__ >= 706+setDeferTypeErrors dflag = dopt_set dflag Opt_DeferTypeErrors #else-    df' = dopt_set df Opt_HideAllPackages+setDeferTypeErrors = id #endif-    df'' = df' {-        packageFlags = map expose pkgs ++ packageFlags df-      }-    expose (pkg, Nothing) = ExposePackage pkg-    expose (_, Just pid) = ExposePackageId pid  ---------------------------------------------------------------- ----------------------------------------------------------------@@ -251,7 +267,7 @@   instance HasType (LHsBind Id) where-#if __GLASGOW_HASKELL__ >= 707+#if __GLASGOW_HASKELL__ >= 708     getType _ (L spn FunBind{fun_matches = MG _ in_tys out_typ}) = return $ Just (spn, typ)       where typ = mkFunTys in_tys out_typ #else@@ -272,7 +288,7 @@ infoThing :: String -> Ghc SDoc infoThing str = do     names <- parseName str-#if __GLASGOW_HASKELL__ >= 707+#if __GLASGOW_HASKELL__ >= 708     mb_stuffs <- mapM (getInfo False) names     let filtered = filterOutChildren (\(t,_f,_i,_fam) -> t) (catMaybes mb_stuffs) #else@@ -281,7 +297,7 @@ #endif     return $ vcat (intersperse (text "") $ map (pprInfo False) filtered) -#if __GLASGOW_HASKELL__ >= 707+#if __GLASGOW_HASKELL__ >= 708 pprInfo :: Bool -> (TyThing, GHC.Fixity, [ClsInst], [FamInst]) -> SDoc pprInfo _ (thing, fixity, insts, famInsts)     = pprTyThingInContextLoc thing@@ -308,14 +324,14 @@ ----------------------------------------------------------------  errorMsgSpan :: ErrMsg -> SrcSpan-#if __GLASGOW_HASKELL__ >= 707+#if __GLASGOW_HASKELL__ >= 708 errorMsgSpan = errMsgSpan #else errorMsgSpan = head . errMsgSpans #endif  typeForUser :: Type -> SDoc-#if __GLASGOW_HASKELL__ >= 707+#if __GLASGOW_HASKELL__ >= 708 typeForUser = pprTypeForUser #else typeForUser = pprTypeForUser False@@ -323,7 +339,7 @@  deSugar :: TypecheckedModule -> LHsExpr Id -> HscEnv          -> IO (Maybe CoreExpr)-#if __GLASGOW_HASKELL__ >= 707+#if __GLASGOW_HASKELL__ >= 708 deSugar _   e hs_env = snd <$> deSugarExpr hs_env e #else deSugar tcm e hs_env = snd <$> deSugarExpr hs_env modu rn_env ty_env e@@ -341,7 +357,7 @@  fromTyThing :: TyThing -> GapThing fromTyThing (AnId i)                   = GtA $ varType i-#if __GLASGOW_HASKELL__ >= 707+#if __GLASGOW_HASKELL__ >= 708 fromTyThing (AConLike (RealDataCon d)) = GtA $ dataConRepType d fromTyThing (AConLike (PatSynCon p))   = GtA $ patSynType p #else@@ -351,10 +367,14 @@ fromTyThing _                          = GtN  ----------------------------------------------------------------+---------------------------------------------------------------- -#if __GLASGOW_HASKELL__ >= 707-dumpSplicesFlag :: DumpFlag+#if __GLASGOW_HASKELL__ >= 704+type WarnFlags = I.IntSet+emptyWarnFlags :: WarnFlags+emptyWarnFlags = I.empty #else-dumpSplicesFlag :: DynFlag+type WarnFlags = [WarningFlag]+emptyWarnFlags :: WarnFlags+emptyWarnFlags = [] #endif-dumpSplicesFlag = Opt_D_dump_splices
+ Language/Haskell/GhcMod/Ghc.hs view
@@ -0,0 +1,25 @@+module Language.Haskell.GhcMod.Ghc (+  -- * Converting the 'Ghc' monad to the 'IO' monad+    withGHC+  , withGHC'+  -- * 'Ghc' utilities+  , boot+  , browse+  , check+  , info+  , types+  , modules+  -- * 'SymMdlDb'+  , Symbol+  , SymMdlDb+  , getSymMdlDb+  , lookupSym+  ) where++import Language.Haskell.GhcMod.Boot+import Language.Haskell.GhcMod.Browse+import Language.Haskell.GhcMod.Check+import Language.Haskell.GhcMod.Find+import Language.Haskell.GhcMod.GHCApi+import Language.Haskell.GhcMod.Info+import Language.Haskell.GhcMod.List
+ Language/Haskell/GhcMod/GhcPkg.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE BangPatterns, ScopedTypeVariables, TupleSections #-}+module Language.Haskell.GhcMod.GhcPkg (+    ghcPkgList+  , ghcPkgListEx+  , ghcPkgDbOpt+  , ghcPkgDbStackOpts+  , ghcDbStackOpts+  , ghcDbOpt+  , getSandboxDb+  , getPackageDbStack+  ) where++import Config (cProjectVersionInt) -- ghc version+import Control.Applicative ((<$>))+import Control.Exception (SomeException(..))+import qualified Control.Exception as E+import Data.Char (isSpace,isAlphaNum)+import Data.List (isPrefixOf, intercalate)+import Data.Maybe (listToMaybe, maybeToList)+import Language.Haskell.GhcMod.Types+import Language.Haskell.GhcMod.Utils+import System.Exit (ExitCode(..))+import System.FilePath ((</>))+import System.IO (hPutStrLn,stderr)+import System.Process (readProcessWithExitCode)+import Text.ParserCombinators.ReadP (ReadP, char, between, sepBy1, many1, string, choice, eof)+import qualified Text.ParserCombinators.ReadP as P++ghcVersion :: Int+ghcVersion = read cProjectVersionInt++-- | Get path to sandbox package db+getSandboxDb :: FilePath -- ^ Path to the cabal package root directory+                         -- (containing the @cabal.sandbox.config@ file)+             -> IO FilePath+getSandboxDb cdir = getSandboxDbDir (cdir </> "cabal.sandbox.config")++-- | Extract the sandbox package db directory from the cabal.sandbox.config file.+--   Exception is thrown if the sandbox config file is broken.+getSandboxDbDir :: FilePath -- ^ Path to the @cabal.sandbox.config@ file+                -> IO FilePath+getSandboxDbDir sconf = do+    -- Be strict to ensure that an error can be caught.+    !path <- extractValue . parse <$> readFile sconf+    return path+  where+    key = "package-db:"+    keyLen = length key++    parse = head . filter (key `isPrefixOf`) . lines+    extractValue = dropWhileEnd isSpace . dropWhile isSpace . drop keyLen++getPackageDbStack :: FilePath -- ^ Project Directory (where the+                                 -- cabal.sandbox.config file would be if it+                                 -- exists)+                  -> IO [GhcPkgDb]+getPackageDbStack cdir =+    (getSandboxDb cdir >>= \db -> return [GlobalDb, PackageDb db])+      `E.catch` \(_ :: SomeException) -> return [GlobalDb, UserDb]+++-- | List packages in one or more ghc package store+ghcPkgList :: [GhcPkgDb] -> IO [PackageBaseName]+ghcPkgList dbs = map fst3 <$> ghcPkgListEx dbs+  where fst3 (x,_,_) = x++ghcPkgListEx :: [GhcPkgDb] -> IO [Package]+ghcPkgListEx dbs = do+    (rv,output,err) <- readProcessWithExitCode "ghc-pkg" opts ""+    case rv of+      ExitFailure val -> do+          hPutStrLn stderr err+          fail $ "ghc-pkg " ++ unwords opts ++ " (exit " ++ show val ++ ")"+      ExitSuccess -> return ()++    return $ parseGhcPkgOutput $ lines output+  where+    opts = ["list", "-v"] ++ ghcPkgDbStackOpts dbs++parseGhcPkgOutput :: [String] -> [Package]+parseGhcPkgOutput [] = []+parseGhcPkgOutput (l:ls) =+    parseGhcPkgOutput ls ++ case l of+      [] -> []+      h:_ | isSpace h -> maybeToList $ packageLine l+          | otherwise -> []++packageLine :: String -> Maybe Package+packageLine l =+    case listToMaybe $ P.readP_to_S packageLineP l of+      Just ((Normal,p),_) -> Just p+      Just ((Hidden,p),_) -> Just p+      _ -> Nothing++data PackageState = Normal | Hidden | Broken deriving (Eq,Show)++packageLineP :: ReadP (PackageState, Package)+packageLineP = do+    P.skipSpaces+    p <- choice [ (Hidden,) <$> between (char '(') (char ')') packageP+                , (Broken,) <$> between (char '{') (char '}') packageP+                , (Normal,) <$> packageP ]+    eof+    return p++packageP :: ReadP (PackageBaseName, PackageVersion, PackageId)+packageP = do+    pkgSpec@(name,ver) <- packageSpecP+    P.skipSpaces+    i <- between (char '(') (char ')') $ packageIdSpecP pkgSpec+    return (name,ver,i)++packageSpecP :: ReadP (PackageBaseName,PackageVersion)+packageSpecP = do+  fs <- many1 packageCompCharP `sepBy1` char '-'+  return (intercalate "-" (init fs), last fs)++packageIdSpecP :: (PackageBaseName,PackageVersion) -> ReadP PackageId+packageIdSpecP (name,ver) = do+    string name >> char '-' >> string ver >> char '-' >> return ()+    many1 (P.satisfy isAlphaNum)++packageCompCharP :: ReadP Char+packageCompCharP =+    P.satisfy $ \c -> isAlphaNum c || c `elem` "_-."++-- | Get options needed to add a list of package dbs to ghc-pkg's db stack+ghcPkgDbStackOpts :: [GhcPkgDb] -- ^ Package db stack+                  -> [String]+ghcPkgDbStackOpts dbs = ghcPkgDbOpt `concatMap` dbs++-- | Get options needed to add a list of package dbs to ghc's db stack+ghcDbStackOpts :: [GhcPkgDb] -- ^ Package db stack+               -> [String]+ghcDbStackOpts dbs = ghcDbOpt `concatMap` dbs++ghcPkgDbOpt :: GhcPkgDb -> [String]+ghcPkgDbOpt GlobalDb = ["--global"]+ghcPkgDbOpt UserDb   = ["--user"]+ghcPkgDbOpt (PackageDb pkgDb)+  | ghcVersion < 706 = ["--no-user-package-conf", "--package-conf=" ++ pkgDb]+  | otherwise        = ["--no-user-package-db",   "--package-db="   ++ pkgDb]++ghcDbOpt :: GhcPkgDb -> [String]+ghcDbOpt GlobalDb+  | ghcVersion < 706 = ["-global-package-conf"]+  | otherwise        = ["-global-package-db"]+ghcDbOpt UserDb+  | ghcVersion < 706 = ["-user-package-conf"]+  | otherwise        = ["-user-package-db"]+ghcDbOpt (PackageDb pkgDb)+  | ghcVersion < 706 = ["-no-user-package-conf", "-package-conf", pkgDb]+  | otherwise        = ["-no-user-package-db",   "-package-db",   pkgDb]
Language/Haskell/GhcMod/Info.hs view
@@ -1,68 +1,56 @@-{-# LANGUAGE TupleSections, FlexibleInstances, TypeSynonymInstances, CPP #-}-{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TupleSections, FlexibleInstances, Rank2Types #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  module Language.Haskell.GhcMod.Info (     infoExpr   , info   , typeExpr-  , typeOf+  , types   ) where  import Control.Applicative ((<$>))-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.Generics import Data.List (sortBy)-import Data.Maybe (catMaybes, fromMaybe, listToMaybe)+import Data.Maybe (catMaybes, fromMaybe) import Data.Ord as O-import Data.Time.Clock (getCurrentTime)-import GHC (Ghc, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), DynFlags, SrcSpan, Type, Located, TypecheckedSource, GenLocated(L), LoadHowMuch(..), TargetId(..))+import Exception (ghandle, SomeException(..))+import GHC (Ghc, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), DynFlags, SrcSpan, Type, Located, TypecheckedSource, GenLocated(L)) import qualified GHC as G import GHC.SYB.Utils (Stage(TypeChecker), everythingStaged)-import HscTypes (ms_imps) import Language.Haskell.GhcMod.Doc (showPage, showOneLine, getStyle) import Language.Haskell.GhcMod.GHCApi-import Language.Haskell.GhcMod.GHCChoice ((||>), goNext)-import Language.Haskell.GhcMod.Gap (HasType(..))+import Language.Haskell.GhcMod.Gap (HasType(..), setDeferTypeErrors) import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Types-import Outputable (PprStyle, ppr)+import Outputable (PprStyle) import TcHsSyn (hsPatType)  ---------------------------------------------------------------- -data Cmd = Info | Type deriving Eq------------------------------------------------------------------- -- | Obtaining information of a target expression. (GHCi's info:) infoExpr :: Options          -> Cradle          -> FilePath     -- ^ A target file.-         -> ModuleString -- ^ A module name.          -> Expression   -- ^ A Haskell expression.          -> IO String-infoExpr opt cradle file modstr expr = (++ "\n") <$> withGHCDummyFile (info opt cradle file modstr expr)+infoExpr opt cradle file expr = withGHC' $ do+    initializeFlagsWithCradle opt cradle+    info opt file expr  -- | Obtaining information of a target expression. (GHCi's info:) info :: Options-     -> Cradle      -> FilePath     -- ^ A target file.-     -> ModuleString -- ^ A module name.      -> Expression   -- ^ A Haskell expression.      -> Ghc String-info opt cradle file modstr expr =-    inModuleContext Info opt cradle file modstr exprToInfo "Cannot show info"+info opt file expr = convert opt <$> ghandle handler body   where-    exprToInfo = do-        dflag <- G.getSessionDynFlags+    body = inModuleContext file $ \dflag style -> do         sdoc <- Gap.infoThing expr-        style <- getStyle         return $ showPage dflag style sdoc+    handler (SomeException _) = return "Cannot show info"  ---------------------------------------------------------------- @@ -81,50 +69,38 @@ typeExpr :: Options          -> Cradle          -> FilePath     -- ^ A target file.-         -> ModuleString -- ^ A odule name.          -> Int          -- ^ Line number.          -> Int          -- ^ Column number.          -> IO String-typeExpr opt cradle file modstr lineNo colNo = withGHCDummyFile $ typeOf opt cradle file modstr lineNo colNo+typeExpr opt cradle file lineNo colNo = withGHC' $ do+    initializeFlagsWithCradle opt cradle+    types opt file lineNo colNo  -- | Obtaining type of a target expression. (GHCi's type:)-typeOf :: Options-       -> Cradle-       -> FilePath     -- ^ A target file.-       -> ModuleString -- ^ A odule name.-       -> Int          -- ^ Line number.-       -> Int          -- ^ Column number.-       -> Ghc String-typeOf opt cradle file modstr lineNo colNo =-    inModuleContext Type opt cradle file modstr exprToType errmsg+types :: Options+      -> FilePath     -- ^ A target file.+      -> Int          -- ^ Line number.+      -> Int          -- ^ Column number.+      -> Ghc String+types opt file lineNo colNo = convert opt <$> ghandle handler body   where-    exprToType = do-      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 <- G.getSessionDynFlags-      style <- getStyle-      let sss = map (toTup dflag style) $ sortBy (cmp `on` fst) $ catMaybes $ concat [ets, bts, pts]-      return $ convert opt sss--    toTup :: DynFlags -> PprStyle -> (SrcSpan, Type) -> ((Int,Int,Int,Int),String)-    toTup dflag style (spn, typ) = (fourInts spn, pretty dflag style typ)--    fourInts :: SrcSpan -> (Int,Int,Int,Int)-    fourInts = fromMaybe (0,0,0,0) . Gap.getSrcSpan--    cmp a b-      | a `G.isSubspanOf` b = O.LT-      | b `G.isSubspanOf` a = O.GT-      | otherwise = O.EQ+    body = inModuleContext file $ \dflag style -> do+        modSum <- Gap.fileModSummary file+        srcSpanTypes <- getSrcSpanType modSum lineNo colNo+        return $ map (toTup dflag style) $ sortBy (cmp `on` fst) srcSpanTypes+    handler (SomeException _) = return [] -    errmsg = convert opt ([] :: [((Int,Int,Int,Int),String)])+getSrcSpanType :: G.ModSummary -> Int -> Int -> Ghc [(SrcSpan, Type)]+getSrcSpanType modSum lineNo colNo = do+    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+    return $ catMaybes $ concat [ets, bts, pts]  listifySpans :: Typeable a => TypecheckedSource -> (Int, Int) -> [Located a] listifySpans tcs lc = listifyStaged TypeChecker p tcs@@ -134,40 +110,28 @@ listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r] listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x])) +cmp :: SrcSpan -> SrcSpan -> Ordering+cmp a b+  | a `G.isSubspanOf` b = O.LT+  | b `G.isSubspanOf` a = O.GT+  | otherwise           = O.EQ++toTup :: DynFlags -> PprStyle -> (SrcSpan, Type) -> ((Int,Int,Int,Int),String)+toTup dflag style (spn, typ) = (fourInts spn, pretty dflag style typ)++fourInts :: SrcSpan -> (Int,Int,Int,Int)+fourInts = fromMaybe (0,0,0,0) . Gap.getSrcSpan+ pretty :: DynFlags -> PprStyle -> Type -> String pretty dflag style = showOneLine dflag style . Gap.typeForUser  ---------------------------------------------------------------- -inModuleContext :: Cmd -> Options -> Cradle -> FilePath -> ModuleString -> Ghc String -> String -> Ghc String-inModuleContext _ opt cradle file modstr action errmsg =-    valid ||> invalid ||> return errmsg-  where-    valid = do-        void $ initializeFlagsWithCradle opt cradle ["-w:"] False-        setTargetFiles [file]-        void $ G.load LoadAllTargets-        doif setContextFromTarget action-    invalid = do-        void $ initializeFlagsWithCradle opt cradle ["-w:"] False-        setTargetBuffer-        void $ G.load LoadAllTargets-        doif setContextFromTarget action-    setTargetBuffer = do-        modgraph <- G.depanal [G.mkModuleName modstr] True+inModuleContext :: FilePath -> (DynFlags -> PprStyle -> Ghc a) -> Ghc a+inModuleContext file action =+    withDynFlags (setDeferTypeErrors . setNoWaringFlags) $ do+    setTargetFiles [file]+    Gap.withContext $ do         dflag <- G.getSessionDynFlags         style <- getStyle-        let imports = concatMap (map (showPage dflag style . 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 <- 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 = G.depanal [] False >>= Gap.setCtx+        action dflag style
Language/Haskell/GhcMod/Internal.hs view
@@ -2,14 +2,13 @@  module Language.Haskell.GhcMod.Internal (   -- * Types-    LogReader-  , GHCOption+    GHCOption   , Package+  , PackageBaseName+  , PackageVersion+  , PackageId   , IncludeDir   , CompilerOptions(..)-  -- * Cradle-  , userPackageDbOptsForGhc-  , userPackageDbOptsForGhcPkg   -- * Cabal API   , parseCabalFile   , getCompilerOptions@@ -21,13 +20,13 @@   , getSystemLibDir   , getDynamicFlags   -- * Initializing 'DynFlags'-  , initializeFlags   , initializeFlagsWithCradle-  -- * 'Ghc' Monad+  -- * Targets   , setTargetFiles-  , addTargetFiles-  , handleErrMsg-  , browseAll+  -- * Logging+  , withLogger+  , setNoWaringFlags+  , setAllWaringFlags   -- * 'Ghc' Choice   , (||>)   , goNext@@ -36,10 +35,8 @@   , (|||>)   ) 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+import Language.Haskell.GhcMod.Logger import Language.Haskell.GhcMod.Types
Language/Haskell/GhcMod/Lang.hs view
@@ -1,9 +1,9 @@ module Language.Haskell.GhcMod.Lang where -import qualified Language.Haskell.GhcMod.Gap as Gap+import DynFlags (supportedLanguagesAndExtensions) import Language.Haskell.GhcMod.Types  -- | Listing language extensions.  listLanguages :: Options -> IO String-listLanguages opt = return $ convert opt Gap.supportedExtensions+listLanguages opt = return $ convert opt supportedLanguagesAndExtensions
Language/Haskell/GhcMod/Lint.hs view
@@ -1,38 +1,18 @@ module Language.Haskell.GhcMod.Lint where  import Control.Applicative ((<$>))-import Control.Exception (finally)-import Data.List (intercalate)-import GHC.IO.Handle (hDuplicate, hDuplicateTo)+import Control.Exception (handle, SomeException(..))+import Language.Haskell.GhcMod.Logger (checkErrorPrefix) import Language.Haskell.GhcMod.Types 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 hopts file+lintSyntax opt file = handle handler $ pack <$> hlint (file : "--quiet" : hopts)   where-    LineSeparator lsep = lineSeparator opt-    pack = unlines . map (intercalate lsep . lines)+    pack = convert opt . map (init . show) -- init drops the last \n.     hopts = hlintOpts opt---- | Checking syntax of a target file using hlint.---   Warnings and errors are returned.-lint :: [String]-     -> FilePath    -- ^ A target file.-     -> IO [String]-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+    handler (SomeException e) = return $ checkErrorPrefix ++ show e ++ "\n"
Language/Haskell/GhcMod/List.hs view
@@ -1,7 +1,7 @@-module Language.Haskell.GhcMod.List (listModules, listMods) where+module Language.Haskell.GhcMod.List (listModules, modules) where  import Control.Applicative ((<$>))-import Control.Monad (void)+import Control.Exception (SomeException(..)) import Data.List (nub, sort) import GHC (Ghc) import qualified GHC as G@@ -14,21 +14,23 @@  -- | Listing installed modules. listModules :: Options -> Cradle -> IO String-listModules opt cradle = convert opt . nub . sort . map dropPkgs <$> withGHCDummyFile (listMods opt cradle)-  where-    dropPkgs (name, pkg)-      | detailed opt = name ++ " " ++ pkg-      | otherwise = name+listModules opt cradle = withGHC' $ do+    initializeFlagsWithCradle opt cradle+    modules opt  -- | Listing installed modules.-listMods :: Options -> Cradle -> Ghc [(String, String)]-listMods opt cradle = do-    void $ initializeFlagsWithCradle opt cradle [] False-    getExposedModules <$> G.getSessionDynFlags+modules :: Options -> Ghc String+modules opt = convert opt . arrange <$> (getModules `G.gcatch` handler)   where+    getModules = getExposedModules <$> G.getSessionDynFlags     getExposedModules = concatMap exposedModules'                       . eltsUFM . pkgIdMap . G.pkgState     exposedModules' p =         map G.moduleNameString (exposedModules p)     	`zip`         repeat (display $ sourcePackageId p)+    arrange = nub . sort . map dropPkgs+    dropPkgs (name, pkg)+      | detailed opt = name ++ " " ++ pkg+      | otherwise = name+    handler (SomeException _) = return []
+ Language/Haskell/GhcMod/Logger.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE BangPatterns, CPP #-}++module Language.Haskell.GhcMod.Logger (+    withLogger+  , checkErrorPrefix+  ) where++import Bag (Bag, bagToList)+import Control.Applicative ((<$>))+import CoreMonad (liftIO)+import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)+import Data.Maybe (fromMaybe)+import ErrUtils (ErrMsg, errMsgShortDoc, errMsgExtraInfo)+import Exception (ghandle)+import GHC (Ghc, DynFlags, SrcSpan, Severity(SevError))+import qualified GHC as G+import HscTypes (SourceError, srcErrorMessages)+import Language.Haskell.GhcMod.Doc (showPage, getStyle)+import Language.Haskell.GhcMod.GHCApi (withDynFlags)+import qualified Language.Haskell.GhcMod.Gap as Gap+import Language.Haskell.GhcMod.Types (Options, convert)+import Outputable (PprStyle, SDoc)+import System.FilePath (normalise)++----------------------------------------------------------------++type Builder = [String] -> [String]++newtype LogRef = LogRef (IORef Builder)++newLogRef :: IO LogRef+newLogRef = LogRef <$> newIORef id++readAndClearLogRef :: Options -> LogRef -> IO String+readAndClearLogRef opt (LogRef ref) = do+    b <- readIORef ref+    writeIORef ref id+    return $! convert opt (b [])++appendLogRef :: DynFlags -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()+appendLogRef df (LogRef ref) _ sev src style msg = do+        let !l = ppMsg src sev df style msg+        modifyIORef ref (\b -> b . (l:))++----------------------------------------------------------------++-- | Set the session flag (e.g. "-Wall" or "-w:") then+--   executes a body. Log messages are returned as 'String'.+--   Right is success and Left is failure.+withLogger :: Options -> (DynFlags -> DynFlags) -> Ghc () -> Ghc (Either String String)+withLogger opt setDF body = ghandle (sourceError opt) $ do+    logref <- liftIO $ newLogRef+    withDynFlags (setLogger logref . setDF) $ do+        body+        liftIO $ Right <$> readAndClearLogRef opt logref+  where+    setLogger logref df = Gap.setLogAction df $ appendLogRef df logref++----------------------------------------------------------------++-- | Converting 'SourceError' to 'String'.+sourceError :: Options -> SourceError -> Ghc (Either String String)+sourceError opt err = do+    dflag <- G.getSessionDynFlags+    style <- getStyle+    let ret = convert opt . errBagToStrList dflag style . srcErrorMessages $ err+    return (Left ret)++errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String]+errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList++----------------------------------------------------------------++ppErrMsg :: DynFlags -> PprStyle -> ErrMsg -> String+ppErrMsg dflag style err = ppMsg spn SevError dflag style msg ++ ext+   where+     spn = Gap.errorMsgSpan err+     msg = errMsgShortDoc err+     ext = showPage dflag style (errMsgExtraInfo err)++ppMsg :: SrcSpan -> Severity-> DynFlags -> PprStyle -> SDoc -> String+ppMsg spn sev dflag style msg = prefix ++ cts+  where+    cts  = showPage dflag style msg+    defaultPrefix+      | Gap.isDumpSplices dflag = ""+      | otherwise               = checkErrorPrefix+    prefix = fromMaybe defaultPrefix $ do+        (line,col,_,_) <- Gap.getSrcSpan spn+        file <- normalise <$> Gap.getSrcFile spn+        let severityCaption = Gap.showSeverityCaption sev+        return $ file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption++checkErrorPrefix :: String+checkErrorPrefix = "Dummy:0:0:Error:"
Language/Haskell/GhcMod/PkgDoc.hs view
@@ -1,8 +1,9 @@ module Language.Haskell.GhcMod.PkgDoc (packageDoc) where -import Control.Applicative ((<$>)) import Language.Haskell.GhcMod.Types-import Language.Haskell.GhcMod.Cradle+import Language.Haskell.GhcMod.GhcPkg++import Control.Applicative ((<$>)) import System.Process (readProcess)  -- | Obtaining the package name and the doc path of a module.@@ -22,6 +23,8 @@         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)+    toModuleOpts = ["find-module", mdl, "--simple-output"]+                   ++ ghcPkgDbStackOpts (cradlePkgDbStack cradle)+    toDocDirOpts pkg = ["field", pkg, "haddock-html"]+                       ++ ghcPkgDbStackOpts (cradlePkgDbStack cradle)     trim = takeWhile (`notElem` " \n")
Language/Haskell/GhcMod/Types.hs view
@@ -2,6 +2,8 @@  module Language.Haskell.GhcMod.Types where +import Data.List (intercalate)+ -- | Output style. data OutputStyle = LispStyle  -- ^ S expression style.                  | PlainStyle -- ^ Plain textstyle.@@ -12,19 +14,15 @@ data Options = Options {     outputStyle   :: OutputStyle   , hlintOpts     :: [String]-  , ghcOpts       :: [String]+  , ghcOpts       :: [GHCOption]   -- | If 'True', 'browse' also returns operators.   , operators     :: Bool   -- | If 'True', 'browse' also returns types.   , detailed      :: Bool   -- | If 'True', 'browse' will return fully qualified name   , qualified     :: Bool-  -- | Whether or not Template Haskell should be expanded.-  , expandSplice  :: Bool   -- | Line separator string.   , lineSeparator :: LineSeparator-  -- | Package id of module-  , packageId :: Maybe String   }  -- | A default 'Options'.@@ -36,47 +34,96 @@   , operators     = False   , detailed      = False   , qualified     = False-  , expandSplice  = False   , lineSeparator = LineSeparator "\0"-  , packageId     = Nothing   }  ---------------------------------------------------------------- +type Builder = String -> String++-- |+--+-- >>> replace '"' "\\\"" "foo\"bar" ""+-- "foo\\\"bar"+replace :: Char -> String -> String -> Builder+replace _ _  [] = id+replace c cs (x:xs)+  | x == c    = (cs ++) . replace c cs xs+  | otherwise = (x :) . replace c cs xs++inter :: Char -> [Builder] -> Builder+inter _ [] = id+inter c bs = foldr1 (\x y -> x . (c:) . y) bs+ convert :: ToString a => Options -> a -> String-convert Options{ outputStyle = LispStyle  } = toLisp-convert Options{ outputStyle = PlainStyle } = toPlain+convert opt@Options { outputStyle = LispStyle  } x = toLisp  opt x "\n"+convert opt@Options { outputStyle = PlainStyle } x = toPlain opt x "\n"  class ToString a where-    toLisp  :: a -> String-    toPlain :: a -> String+    toLisp  :: Options -> a -> Builder+    toPlain :: Options -> a -> Builder +lineSep :: Options -> String+lineSep opt = lsep+  where+    LineSeparator lsep = lineSeparator opt++-- |+--+-- >>> toLisp defaultOptions "fo\"o" ""+-- "\"fo\\\"o\""+-- >>> toPlain defaultOptions "foo" ""+-- "foo"+instance ToString String where+    toLisp  opt = quote opt+    toPlain opt = replace '\n' (lineSep opt)++-- |+--+-- >>> toLisp defaultOptions ["foo", "bar", "ba\"z"] ""+-- "(\"foo\" \"bar\" \"ba\\\"z\")"+-- >>> toPlain defaultOptions ["foo", "bar", "baz"] ""+-- "foo\nbar\nbaz" instance ToString [String] where-    toLisp  = addNewLine . toSexp True-    toPlain = unlines+    toLisp  opt = toSexp1 opt+    toPlain opt = inter '\n' . map (toPlain opt) +-- |+--+-- >>> let inp = [((1,2,3,4),"foo"),((5,6,7,8),"bar")] :: [((Int,Int,Int,Int),String)]+-- >>> toLisp defaultOptions inp ""+-- "((1 2 3 4 \"foo\") (5 6 7 8 \"bar\"))"+-- >>> toPlain defaultOptions inp ""+-- "1 2 3 4 \"foo\"\n5 6 7 8 \"bar\"" instance ToString [((Int,Int,Int,Int),String)] where-    toLisp  = addNewLine . toSexp False . map toS+    toLisp  opt = toSexp2 . map toS       where-        toS x = "(" ++ tupToString x ++ ")"-    toPlain = unlines . map tupToString+        toS x = ('(' :) . tupToString opt x . (')' :)+    toPlain opt = inter '\n' . map (tupToString opt) -toSexp :: Bool -> [String] -> String-toSexp False ss = "(" ++ unwords ss ++ ")"-toSexp True ss  = "(" ++ unwords (map quote ss) ++ ")"+toSexp1 :: Options -> [String] -> Builder+toSexp1 opt ss = ('(' :) . inter ' ' (map (quote opt) ss) . (')' :) -tupToString :: ((Int,Int,Int,Int),String) -> String-tupToString ((a,b,c,d),s) = show a ++ " "-                         ++ show b ++ " "-                         ++ show c ++ " "-                         ++ show d ++ " "-                         ++ quote s+toSexp2 :: [Builder] -> Builder+toSexp2 ss = ('(' :) . (inter ' ' ss) . (')' :) -quote :: String -> String-quote x = "\"" ++ x ++ "\""+tupToString :: Options -> ((Int,Int,Int,Int),String) -> Builder+tupToString opt ((a,b,c,d),s) = (show a ++) . (' ' :)+                              . (show b ++) . (' ' :)+                              . (show c ++) . (' ' :)+                              . (show d ++) . (' ' :)+                              . quote opt s -- fixme: quote is not necessary -addNewLine :: String -> String-addNewLine = (++ "\n")+quote :: Options -> String -> Builder+quote opt str = ("\"" ++) .  (quote' str ++) . ("\"" ++)+  where+    lsep = lineSep opt+    quote' [] = []+    quote' (x:xs)+      | x == '\n' = lsep   ++ quote' xs+      | x == '\\' = "\\\\" ++ quote' xs+      | x == '"'  = "\\\"" ++ quote' xs+      | otherwise = x       : quote' xs  ---------------------------------------------------------------- @@ -88,14 +135,15 @@   , cradleRootDir    :: FilePath   -- | The file name of the found cabal file.   , cradleCabalFile  :: Maybe FilePath-  -- | User package db. (\"\/foo\/bar\/i386-osx-ghc-7.6.3-packages.conf.d\")-  , cradlePackageDb  :: Maybe FilePath-  -- | Dependent packages.-  , cradlePackages   :: [Package]+  -- | Package database stack+  , cradlePkgDbStack  :: [GhcPkgDb]   } deriving (Eq, Show)  ---------------------------------------------------------------- +-- | GHC package database flags.+data GhcPkgDb = GlobalDb | UserDb | PackageDb String deriving (Eq, Show)+ -- | A single GHC command line option. type GHCOption  = String @@ -105,8 +153,29 @@ -- | A package name. type PackageBaseName = String --- | A package name and its ID.-type Package    = (PackageBaseName, Maybe String)+-- | A package version.+type PackageVersion  = String++-- | A package id.+type PackageId  = String++-- | A package's name, verson and id.+type Package    = (PackageBaseName, PackageVersion, PackageId)++pkgName :: Package -> PackageBaseName+pkgName (n,_,_) = n++pkgVer :: Package -> PackageVersion+pkgVer (_,v,_) = v++pkgId :: Package -> PackageId+pkgId (_,_,i) = i++showPkg :: Package -> String+showPkg (n,v,_) = intercalate "-" [n,v]++showPkgId :: Package -> String+showPkgId (n,v,i) = intercalate "-" [n,v,i]  -- | Haskell expression. type Expression = String
+ Language/Haskell/GhcMod/Utils.hs view
@@ -0,0 +1,5 @@+module Language.Haskell.GhcMod.Utils where++-- 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) []
elisp/ghc-check.el view
@@ -46,21 +46,22 @@  (defun ghc-check-syntax ()   (interactive)-  (ghc-with-process 'ghc-check-send 'ghc-check-callback))+  (ghc-with-process (ghc-check-send)+		    'ghc-check-callback+		    (lambda () (setq mode-line-process " -:-"))))  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  (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")))+  (let ((file (buffer-file-name)))+    (if ghc-check-command+	(let ((opts (ghc-haskell-list-of-string ghc-hlint-options)))+	  (if opts+	      (format "lint %s %s\n" opts file)+	    (format "lint %s\n" file)))+      (format "check %s\n" file))))  (defun ghc-haskell-list-of-string (los)   (when los@@ -68,40 +69,50 @@ 	    (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 (expand-file-name (match-string 1))) ;; for Windows-	     (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+(defun ghc-check-callback (status)+  (cond+   ((eq status 'ok)+    (let* ((errs (ghc-read-lisp-this-buffer))+	   (infos (ghc-to-info errs)))+      (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-	(remove-overlays (point-min) (point-max) 'ghc-check t))))+	(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))))))))+   (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))))))))+      (setq mode-line-process " failed"))))) +(defun ghc-to-info (errs)+  ;; [^\t] to include \n.+  (let ((regex "^\\([^\n]*\\):\\([0-9]+\\):\\([0-9]+\\): *\\([^\t]+\\)")+	info infos)+    (dolist (err errs (nreverse infos))+      (when (string-match regex err)+	(let* ((file (expand-file-name (match-string 1 err))) ;; for Windows+	       (line (string-to-number (match-string 2 err)))+	       ;; don't take column to make multiple same errors to a single.+	       (msg (match-string 4 err))+	       (wrn (string-match "^Warning" msg))+	       (info (ghc-make-hilit-info+		      :file file+		      :line line+		      :msg  msg+		      :err  (not wrn))))+	  (unless (member info infos)+	    (ghc-add infos info)))))))+ (defun ghc-check-highlight-original-buffer (ofile buf infos)   (with-current-buffer buf     (remove-overlays (point-min) (point-max) 'ghc-check t)@@ -131,8 +142,7 @@ 	  (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))+	  (overlay-put ovl 'help-echo msg) 	  (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)@@ -140,37 +150,50 @@  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun ghc-overlay-p (ovl)+  (overlay-get ovl 'ghc-check))++(defun ghc-check-overlay-at (p)+  (ghc-filter 'ghc-overlay-p (overlays-at p)))++(ghc-defstruct file-msgs file msgs)++(defun ghc-get-errors-over-warnings ()+  (let ((ovls (ghc-check-overlay-at (point))))+    (when ovls+      (let ((msgs (mapcar (lambda (ovl) (overlay-get ovl 'ghc-msg)) ovls))+	    (file (overlay-get (car ovls) 'ghc-file))+	    errs wrns)+	(dolist (msg msgs)+	  (if (string-match "^Warning" msg)+	      (ghc-add wrns msg)+	    (ghc-add errs msg)))+	(ghc-make-file-msgs :file file :msgs (nconc errs wrns))))))+ (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)+  (let ((file-msgs (ghc-get-errors-over-warnings)))+    (if (null file-msgs) 	(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))))))+      (let ((file (ghc-file-msgs-get-file file-msgs))+	    (msgs (ghc-file-msgs-get-msgs file-msgs)))+	(ghc-display+	 nil+	 (lambda ()+	   (insert file "\n\n")+	   (mapc (lambda (x) (insert x "\n\n")) msgs)))))))  (defun ghc-display-errors-to-minibuf ()-  (interactive)-  (let* ((ovls (ghc-check-overlay-at (point)))-	 (errs (mapcar (lambda (ovl) (overlay-get ovl 'ghc-msg)) ovls))-         (old-max-mini-window-height max-mini-window-height))-    (setq max-mini-window-height 0.95)-    (if (null ovls)+  (let ((file-msgs (ghc-get-errors-over-warnings)))+    (if (null file-msgs) 	(message "No errors or warnings")-      (let* ((buffile buffer-file-name)-             (ghcfile (overlay-get (car ovls) 'ghc-file))-             (errmsg (mapconcat (lambda (x) (replace-regexp-in-string "\0" "\n" x)) errs "\n")))-        (if (string-equal buffile ghcfile)+      (let* ((file (ghc-file-msgs-get-file file-msgs))+	     (msgs (ghc-file-msgs-get-msgs file-msgs))+	     (errmsg (mapconcat 'identity msgs "\n"))+	     (buffile buffer-file-name))+        (if (string-equal buffile file)             (message "%s" errmsg)-          (message "%s\n\n%s" ghcfile errmsg))))-    (setq old-max-mini-window-height)))--(defun ghc-check-overlay-at (p)-  (let ((ovls (overlays-at p)))-    (ghc-filter (lambda (ovl) (overlay-get ovl 'ghc-check)) ovls)))+          (message "%s\n\n%s" file errmsg))))))  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -218,11 +241,20 @@ 	    (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)+       ((string-match "Not in scope: type constructor or class .\\([^\n]+\\)." data) 	(let ((sym (match-string 1 data))) 	  (ghc-ins-mod sym)))-       ((string-match "Not in scope: `\\([^'\n\0]+\\)'" data)+       ((string-match "Not in scope: data constructor .\\([^\n]+\\)." data)+	;; if the type of data constructor, it would be nice. 	(let ((sym (match-string 1 data)))+	  (ghc-ins-mod sym)))+       ((string-match "\n[ ]+.\\([^ ]+\\). is a data constructor of .\\([^\n]+\\).\n" data)+	(let* ((old (match-string 1 data))+	       (type-const (match-string 2 data))+	       (new (format "%s(%s)" type-const old)))+	  (ghc-check-replace old new)))+       ((string-match "Not in scope: .\\([^\n]+\\)." 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)@@ -234,27 +266,30 @@ 	(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)+       ((string-match "Found:\n[ ]+\\([^\t]+\\)\nWhy not:\n[ ]+\\([^\t]+\\)" 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))))+	  (ghc-check-replace old new)))        (t 	(message "Nothing was done")))))) +(defun ghc-check-replace (old new)+  (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-extract-type (str)   (with-temp-buffer     (insert str)     (goto-char (point-min))-    (when (re-search-forward "Inferred type: \\|no type signature:\\( \\|\0 +\\)?" nil t)+    (when (re-search-forward "Inferred type: \\|no type signature:\\( \\|\n +\\)?" nil t)       (delete-region (point-min) (point)))     (when (re-search-forward " forall [^.]+\\." nil t)       (replace-match ""))-    (while (re-search-forward "\0 +" nil t)+    (while (re-search-forward "\n +" nil t)       (replace-match " "))     (goto-char (point-min))     (while (re-search-forward "\\[Char\\]" nil t)@@ -292,7 +327,7 @@ 	(insert fn) 	(dotimes (i arity) 	  (insert " _"))-	(insert  " = error \"" fn "\"")))))+	(insert  " = error \"" fn "\"\n")))))  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
elisp/ghc-comp.el view
@@ -16,7 +16,7 @@ ;;;  (defvar ghc-idle-timer-interval 30- "*Period of idele timer in second. When timeout, the names of+ "*Period of idle timer in second. When timeout, the names of unloaded modules are loaded")  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;@@ -30,7 +30,7 @@ ;; must be sorted (defconst ghc-reserved-keyword '("case" "deriving" "do" "else" "if" "in" "let" "module" "of" "then" "where")) -(defconst ghc-extra-keywords '("ByteString"))+(defconst ghc-extra-keywords '("ByteString" "Text"))  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;@@ -56,8 +56,8 @@ (defconst ghc-keyword-prefix "ghc-keyword-") (defvar ghc-keyword-Prelude nil) (defvar ghc-keyword-Control.Applicative nil)-(defvar ghc-keyword-Control.Monad nil) (defvar ghc-keyword-Control.Exception nil)+(defvar ghc-keyword-Control.Monad nil) (defvar ghc-keyword-Data.Char nil) (defvar ghc-keyword-Data.List nil) (defvar ghc-keyword-Data.Maybe nil)@@ -66,15 +66,14 @@ (defvar ghc-loaded-module nil)  (defun ghc-comp-init ()-  (add-hook 'find-file-hook 'ghc-import-module)   (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 		 ghc-keyword-Control.Exception+		 ghc-keyword-Control.Monad 		 ghc-keyword-Data.Char 		 ghc-keyword-Data.List 		 ghc-keyword-Data.Maybe@@ -86,13 +85,12 @@   ;; hard coded in GHCMod.hs   (ghc-merge-keywords '("Prelude" 			"Control.Applicative"-			"Control.Monad" 			"Control.Exception"+			"Control.Monad" 			"Data.Char" 			"Data.List" 			"Data.Maybe"-			"System.IO"))-  (run-with-idle-timer ghc-idle-timer-interval 'repeat 'ghc-idle-timer))+			"System.IO")))  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;@@ -100,28 +98,23 @@ ;;;  (defun ghc-boot (n)-  (ghc-executable-find ghc-module-command-    (ghc-read-lisp-list-     (lambda ()-       (message "Initializing...")-       (ghc-call-process ghc-module-command nil t nil "-l" "boot")-       (message "Initializing...done"))-     n)))+  (prog2+      (message "Initializing...")+      (ghc-sync-process "boot\n" n)+    (message "Initializing...done")))  (defun ghc-load-modules (mods)-  (if (null mods)-      (progn-	(message "No new modules")-	nil)-    (ghc-executable-find ghc-module-command-      (ghc-read-lisp-list-       (lambda ()-	 (message "Loading names...")-	 (apply 'ghc-call-process ghc-module-command nil '(t nil) nil-		`(,@(ghc-make-ghc-options) "-l" "browse" ,@mods))-	 (message "Loading names...done"))-       (length mods)))))+  (if mods+      (mapcar 'ghc-load-module mods)+    (message "No new modules")+    nil)) +(defun ghc-load-module (mod)+  (prog2+      (message "Loading symbols for %s..." mod)+      (ghc-sync-process (format "browse %s\n" mod))+    (message "Loading symbols for %s...done" mod)))+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Completion@@ -236,8 +229,7 @@  (defun ghc-import-module ()   (interactive)-  (when (eq major-mode 'haskell-mode)-    (ghc-load-module-buffer)))+  (ghc-load-module-buffer))  (defun ghc-unloaded-modules (mods)   (ghc-filter (lambda (mod)@@ -245,9 +237,6 @@ 		     (not (member mod ghc-loaded-module)))) 	      mods)) -(defun ghc-load-module-all-buffers ()-  (ghc-load-merge-modules (ghc-gather-import-modules-all-buffers)))- (defun ghc-load-module-buffer ()   (ghc-load-merge-modules (ghc-gather-import-modules-buffer))) @@ -271,26 +260,6 @@ (defun ghc-module-keyword (mod)   (symbol-value (ghc-module-symbol mod))) --;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;--(ghc-defstruct buffer name file)--(defun ghc-buffer-name-file (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)))-	ret file)-    (save-excursion-      (dolist (buf bufs (ghc-uniq-lol ret))-	(setq file (ghc-buffer-get-file buf))-	(when (and file (string-match "\\.hs$" file))-	  (set-buffer (ghc-buffer-get-name buf))-	  (ghc-add ret (ghc-gather-import-modules-buffer)))))))- (defun ghc-gather-import-modules-buffer ()   (let (ret)     (save-excursion@@ -304,9 +273,5 @@ ;;; ;;; Background Idle Timer ;;;--(defalias 'ghc-idle-timer 'ghc-load-module-all-buffer)--(defun ghc-load-module-all-buffer () nil)  (provide 'ghc-comp)
elisp/ghc-doc.el view
@@ -70,7 +70,7 @@ 	(i 0) 	acc)     (while (< i len)-      (setq acc (cons (format "-%d-" (aref symbol i)) acc))+      (ghc-add acc (format "-%d-" (aref symbol i)))       (setq i (1+ i)))     (apply 'concat (nreverse acc))))
elisp/ghc-func.el view
@@ -63,14 +63,18 @@ (defun ghc-read-lisp (func)   (with-temp-buffer     (funcall func)+    (ghc-read-lisp-this-buffer)))++;; OK/NG are ignored.+(defun ghc-read-lisp-this-buffer ()+  (save-excursion     (goto-char (point-min))     (condition-case nil 	(read (current-buffer))       (error ())))) -(defun ghc-read-lisp-list (func n)-  (with-temp-buffer-    (funcall func)+(defun ghc-read-lisp-list-this-buffer (n)+  (save-excursion     (goto-char (point-min))     (condition-case nil 	(let ((m (set-marker (make-marker) 1 (current-buffer)))@@ -86,11 +90,6 @@  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defconst ghc-null 0)-(defconst ghc-newline 10)--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;- (defun ghc-things-at-point ()   (thing-at-point 'sexp)) @@ -152,7 +151,6 @@       (with-current-buffer buf         (erase-buffer)         (funcall ins-func)-        (ghc-replace-character-buffer ghc-null ghc-newline)         (goto-char (point-min))         (if (not fontify)             (turn-off-haskell-font-lock)@@ -162,14 +160,15 @@  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun ghc-run-ghc-mod (cmds)-  (ghc-executable-find ghc-module-command-    (let ((cdir default-directory))-      (with-temp-buffer-	(cd cdir)-	(apply 'ghc-call-process ghc-module-command nil t nil-	       (append (ghc-make-ghc-options) cmds))-	(buffer-substring (point-min) (1- (point-max)))))))+(defun ghc-run-ghc-mod (cmds &optional prog)+  (let ((target (or prog ghc-module-command)))+    (ghc-executable-find target+      (let ((cdir default-directory))+	(with-temp-buffer+	  (cd cdir)+	  (apply 'ghc-call-process target nil t nil+		 (append (ghc-make-ghc-options) cmds))+	  (buffer-substring (point-min) (1- (point-max))))))))  (defmacro ghc-executable-find (cmd &rest body)   ;; (declare (indent 1))
elisp/ghc-info.el view
@@ -9,6 +9,7 @@ ;;; Code:  (require 'ghc-func)+(require 'ghc-process)  (defun ghc-show-info (&optional ask)   (interactive "P")@@ -21,10 +22,9 @@        (lambda () (insert info))))))  (defun ghc-get-info (expr)-  (let* ((modname (or (ghc-find-module-name) "Main"))-	 (file (buffer-file-name))-	 (cmds (list "info" file modname expr)))-    (ghc-run-ghc-mod cmds)))+  (let* ((file (buffer-file-name))+	 (cmd (format "info %s %s\n" file expr)))+    (ghc-sync-process cmd)))  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;@@ -77,13 +77,8 @@  (defun ghc-show-type ()   (interactive)-  (ghc-executable-find ghc-module-command-    (let ((modname (or (ghc-find-module-name) "Main")))-      (ghc-show-type0 modname))))--(defun ghc-show-type0 (modname)-  (let* ((buf (current-buffer))-	 (tinfos (ghc-type-get-tinfos modname)))+  (let ((buf (current-buffer))+	(tinfos (ghc-type-get-tinfos)))     (if (null tinfos) 	(progn 	  (ghc-type-clear-overlay)@@ -99,11 +94,11 @@ 	(move-overlay ghc-type-overlay (- left 1) (- right 1) buf) 	(message type))))) -(defun ghc-type-get-tinfos (modname)+(defun ghc-type-get-tinfos ()   (if (= (ghc-type-get-point) (point))       (ghc-type-set-ix        (mod (1+ (ghc-type-get-ix)) (length (ghc-type-get-types))))-    (let ((types (ghc-type-obtain-tinfos modname)))+    (let ((types (ghc-type-obtain-tinfos)))       (if (not (listp types)) ;; main does not exist in Main 	  (ghc-type-set-types nil) 	(ghc-type-set-types types)@@ -111,20 +106,19 @@ 	(ghc-type-set-ix 0))))   (ghc-type-get-types)) -(defun ghc-type-obtain-tinfos (modname)+(defun ghc-type-obtain-tinfos ()   (let* ((ln (int-to-string (line-number-at-pos))) 	 (cn (int-to-string (1+ (current-column))))-	 (cdir default-directory)-	 (file (buffer-file-name)))-    (ghc-read-lisp-     (lambda ()-       (cd cdir)-       (apply 'ghc-call-process ghc-module-command nil t nil-	      `(,@(ghc-make-ghc-options) "-l" "type" ,file ,modname ,ln ,cn))-       (goto-char (point-min))-       (while (search-forward "[Char]" nil t)-	 (replace-match "String"))))))+	 (file (buffer-file-name))+	 (cmd (format "type %s %s %s\n" file ln cn)))+    (ghc-sync-process cmd nil 'ghc-type-fix-string))) +(defun ghc-type-fix-string ()+  (save-excursion+    (goto-char (point-min))+    (while (search-forward "[Char]" nil t)+      (replace-match "String"))))+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Expanding Template Haskell@@ -133,7 +127,7 @@ (defun ghc-expand-th ()   (interactive)   (let* ((file (buffer-file-name))-	 (cmds (list "expand" file))+	 (cmds (list "expand" file "-b" "\n")) 	 (source (ghc-run-ghc-mod cmds)))     (when source       (ghc-display
elisp/ghc-ins-mod.el view
@@ -10,9 +10,6 @@  ;;; Code: -(defvar ghc-ins-mod-rendezvous nil)-(defvar ghc-ins-mod-results nil)- (defun ghc-insert-module ()   (interactive)   (let* ((expr0 (ghc-things-at-point))@@ -76,26 +73,7 @@     (forward-line)))  (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-ins-mod-send (fun)-  (concat "find " fun "\n"))--(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"+  (let ((cmd (format "find %s\n" fun)))+    (ghc-sync-process cmd)))  (provide 'ghc-ins-mod)
elisp/ghc-process.el view
@@ -17,24 +17,20 @@ (defvar-local ghc-process-original-buffer nil) (defvar-local ghc-process-original-file nil) (defvar-local ghc-process-callback nil)+(defvar-local ghc-process-hook nil)  (defvar ghc-interactive-command "ghc-modi")  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  (defun ghc-get-project-root ()-  (let ((file (buffer-file-name)))-    (when file-      (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))))))+  (ghc-run-ghc-mod '("root"))) -(defun ghc-with-process (send callback)+(defun ghc-with-process (cmd callback &optional hook1 hook2)   (unless ghc-process-process-name     (setq ghc-process-process-name (ghc-get-project-root)))   (when ghc-process-process-name+    (if hook1 (funcall hook1))     (let* ((cbuf (current-buffer)) 	   (name ghc-process-process-name) 	   (buf (get-buffer-create (concat " ghc-modi:" name)))@@ -46,13 +42,14 @@ 	  (setq ghc-process-original-buffer cbuf) 	  (setq ghc-process-original-file file) 	  (setq ghc-process-callback callback)+	  (setq ghc-process-hook hook2) 	  (erase-buffer)-	  (let ((pro (ghc-get-process cpro name buf))-		(cmd (funcall send)))+	  (let ((pro (ghc-get-process cpro name buf))) 	    (process-send-string pro cmd) 	    (when ghc-debug 	      (ghc-with-debug-buffer-	       (insert (format "%% %s" cmd))))))))))+	       (insert (format "%% %s" cmd))))+	    pro))))))  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -66,7 +63,7 @@    (t cpro)))  (defun ghc-start-process (name buf)-  (let ((pro (start-file-process name buf ghc-interactive-command)))+  (let ((pro (start-file-process name buf ghc-interactive-command "-b" "\n" "-l")))     (set-process-filter pro 'ghc-process-filter)     (set-process-query-on-exit-flag pro nil)     pro))@@ -76,14 +73,59 @@     (goto-char (point-max))     (insert string)     (forward-line -1)-    (when (looking-at "^\\(OK\\|NG\\)$")+    (cond+     ((looking-at "^OK$")+      (if ghc-process-hook (funcall ghc-process-hook))       (goto-char (point-min))-      (funcall ghc-process-callback)+      (funcall ghc-process-callback 'ok)       (when ghc-debug 	(let ((cbuf (current-buffer))) 	  (ghc-with-debug-buffer 	   (insert-buffer-substring cbuf))))-      (setq ghc-process-running nil))))+      (setq ghc-process-running nil))+     ((looking-at "^NG ")+      (funcall ghc-process-callback 'ng)+      (when ghc-debug+	(let ((cbuf (current-buffer)))+	  (ghc-with-debug-buffer+	   (insert-buffer-substring cbuf))))+      (setq ghc-process-running nil)))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defvar ghc-process-rendezvous nil)+(defvar ghc-process-num-of-results nil)+(defvar ghc-process-results nil)++(defun ghc-sync-process (cmd &optional n hook)+  (setq ghc-process-rendezvous nil)+  (setq ghc-process-results nil)+  (setq ghc-process-num-of-results (or n 1))+  (let ((pro (ghc-with-process cmd 'ghc-process-callback nil hook)))+    (condition-case nil+	(while (null ghc-process-rendezvous)+	  ;; 0.1 is too fast for Emacs 24.4.+	  ;; (sit-for 0.1 t) may get stuck when tooltip is displayed.+	  (sit-for 0.1)+	  ;; (discard-input) avoids getting stuck.+	  (discard-input))+      (quit+       (with-current-buffer (process-buffer pro)+	 (setq ghc-process-running nil)))))+  ghc-process-results)++(defun ghc-process-callback (status)+  (cond+   ((eq status 'ok)+    (let* ((n ghc-process-num-of-results)+	   (ret (if (= n 1)+		    (ghc-read-lisp-this-buffer)+		  (ghc-read-lisp-list-this-buffer n))))+      (setq ghc-process-results ret)))+   (t+    (setq ghc-process-results nil)))+  (setq ghc-process-num-of-results nil)+  (setq ghc-process-rendezvous t))  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
elisp/ghc.el view
@@ -7,6 +7,7 @@ ;; Put the following code to your "~/.emacs". ;; ;; (autoload 'ghc-init "ghc" nil t)+;; (autoload 'ghc-debug "ghc" nil t) ;; (add-hook 'haskell-mode-hook (lambda () (ghc-init))) ;; ;; Or if you wish to display error each goto next/prev error,@@ -19,7 +20,7 @@  ;;; Code: -(defconst ghc-version "4.0.2")+(defconst ghc-version "4.1.0")  ;; (eval-when-compile ;;  (require 'haskell-mode))@@ -97,9 +98,34 @@     (define-key haskell-mode-map ghc-deeper-key      'ghc-make-indent-deeper)     (ghc-comp-init)     (setq ghc-initialized t))+  (ghc-import-module)   (ghc-check-syntax))  (defun ghc-abbrev-init ()   (set (make-local-variable 'dabbrev-case-fold-search) nil))++;;;###autoload+(defun ghc-debug ()+  (interactive)+  (let ((el-path (locate-file "ghc.el" load-path))+	(ghc-path (executable-find "ghc"))+	(ghc-mod-path (executable-find ghc-module-command))+	(ghc-modi-path (executable-find ghc-interactive-command))+	(el-ver ghc-version)+	(ghc-ver (ghc-run-ghc-mod '("--version") "ghc"))+	(ghc-mod-ver (ghc-run-ghc-mod '("version")))+	(ghc-modi-ver (ghc-run-ghc-mod '("version") ghc-interactive-command)))+    (switch-to-buffer (get-buffer-create "**GHC Debug**"))+    (erase-buffer)+    (insert "Path: check if you are using intended programs.\n")+    (insert (format "\t  ghc.el path: %s\n" el-path))+    (insert (format "\t ghc-mod path: %s\n" ghc-mod-path))+    (insert (format "\tghc-modi path: %s\n" ghc-modi-path))+    (insert (format "\t     ghc path: %s\n" ghc-path))+    (insert "\nVersion: all versions must be the same.\n")+    (insert (format "\t  ghc.el version %s\n" el-ver))+    (insert (format "\t %s\n" ghc-mod-ver))+    (insert (format "\t%s\n" ghc-modi-ver))+    (insert (format "\t%s\n" ghc-ver))))  (provide 'ghc)
ghc-mod.cabal view
@@ -1,5 +1,5 @@ Name:                   ghc-mod-Version:                4.0.2+Version:                4.1.0 Author:                 Kazu Yamamoto <kazu@iij.ad.jp> Maintainer:             Kazu Yamamoto <kazu@iij.ad.jp> License:                BSD3@@ -26,8 +26,8 @@ Extra-Source-Files:     ChangeLog 			test/data/*.cabal                         test/data/*.hs-                        test/data/cabal.sandbox.config-                        test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/dummy+                        test/data/cabal.sandbox.config.in+                        test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf                         test/data/broken-cabal/*.cabal                         test/data/broken-sandbox/*.cabal                         test/data/broken-sandbox/cabal.sandbox.config@@ -35,6 +35,8 @@                         test/data/check-test-subdir/src/Check/Test/*.hs                         test/data/check-test-subdir/test/*.hs                         test/data/check-test-subdir/test/Bar/*.hs+                        test/data/check-packageid/cabal.sandbox.config.in+                        test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c.conf                         test/data/ghc-mod-check/*.cabal                         test/data/ghc-mod-check/*.hs                         test/data/ghc-mod-check/Data/*.hs@@ -44,31 +46,37 @@   Default-Language:     Haskell2010   GHC-Options:          -Wall   Exposed-Modules:      Language.Haskell.GhcMod+                        Language.Haskell.GhcMod.Ghc                         Language.Haskell.GhcMod.Internal-  Other-Modules:        Language.Haskell.GhcMod.Browse+  Other-Modules:        Language.Haskell.GhcMod.Boot+                        Language.Haskell.GhcMod.Browse                         Language.Haskell.GhcMod.CabalApi                         Language.Haskell.GhcMod.Check                         Language.Haskell.GhcMod.Cradle                         Language.Haskell.GhcMod.Debug                         Language.Haskell.GhcMod.Doc-                        Language.Haskell.GhcMod.ErrMsg+                        Language.Haskell.GhcMod.Find                         Language.Haskell.GhcMod.Flag                         Language.Haskell.GhcMod.GHCApi                         Language.Haskell.GhcMod.GHCChoice                         Language.Haskell.GhcMod.Gap+                        Language.Haskell.GhcMod.GhcPkg+                        Language.Haskell.GhcMod.Logger                         Language.Haskell.GhcMod.Info                         Language.Haskell.GhcMod.Lang                         Language.Haskell.GhcMod.Lint                         Language.Haskell.GhcMod.List                         Language.Haskell.GhcMod.PkgDoc+                        Language.Haskell.GhcMod.Utils                         Language.Haskell.GhcMod.Types   Build-Depends:        base >= 4.0 && < 5                       , containers+                      , deepseq                       , directory                       , filepath                       , ghc                       , ghc-syb-utils-                      , hlint >= 1.8.58+                      , hlint >= 1.8.61                       , io-choice                       , old-time                       , process@@ -117,10 +125,11 @@  Test-Suite spec   Default-Language:     Haskell2010-  Main-Is:              Spec.hs+  Main-Is:              Main.hs   Hs-Source-Dirs:       test, .   Type:                 exitcode-stdio-1.0   Other-Modules:        Dir+                        Spec                         BrowseSpec                         CabalApiSpec                         CheckSpec@@ -129,8 +138,10 @@                         LangSpec                         LintSpec                         ListSpec+                        GhcPkgSpec   Build-Depends:        base >= 4.0 && < 5                       , containers+                      , deepseq                       , directory                       , filepath                       , ghc
src/GHCMod.hs view
@@ -2,6 +2,7 @@  module Main where +import Config (cProjectVersion) import Control.Applicative ((<$>)) import Control.Exception (Exception, Handler(..), ErrorCall(..)) import qualified Control.Exception as E@@ -18,26 +19,34 @@  ---------------------------------------------------------------- +progVersion :: String+progVersion = "ghc-mod version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ++ "\n"+ ghcOptHelp :: String ghcOptHelp = " [-g GHC_opt1 -g GHC_opt2 ...] "  usage :: String-usage =    "ghc-mod version " ++ showVersion version ++ "\n"+usage =    progVersion         ++ "Usage:\n"         ++ "\t ghc-mod list" ++ ghcOptHelp ++ "[-l] [-d]\n"         ++ "\t ghc-mod lang [-l]\n"         ++ "\t ghc-mod flag [-l]\n"-        ++ "\t ghc-mod browse" ++ ghcOptHelp ++ "[-l] [-o] [-d] [-q] [-p package] <module> [<module> ...]\n"+        ++ "\t ghc-mod browse" ++ ghcOptHelp ++ "[-l] [-o] [-d] [-q] [<package>:]<module> [[<package>:]<module> ...]\n"         ++ "\t ghc-mod check" ++ ghcOptHelp ++ "<HaskellFiles...>\n"         ++ "\t ghc-mod expand" ++ ghcOptHelp ++ "<HaskellFiles...>\n"-        ++ "\t ghc-mod debug" ++ ghcOptHelp ++ "<HaskellFile>\n"+        ++ "\t ghc-mod debug" ++ ghcOptHelp ++ "\n"         ++ "\t ghc-mod info" ++ ghcOptHelp ++ "<HaskellFile> <module> <expression>\n"         ++ "\t ghc-mod type" ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"+        ++ "\t ghc-mod find <symbol>\n"         ++ "\t ghc-mod lint [-h opt] <HaskellFile>\n"-        ++ "\t ghc-mod root <HaskellFile>\n"+        ++ "\t ghc-mod root\n"         ++ "\t ghc-mod doc <module>\n"         ++ "\t ghc-mod boot\n"+        ++ "\t ghc-mod version\n"         ++ "\t ghc-mod help\n"+        ++ "\n"+        ++ "<module> for \"info\" and \"type\" is not used, anything is OK.\n"+        ++ "It is necessary to maintain backward compatibility.\n"  ---------------------------------------------------------------- @@ -60,9 +69,6 @@           , Option "q" ["qualified"]             (NoArg (\opts -> opts { qualified = True }))             "show qualified names"-          , Option "p" ["package"]-            (ReqArg (\p opts -> opts { packageId = Just p, ghcOpts = ("-package " ++ p) : ghcOpts opts }) "package-id")-            "specify package of module"           , Option "b" ["boundary"]             (ReqArg (\s opts -> opts { lineSeparator = LineSeparator s }) "sep")             "specify line separator (default is Nul string)"@@ -96,7 +102,6 @@     cradle <- findCradle     let cmdArg0 = cmdArg !. 0         cmdArg1 = cmdArg !. 1-        cmdArg2 = cmdArg !. 2         cmdArg3 = cmdArg !. 3         cmdArg4 = cmdArg !. 4         remainingArgs = tail cmdArg@@ -104,26 +109,23 @@                         then f                         else E.throw (TooManyArguments cmdArg0)     res <- case cmdArg0 of-      "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-      "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-      "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 $ O.usageInfo usage argspec-      cmd      -> E.throw (NoSuchCommand cmd)+      "list"    -> listModules opt cradle+      "lang"    -> listLanguages opt+      "flag"    -> listFlags opt+      "browse"  -> concat <$> mapM (browseModule opt cradle) remainingArgs+      "check"   -> checkSyntax opt cradle remainingArgs+      "expand"  -> expandTemplate opt cradle remainingArgs+      "debug"   -> debugInfo opt cradle+      "info"    -> nArgs 3 infoExpr opt cradle cmdArg1 cmdArg3+      "type"    -> nArgs 4 $ typeExpr opt cradle cmdArg1 (read cmdArg3) (read cmdArg4)+      "find"    -> nArgs 1 $ findSymbol opt cradle cmdArg1+      "lint"    -> nArgs 1 withFile (lintSyntax opt) cmdArg1+      "root"    -> rootInfo opt cradle+      "doc"     -> nArgs 1 $ packageDoc opt cradle cmdArg1+      "boot"    -> bootInfo opt cradle+      "version" -> return progVersion+      "help"    -> return $ O.usageInfo usage argspec+      cmd       -> E.throw (NoSuchCommand cmd)     putStr res   where     handlers = [Handler (handleThenExit handler1), Handler (handleThenExit handler2)]@@ -153,17 +155,3 @@     xs !. idx       | length xs <= idx = E.throw SafeList       | otherwise = xs !! idx--------------------------------------------------------------------preBrowsedModules :: [String]-preBrowsedModules = [-    "Prelude"-  , "Control.Applicative"-  , "Control.Monad"-  , "Control.Exception"-  , "Data.Char"-  , "Data.List"-  , "Data.Maybe"-  , "System.IO"-  ]
src/GHCModi.hs view
@@ -1,12 +1,16 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}  -- Commands: --  check <file> --  find <symbol>+--  info <file> <expr>+--  type <file> <line> <column> --  lint [hlint options] <file> --     the format of hlint options is [String] because they may contain---     spaces and aslo <file> may contain spaces.+--     spaces and also <file> may contain spaces.+--  boot+--  browse [<package>:]<module>+--  quit -- -- Session separators: --   OK -- success@@ -14,35 +18,23 @@  module Main where -#ifndef MIN_VERSION_containers-#define MIN_VERSION_containers(x,y,z) 1-#endif-+import Config (cProjectVersion) import Control.Applicative ((<$>)) import Control.Concurrent (forkIO, MVar, newEmptyMVar, putMVar, readMVar)-import Control.Exception (SomeException(..))+import Control.Exception (SomeException(..), Exception) 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.List (find) import Data.Maybe (fromMaybe) import Data.Set (Set) import qualified Data.Set as S-import Data.Typeable+import Data.Typeable (Typeable) import Data.Version (showVersion)-import qualified Exception as GE-import GHC (Ghc, LoadHowMuch(LoadAllTargets), TargetId(TargetFile))+import GHC (Ghc) import qualified GHC as G-import HscTypes (SourceError) import Language.Haskell.GhcMod+import Language.Haskell.GhcMod.Ghc import Language.Haskell.GhcMod.Internal import Paths_ghc_mod import System.Console.GetOpt@@ -52,35 +44,43 @@  ---------------------------------------------------------------- -type DB = Map String [String]-type Logger = IO [String]+type Logger = IO String  ---------------------------------------------------------------- +progVersion :: String+progVersion = "ghc-modi version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ++ "\n"+ argspec :: [OptDescr (Options -> Options)] argspec = [ Option "b" ["boundary"]             (ReqArg (\s opts -> opts { lineSeparator = LineSeparator s }) "sep")             "specify line separator (default is Nul string)"+          , Option "l" ["tolisp"]+            (NoArg (\opts -> opts { outputStyle = LispStyle }))+            "print as a list of Lisp"+          , Option "g" []+            (ReqArg (\s opts -> opts { ghcOpts = s : ghcOpts opts }) "flag") "specify a ghc flag"           ]  usage :: String-usage =    "ghc-modi version " ++ showVersion version ++ "\n"+usage =    progVersion         ++ "Usage:\n"-        ++ "\t ghc-modi [-b sep]\n"+        ++ "\t ghc-modi [-l] [-b sep] [-g flag]\n"+        ++ "\t ghc-modi version\n"         ++ "\t ghc-modi help\n"  parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String]) parseArgs spec argv     = case getOpt Permute spec argv of         (o,n,[]  ) -> (foldr id defaultOptions o, n)-        (_,_,errs) -> GE.throw (CmdArg errs)+        (_,_,errs) -> E.throw (CmdArg errs)  ----------------------------------------------------------------  data GHCModiError = CmdArg [String]                   deriving (Show, Typeable) -instance GE.Exception GHCModiError+instance Exception GHCModiError  ---------------------------------------------------------------- @@ -88,133 +88,133 @@ -- C-c since installSignalHandlers is called twice, sigh.  main :: IO ()-main = handle [GE.Handler cmdHandler, GE.Handler someHandler] $+main = E.handle cmdHandler $     go =<< parseArgs argspec <$> getArgs   where-    handle = flip GE.catches-    LineSeparator lsc = lineSeparator defaultOptions-    cmdHandler (CmdArg e) = do-        putStr "ghc-modi:0:0:"-        let x = intercalate lsc e-        putStrLn x-        putStr $ usageInfo usage argspec-        putStrLn "NG"-    someHandler (SomeException e) = do-        putStr "ghc-modi:0:0:"-        let x = intercalate lsc $ lines $ show e-        putStrLn x-        putStrLn "NG"-    go (_,"help":_) = do-        putStr $ usageInfo usage argspec-        putStrLn "NG"-    go (opt,_) = do+    cmdHandler (CmdArg _) = putStr $ usageInfo usage argspec+    go (_,"help":_) = putStr $ usageInfo usage argspec+    go (_,"version":_) = putStr progVersion+    go (opt,_) = E.handle someHandler $ do         cradle0 <- findCradle         let rootdir = cradleRootDir cradle0             cradle = cradle0 { cradleCurrentDir = rootdir }-            ls = lineSeparator opt         setCurrentDirectory rootdir         mvar <- liftIO newEmptyMVar         mlibdir <- getSystemLibDir         void $ forkIO $ setupDB cradle mlibdir opt mvar-        run cradle mlibdir opt $ loop S.empty ls mvar+        run cradle mlibdir opt $ loop opt S.empty mvar+      where+        -- this is just in case.+        -- If an error is caught here, it is a bug of GhcMod library.+        someHandler (SomeException e) = do+            putStrLn $ "NG " ++ replace (show e) +replace :: String -> String+replace [] = []+replace ('\n':xs) = ';' : replace xs+replace (x:xs)    =  x  : replace xs+ ---------------------------------------------------------------- -run :: Cradle -> Maybe FilePath -> Options -> (Logger -> Ghc a) -> IO a+run :: Cradle -> Maybe FilePath -> Options -> Ghc a -> IO a run cradle mlibdir opt body = G.runGhc mlibdir $ do-    (readLog,_) <- initializeFlagsWithCradle opt cradle ["-Wall"] True+    initializeFlagsWithCradle opt cradle     dflags <- G.getSessionDynFlags-    G.defaultCleanupHandler dflags $ body readLog+    G.defaultCleanupHandler dflags body  ---------------------------------------------------------------- -setupDB :: Cradle -> Maybe FilePath -> Options -> MVar DB -> IO ()+setupDB :: Cradle -> Maybe FilePath -> Options -> MVar SymMdlDb -> 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+    db <- run cradle mlibdir opt getSymMdlDb+    putMVar mvar db   where-    tieup x = (head (map fst x), map snd x)-    handler (SomeException _) = return ()+    handler (SomeException _) = return () -- fixme: put emptyDb?  ---------------------------------------------------------------- -loop :: Set FilePath -> LineSeparator -> MVar DB -> Logger -> Ghc ()-loop set ls mvar readLog  = do+loop :: Options -> Set FilePath -> MVar SymMdlDb -> Ghc ()+loop opt set mvar = 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"+    (ret,ok,set') <- case cmd of+        "check"  -> checkStx opt set arg+        "find"   -> findSym  opt set arg mvar+        "lint"   -> lintStx  opt set arg+        "info"   -> showInfo opt set arg+        "type"   -> showType opt set arg+        "boot"   -> bootIt   opt set+        "browse" -> browseIt opt set arg+        "quit"   -> return ("quit", False, set)+        ""       -> return ("quit", False, set)+        _        -> return ([], True, set)+    if ok then do+        liftIO $ putStr ret+        liftIO $ putStrLn "OK"+      else do+        liftIO $ putStrLn $ "NG " ++ replace ret     liftIO $ hFlush stdout-    when ok $ loop set' ls mvar readLog+    when ok $ loop opt set' mvar  ---------------------------------------------------------------- -checkStx :: Set FilePath-         -> LineSeparator-         -> Logger+checkStx :: Options+         -> Set FilePath          -> 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)+         -> Ghc (String, Bool, Set FilePath)+checkStx opt set file = do+    set' <- newFileSet set file+    let files = S.toList set'+    eret <- check opt files+    case eret of+        Right ret -> return (ret, True, set')+        Left ret  -> return (ret, True, set) -- fxime: set++newFileSet :: Set FilePath -> FilePath -> Ghc (Set FilePath)+newFileSet set file = do+    let set1+         | S.member file set = set+         | otherwise         = S.insert file set+    mx <- isSameMainFile file <$> getModSummaryForMain+    return $ case mx of+        Nothing       -> set1+        Just mainfile -> S.delete mainfile set1++getModSummaryForMain :: Ghc (Maybe G.ModSummary)+getModSummaryForMain = find isMain <$> G.getModuleGraph   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+isSameMainFile :: FilePath -> (Maybe G.ModSummary) -> Maybe FilePath+isSameMainFile _    Nothing  = Nothing+isSameMainFile file (Just x)+    | mainfile == file = Nothing+    | otherwise        = Just mainfile+  where+    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++----------------------------------------------------------------++findSym :: Options -> Set FilePath -> String -> MVar SymMdlDb+        -> Ghc (String, Bool, Set FilePath)+findSym opt set sym mvar = do     db <- liftIO $ readMVar mvar-    let ret = fromMaybe [] (M.lookup sym db)+    let ret = lookupSym opt 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)+lintStx :: Options -> Set FilePath -> FilePath+        -> Ghc (String, Bool, Set FilePath)+lintStx opt set optFile = liftIO $ do+    ret <-lintSyntax opt' file+    return (ret, 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)+    (opts,file) = parseLintOptions optFile+    hopts = if opts == "" then [] else read opts+    opt' = opt { hlintOpts = hopts }  -- | -- >>> parseLintOptions "[\"--ignore=Use camelCase\", \"--ignore=Eta reduce\"] file name"@@ -230,3 +230,42 @@     brk p (x:xs')         | p x        =  ([x],xs')         | otherwise  =  let (ys,zs) = brk p xs' in (x:ys,zs)++----------------------------------------------------------------++showInfo :: Options+         -> Set FilePath+         -> FilePath+         -> Ghc (String, Bool, Set FilePath)+showInfo opt set fileArg = do+    let [file, expr] = words fileArg+    set' <- newFileSet set file+    ret <- info opt file expr+    return (ret, True, set')++showType :: Options+         -> Set FilePath+         -> FilePath+         -> Ghc (String, Bool, Set FilePath)+showType opt set fileArg  = do+    let [file, line, column] = words fileArg+    set' <- newFileSet set file+    ret <- types opt file (read line) (read column)+    return (ret, True, set')++----------------------------------------------------------------++bootIt :: Options+       -> Set FilePath+       -> Ghc (String, Bool, Set FilePath)+bootIt opt set = do+    ret <- boot opt+    return (ret, True, set)++browseIt :: Options+         -> Set FilePath+         -> ModuleString+         -> Ghc (String, Bool, Set FilePath)+browseIt opt set mdl = do+    ret <- browse opt mdl+    return (ret, True, set)
test/CabalApiSpec.hs view
@@ -9,9 +9,17 @@ import Language.Haskell.GhcMod.Cradle import Language.Haskell.GhcMod.Types import Test.Hspec+import System.Directory+import System.FilePath  import Dir +import Config (cProjectVersionInt) -- ghc version++ghcVersion :: Int+ghcVersion = read cProjectVersionInt++ spec :: Spec spec = do     describe "parseCabalFile" $ do@@ -20,6 +28,7 @@      describe "getCompilerOptions" $ do         it "gets necessary CompilerOptions" $ do+            cwd <- getCurrentDirectory             withDirectory "test/data/subdir1/subdir2" $ \dir -> do                 cradle <- findCradle                 pkgDesc <- parseCabalFile $ fromJust $ cradleCabalFile cradle@@ -28,7 +37,12 @@                         ghcOptions  = ghcOptions res                       , includeDirs = map (toRelativeDir dir) (includeDirs res)                       }-                res' `shouldBe` CompilerOptions {ghcOptions = ["-no-user-package-db","-package-db","/home/me/work/ghc-mod/test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d","-XHaskell98"], includeDirs = ["test/data","test/data/dist/build","test/data/dist/build/autogen","test/data/subdir1/subdir2","test/data/test"], depPackages = [("Cabal", Nothing), ("base", Nothing) , ("template-haskell", Nothing)]}+                if ghcVersion < 706+                  then ghcOptions res' `shouldBe` ["-global-package-conf", "-no-user-package-conf","-package-conf",cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d","-XHaskell98"]+                  else ghcOptions res' `shouldBe` ["-global-package-db", "-no-user-package-db","-package-db",cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d","-XHaskell98"]+                includeDirs res' `shouldBe` ["test/data","test/data/dist/build","test/data/dist/build/autogen","test/data/subdir1/subdir2","test/data/test"]+                depPackages res' `shouldSatisfy` (("Cabal", "1.18.1.3", "2b161c6bf77657aa17e1681d83cb051b")`elem`)+      describe "cabalDependPackages" $ do         it "extracts dependent packages" $ do
+ test/GhcPkgSpec.hs view
@@ -0,0 +1,28 @@+module GhcPkgSpec where++import Language.Haskell.GhcMod.Types+import Language.Haskell.GhcMod.GhcPkg++import Control.Applicative+import System.Directory+import System.FilePath ((</>))+import Test.Hspec++import Dir++spec :: Spec+spec = do+    describe "getSandboxDb" $ do+        it "parses a config file and extracts sandbox package db" $ do+            cwd <- getCurrentDirectory+            pkgDb <- getSandboxDb "test/data/"+            pkgDb `shouldBe` (cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d")++        it "throws an error if a config file is broken" $ do+            getSandboxDb "test/data/broken-sandbox" `shouldThrow` anyException++    describe "getPackageDbPackages" $ do+        it "find a config file and extracts packages" $ do+            sdb <- getSandboxDb "test/data/check-packageid"+            pkgs <- ghcPkgListEx [PackageDb sdb]+            pkgs `shouldBe` [("template-haskell","2.8.0.0","32d4f24abdbb6bf41272b183b2e23e9c")]
test/InfoSpec.hs view
@@ -23,38 +23,38 @@         it "shows types of the expression and its outers" $ do             withDirectory_ "test/data/ghc-mod-check" $ do                 cradle <- findCradleWithoutSandbox-                res <- typeExpr defaultOptions cradle "Data/Foo.hs" "Data.Foo" 9 5+                res <- typeExpr defaultOptions cradle "Data/Foo.hs" 9 5                 res `shouldBe` "9 5 11 40 \"Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n"          it "works with a module using TemplateHaskell" $ do             withDirectory_ "test/data" $ do                 cradle <- findCradleWithoutSandbox-                res <- typeExpr defaultOptions cradle "Bar.hs" "Bar" 5 1+                res <- typeExpr defaultOptions cradle "Bar.hs" 5 1                 res `shouldBe` unlines ["5 1 5 20 \"[Char]\""]          it "works with a module that imports another module using TemplateHaskell" $ do             withDirectory_ "test/data" $ do                 cradle <- findCradleWithoutSandbox-                res <- typeExpr defaultOptions cradle "Main.hs" "Main" 3 8+                res <- typeExpr defaultOptions cradle "Main.hs" 3 8                 res `shouldBe` unlines ["3 8 3 16 \"String -> IO ()\"", "3 8 3 20 \"IO ()\"", "3 1 3 20 \"IO ()\""]      describe "infoExpr" $ do         it "works for non-export functions" $ do             withDirectory_ "test/data" $ do                 cradle <- findCradleWithoutSandbox-                res <- infoExpr defaultOptions cradle "Info.hs" "Info" "fib"+                res <- infoExpr defaultOptions cradle "Info.hs" "fib"                 res `shouldSatisfy` ("fib :: Int -> Int" `isPrefixOf`)          it "works with a module using TemplateHaskell" $ do             withDirectory_ "test/data" $ do                 cradle <- findCradleWithoutSandbox-                res <- infoExpr defaultOptions cradle "Bar.hs" "Bar" "foo"+                res <- infoExpr defaultOptions cradle "Bar.hs" "foo"                 res `shouldSatisfy` ("foo :: ExpQ" `isPrefixOf`)          it "works with a module that imports another module using TemplateHaskell" $ do             withDirectory_ "test/data" $ do                 cradle <- findCradleWithoutSandbox-                res <- infoExpr defaultOptions cradle "Main.hs" "Main" "bar"+                res <- infoExpr defaultOptions cradle "Main.hs" "bar"                 res `shouldSatisfy` ("bar :: [Char]" `isPrefixOf`)          it "doesn't fail on unicode output" $ do
+ test/Main.hs view
@@ -0,0 +1,12 @@+import Spec+import Dir++import Test.Hspec+import System.Process++main = do+  let sandboxes = [ "test/data", "test/data/check-packageid" ]+      genSandboxCfg dir = withDirectory dir $ \cwd -> do+         system ("sed 's|@CWD@|" ++ cwd ++ "|g' cabal.sandbox.config.in > cabal.sandbox.config")+  genSandboxCfg `mapM` sandboxes+  hspec spec
test/Spec.hs view
@@ -1,1 +1,1 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-}
+ test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf view
@@ -0,0 +1,4 @@+name: Cabal+version: 1.18.1.3+id: Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b+exposed: True
− test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/dummy 
@@ -1,1 +0,0 @@-dummy
− test/data/Bs.hs 
@@ -1,11 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Bs where--import Data.ByteString.Lazy (ByteString)-import qualified Data.ByteString as B--foo :: ByteString-foo = "foo"--bar = B.putStrLn foo
− test/data/cabal.sandbox.config 
@@ -1,25 +0,0 @@--- This is a Cabal package environment file.--- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY.--- Please create a 'cabal.config' file in the same directory--- if you want to change the default settings for this sandbox.---local-repo: /home/me/work/ghc-mod/test/data/.cabal-sandbox/packages-logs-dir: /home/me/work/ghc-mod/test/data/.cabal-sandbox/logs-world-file: /home/me/work/ghc-mod/test/data/.cabal-sandbox/world-user-install: False-package-db: /home/me/work/ghc-mod/test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d-build-summary: /home/me/work/ghc-mod/test/data/.cabal-sandbox/logs/build.log--install-dirs -  prefix: /home/me/work/ghc-mod/test/data/.cabal-sandbox-  bindir: $prefix/bin-  libdir: $prefix/lib-  libsubdir: $arch-$os-$compiler/$pkgid-  libexecdir: $prefix/libexec-  datadir: $prefix/share-  datasubdir: $arch-$os-$compiler/$pkgid-  docdir: $datadir/doc/$arch-$os-$compiler/$pkgid-  htmldir: $docdir/html-  haddockdir: $htmldir-  sysconfdir: $prefix/etc
+ test/data/cabal.sandbox.config.in view
@@ -0,0 +1,25 @@+-- This is a Cabal package environment file.+-- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY.+-- Please create a 'cabal.config' file in the same directory+-- if you want to change the default settings for this sandbox.+++local-repo: @CWD@/test/data/.cabal-sandbox/packages+logs-dir: @CWD@/test/data/.cabal-sandbox/logs+world-file: @CWD@/test/data/.cabal-sandbox/world+user-install: False+package-db: @CWD@/test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d+build-summary: @CWD@/test/data/.cabal-sandbox/logs/build.log++install-dirs+  prefix: @CWD@/test/data/.cabal-sandbox+  bindir: $prefix/bin+  libdir: $prefix/lib+  libsubdir: $arch-$os-$compiler/$pkgid+  libexecdir: $prefix/libexec+  datadir: $prefix/share+  datasubdir: $arch-$os-$compiler/$pkgid+  docdir: $datadir/doc/$arch-$os-$compiler/$pkgid+  htmldir: $docdir/html+  haddockdir: $htmldir+  sysconfdir: $prefix/etc
+ test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c.conf view
@@ -0,0 +1,4 @@+name: template-haskell+version: 2.8.0.0+id: template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c+exposed: True
+ test/data/check-packageid/cabal.sandbox.config.in view
@@ -0,0 +1,25 @@+-- This is a Cabal package environment file.+-- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY.+-- Please create a 'cabal.config' file in the same directory+-- if you want to change the default settings for this sandbox.+++local-repo: @CWD@/test/data/.cabal-sandbox/packages+logs-dir: @CWD@/test/data/.cabal-sandbox/logs+world-file: @CWD@/test/data/.cabal-sandbox/world+user-install: False+package-db: test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d+build-summary: @CWD@/test/data/.cabal-sandbox/logs/build.log++install-dirs+  prefix: @CWD@/test/data/.cabal-sandbox+  bindir: $prefix/bin+  libdir: $prefix/lib+  libsubdir: $arch-$os-$compiler/$pkgid+  libexecdir: $prefix/libexec+  datadir: $prefix/share+  datasubdir: $arch-$os-$compiler/$pkgid+  docdir: $datadir/doc/$arch-$os-$compiler/$pkgid+  htmldir: $docdir/html+  haddockdir: $htmldir+  sysconfdir: $prefix/etc
test/doctests.hs view
@@ -6,5 +6,8 @@ main = doctest [     "-package"   , "ghc"+  , "-idist/build/autogen/"+  , "-optP-include"+  , "-optPdist/build/autogen/cabal_macros.h"   , "Language/Haskell/GhcMod.hs"   ]