diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs index bf38e1c..5914acd 100644 --- a/Language/Haskell/GhcMod/Gap.hs +++ b/Language/Haskell/GhcMod/Gap.hs @@ -44,6 +44,7 @@ module Language.Haskell.GhcMod.Gap ( , Language.Haskell.GhcMod.Gap.isSynTyCon , parseModuleHeader , mkErrStyle' + , everythingStagedWithContext ) where import Control.Applicative hiding (empty) @@ -115,6 +116,8 @@ import Lexer as L import Parser import SrcLoc import Packages +import Data.Generics (GenericQ, extQ, gmapQ) +import GHC.SYB.Utils (Stage(..)) import Language.Haskell.GhcMod.Types (Expression(..)) import Prelude @@ -595,3 +598,20 @@ instance NFData ByteString where rnf Empty = () rnf (Chunk _ b) = rnf b #endif + +-- | Like 'everything', but avoid known potholes, based on the 'Stage' that +-- generated the Ast. +everythingStagedWithContext :: Stage -> s -> (r -> r -> r) -> r -> GenericQ (s -> (r, s)) -> GenericQ r +everythingStagedWithContext stage s0 f z q x + | (const False +#if __GLASGOW_HASKELL__ <= 708 + `extQ` postTcType +#endif + `extQ` fixity `extQ` nameSet) x = z + | otherwise = foldl f r (gmapQ (everythingStagedWithContext stage s' f z q) x) + where nameSet = const (stage `elem` [Parser,TypeChecker]) :: NameSet -> Bool +#if __GLASGOW_HASKELL__ <= 708 + postTcType = const (stage Bool +#endif + fixity = const (stage Bool + (r, s') = q x s0 diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs index 31a8eab..dc18f7c 100644 --- a/Language/Haskell/GhcMod/Info.hs +++ b/Language/Haskell/GhcMod/Info.hs @@ -5,10 +5,9 @@ module Language.Haskell.GhcMod.Info ( import Data.Function (on) import Data.List (sortBy) -import Data.Maybe (catMaybes) import System.FilePath import Exception (ghandle, SomeException(..)) -import GHC (GhcMonad, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), SrcSpan, Type) +import GHC (GhcMonad, SrcSpan) import Prelude import qualified GHC as G import qualified Language.Haskell.GhcMod.Gap as Gap @@ -53,17 +52,18 @@ info file expr = -- | Obtaining type of a target expression. (GHCi's type:) types :: IOish m - => FilePath -- ^ A target file. + => Bool -- ^ Include constraints into type signature + -> FilePath -- ^ A target file. -> Int -- ^ Line number. -> Int -- ^ Column number. -> GhcModT m String -types file lineNo colNo = +types withConstraints file lineNo colNo = ghandle handler $ runGmlT' [Left file] deferErrors $ withInteractiveContext $ do crdl <- cradle modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl file) - srcSpanTypes <- getSrcSpanType modSum lineNo colNo + srcSpanTypes <- getSrcSpanType withConstraints modSum lineNo colNo dflag <- G.getSessionDynFlags st <- getStyle convert' $ map (toTup dflag st) $ sortBy (cmp `on` fst) srcSpanTypes @@ -72,14 +72,8 @@ types file lineNo colNo = gmLog GmException "types" $ showDoc ex return [] -getSrcSpanType :: GhcMonad m => G.ModSummary -> Int -> Int -> m [(SrcSpan, Type)] -getSrcSpanType modSum lineNo colNo = do - p <- G.parseModule modSum - tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p - let bs = listifySpans tcs (lineNo, colNo) :: [LHsBind Id] - es = listifySpans tcs (lineNo, colNo) :: [LHsExpr Id] - ps = listifySpans tcs (lineNo, colNo) :: [LPat Id] - bts <- mapM (getType tcm) bs - ets <- mapM (getType tcm) es - pts <- mapM (getType tcm) ps - return $ catMaybes $ concat [ets, bts, pts] +getSrcSpanType :: (GhcMonad m) => Bool -> G.ModSummary -> Int -> Int -> m [(SrcSpan, G.Type)] +getSrcSpanType withConstraints modSum lineNo colNo = + G.parseModule modSum + >>= G.typecheckModule + >>= flip (collectSpansTypes withConstraints) (lineNo, colNo) diff --git a/Language/Haskell/GhcMod/SrcUtils.hs b/Language/Haskell/GhcMod/SrcUtils.hs index 0938f81..961bfae 100644 --- a/Language/Haskell/GhcMod/SrcUtils.hs +++ b/Language/Haskell/GhcMod/SrcUtils.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TupleSections, FlexibleInstances, Rank2Types #-} +{-# LANGUAGE TupleSections, FlexibleInstances, Rank2Types, ImpredicativeTypes #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.Haskell.GhcMod.SrcUtils where @@ -6,11 +6,14 @@ module Language.Haskell.GhcMod.SrcUtils where import Control.Applicative import CoreUtils (exprType) import Data.Generics -import Data.Maybe (fromMaybe) +import Data.Maybe import Data.Ord as O import GHC (LHsExpr, LPat, Id, DynFlags, SrcSpan, Type, Located, ParsedSource, RenamedSource, TypecheckedSource, GenLocated(L)) +import Var (Var) import qualified GHC as G -import GHC.SYB.Utils (Stage(..), everythingStaged) +import qualified Var as G +import qualified Type as G +import GHC.SYB.Utils import GhcMonad import qualified Language.Haskell.Exts.Annotated as HE import Language.Haskell.GhcMod.Doc @@ -20,6 +23,10 @@ import OccName (OccName) import Outputable (PprStyle) import TcHsSyn (hsPatType) import Prelude +import Control.Monad +import Data.List (nub) +import Control.Arrow +import qualified Data.Map as M ---------------------------------------------------------------- @@ -34,6 +41,82 @@ instance HasType (LPat Id) where ---------------------------------------------------------------- +-- | Stores mapping from monomorphic to polymorphic types +type CstGenQS = M.Map Var Type +-- | Generic type to simplify SYB definition +type CstGenQT a = forall m. GhcMonad m => a Id -> CstGenQS -> (m [(SrcSpan, Type)], CstGenQS) + +collectSpansTypes :: (GhcMonad m) => Bool -> G.TypecheckedModule -> (Int, Int) -> m [(SrcSpan, Type)] +collectSpansTypes withConstraints tcs lc = + -- This walks AST top-down, left-to-right, while carrying CstGenQS down the tree + -- (but not left-to-right) + everythingStagedWithContext TypeChecker M.empty (liftM2 (++)) + (return []) + ((return [],) + `mkQ` (hsBind :: CstGenQT G.LHsBind) -- matches on binds + `extQ` (genericCT :: CstGenQT G.LHsExpr) -- matches on expressions + `extQ` (genericCT :: CstGenQT G.LPat) -- matches on patterns + ) + (G.tm_typechecked_source tcs) + where + -- Helper function to insert mapping into CstGenQS + insExp x = M.insert (G.abe_mono x) (G.varType $ G.abe_poly x) + -- If there is AbsBinds here, insert mapping into CstGenQS if needed + hsBind (L _ G.AbsBinds{abs_exports = es'}) s + | withConstraints = (return [], foldr insExp s es') + | otherwise = (return [], s) + -- Otherwise, it's the same as other cases + hsBind x s = genericCT x s + -- Generic SYB function to get type + genericCT x s + | withConstraints + = (maybe [] (uncurry $ constrainedType (collectBinders x) s) <$> getType' x, s) + | otherwise = (maybeToList <$> getType' x, s) + -- Collects everything with Id from LHsBind, LHsExpr, or LPat + collectBinders :: Data a => a -> [Id] + collectBinders = listifyStaged TypeChecker (const True) + -- Gets monomorphic type with location + getType' x@(L spn _) + | G.isGoodSrcSpan spn && spn `G.spans` lc + = getType tcs x + | otherwise = return Nothing + -- Gets constrained type + constrainedType :: [Var] -- ^ Binders in expression, i.e. anything with Id + -> CstGenQS -- ^ Map from Id to polymorphic type + -> SrcSpan -- ^ extent of expression, copied to result + -> Type -- ^ monomorphic type + -> [(SrcSpan, Type)] -- ^ result + constrainedType pids s spn genTyp = + let + -- runs build on every binder. + ctys = mapMaybe build (nub pids) + -- Computes constrained type for x. Returns (constraints, substitutions) + -- Substitutions are needed because type variables don't match + -- between polymorphic and monomorphic types. + -- E.g. poly type might be `Monad m => m ()`, while monomorphic might be `f ()` + build x | Just cti <- x `M.lookup` s + = let + (preds', ctt) = getPreds cti + -- list of type variables in monomorphic type + vts = listifyStaged TypeChecker G.isTyVar $ G.varType x + -- list of type variables in polymorphic type + tvm = listifyStaged TypeChecker G.isTyVarTy ctt + in Just (preds', zip vts tvm) + | otherwise = Nothing + -- list of constraints + preds = concatMap fst ctys + -- Type variable substitutions + subs = G.mkTopTvSubst $ concatMap snd ctys + -- Constrained type + ty = G.substTy subs $ G.mkFunTys preds genTyp + in [(spn, ty)] + -- Splits a given type into list of constraints and simple type. Drops foralls. + getPreds :: Type -> ([Type], Type) + getPreds x | G.isForAllTy x = getPreds $ G.dropForAlls x + | Just (c, t) <- G.splitFunTy_maybe x + , G.isPredTy c = first (c:) $ getPreds t + | otherwise = ([], x) + listifySpans :: Typeable a => TypecheckedSource -> (Int, Int) -> [Located a] listifySpans tcs lc = listifyStaged TypeChecker p tcs where diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 713d567..ed28d56 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -151,7 +151,7 @@ ghcCommands (CmdBrowse opts ms) = concat <$> browse opts `mapM` ms ghcCommands (CmdCheck files) = checkSyntax files ghcCommands (CmdExpand files) = expandTemplate files ghcCommands (CmdInfo file symb) = info file $ Expression symb -ghcCommands (CmdType file (line, col)) = types file line col +ghcCommands (CmdType wCon file (line, col)) = types wCon file line col ghcCommands (CmdSplit file (line, col)) = splits file line col ghcCommands (CmdSig file (line, col)) = sig file line col ghcCommands (CmdAuto file (line, col)) = auto file line col diff --git a/src/GHCMod/Options/Commands.hs b/src/GHCMod/Options/Commands.hs index a2ab3c0..7aaa66e 100644 --- a/src/GHCMod/Options/Commands.hs +++ b/src/GHCMod/Options/Commands.hs @@ -51,7 +51,7 @@ data GhcModCommands = | CmdCheck [FilePath] | CmdExpand [FilePath] | CmdInfo FilePath Symbol - | CmdType FilePath Point + | CmdType Bool FilePath Point | CmdSplit FilePath Point | CmdSig FilePath Point | CmdAuto FilePath Point @@ -215,12 +215,12 @@ interactiveCommandsSpec = strArg :: String -> Parser String strArg = argument str . metavar -filesArgsSpec :: ([String] -> b) -> Parser b -filesArgsSpec x = x <$> some (strArg "FILES..") +filesArgsSpec :: Parser ([String] -> b) -> Parser b +filesArgsSpec x = x <*> some (strArg "FILES..") -locArgSpec :: (String -> (Int, Int) -> b) -> Parser b +locArgSpec :: Parser (String -> (Int, Int) -> b) -> Parser b locArgSpec x = x - <$> strArg "FILE" + <*> strArg "FILE" <*> ( (,) <$> argument int (metavar "LINE") <*> argument int (metavar "COL") @@ -261,17 +261,21 @@ browseArgSpec = CmdBrowse <=> help "Qualify symbols" ) <*> some (strArg "MODULE") -debugComponentArgSpec = filesArgsSpec CmdDebugComponent -checkArgSpec = filesArgsSpec CmdCheck -expandArgSpec = filesArgsSpec CmdExpand +debugComponentArgSpec = filesArgsSpec (pure CmdDebugComponent) +checkArgSpec = filesArgsSpec (pure CmdCheck) +expandArgSpec = filesArgsSpec (pure CmdExpand) infoArgSpec = CmdInfo <$> strArg "FILE" <*> strArg "SYMBOL" -typeArgSpec = locArgSpec CmdType -autoArgSpec = locArgSpec CmdAuto -splitArgSpec = locArgSpec CmdSplit -sigArgSpec = locArgSpec CmdSig -refineArgSpec = locArgSpec CmdRefine <*> strArg "SYMBOL" +typeArgSpec = locArgSpec $ CmdType <$> + switch + $$ long "constraints" + <=> short 'c' + <=> help "Include constraints into type signature" +autoArgSpec = locArgSpec (pure CmdAuto) +splitArgSpec = locArgSpec (pure CmdSplit) +sigArgSpec = locArgSpec (pure CmdSig) +refineArgSpec = locArgSpec (pure CmdRefine) <*> strArg "SYMBOL" mapArgSpec = CmdMapFile <$> strArg "FILE" unmapArgSpec = CmdUnmapFile <$> strArg "FILE" legacyInteractiveArgSpec = const CmdLegacyInteractive <$> diff --git a/test/FileMappingSpec.hs b/test/FileMappingSpec.hs index d6ba1bb..9598fb6 100644 --- a/test/FileMappingSpec.hs +++ b/test/FileMappingSpec.hs @@ -134,13 +134,19 @@ spec = do let tdir = "test/data/file-mapping" res <- runD' tdir $ do loadMappedFile "File.hs" "File_Redir_Lint.hs" - types "File.hs" 4 12 + types False "File.hs" 4 12 res `shouldBe` "4 12 4 15 \"a -> a -> a\"\n4 12 4 17 \"a -> a\"\n4 12 4 19 \"a\"\n4 1 4 19 \"a -> a -> a\"\n" + it "shows types of the expression with constraints for redirected files" $ do + let tdir = "test/data/file-mapping" + res <- runD' tdir $ do + loadMappedFile "File.hs" "File_Redir_Lint.hs" + types True "File.hs" 4 12 + res `shouldBe` "4 12 4 15 \"a -> a -> a\"\n4 12 4 17 \"a -> a\"\n4 12 4 19 \"a\"\n4 1 4 19 \"Num a => a -> a -> a\"\n" it "shows types of the expression for in-memory files" $ do let tdir = "test/data/file-mapping" res <- runD' tdir $ do loadMappedFileSource "File.hs" "main = putStrLn \"Hello!\"" - types "File.hs" 1 14 + types False "File.hs" 1 14 res `shouldBe` "1 8 1 16 \"String -> IO ()\"\n1 8 1 25 \"IO ()\"\n1 1 1 25 \"IO ()\"\n" it "shows info for the expression for redirected files" $ do let tdir = "test/data/file-mapping" @@ -234,7 +240,7 @@ spec = do ,("Bar.hs", tmpdir "Bar_Redir.hs")] res <- run defaultOptions $ do mapM_ (uncurry loadMappedFile) fm - types "Bar.hs" 5 1 + types False "Bar.hs" 5 1 res `shouldBe` unlines ["5 1 5 20 \"[Char]\""] it "works with a memory module using TemplateHaskell" $ do srcFoo <- readFile "test/data/template-haskell/Foo.hs" @@ -244,5 +250,5 @@ spec = do ,("Bar.hs", srcBar)] res <- run defaultOptions $ do mapM_ (uncurry loadMappedFileSource) fm - types "Bar.hs" 5 1 + types False "Bar.hs" 5 1 res `shouldBe` unlines ["5 1 5 20 \"[Char]\""] diff --git a/test/InfoSpec.hs b/test/InfoSpec.hs index 3bdd5ae..d084b9a 100644 --- a/test/InfoSpec.hs +++ b/test/InfoSpec.hs @@ -19,17 +19,22 @@ spec = do describe "types" $ do it "shows types of the expression and its outers" $ do let tdir = "test/data/ghc-mod-check" - res <- runD' tdir $ types "lib/Data/Foo.hs" 9 5 + res <- runD' tdir $ types False "lib/Data/Foo.hs" 9 5 res `shouldBe` "9 5 11 40 \"Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n" + it "shows types of the expression with constraints and its outers" $ do + let tdir = "test/data/ghc-mod-check" + res <- runD' tdir $ types True "lib/Data/Foo.hs" 9 5 + res `shouldBe` "9 5 11 40 \"Num a => Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n" + it "works with a module using TemplateHaskell" $ do let tdir = "test/data/template-haskell" - res <- runD' tdir $ types "Bar.hs" 5 1 + res <- runD' tdir $ types False "Bar.hs" 5 1 res `shouldBe` unlines ["5 1 5 20 \"[Char]\""] it "works with a module that imports another module using TemplateHaskell" $ do let tdir = "test/data/template-haskell" - res <- runD' tdir $ types "ImportsTH.hs" 3 8 + res <- runD' tdir $ types False "ImportsTH.hs" 3 8 res `shouldBe` unlines ["3 8 3 16 \"String -> IO ()\"", "3 8 3 20 \"IO ()\"", "3 1 3 20 \"IO ()\""] describe "info" $ do