info/type does not require module name.

Fallback was removed. See #199.
This commit is contained in:
Kazu Yamamoto 2014-04-11 11:51:25 +09:00
parent 54bea65736
commit e9859980ab
3 changed files with 33 additions and 60 deletions

View File

@ -15,21 +15,18 @@ import CoreUtils (exprType)
import Data.Function (on)
import Data.Generics hiding (typeOf)
import Data.List (sortBy)
import Data.Maybe (catMaybes, fromMaybe, listToMaybe)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Ord as O
import Data.Time.Clock (getCurrentTime)
import Exception (gcatch, SomeException(..))
import GHC (Ghc, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), DynFlags, SrcSpan, Type, Located, TypecheckedSource, GenLocated(L), LoadHowMuch(..), TargetId(..))
import Exception (ghandle, SomeException(..))
import GHC (Ghc, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), DynFlags, SrcSpan, Type, Located, TypecheckedSource, GenLocated(L), LoadHowMuch(..))
import qualified GHC as G
import GHC.SYB.Utils (Stage(TypeChecker), everythingStaged)
import HscTypes (ms_imps)
import Language.Haskell.GhcMod.Doc (showPage, showOneLine, getStyle)
import Language.Haskell.GhcMod.GHCApi
import Language.Haskell.GhcMod.GHCChoice ((||>), goNext)
import Language.Haskell.GhcMod.Gap (HasType(..))
import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Types
import Outputable (PprStyle, ppr)
import Outputable (PprStyle)
import TcHsSyn (hsPatType)
----------------------------------------------------------------
@ -42,20 +39,18 @@ data Cmd = Info | Type deriving Eq
infoExpr :: Options
-> Cradle
-> FilePath -- ^ A target file.
-> ModuleString -- ^ A module name.
-> Expression -- ^ A Haskell expression.
-> IO String
infoExpr opt cradle file modstr expr = (++ "\n") <$> withGHCDummyFile (info opt cradle file modstr expr)
infoExpr opt cradle file expr = (++ "\n") <$> withGHCDummyFile (info opt cradle file expr)
-- | Obtaining information of a target expression. (GHCi's info:)
info :: Options
-> Cradle
-> FilePath -- ^ A target file.
-> ModuleString -- ^ A module name.
-> Expression -- ^ A Haskell expression.
-> Ghc String
info opt cradle file modstr expr =
inModuleContext Info opt cradle file modstr exprToInfo "Cannot show info"
info opt cradle file expr =
inModuleContext Info opt cradle file exprToInfo "Cannot show info"
where
exprToInfo = do
dflag <- G.getSessionDynFlags
@ -80,25 +75,25 @@ instance HasType (LPat Id) where
typeExpr :: Options
-> Cradle
-> FilePath -- ^ A target file.
-> ModuleString -- ^ A module name.
-> Int -- ^ Line number.
-> Int -- ^ Column number.
-> IO String
typeExpr opt cradle file modstr lineNo colNo = withGHCDummyFile $ typeOf opt cradle file modstr lineNo colNo
typeExpr opt cradle file lineNo colNo = withGHCDummyFile $ typeOf opt cradle file lineNo colNo
-- | Obtaining type of a target expression. (GHCi's type:)
typeOf :: Options
-> Cradle
-> FilePath -- ^ A target file.
-> ModuleString -- ^ A module name.
-> Int -- ^ Line number.
-> Int -- ^ Column number.
-> Ghc String
typeOf opt cradle file modstr lineNo colNo =
inModuleContext Type opt cradle file modstr exprToType errmsg
typeOf opt cradle file lineNo colNo =
inModuleContext Type opt cradle file exprToType errmsg
where
exprToType = do
modSum <- G.getModSummary $ G.mkModuleName modstr
modGraph <- G.getModuleGraph
let ms = filter (\m -> G.ml_hs_file (G.ms_location m) == Just file) modGraph
modSum = head ms
p <- G.parseModule modSum
tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
let bs = listifySpans tcs (lineNo, colNo) :: [LHsBind Id]
@ -141,36 +136,12 @@ pretty dflag style = showOneLine dflag style . Gap.typeForUser
noWaringOptions :: [String]
noWaringOptions = ["-w:"]
inModuleContext :: Cmd -> Options -> Cradle -> FilePath -> ModuleString -> Ghc String -> String -> Ghc String
inModuleContext _ opt cradle file modstr action errmsg =
valid ||> invalid ||> return errmsg
where
valid = do
inModuleContext :: Cmd -> Options -> Cradle -> FilePath -> Ghc String -> String -> Ghc String
inModuleContext _ opt cradle file action errmsg = ghandle handler $ do
void $ initializeFlagsWithCradle opt cradle noWaringOptions False
setTargetFiles [file]
void $ G.load LoadAllTargets
doif setContextFromTarget action
invalid = do
void $ initializeFlagsWithCradle opt cradle noWaringOptions False
setTargetBuffer
void $ G.load LoadAllTargets
doif setContextFromTarget action
setTargetBuffer = do
modgraph <- G.depanal [G.mkModuleName modstr] True
dflag <- G.getSessionDynFlags
style <- getStyle
-- FIXME: "import (implicit) Prelude"
let imports = concatMap (map (showPage dflag style . ppr . G.unLoc)) $
map ms_imps modgraph ++ map G.ms_srcimps modgraph
moddef = "module " ++ sanitize modstr ++ " where"
header = moddef : imports
importsBuf <- Gap.toStringBuffer header
clkTime <- liftIO getCurrentTime
G.setTargets [Gap.mkTarget (TargetModule $ G.mkModuleName modstr)
True
(Just (importsBuf, clkTime))]
doif m t = m >>= \ok -> if ok then t else goNext
sanitize = fromMaybe "SomeModule" . listToMaybe . words
setContextFromTarget :: Ghc Bool
setContextFromTarget = (G.depanal [] False >>= Gap.setCtx) `gcatch` \(SomeException _) -> return False
void $ G.depanal [] False >>= Gap.setCtx
action
where
handler (SomeException _) = return errmsg

View File

@ -38,6 +38,9 @@ usage = "ghc-mod version " ++ showVersion version ++ "\n"
++ "\t ghc-mod doc <module>\n"
++ "\t ghc-mod boot\n"
++ "\t ghc-mod help\n"
++ "\n"
++ "<module> is not used, anything is OK.\n"
++ "It is necessary to maintain backward compatibility.\n"
----------------------------------------------------------------
@ -96,7 +99,6 @@ main = flip E.catches handlers $ do
cradle <- findCradle
let cmdArg0 = cmdArg !. 0
cmdArg1 = cmdArg !. 1
cmdArg2 = cmdArg !. 2
cmdArg3 = cmdArg !. 3
cmdArg4 = cmdArg !. 4
remainingArgs = tail cmdArg
@ -111,8 +113,8 @@ main = flip E.catches handlers $ do
"check" -> checkSyntax opt cradle remainingArgs
"expand" -> checkSyntax opt { expandSplice = True } cradle remainingArgs
"debug" -> nArgs 1 $ debugInfo opt cradle cmdArg1
"info" -> nArgs 3 infoExpr opt cradle cmdArg1 cmdArg2 cmdArg3
"type" -> nArgs 4 $ typeExpr opt cradle cmdArg1 cmdArg2 (read cmdArg3) (read cmdArg4)
"info" -> nArgs 3 infoExpr opt cradle cmdArg1 cmdArg3
"type" -> nArgs 4 $ typeExpr opt cradle cmdArg1 (read cmdArg3) (read cmdArg4)
"lint" -> nArgs 1 withFile (lintSyntax opt) cmdArg1
"root" -> nArgs 1 $ rootInfo opt cradle cmdArg1
"doc" -> nArgs 1 $ packageDoc opt cradle cmdArg1

View File

@ -23,38 +23,38 @@ spec = do
it "shows types of the expression and its outers" $ do
withDirectory_ "test/data/ghc-mod-check" $ do
cradle <- findCradleWithoutSandbox
res <- typeExpr defaultOptions cradle "Data/Foo.hs" "Data.Foo" 9 5
res <- typeExpr defaultOptions cradle "Data/Foo.hs" 9 5
res `shouldBe` "9 5 11 40 \"Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n"
it "works with a module using TemplateHaskell" $ do
withDirectory_ "test/data" $ do
cradle <- findCradleWithoutSandbox
res <- typeExpr defaultOptions cradle "Bar.hs" "Bar" 5 1
res <- typeExpr defaultOptions cradle "Bar.hs" 5 1
res `shouldBe` unlines ["5 1 5 20 \"[Char]\""]
it "works with a module that imports another module using TemplateHaskell" $ do
withDirectory_ "test/data" $ do
cradle <- findCradleWithoutSandbox
res <- typeExpr defaultOptions cradle "Main.hs" "Main" 3 8
res <- typeExpr defaultOptions cradle "Main.hs" 3 8
res `shouldBe` unlines ["3 8 3 16 \"String -> IO ()\"", "3 8 3 20 \"IO ()\"", "3 1 3 20 \"IO ()\""]
describe "infoExpr" $ do
it "works for non-export functions" $ do
withDirectory_ "test/data" $ do
cradle <- findCradleWithoutSandbox
res <- infoExpr defaultOptions cradle "Info.hs" "Info" "fib"
res <- infoExpr defaultOptions cradle "Info.hs" "fib"
res `shouldSatisfy` ("fib :: Int -> Int" `isPrefixOf`)
it "works with a module using TemplateHaskell" $ do
withDirectory_ "test/data" $ do
cradle <- findCradleWithoutSandbox
res <- infoExpr defaultOptions cradle "Bar.hs" "Bar" "foo"
res <- infoExpr defaultOptions cradle "Bar.hs" "foo"
res `shouldSatisfy` ("foo :: ExpQ" `isPrefixOf`)
it "works with a module that imports another module using TemplateHaskell" $ do
withDirectory_ "test/data" $ do
cradle <- findCradleWithoutSandbox
res <- infoExpr defaultOptions cradle "Main.hs" "Main" "bar"
res <- infoExpr defaultOptions cradle "Main.hs" "bar"
res `shouldSatisfy` ("bar :: [Char]" `isPrefixOf`)
it "doesn't fail on unicode output" $ do