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
-- | 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]

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

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

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

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

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

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

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)

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-"]

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

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

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)

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)

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

View File

@ -4,13 +4,11 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Haskell.GhcMod.Monad (
GhcMod
, GhcModT
GhcModT
, IOish
, GhcModEnv(..)
, GhcModWriter
, GhcModState(..)
, runGhcMod'
, runGhcMod
, runGhcModT'
, runGhcModT
, newGhcModEnv
@ -60,7 +58,8 @@ import Control.Monad.Base (MonadBase, liftBase)
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.Control (MonadBaseControl(..), StM, liftBaseWith,
control, liftBaseOp, liftBaseOp_)
import Control.Monad.Trans.RWS.Lazy (RWST(..), runRWST)
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 {
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
-> GhcModState
-> GhcModT m a
@ -174,7 +173,7 @@ newGhcModEnv opt dir = do
, 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
env <- liftBase $ newGhcModEnv opt =<< getCurrentDirectory
(a,(_,_)) <- runGhcModT' env defaultState $ do
@ -183,41 +182,31 @@ runGhcModT opt action = do
initializeFlagsWithCradle opt (gmCradle env)
action
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
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

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

View File

@ -51,6 +51,7 @@ Extra-Source-Files: ChangeLog
Library
Default-Language: Haskell2010
GHC-Options: -Wall
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
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
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
Extensions: ConstraintKinds, FlexibleContexts
Main-Is: doctests.hs
Build-Depends: base
, doctest >= 0.9.3
Test-Suite spec
Default-Language: Haskell2010
Extensions: ConstraintKinds, FlexibleContexts
Main-Is: Main.hs
Hs-Source-Dirs: test, .
Type: exitcode-stdio-1.0

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

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)

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