hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge pull request #288 from DanielG/dev-pkgs

Browse Source 
Make `GhcMod` be `GhcModT (ErrorT IO)`
This commit is contained in:
Kazu Yamamoto 2014-07-15 11:49:10 +09:00
commit 89a4db2345
21 changed files with 184 additions and 101 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Language/Haskell/GhcMod/Boot.hs
View File

@ -8,7 +8,7 @@ import Language.Haskell.GhcMod.List
import Language.Haskell.GhcMod.Monad
-- | Printing necessary information for front-end booting.
boot :: GhcMod String
boot :: IOish m => GhcModT m String
boot = concat <$> sequence [modules, languages, flags,
concat <$> mapM browse preBrowsedModules]

15
Language/Haskell/GhcMod/Browse.hs
View File

@ -28,8 +28,9 @@ import Type (dropForAlls, splitFunTy_maybe, mkFunTy, isPredTy)
-- | Getting functions, classes, etc from a module.
-- If 'detailed' is 'True', their types are also obtained.
-- If 'operators' is 'True', operators are also returned.
browse :: ModuleString -- ^ A module name. (e.g. \"Data.List\")
-> GhcMod String
browse :: IOish m
=> ModuleString -- ^ A module name. (e.g. \"Data.List\")
-> GhcModT m String
browse pkgmdl = convert' . sort =<< (listExports =<< getModule)
where
(mpkg,mdl) = splitPkgMdl pkgmdl
@ -61,7 +62,7 @@ splitPkgMdl pkgmdl = case break (==':') pkgmdl of
(mdl,"") -> (Nothing,mdl)
(pkg,_:mdl) -> (Just pkg,mdl)
processExports :: ModuleInfo -> GhcMod [String]
processExports :: IOish m => ModuleInfo -> GhcModT m [String]
processExports minfo = do
opt <- options
let
@ -70,13 +71,13 @@ processExports minfo = do
| otherwise = filter (isAlpha . head . getOccString)
mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo
showExport :: Options -> ModuleInfo -> Name -> GhcMod String
showExport :: IOish m => Options -> ModuleInfo -> Name -> GhcModT m String
showExport opt minfo e = do
mtype' <- mtype
return $ concat $ catMaybes [mqualified, Just $ formatOp $ getOccString e, mtype']
where
mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` qualified opt
mtype :: GhcMod (Maybe String)
mtype :: IOish m => GhcModT m (Maybe String)
mtype
| detailed opt = do
tyInfo <- G.modInfoLookupName minfo e
@ -91,7 +92,7 @@ showExport opt minfo e = do
| isAlpha n = nm
| otherwise = "(" ++ nm ++ ")"
formatOp "" = error "formatOp"
inOtherModule :: Name -> GhcMod (Maybe TyThing)
inOtherModule :: IOish m => Name -> GhcModT m (Maybe TyThing)
inOtherModule nm = G.getModuleInfo (G.nameModule nm) >> G.lookupGlobalName nm
justIf :: a -> Bool -> Maybe a
justIf x True = Just x
@ -138,7 +139,7 @@ showOutputable dflag = unwords . lines . showPage dflag styleUnqualified . ppr
----------------------------------------------------------------
-- | Browsing all functions in all system/user modules.
browseAll :: DynFlags -> GhcMod [(String,String)]
browseAll :: IOish m => DynFlags -> GhcModT m [(String,String)]
browseAll dflag = do
ms <- G.packageDbModules True
is <- mapM G.getModuleInfo ms

5
Language/Haskell/GhcMod/CaseSplit.hs
View File

@ -33,10 +33,11 @@ data SplitToTextInfo = SplitToTextInfo { sVarName :: String
}
-- | Splitting a variable in a equation.
splits :: FilePath -- ^ A target file.
splits :: IOish m
=> FilePath -- ^ A target file.
-> Int -- ^ Line number.
-> Int -- ^ Column number.
-> GhcMod String
-> GhcModT m String
splits file lineNo colNo = ghandle handler body
where
body = inModuleContext file $ \dflag style -> do

20
Language/Haskell/GhcMod/Check.hs
View File

@ -15,8 +15,9 @@ import Language.Haskell.GhcMod.Monad
-- | Checking syntax of a target file using GHC.
-- Warnings and errors are returned.
checkSyntax :: [FilePath] -- ^ The target files.
-> GhcMod String
checkSyntax :: IOish m
=> [FilePath] -- ^ The target files.
-> GhcModT m String
checkSyntax [] = return ""
checkSyntax files = withErrorHandler sessionName $ do
either id id <$> check files
@ -29,8 +30,9 @@ checkSyntax files = withErrorHandler sessionName $ do
-- | Checking syntax of a target file using GHC.
-- Warnings and errors are returned.
check :: [FilePath] -- ^ The target files.
-> GhcMod (Either String String)
check :: IOish m
=> [FilePath] -- ^ The target files.
-> GhcModT m (Either String String)
check fileNames = do
withLogger setAllWaringFlags $ do
setTargetFiles fileNames
@ -38,8 +40,9 @@ check fileNames = do
----------------------------------------------------------------
-- | Expanding Haskell Template.
expandTemplate :: [FilePath] -- ^ The target files.
-> GhcMod String
expandTemplate :: IOish m
=> [FilePath] -- ^ The target files.
-> GhcModT m String
expandTemplate [] = return ""
expandTemplate files = withErrorHandler sessionName $ do
either id id <$> expand files
@ -51,7 +54,8 @@ expandTemplate files = withErrorHandler sessionName $ do
----------------------------------------------------------------
-- | Expanding Haskell Template.
expand :: [FilePath] -- ^ The target files.
-> GhcMod (Either String String)
expand :: IOish m
=> [FilePath] -- ^ The target files.
-> GhcModT m (Either String String)
expand fileNames = withLogger (Gap.setDumpSplices . setNoWaringFlags) $
setTargetFiles fileNames

2
Language/Haskell/GhcMod/Convert.hs
View File

@ -23,7 +23,7 @@ inter :: Char -> [Builder] -> Builder
inter _ [] = id
inter c bs = foldr1 (\x y -> x . (c:) . y) bs
convert' :: ToString a => a -> GhcMod String
convert' :: (ToString a, IOish m) => a -> GhcModT m String
convert' x = flip convert x <$> options
convert :: ToString a => Options -> a -> String

4
Language/Haskell/GhcMod/Debug.hs
View File

@ -12,7 +12,7 @@ import Language.Haskell.GhcMod.Internal
----------------------------------------------------------------
-- | Obtaining debug information.
debugInfo :: GhcMod String
debugInfo :: IOish m => GhcModT m String
debugInfo = cradle >>= \c -> convert' =<< do
CompilerOptions gopts incDir pkgs <-
if isJust $ cradleCabalFile c then
@ -38,5 +38,5 @@ debugInfo = cradle >>= \c -> convert' =<< do
----------------------------------------------------------------
-- | Obtaining root information.
rootInfo :: GhcMod String
rootInfo :: IOish m => GhcModT m String
rootInfo = convert' =<< cradleRootDir <$> cradle

5
Language/Haskell/GhcMod/FillSig.hs
View File

@ -38,10 +38,11 @@ data SigInfo = Signature SrcSpan [G.RdrName] (G.HsType G.RdrName)
data HESigInfo = HESignature HE.SrcSpan [HE.Name HE.SrcSpanInfo] (HE.Type HE.SrcSpanInfo)
-- | Create a initial body from a signature.
sig :: FilePath -- ^ A target file.
sig :: IOish m
=> FilePath -- ^ A target file.
-> Int -- ^ Line number.
-> Int -- ^ Column number.
-> GhcMod String
-> GhcModT m String
sig file lineNo colNo = ghandle handler body
where
body = inModuleContext file $ \dflag style -> do

4
Language/Haskell/GhcMod/Find.hs
View File

@ -31,11 +31,11 @@ type Symbol = String
newtype SymMdlDb = SymMdlDb (Map Symbol [ModuleString])
-- | Finding modules to which the symbol belong.
findSymbol :: Symbol -> GhcMod String
findSymbol :: IOish m => Symbol -> GhcModT m String
findSymbol sym = convert' =<< lookupSym sym <$> getSymMdlDb
-- | Creating 'SymMdlDb'.
getSymMdlDb :: GhcMod SymMdlDb
getSymMdlDb :: IOish m => GhcModT m SymMdlDb
getSymMdlDb = do
sm <- G.getSessionDynFlags >>= browseAll
#if MIN_VERSION_containers(0,5,0)

2
Language/Haskell/GhcMod/Flag.hs
View File

@ -6,7 +6,7 @@ import Language.Haskell.GhcMod.Monad
-- | Listing GHC flags. (e.g -fno-warn-orphans)
flags :: GhcMod String
flags :: IOish m => GhcModT m String
flags = convert' [ "-f" ++ prefix ++ option
| option <- Gap.fOptions
, prefix <- ["","no-"]

10
Language/Haskell/GhcMod/Info.hs
View File

@ -21,9 +21,10 @@ import Language.Haskell.GhcMod.Convert
----------------------------------------------------------------
-- | Obtaining information of a target expression. (GHCi's info:)
info :: FilePath -- ^ A target file.
info :: IOish m
=> FilePath -- ^ A target file.
-> Expression -- ^ A Haskell expression.
-> GhcMod String
-> GhcModT m String
info file expr = do
opt <- options
convert opt <$> ghandle handler body
@ -36,10 +37,11 @@ info file expr = do
----------------------------------------------------------------
-- | Obtaining type of a target expression. (GHCi's type:)
types :: FilePath -- ^ A target file.
types :: IOish m
=> FilePath -- ^ A target file.
-> Int -- ^ Line number.
-> Int -- ^ Column number.
-> GhcMod String
-> GhcModT m String
types file lineNo colNo = do
opt <- options
convert opt <$> ghandle handler body

2
Language/Haskell/GhcMod/Lang.hs
View File

@ -6,5 +6,5 @@ import Language.Haskell.GhcMod.Monad
-- | Listing language extensions.
languages :: GhcMod String
languages :: IOish m => GhcModT m String
languages = convert' supportedLanguagesAndExtensions

5
Language/Haskell/GhcMod/Lint.hs
View File

@ -11,8 +11,9 @@ import Language.Haskell.HLint (hlint)
-- | Checking syntax of a target file using hlint.
-- Warnings and errors are returned.
lint :: FilePath -- ^ A target file.
-> GhcMod String
lint :: IOish m
=> FilePath -- ^ A target file.
-> GhcModT m String
lint file = do
opt <- options
ghandle handler . pack =<< (liftIO $ hlint $ file : "--quiet" : hlintOpts opt)

2
Language/Haskell/GhcMod/List.hs
View File

@ -13,7 +13,7 @@ import UniqFM (eltsUFM)
----------------------------------------------------------------
-- | Listing installed modules.
modules :: GhcMod String
modules :: IOish m => GhcModT m String
modules = do
opt <- options
convert opt . (arrange opt) <$> (getModules `G.gcatch` handler)

11
Language/Haskell/GhcMod/Logger.hs
View File

@ -34,7 +34,7 @@ newtype LogRef = LogRef (IORef Builder)
newLogRef :: IO LogRef
newLogRef = LogRef <$> newIORef id
readAndClearLogRef :: LogRef -> GhcMod String
readAndClearLogRef :: IOish m => LogRef -> GhcModT m String
readAndClearLogRef (LogRef ref) = do
b <- liftIO $ readIORef ref
liftIO $ writeIORef ref id
@ -50,9 +50,10 @@ appendLogRef df (LogRef ref) _ sev src style msg = do
-- | Set the session flag (e.g. "-Wall" or "-w:") then
-- executes a body. Logged messages are returned as 'String'.
-- Right is success and Left is failure.
withLogger :: (DynFlags -> DynFlags)
-> GhcMod ()
-> GhcMod (Either String String)
withLogger :: IOish m
=> (DynFlags -> DynFlags)
-> GhcModT m ()
-> GhcModT m (Either String String)
withLogger setDF body = ghandle sourceError $ do
logref <- liftIO $ newLogRef
wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcOpts <$> options
@ -65,7 +66,7 @@ withLogger setDF body = ghandle sourceError $ do
----------------------------------------------------------------
-- | Converting 'SourceError' to 'String'.
sourceError :: SourceError -> GhcMod (Either String String)
sourceError :: IOish m => SourceError -> GhcModT m (Either String String)
sourceError err = do
dflags <- G.getSessionDynFlags
style <- toGhcMod getStyle

121
Language/Haskell/GhcMod/Monad.hs
View File

@ -1,16 +1,18 @@
{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-}
{-# LANGUAGE TypeFamilies, UndecidableInstances, RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Haskell.GhcMod.Monad (
GhcMod
, runGhcMod
, liftGhcMod
, GhcModT
, IOish
, GhcModEnv(..)
, GhcModWriter
, GhcModState(..)
, runGhcMod'
, runGhcMod
, runGhcModT'
, runGhcModT
, newGhcModEnv
@ -18,11 +20,23 @@ module Language.Haskell.GhcMod.Monad (
, toGhcMod
, options
, cradle
, Options(..)
, defaultOptions
, module Control.Monad.Reader.Class
, module Control.Monad.Writer.Class
, module Control.Monad.State.Class
) where
#if __GLASGOW_HASKELL__ < 708
-- 'CoreMonad.MonadIO' and 'Control.Monad.IO.Class.MonadIO' are different
-- classes before ghc 7.8
#define DIFFERENT_MONADIO 1
-- RWST doen't have a MonadIO instance before ghc 7.8
#define MONADIO_INSTANCES 1
#endif
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Cradle
import Language.Haskell.GhcMod.DynFlags
@ -47,22 +61,26 @@ import HscTypes
-- So, RWST automatically becomes an instance of MonadIO.
import MonadUtils
#if __GLASGOW_HASKELL__ < 708
-- To make RWST an instance of MonadIO.
#if DIFFERENT_MONADIO
import Control.Monad.Trans.Class (lift)
import qualified Control.Monad.IO.Class
import Data.Monoid (Monoid)
#endif
import Control.Applicative (Alternative)
import Control.Monad (MonadPlus, liftM, void)
import Control.Monad.Base (MonadBase, liftBase)
import Control.Monad.Trans.RWS.Lazy (liftCatch)
import Control.Monad.Reader.Class
import Control.Monad.State.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith, control, liftBaseOp, liftBaseOp_)
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith,
control, liftBaseOp, liftBaseOp_)
import Control.Monad.Trans.RWS.Lazy (RWST(..), runRWST)
import Control.Monad.Writer.Class
import Control.Monad.Error (Error(..), ErrorT(..), MonadError)
import Data.Maybe (fromJust, isJust)
import Data.IORef (IORef, readIORef, writeIORef, newIORef)
@ -78,16 +96,28 @@ data GhcModEnv = GhcModEnv {
, gmCradle :: Cradle
}
data GhcModState = GhcModState
data GhcModState = GhcModState deriving (Eq,Show,Read)
defaultState :: GhcModState
defaultState = GhcModState
type GhcModWriter = ()
data GhcModError = GMENoMsg
| GMEString String
| GMECabal
| GMEGhc
deriving (Eq,Show,Read)
instance Error GhcModError where
noMsg = GMENoMsg
strMsg = GMEString
----------------------------------------------------------------
type GhcMod a = GhcModT IO a
type IOish m = (Functor m, MonadIO m, MonadBaseControl IO m)
type GhcMod a = GhcModT (ErrorT GhcModError IO) a
newtype GhcModT m a = GhcModT {
unGhcModT :: RWST GhcModEnv GhcModWriter GhcModState m a
@ -97,16 +127,27 @@ newtype GhcModT m a = GhcModT {
, Monad
, MonadPlus
, MonadIO
#if DIFFERENT_MONADIO
, Control.Monad.IO.Class.MonadIO
#endif
, MonadReader GhcModEnv
, MonadWriter GhcModWriter
, MonadState GhcModState
, MonadTrans
)
#if __GLASGOW_HASKELL__ < 708
deriving instance MonadError GhcModError m => MonadError GhcModError (GhcModT m)
#if MONADIO_INSTANCES
instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where
-- liftIO :: MonadIO m => IO a -> m a
liftIO = lift . liftIO
instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where
liftIO = lift . liftIO
instance (MonadIO m) => MonadIO (MaybeT m) where
liftIO = lift . liftIO
#endif
----------------------------------------------------------------
@ -155,15 +196,6 @@ initSession build Options {..} CompilerOptions {..} = do
----------------------------------------------------------------
runGhcModT' :: (MonadIO m, MonadBaseControl IO m)
=> GhcModEnv
-> GhcModState
-> GhcModT m a
-> m (a,(GhcModState, GhcModWriter))
runGhcModT' r s a = do
(a',s',w) <- runRWST (unGhcModT $ initGhcMonad (Just libdir) >> a) r s
return (a',(s',w))
newGhcModEnv :: Options -> FilePath -> IO GhcModEnv
newGhcModEnv opt dir = do
session <- newIORef (error "empty session")
@ -174,7 +206,10 @@ newGhcModEnv opt dir = do
, gmCradle = c
}
runGhcModT :: (MonadIO m, MonadBaseControl IO m) => Options -> GhcModT m a -> m a
-- | Run a @GhcModT m@ computation, i.e. one with a custom underlying monad.
--
-- You probably don't want this, look at 'runGhcMod' instead.
runGhcModT :: IOish m => Options -> GhcModT m a -> m a
runGhcModT opt action = do
env <- liftBase $ newGhcModEnv opt =<< getCurrentDirectory
(a,(_,_)) <- runGhcModT' env defaultState $ do
@ -184,46 +219,68 @@ runGhcModT opt action = do
action
return a
runGhcMod' :: GhcModEnv
-- | Run a computation inside @GhcModT@ providing the RWST environment and
-- initial state. This is a low level function, use it only if you know what to
-- do with 'GhcModEnv' and 'GhcModState'.
--
-- You should probably look at 'runGhcModT' instead.
runGhcModT' :: IOish m
=> GhcModEnv
-> GhcModState
-> GhcModT IO a
-> IO (a,(GhcModState, GhcModWriter))
runGhcMod' = runGhcModT'
-> GhcModT m a
-> m (a,(GhcModState, GhcModWriter))
runGhcModT' r s a = do
(a',s',w) <- runRWST (unGhcModT $ initGhcMonad (Just libdir) >> a) r s
return (a',(s',w))
-- | Run a 'GhcMod' computation. If you want an underlying monad other than
-- 'ErrorT e IO' you should look at 'runGhcModT'
runGhcMod :: Options
-> GhcMod a
-> IO (Either GhcModError a)
runGhcMod o a =
runErrorT $ runGhcModT o a
liftErrorT :: IOish m => GhcModT m a -> GhcModT (ErrorT GhcModError m) a
liftErrorT action =
GhcModT $ RWST $ \e s -> ErrorT $ Right <$> (runRWST $ unGhcModT action) e s
-- | Lift @(GhcModT IO)@ into @GhcMod@, which is an alias for @GhcModT (ErrorT
-- GhcModError IO)@.
liftGhcMod :: GhcModT IO a -> GhcMod a
liftGhcMod = liftErrorT
runGhcMod :: Options -> GhcMod a -> IO a
runGhcMod = runGhcModT
----------------------------------------------------------------
withErrorHandler :: String -> GhcMod a -> GhcMod a
withErrorHandler :: IOish m => String -> GhcModT m a -> GhcModT m a
withErrorHandler label = ghandle ignore
where
ignore :: SomeException -> GhcMod a
ignore :: IOish m => SomeException -> GhcModT m a
ignore e = liftIO $ do
hPutStr stderr $ label ++ ":0:0:Error:"
hPrint stderr e
exitSuccess
-- | This is only a transitional mechanism don't use it for new code.
toGhcMod :: (Functor m, MonadIO m) => Ghc a -> GhcModT m a
toGhcMod :: IOish m => Ghc a -> GhcModT m a
toGhcMod a = do
s <- gmGhcSession <$> ask
liftIO $ unGhc a $ Session s
----------------------------------------------------------------
options :: GhcMod Options
options :: IOish m => GhcModT m Options
options = gmOptions <$> ask
cradle :: GhcMod Cradle
cradle :: IOish m => GhcModT m Cradle
cradle = gmCradle <$> ask
instance (MonadBaseControl IO m) => MonadBase IO (GhcModT m) where
liftBase = GhcModT . liftBase
instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where
newtype StM (GhcModT m) a = StGhcMod {
unStGhcMod :: StM (RWST GhcModEnv () GhcModState m) a }
unStGhcMod :: StM (RWST GhcModEnv GhcModWriter GhcModState m) a }
liftBaseWith f = GhcModT . liftBaseWith $ \runInBase ->
f $ liftM StGhcMod . runInBase . unGhcModT

2
Language/Haskell/GhcMod/PkgDoc.hs
View File

@ -9,7 +9,7 @@ import Control.Applicative ((<$>))
import System.Process (readProcess)
-- | Obtaining the package name and the doc path of a module.
pkgDoc :: String -> GhcMod String
pkgDoc :: IOish m => String -> GhcModT m String
pkgDoc mdl = cradle >>= \c -> liftIO $ do
pkg <- trim <$> readProcess "ghc-pkg" (toModuleOpts c) []
if pkg == "" then

5
ghc-mod.cabal
View File

@ -51,6 +51,7 @@ Extra-Source-Files: ChangeLog
Library
Default-Language: Haskell2010
GHC-Options: -Wall
Default-Extensions: ConstraintKinds, FlexibleContexts
Exposed-Modules: Language.Haskell.GhcMod
Language.Haskell.GhcMod.Ghc
Language.Haskell.GhcMod.Monad
@ -117,6 +118,7 @@ Executable ghc-mod
Main-Is: GHCMod.hs
Other-Modules: Paths_ghc_mod
GHC-Options: -Wall
Default-Extensions: ConstraintKinds, FlexibleContexts
HS-Source-Dirs: src
Build-Depends: base >= 4.0 && < 5
, directory
@ -130,6 +132,7 @@ Executable ghc-modi
Main-Is: GHCModi.hs
Other-Modules: Paths_ghc_mod
GHC-Options: -Wall
Default-Extensions: ConstraintKinds, FlexibleContexts
HS-Source-Dirs: src
Build-Depends: base >= 4.0 && < 5
, containers
@ -143,12 +146,14 @@ Test-Suite doctest
Default-Language: Haskell2010
HS-Source-Dirs: test
Ghc-Options: -threaded -Wall
Default-Extensions: ConstraintKinds, FlexibleContexts
Main-Is: doctests.hs
Build-Depends: base
, doctest >= 0.9.3
Test-Suite spec
Default-Language: Haskell2010
Default-Extensions: ConstraintKinds, FlexibleContexts
Main-Is: Main.hs
Hs-Source-Dirs: test, .
Type: exitcode-stdio-1.0

4
src/GHCMod.hs
View File

@ -111,7 +111,7 @@ main = flip E.catches handlers $ do
nArgs n f = if length remainingArgs == n
then f
else E.throw (ArgumentsMismatch cmdArg0)
res <- runGhcMod opt $ case cmdArg0 of
res <- runGhcModT opt $ case cmdArg0 of
"list" -> modules
"lang" -> languages
"flag" -> flags
@ -152,7 +152,7 @@ main = flip E.catches handlers $ do
hPutStrLn stderr $ "\"" ++ file ++ "\" not found"
printUsage
printUsage = hPutStrLn stderr $ '\n' : O.usageInfo usage argspec
withFile :: (FilePath -> GhcMod a) -> FilePath -> GhcMod a
withFile :: IOish m => (FilePath -> GhcModT m a) -> FilePath -> GhcModT m a
withFile cmd file = do
exist <- liftIO $ doesFileExist file
if exist

51
src/GHCModi.hs
View File

@ -101,8 +101,8 @@ main = E.handle cmdHandler $
-- c = cradle0 { cradleCurrentDir = rootdir } TODO: ?????
setCurrentDirectory rootdir
mvar <- liftIO newEmptyMVar
void $ forkIO $ runGhcMod opt $ setupDB mvar
runGhcMod opt $ loop S.empty mvar
void $ forkIO $ runGhcModT opt $ setupDB mvar
runGhcModT opt $ loop S.empty mvar
where
-- this is just in case.
-- If an error is caught here, it is a bug of GhcMod library.
@ -116,7 +116,7 @@ replace (x:xs) = x : replace xs
----------------------------------------------------------------
setupDB :: MVar SymMdlDb -> GhcMod ()
setupDB :: IOish m => MVar SymMdlDb -> GhcModT m ()
setupDB mvar = ghandle handler $ do
liftIO . putMVar mvar =<< getSymMdlDb
where
@ -124,7 +124,7 @@ setupDB mvar = ghandle handler $ do
----------------------------------------------------------------
loop :: Set FilePath -> MVar SymMdlDb -> GhcMod ()
loop :: IOish m => Set FilePath -> MVar SymMdlDb -> GhcModT m ()
loop set mvar = do
cmdArg <- liftIO getLine
let (cmd,arg') = break (== ' ') cmdArg
@ -152,9 +152,10 @@ loop set mvar = do
----------------------------------------------------------------
checkStx :: Set FilePath
checkStx :: IOish m
=> Set FilePath
-> FilePath
-> GhcMod (String, Bool, Set FilePath)
-> GhcModT m (String, Bool, Set FilePath)
checkStx set file = do
set' <- toGhcMod $ newFileSet set file
let files = S.toList set'
@ -191,17 +192,17 @@ isSameMainFile file (Just x)
----------------------------------------------------------------
findSym :: Set FilePath -> String -> MVar SymMdlDb
-> GhcMod (String, Bool, Set FilePath)
findSym :: IOish m => Set FilePath -> String -> MVar SymMdlDb
-> GhcModT m (String, Bool, Set FilePath)
findSym set sym mvar = do
db <- liftIO $ readMVar mvar
opt <- options
let ret = lookupSym' opt sym db
return (ret, True, set)
lintStx :: Set FilePath
lintStx :: IOish m => Set FilePath
-> FilePath
-> GhcMod (String, Bool, Set FilePath)
-> GhcModT m (String, Bool, Set FilePath)
lintStx set optFile = do
ret <- local env' $ lint file
return (ret, True, set)
@ -228,36 +229,40 @@ parseLintOptions optFile = case brk (== ']') (dropWhile (/= '[') optFile) of
----------------------------------------------------------------
showInfo :: Set FilePath
showInfo :: IOish m
=> Set FilePath
-> FilePath
-> GhcMod (String, Bool, Set FilePath)
-> GhcModT m (String, Bool, Set FilePath)
showInfo set fileArg = do
let [file, expr] = words fileArg
set' <- newFileSet set file
ret <- info file expr
return (ret, True, set')
showType :: Set FilePath
showType :: IOish m
=> Set FilePath
-> FilePath
-> GhcMod (String, Bool, Set FilePath)
-> GhcModT m (String, Bool, Set FilePath)
showType set fileArg = do
let [file, line, column] = words fileArg
set' <- newFileSet set file
ret <- types file (read line) (read column)
return (ret, True, set')
doSplit :: Set FilePath
doSplit :: IOish m
=> Set FilePath
-> FilePath
-> GhcMod (String, Bool, Set FilePath)
-> GhcModT m (String, Bool, Set FilePath)
doSplit set fileArg = do
let [file, line, column] = words fileArg
set' <- newFileSet set file
ret <- splits file (read line) (read column)
return (ret, True, set')
doSig :: Set FilePath
doSig :: IOish m
=> Set FilePath
-> FilePath
-> GhcMod (String, Bool, Set FilePath)
-> GhcModT m (String, Bool, Set FilePath)
doSig set fileArg = do
let [file, line, column] = words fileArg
set' <- newFileSet set file
@ -266,15 +271,17 @@ doSig set fileArg = do
----------------------------------------------------------------
bootIt :: Set FilePath
-> GhcMod (String, Bool, Set FilePath)
bootIt :: IOish m
=> Set FilePath
-> GhcModT m (String, Bool, Set FilePath)
bootIt set = do
ret <- boot
return (ret, True, set)
browseIt :: Set FilePath
browseIt :: IOish m
=> Set FilePath
-> ModuleString
-> GhcMod (String, Bool, Set FilePath)
-> GhcModT m (String, Bool, Set FilePath)
browseIt set mdl = do
ret <- browse mdl
return (ret, True, set)

12
test/TestUtils.hs
View File

@ -12,14 +12,14 @@ module TestUtils (
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Types
isolateCradle :: GhcMod a -> GhcMod a
isolateCradle :: IOish m => GhcModT m a -> GhcModT m a
isolateCradle action =
local modifyEnv $ action
where
modifyEnv e = e { gmCradle = (gmCradle e) { cradlePkgDbStack = [GlobalDb] } }
runIsolatedGhcMod :: Options -> GhcMod a -> IO a
runIsolatedGhcMod opt action = runGhcMod opt $ isolateCradle action
runIsolatedGhcMod :: Options -> GhcModT IO a -> IO a
runIsolatedGhcMod opt action = runGhcModT opt $ isolateCradle action
-- | Run GhcMod in isolated cradle with default options
runID = runIsolatedGhcMod defaultOptions
@ -28,7 +28,9 @@ runID = runIsolatedGhcMod defaultOptions
runI = runIsolatedGhcMod
-- | Run GhcMod
run = runGhcMod
run :: Options -> GhcModT IO a -> IO a
run = runGhcModT
-- | Run GhcMod with default options
runD = runGhcMod defaultOptions
runD :: GhcModT IO a -> IO a
runD = runGhcModT defaultOptions

1
test/doctests.hs
View File

@ -6,6 +6,7 @@ main :: IO ()
main = doctest [
"-package"
, "ghc"
, "-XConstraintKinds", "-XFlexibleContexts"
, "-idist/build/autogen/"
, "-optP-include"
, "-optPdist/build/autogen/cabal_macros.h"