ghc-mod 5.1.0.2 → 5.1.1.0
raw patch · 18 files changed
+906/−401 lines, 18 filesdep +data-defaultdep +prettydep ~ghcdep ~ghc-syb-utilsdep ~haskell-src-extsPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: data-default, pretty
Dependency ranges changed: ghc, ghc-syb-utils, haskell-src-exts, mtl
API changes (from Hackage documentation)
+ Language.Haskell.GhcMod: cabalProgram :: Options -> FilePath
+ Language.Haskell.GhcMod: ghcProgram :: Options -> FilePath
+ Language.Haskell.GhcMod: isOutdated :: SymbolDb -> IO Bool
+ Language.Haskell.GhcMod.Internal: data World
+ Language.Haskell.GhcMod.Internal: getCurrentWorld :: Cradle -> IO World
+ Language.Haskell.GhcMod.Internal: ghcModExecutable :: IO FilePath
+ Language.Haskell.GhcMod.Internal: gmeDoc :: GhcModError -> Doc
+ Language.Haskell.GhcMod.Internal: isWorldChanged :: World -> Cradle -> IO Bool
- Language.Haskell.GhcMod: Options :: OutputStyle -> [String] -> [GHCOption] -> Bool -> Bool -> Bool -> LineSeparator -> Options
+ Language.Haskell.GhcMod: Options :: OutputStyle -> LineSeparator -> FilePath -> FilePath -> [GHCOption] -> Bool -> Bool -> Bool -> [String] -> Options
Files
- ChangeLog +4/−0
- Language/Haskell/GhcMod.hs +1/−0
- Language/Haskell/GhcMod/CabalApi.hs +2/−2
- Language/Haskell/GhcMod/CabalConfig.hs +82/−10
- Language/Haskell/GhcMod/Check.hs +6/−2
- Language/Haskell/GhcMod/Error.hs +16/−0
- Language/Haskell/GhcMod/Find.hs +29/−69
- Language/Haskell/GhcMod/GhcPkg.hs +42/−1
- Language/Haskell/GhcMod/Internal.hs +11/−1
- Language/Haskell/GhcMod/Monad.hs +3/−3
- Language/Haskell/GhcMod/Types.hs +10/−3
- Language/Haskell/GhcMod/Utils.hs +27/−1
- elisp/ghc-rewrite.el +2/−2
- elisp/ghc.el +1/−1
- ghc-mod.cabal +13/−2
- src/GHCMod.hs +409/−145
- src/GHCModi.hs +94/−159
- src/Misc.hs +154/−0
ChangeLog view
@@ -1,3 +1,7 @@+2014-10-04 v5.1.1.0+ * Handle various consistency related issues: #222, #224, #326, #332+ * Add `isOutdated` to Language.Haskell.GhcMod+ 2014-09-17 v5.1.0.2 * Fix building with haskell-src-exts < 1.16.0
Language/Haskell/GhcMod.hs view
@@ -46,6 +46,7 @@ , dumpSymbol -- * SymbolDb , loadSymbolDb+ , isOutdated ) where import Language.Haskell.GhcMod.Boot
Language/Haskell/GhcMod/CabalApi.hs view
@@ -31,7 +31,7 @@ import Distribution.PackageDescription.Configuration (finalizePackageDescription) import Distribution.PackageDescription.Parse (readPackageDescription) import Distribution.Simple.Compiler (CompilerId(..), CompilerFlavor(..))-import Distribution.Simple.Program (ghcProgram)+import Distribution.Simple.Program as C (ghcProgram) import Distribution.Simple.Program.Types (programName, programFindVersion) import Distribution.System (buildPlatform) import Distribution.Text (display)@@ -155,7 +155,7 @@ getGHC :: IO Version getGHC = do- mv <- programFindVersion ghcProgram silent (programName ghcProgram)+ mv <- programFindVersion C.ghcProgram silent (programName C.ghcProgram) case mv of -- TODO: MonadError it up Nothing -> E.throwIO $ userError "ghc not found"
Language/Haskell/GhcMod/CabalConfig.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards, CPP #-} -- | This module facilitates extracting information from Cabal's on-disk -- 'LocalBuildInfo' (@dist/setup-config@).@@ -6,13 +6,17 @@ CabalConfig , cabalConfigDependencies , cabalConfigFlags+ , setupConfigFile+ , World+ , getCurrentWorld+ , isWorldChanged ) where import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.GhcPkg-import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.Read import Language.Haskell.GhcMod.Types+import Language.Haskell.GhcMod.Utils import qualified Language.Haskell.GhcMod.Cabal16 as C16 import qualified Language.Haskell.GhcMod.Cabal18 as C18@@ -23,7 +27,7 @@ #endif import Control.Applicative ((<$>))-import Control.Monad (mplus)+import Control.Monad (unless, void, mplus) #if MIN_VERSION_mtl(2,2,1) import Control.Monad.Except () #else@@ -39,9 +43,17 @@ import Distribution.Simple.BuildPaths (defaultDistPref) import Distribution.Simple.Configure (localBuildInfoFile) import Distribution.Simple.LocalBuildInfo (ComponentName)+import Data.Traversable (traverse) import MonadUtils (liftIO)+import System.Directory (doesFileExist, getModificationTime) import System.FilePath ((</>)) +#if __GLASGOW_HASKELL__ <= 704+import System.Time (ClockTime)+#else+import Data.Time (UTCTime)+#endif+ ---------------------------------------------------------------- -- | 'Show'ed cabal 'LocalBuildInfo' string@@ -53,20 +65,26 @@ getConfig :: (IOish m, MonadError GhcModError m) => Cradle -> m CabalConfig-getConfig cradle = liftIO (readFile path) `tryFix` \_ ->- configure `modifyError'` GMECabalConfigure+getConfig cradle = do+ world <- liftIO $ getCurrentWorld cradle+ let valid = isSetupConfigValid world+ unless valid configure+ liftIO (readFile file) `tryFix` \_ ->+ configure `modifyError'` GMECabalConfigure where+ file = setupConfigFile cradle prjDir = cradleRootDir cradle- path = prjDir </> configPath configure :: (IOish m, MonadError GhcModError m) => m ()- configure =- withDirectory_ prjDir $ readProcess' "cabal" ["configure"] >> return ()+ configure = withDirectory_ prjDir $ void $ readProcess' "cabal" ["configure"] +setupConfigFile :: Cradle -> FilePath+setupConfigFile crdl = cradleRootDir crdl </> setupConfigPath+ -- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@-configPath :: FilePath-configPath = localBuildInfoFile defaultDistPref+setupConfigPath :: FilePath+setupConfigPath = localBuildInfoFile defaultDistPref -- | Get list of 'Package's needed by all components of the current package cabalConfigDependencies :: (IOish m, MonadError GhcModError m)@@ -175,3 +193,57 @@ case extractParens <$> find (field `isPrefixOf`) (tails config) of Just f -> Right f Nothing -> Left $ "extractField: failed extracting "++field++" from input, input contained `"++field++"'? " ++ show (field `isInfixOf` config)++----------------------------------------------------------------++#if __GLASGOW_HASKELL__ <= 704+type ModTime = ClockTime+#else+type ModTime = UTCTime+#endif++data World = World {+ worldCabalFile :: Maybe FilePath+ , worldCabalFileModificationTime :: Maybe ModTime+ , worldPackageCache :: FilePath+ , worldPackageCacheModificationTime :: ModTime+ , worldSetupConfig :: FilePath+ , worldSetupConfigModificationTime :: Maybe ModTime+ } deriving (Show, Eq)++getCurrentWorld :: Cradle -> IO World+getCurrentWorld crdl = do+ cachePath <- getPackageCachePath crdl+ let mCabalFile = cradleCabalFile crdl+ pkgCache = cachePath </> packageCache+ setupFile = setupConfigFile crdl+ mCabalFileMTime <- getModificationTime `traverse` mCabalFile+ pkgCacheMTime <- getModificationTime pkgCache+ exist <- doesFileExist setupFile+ mSeetupMTime <- if exist then+ Just <$> getModificationTime setupFile+ else+ return Nothing+ return $ World {+ worldCabalFile = mCabalFile+ , worldCabalFileModificationTime = mCabalFileMTime+ , worldPackageCache = pkgCache+ , worldPackageCacheModificationTime = pkgCacheMTime+ , worldSetupConfig = setupFile+ , worldSetupConfigModificationTime = mSeetupMTime+ }++isWorldChanged :: World -> Cradle -> IO Bool+isWorldChanged world crdl = do+ world' <- getCurrentWorld crdl+ return (world /= world')++isSetupConfigValid :: World -> Bool+isSetupConfigValid World{ worldSetupConfigModificationTime = Nothing, ..} = False+isSetupConfigValid World{ worldSetupConfigModificationTime = Just mt, ..} =+ cond1 && cond2+ where+ cond1 = case worldCabalFileModificationTime of+ Nothing -> True+ Just mtime -> mtime <= mt+ cond2 = worldPackageCacheModificationTime <= mt
Language/Haskell/GhcMod/Check.hs view
@@ -8,9 +8,8 @@ import Control.Applicative ((<$>)) import Language.Haskell.GhcMod.DynFlags import qualified Language.Haskell.GhcMod.Gap as Gap-import qualified GHC as G import Language.Haskell.GhcMod.Logger-import Language.Haskell.GhcMod.Monad (IOish, GhcModT, overrideGhcUserOptions)+import Language.Haskell.GhcMod.Monad (IOish, GhcModT) import Language.Haskell.GhcMod.Target (setTargetFiles) ----------------------------------------------------------------@@ -30,9 +29,14 @@ check :: IOish m => [FilePath] -- ^ The target files. -> GhcModT m (Either String String)+{- check fileNames = overrideGhcUserOptions $ \ghcOpts -> do withLogger (setAllWarningFlags . setNoMaxRelevantBindings . Gap.setWarnTypedHoles . Gap.setDeferTypeErrors) $ do _ <- G.setSessionDynFlags =<< addCmdOpts ghcOpts =<< G.getSessionDynFlags+ setTargetFiles fileNames+-}+check fileNames =+ withLogger (setAllWarningFlags . setNoMaxRelevantBindings) $ setTargetFiles fileNames ----------------------------------------------------------------
Language/Haskell/GhcMod/Error.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE TypeFamilies, ScopedTypeVariables #-} module Language.Haskell.GhcMod.Error ( GhcModError(..)+ , gmeDoc , modifyError , modifyError' , tryFix@@ -10,6 +11,7 @@ import Control.Monad.Error (MonadError(..), Error(..)) import Exception+import Text.PrettyPrint data GhcModError = GMENoMsg -- ^ Unknown error@@ -28,6 +30,20 @@ instance Error GhcModError where noMsg = GMENoMsg strMsg = GMEString++gmeDoc :: GhcModError -> Doc+gmeDoc e = case e of+ GMENoMsg ->+ text "Unknown error"+ GMEString msg ->+ text msg+ GMECabalConfigure msg ->+ text "cabal configure failed: " <> gmeDoc msg+ GMECabalFlags msg ->+ text "retrieval of the cabal configuration flags failed: " <> gmeDoc msg+ GMEProcess cmd msg ->+ text ("launching operating system process `"++unwords cmd++"` failed: ")+ <> gmeDoc msg modifyError :: MonadError e m => (e -> e) -> m a -> m a modifyError f action = action `catchError` \e -> throwError $ f e
Language/Haskell/GhcMod/Find.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, BangPatterns #-} module Language.Haskell.GhcMod.Find #ifndef SPEC@@ -10,30 +10,27 @@ , dumpSymbol , findSymbol , lookupSym+ , isOutdated ) #endif where -import Config (cProjectVersion,cTargetPlatformString) import Control.Applicative ((<$>)) import Control.Monad (when, void) import Control.Monad.Error.Class import Data.Function (on) import Data.List (groupBy, sort)-import Data.List.Split (splitOn) import Data.Maybe (fromMaybe)-import DynFlags (DynFlags(..), systemPackageConfig)-import Exception (handleIO) import qualified GHC as G import Language.Haskell.GhcMod.Convert+import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.Monad-import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.Types+import Language.Haskell.GhcMod.Utils import Name (getOccString)-import System.Directory (doesDirectoryExist, getAppUserDataDirectory, doesFileExist, getModificationTime)+import System.Directory (doesFileExist, getModificationTime) import System.FilePath ((</>), takeDirectory) import System.IO-import System.Environment #ifndef MIN_VERSION_containers #define MIN_VERSION_containers(x,y,z) 1@@ -52,9 +49,15 @@ -- | Type of function and operation names. type Symbol = String -- | Database from 'Symbol' to \['ModuleString'\].-newtype SymbolDb = SymbolDb (Map Symbol [ModuleString])- deriving (Show)+data SymbolDb = SymbolDb {+ table :: Map Symbol [ModuleString]+ , packageCachePath :: FilePath+ , symbolDbCachePath :: FilePath+ } deriving (Show) +isOutdated :: SymbolDb -> IO Bool+isOutdated db = symbolDbCachePath db `isOlderThan` packageCachePath db+ ---------------------------------------------------------------- -- | When introducing incompatible changes to the 'symbolCache' file format@@ -66,12 +69,6 @@ symbolCache :: String symbolCache = "ghc-mod-"++ show symbolCacheVersion ++".cache" -packageCache :: String-packageCache = "package.cache"--packageConfDir :: String-packageConfDir = "package.conf.d"- ---------------------------------------------------------------- -- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\]@@ -85,39 +82,21 @@ lookupSymbol sym db = convert' $ lookupSym sym db lookupSym :: Symbol -> SymbolDb -> [ModuleString]-lookupSym sym (SymbolDb db) = fromMaybe [] $ M.lookup sym db+lookupSym sym db = fromMaybe [] $ M.lookup sym $ table db --------------------------------------------------------------- -- | Loading a file and creates 'SymbolDb'. loadSymbolDb :: (IOish m, MonadError GhcModError m) => m SymbolDb-loadSymbolDb = SymbolDb <$> readSymbolDb---- | Returns the path to the currently running ghc-mod executable. With ghc<7.6--- this is a guess but >=7.6 uses 'getExecutablePath'.-ghcModExecutable :: IO FilePath-#ifndef SPEC-ghcModExecutable = do- dir <- getExecutablePath'- return $ dir </> "ghc-mod"-#else-ghcModExecutable = do _ <- getExecutablePath' -- get rid of unused warning when- -- compiling spec- return "dist/build/ghc-mod/ghc-mod"-#endif- where- getExecutablePath' :: IO FilePath-# if __GLASGOW_HASKELL__ >= 706- getExecutablePath' = takeDirectory <$> getExecutablePath-# else- getExecutablePath' = return ""-# endif--readSymbolDb :: (IOish m, MonadError GhcModError m) => m (Map Symbol [ModuleString])-readSymbolDb = do+loadSymbolDb = do ghcMod <- liftIO ghcModExecutable file <- chop <$> readProcess' ghcMod ["dumpsym"]- M.fromAscList . map conv . lines <$> liftIO (readFile file)+ !db <- M.fromAscList . map conv . lines <$> liftIO (readFile file)+ return $ SymbolDb {+ table = db+ , packageCachePath = takeDirectory file </> packageCache+ , symbolDbCachePath = file+ } where conv :: String -> (Symbol,[ModuleString]) conv = read@@ -127,24 +106,18 @@ ---------------------------------------------------------------- -- used 'ghc-mod dumpsym' -getSymbolCachePath :: IOish m => GhcModT m FilePath-getSymbolCachePath = do- u:_ <- filter (/= GlobalDb) . cradlePkgDbStack <$> cradle- Just db <- (liftIO . flip resolvePackageDb u) =<< G.getSessionDynFlags- return db- `catchError` const (fail "Couldn't find non-global package database for symbol cache")- -- | Dumping a set of ('Symbol',\['ModuleString'\]) to a file -- if the file does not exist or is invalid. -- The file name is printed. dumpSymbol :: IOish m => GhcModT m String dumpSymbol = do- dir <- getSymbolCachePath+ crdl <- cradle+ dir <- liftIO $ getPackageCachePath crdl let cache = dir </> symbolCache pkgdb = dir </> packageCache - create <- liftIO $ cache `isNewerThan` pkgdb+ create <- liftIO $ cache `isOlderThan` pkgdb when create $ (liftIO . writeSymbolCache cache) =<< getSymbolTable return $ unlines [cache] @@ -155,15 +128,15 @@ void . withFile cache WriteMode $ \hdl -> mapM (hPrint hdl) sm -isNewerThan :: FilePath -> FilePath -> IO Bool-isNewerThan ref file = do- exist <- doesFileExist ref+isOlderThan :: FilePath -> FilePath -> IO Bool+isOlderThan cache file = do+ exist <- doesFileExist cache if not exist then return True else do- tRef <- getModificationTime ref+ tCache <- getModificationTime cache tFile <- getModificationTime file- return $ tRef <= tFile -- including equal just in case+ return $ tCache <= tFile -- including equal just in case -- | Browsing all functions in all system/user modules. getSymbolTable :: IOish m => GhcModT m [(Symbol,[ModuleString])]@@ -192,16 +165,3 @@ collectModules = map tieup . groupBy ((==) `on` fst) . sort where tieup x = (head (map fst x), map snd x)----- Copied from ghc module `Packages' unfortunately it's not exported :/-resolvePackageDb :: DynFlags -> GhcPkgDb -> IO (Maybe FilePath)-resolvePackageDb df GlobalDb = return $ Just (systemPackageConfig df)-resolvePackageDb _ (PackageDb name) = return $ Just name-resolvePackageDb _ UserDb = handleIO (\_ -> return Nothing) $ do- appdir <- getAppUserDataDirectory "ghc"- let dir = appdir </> (target_arch ++ '-':target_os ++ '-':cProjectVersion)- pkgconf = dir </> packageConfDir- exist <- doesDirectoryExist pkgconf- return $ if exist then Just pkgconf else Nothing- where- [target_arch,_,target_os] = splitOn "-" cTargetPlatformString
Language/Haskell/GhcMod/GhcPkg.hs view
@@ -8,9 +8,12 @@ , fromInstalledPackageId' , getSandboxDb , getPackageDbStack+ , getPackageCachePath+ , packageCache+ , packageConfDir ) where -import Config (cProjectVersionInt)+import Config (cProjectVersion, cTargetPlatformString, cProjectVersionInt) import Control.Applicative ((<$>)) import Control.Exception (SomeException(..)) import qualified Control.Exception as E@@ -18,8 +21,10 @@ import Data.List (isPrefixOf, intercalate) import Data.List.Split (splitOn) import Distribution.Package (InstalledPackageId(..))+import Exception (handleIO) import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils+import System.Directory (doesDirectoryExist, getAppUserDataDirectory) import System.FilePath ((</>)) ghcVersion :: Int@@ -46,6 +51,8 @@ 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)@@ -54,6 +61,8 @@ (getSandboxDb cdir >>= \db -> return [GlobalDb, PackageDb db]) `E.catch` \(_ :: SomeException) -> return [GlobalDb, UserDb] +----------------------------------------------------------------+ fromInstalledPackageId' :: InstalledPackageId -> Maybe Package fromInstalledPackageId' pid = let InstalledPackageId pkg = pid@@ -68,6 +77,8 @@ Nothing -> error $ "fromInstalledPackageId: `"++show pid++"' is not a valid package-id" +----------------------------------------------------------------+ -- | Get options needed to add a list of package dbs to ghc-pkg's db stack ghcPkgDbStackOpts :: [GhcPkgDb] -- ^ Package db stack -> [String]@@ -78,6 +89,8 @@ -> [String] ghcDbStackOpts dbs = ghcDbOpt `concatMap` dbs +----------------------------------------------------------------+ ghcPkgDbOpt :: GhcPkgDb -> [String] ghcPkgDbOpt GlobalDb = ["--global"] ghcPkgDbOpt UserDb = ["--user"]@@ -95,3 +108,31 @@ ghcDbOpt (PackageDb pkgDb) | ghcVersion < 706 = ["-no-user-package-conf", "-package-conf", pkgDb] | otherwise = ["-no-user-package-db", "-package-db", pkgDb]++----------------------------------------------------------------++packageCache :: String+packageCache = "package.cache"++packageConfDir :: String+packageConfDir = "package.conf.d"++-- fixme: error handling+getPackageCachePath :: Cradle -> IO FilePath+getPackageCachePath crdl = do+ let u:_ = filter (/= GlobalDb) $ cradlePkgDbStack crdl+ Just db <- resolvePath u+ return db++--- Copied from ghc module `Packages' unfortunately it's not exported :/+resolvePath :: GhcPkgDb -> IO (Maybe FilePath)+resolvePath (PackageDb name) = return $ Just name+resolvePath UserDb = handleIO (\_ -> return Nothing) $ do+ appdir <- getAppUserDataDirectory "ghc"+ let dir = appdir </> (target_arch ++ '-':target_os ++ '-':cProjectVersion)+ pkgconf = dir </> packageConfDir+ exist <- doesDirectoryExist pkgconf+ return $ if exist then Just pkgconf else Nothing+ where+ [target_arch,_,target_os] = splitOn "-" cTargetPlatformString+resolvePath _ = error "GlobalDb cannot be used in resolvePath"
Language/Haskell/GhcMod/Internal.hs view
@@ -16,8 +16,9 @@ , cabalDependPackages , cabalSourceDirs , cabalAllTargets- -- * GHC.Paths+ -- * Various Paths , ghcLibDir+ , ghcModExecutable -- * IO , getDynamicFlags -- * Targets@@ -42,21 +43,30 @@ , getCompilerMode , setCompilerMode , withOptions+ -- * 'GhcModError'+ , gmeDoc -- * 'GhcMonad' Choice , (||>) , goNext , runAnyOne+ -- * World+ , World+ , getCurrentWorld+ , isWorldChanged ) where import GHC.Paths (libdir) import Language.Haskell.GhcMod.CabalApi+import Language.Haskell.GhcMod.CabalConfig import Language.Haskell.GhcMod.DynFlags+import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.GHCChoice import Language.Haskell.GhcMod.Logger import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Target import Language.Haskell.GhcMod.Types+import Language.Haskell.GhcMod.Utils -- | Obtaining the directory for ghc system libraries. ghcLibDir :: FilePath
Language/Haskell/GhcMod/Monad.hs view
@@ -200,11 +200,11 @@ | cabal = withCabal | otherwise = withSandbox where- mCradleFile = cradleCabalFile c- cabal = isJust mCradleFile+ mCabalFile = cradleCabalFile c+ cabal = isJust mCabalFile ghcopts = ghcUserOptions opt withCabal = do- pkgDesc <- parseCabalFile c $ fromJust mCradleFile+ pkgDesc <- parseCabalFile c $ fromJust mCabalFile compOpts <- getCompilerOptions ghcopts c pkgDesc initSession CabalPkg opt compOpts withSandbox = initSession SingleFile opt compOpts
Language/Haskell/GhcMod/Types.hs view
@@ -25,7 +25,12 @@ data Options = Options { outputStyle :: OutputStyle- , hlintOpts :: [String]+ -- | Line separator string.+ , lineSeparator :: LineSeparator+ -- | @ghc@ program name.+ , ghcProgram :: FilePath+ -- | @cabal@ program name.+ , cabalProgram :: FilePath -- | GHC command line options set on the @ghc-mod@ command line , ghcUserOptions:: [GHCOption] -- | If 'True', 'browse' also returns operators.@@ -34,15 +39,17 @@ , detailed :: Bool -- | If 'True', 'browse' will return fully qualified name , qualified :: Bool- -- | Line separator string.- , lineSeparator :: LineSeparator+ , hlintOpts :: [String] } + -- | A default 'Options'. defaultOptions :: Options defaultOptions = Options { outputStyle = PlainStyle , hlintOpts = []+ , ghcProgram = "ghc"+ , cabalProgram = "cabal" , ghcUserOptions= [] , operators = False , detailed = False
Language/Haskell/GhcMod/Utils.hs view
@@ -1,11 +1,17 @@+{-# LANGUAGE CPP #-} module Language.Haskell.GhcMod.Utils where -+import Control.Applicative ((<$>)) import Language.Haskell.GhcMod.Error import MonadUtils (MonadIO, liftIO) import System.Directory (getCurrentDirectory, setCurrentDirectory) import System.Exit (ExitCode(..)) import System.Process (readProcessWithExitCode)+import System.FilePath (takeDirectory)+import System.Environment+#ifndef SPEC+import System.FilePath ((</>))+#endif -- dropWhileEnd is not provided prior to base 4.5.0.0. dropWhileEnd :: (a -> Bool) -> [a] -> [a]@@ -42,3 +48,23 @@ withDirectory_ dir action = gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory) (\_ -> liftIO (setCurrentDirectory dir) >> action)++-- | Returns the path to the currently running ghc-mod executable. With ghc<7.6+-- this is a guess but >=7.6 uses 'getExecutablePath'.+ghcModExecutable :: IO FilePath+#ifndef SPEC+ghcModExecutable = do+ dir <- getExecutablePath'+ return $ dir </> "ghc-mod"+#else+ghcModExecutable = do _ <- getExecutablePath' -- get rid of unused warning when+ -- compiling spec+ return "dist/build/ghc-mod/ghc-mod"+#endif+ where+ getExecutablePath' :: IO FilePath+# if __GLASGOW_HASKELL__ >= 706+ getExecutablePath' = takeDirectory <$> getExecutablePath+# else+ getExecutablePath' = return ""+# endif
elisp/ghc-rewrite.el view
@@ -125,8 +125,8 @@ (ghc-display nil (lambda () (insert "Possible completions:\n")- (mapc - (lambda (x) + (mapc+ (lambda (x) (let* (; (ins1 (insert "- ")) (pos-begin (point)) (ins (insert x))
elisp/ghc.el view
@@ -28,7 +28,7 @@ (< emacs-minor-version minor))) (error "ghc-mod requires at least Emacs %d.%d" major minor))) -(defconst ghc-version "5.1.0.2")+(defconst ghc-version "v5.1.1.0") ;; (eval-when-compile ;; (require 'haskell-mode))
ghc-mod.cabal view
@@ -1,5 +1,5 @@ Name: ghc-mod-Version: 5.1.0.2+Version: 5.1.1.0 Author: Kazu Yamamoto <kazu@iij.ad.jp> Daniel Gröber <dxld@darkboxed.org> Alejandro Serrano <trupill@gmail.com>@@ -86,8 +86,8 @@ Language.Haskell.GhcMod.Lang Language.Haskell.GhcMod.Lint Language.Haskell.GhcMod.Logger- Language.Haskell.GhcMod.Monad Language.Haskell.GhcMod.Modules+ Language.Haskell.GhcMod.Monad Language.Haskell.GhcMod.PkgDoc Language.Haskell.GhcMod.Read Language.Haskell.GhcMod.SrcUtils@@ -106,6 +106,7 @@ , io-choice , monad-journal >= 0.4 , old-time+ , pretty , process , syb , time@@ -134,8 +135,11 @@ Default-Extensions: ConstraintKinds, FlexibleContexts HS-Source-Dirs: src Build-Depends: base >= 4.0 && < 5+ , data-default , directory , filepath+ , pretty+ , process , mtl >= 2.0 , ghc , ghc-mod@@ -144,8 +148,11 @@ Default-Language: Haskell2010 Main-Is: GHCModi.hs Other-Modules: Paths_ghc_mod+ Misc Utils GHC-Options: -Wall -threaded+ if os(windows)+ Cpp-Options: -DWINDOWS Default-Extensions: ConstraintKinds, FlexibleContexts HS-Source-Dirs: src Build-Depends: base >= 4.0 && < 5@@ -153,7 +160,10 @@ , containers , directory , filepath+ , old-time+ , process , split+ , time , ghc , ghc-mod @@ -199,6 +209,7 @@ , io-choice , monad-journal >= 0.4 , old-time+ , pretty , process , syb , time
src/GHCMod.hs view
@@ -3,187 +3,451 @@ module Main where import Config (cProjectVersion)-import Control.Applicative ((<$>))-import Control.Exception (Exception, Handler(..), ErrorCall(..))-import CoreMonad (liftIO)-import qualified Control.Exception as E+import Control.Arrow+import Control.Applicative+import Control.Exception (Exception, Handler(..), catches, throw) import Data.Typeable (Typeable) import Data.Version (showVersion)+import Data.Default+import Data.List+import Data.Char (isSpace) import Language.Haskell.GhcMod+import Language.Haskell.GhcMod.Internal import Paths_ghc_mod import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..)) import qualified System.Console.GetOpt as O-import System.Directory (doesFileExist) import System.Environment (getArgs) import System.Exit (exitFailure)-import System.IO (hPutStr, hPutStrLn, stdout, stderr, hSetEncoding, utf8)+import System.IO (hPutStrLn, stdout, stderr, hSetEncoding, utf8)+--import System.Process (rawSystem)+--import System.Exit (exitWith)+import Text.PrettyPrint ---------------------------------------------------------------- progVersion :: String-progVersion = "ghc-mod version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ++ "\n"+progVersion =+ "ghc-mod version " ++ showVersion version ++ " compiled by GHC "+ ++ cProjectVersion ++ "\n" -ghcOptHelp :: String-ghcOptHelp = " [-g GHC_opt1 -g GHC_opt2 ...] "+optionUsage :: (String -> String) -> [OptDescr a] -> [String]+optionUsage indent opts = concatMap optUsage opts+ where+ optUsage (Option so lo dsc udsc) =+ [ concat $ intersperse ", " $ addLabel `map` allFlags+ , indent $ udsc+ , ""+ ]+ where+ allFlags = shortFlags ++ longFlags+ shortFlags = (('-':) . return) `map` so :: [String]+ longFlags = ("--"++) `map` lo + addLabel f@('-':'-':_) = f ++ flagLabel "="+ addLabel f@('-':_) = f ++ flagLabel " "+ addLabel _ = undefined++ flagLabel s =+ case dsc of+ NoArg _ -> ""+ ReqArg _ label -> s ++ label+ OptArg _ label -> s ++ "["++label++"]"++-- TODO: Generate the stuff below automatically usage :: String-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] [<package>:]<module> [[<package>:]<module> ...]\n"- ++ "\t ghc-mod check " ++ ghcOptHelp ++ "<HaskellFiles...>\n"- ++ "\t ghc-mod expand " ++ ghcOptHelp ++ "<HaskellFiles...>\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 split " ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"- ++ "\t ghc-mod sig " ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"- ++ "\t ghc-mod refine " ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no> <expression>\n"- ++ "\t ghc-mod auto " ++ 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\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"+usage =+ "Usage: ghc-mod [OPTIONS...] COMMAND [OPTIONS...] \n\+ \*Global Options (OPTIONS)*\n\+ \ Global options can be specified before and after the command and\n\+ \ interspersed with command specific options\n\+ \\n"+ ++ (unlines $ indent <$> optionUsage indent globalArgSpec) +++ "*Commands*\n\+ \ - version\n\+ \ Print the version of the program.\n\+ \\n\+ \ - help | --help\n\+ \ Print this help message.\n\+ \\n\+ \ - list [FLAGS...]\n\+ \ List all visible modules.\n\+ \ Flags:\n\+ \ -d\n\+ \ Also print the modules' package.\n\+ \\n\+ \ - lang\n\+ \ List all known GHC language extensions.\n\+ \\n\+ \ - flag\n\+ \ List GHC -f<bla> flags.\n\+ \\n\+ \ - browse [FLAGS...] [PACKAGE:]MODULE...\n\+ \ List symbols in a module.\n\+ \ Flags:\n\+ \ -o\n\+ \ Also print operators.\n\+ \ -d\n\+ \ Print symbols with accompanying signatures.\n\+ \ -q\n\+ \ Qualify symbols.\n\+ \\n\+ \ - check FILE...\n\+ \ Load the given files using GHC and report errors/warnings, but\n\+ \ don't produce output files.\n\+ \\n\+ \ - expand FILE...\n\+ \ Like `check' but also pass `-ddump-splices' to GHC.\n\+ \\n\+ \ - info FILE [MODULE] EXPR\n\+ \ Look up an identifier in the context of FILE (like ghci's `:info')\n\+ \ MODULE is completely ignored and only allowed for backwards\n\+ \ compatibility.\n\+ \\n\+ \ - type FILE [MODULE] LINE COL\n\+ \ Get the type of the expression under (LINE,COL).\n\+ \\n\+ \ - split FILE [MODULE] LINE COL\n\+ \ Split a function case by examining a type's constructors.\n\+ \\n\+ \ For example given the following code snippet:\n\+ \\n\+ \ f :: [a] -> a\n\+ \ f x = _body\n\+ \\n\+ \ would be replaced by:\n\+ \\n\+ \ f :: [a] -> a\n\+ \ f [] = _body\n\+ \ f (x:xs) = _body\n\+ \\n\+ \ (See https://github.com/kazu-yamamoto/ghc-mod/pull/274)\n\+ \\n\+ \ - sig FILE MODULE LINE COL\n\+ \ Generate initial code given a signature.\n\+ \\n\+ \ For example when (LINE,COL) is on the signature in the following\n\+ \ code snippet:\n\+ \\n\+ \ func :: [a] -> Maybe b -> (a -> b) -> (a,b)\n\+ \\n\+ \ ghc-mod would add the following on the next line:\n\+ \\n\+ \ func x y z f = _func_body\n\+ \\n\+ \ (See: https://github.com/kazu-yamamoto/ghc-mod/pull/274)\n\+ \\n\+ \ - refine FILE MODULE LINE COL EXPR\n\+ \ Refine the typed hole at (LINE,COL) given EXPR.\n\+ \\n\+ \ For example if EXPR is `filter', which has type `(a -> Bool) -> [a]\n\+ \ -> [a]' and (LINE,COL) is on the hole `_body' in the following\n\+ \ code snippet:\n\+ \\n\+ \ filterNothing :: [Maybe a] -> [a]\n\+ \ filterNothing xs = _body\n\+ \\n\+ \ ghc-mod changes the code to get a value of type `[a]', which\n\+ \ results in:\n\+ \\n\+ \ filterNothing xs = filter _body_1 _body_2\n\+ \\n\+ \ (See also: https://github.com/kazu-yamamoto/ghc-mod/issues/311)\n\+ \\n\+ \ - auto FILE MODULE LINE COL\n\+ \ Try to automatically fill the contents of a hole.\n\+ \\n\+ \ - find SYMBOL\n\+ \ List all modules that define SYMBOL.\n\+ \\n\+ \ - lint FILE\n\+ \ Check files using `hlint'.\n\+ \ Flags:\n\+ \ -l\n\+ \ Option to be passed to hlint.\n\+ \\n\+ \ - root FILE\n\+ \ Try to find the project directory given FILE. For Cabal\n\+ \ projects this is the directory containing the cabal file, for\n\+ \ projects that use a cabal sandbox but have no cabal file this is the\n\+ \ directory containing the sandbox and otherwise this is the directory\n\+ \ containing FILE.\n\+ \\n\+ \ - doc MODULE\n\+ \ Try finding the html documentation directory for the given MODULE.\n\+ \\n\+ \ - debug\n\+ \ Print debugging information. Please include the output in any bug\n\+ \ reports you submit.\n\+ \\n\+ \ - boot\n\+ \ Internal command used by the emacs frontend.\n"+ -- "\n\+ -- \The following forms are supported so ghc-mod can be invoked by\n\+ -- \`cabal repl':\n\+ -- \\n\+ -- \ ghc-mod --make GHC_OPTIONS\n\+ -- \ Pass all options through to the GHC executable.\n\+ -- \\n\+ -- \ ghc-mod --interactive GHC_OPTIONS [--ghc-mod]\n\+ -- \ Start ghci emulation mode. GHC_OPTIONS are passed to the\n\+ -- \ GHC API. If `--ghc-mod' is given ghc-mod specific extensions\n\+ -- \ are enabled.\n"+ where+ indent = (" "++) -----------------------------------------------------------------+cmdUsage :: String -> String -> String+cmdUsage cmd s =+ let+ -- Find command head+ a = dropWhile (not . ((" - " ++ cmd) `isInfixOf`)) $ lines s+ -- Take til the end of the current command block+ b = flip takeWhile a $ \l ->+ all isSpace l || (isIndented l && (isCurrCmdHead l || isNotCmdHead l))+ -- Drop extra newline from the end+ c = dropWhileEnd (all isSpace) b -argspec :: [OptDescr (Options -> Options)]-argspec =- let option s l udsc dsc = Option s l dsc udsc- reqArg udsc dsc = ReqArg dsc udsc- in- [ option "l" ["tolisp"] "print as a list of Lisp" $- NoArg $ \o -> o { outputStyle = LispStyle }+ isIndented = (" " `isPrefixOf`)+ isNotCmdHead = ( not . (" - " `isPrefixOf`))+ isCurrCmdHead = ((" - " ++ cmd) `isPrefixOf`) - , option "h" ["hlintOpt"] "hlint options" $- reqArg "hlintOpt" $ \h o -> o { hlintOpts = h : hlintOpts o }+ unindent (' ':' ':' ':' ':l) = l+ unindent l = l+ in unlines $ unindent <$> c+---------------------------------------------------------------- - , option "g" ["ghcOpt"] "GHC options" $- reqArg "ghcOpt" $ \g o ->- o { ghcUserOptions = g : ghcUserOptions o }+option :: [Char] -> [String] -> String -> ArgDescr a -> OptDescr a+option s l udsc dsc = Option s l dsc udsc - , option "v" ["verbose"] "verbose" $+reqArg :: String -> (String -> a) -> ArgDescr a+reqArg udsc dsc = ReqArg dsc udsc++globalArgSpec :: [OptDescr (Options -> Options)]+globalArgSpec =+ [ option "v" ["verbose"] "Be more verbose." $ NoArg $ \o -> o { ghcUserOptions = "-v" : ghcUserOptions o } - , option "o" ["operators"] "print operators, too" $- NoArg $ \o -> o { operators = True }+ , option "l" ["tolisp"] "Format output as an S-Expression" $+ NoArg $ \o -> o { outputStyle = LispStyle } - , option "d" ["detailed"] "print detailed info" $- NoArg $ \o -> o { detailed = True }+ , option "b" ["boundary"] "Output line separator"$+ reqArg "SEP" $ \s o -> o { lineSeparator = LineSeparator s } - , option "q" ["qualified"] "show qualified names" $- NoArg $ \o -> o { qualified = True }+ , option "g" ["ghcOpt"] "Option to be passed to GHC" $+ reqArg "OPT" $ \g o ->+ o { ghcUserOptions = g : ghcUserOptions o } - , option "b" ["boundary"] "specify line separator (default is Nul string)"$- reqArg "sep" $ \s o -> o { lineSeparator = LineSeparator s }+ , option "" ["with-ghc"] "GHC executable to use" $+ reqArg "PROG" $ \p o -> o { ghcProgram = p }++ , option "" ["with-cabal"] "cabal-install executable to use" $+ reqArg "PROG" $ \p o -> o { cabalProgram = p } ] -parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String])-parseArgs spec argv- = case O.getOpt Permute spec argv of- (o,n,[] ) -> (foldr id defaultOptions o, n)- (_,_,errs) -> E.throw (CmdArg errs)+parseGlobalArgs ::[String] -> (Options, [String])+parseGlobalArgs argv+ = case O.getOpt RequireOrder globalArgSpec argv of+ (o,r,[] ) -> (foldr id defaultOptions o, r)+ (_,_,errs) ->+ fatalError $ "Parsing command line options failed: \n" ++ concat errs +parseCommandArgs :: [OptDescr (Options -> Options)]+ -> [String]+ -> Options+ -> (Options, [String])+parseCommandArgs spec argv opts+ = case O.getOpt RequireOrder (globalArgSpec ++ spec) argv of+ (o,r,[]) -> (foldr id opts o, r)+ (_,_,errs) ->+ fatalError $ "Parsing command options failed: \n" ++ concat errs+ ---------------------------------------------------------------- -data GHCModError = SafeList- | ArgumentsMismatch String- | NoSuchCommand String- | CmdArg [String]- | FileNotExist String deriving (Show, Typeable)+data CmdError = UnknownCommand String+ | NoSuchFileError String+ | LibraryError GhcModError -instance Exception GHCModError+ deriving (Show, Typeable) +instance Exception CmdError+ ---------------------------------------------------------------- +data InteractiveOptions = InteractiveOptions {+ ghcModExtensions :: Bool+ }++instance Default InteractiveOptions where+ def = InteractiveOptions False++handler :: IO a -> IO a+handler = flip catches $+ [ Handler $ \(FatalError msg) -> exitError msg+ , Handler $ \(InvalidCommandLine e) -> do+ case e of+ Left cmd ->+ exitError $ (cmdUsage cmd usage)+ ++ "\nghc-mod: Invalid command line form."+ Right msg -> exitError msg+ ]+ main :: IO ()-main = flip E.catches handlers $ do+main = handler $ do hSetEncoding stdout utf8 args <- getArgs- let (opt,cmdArg) = parseArgs argspec args- let cmdArg0 = cmdArg !. 0- cmdArg1 = cmdArg !. 1- cmdArg3 = cmdArg !. 3- cmdArg4 = cmdArg !. 4- cmdArg5 = cmdArg !. 5- remainingArgs = tail cmdArg- nArgs :: Int -> a -> a- nArgs n f = if length remainingArgs == n- then f- else E.throw (ArgumentsMismatch cmdArg0)- (res, _) <- runGhcModT opt $ case cmdArg0 of- "list" -> modules- "lang" -> languages- "flag" -> flags- "browse" -> concat <$> mapM browse remainingArgs- "check" -> checkSyntax remainingArgs- "expand" -> expandTemplate remainingArgs- "debug" -> debugInfo- "info" -> nArgs 3 info cmdArg1 cmdArg3- "type" -> nArgs 4 $ types cmdArg1 (read cmdArg3) (read cmdArg4)- "split" -> nArgs 4 $ splits cmdArg1 (read cmdArg3) (read cmdArg4)- "sig" -> nArgs 4 $ sig cmdArg1 (read cmdArg3) (read cmdArg4)- "refine" -> nArgs 5 $ refine cmdArg1 (read cmdArg3) (read cmdArg4) cmdArg5- "auto" -> nArgs 4 $ auto cmdArg1 (read cmdArg3) (read cmdArg4)- "find" -> nArgs 1 $ findSymbol cmdArg1- "lint" -> nArgs 1 $ withFile lint cmdArg1- "root" -> rootInfo- "doc" -> nArgs 1 $ pkgDoc cmdArg1- "dumpsym" -> dumpSymbol- "boot" -> boot- "version" -> return progVersion- "help" -> return $ O.usageInfo usage argspec- cmd -> E.throw (NoSuchCommand cmd) - case res of- Right s -> putStr s- Left (GMENoMsg) ->- hPutStrLn stderr "Unknown error"- Left (GMEString msg) ->- hPutStrLn stderr msg- Left (GMECabalConfigure msg) ->- hPutStrLn stderr $ "cabal configure failed: " ++ show msg- Left (GMECabalFlags msg) ->- hPutStrLn stderr $ "retrieval of the cabal configuration flags failed: " ++ show msg- Left (GMEProcess cmd msg) ->- hPutStrLn stderr $- "launching operating system process `"++c++"` failed: " ++ show msg- where c = unwords cmd+ let (ghcArgs, modArgs) = second stripSeperator $ span (/="--") args+ _realGhcArgs = filter (/="--ghc-mod") ghcArgs - where- handlers = [Handler (handleThenExit handler1), Handler (handleThenExit handler2)]- handleThenExit handler e = handler e >> exitFailure- handler1 :: ErrorCall -> IO ()- handler1 = print -- for debug- handler2 :: GHCModError -> IO ()- handler2 SafeList = printUsage- handler2 (ArgumentsMismatch cmd) = do- hPutStrLn stderr $ "\"" ++ cmd ++ "\": Arguments did not match"- printUsage- handler2 (NoSuchCommand cmd) = do- hPutStrLn stderr $ "\"" ++ cmd ++ "\" not supported"- printUsage- handler2 (CmdArg errs) = do- mapM_ (hPutStr stderr) errs- printUsage- handler2 (FileNotExist file) = do- hPutStrLn stderr $ "\"" ++ file ++ "\" not found"- printUsage- printUsage = hPutStrLn stderr $ '\n' : O.usageInfo usage argspec- withFile :: IOish m => (FilePath -> GhcModT m a) -> FilePath -> GhcModT m a- withFile cmd file = do- exist <- liftIO $ doesFileExist file- if exist- then cmd file- else E.throw (FileNotExist file)- xs !. idx- | length xs <= idx = E.throw SafeList- | otherwise = xs !! idx+ (globalOptions,_cmdArgs) = parseGlobalArgs modArgs++ stripSeperator ("--":rest) = rest+ stripSeperator l = l++ case args of+ _+ -- | "--numeric-version" `elem` ghcArgs || "--make" `elem` ghcArgs -> do+ -- rawSystem (ghcProgram globalOptions) realGhcArgs >>= exitWith++ -- | "--interactive" `elem` ghcArgs -> do+ -- let interactiveOptions = if "--ghc-mod" `elem` ghcArgs+ -- then def { ghcModExtensions = True }+ -- else def++ -- -- TODO: pass ghcArgs' to ghc API+ -- putStrLn "\ninteractive\n"+ -- --print realGhcArgs+ -- (res, _) <- runGhcModT globalOptions $ undefined+ -- case res of+ -- Right s -> putStr s+ -- Left e -> exitError $ render (gmeDoc e)+++ | otherwise -> do+ (res, _) <- runGhcModT globalOptions $ commands args+ case res of+ Right s -> putStr s+ Left e -> exitError $ render (gmeDoc e)++ -- Obtain ghc options by letting ourselfs be executed by+ -- @cabal repl@+ -- TODO: need to do something about non-cabal projects+ -- exe <- ghcModExecutable+ -- let cabalArgs = ["repl", "-v0", "--with-ghc="++exe]+ -- ++ (("--ghc-option="++) `map` ("--ghc-mod":"--":args))++ -- print cabalArgs++ -- rawSystem "cabal" cabalArgs >>= exitWith++commands :: IOish m => [String] -> GhcModT m String+commands [] = fatalError "No command given (try --help)\n"+commands (cmd:args) = fn args+ where+ fn = case cmd of+ _ | cmd == "list" || cmd == "modules" -> modulesCmd+ _ | cmd == "help" || cmd == "--help" -> const $ return usage+ "version" -> const $ return progVersion+ "lang" -> languagesCmd+ "flag" -> flagsCmd+ "browse" -> browseCmd+ "check" -> checkSyntaxCmd+ "expand" -> expandTemplateCmd+ "debug" -> debugInfoCmd+ "info" -> infoCmd+ "type" -> typesCmd+ "split" -> splitsCmd+ "sig" -> sigCmd+ "refine" -> refineCmd+ "auto" -> autoCmd+ "find" -> findSymbolCmd+ "lint" -> lintCmd+ "root" -> rootInfoCmd+ "doc" -> pkgDocCmd+ "dumpsym" -> dumpSymbolCmd+ "boot" -> bootCmd+ _ -> fatalError $ "unknown command: `" ++ cmd ++ "'"++newtype FatalError = FatalError String deriving (Show, Typeable)+instance Exception FatalError++newtype InvalidCommandLine = InvalidCommandLine (Either String String)+ deriving (Show, Typeable)+instance Exception InvalidCommandLine++exitError :: String -> IO a+exitError msg = hPutStrLn stderr msg >> exitFailure++fatalError :: String -> a+fatalError s = throw $ FatalError $ "ghc-mod: " ++ s++withParseCmd :: IOish m+ => [OptDescr (Options -> Options)]+ -> ([String] -> GhcModT m a)+ -> [String]+ -> GhcModT m a+withParseCmd spec action args = do+ (opts', rest) <- parseCommandArgs spec args <$> options+ withOptions (const opts') $ action rest++modulesCmd, languagesCmd, flagsCmd, browseCmd, checkSyntaxCmd, expandTemplateCmd,+ debugInfoCmd, infoCmd, typesCmd, splitsCmd, sigCmd, refineCmd, autoCmd,+ findSymbolCmd, lintCmd, rootInfoCmd, pkgDocCmd, dumpSymbolCmd, bootCmd+ :: IOish m => [String] -> GhcModT m String++modulesCmd = withParseCmd [] $ \[] -> modules+languagesCmd = withParseCmd [] $ \[] -> languages+flagsCmd = withParseCmd [] $ \[] -> flags+debugInfoCmd = withParseCmd [] $ \[] -> debugInfo+rootInfoCmd = withParseCmd [] $ \[] -> rootInfo+-- internal+dumpSymbolCmd = withParseCmd [] $ \[] -> dumpSymbol+bootCmd = withParseCmd [] $ \[] -> boot++findSymbolCmd = withParseCmd [] $ \[sym] -> findSymbol sym+pkgDocCmd = withParseCmd [] $ \[mdl] -> pkgDoc mdl+lintCmd = withParseCmd s $ \[file] -> lint file+ where s = hlintArgSpec+browseCmd = withParseCmd s $ \mdls -> concat <$> browse `mapM` mdls+ where s = browseArgSpec+checkSyntaxCmd = withParseCmd [] $ checkAction checkSyntax+expandTemplateCmd = withParseCmd [] $ checkAction expandTemplate++typesCmd = withParseCmd [] $ locAction "type" types+splitsCmd = withParseCmd [] $ locAction "split" splits+sigCmd = withParseCmd [] $ locAction "sig" sig+autoCmd = withParseCmd [] $ locAction "auto" auto+refineCmd = withParseCmd [] $ locAction' "refine" refine++infoCmd = withParseCmd [] $ action+ where action [file,_,expr] = info file expr+ action [file,expr] = info file expr+ action _ = throw $ InvalidCommandLine (Left "info")++checkAction :: ([t] -> a) -> [t] -> a+checkAction _ [] = throw $ InvalidCommandLine (Right "No files given.")+checkAction action files = action files++locAction :: String -> (String -> Int -> Int -> a) -> [String] -> a+locAction _ action [file,_,line,col] = action file (read line) (read col)+locAction _ action [file, line,col] = action file (read line) (read col)+locAction cmd _ _ = throw $ InvalidCommandLine (Left cmd)++locAction' :: String -> (String -> Int -> Int -> String -> a) -> [String] -> a+locAction' _ action [f,_,line,col,expr] = action f (read line) (read col) expr+locAction' _ action [f, line,col,expr] = action f (read line) (read col) expr+locAction' cmd _ _ = throw $ InvalidCommandLine (Left cmd)++hlintArgSpec :: [OptDescr (Options -> Options)]+hlintArgSpec =+ [ option "h" ["hlintOpt"] "Option to be passed to hlint" $+ reqArg "hlintOpt" $ \h o -> o { hlintOpts = h : hlintOpts o }+ ]+browseArgSpec :: [OptDescr (Options -> Options)]+browseArgSpec =+ [ option "o" ["operators"] "Also print operators." $+ NoArg $ \o -> o { operators = True }+ , option "d" ["detailed"] "Print symbols with accompanying signature." $+ NoArg $ \o -> o { detailed = True }+ , option "q" ["qualified"] "Qualify symbols" $+ NoArg $ \o -> o { qualified = True }+ ]
src/GHCModi.hs view
@@ -20,36 +20,27 @@ import Config (cProjectVersion) import Control.Applicative ((<$>))-import Control.Concurrent.Async (Async, async, wait)-import Control.Exception (SomeException(..), Exception)+import Control.Exception (SomeException(..)) import qualified Control.Exception as E import Control.Monad (when) import CoreMonad (liftIO)-import Data.List (find, intercalate)+import Data.List (intercalate) import Data.List.Split (splitOn)-import Data.Maybe (fromMaybe)-import Data.Set (Set)-import qualified Data.Set as S-import Data.Typeable (Typeable) import Data.Version (showVersion)-import qualified GHC as G import Language.Haskell.GhcMod import Language.Haskell.GhcMod.Internal import Paths_ghc_mod import System.Console.GetOpt import System.Directory (setCurrentDirectory) import System.Environment (getArgs)-import System.IO (hFlush,stdout) import System.Exit (ExitCode, exitFailure)+import System.IO (hFlush,stdout) +import Misc import Utils ---------------------------------------------------------------- -type Logger = IO String------------------------------------------------------------------- progVersion :: String progVersion = "ghc-modi version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ++ "\n" @@ -79,13 +70,6 @@ ---------------------------------------------------------------- -data GHCModiError = CmdArg [String]- deriving (Show, Typeable)--instance Exception GHCModiError------------------------------------------------------------------- -- Running two GHC monad threads disables the handling of -- C-c since installSignalHandlers is called twice, sigh. @@ -96,25 +80,33 @@ cmdHandler (CmdArg _) = putStr $ usageInfo usage argspec go (_,"help":_) = putStr $ usageInfo usage argspec go (_,"version":_) = putStr progVersion- go (opt,_) = flip E.catches handlers $ do- cradle0 <- findCradle- let rootdir = cradleRootDir cradle0--- c = cradle0 { cradleCurrentDir = rootdir } TODO: ?????- setCurrentDirectory rootdir- symDb <- async $ runGhcModT opt loadSymbolDb- (res, _) <- runGhcModT opt $ loop S.empty symDb+ go (opt,_) = emptyNewUnGetLine >>= run opt - case res of- Right () -> return ()- Left (GMECabalConfigure msg) -> do- putStrLn $ notGood $ "cabal configure failed: " ++ show msg- exitFailure- Left e -> bug $ show e- where- -- this is just in case.- -- If an error is caught here, it is a bug of GhcMod library.- handlers = [ E.Handler (\(_ :: ExitCode) -> return ())- , E.Handler (\(SomeException e) -> bug $ show e) ]+run :: Options -> UnGetLine -> IO ()+run opt ref = flip E.catches handlers $ do+ cradle0 <- findCradle+ let rootdir = cradleRootDir cradle0+-- c = cradle0 { cradleCurrentDir = rootdir } TODO: ?????+ setCurrentDirectory rootdir+ prepareAutogen cradle0+ -- Asynchronous db loading starts here.+ symdbreq <- newSymDbReq opt+ (res, _) <- runGhcModT opt $ do+ crdl <- cradle+ world <- liftIO $ getCurrentWorld crdl+ loop symdbreq ref world+ case res of+ Right () -> return ()+ Left (GMECabalConfigure msg) -> do+ putStrLn $ notGood $ "cabal configure failed: " ++ show msg+ exitFailure+ Left e -> bug $ show e+ where+ -- this is just in case.+ -- If an error is caught here, it is a bug of GhcMod library.+ handlers = [ E.Handler (\(_ :: ExitCode) -> return ())+ , E.Handler (\(_ :: Restart) -> run opt ref)+ , E.Handler (\(SomeException e) -> bug $ show e) ] bug :: String -> IO () bug msg = do@@ -132,91 +124,63 @@ ---------------------------------------------------------------- -loop :: IOish m => Set FilePath -> SymDbReq -> GhcModT m ()-loop set symDbReq = do- cmdArg <- liftIO getLine+loop :: IOish m => SymDbReq -> UnGetLine -> World -> GhcModT m ()+loop symdbreq ref world = do+ -- blocking+ cmdArg <- liftIO $ getCommand ref+ -- after blocking, we need to see if the world has changed.+ crdl <- cradle+ changed <- liftIO $ isWorldChanged world crdl+ when changed $ do+ liftIO $ ungetCommand ref cmdArg+ E.throw Restart+ cradle >>= liftIO . prepareAutogen let (cmd,arg') = break (== ' ') cmdArg arg = dropWhile (== ' ') arg'- (ret,ok,set') <- case cmd of- "check" -> checkStx set arg- "find" -> findSym set arg symDbReq- "lint" -> lintStx set arg- "info" -> showInfo set arg- "type" -> showType set arg- "split" -> doSplit set arg- "sig" -> doSig set arg- "refine" -> doRefine set arg- "auto" -> doAuto set arg- "boot" -> bootIt set- "browse" -> browseIt set arg- "quit" -> return ("quit", False, set)- "" -> return ("quit", False, set)- _ -> return ([], True, set)+ (ret,ok) <- case cmd of+ "check" -> checkStx arg+ "find" -> findSym arg symdbreq+ "lint" -> lintStx arg+ "info" -> showInfo arg+ "type" -> showType arg+ "split" -> doSplit arg+ "sig" -> doSig arg+ "refine" -> doRefine arg+ "auto" -> doAuto arg+ "boot" -> bootIt+ "browse" -> browseIt arg+ "quit" -> return ("quit", False)+ "" -> return ("quit", False)+ _ -> return ([], True) if ok then do liftIO $ putStr ret liftIO $ putStrLn "OK" else do liftIO $ putStrLn $ notGood ret liftIO $ hFlush stdout- when ok $ loop set' symDbReq+ when ok $ loop symdbreq ref world ---------------------------------------------------------------- -checkStx :: IOish m- => Set FilePath- -> FilePath- -> GhcModT m (String, Bool, Set FilePath)-checkStx set file = do- set' <- newFileSet set file- let files = S.toList set'- eret <- check files+checkStx :: IOish m => FilePath -> GhcModT m (String, Bool)+checkStx file = do+ eret <- check [file] case eret of- Right ret -> return (ret, True, set')- Left ret -> return (ret, True, set) -- fxime: set--newFileSet :: IOish m => Set FilePath -> FilePath -> GhcModT m (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 :: IOish m => GhcModT m (Maybe G.ModSummary)-getModSummaryForMain = find isMain <$> G.getModuleGraph- where- isMain m = G.moduleNameString (G.moduleName (G.ms_mod m)) == "Main"--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+ Right ret -> return (ret, True)+ Left ret -> return (ret, True) ---------------------------------------------------------------- -type SymDbReq = Async (Either GhcModError SymbolDb, GhcModLog)--findSym :: IOish m => Set FilePath -> String -> SymDbReq- -> GhcModT m (String, Bool, Set FilePath)-findSym set sym dbReq = do- db <- hoistGhcModT =<< liftIO (wait dbReq)+findSym :: IOish m => Symbol -> SymDbReq -> GhcModT m (String, Bool)+findSym sym symdbreq = do+ db <- getDb symdbreq >>= checkDb symdbreq ret <- lookupSymbol sym db- return (ret, True, set)+ return (ret, True) -lintStx :: IOish m => Set FilePath- -> FilePath- -> GhcModT m (String, Bool, Set FilePath)-lintStx set optFile = do+lintStx :: IOish m => FilePath -> GhcModT m (String, Bool)+lintStx optFile = do ret <- withOptions changeOpt $ lint file- return (ret, True, set)+ return (ret, True) where (opts,file) = parseLintOptions optFile hopts = if opts == "" then [] else read opts@@ -239,85 +203,56 @@ ---------------------------------------------------------------- -showInfo :: IOish m- => Set FilePath- -> FilePath- -> GhcModT m (String, Bool, Set FilePath)-showInfo set fileArg = do+showInfo :: IOish m => FilePath -> GhcModT m (String, Bool)+showInfo fileArg = do let [file, expr] = splitN 2 fileArg- set' <- newFileSet set file ret <- info file expr- return (ret, True, set')+ return (ret, True) -showType :: IOish m- => Set FilePath- -> FilePath- -> GhcModT m (String, Bool, Set FilePath)-showType set fileArg = do+showType :: IOish m => FilePath -> GhcModT m (String, Bool)+showType fileArg = do let [file, line, column] = splitN 3 fileArg- set' <- newFileSet set file ret <- types file (read line) (read column)- return (ret, True, set')+ return (ret, True) -doSplit :: IOish m- => Set FilePath- -> FilePath- -> GhcModT m (String, Bool, Set FilePath)-doSplit set fileArg = do+doSplit :: IOish m => FilePath -> GhcModT m (String, Bool)+doSplit fileArg = do let [file, line, column] = splitN 3 fileArg- set' <- newFileSet set file ret <- splits file (read line) (read column)- return (ret, True, set')+ return (ret, True) -doSig :: IOish m- => Set FilePath- -> FilePath- -> GhcModT m (String, Bool, Set FilePath)-doSig set fileArg = do+doSig :: IOish m => FilePath -> GhcModT m (String, Bool)+doSig fileArg = do let [file, line, column] = splitN 3 fileArg- set' <- newFileSet set file ret <- sig file (read line) (read column)- return (ret, True, set')+ return (ret, True) -doRefine :: IOish m- => Set FilePath- -> FilePath- -> GhcModT m (String, Bool, Set FilePath)-doRefine set fileArg = do+doRefine :: IOish m => FilePath -> GhcModT m (String, Bool)+doRefine fileArg = do let [file, line, column, expr] = splitN 4 fileArg- set' <- newFileSet set file ret <- refine file (read line) (read column) expr- return (ret, True, set')+ return (ret, True) -doAuto :: IOish m- => Set FilePath- -> FilePath- -> GhcModT m (String, Bool, Set FilePath)-doAuto set fileArg = do+doAuto :: IOish m => FilePath -> GhcModT m (String, Bool)+doAuto fileArg = do let [file, line, column] = splitN 3 fileArg- set' <- newFileSet set file ret <- auto file (read line) (read column)- return (ret, True, set')+ return (ret, True) ---------------------------------------------------------------- -bootIt :: IOish m- => Set FilePath- -> GhcModT m (String, Bool, Set FilePath)-bootIt set = do+bootIt :: IOish m => GhcModT m (String, Bool)+bootIt = do ret <- boot- return (ret, True, set)+ return (ret, True) -browseIt :: IOish m- => Set FilePath- -> ModuleString- -> GhcModT m (String, Bool, Set FilePath)-browseIt set mdl = do+browseIt :: IOish m => ModuleString -> GhcModT m (String, Bool)+browseIt mdl = do let (det,rest') = break (== ' ') mdl rest = dropWhile (== ' ') rest' ret <- if det == "-d" then withOptions setDetailed (browse rest) else browse mdl- return (ret, True, set)+ return (ret, True) where- setDetailed opt = opt { detailed = True } + setDetailed opt = opt { detailed = True }
+ src/Misc.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE DeriveDataTypeable, CPP #-}++module Misc (+ GHCModiError(..)+ , Restart(..)+ , UnGetLine+ , emptyNewUnGetLine+ , ungetCommand+ , getCommand+ , SymDbReq+ , newSymDbReq+ , getDb+ , checkDb+ , prepareAutogen+ ) where++import Control.Applicative ((<$>))+import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (Async, async, wait)+import Control.Exception (Exception)+import Control.Monad (unless, when)+import CoreMonad (liftIO)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.List (isPrefixOf)+import Data.Maybe (isJust)+import Data.Typeable (Typeable)+import System.Directory (doesDirectoryExist, getDirectoryContents)+import System.IO (openBinaryFile, IOMode(..))+import System.Process++import Language.Haskell.GhcMod+import Language.Haskell.GhcMod.Internal++----------------------------------------------------------------++data GHCModiError = CmdArg [String] deriving (Show, Typeable)++instance Exception GHCModiError++----------------------------------------------------------------++data Restart = Restart deriving (Show, Typeable)++instance Exception Restart++----------------------------------------------------------------++newtype UnGetLine = UnGetLine (IORef (Maybe String))++emptyNewUnGetLine :: IO UnGetLine+emptyNewUnGetLine = UnGetLine <$> newIORef Nothing++ungetCommand :: UnGetLine -> String -> IO ()+ungetCommand (UnGetLine ref) cmd = writeIORef ref (Just cmd)++getCommand :: UnGetLine -> IO String+getCommand (UnGetLine ref) = do+ mcmd <- readIORef ref+ case mcmd of+ Nothing -> getLine+ Just cmd -> do+ writeIORef ref Nothing+ return cmd++----------------------------------------------------------------++type SymDbReqAction = (Either GhcModError SymbolDb, GhcModLog)+data SymDbReq = SymDbReq (IORef (Async SymDbReqAction)) (IO SymDbReqAction)++newSymDbReq :: Options -> IO SymDbReq+newSymDbReq opt = do+ let act = runGhcModT opt loadSymbolDb+ req <- async act+ ref <- newIORef req+ return $ SymDbReq ref act++getDb :: IOish m => SymDbReq -> GhcModT m SymbolDb+getDb (SymDbReq ref _) = do+ req <- liftIO $ readIORef ref+ -- 'wait' really waits for the asynchronous action at the fist time.+ -- Then it reads a cached value from the second time.+ hoistGhcModT =<< liftIO (wait req)++checkDb :: IOish m => SymDbReq -> SymbolDb -> GhcModT m SymbolDb+checkDb (SymDbReq ref act) db = do+ outdated <- liftIO $ isOutdated db+ if outdated then do+ -- async and wait here is unnecessary because this is essentially+ -- synchronous. But Async can be used a cache.+ req <- liftIO $ async act+ liftIO $ writeIORef ref req+ hoistGhcModT =<< liftIO (wait req)+ else+ return db++----------------------------------------------------------------++build :: IO ProcessHandle+build = do+#ifdef WINDOWS+ nul <- openBinaryFile "NUL" AppendMode+#else+ nul <- openBinaryFile "/dev/null" AppendMode+#endif+ (_, _, _, hdl) <- createProcess $ pro nul+ return hdl+ where+ pro nul = CreateProcess {+ cmdspec = RawCommand "cabal" ["build"]+ , cwd = Nothing+ , env = Nothing+ , std_in = Inherit+ , std_out = UseHandle nul+ , std_err = UseHandle nul+ , close_fds = False+#if __GLASGOW_HASKELL__ >= 702+ , create_group = True+#endif+#if __GLASGOW_HASKELL__ >= 707+ , delegate_ctlc = False+#endif+ }++autogen :: String+autogen = "dist/build/autogen"++isAutogenPrepared :: IO Bool+isAutogenPrepared = do+ exist <- doesDirectoryExist autogen+ if exist then do+ files <- filter ("." `isPrefixOf`) <$> getDirectoryContents autogen+ if length files >= 2 then+ return True+ else+ return False+ else+ return False++watch :: Int -> ProcessHandle -> IO ()+watch 0 _ = return ()+watch n hdl = do+ prepared <- isAutogenPrepared+ if prepared then+ interruptProcessGroupOf hdl+ else do+ threadDelay 100000+ watch (n - 1) hdl++prepareAutogen :: Cradle -> IO ()+prepareAutogen crdl = when (isJust $ cradleCabalFile crdl) $ do+ prepared <- isAutogenPrepared+ unless prepared $ do+ hdl <- build+ watch 30 hdl