summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorChrisDone <>2016-05-13 14:07:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2016-05-13 14:07:00 (GMT)
commiteef7e03761ccb0d6da558f63e3d53ca0683aec06 (patch)
tree78177776682358063ee869012c805323c8929b55
parent01f91d3170a4f573a237d1aed7c922181b977aec (diff)
version 0.1.30.1.3
-rw-r--r--intero.cabal19
-rw-r--r--src/GhciFind.hs71
-rw-r--r--src/InteractiveUI.hs10
-rw-r--r--src/test/Main.hs234
4 files changed, 308 insertions, 26 deletions
diff --git a/intero.cabal b/intero.cabal
index 47fe1ed..3b1aa29 100644
--- 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 @@ executable intero
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
index a204817..7285a6e 100644
--- 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 @@ resolveName spans' sl sc el ec =
((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 @@ findType :: GhcMonad m
-> 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 @@ guessModule infos fp =
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
index c6e1cf7..1b07d45 100644
--- a/src/InteractiveUI.hs
+++ b/src/InteractiveUI.hs
@@ -1583,10 +1583,14 @@ typeAt str =
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
index 0000000..99d5550
--- /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."
+ ,""
+ ,"<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