summaryrefslogtreecommitdiff
path: root/compiler/main
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/main')
-rw-r--r--compiler/main/DynFlags.hs4
-rw-r--r--compiler/main/GHC.hs7
-rw-r--r--compiler/main/HscTypes.lhs31
-rw-r--r--compiler/main/PprTyThing.hs40
-rw-r--r--compiler/main/TidyPgm.lhs1
5 files changed, 47 insertions, 36 deletions
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index e405aea4fe..7db0b9abe6 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -1979,14 +1979,13 @@ forceRecompile :: DynP ()
-- recompiled which probably isn't what you want
forceRecompile = do { dfs <- liftEwM getCmdLineState
; when (force_recomp dfs) (setDynFlag Opt_ForceRecomp) }
- where
+ where
force_recomp dfs = isOneShot (ghcMode dfs)
setVerboseCore2Core :: DynP ()
setVerboseCore2Core = do forceRecompile
setDynFlag Opt_D_verbose_core2core
upd (\dfs -> dfs { shouldDumpSimplPhase = Nothing })
-
setDumpSimplPhases :: String -> DynP ()
setDumpSimplPhases s = do forceRecompile
@@ -2127,7 +2126,6 @@ addImportPath, addLibraryPath, addIncludePath, addFrameworkPath :: FilePath -> D
addImportPath "" = upd (\s -> s{importPaths = []})
addImportPath p = upd (\s -> s{importPaths = importPaths s ++ splitPathList p})
-
addLibraryPath p =
upd (\s -> s{libraryPaths = libraryPaths s ++ splitPathList p})
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index a9e652d01f..44ec3ff26b 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -171,7 +171,7 @@ module GHC (
pprParendType, pprTypeApp,
Kind,
PredType,
- ThetaType, pprForAll, pprThetaArrow,
+ ThetaType, pprForAll, pprThetaArrow, pprThetaArrowTy,
-- ** Entities
TyThing(..),
@@ -256,7 +256,6 @@ import Type
import Coercion ( synTyConResKind )
import TcType hiding( typeKind )
import Id
-import Var
import TysPrim ( alphaTyVars )
import TyCon
import Class
@@ -388,7 +387,7 @@ runGhc :: Maybe FilePath -- ^ See argument to 'initGhcMonad'.
-> Ghc a -- ^ The action to perform.
-> IO a
runGhc mb_top_dir ghc = do
- ref <- newIORef undefined
+ ref <- newIORef (panic "empty session")
let session = Session ref
flip unGhc session $ do
initGhcMonad mb_top_dir
@@ -406,7 +405,7 @@ runGhcT :: (ExceptionMonad m, Functor m, MonadIO m) =>
-> GhcT m a -- ^ The action to perform.
-> m a
runGhcT mb_top_dir ghct = do
- ref <- liftIO $ newIORef undefined
+ ref <- liftIO $ newIORef (panic "empty session")
let session = Session ref
flip unGhcT session $ do
initGhcMonad mb_top_dir
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index 11f1a8bd8a..4d096d213a 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -54,13 +54,13 @@ module HscTypes (
-- * TyThings and type environments
TyThing(..),
- tyThingClass, tyThingTyCon, tyThingDataCon, tyThingId,
+ tyThingClass, tyThingTyCon, tyThingDataCon, tyThingId, tyThingCoAxiom,
implicitTyThings, isImplicitTyThing,
TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv,
extendTypeEnv, extendTypeEnvList, extendTypeEnvWithIds, lookupTypeEnv,
typeEnvElts, typeEnvClasses, typeEnvTyCons, typeEnvIds,
- typeEnvDataCons,
+ typeEnvDataCons, typeEnvCoAxioms,
-- * MonadThings
MonadThings(..),
@@ -1037,7 +1037,10 @@ implicitTyThings (ATyCon tc)
-- for each data constructor in order,
-- the contructor, worker, and (possibly) wrapper
concatMap (extras_plus . ADataCon) (tyConDataCons tc)
-
+
+implicitTyThings (ACoAxiom _cc)
+ = []
+
implicitTyThings (AClass cl)
= -- dictionary datatype:
-- [extras_plus:]
@@ -1069,10 +1072,10 @@ extras_plus thing = thing : implicitTyThings thing
-- add the implicit coercion tycon
implicitCoTyCon :: TyCon -> [TyThing]
implicitCoTyCon tc
- = map ATyCon . catMaybes $ [-- Just if newtype, Nothing if not
- newTyConCo_maybe tc,
+ = map ACoAxiom . catMaybes $ [-- Just if newtype, Nothing if not
+ newTyConCo_maybe tc,
-- Just if family instance, Nothing if not
- tyConFamilyCoercion_maybe tc]
+ tyConFamilyCoercion_maybe tc]
-- sortByOcc = sortBy (\ x -> \ y -> getOccName x < getOccName y)
@@ -1082,10 +1085,11 @@ implicitCoTyCon tc
-- of some other declaration, or it is generated implicitly by some
-- other declaration.
isImplicitTyThing :: TyThing -> Bool
-isImplicitTyThing (ADataCon _) = True
-isImplicitTyThing (AnId id) = isImplicitId id
-isImplicitTyThing (AClass _) = False
-isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc
+isImplicitTyThing (ADataCon {}) = True
+isImplicitTyThing (AnId id) = isImplicitId id
+isImplicitTyThing (AClass {}) = False
+isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc
+isImplicitTyThing (ACoAxiom {}) = True
extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv
extendTypeEnvWithIds env ids
@@ -1107,6 +1111,7 @@ emptyTypeEnv :: TypeEnv
typeEnvElts :: TypeEnv -> [TyThing]
typeEnvClasses :: TypeEnv -> [Class]
typeEnvTyCons :: TypeEnv -> [TyCon]
+typeEnvCoAxioms :: TypeEnv -> [CoAxiom]
typeEnvIds :: TypeEnv -> [Id]
typeEnvDataCons :: TypeEnv -> [DataCon]
lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing
@@ -1115,6 +1120,7 @@ emptyTypeEnv = emptyNameEnv
typeEnvElts env = nameEnvElts env
typeEnvClasses env = [cl | AClass cl <- typeEnvElts env]
typeEnvTyCons env = [tc | ATyCon tc <- typeEnvElts env]
+typeEnvCoAxioms env = [ax | ACoAxiom ax <- typeEnvElts env]
typeEnvIds env = [id | AnId id <- typeEnvElts env]
typeEnvDataCons env = [dc | ADataCon dc <- typeEnvElts env]
@@ -1170,6 +1176,11 @@ tyThingTyCon :: TyThing -> TyCon
tyThingTyCon (ATyCon tc) = tc
tyThingTyCon other = pprPanic "tyThingTyCon" (pprTyThing other)
+-- | Get the 'CoAxiom' from a 'TyThing' if it is a coercion axiom thing. Panics otherwise
+tyThingCoAxiom :: TyThing -> CoAxiom
+tyThingCoAxiom (ACoAxiom ax) = ax
+tyThingCoAxiom other = pprPanic "tyThingCoAxiom" (pprTyThing other)
+
-- | Get the 'Class' from a 'TyThing' if it is a class thing. Panics otherwise
tyThingClass :: TyThing -> Class
tyThingClass (AClass cls) = cls
diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs
index d859784fad..6d5344df74 100644
--- a/compiler/main/PprTyThing.hs
+++ b/compiler/main/PprTyThing.hs
@@ -23,8 +23,8 @@ import DataCon
import Id
import IdInfo
import TyCon
+import Coercion( pprCoAxiom )
import TcType
-import Var
import Name
import Outputable
import FastString
@@ -45,7 +45,7 @@ type ShowMe = Name -> Bool
----------------------------
-- | Pretty-prints a 'TyThing' with its defining location.
pprTyThingLoc :: PrintExplicitForalls -> TyThing -> SDoc
-pprTyThingLoc pefas tyThing
+pprTyThingLoc pefas tyThing
= showWithLoc loc (pprTyThing pefas tyThing)
where loc = pprNameLoc (GHC.getName tyThing)
@@ -57,10 +57,11 @@ ppr_ty_thing :: PrintExplicitForalls -> ShowMe -> TyThing -> SDoc
ppr_ty_thing pefas _ (AnId id) = pprId pefas id
ppr_ty_thing pefas _ (ADataCon dataCon) = pprDataConSig pefas dataCon
ppr_ty_thing pefas show_me (ATyCon tyCon) = pprTyCon pefas show_me tyCon
+ppr_ty_thing _ _ (ACoAxiom ax) = pprCoAxiom ax
ppr_ty_thing pefas show_me (AClass cls) = pprClass pefas show_me cls
-- | Pretty-prints a 'TyThing' in context: that is, if the entity
--- is a data constructor, record selector, or class method, then
+-- is a data constructor, record selector, or class method, then
-- the entity's parent declaration is pretty-printed with irrelevant
-- parts omitted.
pprTyThingInContext :: PrintExplicitForalls -> TyThing -> SDoc
@@ -77,7 +78,7 @@ pprTyThingInContextLoc pefas tyThing
(pprTyThingInContext pefas tyThing)
pprTyThingParent_maybe :: TyThing -> Maybe TyThing
--- (pprTyThingParent_maybe x) returns (Just p)
+-- (pprTyThingParent_maybe x) returns (Just p)
-- when pprTyThingInContext sould print a declaration for p
-- (albeit with some "..." in it) when asked to show x
pprTyThingParent_maybe (ADataCon dc) = Just (ATyCon (dataConTyCon dc))
@@ -94,6 +95,7 @@ pprTyThingHdr :: PrintExplicitForalls -> TyThing -> SDoc
pprTyThingHdr pefas (AnId id) = pprId pefas id
pprTyThingHdr pefas (ADataCon dataCon) = pprDataConSig pefas dataCon
pprTyThingHdr pefas (ATyCon tyCon) = pprTyConHdr pefas tyCon
+pprTyThingHdr _ (ACoAxiom ax) = pprCoAxiom ax
pprTyThingHdr pefas (AClass cls) = pprClassHdr pefas cls
pprTyConHdr :: PrintExplicitForalls -> TyCon -> SDoc
@@ -103,7 +105,7 @@ pprTyConHdr _ tyCon
| otherwise
= ptext keyword <+> opt_family <+> opt_stupid <+> ppr_bndr tyCon <+> hsep (map ppr vars)
where
- vars | GHC.isPrimTyCon tyCon ||
+ vars | GHC.isPrimTyCon tyCon ||
GHC.isFunTyCon tyCon = take (GHC.tyConArity tyCon) GHC.alphaTyVars
| otherwise = GHC.tyConTyVars tyCon
@@ -116,7 +118,7 @@ pprTyConHdr _ tyCon
| otherwise = empty
opt_stupid -- The "stupid theta" part of the declaration
- | isAlgTyCon tyCon = GHC.pprThetaArrow (tyConStupidTheta tyCon)
+ | isAlgTyCon tyCon = GHC.pprThetaArrowTy (tyConStupidTheta tyCon)
| otherwise = empty -- Returns 'empty' if null theta
pprDataConSig :: PrintExplicitForalls -> GHC.DataCon -> SDoc
@@ -125,14 +127,14 @@ pprDataConSig pefas dataCon
pprClassHdr :: PrintExplicitForalls -> GHC.Class -> SDoc
pprClassHdr _ cls
- = ptext (sLit "class") <+>
- GHC.pprThetaArrow (GHC.classSCTheta cls) <+>
+ = ptext (sLit "class") <+>
+ GHC.pprThetaArrowTy (GHC.classSCTheta cls) <+>
ppr_bndr cls <+>
hsep (map ppr tyVars) <+>
GHC.pprFundeps funDeps
where
(tyVars, funDeps) = GHC.classTvsFds cls
-
+
pprId :: PrintExplicitForalls -> Var -> SDoc
pprId pefas ident
= hang (ppr_bndr ident <+> dcolon)
@@ -147,7 +149,7 @@ pprTypeForUser :: PrintExplicitForalls -> GHC.Type -> SDoc
-- forall a. C a => forall b. Ord b => stuff
-- Then we want to display
-- (C a, Ord b) => stuff
-pprTypeForUser print_foralls ty
+pprTypeForUser print_foralls ty
| print_foralls = ppr tidy_ty
| otherwise = ppr (mkPhiTy ctxt ty')
where
@@ -160,7 +162,7 @@ pprTyCon pefas show_me tyCon
= if GHC.isFamilyTyCon tyCon
then pprTyConHdr pefas tyCon <+> dcolon <+>
pprTypeForUser pefas (GHC.synTyConResKind tyCon)
- else
+ else
let rhs_type = GHC.synTyConType tyCon
in hang (pprTyConHdr pefas tyCon <+> equals) 2 (pprTypeForUser pefas rhs_type)
| otherwise
@@ -168,7 +170,7 @@ pprTyCon pefas show_me tyCon
pprAlgTyCon :: PrintExplicitForalls -> ShowMe -> TyCon -> SDoc
pprAlgTyCon pefas show_me tyCon
- | gadt = pprTyConHdr pefas tyCon <+> ptext (sLit "where") $$
+ | gadt = pprTyConHdr pefas tyCon <+> ptext (sLit "where") $$
nest 2 (vcat (ppr_trim show_con datacons))
| otherwise = hang (pprTyConHdr pefas tyCon)
2 (add_bars (ppr_trim show_con datacons))
@@ -184,8 +186,8 @@ pprAlgTyCon pefas show_me tyCon
pprDataConDecl :: PrintExplicitForalls -> ShowMe -> Bool -> GHC.DataCon -> SDoc
pprDataConDecl pefas show_me gadt_style dataCon
| not gadt_style = ppr_fields tys_w_strs
- | otherwise = ppr_bndr dataCon <+> dcolon <+>
- sep [ pp_foralls, GHC.pprThetaArrow theta, pp_tau ]
+ | otherwise = ppr_bndr dataCon <+> dcolon <+>
+ sep [ pp_foralls, GHC.pprThetaArrowTy theta, pp_tau ]
-- Printing out the dataCon as a type signature, in GADT style
where
(forall_tvs, theta, tau) = tcSplitSigmaTy (GHC.dataConUserType dataCon)
@@ -214,15 +216,15 @@ pprDataConDecl pefas show_me gadt_style dataCon
| null labels
= ppr_bndr dataCon <+> sep (map pprParendBangTy fields)
| otherwise
- = ppr_bndr dataCon <+>
- braces (sep (punctuate comma (ppr_trim maybe_show_label
+ = ppr_bndr dataCon <+>
+ braces (sep (punctuate comma (ppr_trim maybe_show_label
(zip labels fields))))
pprClass :: PrintExplicitForalls -> ShowMe -> GHC.Class -> SDoc
pprClass pefas show_me cls
| null methods
= pprClassHdr pefas cls
- | otherwise
+ | otherwise
= hang (pprClassHdr pefas cls <+> ptext (sLit "where"))
2 (vcat (ppr_trim show_meth methods))
where
@@ -237,7 +239,7 @@ pprClassMethod pefas id
-- Here's the magic incantation to strip off the dictionary
-- from the class op type. Stolen from IfaceSyn.tyThingToIfaceDecl.
--
- -- It's important to tidy it *before* splitting it up, so that if
+ -- It's important to tidy it *before* splitting it up, so that if
-- we have class C a b where
-- op :: forall a. a -> b
-- then the inner forall on op gets renamed to a1, and we print
@@ -268,7 +270,7 @@ ppr_bndr :: GHC.NamedThing a => a -> SDoc
ppr_bndr a = GHC.pprParenSymName a
showWithLoc :: SDoc -> SDoc -> SDoc
-showWithLoc loc doc
+showWithLoc loc doc
= hang doc 2 (char '\t' <> comment <+> loc)
-- The tab tries to make them line up a bit
where
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index f23280bc19..b4296cbb07 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -1156,6 +1156,7 @@ cafRefs p (Case e _bndr _ alts) = fastOr (cafRefs p e) (cafRefss p) (rhssOfAlts
cafRefs p (Note _n e) = cafRefs p e
cafRefs p (Cast e _co) = cafRefs p e
cafRefs _ (Type _) = fastBool False
+cafRefs _ (Coercion _) = fastBool False
cafRefss :: VarEnv Id -> [Expr a] -> FastBool
cafRefss _ [] = fastBool False
View Lorry Controller Status