hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'type-constraints' of https://github.com/atom-haskell/ghc-mod into release-5.6.0.0

Browse Source
This commit is contained in:
Daniel Gröber 2016-05-14 21:35:21 +02:00
commit f994893c58
7 changed files with 152 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
Language/Haskell/GhcMod/Gap.hs
View File

@ -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<TypeChecker) :: PostTcType -> Bool
#endif
fixity = const (stage<Renamer) :: GHC.Fixity -> Bool
(r, s') = q x s0

26
Language/Haskell/GhcMod/Info.hs
View File

@ -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)

89
Language/Haskell/GhcMod/SrcUtils.hs
View File

@ -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

2
src/GHCMod.hs
View File

@ -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

30
src/GHCMod/Options/Commands.hs
View File

@ -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 <$>

14
test/FileMappingSpec.hs
View File

@ -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]\""]

11
test/InfoSpec.hs
View File

@ -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