intero-0.1.3: src/test/Main.hs
{-# LANGUAGE ScopedTypeVariables #-}
-- | Test that various commands work properly.
module Main where
import Control.Exception
import Control.Monad.IO.Class
import System.IO
import System.IO.Temp
import System.Process
import Test.Hspec
-- | Main entry point.
main :: IO ()
main = hspec spec
--------------------------------------------------------------------------------
-- Test suite specification
-- | Test suite.
spec :: Spec
spec =
do basics
load
types
use
definition
-- | Basic commands that should work out of the box.
basics :: Spec
basics =
describe "Basics"
(do it ":t 1" (eval ":t 1" "1 :: Num a => a\n")
it ":i Nothing"
(eval ":i Nothing" "data Maybe a = Nothing | ... \t-- Defined in ‘GHC.Base’\n")
it ":k Just" (eval ":k Maybe" "Maybe :: * -> *\n"))
-- | Loading files and seeing the results.
load :: Spec
load =
describe "Load"
(do it ":l X.hs"
(do result <-
withIntero
[]
(\dir repl ->
do writeFile (dir ++ "/X.hs") "x = 'a'"
repl (":l X.hs"))
shouldBe result
(unlines ["[1 of 1] Compiling Main ( X.hs, interpreted )"
,"Ok, modules loaded: Main."
,"Collecting type info for 1 module(s) ... "]))
it ":l NonExistent.hs"
(do result <-
withIntero []
(\_ repl -> repl (":l NonExistent.hs"))
shouldBe result (unlines ["Failed, modules loaded: none."
,""
,"<no location info>: can't find file: NonExistent.hs"])))
-- | Get type information of file contents.
types :: Spec
types =
describe "Types"
(do it ":type-at X.hs 1 1 1 1 x -- Char"
(typeAt "x = 'a'" (1,1,1,1,"x") "x :: Char\n")
it ":type-at X.hs 1 1 1 1 x -- [Char]"
(typeAt "x = 'a' : x" (1,1,1,1,"x") "x :: [Char]\n")
it ":type-at X.hs 1 11 1 12 x -- [Char]"
(typeAt "x = 'a' : x" (1,11,1,12,"x") "x :: [Char]\n")
it ":type-at X.hs 1 11 1 12 y -- [Char] (internal variable)"
(typeAt "x = 'a' : y where y = x" (1,11,1,12,"y") "y :: [Char]\n")
issue ":type-at X.hs 1 1 1 1 f -- Num a => a"
"https://github.com/chrisdone/intero/issues/14"
(typeAt "f x = x * 2" (1,1,1,2,"f") "f :: Num a => a -> a\n"))
-- | Find uses of a variable.
use :: Spec
use =
describe "Uses"
(do it ":uses X.hs 1 1 1 1 x -- from definition site"
(uses "x = 'a' : x"
(1,1,1,1,"x")
(unlines ["X.hs:(1,1)-(1,2)"
,"X.hs:(1,1)-(1,2)"
,"X.hs:(1,11)-(1,12)"]))
it ":uses X.hs 1 11 1 12 x -- from use site"
(uses "x = 'a' : x"
(1,11,1,12,"x")
(unlines ["X.hs:(1,1)-(1,2)","X.hs:(1,11)-(1,12)"]))
it ":uses X.hs 1 5 1 6 id -- package definition"
(uses "x = id"
(1,5,1,6,"id")
(unlines ["base-4.8.2.0:GHC.Base"]))
it ":uses X.hs 1 5 1 6 id -- shadowed package definition"
(uses "x = id where id = ()"
(1,5,1,7,"id")
(unlines ["X.hs:(1,14)-(1,16)"
,"X.hs:(1,14)-(1,16)"
,"X.hs:(1,5)-(1,7)"])))
-- | Find loc-ats of a variable.
definition :: Spec
definition =
describe "Definition location"
(do it ":loc-at X.hs 1 1 1 1 x -- from definition site"
(locAt "x = 'a' : x"
(1,1,1,1,"x")
(unlines ["X.hs:(1,1)-(1,2)"]))
it ":loc-at X.hs 1 11 1 12 x -- from use site"
(locAt "x = 'a' : x"
(1,11,1,12,"x")
(unlines ["X.hs:(1,1)-(1,12)"]))
it ":loc-at X.hs 1 11 1 12 x -- to function argument"
(locAt "f x = 'a' : x"
(1,13,1,14,"x")
(unlines ["X.hs:(1,3)-(1,4)"]))
it ":loc-at X.hs 1 11 1 12 x -- to pattern match"
(locAt "f (Just x) = 'a' : x"
(1,20,1,21,"x")
(unlines ["X.hs:(1,9)-(1,10)"])))
--------------------------------------------------------------------------------
-- Combinators for running and interacting with intero
-- | Find the definition for the thing at point.
locAt
:: String -> (Int,Int,Int,Int,String) -> String -> Expectation
locAt file (line,col,line',col',name) expected =
do result <-
withIntero
[]
(\dir repl ->
do writeFile (dir ++ "/X.hs") file
_ <- repl (":l X.hs")
repl (":loc-at X.hs " ++
unwords (map show [line,col,line',col']) ++ " " ++ name))
shouldBe result expected
-- | Find use-sites for the given place.
uses
:: String -> (Int,Int,Int,Int,String) -> String -> Expectation
uses file (line,col,line',col',name) expected =
do result <-
withIntero
[]
(\dir repl ->
do writeFile (dir ++ "/X.hs") file
_ <- repl (":l X.hs")
repl (":uses X.hs " ++
unwords (map show [line,col,line',col']) ++ " " ++ name))
shouldBe result expected
-- | Test the type at the given place.
typeAt
:: String -> (Int,Int,Int,Int,String) -> String -> Expectation
typeAt file (line,col,line',col',name) expected =
do result <-
withIntero
[]
(\dir repl ->
do writeFile (dir ++ "/X.hs") file
_ <- repl (":l X.hs")
repl (":type-at X.hs " ++
unwords (map show [line,col,line',col']) ++ " " ++ name))
shouldBe result expected
-- | Make a quick interaction with intero.
eval :: String -- ^ Input.
-> String -- ^ Expected output.
-> Expectation
eval send recv =
do reply <-
withIntero []
(\_ repl -> repl send)
shouldBe reply recv
-- | Launch an interactive intero process. Creates a temporary
-- directory in which the computation can work.
withIntero :: MonadIO m => [String] -> (FilePath -> (String -> IO String) -> IO a) -> m a
withIntero arguments cont =
liftIO (withSystemTempDirectory
"withIntero"
(\dir ->
do (inp,out,err,pid) <-
catch (runInteractiveProcess
"intero"
("-ignore-dot-ghci" : arguments)
(Just dir)
Nothing)
(\(_ :: IOException) ->
error "Couldn't launch intero process.")
hSetBuffering inp NoBuffering
hSetBuffering out NoBuffering
hSetBuffering err NoBuffering
let repl instr =
do catch (do hPutStrLn inp instr
let getReply =
do mc <-
catch (fmap Just (hGetChar out))
(\(_ :: IOException) ->
return Nothing)
case mc of
Nothing -> hGetAvailable err
Just '\4' -> hGetAvailable err
Just c ->
do cs <- getReply
return (c : cs)
getReply)
(\(_ :: IOException) -> return "")
_ <- repl ":set prompt \"\\4\""
finally (cont dir repl)
(do ignored (hClose inp)
ignored (hClose out)
ignored (hClose err)
ignored (terminateProcess pid))))
where ignored m = catch m (\(_ :: IOException) -> return ())
hGetAvailable h =
do available <-
catch (hReady h)
(\(_ :: IOException) -> return False)
if available
then catch (do c <- hGetChar h
cs <- hGetAvailable h
return (c : cs))
(\(_ :: IOException) -> return [])
else return []
--------------------------------------------------------------------------------
-- Spec combinators
-- | Specify an issue that needs to be regression tested.
issue :: Example a => String -> t -> a -> SpecWith (Arg a)
issue label _link expectation = it label expectation