diff --git a/Language/Haskell/GhcMod.hs b/Language/Haskell/GhcMod.hs index 46acf71..44d78f8 100644 --- a/Language/Haskell/GhcMod.hs +++ b/Language/Haskell/GhcMod.hs @@ -44,6 +44,7 @@ module Language.Haskell.GhcMod ( , pkgDoc , rootInfo , types + , test , splits , sig , refine @@ -88,3 +89,4 @@ import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Target import Language.Haskell.GhcMod.Output import Language.Haskell.GhcMod.FileMapping +import Language.Haskell.GhcMod.Test diff --git a/Language/Haskell/GhcMod/Test.hs b/Language/Haskell/GhcMod/Test.hs new file mode 100644 index 0000000..f777876 --- /dev/null +++ b/Language/Haskell/GhcMod/Test.hs @@ -0,0 +1,43 @@ +module Language.Haskell.GhcMod.Test where + +import Data.List +import System.FilePath +import System.Directory + +import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Monad +import Language.Haskell.GhcMod.DynFlags + +import GHC --(ModSummary(..), ModLocation(..), moduleName, findModule) +import GHC.Exception +import OccName + +test :: IOish m + => FilePath -> GhcModT m String +test f = runGmlT' [Left f] (return . setHscInterpreted) $ do + mg <- getModuleGraph + root <- cradleRootDir <$> cradle + f' <- makeRelative root <$> liftIO (canonicalizePath f) + let Just ms = find ((==Just f') . ml_hs_file . ms_location) mg + mdl = ms_mod ms + mn = moduleName mdl + + Just mi <- getModuleInfo mdl + let exs = map (occNameString . getOccName) $ modInfoExports mi + cqs = filter ("prop_" `isPrefixOf`) exs + + setContext [ IIDecl $ simpleImportDecl mn + , IIDecl $ simpleImportDecl $ mkModuleName "Test.QuickCheck" + ] + + _res <- mapM runTest cqs + + return "" + +runTest :: GhcMonad m => String -> m (Maybe SomeException) +runTest fn = do + res <- runStmt ("quickCheck " ++ fn) RunToCompletion + return $ case res of + RunOk [] -> Nothing + RunException se -> Just se + _ -> error "runTest" diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 0f4c39e..cac9337 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -140,6 +140,7 @@ Library Language.Haskell.GhcMod.SrcUtils Language.Haskell.GhcMod.Stack Language.Haskell.GhcMod.Target + Language.Haskell.GhcMod.Test Language.Haskell.GhcMod.Types Language.Haskell.GhcMod.Utils Language.Haskell.GhcMod.World diff --git a/src/GHCMod.hs b/src/GHCMod.hs index bae2fe5..09c5036 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -161,6 +161,7 @@ ghcCommands (CmdMapFile f) = >> return "" ghcCommands (CmdUnmapFile f) = unloadMappedFile f >> return "" ghcCommands (CmdQuit) = liftIO exitSuccess +ghcCommands (CmdTest file) = test file ghcCommands cmd = throw $ InvalidCommandLine $ Left $ show cmd newtype InvalidCommandLine = InvalidCommandLine (Either String String) diff --git a/src/GHCMod/Options/Commands.hs b/src/GHCMod/Options/Commands.hs index 1026c52..098bd04 100644 --- a/src/GHCMod/Options/Commands.hs +++ b/src/GHCMod/Options/Commands.hs @@ -60,6 +60,7 @@ data GhcModCommands = | CmdMapFile FilePath | CmdUnmapFile FilePath | CmdQuit + | CmdTest FilePath deriving (Show) commandsSpec :: Parser GhcModCommands @@ -182,6 +183,10 @@ commands = \\ " `[a]', which results in:" code "filterNothing xs = filter _body_1 _body_2" "(See also: https://github.com/kazu-yamamoto/ghc-mod/issues/311)" + <> command "test" + $$ info (CmdTest <$> strArg "FILE") + $$ progDesc "" + interactiveCommandsSpec :: Parser GhcModCommands interactiveCommandsSpec =