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

Merge pull request #301 from DanielG/dev

Browse Source 
Rework GhcModT Monad stack, begin integrating ErrorT and some cleanups
This commit is contained in:
Kazu Yamamoto 2014-08-07 09:18:16 +09:00
commit a61728bc5a
10 changed files with 171 additions and 126 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -18,13 +18,14 @@ import Config (cProjectVersion,cTargetPlatformString)
import Control.Applicative ((<$>))
import Control.Exception (handle, SomeException(..))
import Control.Monad (when, void)
import Control.Monad.Error.Class
import CoreMonad (liftIO)
import Data.Function (on)
import Data.List (groupBy, sort)
import Data.List.Split (splitOn)
import Data.Maybe (fromMaybe)
import DynFlags (DynFlags(..), systemPackageConfig)
import Exception (ghandle, handleIO)
import Exception (handleIO)
import qualified GHC as G
import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Monad
@ -54,6 +55,7 @@ import qualified Data.Map as M
type Symbol = String
-- | Database from 'Symbol' to \['ModuleString'\].
newtype SymbolDb = SymbolDb (Map Symbol [ModuleString])
deriving (Show)
----------------------------------------------------------------
@ -117,61 +119,70 @@ readSymbolDb = handle (\(SomeException _) -> return M.empty) $ do
----------------------------------------------------------------
-- used 'ghc-mod dumpsym'
getPath :: IOish m => GhcModT m (Maybe String)
getPath = do
df <- G.getSessionDynFlags
stack <- cradlePkgDbStack . gmCradle <$> ask
case filter (GlobalDb /=) stack of
[] -> return Nothing
u:_ -> liftIO $ resolvePackageDb df u
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.
-- TODO: Before releaseing add a version number to the name of the cache file
dumpSymbol :: IOish m => GhcModT m String
dumpSymbol = do
mdir <- getPath
ret <- case mdir of
Nothing -> return ""
Just dir -> do
let cache = dir </> symbolCache
pkgdb = dir </> packageCache
ghandle (\(SomeException _) -> return "") $ do
create <- liftIO $ needToCreate cache pkgdb
when create $ do
sm <- getSymbol
void . liftIO $ withFile cache WriteMode $ \hdl ->
mapM (hPrint hdl) sm
return cache
return $ ret ++ "\n"
dir <- getSymbolCachePath
let cache = dir </> symbolCache
pkgdb = dir </> packageCache
needToCreate :: FilePath -> FilePath -> IO Bool
needToCreate file1 file2 = do
exist <- doesFileExist file1
create <- liftIO $ cache `isNewerThan` pkgdb
when create $ (liftIO . writeSymbolCache cache) =<< getSymbolTable
return $ unlines [cache]
writeSymbolCache :: FilePath
-> [(Symbol,[ModuleString])]
-> IO ()
writeSymbolCache cache sm = do
void . withFile cache WriteMode $ \hdl ->
mapM (hPrint hdl) sm
isNewerThan :: FilePath -> FilePath -> IO Bool
isNewerThan ref file = do
exist <- doesFileExist ref
if not exist then
return True
else do
m1 <- getModificationTime file1
m2 <- getModificationTime file2
return $ m1 <= m2 -- including equal just in case
tRef <- getModificationTime ref
tFile <- getModificationTime file
return $ tRef <= tFile -- including equal just in case
-- | Browsing all functions in all system/user modules.
getSymbol :: IOish m => GhcModT m [(Symbol,[ModuleString])]
getSymbol = do
ms <- G.packageDbModules True
let ns = map (G.moduleNameString . G.moduleName) ms
is <- mapM G.getModuleInfo ms
let symbols = concatMap toNameModule (zip is ns)
return $ uniquefy symbols
getSymbolTable :: IOish m => GhcModT m [(Symbol,[ModuleString])]
getSymbolTable = do
ghcModules <- G.packageDbModules True
moduleInfos <- mapM G.getModuleInfo ghcModules
let modules = do
m <- ghcModules
let moduleName = G.moduleNameString $ G.moduleName m
-- modulePkg = G.packageIdString $ G.modulePackageId m
return moduleName
toNameModule :: (Maybe G.ModuleInfo,ModuleString) -> [(Symbol,ModuleString)]
toNameModule (Nothing,_) = []
toNameModule (Just inf,mdlname) = map (\name -> (getOccString name, mdlname)) names
return $ collectModules
$ extractBindings `concatMap` (moduleInfos `zip` modules)
extractBindings :: (Maybe G.ModuleInfo, ModuleString)
-> [(Symbol, ModuleString)]
extractBindings (Nothing,_) = []
extractBindings (Just inf,mdlname) =
map (\name -> (getOccString name, mdlname)) names
where
names = G.modInfoExports inf
uniquefy :: [(Symbol,ModuleString)] -> [(Symbol,[ModuleString])]
uniquefy = map tieup . groupBy ((==) `on` fst) . sort
collectModules :: [(Symbol,ModuleString)]
-> [(Symbol,[ModuleString])]
collectModules = map tieup . groupBy ((==) `on` fst) . sort
where
tieup x = (head (map fst x), map snd x)

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

