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

Merge branch 'release-5.6.0.0' into ghc-8

Browse Source
This commit is contained in:
Daniel Gröber
2016-05-17 20:21:33 +02:00
parent 9eeaf09095 32e81f63c7
commit 66c6379945
15 changed files with 197 additions and 60 deletions
Download Patch File Download Diff File Expand all files Collapse all files

3
Language/Haskell/GhcMod/Boot.hs
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 = [

15
Language/Haskell/GhcMod/Browse.hs
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"

23
Language/Haskell/GhcMod/CaseSplit.hs
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

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

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

6
Language/Haskell/GhcMod/Types.hs
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

3
Language/Haskell/GhcMod/World.hs
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