Merge branch 'master' into release
This commit is contained in:
Daniel Gröber
commit
e3d4303ea8
|
|
@ -46,6 +46,7 @@ module Language.Haskell.GhcMod (
|
|||
, dumpSymbol
|
||||
-- * SymbolDb
|
||||
, loadSymbolDb
|
||||
, isOutdated
|
||||
) where
|
||||
|
||||
import Language.Haskell.GhcMod.Boot
|
||||
|
|
|
|||
|
|
@ -31,7 +31,7 @@ import qualified Distribution.PackageDescription as P
|
|||
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 @@ getGHCId = CompilerId GHC <$> getGHC
|
|||
|
||||
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"
|
||||
|
|
|
|||
|
|
@ -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 @@ module Language.Haskell.GhcMod.CabalConfig (
|
|||
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 @@ import qualified Language.Haskell.GhcMod.Cabal21 as C21
|
|||
#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.PackageDescription (FlagAssignment)
|
|||
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 @@ type CabalConfig = String
|
|||
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 @@ extractField config field =
|
|||
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
|
||||
|
|
|
|||
|
|
@ -8,9 +8,8 @@ module Language.Haskell.GhcMod.Check (
|
|||
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,10 +29,15 @@ checkSyntax files = either id id <$> check files
|
|||
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
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
{-# LANGUAGE TypeFamilies, ScopedTypeVariables #-}
|
||||
module Language.Haskell.GhcMod.Error (
|
||||
GhcModError(..)
|
||||
, gmeDoc
|
||||
, modifyError
|
||||
, modifyError'
|
||||
, tryFix
|
||||
|
|
@ -10,6 +11,7 @@ module Language.Haskell.GhcMod.Error (
|
|||
|
||||
import Control.Monad.Error (MonadError(..), Error(..))
|
||||
import Exception
|
||||
import Text.PrettyPrint
|
||||
|
||||
data GhcModError = GMENoMsg
|
||||
-- ^ Unknown error
|
||||
|
|
@ -29,6 +31,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
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE CPP, BangPatterns #-}
|
||||
|
||||
module Language.Haskell.GhcMod.Find
|
||||
#ifndef SPEC
|
||||
|
|
@ -10,30 +10,27 @@ module Language.Haskell.GhcMod.Find
|
|||
, 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,8 +49,14 @@ import qualified Data.Map as M
|
|||
-- | 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
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
|
|
@ -66,12 +69,6 @@ symbolCacheVersion = 0
|
|||
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 :: IOish m => Symbol -> SymbolDb -> GhcModT m String
|
|||
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 @@ readSymbolDb = do
|
|||
----------------------------------------------------------------
|
||||
-- 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 @@ writeSymbolCache cache sm =
|
|||
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 :: [(Symbol,ModuleString)]
|
|||
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
|
||||
|
|
|
|||
|
|
@ -8,9 +8,12 @@ module Language.Haskell.GhcMod.GhcPkg (
|
|||
, 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.Char (isSpace)
|
|||
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 @@ getSandboxDbDir sconf = do
|
|||
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 @@ getPackageDbStack cdir =
|
|||
(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 @@ fromInstalledPackageId pid =
|
|||
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 @@ ghcDbStackOpts :: [GhcPkgDb] -- ^ Package db stack
|
|||
-> [String]
|
||||
ghcDbStackOpts dbs = ghcDbOpt `concatMap` dbs
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
ghcPkgDbOpt :: GhcPkgDb -> [String]
|
||||
ghcPkgDbOpt GlobalDb = ["--global"]
|
||||
ghcPkgDbOpt UserDb = ["--user"]
|
||||
|
|
@ -95,3 +108,31 @@ ghcDbOpt UserDb
|
|||
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"
|
||||
|
|
|
|||
|
|
@ -16,8 +16,9 @@ module Language.Haskell.GhcMod.Internal (
|
|||
, cabalDependPackages
|
||||
, cabalSourceDirs
|
||||
, cabalAllTargets
|
||||
-- * GHC.Paths
|
||||
-- * Various Paths
|
||||
, ghcLibDir
|
||||
, ghcModExecutable
|
||||
-- * IO
|
||||
, getDynamicFlags
|
||||
-- * Targets
|
||||
|
|
@ -42,21 +43,30 @@ module Language.Haskell.GhcMod.Internal (
|
|||
, 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
|
||||
|
|
|
|||
|
|
@ -200,11 +200,11 @@ initializeFlagsWithCradle opt c
|
|||
| 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
|
||||
|
|
|
|||
|
|
@ -25,7 +25,12 @@ newtype LineSeparator = LineSeparator String
|
|||
|
||||
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 @@ data Options = Options {
|
|||
, 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
|
||||
|
|
|
|||
|
|
@ -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_ :: (MonadIO m, ExceptionMonad m) => FilePath -> m a -> m a
|
|||
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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -86,8 +86,8 @@ Library
|
|||
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 @@ Library
|
|||
, io-choice
|
||||
, monad-journal >= 0.4
|
||||
, old-time
|
||||
, pretty
|
||||
, process
|
||||
, syb
|
||||
, time
|
||||
|
|
@ -134,8 +135,11 @@ Executable ghc-mod
|
|||
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 @@ Executable ghc-modi
|
|||
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 @@ Executable ghc-modi
|
|||
, containers
|
||||
, directory
|
||||
, filepath
|
||||
, old-time
|
||||
, process
|
||||
, split
|
||||
, time
|
||||
, ghc
|
||||
, ghc-mod
|
||||
|
||||
|
|
@ -199,6 +209,7 @@ Test-Suite spec
|
|||
, io-choice
|
||||
, monad-journal >= 0.4
|
||||
, old-time
|
||||
, pretty
|
||||
, process
|
||||
, syb
|
||||
, time
|
||||
|
|
|
|||
554
src/GHCMod.hs
554
src/GHCMod.hs
|
|
@ -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
|
||||
|
||||
isIndented = (" " `isPrefixOf`)
|
||||
isNotCmdHead = ( not . (" - " `isPrefixOf`))
|
||||
isCurrCmdHead = ((" - " ++ cmd) `isPrefixOf`)
|
||||
|
||||
unindent (' ':' ':' ':' ':l) = l
|
||||
unindent l = l
|
||||
in unlines $ unindent <$> c
|
||||
----------------------------------------------------------------
|
||||
|
||||
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 }
|
||||
option :: [Char] -> [String] -> String -> ArgDescr a -> OptDescr a
|
||||
option s l udsc dsc = Option s l dsc udsc
|
||||
|
||||
, option "h" ["hlintOpt"] "hlint options" $
|
||||
reqArg "hlintOpt" $ \h o -> o { hlintOpts = h : hlintOpts o }
|
||||
reqArg :: String -> (String -> a) -> ArgDescr a
|
||||
reqArg udsc dsc = ReqArg dsc udsc
|
||||
|
||||
, option "g" ["ghcOpt"] "GHC options" $
|
||||
reqArg "ghcOpt" $ \g o ->
|
||||
o { ghcUserOptions = g : ghcUserOptions o }
|
||||
|
||||
, option "v" ["verbose"] "verbose" $
|
||||
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 }
|
||||
]
|
||||
|
|
|
|||
253
src/GHCModi.hs
253
src/GHCModi.hs
|
|
@ -20,36 +20,27 @@ module Main where
|
|||
|
||||
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 @@ parseArgs spec argv
|
|||
|
||||
----------------------------------------------------------------
|
||||
|
||||
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 @@ main = E.handle cmdHandler $
|
|||
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 @@ replace needle replacement = intercalate replacement . splitOn needle
|
|||
|
||||
----------------------------------------------------------------
|
||||
|
||||
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 @@ parseLintOptions optFile = case brk (== ']') (dropWhile (/= '[') optFile) of
|
|||
|
||||
----------------------------------------------------------------
|
||||
|
||||
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 }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
Loading…
Reference in New Issue