Use GhcModT everywhere and remove the GhcMod alias

Not doing this makes having GhcModT pretty pointless as users of the
library wouldn't be able to use custom inner monads as evey function for
dealing with GhcModT's would be constraint to (GhcModT IO) thus only
allowing IO as the inner monad.
This commit is contained in:
Daniel Gröber 2014-07-12 11:16:16 +02:00
parent b6896a481a
commit f0bfcb8811
20 changed files with 106 additions and 92 deletions

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

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) data HESigInfo = HESignature HE.SrcSpan [HE.Name HE.SrcSpanInfo] (HE.Type HE.SrcSpanInfo)
-- | Create a initial body from a signature. -- | Create a initial body from a signature.
sig :: FilePath -- ^ A target file. sig :: IOish m
=> FilePath -- ^ A target file.
-> Int -- ^ Line number. -> Int -- ^ Line number.
-> Int -- ^ Column number. -> Int -- ^ Column number.
-> GhcMod String -> GhcModT m String
sig file lineNo colNo = ghandle handler body sig file lineNo colNo = ghandle handler body
where where
body = inModuleContext file $ \dflag style -> do body = inModuleContext file $ \dflag style -> do

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -4,13 +4,11 @@
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Haskell.GhcMod.Monad ( module Language.Haskell.GhcMod.Monad (
GhcMod GhcModT
, GhcModT , IOish
, GhcModEnv(..) , GhcModEnv(..)
, GhcModWriter , GhcModWriter
, GhcModState(..) , GhcModState(..)
, runGhcMod'
, runGhcMod
, runGhcModT' , runGhcModT'
, runGhcModT , runGhcModT
, newGhcModEnv , newGhcModEnv
@ -60,7 +58,8 @@ import Control.Monad.Base (MonadBase, liftBase)
import Control.Monad.Reader.Class import Control.Monad.Reader.Class
import Control.Monad.State.Class import Control.Monad.State.Class
import Control.Monad.Trans.Class import Control.Monad.Trans.Class
import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith, control, liftBaseOp, liftBaseOp_) import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith,
control, liftBaseOp, liftBaseOp_)
import Control.Monad.Trans.RWS.Lazy (RWST(..), runRWST) import Control.Monad.Trans.RWS.Lazy (RWST(..), runRWST)
import Control.Monad.Writer.Class import Control.Monad.Writer.Class
@ -87,7 +86,7 @@ type GhcModWriter = ()
---------------------------------------------------------------- ----------------------------------------------------------------
type GhcMod a = GhcModT IO a type IOish m = (Functor m, MonadIO m, MonadBaseControl IO m)
newtype GhcModT m a = GhcModT { newtype GhcModT m a = GhcModT {
unGhcModT :: RWST GhcModEnv GhcModWriter GhcModState m a unGhcModT :: RWST GhcModEnv GhcModWriter GhcModState m a
@ -155,7 +154,7 @@ initSession build Options {..} CompilerOptions {..} = do
---------------------------------------------------------------- ----------------------------------------------------------------
runGhcModT' :: (MonadIO m, MonadBaseControl IO m) runGhcModT' :: IOish m
=> GhcModEnv => GhcModEnv
-> GhcModState -> GhcModState
-> GhcModT m a -> GhcModT m a
@ -174,7 +173,7 @@ newGhcModEnv opt dir = do
, gmCradle = c , gmCradle = c
} }
runGhcModT :: (MonadIO m, MonadBaseControl IO m) => Options -> GhcModT m a -> m a runGhcModT :: IOish m => Options -> GhcModT m a -> m a
runGhcModT opt action = do runGhcModT opt action = do
env <- liftBase $ newGhcModEnv opt =<< getCurrentDirectory env <- liftBase $ newGhcModEnv opt =<< getCurrentDirectory
(a,(_,_)) <- runGhcModT' env defaultState $ do (a,(_,_)) <- runGhcModT' env defaultState $ do
@ -183,41 +182,31 @@ runGhcModT opt action = do
initializeFlagsWithCradle opt (gmCradle env) initializeFlagsWithCradle opt (gmCradle env)
action action
return a return a
runGhcMod' :: GhcModEnv
-> GhcModState
-> GhcModT IO a
-> IO (a,(GhcModState, GhcModWriter))
runGhcMod' = runGhcModT'
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 withErrorHandler label = ghandle ignore
where where
ignore :: SomeException -> GhcMod a ignore :: IOish m => SomeException -> GhcModT m a
ignore e = liftIO $ do ignore e = liftIO $ do
hPutStr stderr $ label ++ ":0:0:Error:" hPutStr stderr $ label ++ ":0:0:Error:"
hPrint stderr e hPrint stderr e
exitSuccess exitSuccess
-- | This is only a transitional mechanism don't use it for new code. -- | 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 toGhcMod a = do
s <- gmGhcSession <$> ask s <- gmGhcSession <$> ask
liftIO $ unGhc a $ Session s liftIO $ unGhc a $ Session s
---------------------------------------------------------------- ----------------------------------------------------------------
options :: GhcMod Options options :: IOish m => GhcModT m Options
options = gmOptions <$> ask options = gmOptions <$> ask
cradle :: GhcMod Cradle cradle :: IOish m => GhcModT m Cradle
cradle = gmCradle <$> ask cradle = gmCradle <$> ask
instance (MonadBaseControl IO m) => MonadBase IO (GhcModT m) where instance (MonadBaseControl IO m) => MonadBase IO (GhcModT m) where
liftBase = GhcModT . liftBase liftBase = GhcModT . liftBase

View File

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

View File

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

View File

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

View File

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

View File

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