@ -31,20 +31,18 @@ module Language.Haskell.GhcMod.Internal (
, newGhcModEnv
, GhcModState
, defaultState
, Mode(..)
, GhcModWriter
, CompilerMode(..)
, GhcModLog
-- * Monad utilities
, runGhcMod
, runGhcModT'
, withErrorHandler
-- ** Conversion
, liftGhcMod
, toGhcModT
-- ** Accessing 'GhcModEnv' and 'GhcModState'
, options
, cradle
, getMode
, setMode
, getCompilerMode
, setCompilerMode
, withOptions
-- * 'Ghc' Choice
, (||>)

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

@ -6,34 +6,33 @@
module Language.Haskell.GhcMod.Monad (
-- * Monad Types
GhcMod
, GhcModT
GhcModT
, IOish
-- ** Environment, state and logging
, GhcModEnv(..)
, newGhcModEnv
, GhcModState
, GhcModState(..)
, defaultState
, Mode(..)
, GhcModWriter
, CompilerMode(..)
, GhcModLog
, GhcModError(..)
-- * Monad utilities
, runGhcMod
, runGhcModT
, runGhcModT'
, withErrorHandler
-- ** Conversion
, liftGhcMod
, toGhcModT
-- ** Accessing 'GhcModEnv' and 'GhcModState'
, options
, cradle
, getMode
, setMode
, getCompilerMode
, setCompilerMode
, withOptions
-- ** Exporting convenient modules
, module Control.Monad.Reader.Class
, module Control.Monad.Writer.Class
, module Control.Monad.State.Class
, module Control.Monad.Journal.Class
) where
#if __GLASGOW_HASKELL__ < 708
@ -77,20 +76,27 @@ import Data.Monoid (Monoid)
#endif
import Control.Applicative (Alternative)
import Control.Monad (MonadPlus, liftM, void)
import Control.Arrow (first)
import Control.Monad (MonadPlus, void, liftM)
import Control.Monad.Base (MonadBase, liftBase)
import Control.Monad.Reader.Class
import Control.Monad.State.Class
import Control.Monad.Trans.Class
#if __GLASGOW_HASKELL__ < 708
import Control.Monad.Trans.Maybe
#endif
-- Monad transformer stuff
import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith,
control, liftBaseOp, liftBaseOp_)
import Control.Monad.Trans.RWS.Lazy (RWST(..), runRWST)
import Control.Monad.Trans.Class
import Control.Monad.Reader.Class
import Control.Monad.Writer.Class
import Control.Monad.Error (Error(..), ErrorT(..), MonadError)
import Control.Monad.State.Class
import Control.Monad.Error (Error(..), MonadError, ErrorT, runErrorT)
import Control.Monad.Reader (ReaderT, runReaderT)
import Control.Monad.State.Strict (StateT, runStateT)
import Control.Monad.Trans.Journal (JournalT, runJournalT)
#ifdef MONADIO_INSTANCES
import Control.Monad.Trans.Maybe (MaybeT)
#endif
import Control.Monad.Journal.Class
import Data.Maybe (fromJust, isJust)
import Data.IORef (IORef, readIORef, writeIORef, newIORef)
@ -106,15 +112,17 @@ data GhcModEnv = GhcModEnv {
, gmCradle :: Cradle
}
data GhcModState = GhcModState Mode deriving (Eq,Show,Read)
type GhcModLog = ()
data Mode = Simple | Intelligent deriving (Eq,Show,Read)
data GhcModState = GhcModState {
gmCompilerMode :: CompilerMode
} deriving (Eq,Show,Read)
data CompilerMode = Simple | Intelligent deriving (Eq,Show,Read)
defaultState :: GhcModState
defaultState = GhcModState Simple
type GhcModWriter = ()
data GhcModError = GMENoMsg
| GMEString String
| GMECabal
@ -132,20 +140,22 @@ instance Error GhcModError where
--
-- Basicially an @IOish m => m@ is a 'Monad' supporting arbitrary 'IO' and
-- exception handling. Usually this will simply be 'IO' but we parametrise it in
-- the exported API so users have the option to use a custom underlying monad.
-- the exported API so users have the option to use a custom inner monad.
type IOish m = (Functor m, MonadIO m, MonadBaseControl IO m)
type GhcMod a = GhcModT (ErrorT GhcModError IO) a
-- | The GhcMod monad transformer data type. This is basically a wrapper around
-- RWST with custom instances for 'GhcMonad' and it's constraints.
-- | The GhcMod monad transformer data type. This is basically a newtype wrapper
-- around 'StateT', 'ErrorT', 'JournalT' and 'ReaderT' with custom instances for
-- 'GhcMonad' and it's constraints.
--
-- The inner monad should have instances for 'MonadIO' and 'MonadBaseControl'
-- 'IO'. Most @mtl@ monads already have 'MonadBaseControl' 'IO' instances, see
-- the @monad-control@ package.
newtype GhcModT m a = GhcModT {
unGhcModT :: RWST GhcModEnv GhcModWriter GhcModState m a
} deriving (Functor
unGhcModT :: StateT GhcModState
(ErrorT GhcModError
(JournalT GhcModLog
(ReaderT GhcModEnv m) ) ) a
} deriving ( Functor
, Applicative
, Alternative
, Monad
@ -155,23 +165,29 @@ newtype GhcModT m a = GhcModT {
, Control.Monad.IO.Class.MonadIO
#endif
, MonadReader GhcModEnv
, MonadWriter GhcModWriter
, MonadWriter w
, MonadState GhcModState
, MonadTrans
, MonadError GhcModError
)
deriving instance MonadError GhcModError m => MonadError GhcModError (GhcModT m)
instance MonadTrans GhcModT where
lift = GhcModT . lift . lift . lift . lift
#if MONADIO_INSTANCES
instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where
instance MonadIO m => MonadIO (StateT s m) where
liftIO = lift . liftIO
instance MonadIO m => MonadIO (ReaderT r m) where
liftIO = lift . liftIO
instance (Monoid w, MonadIO m) => MonadIO (JournalT w m) where
liftIO = lift . liftIO
instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where
liftIO = lift . liftIO
instance (MonadIO m) => MonadIO (MaybeT m) where
instance MonadIO m => MonadIO (MaybeT m) where
liftIO = lift . liftIO
#endif
----------------------------------------------------------------
@ -231,18 +247,18 @@ newGhcModEnv opt dir = do
, gmCradle = c
}
-- | 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
-- | Run a @GhcModT m@ computation.
runGhcModT :: IOish m
=> Options
-> GhcModT m a
-> m (Either GhcModError a, GhcModLog)
runGhcModT opt action = do
env <- liftBase $ newGhcModEnv opt =<< getCurrentDirectory
(a,(_,_)) <- runGhcModT' env defaultState $ do
first (fmap fst) <$> (runGhcModT' env defaultState $ do
dflags <- getSessionDynFlags
defaultCleanupHandler dflags $ do
initializeFlagsWithCradle opt (gmCradle env)
action
return a
action)
-- | 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
@ -253,28 +269,12 @@ runGhcModT' :: IOish m
=> GhcModEnv
-> GhcModState
-> GhcModT m a
-> m (a,(GhcModState, GhcModWriter))
-> m (Either GhcModError (a, GhcModState), GhcModLog)
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
(res, w') <-
flip runReaderT r $ runJournalT $ runErrorT $ flip runStateT s
$ (unGhcModT $ initGhcMonad (Just libdir) >> a)
return $ (res, w')
----------------------------------------------------------------
withErrorHandler :: IOish m => String -> GhcModT m a -> GhcModT m a
@ -300,13 +300,11 @@ options = gmOptions <$> ask
cradle :: IOish m => GhcModT m Cradle
cradle = gmCradle <$> ask
getMode :: IOish m => GhcModT m Mode
getMode = do
GhcModState mode <- get
return mode
getCompilerMode :: (Functor m, MonadState GhcModState m) => m CompilerMode
getCompilerMode = gmCompilerMode <$> get
setMode :: IOish m => Mode -> GhcModT m ()
setMode mode = put $ GhcModState mode
setCompilerMode :: MonadState GhcModState m => CompilerMode -> m ()
setCompilerMode mode = (\s -> put s { gmCompilerMode = mode } ) =<< get
----------------------------------------------------------------
@ -324,8 +322,10 @@ instance (MonadBaseControl IO m) => MonadBase IO (GhcModT m) where
instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where
newtype StM (GhcModT m) a = StGhcMod {
unStGhcMod :: StM (RWST GhcModEnv GhcModWriter GhcModState m) a }
unStGhcMod :: StM (StateT GhcModState
(ErrorT GhcModError
(JournalT GhcModLog
(ReaderT GhcModEnv m) ) ) ) a }
liftBaseWith f = GhcModT . liftBaseWith $ \runInBase ->
f $ liftM StGhcMod . runInBase . unGhcModT

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

@ -15,7 +15,7 @@ setTargetFiles :: IOish m => [FilePath] -> GhcModT m ()
setTargetFiles files = do
targets <- forM files $ \file -> G.guessTarget file Nothing
G.setTargets targets
mode <- getMode
mode <- gmCompilerMode <$> get
if mode == Intelligent then
loadTargets Intelligent
else do
@ -47,7 +47,7 @@ setTargetFiles files = do
setIntelligent = do
newdf <- setModeIntelligent <$> G.getSessionDynFlags
void $ G.setSessionDynFlags newdf
setMode Intelligent
setCompilerMode Intelligent
needsFallback :: G.ModuleGraph -> Bool
needsFallback = any (hasTHorQQ . G.ms_hspp_opts)

3
ghc-mod.cabal
View File

@ -96,6 +96,7 @@ Library
, ghc-syb-utils
, hlint >= 1.8.61
, io-choice
, monad-journal >= 0.2.2.0
, old-time
, process
, syb
@ -168,6 +169,7 @@ Test-Suite spec
LangSpec
LintSpec
ListSpec
MonadSpec
GhcPkgSpec
TestUtils
Build-Depends: base >= 4.0 && < 5
@ -180,6 +182,7 @@ Test-Suite spec
, ghc-syb-utils
, hlint >= 1.7.1
, io-choice
, monad-journal >= 0.2.2.0
, old-time
, process
, syb

6
src/GHCMod.hs
View File

@ -113,7 +113,7 @@ main = flip E.catches handlers $ do
nArgs n f = if length remainingArgs == n
then f
else E.throw (ArgumentsMismatch cmdArg0)
res <- runGhcModT opt $ case cmdArg0 of
(res, _) <- runGhcModT opt $ case cmdArg0 of
"list" -> modules
"lang" -> languages
"flag" -> flags
@ -136,7 +136,9 @@ main = flip E.catches handlers $ do
"version" -> return progVersion
"help" -> return $ O.usageInfo usage argspec
cmd -> E.throw (NoSuchCommand cmd)
putStr res
case res of
Right s -> putStr s
Left e -> error $ show e
where
handlers = [Handler (handleThenExit handler1), Handler (handleThenExit handler2)]
handleThenExit handler e = handler e >> exitFailure

6
src/GHCModi.hs
View File

@ -98,7 +98,11 @@ main = E.handle cmdHandler $
setCurrentDirectory rootdir
mvar <- liftIO newEmptyMVar
void $ forkIO $ setupDB mvar
runGhcModT opt $ loop S.empty mvar
(res, _) <- runGhcModT opt $ loop S.empty mvar
case res of
Right () -> return ()
Left e -> error $ show e
where
-- this is just in case.
-- If an error is caught here, it is a bug of GhcMod library.

2
test/Main.hs
View File

@ -21,7 +21,7 @@ main = do
genGhcPkgCache dir = system $ "ghc-pkg recache --force -f" ++ dir
genSandboxCfg `mapM_` sandboxes
genGhcPkgCache `mapM_` pkgDirs
system "find test -name setup-config -exec rm {} \\;"
system "find test -name setup-config -name ghc-mod.cache -exec rm {} \\;"
system "cabal --version"
putStrLn $ "ghc-mod was built with Cabal version " ++ VERSION_Cabal
system "ghc --version"

19
test/MonadSpec.hs Normal file
View File

@ -0,0 +1,19 @@
module MonadSpec where
import Test.Hspec
import Control.Monad.Error.Class
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Find
spec :: Spec
spec = do
describe "When using GhcModT in a do block" $
it "a pattern match failure causes a call to `fail` on ErrorT in the monad stack" $ do
(a, w)
<- runGhcModT defaultOptions $
do
Just a <- return Nothing
return "hello"
`catchError` (const $ fail "oh noes")
a `shouldBe` (Left $ GMEString "oh noes")

14
test/TestUtils.hs
View File

@ -12,14 +12,22 @@ module TestUtils (
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Types
import Control.Applicative
isolateCradle :: IOish m => GhcModT m a -> GhcModT m a
isolateCradle action =
local modifyEnv $ action
where
modifyEnv e = e { gmCradle = (gmCradle e) { cradlePkgDbStack = [GlobalDb] } }
extract :: IO (Either e a, w) -> IO a
extract action = do
(Right a, _) <- action
return a
runIsolatedGhcMod :: Options -> GhcModT IO a -> IO a
runIsolatedGhcMod opt action = runGhcModT opt $ isolateCradle action
runIsolatedGhcMod opt action = do
extract $ runGhcModT opt $ isolateCradle action
-- | Run GhcMod in isolated cradle with default options
runID = runIsolatedGhcMod defaultOptions
@ -29,8 +37,8 @@ runI = runIsolatedGhcMod
-- | Run GhcMod
run :: Options -> GhcModT IO a -> IO a
run = runGhcModT
run opt a = extract $ runGhcModT opt a
-- | Run GhcMod with default options
runD :: GhcModT IO a -> IO a
runD = runGhcModT defaultOptions
runD = extract . runGhcModT defaultOptions