diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs index 8f3db29..21de334 100644 --- a/Language/Haskell/GhcMod/Info.hs +++ b/Language/Haskell/GhcMod/Info.hs @@ -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 - 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 +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 + void $ G.depanal [] False >>= Gap.setCtx + action + where + handler (SomeException _) = return errmsg diff --git a/src/GHCMod.hs b/src/GHCMod.hs index e99b2e2..43bed57 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -38,6 +38,9 @@ usage = "ghc-mod version " ++ showVersion version ++ "\n" ++ "\t ghc-mod doc \n" ++ "\t ghc-mod boot\n" ++ "\t ghc-mod help\n" + ++ "\n" + ++ " 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 diff --git a/test/InfoSpec.hs b/test/InfoSpec.hs index a81ab49..4ff7809 100644 --- a/test/InfoSpec.hs +++ b/test/InfoSpec.hs @@ -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