Merge pull request #314 from DanielG/dev

Make GhcModT's MonadState instance pass through and other release-prep

Language/Haskell/GhcMod.hs

@@ -18,6 +18,7 @@ module Language.Haskell.GhcMod (
   -- * Monad Types
   , GhcModT
   , IOish
+  , GhcModError(..)
   -- * Monad utilities
   , runGhcModT
   , withOptions

Language/Haskell/GhcMod/CabalApi.hs

@@ -11,14 +11,16 @@ module Language.Haskell.GhcMod.CabalApi (
   ) where
 
 import Language.Haskell.GhcMod.CabalConfig
-import Language.Haskell.GhcMod.Gap (benchmarkBuildInfo, benchmarkTargets, toModuleString)
+import Language.Haskell.GhcMod.Gap (benchmarkBuildInfo, benchmarkTargets,
+                                    toModuleString)
 import Language.Haskell.GhcMod.GhcPkg
 import Language.Haskell.GhcMod.Types
 
+import MonadUtils (MonadIO, liftIO)
 import Control.Applicative ((<$>))
 import qualified Control.Exception as E
 import Control.Monad (filterM)
-import CoreMonad (liftIO)
+import Control.Monad.Error.Class (Error, MonadError(..))
 import Data.Maybe (maybeToList)
 import Data.Set (fromList, toList)
 import Distribution.Package (Dependency(Dependency)
@@ -69,19 +71,21 @@ includeDirectories cdir wdir dirs = uniqueAndSort (extdirs ++ [cdir,wdir])
 
 ----------------------------------------------------------------
 
--- | Parsing a cabal file and returns 'PackageDescription'.
---   'IOException' is thrown if parsing fails.
-parseCabalFile :: FilePath -> IO PackageDescription
+-- | Parse a cabal file and return a 'PackageDescription'.
+parseCabalFile :: (MonadIO m, Error e,  MonadError e m)
+               => FilePath
+               -> m PackageDescription
 parseCabalFile file = do
-    cid <- getGHCId
-    epgd <- readPackageDescription silent file
+    cid <- liftIO $ getGHCId
+    epgd <- liftIO $ readPackageDescription silent file
     case toPkgDesc cid epgd of
-        Left deps    -> E.throwIO $ userError $ show deps ++ " are not installed"
+        Left deps    -> fail $ show deps ++ " are not installed"
         Right (pd,_) -> if nullPkg pd
-                        then E.throwIO $ userError $ file ++ " is broken"
+                        then fail $ file ++ " is broken"
                         else return pd
   where
-    toPkgDesc cid = finalizePackageDescription [] (const True) buildPlatform cid []
+    toPkgDesc cid =
+        finalizePackageDescription [] (const True) buildPlatform cid []
     nullPkg pd = name == ""
       where
         PackageName name = C.pkgName (P.package pd)

Language/Haskell/GhcMod/Debug.hs

@@ -31,9 +31,9 @@ debugInfo = cradle >>= \c -> convert' =<< do
   where
     simpleCompilerOption = options >>= \op ->
         return $ CompilerOptions (ghcOpts op) [] []
-    fromCabalFile c = options >>= \opts -> liftIO $ do
+    fromCabalFile c = options >>= \opts -> do
         pkgDesc <- parseCabalFile $ fromJust $ cradleCabalFile c
-        getCompilerOptions (ghcOpts opts) c pkgDesc
+        liftIO $ getCompilerOptions (ghcOpts opts) c pkgDesc
 
 ----------------------------------------------------------------
 

Language/Haskell/GhcMod/Find.hs

@@ -59,8 +59,13 @@ newtype SymbolDb = SymbolDb (Map Symbol [ModuleString])
 
 ----------------------------------------------------------------
 
+-- | When introducing incompatible changes to the 'symbolCache' file format
+-- increment this version number.
+symbolCacheVersion = 0
+
+-- | Filename of the symbol table cache file.
 symbolCache :: String
-symbolCache = "ghc-mod.cache"
+symbolCache = "ghc-mod-"++ show symbolCacheVersion ++".cache"
 
 packageCache :: String
 packageCache = "package.cache"
@@ -89,6 +94,8 @@ lookupSym sym (SymbolDb db) = fromMaybe [] $ M.lookup sym db
 loadSymbolDb :: IO SymbolDb
 loadSymbolDb = SymbolDb <$> readSymbolDb
 
+-- | Returns the path to the currently running ghc-mod executable. With ghc<7.6
+-- this is a guess but >=7.6 uses 'getExecutablePath'.
 ghcModExecutable :: IO FilePath
 #ifndef SPEC
 ghcModExecutable = do
@@ -130,7 +137,6 @@ getSymbolCachePath = do
 --   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
     dir <- getSymbolCachePath

Language/Haskell/GhcMod/Monad.hs

@@ -23,6 +23,8 @@ module Language.Haskell.GhcMod.Monad (
   -- ** Conversion
   , toGhcModT
   -- ** Accessing 'GhcModEnv' and 'GhcModState'
+  , gmsGet
+  , gmsPut
   , options
   , cradle
   , getCompilerMode
@@ -30,8 +32,6 @@ module Language.Haskell.GhcMod.Monad (
   , 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
 
@@ -85,15 +85,16 @@ import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith,
 
 import Control.Monad.Trans.Class
 import Control.Monad.Reader.Class
-import Control.Monad.Writer.Class
-import Control.Monad.State.Class
+import Control.Monad.Writer.Class (MonadWriter)
+import Control.Monad.State.Class (MonadState(..))
 
-import Control.Monad.Error (Error(..), MonadError, ErrorT, runErrorT)
+import Control.Monad.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)
+import Control.Monad.Error (Error(..))
 #endif
 import Control.Monad.Journal.Class
 
@@ -122,16 +123,6 @@ data CompilerMode = Simple | Intelligent deriving (Eq,Show,Read)
 defaultState :: GhcModState
 defaultState = GhcModState Simple
 
-data GhcModError = GMENoMsg
-                 | GMEString String
-                 | GMECabal
-                 | GMEGhc
-                   deriving (Eq,Show,Read)
-
-instance Error GhcModError where
-    noMsg = GMENoMsg
-    strMsg = GMEString
-
 ----------------------------------------------------------------
 
 -- | A constraint alias (-XConstraintKinds) to make functions dealing with
@@ -163,15 +154,21 @@ newtype GhcModT m a = GhcModT {
 #if DIFFERENT_MONADIO
                , Control.Monad.IO.Class.MonadIO
 #endif
-               , MonadReader GhcModEnv
+               , MonadReader GhcModEnv -- TODO: make MonadReader instance
+                                       -- pass-through like MonadState
                , MonadWriter w
-               , MonadState GhcModState
                , MonadError GhcModError
                )
 
 instance MonadTrans GhcModT where
     lift = GhcModT . lift . lift . lift . lift
 
+instance MonadState s m => MonadState s (GhcModT m) where
+    get = GhcModT $ lift $ lift $ lift $ get
+    put = GhcModT . lift . lift . lift . put
+    state = GhcModT . lift . lift . lift . state
+
+
 #if MONADIO_INSTANCES
 instance MonadIO m => MonadIO (StateT s m) where
     liftIO = lift . liftIO
@@ -194,7 +191,7 @@ instance MonadIO m => MonadIO (MaybeT m) where
 -- | Initialize the 'DynFlags' relating to the compilation of a single
 -- file or GHC session according to the 'Cradle' and 'Options'
 -- provided.
-initializeFlagsWithCradle :: GhcMonad m
+initializeFlagsWithCradle :: (GhcMonad m, MonadError GhcModError m)
         => Options
         -> Cradle
         -> m ()
@@ -206,7 +203,7 @@ initializeFlagsWithCradle opt c
     cabal = isJust mCradleFile
     ghcopts = ghcOpts opt
     withCabal = do
-        pkgDesc <- liftIO $ parseCabalFile $ fromJust mCradleFile
+        pkgDesc <- parseCabalFile $ fromJust mCradleFile
         compOpts <- liftIO $ getCompilerOptions ghcopts c pkgDesc
         initSession CabalPkg opt compOpts
     withSandbox = initSession SingleFile opt compOpts
@@ -293,17 +290,23 @@ toGhcModT a = do
 
 ----------------------------------------------------------------
 
+gmsGet :: IOish m => GhcModT m GhcModState
+gmsGet = GhcModT get
+
+gmsPut :: IOish m => GhcModState -> GhcModT m ()
+gmsPut = GhcModT . put
+
 options :: IOish m => GhcModT m Options
 options = gmOptions <$> ask
 
 cradle :: IOish m => GhcModT m Cradle
 cradle = gmCradle <$> ask
 
-getCompilerMode :: (Functor m, MonadState GhcModState m) => m CompilerMode
-getCompilerMode = gmCompilerMode <$> get
+getCompilerMode :: IOish m => GhcModT m CompilerMode
+getCompilerMode = gmCompilerMode <$> gmsGet
 
-setCompilerMode :: MonadState GhcModState m => CompilerMode -> m ()
-setCompilerMode mode = (\s -> put s { gmCompilerMode = mode } ) =<< get
+setCompilerMode :: IOish m => CompilerMode -> GhcModT m ()
+setCompilerMode mode = (\s -> gmsPut s { gmCompilerMode = mode } ) =<< gmsGet
 
 ----------------------------------------------------------------
 

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 <- gmCompilerMode <$> get
+    mode <- getCompilerMode
     if mode == Intelligent then
         loadTargets Intelligent
       else do

Language/Haskell/GhcMod/Types.hs

@@ -2,9 +2,22 @@ module Language.Haskell.GhcMod.Types where
 
 import Data.List (intercalate)
 import qualified Data.Map as M
+import Control.Monad.Error (Error(..))
 
 import PackageConfig (PackageConfig)
 
+-- |
+data GhcModError = GMENoMsg
+                 -- ^ Unknown error
+                 | GMEString String
+                 -- ^ Some Error with a message. These are produced mostly by
+                 -- 'fail' calls on GhcModT.
+                   deriving (Eq,Show,Read)
+
+instance Error GhcModError where
+    noMsg = GMENoMsg
+    strMsg = GMEString
+
 -- | Output style.
 data OutputStyle = LispStyle  -- ^ S expression style.
                  | PlainStyle -- ^ Plain textstyle.

test/CabalApiSpec.hs

@@ -13,6 +13,7 @@ import System.Directory
 import System.FilePath
 
 import Dir
+import TestUtils
 
 import Config (cProjectVersionInt) -- ghc version
 
@@ -23,14 +24,16 @@ spec :: Spec
 spec = do
     describe "parseCabalFile" $ do
         it "throws an exception if the cabal file is broken" $ do
-            parseCabalFile "test/data/broken-cabal/broken.cabal" `shouldThrow` (\(_::IOException) -> True)
+            shouldReturnError $
+              runD' $ parseCabalFile "test/data/broken-cabal/broken.cabal"
+
 
     describe "getCompilerOptions" $ do
         it "gets necessary CompilerOptions" $ do
             cwd <- getCurrentDirectory
             withDirectory "test/data/subdir1/subdir2" $ \dir -> do
                 cradle <- findCradle
-                pkgDesc <- parseCabalFile $ fromJust $ cradleCabalFile cradle
+                pkgDesc <- runD $ parseCabalFile $ fromJust $ cradleCabalFile cradle
                 res <- getCompilerOptions [] cradle pkgDesc
                 let res' = res {
                         ghcOptions  = ghcOptions res
@@ -45,18 +48,18 @@ spec = do
 
     describe "cabalDependPackages" $ do
         it "extracts dependent packages" $ do
-            pkgs <- cabalDependPackages . cabalAllBuildInfo <$> parseCabalFile "test/data/cabalapi.cabal"
+            pkgs <- cabalDependPackages . cabalAllBuildInfo <$> runD (parseCabalFile "test/data/cabalapi.cabal")
             pkgs `shouldBe` ["Cabal","base","template-haskell"]
 
     describe "cabalSourceDirs" $ do
         it "extracts all hs-source-dirs" $ do
-            dirs <- cabalSourceDirs . cabalAllBuildInfo <$> parseCabalFile "test/data/check-test-subdir/check-test-subdir.cabal"
+            dirs <- cabalSourceDirs . cabalAllBuildInfo <$> runD (parseCabalFile "test/data/check-test-subdir/check-test-subdir.cabal")
             dirs `shouldBe` ["src", "test"]
         it "extracts all hs-source-dirs including \".\"" $ do
-            dirs <- cabalSourceDirs . cabalAllBuildInfo <$> parseCabalFile "test/data/cabalapi.cabal"
+            dirs <- cabalSourceDirs . cabalAllBuildInfo <$> runD (parseCabalFile "test/data/cabalapi.cabal")
             dirs `shouldBe` [".", "test"]
 
     describe "cabalAllBuildInfo" $ do
         it "extracts build info" $ do
-            info <- cabalAllBuildInfo <$> parseCabalFile "test/data/cabalapi.cabal"
+            info <- cabalAllBuildInfo <$> runD (parseCabalFile "test/data/cabalapi.cabal")
             show info `shouldBe` "[BuildInfo {buildable = True, buildTools = [], cppOptions = [], ccOptions = [], ldOptions = [], pkgconfigDepends = [], frameworks = [], cSources = [], hsSourceDirs = [\".\"], otherModules = [ModuleName [\"Browse\"],ModuleName [\"CabalApi\"],ModuleName [\"Cabal\"],ModuleName [\"CabalDev\"],ModuleName [\"Check\"],ModuleName [\"ErrMsg\"],ModuleName [\"Flag\"],ModuleName [\"GHCApi\"],ModuleName [\"GHCChoice\"],ModuleName [\"Gap\"],ModuleName [\"Info\"],ModuleName [\"Lang\"],ModuleName [\"Lint\"],ModuleName [\"List\"],ModuleName [\"Paths_ghc_mod\"],ModuleName [\"Types\"]], defaultLanguage = Nothing, otherLanguages = [], defaultExtensions = [], otherExtensions = [], oldExtensions = [], extraLibs = [], extraLibDirs = [], includeDirs = [], includes = [], installIncludes = [], options = [(GHC,[\"-Wall\"])], ghcProfOptions = [], ghcSharedOptions = [], customFieldsBI = [], targetBuildDepends = [Dependency (PackageName \"Cabal\") (UnionVersionRanges (ThisVersion (Version {versionBranch = [1,10], versionTags = []})) (LaterVersion (Version {versionBranch = [1,10], versionTags = []}))),Dependency (PackageName \"base\") (IntersectVersionRanges (UnionVersionRanges (ThisVersion (Version {versionBranch = [4,0], versionTags = []})) (LaterVersion (Version {versionBranch = [4,0], versionTags = []}))) (EarlierVersion (Version {versionBranch = [5], versionTags = []}))),Dependency (PackageName \"template-haskell\") AnyVersion]},BuildInfo {buildable = True, buildTools = [], cppOptions = [], ccOptions = [], ldOptions = [], pkgconfigDepends = [], frameworks = [], cSources = [], hsSourceDirs = [\"test\",\".\"], otherModules = [ModuleName [\"Expectation\"],ModuleName [\"BrowseSpec\"],ModuleName [\"CabalApiSpec\"],ModuleName [\"FlagSpec\"],ModuleName [\"LangSpec\"],ModuleName [\"LintSpec\"],ModuleName [\"ListSpec\"]], defaultLanguage = Nothing, otherLanguages = [], defaultExtensions = [], otherExtensions = [], oldExtensions = [], extraLibs = [], extraLibDirs = [], includeDirs = [], includes = [], installIncludes = [], options = [], ghcProfOptions = [], ghcSharedOptions = [], customFieldsBI = [], targetBuildDepends = [Dependency (PackageName \"Cabal\") (UnionVersionRanges (ThisVersion (Version {versionBranch = [1,10], versionTags = []})) (LaterVersion (Version {versionBranch = [1,10], versionTags = []}))),Dependency (PackageName \"base\") (IntersectVersionRanges (UnionVersionRanges (ThisVersion (Version {versionBranch = [4,0], versionTags = []})) (LaterVersion (Version {versionBranch = [4,0], versionTags = []}))) (EarlierVersion (Version {versionBranch = [5], versionTags = []})))]}]"

test/Main.hs

@@ -11,7 +11,9 @@ import TestUtils
 
 main = do
   let sandboxes = [ "test/data", "test/data/check-packageid"
-                  , "test/data/duplicate-pkgver/" ]
+                  , "test/data/duplicate-pkgver/"
+                  , "test/data/broken-cabal/"
+                  ]
       genSandboxCfg dir = withDirectory dir $ \cwd -> do
          system ("sed 's|@CWD@|" ++ cwd ++ "|g' cabal.sandbox.config.in > cabal.sandbox.config")
       pkgDirs =

test/MonadSpec.hs

@@ -3,6 +3,7 @@ module MonadSpec where
 
 import Test.Hspec
 import Dir
+import TestUtils
 import Control.Applicative
 import Control.Monad.Error.Class
 import Language.Haskell.GhcMod.Types
@@ -23,5 +24,9 @@ spec = do
 
     describe "runGhcModT" $
         it "complains if the cabal file fails to parse while a sandbox is present" $ withDirectory_ "test/data/broken-cabal" $ do
-          (a,_) <- runGhcModT defaultOptions (gmCradle <$> ask)
-          a `shouldSatisfy` (\(Left _) -> True)
+          shouldReturnError $ runD' (gmCradle <$> ask)
+
+    describe "gmsGet/Put" $
+        it "work" $ do
+          (runD $ gmsPut (GhcModState Intelligent) >> gmsGet)
+            `shouldReturn` (GhcModState Intelligent)

test/TestUtils.hs

@@ -1,10 +1,12 @@
 module TestUtils (
     run
   , runD
+  , runD'
   , runI
   , runID
   , runIsolatedGhcMod
   , isolateCradle
+  , shouldReturnError
   , module Language.Haskell.GhcMod.Monad
   , module Language.Haskell.GhcMod.Types
   ) where
@@ -12,6 +14,8 @@ module TestUtils (
 import Language.Haskell.GhcMod.Monad
 import Language.Haskell.GhcMod.Types
 
+import Test.Hspec
+
 isolateCradle :: IOish m => GhcModT m a -> GhcModT m a
 isolateCradle action =
     local modifyEnv  $ action
@@ -42,3 +46,16 @@ run opt a = extract $ runGhcModT opt a
 -- | Run GhcMod with default options
 runD :: GhcModT IO a -> IO a
 runD = extract . runGhcModT defaultOptions
+
+runD' :: GhcModT IO a -> IO (Either GhcModError a, GhcModLog)
+runD' = runGhcModT defaultOptions
+
+shouldReturnError :: Show a
+                  => IO (Either GhcModError a, GhcModLog)
+                  -> Expectation
+shouldReturnError action = do
+  (a,_) <- action
+  a `shouldSatisfy` isLeft
+ where
+   isLeft (Left _) = True
+   isLeft _ = False