Merge branch 'release-5.6.0.0' into ghc-8

This commit is contained in:
Daniel Gröber 2016-05-17 20:21:33 +02:00
commit 66c6379945
15 changed files with 197 additions and 60 deletions

View File

@ -7,12 +7,13 @@ import Language.Haskell.GhcMod.Flag
import Language.Haskell.GhcMod.Lang
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Modules
import Language.Haskell.GhcMod.Types (defaultBrowseOpts)
-- | Printing necessary information for front-end booting.
boot :: IOish m => GhcModT m String
boot = concat <$> sequence ms
where
ms = [modules False, languages, flags, concat <$> mapM (browse (BrowseOpts False False False)) preBrowsedModules]
ms = [modules False, languages, flags, concat <$> mapM (browse defaultBrowseOpts) preBrowsedModules]
preBrowsedModules :: [String]
preBrowsedModules = [

View File

@ -11,6 +11,7 @@ import Data.List
import Data.Maybe
import FastString
import GHC
import HscTypes
import qualified GHC as G
import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Doc (showPage, styleUnqualified)
@ -96,14 +97,20 @@ showExport opt minfo e = do
mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` optBrowseQualified opt
mtype :: m (Maybe String)
mtype
| optBrowseDetailed opt = do
| optBrowseDetailed opt || optBrowseParents opt = do
tyInfo <- G.modInfoLookupName minfo e
-- If nothing found, load dependent module and lookup global
tyResult <- maybe (inOtherModule e) (return . Just) tyInfo
dflag <- G.getSessionDynFlags
return $ do
typeName <- tyResult >>= showThing dflag
(" :: " ++ typeName) `justIf` optBrowseDetailed opt
let sig = do
typeName <- tyResult >>= showThing dflag
(" :: " ++ typeName) `justIf` optBrowseDetailed opt
let parent = do
thing <- fmap getOccString $ tyResult >>= tyThingParent_maybe
(" -- from:" ++ thing) `justIf` optBrowseParents opt
return $ case concat $ catMaybes [sig, parent] of
[] -> Nothing
x -> Just x
| otherwise = return Nothing
formatOp nm
| null nm = error "formatOp"

View File

@ -29,6 +29,7 @@ import Language.Haskell.GhcMod.Logging
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils (withMappedFile)
import Language.Haskell.GhcMod.FileMapping (fileModSummaryWithMapping)
import Control.DeepSeq
----------------------------------------------------------------
-- CASE SPLITTING
@ -55,19 +56,17 @@ splits file lineNo colNo =
style <- getStyle
dflag <- G.getSessionDynFlags
modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl </> file)
whenFound' oopts (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> case x of
(SplitInfo varName bndLoc (varLoc,varT) _matches) -> do
let varName' = showName dflag style varName -- Convert name to string
whenFound' oopts (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> do
let (varName, bndLoc, (varLoc,varT))
| (SplitInfo vn bl vlvt _matches) <- x
= (vn, bl, vlvt)
| (TySplitInfo vn bl vlvt) <- x
= (vn, bl, vlvt)
varName' = showName dflag style varName -- Convert name to string
t <- withMappedFile file $ \file' ->
genCaseSplitTextFile file' (SplitToTextInfo varName' bndLoc varLoc $
getTyCons dflag style varName varT)
return (fourInts bndLoc, t)
(TySplitInfo varName bndLoc (varLoc,varT)) -> do
let varName' = showName dflag style varName -- Convert name to string
t <- withMappedFile file $ \file' ->
genCaseSplitTextFile file' (SplitToTextInfo varName' bndLoc varLoc $
getTyCons dflag style varName varT)
return (fourInts bndLoc, t)
return $!! (fourInts bndLoc, t)
where
handler (SomeException ex) = do
gmLog GmException "splits" $
@ -215,8 +214,8 @@ genCaseSplitTextFile file info = liftIO $ do
return $ getCaseSplitText (T.lines t) info
getCaseSplitText :: [T.Text] -> SplitToTextInfo -> String
getCaseSplitText t (SplitToTextInfo { sVarName = sVN, sBindingSpan = sBS
, sVarSpan = sVS, sTycons = sT }) =
getCaseSplitText t SplitToTextInfo{ sVarName = sVN, sBindingSpan = sBS
, sVarSpan = sVS, sTycons = sT } =
let bindingText = getBindingText t sBS
difference = srcSpanDifference sBS sVS
replaced = map (replaceVarWithTyCon bindingText difference sVN) sT

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
@ -607,3 +610,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

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)

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

View File

@ -71,7 +71,7 @@ data OutputStyle = LispStyle -- ^ S expression style.
newtype LineSeparator = LineSeparator String deriving (Show)
data FileMapping = FileMapping {fmPath :: FilePath, fmTemp :: Bool}
deriving Show
deriving (Eq, Show)
type FileMappingMap = Map FilePath FileMapping
@ -388,13 +388,15 @@ data BrowseOpts = BrowseOpts {
-- ^ If 'True', "browseWith" also returns operators.
, optBrowseDetailed :: Bool
-- ^ If 'True', "browseWith" also returns types.
, optBrowseParents :: Bool
-- ^ If 'True', "browseWith" also returns parents.
, optBrowseQualified :: Bool
-- ^ If 'True', "browseWith" will return fully qualified name
} deriving (Show)
-- | Default "BrowseOpts" instance
defaultBrowseOpts :: BrowseOpts
defaultBrowseOpts = BrowseOpts False False False
defaultBrowseOpts = BrowseOpts False False False False
mkLabel ''GhcModCaches
mkLabel ''GhcModState

View File

@ -19,6 +19,7 @@ data World = World {
, worldCabalFile :: Maybe TimedFile
, worldCabalConfig :: Maybe TimedFile
, worldCabalSandboxConfig :: Maybe TimedFile
, worldMappedFiles :: FileMappingMap
} deriving (Eq)
timedPackageCaches :: IOish m => GhcModT m [TimedFile]
@ -34,12 +35,14 @@ getCurrentWorld = do
mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl
mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl)
mCabalSandboxConfig <- liftIO $ timeMaybe (sandboxConfigFile crdl)
mFileMap <- getMMappedFiles
return World {
worldPackageCaches = pkgCaches
, worldCabalFile = mCabalFile
, worldCabalConfig = mCabalConfig
, worldCabalSandboxConfig = mCabalSandboxConfig
, worldMappedFiles = mFileMap
}
didWorldChange :: IOish m => World -> GhcModT m Bool

View File

@ -165,7 +165,7 @@ Library
, bytestring < 0.11
, binary < 0.9 && >= 0.5.1.0
, containers < 0.6
, cabal-helper < 0.8 && >= 0.7.0.1
, cabal-helper < 0.8 && >= 0.7.1.0
, deepseq < 1.5
, directory < 1.3
, filepath < 1.5

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

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")
@ -255,23 +255,31 @@ browseArgSpec = CmdBrowse
$$ long "detailed"
<=> short 'd'
<=> help "Print symbols with accompanying signature"
<*> switch
$$ long "parents"
<=> short 'p'
<=> help "Print symbols parents"
<*> switch
$$ long "qualified"
<=> short 'q'
<=> 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 <$>

View File

@ -39,3 +39,8 @@ spec = do
res `shouldBe` "38 21 38 59"++
" \"mlReverse' Nil accum = _mlReverse_body\NUL"++
" mlReverse' (Cons xs'1 xs'2) accum = _mlReverse_body\"\n"
it "doesn't crash when source doesn't make sense" $
withDirectory_ "test/data/case-split" $ do
res <- runD $ splits "Crash.hs" 4 6
res `shouldBe` []

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

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

View File

@ -0,0 +1,4 @@
module Crash where
test :: Maybe a
test x = undefined