diff --git a/intero.cabal b/intero.cabal --- a/intero.cabal +++ b/intero.cabal @@ -1,7 +1,7 @@ name: intero version: - 0.1.2 + 0.1.3 synopsis: Complete interactive development program for Haskell license: @@ -78,3 +78,20 @@ else build-depends: unix + +test-suite store-test + default-language: + Haskell2010 + type: + exitcode-stdio-1.0 + hs-source-dirs: + src/test + main-is: + Main.hs + build-depends: + base, + hspec, + temporary, + process, + transformers, + directory diff --git a/src/GhciFind.hs b/src/GhciFind.hs --- a/src/GhciFind.hs +++ b/src/GhciFind.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} @@ -5,15 +6,14 @@ -- | Find type/location information. module GhciFind - (findType,findLoc,findNameUses) + (findType,FindType(..),findLoc,findNameUses) where -import Control.Monad +import Control.Exception import Data.List import Data.Map (Map) import qualified Data.Map as M import Data.Maybe - import FastString import GHC import GhcMonad @@ -209,6 +209,13 @@ ((sl' == sl && sc' >= sc) || (sl' > sl)) && ((el' == el && ec' <= ec) || (el' < el)) +data FindType + = FindTypeFail String + | FindType ModInfo + Type + | FindTyThing ModInfo + TyThing + -- | Try to find the type of the given span. findType :: GhcMonad m => Map ModuleName ModInfo @@ -218,32 +225,46 @@ -> Int -> Int -> Int - -> m (Either String (ModInfo, Type)) + -> m FindType findType infos fp string sl sc el ec = do mname <- guessModule infos fp case mname of Nothing -> - return (Left "Couldn't guess that module name. Does it exist?") - Just name -> - case M.lookup name infos of + return (FindTypeFail "Couldn't guess that module name. Does it exist?") + Just modName -> + case M.lookup modName infos of Nothing -> - return (Left ("Couldn't guess the module name. Is this module loaded?")) - Just info -> - do let !mty = - resolveType (modinfoSpans info) - sl - sc - el - ec - case mty of - Just ty -> return (Right (info, ty)) - Nothing -> - fmap (Right . (,) info) (exprType string) + return (FindTypeFail "Couldn't guess the module name. Is this module loaded?") + Just minfo -> + do names <- lookupNamesInContext string + let !mspaninfo = + resolveSpanInfo (modinfoSpans minfo) + sl + sc + el + ec + case mspaninfo of + Just si + | Just ty <- spaninfoType si -> + case fmap Var.varName (spaninfoVar si) of + Nothing -> return (FindType minfo ty) + Just name -> + case find (reliableNameEquality name) names of + Just nameWithBetterType -> + do result <- getInfo True nameWithBetterType + case result of + Just (thing,_,_,_) -> + return (FindTyThing minfo thing) + Nothing -> return (FindType minfo ty) + Nothing -> return (FindType minfo ty) + _ -> + fmap (FindType minfo) + (exprType string) -- | Try to resolve the type display from the given span. -resolveType :: [SpanInfo] -> Int -> Int -> Int -> Int -> Maybe Type -resolveType spans' sl sc el ec = - join (fmap spaninfoType (find inside (reverse spans'))) +resolveSpanInfo :: [SpanInfo] -> Int -> Int -> Int -> Int -> Maybe SpanInfo +resolveSpanInfo spans' sl sc el ec = + find inside (reverse spans') where inside (SpanInfo sl' sc' el' ec' _ _) = ((sl' == sl && sc' >= sc) || (sl' > sl)) && ((el' == el && ec' <= ec) || (el' < el)) @@ -273,3 +294,9 @@ Just (mn,_) -> return (Just mn) Nothing -> return Nothing + +-- | Lookup the name of something in the current context. +lookupNamesInContext :: GhcMonad m => String -> m [Name] +lookupNamesInContext string = + gcatch (GHC.parseName string) + (\(_ :: SomeException) -> return []) diff --git a/src/InteractiveUI.hs b/src/InteractiveUI.hs --- a/src/InteractiveUI.hs +++ b/src/InteractiveUI.hs @@ -1583,10 +1583,14 @@ do infos <- fmap mod_infos (lift getGHCiState) result <- findType infos fp sample sl sc el ec case result of - Left err -> liftIO (putStrLn err) - Right (info', ty) -> + FindTypeFail err -> liftIO (putStrLn err) + FindType info' ty -> + printForUserModInfo + (modinfoInfo info') + (sep [text sample,nest 2 (dcolon <+> ppr ty)]) + FindTyThing info' tything -> printForUserModInfo (modinfoInfo info') - (sep [text sample,nest 2 (dcolon <+> ppr ty)])) + (pprTyThing tything)) ----------------------------------------------------------------------------- -- :uses diff --git a/src/test/Main.hs b/src/test/Main.hs new file mode 100644 --- /dev/null +++ b/src/test/Main.hs @@ -0,0 +1,234 @@ +{-# 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." + ,"" + ,": 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