ghc-mod/test/TestUtils.hs

131 lines
3.6 KiB
Haskell
Raw Normal View History

2015-03-04 20:48:21 +00:00
{-# OPTIONS_GHC -fno-warn-orphans #-}
2014-05-10 13:10:34 +00:00
module TestUtils (
run
, runD
2014-08-12 16:11:32 +00:00
, runD'
2015-03-04 20:48:21 +00:00
, runE
, runNullLog
, runGmOutDef
2014-08-12 16:11:32 +00:00
, shouldReturnError
2015-02-07 15:41:15 +00:00
, isPkgDbAt
, isPkgConfDAt
2014-05-10 13:10:34 +00:00
, module Language.Haskell.GhcMod.Monad
, module Language.Haskell.GhcMod.Types
) where
2015-03-04 20:48:21 +00:00
import Language.Haskell.GhcMod.Logging
2014-05-10 13:10:34 +00:00
import Language.Haskell.GhcMod.Monad
2015-03-04 20:48:21 +00:00
import Language.Haskell.GhcMod.Cradle
2014-05-10 13:10:34 +00:00
import Language.Haskell.GhcMod.Types
2015-03-04 20:48:21 +00:00
import Control.Arrow
2015-08-31 06:01:20 +00:00
import Control.Category
2015-03-04 20:48:21 +00:00
import Control.Applicative
import Control.Monad.Error (ErrorT, runErrorT)
import Control.Monad.Trans.Journal
2015-02-07 15:41:15 +00:00
import Data.List.Split
2015-08-31 06:01:20 +00:00
import Data.Label
2015-03-04 20:48:21 +00:00
import Data.String
2015-02-07 15:41:15 +00:00
import System.FilePath
2015-03-04 20:48:21 +00:00
import System.Directory
2014-08-12 16:11:32 +00:00
import Test.Hspec
2015-08-31 06:01:20 +00:00
import Prelude hiding ((.))
2014-08-12 16:11:32 +00:00
2015-03-04 20:48:21 +00:00
import Exception
testLogLevel :: GmLogLevel
2015-03-06 13:04:49 +00:00
testLogLevel = GmDebug
2014-05-10 13:10:34 +00:00
2014-08-21 05:16:56 +00:00
extract :: Show e => IO (Either e a, w) -> IO a
2014-07-22 17:45:48 +00:00
extract action = do
2014-08-21 05:16:56 +00:00
(r,_) <- action
case r of
Right a -> return a
Left e -> error $ show e
2014-07-22 17:45:48 +00:00
2015-09-14 03:59:01 +00:00
withSpecCradle :: (IOish m, GmOut m) => FilePath -> (Cradle -> m a) -> m a
2015-09-14 08:11:33 +00:00
withSpecCradle cradledir f = do
gbracket (findSpecCradle cradledir) (liftIO . cleanupCradle) $ \crdl ->
bracketWorkingDirectory (cradleRootDir crdl) $
f crdl
bracketWorkingDirectory ::
(ExceptionMonad m, MonadIO m) => FilePath -> m c -> m c
bracketWorkingDirectory dir a =
gbracket (swapWorkingDirectory dir) (liftIO . setCurrentDirectory) (const a)
swapWorkingDirectory :: MonadIO m => FilePath -> m FilePath
swapWorkingDirectory ndir = liftIO $ do
odir <- getCurrentDirectory >>= canonicalizePath
setCurrentDirectory $ ndir
return odir
2014-05-10 13:10:34 +00:00
2015-03-04 20:48:21 +00:00
runGhcModTSpec :: Options -> GhcModT IO a -> IO (Either GhcModError a, GhcModLog)
runGhcModTSpec opt action = do
dir <- getCurrentDirectory
runGhcModTSpec' dir opt action
2014-05-10 13:10:34 +00:00
2015-03-04 20:48:21 +00:00
runGhcModTSpec' :: IOish m
=> FilePath -> Options -> GhcModT m b -> m (Either GhcModError b, GhcModLog)
runGhcModTSpec' dir opt action = liftIO (canonicalizePath dir) >>= \dir' -> do
2015-09-14 08:11:33 +00:00
runGmOutT opt $
withGhcModEnv' withSpecCradle dir' opt $ \env -> do
first (fst <$>) <$> runGhcModT' env defaultGhcModState
(gmSetLogLevel (ooptLogLevel $ optOutput opt) >> action)
2014-05-10 13:10:34 +00:00
-- | Run GhcMod
run :: Options -> GhcModT IO a -> IO a
2015-03-04 20:48:21 +00:00
run opt a = extract $ runGhcModTSpec opt a
2014-05-10 13:10:34 +00:00
-- | Run GhcMod with default options
runD :: GhcModT IO a -> IO a
2015-03-04 20:48:21 +00:00
runD =
2015-08-31 06:01:20 +00:00
extract . runGhcModTSpec (setLogLevel testLogLevel defaultOptions)
2014-08-12 16:11:32 +00:00
2015-03-04 20:48:21 +00:00
runD' :: FilePath -> GhcModT IO a -> IO a
runD' dir =
2015-08-31 06:01:20 +00:00
extract . runGhcModTSpec' dir (setLogLevel testLogLevel defaultOptions)
setLogLevel :: GmLogLevel -> Options -> Options
setLogLevel = set (lOoptLogLevel . lOptOutput)
2015-03-04 20:48:21 +00:00
runE :: ErrorT e IO a -> IO (Either e a)
runE = runErrorT
runNullLog :: MonadIO m => JournalT GhcModLog m a -> m a
runNullLog action = do
(a,w) <- runJournalT action
2015-05-06 14:13:08 +00:00
liftIO $ print w
2015-03-04 20:48:21 +00:00
return a
2014-08-12 16:11:32 +00:00
runGmOutDef :: IOish m => GmOutT m a -> m a
2015-09-14 08:11:33 +00:00
runGmOutDef = runGmOutT defaultOptions
2014-08-12 16:11:32 +00:00
shouldReturnError :: Show a
=> IO (Either GhcModError a, GhcModLog)
-> Expectation
shouldReturnError action = do
(a,_) <- action
a `shouldSatisfy` isLeft
where
isLeft (Left _) = True
isLeft _ = False
2015-02-07 15:41:15 +00:00
isPkgConfD :: FilePath -> Bool
isPkgConfD d = let
(_dir, pkgconfd) = splitFileName d
in case splitOn "-" pkgconfd of
[_arch, _platform, _compiler, _compver, "packages.conf.d"] -> True
_ -> False
isPkgConfDAt :: FilePath -> FilePath -> Bool
isPkgConfDAt d d' | d == takeDirectory d' && isPkgConfD d' = True
isPkgConfDAt _ _ = False
isPkgDbAt :: FilePath -> GhcPkgDb -> Bool
isPkgDbAt d (PackageDb dir) = isPkgConfDAt d dir
isPkgDbAt _ _ = False
2015-03-04 20:48:21 +00:00
instance IsString ModuleName where
fromString = mkModuleName