intero 0.1.2 → 0.1.3
raw patch · 4 files changed
+308/−26 lines, 4 filesdep +hspecdep +temporarydep ~base
Dependencies added: hspec, temporary
Dependency ranges changed: base
Files
- intero.cabal +18/−1
- src/GhciFind.hs +49/−22
- src/InteractiveUI.hs +7/−3
- src/test/Main.hs +234/−0
intero.cabal view
@@ -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
src/GhciFind.hs view
@@ -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 [])
src/InteractiveUI.hs view
@@ -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
+ src/test/Main.hs view
@@ -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."+ ,""+ ,"<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