Merge pull request #301 from DanielG/dev

Rework GhcModT Monad stack, begin integrating ErrorT and some cleanups

Language/Haskell/GhcMod/Find.hs

@@ -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)
 

Language/Haskell/GhcMod/Internal.hs

@@ -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
   , (||>)

Language/Haskell/GhcMod/Monad.hs

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

Language/Haskell/GhcMod/Target.hs

@@ -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)

ghc-mod.cabal

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

src/GHCMod.hs

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

src/GHCModi.hs

@@ -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.

test/Main.hs

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

test/MonadSpec.hs

@@ -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")

test/TestUtils.hs

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