ghc-mod/Language/Haskell/GhcMod/Gap.hs

406 lines
11 KiB
Haskell
Raw Normal View History

{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP #-}
2012-02-14 07:09:53 +00:00
2013-05-17 01:00:01 +00:00
module Language.Haskell.GhcMod.Gap (
Language.Haskell.GhcMod.Gap.ClsInst
, mkTarget
2013-03-12 13:15:23 +00:00
, withStyle
, setLogAction
2012-02-14 07:09:53 +00:00
, getSrcSpan
, getSrcFile
2014-04-27 12:26:03 +00:00
, withContext
2012-02-14 07:09:53 +00:00
, fOptions
, toStringBuffer
, showSeverityCaption
, setCabalPkg
2014-04-23 01:41:28 +00:00
, setHideAllPackages
, addPackageFlags
2014-04-26 04:21:22 +00:00
, setDeferTypeErrors
2014-06-09 08:30:33 +00:00
, setWarnTypedHoles
2014-04-26 04:21:22 +00:00
, setDumpSplices
, isDumpSplices
, filterOutChildren
, infoThing
, pprInfo
, HasType(..)
2013-11-19 03:28:59 +00:00
, errorMsgSpan
2013-11-19 03:35:42 +00:00
, typeForUser
, nameForUser
, occNameForUser
2013-11-19 03:54:08 +00:00
, deSugar
, showDocWith
2014-02-06 12:34:40 +00:00
, GapThing(..)
, fromTyThing
2014-04-27 12:26:03 +00:00
, fileModSummary
2014-04-28 05:36:55 +00:00
, WarnFlags
, emptyWarnFlags
2012-02-14 07:09:53 +00:00
) where
import Control.Applicative hiding (empty)
2014-03-27 07:02:16 +00:00
import Control.Monad (filterM)
import CoreSyn (CoreExpr)
import Data.List (intersperse)
import Data.Maybe (catMaybes)
import Data.Time.Clock (UTCTime)
2014-02-06 13:09:00 +00:00
import DataCon (dataConRepType)
2013-11-19 03:54:08 +00:00
import Desugar (deSugarExpr)
2012-02-14 07:09:53 +00:00
import DynFlags
import ErrUtils
2012-02-14 07:09:53 +00:00
import FastString
2013-07-14 08:07:30 +00:00
import HscTypes
2013-05-17 01:00:01 +00:00
import Language.Haskell.GhcMod.GHCChoice
import Language.Haskell.GhcMod.Types
2013-07-14 08:07:30 +00:00
import NameSet
import OccName
2012-02-14 07:09:53 +00:00
import Outputable
2013-07-14 08:07:30 +00:00
import PprTyThing
2012-02-14 07:09:53 +00:00
import StringBuffer
import TcType
2014-02-06 13:09:00 +00:00
import Var (varType)
2012-02-14 07:09:53 +00:00
import qualified InstEnv
import qualified Pretty
import qualified StringBuffer as SB
2014-04-28 05:13:25 +00:00
2014-04-28 05:04:18 +00:00
#if __GLASGOW_HASKELL__ >= 708
import FamInstEnv
import ConLike (ConLike(..))
2014-02-06 13:12:07 +00:00
import PatSyn (patSynType)
2014-01-08 00:55:06 +00:00
#else
import TcRnTypes
#endif
#if __GLASGOW_HASKELL__ >= 706
import GHC hiding (ClsInst)
#else
import GHC hiding (Instance)
2013-07-02 09:29:08 +00:00
import Control.Arrow hiding ((<+>))
import Data.Convertible
#endif
2014-04-28 05:36:55 +00:00
#if __GLASGOW_HASKELL__ >= 704
import qualified Data.IntSet as I (IntSet, empty)
#endif
----------------------------------------------------------------
----------------------------------------------------------------
--
#if __GLASGOW_HASKELL__ >= 706
type ClsInst = InstEnv.ClsInst
#else
type ClsInst = InstEnv.Instance
#endif
mkTarget :: TargetId -> Bool -> Maybe (SB.StringBuffer, UTCTime) -> Target
#if __GLASGOW_HASKELL__ >= 706
mkTarget = Target
#else
mkTarget tid allowObjCode = Target tid allowObjCode . (fmap . second) convert
#endif
----------------------------------------------------------------
----------------------------------------------------------------
2013-03-12 13:15:23 +00:00
withStyle :: DynFlags -> PprStyle -> SDoc -> Pretty.Doc
#if __GLASGOW_HASKELL__ >= 706
2013-03-12 13:15:23 +00:00
withStyle = withPprStyleDoc
#else
2013-03-12 13:15:23 +00:00
withStyle _ = withPprStyleDoc
#endif
setLogAction :: DynFlags
-> (DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ())
-> DynFlags
setLogAction df f =
#if __GLASGOW_HASKELL__ >= 706
df { log_action = f }
#else
df { log_action = f df }
#endif
showDocWith :: DynFlags -> Pretty.Mode -> Pretty.Doc -> String
2014-04-28 05:04:18 +00:00
#if __GLASGOW_HASKELL__ >= 708
-- Pretty.showDocWith disappeard.
-- https://github.com/ghc/ghc/commit/08a3536e4246e323fbcd8040e0b80001950fe9bc
showDocWith dflags mode = Pretty.showDoc mode (pprCols dflags)
#else
showDocWith _ = Pretty.showDocWith
#endif
2012-02-14 07:09:53 +00:00
----------------------------------------------------------------
----------------------------------------------------------------
getSrcSpan :: SrcSpan -> Maybe (Int,Int,Int,Int)
#if __GLASGOW_HASKELL__ >= 702
getSrcSpan (RealSrcSpan spn)
#else
getSrcSpan spn | isGoodSrcSpan spn
#endif
= Just (srcSpanStartLine spn
, srcSpanStartCol spn
, srcSpanEndLine spn
, srcSpanEndCol spn)
getSrcSpan _ = Nothing
getSrcFile :: SrcSpan -> Maybe String
#if __GLASGOW_HASKELL__ >= 702
getSrcFile (RealSrcSpan spn) = Just . unpackFS . srcSpanFile $ spn
#else
getSrcFile spn | isGoodSrcSpan spn = Just . unpackFS . srcSpanFile $ spn
#endif
getSrcFile _ = Nothing
----------------------------------------------------------------
toStringBuffer :: [String] -> Ghc StringBuffer
#if __GLASGOW_HASKELL__ >= 702
toStringBuffer = return . stringToStringBuffer . unlines
#else
toStringBuffer = liftIO . stringToStringBuffer . unlines
#endif
----------------------------------------------------------------
fOptions :: [String]
2014-04-28 05:36:46 +00:00
#if __GLASGOW_HASKELL__ >= 704
2012-06-07 06:56:55 +00:00
fOptions = [option | (option,_,_) <- fFlags]
++ [option | (option,_,_) <- fWarningFlags]
++ [option | (option,_,_) <- fLangFlags]
2014-04-28 05:13:25 +00:00
#else
2012-02-14 07:09:53 +00:00
fOptions = [option | (option,_,_,_) <- fFlags]
++ [option | (option,_,_,_) <- fWarningFlags]
++ [option | (option,_,_,_) <- fLangFlags]
2012-02-14 07:09:53 +00:00
#endif
----------------------------------------------------------------
----------------------------------------------------------------
2014-04-27 12:26:03 +00:00
fileModSummary :: FilePath -> Ghc ModSummary
fileModSummary file = do
mss <- getModuleGraph
let [ms] = filter (\m -> ml_hs_file (ms_location m) == Just file) mss
return ms
withContext :: Ghc a -> Ghc a
withContext action = gbracket setup teardown body
where
setup = getContext
2014-04-28 00:28:57 +00:00
teardown = setCtx
2014-04-27 12:26:03 +00:00
body _ = do
2014-04-28 00:00:03 +00:00
topImports >>= setCtx
2014-04-27 12:26:03 +00:00
action
topImports = do
mss <- getModuleGraph
2014-04-28 02:26:06 +00:00
ms <- map modName <$> filterM isTop mss
#if __GLASGOW_HASKELL__ >= 704
return ms
#else
return (ms,[])
#endif
2014-04-28 00:00:03 +00:00
isTop mos = lookupMod mos ||> returnFalse
lookupMod mos = lookupModule (ms_mod_name mos) Nothing >> return True
returnFalse = return False
#if __GLASGOW_HASKELL__ >= 706
2014-04-28 00:00:03 +00:00
modName = IIModule . moduleName . ms_mod
setCtx = setContext
2014-04-27 12:26:03 +00:00
#elif __GLASGOW_HASKELL__ >= 704
2014-04-28 00:00:03 +00:00
modName = IIModule . ms_mod
setCtx = setContext
2012-02-14 07:09:53 +00:00
#else
2014-04-28 00:00:03 +00:00
modName = ms_mod
2014-04-28 02:26:06 +00:00
setCtx = uncurry setContext
2012-02-14 07:09:53 +00:00
#endif
showSeverityCaption :: Severity -> String
#if __GLASGOW_HASKELL__ >= 706
showSeverityCaption SevWarning = "Warning: "
showSeverityCaption _ = ""
#else
showSeverityCaption = const ""
#endif
----------------------------------------------------------------
----------------------------------------------------------------
setCabalPkg :: DynFlags -> DynFlags
2014-04-28 05:04:18 +00:00
#if __GLASGOW_HASKELL__ >= 708
setCabalPkg dflag = gopt_set dflag Opt_BuildingCabalPackage
#else
setCabalPkg dflag = dopt_set dflag Opt_BuildingCabalPackage
#endif
----------------------------------------------------------------
2014-04-23 01:41:28 +00:00
setHideAllPackages :: DynFlags -> DynFlags
2014-04-28 05:04:18 +00:00
#if __GLASGOW_HASKELL__ >= 708
2014-04-26 04:21:22 +00:00
setHideAllPackages df = gopt_set df Opt_HideAllPackages
2013-07-14 08:07:30 +00:00
#else
2014-04-26 04:21:22 +00:00
setHideAllPackages df = dopt_set df Opt_HideAllPackages
2013-07-14 08:07:30 +00:00
#endif
2014-04-23 01:41:28 +00:00
addPackageFlags :: [Package] -> DynFlags -> DynFlags
addPackageFlags pkgs df =
df { packageFlags = packageFlags df ++ expose `map` pkgs }
where
expose pkg = ExposePackageId $ showPkgId pkg
2014-04-26 04:21:22 +00:00
----------------------------------------------------------------
setDumpSplices :: DynFlags -> DynFlags
setDumpSplices dflag = dopt_set dflag Opt_D_dump_splices
isDumpSplices :: DynFlags -> Bool
isDumpSplices dflag = dopt Opt_D_dump_splices dflag
----------------------------------------------------------------
setDeferTypeErrors :: DynFlags -> DynFlags
2014-04-28 05:04:18 +00:00
#if __GLASGOW_HASKELL__ >= 708
2014-04-26 04:21:22 +00:00
setDeferTypeErrors dflag = gopt_set dflag Opt_DeferTypeErrors
#elif __GLASGOW_HASKELL__ >= 706
setDeferTypeErrors dflag = dopt_set dflag Opt_DeferTypeErrors
#else
setDeferTypeErrors = id
#endif
2014-06-09 08:30:33 +00:00
setWarnTypedHoles :: DynFlags -> DynFlags
#if __GLASGOW_HASKELL__ >= 708
setWarnTypedHoles dflag = wopt_set dflag Opt_WarnTypedHoles
#else
setWarnTypedHoles = id
2014-04-26 04:21:22 +00:00
#endif
----------------------------------------------------------------
----------------------------------------------------------------
class HasType a where
getType :: GhcMonad m => TypecheckedModule -> a -> m (Maybe (SrcSpan, Type))
instance HasType (LHsBind Id) where
2014-04-28 05:04:18 +00:00
#if __GLASGOW_HASKELL__ >= 708
getType _ (L spn FunBind{fun_matches = MG _ in_tys out_typ}) = return $ Just (spn, typ)
where typ = mkFunTys in_tys out_typ
2013-07-14 08:07:30 +00:00
#else
getType _ (L spn FunBind{fun_matches = MatchGroup _ typ}) = return $ Just (spn, typ)
2013-07-14 08:07:30 +00:00
#endif
getType _ _ = return Nothing
----------------------------------------------------------------
----------------------------------------------------------------
-- from ghc/InteractiveUI.hs
filterOutChildren :: (a -> TyThing) -> [a] -> [a]
filterOutChildren get_thing xs
= [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
where
implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
2013-07-14 08:07:30 +00:00
infoThing :: String -> Ghc SDoc
infoThing str = do
names <- parseName str
2014-04-28 05:04:18 +00:00
#if __GLASGOW_HASKELL__ >= 708
mb_stuffs <- mapM (getInfo False) names
let filtered = filterOutChildren (\(t,_f,_i,_fam) -> t) (catMaybes mb_stuffs)
2013-07-14 08:07:30 +00:00
#else
mb_stuffs <- mapM getInfo names
let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
#endif
2013-07-14 08:07:30 +00:00
return $ vcat (intersperse (text "") $ map (pprInfo False) filtered)
2014-04-28 05:04:18 +00:00
#if __GLASGOW_HASKELL__ >= 708
2013-11-12 23:44:34 +00:00
pprInfo :: Bool -> (TyThing, GHC.Fixity, [ClsInst], [FamInst]) -> SDoc
pprInfo _ (thing, fixity, insts, famInsts)
= pprTyThingInContextLoc thing
$$ show_fixity fixity
$$ InstEnv.pprInstances insts
$$ pprFamInsts famInsts
where
show_fixity fx
| fx == defaultFixity = Outputable.empty
| otherwise = ppr fx <+> ppr (getName thing)
2013-07-14 08:07:30 +00:00
#else
pprInfo :: PrintExplicitForalls -> (TyThing, GHC.Fixity, [ClsInst]) -> SDoc
pprInfo pefas (thing, fixity, insts)
= pprTyThingInContextLoc pefas thing
$$ show_fixity fixity
$$ vcat (map pprInstance insts)
where
show_fixity fx
| fx == defaultFixity = Outputable.empty
| otherwise = ppr fx <+> ppr (getName thing)
#endif
2013-11-12 23:44:34 +00:00
2013-11-19 03:28:59 +00:00
----------------------------------------------------------------
----------------------------------------------------------------
errorMsgSpan :: ErrMsg -> SrcSpan
2014-04-28 05:04:18 +00:00
#if __GLASGOW_HASKELL__ >= 708
2013-11-19 03:28:59 +00:00
errorMsgSpan = errMsgSpan
#else
errorMsgSpan = head . errMsgSpans
#endif
2013-11-19 03:35:42 +00:00
typeForUser :: Type -> SDoc
2014-04-28 05:04:18 +00:00
#if __GLASGOW_HASKELL__ >= 708
2013-11-19 03:35:42 +00:00
typeForUser = pprTypeForUser
#else
typeForUser = pprTypeForUser False
#endif
2013-11-19 03:54:08 +00:00
nameForUser :: Name -> SDoc
#if __GLASGOW_HASKELL__ >= 708
nameForUser = pprOccName . getOccName
#else
nameForUser = pprOccName False . getOccName
#endif
occNameForUser :: OccName -> SDoc
#if __GLASGOW_HASKELL__ >= 708
occNameForUser = pprOccName
#else
occNameForUser = pprOccName False
#endif
2013-11-19 03:54:08 +00:00
deSugar :: TypecheckedModule -> LHsExpr Id -> HscEnv
2014-03-27 07:02:16 +00:00
-> IO (Maybe CoreExpr)
2014-04-28 05:04:18 +00:00
#if __GLASGOW_HASKELL__ >= 708
2014-01-08 00:55:06 +00:00
deSugar _ e hs_env = snd <$> deSugarExpr hs_env e
2013-11-19 03:54:08 +00:00
#else
deSugar tcm e hs_env = snd <$> deSugarExpr hs_env modu rn_env ty_env e
where
modu = ms_mod $ pm_mod_summary $ tm_parsed_module tcm
tcgEnv = fst $ tm_internals_ tcm
rn_env = tcg_rdr_env tcgEnv
ty_env = tcg_type_env tcgEnv
#endif
2014-02-06 12:34:40 +00:00
----------------------------------------------------------------
----------------------------------------------------------------
2014-02-06 13:09:00 +00:00
data GapThing = GtA Type | GtT TyCon | GtN
2014-02-06 12:34:40 +00:00
fromTyThing :: TyThing -> GapThing
2014-02-06 13:09:00 +00:00
fromTyThing (AnId i) = GtA $ varType i
2014-04-28 05:04:18 +00:00
#if __GLASGOW_HASKELL__ >= 708
2014-02-06 13:09:00 +00:00
fromTyThing (AConLike (RealDataCon d)) = GtA $ dataConRepType d
fromTyThing (AConLike (PatSynCon p)) = GtA $ patSynType p
#else
2014-02-06 13:09:00 +00:00
fromTyThing (ADataCon d) = GtA $ dataConRepType d
#endif
fromTyThing (ATyCon t) = GtT t
fromTyThing _ = GtN
2014-04-28 05:36:55 +00:00
----------------------------------------------------------------
----------------------------------------------------------------
#if __GLASGOW_HASKELL__ >= 704
type WarnFlags = I.IntSet
emptyWarnFlags :: WarnFlags
emptyWarnFlags = I.empty
#else
type WarnFlags = [WarningFlag]
emptyWarnFlags :: WarnFlags
emptyWarnFlags = []
#endif