diff options
| author | Alan Zimmerman <alan.zimm@gmail.com> | 2017-05-19 14:56:09 +0200 |
|---|---|---|
| committer | Alan Zimmerman <alan.zimm@gmail.com> | 2017-06-06 00:16:20 +0200 |
| commit | 8e6ec0fa7431b0454b09c0011a615f0845df1198 (patch) | |
| tree | d6b3604e0ceac3d81d0510669f7ccce9a2bf3ae2 | |
| parent | c9eb4385aad248118650725b7b699bb97ee21c0d (diff) | |
| download | haskell-8e6ec0fa7431b0454b09c0011a615f0845df1198.tar.gz | |
Udate hsSyn AST to use Trees that Grow
Summary:
See https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow
This commit prepares the ground for a full extensible AST, by replacing the type
parameter for the hsSyn data types with a set of indices into type families,
data GhcPs -- ^ Index for GHC parser output
data GhcRn -- ^ Index for GHC renamer output
data GhcTc -- ^ Index for GHC typechecker output
These are now used instead of `RdrName`, `Name` and `Id`/`TcId`/`Var`
Where the original name type is required in a polymorphic context, this is
accessible via the IdP type family, defined as
type family IdP p
type instance IdP GhcPs = RdrName
type instance IdP GhcRn = Name
type instance IdP GhcTc = Id
These types are declared in the new 'hsSyn/HsExtension.hs' module.
To gain a better understanding of the extension mechanism, it has been applied
to `HsLit` only, also replacing the `SourceText` fields in them with extension
types.
To preserve extension generality, a type class is introduced to capture the
`SourceText` interface, which must be honoured by all of the extension points
which originally had a `SourceText`. The class is defined as
class HasSourceText a where
-- Provide setters to mimic existing constructors
noSourceText :: a
sourceText :: String -> a
setSourceText :: SourceText -> a
getSourceText :: a -> SourceText
And the constraint is captured in `SourceTextX`, which is a constraint type
listing all the extension points that make use of the class.
Updating Haddock submodule to match.
Test Plan: ./validate
Reviewers: simonpj, shayan-najd, goldfire, austin, bgamari
Subscribers: rwbarton, thomie, mpickering
Differential Revision: https://phabricator.haskell.org/D3609
111 files changed, 3940 insertions, 3347 deletions
diff --git a/compiler/backpack/BkpSyn.hs b/compiler/backpack/BkpSyn.hs index a7e4db30dd..842c0df49d 100644 --- a/compiler/backpack/BkpSyn.hs +++ b/compiler/backpack/BkpSyn.hs @@ -18,7 +18,6 @@ module BkpSyn ( ) where import HsSyn -import RdrName import SrcLoc import Outputable import Module @@ -61,7 +60,7 @@ type LHsUnit n = Located (HsUnit n) -- or an include. data HsDeclType = ModuleD | SignatureD data HsUnitDecl n - = DeclD HsDeclType (Located ModuleName) (Maybe (Located (HsModule RdrName))) + = DeclD HsDeclType (Located ModuleName) (Maybe (Located (HsModule GhcPs))) | IncludeD (IncludeDecl n) type LHsUnitDecl n = Located (HsUnitDecl n) diff --git a/compiler/backpack/DriverBkp.hs b/compiler/backpack/DriverBkp.hs index a82e66b7b0..6123bc8133 100644 --- a/compiler/backpack/DriverBkp.hs +++ b/compiler/backpack/DriverBkp.hs @@ -709,7 +709,7 @@ summariseRequirement pn mod_name = do summariseDecl :: PackageName -> HscSource -> Located ModuleName - -> Maybe (Located (HsModule RdrName)) + -> Maybe (Located (HsModule GhcPs)) -> BkpM ModSummary summariseDecl pn hsc_src (L _ modname) (Just hsmod) = hsModuleToModSummary pn hsc_src modname hsmod summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing @@ -736,7 +736,7 @@ summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing hsModuleToModSummary :: PackageName -> HscSource -> ModuleName - -> Located (HsModule RdrName) + -> Located (HsModule GhcPs) -> BkpM ModSummary hsModuleToModSummary pn hsc_src modname hsmod = do diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs index 8234cccb5c..19bdba658f 100644 --- a/compiler/deSugar/Check.hs +++ b/compiler/deSugar/Check.hs @@ -134,7 +134,7 @@ data PmPat :: PatTy -> * where , pm_con_dicts :: [EvVar] , pm_con_args :: [PmPat t] } -> PmPat t -- For PmCon arguments' meaning see @ConPatOut@ in hsSyn/HsPat.hs - PmVar :: { pm_var_id :: Id } -> PmPat t + PmVar :: { pm_var_id :: Id } -> PmPat t PmLit :: { pm_lit_lit :: PmLit } -> PmPat t -- See Note [Literals in PmPat] PmNLit :: { pm_lit_id :: Id , pm_lit_not :: [PmLit] } -> PmPat 'VA @@ -254,9 +254,9 @@ instance Monoid PartialResult where data PmResult = PmResult { pmresultProvenance :: Provenance - , pmresultRedundant :: [Located [LPat Id]] + , pmresultRedundant :: [Located [LPat GhcTc]] , pmresultUncovered :: UncoveredCandidates - , pmresultInaccessible :: [Located [LPat Id]] } + , pmresultInaccessible :: [Located [LPat GhcTc]] } -- | Either a list of patterns that are not covered, or their type, in case we -- have no patterns at hand. Not having patterns at hand can arise when @@ -289,7 +289,7 @@ uncoveredWithTy ty = PmResult FromBuiltin [] (TypeOfUncovered ty) [] -} -- | Check a single pattern binding (let) -checkSingle :: DynFlags -> DsMatchContext -> Id -> Pat Id -> DsM () +checkSingle :: DynFlags -> DsMatchContext -> Id -> Pat GhcTc -> DsM () checkSingle dflags ctxt@(DsMatchContext _ locn) var p = do tracePmD "checkSingle" (vcat [ppr ctxt, ppr var, ppr p]) mb_pm_res <- tryM (getResult (checkSingle' locn var p)) @@ -298,7 +298,7 @@ checkSingle dflags ctxt@(DsMatchContext _ locn) var p = do Right res -> dsPmWarn dflags ctxt res -- | Check a single pattern binding (let) -checkSingle' :: SrcSpan -> Id -> Pat Id -> PmM PmResult +checkSingle' :: SrcSpan -> Id -> Pat GhcTc -> PmM PmResult checkSingle' locn var p = do liftD resetPmIterDs -- set the iter-no to zero fam_insts <- liftD dsGetFamInstEnvs @@ -316,7 +316,7 @@ checkSingle' locn var p = do -- | Check a matchgroup (case, functions, etc.) checkMatches :: DynFlags -> DsMatchContext - -> [Id] -> [LMatch Id (LHsExpr Id)] -> DsM () + -> [Id] -> [LMatch GhcTc (LHsExpr GhcTc)] -> DsM () checkMatches dflags ctxt vars matches = do tracePmD "checkMatches" (hang (vcat [ppr ctxt , ppr vars @@ -334,7 +334,7 @@ checkMatches dflags ctxt vars matches = do -- | Check a matchgroup (case, functions, etc.). To be called on a non-empty -- list of matches. For empty case expressions, use checkEmptyCase' instead. -checkMatches' :: [Id] -> [LMatch Id (LHsExpr Id)] -> PmM PmResult +checkMatches' :: [Id] -> [LMatch GhcTc (LHsExpr GhcTc)] -> PmM PmResult checkMatches' vars matches | null matches = panic "checkMatches': EmptyCase" | otherwise = do @@ -348,11 +348,11 @@ checkMatches' vars matches , pmresultUncovered = UncoveredPatterns us , pmresultInaccessible = map hsLMatchToLPats ds } where - go :: [LMatch Id (LHsExpr Id)] -> Uncovered + go :: [LMatch GhcTc (LHsExpr GhcTc)] -> Uncovered -> PmM (Provenance - , [LMatch Id (LHsExpr Id)] + , [LMatch GhcTc (LHsExpr GhcTc)] , Uncovered - , [LMatch Id (LHsExpr Id)]) + , [LMatch GhcTc (LHsExpr GhcTc)]) go [] missing = return (mempty, [], missing, []) go (m:ms) missing = do tracePm "checMatches': go" (ppr m $$ ppr missing) @@ -544,14 +544,14 @@ mkListPatVec ty xs ys = [PmCon { pm_con_con = RealDataCon consDataCon {-# INLINE mkListPatVec #-} -- | Create a (non-overloaded) literal pattern -mkLitPattern :: HsLit -> Pattern +mkLitPattern :: HsLit GhcTc -> Pattern mkLitPattern lit = PmLit { pm_lit_lit = PmSLit lit } {-# INLINE mkLitPattern #-} -- ----------------------------------------------------------------------- -- * Transform (Pat Id) into of (PmPat Id) -translatePat :: FamInstEnvs -> Pat Id -> DsM PatVec +translatePat :: FamInstEnvs -> Pat GhcTc -> DsM PatVec translatePat fam_insts pat = case pat of WildPat ty -> mkPmVars [ty] VarPat id -> return [PmVar (unLoc id)] @@ -661,15 +661,16 @@ translatePat fam_insts pat = case pat of -- | Translate an overloaded literal (see `tidyNPat' in deSugar/MatchLit.hs) translateNPat :: FamInstEnvs - -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> Type -> DsM PatVec + -> HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> Type + -> DsM PatVec translateNPat fam_insts (OverLit val False _ ty) mb_neg outer_ty | not type_change, isStringTy ty, HsIsString src s <- val, Nothing <- mb_neg = translatePat fam_insts (LitPat (HsString src s)) | not type_change, isIntTy ty, HsIntegral i <- val = translatePat fam_insts (LitPat $ case mb_neg of - Nothing -> HsInt i - Just _ -> HsInt (negateIntegralLit i)) + Nothing -> HsInt def i + Just _ -> HsInt def (negateIntegralLit i)) | not type_change, isWordTy ty, HsIntegral i <- val = translatePat fam_insts (LitPat $ case mb_neg of @@ -684,12 +685,12 @@ translateNPat _ ol mb_neg _ -- | Translate a list of patterns (Note: each pattern is translated -- to a pattern vector but we do not concatenate the results). -translatePatVec :: FamInstEnvs -> [Pat Id] -> DsM [PatVec] +translatePatVec :: FamInstEnvs -> [Pat GhcTc] -> DsM [PatVec] translatePatVec fam_insts pats = mapM (translatePat fam_insts) pats -- | Translate a constructor pattern translateConPatVec :: FamInstEnvs -> [Type] -> [TyVar] - -> ConLike -> HsConPatDetails Id -> DsM PatVec + -> ConLike -> HsConPatDetails GhcTc -> DsM PatVec translateConPatVec fam_insts _univ_tys _ex_tvs _ (PrefixCon ps) = concat <$> translatePatVec fam_insts (map unLoc ps) translateConPatVec fam_insts _univ_tys _ex_tvs _ (InfixCon p1 p2) @@ -744,13 +745,14 @@ translateConPatVec fam_insts univ_tys ex_tvs c (RecCon (HsRecFields fs _)) | otherwise = subsetOf (x:xs) ys -- Translate a single match -translateMatch :: FamInstEnvs -> LMatch Id (LHsExpr Id) -> DsM (PatVec,[PatVec]) +translateMatch :: FamInstEnvs -> LMatch GhcTc (LHsExpr GhcTc) + -> DsM (PatVec,[PatVec]) translateMatch fam_insts (L _ (Match _ lpats _ grhss)) = do pats' <- concat <$> translatePatVec fam_insts pats guards' <- mapM (translateGuards fam_insts) guards return (pats', guards') where - extractGuards :: LGRHS Id (LHsExpr Id) -> [GuardStmt Id] + extractGuards :: LGRHS GhcTc (LHsExpr GhcTc) -> [GuardStmt GhcTc] extractGuards (L _ (GRHS gs _)) = map unLoc gs pats = map unLoc lpats @@ -760,7 +762,7 @@ translateMatch fam_insts (L _ (Match _ lpats _ grhss)) = do -- * Transform source guards (GuardStmt Id) to PmPats (Pattern) -- | Translate a list of guard statements to a pattern vector -translateGuards :: FamInstEnvs -> [GuardStmt Id] -> DsM PatVec +translateGuards :: FamInstEnvs -> [GuardStmt GhcTc] -> DsM PatVec translateGuards fam_insts guards = do all_guards <- concat <$> mapM (translateGuard fam_insts) guards return (replace_unhandled all_guards) @@ -800,7 +802,7 @@ cantFailPattern (PmGrd pv _e) cantFailPattern _ = False -- | Translate a guard statement to Pattern -translateGuard :: FamInstEnvs -> GuardStmt Id -> DsM PatVec +translateGuard :: FamInstEnvs -> GuardStmt GhcTc -> DsM PatVec translateGuard fam_insts guard = case guard of BodyStmt e _ _ _ -> translateBoolGuard e LetStmt binds -> translateLet (unLoc binds) @@ -812,17 +814,17 @@ translateGuard fam_insts guard = case guard of ApplicativeStmt {} -> panic "translateGuard ApplicativeLastStmt" -- | Translate let-bindings -translateLet :: HsLocalBinds Id -> DsM PatVec +translateLet :: HsLocalBinds GhcTc -> DsM PatVec translateLet _binds = return [] -- | Translate a pattern guard -translateBind :: FamInstEnvs -> LPat Id -> LHsExpr Id -> DsM PatVec +translateBind :: FamInstEnvs -> LPat GhcTc -> LHsExpr GhcTc -> DsM PatVec translateBind fam_insts (L _ p) e = do ps <- translatePat fam_insts p return [mkGuard ps (unLoc e)] -- | Translate a boolean guard -translateBoolGuard :: LHsExpr Id -> DsM PatVec +translateBoolGuard :: LHsExpr GhcTc -> DsM PatVec translateBoolGuard e | isJust (isTrueLHsExpr e) = return [] -- The formal thing to do would be to generate (True <- True) @@ -996,7 +998,7 @@ mkOneConFull x con = do -- * More smart constructors and fresh variable generation -- | Create a guard pattern -mkGuard :: PatVec -> HsExpr Id -> Pattern +mkGuard :: PatVec -> HsExpr GhcTc -> Pattern mkGuard pv e | all cantFailPattern pv = PmGrd pv expr | PmExprOther {} <- expr = fake_pat @@ -1041,7 +1043,7 @@ mkPmId ty = getUniqueM >>= \unique -> -- | Generate a fresh term variable of a given and return it in two forms: -- * A variable pattern -- * A variable expression -mkPmId2Forms :: Type -> DsM (Pattern, LHsExpr Id) +mkPmId2Forms :: Type -> DsM (Pattern, LHsExpr GhcTc) mkPmId2Forms ty = do x <- mkPmId ty return (PmVar x, noLoc (HsVar (noLoc x))) @@ -1508,9 +1510,9 @@ these constraints. -- When we go deeper to check e.g. e1 we record two equalities: -- (x ~ y), where y is the initial uncovered when checking (p1; .. ; pn) -- and (x ~ p1). -genCaseTmCs2 :: Maybe (LHsExpr Id) -- Scrutinee - -> [Pat Id] -- LHS (should have length 1) - -> [Id] -- MatchVars (should have length 1) +genCaseTmCs2 :: Maybe (LHsExpr GhcTc) -- Scrutinee + -> [Pat GhcTc] -- LHS (should have length 1) + -> [Id] -- MatchVars (should have length 1) -> DsM (Bag SimpleEq) genCaseTmCs2 Nothing _ _ = return emptyBag genCaseTmCs2 (Just scr) [p] [var] = do @@ -1524,7 +1526,7 @@ genCaseTmCs2 _ _ _ = panic "genCaseTmCs2: HsCase" -- case x of { matches } -- When checking matches we record that (x ~ y) where y is the initial -- uncovered. All matches will have to satisfy this equality. -genCaseTmCs1 :: Maybe (LHsExpr Id) -> [Id] -> Bag SimpleEq +genCaseTmCs1 :: Maybe (LHsExpr GhcTc) -> [Id] -> Bag SimpleEq genCaseTmCs1 Nothing _ = emptyBag genCaseTmCs1 (Just scr) [var] = unitBag (var, lhsExprToPmExpr scr) genCaseTmCs1 _ _ = panic "genCaseTmCs1: HsCase" @@ -1742,11 +1744,11 @@ pp_context singular (DsMatchContext kind _loc) msg rest_of_msg_fun \ pp -> ppr fun <+> pp) _ -> (pprMatchContext kind, \ pp -> pp) -ppr_pats :: HsMatchContext Name -> [Pat Id] -> SDoc +ppr_pats :: HsMatchContext Name -> [Pat GhcTc] -> SDoc ppr_pats kind pats = sep [sep (map ppr pats), matchSeparator kind, text "..."] -ppr_eqn :: (SDoc -> SDoc) -> HsMatchContext Name -> [LPat Id] -> SDoc +ppr_eqn :: (SDoc -> SDoc) -> HsMatchContext Name -> [LPat GhcTc] -> SDoc ppr_eqn prefixF kind eqn = prefixF (ppr_pats kind (map unLoc eqn)) ppr_constraint :: (SDoc,[PmLit]) -> SDoc diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index 92002bf793..16537bd7a5 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -68,8 +68,8 @@ addTicksToBinds -- isExportedId doesn't work yet (the desugarer -- hasn't set it), so we have to work from this set. -> [TyCon] -- Type constructor in this module - -> LHsBinds Id - -> IO (LHsBinds Id, HpcInfo, Maybe ModBreaks) + -> LHsBinds GhcTc + -> IO (LHsBinds GhcTc, HpcInfo, Maybe ModBreaks) addTicksToBinds hsc_env mod mod_loc exports tyCons binds | let dflags = hsc_dflags hsc_env @@ -118,7 +118,7 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds | otherwise = return (binds, emptyHpcInfo False, Nothing) -guessSourceFile :: LHsBinds Id -> FilePath -> FilePath +guessSourceFile :: LHsBinds GhcTc -> FilePath -> FilePath guessSourceFile binds orig_file = -- Try look for a file generated from a .hsc file to a -- .hs file, by peeking ahead. @@ -252,10 +252,10 @@ shouldTickPatBind density top_lev -- ----------------------------------------------------------------------------- -- Adding ticks to bindings -addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id) +addTickLHsBinds :: LHsBinds GhcTc -> TM (LHsBinds GhcTc) addTickLHsBinds = mapBagM addTickLHsBind -addTickLHsBind :: LHsBind Id -> TM (LHsBind Id) +addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc) addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds, abs_exports = abs_exports })) = do withEnv add_exports $ do @@ -419,7 +419,7 @@ bindTick density name pos fvs = do -- Decorate an LHsExpr with ticks -- selectively add ticks to interesting expressions -addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id) +addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) addTickLHsExpr e@(L pos e0) = do d <- getDensity case d of @@ -435,7 +435,7 @@ addTickLHsExpr e@(L pos e0) = do -- We always consider these to be breakpoints, unless the expression is a 'let' -- (because the body will definitely have a tick somewhere). ToDo: perhaps -- we should treat 'case' and 'if' the same way? -addTickLHsExprRHS :: LHsExpr Id -> TM (LHsExpr Id) +addTickLHsExprRHS :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) addTickLHsExprRHS e@(L pos e0) = do d <- getDensity case d of @@ -452,7 +452,7 @@ addTickLHsExprRHS e@(L pos e0) = do -- let binds in [], ( [] ) -- we never tick these if we're doing HPC, but otherwise -- we treat it like an ordinary expression. -addTickLHsExprEvalInner :: LHsExpr Id -> TM (LHsExpr Id) +addTickLHsExprEvalInner :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) addTickLHsExprEvalInner e = do d <- getDensity case d of @@ -464,7 +464,7 @@ addTickLHsExprEvalInner e = do -- want to tick the body, even if it is not a redex. See test -- break012. This gives the user the opportunity to inspect the -- values of the let-bound variables. -addTickLHsExprLetBody :: LHsExpr Id -> TM (LHsExpr Id) +addTickLHsExprLetBody :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) addTickLHsExprLetBody e@(L pos e0) = do d <- getDensity case d of @@ -478,32 +478,32 @@ addTickLHsExprLetBody e@(L pos e0) = do -- version of addTick that does not actually add a tick, -- because the scope of this tick is completely subsumed by -- another. -addTickLHsExprNever :: LHsExpr Id -> TM (LHsExpr Id) +addTickLHsExprNever :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) addTickLHsExprNever (L pos e0) = do e1 <- addTickHsExpr e0 return $ L pos e1 -- general heuristic: expressions which do not denote values are good -- break points -isGoodBreakExpr :: HsExpr Id -> Bool +isGoodBreakExpr :: HsExpr GhcTc -> Bool isGoodBreakExpr (HsApp {}) = True isGoodBreakExpr (HsAppTypeOut {}) = True isGoodBreakExpr (OpApp {}) = True isGoodBreakExpr _other = False -isCallSite :: HsExpr Id -> Bool +isCallSite :: HsExpr GhcTc -> Bool isCallSite HsApp{} = True isCallSite HsAppTypeOut{} = True isCallSite OpApp{} = True isCallSite _ = False -addTickLHsExprOptAlt :: Bool -> LHsExpr Id -> TM (LHsExpr Id) +addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) addTickLHsExprOptAlt oneOfMany (L pos e0) = ifDensity TickForCoverage (allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0) (addTickLHsExpr (L pos e0)) -addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id) +addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) addBinTickLHsExpr boxLabel (L pos e0) = ifDensity TickForCoverage (allocBinTickBox boxLabel pos $ addTickHsExpr e0) @@ -515,7 +515,7 @@ addBinTickLHsExpr boxLabel (L pos e0) -- (Whether to put a tick around the whole expression was already decided, -- in the addTickLHsExpr family of functions.) -addTickHsExpr :: HsExpr Id -> TM (HsExpr Id) +addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc) addTickHsExpr e@(HsVar (L _ id)) = do freeVar id; return e addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar" addTickHsExpr e@(HsConLikeOut con) @@ -668,24 +668,27 @@ addTickHsExpr (ExprWithTySigOut e ty) = -- Others should never happen in expression content. addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e) -addTickTupArg :: LHsTupArg Id -> TM (LHsTupArg Id) +addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc) addTickTupArg (L l (Present e)) = do { e' <- addTickLHsExpr e ; return (L l (Present e')) } addTickTupArg (L l (Missing ty)) = return (L l (Missing ty)) -addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id (LHsExpr Id) -> TM (MatchGroup Id (LHsExpr Id)) +addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc) + -> TM (MatchGroup GhcTc (LHsExpr GhcTc)) addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do let isOneOfMany = matchesOneOfMany matches matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches return $ mg { mg_alts = L l matches' } -addTickMatch :: Bool -> Bool -> Match Id (LHsExpr Id) -> TM (Match Id (LHsExpr Id)) +addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc) + -> TM (Match GhcTc (LHsExpr GhcTc)) addTickMatch isOneOfMany isLambda (Match mf pats opSig gRHSs) = bindLocals (collectPatsBinders pats) $ do gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs return $ Match mf pats opSig gRHSs' -addTickGRHSs :: Bool -> Bool -> GRHSs Id (LHsExpr Id) -> TM (GRHSs Id (LHsExpr Id)) +addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc) + -> TM (GRHSs GhcTc (LHsExpr GhcTc)) addTickGRHSs isOneOfMany isLambda (GRHSs guarded (L l local_binds)) = do bindLocals binders $ do local_binds' <- addTickHsLocalBinds local_binds @@ -694,13 +697,14 @@ addTickGRHSs isOneOfMany isLambda (GRHSs guarded (L l local_binds)) = do where binders = collectLocalBinders local_binds -addTickGRHS :: Bool -> Bool -> GRHS Id (LHsExpr Id) -> TM (GRHS Id (LHsExpr Id)) +addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc) + -> TM (GRHS GhcTc (LHsExpr GhcTc)) addTickGRHS isOneOfMany isLambda (GRHS stmts expr) = do (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts (addTickGRHSBody isOneOfMany isLambda expr) return $ GRHS stmts' expr' -addTickGRHSBody :: Bool -> Bool -> LHsExpr Id -> TM (LHsExpr Id) +addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do d <- getDensity case d of @@ -712,20 +716,22 @@ addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do _otherwise -> addTickLHsExprRHS expr -addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM [ExprLStmt Id] +addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] + -> TM [ExprLStmt GhcTc] addTickLStmts isGuard stmts = do (stmts, _) <- addTickLStmts' isGuard stmts (return ()) return stmts -addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM a - -> TM ([ExprLStmt Id], a) +addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a + -> TM ([ExprLStmt GhcTc], a) addTickLStmts' isGuard lstmts res = bindLocals (collectLStmtsBinders lstmts) $ do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts ; a <- res ; return (lstmts', a) } -addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id (LHsExpr Id) -> TM (Stmt Id (LHsExpr Id)) +addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt GhcTc (LHsExpr GhcTc) + -> TM (Stmt GhcTc (LHsExpr GhcTc)) addTickStmt _isGuard (LastStmt e noret ret) = do liftM3 LastStmt (addTickLHsExpr e) @@ -778,13 +784,13 @@ addTickStmt isGuard stmt@(RecStmt {}) ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret' , recS_mfix_fn = mfix', recS_bind_fn = bind' }) } -addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id) +addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e | otherwise = addTickLHsExprRHS e addTickApplicativeArg - :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr Id, ApplicativeArg Id Id) - -> TM (SyntaxExpr Id, ApplicativeArg Id Id) + :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc GhcTc) + -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc GhcTc) addTickApplicativeArg isGuard (op, arg) = liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg) where @@ -796,15 +802,15 @@ addTickApplicativeArg isGuard (op, arg) = <*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret)) <*> addTickLPat pat -addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock Id Id - -> TM (ParStmtBlock Id Id) +addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc + -> TM (ParStmtBlock GhcTc GhcTc) addTickStmtAndBinders isGuard (ParStmtBlock stmts ids returnExpr) = liftM3 ParStmtBlock (addTickLStmts isGuard stmts) (return ids) (addTickSyntaxExpr hpcSrcSpan returnExpr) -addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id) +addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc) addTickHsLocalBinds (HsValBinds binds) = liftM HsValBinds (addTickHsValBinds binds) @@ -813,7 +819,7 @@ addTickHsLocalBinds (HsIPBinds binds) = (addTickHsIPBinds binds) addTickHsLocalBinds (EmptyLocalBinds) = return EmptyLocalBinds -addTickHsValBinds :: HsValBindsLR Id a -> TM (HsValBindsLR Id b) +addTickHsValBinds :: HsValBindsLR GhcTc a -> TM (HsValBindsLR GhcTc b) addTickHsValBinds (ValBindsOut binds sigs) = liftM2 ValBindsOut (mapM (\ (rec,binds') -> @@ -824,28 +830,28 @@ addTickHsValBinds (ValBindsOut binds sigs) = (return sigs) addTickHsValBinds _ = panic "addTickHsValBinds" -addTickHsIPBinds :: HsIPBinds Id -> TM (HsIPBinds Id) +addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc) addTickHsIPBinds (IPBinds ipbinds dictbinds) = liftM2 IPBinds (mapM (liftL (addTickIPBind)) ipbinds) (return dictbinds) -addTickIPBind :: IPBind Id -> TM (IPBind Id) +addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc) addTickIPBind (IPBind nm e) = liftM2 IPBind (return nm) (addTickLHsExpr e) -- There is no location here, so we might need to use a context location?? -addTickSyntaxExpr :: SrcSpan -> SyntaxExpr Id -> TM (SyntaxExpr Id) +addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc) addTickSyntaxExpr pos syn@(SyntaxExpr { syn_expr = x }) = do L _ x' <- addTickLHsExpr (L pos x) return $ syn { syn_expr = x' } -- we do not walk into patterns. -addTickLPat :: LPat Id -> TM (LPat Id) +addTickLPat :: LPat GhcTc -> TM (LPat GhcTc) addTickLPat pat = return pat -addTickHsCmdTop :: HsCmdTop Id -> TM (HsCmdTop Id) +addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc) addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) = liftM4 HsCmdTop (addTickLHsCmd cmd) @@ -853,12 +859,12 @@ addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) = (return ty) (return syntaxtable) -addTickLHsCmd :: LHsCmd Id -> TM (LHsCmd Id) +addTickLHsCmd :: LHsCmd GhcTc -> TM (LHsCmd GhcTc) addTickLHsCmd (L pos c0) = do c1 <- addTickHsCmd c0 return $ L pos c1 -addTickHsCmd :: HsCmd Id -> TM (HsCmd Id) +addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc) addTickHsCmd (HsCmdLam matchgroup) = liftM HsCmdLam (addTickCmdMatchGroup matchgroup) addTickHsCmd (HsCmdApp c e) = @@ -910,18 +916,19 @@ addTickHsCmd (HsCmdWrap w cmd) -- Others should never happen in a command context. --addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e) -addTickCmdMatchGroup :: MatchGroup Id (LHsCmd Id) -> TM (MatchGroup Id (LHsCmd Id)) +addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc) + -> TM (MatchGroup GhcTc (LHsCmd GhcTc)) addTickCmdMatchGroup mg@(MG { mg_alts = L l matches }) = do matches' <- mapM (liftL addTickCmdMatch) matches return $ mg { mg_alts = L l matches' } -addTickCmdMatch :: Match Id (LHsCmd Id) -> TM (Match Id (LHsCmd Id)) +addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc)) addTickCmdMatch (Match mf pats opSig gRHSs) = bindLocals (collectPatsBinders pats) $ do gRHSs' <- addTickCmdGRHSs gRHSs return $ Match mf pats opSig gRHSs' -addTickCmdGRHSs :: GRHSs Id (LHsCmd Id) -> TM (GRHSs Id (LHsCmd Id)) +addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc)) addTickCmdGRHSs (GRHSs guarded (L l local_binds)) = do bindLocals binders $ do local_binds' <- addTickHsLocalBinds local_binds @@ -930,7 +937,7 @@ addTickCmdGRHSs (GRHSs guarded (L l local_binds)) = do where binders = collectLocalBinders local_binds -addTickCmdGRHS :: GRHS Id (LHsCmd Id) -> TM (GRHS Id (LHsCmd Id)) +addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc)) -- The *guards* are *not* Cmds, although the body is -- C.f. addTickGRHS for the BinBox stuff addTickCmdGRHS (GRHS stmts cmd) @@ -938,12 +945,14 @@ addTickCmdGRHS (GRHS stmts cmd) stmts (addTickLHsCmd cmd) ; return $ GRHS stmts' expr' } -addTickLCmdStmts :: [LStmt Id (LHsCmd Id)] -> TM [LStmt Id (LHsCmd Id)] +addTickLCmdStmts :: [LStmt GhcTc (LHsCmd GhcTc)] + -> TM [LStmt GhcTc (LHsCmd GhcTc)] addTickLCmdStmts stmts = do (stmts, _) <- addTickLCmdStmts' stmts (return ()) return stmts -addTickLCmdStmts' :: [LStmt Id (LHsCmd Id)] -> TM a -> TM ([LStmt Id (LHsCmd Id)], a) +addTickLCmdStmts' :: [LStmt GhcTc (LHsCmd GhcTc)] -> TM a + -> TM ([LStmt GhcTc (LHsCmd GhcTc)], a) addTickLCmdStmts' lstmts res = bindLocals binders $ do lstmts' <- mapM (liftL addTickCmdStmt) lstmts @@ -952,7 +961,7 @@ addTickLCmdStmts' lstmts res where binders = collectLStmtsBinders lstmts -addTickCmdStmt :: Stmt Id (LHsCmd Id) -> TM (Stmt Id (LHsCmd Id)) +addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc)) addTickCmdStmt (BindStmt pat c bind fail ty) = do liftM5 BindStmt (addTickLPat pat) @@ -987,18 +996,19 @@ addTickCmdStmt ApplicativeStmt{} = -- Others should never happen in a command context. addTickCmdStmt stmt = pprPanic "addTickHsCmd" (ppr stmt) -addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id) +addTickHsRecordBinds :: HsRecordBinds GhcTc -> TM (HsRecordBinds GhcTc) addTickHsRecordBinds (HsRecFields fields dd) = do { fields' <- mapM addTickHsRecField fields ; return (HsRecFields fields' dd) } -addTickHsRecField :: LHsRecField' id (LHsExpr Id) -> TM (LHsRecField' id (LHsExpr Id)) +addTickHsRecField :: LHsRecField' id (LHsExpr GhcTc) + -> TM (LHsRecField' id (LHsExpr GhcTc)) addTickHsRecField (L l (HsRecField id expr pun)) = do { expr' <- addTickLHsExpr expr ; return (L l (HsRecField id expr' pun)) } -addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id) +addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc) addTickArithSeqInfo (From e1) = liftM From (addTickLHsExpr e1) @@ -1174,8 +1184,8 @@ isBlackListed pos = TM $ \ env st -> -- the tick application inherits the source position of its -- expression argument to support nested box allocations -allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr Id) - -> TM (LHsExpr Id) +allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr GhcTc) + -> TM (LHsExpr GhcTc) allocTickBox boxLabel countEntries topOnly pos m = ifGoodTickSrcSpan pos (do (fvs, e) <- getFreeVars m @@ -1246,8 +1256,8 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path = do _otherwise -> panic "mkTickish: bad source span!" -allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr Id) - -> TM (LHsExpr Id) +allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr GhcTc) + -> TM (LHsExpr GhcTc) allocBinTickBox boxLabel pos m = do env <- getEnv case tickishType env of @@ -1257,8 +1267,8 @@ allocBinTickBox boxLabel pos m = do (return e) _other -> allocTickBox (ExpBox False) False False pos m -mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr Id - -> TM (LHsExpr Id) +mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr GhcTc + -> TM (LHsExpr GhcTc) mkBinTickBoxHpc boxLabel pos e = TM $ \ env st -> let meT = (pos,declPath env, [],boxLabel True) @@ -1291,7 +1301,7 @@ mkHpcPos _ = panic "bad source span; expected such spans to be filtered out" hpcSrcSpan :: SrcSpan hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals") -matchesOneOfMany :: [LMatch Id body] -> Bool +matchesOneOfMany :: [LMatch GhcTc body] -> Bool matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1 where matchCount (L _ (Match _ _pats _ty (GRHSs grhss _binds))) = length grhss diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs index 0d8965a118..3d8a28f7b0 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -7,6 +7,7 @@ The Desugarer: turning HsSyn into Core. -} {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} module Desugar ( -- * Desugaring operations @@ -250,7 +251,7 @@ So we pull out the type/coercion variables (which are in dependency order), and Rec the rest. -} -deSugarExpr :: HscEnv -> LHsExpr Id -> IO (Messages, Maybe CoreExpr) +deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages, Maybe CoreExpr) deSugarExpr hsc_env tc_expr = do { let dflags = hsc_dflags hsc_env @@ -362,7 +363,7 @@ Reason ************************************************************************ -} -dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule) +dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule) dsRule (L loc (HsRule name rule_act vars lhs _tv_lhs rhs _fv_rhs)) = putSrcSpanDs loc $ do { let bndrs' = [var | L _ (RuleBndr (L _ var)) <- vars] @@ -541,7 +542,7 @@ subsequent transformations could fire. ************************************************************************ -} -dsVect :: LVectDecl Id -> DsM CoreVect +dsVect :: LVectDecl GhcTc -> DsM CoreVect dsVect (L loc (HsVect _ (L _ v) rhs)) = putSrcSpanDs loc $ do { rhs' <- dsLExpr rhs diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs index 4fe43eb1c0..fb16d53e78 100644 --- a/compiler/deSugar/DsArrows.hs +++ b/compiler/deSugar/DsArrows.hs @@ -7,6 +7,7 @@ Desugaring arrow commands -} {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} module DsArrows ( dsProcExpr ) where @@ -37,7 +38,6 @@ import MkCore import DsBinds (dsHsWrapper) import Name -import Var import Id import ConLike import TysWiredIn @@ -57,7 +57,7 @@ data DsCmdEnv = DsCmdEnv { arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr } -mkCmdEnv :: CmdSyntaxTable Id -> DsM ([CoreBind], DsCmdEnv) +mkCmdEnv :: CmdSyntaxTable GhcTc -> DsM ([CoreBind], DsCmdEnv) -- See Note [CmdSyntaxTable] in HsExpr mkCmdEnv tc_meths = do { (meth_binds, prs) <- mapAndUnzipM mk_bind tc_meths @@ -295,7 +295,7 @@ matchVarStack (param_id:param_ids) stack_id body = do pair_id <- newSysLocalDs (mkCorePairTy (idType param_id) (idType tail_id)) return (pair_id, coreCasePair pair_id param_id tail_id tail_code) -mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr Id +mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr GhcTc mkHsEnvStackExpr env_ids stack_id = mkLHsTupleExpr [mkLHsVarTuple env_ids, nlHsVar stack_id] @@ -308,8 +308,8 @@ mkHsEnvStackExpr env_ids stack_id -- where (xs) is the tuple of variables bound by p dsProcExpr - :: LPat Id - -> LHsCmdTop Id + :: LPat GhcTc + -> LHsCmdTop GhcTc -> DsM CoreExpr dsProcExpr pat (L _ (HsCmdTop cmd _unitTy cmd_ty ids)) = do (meth_binds, meth_ids) <- mkCmdEnv ids @@ -337,7 +337,7 @@ to an expression e such that D |- e :: a (xs, stk) t -} -dsLCmd :: DsCmdEnv -> IdSet -> Type -> Type -> LHsCmd Id -> [Id] +dsLCmd :: DsCmdEnv -> IdSet -> Type -> Type -> LHsCmd GhcTc -> [Id] -> DsM (CoreExpr, DIdSet) dsLCmd ids local_vars stk_ty res_ty cmd env_ids = dsCmd ids local_vars stk_ty res_ty (unLoc cmd) env_ids @@ -346,8 +346,8 @@ dsCmd :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this command -> Type -- type of the stack (right-nested tuple) -> Type -- return type of the command - -> HsCmd Id -- command to desugar - -> [Id] -- list of vars in the input to this command + -> HsCmd GhcTc -- command to desugar + -> [Id] -- list of vars in the input to this command -- This is typically fed back, -- so don't pull on it too early -> DsM (CoreExpr, -- desugared expression @@ -676,8 +676,8 @@ dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c) dsTrimCmdArg :: IdSet -- set of local vars available to this command - -> [Id] -- list of vars in the input to this command - -> LHsCmdTop Id -- command argument to desugar + -> [Id] -- list of vars in the input to this command + -> LHsCmdTop GhcTc -- command argument to desugar -> DsM (CoreExpr, -- desugared expression DIdSet) -- subset of local vars that occur free dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack_ty cmd_ty ids)) = do @@ -700,7 +700,7 @@ dsfixCmd -> IdSet -- set of local vars available to this command -> Type -- type of the stack (right-nested tuple) -> Type -- return type of the command - -> LHsCmd Id -- command to desugar + -> LHsCmd GhcTc -- command to desugar -> DsM (CoreExpr, -- desugared expression DIdSet, -- subset of local vars that occur free [Id]) -- the same local vars as a list, fed back @@ -733,7 +733,7 @@ Translation of command judgements of the form dsCmdDo :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this statement -> Type -- return type of the statement - -> [CmdLStmt Id] -- statements to desugar + -> [CmdLStmt GhcTc] -- statements to desugar -> [Id] -- list of vars in the input to this statement -- This is typically fed back, -- so don't pull on it too early @@ -782,7 +782,7 @@ as an arrow from one tuple type to another. A statement sequence is translated to a composition of such arrows. -} -dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> CmdLStmt Id -> [Id] +dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> CmdLStmt GhcTc -> [Id] -> DsM (CoreExpr, DIdSet) dsCmdLStmt ids local_vars out_ids cmd env_ids = dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids @@ -791,7 +791,7 @@ dsCmdStmt :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this statement -> [Id] -- list of vars in the output of this statement - -> CmdStmt Id -- statement to desugar + -> CmdStmt GhcTc -- statement to desugar -> [Id] -- list of vars in the input to this statement -- This is typically fed back, -- so don't pull on it too early @@ -973,11 +973,11 @@ dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s) dsRecCmd :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this statement - -> [CmdLStmt Id] -- list of statements inside the RecCmd + -> [CmdLStmt GhcTc] -- list of statements inside the RecCmd -> [Id] -- list of vars defined here and used later - -> [HsExpr Id] -- expressions corresponding to later_ids + -> [HsExpr GhcTc] -- expressions corresponding to later_ids -> [Id] -- list of vars fed back through the loop - -> [HsExpr Id] -- expressions corresponding to rec_ids + -> [HsExpr GhcTc] -- expressions corresponding to rec_ids -> DsM (CoreExpr, -- desugared statement DIdSet, -- subset of local vars that occur free [Id]) -- same local vars as a list @@ -1051,7 +1051,7 @@ dsfixCmdStmts :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this statement -> [Id] -- output vars of these statements - -> [CmdLStmt Id] -- statements to desugar + -> [CmdLStmt GhcTc] -- statements to desugar -> DsM (CoreExpr, -- desugared expression DIdSet, -- subset of local vars that occur free [Id]) -- same local vars as a list @@ -1065,7 +1065,7 @@ dsCmdStmts :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this statement -> [Id] -- output vars of these statements - -> [CmdLStmt Id] -- statements to desugar + -> [CmdLStmt GhcTc] -- statements to desugar -> [Id] -- list of vars in the input to these statements -> DsM (CoreExpr, -- desugared expression DIdSet) -- subset of local vars that occur free @@ -1092,7 +1092,7 @@ dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []" matchSimplys :: [CoreExpr] -- Scrutinees -> HsMatchContext Name -- Match kind - -> [LPat Id] -- Patterns they should match + -> [LPat GhcTc] -- Patterns they should match -> CoreExpr -- Return this if they all match -> CoreExpr -- Return this if they don't -> DsM CoreExpr @@ -1104,7 +1104,8 @@ matchSimplys _ _ _ _ _ = panic "matchSimplys" -- List of leaf expressions, with set of variables bound in each -leavesMatch :: LMatch Id (Located (body Id)) -> [(Located (body Id), IdSet)] +leavesMatch :: LMatch GhcTc (Located (body GhcTc)) + -> [(Located (body GhcTc), IdSet)] leavesMatch (L _ (Match _ pats _ (GRHSs grhss (L _ binds)))) = let defined_vars = mkVarSet (collectPatsBinders pats) @@ -1120,10 +1121,10 @@ leavesMatch (L _ (Match _ pats _ (GRHSs grhss (L _ binds)))) replaceLeavesMatch :: Type -- new result type - -> [Located (body' Id)] -- replacement leaf expressions of that type - -> LMatch Id (Located (body Id)) -- the matches of a case command - -> ([Located (body' Id)], -- remaining leaf expressions - LMatch Id (Located (body' Id))) -- updated match + -> [Located (body' GhcTc)] -- replacement leaf expressions of that type + -> LMatch GhcTc (Located (body GhcTc)) -- the matches of a case command + -> ([Located (body' GhcTc)], -- remaining leaf expressions + LMatch GhcTc (Located (body' GhcTc))) -- updated match replaceLeavesMatch _res_ty leaves (L loc (Match mf pat mt (GRHSs grhss binds))) = let (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss @@ -1131,10 +1132,10 @@ replaceLeavesMatch _res_ty leaves (L loc (Match mf pat mt (GRHSs grhss binds))) (leaves', L loc (Match mf pat mt (GRHSs grhss' binds))) replaceLeavesGRHS - :: [Located (body' Id)] -- replacement leaf expressions of that type - -> LGRHS Id (Located (body Id)) -- rhss of a case command - -> ([Located (body' Id)], -- remaining leaf expressions - LGRHS Id (Located (body' Id))) -- updated GRHS + :: [Located (body' GhcTc)] -- replacement leaf expressions of that type + -> LGRHS GhcTc (Located (body GhcTc)) -- rhss of a case command + -> ([Located (body' GhcTc)], -- remaining leaf expressions + LGRHS GhcTc (Located (body' GhcTc))) -- updated GRHS replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts _)) = (leaves, L loc (GRHS stmts leaf)) replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []" @@ -1172,14 +1173,14 @@ See comments in HsUtils for why the other version does not include these bindings. -} -collectPatBinders :: LPat Id -> [Id] +collectPatBinders :: LPat GhcTc -> [Id] collectPatBinders pat = collectl pat [] -collectPatsBinders :: [LPat Id] -> [Id] +collectPatsBinders :: [LPat GhcTc] -> [Id] collectPatsBinders pats = foldr collectl [] pats --------------------- -collectl :: LPat Id -> [Id] -> [Id] +collectl :: LPat GhcTc -> [Id] -> [Id] -- See Note [Dictionary binders in ConPatOut] collectl (L _ pat) bndrs = go pat @@ -1219,12 +1220,12 @@ add_ev_bndr (EvBind { eb_lhs = b }) bs | isId b = b:bs | otherwise = bs -- A worry: what about coercion variable binders?? -collectLStmtsBinders :: [LStmt Id body] -> [Id] +collectLStmtsBinders :: [LStmt GhcTc body] -> [Id] collectLStmtsBinders = concatMap collectLStmtBinders -collectLStmtBinders :: LStmt Id body -> [Id] +collectLStmtBinders :: LStmt GhcTc body -> [Id] collectLStmtBinders = collectStmtBinders . unLoc -collectStmtBinders :: Stmt Id body -> [Id] +collectStmtBinders :: Stmt GhcTc body -> [Id] collectStmtBinders (RecStmt { recS_later_ids = later_ids }) = later_ids collectStmtBinders stmt = HsUtils.collectStmtBinders stmt diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index 26aebe9363..2a0abca5de 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -11,6 +11,7 @@ lower levels it is preserved with @let@/@letrec@s). -} {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec, dsHsWrapper, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule @@ -73,7 +74,7 @@ import Control.Monad -- | Desugar top level binds, strict binds are treated like normal -- binds since there is no good time to force before first usage. -dsTopLHsBinds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr)) +dsTopLHsBinds :: LHsBinds GhcTc -> DsM (OrdList (Id,CoreExpr)) dsTopLHsBinds binds -- see Note [Strict binds checks] | not (isEmptyBag unlifted_binds) || not (isEmptyBag bang_binds) @@ -102,7 +103,7 @@ dsTopLHsBinds binds -- | Desugar all other kind of bindings, Ids of strict binds are returned to -- later be forced in the binding group body, see Note [Desugar Strict binds] -dsLHsBinds :: LHsBinds Id -> DsM ([Id], [(Id,CoreExpr)]) +dsLHsBinds :: LHsBinds GhcTc -> DsM ([Id], [(Id,CoreExpr)]) dsLHsBinds binds = do { MASSERT( allBag (not . isUnliftedHsBind . unLoc) binds ) ; ds_bs <- mapBagM dsLHsBind binds @@ -110,14 +111,14 @@ dsLHsBinds binds id ([], []) ds_bs) } ------------------------ -dsLHsBind :: LHsBind Id +dsLHsBind :: LHsBind GhcTc -> DsM ([Id], [(Id,CoreExpr)]) dsLHsBind (L loc bind) = do dflags <- getDynFlags putSrcSpanDs loc $ dsHsBind dflags bind -- | Desugar a single binding (or group of recursive binds). dsHsBind :: DynFlags - -> HsBind Id + -> HsBind GhcTc -> DsM ([Id], [(Id,CoreExpr)]) -- ^ The Ids of strict binds, to be forced in the body of the -- binding group see Note [Desugar Strict binds] and all @@ -275,7 +276,7 @@ dsHsBind dflags ,(poly_tup_id, poly_tup_rhs) : concat export_binds_s) } where - inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with + inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with -- the inline pragma from the source -- The type checker put the inline pragma -- on the *global* Id, so we need to transfer it @@ -302,7 +303,7 @@ dsHsBind dflags [] lcls -- find exports or make up new exports for force variables - get_exports :: [Id] -> DsM ([Id], [ABExport Id]) + get_exports :: [Id] -> DsM ([Id], [ABExport GhcTc]) get_exports lcls = foldM (\(glbls, exports) lcl -> case lookupVarEnv global_env lcl of @@ -373,7 +374,8 @@ dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind" -- the unfolding in the interface file is made in `TidyPgm.addExternal` -- using this information. ------------------------ -makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr) +makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr + -> (Id, CoreExpr) makeCorePair dflags gbl_id is_default_method dict_arity rhs | is_default_method -- Default methods are *always* inlined = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs) diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index cfd9996f1a..c3d9489476 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -7,6 +7,7 @@ Desugaring exporessions. -} {-# LANGUAGE CPP, MultiWayIf #-} +{-# LANGUAGE TypeFamilies #-} module DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds , dsValBinds, dsLit, dsSyntaxExpr ) where @@ -66,7 +67,7 @@ import Control.Monad ************************************************************************ -} -dsLocalBinds :: LHsLocalBinds Id -> CoreExpr -> DsM CoreExpr +dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr dsLocalBinds (L _ EmptyLocalBinds) body = return body dsLocalBinds (L loc (HsValBinds binds)) body = putSrcSpanDs loc $ dsValBinds binds body @@ -74,12 +75,12 @@ dsLocalBinds (L _ (HsIPBinds binds)) body = dsIPBinds binds body ------------------------- -- caller sets location -dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr +dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds dsValBinds (ValBindsIn {}) _ = panic "dsValBinds ValBindsIn" ------------------------- -dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr +dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr dsIPBinds (IPBinds ip_binds ev_binds) body = do { ds_binds <- dsTcEvBinds ev_binds ; let inner = mkCoreLets ds_binds body @@ -93,7 +94,7 @@ dsIPBinds (IPBinds ip_binds ev_binds) body ------------------------- -- caller sets location -ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr +ds_val_bind :: (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr -- Special case for bindings which bind unlifted variables -- We need to do a case right away, rather than building -- a tuple and doing selections. @@ -173,7 +174,7 @@ ds_val_bind (is_rec, binds) body -- only have to deal with lifted ones now; so Rec is ok ------------------ -dsUnliftedBind :: HsBind Id -> CoreExpr -> DsM CoreExpr +dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = [] , abs_exports = exports , abs_ev_binds = ev_binds @@ -228,7 +229,7 @@ dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body) ************************************************************************ -} -dsLExpr :: LHsExpr Id -> DsM CoreExpr +dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr dsLExpr (L loc e) = putSrcSpanDs loc $ @@ -244,19 +245,19 @@ dsLExpr (L loc e) -- be an argument to some other function. -- See Note [Levity polymorphism checking] in DsMonad -- See Note [Levity polymorphism invariants] in CoreSyn -dsLExprNoLP :: LHsExpr Id -> DsM CoreExpr +dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr dsLExprNoLP (L loc e) = putSrcSpanDs loc $ do { e' <- dsExpr e ; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e) ; return e' } -dsExpr :: HsExpr Id -> DsM CoreExpr +dsExpr :: HsExpr GhcTc -> DsM CoreExpr dsExpr = ds_expr False ds_expr :: Bool -- are we directly inside an HsWrap? -- See Wrinkle in Note [Detecting forced eta expansion] - -> HsExpr Id -> DsM CoreExpr + -> HsExpr GhcTc -> DsM CoreExpr ds_expr _ (HsPar e) = dsLExpr e ds_expr _ (ExprWithTySigOut e _) = dsLExpr e ds_expr w (HsVar (L _ var)) = dsHsVar w var @@ -264,7 +265,7 @@ ds_expr _ (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker e ds_expr w (HsConLikeOut con) = dsConLike w con ds_expr _ (HsIPVar _) = panic "dsExpr: HsIPVar" ds_expr _ (HsOverLabel{}) = panic "dsExpr: HsOverLabel" -ds_expr _ (HsLit lit) = dsLit lit +ds_expr _ (HsLit lit) = dsLit (convertLit lit) ds_expr _ (HsOverLit lit) = dsOverLit lit ds_expr _ (HsWrap co_fn e) @@ -632,7 +633,7 @@ ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields ; return (add_field_binds field_binds' $ bindNonRec discrim_var record_expr' matching_code) } where - ds_field :: LHsRecUpdField Id -> DsM (Name, Id, CoreExpr) + ds_field :: LHsRecUpdField GhcTc -> DsM (Name, Id, CoreExpr) -- Clone the Id in the HsRecField, because its Name is that -- of the record selector, and we must not make that a local binder -- else we shadow other uses of the record selector @@ -768,7 +769,7 @@ ds_expr _ (HsDo {}) = panic "dsExpr:HsDo" ds_expr _ (HsRecFld {}) = panic "dsExpr:HsRecFld" ------------------------------ -dsSyntaxExpr :: SyntaxExpr Id -> [CoreExpr] -> DsM CoreExpr +dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr dsSyntaxExpr (SyntaxExpr { syn_expr = expr , syn_arg_wraps = arg_wraps , syn_res_wrap = res_wrap }) @@ -782,7 +783,7 @@ dsSyntaxExpr (SyntaxExpr { syn_expr = expr where mk_doc n = text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr) -findField :: [LHsRecField Id arg] -> Name -> [arg] +findField :: [LHsRecField GhcTc arg] -> Name -> [arg] findField rbinds sel = [hsRecFieldArg fld | L _ fld <- rbinds , sel == idName (unLoc $ hsRecFieldId fld) ] @@ -847,7 +848,7 @@ time. maxBuildLength :: Int maxBuildLength = 32 -dsExplicitList :: Type -> Maybe (SyntaxExpr Id) -> [LHsExpr Id] +dsExplicitList :: Type -> Maybe (SyntaxExpr GhcTc) -> [LHsExpr GhcTc] -> DsM CoreExpr -- See Note [Desugaring explicit lists] dsExplicitList elt_ty Nothing xs @@ -871,7 +872,7 @@ dsExplicitList elt_ty (Just fln) xs ; dflags <- getDynFlags ; dsSyntaxExpr fln [mkIntExprInt dflags (length xs), list] } -dsArithSeq :: PostTcExpr -> (ArithSeqInfo Id) -> DsM CoreExpr +dsArithSeq :: PostTcExpr -> (ArithSeqInfo GhcTc) -> DsM CoreExpr dsArithSeq expr (From from) = App <$> dsExpr expr <*> dsLExprNoLP from dsArithSeq expr (FromTo from to) @@ -898,7 +899,7 @@ handled in DsListComp). Basically does the translation given in the Haskell 98 report: -} -dsDo :: [ExprLStmt Id] -> DsM CoreExpr +dsDo :: [ExprLStmt GhcTc] -> DsM CoreExpr dsDo stmts = goL stmts where @@ -994,7 +995,7 @@ dsDo stmts go _ (ParStmt {}) _ = panic "dsDo ParStmt" go _ (TransStmt {}) _ = panic "dsDo TransStmt" -handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr +handle_failure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr -- In a do expression, pattern-match failure just calls -- the monadic 'fail' rather than throwing an exception handle_failure pat match fail_op @@ -1052,7 +1053,7 @@ dsConLike _ (PatSynCon ps) = return $ case patSynBuilder ps of -} -- Warn about certain types of values discarded in monadic bindings (#3263) -warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM () +warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> DsM () warnDiscardedDoBindings rhs rhs_ty | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty = do { warn_unused <- woptM Opt_WarnUnusedDoBind @@ -1080,7 +1081,7 @@ warnDiscardedDoBindings rhs rhs_ty | otherwise -- RHS does have type of form (m ty), which is weird = return () -- but at lesat this warning is irrelevant -badMonadBind :: LHsExpr Id -> Type -> SDoc +badMonadBind :: LHsExpr GhcTc -> Type -> SDoc badMonadBind rhs elt_ty = vcat [ hang (text "A do-notation statement discarded a result of type") 2 (quotes (ppr elt_ty)) @@ -1143,7 +1144,7 @@ we're not directly in an HsWrap, reject. -- | Takes an expression and its instantiated type. If the expression is an -- HsVar with a hasNoBinding primop and the type has levity-polymorphic arguments, -- issue an error. See Note [Detecting forced eta expansion] -checkForcedEtaExpansion :: HsExpr Id -> Type -> DsM () +checkForcedEtaExpansion :: HsExpr GhcTc -> Type -> DsM () checkForcedEtaExpansion expr ty | Just var <- case expr of HsVar (L _ var) -> Just var diff --git a/compiler/deSugar/DsExpr.hs-boot b/compiler/deSugar/DsExpr.hs-boot index 864df833a7..65c4f188fd 100644 --- a/compiler/deSugar/DsExpr.hs-boot +++ b/compiler/deSugar/DsExpr.hs-boot @@ -1,10 +1,10 @@ module DsExpr where -import HsSyn ( HsExpr, LHsExpr, LHsLocalBinds, SyntaxExpr ) -import Var ( Id ) -import DsMonad ( DsM ) -import CoreSyn ( CoreExpr ) +import HsSyn ( HsExpr, LHsExpr, LHsLocalBinds, SyntaxExpr ) +import DsMonad ( DsM ) +import CoreSyn ( CoreExpr ) +import HsExtension ( GhcTc) -dsExpr :: HsExpr Id -> DsM CoreExpr -dsLExpr, dsLExprNoLP :: LHsExpr Id -> DsM CoreExpr -dsSyntaxExpr :: SyntaxExpr Id -> [CoreExpr] -> DsM CoreExpr -dsLocalBinds :: LHsLocalBinds Id -> CoreExpr -> DsM CoreExpr +dsExpr :: HsExpr GhcTc -> DsM CoreExpr +dsLExpr, dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr +dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr +dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs index 9998a4d419..fb3752d104 100644 --- a/compiler/deSugar/DsForeign.hs +++ b/compiler/deSugar/DsForeign.hs @@ -7,6 +7,8 @@ Desugaring foreign declarations (see also DsCCall). -} {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} module DsForeign ( dsForeigns ) where @@ -69,14 +71,14 @@ is the same as so we reuse the desugaring code in @DsCCall@ to deal with these. -} -type Binding = (Id, CoreExpr) -- No rec/nonrec structure; - -- the occurrence analyser will sort it all out +type Binding = (Id, CoreExpr) -- No rec/nonrec structure; + -- the occurrence analyser will sort it all out -dsForeigns :: [LForeignDecl Id] +dsForeigns :: [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding) dsForeigns fos = getHooked dsForeignsHook dsForeigns' >>= ($ fos) -dsForeigns' :: [LForeignDecl Id] +dsForeigns' :: [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding) dsForeigns' [] = return (NoStubs, nilOL) diff --git a/compiler/deSugar/DsGRHSs.hs b/compiler/deSugar/DsGRHSs.hs index e66461259d..c3dcdf6879 100644 --- a/compiler/deSugar/DsGRHSs.hs +++ b/compiler/deSugar/DsGRHSs.hs @@ -18,7 +18,6 @@ import {-# SOURCE #-} Match ( matchSinglePat ) import HsSyn import MkCore import CoreSyn -import Var import DsMonad import DsUtils @@ -44,7 +43,7 @@ producing an expression with a runtime error in the corner if necessary. The type argument gives the type of the @ei@. -} -dsGuarded :: GRHSs Id (LHsExpr Id) -> Type -> DsM CoreExpr +dsGuarded :: GRHSs GhcTc (LHsExpr GhcTc) -> Type -> DsM CoreExpr dsGuarded grhss rhs_ty = do match_result <- dsGRHSs PatBindRhs grhss rhs_ty @@ -54,7 +53,7 @@ dsGuarded grhss rhs_ty = do -- In contrast, @dsGRHSs@ produces a @MatchResult@. dsGRHSs :: HsMatchContext Name - -> GRHSs Id (LHsExpr Id) -- Guarded RHSs + -> GRHSs GhcTc (LHsExpr GhcTc) -- Guarded RHSs -> Type -- Type of RHS -> DsM MatchResult dsGRHSs hs_ctx (GRHSs grhss binds) rhs_ty @@ -65,7 +64,8 @@ dsGRHSs hs_ctx (GRHSs grhss binds) rhs_ty -- NB: nested dsLet inside matchResult ; return match_result2 } -dsGRHS :: HsMatchContext Name -> Type -> LGRHS Id (LHsExpr Id) -> DsM MatchResult +dsGRHS :: HsMatchContext Name -> Type -> LGRHS GhcTc (LHsExpr GhcTc) + -> DsM MatchResult dsGRHS hs_ctx rhs_ty (L _ (GRHS guards rhs)) = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty @@ -77,10 +77,10 @@ dsGRHS hs_ctx rhs_ty (L _ (GRHS guards rhs)) ************************************************************************ -} -matchGuards :: [GuardStmt Id] -- Guard - -> HsStmtContext Name -- Context - -> LHsExpr Id -- RHS - -> Type -- Type of RHS of guard +matchGuards :: [GuardStmt GhcTc] -- Guard + -> HsStmtContext Name -- Context + -> LHsExpr GhcTc -- RHS + -> Type -- Type of RHS of guard -> DsM MatchResult -- See comments with HsExpr.Stmt re what a BodyStmt means @@ -126,7 +126,7 @@ matchGuards (RecStmt {} : _) _ _ _ = panic "matchGuards RecStmt" matchGuards (ApplicativeStmt {} : _) _ _ _ = panic "matchGuards ApplicativeLastStmt" -isTrueLHsExpr :: LHsExpr Id -> Maybe (CoreExpr -> DsM CoreExpr) +isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr) -- Returns Just {..} if we're sure that the expression is True -- I.e. * 'True' datacon diff --git a/compiler/deSugar/DsListComp.hs b/compiler/deSugar/DsListComp.hs index 2bb303ec98..dc24183537 100644 --- a/compiler/deSugar/DsListComp.hs +++ b/compiler/deSugar/DsListComp.hs @@ -7,6 +7,7 @@ Desugaring list comprehensions, monad comprehensions and array comprehensions -} {-# LANGUAGE CPP, NamedFieldPuns #-} +{-# LANGUAGE TypeFamilies #-} module DsListComp ( dsListComp, dsPArrComp, dsMonadComp ) where @@ -43,7 +44,7 @@ turned on'' (if you read Gill {\em et al.}'s paper on the subject). There will be at least one ``qualifier'' in the input. -} -dsListComp :: [ExprLStmt Id] +dsListComp :: [ExprLStmt GhcTc] -> Type -- Type of entire list -> DsM CoreExpr dsListComp lquals res_ty = do @@ -78,7 +79,7 @@ dsListComp lquals res_ty = do -- This function lets you desugar a inner list comprehension and a list of the binders -- of that comprehension that we need in the outer comprehension into such an expression -- and the type of the elements that it outputs (tuples of binders) -dsInnerListComp :: (ParStmtBlock Id Id) -> DsM (CoreExpr, Type) +dsInnerListComp :: (ParStmtBlock GhcTc GhcTc) -> DsM (CoreExpr, Type) dsInnerListComp (ParStmtBlock stmts bndrs _) = do { let bndrs_tuple_type = mkBigCoreVarTupTy bndrs list_ty = mkListTy bndrs_tuple_type @@ -91,7 +92,7 @@ dsInnerListComp (ParStmtBlock stmts bndrs _) -- This function factors out commonality between the desugaring strategies for GroupStmt. -- Given such a statement it gives you back an expression representing how to compute the transformed -- list and the tuple that you need to bind from that list in order to proceed with your desugaring -dsTransStmt :: ExprStmt Id -> DsM (CoreExpr, LPat Id) +dsTransStmt :: ExprStmt GhcTc -> DsM (CoreExpr, LPat GhcTc) dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderMap , trS_by = by, trS_using = using }) = do let (from_bndrs, to_bndrs) = unzip binderMap @@ -211,7 +212,7 @@ The introduced tuples are Boxed, but only because I couldn't get it to work with the Unboxed variety. -} -deListComp :: [ExprStmt Id] -> CoreExpr -> DsM CoreExpr +deListComp :: [ExprStmt GhcTc] -> CoreExpr -> DsM CoreExpr deListComp [] _ = panic "deListComp" @@ -261,9 +262,9 @@ deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt" deListComp (ApplicativeStmt {} : _) _ = panic "deListComp ApplicativeStmt" -deBindComp :: OutPat Id +deBindComp :: OutPat GhcTc -> CoreExpr - -> [ExprStmt Id] + -> [ExprStmt GhcTc] -> CoreExpr -> DsM (Expr Id) deBindComp pat core_list1 quals core_list2 = do @@ -317,8 +318,8 @@ TE[ e | p <- l , q ] c n = let \end{verbatim} -} -dfListComp :: Id -> Id -- 'c' and 'n' - -> [ExprStmt Id] -- the rest of the qual's +dfListComp :: Id -> Id -- 'c' and 'n' + -> [ExprStmt GhcTc] -- the rest of the qual's -> DsM CoreExpr dfListComp _ _ [] = panic "dfListComp" @@ -356,9 +357,9 @@ dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt" dfListComp _ _ (ApplicativeStmt {} : _) = panic "dfListComp ApplicativeStmt" -dfBindComp :: Id -> Id -- 'c' and 'n' - -> (LPat Id, CoreExpr) - -> [ExprStmt Id] -- the rest of the qual's +dfBindComp :: Id -> Id -- 'c' and 'n' + -> (LPat GhcTc, CoreExpr) + -> [ExprStmt GhcTc] -- the rest of the qual's -> DsM CoreExpr dfBindComp c_id n_id (pat, core_list1) quals = do -- find the required type @@ -478,7 +479,7 @@ mkUnzipBind _ elt_tys -- -- [:e | qss:] = <<[:e | qss:]>> () [:():] -- -dsPArrComp :: [ExprStmt Id] +dsPArrComp :: [ExprStmt GhcTc] -> DsM CoreExpr -- Special case for parallel comprehension @@ -514,8 +515,8 @@ dsPArrComp qs = do -- no ParStmt in `qs' -- the work horse -- -dePArrComp :: [ExprStmt Id] - -> LPat Id -- the current generator pattern +dePArrComp :: [ExprStmt GhcTc] + -> LPat GhcTc -- the current generator pattern -> CoreExpr -- the current generator expression -> DsM CoreExpr @@ -612,7 +613,7 @@ dePArrComp (ApplicativeStmt {} : _) _ _ = -- where -- {x_1, ..., x_n} = DV (qs) -- -dePArrParComp :: [ParStmtBlock Id Id] -> [ExprStmt Id] -> DsM CoreExpr +dePArrParComp :: [ParStmtBlock GhcTc GhcTc] -> [ExprStmt GhcTc] -> DsM CoreExpr dePArrParComp qss quals = do (pQss, ceQss) <- deParStmt qss dePArrComp quals pQss ceQss @@ -639,8 +640,8 @@ dePArrParComp qss quals = do -- generate Core corresponding to `\p -> e' -- deLambda :: Type -- type of the argument (not levity-polymorphic) - -> LPat Id -- argument pattern - -> LHsExpr Id -- body + -> LPat GhcTc -- argument pattern + -> LHsExpr GhcTc -- body -> DsM (CoreExpr, Type) deLambda ty p e = mkLambda ty p =<< dsLExpr e @@ -648,7 +649,7 @@ deLambda ty p e = -- generate Core for a lambda pattern match, where the body is already in Core -- mkLambda :: Type -- type of the argument (not levity-polymorphic) - -> LPat Id -- argument pattern + -> LPat GhcTc -- argument pattern -> CoreExpr -- desugared body -> DsM (CoreExpr, Type) mkLambda ty p ce = do @@ -672,15 +673,15 @@ parrElemType e = -- Translation for monad comprehensions -- Entry point for monad comprehension desugaring -dsMonadComp :: [ExprLStmt Id] -> DsM CoreExpr +dsMonadComp :: [ExprLStmt GhcTc] -> DsM CoreExpr dsMonadComp stmts = dsMcStmts stmts -dsMcStmts :: [ExprLStmt Id] -> DsM CoreExpr +dsMcStmts :: [ExprLStmt GhcTc] -> DsM CoreExpr dsMcStmts [] = panic "dsMcStmts" dsMcStmts (L loc stmt : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts) --------------- -dsMcStmt :: ExprStmt Id -> [ExprLStmt Id] -> DsM CoreExpr +dsMcStmt :: ExprStmt GhcTc -> [ExprLStmt GhcTc] -> DsM CoreExpr dsMcStmt (LastStmt body _ ret_op) stmts = ASSERT( null stmts ) @@ -803,12 +804,12 @@ matchTuple ids body -- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a -- desugared `CoreExpr` -dsMcBindStmt :: LPat Id +dsMcBindStmt :: LPat GhcTc -> CoreExpr -- ^ the desugared rhs of the bind statement - -> SyntaxExpr Id - -> SyntaxExpr Id + -> SyntaxExpr GhcTc + -> SyntaxExpr GhcTc -> Type -- ^ S in (>>=) :: Q -> (R -> S) -> T - -> [ExprLStmt Id] + -> [ExprLStmt GhcTc] -> DsM CoreExpr dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts = do { body <- dsMcStmts stmts @@ -840,9 +841,9 @@ dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts -- returns the desugaring of -- [ (a,b,c) | quals ] -dsInnerMonadComp :: [ExprLStmt Id] - -> [Id] -- Return a tuple of these variables - -> SyntaxExpr Id -- The monomorphic "return" operator +dsInnerMonadComp :: [ExprLStmt GhcTc] + -> [Id] -- Return a tuple of these variables + -> SyntaxExpr GhcTc -- The monomorphic "return" operator -> DsM CoreExpr dsInnerMonadComp stmts bndrs ret_op = dsMcStmts (stmts ++ [noLoc (LastStmt (mkBigLHsVarTupId bndrs) False ret_op)]) @@ -860,7 +861,7 @@ dsInnerMonadComp stmts bndrs ret_op -- , fmap (selN2 :: (t1, t2) -> t2) ys ) mkMcUnzipM :: TransForm - -> HsExpr TcId -- fmap + -> HsExpr GhcTcId -- fmap -> Id -- Of type n (a,b,c) -> [Type] -- [a,b,c] (not levity-polymorphic) -> DsM CoreExpr -- Of type (n a, n b, n c) diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index bb4361e34a..f7f2fd597e 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP, TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- @@ -64,7 +65,7 @@ import Control.Monad import Data.List ----------------------------------------------------------------------------- -dsBracket :: HsBracket Name -> [PendingTcSplice] -> DsM CoreExpr +dsBracket :: HsBracket GhcRn -> [PendingTcSplice] -> DsM CoreExpr -- Returns a CoreExpr of type TH.ExpQ -- The quoted thing is parameterised over Name, even though it has -- been type checked. We don't want all those type decorations! @@ -101,12 +102,12 @@ dsBracket brack splices -- Declarations ------------------------------------------------------- -repTopP :: LPat Name -> DsM (Core TH.PatQ) +repTopP :: LPat GhcRn -> DsM (Core TH.PatQ) repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat) ; pat' <- addBinds ss (repLP pat) ; wrapGenSyms ss pat' } -repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec])) +repTopDs :: HsGroup GhcRn -> DsM (Core (TH.Q [TH.Dec])) repTopDs group@(HsGroup { hs_valds = valds , hs_splcds = splcds , hs_tyclds = tyclds @@ -178,12 +179,12 @@ repTopDs group@(HsGroup { hs_valds = valds no_doc (L loc _) = notHandledL loc "Haddock documentation" empty -hsSigTvBinders :: HsValBinds Name -> [Name] +hsSigTvBinders :: HsValBinds GhcRn -> [Name] -- See Note [Scoped type variables in bindings] hsSigTvBinders binds = concatMap get_scoped_tvs sigs where - get_scoped_tvs :: LSig Name -> [Name] + get_scoped_tvs :: LSig GhcRn -> [Name] -- Both implicit and explicit quantified variables -- We need the implicit ones for f :: forall (a::k). blah -- here 'k' scopes too @@ -262,7 +263,7 @@ them into a `ForallT` or `ForallC`. Doing so caused #13018 and #13123. -- represent associated family instances -- -repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ)) +repTyClD :: LTyClDecl GhcRn -> DsM (Maybe (SrcSpan, Core TH.DecQ)) repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $ repFamilyDecl (L loc fam) @@ -297,7 +298,7 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, } ------------------------- -repRoleD :: LRoleAnnotDecl Name -> DsM (SrcSpan, Core TH.DecQ) +repRoleD :: LRoleAnnotDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) repRoleD (L loc (RoleAnnotDecl tycon roles)) = do { tycon1 <- lookupLOcc tycon ; roles1 <- mapM repRole roles @@ -308,7 +309,7 @@ repRoleD (L loc (RoleAnnotDecl tycon roles)) ------------------------- repDataDefn :: Core TH.Name -> Core [TH.TyVarBndr] -> Maybe (Core [TH.TypeQ]) - -> HsDataDefn Name + -> HsDataDefn GhcRn -> DsM (Core TH.DecQ) repDataDefn tc bndrs opt_tys (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt, dd_kindSig = ksig @@ -331,20 +332,20 @@ repDataDefn tc bndrs opt_tys } repSynDecl :: Core TH.Name -> Core [TH.TyVarBndr] - -> LHsType Name + -> LHsType GhcRn -> DsM (Core TH.DecQ) repSynDecl tc bndrs ty = do { ty1 <- repLTy ty ; repTySyn tc bndrs ty1 } -repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ) +repFamilyDecl :: LFamilyDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info, fdLName = tc, fdTyVars = tvs, fdResultSig = L _ resultSig, fdInjectivityAnn = injectivity })) = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] - ; let mkHsQTvs :: [LHsTyVarBndr Name] -> LHsQTyVars Name + ; let mkHsQTvs :: [LHsTyVarBndr GhcRn] -> LHsQTyVars GhcRn mkHsQTvs tvs = HsQTvs { hsq_implicit = [], hsq_explicit = tvs , hsq_dependent = emptyNameSet } resTyVar = case resultSig of @@ -372,7 +373,7 @@ repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info, } -- | Represent result signature of a type family -repFamilyResultSig :: FamilyResultSig Name -> DsM (Core TH.FamilyResultSig) +repFamilyResultSig :: FamilyResultSig GhcRn -> DsM (Core TH.FamilyResultSig) repFamilyResultSig NoSig = repNoSig repFamilyResultSig (KindSig ki) = do { ki' <- repLKind ki ; repKindSig ki' } @@ -382,7 +383,7 @@ repFamilyResultSig (TyVarSig bndr) = do { bndr' <- repTyVarBndr bndr -- | Represent result signature using a Maybe Kind. Used with data families, -- where the result signature can be either missing or a kind but never a named -- result variable. -repFamilyResultSigToMaybeKind :: FamilyResultSig Name +repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn -> DsM (Core (Maybe TH.Kind)) repFamilyResultSigToMaybeKind NoSig = do { coreNothing kindTyConName } @@ -392,7 +393,7 @@ repFamilyResultSigToMaybeKind (KindSig ki) = repFamilyResultSigToMaybeKind _ = panic "repFamilyResultSigToMaybeKind" -- | Represent injectivity annotation of a type family -repInjectivityAnn :: Maybe (LInjectivityAnn Name) +repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn) -> DsM (Core (Maybe TH.InjectivityAnn)) repInjectivityAnn Nothing = do { coreNothing injAnnTyConName } @@ -403,14 +404,14 @@ repInjectivityAnn (Just (L _ (InjectivityAnn lhs rhs))) = ; injAnn <- rep2 injectivityAnnName [unC lhs', unC rhs2] ; coreJust injAnnTyConName injAnn } -repFamilyDecls :: [LFamilyDecl Name] -> DsM [Core TH.DecQ] +repFamilyDecls :: [LFamilyDecl GhcRn] -> DsM [Core TH.DecQ] repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds) -repAssocTyFamDefaults :: [LTyFamDefltEqn Name] -> DsM [Core TH.DecQ] +repAssocTyFamDefaults :: [LTyFamDefltEqn GhcRn] -> DsM [Core TH.DecQ] repAssocTyFamDefaults = mapM rep_deflt where -- very like repTyFamEqn, but different in the details - rep_deflt :: LTyFamDefltEqn Name -> DsM (Core TH.DecQ) + rep_deflt :: LTyFamDefltEqn GhcRn -> DsM (Core TH.DecQ) rep_deflt (L _ (TyFamEqn { tfe_tycon = tc , tfe_pats = bndrs , tfe_rhs = rhs })) @@ -436,7 +437,7 @@ repLFunDep (L _ (xs, ys)) -- Represent instance declarations -- -repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ) +repInstD :: LInstDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) repInstD (L loc (TyFamInstD { tfid_inst = fi_decl })) = do { dec <- repTyFamInstD fi_decl ; return (loc, dec) } @@ -447,7 +448,7 @@ repInstD (L loc (ClsInstD { cid_inst = cls_decl })) = do { dec <- repClsInstD cls_decl ; return (loc, dec) } -repClsInstD :: ClsInstDecl Name -> DsM (Core TH.DecQ) +repClsInstD :: ClsInstDecl GhcRn -> DsM (Core TH.DecQ) repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds , cid_sigs = prags, cid_tyfam_insts = ats , cid_datafam_insts = adts @@ -475,7 +476,7 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds where (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty -repStandaloneDerivD :: LDerivDecl Name -> DsM (SrcSpan, Core TH.DecQ) +repStandaloneDerivD :: LDerivDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat , deriv_type = ty })) = do { dec <- addSimpleTyVarBinds tvs $ @@ -487,14 +488,14 @@ repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat where (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty -repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ) +repTyFamInstD :: TyFamInstDecl GhcRn -> DsM (Core TH.DecQ) repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn }) = do { let tc_name = tyFamInstDeclLName decl ; tc <- lookupLOcc tc_name -- See note [Binders and occurrences] ; eqn1 <- repTyFamEqn eqn ; repTySynInst tc eqn1 } -repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ) +repTyFamEqn :: LTyFamInstEqn GhcRn -> DsM (Core TH.TySynEqnQ) repTyFamEqn (L _ (TyFamEqn { tfe_pats = HsIB { hsib_body = tys , hsib_vars = var_names } , tfe_rhs = rhs })) @@ -507,7 +508,7 @@ repTyFamEqn (L _ (TyFamEqn { tfe_pats = HsIB { hsib_body = tys ; rhs1 <- repLTy rhs ; repTySynEqn tys2 rhs1 } } -repDataFamInstD :: DataFamInstDecl Name -> DsM (Core TH.DecQ) +repDataFamInstD :: DataFamInstDecl GhcRn -> DsM (Core TH.DecQ) repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name , dfid_pats = HsIB { hsib_body = tys, hsib_vars = var_names } , dfid_defn = defn }) @@ -519,7 +520,7 @@ repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name do { tys1 <- repList typeQTyConName repLTy tys ; repDataDefn tc bndrs (Just tys1) defn } } -repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ) +repForD :: Located (ForeignDecl GhcRn) -> DsM (SrcSpan, Core TH.DecQ) repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ , fd_fi = CImport (L _ cc) (L _ s) mch cis _ })) = do MkC name' <- lookupLOcc name @@ -560,7 +561,7 @@ repSafety PlayRisky = rep2 unsafeName [] repSafety PlayInterruptible = rep2 interruptibleName [] repSafety PlaySafe = rep2 safeName [] -repFixD :: LFixitySig Name -> DsM [(SrcSpan, Core TH.DecQ)] +repFixD :: LFixitySig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)] repFixD (L loc (FixitySig names (Fixity _ prec dir))) = do { MkC prec' <- coreIntLit prec ; let rep_fn = case dir of @@ -573,7 +574,7 @@ repFixD (L loc (FixitySig names (Fixity _ prec dir))) ; return (loc,dec) } ; mapM do_one names } -repRuleD :: LRuleDecl Name -> DsM (SrcSpan, Core TH.DecQ) +repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) repRuleD (L loc (HsRule n act bndrs lhs _ rhs _)) = do { let bndr_names = concatMap ruleBndrNames bndrs ; ss <- mkGenSyms bndr_names @@ -587,13 +588,13 @@ repRuleD (L loc (HsRule n act bndrs lhs _ rhs _)) ; rule2 <- wrapGenSyms ss rule1 ; return (loc, rule2) } -ruleBndrNames :: LRuleBndr Name -> [Name] +ruleBndrNames :: LRuleBndr GhcRn -> [Name] ruleBndrNames (L _ (RuleBndr n)) = [unLoc n] ruleBndrNames (L _ (RuleBndrSig n sig)) | HsWC { hswc_body = HsIB { hsib_vars = vars }} <- sig = unLoc n : vars -repRuleBndr :: LRuleBndr Name -> DsM (Core TH.RuleBndrQ) +repRuleBndr :: LRuleBndr GhcRn -> DsM (Core TH.RuleBndrQ) repRuleBndr (L _ (RuleBndr n)) = do { MkC n' <- lookupLBinder n ; rep2 ruleVarName [n'] } @@ -602,7 +603,7 @@ repRuleBndr (L _ (RuleBndrSig n sig)) ; MkC ty' <- repLTy (hsSigWcType sig) ; rep2 typedRuleVarName [n', ty'] } -repAnnD :: LAnnDecl Name -> DsM (SrcSpan, Core TH.DecQ) +repAnnD :: LAnnDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) repAnnD (L loc (HsAnnotation _ ann_prov (L _ exp))) = do { target <- repAnnProv ann_prov ; exp' <- repE exp @@ -623,7 +624,7 @@ repAnnProv ModuleAnnProvenance -- Constructors ------------------------------------------------------- -repC :: LConDecl Name -> DsM (Core TH.ConQ) +repC :: LConDecl GhcRn -> DsM (Core TH.ConQ) repC (L _ (ConDeclH98 { con_name = con , con_qvars = Nothing, con_cxt = Nothing , con_details = details })) @@ -681,7 +682,7 @@ repSrcStrictness SrcLazy = rep2 sourceLazyName [] repSrcStrictness SrcStrict = rep2 sourceStrictName [] repSrcStrictness NoSrcStrict = rep2 noSourceStrictnessName [] -repBangTy :: LBangType Name -> DsM (Core (TH.BangTypeQ)) +repBangTy :: LBangType GhcRn -> DsM (Core (TH.BangTypeQ)) repBangTy ty = do MkC u <- repSrcUnpackedness su' MkC s <- repSrcStrictness ss' @@ -697,10 +698,10 @@ repBangTy ty = do -- Deriving clauses ------------------------------------------------------- -repDerivs :: HsDeriving Name -> DsM (Core [TH.DerivClauseQ]) +repDerivs :: HsDeriving GhcRn -> DsM (Core [TH.DerivClauseQ]) repDerivs (L _ clauses) = repList derivClauseQTyConName repDerivClause clauses -repDerivClause :: LHsDerivingClause Name +repDerivClause :: LHsDerivingClause GhcRn -> DsM (Core TH.DerivClauseQ) repDerivClause (L _ (HsDerivingClause { deriv_clause_strategy = dcs , deriv_clause_tys = L _ dct })) @@ -708,22 +709,22 @@ repDerivClause (L _ (HsDerivingClause { deriv_clause_strategy = dcs MkC dct' <- repList typeQTyConName (rep_deriv_ty . hsSigType) dct rep2 derivClauseName [dcs',dct'] where - rep_deriv_ty :: LHsType Name -> DsM (Core TH.TypeQ) + rep_deriv_ty :: LHsType GhcRn -> DsM (Core TH.TypeQ) rep_deriv_ty (L _ ty) = repTy ty ------------------------------------------------------- -- Signatures in a class decl, or a group of bindings ------------------------------------------------------- -rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ] +rep_sigs :: [LSig GhcRn] -> DsM [Core TH.DecQ] rep_sigs sigs = do locs_cores <- rep_sigs' sigs return $ de_loc $ sort_by_loc locs_cores -rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)] +rep_sigs' :: [LSig GhcRn] -> DsM [(SrcSpan, Core TH.DecQ)] -- We silently ignore ones we don't recognise rep_sigs' = concatMapM rep_sig -rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)] +rep_sig :: LSig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)] rep_sig (L loc (TypeSig nms ty)) = mapM (rep_wc_ty_sig sigDName loc ty) nms rep_sig (L loc (PatSynSig nms ty)) = mapM (rep_patsyn_ty_sig loc ty) nms rep_sig (L loc (ClassOpSig is_deflt nms ty)) @@ -740,7 +741,7 @@ rep_sig (L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty rep_sig (L loc (CompleteMatchSig _st cls mty)) = rep_complete_sig cls mty loc -rep_ty_sig :: Name -> SrcSpan -> LHsSigType Name -> Located Name +rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name -> DsM (SrcSpan, Core TH.DecQ) rep_ty_sig mk_sig loc sig_ty nm = do { nm1 <- lookupLOcc nm @@ -748,7 +749,7 @@ rep_ty_sig mk_sig loc sig_ty nm ; sig <- repProto mk_sig nm1 ty1 ; return (loc, sig) } -rep_patsyn_ty_sig :: SrcSpan -> LHsSigType Name -> Located Name +rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name -> DsM (SrcSpan, Core TH.DecQ) -- represents a pattern synonym type signature; -- see Note [Pattern synonym type signatures and Template Haskell] in Convert @@ -758,7 +759,7 @@ rep_patsyn_ty_sig loc sig_ty nm ; sig <- repProto patSynSigDName nm1 ty1 ; return (loc, sig) } -rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType Name -> Located Name +rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> Located Name -> DsM (SrcSpan, Core TH.DecQ) -- We must special-case the top-level explicit for-all of a TypeSig -- See Note [Scoped type variables in bindings] @@ -794,7 +795,8 @@ rep_inline nm ispec loc ; return [(loc, pragma)] } -rep_specialise :: Located Name -> LHsSigType Name -> InlinePragma -> SrcSpan +rep_specialise :: Located Name -> LHsSigType GhcRn -> InlinePragma + -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)] rep_specialise nm ty ispec loc = do { nm1 <- lookupLOcc nm @@ -810,7 +812,8 @@ rep_specialise nm ty ispec loc ; return [(loc, pragma)] } -rep_specialiseInst :: LHsSigType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)] +rep_specialiseInst :: LHsSigType GhcRn -> SrcSpan + -> DsM [(SrcSpan, Core TH.DecQ)] rep_specialiseInst ty loc = do { ty1 <- repHsSigType ty ; pragma <- repPragSpecInst ty1 @@ -860,7 +863,7 @@ addSimpleTyVarBinds names thing_inside ; term <- addBinds fresh_names thing_inside ; wrapGenSyms fresh_names term } -addTyVarBinds :: LHsQTyVars Name -- the binders to be added +addTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a))) -- action in the ext env -> DsM (Core (TH.Q a)) -- gensym a list of type variables and enter them into the meta environment; @@ -879,7 +882,7 @@ addTyVarBinds (HsQTvs { hsq_implicit = imp_tvs, hsq_explicit = exp_tvs }) m where mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v) -addTyClTyVarBinds :: LHsQTyVars Name +addTyClTyVarBinds :: LHsQTyVars GhcRn -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a))) -> DsM (Core (TH.Q a)) @@ -906,7 +909,7 @@ addTyClTyVarBinds tvs m -- Produce kinded binder constructors from the Haskell tyvar binders -- -repTyVarBndrWithKind :: LHsTyVarBndr Name +repTyVarBndrWithKind :: LHsTyVarBndr GhcRn -> Core TH.Name -> DsM (Core TH.TyVarBndr) repTyVarBndrWithKind (L _ (UserTyVar _)) nm = repPlainTV nm @@ -914,7 +917,7 @@ repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm = repLKind ki >>= repKindedTV nm -- | Represent a type variable binder -repTyVarBndr :: LHsTyVarBndr Name -> DsM (Core TH.TyVarBndr) +repTyVarBndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndr) repTyVarBndr (L _ (UserTyVar (L _ nm)) )= do { nm' <- lookupBinder nm ; repPlainTV nm' } repTyVarBndr (L _ (KindedTyVar (L _ nm) ki)) = do { nm' <- lookupBinder nm @@ -923,14 +926,14 @@ repTyVarBndr (L _ (KindedTyVar (L _ nm) ki)) = do { nm' <- lookupBinder nm -- represent a type context -- -repLContext :: LHsContext Name -> DsM (Core TH.CxtQ) +repLContext :: LHsContext GhcRn -> DsM (Core TH.CxtQ) repLContext (L _ ctxt) = repContext ctxt -repContext :: HsContext Name -> DsM (Core TH.CxtQ) +repContext :: HsContext GhcRn -> DsM (Core TH.CxtQ) repContext ctxt = do preds <- repList typeQTyConName repLTy ctxt repCtxt preds -repHsSigType :: LHsSigType Name -> DsM (Core TH.TypeQ) +repHsSigType :: LHsSigType GhcRn -> DsM (Core TH.TypeQ) repHsSigType (HsIB { hsib_vars = implicit_tvs , hsib_body = body }) | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy body @@ -946,7 +949,7 @@ repHsSigType (HsIB { hsib_vars = implicit_tvs then return th_ty else repTForall th_explicit_tvs th_ctxt th_ty } -repHsPatSynSigType :: LHsSigType Name -> DsM (Core TH.TypeQ) +repHsPatSynSigType :: LHsSigType GhcRn -> DsM (Core TH.TypeQ) repHsPatSynSigType (HsIB { hsib_vars = implicit_tvs , hsib_body = body }) = addTyVarBinds (newTvs implicit_tvs univs) $ \th_univs -> @@ -965,19 +968,19 @@ repHsPatSynSigType (HsIB { hsib_vars = implicit_tvs (univs, reqs, exis, provs, ty) = splitLHsPatSynTy body -repHsSigWcType :: LHsSigWcType Name -> DsM (Core TH.TypeQ) +repHsSigWcType :: LHsSigWcType GhcRn -> DsM (Core TH.TypeQ) repHsSigWcType (HsWC { hswc_body = sig1 }) = repHsSigType sig1 -- yield the representation of a list of types -repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ] +repLTys :: [LHsType GhcRn] -> DsM [Core TH.TypeQ] repLTys tys = mapM repLTy tys -- represent a type -repLTy :: LHsType Name -> DsM (Core TH.TypeQ) +repLTy :: LHsType GhcRn -> DsM (Core TH.TypeQ) repLTy (L _ ty) = repTy ty -repForall :: HsType Name -> DsM (Core TH.TypeQ) +repForall :: HsType GhcRn -> DsM (Core TH.TypeQ) -- Arg of repForall is always HsForAllTy or HsQualTy repForall ty | (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty) @@ -987,7 +990,7 @@ repForall ty ; ty1 <- repLTy tau ; repTForall bndrs ctxt1 ty1 } -repTy :: HsType Name -> DsM (Core TH.TypeQ) +repTy :: HsType GhcRn -> DsM (Core TH.TypeQ) repTy ty@(HsForAllTy {}) = repForall ty repTy ty@(HsQualTy {}) = repForall ty @@ -1066,7 +1069,7 @@ repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s -- represent a kind -- -repLKind :: LHsKind Name -> DsM (Core TH.Kind) +repLKind :: LHsKind GhcRn -> DsM (Core TH.Kind) repLKind ki = do { let (kis, ki') = splitHsFunType ki ; kis_rep <- mapM repLKind kis @@ -1077,7 +1080,7 @@ repLKind ki } -- | Represent a kind wrapped in a Maybe -repMaybeLKind :: Maybe (LHsKind Name) +repMaybeLKind :: Maybe (LHsKind GhcRn) -> DsM (Core (Maybe TH.Kind)) repMaybeLKind Nothing = do { coreNothing kindTyConName } @@ -1085,10 +1088,10 @@ repMaybeLKind (Just ki) = do { ki' <- repLKind ki ; coreJust kindTyConName ki' } -repNonArrowLKind :: LHsKind Name -> DsM (Core TH.Kind) +repNonArrowLKind :: LHsKind GhcRn -> DsM (Core TH.Kind) repNonArrowLKind (L _ ki) = repNonArrowKind ki -repNonArrowKind :: HsKind Name -> DsM (Core TH.Kind) +repNonArrowKind :: HsKind GhcRn -> DsM (Core TH.Kind) repNonArrowKind (HsTyVar _ (L _ name)) | isLiftedTypeKindTyConName name = repKStar | name `hasKey` constraintKindTyConKey = repKConstraint @@ -1118,7 +1121,7 @@ repRole (L _ Nothing) = rep2 inferRName [] -- Splices ----------------------------------------------------------------------------- -repSplice :: HsSplice Name -> DsM (Core a) +repSplice :: HsSplice GhcRn -> DsM (Core a) -- See Note [How brackets and nested splices are handled] in TcSplice -- We return a CoreExpr of any old type; the context should know repSplice (HsTypedSplice _ n _) = rep_splice n @@ -1139,16 +1142,16 @@ rep_splice splice_name -- Expressions ----------------------------------------------------------------------------- -repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ]) +repLEs :: [LHsExpr GhcRn] -> DsM (Core [TH.ExpQ]) repLEs es = repList expQTyConName repLE es -- FIXME: some of these panics should be converted into proper error messages -- unless we can make sure that constructs, which are plainly not -- supported in TH already lead to error messages at an earlier stage -repLE :: LHsExpr Name -> DsM (Core TH.ExpQ) +repLE :: LHsExpr GhcRn -> DsM (Core TH.ExpQ) repLE (L loc e) = putSrcSpanDs loc (repE e) -repE :: HsExpr Name -> DsM (Core TH.ExpQ) +repE :: HsExpr GhcRn -> DsM (Core TH.ExpQ) repE (HsVar (L _ x)) = do { mb_val <- dsLookupMetaEnv x ; case mb_val of @@ -1284,7 +1287,7 @@ repE e = notHandled "Expression form" (ppr e) ----------------------------------------------------------------------------- -- Building representations of auxillary structures like Match, Clause, Stmt, -repMatchTup :: LMatch Name (LHsExpr Name) -> DsM (Core TH.MatchQ) +repMatchTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.MatchQ) repMatchTup (L _ (Match _ [p] _ (GRHSs guards (L _ wheres)))) = do { ss1 <- mkGenSyms (collectPatBinders p) ; addBinds ss1 $ do { @@ -1296,7 +1299,7 @@ repMatchTup (L _ (Match _ [p] _ (GRHSs guards (L _ wheres)))) = ; wrapGenSyms (ss1++ss2) match }}} repMatchTup _ = panic "repMatchTup: case alt with more than one arg" -repClauseTup :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ClauseQ) +repClauseTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ClauseQ) repClauseTup (L _ (Match _ ps _ (GRHSs guards (L _ wheres)))) = do { ss1 <- mkGenSyms (collectPatsBinders ps) ; addBinds ss1 $ do { @@ -1307,7 +1310,7 @@ repClauseTup (L _ (Match _ ps _ (GRHSs guards (L _ wheres)))) = ; clause <- repClause ps1 gs ds ; wrapGenSyms (ss1++ss2) clause }}} -repGuards :: [LGRHS Name (LHsExpr Name)] -> DsM (Core TH.BodyQ) +repGuards :: [LGRHS GhcRn (LHsExpr GhcRn)] -> DsM (Core TH.BodyQ) repGuards [L _ (GRHS [] e)] = do {a <- repLE e; repNormal a } repGuards other @@ -1316,7 +1319,8 @@ repGuards other ; gd <- repGuarded (nonEmptyCoreList ys) ; wrapGenSyms (concat xs) gd } -repLGRHS :: LGRHS Name (LHsExpr Name) -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp)))) +repLGRHS :: LGRHS GhcRn (LHsExpr GhcRn) + -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp)))) repLGRHS (L _ (GRHS [L _ (BodyStmt e1 _ _ _)] e2)) = do { guarded <- repLNormalGE e1 e2 ; return ([], guarded) } @@ -1326,19 +1330,20 @@ repLGRHS (L _ (GRHS ss rhs)) ; guarded <- repPatGE (nonEmptyCoreList ss') rhs' ; return (gs, guarded) } -repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp]) +repFields :: HsRecordBinds GhcRn -> DsM (Core [TH.Q TH.FieldExp]) repFields (HsRecFields { rec_flds = flds }) = repList fieldExpQTyConName rep_fld flds where - rep_fld :: LHsRecField Name (LHsExpr Name) -> DsM (Core (TH.Q TH.FieldExp)) + rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn) + -> DsM (Core (TH.Q TH.FieldExp)) rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld) ; e <- repLE (hsRecFieldArg fld) ; repFieldExp fn e } -repUpdFields :: [LHsRecUpdField Name] -> DsM (Core [TH.Q TH.FieldExp]) +repUpdFields :: [LHsRecUpdField GhcRn] -> DsM (Core [TH.Q TH.FieldExp]) repUpdFields = repList fieldExpQTyConName rep_fld where - rep_fld :: LHsRecUpdField Name -> DsM (Core (TH.Q TH.FieldExp)) + rep_fld :: LHsRecUpdField GhcRn -> DsM (Core (TH.Q TH.FieldExp)) rep_fld (L l fld) = case unLoc (hsRecFieldLbl fld) of Unambiguous _ sel_name -> do { fn <- lookupLOcc (L l sel_name) ; e <- repLE (hsRecFieldArg fld) @@ -1372,10 +1377,10 @@ repUpdFields = repList fieldExpQTyConName rep_fld -- The helper function repSts computes the translation of each sub expression -- and a bunch of prefix bindings denoting the dynamic renaming. -repLSts :: [LStmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ]) +repLSts :: [LStmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ]) repLSts stmts = repSts (map unLoc stmts) -repSts :: [Stmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ]) +repSts :: [Stmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ]) repSts (BindStmt p e _ _ _ : ss) = do { e2 <- repLE e ; ss1 <- mkGenSyms (collectPatBinders p) @@ -1402,7 +1407,8 @@ repSts (ParStmt stmt_blocks _ _ _ : ss) = ; (ss2, zs) <- addBinds ss1 (repSts ss) ; return (ss1++ss2, z : zs) } where - rep_stmt_block :: ParStmtBlock Name Name -> DsM ([GenSymBind], Core [TH.StmtQ]) + rep_stmt_block :: ParStmtBlock GhcRn GhcRn + -> DsM ([GenSymBind], Core [TH.StmtQ]) rep_stmt_block (ParStmtBlock stmts _ _) = do { (ss1, zs) <- repSts (map unLoc stmts) ; zs1 <- coreList stmtQTyConName zs @@ -1419,7 +1425,7 @@ repSts other = notHandled "Exotic statement" (ppr other) -- Bindings ----------------------------------------------------------- -repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ]) +repBinds :: HsLocalBinds GhcRn -> DsM ([GenSymBind], Core [TH.DecQ]) repBinds EmptyLocalBinds = do { core_list <- coreList decQTyConName [] ; return ([], core_list) } @@ -1439,7 +1445,7 @@ repBinds (HsValBinds decs) (de_loc (sort_by_loc prs)) ; return (ss, core_list) } -rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)] +rep_val_binds :: HsValBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)] -- Assumes: all the binders of the binding are already in the meta-env rep_val_binds (ValBindsOut binds sigs) = do { core1 <- rep_binds' (unionManyBags (map snd binds)) @@ -1448,14 +1454,14 @@ rep_val_binds (ValBindsOut binds sigs) rep_val_binds (ValBindsIn _ _) = panic "rep_val_binds: ValBindsIn" -rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ] +rep_binds :: LHsBinds GhcRn -> DsM [Core TH.DecQ] rep_binds binds = do { binds_w_locs <- rep_binds' binds ; return (de_loc (sort_by_loc binds_w_locs)) } -rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)] +rep_binds' :: LHsBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)] rep_binds' = mapM rep_bind . bagToList -rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ) +rep_bind :: LHsBind GhcRn -> DsM (SrcSpan, Core TH.DecQ) -- Assumes: all the binders of the binding are already in the meta-env -- Note GHC treats declarations of a variable (not a pattern) @@ -1571,7 +1577,7 @@ repRecordPatSynArgs :: Core [TH.Name] -> DsM (Core TH.PatSynArgsQ) repRecordPatSynArgs (MkC sels) = rep2 recordPatSynName [sels] -repPatSynDir :: HsPatSynDir Name -> DsM (Core TH.PatSynDirQ) +repPatSynDir :: HsPatSynDir GhcRn -> DsM (Core TH.PatSynDirQ) repPatSynDir Unidirectional = rep2 unidirPatSynName [] repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName [] repPatSynDir (ExplicitBidirectional (MG { mg_alts = L _ clauses })) @@ -1606,7 +1612,7 @@ repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls] -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like -- (\ p1 .. pn -> exp) by causing an error. -repLambda :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ExpQ) +repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ExpQ) repLambda (L _ (Match _ ps _ (GRHSs [L _ (GRHS [] e)] (L _ EmptyLocalBinds)))) = do { let bndrs = collectPatsBinders ps ; ; ss <- mkGenSyms bndrs @@ -1625,13 +1631,13 @@ repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch m) -- variable should already appear in the environment. -- Process a list of patterns -repLPs :: [LPat Name] -> DsM (Core [TH.PatQ]) +repLPs :: [LPat GhcRn] -> DsM (Core [TH.PatQ]) repLPs ps = repList patQTyConName repLP ps -repLP :: LPat Name -> DsM (Core TH.PatQ) +repLP :: LPat GhcRn -> DsM (Core TH.PatQ) repLP (L _ p) = repP p -repP :: Pat Name -> DsM (Core TH.PatQ) +repP :: Pat GhcRn -> DsM (Core TH.PatQ) repP (WildPat _) = repPwild repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 } repP (VarPat (L _ x)) = do { x' <- lookupBinder x; repPvar x' } @@ -1656,7 +1662,7 @@ repP (ConPatIn dc details) repPinfix p1' con_str p2' } } where - rep_fld :: LHsRecField Name (LPat Name) -> DsM (Core (TH.Name,TH.PatQ)) + rep_fld :: LHsRecField GhcRn (LPat GhcRn) -> DsM (Core (TH.Name,TH.PatQ)) rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld) ; MkC p <- repLP (hsRecFieldArg fld) ; rep2 fieldPatName [v,p] } @@ -1977,7 +1983,8 @@ repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ) repNormal (MkC e) = rep2 normalBName [e] ------------ Guards ---- -repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp))) +repLNormalGE :: LHsExpr GhcRn -> LHsExpr GhcRn + -> DsM (Core (TH.Q (TH.Guard, TH.Exp))) repLNormalGE g e = do g' <- repLE g e' <- repLE e repNormalGE g' e' @@ -2171,15 +2178,15 @@ repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ) repCtxt (MkC tys) = rep2 cxtName [tys] repDataCon :: Located Name - -> HsConDeclDetails Name + -> HsConDeclDetails GhcRn -> DsM (Core TH.ConQ) repDataCon con details = do con' <- lookupLOcc con -- See Note [Binders and occurrences] repConstr details Nothing [con'] repGadtDataCons :: [Located Name] - -> HsConDeclDetails Name - -> LHsType Name + -> HsConDeclDetails GhcRn + -> LHsType GhcRn -> DsM (Core TH.ConQ) repGadtDataCons cons details res_ty = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences] @@ -2190,8 +2197,8 @@ repGadtDataCons cons details res_ty -- argument is a singleton list -- * for GADTs data constructors second argument is (Just return_type) and -- third argument is a non-empty list -repConstr :: HsConDeclDetails Name - -> Maybe (LHsType Name) +repConstr :: HsConDeclDetails GhcRn + -> Maybe (LHsType GhcRn) -> [Core TH.Name] -> DsM (Core TH.ConQ) repConstr (PrefixCon ps) Nothing [con] @@ -2216,7 +2223,7 @@ repConstr (RecCon (L _ ips)) resTy cons where rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip) - rep_one_ip :: LBangType Name -> LFieldOcc Name -> DsM (Core a) + rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> DsM (Core a) rep_one_ip t n = do { MkC v <- lookupOcc (selectorFieldOcc $ unLoc n) ; MkC ty <- repBangTy t ; rep2 varBangTypeName [v,ty] } @@ -2359,7 +2366,7 @@ repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr] ---------------------------------------------------------- -- Literals -repLiteral :: HsLit -> DsM (Core TH.Lit) +repLiteral :: HsLit GhcRn -> DsM (Core TH.Lit) repLiteral (HsStringPrim _ bs) = do dflags <- getDynFlags word8_ty <- lookupType word8TyConName @@ -2371,9 +2378,9 @@ repLiteral lit = do lit' <- case lit of HsIntPrim _ i -> mk_integer i HsWordPrim _ w -> mk_integer w - HsInt i -> mk_integer (il_value i) - HsFloatPrim r -> mk_rational r - HsDoublePrim r -> mk_rational r + HsInt _ i -> mk_integer (il_value i) + HsFloatPrim _ r -> mk_rational r + HsDoublePrim _ r -> mk_rational r HsCharPrim _ c -> mk_char c _ -> return lit lit_expr <- dsLit lit' @@ -2383,38 +2390,38 @@ repLiteral lit where mb_lit_name = case lit of HsInteger _ _ _ -> Just integerLName - HsInt _ -> Just integerLName + HsInt _ _ -> Just integerLName HsIntPrim _ _ -> Just intPrimLName HsWordPrim _ _ -> Just wordPrimLName - HsFloatPrim _ -> Just floatPrimLName - HsDoublePrim _ -> Just doublePrimLName + HsFloatPrim _ _ -> Just floatPrimLName + HsDoublePrim _ _ -> Just doublePrimLName HsChar _ _ -> Just charLName HsCharPrim _ _ -> Just charPrimLName HsString _ _ -> Just stringLName - HsRat _ _ -> Just rationalLName + HsRat _ _ _ -> Just rationalLName _ -> Nothing -mk_integer :: Integer -> DsM HsLit +mk_integer :: Integer -> DsM (HsLit GhcRn) mk_integer i = do integer_ty <- lookupType integerTyConName - return $ HsInteger NoSourceText i integer_ty + return $ HsInteger noSourceText i integer_ty -mk_rational :: FractionalLit -> DsM HsLit +mk_rational :: FractionalLit -> DsM (HsLit GhcRn) mk_rational r = do rat_ty <- lookupType rationalTyConName - return $ HsRat r rat_ty -mk_string :: FastString -> DsM HsLit -mk_string s = return $ HsString NoSourceText s + return $ HsRat def r rat_ty +mk_string :: FastString -> DsM (HsLit GhcRn) +mk_string s = return $ HsString noSourceText s -mk_char :: Char -> DsM HsLit -mk_char c = return $ HsChar NoSourceText c +mk_char :: Char -> DsM (HsLit GhcRn) +mk_char c = return $ HsChar noSourceText c -repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit) +repOverloadedLiteral :: HsOverLit GhcRn -> DsM (Core TH.Lit) repOverloadedLiteral (OverLit { ol_val = val}) = do { lit <- mk_lit val; repLiteral lit } -- The type Rational will be in the environment, because -- the smart constructor 'TH.Syntax.rationalL' uses it in its type, -- and rationalL is sucked in when any TH stuff is used -mk_lit :: OverLitVal -> DsM HsLit +mk_lit :: OverLitVal -> DsM (HsLit GhcRn) mk_lit (HsIntegral i) = mk_integer (il_value i) mk_lit (HsFractional f) = mk_rational f mk_lit (HsIsString _ s) = mk_string s @@ -2443,12 +2450,12 @@ repUnboundVar (MkC name) = rep2 unboundVarEName [name] -- turn a list of patterns into a single pattern matching a list repList :: Name -> (a -> DsM (Core b)) - -> [a] -> DsM (Core [b]) + -> [a] -> DsM (Core [b]) repList tc_name f args = do { args1 <- mapM f args ; coreList tc_name args1 } -coreList :: Name -- Of the TyCon of the element type +coreList :: Name -- Of the TyCon of the element type -> [Core a] -> DsM (Core [a]) coreList tc_name es = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) } diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs index 81a8e35d7c..c3a29733be 100644 --- a/compiler/deSugar/DsMonad.hs +++ b/compiler/deSugar/DsMonad.hs @@ -105,7 +105,7 @@ instance Outputable DsMatchContext where ppr (DsMatchContext hs_match ss) = ppr ss <+> pprMatchContext hs_match data EquationInfo - = EqnInfo { eqn_pats :: [Pat Id], -- The patterns for an eqn + = EqnInfo { eqn_pats :: [Pat GhcTc], -- The patterns for an eqn eqn_rhs :: MatchResult } -- What to do after match instance Outputable EquationInfo where diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs index db757d6afe..4ef279faed 100644 --- a/compiler/deSugar/DsUtils.hs +++ b/compiler/deSugar/DsUtils.hs @@ -92,7 +92,7 @@ hand, which should indeed be bound to the pattern as a whole, then use it; otherwise, make one up. -} -selectSimpleMatchVarL :: LPat Id -> DsM Id +selectSimpleMatchVarL :: LPat GhcTc -> DsM Id selectSimpleMatchVarL pat = selectMatchVar (unLoc pat) -- (selectMatchVars ps tys) chooses variables of type tys @@ -111,10 +111,10 @@ selectSimpleMatchVarL pat = selectMatchVar (unLoc pat) -- Then we must not choose (x::Int) as the matching variable! -- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat -selectMatchVars :: [Pat Id] -> DsM [Id] +selectMatchVars :: [Pat GhcTc] -> DsM [Id] selectMatchVars ps = mapM selectMatchVar ps -selectMatchVar :: Pat Id -> DsM Id +selectMatchVar :: Pat GhcTc -> DsM Id selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat) selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat) selectMatchVar (ParPat pat) = selectMatchVar (unLoc pat) @@ -174,7 +174,7 @@ The ``equation info'' used by @match@ is relatively complicated and worthy of a type synonym and a few handy functions. -} -firstPat :: EquationInfo -> Pat Id +firstPat :: EquationInfo -> Pat GhcTc firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn) shiftEqns :: [EquationInfo] -> [EquationInfo] @@ -255,7 +255,7 @@ mkGuardedMatchResult pred_expr (MatchResult _ body_fn) = MatchResult CanFail (\fail -> do body <- body_fn fail return (mkIfThenElse pred_expr body fail)) -mkCoPrimCaseMatchResult :: Id -- Scrutinee +mkCoPrimCaseMatchResult :: Id -- Scrutinee -> Type -- Type of the case -> [(Literal, MatchResult)] -- Alternatives -> MatchResult -- Literals are all unlifted @@ -414,7 +414,8 @@ mkDataConCase var ty alts@(alt1:_) = MatchResult fail_flag mk_case -- parallel arrays, which are introduced by `tidy1' in the `PArrPat' -- case -- -mkPArrCase :: DynFlags -> Id -> Type -> [CaseAlt DataCon] -> CoreExpr -> DsM CoreExpr +mkPArrCase :: DynFlags -> Id -> Type -> [CaseAlt DataCon] -> CoreExpr + -> DsM CoreExpr mkPArrCase dflags var ty sorted_alts fail = do lengthP <- dsDPHBuiltin lengthPVar alt <- unboxAlt @@ -725,7 +726,7 @@ work out well: -} mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly - -> LPat Id -- ^ The pattern + -> LPat GhcTc -- ^ The pattern -> CoreExpr -- ^ Expression to which the pattern is bound -> DsM (Id,[(Id,CoreExpr)]) -- ^ Id the rhs is bound to, for desugaring strict @@ -814,31 +815,31 @@ is_triv_pat _ = False * * ********************************************************************* -} -mkLHsPatTup :: [LPat Id] -> LPat Id +mkLHsPatTup :: [LPat GhcTc] -> LPat GhcTc mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed mkLHsPatTup [lpat] = lpat mkLHsPatTup lpats = L (getLoc (head lpats)) $ mkVanillaTuplePat lpats Boxed -mkLHsVarPatTup :: [Id] -> LPat Id +mkLHsVarPatTup :: [Id] -> LPat GhcTc mkLHsVarPatTup bs = mkLHsPatTup (map nlVarPat bs) -mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id +mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc -- A vanilla tuple pattern simply gets its type from its sub-patterns mkVanillaTuplePat pats box = TuplePat pats box (map hsLPatType pats) -- The Big equivalents for the source tuple expressions -mkBigLHsVarTupId :: [Id] -> LHsExpr Id +mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc mkBigLHsVarTupId ids = mkBigLHsTupId (map nlHsVar ids) -mkBigLHsTupId :: [LHsExpr Id] -> LHsExpr Id +mkBigLHsTupId :: [LHsExpr GhcTc] -> LHsExpr GhcTc mkBigLHsTupId = mkChunkified mkLHsTupleExpr -- The Big equivalents for the source tuple patterns -mkBigLHsVarPatTupId :: [Id] -> LPat Id +mkBigLHsVarPatTupId :: [Id] -> LPat GhcTc mkBigLHsVarPatTupId bs = mkBigLHsPatTupId (map nlVarPat bs) -mkBigLHsPatTupId :: [LPat Id] -> LPat Id +mkBigLHsPatTupId :: [LPat GhcTc] -> LPat GhcTc mkBigLHsPatTupId = mkChunkified mkLHsPatTup {- diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs index 14166205e2..19f70363d0 100644 --- a/compiler/deSugar/Match.hs +++ b/compiler/deSugar/Match.hs @@ -7,6 +7,7 @@ The @match@ function -} {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where @@ -304,12 +305,12 @@ matchOverloadedList (var:vars) ty (eqns@(eqn1:_)) matchOverloadedList _ _ _ = panic "matchOverloadedList" -- decompose the first pattern and leave the rest alone -decomposeFirstPat :: (Pat Id -> Pat Id) -> EquationInfo -> EquationInfo +decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats })) = eqn { eqn_pats = extractpat pat : pats} decomposeFirstPat _ _ = panic "decomposeFirstPat" -getCoPat, getBangPat, getViewPat, getOLPat :: Pat Id -> Pat Id +getCoPat, getBangPat, getViewPat, getOLPat :: Pat GhcTc -> Pat GhcTc getCoPat (CoPat _ pat _) = pat getCoPat _ = panic "getCoPat" getBangPat (BangPat pat ) = unLoc pat @@ -402,10 +403,10 @@ tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats }) = do { (wrap, pat') <- tidy1 v pat ; return (wrap, eqn { eqn_pats = do pat' : pats }) } -tidy1 :: Id -- The Id being scrutinised - -> Pat Id -- The pattern against which it is to be matched - -> DsM (DsWrapper, -- Extra bindings to do before the match - Pat Id) -- Equivalent pattern +tidy1 :: Id -- The Id being scrutinised + -> Pat GhcTc -- The pattern against which it is to be matched + -> DsM (DsWrapper, -- Extra bindings to do before the match + Pat GhcTc) -- Equivalent pattern ------------------------------------------------------- -- (pat', mr') = tidy1 v pat mr @@ -501,7 +502,7 @@ tidy1 _ non_interesting_pat = return (idDsWrapper, non_interesting_pat) -------------------- -tidy_bang_pat :: Id -> SrcSpan -> Pat Id -> DsM (DsWrapper, Pat Id) +tidy_bang_pat :: Id -> SrcSpan -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc) -- Discard par/sig under a bang tidy_bang_pat v _ (ParPat (L l p)) = tidy_bang_pat v l p @@ -552,7 +553,7 @@ tidy_bang_pat _ l p = return (idDsWrapper, BangPat (L l p)) push_bang_into_newtype_arg :: SrcSpan -> Type -- The type of the argument we are pushing -- onto - -> HsConPatDetails Id -> HsConPatDetails Id + -> HsConPatDetails GhcTc -> HsConPatDetails GhcTc -- See Note [Bang patterns and newtypes] -- We are transforming !(N p) into (N !p) push_bang_into_newtype_arg l _ty (PrefixCon (arg:args)) @@ -695,10 +696,10 @@ Call @match@ with all of this information! \end{enumerate} -} -matchWrapper :: HsMatchContext Name -- For shadowing warning messages - -> Maybe (LHsExpr Id) -- The scrutinee, if we check a case expr - -> MatchGroup Id (LHsExpr Id) -- Matches being desugared - -> DsM ([Id], CoreExpr) -- Results +matchWrapper :: HsMatchContext Name -- For shadowing warning messages + -> Maybe (LHsExpr GhcTc) -- The scrutinee, if we check a case expr + -> MatchGroup GhcTc (LHsExpr GhcTc) -- Matches being desugared + -> DsM ([Id], CoreExpr) -- Results {- There is one small problem with the Lambda Patterns, when somebody @@ -788,7 +789,7 @@ pattern. It returns an expression. matchSimply :: CoreExpr -- Scrutinee -> HsMatchContext Name -- Match kind - -> LPat Id -- Pattern it should match + -> LPat GhcTc -- Pattern it should match -> CoreExpr -- Return this if it matches -> CoreExpr -- Return this if it doesn't -> DsM CoreExpr @@ -801,7 +802,7 @@ matchSimply scrut hs_ctx pat result_expr fail_expr = do match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result extractMatchResult match_result' fail_expr -matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id +matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat GhcTc -> Type -> MatchResult -> DsM MatchResult -- matchSinglePat ensures that the scrutinee is a variable -- and then calls match_single_pat_var @@ -820,7 +821,7 @@ matchSinglePat scrut hs_ctx pat ty match_result ; return (adjustMatchResult (bindNonRec var scrut) match_result') } match_single_pat_var :: Id -- See Note [Match Ids] - -> HsMatchContext Name -> LPat Id + -> HsMatchContext Name -> LPat GhcTc -> Type -> MatchResult -> DsM MatchResult match_single_pat_var var ctx pat ty match_result = ASSERT2( isInternalName (idName var), ppr var ) @@ -856,7 +857,7 @@ data PatGroup | PgBang -- Bang patterns | PgCo Type -- Coercion patterns; the type is the type -- of the pattern *inside* - | PgView (LHsExpr Id) -- view pattern (e -> p): + | PgView (LHsExpr GhcTc) -- view pattern (e -> p): -- the LHsExpr is the expression e Type -- the Type is the type of p (equivalently, the result type of e) | PgOverloadedList @@ -985,14 +986,14 @@ sameGroup _ _ = False -- NB we can't assume that the two view expressions have the same type. Consider -- f (e1 -> True) = ... -- f (e2 -> "hi") = ... -viewLExprEq :: (LHsExpr Id,Type) -> (LHsExpr Id,Type) -> Bool +viewLExprEq :: (LHsExpr GhcTc,Type) -> (LHsExpr GhcTc,Type) -> Bool viewLExprEq (e1,_) (e2,_) = lexp e1 e2 where - lexp :: LHsExpr Id -> LHsExpr Id -> Bool + lexp :: LHsExpr GhcTc -> LHsExpr GhcTc -> Bool lexp e e' = exp (unLoc e) (unLoc e') --------- - exp :: HsExpr Id -> HsExpr Id -> Bool + exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool -- real comparison is on HsExpr's -- strip parens exp (HsPar (L _ e)) e' = exp e e' @@ -1037,7 +1038,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 exp _ _ = False --------- - syn_exp :: SyntaxExpr Id -> SyntaxExpr Id -> Bool + syn_exp :: SyntaxExpr GhcTc -> SyntaxExpr GhcTc -> Bool syn_exp (SyntaxExpr { syn_expr = expr1 , syn_arg_wraps = arg_wraps1 , syn_res_wrap = res_wrap1 }) @@ -1084,7 +1085,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 eq_list _ (_:_) [] = False eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys -patGroup :: DynFlags -> Pat Id -> PatGroup +patGroup :: DynFlags -> Pat GhcTc -> PatGroup patGroup _ (ConPatOut { pat_con = L _ con , pat_arg_tys = tys }) | RealDataCon dcon <- con = PgCon dcon diff --git a/compiler/deSugar/Match.hs-boot b/compiler/deSugar/Match.hs-boot index 31bd351caa..4096b9cd0b 100644 --- a/compiler/deSugar/Match.hs-boot +++ b/compiler/deSugar/Match.hs-boot @@ -5,6 +5,7 @@ import DsMonad ( DsM, EquationInfo, MatchResult ) import CoreSyn ( CoreExpr ) import HsSyn ( LPat, HsMatchContext, MatchGroup, LHsExpr ) import Name ( Name ) +import HsExtension ( GhcTc ) match :: [Id] -> Type @@ -13,14 +14,14 @@ match :: [Id] matchWrapper :: HsMatchContext Name - -> Maybe (LHsExpr Id) - -> MatchGroup Id (LHsExpr Id) + -> Maybe (LHsExpr GhcTc) + -> MatchGroup GhcTc (LHsExpr GhcTc) -> DsM ([Id], CoreExpr) matchSimply :: CoreExpr -> HsMatchContext Name - -> LPat Id + -> LPat GhcTc -> CoreExpr -> CoreExpr -> DsM CoreExpr @@ -28,7 +29,7 @@ matchSimply matchSinglePat :: CoreExpr -> HsMatchContext Name - -> LPat Id + -> LPat GhcTc -> Type -> MatchResult -> DsM MatchResult diff --git a/compiler/deSugar/MatchCon.hs b/compiler/deSugar/MatchCon.hs index 47d1276ba6..7923ae4eb5 100644 --- a/compiler/deSugar/MatchCon.hs +++ b/compiler/deSugar/MatchCon.hs @@ -7,6 +7,7 @@ Pattern-matching constructors -} {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} module MatchCon ( matchConFamily, matchPatSyn ) where @@ -112,7 +113,7 @@ matchPatSyn (var:vars) ty eqns _ -> panic "matchPatSyn: not PatSynCon" matchPatSyn _ _ _ = panic "matchPatSyn []" -type ConArgPats = HsConDetails (LPat Id) (HsRecFields Id (LPat Id)) +type ConArgPats = HsConDetails (LPat GhcTc) (HsRecFields GhcTc (LPat GhcTc)) matchOneConLike :: [Id] -> Type @@ -198,7 +199,8 @@ compatible_pats (RecCon flds1, _) _ = null (rec_flds flds1) compatible_pats _ (RecCon flds2, _) = null (rec_flds flds2) compatible_pats _ _ = True -- Prefix or infix con -same_fields :: HsRecFields Id (LPat Id) -> HsRecFields Id (LPat Id) -> Bool +same_fields :: HsRecFields GhcTc (LPat GhcTc) -> HsRecFields GhcTc (LPat GhcTc) + -> Bool same_fields flds1 flds2 = all2 (\(L _ f1) (L _ f2) -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2)) @@ -215,7 +217,7 @@ conArgPats :: [Type] -- Instantiated argument types -- Used only to fill in the types of WildPats, which -- are probably never looked at anyway -> ConArgPats - -> [Pat Id] + -> [Pat GhcTc] conArgPats _arg_tys (PrefixCon ps) = map unLoc ps conArgPats _arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2] conArgPats arg_tys (RecCon (HsRecFields { rec_flds = rpats })) diff --git a/compiler/deSugar/MatchLit.hs b/compiler/deSugar/MatchLit.hs index 748de5c8de..c3ba420232 100644 --- a/compiler/deSugar/MatchLit.hs +++ b/compiler/deSugar/MatchLit.hs @@ -74,22 +74,22 @@ For numeric literals, we try to detect there use at a standard type See also below where we look for @DictApps@ for \tr{plusInt}, etc. -} -dsLit :: HsLit -> DsM CoreExpr +dsLit :: HsLit GhcRn -> DsM CoreExpr dsLit (HsStringPrim _ s) = return (Lit (MachStr s)) dsLit (HsCharPrim _ c) = return (Lit (MachChar c)) dsLit (HsIntPrim _ i) = return (Lit (MachInt i)) dsLit (HsWordPrim _ w) = return (Lit (MachWord w)) dsLit (HsInt64Prim _ i) = return (Lit (MachInt64 i)) dsLit (HsWord64Prim _ w) = return (Lit (MachWord64 w)) -dsLit (HsFloatPrim f) = return (Lit (MachFloat (fl_value f))) -dsLit (HsDoublePrim d) = return (Lit (MachDouble (fl_value d))) +dsLit (HsFloatPrim _ f) = return (Lit (MachFloat (fl_value f))) +dsLit (HsDoublePrim _ d) = return (Lit (MachDouble (fl_value d))) dsLit (HsChar _ c) = return (mkCharExpr c) dsLit (HsString _ str) = mkStringExprFS str dsLit (HsInteger _ i _) = mkIntegerExpr i -dsLit (HsInt i) = do dflags <- getDynFlags +dsLit (HsInt _ i) = do dflags <- getDynFlags return (mkIntExpr dflags (il_value i)) -dsLit (HsRat (FL _ _ val) ty) = do +dsLit (HsRat _ (FL _ _ val) ty) = do num <- mkIntegerExpr (numerator val) denom <- mkIntegerExpr (denominator val) return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom]) @@ -100,12 +100,12 @@ dsLit (HsRat (FL _ _ val) ty) = do (head (tyConDataCons tycon), i_ty) x -> pprPanic "dsLit" (ppr x) -dsOverLit :: HsOverLit Id -> DsM CoreExpr +dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr dsOverLit lit = do { dflags <- getDynFlags ; warnAboutOverflowedLiterals dflags lit ; dsOverLit' dflags lit } -dsOverLit' :: DynFlags -> HsOverLit Id -> DsM CoreExpr +dsOverLit' :: DynFlags -> HsOverLit GhcTc -> DsM CoreExpr -- Post-typechecker, the HsExpr field of an OverLit contains -- (an expression for) the literal value itself dsOverLit' dflags (OverLit { ol_val = val, ol_rebindable = rebindable @@ -153,7 +153,7 @@ conversionNames -- We can't easily add fromIntegerName, fromRationalName, -- because they are generated by literals -warnAboutOverflowedLiterals :: DynFlags -> HsOverLit Id -> DsM () +warnAboutOverflowedLiterals :: DynFlags -> HsOverLit GhcTc -> DsM () warnAboutOverflowedLiterals dflags lit | wopt Opt_WarnOverflowedLiterals dflags , Just (i, tc) <- getIntegralLit lit @@ -200,7 +200,8 @@ We get an erroneous suggestion for but perhaps that does not matter too much. -} -warnAboutEmptyEnumerations :: DynFlags -> LHsExpr Id -> Maybe (LHsExpr Id) -> LHsExpr Id -> DsM () +warnAboutEmptyEnumerations :: DynFlags -> LHsExpr GhcTc -> Maybe (LHsExpr GhcTc) + -> LHsExpr GhcTc -> DsM () -- Warns about [2,3 .. 1] which returns the empty list -- Only works for integral types, not floating point warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr @@ -233,7 +234,7 @@ warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr | otherwise = return () -getLHsIntegralLit :: LHsExpr Id -> Maybe (Integer, Name) +getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Name) -- See if the expression is an Integral literal -- Remember to look through automatically-added tick-boxes! (Trac #8384) getLHsIntegralLit (L _ (HsPar e)) = getLHsIntegralLit e @@ -242,7 +243,7 @@ getLHsIntegralLit (L _ (HsBinTick _ _ e)) = getLHsIntegralLit e getLHsIntegralLit (L _ (HsOverLit over_lit)) = getIntegralLit over_lit getLHsIntegralLit _ = Nothing -getIntegralLit :: HsOverLit Id -> Maybe (Integer, Name) +getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Name) getIntegralLit (OverLit { ol_val = HsIntegral i, ol_type = ty }) | Just tc <- tyConAppTyCon_maybe ty = Just (il_value i, tyConName tc) @@ -256,7 +257,7 @@ getIntegralLit _ = Nothing ************************************************************************ -} -tidyLitPat :: HsLit -> Pat Id +tidyLitPat :: HsLit GhcTc -> Pat GhcTc -- Result has only the following HsLits: -- HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim -- HsDoublePrim, HsStringPrim, HsString @@ -273,13 +274,14 @@ tidyLitPat (HsString src s) tidyLitPat lit = LitPat lit ---------------- -tidyNPat :: (HsLit -> Pat Id) -- How to tidy a LitPat +tidyNPat :: (HsLit GhcTc -> Pat GhcTc) -- How to tidy a LitPat -- We need this argument because tidyNPat is called -- both by Match and by Check, but they tidy LitPats -- slightly differently; and we must desugar -- literals consistently (see Trac #5117) - -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id -> Type - -> Pat Id + -> HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> SyntaxExpr GhcTc + -> Type + -> Pat GhcTc tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty -- False: Take short cuts only if the literal is not using rebindable syntax -- @@ -308,7 +310,7 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty -- type family Id). In these cases, we can't do the short-cut. type_change = not (outer_ty `eqType` ty) - mk_con_pat :: DataCon -> HsLit -> Pat Id + mk_con_pat :: DataCon -> HsLit GhcTc -> Pat GhcTc mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] []) mb_int_lit :: Maybe Integer @@ -375,7 +377,7 @@ matchLiterals (var:vars) ty sub_groups matchLiterals [] _ _ = panic "matchLiterals []" --------------------------- -hsLitKey :: DynFlags -> HsLit -> Literal +hsLitKey :: DynFlags -> HsLit GhcTc -> Literal -- Get the Core literal corresponding to a HsLit. -- It only works for primitive types and strings; -- others have been removed by tidy @@ -390,8 +392,8 @@ hsLitKey dflags (HsWordPrim _ w) = mkMachWordWrap dflags w hsLitKey _ (HsInt64Prim _ i) = mkMachInt64Wrap i hsLitKey _ (HsWord64Prim _ w) = mkMachWord64Wrap w hsLitKey _ (HsCharPrim _ c) = mkMachChar c -hsLitKey _ (HsFloatPrim f) = mkMachFloat (fl_value f) -hsLitKey _ (HsDoublePrim d) = mkMachDouble (fl_value d) +hsLitKey _ (HsFloatPrim _ f) = mkMachFloat (fl_value f) +hsLitKey _ (HsDoublePrim _ d) = mkMachDouble (fl_value d) hsLitKey _ (HsString _ s) = MachStr (fastStringToByteString s) hsLitKey _ l = pprPanic "hsLitKey" (ppr l) diff --git a/compiler/deSugar/PmExpr.hs b/compiler/deSugar/PmExpr.hs index 8c3df9689e..e9af145183 100644 --- a/compiler/deSugar/PmExpr.hs +++ b/compiler/deSugar/PmExpr.hs @@ -56,15 +56,15 @@ data PmExpr = PmExprVar Name | PmExprCon ConLike [PmExpr] | PmExprLit PmLit | PmExprEq PmExpr PmExpr -- Syntactic equality - | PmExprOther (HsExpr Id) -- Note [PmExprOther in PmExpr] + | PmExprOther (HsExpr GhcTc) -- Note [PmExprOther in PmExpr] mkPmExprData :: DataCon -> [PmExpr] -> PmExpr mkPmExprData dc args = PmExprCon (RealDataCon dc) args -- | Literals (simple and overloaded ones) for pattern match checking. -data PmLit = PmSLit HsLit -- simple - | PmOLit Bool {- is it negated? -} (HsOverLit Id) -- overloaded +data PmLit = PmSLit (HsLit GhcTc) -- simple + | PmOLit Bool {- is it negated? -} (HsOverLit GhcTc) -- overloaded -- | Equality between literals for pattern match checking. eqPmLit :: PmLit -> PmLit -> Bool @@ -229,10 +229,10 @@ substComplexEq x e (ex, ey) -- ----------------------------------------------------------------------- -- ** Lift source expressions (HsExpr Id) to PmExpr -lhsExprToPmExpr :: LHsExpr Id -> PmExpr +lhsExprToPmExpr :: LHsExpr GhcTc -> PmExpr lhsExprToPmExpr (L _ e) = hsExprToPmExpr e -hsExprToPmExpr :: HsExpr Id -> PmExpr +hsExprToPmExpr :: HsExpr GhcTc -> PmExpr hsExprToPmExpr (HsVar x) = PmExprVar (idName (unLoc x)) hsExprToPmExpr (HsConLikeOut c) = PmExprVar (conLikeName c) @@ -282,7 +282,7 @@ hsExprToPmExpr (ExprWithTySigOut e _) = lhsExprToPmExpr e hsExprToPmExpr (HsWrap _ e) = hsExprToPmExpr e hsExprToPmExpr e = PmExprOther e -- the rest are not handled by the oracle -synExprToPmExpr :: SyntaxExpr Id -> PmExpr +synExprToPmExpr :: SyntaxExpr GhcTc -> PmExpr synExprToPmExpr = hsExprToPmExpr . syn_expr -- ignore the wrappers {- diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index e1d44c1740..2ef2db45d3 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -312,6 +312,7 @@ Library HsImpExp HsLit PlaceHolder + HsExtension HsPat HsSyn HsTypes diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 2d2fedec4a..a2a123c03b 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -490,6 +490,7 @@ compiler_stage2_dll0_MODULES = \ HsImpExp \ HsLit \ PlaceHolder \ + HsExtension \ PmExpr \ HsPat \ HsSyn \ diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index e64c4eaed5..5ded8bcde3 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -6,6 +6,7 @@ This module converts Template Haskell syntax into HsSyn -} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} module Convert( convertToHsExpr, convertToPat, convertToHsDecls, @@ -46,20 +47,20 @@ import Language.Haskell.TH.Syntax as TH ------------------------------------------------------------------- -- The external interface -convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl RdrName] +convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl GhcPs] convertToHsDecls loc ds = initCvt loc (fmap catMaybes (mapM cvt_dec ds)) where cvt_dec d = wrapMsg "declaration" d (cvtDec d) -convertToHsExpr :: SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr RdrName) +convertToHsExpr :: SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr GhcPs) convertToHsExpr loc e = initCvt loc $ wrapMsg "expression" e $ cvtl e -convertToPat :: SrcSpan -> TH.Pat -> Either MsgDoc (LPat RdrName) +convertToPat :: SrcSpan -> TH.Pat -> Either MsgDoc (LPat GhcPs) convertToPat loc p = initCvt loc $ wrapMsg "pattern" p $ cvtPat p -convertToHsType :: SrcSpan -> TH.Type -> Either MsgDoc (LHsType RdrName) +convertToHsType :: SrcSpan -> TH.Type -> Either MsgDoc (LHsType GhcPs) convertToHsType loc t = initCvt loc $ wrapMsg "type" t $ cvtType t @@ -133,10 +134,10 @@ wrapL (CvtM m) = CvtM (\loc -> case m loc of Right (loc',v) -> Right (loc',L loc v)) ------------------------------------------------------------------- -cvtDecs :: [TH.Dec] -> CvtM [LHsDecl RdrName] +cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs] cvtDecs = fmap catMaybes . mapM cvtDec -cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl RdrName)) +cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl GhcPs)) cvtDec (TH.ValD pat body ds) | TH.VarP s <- pat = do { s' <- vNameL s @@ -248,7 +249,7 @@ cvtDec (ClassD ctxt cl tvs fds decs) -- no docs in TH ^^ } where - cvt_at_def :: LTyFamInstDecl RdrName -> CvtM (LTyFamDefltEqn RdrName) + cvt_at_def :: LTyFamInstDecl GhcPs -> CvtM (LTyFamDefltEqn GhcPs) -- Very similar to what happens in RdrHsSyn.mkClassDecl cvt_at_def decl = case RdrHsSyn.mkATDefault decl of Right def -> return def @@ -384,7 +385,7 @@ cvtDec (TH.PatSynSigD nm ty) ; returnJustL $ Hs.SigD $ PatSynSig [nm'] (mkLHsSigType ty') } ---------------- -cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName) +cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn GhcPs) cvtTySynEqn tc (TySynEqn lhs rhs) = do { lhs' <- mapM (wrap_apps <=< cvtType) lhs ; rhs' <- cvtType rhs @@ -395,11 +396,11 @@ cvtTySynEqn tc (TySynEqn lhs rhs) ---------------- cvt_ci_decs :: MsgDoc -> [TH.Dec] - -> CvtM (LHsBinds RdrName, - [LSig RdrName], - [LFamilyDecl RdrName], - [LTyFamInstDecl RdrName], - [LDataFamInstDecl RdrName]) + -> CvtM (LHsBinds GhcPs, + [LSig GhcPs], + [LFamilyDecl GhcPs], + [LTyFamInstDecl GhcPs], + [LDataFamInstDecl GhcPs]) -- Convert the declarations inside a class or instance decl -- ie signatures, bindings, and associated types cvt_ci_decs doc decs @@ -416,9 +417,9 @@ cvt_ci_decs doc decs ---------------- cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr] - -> CvtM ( LHsContext RdrName + -> CvtM ( LHsContext GhcPs , Located RdrName - , LHsQTyVars RdrName) + , LHsQTyVars GhcPs) cvt_tycl_hdr cxt tc tvs = do { cxt' <- cvtContext cxt ; tc' <- tconNameL tc @@ -427,9 +428,9 @@ cvt_tycl_hdr cxt tc tvs } cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type] - -> CvtM ( LHsContext RdrName + -> CvtM ( LHsContext GhcPs , Located RdrName - , HsImplicitBndrs RdrName [LHsType RdrName]) + , HsImplicitBndrs GhcPs [LHsType GhcPs]) cvt_tyinst_hdr cxt tc tys = do { cxt' <- cvtContext cxt ; tc' <- tconNameL tc @@ -439,9 +440,9 @@ cvt_tyinst_hdr cxt tc tys ---------------- cvt_tyfam_head :: TypeFamilyHead -> CvtM ( Located RdrName - , LHsQTyVars RdrName - , Hs.LFamilyResultSig RdrName - , Maybe (Hs.LInjectivityAnn RdrName)) + , LHsQTyVars GhcPs + , Hs.LFamilyResultSig GhcPs + , Maybe (Hs.LInjectivityAnn GhcPs)) cvt_tyfam_head (TypeFamilyHead tc tyvars result injectivity) = do {(_, tc', tyvars') <- cvt_tycl_hdr [] tc tyvars @@ -453,23 +454,24 @@ cvt_tyfam_head (TypeFamilyHead tc tyvars result injectivity) -- Partitioning declarations ------------------------------------------------------------------- -is_fam_decl :: LHsDecl RdrName -> Either (LFamilyDecl RdrName) (LHsDecl RdrName) +is_fam_decl :: LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs) is_fam_decl (L loc (TyClD (FamDecl { tcdFam = d }))) = Left (L loc d) is_fam_decl decl = Right decl -is_tyfam_inst :: LHsDecl RdrName -> Either (LTyFamInstDecl RdrName) (LHsDecl RdrName) +is_tyfam_inst :: LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs) is_tyfam_inst (L loc (Hs.InstD (TyFamInstD { tfid_inst = d }))) = Left (L loc d) is_tyfam_inst decl = Right decl -is_datafam_inst :: LHsDecl RdrName -> Either (LDataFamInstDecl RdrName) (LHsDecl RdrName) +is_datafam_inst :: LHsDecl GhcPs + -> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs) is_datafam_inst (L loc (Hs.InstD (DataFamInstD { dfid_inst = d }))) = Left (L loc d) is_datafam_inst decl = Right decl -is_sig :: LHsDecl RdrName -> Either (LSig RdrName) (LHsDecl RdrName) +is_sig :: LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs) is_sig (L loc (Hs.SigD sig)) = Left (L loc sig) is_sig decl = Right decl -is_bind :: LHsDecl RdrName -> Either (LHsBind RdrName) (LHsDecl RdrName) +is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs) is_bind (L loc (Hs.ValD bind)) = Left (L loc bind) is_bind decl = Right decl @@ -482,7 +484,7 @@ mkBadDecMsg doc bads -- Data types --------------------------------------------------- -cvtConstr :: TH.Con -> CvtM (LConDecl RdrName) +cvtConstr :: TH.Con -> CvtM (LConDecl GhcPs) cvtConstr (NormalC c strtys) = do { c' <- cNameL c @@ -550,7 +552,7 @@ cvtSrcStrictness NoSourceStrictness = NoSrcStrict cvtSrcStrictness SourceLazy = SrcLazy cvtSrcStrictness SourceStrict = SrcStrict -cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType RdrName) +cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType GhcPs) cvt_arg (Bang su ss, ty) = do { ty'' <- cvtType ty ; ty' <- wrap_apps ty'' @@ -558,7 +560,7 @@ cvt_arg (Bang su ss, ty) ; let ss' = cvtSrcStrictness ss ; returnL $ HsBangTy (HsSrcBang NoSourceText su' ss') ty' } -cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField RdrName) +cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs) cvt_id_arg (i, str, ty) = do { L li i' <- vNameL i ; ty' <- cvt_arg (str,ty) @@ -568,7 +570,7 @@ cvt_id_arg (i, str, ty) , cd_fld_type = ty' , cd_fld_doc = Nothing}) } -cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving RdrName) +cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs) cvtDerivs cs = do { cs' <- mapM cvtDerivClause cs ; returnL cs' } @@ -582,7 +584,7 @@ cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs -- Foreign declarations ------------------------------------------ -cvtForD :: Foreign -> CvtM (ForeignDecl RdrName) +cvtForD :: Foreign -> CvtM (ForeignDecl GhcPs) cvtForD (ImportF callconv safety from nm ty) -- the prim and javascript calling conventions do not support headers -- and are inserted verbatim, analogous to mkImport in RdrHsSyn @@ -635,7 +637,7 @@ cvt_conv TH.JavaScript = JavaScriptCallConv -- Pragmas ------------------------------------------ -cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl RdrName)) +cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl GhcPs)) cvtPragmaD (InlineP nm inline rm phases) = do { nm' <- vNameL nm ; let dflt = dfltActivation inline @@ -727,7 +729,7 @@ cvtPhases AllPhases dflt = dflt cvtPhases (FromPhase i) _ = ActiveAfter NoSourceText i cvtPhases (BeforePhase i) _ = ActiveBefore NoSourceText i -cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr RdrName) +cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs) cvtRuleBndr (RuleVar n) = do { n' <- vNameL n ; return $ noLoc $ Hs.RuleBndr n' } @@ -740,7 +742,7 @@ cvtRuleBndr (TypedRuleVar n ty) -- Declarations --------------------------------------------------- -cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds RdrName) +cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs) cvtLocalDecs doc ds | null ds = return EmptyLocalBinds @@ -752,7 +754,7 @@ cvtLocalDecs doc ds ; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) } cvtClause :: HsMatchContext RdrName - -> TH.Clause -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName)) + -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) cvtClause ctxt (Clause ps body wheres) = do { ps' <- cvtPats ps ; pps <- mapM wrap_conpat ps' @@ -766,7 +768,7 @@ cvtClause ctxt (Clause ps body wheres) -- Expressions ------------------------------------------------------------------- -cvtl :: TH.Exp -> CvtM (LHsExpr RdrName) +cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs) cvtl e = wrapL (cvt e) where cvt (VarE s) = do { s' <- vName s; return $ HsVar (noLoc s') } @@ -875,14 +877,15 @@ and the above expression would be reassociated to which we don't want. -} -cvtFld :: (RdrName -> t) -> (TH.Name, TH.Exp) -> CvtM (LHsRecField' t (LHsExpr RdrName)) +cvtFld :: (RdrName -> t) -> (TH.Name, TH.Exp) + -> CvtM (LHsRecField' t (LHsExpr GhcPs)) cvtFld f (v,e) = do { v' <- vNameL v; e' <- cvtl e ; return (noLoc $ HsRecField { hsRecFieldLbl = fmap f v' , hsRecFieldArg = e' , hsRecPun = False}) } -cvtDD :: Range -> CvtM (ArithSeqInfo RdrName) +cvtDD :: Range -> CvtM (ArithSeqInfo GhcPs) cvtDD (FromR x) = do { x' <- cvtl x; return $ From x' } cvtDD (FromThenR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' } cvtDD (FromToR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' } @@ -940,7 +943,7 @@ the recursive calls to @cvtOpApp@. When we call @cvtOpApp@ from @cvtl@, the first argument will always be left-biased since we have already run @cvtl@ on it. -} -cvtOpApp :: LHsExpr RdrName -> TH.Exp -> TH.Exp -> CvtM (HsExpr RdrName) +cvtOpApp :: LHsExpr GhcPs -> TH.Exp -> TH.Exp -> CvtM (HsExpr GhcPs) cvtOpApp x op1 (UInfixE y op2 z) = do { l <- wrapL $ cvtOpApp x op1 y ; cvtOpApp l op2 z } @@ -953,7 +956,7 @@ cvtOpApp x op y -- Do notation and statements ------------------------------------- -cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr RdrName) +cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr GhcPs) cvtHsDo do_or_lc stmts | null stmts = failWith (text "Empty stmt list in do-block") | otherwise @@ -970,10 +973,10 @@ cvtHsDo do_or_lc stmts , nest 2 $ Outputable.ppr stmt , text "(It should be an expression.)" ] -cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName (LHsExpr RdrName)] +cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt GhcPs (LHsExpr GhcPs)] cvtStmts = mapM cvtStmt -cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName (LHsExpr RdrName)) +cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt GhcPs (LHsExpr GhcPs)) cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkBodyStmt e' } cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' } cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (text "a let binding") ds @@ -983,7 +986,7 @@ cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' n cvt_one ds = do { ds' <- cvtStmts ds; return (ParStmtBlock ds' undefined noSyntaxExpr) } cvtMatch :: HsMatchContext RdrName - -> TH.Match -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName)) + -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) cvtMatch ctxt (TH.Match p body decs) = do { p' <- cvtPat p ; lp <- case ctxt of @@ -994,18 +997,18 @@ cvtMatch ctxt (TH.Match p body decs) ; returnL $ Hs.Match ctxt [lp] Nothing (GRHSs g' (noLoc decs')) } -cvtGuard :: TH.Body -> CvtM [LGRHS RdrName (LHsExpr RdrName)] +cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)] cvtGuard (GuardedB pairs) = mapM cvtpair pairs cvtGuard (NormalB e) = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] } -cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName (LHsExpr RdrName)) +cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs)) cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs ; g' <- returnL $ mkBodyStmt ge' ; returnL $ GRHS [g'] rhs' } cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs ; returnL $ GRHS gs' rhs' } -cvtOverLit :: Lit -> CvtM (HsOverLit RdrName) +cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs) cvtOverLit (IntegerL i) = do { force i; return $ mkHsIntegral (mkIntegralLit i) placeHolderType} cvtOverLit (RationalL r) @@ -1040,11 +1043,13 @@ allCharLs xs go cs (LitE (CharL c) : ys) = go (c:cs) ys go _ _ = Nothing -cvtLit :: Lit -> CvtM HsLit +cvtLit :: Lit -> CvtM (HsLit GhcPs) cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim NoSourceText i } cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim NoSourceText w } -cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim (mkFractionalLit f) } -cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim (mkFractionalLit f) } +cvtLit (FloatPrimL f) + = do { force f; return $ HsFloatPrim def (mkFractionalLit f) } +cvtLit (DoublePrimL f) + = do { force f; return $ HsDoublePrim def (mkFractionalLit f) } cvtLit (CharL c) = do { force c; return $ HsChar NoSourceText c } cvtLit (CharPrimL c) = do { force c; return $ HsCharPrim NoSourceText c } cvtLit (StringL s) = do { let { s' = mkFastString s } @@ -1061,13 +1066,13 @@ cvtLit _ = panic "Convert.cvtLit: Unexpected literal" quotedSourceText :: String -> SourceText quotedSourceText s = SourceText $ "\"" ++ s ++ "\"" -cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName] +cvtPats :: [TH.Pat] -> CvtM [Hs.LPat GhcPs] cvtPats pats = mapM cvtPat pats -cvtPat :: TH.Pat -> CvtM (Hs.LPat RdrName) +cvtPat :: TH.Pat -> CvtM (Hs.LPat GhcPs) cvtPat pat = wrapL (cvtp pat) -cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName) +cvtp :: TH.Pat -> CvtM (Hs.Pat GhcPs) cvtp (TH.LitP l) | overloadedLit l = do { l' <- cvtOverLit l ; return (mkNPat (noLoc l') Nothing) } @@ -1108,7 +1113,7 @@ cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p ; return $ ViewPat e' p' placeHolderType } -cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField RdrName (LPat RdrName)) +cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs)) cvtPatFld (s,p) = do { L ls s' <- vNameL s; p' <- cvtPat p ; return (noLoc $ HsRecField { hsRecFieldLbl @@ -1116,7 +1121,7 @@ cvtPatFld (s,p) , hsRecFieldArg = p' , hsRecPun = False}) } -wrap_conpat :: Hs.LPat RdrName -> CvtM (Hs.LPat RdrName) +wrap_conpat :: Hs.LPat GhcPs -> CvtM (Hs.LPat GhcPs) wrap_conpat p@(L _ (ConPatIn _ (InfixCon{}))) = returnL $ ParPat p wrap_conpat p@(L _ (ConPatIn _ (PrefixCon []))) = return p wrap_conpat p@(L _ (ConPatIn _ (PrefixCon _))) = returnL $ ParPat p @@ -1127,7 +1132,7 @@ The produced tree of infix patterns will be left-biased, provided @x@ is. See the @cvtOpApp@ documentation for how this function works. -} -cvtOpAppP :: Hs.LPat RdrName -> TH.Name -> TH.Pat -> CvtM (Hs.Pat RdrName) +cvtOpAppP :: Hs.LPat GhcPs -> TH.Name -> TH.Pat -> CvtM (Hs.Pat GhcPs) cvtOpAppP x op1 (UInfixP y op2 z) = do { l <- wrapL $ cvtOpAppP x op1 y ; cvtOpAppP l op2 z } @@ -1139,10 +1144,10 @@ cvtOpAppP x op y ----------------------------------------------------------- -- Types and type variables -cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsQTyVars RdrName) +cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsQTyVars GhcPs) cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') } -cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName) +cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr GhcPs) cvt_tv (TH.PlainTV nm) = do { nm' <- tNameL nm ; returnL $ UserTyVar nm' } @@ -1157,14 +1162,14 @@ cvtRole TH.RepresentationalR = Just Coercion.Representational cvtRole TH.PhantomR = Just Coercion.Phantom cvtRole TH.InferR = Nothing -cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName) +cvtContext :: TH.Cxt -> CvtM (LHsContext GhcPs) cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' } -cvtPred :: TH.Pred -> CvtM (LHsType RdrName) +cvtPred :: TH.Pred -> CvtM (LHsType GhcPs) cvtPred = cvtType cvtDerivClause :: TH.DerivClause - -> CvtM (LHsDerivingClause RdrName) + -> CvtM (LHsDerivingClause GhcPs) cvtDerivClause (TH.DerivClause ds ctxt) = do { ctxt'@(L loc _) <- fmap (map mkLHsSigType) <$> cvtContext ctxt ; let ds' = fmap (L loc . cvtDerivStrategy) ds @@ -1175,10 +1180,10 @@ cvtDerivStrategy TH.StockStrategy = Hs.StockStrategy cvtDerivStrategy TH.AnyclassStrategy = Hs.AnyclassStrategy cvtDerivStrategy TH.NewtypeStrategy = Hs.NewtypeStrategy -cvtType :: TH.Type -> CvtM (LHsType RdrName) +cvtType :: TH.Type -> CvtM (LHsType GhcPs) cvtType = cvtTypeKind "type" -cvtTypeKind :: String -> TH.Type -> CvtM (LHsType RdrName) +cvtTypeKind :: String -> TH.Type -> CvtM (LHsType GhcPs) cvtTypeKind ty_str ty = do { (head_ty, tys') <- split_ty_app ty ; case head_ty of @@ -1313,7 +1318,7 @@ cvtTypeKind ty_str ty } -- | Constructs an application of a type to arguments passed in a list. -mk_apps :: HsType RdrName -> [LHsType RdrName] -> CvtM (LHsType RdrName) +mk_apps :: HsType GhcPs -> [LHsType GhcPs] -> CvtM (LHsType GhcPs) mk_apps head_ty [] = returnL head_ty mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty @@ -1323,18 +1328,18 @@ mk_apps head_ty (ty:tys) = add_parens t@(L _ HsAppTy{}) = returnL (HsParTy t) add_parens t = return t -wrap_apps :: LHsType RdrName -> CvtM (LHsType RdrName) +wrap_apps :: LHsType GhcPs -> CvtM (LHsType GhcPs) wrap_apps t@(L _ HsAppTy {}) = returnL (HsParTy t) wrap_apps t = return t -- | Constructs an arrow type with a specified return type -mk_arr_apps :: [LHsType RdrName] -> HsType RdrName -> CvtM (LHsType RdrName) +mk_arr_apps :: [LHsType GhcPs] -> HsType GhcPs -> CvtM (LHsType GhcPs) mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL - where go :: LHsType RdrName -> HsType RdrName -> CvtM (HsType RdrName) + where go :: LHsType GhcPs -> HsType GhcPs -> CvtM (HsType GhcPs) go arg ret_ty = do { ret_ty_l <- returnL ret_ty ; return (HsFunTy arg ret_ty_l) } -split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName]) +split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType GhcPs]) split_ty_app ty = go ty [] where go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') } @@ -1347,7 +1352,7 @@ cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s) {- | @cvtOpAppT x op y@ takes converted arguments and flattens any HsAppsTy structure in them. -} -cvtOpAppT :: LHsType RdrName -> RdrName -> LHsType RdrName -> LHsType RdrName +cvtOpAppT :: LHsType GhcPs -> RdrName -> LHsType GhcPs -> LHsType GhcPs cvtOpAppT t1@(L loc1 _) op t2@(L loc2 _) = L (combineSrcSpans loc1 loc2) $ HsAppsTy (t1' ++ [noLoc $ HsAppInfix (noLoc op)] ++ t2') @@ -1362,21 +1367,21 @@ cvtOpAppT t1@(L loc1 _) op t2@(L loc2 _) | otherwise = [noLoc $ HsAppPrefix t2] -cvtKind :: TH.Kind -> CvtM (LHsKind RdrName) +cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs) cvtKind = cvtTypeKind "kind" -- | Convert Maybe Kind to a type family result signature. Used with data -- families where naming of the result is not possible (thus only kind or no -- signature is possible). cvtMaybeKindToFamilyResultSig :: Maybe TH.Kind - -> CvtM (LFamilyResultSig RdrName) + -> CvtM (LFamilyResultSig GhcPs) cvtMaybeKindToFamilyResultSig Nothing = returnL Hs.NoSig cvtMaybeKindToFamilyResultSig (Just ki) = do { ki' <- cvtKind ki ; returnL (Hs.KindSig ki') } -- | Convert type family result signature. Used with both open and closed type -- families. -cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig RdrName) +cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig GhcPs) cvtFamilyResultSig TH.NoSig = returnL Hs.NoSig cvtFamilyResultSig (TH.KindSig ki) = do { ki' <- cvtKind ki ; returnL (Hs.KindSig ki') } @@ -1385,13 +1390,13 @@ cvtFamilyResultSig (TH.TyVarSig bndr) = do { tv <- cvt_tv bndr -- | Convert injectivity annotation of a type family. cvtInjectivityAnnotation :: TH.InjectivityAnn - -> CvtM (Hs.LInjectivityAnn RdrName) + -> CvtM (Hs.LInjectivityAnn GhcPs) cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS) = do { annLHS' <- tNameL annLHS ; annRHS' <- mapM tNameL annRHS ; returnL (Hs.InjectivityAnn annLHS' annRHS') } -cvtPatSynSigTy :: TH.Type -> CvtM (LHsType RdrName) +cvtPatSynSigTy :: TH.Type -> CvtM (LHsType GhcPs) -- pattern synonym types are of peculiar shapes, which is why we treat -- them separately from regular types; -- see Note [Pattern synonym type signatures and Template Haskell] diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs index b39e25a2c7..b760cb3a88 100644 --- a/compiler/hsSyn/HsBinds.hs +++ b/compiler/hsSyn/HsBinds.hs @@ -22,13 +22,12 @@ import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr, GRHSs, pprPatBind ) import {-# SOURCE #-} HsPat ( LPat ) -import PlaceHolder ( PostTc,PostRn,DataId,OutputableBndrId ) +import HsExtension import HsTypes import PprCore () import CoreSyn import TcEvidence import Type -import Name import NameSet import BasicTypes import Outputable @@ -87,8 +86,7 @@ data HsLocalBindsLR idL idR type LHsLocalBindsLR idL idR = Located (HsLocalBindsLR idL idR) -deriving instance (DataId idL, DataId idR) - => Data (HsLocalBindsLR idL idR) +deriving instance (DataId idL, DataId idR) => Data (HsLocalBindsLR idL idR) -- | Haskell Value Bindings type HsValBinds id = HsValBindsLR id id @@ -112,10 +110,9 @@ data HsValBindsLR idL idR -- later bindings in the list may depend on earlier ones. | ValBindsOut [(RecFlag, LHsBinds idL)] - [LSig Name] + [LSig GhcRn] -- AZ: how to do this? -deriving instance (DataId idL, DataId idR) - => Data (HsValBindsLR idL idR) +deriving instance (DataId idL, DataId idR) => Data (HsValBindsLR idL idR) -- | Located Haskell Binding type LHsBind id = LHsBindLR id id @@ -158,7 +155,7 @@ data HsBindLR idL idR -- For details on above see note [Api annotations] in ApiAnnotation FunBind { - fun_id :: Located idL, -- Note [fun_id in Match] in HsExpr + fun_id :: Located (IdP idL), -- Note [fun_id in Match] in HsExpr fun_matches :: MatchGroup idR (LHsExpr idR), -- ^ The payload @@ -182,7 +179,7 @@ data HsBindLR idL idR -- See Note [Bind free vars] - fun_tick :: [Tickish Id] -- ^ Ticks to put on the rhs, if any + fun_tick :: [Tickish Id] -- ^ Ticks to put on the rhs, if any } -- | Pattern Binding @@ -210,7 +207,7 @@ data HsBindLR idL idR -- Dictionary binding and suchlike. -- All VarBinds are introduced by the type checker | VarBind { - var_id :: idL, + var_id :: IdP idL, var_rhs :: LHsExpr idR, -- ^ Located only for consistency var_inline :: Bool -- ^ True <=> inline this binding regardless -- (used for implication constraints only) @@ -242,7 +239,7 @@ data HsBindLR idL idR abs_tvs :: [TyVar], abs_ev_vars :: [EvVar], - abs_sig_export :: idL, -- like abe_poly + abs_sig_export :: IdP idL, -- like abe_poly abs_sig_prags :: TcSpecPrags, abs_sig_ev_bind :: TcEvBinds, -- no list needed here @@ -259,8 +256,7 @@ data HsBindLR idL idR -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId idL, DataId idR) - => Data (HsBindLR idL idR) +deriving instance (DataId idL, DataId idR) => Data (HsBindLR idL idR) -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds] -- @@ -275,13 +271,14 @@ deriving instance (DataId idL, DataId idR) -- See Note [AbsBinds] -- | Abtraction Bindings Export -data ABExport id - = ABE { abe_poly :: id -- ^ Any INLINE pragmas is attached to this Id - , abe_mono :: id +data ABExport p + = ABE { abe_poly :: IdP p -- ^ Any INLINE pragmas is attached to this Id + , abe_mono :: IdP p , abe_wrap :: HsWrapper -- ^ See Note [ABExport wrapper] -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly , abe_prags :: TcSpecPrags -- ^ SPECIALISE pragmas - } deriving Data + } +deriving instance (DataId p) => Data (ABExport p) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern', -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnLarrow' @@ -292,14 +289,14 @@ data ABExport id -- | Pattern Synonym binding data PatSynBind idL idR - = PSB { psb_id :: Located idL, -- ^ Name of the pattern synonym + = PSB { psb_id :: Located (IdP idL), -- ^ Name of the pattern synonym psb_fvs :: PostRn idR NameSet, -- ^ See Note [Bind free vars] - psb_args :: HsPatSynDetails (Located idR), -- ^ Formal parameter names - psb_def :: LPat idR, -- ^ Right-hand side - psb_dir :: HsPatSynDir idR -- ^ Directionality + psb_args :: HsPatSynDetails (Located (IdP idR)), + -- ^ Formal parameter names + psb_def :: LPat idR, -- ^ Right-hand side + psb_dir :: HsPatSynDir idR -- ^ Directionality } -deriving instance (DataId idL, DataId idR) - => Data (PatSynBind idL idR) +deriving instance (DataId idL, DataId idR) => Data (PatSynBind idL idR) {- Note [AbsBinds] @@ -442,13 +439,15 @@ Specifically, it's just an error thunk -} -instance (OutputableBndrId idL, OutputableBndrId idR) +instance (SourceTextX idL, SourceTextX idR, + OutputableBndrId idL, OutputableBndrId idR) => Outputable (HsLocalBindsLR idL idR) where ppr (HsValBinds bs) = ppr bs ppr (HsIPBinds bs) = ppr bs ppr EmptyLocalBinds = empty -instance (OutputableBndrId idL, OutputableBndrId idR) +instance (SourceTextX idL, SourceTextX idR, + OutputableBndrId idL, OutputableBndrId idR) => Outputable (HsValBindsLR idL idR) where ppr (ValBindsIn binds sigs) = pprDeclList (pprLHsBindsForUser binds sigs) @@ -464,14 +463,16 @@ instance (OutputableBndrId idL, OutputableBndrId idR) pp_rec Recursive = text "rec" pp_rec NonRecursive = text "nonrec" -pprLHsBinds :: (OutputableBndrId idL, OutputableBndrId idR) +pprLHsBinds :: (SourceTextX idL, SourceTextX idR, + OutputableBndrId idL, OutputableBndrId idR) => LHsBindsLR idL idR -> SDoc pprLHsBinds binds | isEmptyLHsBinds binds = empty | otherwise = pprDeclList (map ppr (bagToList binds)) -pprLHsBindsForUser :: (OutputableBndrId idL, OutputableBndrId idR, - OutputableBndrId id2) +pprLHsBindsForUser :: (SourceTextX idL, SourceTextX idR, + OutputableBndrId idL, OutputableBndrId idR, + SourceTextX id2, OutputableBndrId id2) => LHsBindsLR idL idR -> [LSig id2] -> [SDoc] -- pprLHsBindsForUser is different to pprLHsBinds because -- a) No braces: 'let' and 'where' include a list of HsBindGroups @@ -562,11 +563,13 @@ So the desugarer tries to do a better job: in (fm,gm) -} -instance (OutputableBndrId idL, OutputableBndrId idR) +instance (SourceTextX idL, SourceTextX idR, + OutputableBndrId idL, OutputableBndrId idR) => Outputable (HsBindLR idL idR) where ppr mbind = ppr_monobind mbind -ppr_monobind :: (OutputableBndrId idL, OutputableBndrId idR) +ppr_monobind :: (SourceTextX idL, SourceTextX idR, + OutputableBndrId idL, OutputableBndrId idR) => HsBindLR idL idR -> SDoc ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) @@ -616,13 +619,14 @@ ppr_monobind (AbsBindsSig { abs_tvs = tyvars else ppr bind -instance (OutputableBndr id) => Outputable (ABExport id) where +instance (OutputableBndrId p) => Outputable (ABExport p) where ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags }) = vcat [ ppr gbl <+> text "<=" <+> ppr lcl , nest 2 (pprTcSpecPrags prags) , nest 2 (text "wrap:" <+> ppr wrap)] -instance (OutputableBndr idL, OutputableBndrId idR) +instance (SourceTextX idR, + OutputableBndrId idL, OutputableBndrId idR) => Outputable (PatSynBind idL idR) where ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat, psb_dir = dir }) @@ -691,14 +695,14 @@ type LIPBind id = Located (IPBind id) -- For details on above see note [Api annotations] in ApiAnnotation data IPBind id - = IPBind (Either (Located HsIPName) id) (LHsExpr id) + = IPBind (Either (Located HsIPName) (IdP id)) (LHsExpr id) deriving instance (DataId name) => Data (IPBind name) -instance (OutputableBndrId id ) => Outputable (HsIPBinds id) where +instance (SourceTextX p, OutputableBndrId p) => Outputable (HsIPBinds p) where ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs) $$ ifPprDebug (ppr ds) -instance (OutputableBndrId id ) => Outputable (IPBind id) where +instance (SourceTextX p, OutputableBndrId p ) => Outputable (IPBind p) where ppr (IPBind lr rhs) = name <+> equals <+> pprExpr (unLoc rhs) where name = case lr of Left (L _ ip) -> pprBndr LetBind ip @@ -718,10 +722,10 @@ serves for both. -} -- | Located Signature -type LSig name = Located (Sig name) +type LSig pass = Located (Sig pass) -- | Signatures and pragmas -data Sig name +data Sig pass = -- | An ordinary type signature -- -- > f :: Num a => a -> a @@ -739,8 +743,8 @@ data Sig name -- For details on above see note [Api annotations] in ApiAnnotation TypeSig - [Located name] -- LHS of the signature; e.g. f,g,h :: blah - (LHsSigWcType name) -- RHS of the signature; can have wildcards + [Located (IdP pass)] -- LHS of the signature; e.g. f,g,h :: blah + (LHsSigWcType pass) -- RHS of the signature; can have wildcards -- | A pattern synonym type signature -- @@ -751,7 +755,7 @@ data Sig name -- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow' -- For details on above see note [Api annotations] in ApiAnnotation - | PatSynSig [Located name] (LHsSigType name) + | PatSynSig [Located (IdP pass)] (LHsSigType pass) -- P :: forall a b. Req => Prov => ty -- | A signature for a class method @@ -764,7 +768,7 @@ data Sig name -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault', -- 'ApiAnnotation.AnnDcolon' - | ClassOpSig Bool [Located name] (LHsSigType name) + | ClassOpSig Bool [Located (IdP pass)] (LHsSigType pass) -- | A type signature in generated code, notably the code -- generated for record selectors. We simply record @@ -782,7 +786,7 @@ data Sig name -- 'ApiAnnotation.AnnVal' -- For details on above see note [Api annotations] in ApiAnnotation - | FixSig (FixitySig name) + | FixSig (FixitySig pass) -- | An inline pragma -- @@ -795,8 +799,8 @@ data Sig name -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation - | InlineSig (Located name) -- Function name - InlinePragma -- Never defaultInlinePragma + | InlineSig (Located (IdP pass)) -- Function name + InlinePragma -- Never defaultInlinePragma -- | A specialisation pragma -- @@ -810,8 +814,8 @@ data Sig name -- 'ApiAnnotation.AnnDcolon' -- For details on above see note [Api annotations] in ApiAnnotation - | SpecSig (Located name) -- Specialise a function or datatype ... - [LHsSigType name] -- ... to these types + | SpecSig (Located (IdP pass)) -- Specialise a function or datatype ... + [LHsSigType pass] -- ... to these types InlinePragma -- The pragma on SPECIALISE_INLINE form. -- If it's just defaultInlinePragma, then we said -- SPECIALISE, not SPECIALISE_INLINE @@ -827,7 +831,7 @@ data Sig name -- 'ApiAnnotation.AnnInstance','ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation - | SpecInstSig SourceText (LHsSigType name) + | SpecInstSig SourceText (LHsSigType pass) -- Note [Pragma source text] in BasicTypes -- | A minimal complete definition pragma @@ -839,7 +843,7 @@ data Sig name -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation - | MinimalSig SourceText (LBooleanFormula (Located name)) + | MinimalSig SourceText (LBooleanFormula (Located (IdP pass))) -- Note [Pragma source text] in BasicTypes -- | A "set cost centre" pragma for declarations @@ -851,7 +855,7 @@ data Sig name -- > {-# SCC funName "cost_centre_name" #-} | SCCFunSig SourceText -- Note [Pragma source text] in BasicTypes - (Located name) -- Function name + (Located (IdP pass)) -- Function name (Maybe (Located StringLiteral)) -- | A complete match pragma -- @@ -860,16 +864,18 @@ data Sig name -- Used to inform the pattern match checker about additional -- complete matchings which, for example, arise from pattern -- synonym definitions. - | CompleteMatchSig SourceText (Located [Located name]) (Maybe (Located name)) + | CompleteMatchSig SourceText + (Located [Located (IdP pass)]) + (Maybe (Located (IdP pass))) -deriving instance (DataId name) => Data (Sig name) +deriving instance (DataId pass) => Data (Sig pass) -- | Located Fixity Signature -type LFixitySig name = Located (FixitySig name) +type LFixitySig pass = Located (FixitySig pass) -- | Fixity Signature -data FixitySig name = FixitySig [Located name] Fixity - deriving Data +data FixitySig pass = FixitySig [Located (IdP pass)] Fixity +deriving instance (DataId pass) => Data (FixitySig pass) -- | Type checker Specialisation Pragmas -- @@ -969,10 +975,11 @@ signatures. Since some of the signatures contain a list of names, testing for equality is not enough -- we have to check if they overlap. -} -instance (OutputableBndrId name ) => Outputable (Sig name) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (Sig pass) where ppr sig = ppr_sig sig -ppr_sig :: (OutputableBndrId name ) => Sig name -> SDoc +ppr_sig :: (SourceTextX pass, OutputableBndrId pass ) => Sig pass -> SDoc ppr_sig (TypeSig vars ty) = pprVarSig (map unLoc vars) (ppr ty) ppr_sig (ClassOpSig is_deflt vars ty) | is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty) @@ -1004,7 +1011,7 @@ ppr_sig (CompleteMatchSig src cs mty) where opt_sig = maybe empty ((\t -> dcolon <+> ppr t) . unLoc) mty -instance OutputableBndr name => Outputable (FixitySig name) where +instance OutputableBndrId pass => Outputable (FixitySig pass) where ppr (FixitySig names fixity) = sep [ppr fixity, pprops] where pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names) diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index 7fcc3b8699..8b7d9c6a40 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -98,7 +98,8 @@ import Name import BasicTypes import Coercion import ForeignCall -import PlaceHolder ( PostTc,PostRn,PlaceHolder(..),DataId, OutputableBndrId ) +import PlaceHolder ( PlaceHolder(..) ) +import HsExtension import NameSet -- others: @@ -251,7 +252,8 @@ appendGroups hs_vects = vects1 ++ vects2, hs_docs = docs1 ++ docs2 } -instance (OutputableBndrId name) => Outputable (HsDecl name) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (HsDecl pass) where ppr (TyClD dcl) = ppr dcl ppr (ValD binds) = ppr binds ppr (DefD def) = ppr def @@ -267,7 +269,8 @@ instance (OutputableBndrId name) => Outputable (HsDecl name) where ppr (DocD doc) = ppr doc ppr (RoleAnnotD ra) = ppr ra -instance (OutputableBndrId name) => Outputable (HsGroup name) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (HsGroup pass) where ppr (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, hs_derivds = deriv_decls, @@ -302,7 +305,7 @@ instance (OutputableBndrId name) => Outputable (HsGroup name) where vcat_mb gap (Just d : ds) = gap $$ d $$ vcat_mb blankLine ds -- | Located Splice Declaration -type LSpliceDecl name = Located (SpliceDecl name) +type LSpliceDecl pass = Located (SpliceDecl pass) -- | Splice Declaration data SpliceDecl id @@ -311,7 +314,8 @@ data SpliceDecl id SpliceExplicitFlag deriving instance (DataId id) => Data (SpliceDecl id) -instance (OutputableBndrId name) => Outputable (SpliceDecl name) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (SpliceDecl pass) where ppr (SpliceDecl (L _ e) f) = pprSpliceDecl e f {- @@ -454,10 +458,10 @@ Interface file code: -} -- | Located Declaration of a Type or Class -type LTyClDecl name = Located (TyClDecl name) +type LTyClDecl pass = Located (TyClDecl pass) -- | A type or class declaration. -data TyClDecl name +data TyClDecl pass = -- | @type/data family T :: *->*@ -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', @@ -469,7 +473,7 @@ data TyClDecl name -- 'ApiAnnotation.AnnVbar' -- For details on above see note [Api annotations] in ApiAnnotation - FamDecl { tcdFam :: FamilyDecl name } + FamDecl { tcdFam :: FamilyDecl pass } | -- | @type@ declaration -- @@ -477,12 +481,13 @@ data TyClDecl name -- 'ApiAnnotation.AnnEqual', -- For details on above see note [Api annotations] in ApiAnnotation - SynDecl { tcdLName :: Located name -- ^ Type constructor - , tcdTyVars :: LHsQTyVars name -- ^ Type variables; for an associated type - -- these include outer binders + SynDecl { tcdLName :: Located (IdP pass) -- ^ Type constructor + , tcdTyVars :: LHsQTyVars pass -- ^ Type variables; for an + -- associated type these + -- include outer binders , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration - , tcdRhs :: LHsType name -- ^ RHS of type declaration - , tcdFVs :: PostRn name NameSet } + , tcdRhs :: LHsType pass -- ^ RHS of type declaration + , tcdFVs :: PostRn pass NameSet } | -- | @data@ declaration -- @@ -493,31 +498,33 @@ data TyClDecl name -- 'ApiAnnotation.AnnWhere', -- For details on above see note [Api annotations] in ApiAnnotation - DataDecl { tcdLName :: Located name -- ^ Type constructor - , tcdTyVars :: LHsQTyVars name -- ^ Type variables; for an associated type - -- these include outer binders - -- Eg class T a where - -- type F a :: * - -- type F a = a -> a - -- Here the type decl for 'f' includes 'a' - -- in its tcdTyVars + DataDecl { tcdLName :: Located (IdP pass) -- ^ Type constructor + , tcdTyVars :: LHsQTyVars pass -- ^ Type variables; for an + -- associated type + -- these include outer binders + -- Eg class T a where + -- type F a :: * + -- type F a = a -> a + -- Here the type decl for 'f' + -- includes 'a' in its tcdTyVars , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration - , tcdDataDefn :: HsDataDefn name - , tcdDataCusk :: PostRn name Bool -- ^ does this have a CUSK? - , tcdFVs :: PostRn name NameSet } + , tcdDataDefn :: HsDataDefn pass + , tcdDataCusk :: PostRn pass Bool -- ^ does this have a CUSK? + , tcdFVs :: PostRn pass NameSet } - | ClassDecl { tcdCtxt :: LHsContext name, -- ^ Context... - tcdLName :: Located name, -- ^ Name of the class - tcdTyVars :: LHsQTyVars name, -- ^ Class type variables + | ClassDecl { tcdCtxt :: LHsContext pass, -- ^ Context... + tcdLName :: Located (IdP pass), -- ^ Name of the class + tcdTyVars :: LHsQTyVars pass, -- ^ Class type variables tcdFixity :: LexicalFixity, -- ^ Fixity used in the declaration - tcdFDs :: [Located (FunDep (Located name))], + tcdFDs :: [Located (FunDep (Located (IdP pass)))], -- ^ Functional deps - tcdSigs :: [LSig name], -- ^ Methods' signatures - tcdMeths :: LHsBinds name, -- ^ Default methods - tcdATs :: [LFamilyDecl name], -- ^ Associated types; - tcdATDefs :: [LTyFamDefltEqn name], -- ^ Associated type defaults + tcdSigs :: [LSig pass], -- ^ Methods' signatures + tcdMeths :: LHsBinds pass, -- ^ Default methods + tcdATs :: [LFamilyDecl pass], -- ^ Associated types; + tcdATDefs :: [LTyFamDefltEqn pass], + -- ^ Associated type defaults tcdDocs :: [LDocDecl], -- ^ Haddock docs - tcdFVs :: PostRn name NameSet + tcdFVs :: PostRn pass NameSet } -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnClass', -- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen', @@ -536,27 +543,27 @@ deriving instance (DataId id) => Data (TyClDecl id) -- | @True@ <=> argument is a @data@\/@newtype@ -- declaration. -isDataDecl :: TyClDecl name -> Bool +isDataDecl :: TyClDecl pass -> Bool isDataDecl (DataDecl {}) = True isDataDecl _other = False -- | type or type instance declaration -isSynDecl :: TyClDecl name -> Bool +isSynDecl :: TyClDecl pass -> Bool isSynDecl (SynDecl {}) = True isSynDecl _other = False -- | type class -isClassDecl :: TyClDecl name -> Bool +isClassDecl :: TyClDecl pass -> Bool isClassDecl (ClassDecl {}) = True isClassDecl _ = False -- | type/data family declaration -isFamilyDecl :: TyClDecl name -> Bool +isFamilyDecl :: TyClDecl pass -> Bool isFamilyDecl (FamDecl {}) = True isFamilyDecl _other = False -- | type family declaration -isTypeFamilyDecl :: TyClDecl name -> Bool +isTypeFamilyDecl :: TyClDecl pass -> Bool isTypeFamilyDecl (FamDecl (FamilyDecl { fdInfo = info })) = case info of OpenTypeFamily -> True ClosedTypeFamily {} -> True @@ -564,42 +571,42 @@ isTypeFamilyDecl (FamDecl (FamilyDecl { fdInfo = info })) = case info of isTypeFamilyDecl _ = False -- | open type family info -isOpenTypeFamilyInfo :: FamilyInfo name -> Bool +isOpenTypeFamilyInfo :: FamilyInfo pass -> Bool isOpenTypeFamilyInfo OpenTypeFamily = True isOpenTypeFamilyInfo _ = False -- | closed type family info -isClosedTypeFamilyInfo :: FamilyInfo name -> Bool +isClosedTypeFamilyInfo :: FamilyInfo pass -> Bool isClosedTypeFamilyInfo (ClosedTypeFamily {}) = True isClosedTypeFamilyInfo _ = False -- | data family declaration -isDataFamilyDecl :: TyClDecl name -> Bool +isDataFamilyDecl :: TyClDecl pass -> Bool isDataFamilyDecl (FamDecl (FamilyDecl { fdInfo = DataFamily })) = True isDataFamilyDecl _other = False -- Dealing with names -tyFamInstDeclName :: TyFamInstDecl name -> name +tyFamInstDeclName :: TyFamInstDecl pass -> (IdP pass) tyFamInstDeclName = unLoc . tyFamInstDeclLName -tyFamInstDeclLName :: TyFamInstDecl name -> Located name +tyFamInstDeclLName :: TyFamInstDecl pass -> Located (IdP pass) tyFamInstDeclLName (TyFamInstDecl { tfid_eqn = (L _ (TyFamEqn { tfe_tycon = ln })) }) = ln -tyClDeclLName :: TyClDecl name -> Located name +tyClDeclLName :: TyClDecl pass -> Located (IdP pass) tyClDeclLName (FamDecl { tcdFam = FamilyDecl { fdLName = ln } }) = ln tyClDeclLName decl = tcdLName decl -tcdName :: TyClDecl name -> name +tcdName :: TyClDecl pass -> (IdP pass) tcdName = unLoc . tyClDeclLName -tyClDeclTyVars :: TyClDecl name -> LHsQTyVars name +tyClDeclTyVars :: TyClDecl pass -> LHsQTyVars pass tyClDeclTyVars (FamDecl { tcdFam = FamilyDecl { fdTyVars = tvs } }) = tvs tyClDeclTyVars d = tcdTyVars d -countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int) +countTyClDecls :: [TyClDecl pass] -> (Int, Int, Int, Int, Int) -- class, synonym decls, data, newtype, family decls countTyClDecls decls = (count isClassDecl decls, @@ -616,7 +623,7 @@ countTyClDecls decls -- | Does this declaration have a complete, user-supplied kind signature? -- See Note [Complete user-supplied kind signatures] -hsDeclHasCusk :: TyClDecl Name -> Bool +hsDeclHasCusk :: TyClDecl GhcRn -> Bool hsDeclHasCusk (FamDecl { tcdFam = fam_decl }) = famDeclHasCusk Nothing fam_decl hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs }) -- NB: Keep this synchronized with 'getInitialKind' @@ -632,7 +639,8 @@ hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars -- Pretty-printing TyClDecl -- ~~~~~~~~~~~~~~~~~~~~~~~~ -instance (OutputableBndrId name) => Outputable (TyClDecl name) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (TyClDecl pass) where ppr (FamDecl { tcdFam = decl }) = ppr decl ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity @@ -663,7 +671,8 @@ instance (OutputableBndrId name) => Outputable (TyClDecl name) where <+> pp_vanilla_decl_head lclas tyvars fixity (unLoc context) <+> pprFundeps (map unLoc fds) -instance (OutputableBndrId name) => Outputable (TyClGroup name) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (TyClGroup pass) where ppr (TyClGroup { group_tyclds = tyclds , group_roles = roles , group_instds = instds @@ -673,10 +682,11 @@ instance (OutputableBndrId name) => Outputable (TyClGroup name) where ppr roles $$ ppr instds -pp_vanilla_decl_head :: (OutputableBndrId name) => Located name - -> LHsQTyVars name +pp_vanilla_decl_head :: (SourceTextX pass, OutputableBndrId pass) + => Located (IdP pass) + -> LHsQTyVars pass -> LexicalFixity - -> HsContext name + -> HsContext pass -> SDoc pp_vanilla_decl_head thing (HsQTvs { hsq_explicit = tyvars }) fixity context = hsep [pprHsContext context, pp_tyvars tyvars] @@ -762,25 +772,25 @@ in RnSource for more info. -} -- | Type or Class Group -data TyClGroup name -- See Note [TyClGroups and dependency analysis] - = TyClGroup { group_tyclds :: [LTyClDecl name] - , group_roles :: [LRoleAnnotDecl name] - , group_instds :: [LInstDecl name] } +data TyClGroup pass -- See Note [TyClGroups and dependency analysis] + = TyClGroup { group_tyclds :: [LTyClDecl pass] + , group_roles :: [LRoleAnnotDecl pass] + , group_instds :: [LInstDecl pass] } deriving instance (DataId id) => Data (TyClGroup id) -emptyTyClGroup :: TyClGroup name +emptyTyClGroup :: TyClGroup pass emptyTyClGroup = TyClGroup [] [] [] -tyClGroupTyClDecls :: [TyClGroup name] -> [LTyClDecl name] +tyClGroupTyClDecls :: [TyClGroup pass] -> [LTyClDecl pass] tyClGroupTyClDecls = concatMap group_tyclds -tyClGroupInstDecls :: [TyClGroup name] -> [LInstDecl name] +tyClGroupInstDecls :: [TyClGroup pass] -> [LInstDecl pass] tyClGroupInstDecls = concatMap group_instds -tyClGroupRoleDecls :: [TyClGroup name] -> [LRoleAnnotDecl name] +tyClGroupRoleDecls :: [TyClGroup pass] -> [LRoleAnnotDecl pass] tyClGroupRoleDecls = concatMap group_roles -mkTyClGroup :: [LTyClDecl name] -> [LInstDecl name] -> TyClGroup name +mkTyClGroup :: [LTyClDecl pass] -> [LInstDecl pass] -> TyClGroup pass mkTyClGroup decls instds = TyClGroup { group_tyclds = decls , group_roles = [] @@ -859,42 +869,42 @@ See also Note [Injective type families] in TyCon -} -- | Located type Family Result Signature -type LFamilyResultSig name = Located (FamilyResultSig name) +type LFamilyResultSig pass = Located (FamilyResultSig pass) -- | type Family Result Signature -data FamilyResultSig name = -- see Note [FamilyResultSig] +data FamilyResultSig pass = -- see Note [FamilyResultSig] NoSig -- ^ - 'ApiAnnotation.AnnKeywordId' : -- For details on above see note [Api annotations] in ApiAnnotation - | KindSig (LHsKind name) + | KindSig (LHsKind pass) -- ^ - 'ApiAnnotation.AnnKeywordId' : -- 'ApiAnnotation.AnnOpenP','ApiAnnotation.AnnDcolon', -- 'ApiAnnotation.AnnCloseP' -- For details on above see note [Api annotations] in ApiAnnotation - | TyVarSig (LHsTyVarBndr name) + | TyVarSig (LHsTyVarBndr pass) -- ^ - 'ApiAnnotation.AnnKeywordId' : -- 'ApiAnnotation.AnnOpenP','ApiAnnotation.AnnDcolon', -- 'ApiAnnotation.AnnCloseP', 'ApiAnnotation.AnnEqual' -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId name) => Data (FamilyResultSig name) +deriving instance (DataId pass) => Data (FamilyResultSig pass) -- | Located type Family Declaration -type LFamilyDecl name = Located (FamilyDecl name) +type LFamilyDecl pass = Located (FamilyDecl pass) -- | type Family Declaration -data FamilyDecl name = FamilyDecl - { fdInfo :: FamilyInfo name -- type/data, closed/open - , fdLName :: Located name -- type constructor - , fdTyVars :: LHsQTyVars name -- type variables +data FamilyDecl pass = FamilyDecl + { fdInfo :: FamilyInfo pass -- type/data, closed/open + , fdLName :: Located (IdP pass) -- type constructor + , fdTyVars :: LHsQTyVars pass -- type variables , fdFixity :: LexicalFixity -- Fixity used in the declaration - , fdResultSig :: LFamilyResultSig name -- result signature - , fdInjectivityAnn :: Maybe (LInjectivityAnn name) -- optional injectivity ann + , fdResultSig :: LFamilyResultSig pass -- result signature + , fdInjectivityAnn :: Maybe (LInjectivityAnn pass) -- optional injectivity ann } -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', -- 'ApiAnnotation.AnnData', 'ApiAnnotation.AnnFamily', @@ -908,7 +918,7 @@ data FamilyDecl name = FamilyDecl deriving instance (DataId id) => Data (FamilyDecl id) -- | Located Injectivity Annotation -type LInjectivityAnn name = Located (InjectivityAnn name) +type LInjectivityAnn pass = Located (InjectivityAnn pass) -- | If the user supplied an injectivity annotation it is represented using -- InjectivityAnn. At the moment this is a single injectivity condition - see @@ -918,26 +928,26 @@ type LInjectivityAnn name = Located (InjectivityAnn name) -- type family Foo a b c = r | r -> a c where ... -- -- This will be represented as "InjectivityAnn `r` [`a`, `c`]" -data InjectivityAnn name - = InjectivityAnn (Located name) [Located name] +data InjectivityAnn pass + = InjectivityAnn (Located (IdP pass)) [Located (IdP pass)] -- ^ - 'ApiAnnotation.AnnKeywordId' : -- 'ApiAnnotation.AnnRarrow', 'ApiAnnotation.AnnVbar' -- For details on above see note [Api annotations] in ApiAnnotation - deriving Data +deriving instance (DataId pass) => Data (InjectivityAnn pass) -data FamilyInfo name +data FamilyInfo pass = DataFamily | OpenTypeFamily -- | 'Nothing' if we're in an hs-boot file and the user -- said "type family Foo x where .." - | ClosedTypeFamily (Maybe [LTyFamInstEqn name]) -deriving instance (DataId name) => Data (FamilyInfo name) + | ClosedTypeFamily (Maybe [LTyFamInstEqn pass]) +deriving instance (DataId pass) => Data (FamilyInfo pass) -- | Does this family declaration have a complete, user-supplied kind signature? famDeclHasCusk :: Maybe Bool -- ^ if associated, does the enclosing class have a CUSK? - -> FamilyDecl name -> Bool + -> FamilyDecl pass -> Bool famDeclHasCusk _ (FamilyDecl { fdInfo = ClosedTypeFamily _ , fdTyVars = tyvars , fdResultSig = L _ resultSig }) @@ -952,15 +962,16 @@ hasReturnKindSignature (TyVarSig (L _ (UserTyVar _))) = False hasReturnKindSignature _ = True -- | Maybe return name of the result type variable -resultVariableName :: FamilyResultSig a -> Maybe a +resultVariableName :: FamilyResultSig a -> Maybe (IdP a) resultVariableName (TyVarSig sig) = Just $ hsLTyVarName sig resultVariableName _ = Nothing -instance (OutputableBndrId name) => Outputable (FamilyDecl name) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (FamilyDecl pass) where ppr = pprFamilyDecl TopLevel -pprFamilyDecl :: (OutputableBndrId name) - => TopLevelFlag -> FamilyDecl name -> SDoc +pprFamilyDecl :: (SourceTextX pass, OutputableBndrId pass) + => TopLevelFlag -> FamilyDecl pass -> SDoc pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon , fdTyVars = tyvars , fdFixity = fixity @@ -991,12 +1002,12 @@ pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon Just eqns -> vcat $ map ppr_fam_inst_eqn eqns ) _ -> (empty, empty) -pprFlavour :: FamilyInfo name -> SDoc +pprFlavour :: FamilyInfo pass -> SDoc pprFlavour DataFamily = text "data" pprFlavour OpenTypeFamily = text "type" pprFlavour (ClosedTypeFamily {}) = text "type" -instance Outputable (FamilyInfo name) where +instance Outputable (FamilyInfo pass) where ppr info = pprFlavour info <+> text "family" @@ -1008,7 +1019,7 @@ instance Outputable (FamilyInfo name) where ********************************************************************* -} -- | Haskell Data type Definition -data HsDataDefn name -- The payload of a data type defn +data HsDataDefn pass -- The payload of a data type defn -- Used *both* for vanilla data declarations, -- *and* for data family instances = -- | Declares a data type or newtype, giving its constructors @@ -1017,9 +1028,9 @@ data HsDataDefn name -- The payload of a data type defn -- data/newtype instance T [a] = <constrs> -- @ HsDataDefn { dd_ND :: NewOrData, - dd_ctxt :: LHsContext name, -- ^ Context + dd_ctxt :: LHsContext pass, -- ^ Context dd_cType :: Maybe (Located CType), - dd_kindSig:: Maybe (LHsKind name), + dd_kindSig:: Maybe (LHsKind pass), -- ^ Optional kind signature. -- -- @(Just k)@ for a GADT-style @data@, @@ -1027,7 +1038,7 @@ data HsDataDefn name -- The payload of a data type defn -- -- Always @Nothing@ for H98-syntax decls - dd_cons :: [LConDecl name], + dd_cons :: [LConDecl pass], -- ^ Data constructors -- -- For @data T a = T1 | T2 a@ @@ -1035,14 +1046,14 @@ data HsDataDefn name -- The payload of a data type defn -- For @data T a where { T1 :: T a }@ -- the 'LConDecls' all have 'ConDeclGADT'. - dd_derivs :: HsDeriving name -- ^ Optional 'deriving' claues + dd_derivs :: HsDeriving pass -- ^ Optional 'deriving' claues -- For details on above see note [Api annotations] in ApiAnnotation } deriving instance (DataId id) => Data (HsDataDefn id) -- | Haskell Deriving clause -type HsDeriving name = Located [LHsDerivingClause name] +type HsDeriving pass = Located [LHsDerivingClause pass] -- ^ The optional @deriving@ clauses of a data declaration. "Clauses" is -- plural because one can specify multiple deriving clauses using the -- @-XDerivingStrategies@ language extension. @@ -1051,7 +1062,7 @@ type HsDeriving name = Located [LHsDerivingClause name] -- requested to derive, in order. If no deriving clauses were specified, -- the list is empty. -type LHsDerivingClause name = Located (HsDerivingClause name) +type LHsDerivingClause pass = Located (HsDerivingClause pass) -- | A single @deriving@ clause of a data declaration. -- @@ -1059,13 +1070,13 @@ type LHsDerivingClause name = Located (HsDerivingClause name) -- 'ApiAnnotation.AnnDeriving', 'ApiAnnotation.AnnStock', -- 'ApiAnnotation.AnnAnyClass', 'Api.AnnNewtype', -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' -data HsDerivingClause name +data HsDerivingClause pass -- See Note [Deriving strategies] in TcDeriv = HsDerivingClause { deriv_clause_strategy :: Maybe (Located DerivStrategy) -- ^ The user-specified strategy (if any) to use when deriving -- 'deriv_clause_tys'. - , deriv_clause_tys :: Located [LHsSigType name] + , deriv_clause_tys :: Located [LHsSigType pass] -- ^ The types to derive. -- -- It uses 'LHsSigType's because, with @-XGeneralizedNewtypeDeriving@, @@ -1077,8 +1088,8 @@ data HsDerivingClause name } deriving instance (DataId id) => Data (HsDerivingClause id) -instance (OutputableBndrId name) - => Outputable (HsDerivingClause name) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (HsDerivingClause pass) where ppr (HsDerivingClause { deriv_clause_strategy = dcs , deriv_clause_tys = L _ dct }) = hsep [ text "deriving" @@ -1098,7 +1109,7 @@ data NewOrData deriving( Eq, Data ) -- Needed because Demand derives Eq -- | Located data Constructor Declaration -type LConDecl name = Located (ConDecl name) +type LConDecl pass = Located (ConDecl pass) -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when -- in a GADT constructor list @@ -1129,57 +1140,57 @@ type LConDecl name = Located (ConDecl name) -- For details on above see note [Api annotations] in ApiAnnotation -- | data Constructor Declaration -data ConDecl name +data ConDecl pass = ConDeclGADT - { con_names :: [Located name] - , con_type :: LHsSigType name + { con_names :: [Located (IdP pass)] + , con_type :: LHsSigType pass -- ^ The type after the ‘::’ , con_doc :: Maybe LHsDocString -- ^ A possible Haddock comment. } | ConDeclH98 - { con_name :: Located name + { con_name :: Located (IdP pass) - , con_qvars :: Maybe (LHsQTyVars name) + , con_qvars :: Maybe (LHsQTyVars pass) -- User-written forall (if any), and its implicit -- kind variables -- Non-Nothing needs -XExistentialQuantification -- e.g. data T a = forall b. MkT b (b->a) -- con_qvars = {b} - , con_cxt :: Maybe (LHsContext name) + , con_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) - , con_details :: HsConDeclDetails name + , con_details :: HsConDeclDetails pass -- ^ Arguments , con_doc :: Maybe LHsDocString -- ^ A possible Haddock comment. } -deriving instance (DataId name) => Data (ConDecl name) +deriving instance (DataId pass) => Data (ConDecl pass) -- | Haskell data Constructor Declaration Details -type HsConDeclDetails name - = HsConDetails (LBangType name) (Located [LConDeclField name]) +type HsConDeclDetails pass + = HsConDetails (LBangType pass) (Located [LConDeclField pass]) -getConNames :: ConDecl name -> [Located name] +getConNames :: ConDecl pass -> [Located (IdP pass)] getConNames ConDeclH98 {con_name = name} = [name] getConNames ConDeclGADT {con_names = names} = names -- don't call with RdrNames, because it can't deal with HsAppsTy -getConDetails :: ConDecl name -> HsConDeclDetails name +getConDetails :: ConDecl pass -> HsConDeclDetails pass getConDetails ConDeclH98 {con_details = details} = details getConDetails ConDeclGADT {con_type = ty } = details where (details,_,_,_) = gadtDeclDetails ty -- don't call with RdrNames, because it can't deal with HsAppsTy -gadtDeclDetails :: LHsSigType name - -> ( HsConDeclDetails name - , LHsType name - , LHsContext name - , [LHsTyVarBndr name] ) +gadtDeclDetails :: LHsSigType pass + -> ( HsConDeclDetails pass + , LHsType pass + , LHsContext pass + , [LHsTyVarBndr pass] ) gadtDeclDetails HsIB {hsib_body = lbody_ty} = (details,res_ty,cxt,tvs) where (tvs, cxt, tau) = splitLHsSigmaTy lbody_ty @@ -1189,14 +1200,14 @@ gadtDeclDetails HsIB {hsib_body = lbody_ty} = (details,res_ty,cxt,tvs) -> (RecCon (L l flds), res_ty') _other -> (PrefixCon [], tau) -hsConDeclArgTys :: HsConDeclDetails name -> [LBangType name] +hsConDeclArgTys :: HsConDeclDetails pass -> [LBangType pass] hsConDeclArgTys (PrefixCon tys) = tys hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2] hsConDeclArgTys (RecCon flds) = map (cd_fld_type . unLoc) (unLoc flds) -pp_data_defn :: (OutputableBndrId name) - => (HsContext name -> SDoc) -- Printing the header - -> HsDataDefn name +pp_data_defn :: (SourceTextX pass, OutputableBndrId pass) + => (HsContext pass -> SDoc) -- Printing the header + -> HsDataDefn pass -> SDoc pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context , dd_cType = mb_ct @@ -1218,23 +1229,26 @@ pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context Just kind -> dcolon <+> ppr kind pp_derivings (L _ ds) = vcat (map ppr ds) -instance (OutputableBndrId name) => Outputable (HsDataDefn name) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (HsDataDefn pass) where ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d instance Outputable NewOrData where ppr NewType = text "newtype" ppr DataType = text "data" -pp_condecls :: (OutputableBndrId name) => [LConDecl name] -> SDoc +pp_condecls :: (SourceTextX pass, OutputableBndrId pass) + => [LConDecl pass] -> SDoc pp_condecls cs@(L _ ConDeclGADT{} : _) -- In GADT syntax = hang (text "where") 2 (vcat (map ppr cs)) pp_condecls cs -- In H98 syntax = equals <+> sep (punctuate (text " |") (map ppr cs)) -instance (OutputableBndrId name) => Outputable (ConDecl name) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (ConDecl pass) where ppr = pprConDecl -pprConDecl :: (OutputableBndrId name) => ConDecl name -> SDoc +pprConDecl :: (SourceTextX pass, OutputableBndrId pass) => ConDecl pass -> SDoc pprConDecl (ConDeclH98 { con_name = L _ con , con_qvars = mtvs , con_cxt = mcxt @@ -1257,7 +1271,7 @@ pprConDecl (ConDeclGADT { con_names = cons, con_type = res_ty, con_doc = doc }) = sep [ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon <+> ppr res_ty] -ppr_con_names :: (OutputableBndr name) => [Located name] -> SDoc +ppr_con_names :: (OutputableBndr a) => [Located a] -> SDoc ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc) {- @@ -1289,17 +1303,17 @@ It is parameterised over its tfe_pats field: ----------------- Type synonym family instances ------------- -- | Located Type Family Instance Equation -type LTyFamInstEqn name = Located (TyFamInstEqn name) +type LTyFamInstEqn pass = Located (TyFamInstEqn pass) -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' -- when in a list -- For details on above see note [Api annotations] in ApiAnnotation -- | Located Type Family Default Equation -type LTyFamDefltEqn name = Located (TyFamDefltEqn name) +type LTyFamDefltEqn pass = Located (TyFamDefltEqn pass) -- | Haskell Type Patterns -type HsTyPats name = HsImplicitBndrs name [LHsType name] +type HsTyPats pass = HsImplicitBndrs pass [LHsType pass] -- ^ Type patterns (with kind and type bndrs) -- See Note [Family instance declaration binders] @@ -1333,56 +1347,57 @@ type patterns, i.e. fv(pat_tys). Note in particular -} -- | Type Family Instance Equation -type TyFamInstEqn name = TyFamEqn name (HsTyPats name) +type TyFamInstEqn pass = TyFamEqn pass (HsTyPats pass) -- | Type Family Default Equation -type TyFamDefltEqn name = TyFamEqn name (LHsQTyVars name) +type TyFamDefltEqn pass = TyFamEqn pass (LHsQTyVars pass) -- See Note [Type family instance declarations in HsSyn] -- | Type Family Equation -- -- One equation in a type family instance declaration -- See Note [Type family instance declarations in HsSyn] -data TyFamEqn name pats +data TyFamEqn pass pats = TyFamEqn - { tfe_tycon :: Located name + { tfe_tycon :: Located (IdP pass) , tfe_pats :: pats , tfe_fixity :: LexicalFixity -- ^ Fixity used in the declaration - , tfe_rhs :: LHsType name } + , tfe_rhs :: LHsType pass } -- ^ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual' -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId name, Data pats) => Data (TyFamEqn name pats) +deriving instance (DataId pass, Data pats) => Data (TyFamEqn pass pats) -- | Located Type Family Instance Declaration -type LTyFamInstDecl name = Located (TyFamInstDecl name) +type LTyFamInstDecl pass = Located (TyFamInstDecl pass) -- | Type Family Instance Declaration -data TyFamInstDecl name +data TyFamInstDecl pass = TyFamInstDecl - { tfid_eqn :: LTyFamInstEqn name - , tfid_fvs :: PostRn name NameSet } + { tfid_eqn :: LTyFamInstEqn pass + , tfid_fvs :: PostRn pass NameSet } -- ^ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', -- 'ApiAnnotation.AnnInstance', -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId name) => Data (TyFamInstDecl name) +deriving instance (DataId pass) => Data (TyFamInstDecl pass) ----------------- Data family instances ------------- -- | Located Data Family Instance Declaration -type LDataFamInstDecl name = Located (DataFamInstDecl name) +type LDataFamInstDecl pass = Located (DataFamInstDecl pass) -- | Data Family Instance Declaration -data DataFamInstDecl name +data DataFamInstDecl pass = DataFamInstDecl - { dfid_tycon :: Located name - , dfid_pats :: HsTyPats name -- LHS + { dfid_tycon :: Located (IdP pass) + , dfid_pats :: HsTyPats pass -- LHS , dfid_fixity :: LexicalFixity -- ^ Fixity used in the declaration - , dfid_defn :: HsDataDefn name -- RHS - , dfid_fvs :: PostRn name NameSet } -- Free vars for dependency analysis + , dfid_defn :: HsDataDefn pass -- RHS + , dfid_fvs :: PostRn pass NameSet } + -- Free vars for dependency analysis -- ^ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData', -- 'ApiAnnotation.AnnNewType','ApiAnnotation.AnnInstance', @@ -1391,24 +1406,24 @@ data DataFamInstDecl name -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId name) => Data (DataFamInstDecl name) +deriving instance (DataId pass) => Data (DataFamInstDecl pass) ----------------- Class instances ------------- -- | Located Class Instance Declaration -type LClsInstDecl name = Located (ClsInstDecl name) +type LClsInstDecl pass = Located (ClsInstDecl pass) -- | Class Instance Declaration -data ClsInstDecl name +data ClsInstDecl pass = ClsInstDecl - { cid_poly_ty :: LHsSigType name -- Context => Class Instance-type + { cid_poly_ty :: LHsSigType pass -- Context => Class Instance-type -- Using a polytype means that the renamer conveniently -- figures out the quantified type variables for us. - , cid_binds :: LHsBinds name -- Class methods - , cid_sigs :: [LSig name] -- User-supplied pragmatic info - , cid_tyfam_insts :: [LTyFamInstDecl name] -- Type family instances - , cid_datafam_insts :: [LDataFamInstDecl name] -- Data family instances + , cid_binds :: LHsBinds pass -- Class methods + , cid_sigs :: [LSig pass] -- User-supplied pragmatic info + , cid_tyfam_insts :: [LTyFamInstDecl pass] -- Type family instances + , cid_datafam_insts :: [LDataFamInstDecl pass] -- Data family instances , cid_overlap_mode :: Maybe (Located OverlapMode) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnClose', @@ -1427,23 +1442,24 @@ deriving instance (DataId id) => Data (ClsInstDecl id) ----------------- Instances of all kinds ------------- -- | Located Instance Declaration -type LInstDecl name = Located (InstDecl name) +type LInstDecl pass = Located (InstDecl pass) -- | Instance Declaration -data InstDecl name -- Both class and family instances +data InstDecl pass -- Both class and family instances = ClsInstD - { cid_inst :: ClsInstDecl name } + { cid_inst :: ClsInstDecl pass } | DataFamInstD -- data family instance - { dfid_inst :: DataFamInstDecl name } + { dfid_inst :: DataFamInstDecl pass } | TyFamInstD -- type family instance - { tfid_inst :: TyFamInstDecl name } + { tfid_inst :: TyFamInstDecl pass } deriving instance (DataId id) => Data (InstDecl id) -instance (OutputableBndrId name) => Outputable (TyFamInstDecl name) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (TyFamInstDecl pass) where ppr = pprTyFamInstDecl TopLevel -pprTyFamInstDecl :: (OutputableBndrId name) - => TopLevelFlag -> TyFamInstDecl name -> SDoc +pprTyFamInstDecl :: (SourceTextX pass, OutputableBndrId pass) + => TopLevelFlag -> TyFamInstDecl pass -> SDoc pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn }) = text "type" <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn @@ -1451,14 +1467,16 @@ ppr_instance_keyword :: TopLevelFlag -> SDoc ppr_instance_keyword TopLevel = text "instance" ppr_instance_keyword NotTopLevel = empty -ppr_fam_inst_eqn :: (OutputableBndrId name) => LTyFamInstEqn name -> SDoc +ppr_fam_inst_eqn :: (SourceTextX pass, OutputableBndrId pass) + => LTyFamInstEqn pass -> SDoc ppr_fam_inst_eqn (L _ (TyFamEqn { tfe_tycon = tycon , tfe_pats = pats , tfe_fixity = fixity , tfe_rhs = rhs })) = pp_fam_inst_lhs tycon pats fixity [] <+> equals <+> ppr rhs -ppr_fam_deflt_eqn :: (OutputableBndrId name) => LTyFamDefltEqn name -> SDoc +ppr_fam_deflt_eqn :: (SourceTextX pass, OutputableBndrId pass) + => LTyFamDefltEqn pass -> SDoc ppr_fam_deflt_eqn (L _ (TyFamEqn { tfe_tycon = tycon , tfe_pats = tvs , tfe_fixity = fixity @@ -1466,11 +1484,12 @@ ppr_fam_deflt_eqn (L _ (TyFamEqn { tfe_tycon = tycon = text "type" <+> pp_vanilla_decl_head tycon tvs fixity [] <+> equals <+> ppr rhs -instance (OutputableBndrId name) => Outputable (DataFamInstDecl name) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (DataFamInstDecl pass) where ppr = pprDataFamInstDecl TopLevel -pprDataFamInstDecl :: (OutputableBndrId name) - => TopLevelFlag -> DataFamInstDecl name -> SDoc +pprDataFamInstDecl :: (SourceTextX pass, OutputableBndrId pass) + => TopLevelFlag -> DataFamInstDecl pass -> SDoc pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_tycon = tycon , dfid_pats = pats , dfid_fixity = fixity @@ -1480,14 +1499,15 @@ pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_tycon = tycon pp_hdr ctxt = ppr_instance_keyword top_lvl <+> pp_fam_inst_lhs tycon pats fixity ctxt -pprDataFamInstFlavour :: DataFamInstDecl name -> SDoc +pprDataFamInstFlavour :: DataFamInstDecl pass -> SDoc pprDataFamInstFlavour (DataFamInstDecl { dfid_defn = (HsDataDefn { dd_ND = nd }) }) = ppr nd -pp_fam_inst_lhs :: (OutputableBndrId name) => Located name - -> HsTyPats name +pp_fam_inst_lhs :: (SourceTextX pass, OutputableBndrId pass) + => Located (IdP pass) + -> HsTyPats pass -> LexicalFixity - -> HsContext name + -> HsContext pass -> SDoc pp_fam_inst_lhs thing (HsIB { hsib_body = typats }) fixity context -- explicit type patterns @@ -1501,7 +1521,8 @@ pp_fam_inst_lhs thing (HsIB { hsib_body = typats }) fixity context , hsep (map (pprHsType.unLoc) (patl:patsr))] pp_pats [] = empty -instance (OutputableBndrId name) => Outputable (ClsInstDecl name) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (ClsInstDecl pass) where ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds , cid_sigs = sigs, cid_tyfam_insts = ats , cid_overlap_mode = mbOverlap @@ -1539,14 +1560,15 @@ ppOverlapPragma mb = maybe_stext (SourceText src) _ = text src <+> text "#-}" -instance (OutputableBndrId name) => Outputable (InstDecl name) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (InstDecl pass) where ppr (ClsInstD { cid_inst = decl }) = ppr decl ppr (TyFamInstD { tfid_inst = decl }) = ppr decl ppr (DataFamInstD { dfid_inst = decl }) = ppr decl -- Extract the declarations of associated data types from an instance -instDeclDataFamInsts :: [LInstDecl name] -> [DataFamInstDecl name] +instDeclDataFamInsts :: [LInstDecl pass] -> [DataFamInstDecl pass] instDeclDataFamInsts inst_decls = concatMap do_one inst_decls where @@ -1564,11 +1586,11 @@ instDeclDataFamInsts inst_decls -} -- | Located Deriving Declaration -type LDerivDecl name = Located (DerivDecl name) +type LDerivDecl pass = Located (DerivDecl pass) -- | Deriving Declaration -data DerivDecl name = DerivDecl - { deriv_type :: LHsSigType name +data DerivDecl pass = DerivDecl + { deriv_type :: LHsSigType pass , deriv_strategy :: Maybe (Located DerivStrategy) , deriv_overlap_mode :: Maybe (Located OverlapMode) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDeriving', @@ -1578,9 +1600,10 @@ data DerivDecl name = DerivDecl -- For details on above see note [Api annotations] in ApiAnnotation } -deriving instance (DataId name) => Data (DerivDecl name) +deriving instance (DataId pass) => Data (DerivDecl pass) -instance (OutputableBndrId name) => Outputable (DerivDecl name) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (DerivDecl pass) where ppr (DerivDecl { deriv_type = ty , deriv_strategy = ds , deriv_overlap_mode = o }) @@ -1603,18 +1626,19 @@ syntax, and that restriction must be checked in the front end. -} -- | Located Default Declaration -type LDefaultDecl name = Located (DefaultDecl name) +type LDefaultDecl pass = Located (DefaultDecl pass) -- | Default Declaration -data DefaultDecl name - = DefaultDecl [LHsType name] +data DefaultDecl pass + = DefaultDecl [LHsType pass] -- ^ - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnDefault', -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId name) => Data (DefaultDecl name) +deriving instance (DataId pass) => Data (DefaultDecl pass) -instance (OutputableBndrId name) => Outputable (DefaultDecl name) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (DefaultDecl pass) where ppr (DefaultDecl tys) = text "default" <+> parens (interpp'SP tys) @@ -1634,20 +1658,20 @@ instance (OutputableBndrId name) => Outputable (DefaultDecl name) where -- has been used -- | Located Foreign Declaration -type LForeignDecl name = Located (ForeignDecl name) +type LForeignDecl pass = Located (ForeignDecl pass) -- | Foreign Declaration -data ForeignDecl name +data ForeignDecl pass = ForeignImport - { fd_name :: Located name -- defines this name - , fd_sig_ty :: LHsSigType name -- sig_ty - , fd_co :: PostTc name Coercion -- rep_ty ~ sig_ty + { fd_name :: Located (IdP pass) -- defines this name + , fd_sig_ty :: LHsSigType pass -- sig_ty + , fd_co :: PostTc pass Coercion -- rep_ty ~ sig_ty , fd_fi :: ForeignImport } | ForeignExport - { fd_name :: Located name -- uses this name - , fd_sig_ty :: LHsSigType name -- sig_ty - , fd_co :: PostTc name Coercion -- rep_ty ~ sig_ty + { fd_name :: Located (IdP pass) -- uses this name + , fd_sig_ty :: LHsSigType pass -- sig_ty + , fd_co :: PostTc pass Coercion -- rep_ty ~ sig_ty , fd_fe :: ForeignExport } -- ^ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForeign', @@ -1656,7 +1680,7 @@ data ForeignDecl name -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId name) => Data (ForeignDecl name) +deriving instance (DataId pass) => Data (ForeignDecl pass) {- In both ForeignImport and ForeignExport: sig_ty is the type given in the Haskell code @@ -1717,7 +1741,8 @@ data ForeignExport = CExport (Located CExportSpec) -- contains the calling -- pretty printing of foreign declarations -- -instance (OutputableBndrId name) => Outputable (ForeignDecl name) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (ForeignDecl pass) where ppr (ForeignImport { fd_name = n, fd_sig_ty = ty, fd_fi = fimport }) = hang (text "foreign import" <+> ppr fimport <+> ppr n) 2 (dcolon <+> ppr ty) @@ -1766,29 +1791,29 @@ instance Outputable ForeignExport where -} -- | Located Rule Declarations -type LRuleDecls name = Located (RuleDecls name) +type LRuleDecls pass = Located (RuleDecls pass) -- Note [Pragma source text] in BasicTypes -- | Rule Declarations -data RuleDecls name = HsRules { rds_src :: SourceText - , rds_rules :: [LRuleDecl name] } -deriving instance (DataId name) => Data (RuleDecls name) +data RuleDecls pass = HsRules { rds_src :: SourceText + , rds_rules :: [LRuleDecl pass] } +deriving instance (DataId pass) => Data (RuleDecls pass) -- | Located Rule Declaration -type LRuleDecl name = Located (RuleDecl name) +type LRuleDecl pass = Located (RuleDecl pass) -- | Rule Declaration -data RuleDecl name +data RuleDecl pass = HsRule -- Source rule (Located (SourceText,RuleName)) -- Rule name -- Note [Pragma source text] in BasicTypes Activation - [LRuleBndr name] -- Forall'd vars; after typechecking this + [LRuleBndr pass] -- Forall'd vars; after typechecking this -- includes tyvars - (Located (HsExpr name)) -- LHS - (PostRn name NameSet) -- Free-vars from the LHS - (Located (HsExpr name)) -- RHS - (PostRn name NameSet) -- Free-vars from the RHS + (Located (HsExpr pass)) -- LHS + (PostRn pass NameSet) -- Free-vars from the LHS + (Located (HsExpr pass)) -- RHS + (PostRn pass NameSet) -- Free-vars from the RHS -- ^ -- - 'ApiAnnotation.AnnKeywordId' : -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnTilde', @@ -1798,37 +1823,39 @@ data RuleDecl name -- 'ApiAnnotation.AnnEqual', -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId name) => Data (RuleDecl name) +deriving instance (DataId pass) => Data (RuleDecl pass) -flattenRuleDecls :: [LRuleDecls name] -> [LRuleDecl name] +flattenRuleDecls :: [LRuleDecls pass] -> [LRuleDecl pass] flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls -- | Located Rule Binder -type LRuleBndr name = Located (RuleBndr name) +type LRuleBndr pass = Located (RuleBndr pass) -- | Rule Binder -data RuleBndr name - = RuleBndr (Located name) - | RuleBndrSig (Located name) (LHsSigWcType name) +data RuleBndr pass + = RuleBndr (Located (IdP pass)) + | RuleBndrSig (Located (IdP pass)) (LHsSigWcType pass) -- ^ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId name) => Data (RuleBndr name) +deriving instance (DataId pass) => Data (RuleBndr pass) -collectRuleBndrSigTys :: [RuleBndr name] -> [LHsSigWcType name] +collectRuleBndrSigTys :: [RuleBndr pass] -> [LHsSigWcType pass] collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs] pprFullRuleName :: Located (SourceText, RuleName) -> SDoc pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n) -instance (OutputableBndrId name) => Outputable (RuleDecls name) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (RuleDecls pass) where ppr (HsRules st rules) = pprWithSourceText st (text "{-# RULES") <+> vcat (punctuate semi (map ppr rules)) <+> text "#-}" -instance (OutputableBndrId name) => Outputable (RuleDecl name) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (RuleDecl pass) where ppr (HsRule name act ns lhs _fv_lhs rhs _fv_rhs) = sep [pprFullRuleName name <+> ppr act, nest 4 (pp_forall <+> pprExpr (unLoc lhs)), @@ -1837,7 +1864,8 @@ instance (OutputableBndrId name) => Outputable (RuleDecl name) where pp_forall | null ns = empty | otherwise = forAllLit <+> fsep (map ppr ns) <> dot -instance (OutputableBndrId name) => Outputable (RuleBndr name) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (RuleBndr pass) where ppr (RuleBndr name) = ppr name ppr (RuleBndrSig name ty) = parens (ppr name <> dcolon <> ppr ty) @@ -1859,21 +1887,21 @@ A vectorisation pragma, one of -} -- | Located Vectorise Declaration -type LVectDecl name = Located (VectDecl name) +type LVectDecl pass = Located (VectDecl pass) -- | Vectorise Declaration -data VectDecl name +data VectDecl pass = HsVect SourceText -- Note [Pragma source text] in BasicTypes - (Located name) - (LHsExpr name) + (Located (IdP pass)) + (LHsExpr pass) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation | HsNoVect SourceText -- Note [Pragma source text] in BasicTypes - (Located name) + (Located (IdP pass)) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnClose' @@ -1881,8 +1909,8 @@ data VectDecl name | HsVectTypeIn -- pre type-checking SourceText -- Note [Pragma source text] in BasicTypes Bool -- 'TRUE' => SCALAR declaration - (Located name) - (Maybe (Located name)) -- 'Nothing' => no right-hand side + (Located (IdP pass)) + (Maybe (Located (IdP pass))) -- 'Nothing' => no right-hand side -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnType','ApiAnnotation.AnnClose', -- 'ApiAnnotation.AnnEqual' @@ -1894,7 +1922,7 @@ data VectDecl name (Maybe TyCon) -- 'Nothing' => no right-hand side | HsVectClassIn -- pre type-checking SourceText -- Note [Pragma source text] in BasicTypes - (Located name) + (Located (IdP pass)) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnClass','ApiAnnotation.AnnClose', @@ -1902,12 +1930,12 @@ data VectDecl name | HsVectClassOut -- post type-checking Class | HsVectInstIn -- pre type-checking (always SCALAR) !!!FIXME: should be superfluous now - (LHsSigType name) + (LHsSigType pass) | HsVectInstOut -- post type-checking (always SCALAR) !!!FIXME: should be superfluous now ClsInst -deriving instance (DataId name) => Data (VectDecl name) +deriving instance (DataId pass) => Data (VectDecl pass) -lvectDeclName :: NamedThing name => LVectDecl name -> Name +lvectDeclName :: NamedThing (IdP pass) => LVectDecl pass -> Name lvectDeclName (L _ (HsVect _ (L _ name) _)) = getName name lvectDeclName (L _ (HsNoVect _ (L _ name))) = getName name lvectDeclName (L _ (HsVectTypeIn _ _ (L _ name) _)) = getName name @@ -1919,12 +1947,13 @@ lvectDeclName (L _ (HsVectInstIn _)) lvectDeclName (L _ (HsVectInstOut _)) = panic "HsDecls.lvectDeclName: HsVectInstOut" -lvectInstDecl :: LVectDecl name -> Bool +lvectInstDecl :: LVectDecl pass -> Bool lvectInstDecl (L _ (HsVectInstIn _)) = True lvectInstDecl (L _ (HsVectInstOut _)) = True lvectInstDecl _ = False -instance (OutputableBndrId name) => Outputable (VectDecl name) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (VectDecl pass) where ppr (HsVect _ v rhs) = sep [text "{-# VECTORISE" <+> ppr v, nest 4 $ @@ -1996,28 +2025,28 @@ We use exported entities for things to deprecate. -} -- | Located Warning Declarations -type LWarnDecls name = Located (WarnDecls name) +type LWarnDecls pass = Located (WarnDecls pass) -- Note [Pragma source text] in BasicTypes -- | Warning pragma Declarations -data WarnDecls name = Warnings { wd_src :: SourceText - , wd_warnings :: [LWarnDecl name] +data WarnDecls pass = Warnings { wd_src :: SourceText + , wd_warnings :: [LWarnDecl pass] } - deriving Data +deriving instance (DataId pass) => Data (WarnDecls pass) -- | Located Warning pragma Declaration -type LWarnDecl name = Located (WarnDecl name) +type LWarnDecl pass = Located (WarnDecl pass) -- | Warning pragma Declaration -data WarnDecl name = Warning [Located name] WarningTxt - deriving Data +data WarnDecl pass = Warning [Located (IdP pass)] WarningTxt +deriving instance (DataId pass) => Data (WarnDecl pass) -instance OutputableBndr name => Outputable (WarnDecls name) where +instance OutputableBndr (IdP pass) => Outputable (WarnDecls pass) where ppr (Warnings (SourceText src) decls) = text src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}" ppr (Warnings NoSourceText _decls) = panic "WarnDecls" -instance OutputableBndr name => Outputable (WarnDecl name) where +instance OutputableBndr (IdP pass) => Outputable (WarnDecl pass) where ppr (Warning thing txt) = hsep ( punctuate comma (map ppr thing)) <+> ppr txt @@ -2031,21 +2060,22 @@ instance OutputableBndr name => Outputable (WarnDecl name) where -} -- | Located Annotation Declaration -type LAnnDecl name = Located (AnnDecl name) +type LAnnDecl pass = Located (AnnDecl pass) -- | Annotation Declaration -data AnnDecl name = HsAnnotation +data AnnDecl pass = HsAnnotation SourceText -- Note [Pragma source text] in BasicTypes - (AnnProvenance name) (Located (HsExpr name)) + (AnnProvenance (IdP pass)) (Located (HsExpr pass)) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnType' -- 'ApiAnnotation.AnnModule' -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId name) => Data (AnnDecl name) +deriving instance (DataId pass) => Data (AnnDecl pass) -instance (OutputableBndrId name) => Outputable (AnnDecl name) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (AnnDecl pass) where ppr (HsAnnotation _ provenance expr) = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"] @@ -2053,9 +2083,10 @@ instance (OutputableBndrId name) => Outputable (AnnDecl name) where data AnnProvenance name = ValueAnnProvenance (Located name) | TypeAnnProvenance (Located name) | ModuleAnnProvenance - deriving (Data, Functor) +deriving instance Functor AnnProvenance deriving instance Foldable AnnProvenance deriving instance Traversable AnnProvenance +deriving instance (Data pass) => Data (AnnProvenance pass) annProvenanceName_maybe :: AnnProvenance name -> Maybe name annProvenanceName_maybe (ValueAnnProvenance (L _ name)) = Just name @@ -2078,21 +2109,21 @@ pprAnnProvenance (TypeAnnProvenance (L _ name)) -} -- | Located Role Annotation Declaration -type LRoleAnnotDecl name = Located (RoleAnnotDecl name) +type LRoleAnnotDecl pass = Located (RoleAnnotDecl pass) -- See #8185 for more info about why role annotations are -- top-level declarations -- | Role Annotation Declaration -data RoleAnnotDecl name - = RoleAnnotDecl (Located name) -- type constructor +data RoleAnnotDecl pass + = RoleAnnotDecl (Located (IdP pass)) -- type constructor [Located (Maybe Role)] -- optional annotations -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', -- 'ApiAnnotation.AnnRole' -- For details on above see note [Api annotations] in ApiAnnotation - deriving Data +deriving instance (DataId pass) => Data (RoleAnnotDecl pass) -instance OutputableBndr name => Outputable (RoleAnnotDecl name) where +instance OutputableBndr (IdP pass) => Outputable (RoleAnnotDecl pass) where ppr (RoleAnnotDecl ltycon roles) = text "type role" <+> ppr ltycon <+> hsep (map (pp_role . unLoc) roles) @@ -2100,5 +2131,5 @@ instance OutputableBndr name => Outputable (RoleAnnotDecl name) where pp_role Nothing = underscore pp_role (Just r) = ppr r -roleAnnotDeclName :: RoleAnnotDecl name -> name +roleAnnotDeclName :: RoleAnnotDecl pass -> (IdP pass) roleAnnotDeclName (RoleAnnotDecl (L _ name) _) = name diff --git a/compiler/hsSyn/HsDumpAst.hs b/compiler/hsSyn/HsDumpAst.hs index b76b3fbd94..e2244312d0 100644 --- a/compiler/hsSyn/HsDumpAst.hs +++ b/compiler/hsSyn/HsDumpAst.hs @@ -22,7 +22,6 @@ import BasicTypes import FastString import NameSet import Name -import RdrName import DataCon import SrcLoc import HsSyn @@ -47,7 +46,8 @@ showAstData b = showAstData' 0 showAstData' n = generic `ext1Q` list - `extQ` string `extQ` fastString `extQ` srcSpan `extQ` lit + `extQ` string `extQ` fastString `extQ` srcSpan + `extQ` lit `extQ` litr `extQ` litt `extQ` bytestring `extQ` name `extQ` occName `extQ` moduleName `extQ` var `extQ` dataCon @@ -78,13 +78,27 @@ showAstData b = showAstData' 0 ++ "]" -- Eliminate word-size dependence - lit :: HsLit -> String + lit :: HsLit GhcPs -> String lit (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s lit (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s lit (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s lit (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s lit l = generic l + litr :: HsLit GhcRn -> String + litr (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s + litr (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s + litr (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s + litr (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s + litr l = generic l + + litt :: HsLit GhcTc -> String + litt (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s + litt (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s + litt (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s + litt (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s + litt l = generic l + numericLit :: String -> Integer -> SourceText -> String numericLit tag x s = indent n ++ unwords [ "{" ++ tag , generic x @@ -114,15 +128,15 @@ showAstData b = showAstData' 0 dataCon :: DataCon -> String dataCon = ("{DataCon: "++) . (++"}") . showSDoc_ . ppr - bagRdrName:: Bag (Located (HsBind RdrName)) -> String - bagRdrName = ("{Bag(Located (HsBind RdrName)): "++) . (++"}") + bagRdrName:: Bag (Located (HsBind GhcPs)) -> String + bagRdrName = ("{Bag(Located (HsBind GhcPs)): "++) . (++"}") . list . bagToList - bagName :: Bag (Located (HsBind Name)) -> String + bagName :: Bag (Located (HsBind GhcRn)) -> String bagName = ("{Bag(Located (HsBind Name)): "++) . (++"}") . list . bagToList - bagVar :: Bag (Located (HsBind Var)) -> String + bagVar :: Bag (Located (HsBind GhcTc)) -> String bagVar = ("{Bag(Located (HsBind Var)): "++) . (++"}") . list . bagToList diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index c281e6361c..cfc9d177bd 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -21,15 +21,14 @@ module HsExpr where import HsDecls import HsPat import HsLit -import PlaceHolder ( PostTc,PostRn,DataId,DataIdPost, - NameOrRdrName,OutputableBndrId ) +import PlaceHolder ( NameOrRdrName ) +import HsExtension import HsTypes import HsBinds -- others: import TcEvidence import CoreSyn -import Var import DynFlags ( gopt, GeneralFlag(Opt_PrintExplicitCoercions) ) import Name import NameSet @@ -61,7 +60,7 @@ import qualified Language.Haskell.TH as TH (Q) -- * Expressions proper -- | Located Haskell Expression -type LHsExpr id = Located (HsExpr id) +type LHsExpr p = Located (HsExpr p) -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when -- in a list @@ -72,7 +71,7 @@ type LHsExpr id = Located (HsExpr id) -- -- PostTcExpr is an evidence expression attached to the syntax tree by the -- type checker (c.f. postTcType). -type PostTcExpr = HsExpr Id +type PostTcExpr = HsExpr GhcTc -- | Post-Type checking Table -- @@ -81,7 +80,7 @@ type PostTcExpr = HsExpr Id type PostTcTable = [(Name, PostTcExpr)] noPostTcExpr :: PostTcExpr -noPostTcExpr = HsLit (HsString NoSourceText (fsLit "noPostTcExpr")) +noPostTcExpr = HsLit (HsString noSourceText (fsLit "noPostTcExpr")) noPostTcTable :: PostTcTable noPostTcTable = [] @@ -105,33 +104,34 @@ noPostTcTable = [] -- This could be defined using @PostRn@ and @PostTc@ and such, but it's -- harder to get it all to work out that way. ('noSyntaxExpr' is hard to -- write, for example.) -data SyntaxExpr id = SyntaxExpr { syn_expr :: HsExpr id - , syn_arg_wraps :: [HsWrapper] - , syn_res_wrap :: HsWrapper } -deriving instance (DataId id) => Data (SyntaxExpr id) +data SyntaxExpr p = SyntaxExpr { syn_expr :: HsExpr p + , syn_arg_wraps :: [HsWrapper] + , syn_res_wrap :: HsWrapper } +deriving instance (DataId p) => Data (SyntaxExpr p) -- | This is used for rebindable-syntax pieces that are too polymorphic -- for tcSyntaxOp (trS_fmap and the mzip in ParStmt) -noExpr :: HsExpr id -noExpr = HsLit (HsString (SourceText "noExpr") (fsLit "noExpr")) +noExpr :: SourceTextX p => HsExpr p +noExpr = HsLit (HsString (sourceText "noExpr") (fsLit "noExpr")) -noSyntaxExpr :: SyntaxExpr id -- Before renaming, and sometimes after, +noSyntaxExpr :: SourceTextX p => SyntaxExpr p + -- Before renaming, and sometimes after, -- (if the syntax slot makes no sense) -noSyntaxExpr = SyntaxExpr { syn_expr = HsLit (HsString NoSourceText +noSyntaxExpr = SyntaxExpr { syn_expr = HsLit (HsString noSourceText (fsLit "noSyntaxExpr")) , syn_arg_wraps = [] , syn_res_wrap = WpHole } -- | Make a 'SyntaxExpr Name' (the "rn" is because this is used in the -- renamer), missing its HsWrappers. -mkRnSyntaxExpr :: Name -> SyntaxExpr Name +mkRnSyntaxExpr :: Name -> SyntaxExpr GhcRn mkRnSyntaxExpr name = SyntaxExpr { syn_expr = HsVar $ noLoc name , syn_arg_wraps = [] , syn_res_wrap = WpHole } -- don't care about filling in syn_arg_wraps because we're clearly -- not past the typechecker -instance (OutputableBndrId id) => Outputable (SyntaxExpr id) where +instance (SourceTextX p, OutputableBndrId p) => Outputable (SyntaxExpr p) where ppr (SyntaxExpr { syn_expr = expr , syn_arg_wraps = arg_wraps , syn_res_wrap = res_wrap }) @@ -143,7 +143,7 @@ instance (OutputableBndrId id) => Outputable (SyntaxExpr id) where else ppr expr -- | Command Syntax Table (for Arrow syntax) -type CmdSyntaxTable id = [(Name, HsExpr id)] +type CmdSyntaxTable p = [(Name, HsExpr p)] -- See Note [CmdSyntaxTable] {- @@ -273,8 +273,8 @@ information to use is the GlobalRdrEnv itself. -} -- | A Haskell expression. -data HsExpr id - = HsVar (Located id) -- ^ Variable +data HsExpr p + = HsVar (Located (IdP p)) -- ^ Variable -- See Note [Located RdrNames] @@ -289,28 +289,29 @@ data HsExpr id | HsConLikeOut ConLike -- ^ After typechecker only; must be different -- HsVar for pretty printing - | HsRecFld (AmbiguousFieldOcc id) -- ^ Variable pointing to record selector + | HsRecFld (AmbiguousFieldOcc p) -- ^ Variable pointing to record selector -- Not in use after typechecking - | HsOverLabel (Maybe id) FastString + | HsOverLabel (Maybe (IdP p)) FastString -- ^ Overloaded label (Note [Overloaded labels] in GHC.OverloadedLabels) -- @Just id@ means @RebindableSyntax@ is in use, and gives the id of the -- in-scope 'fromLabel'. -- NB: Not in use after typechecking | HsIPVar HsIPName -- ^ Implicit parameter (not in use after typechecking) - | HsOverLit (HsOverLit id) -- ^ Overloaded literals + | HsOverLit (HsOverLit p) -- ^ Overloaded literals - | HsLit HsLit -- ^ Simple (non-overloaded) literals + | HsLit (HsLit p) -- ^ Simple (non-overloaded) literals - | HsLam (MatchGroup id (LHsExpr id)) -- ^ Lambda abstraction. Currently always a single match + | HsLam (MatchGroup p (LHsExpr p)) + -- ^ Lambda abstraction. Currently always a single match -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam', -- 'ApiAnnotation.AnnRarrow', -- For details on above see note [Api annotations] in ApiAnnotation - | HsLamCase (MatchGroup id (LHsExpr id)) -- ^ Lambda-case + | HsLamCase (MatchGroup p (LHsExpr p)) -- ^ Lambda-case -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam', -- 'ApiAnnotation.AnnCase','ApiAnnotation.AnnOpen', @@ -318,16 +319,17 @@ data HsExpr id -- For details on above see note [Api annotations] in ApiAnnotation - | HsApp (LHsExpr id) (LHsExpr id) -- ^ Application + | HsApp (LHsExpr p) (LHsExpr p) -- ^ Application - | HsAppType (LHsExpr id) (LHsWcType id) -- ^ Visible type application + | HsAppType (LHsExpr p) (LHsWcType p) -- ^ Visible type application -- -- Explicit type argument; e.g f @Int x y -- NB: Has wildcards, but no implicit quantification -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt', - | HsAppTypeOut (LHsExpr id) (LHsWcType Name) -- just for pretty-printing + -- TODO:AZ: Sort out Name + | HsAppTypeOut (LHsExpr p) (LHsWcType GhcRn) -- just for pretty-printing -- | Operator applications: @@ -336,10 +338,10 @@ data HsExpr id -- NB We need an expr for the operator in an OpApp/Section since -- the typechecker may need to apply the operator to a few types. - | OpApp (LHsExpr id) -- left operand - (LHsExpr id) -- operator - (PostRn id Fixity) -- Renamer adds fixity; bottom until then - (LHsExpr id) -- right operand + | OpApp (LHsExpr p) -- left operand + (LHsExpr p) -- operator + (PostRn p Fixity) -- Renamer adds fixity; bottom until then + (LHsExpr p) -- right operand -- | Negation operator. Contains the negated expression and the name -- of 'negate' @@ -347,19 +349,19 @@ data HsExpr id -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnMinus' -- For details on above see note [Api annotations] in ApiAnnotation - | NegApp (LHsExpr id) - (SyntaxExpr id) + | NegApp (LHsExpr p) + (SyntaxExpr p) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, -- 'ApiAnnotation.AnnClose' @')'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsPar (LHsExpr id) -- ^ Parenthesised expr; see Note [Parens in HsSyn] + | HsPar (LHsExpr p) -- ^ Parenthesised expr; see Note [Parens in HsSyn] - | SectionL (LHsExpr id) -- operand; see Note [Sections in HsSyn] - (LHsExpr id) -- operator - | SectionR (LHsExpr id) -- operator; see Note [Sections in HsSyn] - (LHsExpr id) -- operand + | SectionL (LHsExpr p) -- operand; see Note [Sections in HsSyn] + (LHsExpr p) -- operator + | SectionR (LHsExpr p) -- operator; see Note [Sections in HsSyn] + (LHsExpr p) -- operand -- | Used for explicit tuples and sections thereof -- @@ -368,7 +370,7 @@ data HsExpr id -- For details on above see note [Api annotations] in ApiAnnotation | ExplicitTuple - [LHsTupArg id] + [LHsTupArg p] Boxity -- | Used for unboxed sum types @@ -381,16 +383,16 @@ data HsExpr id | ExplicitSum ConTag -- Alternative (one-based) Arity -- Sum arity - (LHsExpr id) - (PostTc id [Type]) -- the type arguments + (LHsExpr p) + (PostTc p [Type]) -- the type arguments -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase', -- 'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@, -- 'ApiAnnotation.AnnClose' @'}'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsCase (LHsExpr id) - (MatchGroup id (LHsExpr id)) + | HsCase (LHsExpr p) + (MatchGroup p (LHsExpr p)) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf', -- 'ApiAnnotation.AnnSemi', @@ -398,12 +400,12 @@ data HsExpr id -- 'ApiAnnotation.AnnElse', -- For details on above see note [Api annotations] in ApiAnnotation - | HsIf (Maybe (SyntaxExpr id)) -- cond function + | HsIf (Maybe (SyntaxExpr p)) -- cond function -- Nothing => use the built-in 'if' -- See Note [Rebindable if] - (LHsExpr id) -- predicate - (LHsExpr id) -- then part - (LHsExpr id) -- else part + (LHsExpr p) -- predicate + (LHsExpr p) -- then part + (LHsExpr p) -- else part -- | Multi-way if -- @@ -411,7 +413,7 @@ data HsExpr id -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', -- For details on above see note [Api annotations] in ApiAnnotation - | HsMultiIf (PostTc id Type) [LGRHS id (LHsExpr id)] + | HsMultiIf (PostTc p Type) [LGRHS p (LHsExpr p)] -- | let(rec) -- @@ -420,8 +422,8 @@ data HsExpr id -- 'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn' -- For details on above see note [Api annotations] in ApiAnnotation - | HsLet (LHsLocalBinds id) - (LHsExpr id) + | HsLet (LHsLocalBinds p) + (LHsExpr p) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo', -- 'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnSemi', @@ -432,8 +434,8 @@ data HsExpr id | HsDo (HsStmtContext Name) -- The parameterisation is unimportant -- because in this context we never use -- the PatGuard or ParStmt variant - (Located [ExprLStmt id]) -- "do":one or more stmts - (PostTc id Type) -- Type of the whole expression + (Located [ExprLStmt p]) -- "do":one or more stmts + (PostTc p Type) -- Type of the whole expression -- | Syntactic list: [a,b,c,...] -- @@ -442,9 +444,10 @@ data HsExpr id -- For details on above see note [Api annotations] in ApiAnnotation | ExplicitList - (PostTc id Type) -- Gives type of components of list - (Maybe (SyntaxExpr id)) -- For OverloadedLists, the fromListN witness - [LHsExpr id] + (PostTc p Type) -- Gives type of components of list + (Maybe (SyntaxExpr p)) + -- For OverloadedLists, the fromListN witness + [LHsExpr p] -- | Syntactic parallel array: [:e1, ..., en:] -- @@ -455,8 +458,8 @@ data HsExpr id -- For details on above see note [Api annotations] in ApiAnnotation | ExplicitPArr - (PostTc id Type) -- type of elements of the parallel array - [LHsExpr id] + (PostTc p Type) -- type of elements of the parallel array + [LHsExpr p] -- | Record construction -- @@ -465,11 +468,12 @@ data HsExpr id -- For details on above see note [Api annotations] in ApiAnnotation | RecordCon - { rcon_con_name :: Located id -- The constructor name; + { rcon_con_name :: Located (IdP p) -- The constructor name; -- not used after type checking - , rcon_con_like :: PostTc id ConLike -- The data constructor or pattern synonym + , rcon_con_like :: PostTc p ConLike + -- The data constructor or pattern synonym , rcon_con_expr :: PostTcExpr -- Instantiated constructor function - , rcon_flds :: HsRecordBinds id } -- The fields + , rcon_flds :: HsRecordBinds p } -- The fields -- | Record update -- @@ -478,18 +482,18 @@ data HsExpr id -- For details on above see note [Api annotations] in ApiAnnotation | RecordUpd - { rupd_expr :: LHsExpr id - , rupd_flds :: [LHsRecUpdField id] - , rupd_cons :: PostTc id [ConLike] + { rupd_expr :: LHsExpr p + , rupd_flds :: [LHsRecUpdField p] + , rupd_cons :: PostTc p [ConLike] -- Filled in by the type checker to the -- _non-empty_ list of DataCons that have -- all the upd'd fields - , rupd_in_tys :: PostTc id [Type] -- Argument types of *input* record type - , rupd_out_tys :: PostTc id [Type] -- and *output* record type - -- The original type can be reconstructed - -- with conLikeResTy - , rupd_wrap :: PostTc id HsWrapper -- See note [Record Update HsWrapper] + , rupd_in_tys :: PostTc p [Type] -- Argument types of *input* record type + , rupd_out_tys :: PostTc p [Type] -- and *output* record type + -- The original type can be reconstructed + -- with conLikeResTy + , rupd_wrap :: PostTc p HsWrapper -- See note [Record Update HsWrapper] } -- For a type family, the arg types are of the *instance* tycon, -- not the family tycon @@ -500,12 +504,12 @@ data HsExpr id -- For details on above see note [Api annotations] in ApiAnnotation | ExprWithTySig - (LHsExpr id) - (LHsSigWcType id) + (LHsExpr p) + (LHsSigWcType p) | ExprWithTySigOut -- Post typechecking - (LHsExpr id) - (LHsSigWcType Name) -- Retain the signature, + (LHsExpr p) + (LHsSigWcType GhcRn) -- Retain the signature, -- as HsSigType Name, for -- round-tripping purposes @@ -518,8 +522,9 @@ data HsExpr id -- For details on above see note [Api annotations] in ApiAnnotation | ArithSeq PostTcExpr - (Maybe (SyntaxExpr id)) -- For OverloadedLists, the fromList witness - (ArithSeqInfo id) + (Maybe (SyntaxExpr p)) + -- For OverloadedLists, the fromList witness + (ArithSeqInfo p) -- | Arithmetic sequence for parallel array -- @@ -533,7 +538,7 @@ data HsExpr id -- For details on above see note [Api annotations] in ApiAnnotation | PArrSeq PostTcExpr - (ArithSeqInfo id) + (ArithSeqInfo p) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# SCC'@, -- 'ApiAnnotation.AnnVal' or 'ApiAnnotation.AnnValStr', @@ -542,7 +547,7 @@ data HsExpr id -- For details on above see note [Api annotations] in ApiAnnotation | HsSCC SourceText -- Note [Pragma source text] in BasicTypes StringLiteral -- "set cost centre" SCC pragma - (LHsExpr id) -- expr whose cost is to be measured + (LHsExpr p) -- expr whose cost is to be measured -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CORE'@, -- 'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose' @'\#-}'@ @@ -550,7 +555,7 @@ data HsExpr id -- For details on above see note [Api annotations] in ApiAnnotation | HsCoreAnn SourceText -- Note [Pragma source text] in BasicTypes StringLiteral -- hdaume: core annotation - (LHsExpr id) + (LHsExpr p) ----------------------------------------------------------- -- MetaHaskell Extensions @@ -560,16 +565,16 @@ data HsExpr id -- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnCloseQ' -- For details on above see note [Api annotations] in ApiAnnotation - | HsBracket (HsBracket id) + | HsBracket (HsBracket p) -- See Note [Pending Splices] | HsRnBracketOut - (HsBracket Name) -- Output of the renamer is the *original* renamed + (HsBracket GhcRn) -- Output of the renamer is the *original* renamed -- expression, plus [PendingRnSplice] -- _renamed_ splices to be type checked | HsTcBracketOut - (HsBracket Name) -- Output of the type checker is the *original* + (HsBracket GhcRn) -- Output of the type checker is the *original* -- renamed expression, plus [PendingTcSplice] -- _typechecked_ splices to be -- pasted back in by the desugarer @@ -578,7 +583,7 @@ data HsExpr id -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation - | HsSpliceE (HsSplice id) + | HsSpliceE (HsSplice p) ----------------------------------------------------------- -- Arrow notation extension @@ -589,17 +594,17 @@ data HsExpr id -- 'ApiAnnotation.AnnRarrow' -- For details on above see note [Api annotations] in ApiAnnotation - | HsProc (LPat id) -- arrow abstraction, proc - (LHsCmdTop id) -- body of the abstraction - -- always has an empty stack + | HsProc (LPat p) -- arrow abstraction, proc + (LHsCmdTop p) -- body of the abstraction + -- always has an empty stack --------------------------------------- -- static pointers extension -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnStatic', -- For details on above see note [Api annotations] in ApiAnnotation - | HsStatic (PostRn id NameSet) -- Free variables of the body - (LHsExpr id) -- Body + | HsStatic (PostRn p NameSet) -- Free variables of the body + (LHsExpr p) -- Body --------------------------------------- -- The following are commands, not expressions proper @@ -612,37 +617,37 @@ data HsExpr id -- For details on above see note [Api annotations] in ApiAnnotation | HsArrApp -- Arrow tail, or arrow application (f -< arg) - (LHsExpr id) -- arrow expression, f - (LHsExpr id) -- input expression, arg - (PostTc id Type) -- type of the arrow expressions f, - -- of the form a t t', where arg :: t - HsArrAppType -- higher-order (-<<) or first-order (-<) - Bool -- True => right-to-left (f -< arg) - -- False => left-to-right (arg >- f) + (LHsExpr p) -- arrow expression, f + (LHsExpr p) -- input expression, arg + (PostTc p Type) -- type of the arrow expressions f, + -- of the form a t t', where arg :: t + HsArrAppType -- higher-order (-<<) or first-order (-<) + Bool -- True => right-to-left (f -< arg) + -- False => left-to-right (arg >- f) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpenB' @'(|'@, -- 'ApiAnnotation.AnnCloseB' @'|)'@ -- For details on above see note [Api annotations] in ApiAnnotation | HsArrForm -- Command formation, (| e cmd1 .. cmdn |) - (LHsExpr id) -- the operator + (LHsExpr p) -- the operator -- after type-checking, a type abstraction to be -- applied to the type of the local environment tuple (Maybe Fixity) -- fixity (filled in by the renamer), for forms that -- were converted from OpApp's by the renamer - [LHsCmdTop id] -- argument commands + [LHsCmdTop p] -- argument commands --------------------------------------- -- Haskell program coverage (Hpc) Support | HsTick - (Tickish id) - (LHsExpr id) -- sub-expression + (Tickish (IdP p)) + (LHsExpr p) -- sub-expression | HsBinTick Int -- module-local tick number for True Int -- module-local tick number for False - (LHsExpr id) -- sub-expression + (LHsExpr p) -- sub-expression -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnOpen' @'{-\# GENERATED'@, @@ -661,7 +666,7 @@ data HsExpr id ((SourceText,SourceText),(SourceText,SourceText)) -- Source text for the four integers used in the span. -- See note [Pragma source text] in BasicTypes - (LHsExpr id) + (LHsExpr p) --------------------------------------- -- These constructors only appear temporarily in the parser. @@ -672,19 +677,19 @@ data HsExpr id -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt' -- For details on above see note [Api annotations] in ApiAnnotation - | EAsPat (Located id) -- as pattern - (LHsExpr id) + | EAsPat (Located (IdP p)) -- as pattern + (LHsExpr p) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow' -- For details on above see note [Api annotations] in ApiAnnotation - | EViewPat (LHsExpr id) -- view pattern - (LHsExpr id) + | EViewPat (LHsExpr p) -- view pattern + (LHsExpr p) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde' -- For details on above see note [Api annotations] in ApiAnnotation - | ELazyPat (LHsExpr id) -- ~ pattern + | ELazyPat (LHsExpr p) -- ~ pattern --------------------------------------- @@ -694,9 +699,9 @@ data HsExpr id -- is maintained by HsUtils.mkHsWrap. | HsWrap HsWrapper -- TRANSLATION - (HsExpr id) + (HsExpr p) -deriving instance (DataId id) => Data (HsExpr id) +deriving instance (DataId p) => Data (HsExpr p) -- | Located Haskell Tuple Argument -- @@ -791,16 +796,16 @@ RenamedSource that the API Annotations cannot be used directly with RenamedSource, so this allows a simple mapping to be used based on the location. -} -instance (OutputableBndrId id) => Outputable (HsExpr id) where +instance (SourceTextX p, OutputableBndrId p) => Outputable (HsExpr p) where ppr expr = pprExpr expr ----------------------- -- pprExpr, pprLExpr, pprBinds call pprDeeper; -- the underscore versions do not -pprLExpr :: (OutputableBndrId id) => LHsExpr id -> SDoc +pprLExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc pprLExpr (L _ e) = pprExpr e -pprExpr :: (OutputableBndrId id) => HsExpr id -> SDoc +pprExpr :: (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc pprExpr e | isAtomicHsExpr e || isQuietHsExpr e = ppr_expr e | otherwise = pprDeeper (ppr_expr e) @@ -816,15 +821,16 @@ isQuietHsExpr (HsAppTypeOut _ _) = True isQuietHsExpr (OpApp _ _ _ _) = True isQuietHsExpr _ = False -pprBinds :: (OutputableBndrId idL, OutputableBndrId idR) +pprBinds :: (SourceTextX idL, SourceTextX idR, + OutputableBndrId idL, OutputableBndrId idR) => HsLocalBindsLR idL idR -> SDoc pprBinds b = pprDeeper (ppr b) ----------------------- -ppr_lexpr :: (OutputableBndrId id) => LHsExpr id -> SDoc +ppr_lexpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc ppr_lexpr e = ppr_expr (unLoc e) -ppr_expr :: forall id. (OutputableBndrId id) => HsExpr id -> SDoc +ppr_expr :: forall p. (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc ppr_expr (HsVar (L _ v)) = pprPrefixOcc v ppr_expr (HsUnboundVar uv)= pprPrefixOcc (unboundVarOcc uv) ppr_expr (HsConLikeOut c) = pprPrefixOcc c @@ -1042,10 +1048,11 @@ ppr_expr (HsRecFld f) = ppr f -- We must tiresomely make the "id" parameter to the LHsWcType existential -- because it's different in the HsAppType case and the HsAppTypeOut case -- | Located Haskell Wildcard Type Expression -data LHsWcTypeX = forall id. (OutputableBndrId id) => LHsWcTypeX (LHsWcType id) +data LHsWcTypeX = forall p. (SourceTextX p, OutputableBndrId p) + => LHsWcTypeX (LHsWcType p) -ppr_apps :: (OutputableBndrId id) => HsExpr id - -> [Either (LHsExpr id) LHsWcTypeX] +ppr_apps :: (SourceTextX p, OutputableBndrId p) => HsExpr p + -> [Either (LHsExpr p) LHsWcTypeX] -> SDoc ppr_apps (HsApp (L _ fun) arg) args = ppr_apps fun (Left arg : args) @@ -1075,16 +1082,16 @@ fixities should do the job, except in debug mode (-dppr-debug) so we can see the structure of the parse tree. -} -pprDebugParendExpr :: (OutputableBndrId id) => LHsExpr id -> SDoc +pprDebugParendExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc pprDebugParendExpr expr = getPprStyle (\sty -> if debugStyle sty then pprParendLExpr expr else pprLExpr expr) -pprParendLExpr :: (OutputableBndrId id) => LHsExpr id -> SDoc +pprParendLExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc pprParendLExpr (L _ e) = pprParendExpr e -pprParendExpr :: (OutputableBndrId id) => HsExpr id -> SDoc +pprParendExpr :: (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc pprParendExpr expr | hsExprNeedsParens expr = parens (pprExpr expr) | otherwise = pprExpr expr @@ -1245,26 +1252,26 @@ argument of a command-forming operator. -} -- | Located Haskell Top-level Command -type LHsCmdTop id = Located (HsCmdTop id) +type LHsCmdTop p = Located (HsCmdTop p) -- | Haskell Top-level Command -data HsCmdTop id - = HsCmdTop (LHsCmd id) - (PostTc id Type) -- Nested tuple of inputs on the command's stack - (PostTc id Type) -- return type of the command - (CmdSyntaxTable id) -- See Note [CmdSyntaxTable] -deriving instance (DataId id) => Data (HsCmdTop id) - -instance (OutputableBndrId id) => Outputable (HsCmd id) where +data HsCmdTop p + = HsCmdTop (LHsCmd p) + (PostTc p Type) -- Nested tuple of inputs on the command's stack + (PostTc p Type) -- return type of the command + (CmdSyntaxTable p) -- See Note [CmdSyntaxTable] +deriving instance (DataId p) => Data (HsCmdTop p) + +instance (SourceTextX p, OutputableBndrId p) => Outputable (HsCmd p) where ppr cmd = pprCmd cmd ----------------------- -- pprCmd and pprLCmd call pprDeeper; -- the underscore versions do not -pprLCmd :: (OutputableBndrId id) => LHsCmd id -> SDoc +pprLCmd :: (SourceTextX p, OutputableBndrId p) => LHsCmd p -> SDoc pprLCmd (L _ c) = pprCmd c -pprCmd :: (OutputableBndrId id) => HsCmd id -> SDoc +pprCmd :: (SourceTextX p, OutputableBndrId p) => HsCmd p -> SDoc pprCmd c | isQuietHsCmd c = ppr_cmd c | otherwise = pprDeeper (ppr_cmd c) @@ -1278,10 +1285,10 @@ isQuietHsCmd (HsCmdApp _ _) = True isQuietHsCmd _ = False ----------------------- -ppr_lcmd :: (OutputableBndrId id) => LHsCmd id -> SDoc +ppr_lcmd :: (SourceTextX p, OutputableBndrId p) => LHsCmd p -> SDoc ppr_lcmd c = ppr_cmd (unLoc c) -ppr_cmd :: forall id. (OutputableBndrId id) => HsCmd id -> SDoc +ppr_cmd :: forall p. (SourceTextX p, OutputableBndrId p) => HsCmd p -> SDoc ppr_cmd (HsCmdPar c) = parens (ppr_lcmd c) ppr_cmd (HsCmdApp c e) @@ -1342,11 +1349,11 @@ ppr_cmd (HsCmdArrForm op _ _ args) = hang (text "(|" <> ppr_lexpr op) 4 (sep (map (pprCmdArg.unLoc) args) <> text "|)") -pprCmdArg :: (OutputableBndrId id) => HsCmdTop id -> SDoc +pprCmdArg :: (SourceTextX p, OutputableBndrId p) => HsCmdTop p -> SDoc pprCmdArg (HsCmdTop cmd _ _ _) = ppr_lcmd cmd -instance (OutputableBndrId id) => Outputable (HsCmdTop id) where +instance (SourceTextX p, OutputableBndrId p) => Outputable (HsCmdTop p) where ppr = pprCmdArg {- @@ -1358,7 +1365,7 @@ instance (OutputableBndrId id) => Outputable (HsCmdTop id) where -} -- | Haskell Record Bindings -type HsRecordBinds id = HsRecFields id (LHsExpr id) +type HsRecordBinds p = HsRecFields p (LHsExpr p) {- ************************************************************************ @@ -1382,15 +1389,15 @@ a function defined by pattern matching must have the same number of patterns in each equation. -} -data MatchGroup id body - = MG { mg_alts :: Located [LMatch id body] -- The alternatives - , mg_arg_tys :: [PostTc id Type] -- Types of the arguments, t1..tn - , mg_res_ty :: PostTc id Type -- Type of the result, tr +data MatchGroup p body + = MG { mg_alts :: Located [LMatch p body] -- The alternatives + , mg_arg_tys :: [PostTc p Type] -- Types of the arguments, t1..tn + , mg_res_ty :: PostTc p Type -- Type of the result, tr , mg_origin :: Origin } -- The type is the type of the entire group -- t1 -> ... -> tn -> tr -- where there are n patterns -deriving instance (Data body,DataId id) => Data (MatchGroup id body) +deriving instance (Data body,DataId p) => Data (MatchGroup p body) -- | Located Match type LMatch id body = Located (Match id body) @@ -1398,20 +1405,20 @@ type LMatch id body = Located (Match id body) -- list -- For details on above see note [Api annotations] in ApiAnnotation -data Match id body +data Match p body = Match { - m_ctxt :: HsMatchContext (NameOrRdrName id), + m_ctxt :: HsMatchContext (NameOrRdrName (IdP p)), -- See note [m_ctxt in Match] - m_pats :: [LPat id], -- The patterns - m_type :: (Maybe (LHsType id)), + m_pats :: [LPat p], -- The patterns + m_type :: (Maybe (LHsType p)), -- A type signature for the result of the match -- Nothing after typechecking -- NB: No longer supported - m_grhss :: (GRHSs id body) + m_grhss :: (GRHSs p body) } -deriving instance (Data body,DataId id) => Data (Match id body) +deriving instance (Data body,DataId p) => Data (Match p body) -instance (OutputableBndrId idR, Outputable body) +instance (SourceTextX idR, OutputableBndrId idR, Outputable body) => Outputable (Match idR body) where ppr = pprMatch @@ -1489,12 +1496,12 @@ hsLMatchPats (L _ (Match _ pats _ _)) = pats -- 'ApiAnnotation.AnnRarrow','ApiAnnotation.AnnSemi' -- For details on above see note [Api annotations] in ApiAnnotation -data GRHSs id body +data GRHSs p body = GRHSs { - grhssGRHSs :: [LGRHS id body], -- ^ Guarded RHSs - grhssLocalBinds :: LHsLocalBinds id -- ^ The where clause + grhssGRHSs :: [LGRHS p body], -- ^ Guarded RHSs + grhssLocalBinds :: LHsLocalBinds p -- ^ The where clause } -deriving instance (Data body,DataId id) => Data (GRHSs id body) +deriving instance (Data body,DataId p) => Data (GRHSs p body) -- | Located Guarded Right-Hand Side type LGRHS id body = Located (GRHS id body) @@ -1506,26 +1513,28 @@ deriving instance (Data body,DataId id) => Data (GRHS id body) -- We know the list must have at least one @Match@ in it. -pprMatches :: (OutputableBndrId idR, Outputable body) +pprMatches :: (SourceTextX idR, OutputableBndrId idR, Outputable body) => MatchGroup idR body -> SDoc pprMatches MG { mg_alts = matches } = vcat (map pprMatch (map unLoc (unLoc matches))) -- Don't print the type; it's only a place-holder before typechecking -- Exported to HsBinds, which can't see the defn of HsMatchContext -pprFunBind :: (OutputableBndrId idR, Outputable body) +pprFunBind :: (SourceTextX idR, OutputableBndrId idR, Outputable body) => MatchGroup idR body -> SDoc pprFunBind matches = pprMatches matches -- Exported to HsBinds, which can't see the defn of HsMatchContext -pprPatBind :: forall bndr id body. (OutputableBndrId bndr, - OutputableBndrId id, - Outputable body) - => LPat bndr -> GRHSs id body -> SDoc +pprPatBind :: forall bndr p body. (SourceTextX p, SourceTextX bndr, + OutputableBndrId bndr, + OutputableBndrId p, + Outputable body) + => LPat bndr -> GRHSs p body -> SDoc pprPatBind pat (grhss) - = sep [ppr pat, nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext id) grhss)] + = sep [ppr pat, nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (IdP p)) grhss)] -pprMatch :: (OutputableBndrId idR, Outputable body) => Match idR body -> SDoc +pprMatch :: (SourceTextX idR, OutputableBndrId idR, Outputable body) + => Match idR body -> SDoc pprMatch match = sep [ sep (herald : map (nest 2 . pprParendLPat) other_pats) , nest 2 ppr_maybe_ty @@ -1560,7 +1569,7 @@ pprMatch match Nothing -> empty -pprGRHSs :: (OutputableBndrId idR, Outputable body) +pprGRHSs :: (SourceTextX idR, OutputableBndrId idR, Outputable body) => HsMatchContext idL -> GRHSs idR body -> SDoc pprGRHSs ctxt (GRHSs grhss (L _ binds)) = vcat (map (pprGRHS ctxt . unLoc) grhss) @@ -1569,7 +1578,7 @@ pprGRHSs ctxt (GRHSs grhss (L _ binds)) $$ ppUnless (eqEmptyLocalBinds binds) (text "where" $$ nest 4 (pprBinds binds)) -pprGRHS :: (OutputableBndrId idR, Outputable body) +pprGRHS :: (SourceTextX idR, OutputableBndrId idR, Outputable body) => HsMatchContext idL -> GRHS idR body -> SDoc pprGRHS ctxt (GRHS [] body) = pp_rhs ctxt body @@ -1695,7 +1704,7 @@ data StmtLR idL idR body -- body should always be (LHs**** idR) trS_stmts :: [ExprLStmt idL], -- Stmts to the *left* of the 'group' -- which generates the tuples to be grouped - trS_bndrs :: [(idR, idR)], -- See Note [TransStmt binder map] + trS_bndrs :: [(IdP idR, IdP idR)], -- See Note [TransStmt binder map] trS_using :: LHsExpr idR, trS_by :: Maybe (LHsExpr idR), -- "by e" (optional) @@ -1719,12 +1728,14 @@ data StmtLR idL idR body -- body should always be (LHs**** idR) { recS_stmts :: [LStmtLR idL idR body] -- The next two fields are only valid after renaming - , recS_later_ids :: [idR] -- The ids are a subset of the variables bound by the - -- stmts that are used in stmts that follow the RecStmt - - , recS_rec_ids :: [idR] -- Ditto, but these variables are the "recursive" ones, - -- that are used before they are bound in the stmts of - -- the RecStmt. + , recS_later_ids :: [IdP idR] + -- The ids are a subset of the variables bound by the + -- stmts that are used in stmts that follow the RecStmt + + , recS_rec_ids :: [IdP idR] + -- Ditto, but these variables are the "recursive" ones, + -- that are used before they are bound in the stmts of + -- the RecStmt. -- An Id can be in both groups -- Both sets of Ids are (now) treated monomorphically -- See Note [How RecStmt works] for why they are separate @@ -1763,7 +1774,7 @@ data TransForm -- The 'f' below is the 'using' function, 'e' is the by functio data ParStmtBlock idL idR = ParStmtBlock [ExprLStmt idL] - [idR] -- The variables to be returned + [IdP idR] -- The variables to be returned (SyntaxExpr idR) -- The return operator deriving instance (DataId idL, DataId idR) => Data (ParStmtBlock idL idR) @@ -1915,14 +1926,17 @@ In any other context than 'MonadComp', the fields for most of these 'SyntaxExpr's stay bottom. -} -instance (OutputableBndrId idL) => Outputable (ParStmtBlock idL idR) where +instance (SourceTextX idL, OutputableBndrId idL) + => Outputable (ParStmtBlock idL idR) where ppr (ParStmtBlock stmts _ _) = interpp'SP stmts -instance (OutputableBndrId idL, OutputableBndrId idR, Outputable body) +instance (SourceTextX idL, SourceTextX idR, + OutputableBndrId idL, OutputableBndrId idR, Outputable body) => Outputable (StmtLR idL idR body) where ppr stmt = pprStmt stmt -pprStmt :: forall idL idR body . (OutputableBndrId idL, OutputableBndrId idR, +pprStmt :: forall idL idR body . (SourceTextX idL, SourceTextX idR, + OutputableBndrId idL, OutputableBndrId idR, Outputable body) => (StmtLR idL idR body) -> SDoc pprStmt (LastStmt expr ret_stripped _) @@ -1986,8 +2000,8 @@ pprStmt (ApplicativeStmt args mb_join _) (stmts ++ [noLoc (LastStmt (noLoc return) False noSyntaxExpr)])) (error "pprStmt")) -pprTransformStmt :: (OutputableBndrId id) - => [id] -> LHsExpr id -> Maybe (LHsExpr id) -> SDoc +pprTransformStmt :: (SourceTextX p, OutputableBndrId p) + => [IdP p] -> LHsExpr p -> Maybe (LHsExpr p) -> SDoc pprTransformStmt bndrs using by = sep [ text "then" <+> ifPprDebug (braces (ppr bndrs)) , nest 2 (ppr using) @@ -2003,8 +2017,8 @@ pprBy :: Outputable body => Maybe body -> SDoc pprBy Nothing = empty pprBy (Just e) = text "by" <+> ppr e -pprDo :: (OutputableBndrId id, Outputable body) - => HsStmtContext any -> [LStmt id body] -> SDoc +pprDo :: (SourceTextX p, OutputableBndrId p, Outputable body) + => HsStmtContext any -> [LStmt p body] -> SDoc pprDo DoExpr stmts = text "do" <+> ppr_do_stmts stmts pprDo GhciStmtCtxt stmts = text "do" <+> ppr_do_stmts stmts pprDo ArrowExpr stmts = text "do" <+> ppr_do_stmts stmts @@ -2014,12 +2028,14 @@ pprDo PArrComp stmts = paBrackets $ pprComp stmts pprDo MonadComp stmts = brackets $ pprComp stmts pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt -ppr_do_stmts :: (OutputableBndrId idL, OutputableBndrId idR, Outputable body) +ppr_do_stmts :: (SourceTextX idL, SourceTextX idR, + OutputableBndrId idL, OutputableBndrId idR, Outputable body) => [LStmtLR idL idR body] -> SDoc -- Print a bunch of do stmts ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts) -pprComp :: (OutputableBndrId id, Outputable body) => [LStmt id body] -> SDoc +pprComp :: (SourceTextX p, OutputableBndrId p, Outputable body) + => [LStmt p body] -> SDoc pprComp quals -- Prints: body | qual1, ..., qualn | Just (initStmts, L _ (LastStmt body _ _)) <- snocView quals = if null initStmts @@ -2033,7 +2049,8 @@ pprComp quals -- Prints: body | qual1, ..., qualn | otherwise = pprPanic "pprComp" (pprQuals quals) -pprQuals :: (OutputableBndrId id, Outputable body) => [LStmt id body] -> SDoc +pprQuals :: (SourceTextX p, OutputableBndrId p, Outputable body) + => [LStmt p body] -> SDoc -- Show list comprehension qualifiers separated by commas pprQuals quals = interpp'SP quals @@ -2049,17 +2066,17 @@ pprQuals quals = interpp'SP quals data HsSplice id = HsTypedSplice -- $$z or $$(f 4) SpliceDecoration -- Whether $$( ) variant found, for pretty printing - id -- A unique name to identify this splice point + (IdP id) -- A unique name to identify this splice point (LHsExpr id) -- See Note [Pending Splices] | HsUntypedSplice -- $z or $(f 4) SpliceDecoration -- Whether $( ) variant found, for pretty printing - id -- A unique name to identify this splice point + (IdP id) -- A unique name to identify this splice point (LHsExpr id) -- See Note [Pending Splices] | HsQuasiQuote -- See Note [Quasi-quote overview] in TcSplice - id -- Splice point - id -- Quoter + (IdP id) -- Splice point + (IdP id) -- Quoter SrcSpan -- The span of the enclosed string FastString -- The enclosed string @@ -2120,7 +2137,8 @@ type SplicePointName = Name -- | Pending Renamer Splice data PendingRnSplice - = PendingRnSplice UntypedSpliceFlavour SplicePointName (LHsExpr Name) + -- AZ:TODO: The hard-coded GhcRn feels wrong. How to force the PostRn? + = PendingRnSplice UntypedSpliceFlavour SplicePointName (LHsExpr GhcRn) deriving Data data UntypedSpliceFlavour @@ -2132,7 +2150,8 @@ data UntypedSpliceFlavour -- | Pending Type-checker Splice data PendingTcSplice - = PendingTcSplice SplicePointName (LHsExpr Id) + -- AZ:TODO: The hard-coded GhcTc feels wrong. How to force the PostTc? + = PendingTcSplice SplicePointName (LHsExpr GhcTc) deriving Data @@ -2200,29 +2219,30 @@ splices. In contrast, when pretty printing the output of the type checker, we sense, although I hate to add another constructor to HsExpr. -} -instance (OutputableBndrId id) => Outputable (HsSplicedThing id) where +instance (SourceTextX p, OutputableBndrId p) + => Outputable (HsSplicedThing p) where ppr (HsSplicedExpr e) = ppr_expr e ppr (HsSplicedTy t) = ppr t ppr (HsSplicedPat p) = ppr p -instance (OutputableBndrId id) => Outputable (HsSplice id) where +instance (SourceTextX p, OutputableBndrId p) => Outputable (HsSplice p) where ppr s = pprSplice s -pprPendingSplice :: (OutputableBndrId id) - => SplicePointName -> LHsExpr id -> SDoc +pprPendingSplice :: (SourceTextX p, OutputableBndrId p) + => SplicePointName -> LHsExpr p -> SDoc pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr e) -pprSpliceDecl :: (OutputableBndrId id) - => HsSplice id -> SpliceExplicitFlag -> SDoc +pprSpliceDecl :: (SourceTextX p, OutputableBndrId p) + => HsSplice p -> SpliceExplicitFlag -> SDoc pprSpliceDecl e@HsQuasiQuote{} _ = pprSplice e pprSpliceDecl e ExplicitSplice = text "$(" <> ppr_splice_decl e <> text ")" pprSpliceDecl e ImplicitSplice = ppr_splice_decl e -ppr_splice_decl :: (OutputableBndrId id) => HsSplice id -> SDoc +ppr_splice_decl :: (SourceTextX p, OutputableBndrId p) => HsSplice p -> SDoc ppr_splice_decl (HsUntypedSplice _ n e) = ppr_splice empty n e empty ppr_splice_decl e = pprSplice e -pprSplice :: (OutputableBndrId id) => HsSplice id -> SDoc +pprSplice :: (SourceTextX p, OutputableBndrId p) => HsSplice p -> SDoc pprSplice (HsTypedSplice HasParens n e) = ppr_splice (text "$$(") n e (text ")") pprSplice (HsTypedSplice HasDollar n e) @@ -2238,36 +2258,36 @@ pprSplice (HsUntypedSplice NoParens n e) pprSplice (HsQuasiQuote n q _ s) = ppr_quasi n q s pprSplice (HsSpliced _ thing) = ppr thing -ppr_quasi :: OutputableBndr id => id -> id -> FastString -> SDoc +ppr_quasi :: OutputableBndr p => p -> p -> FastString -> SDoc ppr_quasi n quoter quote = ifPprDebug (brackets (ppr n)) <> char '[' <> ppr quoter <> vbar <> ppr quote <> text "|]" -ppr_splice :: (OutputableBndrId id) - => SDoc -> id -> LHsExpr id -> SDoc -> SDoc +ppr_splice :: (SourceTextX p, OutputableBndrId p) + => SDoc -> (IdP p) -> LHsExpr p -> SDoc -> SDoc ppr_splice herald n e trail = herald <> ifPprDebug (brackets (ppr n)) <> ppr e <> trail -- | Haskell Bracket -data HsBracket id = ExpBr (LHsExpr id) -- [| expr |] - | PatBr (LPat id) -- [p| pat |] - | DecBrL [LHsDecl id] -- [d| decls |]; result of parser - | DecBrG (HsGroup id) -- [d| decls |]; result of renamer - | TypBr (LHsType id) -- [t| type |] - | VarBr Bool id -- True: 'x, False: ''T - -- (The Bool flag is used only in pprHsBracket) - | TExpBr (LHsExpr id) -- [|| expr ||] -deriving instance (DataId id) => Data (HsBracket id) +data HsBracket p = ExpBr (LHsExpr p) -- [| expr |] + | PatBr (LPat p) -- [p| pat |] + | DecBrL [LHsDecl p] -- [d| decls |]; result of parser + | DecBrG (HsGroup p) -- [d| decls |]; result of renamer + | TypBr (LHsType p) -- [t| type |] + | VarBr Bool (IdP p) -- True: 'x, False: ''T + -- (The Bool flag is used only in pprHsBracket) + | TExpBr (LHsExpr p) -- [|| expr ||] +deriving instance (DataId p) => Data (HsBracket p) isTypedBracket :: HsBracket id -> Bool isTypedBracket (TExpBr {}) = True isTypedBracket _ = False -instance (OutputableBndrId id) => Outputable (HsBracket id) where +instance (SourceTextX p, OutputableBndrId p) => Outputable (HsBracket p) where ppr = pprHsBracket -pprHsBracket :: (OutputableBndrId id) => HsBracket id -> SDoc +pprHsBracket :: (SourceTextX p, OutputableBndrId p) => HsBracket p -> SDoc pprHsBracket (ExpBr e) = thBrackets empty (ppr e) pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p) pprHsBracket (DecBrG gp) = thBrackets (char 'd') (ppr gp) @@ -2312,8 +2332,8 @@ data ArithSeqInfo id (LHsExpr id) deriving instance (DataId id) => Data (ArithSeqInfo id) -instance (OutputableBndrId id) - => Outputable (ArithSeqInfo id) where +instance (SourceTextX p, OutputableBndrId p) + => Outputable (ArithSeqInfo p) where ppr (From e1) = hcat [ppr e1, pp_dotdot] ppr (FromThen e1 e2) = hcat [ppr e1, comma, space, ppr e2, pp_dotdot] ppr (FromTo e1 e3) = hcat [ppr e1, pp_dotdot, ppr e3] @@ -2334,7 +2354,7 @@ pp_dotdot = text " .. " -- | Haskell Match Context -- -- Context of a Match -data HsMatchContext id +data HsMatchContext id -- Not an extensible tag = FunRhs (Located id) LexicalFixity -- ^Function binding for f, fixity | LambdaExpr -- ^Patterns of a lambda | CaseAlt -- ^Patterns and guards on a case alternative @@ -2353,7 +2373,7 @@ data HsMatchContext id | ThPatQuote -- ^A Template Haskell pattern quotation [p| (a,b) |] | PatSyn -- ^A pattern synonym declaration deriving Functor -deriving instance (DataIdPost id) => Data (HsMatchContext id) +deriving instance (Data id) => Data (HsMatchContext id) instance OutputableBndr id => Outputable (HsMatchContext id) where ppr (FunRhs (L _ id) fix) = text "FunRhs" <+> ppr id <+> ppr fix @@ -2374,7 +2394,8 @@ isPatSynCtxt ctxt = PatSyn -> True _ -> False --- | Haskell Statement Context +-- | Haskell Statement Context. It expects to be parameterised with one of +-- 'RdrName', 'Name' or 'Id' data HsStmtContext id = ListComp | MonadComp @@ -2389,7 +2410,7 @@ data HsStmtContext id | ParStmtCtxt (HsStmtContext id) -- ^A branch of a parallel stmt | TransStmtCtxt (HsStmtContext id) -- ^A branch of a transform stmt deriving Functor -deriving instance (DataIdPost id) => Data (HsStmtContext id) +deriving instance (Data id) => Data (HsStmtContext id) isListCompExpr :: HsStmtContext id -> Bool -- Uses syntax [ e | quals ] @@ -2494,8 +2515,8 @@ pprStmtContext (TransStmtCtxt c) = then sep [text "transformed branch of", pprAStmtContext c] else pprStmtContext c -instance (Outputable id, Outputable (NameOrRdrName id)) - => Outputable (HsStmtContext id) where +instance (Outputable p, Outputable (NameOrRdrName p)) + => Outputable (HsStmtContext p) where ppr = pprStmtContext -- Used to generate the string for a *runtime* error message @@ -2522,17 +2543,19 @@ matchContextErrString (StmtCtxt ListComp) = text "list comprehension" matchContextErrString (StmtCtxt MonadComp) = text "monad comprehension" matchContextErrString (StmtCtxt PArrComp) = text "array comprehension" -pprMatchInCtxt :: (OutputableBndrId idR, - Outputable (NameOrRdrName (NameOrRdrName idR)), +pprMatchInCtxt :: (SourceTextX idR, OutputableBndrId idR, + -- TODO:AZ these constraints do not make sense + Outputable (NameOrRdrName (NameOrRdrName (IdP idR))), Outputable body) => Match idR body -> SDoc pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match) <> colon) 4 (pprMatch match) -pprStmtInCtxt :: (OutputableBndrId idL, OutputableBndrId idR, +pprStmtInCtxt :: (SourceTextX idL, SourceTextX idR, + OutputableBndrId idL, OutputableBndrId idR, Outputable body) - => HsStmtContext idL -> StmtLR idL idR body -> SDoc + => HsStmtContext (IdP idL) -> StmtLR idL idR body -> SDoc pprStmtInCtxt ctxt (LastStmt e _ _) | isListCompExpr ctxt -- For [ e | .. ], do not mutter about "stmts" = hang (text "In the expression:") 2 (ppr e) diff --git a/compiler/hsSyn/HsExpr.hs-boot b/compiler/hsSyn/HsExpr.hs-boot index dad2a78185..bac8a5a183 100644 --- a/compiler/hsSyn/HsExpr.hs-boot +++ b/compiler/hsSyn/HsExpr.hs-boot @@ -4,6 +4,7 @@ -- in module PlaceHolder {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ExistentialQuantification #-} module HsExpr where @@ -11,7 +12,7 @@ import SrcLoc ( Located ) import Outputable ( SDoc, Outputable ) import {-# SOURCE #-} HsPat ( LPat ) import BasicTypes ( SpliceExplicitFlag(..)) -import PlaceHolder ( DataId, OutputableBndrId ) +import HsExtension ( OutputableBndrId, DataId, SourceTextX ) import Data.Data hiding ( Fixity ) type role HsExpr nominal @@ -27,31 +28,32 @@ data MatchGroup (a :: *) (body :: *) data GRHSs (a :: *) (body :: *) data SyntaxExpr (i :: *) -instance (DataId id) => Data (HsSplice id) -instance (DataId id) => Data (HsExpr id) -instance (DataId id) => Data (HsCmd id) -instance (Data body,DataId id) => Data (MatchGroup id body) -instance (Data body,DataId id) => Data (GRHSs id body) -instance (DataId id) => Data (SyntaxExpr id) +instance (DataId p) => Data (HsSplice p) +instance (DataId p) => Data (HsExpr p) +instance (DataId p) => Data (HsCmd p) +instance (Data body,DataId p) => Data (MatchGroup p body) +instance (Data body,DataId p) => Data (GRHSs p body) +instance (DataId p) => Data (SyntaxExpr p) -instance (OutputableBndrId id) => Outputable (HsExpr id) -instance (OutputableBndrId id) => Outputable (HsCmd id) +instance (SourceTextX p, OutputableBndrId p) => Outputable (HsExpr p) +instance (SourceTextX p, OutputableBndrId p) => Outputable (HsCmd p) type LHsExpr a = Located (HsExpr a) -pprLExpr :: (OutputableBndrId id) => LHsExpr id -> SDoc +pprLExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc -pprExpr :: (OutputableBndrId id) => HsExpr id -> SDoc +pprExpr :: (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc -pprSplice :: (OutputableBndrId id) => HsSplice id -> SDoc +pprSplice :: (SourceTextX p, OutputableBndrId p) => HsSplice p -> SDoc -pprSpliceDecl :: (OutputableBndrId id) - => HsSplice id -> SpliceExplicitFlag -> SDoc +pprSpliceDecl :: (SourceTextX p, OutputableBndrId p) + => HsSplice p -> SpliceExplicitFlag -> SDoc -pprPatBind :: (OutputableBndrId bndr, - OutputableBndrId id, - Outputable body) - => LPat bndr -> GRHSs id body -> SDoc +pprPatBind :: forall bndr p body. (SourceTextX p, SourceTextX bndr, + OutputableBndrId bndr, + OutputableBndrId p, + Outputable body) + => LPat bndr -> GRHSs p body -> SDoc -pprFunBind :: (OutputableBndrId idR, Outputable body) +pprFunBind :: (SourceTextX idR, OutputableBndrId idR, Outputable body) => MatchGroup idR body -> SDoc diff --git a/compiler/hsSyn/HsExtension.hs b/compiler/hsSyn/HsExtension.hs new file mode 100644 index 0000000000..880f7096c6 --- /dev/null +++ b/compiler/hsSyn/HsExtension.hs @@ -0,0 +1,289 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE StandaloneDeriving #-} + +module HsExtension where + +-- This module captures the type families to precisely identify the extension +-- points for HsSyn + +import GHC.Exts (Constraint) +import Data.Data hiding ( Fixity ) +import PlaceHolder +import BasicTypes +import ConLike +import NameSet +import Name +import RdrName +import Var +import Type ( Type ) +import Outputable +import SrcLoc (Located) +import Coercion +import TcEvidence + +{- +Note [Trees that grow] +~~~~~~~~~~~~~~~~~~~~~~ + +See https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow + +The hsSyn AST is reused across multiple compiler passes. We also have the +Template Haskell AST, and the haskell-src-exts one (outside of GHC) + +Supporting multiple passes means the AST has various warts on it to cope with +the specifics for the phases, such as the 'ValBindsOut', 'ConPatOut', +'SigPatOut' etc. + +The growable AST will allow each of these variants to be captured explicitly, +such that they only exist in the given compiler pass AST, as selected by the +type parameter to the AST. + +In addition it will allow tool writers to define their own extensions to capture +additional information for the tool, in a natural way. + +A further goal is to provide a means to harmonise the Template Haskell and +haskell-src-exts ASTs as well. + +-} + +-- | Used as a data type index for the hsSyn AST +data GhcPass (c :: Pass) +deriving instance Eq (GhcPass c) +deriving instance Typeable c => Data (GhcPass c) + +data Pass = Parsed | Renamed | Typechecked + deriving (Data) + +-- Type synonyms as a shorthand for tagging +type GhcPs = GhcPass 'Parsed -- Old 'RdrName' type param +type GhcRn = GhcPass 'Renamed -- Old 'Name' type param +type GhcTc = GhcPass 'Typechecked -- Old 'Id' type para, +type GhcTcId = GhcTc -- Old 'TcId' type param + + +-- | Types that are not defined until after type checking +type family PostTc x ty -- Note [Pass sensitive types] in PlaceHolder +type instance PostTc GhcPs ty = PlaceHolder +type instance PostTc GhcRn ty = PlaceHolder +type instance PostTc GhcTc ty = ty + +-- | Types that are not defined until after renaming +type family PostRn x ty -- Note [Pass sensitive types] in PlaceHolder +type instance PostRn GhcPs ty = PlaceHolder +type instance PostRn GhcRn ty = ty +type instance PostRn GhcTc ty = ty + +-- | Maps the "normal" id type for a given pass +type family IdP p +type instance IdP GhcPs = RdrName +type instance IdP GhcRn = Name +type instance IdP GhcTc = Id + + +-- We define a type family for each extension point. This is based on prepending +-- 'X' to the constructor name, for ease of reference. +type family XHsChar x +type family XHsCharPrim x +type family XHsString x +type family XHsStringPrim x +type family XHsInt x +type family XHsIntPrim x +type family XHsWordPrim x +type family XHsInt64Prim x +type family XHsWord64Prim x +type family XHsInteger x +type family XHsRat x +type family XHsFloatPrim x +type family XHsDoublePrim x + +-- | Helper to apply a constraint to all extension points. It has one +-- entry per extension point type family. +type ForallX (c :: * -> Constraint) (x :: *) = + ( c (XHsChar x) + , c (XHsCharPrim x) + , c (XHsString x) + , c (XHsStringPrim x) + , c (XHsInt x) + , c (XHsIntPrim x) + , c (XHsWordPrim x) + , c (XHsInt64Prim x) + , c (XHsWord64Prim x) + , c (XHsInteger x) + , c (XHsRat x) + , c (XHsFloatPrim x) + , c (XHsDoublePrim x) + ) + + +-- Provide the specific extension types for the parser phase. +type instance XHsChar GhcPs = SourceText +type instance XHsCharPrim GhcPs = SourceText +type instance XHsString GhcPs = SourceText +type instance XHsStringPrim GhcPs = SourceText +type instance XHsInt GhcPs = () +type instance XHsIntPrim GhcPs = SourceText +type instance XHsWordPrim GhcPs = SourceText +type instance XHsInt64Prim GhcPs = SourceText +type instance XHsWord64Prim GhcPs = SourceText +type instance XHsInteger GhcPs = SourceText +type instance XHsRat GhcPs = () +type instance XHsFloatPrim GhcPs = () +type instance XHsDoublePrim GhcPs = () + +-- Provide the specific extension types for the renamer phase. +type instance XHsChar GhcRn = SourceText +type instance XHsCharPrim GhcRn = SourceText +type instance XHsString GhcRn = SourceText +type instance XHsStringPrim GhcRn = SourceText +type instance XHsInt GhcRn = () +type instance XHsIntPrim GhcRn = SourceText +type instance XHsWordPrim GhcRn = SourceText +type instance XHsInt64Prim GhcRn = SourceText +type instance XHsWord64Prim GhcRn = SourceText +type instance XHsInteger GhcRn = SourceText +type instance XHsRat GhcRn = () +type instance XHsFloatPrim GhcRn = () +type instance XHsDoublePrim GhcRn = () + +-- Provide the specific extension types for the typechecker phase. +type instance XHsChar GhcTc = SourceText +type instance XHsCharPrim GhcTc = SourceText +type instance XHsString GhcTc = SourceText +type instance XHsStringPrim GhcTc = SourceText +type instance XHsInt GhcTc = () +type instance XHsIntPrim GhcTc = SourceText +type instance XHsWordPrim GhcTc = SourceText +type instance XHsInt64Prim GhcTc = SourceText +type instance XHsWord64Prim GhcTc = SourceText +type instance XHsInteger GhcTc = SourceText +type instance XHsRat GhcTc = () +type instance XHsFloatPrim GhcTc = () +type instance XHsDoublePrim GhcTc = () + + +-- --------------------------------------------------------------------- + +-- | The 'SourceText' fields have been moved into the extension fields, thus +-- placing a requirement in the extension field to contain a 'SourceText' so +-- that the pretty printing and round tripping of source can continue to +-- operate. +-- +-- The 'HasSourceText' class captures this requirement for the relevant fields. +class HasSourceText a where + -- Provide setters to mimic existing constructors + noSourceText :: a + sourceText :: String -> a + + setSourceText :: SourceText -> a + getSourceText :: a -> SourceText + +-- | Provide a summary constraint that lists all the extension points requiring +-- the 'HasSourceText' class, so that it can be changed in one place as the +-- named extensions change throughout the AST. +type SourceTextX x = + ( HasSourceText (XHsChar x) + , HasSourceText (XHsCharPrim x) + , HasSourceText (XHsString x) + , HasSourceText (XHsStringPrim x) + , HasSourceText (XHsIntPrim x) + , HasSourceText (XHsWordPrim x) + , HasSourceText (XHsInt64Prim x) + , HasSourceText (XHsWord64Prim x) + , HasSourceText (XHsInteger x) + ) + + +-- | 'SourceText' trivially implements 'HasSourceText' +instance HasSourceText SourceText where + noSourceText = NoSourceText + sourceText s = SourceText s + + setSourceText s = s + getSourceText a = a + + +-- ---------------------------------------------------------------------- +-- | Defaults for each annotation, used to simplify creation in arbitrary +-- contexts +class HasDefault a where + def :: a + +instance HasDefault () where + def = () + +instance HasDefault SourceText where + def = NoSourceText + +-- | Provide a single constraint that captures the requirement for a default +-- across all the extension points. +type HasDefaultX x = ForallX HasDefault x + +-- ---------------------------------------------------------------------- +-- | Conversion of annotations from one type index to another. This is required +-- where the AST is converted from one pass to another, and the extension values +-- need to be brought along if possible. So for example a 'SourceText' is +-- converted via 'id', but needs a type signature to keep the type checker +-- happy. +class Convertable a b | a -> b where + convert :: a -> b + +instance Convertable a a where + convert = id + +-- | A constraint capturing all the extension points that can be converted via +-- @instance Convertable a a@ +type ConvertIdX a b = + (XHsDoublePrim a ~ XHsDoublePrim b, + XHsFloatPrim a ~ XHsFloatPrim b, + XHsRat a ~ XHsRat b, + XHsInteger a ~ XHsInteger b, + XHsWord64Prim a ~ XHsWord64Prim b, + XHsInt64Prim a ~ XHsInt64Prim b, + XHsWordPrim a ~ XHsWordPrim b, + XHsIntPrim a ~ XHsIntPrim b, + XHsInt a ~ XHsInt b, + XHsStringPrim a ~ XHsStringPrim b, + XHsString a ~ XHsString b, + XHsCharPrim a ~ XHsCharPrim b, + XHsChar a ~ XHsChar b) + + +-- ---------------------------------------------------------------------- + +-- +type DataId p = + ( Data p + , ForallX Data p + , Data (NameOrRdrName (IdP p)) + + , Data (IdP p) + , Data (PostRn p (IdP p)) + , Data (PostRn p (Located Name)) + , Data (PostRn p Bool) + , Data (PostRn p Fixity) + , Data (PostRn p NameSet) + , Data (PostRn p [Name]) + + , Data (PostTc p (IdP p)) + , Data (PostTc p Coercion) + , Data (PostTc p ConLike) + , Data (PostTc p HsWrapper) + , Data (PostTc p Type) + , Data (PostTc p [ConLike]) + , Data (PostTc p [Type]) + ) + + +-- |Constraint type to bundle up the requirement for 'OutputableBndr' on both +-- the @id@ and the 'NameOrRdrName' type for it +type OutputableBndrId id = + ( OutputableBndr (NameOrRdrName (IdP id)) + , OutputableBndr (IdP id) + ) diff --git a/compiler/hsSyn/HsImpExp.hs b/compiler/hsSyn/HsImpExp.hs index 3424a0816c..57f74e3666 100644 --- a/compiler/hsSyn/HsImpExp.hs +++ b/compiler/hsSyn/HsImpExp.hs @@ -7,6 +7,10 @@ HsImpExp: Abstract syntax: imports, exports, interfaces -} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module PlaceHolder module HsImpExp where @@ -19,6 +23,7 @@ import FieldLabel ( FieldLbl(..) ) import Outputable import FastString import SrcLoc +import HsExtension import Data.Data @@ -73,7 +78,7 @@ data ImportDecl name -- to location in ideclHiding -- For details on above see note [Api annotations] in ApiAnnotation - deriving Data +deriving instance (DataId name) => Data (ImportDecl name) simpleImportDecl :: ModuleName -> ImportDecl name simpleImportDecl mn = ImportDecl { @@ -88,7 +93,7 @@ simpleImportDecl mn = ImportDecl { ideclHiding = Nothing } -instance (OutputableBndr name, HasOccName name) => Outputable (ImportDecl name) where +instance (OutputableBndrId pass) => Outputable (ImportDecl pass) where ppr (ImportDecl { ideclSourceSrc = mSrcText, ideclName = mod' , ideclPkgQual = pkg , ideclSource = from, ideclSafe = safe @@ -160,10 +165,10 @@ type LIE name = Located (IE name) -- | Imported or exported entity. data IE name - = IEVar (LIEWrappedName name) + = IEVar (LIEWrappedName (IdP name)) -- ^ Imported or Exported Variable - | IEThingAbs (LIEWrappedName name) + | IEThingAbs (LIEWrappedName (IdP name)) -- ^ Imported or exported Thing with Absent list -- -- The thing is a Class/Type (can't tell) @@ -172,7 +177,7 @@ data IE name -- For details on above see note [Api annotations] in ApiAnnotation -- See Note [Located RdrNames] in HsExpr - | IEThingAll (LIEWrappedName name) + | IEThingAll (LIEWrappedName (IdP name)) -- ^ Imported or exported Thing with All imported or exported -- -- The thing is a Class/Type and the All refers to methods/constructors @@ -184,10 +189,10 @@ data IE name -- For details on above see note [Api annotations] in ApiAnnotation -- See Note [Located RdrNames] in HsExpr - | IEThingWith (LIEWrappedName name) + | IEThingWith (LIEWrappedName (IdP name)) IEWildcard - [LIEWrappedName name] - [Located (FieldLbl name)] + [LIEWrappedName (IdP name)] + [Located (FieldLbl (IdP name))] -- ^ Imported or exported Thing With given imported or exported -- -- The thing is a Class/Type and the imported or exported things are @@ -209,7 +214,9 @@ data IE name | IEGroup Int HsDocString -- ^ Doc section heading | IEDoc HsDocString -- ^ Some documentation | IEDocNamed String -- ^ Reference to named doc - deriving (Eq, Data) + -- deriving (Eq, Data) +deriving instance (Eq name, Eq (IdP name)) => Eq (IE name) +deriving instance (DataId name) => Data (IE name) -- | Imported or Exported Wildcard data IEWildcard = NoIEWildcard | IEWildcard Int deriving (Eq, Data) @@ -231,14 +238,14 @@ gives rise to See Note [Representing fields in AvailInfo] in Avail for more details. -} -ieName :: IE name -> name +ieName :: IE pass -> IdP pass ieName (IEVar (L _ n)) = ieWrappedName n ieName (IEThingAbs (L _ n)) = ieWrappedName n ieName (IEThingWith (L _ n) _ _ _) = ieWrappedName n ieName (IEThingAll (L _ n)) = ieWrappedName n ieName _ = panic "ieName failed pattern match!" -ieNames :: IE a -> [a] +ieNames :: IE pass -> [IdP pass] ieNames (IEVar (L _ n) ) = [ieWrappedName n] ieNames (IEThingAbs (L _ n) ) = [ieWrappedName n] ieNames (IEThingAll (L _ n) ) = [ieWrappedName n] @@ -265,7 +272,7 @@ replaceWrappedName (IEType (L l _)) n = IEType (L l n) replaceLWrappedName :: LIEWrappedName name1 -> name2 -> LIEWrappedName name2 replaceLWrappedName (L l n) n' = L l (replaceWrappedName n n') -instance (HasOccName name, OutputableBndr name) => Outputable (IE name) where +instance (OutputableBndrId pass) => Outputable (IE pass) where ppr (IEVar var) = ppr (unLoc var) ppr (IEThingAbs thing) = ppr (unLoc thing) ppr (IEThingAll thing) = hcat [ppr (unLoc thing), text "(..)"] @@ -290,14 +297,12 @@ instance (HasOccName name, OutputableBndr name) => Outputable (IE name) where instance (HasOccName name) => HasOccName (IEWrappedName name) where occName w = occName (ieWrappedName w) -instance (OutputableBndr name, HasOccName name) - => OutputableBndr (IEWrappedName name) where +instance (OutputableBndr name) => OutputableBndr (IEWrappedName name) where pprBndr bs w = pprBndr bs (ieWrappedName w) pprPrefixOcc w = pprPrefixOcc (ieWrappedName w) pprInfixOcc w = pprInfixOcc (ieWrappedName w) -instance (HasOccName name, OutputableBndr name) - => Outputable (IEWrappedName name) where +instance (OutputableBndr name) => Outputable (IEWrappedName name) where ppr (IEName n) = pprPrefixOcc (unLoc n) ppr (IEPattern n) = text "pattern" <+> pprPrefixOcc (unLoc n) ppr (IEType n) = text "type" <+> pprPrefixOcc (unLoc n) diff --git a/compiler/hsSyn/HsLit.hs b/compiler/hsSyn/HsLit.hs index 0226591729..46e5dd5aa3 100644 --- a/compiler/hsSyn/HsLit.hs +++ b/compiler/hsSyn/HsLit.hs @@ -13,6 +13,7 @@ {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module PlaceHolder {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} module HsLit where @@ -24,7 +25,7 @@ import BasicTypes ( IntegralLit(..),FractionalLit(..),negateIntegralLit, import Type ( Type ) import Outputable import FastString -import PlaceHolder ( PostTc,PostRn,DataId,OutputableBndrId ) +import HsExtension import Data.ByteString (ByteString) import Data.Data hiding ( Fixity ) @@ -39,65 +40,68 @@ import Data.Data hiding ( Fixity ) -- Note [Literal source text] in BasicTypes for SourceText fields in -- the following +-- Note [Trees that grow] in HsExtension for the Xxxxx fields in the following -- | Haskell Literal -data HsLit - = HsChar SourceText Char +data HsLit x + = HsChar (XHsChar x) {- SourceText -} Char -- ^ Character - | HsCharPrim SourceText Char + | HsCharPrim (XHsCharPrim x) {- SourceText -} Char -- ^ Unboxed character - | HsString SourceText FastString + | HsString (XHsString x) {- SourceText -} FastString -- ^ String - | HsStringPrim SourceText ByteString + | HsStringPrim (XHsStringPrim x) {- SourceText -} ByteString -- ^ Packed bytes - | HsInt IntegralLit + | HsInt (XHsInt x) IntegralLit -- ^ Genuinely an Int; arises from -- @TcGenDeriv@, and from TRANSLATION - | HsIntPrim SourceText Integer + | HsIntPrim (XHsIntPrim x) {- SourceText -} Integer -- ^ literal @Int#@ - | HsWordPrim SourceText Integer + | HsWordPrim (XHsWordPrim x) {- SourceText -} Integer -- ^ literal @Word#@ - | HsInt64Prim SourceText Integer + | HsInt64Prim (XHsInt64Prim x) {- SourceText -} Integer -- ^ literal @Int64#@ - | HsWord64Prim SourceText Integer + | HsWord64Prim (XHsWord64Prim x) {- SourceText -} Integer -- ^ literal @Word64#@ - | HsInteger SourceText Integer Type + | HsInteger (XHsInteger x) {- SourceText -} Integer Type -- ^ Genuinely an integer; arises only -- from TRANSLATION (overloaded -- literals are done with HsOverLit) - | HsRat FractionalLit Type + | HsRat (XHsRat x) FractionalLit Type -- ^ Genuinely a rational; arises only from -- TRANSLATION (overloaded literals are -- done with HsOverLit) - | HsFloatPrim FractionalLit + | HsFloatPrim (XHsFloatPrim x) FractionalLit -- ^ Unboxed Float - | HsDoublePrim FractionalLit + | HsDoublePrim (XHsDoublePrim x) FractionalLit -- ^ Unboxed Double - deriving Data -instance Eq HsLit where +deriving instance (DataId x) => Data (HsLit x) + + +instance Eq (HsLit x) where (HsChar _ x1) == (HsChar _ x2) = x1==x2 (HsCharPrim _ x1) == (HsCharPrim _ x2) = x1==x2 (HsString _ x1) == (HsString _ x2) = x1==x2 (HsStringPrim _ x1) == (HsStringPrim _ x2) = x1==x2 - (HsInt x1) == (HsInt x2) = x1==x2 + (HsInt _ x1) == (HsInt _ x2) = x1==x2 (HsIntPrim _ x1) == (HsIntPrim _ x2) = x1==x2 (HsWordPrim _ x1) == (HsWordPrim _ x2) = x1==x2 (HsInt64Prim _ x1) == (HsInt64Prim _ x2) = x1==x2 (HsWord64Prim _ x1) == (HsWord64Prim _ x2) = x1==x2 (HsInteger _ x1 _) == (HsInteger _ x2 _) = x1==x2 - (HsRat x1 _) == (HsRat x2 _) = x1==x2 - (HsFloatPrim x1) == (HsFloatPrim x2) = x1==x2 - (HsDoublePrim x1) == (HsDoublePrim x2) = x1==x2 + (HsRat _ x1 _) == (HsRat _ x2 _) = x1==x2 + (HsFloatPrim _ x1) == (HsFloatPrim _ x2) = x1==x2 + (HsDoublePrim _ x1) == (HsDoublePrim _ x2) = x1==x2 _ == _ = False -- | Haskell Overloaded Literal -data HsOverLit id +data HsOverLit p = OverLit { ol_val :: OverLitVal, - ol_rebindable :: PostRn id Bool, -- Note [ol_rebindable] - ol_witness :: HsExpr id, -- Note [Overloaded literal witnesses] - ol_type :: PostTc id Type } -deriving instance (DataId id) => Data (HsOverLit id) + ol_rebindable :: PostRn p Bool, -- Note [ol_rebindable] + ol_witness :: HsExpr p, -- Note [Overloaded literal witnesses] + ol_type :: PostTc p Type } +deriving instance (DataId p, DataId p) => Data (HsOverLit p) -- Note [Literal source text] in BasicTypes for SourceText fields in -- the following @@ -113,9 +117,26 @@ negateOverLitVal (HsIntegral i) = HsIntegral (negateIntegralLit i) negateOverLitVal (HsFractional f) = HsFractional (negateFractionalLit f) negateOverLitVal _ = panic "negateOverLitVal: argument is not a number" -overLitType :: HsOverLit a -> PostTc a Type +overLitType :: HsOverLit p -> PostTc p Type overLitType = ol_type +-- | Convert a literal from one index type to another, updating the annotations +-- according to the relevant 'Convertable' instance +convertLit :: (ConvertIdX a b) => HsLit a -> HsLit b +convertLit (HsChar a x) = (HsChar (convert a) x) +convertLit (HsCharPrim a x) = (HsCharPrim (convert a) x) +convertLit (HsString a x) = (HsString (convert a) x) +convertLit (HsStringPrim a x) = (HsStringPrim (convert a) x) +convertLit (HsInt a x) = (HsInt (convert a) x) +convertLit (HsIntPrim a x) = (HsIntPrim (convert a) x) +convertLit (HsWordPrim a x) = (HsWordPrim (convert a) x) +convertLit (HsInt64Prim a x) = (HsInt64Prim (convert a) x) +convertLit (HsWord64Prim a x) = (HsWord64Prim (convert a) x) +convertLit (HsInteger a x b) = (HsInteger (convert a) x b) +convertLit (HsRat a x b) = (HsRat (convert a) x b) +convertLit (HsFloatPrim a x) = (HsFloatPrim (convert a) x) +convertLit (HsDoublePrim a x) = (HsDoublePrim (convert a) x) + {- Note [ol_rebindable] ~~~~~~~~~~~~~~~~~~~~ @@ -148,7 +169,7 @@ found to have. -- Comparison operations are needed when grouping literals -- for compiling pattern-matching (module MatchLit) -instance Eq (HsOverLit id) where +instance Eq (HsOverLit p) where (OverLit {ol_val = val1}) == (OverLit {ol_val=val2}) = val1 == val2 instance Eq OverLitVal where @@ -157,7 +178,7 @@ instance Eq OverLitVal where (HsIsString _ s1) == (HsIsString _ s2) = s1 == s2 _ == _ = False -instance Ord (HsOverLit id) where +instance Ord (HsOverLit p) where compare (OverLit {ol_val=val1}) (OverLit {ol_val=val2}) = val1 `compare` val2 instance Ord OverLitVal where @@ -171,27 +192,37 @@ instance Ord OverLitVal where compare (HsIsString _ _) (HsIntegral _) = GT compare (HsIsString _ _) (HsFractional _) = GT -instance Outputable HsLit where - ppr (HsChar st c) = pprWithSourceText st (pprHsChar c) - ppr (HsCharPrim st c) = pp_st_suffix st primCharSuffix (pprPrimChar c) - ppr (HsString st s) = pprWithSourceText st (pprHsString s) - ppr (HsStringPrim st s) = pprWithSourceText st (pprHsBytes s) - ppr (HsInt i) = pprWithSourceText (il_text i) (integer (il_value i)) - ppr (HsInteger st i _) = pprWithSourceText st (integer i) - ppr (HsRat f _) = ppr f - ppr (HsFloatPrim f) = ppr f <> primFloatSuffix - ppr (HsDoublePrim d) = ppr d <> primDoubleSuffix - ppr (HsIntPrim st i) = pprWithSourceText st (pprPrimInt i) - ppr (HsWordPrim st w) = pprWithSourceText st (pprPrimWord w) - ppr (HsInt64Prim st i) = pp_st_suffix st primInt64Suffix (pprPrimInt64 i) - ppr (HsWord64Prim st w) = pp_st_suffix st primWord64Suffix (pprPrimWord64 w) +-- Instance specific to GhcPs, need the SourceText +instance (SourceTextX x) => Outputable (HsLit x) where + ppr (HsChar st c) = pprWithSourceText (getSourceText st) (pprHsChar c) + ppr (HsCharPrim st c) + = pp_st_suffix (getSourceText st) primCharSuffix (pprPrimChar c) + ppr (HsString st s) + = pprWithSourceText (getSourceText st) (pprHsString s) + ppr (HsStringPrim st s) + = pprWithSourceText (getSourceText st) (pprHsBytes s) + ppr (HsInt _ i) + = pprWithSourceText (il_text i) (integer (il_value i)) + ppr (HsInteger st i _) = pprWithSourceText (getSourceText st) (integer i) + ppr (HsRat _ f _) = ppr f + ppr (HsFloatPrim _ f) = ppr f <> primFloatSuffix + ppr (HsDoublePrim _ d) = ppr d <> primDoubleSuffix + ppr (HsIntPrim st i) + = pprWithSourceText (getSourceText st) (pprPrimInt i) + ppr (HsWordPrim st w) + = pprWithSourceText (getSourceText st) (pprPrimWord w) + ppr (HsInt64Prim st i) + = pp_st_suffix (getSourceText st) primInt64Suffix (pprPrimInt64 i) + ppr (HsWord64Prim st w) + = pp_st_suffix (getSourceText st) primWord64Suffix (pprPrimWord64 w) pp_st_suffix :: SourceText -> SDoc -> SDoc -> SDoc pp_st_suffix NoSourceText _ doc = doc pp_st_suffix (SourceText st) suffix _ = text st <> suffix -- in debug mode, print the expression that it's resolved to, too -instance (OutputableBndrId id) => Outputable (HsOverLit id) where +instance (SourceTextX p, OutputableBndrId p) + => Outputable (HsOverLit p) where ppr (OverLit {ol_val=val, ol_witness=witness}) = ppr val <+> (ifPprDebug (parens (pprExpr witness))) @@ -206,17 +237,18 @@ instance Outputable OverLitVal where -- mainly for too reasons: -- * We do not want to expose their internal representation -- * The warnings become too messy -pmPprHsLit :: HsLit -> SDoc +pmPprHsLit :: (SourceTextX x) => HsLit x -> SDoc pmPprHsLit (HsChar _ c) = pprHsChar c pmPprHsLit (HsCharPrim _ c) = pprHsChar c -pmPprHsLit (HsString st s) = pprWithSourceText st (pprHsString s) +pmPprHsLit (HsString st s) = pprWithSourceText (getSourceText st) + (pprHsString s) pmPprHsLit (HsStringPrim _ s) = pprHsBytes s -pmPprHsLit (HsInt i) = integer (il_value i) +pmPprHsLit (HsInt _ i) = integer (il_value i) pmPprHsLit (HsIntPrim _ i) = integer i pmPprHsLit (HsWordPrim _ w) = integer w pmPprHsLit (HsInt64Prim _ i) = integer i pmPprHsLit (HsWord64Prim _ w) = integer w pmPprHsLit (HsInteger _ i _) = integer i -pmPprHsLit (HsRat f _) = ppr f -pmPprHsLit (HsFloatPrim f) = ppr f -pmPprHsLit (HsDoublePrim d) = ppr d +pmPprHsLit (HsRat _ f _) = ppr f +pmPprHsLit (HsFloatPrim _ f) = ppr f +pmPprHsLit (HsDoublePrim _ d) = ppr d diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs index 174e83702e..93ad9ec383 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -43,7 +43,7 @@ import {-# SOURCE #-} HsExpr (SyntaxExpr, LHsExpr, HsSplice, pprLExpr -- friends: import HsBinds import HsLit -import PlaceHolder +import HsExtension import HsTypes import TcEvidence import BasicTypes @@ -64,50 +64,51 @@ import Maybes -- libraries: import Data.Data hiding (TyCon,Fixity) -type InPat id = LPat id -- No 'Out' constructors -type OutPat id = LPat id -- No 'In' constructors +type InPat p = LPat p -- No 'Out' constructors +type OutPat p = LPat p -- No 'In' constructors -type LPat id = Located (Pat id) +type LPat p = Located (Pat p) -- | Pattern -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang' -- For details on above see note [Api annotations] in ApiAnnotation -data Pat id +data Pat p = ------------ Simple patterns --------------- - WildPat (PostTc id Type) -- ^ Wildcard Pattern + WildPat (PostTc p Type) -- ^ Wildcard Pattern -- The sole reason for a type on a WildPat is to -- support hsPatType :: Pat Id -> Type - | VarPat (Located id) -- ^ Variable Pattern + -- AZ:TODO above comment needs to be updated + | VarPat (Located (IdP p)) -- ^ Variable Pattern -- See Note [Located RdrNames] in HsExpr - | LazyPat (LPat id) -- ^ Lazy Pattern + | LazyPat (LPat p) -- ^ Lazy Pattern -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde' -- For details on above see note [Api annotations] in ApiAnnotation - | AsPat (Located id) (LPat id) -- ^ As pattern + | AsPat (Located (IdP p)) (LPat p) -- ^ As pattern -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt' -- For details on above see note [Api annotations] in ApiAnnotation - | ParPat (LPat id) -- ^ Parenthesised pattern + | ParPat (LPat p) -- ^ Parenthesised pattern -- See Note [Parens in HsSyn] in HsExpr -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, -- 'ApiAnnotation.AnnClose' @')'@ -- For details on above see note [Api annotations] in ApiAnnotation - | BangPat (LPat id) -- ^ Bang pattern + | BangPat (LPat p) -- ^ Bang pattern -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang' -- For details on above see note [Api annotations] in ApiAnnotation ------------ Lists, tuples, arrays --------------- - | ListPat [LPat id] - (PostTc id Type) -- The type of the elements - (Maybe (PostTc id Type, SyntaxExpr id)) -- For rebindable syntax + | ListPat [LPat p] + (PostTc p Type) -- The type of the elements + (Maybe (PostTc p Type, SyntaxExpr p)) -- For rebindable syntax -- For OverloadedLists a Just (ty,fn) gives -- overall type of the pattern, and the toList -- function to convert the scrutinee to a list value @@ -118,11 +119,11 @@ data Pat id -- For details on above see note [Api annotations] in ApiAnnotation - | TuplePat [LPat id] -- Tuple sub-patterns + | TuplePat [LPat p] -- Tuple sub-patterns Boxity -- UnitPat is TuplePat [] - [PostTc id Type] -- [] before typechecker, filled in afterwards + [PostTc p Type] -- [] before typechecker, filled in afterwards -- with the types of the tuple components - -- You might think that the PostTc id Type was redundant, because we can + -- You might think that the PostTc p Type was redundant, because we can -- get the pattern type by getting the types of the sub-patterns. -- But it's essential -- data T a where @@ -143,10 +144,10 @@ data Pat id -- 'ApiAnnotation.AnnOpen' @'('@ or @'(#'@, -- 'ApiAnnotation.AnnClose' @')'@ or @'#)'@ - | SumPat (LPat id) -- Sum sub-pattern + | SumPat (LPat p) -- Sum sub-pattern ConTag -- Alternative (one-based) Arity -- Arity - (PostTc id [Type]) -- PlaceHolder before typechecker, filled in + (PostTc p [Type]) -- PlaceHolder before typechecker, filled in -- afterwards with the types of the -- alternative -- ^ Anonymous sum pattern @@ -156,15 +157,15 @@ data Pat id -- 'ApiAnnotation.AnnClose' @'#)'@ -- For details on above see note [Api annotations] in ApiAnnotation - | PArrPat [LPat id] -- Syntactic parallel array - (PostTc id Type) -- The type of the elements + | PArrPat [LPat p] -- Syntactic parallel array + (PostTc p Type) -- The type of the elements -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@, -- 'ApiAnnotation.AnnClose' @':]'@ -- For details on above see note [Api annotations] in ApiAnnotation ------------ Constructor patterns --------------- - | ConPatIn (Located id) - (HsConPatDetails id) + | ConPatIn (Located (IdP p)) + (HsConPatDetails p) -- ^ Constructor Pattern In | ConPatOut { @@ -181,7 +182,7 @@ data Pat id -- is to ensure their kinds are zonked pat_binds :: TcEvBinds, -- Bindings involving those dictionaries - pat_args :: HsConPatDetails id, + pat_args :: HsConPatDetails p, pat_wrap :: HsWrapper -- Extra wrapper to pass to the matcher -- Only relevant for pattern-synonyms; -- ignored for data cons @@ -192,9 +193,9 @@ data Pat id -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow' -- For details on above see note [Api annotations] in ApiAnnotation - | ViewPat (LHsExpr id) - (LPat id) - (PostTc id Type) -- The overall type of the pattern + | ViewPat (LHsExpr p) + (LPat p) + (PostTc p Type) -- The overall type of the pattern -- (= the argument type of the view function) -- for hsPatType. -- ^ View Pattern @@ -204,68 +205,69 @@ data Pat id -- 'ApiAnnotation.AnnClose' @')'@ -- For details on above see note [Api annotations] in ApiAnnotation - | SplicePat (HsSplice id) -- ^ Splice Pattern (Includes quasi-quotes) + | SplicePat (HsSplice p) -- ^ Splice Pattern (Includes quasi-quotes) ------------ Literal and n+k patterns --------------- - | LitPat HsLit -- ^ Literal Pattern + | LitPat (HsLit p) -- ^ Literal Pattern -- Used for *non-overloaded* literal patterns: -- Int#, Char#, Int, Char, String, etc. | NPat -- Natural Pattern -- Used for all overloaded literals, -- including overloaded strings with -XOverloadedStrings - (Located (HsOverLit id)) -- ALWAYS positive - (Maybe (SyntaxExpr id)) -- Just (Name of 'negate') for negative - -- patterns, Nothing otherwise - (SyntaxExpr id) -- Equality checker, of type t->t->Bool - (PostTc id Type) -- Overall type of pattern. Might be - -- different than the literal's type - -- if (==) or negate changes the type + (Located (HsOverLit p)) -- ALWAYS positive + (Maybe (SyntaxExpr p)) -- Just (Name of 'negate') for + -- negative patterns, Nothing + -- otherwise + (SyntaxExpr p) -- Equality checker, of type t->t->Bool + (PostTc p Type) -- Overall type of pattern. Might be + -- different than the literal's type + -- if (==) or negate changes the type -- ^ Natural Pattern -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVal' @'+'@ -- For details on above see note [Api annotations] in ApiAnnotation - | NPlusKPat (Located id) -- n+k pattern - (Located (HsOverLit id)) -- It'll always be an HsIntegral - (HsOverLit id) -- See Note [NPlusK patterns] in TcPat + | NPlusKPat (Located (IdP p)) -- n+k pattern + (Located (HsOverLit p)) -- It'll always be an HsIntegral + (HsOverLit p) -- See Note [NPlusK patterns] in TcPat -- NB: This could be (PostTc ...), but that induced a -- a new hs-boot file. Not worth it. - (SyntaxExpr id) -- (>=) function, of type t1->t2->Bool - (SyntaxExpr id) -- Name of '-' (see RnEnv.lookupSyntaxName) - (PostTc id Type) -- Type of overall pattern + (SyntaxExpr p) -- (>=) function, of type t1->t2->Bool + (SyntaxExpr p) -- Name of '-' (see RnEnv.lookupSyntaxName) + (PostTc p Type) -- Type of overall pattern -- ^ n+k pattern ------------ Pattern type signatures --------------- -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' -- For details on above see note [Api annotations] in ApiAnnotation - | SigPatIn (LPat id) -- Pattern with a type signature - (LHsSigWcType id) -- Signature can bind both + | SigPatIn (LPat p) -- Pattern with a type signature + (LHsSigWcType p) -- Signature can bind both -- kind and type vars -- ^ Pattern with a type signature - | SigPatOut (LPat id) + | SigPatOut (LPat p) Type -- ^ Pattern with a type signature ------------ Pattern coercions (translation only) --------------- - | CoPat HsWrapper -- Coercion Pattern - -- If co :: t1 ~ t2, p :: t2, - -- then (CoPat co p) :: t1 - (Pat id) -- Why not LPat? Ans: existing locn will do - Type -- Type of whole pattern, t1 + | CoPat HsWrapper -- Coercion Pattern + -- If co :: t1 ~ t2, p :: t2, + -- then (CoPat co p) :: t1 + (Pat p) -- Why not LPat? Ans: existing locn will do + Type -- Type of whole pattern, t1 -- During desugaring a (CoPat co pat) turns into a cast with 'co' on -- the scrutinee, followed by a match on 'pat' -- ^ Coercion Pattern -deriving instance (DataId id) => Data (Pat id) +deriving instance (DataId p) => Data (Pat p) -- | Haskell Constructor Pattern Details -type HsConPatDetails id = HsConDetails (LPat id) (HsRecFields id (LPat id)) +type HsConPatDetails p = HsConDetails (LPat p) (HsRecFields p (LPat p)) -hsConPatArgs :: HsConPatDetails id -> [LPat id] +hsConPatArgs :: HsConPatDetails p -> [LPat p] hsConPatArgs (PrefixCon ps) = ps hsConPatArgs (RecCon fs) = map (hsRecFieldArg . unLoc) (rec_flds fs) hsConPatArgs (InfixCon p1 p2) = [p1,p2] @@ -274,13 +276,13 @@ hsConPatArgs (InfixCon p1 p2) = [p1,p2] -- -- HsRecFields is used only for patterns and expressions (not data type -- declarations) -data HsRecFields id arg -- A bunch of record fields +data HsRecFields p arg -- A bunch of record fields -- { x = 3, y = True } -- Used for both expressions and patterns - = HsRecFields { rec_flds :: [LHsRecField id arg], + = HsRecFields { rec_flds :: [LHsRecField p arg], rec_dotdot :: Maybe Int } -- Note [DotDot fields] deriving (Functor, Foldable, Traversable) -deriving instance (DataId id, Data arg) => Data (HsRecFields id arg) +deriving instance (DataId p, Data arg) => Data (HsRecFields p arg) -- Note [DotDot fields] @@ -298,19 +300,19 @@ deriving instance (DataId id, Data arg) => Data (HsRecFields id arg) -- and the remainder being 'filled in' implicitly -- | Located Haskell Record Field -type LHsRecField' id arg = Located (HsRecField' id arg) +type LHsRecField' p arg = Located (HsRecField' p arg) -- | Located Haskell Record Field -type LHsRecField id arg = Located (HsRecField id arg) +type LHsRecField p arg = Located (HsRecField p arg) -- | Located Haskell Record Update Field -type LHsRecUpdField id = Located (HsRecUpdField id) +type LHsRecUpdField p = Located (HsRecUpdField p) -- | Haskell Record Field -type HsRecField id arg = HsRecField' (FieldOcc id) arg +type HsRecField p arg = HsRecField' (FieldOcc p) arg -- | Haskell Record Update Field -type HsRecUpdField id = HsRecField' (AmbiguousFieldOcc id) (LHsExpr id) +type HsRecUpdField p = HsRecField' (AmbiguousFieldOcc p) (LHsExpr p) -- | Haskell Record Field -- @@ -378,26 +380,26 @@ data HsRecField' id arg = HsRecField { -- -- See also Note [Disambiguating record fields] in TcExpr. -hsRecFields :: HsRecFields id arg -> [PostRn id id] +hsRecFields :: HsRecFields p arg -> [PostRn p (IdP p)] hsRecFields rbinds = map (unLoc . hsRecFieldSel . unLoc) (rec_flds rbinds) -- Probably won't typecheck at once, things have changed :/ -hsRecFieldsArgs :: HsRecFields id arg -> [arg] +hsRecFieldsArgs :: HsRecFields p arg -> [arg] hsRecFieldsArgs rbinds = map (hsRecFieldArg . unLoc) (rec_flds rbinds) -hsRecFieldSel :: HsRecField name arg -> Located (PostRn name name) +hsRecFieldSel :: HsRecField pass arg -> Located (PostRn pass (IdP pass)) hsRecFieldSel = fmap selectorFieldOcc . hsRecFieldLbl -hsRecFieldId :: HsRecField Id arg -> Located Id +hsRecFieldId :: HsRecField GhcTc arg -> Located Id hsRecFieldId = hsRecFieldSel -hsRecUpdFieldRdr :: HsRecUpdField id -> Located RdrName +hsRecUpdFieldRdr :: HsRecUpdField p -> Located RdrName hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hsRecFieldLbl -hsRecUpdFieldId :: HsRecField' (AmbiguousFieldOcc Id) arg -> Located Id +hsRecUpdFieldId :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> Located Id hsRecUpdFieldId = fmap selectorFieldOcc . hsRecUpdFieldOcc -hsRecUpdFieldOcc :: HsRecField' (AmbiguousFieldOcc Id) arg -> LFieldOcc Id +hsRecUpdFieldOcc :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> LFieldOcc GhcTc hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl @@ -409,7 +411,8 @@ hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl ************************************************************************ -} -instance (OutputableBndrId name) => Outputable (Pat name) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (Pat pass) where ppr = pprPat pprPatBndr :: OutputableBndr name => name -> SDoc @@ -421,10 +424,10 @@ pprPatBndr var -- Print with type info if -dppr-debug is on else pprPrefixOcc var -pprParendLPat :: (OutputableBndrId name) => LPat name -> SDoc +pprParendLPat :: (SourceTextX pass, OutputableBndrId pass) => LPat pass -> SDoc pprParendLPat (L _ p) = pprParendPat p -pprParendPat :: (OutputableBndrId name) => Pat name -> SDoc +pprParendPat :: (SourceTextX pass, OutputableBndrId pass) => Pat pass -> SDoc pprParendPat p = sdocWithDynFlags $ \ dflags -> if need_parens dflags p then parens (pprPat p) @@ -438,7 +441,7 @@ pprParendPat p = sdocWithDynFlags $ \ dflags -> -- But otherwise the CoPat is discarded, so it -- is the pattern inside that matters. Sigh. -pprPat :: (OutputableBndrId name) => Pat name -> SDoc +pprPat :: (SourceTextX pass, OutputableBndrId pass) => Pat pass -> SDoc pprPat (VarPat (L _ var)) = pprPatBndr var pprPat (WildPat _) = char '_' pprPat (LazyPat pat) = char '~' <> pprParendLPat pat @@ -475,18 +478,18 @@ pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts, else pprUserCon (unLoc con) details -pprUserCon :: (OutputableBndr con, OutputableBndrId id) - => con -> HsConPatDetails id -> SDoc +pprUserCon :: (SourceTextX p, OutputableBndr con, OutputableBndrId p) + => con -> HsConPatDetails p -> SDoc pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2 pprUserCon c details = pprPrefixOcc c <+> pprConArgs details -pprConArgs :: (OutputableBndrId id) => HsConPatDetails id -> SDoc +pprConArgs :: (SourceTextX p, OutputableBndrId p) => HsConPatDetails p -> SDoc pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats) pprConArgs (InfixCon p1 p2) = sep [pprParendLPat p1, pprParendLPat p2] pprConArgs (RecCon rpats) = ppr rpats instance (Outputable arg) - => Outputable (HsRecFields id arg) where + => Outputable (HsRecFields p arg) where ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing }) = braces (fsep (punctuate comma (map ppr flds))) ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just n }) @@ -494,8 +497,8 @@ instance (Outputable arg) where dotdot = text ".." <+> ifPprDebug (ppr (drop n flds)) -instance (Outputable id, Outputable arg) - => Outputable (HsRecField' id arg) where +instance (Outputable p, Outputable arg) + => Outputable (HsRecField' p arg) where ppr (HsRecField { hsRecFieldLbl = f, hsRecFieldArg = arg, hsRecPun = pun }) = ppr f <+> (ppUnless pun $ equals <+> ppr arg) @@ -509,19 +512,19 @@ instance (Outputable id, Outputable arg) ************************************************************************ -} -mkPrefixConPat :: DataCon -> [OutPat id] -> [Type] -> OutPat id +mkPrefixConPat :: DataCon -> [OutPat p] -> [Type] -> OutPat p -- Make a vanilla Prefix constructor pattern mkPrefixConPat dc pats tys = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon dc), pat_tvs = [], pat_dicts = [], pat_binds = emptyTcEvBinds, pat_args = PrefixCon pats, pat_arg_tys = tys, pat_wrap = idHsWrapper } -mkNilPat :: Type -> OutPat id +mkNilPat :: Type -> OutPat p mkNilPat ty = mkPrefixConPat nilDataCon [] [ty] -mkCharLitPat :: SourceText -> Char -> OutPat id +mkCharLitPat :: (SourceTextX p) => SourceText -> Char -> OutPat p mkCharLitPat src c = mkPrefixConPat charDataCon - [noLoc $ LitPat (HsCharPrim src c)] [] + [noLoc $ LitPat (HsCharPrim (setSourceText src) c)] [] {- ************************************************************************ @@ -555,16 +558,16 @@ patterns are treated specially, of course. The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are. -} -isBangedPatBind :: HsBind id -> Bool +isBangedPatBind :: HsBind p -> Bool isBangedPatBind (PatBind {pat_lhs = pat}) = isBangedLPat pat isBangedPatBind _ = False -isBangedLPat :: LPat id -> Bool +isBangedLPat :: LPat p -> Bool isBangedLPat (L _ (ParPat p)) = isBangedLPat p isBangedLPat (L _ (BangPat {})) = True isBangedLPat _ = False -looksLazyPatBind :: HsBind id -> Bool +looksLazyPatBind :: HsBind p -> Bool -- Returns True of anything *except* -- a StrictHsBind (as above) or -- a VarPat @@ -579,7 +582,7 @@ looksLazyPatBind (AbsBindsSig { abs_sig_bind = L _ bind }) looksLazyPatBind _ = False -looksLazyLPat :: LPat id -> Bool +looksLazyLPat :: LPat p -> Bool looksLazyLPat (L _ (ParPat p)) = looksLazyLPat p looksLazyLPat (L _ (AsPat _ p)) = looksLazyLPat p looksLazyLPat (L _ (BangPat {})) = False @@ -587,7 +590,7 @@ looksLazyLPat (L _ (VarPat {})) = False looksLazyLPat (L _ (WildPat {})) = False looksLazyLPat _ = True -isIrrefutableHsPat :: (OutputableBndrId id) => LPat id -> Bool +isIrrefutableHsPat :: (SourceTextX p, OutputableBndrId p) => LPat p -> Bool -- (isIrrefutableHsPat p) is true if matching against p cannot fail, -- in the sense of falling through to the next pattern. -- (NB: this is not quite the same as the (silly) defn @@ -671,13 +674,13 @@ conPatNeedsParens (RecCon {}) = False -} -- May need to add more cases -collectEvVarsPats :: [Pat id] -> Bag EvVar +collectEvVarsPats :: [Pat p] -> Bag EvVar collectEvVarsPats = unionManyBags . map collectEvVarsPat -collectEvVarsLPat :: LPat id -> Bag EvVar +collectEvVarsLPat :: LPat p -> Bag EvVar collectEvVarsLPat (L _ pat) = collectEvVarsPat pat -collectEvVarsPat :: Pat id -> Bag EvVar +collectEvVarsPat :: Pat p -> Bag EvVar collectEvVarsPat pat = case pat of LazyPat p -> collectEvVarsLPat p diff --git a/compiler/hsSyn/HsPat.hs-boot b/compiler/hsSyn/HsPat.hs-boot index aba5686085..8cb82ed22e 100644 --- a/compiler/hsSyn/HsPat.hs-boot +++ b/compiler/hsSyn/HsPat.hs-boot @@ -10,11 +10,11 @@ import SrcLoc( Located ) import Data.Data hiding (Fixity) import Outputable -import PlaceHolder ( DataId, OutputableBndrId ) +import HsExtension ( SourceTextX, DataId, OutputableBndrId ) type role Pat nominal data Pat (i :: *) type LPat i = Located (Pat i) -instance (DataId id) => Data (Pat id) -instance (OutputableBndrId name) => Outputable (Pat name) +instance (DataId p) => Data (Pat p) +instance (SourceTextX pass, OutputableBndrId pass) => Outputable (Pat pass) diff --git a/compiler/hsSyn/HsSyn.hs b/compiler/hsSyn/HsSyn.hs index e7cae91572..76afa8b81e 100644 --- a/compiler/hsSyn/HsSyn.hs +++ b/compiler/hsSyn/HsSyn.hs @@ -27,6 +27,7 @@ module HsSyn ( module HsUtils, module HsDoc, module PlaceHolder, + module HsExtension, Fixity, HsModule(..) @@ -39,12 +40,12 @@ import HsExpr import HsImpExp import HsLit import PlaceHolder +import HsExtension import HsPat import HsTypes import BasicTypes ( Fixity, WarningTxt ) import HsUtils import HsDoc -import OccName ( HasOccName(..) ) -- others: import Outputable @@ -109,8 +110,8 @@ data HsModule name -- For details on above see note [Api annotations] in ApiAnnotation deriving instance (DataId name) => Data (HsModule name) -instance (OutputableBndrId name, HasOccName name) - => Outputable (HsModule name) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (HsModule pass) where ppr (HsModule Nothing _ imports decls _ mbDoc) = pp_mb mbDoc $$ pp_nonnull imports diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index 9d7efc5bb5..77b1439efb 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -70,8 +70,8 @@ module HsTypes ( import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice ) -import PlaceHolder ( PostTc,PostRn,DataId,PlaceHolder(..), - OutputableBndrId ) +import PlaceHolder ( PlaceHolder(..) ) +import HsExtension import Id ( Id ) import Name( Name ) @@ -101,10 +101,10 @@ import Control.Monad ( unless ) -} -- | Located Bang Type -type LBangType name = Located (BangType name) +type LBangType pass = Located (BangType pass) -- | Bang Type -type BangType name = HsType name -- Bangs are in the HsType data type +type BangType pass = HsType pass -- Bangs are in the HsType data type getBangType :: LHsType a -> LHsType a getBangType (L _ (HsBangTy _ ty)) = ty @@ -219,26 +219,26 @@ Note carefully: -} -- | Located Haskell Context -type LHsContext name = Located (HsContext name) +type LHsContext pass = Located (HsContext pass) -- ^ 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnUnit' -- For details on above see note [Api annotations] in ApiAnnotation -- | Haskell Context -type HsContext name = [LHsType name] +type HsContext pass = [LHsType pass] -- | Located Haskell Type -type LHsType name = Located (HsType name) +type LHsType pass = Located (HsType pass) -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when -- in a list -- For details on above see note [Api annotations] in ApiAnnotation -- | Haskell Kind -type HsKind name = HsType name +type HsKind pass = HsType pass -- | Located Haskell Kind -type LHsKind name = Located (HsKind name) +type LHsKind pass = Located (HsKind pass) -- ^ 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' -- For details on above see note [Api annotations] in ApiAnnotation @@ -248,32 +248,33 @@ type LHsKind name = Located (HsKind name) -- The explicitly-quantified binders in a data/type declaration -- | Located Haskell Type Variable Binder -type LHsTyVarBndr name = Located (HsTyVarBndr name) +type LHsTyVarBndr pass = Located (HsTyVarBndr pass) -- See Note [HsType binders] -- | Located Haskell Quantified Type Variables -data LHsQTyVars name -- See Note [HsType binders] - = HsQTvs { hsq_implicit :: PostRn name [Name] -- implicit (dependent) variables - , hsq_explicit :: [LHsTyVarBndr name] -- explicit variables +data LHsQTyVars pass -- See Note [HsType binders] + = HsQTvs { hsq_implicit :: PostRn pass [Name] + -- implicit (dependent) variables + , hsq_explicit :: [LHsTyVarBndr pass] -- explicit variables -- See Note [HsForAllTy tyvar binders] - , hsq_dependent :: PostRn name NameSet + , hsq_dependent :: PostRn pass NameSet -- which explicit vars are dependent -- See Note [Dependent LHsQTyVars] in TcHsType } -deriving instance (DataId name) => Data (LHsQTyVars name) +deriving instance (DataId pass) => Data (LHsQTyVars pass) -mkHsQTvs :: [LHsTyVarBndr RdrName] -> LHsQTyVars RdrName +mkHsQTvs :: [LHsTyVarBndr GhcPs] -> LHsQTyVars GhcPs mkHsQTvs tvs = HsQTvs { hsq_implicit = PlaceHolder, hsq_explicit = tvs , hsq_dependent = PlaceHolder } -hsQTvExplicit :: LHsQTyVars name -> [LHsTyVarBndr name] +hsQTvExplicit :: LHsQTyVars pass -> [LHsTyVarBndr pass] hsQTvExplicit = hsq_explicit -emptyLHsQTvs :: LHsQTyVars Name +emptyLHsQTvs :: LHsQTyVars GhcRn emptyLHsQTvs = HsQTvs [] [] emptyNameSet -isEmptyLHsQTvs :: LHsQTyVars Name -> Bool +isEmptyLHsQTvs :: LHsQTyVars GhcRn -> Bool isEmptyLHsQTvs (HsQTvs [] [] _) = True isEmptyLHsQTvs _ = False @@ -287,19 +288,20 @@ isEmptyLHsQTvs _ = False -- In the last of these, wildcards can happen, so we must accommodate them -- | Haskell Implicit Binders -data HsImplicitBndrs name thing -- See Note [HsType binders] - = HsIB { hsib_vars :: PostRn name [Name] -- Implicitly-bound kind & type vars +data HsImplicitBndrs pass thing -- See Note [HsType binders] + = HsIB { hsib_vars :: PostRn pass [Name] -- Implicitly-bound kind & type vars , hsib_body :: thing -- Main payload (type or list of types) - , hsib_closed :: PostRn name Bool -- Taking the hsib_vars into account, + , hsib_closed :: PostRn pass Bool -- Taking the hsib_vars into account, -- is the payload closed? Used in -- TcHsType.decideKindGeneralisationPlan } +deriving instance (DataId pass, Data thing) => Data (HsImplicitBndrs pass thing) -- | Haskell Wildcard Binders -data HsWildCardBndrs name thing +data HsWildCardBndrs pass thing -- See Note [HsType binders] -- See Note [The wildcard story for types] - = HsWC { hswc_wcs :: PostRn name [Name] + = HsWC { hswc_wcs :: PostRn pass [Name] -- Wild cards, both named and anonymous -- after the renamer @@ -309,33 +311,29 @@ data HsWildCardBndrs name thing -- it's still there in the hsc_body. } -deriving instance (Data name, Data thing, Data (PostRn name [Name]), Data (PostRn name Bool)) - => Data (HsImplicitBndrs name thing) - -deriving instance (Data name, Data thing, Data (PostRn name [Name])) - => Data (HsWildCardBndrs name thing) +deriving instance (DataId pass, Data thing) => Data (HsWildCardBndrs pass thing) -- | Located Haskell Signature Type -type LHsSigType name = HsImplicitBndrs name (LHsType name) -- Implicit only +type LHsSigType pass = HsImplicitBndrs pass (LHsType pass) -- Implicit only -- | Located Haskell Wildcard Type -type LHsWcType name = HsWildCardBndrs name (LHsType name) -- Wildcard only +type LHsWcType pass = HsWildCardBndrs pass (LHsType pass) -- Wildcard only -- | Located Haskell Signature Wildcard Type -type LHsSigWcType name = HsWildCardBndrs name (LHsSigType name) -- Both +type LHsSigWcType pass = HsWildCardBndrs pass (LHsSigType pass) -- Both -- See Note [Representing type signatures] -hsImplicitBody :: HsImplicitBndrs name thing -> thing +hsImplicitBody :: HsImplicitBndrs pass thing -> thing hsImplicitBody (HsIB { hsib_body = body }) = body -hsSigType :: LHsSigType name -> LHsType name +hsSigType :: LHsSigType pass -> LHsType pass hsSigType = hsImplicitBody -hsSigWcType :: LHsSigWcType name -> LHsType name +hsSigWcType :: LHsSigWcType pass -> LHsType pass hsSigWcType sig_ty = hsib_body (hswc_body sig_ty) -dropWildCards :: LHsSigWcType name -> LHsSigType name +dropWildCards :: LHsSigWcType pass -> LHsSigType pass -- Drop the wildcard part of a LHsSigWcType dropWildCards sig_ty = hswc_body sig_ty @@ -359,23 +357,23 @@ The implicit kind variable 'k' is bound by the HsIB; the explicitly forall'd tyvar 'a' is bound by the HsForAllTy -} -mkHsImplicitBndrs :: thing -> HsImplicitBndrs RdrName thing +mkHsImplicitBndrs :: thing -> HsImplicitBndrs GhcPs thing mkHsImplicitBndrs x = HsIB { hsib_body = x , hsib_vars = PlaceHolder , hsib_closed = PlaceHolder } -mkHsWildCardBndrs :: thing -> HsWildCardBndrs RdrName thing +mkHsWildCardBndrs :: thing -> HsWildCardBndrs GhcPs thing mkHsWildCardBndrs x = HsWC { hswc_body = x , hswc_wcs = PlaceHolder } -- Add empty binders. This is a bit suspicious; what if -- the wrapped thing had free type variables? -mkEmptyImplicitBndrs :: thing -> HsImplicitBndrs Name thing +mkEmptyImplicitBndrs :: thing -> HsImplicitBndrs GhcRn thing mkEmptyImplicitBndrs x = HsIB { hsib_body = x , hsib_vars = [] , hsib_closed = False } -mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs Name thing +mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs GhcRn thing mkEmptyWildCardBndrs x = HsWC { hswc_body = x , hswc_wcs = [] } @@ -400,46 +398,47 @@ instance OutputableBndr HsIPName where -------------------------------------------------- -- | Haskell Type Variable Binder -data HsTyVarBndr name +data HsTyVarBndr pass = UserTyVar -- no explicit kinding - (Located name) + (Located (IdP pass)) -- See Note [Located RdrNames] in HsExpr | KindedTyVar - (Located name) - (LHsKind name) -- The user-supplied kind signature + (Located (IdP pass)) + (LHsKind pass) -- The user-supplied kind signature -- ^ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnDcolon', 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId name) => Data (HsTyVarBndr name) +deriving instance (DataId pass) => Data (HsTyVarBndr pass) -- | Does this 'HsTyVarBndr' come with an explicit kind annotation? -isHsKindedTyVar :: HsTyVarBndr name -> Bool +isHsKindedTyVar :: HsTyVarBndr pass -> Bool isHsKindedTyVar (UserTyVar {}) = False isHsKindedTyVar (KindedTyVar {}) = True -- | Do all type variables in this 'LHsQTyVars' come with kind annotations? -hsTvbAllKinded :: LHsQTyVars name -> Bool +hsTvbAllKinded :: LHsQTyVars pass -> Bool hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit -- | Haskell Type -data HsType name +data HsType pass = HsForAllTy -- See Note [HsType binders] - { hst_bndrs :: [LHsTyVarBndr name] -- Explicit, user-supplied 'forall a b c' - , hst_body :: LHsType name -- body type + { hst_bndrs :: [LHsTyVarBndr pass] + -- Explicit, user-supplied 'forall a b c' + , hst_body :: LHsType pass -- body type } -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForall', -- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow' -- For details on above see note [Api annotations] in ApiAnnotation | HsQualTy -- See Note [HsType binders] - { hst_ctxt :: LHsContext name -- Context C => blah - , hst_body :: LHsType name } + { hst_ctxt :: LHsContext pass -- Context C => blah + , hst_body :: LHsType pass } | HsTyVar Promoted -- whether explicitly promoted, for the pretty -- printer - (Located name) + (Located (IdP pass)) -- Type variable, type constructor, or data constructor -- see Note [Promotions (HsTyVar)] -- See Note [Located RdrNames] in HsExpr @@ -447,53 +446,53 @@ data HsType name -- For details on above see note [Api annotations] in ApiAnnotation - | HsAppsTy [LHsAppType name] -- Used only before renaming, + | HsAppsTy [LHsAppType pass] -- Used only before renaming, -- Note [HsAppsTy] -- ^ - 'ApiAnnotation.AnnKeywordId' : None - | HsAppTy (LHsType name) - (LHsType name) + | HsAppTy (LHsType pass) + (LHsType pass) -- ^ - 'ApiAnnotation.AnnKeywordId' : None -- For details on above see note [Api annotations] in ApiAnnotation - | HsFunTy (LHsType name) -- function type - (LHsType name) + | HsFunTy (LHsType pass) -- function type + (LHsType pass) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow', -- For details on above see note [Api annotations] in ApiAnnotation - | HsListTy (LHsType name) -- Element type + | HsListTy (LHsType pass) -- Element type -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, -- 'ApiAnnotation.AnnClose' @']'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsPArrTy (LHsType name) -- Elem. type of parallel array: [:t:] + | HsPArrTy (LHsType pass) -- Elem. type of parallel array: [:t:] -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@, -- 'ApiAnnotation.AnnClose' @':]'@ -- For details on above see note [Api annotations] in ApiAnnotation | HsTupleTy HsTupleSort - [LHsType name] -- Element types (length gives arity) + [LHsType pass] -- Element types (length gives arity) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(' or '(#'@, -- 'ApiAnnotation.AnnClose' @')' or '#)'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsSumTy [LHsType name] -- Element types (length gives arity) + | HsSumTy [LHsType pass] -- Element types (length gives arity) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(#'@, -- 'ApiAnnotation.AnnClose' '#)'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsOpTy (LHsType name) (Located name) (LHsType name) + | HsOpTy (LHsType pass) (Located (IdP pass)) (LHsType pass) -- ^ - 'ApiAnnotation.AnnKeywordId' : None -- For details on above see note [Api annotations] in ApiAnnotation - | HsParTy (LHsType name) -- See Note [Parens in HsSyn] in HsExpr + | HsParTy (LHsType pass) -- See Note [Parens in HsSyn] in HsExpr -- Parenthesis preserved for the precedence re-arrangement in RnTypes -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c! -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, @@ -502,7 +501,8 @@ data HsType name -- For details on above see note [Api annotations] in ApiAnnotation | HsIParamTy (Located HsIPName) -- (?x :: ty) - (LHsType name) -- Implicit parameters as they occur in contexts + (LHsType pass) -- Implicit parameters as they occur in + -- contexts -- ^ -- > (?x :: ty) -- @@ -510,8 +510,10 @@ data HsType name -- For details on above see note [Api annotations] in ApiAnnotation - | HsEqTy (LHsType name) -- ty1 ~ ty2 - (LHsType name) -- Always allowed even without TypeOperators, and has special kinding rule + | HsEqTy (LHsType pass) -- ty1 ~ ty2 + (LHsType pass) -- Always allowed even without + -- TypeOperators, and has special + -- kinding rule -- ^ -- > ty1 ~ ty2 -- @@ -519,8 +521,8 @@ data HsType name -- For details on above see note [Api annotations] in ApiAnnotation - | HsKindSig (LHsType name) -- (ty :: kind) - (LHsKind name) -- A type with a kind signature + | HsKindSig (LHsType pass) -- (ty :: kind) + (LHsKind pass) -- A type with a kind signature -- ^ -- > (ty :: kind) -- @@ -529,19 +531,19 @@ data HsType name -- For details on above see note [Api annotations] in ApiAnnotation - | HsSpliceTy (HsSplice name) -- Includes quasi-quotes - (PostTc name Kind) + | HsSpliceTy (HsSplice pass) -- Includes quasi-quotes + (PostTc pass Kind) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@, -- 'ApiAnnotation.AnnClose' @')'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsDocTy (LHsType name) LHsDocString -- A documented type + | HsDocTy (LHsType pass) LHsDocString -- A documented type -- ^ - 'ApiAnnotation.AnnKeywordId' : None -- For details on above see note [Api annotations] in ApiAnnotation - | HsBangTy HsSrcBang (LHsType name) -- Bang-style type annotations + | HsBangTy HsSrcBang (LHsType pass) -- Bang-style type annotations -- ^ - 'ApiAnnotation.AnnKeywordId' : -- 'ApiAnnotation.AnnOpen' @'{-\# UNPACK' or '{-\# NOUNPACK'@, -- 'ApiAnnotation.AnnClose' @'#-}'@ @@ -549,7 +551,7 @@ data HsType name -- For details on above see note [Api annotations] in ApiAnnotation - | HsRecTy [LConDeclField name] -- Only in data type declarations + | HsRecTy [LConDeclField pass] -- Only in data type declarations -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@, -- 'ApiAnnotation.AnnClose' @'}'@ @@ -563,16 +565,16 @@ data HsType name | HsExplicitListTy -- A promoted explicit list Promoted -- whether explcitly promoted, for pretty printer - (PostTc name Kind) -- See Note [Promoted lists and tuples] - [LHsType name] + (PostTc pass Kind) -- See Note [Promoted lists and tuples] + [LHsType pass] -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'["@, -- 'ApiAnnotation.AnnClose' @']'@ -- For details on above see note [Api annotations] in ApiAnnotation | HsExplicitTupleTy -- A promoted explicit tuple - [PostTc name Kind] -- See Note [Promoted lists and tuples] - [LHsType name] + [PostTc pass Kind] -- See Note [Promoted lists and tuples] + [LHsType pass] -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'("@, -- 'ApiAnnotation.AnnClose' @')'@ @@ -583,12 +585,12 @@ data HsType name -- For details on above see note [Api annotations] in ApiAnnotation - | HsWildCardTy (HsWildCardInfo name) -- A type wildcard + | HsWildCardTy (HsWildCardInfo pass) -- A type wildcard -- See Note [The wildcard story for types] -- ^ - 'ApiAnnotation.AnnKeywordId' : None -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId name) => Data (HsType name) +deriving instance (DataId pass) => Data (HsType pass) -- Note [Literal source text] in BasicTypes for SourceText fields in -- the following @@ -598,23 +600,24 @@ data HsTyLit | HsStrTy SourceText FastString deriving Data -newtype HsWildCardInfo name -- See Note [The wildcard story for types] - = AnonWildCard (PostRn name (Located Name)) +newtype HsWildCardInfo pass -- See Note [The wildcard story for types] + = AnonWildCard (PostRn pass (Located Name)) -- A anonymous wild card ('_'). A fresh Name is generated for -- each individual anonymous wildcard during renaming -deriving instance (DataId name) => Data (HsWildCardInfo name) +deriving instance (DataId pass) => Data (HsWildCardInfo pass) -- | Located Haskell Application Type -type LHsAppType name = Located (HsAppType name) +type LHsAppType pass = Located (HsAppType pass) -- ^ 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSimpleQuote' -- | Haskell Application Type -data HsAppType name - = HsAppInfix (Located name) -- either a symbol or an id in backticks - | HsAppPrefix (LHsType name) -- anything else, including things like (+) -deriving instance (DataId name) => Data (HsAppType name) +data HsAppType pass + = HsAppInfix (Located (IdP pass)) -- either a symbol or an id in backticks + | HsAppPrefix (LHsType pass) -- anything else, including things like (+) +deriving instance (DataId pass) => Data (HsAppType pass) -instance (OutputableBndrId name) => Outputable (HsAppType name) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (HsAppType pass) where ppr = ppr_app_ty {- @@ -741,24 +744,25 @@ data Promoted = Promoted deriving (Data, Eq, Show) -- | Located Constructor Declaration Field -type LConDeclField name = Located (ConDeclField name) +type LConDeclField pass = Located (ConDeclField pass) -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when -- in a list -- For details on above see note [Api annotations] in ApiAnnotation -- | Constructor Declaration Field -data ConDeclField name -- Record fields have Haddoc docs on them - = ConDeclField { cd_fld_names :: [LFieldOcc name], - -- ^ See Note [ConDeclField names] - cd_fld_type :: LBangType name, +data ConDeclField pass -- Record fields have Haddoc docs on them + = ConDeclField { cd_fld_names :: [LFieldOcc pass], + -- ^ See Note [ConDeclField passs] + cd_fld_type :: LBangType pass, cd_fld_doc :: Maybe LHsDocString } -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId name) => Data (ConDeclField name) +deriving instance (DataId pass) => Data (ConDeclField pass) -instance (OutputableBndrId name) => Outputable (ConDeclField name) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (ConDeclField pass) where ppr (ConDeclField fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty -- HsConDetails is used for patterns/expressions *and* for data type @@ -783,11 +787,11 @@ updateGadtResult :: (Monad m) => (SDoc -> m ()) -> SDoc - -> HsConDetails (LHsType Name) (Located [LConDeclField Name]) + -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]) -- ^ Original details - -> LHsType Name -- ^ Original result type - -> m (HsConDetails (LHsType Name) (Located [LConDeclField Name]), - LHsType Name) + -> LHsType GhcRn -- ^ Original result type + -> m (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]), + LHsType GhcRn) updateGadtResult failWith doc details ty = do { let (arg_tys, res_ty) = splitHsFunType ty badConSig = text "Malformed constructor signature" @@ -801,7 +805,7 @@ updateGadtResult failWith doc details ty PrefixCon {} -> return (PrefixCon arg_tys, res_ty)} {- -Note [ConDeclField names] +Note [ConDeclField passs] ~~~~~~~~~~~~~~~~~~~~~~~~~ A ConDeclField contains a list of field occurrences: these always @@ -825,7 +829,7 @@ gives -- types --------------------- -hsWcScopedTvs :: LHsSigWcType Name -> [Name] +hsWcScopedTvs :: LHsSigWcType GhcRn -> [Name] -- Get the lexically-scoped type variables of a HsSigType -- - the explicitly-given forall'd type variables -- - the implicitly-bound kind variables @@ -841,7 +845,7 @@ hsWcScopedTvs sig_ty -- (this is consistent with GHC 7 behaviour) _ -> nwcs -hsScopedTvs :: LHsSigType Name -> [Name] +hsScopedTvs :: LHsSigType GhcRn -> [Name] -- Same as hsWcScopedTvs, but for a LHsSigType hsScopedTvs sig_ty | HsIB { hsib_vars = vars, hsib_body = sig_ty2 } <- sig_ty @@ -864,30 +868,30 @@ I don't know if this is a good idea, but there it is. -} --------------------- -hsTyVarName :: HsTyVarBndr name -> name +hsTyVarName :: HsTyVarBndr pass -> IdP pass hsTyVarName (UserTyVar (L _ n)) = n hsTyVarName (KindedTyVar (L _ n) _) = n -hsLTyVarName :: LHsTyVarBndr name -> name +hsLTyVarName :: LHsTyVarBndr pass -> IdP pass hsLTyVarName = hsTyVarName . unLoc -hsExplicitLTyVarNames :: LHsQTyVars name -> [name] +hsExplicitLTyVarNames :: LHsQTyVars pass -> [IdP pass] -- Explicit variables only hsExplicitLTyVarNames qtvs = map hsLTyVarName (hsQTvExplicit qtvs) -hsAllLTyVarNames :: LHsQTyVars Name -> [Name] +hsAllLTyVarNames :: LHsQTyVars GhcRn -> [Name] -- All variables hsAllLTyVarNames (HsQTvs { hsq_implicit = kvs, hsq_explicit = tvs }) = kvs ++ map hsLTyVarName tvs -hsLTyVarLocName :: LHsTyVarBndr name -> Located name +hsLTyVarLocName :: LHsTyVarBndr pass -> Located (IdP pass) hsLTyVarLocName = fmap hsTyVarName -hsLTyVarLocNames :: LHsQTyVars name -> [Located name] +hsLTyVarLocNames :: LHsQTyVars pass -> [Located (IdP pass)] hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs) -- | Convert a LHsTyVarBndr to an equivalent LHsType. -hsLTyVarBndrToType :: LHsTyVarBndr name -> LHsType name +hsLTyVarBndrToType :: LHsTyVarBndr pass -> LHsType pass hsLTyVarBndrToType = fmap cvt where cvt (UserTyVar n) = HsTyVar NotPromoted n cvt (KindedTyVar (L name_loc n) kind) @@ -895,19 +899,19 @@ hsLTyVarBndrToType = fmap cvt -- | Convert a LHsTyVarBndrs to a list of types. -- Works on *type* variable only, no kind vars. -hsLTyVarBndrsToTypes :: LHsQTyVars name -> [LHsType name] +hsLTyVarBndrsToTypes :: LHsQTyVars pass -> [LHsType pass] hsLTyVarBndrsToTypes (HsQTvs { hsq_explicit = tvbs }) = map hsLTyVarBndrToType tvbs --------------------- -wildCardName :: HsWildCardInfo Name -> Name +wildCardName :: HsWildCardInfo GhcRn -> Name wildCardName (AnonWildCard (L _ n)) = n -- Two wild cards are the same when they have the same location -sameWildCard :: Located (HsWildCardInfo name) - -> Located (HsWildCardInfo name) -> Bool +sameWildCard :: Located (HsWildCardInfo pass) + -> Located (HsWildCardInfo pass) -> Bool sameWildCard (L l1 (AnonWildCard _)) (L l2 (AnonWildCard _)) = l1 == l2 -ignoreParens :: LHsType name -> LHsType name +ignoreParens :: LHsType pass -> LHsType pass ignoreParens (L _ (HsParTy ty)) = ignoreParens ty ignoreParens (L _ (HsAppsTy [L _ (HsAppPrefix ty)])) = ignoreParens ty ignoreParens ty = ty @@ -920,16 +924,16 @@ ignoreParens ty = ty ************************************************************************ -} -mkAnonWildCardTy :: HsType RdrName +mkAnonWildCardTy :: HsType GhcPs mkAnonWildCardTy = HsWildCardTy (AnonWildCard PlaceHolder) -mkHsOpTy :: LHsType name -> Located name -> LHsType name -> HsType name +mkHsOpTy :: LHsType pass -> Located (IdP pass) -> LHsType pass -> HsType pass mkHsOpTy ty1 op ty2 = HsOpTy ty1 op ty2 -mkHsAppTy :: LHsType name -> LHsType name -> LHsType name +mkHsAppTy :: LHsType pass -> LHsType pass -> LHsType pass mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2) -mkHsAppTys :: LHsType name -> [LHsType name] -> LHsType name +mkHsAppTys :: LHsType pass -> [LHsType pass] -> LHsType pass mkHsAppTys = foldl mkHsAppTy @@ -947,7 +951,7 @@ mkHsAppTys = foldl mkHsAppTy -- splitHsFunType (a -> (b -> c)) = ([a,b], c) -- Also deals with (->) t1 t2; that is why it only works on LHsType Name -- (see Trac #9096) -splitHsFunType :: LHsType Name -> ([LHsType Name], LHsType Name) +splitHsFunType :: LHsType GhcRn -> ([LHsType GhcRn], LHsType GhcRn) splitHsFunType (L _ (HsParTy ty)) = splitHsFunType ty @@ -971,8 +975,8 @@ splitHsFunType other = ([], other) -------------------------------- -- | Retrieves the head of an HsAppsTy, if this can be done unambiguously, -- without consulting fixities. -getAppsTyHead_maybe :: [LHsAppType name] - -> Maybe (LHsType name, [LHsType name], LexicalFixity) +getAppsTyHead_maybe :: [LHsAppType pass] + -> Maybe (LHsType pass, [LHsType pass], LexicalFixity) getAppsTyHead_maybe tys = case splitHsAppsTy tys of ([app1:apps], []) -> -- no symbols, some normal types Just (mkHsAppTys app1 apps, [], Prefix) @@ -982,13 +986,13 @@ getAppsTyHead_maybe tys = case splitHsAppsTy tys of _ -> -- can't figure it out Nothing --- | Splits a [HsAppType name] (the payload of an HsAppsTy) into regions of prefix --- types (normal types) and infix operators. +-- | Splits a [HsAppType pass] (the payload of an HsAppsTy) into regions of +-- prefix types (normal types) and infix operators. -- If @splitHsAppsTy tys = (non_syms, syms)@, then @tys@ starts with the first -- element of @non_syms@ followed by the first element of @syms@ followed by -- the next element of @non_syms@, etc. It is guaranteed that the non_syms list -- has one more element than the syms list. -splitHsAppsTy :: [LHsAppType name] -> ([[LHsType name]], [Located name]) +splitHsAppsTy :: [LHsAppType pass] -> ([[LHsType pass]], [Located (IdP pass)]) splitHsAppsTy = go [] [] [] where go acc acc_non acc_sym [] = (reverse (reverse acc : acc_non), reverse acc_sym) @@ -1001,7 +1005,8 @@ splitHsAppsTy = go [] [] [] -- somewhat like splitHsAppTys, but a little more thorough -- used to examine the result of a GADT-like datacon, so it doesn't handle -- *all* cases (like lists, tuples, (~), etc.) -hsTyGetAppHead_maybe :: LHsType name -> Maybe (Located name, [LHsType name]) +hsTyGetAppHead_maybe :: LHsType pass + -> Maybe (Located (IdP pass), [LHsType pass]) hsTyGetAppHead_maybe = go [] where go tys (L _ (HsTyVar _ ln)) = Just (ln, tys) @@ -1014,19 +1019,20 @@ hsTyGetAppHead_maybe = go [] go tys (L _ (HsKindSig t _)) = go tys t go _ _ = Nothing -splitHsAppTys :: LHsType Name -> [LHsType Name] -> (LHsType Name, [LHsType Name]) +splitHsAppTys :: LHsType GhcRn -> [LHsType GhcRn] + -> (LHsType GhcRn, [LHsType GhcRn]) -- no need to worry about HsAppsTy here splitHsAppTys (L _ (HsAppTy f a)) as = splitHsAppTys f (a:as) splitHsAppTys (L _ (HsParTy f)) as = splitHsAppTys f as splitHsAppTys f as = (f,as) -------------------------------- -splitLHsPatSynTy :: LHsType name - -> ( [LHsTyVarBndr name] -- universals - , LHsContext name -- required constraints - , [LHsTyVarBndr name] -- existentials - , LHsContext name -- provided constraints - , LHsType name) -- body type +splitLHsPatSynTy :: LHsType pass + -> ( [LHsTyVarBndr pass] -- universals + , LHsContext pass -- required constraints + , [LHsTyVarBndr pass] -- existentials + , LHsContext pass -- provided constraints + , LHsType pass) -- body type splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4) where (univs, ty1) = splitLHsForAllTy ty @@ -1034,22 +1040,23 @@ splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4) (exis, ty3) = splitLHsForAllTy ty2 (provs, ty4) = splitLHsQualTy ty3 -splitLHsSigmaTy :: LHsType name -> ([LHsTyVarBndr name], LHsContext name, LHsType name) +splitLHsSigmaTy :: LHsType pass + -> ([LHsTyVarBndr pass], LHsContext pass, LHsType pass) splitLHsSigmaTy ty | (tvs, ty1) <- splitLHsForAllTy ty , (ctxt, ty2) <- splitLHsQualTy ty1 = (tvs, ctxt, ty2) -splitLHsForAllTy :: LHsType name -> ([LHsTyVarBndr name], LHsType name) +splitLHsForAllTy :: LHsType pass -> ([LHsTyVarBndr pass], LHsType pass) splitLHsForAllTy (L _ (HsForAllTy { hst_bndrs = tvs, hst_body = body })) = (tvs, body) splitLHsForAllTy body = ([], body) -splitLHsQualTy :: LHsType name -> (LHsContext name, LHsType name) +splitLHsQualTy :: LHsType pass -> (LHsContext pass, LHsType pass) splitLHsQualTy (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body })) = (ctxt, body) splitLHsQualTy body = (noLoc [], body) -splitLHsInstDeclTy :: LHsSigType Name - -> ([Name], LHsContext Name, LHsType Name) +splitLHsInstDeclTy :: LHsSigType GhcRn + -> ([Name], LHsContext GhcRn, LHsType GhcRn) -- Split up an instance decl type, returning the pieces splitLHsInstDeclTy (HsIB { hsib_vars = itkvs , hsib_body = inst_ty }) @@ -1058,12 +1065,12 @@ splitLHsInstDeclTy (HsIB { hsib_vars = itkvs -- Return implicitly bound type and kind vars -- For an instance decl, all of them are in scope -getLHsInstDeclHead :: LHsSigType name -> LHsType name +getLHsInstDeclHead :: LHsSigType pass -> LHsType pass getLHsInstDeclHead inst_ty | (_tvs, _cxt, body_ty) <- splitLHsSigmaTy (hsSigType inst_ty) = body_ty -getLHsInstDeclClass_maybe :: LHsSigType name -> Maybe (Located name) +getLHsInstDeclClass_maybe :: LHsSigType pass -> Maybe (Located (IdP pass)) -- Works on (HsSigType RdrName) getLHsInstDeclClass_maybe inst_ty = do { let head_ty = getLHsInstDeclHead inst_ty @@ -1079,25 +1086,25 @@ getLHsInstDeclClass_maybe inst_ty -} -- | Located Field Occurrence -type LFieldOcc name = Located (FieldOcc name) +type LFieldOcc pass = Located (FieldOcc pass) -- | Field Occurrence -- -- Represents an *occurrence* of an unambiguous field. We store -- both the 'RdrName' the user originally wrote, and after the -- renamer, the selector function. -data FieldOcc name = FieldOcc { rdrNameFieldOcc :: Located RdrName +data FieldOcc pass = FieldOcc { rdrNameFieldOcc :: Located RdrName -- ^ See Note [Located RdrNames] in HsExpr - , selectorFieldOcc :: PostRn name name + , selectorFieldOcc :: PostRn pass (IdP pass) } -deriving instance Eq (PostRn name name) => Eq (FieldOcc name) -deriving instance Ord (PostRn name name) => Ord (FieldOcc name) -deriving instance (Data name, Data (PostRn name name)) => Data (FieldOcc name) +deriving instance Eq (PostRn pass (IdP pass)) => Eq (FieldOcc pass) +deriving instance Ord (PostRn pass (IdP pass)) => Ord (FieldOcc pass) +deriving instance (DataId pass) => Data (FieldOcc pass) -instance Outputable (FieldOcc name) where +instance Outputable (FieldOcc pass) where ppr = ppr . rdrNameFieldOcc -mkFieldOcc :: Located RdrName -> FieldOcc RdrName +mkFieldOcc :: Located RdrName -> FieldOcc GhcPs mkFieldOcc rdr = FieldOcc rdr PlaceHolder @@ -1113,37 +1120,37 @@ mkFieldOcc rdr = FieldOcc rdr PlaceHolder -- See Note [HsRecField and HsRecUpdField] in HsPat and -- Note [Disambiguating record fields] in TcExpr. -- See Note [Located RdrNames] in HsExpr -data AmbiguousFieldOcc name - = Unambiguous (Located RdrName) (PostRn name name) - | Ambiguous (Located RdrName) (PostTc name name) -deriving instance ( Data name - , Data (PostRn name name) - , Data (PostTc name name)) - => Data (AmbiguousFieldOcc name) - -instance Outputable (AmbiguousFieldOcc name) where +data AmbiguousFieldOcc pass + = Unambiguous (Located RdrName) (PostRn pass (IdP pass)) + | Ambiguous (Located RdrName) (PostTc pass (IdP pass)) +deriving instance ( Data pass + , Data (PostTc pass (IdP pass)) + , Data (PostRn pass (IdP pass))) + => Data (AmbiguousFieldOcc pass) + +instance Outputable (AmbiguousFieldOcc pass) where ppr = ppr . rdrNameAmbiguousFieldOcc -instance OutputableBndr (AmbiguousFieldOcc name) where +instance OutputableBndr (AmbiguousFieldOcc pass) where pprInfixOcc = pprInfixOcc . rdrNameAmbiguousFieldOcc pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc -mkAmbiguousFieldOcc :: Located RdrName -> AmbiguousFieldOcc RdrName +mkAmbiguousFieldOcc :: Located RdrName -> AmbiguousFieldOcc GhcPs mkAmbiguousFieldOcc rdr = Unambiguous rdr PlaceHolder -rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc name -> RdrName +rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc pass -> RdrName rdrNameAmbiguousFieldOcc (Unambiguous (L _ rdr) _) = rdr rdrNameAmbiguousFieldOcc (Ambiguous (L _ rdr) _) = rdr -selectorAmbiguousFieldOcc :: AmbiguousFieldOcc Id -> Id +selectorAmbiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> Id selectorAmbiguousFieldOcc (Unambiguous _ sel) = sel selectorAmbiguousFieldOcc (Ambiguous _ sel) = sel -unambiguousFieldOcc :: AmbiguousFieldOcc Id -> FieldOcc Id +unambiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> FieldOcc GhcTc unambiguousFieldOcc (Unambiguous rdr sel) = FieldOcc rdr sel unambiguousFieldOcc (Ambiguous rdr sel) = FieldOcc rdr sel -ambiguousFieldOcc :: FieldOcc name -> AmbiguousFieldOcc name +ambiguousFieldOcc :: FieldOcc pass -> AmbiguousFieldOcc pass ambiguousFieldOcc (FieldOcc rdr sel) = Unambiguous rdr sel {- @@ -1154,30 +1161,33 @@ ambiguousFieldOcc (FieldOcc rdr sel) = Unambiguous rdr sel ************************************************************************ -} -instance (OutputableBndrId name) => Outputable (HsType name) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (HsType pass) where ppr ty = pprHsType ty instance Outputable HsTyLit where ppr = ppr_tylit -instance (OutputableBndrId name) => Outputable (LHsQTyVars name) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (LHsQTyVars pass) where ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs -instance (OutputableBndrId name) => Outputable (HsTyVarBndr name) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (HsTyVarBndr pass) where ppr (UserTyVar n) = ppr n ppr (KindedTyVar n k) = parens $ hsep [ppr n, dcolon, ppr k] -instance (Outputable thing) => Outputable (HsImplicitBndrs name thing) where +instance (Outputable thing) => Outputable (HsImplicitBndrs pass thing) where ppr (HsIB { hsib_body = ty }) = ppr ty -instance (Outputable thing) => Outputable (HsWildCardBndrs name thing) where +instance (Outputable thing) => Outputable (HsWildCardBndrs pass thing) where ppr (HsWC { hswc_body = ty }) = ppr ty -instance Outputable (HsWildCardInfo name) where +instance Outputable (HsWildCardInfo pass) where ppr (AnonWildCard _) = char '_' -pprHsForAll :: (OutputableBndrId name) - => [LHsTyVarBndr name] -> LHsContext name -> SDoc +pprHsForAll :: (SourceTextX pass, OutputableBndrId pass) + => [LHsTyVarBndr pass] -> LHsContext pass -> SDoc pprHsForAll = pprHsForAllExtra Nothing -- | Version of 'pprHsForAll' that can also print an extra-constraints @@ -1187,37 +1197,43 @@ pprHsForAll = pprHsForAllExtra Nothing -- function for this is needed, as the extra-constraints wildcard is removed -- from the actual context and type, and stored in a separate field, thus just -- printing the type will not print the extra-constraints wildcard. -pprHsForAllExtra :: (OutputableBndrId name) - => Maybe SrcSpan -> [LHsTyVarBndr name] -> LHsContext name +pprHsForAllExtra :: (SourceTextX pass, OutputableBndrId pass) + => Maybe SrcSpan -> [LHsTyVarBndr pass] -> LHsContext pass -> SDoc pprHsForAllExtra extra qtvs cxt = pprHsForAllTvs qtvs <+> pprHsContextExtra show_extra (unLoc cxt) where show_extra = isJust extra -pprHsForAllTvs :: (OutputableBndrId name) => [LHsTyVarBndr name] -> SDoc +pprHsForAllTvs :: (SourceTextX pass, OutputableBndrId pass) + => [LHsTyVarBndr pass] -> SDoc pprHsForAllTvs qtvs = sdocWithPprDebug $ \debug -> ppWhen (debug || not (null qtvs)) $ forAllLit <+> interppSP qtvs <> dot -pprHsContext :: (OutputableBndrId name) => HsContext name -> SDoc +pprHsContext :: (SourceTextX pass, OutputableBndrId pass) + => HsContext pass -> SDoc pprHsContext = maybe empty (<+> darrow) . pprHsContextMaybe -pprHsContextNoArrow :: (OutputableBndrId name) => HsContext name -> SDoc +pprHsContextNoArrow :: (SourceTextX pass, OutputableBndrId pass) + => HsContext pass -> SDoc pprHsContextNoArrow = fromMaybe empty . pprHsContextMaybe -pprHsContextMaybe :: (OutputableBndrId name) => HsContext name -> Maybe SDoc +pprHsContextMaybe :: (SourceTextX pass, OutputableBndrId pass) + => HsContext pass -> Maybe SDoc pprHsContextMaybe [] = Nothing pprHsContextMaybe [L _ pred] = Just $ ppr_mono_ty pred pprHsContextMaybe cxt = Just $ parens (interpp'SP cxt) -- For use in a HsQualTy, which always gets printed if it exists. -pprHsContextAlways :: (OutputableBndrId name) => HsContext name -> SDoc +pprHsContextAlways :: (SourceTextX pass, OutputableBndrId pass) + => HsContext pass -> SDoc pprHsContextAlways [] = parens empty <+> darrow pprHsContextAlways [L _ ty] = ppr_mono_ty ty <+> darrow pprHsContextAlways cxt = parens (interpp'SP cxt) <+> darrow -- True <=> print an extra-constraints wildcard, e.g. @(Show a, _) =>@ -pprHsContextExtra :: (OutputableBndrId name) => Bool -> HsContext name -> SDoc +pprHsContextExtra :: (SourceTextX pass, OutputableBndrId pass) + => Bool -> HsContext pass -> SDoc pprHsContextExtra show_extra ctxt | not show_extra = pprHsContext ctxt @@ -1228,7 +1244,8 @@ pprHsContextExtra show_extra ctxt where ctxt' = map ppr ctxt ++ [char '_'] -pprConDeclFields :: (OutputableBndrId name) => [LConDeclField name] -> SDoc +pprConDeclFields :: (SourceTextX pass, OutputableBndrId pass) + => [LConDeclField pass] -> SDoc pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields))) where ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty, @@ -1252,13 +1269,15 @@ seems like the Right Thing anyway.) -- Printing works more-or-less as for Types -pprHsType :: (OutputableBndrId name) => HsType name -> SDoc +pprHsType :: (SourceTextX pass, OutputableBndrId pass) => HsType pass -> SDoc pprHsType ty = ppr_mono_ty ty -ppr_mono_lty :: (OutputableBndrId name) => LHsType name -> SDoc +ppr_mono_lty :: (SourceTextX pass, OutputableBndrId pass) + => LHsType pass -> SDoc ppr_mono_lty ty = ppr_mono_ty (unLoc ty) -ppr_mono_ty :: (OutputableBndrId name) => HsType name -> SDoc +ppr_mono_ty :: (SourceTextX pass, OutputableBndrId pass) + => HsType pass -> SDoc ppr_mono_ty (HsForAllTy { hst_bndrs = tvs, hst_body = ty }) = sep [pprHsForAllTvs tvs, ppr_mono_lty ty] @@ -1318,8 +1337,8 @@ ppr_mono_ty (HsDocTy ty doc) -- postfix operators -------------------------- -ppr_fun_ty :: (OutputableBndrId name) - => LHsType name -> LHsType name -> SDoc +ppr_fun_ty :: (SourceTextX pass, OutputableBndrId pass) + => LHsType pass -> LHsType pass -> SDoc ppr_fun_ty ty1 ty2 = let p1 = ppr_mono_lty ty1 p2 = ppr_mono_lty ty2 @@ -1327,7 +1346,8 @@ ppr_fun_ty ty1 ty2 sep [p1, text "->" <+> p2] -------------------------- -ppr_app_ty :: (OutputableBndrId name) => HsAppType name -> SDoc +ppr_app_ty :: (SourceTextX pass, OutputableBndrId pass) + => HsAppType pass -> SDoc ppr_app_ty (HsAppInfix (L _ n)) = pprInfixOcc n ppr_app_ty (HsAppPrefix (L _ (HsTyVar NotPromoted (L _ n)))) = pprPrefixOcc n diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index 4b07683a67..c1a9a2f252 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -6,11 +6,11 @@ Here we collect a variety of helper functions that construct or analyse HsSyn. All these functions deal with generic HsSyn; functions which deal with the instantiated versions are located elsewhere: - Parameterised by Module - ---------------- ------------- - RdrName parser/RdrHsSyn - Name rename/RnHsSyn - Id typecheck/TcHsSyn + Parameterised by Module + ---------------- ------------- + GhcPs/RdrName parser/RdrHsSyn + GhcRn/Name rename/RnHsSyn + GhcTc/Id typecheck/TcHsSyn -} {-# LANGUAGE CPP #-} @@ -99,6 +99,7 @@ import HsPat import HsTypes import HsLit import PlaceHolder +import HsExtension import TcEvidence import RdrName @@ -140,7 +141,7 @@ just attach noSrcSpan to everything. mkHsPar :: LHsExpr id -> LHsExpr id mkHsPar e = L (getLoc e) (HsPar e) -mkSimpleMatch :: HsMatchContext (NameOrRdrName id) +mkSimpleMatch :: HsMatchContext (NameOrRdrName (IdP id)) -> [LPat id] -> Located (body id) -> LMatch id (Located (body id)) mkSimpleMatch ctxt pats rhs @@ -176,16 +177,16 @@ mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2) mkHsAppType :: LHsExpr name -> LHsWcType name -> LHsExpr name mkHsAppType e t = addCLoc e (hswc_body t) (HsAppType e t) -mkHsAppTypeOut :: LHsExpr Id -> LHsWcType Name -> LHsExpr Id +mkHsAppTypeOut :: LHsExpr GhcTc -> LHsWcType GhcRn -> LHsExpr GhcTc mkHsAppTypeOut e t = addCLoc e (hswc_body t) (HsAppTypeOut e t) -mkHsLam :: [LPat RdrName] -> LHsExpr RdrName -> LHsExpr RdrName +mkHsLam :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches)) where matches = mkMatchGroup Generated [mkSimpleMatch LambdaExpr pats body] -mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr Id -> LHsExpr Id +mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars <.> mkWpLams dicts) expr @@ -195,10 +196,10 @@ mkHsCaseAlt :: LPat id -> (Located (body id)) -> LMatch id (Located (body id)) mkHsCaseAlt pat expr = mkSimpleMatch CaseAlt [pat] expr -nlHsTyApp :: name -> [Type] -> LHsExpr name +nlHsTyApp :: IdP name -> [Type] -> LHsExpr name nlHsTyApp fun_id tys = noLoc (mkHsWrap (mkWpTyApps tys) (HsVar (noLoc fun_id))) -nlHsTyApps :: name -> [Type] -> [LHsExpr name] -> LHsExpr name +nlHsTyApps :: IdP name -> [Type] -> [LHsExpr name] -> LHsExpr name nlHsTyApps fun_id tys xs = foldl nlHsApp (nlHsTyApp fun_id tys) xs --------- Adding parens --------- @@ -219,30 +220,33 @@ nlParPat p = noLoc (ParPat p) -- These are the bits of syntax that contain rebindable names -- See RnEnv.lookupSyntaxName -mkHsIntegral :: IntegralLit -> PostTc RdrName Type - -> HsOverLit RdrName -mkHsFractional :: FractionalLit -> PostTc RdrName Type -> HsOverLit RdrName -mkHsIsString :: SourceText -> FastString -> PostTc RdrName Type - -> HsOverLit RdrName -mkHsDo :: HsStmtContext Name -> [ExprLStmt RdrName] -> HsExpr RdrName -mkHsComp :: HsStmtContext Name -> [ExprLStmt RdrName] -> LHsExpr RdrName - -> HsExpr RdrName - -mkNPat :: Located (HsOverLit RdrName) -> Maybe (SyntaxExpr RdrName) -> Pat RdrName -mkNPlusKPat :: Located RdrName -> Located (HsOverLit RdrName) -> Pat RdrName - -mkLastStmt :: Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR)) -mkBodyStmt :: Located (bodyR RdrName) - -> StmtLR idL RdrName (Located (bodyR RdrName)) -mkBindStmt :: (PostTc idR Type ~ PlaceHolder) +mkHsIntegral :: IntegralLit -> PostTc GhcPs Type + -> HsOverLit GhcPs +mkHsFractional :: FractionalLit -> PostTc GhcPs Type -> HsOverLit GhcPs +mkHsIsString :: SourceText -> FastString -> PostTc GhcPs Type + -> HsOverLit GhcPs +mkHsDo :: HsStmtContext Name -> [ExprLStmt GhcPs] -> HsExpr GhcPs +mkHsComp :: HsStmtContext Name -> [ExprLStmt GhcPs] -> LHsExpr GhcPs + -> HsExpr GhcPs + +mkNPat :: Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) + -> Pat GhcPs +mkNPlusKPat :: Located RdrName -> Located (HsOverLit GhcPs) -> Pat GhcPs + +mkLastStmt :: SourceTextX idR + => Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR)) +mkBodyStmt :: Located (bodyR GhcPs) + -> StmtLR idL GhcPs (Located (bodyR GhcPs)) +mkBindStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder) => LPat idL -> Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR)) -mkTcBindStmt :: LPat Id -> Located (bodyR Id) -> StmtLR Id Id (Located (bodyR Id)) +mkTcBindStmt :: LPat GhcTc -> Located (bodyR GhcTc) + -> StmtLR GhcTc GhcTc (Located (bodyR GhcTc)) -emptyRecStmt :: StmtLR idL RdrName bodyR -emptyRecStmtName :: StmtLR Name Name bodyR -emptyRecStmtId :: StmtLR Id Id bodyR -mkRecStmt :: [LStmtLR idL RdrName bodyR] -> StmtLR idL RdrName bodyR +emptyRecStmt :: StmtLR idL GhcPs bodyR +emptyRecStmtName :: StmtLR GhcRn GhcRn bodyR +emptyRecStmtId :: StmtLR GhcTc GhcTc bodyR +mkRecStmt :: [LStmtLR idL GhcPs bodyR] -> StmtLR idL GhcPs bodyR mkHsIntegral i = OverLit (HsIntegral i) noRebindableInfo noExpr @@ -257,26 +261,27 @@ mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt]) where last_stmt = L (getLoc expr) $ mkLastStmt expr -mkHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> HsExpr id +mkHsIf :: SourceTextX p => LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b mkNPat lit neg = NPat lit neg noSyntaxExpr placeHolderType mkNPlusKPat id lit = NPlusKPat id lit (unLoc lit) noSyntaxExpr noSyntaxExpr placeHolderType -mkTransformStmt :: (PostTc idR Type ~ PlaceHolder) +mkTransformStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder) => [ExprLStmt idL] -> LHsExpr idR -> StmtLR idL idR (LHsExpr idL) -mkTransformByStmt :: (PostTc idR Type ~ PlaceHolder) +mkTransformByStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder) => [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR (LHsExpr idL) -mkGroupUsingStmt :: (PostTc idR Type ~ PlaceHolder) +mkGroupUsingStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder) => [ExprLStmt idL] -> LHsExpr idR -> StmtLR idL idR (LHsExpr idL) -mkGroupByUsingStmt :: (PostTc idR Type ~ PlaceHolder) +mkGroupByUsingStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder) => [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR (LHsExpr idL) -emptyTransStmt :: (PostTc idR Type ~ PlaceHolder) => StmtLR idL idR (LHsExpr idR) +emptyTransStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder) + => StmtLR idL idR (LHsExpr idR) emptyTransStmt = TransStmt { trS_form = panic "emptyTransStmt: form" , trS_stmts = [], trS_bndrs = [] , trS_by = Nothing, trS_using = noLoc noExpr @@ -294,7 +299,7 @@ mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr PlaceHolder mkTcBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr unitTy -- don't use placeHolderTypeTc above, because that panics during zonking -emptyRecStmt' :: forall idL idR body. +emptyRecStmt' :: forall idL idR body. SourceTextX idR => PostTc idR Type -> StmtLR idL idR body emptyRecStmt' tyVal = RecStmt @@ -314,27 +319,27 @@ mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts } ------------------------------- --- A useful function for building @OpApps@. The operator is always a -- variable, and we don't know the fixity yet. -mkHsOpApp :: LHsExpr id -> id -> LHsExpr id -> HsExpr id +mkHsOpApp :: LHsExpr id -> IdP id -> LHsExpr id -> HsExpr id mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar (noLoc op))) (error "mkOpApp:fixity") e2 unqualSplice :: RdrName unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice")) -mkUntypedSplice :: SpliceDecoration -> LHsExpr RdrName -> HsSplice RdrName +mkUntypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs mkUntypedSplice hasParen e = HsUntypedSplice hasParen unqualSplice e -mkHsSpliceE :: SpliceDecoration -> LHsExpr RdrName -> HsExpr RdrName +mkHsSpliceE :: SpliceDecoration -> LHsExpr GhcPs -> HsExpr GhcPs mkHsSpliceE hasParen e = HsSpliceE (mkUntypedSplice hasParen e) -mkHsSpliceTE :: SpliceDecoration -> LHsExpr RdrName -> HsExpr RdrName +mkHsSpliceTE :: SpliceDecoration -> LHsExpr GhcPs -> HsExpr GhcPs mkHsSpliceTE hasParen e = HsSpliceE (HsTypedSplice hasParen unqualSplice e) -mkHsSpliceTy :: SpliceDecoration -> LHsExpr RdrName -> HsType RdrName +mkHsSpliceTy :: SpliceDecoration -> LHsExpr GhcPs -> HsType GhcPs mkHsSpliceTy hasParen e = HsSpliceTy (HsUntypedSplice hasParen unqualSplice e) placeHolderKind -mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice RdrName +mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice GhcPs mkHsQuasiQuote quoter span quote = HsQuasiQuote unqualSplice quoter span quote unqualQuasiQuote :: RdrName @@ -342,19 +347,19 @@ unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote")) -- A name (uniquified later) to -- identify the quasi-quote -mkHsString :: String -> HsLit -mkHsString s = HsString NoSourceText (mkFastString s) +mkHsString :: SourceTextX p => String -> HsLit p +mkHsString s = HsString noSourceText (mkFastString s) -mkHsStringPrimLit :: FastString -> HsLit +mkHsStringPrimLit :: SourceTextX p => FastString -> HsLit p mkHsStringPrimLit fs - = HsStringPrim NoSourceText (fastStringToByteString fs) + = HsStringPrim noSourceText (fastStringToByteString fs) ------------- -userHsLTyVarBndrs :: SrcSpan -> [Located name] -> [LHsTyVarBndr name] +userHsLTyVarBndrs :: SrcSpan -> [Located (IdP name)] -> [LHsTyVarBndr name] -- Caller sets location userHsLTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | v <- bndrs ] -userHsTyVarBndrs :: SrcSpan -> [name] -> [LHsTyVarBndr name] +userHsTyVarBndrs :: SrcSpan -> [IdP name] -> [LHsTyVarBndr name] -- Caller sets location userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar (L loc v)) | v <- bndrs ] @@ -367,23 +372,23 @@ userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar (L loc v)) | v <- bndrs ] ************************************************************************ -} -nlHsVar :: id -> LHsExpr id +nlHsVar :: IdP id -> LHsExpr id nlHsVar n = noLoc (HsVar (noLoc n)) -- NB: Only for LHsExpr **Id** -nlHsDataCon :: DataCon -> LHsExpr Id +nlHsDataCon :: DataCon -> LHsExpr GhcTc nlHsDataCon con = noLoc (HsConLikeOut (RealDataCon con)) -nlHsLit :: HsLit -> LHsExpr id +nlHsLit :: HsLit p -> LHsExpr p nlHsLit n = noLoc (HsLit n) -nlHsIntLit :: Integer -> LHsExpr id -nlHsIntLit n = noLoc (HsLit (HsInt (mkIntegralLit n))) +nlHsIntLit :: HasDefaultX p => Integer -> LHsExpr p +nlHsIntLit n = noLoc (HsLit (HsInt def (mkIntegralLit n))) -nlVarPat :: id -> LPat id +nlVarPat :: IdP id -> LPat id nlVarPat n = noLoc (VarPat (noLoc n)) -nlLitPat :: HsLit -> LPat id +nlLitPat :: HsLit p -> LPat p nlLitPat l = noLoc (LitPat l) nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id @@ -401,59 +406,59 @@ nlHsSyntaxApps (SyntaxExpr { syn_expr = fun = mkLHsWrap res_wrap (foldl nlHsApp (noLoc fun) (zipWithEqual "nlHsSyntaxApps" mkLHsWrap arg_wraps args)) -nlHsApps :: id -> [LHsExpr id] -> LHsExpr id +nlHsApps :: IdP id -> [LHsExpr id] -> LHsExpr id nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs -nlHsVarApps :: id -> [id] -> LHsExpr id +nlHsVarApps :: IdP id -> [IdP id] -> LHsExpr id nlHsVarApps f xs = noLoc (foldl mk (HsVar (noLoc f)) (map (HsVar . noLoc) xs)) where mk f a = HsApp (noLoc f) (noLoc a) -nlConVarPat :: RdrName -> [RdrName] -> LPat RdrName +nlConVarPat :: RdrName -> [RdrName] -> LPat GhcPs nlConVarPat con vars = nlConPat con (map nlVarPat vars) -nlConVarPatName :: Name -> [Name] -> LPat Name +nlConVarPatName :: Name -> [Name] -> LPat GhcRn nlConVarPatName con vars = nlConPatName con (map nlVarPat vars) -nlInfixConPat :: id -> LPat id -> LPat id -> LPat id +nlInfixConPat :: IdP id -> LPat id -> LPat id -> LPat id nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r)) -nlConPat :: RdrName -> [LPat RdrName] -> LPat RdrName +nlConPat :: RdrName -> [LPat GhcPs] -> LPat GhcPs nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats)) -nlConPatName :: Name -> [LPat Name] -> LPat Name +nlConPatName :: Name -> [LPat GhcRn] -> LPat GhcRn nlConPatName con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats)) -nlNullaryConPat :: id -> LPat id +nlNullaryConPat :: IdP id -> LPat id nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon [])) -nlWildConPat :: DataCon -> LPat RdrName +nlWildConPat :: DataCon -> LPat GhcPs nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con)) (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat))) -nlWildPat :: LPat RdrName +nlWildPat :: LPat GhcPs nlWildPat = noLoc (WildPat placeHolderType ) -- Pre-typechecking -nlWildPatName :: LPat Name +nlWildPatName :: LPat GhcRn nlWildPatName = noLoc (WildPat placeHolderType ) -- Pre-typechecking -nlWildPatId :: LPat Id +nlWildPatId :: LPat GhcTc nlWildPatId = noLoc (WildPat placeHolderTypeTc ) -- Post-typechecking -nlHsDo :: HsStmtContext Name -> [LStmt RdrName (LHsExpr RdrName)] - -> LHsExpr RdrName +nlHsDo :: HsStmtContext Name -> [LStmt GhcPs (LHsExpr GhcPs)] + -> LHsExpr GhcPs nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts) -nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id +nlHsOpApp :: LHsExpr id -> IdP id -> LHsExpr id -> LHsExpr id nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2) -nlHsLam :: LMatch RdrName (LHsExpr RdrName) -> LHsExpr RdrName +nlHsLam :: LMatch GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs nlHsPar :: LHsExpr id -> LHsExpr id nlHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id -nlHsCase :: LHsExpr RdrName -> [LMatch RdrName (LHsExpr RdrName)] - -> LHsExpr RdrName -nlList :: [LHsExpr RdrName] -> LHsExpr RdrName +nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] + -> LHsExpr GhcPs +nlList :: [LHsExpr GhcPs] -> LHsExpr GhcPs nlHsLam match = noLoc (HsLam (mkMatchGroup Generated [match])) nlHsPar e = noLoc (HsPar e) @@ -467,7 +472,7 @@ nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup Generated matches)) nlList exprs = noLoc (ExplicitList placeHolderType Nothing exprs) nlHsAppTy :: LHsType name -> LHsType name -> LHsType name -nlHsTyVar :: name -> LHsType name +nlHsTyVar :: IdP name -> LHsType name nlHsFunTy :: LHsType name -> LHsType name -> LHsType name nlHsParTy :: LHsType name -> LHsType name @@ -476,7 +481,7 @@ nlHsTyVar x = noLoc (HsTyVar NotPromoted (noLoc x)) nlHsFunTy a b = noLoc (HsFunTy a b) nlHsParTy t = noLoc (HsParTy t) -nlHsTyConApp :: name -> [LHsType name] -> LHsType name +nlHsTyConApp :: IdP name -> [LHsType name] -> LHsType name nlHsTyConApp tycon tys = foldl nlHsAppTy (nlHsTyVar tycon) tys {- @@ -489,13 +494,13 @@ mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a mkLHsTupleExpr [e] = e mkLHsTupleExpr es = noLoc $ ExplicitTuple (map (noLoc . Present) es) Boxed -mkLHsVarTuple :: [a] -> LHsExpr a +mkLHsVarTuple :: [IdP a] -> LHsExpr a mkLHsVarTuple ids = mkLHsTupleExpr (map nlHsVar ids) nlTuplePat :: [LPat id] -> Boxity -> LPat id nlTuplePat pats box = noLoc (TuplePat pats box []) -missingTupArg :: HsTupArg RdrName +missingTupArg :: HsTupArg GhcPs missingTupArg = Missing placeHolderType mkLHsPatTup :: [LPat id] -> LPat id @@ -504,14 +509,14 @@ mkLHsPatTup [lpat] = lpat mkLHsPatTup lpats = L (getLoc (head lpats)) $ TuplePat lpats Boxed [] -- The Big equivalents for the source tuple expressions -mkBigLHsVarTup :: [id] -> LHsExpr id +mkBigLHsVarTup :: [IdP id] -> LHsExpr id mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids) mkBigLHsTup :: [LHsExpr id] -> LHsExpr id mkBigLHsTup = mkChunkified mkLHsTupleExpr -- The Big equivalents for the source tuple patterns -mkBigLHsVarPatTup :: [id] -> LPat id +mkBigLHsVarPatTup :: [IdP id] -> LPat id mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs) mkBigLHsPatTup :: [LPat id] -> LPat id @@ -565,14 +570,14 @@ chunkify xs * * ********************************************************************* -} -mkLHsSigType :: LHsType RdrName -> LHsSigType RdrName +mkLHsSigType :: LHsType GhcPs -> LHsSigType GhcPs mkLHsSigType ty = mkHsImplicitBndrs ty -mkLHsSigWcType :: LHsType RdrName -> LHsSigWcType RdrName +mkLHsSigWcType :: LHsType GhcPs -> LHsSigWcType GhcPs mkLHsSigWcType ty = mkHsWildCardBndrs (mkHsImplicitBndrs ty) -mkHsSigEnv :: forall a. (LSig Name -> Maybe ([Located Name], a)) - -> [LSig Name] +mkHsSigEnv :: forall a. (LSig GhcRn -> Maybe ([Located Name], a)) + -> [LSig GhcRn] -> NameEnv a mkHsSigEnv get_info sigs = mkNameEnv (mk_pairs ordinary_sigs) @@ -593,11 +598,11 @@ mkHsSigEnv get_info sigs is_gen_dm_sig (L _ (ClassOpSig True _ _)) = True is_gen_dm_sig _ = False - mk_pairs :: [LSig Name] -> [(Name, a)] + mk_pairs :: [LSig GhcRn] -> [(Name, a)] mk_pairs sigs = [ (n,a) | Just (ns,a) <- map get_info sigs , L _ n <- ns ] -mkClassOpSigs :: [LSig RdrName] -> [LSig RdrName] +mkClassOpSigs :: [LSig GhcPs] -> [LSig GhcPs] -- Convert TypeSig to ClassOpSig -- The former is what is parsed, but the latter is -- what we need in class/instance declarations @@ -607,7 +612,7 @@ mkClassOpSigs sigs fiddle (L loc (TypeSig nms ty)) = L loc (ClassOpSig False nms (dropWildCards ty)) fiddle sig = sig -typeToLHsType :: Type -> LHsType RdrName +typeToLHsType :: Type -> LHsType GhcPs -- ^ Converting a Type to an HsType RdrName -- This is needed to implement GeneralizedNewtypeDeriving. -- @@ -616,7 +621,7 @@ typeToLHsType :: Type -> LHsType RdrName typeToLHsType ty = go ty where - go :: Type -> LHsType RdrName + go :: Type -> LHsType GhcPs go ty@(FunTy arg _) | isPredTy arg , (theta, tau) <- tcSplitPhiTy ty @@ -629,8 +634,8 @@ typeToLHsType ty , hst_body = go tau }) go (TyVarTy tv) = nlHsTyVar (getRdrName tv) go (AppTy t1 t2) = nlHsAppTy (go t1) (go t2) - go (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy NoSourceText n) - go (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy NoSourceText s) + go (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy noSourceText n) + go (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy noSourceText s) go (TyConApp tc args) = nlHsTyConApp (getRdrName tc) (map go args') where args' = filterOutInvisibleTypes tc args @@ -640,7 +645,7 @@ typeToLHsType ty -- Source-language types have _invisible_ kind arguments, -- so we must remove them here (Trac #8563) - go_tv :: TyVar -> LHsTyVarBndr RdrName + go_tv :: TyVar -> LHsTyVarBndr GhcPs go_tv tv = noLoc $ KindedTyVar (noLoc (getRdrName tv)) (go (tyVarKind tv)) @@ -687,7 +692,7 @@ mkHsWrapPatCo :: TcCoercionN -> Pat id -> Type -> Pat id mkHsWrapPatCo co pat ty | isTcReflCo co = pat | otherwise = CoPat (mkWpCastN co) pat ty -mkHsDictLet :: TcEvBinds -> LHsExpr Id -> LHsExpr Id +mkHsDictLet :: TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr {- @@ -699,8 +704,8 @@ l ************************************************************************ -} -mkFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] - -> HsBind RdrName +mkFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] + -> HsBind GhcPs -- Not infix, with place holders for coercion and free vars mkFunBind fn ms = FunBind { fun_id = fn , fun_matches = mkMatchGroup Generated ms @@ -708,8 +713,8 @@ mkFunBind fn ms = FunBind { fun_id = fn , bind_fvs = placeHolderNames , fun_tick = [] } -mkTopFunBind :: Origin -> Located Name -> [LMatch Name (LHsExpr Name)] - -> HsBind Name +mkTopFunBind :: Origin -> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)] + -> HsBind GhcRn -- In Name-land, with empty bind_fvs mkTopFunBind origin fn ms = FunBind { fun_id = fn , fun_matches = mkMatchGroup origin ms @@ -718,15 +723,15 @@ mkTopFunBind origin fn ms = FunBind { fun_id = fn -- binding , fun_tick = [] } -mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName +mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs -mkVarBind :: id -> LHsExpr id -> LHsBind id +mkVarBind :: IdP p -> LHsExpr p -> LHsBind p mkVarBind var rhs = L (getLoc rhs) $ VarBind { var_id = var, var_rhs = rhs, var_inline = False } mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName) - -> LPat RdrName -> HsPatSynDir RdrName -> HsBind RdrName + -> LPat GhcPs -> HsPatSynDir GhcPs -> HsBind GhcPs mkPatSynBind name details lpat dir = PatSynBind psb where psb = PSB{ psb_id = name @@ -744,8 +749,8 @@ isInfixFunBind _ = False ------------ -mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName] - -> LHsExpr RdrName -> LHsBind RdrName +mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat GhcPs] + -> LHsExpr GhcPs -> LHsBind GhcPs mk_easy_FunBind loc fun pats expr = L loc $ mkFunBind (L loc fun) [mkMatch (mkPrefixFunRhs (L loc fun)) pats expr @@ -756,8 +761,8 @@ mkPrefixFunRhs :: Located id -> HsMatchContext id mkPrefixFunRhs n = FunRhs n Prefix ------------ -mkMatch :: HsMatchContext (NameOrRdrName id) -> [LPat id] -> LHsExpr id - -> Located (HsLocalBinds id) -> LMatch id (LHsExpr id) +mkMatch :: HsMatchContext (NameOrRdrName (IdP p)) -> [LPat p] -> LHsExpr p + -> Located (HsLocalBinds p) -> LMatch p (LHsExpr p) mkMatch ctxt pats expr lbinds = noLoc (Match ctxt (map paren pats) Nothing (GRHSs (unguardedRHS noSrcSpan expr) lbinds)) @@ -840,7 +845,7 @@ is a lifted function type, with no trouble at all. -- bind that binds an unlifted variable, but we must be careful around -- AbsBinds. See Note [Unlifted id check in isUnliftedHsBind]. For usage -- information, see Note [Strict binds check] is DsBinds. -isUnliftedHsBind :: HsBind Id -> Bool -- works only over typechecked binds +isUnliftedHsBind :: HsBind GhcTc -> Bool -- works only over typechecked binds isUnliftedHsBind (AbsBindsSig { abs_sig_export = id }) = isUnliftedType (idType id) isUnliftedHsBind bind @@ -854,40 +859,40 @@ isUnliftedHsBind bind -- would get type forall a. Num a => (# a, Bool #) -- and we want to reject that. See Trac #9140 -collectLocalBinders :: HsLocalBindsLR idL idR -> [idL] +collectLocalBinders :: HsLocalBindsLR idL idR -> [IdP idL] collectLocalBinders (HsValBinds binds) = collectHsIdBinders binds -- No pattern synonyms here collectLocalBinders (HsIPBinds _) = [] collectLocalBinders EmptyLocalBinds = [] -collectHsIdBinders, collectHsValBinders :: HsValBindsLR idL idR -> [idL] +collectHsIdBinders, collectHsValBinders :: HsValBindsLR idL idR -> [IdP idL] -- Collect Id binders only, or Ids + pattern synonyms, respectively collectHsIdBinders = collect_hs_val_binders True collectHsValBinders = collect_hs_val_binders False -collectHsBindBinders :: HsBindLR idL idR -> [idL] +collectHsBindBinders :: HsBindLR idL idR -> [IdP idL] -- Collect both Ids and pattern-synonym binders collectHsBindBinders b = collect_bind False b [] -collectHsBindsBinders :: LHsBindsLR idL idR -> [idL] +collectHsBindsBinders :: LHsBindsLR idL idR -> [IdP idL] collectHsBindsBinders binds = collect_binds False binds [] -collectHsBindListBinders :: [LHsBindLR idL idR] -> [idL] +collectHsBindListBinders :: [LHsBindLR idL idR] -> [IdP idL] -- Same as collectHsBindsBinders, but works over a list of bindings collectHsBindListBinders = foldr (collect_bind False . unLoc) [] -collect_hs_val_binders :: Bool -> HsValBindsLR idL idR -> [idL] +collect_hs_val_binders :: Bool -> HsValBindsLR idL idR -> [IdP idL] collect_hs_val_binders ps (ValBindsIn binds _) = collect_binds ps binds [] collect_hs_val_binders ps (ValBindsOut binds _) = collect_out_binds ps binds -collect_out_binds :: Bool -> [(RecFlag, LHsBinds id)] -> [id] +collect_out_binds :: Bool -> [(RecFlag, LHsBinds p)] -> [IdP p] collect_out_binds ps = foldr (collect_binds ps . snd) [] -collect_binds :: Bool -> LHsBindsLR idL idR -> [idL] -> [idL] +collect_binds :: Bool -> LHsBindsLR idL idR -> [IdP idL] -> [IdP idL] -- Collect Ids, or Ids + pattern synonyms, depending on boolean flag collect_binds ps binds acc = foldrBag (collect_bind ps . unLoc) acc binds -collect_bind :: Bool -> HsBindLR idL idR -> [idL] -> [idL] +collect_bind :: Bool -> HsBindLR idL idR -> [IdP idL] -> [IdP idL] collect_bind _ (PatBind { pat_lhs = p }) acc = collect_lpat p acc collect_bind _ (FunBind { fun_id = L _ f }) acc = f : acc collect_bind _ (VarBind { var_id = f }) acc = f : acc @@ -900,7 +905,7 @@ collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc | omitPatSyn = acc | otherwise = ps : acc -collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName] +collectMethodBinders :: LHsBindsLR GhcPs idR -> [Located RdrName] -- Used exclusively for the bindings of an instance decl which are all FunBinds collectMethodBinders binds = foldrBag (get . unLoc) [] binds where @@ -909,16 +914,16 @@ collectMethodBinders binds = foldrBag (get . unLoc) [] binds -- Someone else complains about non-FunBinds ----------------- Statements -------------------------- -collectLStmtsBinders :: [LStmtLR idL idR body] -> [idL] +collectLStmtsBinders :: [LStmtLR idL idR body] -> [IdP idL] collectLStmtsBinders = concatMap collectLStmtBinders -collectStmtsBinders :: [StmtLR idL idR body] -> [idL] +collectStmtsBinders :: [StmtLR idL idR body] -> [IdP idL] collectStmtsBinders = concatMap collectStmtBinders -collectLStmtBinders :: LStmtLR idL idR body -> [idL] +collectLStmtBinders :: LStmtLR idL idR body -> [IdP idL] collectLStmtBinders = collectStmtBinders . unLoc -collectStmtBinders :: StmtLR idL idR body -> [idL] +collectStmtBinders :: StmtLR idL idR body -> [IdP idL] -- Id Binders for a Stmt... [but what about pattern-sig type vars]? collectStmtBinders (BindStmt pat _ _ _ _)= collectPatBinders pat collectStmtBinders (LetStmt (L _ binds)) = collectLocalBinders binds @@ -932,14 +937,14 @@ collectStmtBinders ApplicativeStmt{} = [] ----------------- Patterns -------------------------- -collectPatBinders :: LPat a -> [a] +collectPatBinders :: LPat a -> [IdP a] collectPatBinders pat = collect_lpat pat [] -collectPatsBinders :: [LPat a] -> [a] +collectPatsBinders :: [LPat a] -> [IdP a] collectPatsBinders pats = foldr collect_lpat [] pats ------------- -collect_lpat :: LPat name -> [name] -> [name] +collect_lpat :: LPat pass -> [IdP pass] -> [IdP pass] collect_lpat (L _ pat) bndrs = go pat where @@ -999,14 +1004,14 @@ variables bound by the lazy pattern are n,m, *not* the dictionary d. So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound. -} -hsGroupBinders :: HsGroup Name -> [Name] +hsGroupBinders :: HsGroup GhcRn -> [Name] hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, hs_fords = foreign_decls }) = collectHsValBinders val_decls ++ hsTyClForeignBinders tycl_decls foreign_decls -hsTyClForeignBinders :: [TyClGroup Name] - -> [LForeignDecl Name] +hsTyClForeignBinders :: [TyClGroup GhcRn] + -> [LForeignDecl GhcRn] -> [Name] -- We need to look at instance declarations too, -- because their associated types may bind data constructors @@ -1017,13 +1022,13 @@ hsTyClForeignBinders tycl_decls foreign_decls `mappend` foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls) where - getSelectorNames :: ([Located Name], [LFieldOcc Name]) -> [Name] + getSelectorNames :: ([Located Name], [LFieldOcc GhcRn]) -> [Name] getSelectorNames (ns, fs) = map unLoc ns ++ map (selectorFieldOcc.unLoc) fs ------------------- -hsLTyClDeclBinders :: Located (TyClDecl name) -> ([Located name], [LFieldOcc name]) +hsLTyClDeclBinders :: Located (TyClDecl pass) + -> ([Located (IdP pass)], [LFieldOcc pass]) -- ^ Returns all the /binding/ names of the decl. The first one is - -- guaranteed to be the name of the decl. The first component -- represents all binding names except record fields; the second -- represents field occurrences. For record fields mentioned in @@ -1045,7 +1050,7 @@ hsLTyClDeclBinders (L loc (DataDecl { tcdLName = L _ name, tcdDataDefn = defn = (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn ------------------- -hsForeignDeclsBinders :: [LForeignDecl name] -> [Located name] +hsForeignDeclsBinders :: [LForeignDecl pass] -> [Located (IdP pass)] -- See Note [SrcSpan for binders] hsForeignDeclsBinders foreign_decls = [ L decl_loc n @@ -1053,14 +1058,14 @@ hsForeignDeclsBinders foreign_decls ------------------- -hsPatSynSelectors :: HsValBinds id -> [id] +hsPatSynSelectors :: HsValBinds p -> [IdP p] -- Collects record pattern-synonym selectors only; the pattern synonym -- names are collected by collectHsValBinders. hsPatSynSelectors (ValBindsIn _ _) = panic "hsPatSynSelectors" hsPatSynSelectors (ValBindsOut binds _) = foldrBag addPatSynSelector [] . unionManyBags $ map snd binds -addPatSynSelector:: LHsBind id -> [id] -> [id] +addPatSynSelector:: LHsBind p -> [IdP p] -> [IdP p] addPatSynSelector bind sels | L _ (PatSynBind (PSB { psb_args = RecordPatSyn as })) <- bind = map (unLoc . recordPatSynSelectorId) as ++ sels @@ -1072,7 +1077,8 @@ getPatSynBinds binds , L _ (PatSynBind psb) <- bagToList lbinds ] ------------------- -hsLInstDeclBinders :: LInstDecl name -> ([Located name], [LFieldOcc name]) +hsLInstDeclBinders :: LInstDecl pass + -> ([Located (IdP pass)], [LFieldOcc pass]) hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } })) = foldMap (hsDataFamInstBinders . unLoc) dfis hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi })) @@ -1081,26 +1087,27 @@ hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty ------------------- -- the SrcLoc returned are for the whole declarations, not just the names -hsDataFamInstBinders :: DataFamInstDecl name -> ([Located name], [LFieldOcc name]) +hsDataFamInstBinders :: DataFamInstDecl pass + -> ([Located (IdP pass)], [LFieldOcc pass]) hsDataFamInstBinders (DataFamInstDecl { dfid_defn = defn }) = hsDataDefnBinders defn -- There can't be repeated symbols because only data instances have binders ------------------- -- the SrcLoc returned are for the whole declarations, not just the names -hsDataDefnBinders :: HsDataDefn name -> ([Located name], [LFieldOcc name]) +hsDataDefnBinders :: HsDataDefn pass -> ([Located (IdP pass)], [LFieldOcc pass]) hsDataDefnBinders (HsDataDefn { dd_cons = cons }) = hsConDeclsBinders cons -- See Note [Binders in family instances] ------------------- -hsConDeclsBinders :: [LConDecl name] -> ([Located name], [LFieldOcc name]) +hsConDeclsBinders :: [LConDecl pass] -> ([Located (IdP pass)], [LFieldOcc pass]) -- See hsLTyClDeclBinders for what this does -- The function is boringly complicated because of the records -- And since we only have equality, we have to be a little careful hsConDeclsBinders cons = go id cons - where go :: ([LFieldOcc name] -> [LFieldOcc name]) - -> [LConDecl name] -> ([Located name], [LFieldOcc name]) + where go :: ([LFieldOcc pass] -> [LFieldOcc pass]) + -> [LConDecl pass] -> ([Located (IdP pass)], [LFieldOcc pass]) go _ [] = ([], []) go remSeen (r:rs) = -- don't re-mangle the location of field names, because we don't @@ -1176,13 +1183,13 @@ The main purpose is to find names introduced by record wildcards so that we can warning the user when they don't use those names (#4404) -} -lStmtsImplicits :: [LStmtLR Name idR (Located (body idR))] -> NameSet +lStmtsImplicits :: [LStmtLR GhcRn idR (Located (body idR))] -> NameSet lStmtsImplicits = hs_lstmts where - hs_lstmts :: [LStmtLR Name idR (Located (body idR))] -> NameSet + hs_lstmts :: [LStmtLR GhcRn idR (Located (body idR))] -> NameSet hs_lstmts = foldr (\stmt rest -> unionNameSet (hs_stmt (unLoc stmt)) rest) emptyNameSet - hs_stmt :: StmtLR Name idR (Located (body idR)) -> NameSet + hs_stmt :: StmtLR GhcRn idR (Located (body idR)) -> NameSet hs_stmt (BindStmt pat _ _ _ _) = lPatImplicits pat hs_stmt (ApplicativeStmt args _ _) = unionNameSets (map do_arg args) where do_arg (_, ApplicativeArgOne pat _) = lPatImplicits pat @@ -1198,19 +1205,19 @@ lStmtsImplicits = hs_lstmts hs_local_binds (HsIPBinds _) = emptyNameSet hs_local_binds EmptyLocalBinds = emptyNameSet -hsValBindsImplicits :: HsValBindsLR Name idR -> NameSet +hsValBindsImplicits :: HsValBindsLR GhcRn idR -> NameSet hsValBindsImplicits (ValBindsOut binds _) = foldr (unionNameSet . lhsBindsImplicits . snd) emptyNameSet binds hsValBindsImplicits (ValBindsIn binds _) = lhsBindsImplicits binds -lhsBindsImplicits :: LHsBindsLR Name idR -> NameSet +lhsBindsImplicits :: LHsBindsLR GhcRn idR -> NameSet lhsBindsImplicits = foldBag unionNameSet (lhs_bind . unLoc) emptyNameSet where lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat lhs_bind _ = emptyNameSet -lPatImplicits :: LPat Name -> NameSet +lPatImplicits :: LPat GhcRn -> NameSet lPatImplicits = hs_lpat where hs_lpat (L _ pat) = hs_pat pat diff --git a/compiler/hsSyn/PlaceHolder.hs b/compiler/hsSyn/PlaceHolder.hs index 2e195df799..5c716d259c 100644 --- a/compiler/hsSyn/PlaceHolder.hs +++ b/compiler/hsSyn/PlaceHolder.hs @@ -12,14 +12,8 @@ import Name import NameSet import RdrName import Var -import Coercion -import ConLike (ConLike) -import FieldLabel -import SrcLoc (Located) -import TcEvidence ( HsWrapper ) import Data.Data hiding ( Fixity ) -import BasicTypes (Fixity) {- @@ -37,18 +31,6 @@ import BasicTypes (Fixity) data PlaceHolder = PlaceHolder deriving (Data) --- | Types that are not defined until after type checking -type family PostTc id ty -- Note [Pass sensitive types] -type instance PostTc Id ty = ty -type instance PostTc Name ty = PlaceHolder -type instance PostTc RdrName ty = PlaceHolder - --- | Types that are not defined until after renaming -type family PostRn id ty -- Note [Pass sensitive types] -type instance PostRn Id ty = ty -type instance PostRn Name ty = ty -type instance PostRn RdrName ty = PlaceHolder - placeHolderKind :: PlaceHolder placeHolderKind = PlaceHolder @@ -103,31 +85,6 @@ DataId constraint type based on this, so even though it is safe the UndecidableInstances pragma is required where this is used. -} -type DataId id = - ( DataIdPost id - , DataIdPost (NameOrRdrName id) - ) - -type DataIdPost id = - ( Data id - , Data (PostRn id NameSet) - , Data (PostRn id Fixity) - , Data (PostRn id Bool) - , Data (PostRn id Name) - , Data (PostRn id (Located Name)) - , Data (PostRn id [Name]) - - , Data (PostRn id id) - , Data (PostTc id Type) - , Data (PostTc id Coercion) - , Data (PostTc id id) - , Data (PostTc id [Type]) - , Data (PostTc id ConLike) - , Data (PostTc id [ConLike]) - , Data (PostTc id HsWrapper) - , Data (PostTc id [FieldLabel]) - ) - -- |Follow the @id@, but never beyond Name. This is used in a 'HsMatchContext', -- for printing messages related to a 'Match' @@ -135,10 +92,3 @@ type family NameOrRdrName id where NameOrRdrName Id = Name NameOrRdrName Name = Name NameOrRdrName RdrName = RdrName - --- |Constraint type to bundle up the requirement for 'OutputableBndr' on both --- the @id@ and the 'NameOrRdrName' type for it -type OutputableBndrId id = - ( OutputableBndr id - , OutputableBndr (NameOrRdrName id) - ) diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 48767bf12d..af00dab4f2 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -831,10 +831,10 @@ instance TypecheckedMod DesugaredModule where instance DesugaredMod DesugaredModule where coreModule m = dm_core_module m -type ParsedSource = Located (HsModule RdrName) -type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name], +type ParsedSource = Located (HsModule GhcPs) +type RenamedSource = (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [LIE GhcRn], Maybe LHsDocString) -type TypecheckedSource = LHsBinds Id +type TypecheckedSource = LHsBinds GhcTc -- NOTE: -- - things that aren't in the output of the typechecker right now: @@ -1481,7 +1481,7 @@ lookupName name = parser :: String -- ^ Haskell module source text (full Unicode is supported) -> DynFlags -- ^ the flags -> FilePath -- ^ the filename (for source locations) - -> (WarningMessages, Either ErrorMessages (Located (HsModule RdrName))) + -> (WarningMessages, Either ErrorMessages (Located (HsModule GhcPs))) parser str dflags filename = let diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index c69e0f331d..be38e53f3d 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -18,7 +18,6 @@ module HeaderInfo ( getImports #include "HsVersions.h" -import RdrName import HscTypes import Parser ( parseHeader ) import Lexer @@ -99,8 +98,8 @@ getImports dflags buf filename source_filename = do mkPrelImports :: ModuleName -> SrcSpan -- Attribute the "import Prelude" to this location - -> Bool -> [LImportDecl RdrName] - -> [LImportDecl RdrName] + -> Bool -> [LImportDecl GhcPs] + -> [LImportDecl GhcPs] -- Construct the implicit declaration "import Prelude" (or not) -- -- NB: opt_NoImplicitPrelude is slightly different to import Prelude (); @@ -119,7 +118,7 @@ mkPrelImports this_mod loc implicit_prelude import_decls <- import_decls , unLoc mod == pRELUDE_NAME ] - preludeImportDecl :: LImportDecl RdrName + preludeImportDecl :: LImportDecl GhcPs preludeImportDecl = L loc $ ImportDecl { ideclSourceSrc = NoSourceText, ideclName = L loc pRELUDE_NAME, diff --git a/compiler/main/Hooks.hs b/compiler/main/Hooks.hs index eefdde4b88..59126e98d5 100644 --- a/compiler/main/Hooks.hs +++ b/compiler/main/Hooks.hs @@ -26,23 +26,24 @@ module Hooks ( Hooks ) where import DynFlags -import Name import PipelineMonad import HscTypes import HsDecls import HsBinds import HsExpr import OrdList -import Id import TcRnTypes import Bag import RdrName +import Name +import Id import CoreSyn import GHCi.RemoteTypes import SrcLoc import Type import System.Process import BasicTypes +import HsExtension import Data.Maybe @@ -75,17 +76,24 @@ emptyHooks = Hooks } data Hooks = Hooks - { dsForeignsHook :: Maybe ([LForeignDecl Id] -> DsM (ForeignStubs, OrdList (Id, CoreExpr))) - , tcForeignImportsHook :: Maybe ([LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id], Bag GlobalRdrElt)) - , tcForeignExportsHook :: Maybe ([LForeignDecl Name] -> TcM (LHsBinds TcId, [LForeignDecl TcId], Bag GlobalRdrElt)) + { dsForeignsHook :: Maybe ([LForeignDecl GhcTc] + -> DsM (ForeignStubs, OrdList (Id, CoreExpr))) + , tcForeignImportsHook :: Maybe ([LForeignDecl GhcRn] + -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)) + , tcForeignExportsHook :: Maybe ([LForeignDecl GhcRn] + -> TcM (LHsBinds GhcTcId, [LForeignDecl GhcTcId], Bag GlobalRdrElt)) , hscFrontendHook :: Maybe (ModSummary -> Hsc FrontendResult) - , hscCompileCoreExprHook :: Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue) + , hscCompileCoreExprHook :: + Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue) , ghcPrimIfaceHook :: Maybe ModIface - , runPhaseHook :: Maybe (PhasePlus -> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath)) + , runPhaseHook :: Maybe (PhasePlus -> FilePath -> DynFlags + -> CompPipeline (PhasePlus, FilePath)) , runMetaHook :: Maybe (MetaHook TcM) - , linkHook :: Maybe (GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag) - , runRnSpliceHook :: Maybe (HsSplice Name -> RnM (HsSplice Name)) - , getValueSafelyHook :: Maybe (HscEnv -> Name -> Type -> IO (Maybe HValue)) + , linkHook :: Maybe (GhcLink -> DynFlags -> Bool + -> HomePackageTable -> IO SuccessFlag) + , runRnSpliceHook :: Maybe (HsSplice GhcRn -> RnM (HsSplice GhcRn)) + , getValueSafelyHook :: Maybe (HscEnv -> Name -> Type + -> IO (Maybe HValue)) , createIservProcessHook :: Maybe (CreateProcess -> IO ProcessHandle) } diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index f4ca3a8b34..d2b6e5bd6e 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -292,7 +292,7 @@ hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do -- ----------------------------------------------------------------------------- -- | Rename some import declarations -hscRnImportDecls :: HscEnv -> [LImportDecl RdrName] -> IO GlobalRdrEnv +hscRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do hsc_env <- getHscEnv ioMsgMaybe $ tcRnImportDecls hsc_env import_decls @@ -382,7 +382,7 @@ hscParse' mod_summary -- can become a Nothing and decide whether this should instead throw an -- exception/signal an error. type RenamedStuff = - (Maybe (HsGroup Name, [LImportDecl Name], Maybe [LIE Name], + (Maybe (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [LIE GhcRn], Maybe LHsDocString)) -- | Rename and typecheck a module, additionally returning the renamed syntax @@ -1495,7 +1495,7 @@ hscStmtWithLocation hsc_env0 stmt source linenumber = liftIO $ hscParsedStmt hsc_env parsed_stmt hscParsedStmt :: HscEnv - -> GhciLStmt RdrName -- ^ The parsed statement + -> GhciLStmt GhcPs -- ^ The parsed statement -> IO ( Maybe ([Id] , ForeignHValue {- IO [HValue] -} , FixityEnv)) @@ -1631,7 +1631,7 @@ hscAddSptEntries hsc_env entries = do -} -hscImport :: HscEnv -> String -> IO (ImportDecl RdrName) +hscImport :: HscEnv -> String -> IO (ImportDecl GhcPs) hscImport hsc_env str = runInteractiveHsc hsc_env $ do (L _ (HsModule{hsmodImports=is})) <- hscParseThing parseModule str @@ -1663,7 +1663,7 @@ hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do ty <- hscParseType str ioMsgMaybe $ tcRnType hsc_env normalise ty -hscParseExpr :: String -> Hsc (LHsExpr RdrName) +hscParseExpr :: String -> Hsc (LHsExpr GhcPs) hscParseExpr expr = do hsc_env <- getHscEnv maybe_stmt <- hscParseStmt expr @@ -1672,15 +1672,15 @@ hscParseExpr expr = do _ -> throwErrors $ unitBag $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan (text "not an expression:" <+> quotes (text expr)) -hscParseStmt :: String -> Hsc (Maybe (GhciLStmt RdrName)) +hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs)) hscParseStmt = hscParseThing parseStmt hscParseStmtWithLocation :: String -> Int -> String - -> Hsc (Maybe (GhciLStmt RdrName)) + -> Hsc (Maybe (GhciLStmt GhcPs)) hscParseStmtWithLocation source linenumber stmt = hscParseThingWithLocation source linenumber parseStmt stmt -hscParseType :: String -> Hsc (LHsType RdrName) +hscParseType :: String -> Hsc (LHsType GhcPs) hscParseType = hscParseThing parseType hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName) diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs index 241dfd8095..598cb5be0a 100644 --- a/compiler/main/HscStats.hs +++ b/compiler/main/HscStats.hs @@ -11,7 +11,6 @@ module HscStats ( ppSourceStats ) where import Bag import HsSyn import Outputable -import RdrName import SrcLoc import Util @@ -19,7 +18,7 @@ import Data.Char import Data.Foldable (foldl') -- | Source Statistics -ppSourceStats :: Bool -> Located (HsModule RdrName) -> SDoc +ppSourceStats :: Bool -> Located (HsModule GhcPs) -> SDoc ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) = (if short then hcat else vcat) (map pp_val diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index 62ae8cce5a..70af19de9b 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -701,35 +701,35 @@ hptObjs hpt = concat (map (maybe [] linkableObjs . hm_linkable) (eltsHpt hpt)) -- | The supported metaprogramming result types data MetaRequest - = MetaE (LHsExpr RdrName -> MetaResult) - | MetaP (LPat RdrName -> MetaResult) - | MetaT (LHsType RdrName -> MetaResult) - | MetaD ([LHsDecl RdrName] -> MetaResult) - | MetaAW (Serialized -> MetaResult) + = MetaE (LHsExpr GhcPs -> MetaResult) + | MetaP (LPat GhcPs -> MetaResult) + | MetaT (LHsType GhcPs -> MetaResult) + | MetaD ([LHsDecl GhcPs] -> MetaResult) + | MetaAW (Serialized -> MetaResult) -- | data constructors not exported to ensure correct result type data MetaResult - = MetaResE { unMetaResE :: LHsExpr RdrName } - | MetaResP { unMetaResP :: LPat RdrName } - | MetaResT { unMetaResT :: LHsType RdrName } - | MetaResD { unMetaResD :: [LHsDecl RdrName] } + = MetaResE { unMetaResE :: LHsExpr GhcPs } + | MetaResP { unMetaResP :: LPat GhcPs } + | MetaResT { unMetaResT :: LHsType GhcPs } + | MetaResD { unMetaResD :: [LHsDecl GhcPs] } | MetaResAW { unMetaResAW :: Serialized } -type MetaHook f = MetaRequest -> LHsExpr Id -> f MetaResult +type MetaHook f = MetaRequest -> LHsExpr GhcTc -> f MetaResult -metaRequestE :: Functor f => MetaHook f -> LHsExpr Id -> f (LHsExpr RdrName) +metaRequestE :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LHsExpr GhcPs) metaRequestE h = fmap unMetaResE . h (MetaE MetaResE) -metaRequestP :: Functor f => MetaHook f -> LHsExpr Id -> f (LPat RdrName) +metaRequestP :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LPat GhcPs) metaRequestP h = fmap unMetaResP . h (MetaP MetaResP) -metaRequestT :: Functor f => MetaHook f -> LHsExpr Id -> f (LHsType RdrName) +metaRequestT :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LHsType GhcPs) metaRequestT h = fmap unMetaResT . h (MetaT MetaResT) -metaRequestD :: Functor f => MetaHook f -> LHsExpr Id -> f [LHsDecl RdrName] +metaRequestD :: Functor f => MetaHook f -> LHsExpr GhcTc -> f [LHsDecl GhcPs] metaRequestD h = fmap unMetaResD . h (MetaD MetaResD) -metaRequestAW :: Functor f => MetaHook f -> LHsExpr Id -> f Serialized +metaRequestAW :: Functor f => MetaHook f -> LHsExpr GhcTc -> f Serialized metaRequestAW h = fmap unMetaResAW . h (MetaAW MetaResAW) {- @@ -1545,7 +1545,7 @@ data InteractiveContext } data InteractiveImport - = IIDecl (ImportDecl RdrName) + = IIDecl (ImportDecl GhcPs) -- ^ Bring the exports of a particular module -- (filtered by an import decl) into scope @@ -2936,7 +2936,7 @@ instance Binary IfaceTrustInfo where -} data HsParsedModule = HsParsedModule { - hpm_module :: Located (HsModule RdrName), + hpm_module :: Located (HsModule GhcPs), hpm_src_files :: [FilePath], -- ^ extra source files (e.g. from #includes). The lexer collects -- these from '# <file> <line>' pragmas, which the C preprocessor diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 8b5a6b6af7..8e396cc16a 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -246,7 +246,7 @@ withVirtualCWD m = do gbracket set_cwd reset_cwd $ \_ -> m -parseImportDecl :: GhcMonad m => String -> m (ImportDecl RdrName) +parseImportDecl :: GhcMonad m => String -> m (ImportDecl GhcPs) parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr emptyHistory :: Int -> BoundedList History @@ -674,7 +674,7 @@ findGlobalRdrEnv hsc_env imports ([], imods_env) -> Right (foldr plusGlobalRdrEnv idecls_env imods_env) (err : _, _) -> Left err } where - idecls :: [LImportDecl RdrName] + idecls :: [LImportDecl GhcPs] idecls = [noLoc d | IIDecl d <- imports] imods :: [ModuleName] @@ -841,7 +841,7 @@ typeKind normalise str = withSession $ \hsc_env -> do -- | Parse an expression, the parsed expression can be further processed and -- passed to compileParsedExpr. -parseExpr :: GhcMonad m => String -> m (LHsExpr RdrName) +parseExpr :: GhcMonad m => String -> m (LHsExpr GhcPs) parseExpr expr = withSession $ \hsc_env -> do liftIO $ runInteractiveHsc hsc_env $ hscParseExpr expr @@ -859,7 +859,7 @@ compileExprRemote expr = do -- | Compile an parsed expression (before renaming), run it and deliver -- the resulting HValue. -compileParsedExprRemote :: GhcMonad m => LHsExpr RdrName -> m ForeignHValue +compileParsedExprRemote :: GhcMonad m => LHsExpr GhcPs -> m ForeignHValue compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do -- > let _compileParsedExpr = expr -- Create let stmt from expr to make hscParsedStmt happy. @@ -879,7 +879,7 @@ compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do liftIO $ throwIO (fromSerializableException e) _ -> panic "compileParsedExpr" -compileParsedExpr :: GhcMonad m => LHsExpr RdrName -> m HValue +compileParsedExpr :: GhcMonad m => LHsExpr GhcPs -> m HValue compileParsedExpr expr = do fhv <- compileParsedExprRemote expr dflags <- getDynFlags diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 7af02053fd..02aeb86180 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -661,7 +661,7 @@ unitdecl :: { LHsUnitDecl PackageName } -- either, and DEPRECATED is only expected to be used by people who really -- know what they are doing. :-) -signature :: { Located (HsModule RdrName) } +signature :: { Located (HsModule GhcPs) } : maybedocheader 'signature' modid maybemodwarning maybeexports 'where' body {% fileSrcSpan >>= \ loc -> ams (L loc (HsModule (Just $3) $5 (fst $ snd $7) @@ -669,7 +669,7 @@ signature :: { Located (HsModule RdrName) } ) ([mj AnnSignature $2, mj AnnWhere $6] ++ fst $7) } -module :: { Located (HsModule RdrName) } +module :: { Located (HsModule GhcPs) } : maybedocheader 'module' modid maybemodwarning maybeexports 'where' body {% fileSrcSpan >>= \ loc -> ams (L loc (HsModule (Just $3) $5 (fst $ snd $7) @@ -702,23 +702,23 @@ maybemodwarning :: { Maybe (Located WarningTxt) } | {- empty -} { Nothing } body :: { ([AddAnn] - ,([LImportDecl RdrName], [LHsDecl RdrName])) } + ,([LImportDecl GhcPs], [LHsDecl GhcPs])) } : '{' top '}' { (moc $1:mcc $3:(fst $2) , snd $2) } | vocurly top close { (fst $2, snd $2) } body2 :: { ([AddAnn] - ,([LImportDecl RdrName], [LHsDecl RdrName])) } + ,([LImportDecl GhcPs], [LHsDecl GhcPs])) } : '{' top '}' { (moc $1:mcc $3 :(fst $2), snd $2) } | missing_module_keyword top close { ([],snd $2) } top :: { ([AddAnn] - ,([LImportDecl RdrName], [LHsDecl RdrName])) } + ,([LImportDecl GhcPs], [LHsDecl GhcPs])) } : semis top1 { ($1, $2) } -top1 :: { ([LImportDecl RdrName], [LHsDecl RdrName]) } +top1 :: { ([LImportDecl GhcPs], [LHsDecl GhcPs]) } : importdecls_semi topdecls_semi { (reverse $1, cvTopDecls $2) } | importdecls_semi topdecls { (reverse $1, cvTopDecls $2) } | importdecls { (reverse $1, []) } @@ -726,7 +726,7 @@ top1 :: { ([LImportDecl RdrName], [LHsDecl RdrName]) } ----------------------------------------------------------------------------- -- Module declaration & imports only -header :: { Located (HsModule RdrName) } +header :: { Located (HsModule GhcPs) } : maybedocheader 'module' modid maybemodwarning maybeexports 'where' header_body {% fileSrcSpan >>= \ loc -> ams (L loc (HsModule (Just $3) $5 $7 [] $4 $1 @@ -740,35 +740,35 @@ header :: { Located (HsModule RdrName) } return (L loc (HsModule Nothing Nothing $1 [] Nothing Nothing)) } -header_body :: { [LImportDecl RdrName] } +header_body :: { [LImportDecl GhcPs] } : '{' header_top { $2 } | vocurly header_top { $2 } -header_body2 :: { [LImportDecl RdrName] } +header_body2 :: { [LImportDecl GhcPs] } : '{' header_top { $2 } | missing_module_keyword header_top { $2 } -header_top :: { [LImportDecl RdrName] } +header_top :: { [LImportDecl GhcPs] } : semis header_top_importdecls { $2 } -header_top_importdecls :: { [LImportDecl RdrName] } +header_top_importdecls :: { [LImportDecl GhcPs] } : importdecls_semi { $1 } | importdecls { $1 } ----------------------------------------------------------------------------- -- The Export List -maybeexports :: { (Maybe (Located [LIE RdrName])) } +maybeexports :: { (Maybe (Located [LIE GhcPs])) } : '(' exportlist ')' {% ams (sLL $1 $> ()) [mop $1,mcp $3] >> return (Just (sLL $1 $> (fromOL $2))) } | {- empty -} { Nothing } -exportlist :: { OrdList (LIE RdrName) } +exportlist :: { OrdList (LIE GhcPs) } : expdoclist ',' expdoclist {% addAnnotation (oll $1) AnnComma (gl $2) >> return ($1 `appOL` $3) } | exportlist1 { $1 } -exportlist1 :: { OrdList (LIE RdrName) } +exportlist1 :: { OrdList (LIE GhcPs) } : expdoclist export expdoclist ',' exportlist1 {% (addAnnotation (oll ($1 `appOL` $2 `appOL` $3)) AnnComma (gl $4) ) >> @@ -776,11 +776,11 @@ exportlist1 :: { OrdList (LIE RdrName) } | expdoclist export expdoclist { $1 `appOL` $2 `appOL` $3 } | expdoclist { $1 } -expdoclist :: { OrdList (LIE RdrName) } +expdoclist :: { OrdList (LIE GhcPs) } : exp_doc expdoclist { $1 `appOL` $2 } | {- empty -} { nilOL } -exp_doc :: { OrdList (LIE RdrName) } +exp_doc :: { OrdList (LIE GhcPs) } : docsection { unitOL (sL1 $1 (case (unLoc $1) of (n, doc) -> IEGroup n doc)) } | docnamed { unitOL (sL1 $1 (IEDocNamed ((fst . unLoc) $1))) } | docnext { unitOL (sL1 $1 (IEDoc (unLoc $1))) } @@ -788,7 +788,7 @@ exp_doc :: { OrdList (LIE RdrName) } -- No longer allow things like [] and (,,,) to be exported -- They are built in syntax, always available -export :: { OrdList (LIE RdrName) } +export :: { OrdList (LIE GhcPs) } : qcname_ext export_subspec {% mkModuleImpExp $1 (snd $ unLoc $2) >>= \ie -> amsu (sLL $1 $> ie) (fst $ unLoc $2) } | 'module' modid {% amsu (sLL $1 $> (IEModuleContents $2)) @@ -855,19 +855,19 @@ semis : semis ';' { mj AnnSemi $2 : $1 } | {- empty -} { [] } -- No trailing semicolons, non-empty -importdecls :: { [LImportDecl RdrName] } +importdecls :: { [LImportDecl GhcPs] } importdecls : importdecls_semi importdecl { $2 : $1 } -- May have trailing semicolons, can be empty -importdecls_semi :: { [LImportDecl RdrName] } +importdecls_semi :: { [LImportDecl GhcPs] } importdecls_semi : importdecls_semi importdecl semis1 {% ams $2 $3 >> return ($2 : $1) } | {- empty -} { [] } -importdecl :: { LImportDecl RdrName } +importdecl :: { LImportDecl GhcPs } : 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec {% ams (L (comb4 $1 $6 (snd $7) $8) $ ImportDecl { ideclSourceSrc = snd $ fst $2 @@ -907,14 +907,14 @@ maybeas :: { ([AddAnn],Located (Maybe (Located ModuleName))) } ,sLL $1 $> (Just $2)) } | {- empty -} { ([],noLoc Nothing) } -maybeimpspec :: { Located (Maybe (Bool, Located [LIE RdrName])) } +maybeimpspec :: { Located (Maybe (Bool, Located [LIE GhcPs])) } : impspec {% let (b, ie) = unLoc $1 in checkImportSpec ie >>= \checkedIe -> return (L (gl $1) (Just (b, checkedIe))) } | {- empty -} { noLoc Nothing } -impspec :: { Located (Bool, Located [LIE RdrName]) } +impspec :: { Located (Bool, Located [LIE GhcPs]) } : '(' exportlist ')' {% ams (sLL $1 $> (False, sLL $1 $> $ fromOL $2)) [mop $1,mcp $3] } @@ -944,15 +944,15 @@ ops :: { Located (OrdList (Located RdrName)) } -- Top-Level Declarations -- No trailing semicolons, non-empty -topdecls :: { OrdList (LHsDecl RdrName) } +topdecls :: { OrdList (LHsDecl GhcPs) } : topdecls_semi topdecl { $1 `snocOL` $2 } -- May have trailing semicolons, can be empty -topdecls_semi :: { OrdList (LHsDecl RdrName) } +topdecls_semi :: { OrdList (LHsDecl GhcPs) } : topdecls_semi topdecl semis1 {% ams $2 $3 >> return ($1 `snocOL` $2) } | {- empty -} { nilOL } -topdecl :: { LHsDecl RdrName } +topdecl :: { LHsDecl GhcPs } : cl_decl { sL1 $1 (TyClD (unLoc $1)) } | ty_decl { sL1 $1 (TyClD (unLoc $1)) } | inst_decl { sL1 $1 (InstD (unLoc $1)) } @@ -1007,14 +1007,14 @@ topdecl :: { LHsDecl RdrName } -- Type classes -- -cl_decl :: { LTyClDecl RdrName } +cl_decl :: { LTyClDecl GhcPs } : 'class' tycl_hdr fds where_cls {% amms (mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 (snd $ unLoc $4)) (mj AnnClass $1:(fst $ unLoc $3)++(fst $ unLoc $4)) } -- Type declarations (toplevel) -- -ty_decl :: { LTyClDecl RdrName } +ty_decl :: { LTyClDecl GhcPs } -- ordinary type synonyms : 'type' type '=' ctypedoc -- Note ctype, not sigtype, on the right of '=' @@ -1063,7 +1063,7 @@ ty_decl :: { LTyClDecl RdrName } (snd $ unLoc $4) Nothing) (mj AnnData $1:mj AnnFamily $2:(fst $ unLoc $4)) } -inst_decl :: { LInstDecl RdrName } +inst_decl :: { LInstDecl GhcPs } : 'instance' overlap_pragma inst_type where_inst {% do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc $4) ; let cid = ClsInstDecl { cid_poly_ty = $3, cid_binds = binds @@ -1120,12 +1120,12 @@ deriv_strategy :: { Maybe (Located DerivStrategy) } -- Injective type families -opt_injective_info :: { Located ([AddAnn], Maybe (LInjectivityAnn RdrName)) } +opt_injective_info :: { Located ([AddAnn], Maybe (LInjectivityAnn GhcPs)) } : {- empty -} { noLoc ([], Nothing) } | '|' injectivity_cond { sLL $1 $> ([mj AnnVbar $1] , Just ($2)) } -injectivity_cond :: { LInjectivityAnn RdrName } +injectivity_cond :: { LInjectivityAnn GhcPs } : tyvarid '->' inj_varids {% ams (sLL $1 $> (InjectivityAnn $1 (reverse (unLoc $3)))) [mu AnnRarrow $2] } @@ -1136,13 +1136,13 @@ inj_varids :: { Located [Located RdrName] } -- Closed type families -where_type_family :: { Located ([AddAnn],FamilyInfo RdrName) } +where_type_family :: { Located ([AddAnn],FamilyInfo GhcPs) } : {- empty -} { noLoc ([],OpenTypeFamily) } | 'where' ty_fam_inst_eqn_list { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2) ,ClosedTypeFamily (fmap reverse $ snd $ unLoc $2)) } -ty_fam_inst_eqn_list :: { Located ([AddAnn],Maybe [LTyFamInstEqn RdrName]) } +ty_fam_inst_eqn_list :: { Located ([AddAnn],Maybe [LTyFamInstEqn GhcPs]) } : '{' ty_fam_inst_eqns '}' { sLL $1 $> ([moc $1,mcc $3] ,Just (unLoc $2)) } | vocurly ty_fam_inst_eqns close { let L loc _ = $2 in @@ -1152,7 +1152,7 @@ ty_fam_inst_eqn_list :: { Located ([AddAnn],Maybe [LTyFamInstEqn RdrName]) } | vocurly '..' close { let L loc _ = $2 in L loc ([mj AnnDotdot $2],Nothing) } -ty_fam_inst_eqns :: { Located [LTyFamInstEqn RdrName] } +ty_fam_inst_eqns :: { Located [LTyFamInstEqn GhcPs] } : ty_fam_inst_eqns ';' ty_fam_inst_eqn {% asl (unLoc $1) $2 (snd $ unLoc $3) >> ams $3 (fst $ unLoc $3) @@ -1163,7 +1163,7 @@ ty_fam_inst_eqns :: { Located [LTyFamInstEqn RdrName] } >> return (sLL $1 $> [snd $ unLoc $1]) } | {- empty -} { noLoc [] } -ty_fam_inst_eqn :: { Located ([AddAnn],LTyFamInstEqn RdrName) } +ty_fam_inst_eqn :: { Located ([AddAnn],LTyFamInstEqn GhcPs) } : type '=' ctype -- Note the use of type for the head; this allows -- infix type constructors and type patterns @@ -1179,7 +1179,7 @@ ty_fam_inst_eqn :: { Located ([AddAnn],LTyFamInstEqn RdrName) } -- declarations without a kind signature cause parsing conflicts with empty -- data declarations. -- -at_decl_cls :: { LHsDecl RdrName } +at_decl_cls :: { LHsDecl GhcPs } : -- data family declarations, with optional 'family' keyword 'data' opt_family type opt_datafam_kind_sig {% amms (liftM mkTyClD (mkFamDecl (comb3 $1 $3 $4) DataFamily $3 @@ -1217,7 +1217,7 @@ opt_family :: { [AddAnn] } -- Associated type instances -- -at_decl_inst :: { LInstDecl RdrName } +at_decl_inst :: { LInstDecl GhcPs } -- type instance declarations : 'type' ty_fam_inst_eqn -- Note the use of type for the head; this allows @@ -1248,21 +1248,21 @@ data_or_newtype :: { Located (AddAnn, NewOrData) } -- Family result/return kind signatures -opt_kind_sig :: { Located ([AddAnn], Maybe (LHsKind RdrName)) } +opt_kind_sig :: { Located ([AddAnn], Maybe (LHsKind GhcPs)) } : { noLoc ([] , Nothing) } | '::' kind { sLL $1 $> ([mu AnnDcolon $1], Just $2) } -opt_datafam_kind_sig :: { Located ([AddAnn], LFamilyResultSig RdrName) } +opt_datafam_kind_sig :: { Located ([AddAnn], LFamilyResultSig GhcPs) } : { noLoc ([] , noLoc NoSig )} | '::' kind { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig $2))} -opt_tyfam_kind_sig :: { Located ([AddAnn], LFamilyResultSig RdrName) } +opt_tyfam_kind_sig :: { Located ([AddAnn], LFamilyResultSig GhcPs) } : { noLoc ([] , noLoc NoSig )} | '::' kind { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig $2))} | '=' tv_bndr { sLL $1 $> ([mj AnnEqual $1] , sLL $1 $> (TyVarSig $2))} -opt_at_kind_inj_sig :: { Located ([AddAnn], ( LFamilyResultSig RdrName - , Maybe (LInjectivityAnn RdrName)))} +opt_at_kind_inj_sig :: { Located ([AddAnn], ( LFamilyResultSig GhcPs + , Maybe (LInjectivityAnn GhcPs)))} : { noLoc ([], (noLoc NoSig, Nothing)) } | '::' kind { sLL $1 $> ( [mu AnnDcolon $1] , (sLL $2 $> (KindSig $2), Nothing)) } @@ -1277,7 +1277,7 @@ opt_at_kind_inj_sig :: { Located ([AddAnn], ( LFamilyResultSig RdrName -- (Eq a, Ord b) => T a b -- T Int [a] -- for associated types -- Rather a lot of inlining here, else we get reduce/reduce errors -tycl_hdr :: { Located (Maybe (LHsContext RdrName), LHsType RdrName) } +tycl_hdr :: { Located (Maybe (LHsContext GhcPs), LHsType GhcPs) } : context '=>' type {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2) >> (return (sLL $1 $> (Just $1, $3))) } @@ -1299,7 +1299,7 @@ capi_ctype : '{-# CTYPE' STRING STRING '#-}' -- Stand-alone deriving -- Glasgow extension: stand-alone deriving declarations -stand_alone_deriving :: { LDerivDecl RdrName } +stand_alone_deriving :: { LDerivDecl GhcPs } : 'deriving' deriv_strategy 'instance' overlap_pragma inst_type {% do { let { err = text "in the stand-alone deriving instance" <> colon <+> quotes (ppr $5) } @@ -1309,7 +1309,7 @@ stand_alone_deriving :: { LDerivDecl RdrName } ----------------------------------------------------------------------------- -- Role annotations -role_annot :: { LRoleAnnotDecl RdrName } +role_annot :: { LRoleAnnotDecl GhcPs } role_annot : 'type' 'role' oqtycon maybe_roles {% amms (mkRoleAnnotDecl (comb3 $1 $3 $4) $3 (reverse (unLoc $4))) [mj AnnType $1,mj AnnRole $2] } @@ -1331,7 +1331,7 @@ role : VARID { sL1 $1 $ Just $ getVARID $1 } -- Pattern synonyms -- Glasgow extension: pattern synonyms -pattern_synonym_decl :: { LHsDecl RdrName } +pattern_synonym_decl :: { LHsDecl GhcPs } : 'pattern' pattern_synonym_lhs '=' pat {% let (name, args,as ) = $2 in ams (sLL $1 $> . ValD $ mkPatSynBind name args $4 @@ -1367,13 +1367,13 @@ cvars1 :: { [RecordPatSynField (Located RdrName)] } return ((RecordPatSynField $1 $1) : $3 )} where_decls :: { Located ([AddAnn] - , Located (OrdList (LHsDecl RdrName))) } + , Located (OrdList (LHsDecl GhcPs))) } : 'where' '{' decls '}' { sLL $1 $> ((mj AnnWhere $1:moc $2 :mcc $4:(fst $ unLoc $3)),sL1 $3 (snd $ unLoc $3)) } | 'where' vocurly decls close { L (comb2 $1 $3) ((mj AnnWhere $1:(fst $ unLoc $3)) ,sL1 $3 (snd $ unLoc $3)) } -pattern_synonym_sig :: { LSig RdrName } +pattern_synonym_sig :: { LSig GhcPs } : 'pattern' con_list '::' sigtype {% ams (sLL $1 $> $ PatSynSig (unLoc $2) (mkLHsSigType $4)) [mj AnnPattern $1, mu AnnDcolon $3] } @@ -1383,7 +1383,7 @@ pattern_synonym_sig :: { LSig RdrName } -- Declaration in class bodies -- -decl_cls :: { LHsDecl RdrName } +decl_cls :: { LHsDecl GhcPs } decl_cls : at_decl_cls { $1 } | decl { $1 } @@ -1395,7 +1395,7 @@ decl_cls : at_decl_cls { $1 } ; ams (sLL $1 $> $ SigD $ ClassOpSig True [v] $ mkLHsSigType $4) [mj AnnDefault $1,mu AnnDcolon $3] } } -decls_cls :: { Located ([AddAnn],OrdList (LHsDecl RdrName)) } -- Reversed +decls_cls :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) } -- Reversed : decls_cls ';' decl_cls {% if isNilOL (snd $ unLoc $1) then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) , unitOL $3)) @@ -1412,7 +1412,7 @@ decls_cls :: { Located ([AddAnn],OrdList (LHsDecl RdrName)) } -- Reversed decllist_cls :: { Located ([AddAnn] - , OrdList (LHsDecl RdrName)) } -- Reversed + , OrdList (LHsDecl GhcPs)) } -- Reversed : '{' decls_cls '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2) ,snd $ unLoc $2) } | vocurly decls_cls close { $2 } @@ -1420,7 +1420,7 @@ decllist_cls -- Class body -- where_cls :: { Located ([AddAnn] - ,(OrdList (LHsDecl RdrName))) } -- Reversed + ,(OrdList (LHsDecl GhcPs))) } -- Reversed -- No implicit parameters -- May have type declarations : 'where' decllist_cls { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2) @@ -1429,11 +1429,11 @@ where_cls :: { Located ([AddAnn] -- Declarations in instance bodies -- -decl_inst :: { Located (OrdList (LHsDecl RdrName)) } +decl_inst :: { Located (OrdList (LHsDecl GhcPs)) } decl_inst : at_decl_inst { sLL $1 $> (unitOL (sL1 $1 (InstD (unLoc $1)))) } | decl { sLL $1 $> (unitOL $1) } -decls_inst :: { Located ([AddAnn],OrdList (LHsDecl RdrName)) } -- Reversed +decls_inst :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) } -- Reversed : decls_inst ';' decl_inst {% if isNilOL (snd $ unLoc $1) then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) , unLoc $3)) @@ -1451,14 +1451,14 @@ decls_inst :: { Located ([AddAnn],OrdList (LHsDecl RdrName)) } -- Reversed decllist_inst :: { Located ([AddAnn] - , OrdList (LHsDecl RdrName)) } -- Reversed + , OrdList (LHsDecl GhcPs)) } -- Reversed : '{' decls_inst '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2),snd $ unLoc $2) } | vocurly decls_inst close { L (gl $2) (unLoc $2) } -- Instance body -- where_inst :: { Located ([AddAnn] - , OrdList (LHsDecl RdrName)) } -- Reversed + , OrdList (LHsDecl GhcPs)) } -- Reversed -- No implicit parameters -- May have type declarations : 'where' decllist_inst { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2) @@ -1467,7 +1467,7 @@ where_inst :: { Located ([AddAnn] -- Declarations in binding groups other than classes and instances -- -decls :: { Located ([AddAnn],OrdList (LHsDecl RdrName)) } +decls :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) } : decls ';' decl {% if isNilOL (snd $ unLoc $1) then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) , unitOL $3)) @@ -1486,14 +1486,14 @@ decls :: { Located ([AddAnn],OrdList (LHsDecl RdrName)) } | decl { sL1 $1 ([], unitOL $1) } | {- empty -} { noLoc ([],nilOL) } -decllist :: { Located ([AddAnn],Located (OrdList (LHsDecl RdrName))) } +decllist :: { Located ([AddAnn],Located (OrdList (LHsDecl GhcPs))) } : '{' decls '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2) ,sL1 $2 $ snd $ unLoc $2) } | vocurly decls close { L (gl $2) (fst $ unLoc $2,sL1 $2 $ snd $ unLoc $2) } -- Binding groups other than those of class and instance declarations -- -binds :: { Located ([AddAnn],Located (HsLocalBinds RdrName)) } +binds :: { Located ([AddAnn],Located (HsLocalBinds GhcPs)) } -- May have implicit parameters -- No type declarations : decllist {% do { val_binds <- cvBindGroup (unLoc $ snd $ unLoc $1) @@ -1509,7 +1509,7 @@ binds :: { Located ([AddAnn],Located (HsLocalBinds RdrName)) } emptyTcEvBinds)) } -wherebinds :: { Located ([AddAnn],Located (HsLocalBinds RdrName)) } +wherebinds :: { Located ([AddAnn],Located (HsLocalBinds GhcPs)) } -- May have implicit parameters -- No type declarations : 'where' binds { sLL $1 $> (mj AnnWhere $1 : (fst $ unLoc $2) @@ -1520,7 +1520,7 @@ wherebinds :: { Located ([AddAnn],Located (HsLocalBinds RdrName)) } ----------------------------------------------------------------------------- -- Transformation Rules -rules :: { OrdList (LRuleDecl RdrName) } +rules :: { OrdList (LRuleDecl GhcPs) } : rules ';' rule {% addAnnotation (oll $1) AnnSemi (gl $2) >> return ($1 `snocOL` $3) } | rules ';' {% addAnnotation (oll $1) AnnSemi (gl $2) @@ -1528,7 +1528,7 @@ rules :: { OrdList (LRuleDecl RdrName) } | rule { unitOL $1 } | {- empty -} { nilOL } -rule :: { LRuleDecl RdrName } +rule :: { LRuleDecl GhcPs } : STRING rule_activation rule_forall infixexp '=' exp {%ams (sLL $1 $> $ (HsRule (L (gl $1) (getSTRINGs $1,getSTRING $1)) ((snd $2) `orElse` AlwaysActive) @@ -1550,15 +1550,15 @@ rule_explicit_activation :: { ([AddAnn] | '[' '~' ']' { ([mos $1,mj AnnTilde $2,mcs $3] ,NeverActive) } -rule_forall :: { ([AddAnn],[LRuleBndr RdrName]) } +rule_forall :: { ([AddAnn],[LRuleBndr GhcPs]) } : 'forall' rule_var_list '.' { ([mu AnnForall $1,mj AnnDot $3],$2) } | {- empty -} { ([],[]) } -rule_var_list :: { [LRuleBndr RdrName] } +rule_var_list :: { [LRuleBndr GhcPs] } : rule_var { [$1] } | rule_var rule_var_list { $1 : $2 } -rule_var :: { LRuleBndr RdrName } +rule_var :: { LRuleBndr GhcPs } : varid { sLL $1 $> (RuleBndr $1) } | '(' varid '::' ctype ')' {% ams (sLL $1 $> (RuleBndrSig $2 (mkLHsSigWcType $4))) @@ -1567,7 +1567,7 @@ rule_var :: { LRuleBndr RdrName } ----------------------------------------------------------------------------- -- Warnings and deprecations (c.f. rules) -warnings :: { OrdList (LWarnDecl RdrName) } +warnings :: { OrdList (LWarnDecl GhcPs) } : warnings ';' warning {% addAnnotation (oll $1) AnnSemi (gl $2) >> return ($1 `appOL` $3) } | warnings ';' {% addAnnotation (oll $1) AnnSemi (gl $2) @@ -1576,12 +1576,12 @@ warnings :: { OrdList (LWarnDecl RdrName) } | {- empty -} { nilOL } -- SUP: TEMPORARY HACK, not checking for `module Foo' -warning :: { OrdList (LWarnDecl RdrName) } +warning :: { OrdList (LWarnDecl GhcPs) } : namelist strings {% amsu (sLL $1 $> (Warning (unLoc $1) (WarningTxt (noLoc NoSourceText) $ snd $ unLoc $2))) (fst $ unLoc $2) } -deprecations :: { OrdList (LWarnDecl RdrName) } +deprecations :: { OrdList (LWarnDecl GhcPs) } : deprecations ';' deprecation {% addAnnotation (oll $1) AnnSemi (gl $2) >> return ($1 `appOL` $3) } @@ -1591,7 +1591,7 @@ deprecations :: { OrdList (LWarnDecl RdrName) } | {- empty -} { nilOL } -- SUP: TEMPORARY HACK, not checking for `module Foo' -deprecation :: { OrdList (LWarnDecl RdrName) } +deprecation :: { OrdList (LWarnDecl GhcPs) } : namelist strings {% amsu (sLL $1 $> $ (Warning (unLoc $1) (DeprecatedTxt (noLoc NoSourceText) $ snd $ unLoc $2))) (fst $ unLoc $2) } @@ -1609,7 +1609,7 @@ stringlist :: { Located (OrdList (Located StringLiteral)) } ----------------------------------------------------------------------------- -- Annotations -annotation :: { LHsDecl RdrName } +annotation :: { LHsDecl GhcPs } : '{-# ANN' name_var aexp '#-}' {% ams (sLL $1 $> (AnnD $ HsAnnotation (getANN_PRAGs $1) (ValueAnnProvenance $2) $3)) @@ -1629,7 +1629,7 @@ annotation :: { LHsDecl RdrName } ----------------------------------------------------------------------------- -- Foreign import and export declarations -fdecl :: { Located ([AddAnn],HsDecl RdrName) } +fdecl :: { Located ([AddAnn],HsDecl GhcPs) } fdecl : 'import' callconv safety fspec {% mkImport $2 $3 (snd $ unLoc $4) >>= \i -> return (sLL $1 $> (mj AnnImport $1 : (fst $ unLoc $4),i)) } @@ -1653,7 +1653,7 @@ safety :: { Located Safety } | 'interruptible' { sLL $1 $> PlayInterruptible } fspec :: { Located ([AddAnn] - ,(Located StringLiteral, Located RdrName, LHsSigType RdrName)) } + ,(Located StringLiteral, Located RdrName, LHsSigType GhcPs)) } : STRING var '::' sigtypedoc { sLL $1 $> ([mu AnnDcolon $3] ,(L (getLoc $1) (getStringLiteral $1), $2, mkLHsSigType $4)) } @@ -1666,11 +1666,11 @@ fspec :: { Located ([AddAnn] ----------------------------------------------------------------------------- -- Type signatures -opt_sig :: { ([AddAnn], Maybe (LHsType RdrName)) } +opt_sig :: { ([AddAnn], Maybe (LHsType GhcPs)) } : {- empty -} { ([],Nothing) } | '::' sigtype { ([mu AnnDcolon $1],Just $2) } -opt_asig :: { ([AddAnn],Maybe (LHsType RdrName)) } +opt_asig :: { ([AddAnn],Maybe (LHsType GhcPs)) } : {- empty -} { ([],Nothing) } | '::' atype { ([mu AnnDcolon $1],Just $2) } @@ -1678,10 +1678,10 @@ opt_tyconsig :: { ([AddAnn], Maybe (Located RdrName)) } : {- empty -} { ([], Nothing) } | '::' gtycon { ([mu AnnDcolon $1], Just $2) } -sigtype :: { LHsType RdrName } +sigtype :: { LHsType GhcPs } : ctype { $1 } -sigtypedoc :: { LHsType RdrName } +sigtypedoc :: { LHsType GhcPs } : ctypedoc { $1 } @@ -1691,7 +1691,7 @@ sig_vars :: { Located [Located RdrName] } -- Returned in reversed order >> return (sLL $1 $> ($3 : unLoc $1)) } | var { sL1 $1 [$1] } -sigtypes1 :: { (OrdList (LHsSigType RdrName)) } +sigtypes1 :: { (OrdList (LHsSigType GhcPs)) } : sigtype { unitOL (mkLHsSigType $1) } | sigtype ',' sigtypes1 {% addAnnotation (gl $1) AnnComma (gl $2) >> return (unitOL (mkLHsSigType $1) `appOL` $3) } @@ -1717,7 +1717,7 @@ unpackedness :: { Located ([AddAnn], SourceText, SrcUnpackedness) } | '{-# NOUNPACK' '#-}' { sLL $1 $> ([mo $1, mc $2], getNOUNPACK_PRAGs $1, SrcNoUnpack) } -- A ctype is a for-all type -ctype :: { LHsType RdrName } +ctype :: { LHsType GhcPs } : 'forall' tv_bndrs '.' ctype {% hintExplicitForall (getLoc $1) >> ams (sLL $1 $> $ HsForAllTy { hst_bndrs = $2 @@ -1742,7 +1742,7 @@ ctype :: { LHsType RdrName } -- If we allow comments on types here, it's not clear if the comment applies -- to 'field' or to 'Int'. So we must use `ctype` to describe the type. -ctypedoc :: { LHsType RdrName } +ctypedoc :: { LHsType GhcPs } : 'forall' tv_bndrs '.' ctypedoc {% hintExplicitForall (getLoc $1) >> ams (sLL $1 $> $ HsForAllTy { hst_bndrs = $2 @@ -1768,7 +1768,7 @@ ctypedoc :: { LHsType RdrName } -- Thus for some reason we allow f :: a~b => blah -- but not f :: ?x::Int => blah -- See Note [Parsing ~] -context :: { LHsContext RdrName } +context :: { LHsContext GhcPs } : btype {% do { (anns,ctx) <- checkContext $1 ; if null (unLoc ctx) then addAnnotation (gl $1) AnnUnit (gl $1) @@ -1776,7 +1776,7 @@ context :: { LHsContext RdrName } ; ams ctx anns } } -context_no_ops :: { LHsContext RdrName } +context_no_ops :: { LHsContext GhcPs } : btype_no_ops {% do { ty <- splitTilde $1 ; (anns,ctx) <- checkContext ty ; if null (unLoc ctx) @@ -1801,14 +1801,14 @@ the top-level annotation will be disconnected. Hence for this specific case it is connected to the first type too. -} -type :: { LHsType RdrName } +type :: { LHsType GhcPs } : btype { $1 } | btype '->' ctype {% ams $1 [mu AnnRarrow $2] -- See note [GADT decl discards annotations] >> ams (sLL $1 $> $ HsFunTy $1 $3) [mu AnnRarrow $2] } -typedoc :: { LHsType RdrName } +typedoc :: { LHsType GhcPs } : btype { $1 } | btype docprev { sLL $1 $> $ HsDocTy $1 $2 } | btype '->' ctypedoc {% ams (sLL $1 $> $ HsFunTy $1 $3) @@ -1819,7 +1819,7 @@ typedoc :: { LHsType RdrName } [mu AnnRarrow $3] } -- See Note [Parsing ~] -btype :: { LHsType RdrName } +btype :: { LHsType GhcPs } : tyapps {% splitTildeApps (reverse (unLoc $1)) >>= \ts -> return $ sL1 $1 $ HsAppsTy ts } @@ -1827,16 +1827,16 @@ btype :: { LHsType RdrName } -- in order to forbid the blasphemous -- > data Foo = Int :+ Char :* Bool -- See also Note [Parsing data constructors is hard] in RdrHsSyn -btype_no_ops :: { LHsType RdrName } +btype_no_ops :: { LHsType GhcPs } : btype_no_ops atype { sLL $1 $> $ HsAppTy $1 $2 } | atype { $1 } -tyapps :: { Located [LHsAppType RdrName] } -- NB: This list is reversed +tyapps :: { Located [LHsAppType GhcPs] } -- NB: This list is reversed : tyapp { sL1 $1 [$1] } | tyapps tyapp { sLL $1 $> $ $2 : (unLoc $1) } -- See Note [HsAppsTy] in HsTypes -tyapp :: { LHsAppType RdrName } +tyapp :: { LHsAppType GhcPs } : atype { sL1 $1 $ HsAppPrefix $1 } | qtyconop { sL1 $1 $ HsAppInfix $1 } | tyvarop { sL1 $1 $ HsAppInfix $1 } @@ -1845,7 +1845,7 @@ tyapp :: { LHsAppType RdrName } | SIMPLEQUOTE varop {% ams (sLL $1 $> $ HsAppInfix $2) [mj AnnSimpleQuote $1] } -atype :: { LHsType RdrName } +atype :: { LHsType GhcPs } : ntgtycon { sL1 $1 (HsTyVar NotPromoted $1) } -- Not including unit tuples | tyvar { sL1 $1 (HsTyVar NotPromoted $1) } -- (See Note [Unit tuples]) | strict_mark atype {% ams (sLL $1 $> (HsBangTy (snd $ unLoc $1) $2)) @@ -1909,35 +1909,35 @@ atype :: { LHsType RdrName } -- An inst_type is what occurs in the head of an instance decl -- e.g. (Foo a, Gaz b) => Wibble a b -- It's kept as a single type for convenience. -inst_type :: { LHsSigType RdrName } +inst_type :: { LHsSigType GhcPs } : sigtype { mkLHsSigType $1 } -deriv_types :: { [LHsSigType RdrName] } +deriv_types :: { [LHsSigType GhcPs] } : typedoc { [mkLHsSigType $1] } | typedoc ',' deriv_types {% addAnnotation (gl $1) AnnComma (gl $2) >> return (mkLHsSigType $1 : $3) } -comma_types0 :: { [LHsType RdrName] } -- Zero or more: ty,ty,ty +comma_types0 :: { [LHsType GhcPs] } -- Zero or more: ty,ty,ty : comma_types1 { $1 } | {- empty -} { [] } -comma_types1 :: { [LHsType RdrName] } -- One or more: ty,ty,ty +comma_types1 :: { [LHsType GhcPs] } -- One or more: ty,ty,ty : ctype { [$1] } | ctype ',' comma_types1 {% addAnnotation (gl $1) AnnComma (gl $2) >> return ($1 : $3) } -bar_types2 :: { [LHsType RdrName] } -- Two or more: ty|ty|ty +bar_types2 :: { [LHsType GhcPs] } -- Two or more: ty|ty|ty : ctype '|' ctype {% addAnnotation (gl $1) AnnVbar (gl $2) >> return [$1,$3] } | ctype '|' bar_types2 {% addAnnotation (gl $1) AnnVbar (gl $2) >> return ($1 : $3) } -tv_bndrs :: { [LHsTyVarBndr RdrName] } +tv_bndrs :: { [LHsTyVarBndr GhcPs] } : tv_bndr tv_bndrs { $1 : $2 } | {- empty -} { [] } -tv_bndr :: { LHsTyVarBndr RdrName } +tv_bndr :: { LHsTyVarBndr GhcPs } : tyvar { sL1 $1 (UserTyVar $1) } | '(' tyvar '::' kind ')' {% ams (sLL $1 $> (KindedTyVar $2 $4)) [mop $1,mu AnnDcolon $3 @@ -1982,7 +1982,7 @@ turn them into HsEqTy's. ----------------------------------------------------------------------------- -- Kinds -kind :: { LHsKind RdrName } +kind :: { LHsKind GhcPs } : ctype { $1 } {- Note [Promotion] @@ -2011,7 +2011,7 @@ both become a HsTyVar ("Zero", DataName) after the renamer. -- Datatype declarations gadt_constrlist :: { Located ([AddAnn] - ,[LConDecl RdrName]) } -- Returned in order + ,[LConDecl GhcPs]) } -- Returned in order : 'where' '{' gadt_constrs '}' { L (comb2 $1 $3) ([mj AnnWhere $1 ,moc $2 @@ -2022,7 +2022,7 @@ gadt_constrlist :: { Located ([AddAnn] , unLoc $3) } | {- empty -} { noLoc ([],[]) } -gadt_constrs :: { Located [LConDecl RdrName] } +gadt_constrs :: { Located [LConDecl GhcPs] } : gadt_constr_with_doc ';' gadt_constrs {% addAnnotation (gl $1) AnnSemi (gl $2) >> return (L (comb2 $1 $3) ($1 : unLoc $3)) } @@ -2035,14 +2035,14 @@ gadt_constrs :: { Located [LConDecl RdrName] } -- D { x,y :: a } :: T a -- forall a. Eq a => D { x,y :: a } :: T a -gadt_constr_with_doc :: { LConDecl RdrName } +gadt_constr_with_doc :: { LConDecl GhcPs } gadt_constr_with_doc : maybe_docnext ';' gadt_constr {% return $ addConDoc $3 $1 } | gadt_constr {% return $1 } -gadt_constr :: { LConDecl RdrName } +gadt_constr :: { LConDecl GhcPs } -- see Note [Difference in parsing GADT and data constructors] -- Returns a list because of: C,D :: ty : con_list '::' sigtype @@ -2061,17 +2061,17 @@ consequence, GADT constructor names are resticted (names like '(*)' are allowed in usual data constructors, but not in GADTs). -} -constrs :: { Located ([AddAnn],[LConDecl RdrName]) } +constrs :: { Located ([AddAnn],[LConDecl GhcPs]) } : maybe_docnext '=' constrs1 { L (comb2 $2 $3) ([mj AnnEqual $2] ,addConDocs (unLoc $3) $1)} -constrs1 :: { Located [LConDecl RdrName] } +constrs1 :: { Located [LConDecl GhcPs] } : constrs1 maybe_docnext '|' maybe_docprev constr {% addAnnotation (gl $ head $ unLoc $1) AnnVbar (gl $3) >> return (sLL $1 $> (addConDoc $5 $2 : addConDocFirst (unLoc $1) $4)) } | constr { sL1 $1 [$1] } -constr :: { LConDecl RdrName } +constr :: { LConDecl GhcPs } : maybe_docnext forall context_no_ops '=>' constr_stuff maybe_docprev {% ams (let (con,details) = unLoc $5 in addConDoc (L (comb4 $2 $3 $4 $5) (mkConDeclH98 con @@ -2085,28 +2085,28 @@ constr :: { LConDecl RdrName } ($1 `mplus` $4)) (fst $ unLoc $2) } -forall :: { Located ([AddAnn], Maybe [LHsTyVarBndr RdrName]) } +forall :: { Located ([AddAnn], Maybe [LHsTyVarBndr GhcPs]) } : 'forall' tv_bndrs '.' { sLL $1 $> ([mu AnnForall $1,mj AnnDot $3], Just $2) } | {- empty -} { noLoc ([], Nothing) } -constr_stuff :: { Located (Located RdrName, HsConDeclDetails RdrName) } +constr_stuff :: { Located (Located RdrName, HsConDeclDetails GhcPs) } -- See Note [Parsing data constructors is hard] in RdrHsSyn : btype_no_ops {% do { c <- splitCon $1 ; return $ sLL $1 $> c } } | btype_no_ops conop btype_no_ops {% do { ty <- splitTilde $1 ; return $ sLL $1 $> ($2, InfixCon ty $3) } } -fielddecls :: { [LConDeclField RdrName] } +fielddecls :: { [LConDeclField GhcPs] } : {- empty -} { [] } | fielddecls1 { $1 } -fielddecls1 :: { [LConDeclField RdrName] } +fielddecls1 :: { [LConDeclField GhcPs] } : fielddecl maybe_docnext ',' maybe_docprev fielddecls1 {% addAnnotation (gl $1) AnnComma (gl $3) >> return ((addFieldDoc $1 $4) : addFieldDocs $5 $2) } | fielddecl { [$1] } -fielddecl :: { LConDeclField RdrName } +fielddecl :: { LConDeclField GhcPs } -- A list because of f,g :: Int : maybe_docnext sig_vars '::' ctype maybe_docprev {% ams (L (comb2 $2 $4) @@ -2114,18 +2114,18 @@ fielddecl :: { LConDeclField RdrName } [mu AnnDcolon $3] } -- Reversed! -maybe_derivings :: { HsDeriving RdrName } +maybe_derivings :: { HsDeriving GhcPs } : {- empty -} { noLoc [] } | derivings { $1 } -- A list of one or more deriving clauses at the end of a datatype -derivings :: { HsDeriving RdrName } +derivings :: { HsDeriving GhcPs } : derivings deriving { sLL $1 $> $ $2 : unLoc $1 } | deriving { sLL $1 $> [$1] } -- The outer Located is just to allow the caller to -- know the rightmost extremity of the 'deriving' clause -deriving :: { LHsDerivingClause RdrName } +deriving :: { LHsDerivingClause GhcPs } : 'deriving' deriv_strategy qtycondoc {% let { full_loc = comb2 $1 $> } in ams (L full_loc $ HsDerivingClause $2 $ L full_loc @@ -2169,7 +2169,7 @@ There's an awkward overlap with a type signature. Consider We can't tell whether to reduce var to qvar until after we've read the signatures. -} -docdecl :: { LHsDecl RdrName } +docdecl :: { LHsDecl GhcPs } : docdecld { sL1 $1 (DocD (unLoc $1)) } docdecld :: { LDocDecl } @@ -2178,7 +2178,7 @@ docdecld :: { LDocDecl } | docnamed { sL1 $1 (case (unLoc $1) of (n, doc) -> DocCommentNamed n doc) } | docsection { sL1 $1 (case (unLoc $1) of (n, doc) -> DocGroup n doc) } -decl_no_th :: { LHsDecl RdrName } +decl_no_th :: { LHsDecl GhcPs } : sigdecl { $1 } | '!' aexp rhs {% do { let { e = sLL $1 $2 (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2) }; @@ -2205,7 +2205,7 @@ decl_no_th :: { LHsDecl RdrName } | pattern_synonym_decl { $1 } | docdecl { $1 } -decl :: { LHsDecl RdrName } +decl :: { LHsDecl GhcPs } : decl_no_th { $1 } -- Why do we only allow naked declaration splices in top-level @@ -2213,7 +2213,7 @@ decl :: { LHsDecl RdrName } -- fails terribly with a panic in cvBindsAndSigs otherwise. | splice_exp { sLL $1 $> $ mkSpliceDecl $1 } -rhs :: { Located ([AddAnn],GRHSs RdrName (LHsExpr RdrName)) } +rhs :: { Located ([AddAnn],GRHSs GhcPs (LHsExpr GhcPs)) } : '=' exp wherebinds { sL (comb3 $1 $2 $3) ((mj AnnEqual $1 : (fst $ unLoc $3)) ,GRHSs (unguardedRHS (comb3 $1 $2 $3) $2) @@ -2222,15 +2222,15 @@ rhs :: { Located ([AddAnn],GRHSs RdrName (LHsExpr RdrName)) } ,GRHSs (reverse (unLoc $1)) (snd $ unLoc $2)) } -gdrhs :: { Located [LGRHS RdrName (LHsExpr RdrName)] } +gdrhs :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] } : gdrhs gdrh { sLL $1 $> ($2 : unLoc $1) } | gdrh { sL1 $1 [$1] } -gdrh :: { LGRHS RdrName (LHsExpr RdrName) } +gdrh :: { LGRHS GhcPs (LHsExpr GhcPs) } : '|' guardquals '=' exp {% ams (sL (comb2 $1 $>) $ GRHS (unLoc $2) $4) [mj AnnVbar $1,mj AnnEqual $3] } -sigdecl :: { LHsDecl RdrName } +sigdecl :: { LHsDecl GhcPs } : -- See Note [Declaration/signature overlap] for why we need infixexp here infixexp_top '::' sigtypedoc @@ -2315,7 +2315,7 @@ explicit_activation :: { ([AddAnn],Activation) } -- In brackets ----------------------------------------------------------------------------- -- Expressions -quasiquote :: { Located (HsSplice RdrName) } +quasiquote :: { Located (HsSplice GhcPs) } : TH_QUASIQUOTE { let { loc = getLoc $1 ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1 ; quoterId = mkUnqual varName quoter } @@ -2325,7 +2325,7 @@ quasiquote :: { Located (HsSplice RdrName) } ; quoterId = mkQual varName (qual, quoter) } in sL (getLoc $1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) } -exp :: { LHsExpr RdrName } +exp :: { LHsExpr GhcPs } : infixexp '::' sigtype {% ams (sLL $1 $> $ ExprWithTySig $1 (mkLHsSigWcType $3)) [mu AnnDcolon $2] } | infixexp '-<' exp {% ams (sLL $1 $> $ HsArrApp $1 $3 placeHolderType @@ -2342,19 +2342,19 @@ exp :: { LHsExpr RdrName } [mu AnnRarrowtail $2] } | infixexp { $1 } -infixexp :: { LHsExpr RdrName } +infixexp :: { LHsExpr GhcPs } : exp10 { $1 } | infixexp qop exp10 {% ams (sLL $1 $> (OpApp $1 $2 placeHolderFixity $3)) [mj AnnVal $2] } -- AnnVal annotation for NPlusKPat, which discards the operator -infixexp_top :: { LHsExpr RdrName } +infixexp_top :: { LHsExpr GhcPs } : exp10_top { $1 } | infixexp_top qop exp10_top {% ams (sLL $1 $> (OpApp $1 $2 placeHolderFixity $3)) [mj AnnVal $2] } -exp10_top :: { LHsExpr RdrName } +exp10_top :: { LHsExpr GhcPs } : '\\' apat apats opt_asig '->' exp {% ams (sLL $1 $> $ HsLam (mkMatchGroup FromSource [sLL $1 $> $ Match { m_ctxt = LambdaExpr @@ -2414,7 +2414,7 @@ exp10_top :: { LHsExpr RdrName } -- hdaume: core annotation | fexp { $1 } -exp10 :: { LHsExpr RdrName } +exp10 :: { LHsExpr GhcPs } : exp10_top { $1 } | scc_annot exp {% ams (sLL $1 $> $ HsSCC (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2) (fst $ fst $ unLoc $1) } @@ -2458,7 +2458,7 @@ hpc_annot :: { Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,In ))) } -fexp :: { LHsExpr RdrName } +fexp :: { LHsExpr GhcPs } : fexp aexp { sLL $1 $> $ HsApp $1 $2 } | fexp TYPEAPP atype {% ams (sLL $1 $> $ HsAppType $1 (mkHsWildCardBndrs $3)) [mj AnnAt $2] } @@ -2466,7 +2466,7 @@ fexp :: { LHsExpr RdrName } [mj AnnStatic $1] } | aexp { $1 } -aexp :: { LHsExpr RdrName } +aexp :: { LHsExpr GhcPs } : qvar '@' aexp {% ams (sLL $1 $> $ EAsPat $1 $3) [mj AnnAt $2] } -- If you change the parsing, make sure to understand -- Note [Lexing type applications] in Lexer.x @@ -2474,14 +2474,14 @@ aexp :: { LHsExpr RdrName } | '~' aexp {% ams (sLL $1 $> $ ELazyPat $2) [mj AnnTilde $1] } | aexp1 { $1 } -aexp1 :: { LHsExpr RdrName } +aexp1 :: { LHsExpr GhcPs } : aexp1 '{' fbinds '}' {% do { r <- mkRecConstrOrUpdate $1 (comb2 $2 $4) (snd $3) ; _ <- ams (sLL $1 $> ()) (moc $2:mcc $4:(fst $3)) ; checkRecordSyntax (sLL $1 $> r) }} | aexp2 { $1 } -aexp2 :: { LHsExpr RdrName } +aexp2 :: { LHsExpr GhcPs } : qvar { sL1 $1 (HsVar $! $1) } | qcon { sL1 $1 (HsVar $! $1) } | ipvar { sL1 $1 (HsIPVar $! unLoc $1) } @@ -2539,7 +2539,7 @@ aexp2 :: { LHsExpr RdrName } Nothing (reverse $3)) [mu AnnOpenB $1,mu AnnCloseB $4] } -splice_exp :: { LHsExpr RdrName } +splice_exp :: { LHsExpr GhcPs } : TH_ID_SPLICE {% ams (sL1 $1 $ mkHsSpliceE HasDollar (sL1 $1 $ HsVar (sL1 $1 (mkUnqual varName (getTH_ID_SPLICE $1))))) @@ -2553,21 +2553,21 @@ splice_exp :: { LHsExpr RdrName } | '$$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceTE HasParens $2) [mj AnnOpenPTE $1,mj AnnCloseP $3] } -cmdargs :: { [LHsCmdTop RdrName] } +cmdargs :: { [LHsCmdTop GhcPs] } : cmdargs acmd { $2 : $1 } | {- empty -} { [] } -acmd :: { LHsCmdTop RdrName } +acmd :: { LHsCmdTop GhcPs } : aexp2 {% checkCommand $1 >>= \ cmd -> return (sL1 $1 $ HsCmdTop cmd placeHolderType placeHolderType []) } -cvtopbody :: { ([AddAnn],[LHsDecl RdrName]) } +cvtopbody :: { ([AddAnn],[LHsDecl GhcPs]) } : '{' cvtopdecls0 '}' { ([mj AnnOpenC $1 ,mj AnnCloseC $3],$2) } | vocurly cvtopdecls0 close { ([],$2) } -cvtopdecls0 :: { [LHsDecl RdrName] } +cvtopdecls0 :: { [LHsDecl GhcPs] } : topdecls_semi { cvTopDecls $1 } | topdecls { cvTopDecls $1 } @@ -2577,7 +2577,7 @@ cvtopdecls0 :: { [LHsDecl RdrName] } -- "texp" is short for tuple expressions: -- things that can appear unparenthesized as long as they're -- inside parens or delimitted by commas -texp :: { LHsExpr RdrName } +texp :: { LHsExpr GhcPs } : exp { $1 } -- Note [Parsing sections] @@ -2614,7 +2614,7 @@ tup_exprs :: { ([AddAnn],SumOrTuple) } { (mvbars (fst $1) ++ mvbars (fst $3), Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2) } -- Always starts with commas; always follows an expr -commas_tup_tail :: { (SrcSpan,[LHsTupArg RdrName]) } +commas_tup_tail :: { (SrcSpan,[LHsTupArg GhcPs]) } commas_tup_tail : commas tup_tail {% do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (tail $ fst $1) ; return ( @@ -2622,7 +2622,7 @@ commas_tup_tail : commas tup_tail ,(map (\l -> L l missingTupArg) (tail $ fst $1)) ++ $2)) } } -- Always follows a comma -tup_tail :: { [LHsTupArg RdrName] } +tup_tail :: { [LHsTupArg GhcPs] } : texp commas_tup_tail {% addAnnotation (gl $1) AnnComma (fst $2) >> return ((L (gl $1) (Present $1)) : snd $2) } | texp { [L (gl $1) (Present $1)] } @@ -2633,7 +2633,7 @@ tup_tail :: { [LHsTupArg RdrName] } -- The rules below are little bit contorted to keep lexps left-recursive while -- avoiding another shift/reduce-conflict. -list :: { ([AddAnn],HsExpr RdrName) } +list :: { ([AddAnn],HsExpr GhcPs) } : texp { ([],ExplicitList placeHolderType Nothing [$1]) } | lexps { ([],ExplicitList placeHolderType Nothing (reverse (unLoc $1))) } @@ -2653,7 +2653,7 @@ list :: { ([AddAnn],HsExpr RdrName) } return ([mj AnnVbar $2], mkHsComp ctxt (unLoc $3) $1) } -lexps :: { Located [LHsExpr RdrName] } +lexps :: { Located [LHsExpr GhcPs] } : lexps ',' texp {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >> return (sLL $1 $> (((:) $! $3) $! unLoc $1)) } @@ -2663,7 +2663,7 @@ lexps :: { Located [LHsExpr RdrName] } ----------------------------------------------------------------------------- -- List Comprehensions -flattenedpquals :: { Located [LStmt RdrName (LHsExpr RdrName)] } +flattenedpquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } : pquals { case (unLoc $1) of [qs] -> sL1 $1 qs -- We just had one thing in our "parallel" list so @@ -2676,13 +2676,13 @@ flattenedpquals :: { Located [LStmt RdrName (LHsExpr RdrName)] } -- we wrap them into as a ParStmt } -pquals :: { Located [[LStmt RdrName (LHsExpr RdrName)]] } +pquals :: { Located [[LStmt GhcPs (LHsExpr GhcPs)]] } : squals '|' pquals {% addAnnotation (gl $ head $ unLoc $1) AnnVbar (gl $2) >> return (sLL $1 $> (reverse (unLoc $1) : unLoc $3)) } | squals { L (getLoc $1) [reverse (unLoc $1)] } -squals :: { Located [LStmt RdrName (LHsExpr RdrName)] } -- In reverse order, because the last +squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } -- In reverse order, because the last -- one can "grab" the earlier ones : squals ',' transformqual {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >> @@ -2702,7 +2702,7 @@ squals :: { Located [LStmt RdrName (LHsExpr RdrName)] } -- In reverse order, b -- consensus on the syntax, this feature is not being used until we -- get user demand. -transformqual :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)] -> Stmt RdrName (LHsExpr RdrName)) } +transformqual :: { Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs (LHsExpr GhcPs)) } -- Function is applied to a list of stmts *in order* : 'then' exp { sLL $1 $> ([mj AnnThen $1], \ss -> (mkTransformStmt ss $2)) } | 'then' exp 'by' exp { sLL $1 $> ([mj AnnThen $1,mj AnnBy $3],\ss -> (mkTransformByStmt ss $2 $4)) } @@ -2725,7 +2725,7 @@ transformqual :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)] -> Stmt R -- Moreover, we allow explicit arrays with no element (represented by the nil -- constructor in the list case). -parr :: { ([AddAnn],HsExpr RdrName) } +parr :: { ([AddAnn],HsExpr GhcPs) } : { ([],ExplicitPArr placeHolderType []) } | texp { ([],ExplicitPArr placeHolderType [$1]) } | lexps { ([],ExplicitPArr placeHolderType @@ -2743,10 +2743,10 @@ parr :: { ([AddAnn],HsExpr RdrName) } ----------------------------------------------------------------------------- -- Guards -guardquals :: { Located [LStmt RdrName (LHsExpr RdrName)] } +guardquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } : guardquals1 { L (getLoc $1) (reverse (unLoc $1)) } -guardquals1 :: { Located [LStmt RdrName (LHsExpr RdrName)] } +guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } : guardquals1 ',' qual {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >> return (sLL $1 $> ($3 : unLoc $1)) } @@ -2755,7 +2755,7 @@ guardquals1 :: { Located [LStmt RdrName (LHsExpr RdrName)] } ----------------------------------------------------------------------------- -- Case alternatives -altslist :: { Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)]) } +altslist :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } : '{' alts '}' { sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2)) ,(reverse (snd $ unLoc $2))) } | vocurly alts close { L (getLoc $2) (fst $ unLoc $2 @@ -2763,12 +2763,12 @@ altslist :: { Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)]) } | '{' '}' { noLoc ([moc $1,mcc $2],[]) } | vocurly close { noLoc ([],[]) } -alts :: { Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)]) } +alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)) ,snd $ unLoc $2) } -alts1 :: { Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)]) } +alts1 :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } : alts1 ';' alt {% if null (snd $ unLoc $1) then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) ,[$3])) @@ -2783,34 +2783,34 @@ alts1 :: { Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)]) } >> return (sLL $1 $> ([],snd $ unLoc $1))) } | alt { sL1 $1 ([],[$1]) } -alt :: { LMatch RdrName (LHsExpr RdrName) } +alt :: { LMatch GhcPs (LHsExpr GhcPs) } : pat opt_asig alt_rhs {%ams (sLL $1 $> (Match { m_ctxt = CaseAlt , m_pats = [$1] , m_type = snd $2 , m_grhss = snd $ unLoc $3 })) (fst $2 ++ (fst $ unLoc $3))} -alt_rhs :: { Located ([AddAnn],GRHSs RdrName (LHsExpr RdrName)) } +alt_rhs :: { Located ([AddAnn],GRHSs GhcPs (LHsExpr GhcPs)) } : ralt wherebinds { sLL $1 $> (fst $ unLoc $2, GRHSs (unLoc $1) (snd $ unLoc $2)) } -ralt :: { Located [LGRHS RdrName (LHsExpr RdrName)] } +ralt :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] } : '->' exp {% ams (sLL $1 $> (unguardedRHS (comb2 $1 $2) $2)) [mu AnnRarrow $1] } | gdpats { sL1 $1 (reverse (unLoc $1)) } -gdpats :: { Located [LGRHS RdrName (LHsExpr RdrName)] } +gdpats :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] } : gdpats gdpat { sLL $1 $> ($2 : unLoc $1) } | gdpat { sL1 $1 [$1] } -- layout for MultiWayIf doesn't begin with an open brace, because it's hard to -- generate the open brace in addition to the vertical bar in the lexer, and -- we don't need it. -ifgdpats :: { Located ([AddAnn],[LGRHS RdrName (LHsExpr RdrName)]) } +ifgdpats :: { Located ([AddAnn],[LGRHS GhcPs (LHsExpr GhcPs)]) } : '{' gdpats '}' { sLL $1 $> ([moc $1,mcc $3],unLoc $2) } | gdpats close { sL1 $1 ([],unLoc $1) } -gdpat :: { LGRHS RdrName (LHsExpr RdrName) } +gdpat :: { LGRHS GhcPs (LHsExpr GhcPs) } : '|' guardquals '->' exp {% ams (sL (comb2 $1 $>) $ GRHS (unLoc $2) $4) [mj AnnVbar $1,mu AnnRarrow $3] } @@ -2819,13 +2819,13 @@ gdpat :: { LGRHS RdrName (LHsExpr RdrName) } -- e.g. "!x" or "!(x,y)" or "C a b" etc -- Bangs inside are parsed as infix operator applications, so that -- we parse them right when bang-patterns are off -pat :: { LPat RdrName } +pat :: { LPat GhcPs } pat : exp {% checkPattern empty $1 } | '!' aexp {% amms (checkPattern empty (sLL $1 $> (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2))) [mj AnnBang $1] } -bindpat :: { LPat RdrName } +bindpat :: { LPat GhcPs } bindpat : exp {% checkPattern (text "Possibly caused by a missing 'do'?") $1 } | '!' aexp {% amms (checkPattern @@ -2833,21 +2833,21 @@ bindpat : exp {% checkPattern (sLL $1 $> (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2))) [mj AnnBang $1] } -apat :: { LPat RdrName } +apat :: { LPat GhcPs } apat : aexp {% checkPattern empty $1 } | '!' aexp {% amms (checkPattern empty (sLL $1 $> (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2))) [mj AnnBang $1] } -apats :: { [LPat RdrName] } +apats :: { [LPat GhcPs] } : apat apats { $1 : $2 } | {- empty -} { [] } ----------------------------------------------------------------------------- -- Statement sequences -stmtlist :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)]) } +stmtlist :: { Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)]) } : '{' stmts '}' { sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2)) ,(reverse $ snd $ unLoc $2)) } -- AZ:performance of reverse? | vocurly stmts close { L (gl $2) (fst $ unLoc $2 @@ -2859,7 +2859,7 @@ stmtlist :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)]) } -- So we use BodyStmts throughout, and switch the last one over -- in ParseUtils.checkDo instead -stmts :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)]) } +stmts :: { Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)]) } : stmts ';' stmt {% if null (snd $ unLoc $1) then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) ,$3 : (snd $ unLoc $1))) @@ -2879,16 +2879,16 @@ stmts :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)]) } -- For typing stmts at the GHCi prompt, where -- the input may consist of just comments. -maybe_stmt :: { Maybe (LStmt RdrName (LHsExpr RdrName)) } +maybe_stmt :: { Maybe (LStmt GhcPs (LHsExpr GhcPs)) } : stmt { Just $1 } | {- nothing -} { Nothing } -stmt :: { LStmt RdrName (LHsExpr RdrName) } +stmt :: { LStmt GhcPs (LHsExpr GhcPs) } : qual { $1 } | 'rec' stmtlist {% ams (sLL $1 $> $ mkRecStmt (snd $ unLoc $2)) (mj AnnRec $1:(fst $ unLoc $2)) } -qual :: { LStmt RdrName (LHsExpr RdrName) } +qual :: { LStmt GhcPs (LHsExpr GhcPs) } : bindpat '<-' exp {% ams (sLL $1 $> $ mkBindStmt $1 $3) [mu AnnLarrow $2] } | exp { sL1 $1 $ mkBodyStmt $1 } @@ -2898,18 +2898,18 @@ qual :: { LStmt RdrName (LHsExpr RdrName) } ----------------------------------------------------------------------------- -- Record Field Update/Construction -fbinds :: { ([AddAnn],([LHsRecField RdrName (LHsExpr RdrName)], Bool)) } +fbinds :: { ([AddAnn],([LHsRecField GhcPs (LHsExpr GhcPs)], Bool)) } : fbinds1 { $1 } | {- empty -} { ([],([], False)) } -fbinds1 :: { ([AddAnn],([LHsRecField RdrName (LHsExpr RdrName)], Bool)) } +fbinds1 :: { ([AddAnn],([LHsRecField GhcPs (LHsExpr GhcPs)], Bool)) } : fbind ',' fbinds1 {% addAnnotation (gl $1) AnnComma (gl $2) >> return (case $3 of (ma,(flds, dd)) -> (ma,($1 : flds, dd))) } | fbind { ([],([$1], False)) } | '..' { ([mj AnnDotdot $1],([], True)) } -fbind :: { LHsRecField RdrName (LHsExpr RdrName) } +fbind :: { LHsRecField GhcPs (LHsExpr GhcPs) } : qvar '=' texp {% ams (sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) $3 False) [mj AnnEqual $2] } -- RHS is a 'texp', allowing view patterns (Trac #6038) @@ -2923,7 +2923,7 @@ fbind :: { LHsRecField RdrName (LHsExpr RdrName) } ----------------------------------------------------------------------------- -- Implicit Parameter Bindings -dbinds :: { Located [LIPBind RdrName] } +dbinds :: { Located [LIPBind GhcPs] } : dbinds ';' dbind {% addAnnotation (gl $ last $ unLoc $1) AnnSemi (gl $2) >> return (let { this = $3; rest = unLoc $1 } @@ -2933,7 +2933,7 @@ dbinds :: { Located [LIPBind RdrName] } | dbind { let this = $1 in this `seq` sL1 $1 [this] } -- | {- empty -} { [] } -dbind :: { LIPBind RdrName } +dbind :: { LIPBind GhcPs } dbind : ipvar '=' exp {% ams (sLL $1 $> (IPBind (Left $1) $3)) [mj AnnEqual $2] } @@ -3114,7 +3114,7 @@ qtycon :: { Located RdrName } -- Qualified or unqualified : QCONID { sL1 $1 $! mkQual tcClsName (getQCONID $1) } | tycon { $1 } -qtycondoc :: { LHsType RdrName } -- Qualified or unqualified +qtycondoc :: { LHsType GhcPs } -- Qualified or unqualified : qtycon { sL1 $1 (HsTyVar NotPromoted $1) } | qtycon docprev { sLL $1 $> (HsDocTy (sL1 $1 (HsTyVar NotPromoted $1)) $2) } @@ -3148,14 +3148,14 @@ varop :: { Located RdrName } [mj AnnBackquote $1,mj AnnVal $2 ,mj AnnBackquote $3] } -qop :: { LHsExpr RdrName } -- used in sections +qop :: { LHsExpr GhcPs } -- used in sections : qvarop { sL1 $1 $ HsVar $1 } | qconop { sL1 $1 $ HsVar $1 } | '`' '_' '`' {% ams (sLL $1 $> EWildPat) [mj AnnBackquote $1,mj AnnVal $2 ,mj AnnBackquote $3] } -qopm :: { LHsExpr RdrName } -- used in sections +qopm :: { LHsExpr GhcPs } -- used in sections : qvaropm { sL1 $1 $ HsVar $1 } | qconop { sL1 $1 $ HsVar $1 } @@ -3302,20 +3302,20 @@ consym :: { Located RdrName } ----------------------------------------------------------------------------- -- Literals -literal :: { Located HsLit } - : CHAR { sL1 $1 $ HsChar (getCHARs $1) $ getCHAR $1 } - | STRING { sL1 $1 $ HsString (getSTRINGs $1) - $ getSTRING $1 } - | PRIMINTEGER { sL1 $1 $ HsIntPrim (getPRIMINTEGERs $1) - $ getPRIMINTEGER $1 } - | PRIMWORD { sL1 $1 $ HsWordPrim (getPRIMWORDs $1) - $ getPRIMWORD $1 } - | PRIMCHAR { sL1 $1 $ HsCharPrim (getPRIMCHARs $1) - $ getPRIMCHAR $1 } - | PRIMSTRING { sL1 $1 $ HsStringPrim (getPRIMSTRINGs $1) - $ getPRIMSTRING $1 } - | PRIMFLOAT { sL1 $1 $ HsFloatPrim $ getPRIMFLOAT $1 } - | PRIMDOUBLE { sL1 $1 $ HsDoublePrim $ getPRIMDOUBLE $1 } +literal :: { Located (HsLit GhcPs) } + : CHAR { sL1 $1 $ HsChar (sst $ getCHARs $1) $ getCHAR $1 } + | STRING { sL1 $1 $ HsString (sst $ getSTRINGs $1) + $ getSTRING $1 } + | PRIMINTEGER { sL1 $1 $ HsIntPrim (sst $ getPRIMINTEGERs $1) + $ getPRIMINTEGER $1 } + | PRIMWORD { sL1 $1 $ HsWordPrim (sst $ getPRIMWORDs $1) + $ getPRIMWORD $1 } + | PRIMCHAR { sL1 $1 $ HsCharPrim (sst $ getPRIMCHARs $1) + $ getPRIMCHAR $1 } + | PRIMSTRING { sL1 $1 $ HsStringPrim (sst $ getPRIMSTRINGs $1) + $ getPRIMSTRING $1 } + | PRIMFLOAT { sL1 $1 $ HsFloatPrim def $ getPRIMFLOAT $1 } + | PRIMDOUBLE { sL1 $1 $ HsDoublePrim def $ getPRIMDOUBLE $1 } ----------------------------------------------------------------------------- -- Layout @@ -3563,7 +3563,7 @@ hintMultiWayIf span = do text "Multi-way if-expressions need MultiWayIf turned on" -- Hint about if usage for beginners -hintIf :: SrcSpan -> String -> P (LHsExpr RdrName) +hintIf :: SrcSpan -> String -> P (LHsExpr GhcPs) hintIf span msg = do mwiEnabled <- liftM ((LangExt.MultiWayIf `extopt`) . options) getPState if mwiEnabled @@ -3712,4 +3712,7 @@ oll l = asl :: [Located a] -> Located b -> Located a -> P() asl [] (L ls _) (L l _) = addAnnotation l AnnSemi ls asl (x:_xs) (L ls _) _x = addAnnotation (getLoc x) AnnSemi ls + +sst ::HasSourceText a => SourceText -> a +sst = setSourceText } diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index d6fc6fb642..eb78073b66 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -6,6 +6,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} module RdrHsSyn ( mkHsOpApp, @@ -130,10 +131,10 @@ mkInstD :: LInstDecl n -> LHsDecl n mkInstD (L loc d) = L loc (InstD d) mkClassDecl :: SrcSpan - -> Located (Maybe (LHsContext RdrName), LHsType RdrName) + -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) -> Located (a,[Located (FunDep (Located RdrName))]) - -> OrdList (LHsDecl RdrName) - -> P (LTyClDecl RdrName) + -> OrdList (LHsDecl GhcPs) + -> P (LTyClDecl GhcPs) mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls = do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs where_cls @@ -150,8 +151,8 @@ mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls , tcdATs = ats, tcdATDefs = at_defs, tcdDocs = docs , tcdFVs = placeHolderNames })) } -mkATDefault :: LTyFamInstDecl RdrName - -> Either (SrcSpan, SDoc) (LTyFamDefltEqn RdrName) +mkATDefault :: LTyFamInstDecl GhcPs + -> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs) -- Take a type-family instance declaration and turn it into -- a type-family default equation for a class declaration -- We parse things as the former and use this function to convert to the latter @@ -170,11 +171,11 @@ mkATDefault (L loc (TyFamInstDecl { tfid_eqn = L _ e })) mkTyData :: SrcSpan -> NewOrData -> Maybe (Located CType) - -> Located (Maybe (LHsContext RdrName), LHsType RdrName) - -> Maybe (LHsKind RdrName) - -> [LConDecl RdrName] - -> HsDeriving RdrName - -> P (LTyClDecl RdrName) + -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) + -> Maybe (LHsKind GhcPs) + -> [LConDecl GhcPs] + -> HsDeriving GhcPs + -> P (LTyClDecl GhcPs) mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan @@ -188,11 +189,11 @@ mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv mkDataDefn :: NewOrData -> Maybe (Located CType) - -> Maybe (LHsContext RdrName) - -> Maybe (LHsKind RdrName) - -> [LConDecl RdrName] - -> HsDeriving RdrName - -> P (HsDataDefn RdrName) + -> Maybe (LHsContext GhcPs) + -> Maybe (LHsKind GhcPs) + -> [LConDecl GhcPs] + -> HsDeriving GhcPs + -> P (HsDataDefn GhcPs) mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv = do { checkDatatypeContext mcxt ; let cxt = fromMaybe (noLoc []) mcxt @@ -204,9 +205,9 @@ mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv mkTySynonym :: SrcSpan - -> LHsType RdrName -- LHS - -> LHsType RdrName -- RHS - -> P (LTyClDecl RdrName) + -> LHsType GhcPs -- LHS + -> LHsType GhcPs -- RHS + -> P (LTyClDecl GhcPs) mkTySynonym loc lhs rhs = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan @@ -215,9 +216,9 @@ mkTySynonym loc lhs rhs , tcdFixity = fixity , tcdRhs = rhs, tcdFVs = placeHolderNames })) } -mkTyFamInstEqn :: LHsType RdrName - -> LHsType RdrName - -> P (TyFamInstEqn RdrName,[AddAnn]) +mkTyFamInstEqn :: LHsType GhcPs + -> LHsType GhcPs + -> P (TyFamInstEqn GhcPs,[AddAnn]) mkTyFamInstEqn lhs rhs = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs ; return (TyFamEqn { tfe_tycon = tc @@ -229,11 +230,11 @@ mkTyFamInstEqn lhs rhs mkDataFamInst :: SrcSpan -> NewOrData -> Maybe (Located CType) - -> Located (Maybe (LHsContext RdrName), LHsType RdrName) - -> Maybe (LHsKind RdrName) - -> [LConDecl RdrName] - -> HsDeriving RdrName - -> P (LInstDecl RdrName) + -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) + -> Maybe (LHsKind GhcPs) + -> [LConDecl GhcPs] + -> HsDeriving GhcPs + -> P (LInstDecl GhcPs) mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan @@ -245,18 +246,18 @@ mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_ , dfid_defn = defn, dfid_fvs = placeHolderNames }))) } mkTyFamInst :: SrcSpan - -> LTyFamInstEqn RdrName - -> P (LInstDecl RdrName) + -> LTyFamInstEqn GhcPs + -> P (LInstDecl GhcPs) mkTyFamInst loc eqn = return (L loc (TyFamInstD (TyFamInstDecl { tfid_eqn = eqn , tfid_fvs = placeHolderNames }))) mkFamDecl :: SrcSpan - -> FamilyInfo RdrName - -> LHsType RdrName -- LHS - -> Located (FamilyResultSig RdrName) -- Optional result signature - -> Maybe (LInjectivityAnn RdrName) -- Injectivity annotation - -> P (LTyClDecl RdrName) + -> FamilyInfo GhcPs + -> LHsType GhcPs -- LHS + -> Located (FamilyResultSig GhcPs) -- Optional result signature + -> Maybe (LInjectivityAnn GhcPs) -- Injectivity annotation + -> P (LTyClDecl GhcPs) mkFamDecl loc info lhs ksig injAnn = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan @@ -272,7 +273,7 @@ mkFamDecl loc info lhs ksig injAnn OpenTypeFamily -> empty ClosedTypeFamily {} -> whereDots -mkSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName +mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs -- If the user wrote -- [pads| ... ] then return a QuasiQuoteD -- $(e) then return a SpliceD @@ -293,9 +294,9 @@ mkSpliceDecl lexpr@(L loc expr) = SpliceD (SpliceDecl (L loc (mkUntypedSplice NoParens lexpr)) ImplicitSplice) mkRoleAnnotDecl :: SrcSpan - -> Located RdrName -- type being annotated + -> Located RdrName -- type being annotated -> [Located (Maybe FastString)] -- roles - -> P (LRoleAnnotDecl RdrName) + -> P (LRoleAnnotDecl GhcPs) mkRoleAnnotDecl loc tycon roles = do { roles' <- mapM parse_role roles ; return $ L loc $ RoleAnnotDecl tycon roles' } @@ -332,25 +333,25 @@ mkRoleAnnotDecl loc tycon roles -- | Groups together bindings for a single function -cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName] +cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs] cvTopDecls decls = go (fromOL decls) where - go :: [LHsDecl RdrName] -> [LHsDecl RdrName] + go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs] go [] = [] go (L l (ValD b) : ds) = L l' (ValD b') : go ds' where (L l' b', ds') = getMonoBind (L l b) ds go (d : ds) = d : go ds -- Declaration list may only contain value bindings and signatures. -cvBindGroup :: OrdList (LHsDecl RdrName) -> P (HsValBinds RdrName) +cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs) cvBindGroup binding = do { (mbs, sigs, fam_ds, tfam_insts, dfam_insts, _) <- cvBindsAndSigs binding ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts) return $ ValBindsIn mbs sigs } -cvBindsAndSigs :: OrdList (LHsDecl RdrName) - -> P (LHsBinds RdrName, [LSig RdrName], [LFamilyDecl RdrName] - , [LTyFamInstDecl RdrName], [LDataFamInstDecl RdrName], [LDocDecl]) +cvBindsAndSigs :: OrdList (LHsDecl GhcPs) + -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs] + , [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl]) -- Input decls contain just value bindings and signatures -- and in case of class or instance declarations also -- associated type declarations. They might also contain Haddock comments. @@ -385,8 +386,8 @@ cvBindsAndSigs fb = go (fromOL fb) ----------------------------------------------------------------------------- -- Group function bindings into equation groups -getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName] - -> (LHsBind RdrName, [LHsDecl RdrName]) +getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs] + -> (LHsBind GhcPs, [LHsDecl GhcPs]) -- Suppose (b',ds') = getMonoBind b ds -- ds is a list of parsed bindings -- b is a MonoBinds that has just been read off the front @@ -423,7 +424,7 @@ getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), getMonoBind bind binds = (bind, binds) -has_args :: [LMatch RdrName (LHsExpr RdrName)] -> Bool +has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool has_args [] = panic "RdrHsSyn:has_args" has_args ((L _ (Match _ args _ _)) : _) = not (null args) -- Don't group together FunBinds if they have @@ -462,8 +463,8 @@ So the plan is: it (Trac #12051). -} -splitCon :: LHsType RdrName - -> P (Located RdrName, HsConDeclDetails RdrName) +splitCon :: LHsType GhcPs + -> P (Located RdrName, HsConDeclDetails GhcPs) -- See Note [Parsing data constructors is hard] -- This gets given a "type" that should look like -- C Int Bool @@ -502,8 +503,8 @@ tyConToDataCon loc tc | otherwise = empty mkPatSynMatchGroup :: Located RdrName - -> Located (OrdList (LHsDecl RdrName)) - -> P (MatchGroup RdrName (LHsExpr RdrName)) + -> Located (OrdList (LHsDecl GhcPs)) + -> P (MatchGroup GhcPs (LHsExpr GhcPs)) mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) = do { matches <- mapM fromDecl (fromOL decls) ; when (null matches) (wrongNumberErr loc) @@ -536,15 +537,15 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) = text "pattern synonym 'where' clause cannot be empty" $$ text "In the pattern synonym declaration for: " <+> ppr (patsyn_name) -recordPatSynErr :: SrcSpan -> LPat RdrName -> P a +recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a recordPatSynErr loc pat = parseErrorSDoc loc $ text "record syntax not supported for pattern synonym declarations:" $$ ppr pat -mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr RdrName] - -> LHsContext RdrName -> HsConDeclDetails RdrName - -> ConDecl RdrName +mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr GhcPs] + -> LHsContext GhcPs -> HsConDeclDetails GhcPs + -> ConDecl GhcPs mkConDeclH98 name mb_forall cxt details = ConDeclH98 { con_name = name @@ -556,8 +557,8 @@ mkConDeclH98 name mb_forall cxt details , con_doc = Nothing } mkGadtDecl :: [Located RdrName] - -> LHsSigType RdrName -- Always a HsForAllTy - -> ConDecl RdrName + -> LHsSigType GhcPs -- Always a HsForAllTy + -> ConDecl GhcPs mkGadtDecl names ty = ConDeclGADT { con_names = names , con_type = ty , con_doc = Nothing } @@ -664,7 +665,8 @@ really doesn't matter! -- * For PrefixCon we keep all the args in the res_ty -- * For RecCon we do not -checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] -> P (LHsQTyVars RdrName) +checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType GhcPs] + -> P (LHsQTyVars GhcPs) -- Same as checkTyVars, but in the P monad checkTyVarsP pp_what equals_or_where tc tparms = eitherToP $ checkTyVars pp_what equals_or_where tc tparms @@ -674,8 +676,8 @@ eitherToP :: Either (SrcSpan, SDoc) a -> P a eitherToP (Left (loc, doc)) = parseErrorSDoc loc doc eitherToP (Right thing) = return thing -checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] - -> Either (SrcSpan, SDoc) (LHsQTyVars RdrName) +checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType GhcPs] + -> Either (SrcSpan, SDoc) (LHsQTyVars GhcPs) -- Check whether the given list of type parameters are all type variables -- (possibly with a kind signature) -- We use the Either monad because it's also called (via mkATDefault) from @@ -708,7 +710,7 @@ whereDots, equalsDots :: SDoc whereDots = text "where ..." equalsDots = text "= ..." -checkDatatypeContext :: Maybe (LHsContext RdrName) -> P () +checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P () checkDatatypeContext Nothing = return () checkDatatypeContext (Just (L loc c)) = do allowed <- extension datatypeContextsEnabled @@ -728,10 +730,10 @@ checkRecordSyntax lr@(L loc r) checkTyClHdr :: Bool -- True <=> class header -- False <=> type header - -> LHsType RdrName - -> P (Located RdrName, -- the head symbol (type or class name) - [LHsType RdrName], -- parameters of head symbol - LexicalFixity, -- the declaration is in infix format + -> LHsType GhcPs + -> P (Located RdrName, -- the head symbol (type or class name) + [LHsType GhcPs], -- parameters of head symbol + LexicalFixity, -- the declaration is in infix format [AddAnn]) -- API Annotation for HsParTy when stripping parens -- Well-formedness check and decomposition of type and class heads. -- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn]) @@ -769,7 +771,7 @@ checkTyClHdr is_cls ty = parseErrorSDoc l (text "Malformed head of type or class declaration:" <+> ppr ty) -checkContext :: LHsType RdrName -> P ([AddAnn],LHsContext RdrName) +checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs) checkContext (L l orig_t) = check [] (L l orig_t) where @@ -794,17 +796,17 @@ checkContext (L l orig_t) -- We parse patterns as expressions and check for valid patterns below, -- converting the expression into a pattern at the same time. -checkPattern :: SDoc -> LHsExpr RdrName -> P (LPat RdrName) +checkPattern :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs) checkPattern msg e = checkLPat msg e -checkPatterns :: SDoc -> [LHsExpr RdrName] -> P [LPat RdrName] +checkPatterns :: SDoc -> [LHsExpr GhcPs] -> P [LPat GhcPs] checkPatterns msg es = mapM (checkPattern msg) es -checkLPat :: SDoc -> LHsExpr RdrName -> P (LPat RdrName) +checkLPat :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs) checkLPat msg e@(L l _) = checkPat msg l e [] -checkPat :: SDoc -> SrcSpan -> LHsExpr RdrName -> [LPat RdrName] - -> P (LPat RdrName) +checkPat :: SDoc -> SrcSpan -> LHsExpr GhcPs -> [LPat GhcPs] + -> P (LPat GhcPs) checkPat _ loc (L l e@(HsVar (L _ c))) args | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args))) | not (null args) && patIsRec c = @@ -824,7 +826,7 @@ checkPat msg loc (L _ e) [] checkPat msg loc e _ = patFail msg loc (unLoc e) -checkAPat :: SDoc -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName) +checkAPat :: SDoc -> SrcSpan -> HsExpr GhcPs -> P (Pat GhcPs) checkAPat msg loc e0 = do pState <- getPState let opts = options pState @@ -895,7 +897,7 @@ checkAPat msg loc e0 = do -> return (SplicePat s) _ -> patFail msg loc e0 -placeHolderPunRhs :: LHsExpr RdrName +placeHolderPunRhs :: LHsExpr GhcPs -- The RHS of a punned record field will be filled in by the renamer -- It's better not to make it an error, in case we want to print it when debugging placeHolderPunRhs = noLoc (HsVar (noLoc pun_RDR)) @@ -905,12 +907,12 @@ plus_RDR = mkUnqual varName (fsLit "+") -- Hack bang_RDR = mkUnqual varName (fsLit "!") -- Hack pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side") -checkPatField :: SDoc -> LHsRecField RdrName (LHsExpr RdrName) - -> P (LHsRecField RdrName (LPat RdrName)) +checkPatField :: SDoc -> LHsRecField GhcPs (LHsExpr GhcPs) + -> P (LHsRecField GhcPs (LPat GhcPs)) checkPatField msg (L l fld) = do p <- checkLPat msg (hsRecFieldArg fld) return (L l (fld { hsRecFieldArg = p })) -patFail :: SDoc -> SrcSpan -> HsExpr RdrName -> P a +patFail :: SDoc -> SrcSpan -> HsExpr GhcPs -> P a patFail msg loc e = parseErrorSDoc loc err where err = text "Parse error in pattern:" <+> ppr e $$ msg @@ -923,10 +925,10 @@ patIsRec e = e == mkUnqual varName (fsLit "rec") -- Check Equation Syntax checkValDef :: SDoc - -> LHsExpr RdrName - -> Maybe (LHsType RdrName) - -> Located (a,GRHSs RdrName (LHsExpr RdrName)) - -> P ([AddAnn],HsBind RdrName) + -> LHsExpr GhcPs + -> Maybe (LHsType GhcPs) + -> Located (a,GRHSs GhcPs (LHsExpr GhcPs)) + -> P ([AddAnn],HsBind GhcPs) checkValDef msg lhs (Just sig) grhss -- x :: ty = rhs parses as a *pattern* binding @@ -946,10 +948,10 @@ checkFunBind :: SDoc -> SrcSpan -> Located RdrName -> LexicalFixity - -> [LHsExpr RdrName] - -> Maybe (LHsType RdrName) - -> Located (GRHSs RdrName (LHsExpr RdrName)) - -> P ([AddAnn],HsBind RdrName) + -> [LHsExpr GhcPs] + -> Maybe (LHsType GhcPs) + -> Located (GRHSs GhcPs (LHsExpr GhcPs)) + -> P ([AddAnn],HsBind GhcPs) checkFunBind msg ann lhs_loc fun is_infix pats opt_sig (L rhs_span grhss) = do ps <- checkPatterns msg pats let match_span = combineSrcSpans lhs_loc rhs_span @@ -963,8 +965,8 @@ checkFunBind msg ann lhs_loc fun is_infix pats opt_sig (L rhs_span grhss) -- The span of the match covers the entire equation. -- That isn't quite right, but it'll do for now. -makeFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] - -> HsBind RdrName +makeFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] + -> HsBind GhcPs -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too makeFunBind fn ms = FunBind { fun_id = fn, @@ -974,15 +976,15 @@ makeFunBind fn ms fun_tick = [] } checkPatBind :: SDoc - -> LHsExpr RdrName - -> Located (a,GRHSs RdrName (LHsExpr RdrName)) - -> P ([AddAnn],HsBind RdrName) + -> LHsExpr GhcPs + -> Located (a,GRHSs GhcPs (LHsExpr GhcPs)) + -> P ([AddAnn],HsBind GhcPs) checkPatBind msg lhs (L _ (_,grhss)) = do { lhs <- checkPattern msg lhs ; return ([],PatBind lhs grhss placeHolderType placeHolderNames ([],[])) } -checkValSigLhs :: LHsExpr RdrName -> P (Located RdrName) +checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName) checkValSigLhs (L _ (HsVar lrdr@(L _ v))) | isUnqual v , not (isDataOcc (rdrNameOcc v)) @@ -1014,11 +1016,11 @@ checkValSigLhs lhs@(L l _) pattern_RDR = mkUnqual varName (fsLit "pattern") -checkDoAndIfThenElse :: LHsExpr RdrName +checkDoAndIfThenElse :: LHsExpr GhcPs -> Bool - -> LHsExpr RdrName + -> LHsExpr GhcPs -> Bool - -> LHsExpr RdrName + -> LHsExpr GhcPs -> P () checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr | semiThen || semiElse @@ -1038,7 +1040,7 @@ checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr -- The parser left-associates, so there should -- not be any OpApps inside the e's -splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName]) +splitBang :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs]) -- Splits (f ! g a b) into (f, [(! g), a, b]) splitBang (L _ (OpApp l_arg bang@(L _ (HsVar (L _ op))) _ r_arg)) | op == bang_RDR = Just (l_arg, L l' (SectionR bang arg1) : argns) @@ -1049,8 +1051,8 @@ splitBang (L _ (OpApp l_arg bang@(L _ (HsVar (L _ op))) _ r_arg)) split_bang e es = (e,es) splitBang _ = Nothing -isFunLhs :: LHsExpr RdrName - -> P (Maybe (Located RdrName, LexicalFixity, [LHsExpr RdrName],[AddAnn])) +isFunLhs :: LHsExpr GhcPs + -> P (Maybe (Located RdrName, LexicalFixity, [LHsExpr GhcPs],[AddAnn])) -- A variable binding is parsed as a FunBind. -- Just (fun, is_infix, arg_pats) if e is a function LHS -- @@ -1104,7 +1106,7 @@ isFunLhs e = go e [] [] -- | Transform btype_no_ops with strict_mark's into HsEqTy's -- (((~a) ~b) c) ~d ==> ((~a) ~ (b c)) ~ d -splitTilde :: LHsType RdrName -> P (LHsType RdrName) +splitTilde :: LHsType GhcPs -> P (LHsType GhcPs) splitTilde t = go t where go (L loc (HsAppTy t1 t2)) | L lo (HsBangTy (HsSrcBang NoSourceText NoSrcUnpack SrcLazy) t2') @@ -1129,7 +1131,7 @@ splitTilde t = go t -- | Transform tyapps with strict_marks into uses of twiddle -- [~a, ~b, c, ~d] ==> (~a) ~ b c ~ d -splitTildeApps :: [LHsAppType RdrName] -> P [LHsAppType RdrName] +splitTildeApps :: [LHsAppType GhcPs] -> P [LHsAppType GhcPs] splitTildeApps [] = return [] splitTildeApps (t : rest) = do rest' <- concatMapM go rest @@ -1170,13 +1172,13 @@ checkMonadComp = do -- We parse arrow syntax as expressions and check for valid syntax below, -- converting the expression into a pattern at the same time. -checkCommand :: LHsExpr RdrName -> P (LHsCmd RdrName) +checkCommand :: LHsExpr GhcPs -> P (LHsCmd GhcPs) checkCommand lc = locMap checkCmd lc locMap :: (SrcSpan -> a -> P b) -> Located a -> P (Located b) locMap f (L l a) = f l a >>= (\b -> return $ L l b) -checkCmd :: SrcSpan -> HsExpr RdrName -> P (HsCmd RdrName) +checkCmd :: SrcSpan -> HsExpr GhcPs -> P (HsCmd GhcPs) checkCmd _ (HsArrApp e1 e2 ptt haat b) = return $ HsCmdArrApp e1 e2 ptt haat b checkCmd _ (HsArrForm e mf args) = @@ -1208,10 +1210,10 @@ checkCmd _ (OpApp eLeft op _fixity eRight) = do checkCmd l e = cmdFail l e -checkCmdLStmt :: ExprLStmt RdrName -> P (CmdLStmt RdrName) +checkCmdLStmt :: ExprLStmt GhcPs -> P (CmdLStmt GhcPs) checkCmdLStmt = locMap checkCmdStmt -checkCmdStmt :: SrcSpan -> ExprStmt RdrName -> P (CmdStmt RdrName) +checkCmdStmt :: SrcSpan -> ExprStmt GhcPs -> P (CmdStmt GhcPs) checkCmdStmt _ (LastStmt e s r) = checkCommand e >>= (\c -> return $ LastStmt c s r) checkCmdStmt _ (BindStmt pat e b f t) = @@ -1224,7 +1226,8 @@ checkCmdStmt _ stmt@(RecStmt { recS_stmts = stmts }) = do return $ stmt { recS_stmts = ss } checkCmdStmt l stmt = cmdStmtFail l stmt -checkCmdMatchGroup :: MatchGroup RdrName (LHsExpr RdrName) -> P (MatchGroup RdrName (LHsCmd RdrName)) +checkCmdMatchGroup :: MatchGroup GhcPs (LHsExpr GhcPs) + -> P (MatchGroup GhcPs (LHsCmd GhcPs)) checkCmdMatchGroup mg@(MG { mg_alts = L l ms }) = do ms' <- mapM (locMap $ const convert) ms return $ mg { mg_alts = L l ms' } @@ -1232,12 +1235,12 @@ checkCmdMatchGroup mg@(MG { mg_alts = L l ms }) = do grhss' <- checkCmdGRHSs grhss return $ Match mf pat mty grhss' -checkCmdGRHSs :: GRHSs RdrName (LHsExpr RdrName) -> P (GRHSs RdrName (LHsCmd RdrName)) +checkCmdGRHSs :: GRHSs GhcPs (LHsExpr GhcPs) -> P (GRHSs GhcPs (LHsCmd GhcPs)) checkCmdGRHSs (GRHSs grhss binds) = do grhss' <- mapM checkCmdGRHS grhss return $ GRHSs grhss' binds -checkCmdGRHS :: LGRHS RdrName (LHsExpr RdrName) -> P (LGRHS RdrName (LHsCmd RdrName)) +checkCmdGRHS :: LGRHS GhcPs (LHsExpr GhcPs) -> P (LGRHS GhcPs (LHsCmd GhcPs)) checkCmdGRHS = locMap $ const convert where convert (GRHS stmts e) = do @@ -1246,9 +1249,9 @@ checkCmdGRHS = locMap $ const convert return $ GRHS {- cmdStmts -} stmts c -cmdFail :: SrcSpan -> HsExpr RdrName -> P a +cmdFail :: SrcSpan -> HsExpr GhcPs -> P a cmdFail loc e = parseErrorSDoc loc (text "Parse error in command:" <+> ppr e) -cmdStmtFail :: SrcSpan -> Stmt RdrName (LHsExpr RdrName) -> P a +cmdStmtFail :: SrcSpan -> Stmt GhcPs (LHsExpr GhcPs) -> P a cmdStmtFail loc e = parseErrorSDoc loc (text "Parse error in command statement:" <+> ppr e) @@ -1262,10 +1265,10 @@ checkPrecP (L l (src,i)) = parseErrorSDoc l (text ("Precedence out of range: " ++ show i)) mkRecConstrOrUpdate - :: LHsExpr RdrName + :: LHsExpr GhcPs -> SrcSpan - -> ([LHsRecField RdrName (LHsExpr RdrName)], Bool) - -> P (HsExpr RdrName) + -> ([LHsRecField GhcPs (LHsExpr GhcPs)], Bool) + -> P (HsExpr GhcPs) mkRecConstrOrUpdate (L l (HsVar (L _ c))) _ (fs,dd) | isRdrDataCon c @@ -1274,14 +1277,14 @@ mkRecConstrOrUpdate exp@(L l _) _ (fs,dd) | dd = parseErrorSDoc l (text "You cannot use `..' in a record update") | otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs)) -mkRdrRecordUpd :: LHsExpr RdrName -> [LHsRecUpdField RdrName] -> HsExpr RdrName +mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs mkRdrRecordUpd exp flds = RecordUpd { rupd_expr = exp , rupd_flds = flds , rupd_cons = PlaceHolder, rupd_in_tys = PlaceHolder , rupd_out_tys = PlaceHolder, rupd_wrap = PlaceHolder } -mkRdrRecordCon :: Located RdrName -> HsRecordBinds RdrName -> HsExpr RdrName +mkRdrRecordCon :: Located RdrName -> HsRecordBinds GhcPs -> HsExpr GhcPs mkRdrRecordCon con flds = RecordCon { rcon_con_name = con, rcon_flds = flds , rcon_con_expr = noPostTcExpr, rcon_con_like = PlaceHolder } @@ -1290,7 +1293,7 @@ mk_rec_fields :: [LHsRecField id arg] -> Bool -> HsRecFields id arg mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) } -mk_rec_upd_field :: HsRecField RdrName (LHsExpr RdrName) -> HsRecUpdField RdrName +mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs mk_rec_upd_field (HsRecField (L loc (FieldOcc rdr _)) arg pun) = HsRecField (L loc (Unambiguous rdr PlaceHolder)) arg pun @@ -1319,8 +1322,8 @@ mkInlinePragma src (inl, match_info) mb_act -- mkImport :: Located CCallConv -> Located Safety - -> (Located StringLiteral, Located RdrName, LHsSigType RdrName) - -> P (HsDecl RdrName) + -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs) + -> P (HsDecl GhcPs) mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) = case cconv of L _ CCallConv -> mkCImport @@ -1419,8 +1422,8 @@ parseCImport cconv safety nm str sourceText = -- construct a foreign export declaration -- mkExport :: Located CCallConv - -> (Located StringLiteral, Located RdrName, LHsSigType RdrName) - -> P (HsDecl RdrName) + -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs) + -> P (HsDecl GhcPs) mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty) = return $ ForD $ ForeignExport { fd_name = v, fd_sig_ty = ty @@ -1452,7 +1455,7 @@ data ImpExpQcSpec = ImpExpQcName (Located RdrName) | ImpExpQcType (Located RdrName) | ImpExpQcWildcard -mkModuleImpExp :: Located ImpExpQcSpec -> ImpExpSubSpec -> P (IE RdrName) +mkModuleImpExp :: Located ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs) mkModuleImpExp (L l specname) subs = case subs of ImpExpAbs @@ -1506,7 +1509,7 @@ mkTypeImpExp name = else parseErrorSDoc (getLoc name) (text "Illegal keyword 'type' (use ExplicitNamespaces to enable)") -checkImportSpec :: Located [LIE RdrName] -> P (Located [LIE RdrName]) +checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs]) checkImportSpec ie@(L _ specs) = case [l | (L l (IEThingWith _ (IEWildcard _) _ _)) <- specs] of [] -> return ie @@ -1538,10 +1541,10 @@ parseErrorSDoc :: SrcSpan -> SDoc -> P a parseErrorSDoc span s = failSpanMsgP span s data SumOrTuple - = Sum ConTag Arity (LHsExpr RdrName) - | Tuple [LHsTupArg RdrName] + = Sum ConTag Arity (LHsExpr GhcPs) + | Tuple [LHsTupArg GhcPs] -mkSumOrTuple :: Boxity -> SrcSpan -> SumOrTuple -> P (HsExpr RdrName) +mkSumOrTuple :: Boxity -> SrcSpan -> SumOrTuple -> P (HsExpr GhcPs) -- Tuple mkSumOrTuple boxity _ (Tuple es) = return (ExplicitTuple es boxity) @@ -1552,7 +1555,7 @@ mkSumOrTuple Unboxed _ (Sum alt arity e) = mkSumOrTuple Boxed l (Sum alt arity (L _ e)) = parseErrorSDoc l (hang (text "Boxed sums not supported:") 2 (ppr_boxed_sum alt arity e)) where - ppr_boxed_sum :: ConTag -> Arity -> HsExpr RdrName -> SDoc + ppr_boxed_sum :: ConTag -> Arity -> HsExpr GhcPs -> SDoc ppr_boxed_sum alt arity e = text "(" <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt) <+> text ")" diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs index 7f0490a68e..5d6d037e6e 100644 --- a/compiler/rename/RnBinds.hs +++ b/compiler/rename/RnBinds.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables, BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -170,12 +171,13 @@ it expects the global environment to contain bindings for the binders -- for top-level bindings, we need to make top-level names, -- so we have a different entry point than for local bindings rnTopBindsLHS :: MiniFixityEnv - -> HsValBinds RdrName - -> RnM (HsValBindsLR Name RdrName) + -> HsValBinds GhcPs + -> RnM (HsValBindsLR GhcRn GhcPs) rnTopBindsLHS fix_env binds = rnValBindsLHS (topRecNameMaker fix_env) binds -rnTopBindsBoot :: NameSet -> HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) +rnTopBindsBoot :: NameSet -> HsValBindsLR GhcRn GhcPs + -> RnM (HsValBinds GhcRn, DefUses) -- A hs-boot file has no bindings. -- Return a single HsBindGroup with empty binds and renamed signatures rnTopBindsBoot bound_names (ValBindsIn mbinds sigs) @@ -192,9 +194,9 @@ rnTopBindsBoot _ b = pprPanic "rnTopBindsBoot" (ppr b) ********************************************************* -} -rnLocalBindsAndThen :: HsLocalBinds RdrName - -> (HsLocalBinds Name -> FreeVars -> RnM (result, FreeVars)) - -> RnM (result, FreeVars) +rnLocalBindsAndThen :: HsLocalBinds GhcPs + -> (HsLocalBinds GhcRn -> FreeVars -> RnM (result, FreeVars)) + -> RnM (result, FreeVars) -- This version (a) assumes that the binding vars are *not* already in scope -- (b) removes the binders from the free vars of the thing inside -- The parser doesn't produce ThenBinds @@ -210,12 +212,12 @@ rnLocalBindsAndThen (HsIPBinds binds) thing_inside = do (thing, fvs_thing) <- thing_inside (HsIPBinds binds') fv_binds return (thing, fvs_thing `plusFV` fv_binds) -rnIPBinds :: HsIPBinds RdrName -> RnM (HsIPBinds Name, FreeVars) +rnIPBinds :: HsIPBinds GhcPs -> RnM (HsIPBinds GhcRn, FreeVars) rnIPBinds (IPBinds ip_binds _no_dict_binds) = do (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds return (IPBinds ip_binds' emptyTcEvBinds, plusFVs fvs_s) -rnIPBind :: IPBind RdrName -> RnM (IPBind Name, FreeVars) +rnIPBind :: IPBind GhcPs -> RnM (IPBind GhcRn, FreeVars) rnIPBind (IPBind ~(Left n) expr) = do (expr',fvExpr) <- rnLExpr expr return (IPBind (Left n) expr', fvExpr) @@ -231,8 +233,8 @@ rnIPBind (IPBind ~(Left n) expr) = do -- Renaming local binding groups -- Does duplicate/shadow check rnLocalValBindsLHS :: MiniFixityEnv - -> HsValBinds RdrName - -> RnM ([Name], HsValBindsLR Name RdrName) + -> HsValBinds GhcPs + -> RnM ([Name], HsValBindsLR GhcRn GhcPs) rnLocalValBindsLHS fix_env binds = do { binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds @@ -267,8 +269,8 @@ rnLocalValBindsLHS fix_env binds -- generic version used both at the top level and for local binds -- does some error checking, but not what gets done elsewhere at the top level rnValBindsLHS :: NameMaker - -> HsValBinds RdrName - -> RnM (HsValBindsLR Name RdrName) + -> HsValBinds GhcPs + -> RnM (HsValBindsLR GhcRn GhcPs) rnValBindsLHS topP (ValBindsIn mbinds sigs) = do { mbinds' <- mapBagM (wrapLocM (rnBindLHS topP doc)) mbinds ; return $ ValBindsIn mbinds' sigs } @@ -283,8 +285,8 @@ rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b) -- -- Does not bind the local fixity declarations rnValBindsRHS :: HsSigCtxt - -> HsValBindsLR Name RdrName - -> RnM (HsValBinds Name, DefUses) + -> HsValBindsLR GhcRn GhcPs + -> RnM (HsValBinds GhcRn, DefUses) rnValBindsRHS ctxt (ValBindsIn mbinds sigs) = do { (sigs', sig_fvs) <- renameSigs ctxt sigs @@ -317,8 +319,8 @@ rnValBindsRHS _ b = pprPanic "rnValBindsRHS" (ppr b) -- -- The client is also responsible for bringing the fixities into scope rnLocalValBindsRHS :: NameSet -- names bound by the LHSes - -> HsValBindsLR Name RdrName - -> RnM (HsValBinds Name, DefUses) + -> HsValBindsLR GhcRn GhcPs + -> RnM (HsValBinds GhcRn, DefUses) rnLocalValBindsRHS bound_names binds = rnValBindsRHS (LocalBindCtxt bound_names) binds @@ -328,8 +330,8 @@ rnLocalValBindsRHS bound_names binds -- here there are no local fixity decls passed in; -- the local fixity decls come from the ValBinds sigs rnLocalValBindsAndThen - :: HsValBinds RdrName - -> (HsValBinds Name -> FreeVars -> RnM (result, FreeVars)) + :: HsValBinds GhcPs + -> (HsValBinds GhcRn -> FreeVars -> RnM (result, FreeVars)) -> RnM (result, FreeVars) rnLocalValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside = do { -- (A) Create the local fixity environment @@ -390,11 +392,11 @@ rnLocalValBindsAndThen bs _ = pprPanic "rnLocalValBindsAndThen" (ppr bs) rnBindLHS :: NameMaker -> SDoc - -> HsBind RdrName + -> HsBind GhcPs -- returns the renamed left-hand side, -- and the FreeVars *of the LHS* -- (i.e., any free variables of the pattern) - -> RnM (HsBindLR Name RdrName) + -> RnM (HsBindLR GhcRn GhcPs) rnBindLHS name_maker _ bind@(PatBind { pat_lhs = pat }) = do @@ -429,18 +431,18 @@ rnBindLHS name_maker _ (PatSynBind psb@PSB{ psb_id = rdrname }) rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b) -rnLBind :: (Name -> [Name]) -- Signature tyvar function - -> LHsBindLR Name RdrName - -> RnM (LHsBind Name, [Name], Uses) +rnLBind :: (Name -> [Name]) -- Signature tyvar function + -> LHsBindLR GhcRn GhcPs + -> RnM (LHsBind GhcRn, [Name], Uses) rnLBind sig_fn (L loc bind) = setSrcSpan loc $ do { (bind', bndrs, dus) <- rnBind sig_fn bind ; return (L loc bind', bndrs, dus) } -- assumes the left-hands-side vars are in scope -rnBind :: (Name -> [Name]) -- Signature tyvar function - -> HsBindLR Name RdrName - -> RnM (HsBind Name, [Name], Uses) +rnBind :: (Name -> [Name]) -- Signature tyvar function + -> HsBindLR GhcRn GhcPs + -> RnM (HsBind GhcRn, [Name], Uses) rnBind _ bind@(PatBind { pat_lhs = pat , pat_rhs = grhss -- pat fvs were stored in bind_fvs @@ -542,8 +544,8 @@ trac ticket #1136. * * ********************************************************************* -} -depAnalBinds :: Bag (LHsBind Name, [Name], Uses) - -> ([(RecFlag, LHsBinds Name)], DefUses) +depAnalBinds :: Bag (LHsBind GhcRn, [Name], Uses) + -> ([(RecFlag, LHsBinds GhcRn)], DefUses) -- Dependency analysis; this is important so that -- unused-binding reporting is accurate depAnalBinds binds_w_dus @@ -577,14 +579,14 @@ depAnalBinds binds_w_dus -- (x,y) = e -- In e, 'a' will be in scope, and it'll be the one from 'y'! -mkSigTvFn :: [LSig Name] -> (Name -> [Name]) +mkSigTvFn :: [LSig GhcRn] -> (Name -> [Name]) -- Return a lookup function that maps an Id Name to the names -- of the type variables that should scope over its body. mkSigTvFn sigs = \n -> lookupNameEnv env n `orElse` [] where env = mkHsSigEnv get_scoped_tvs sigs - get_scoped_tvs :: LSig Name -> Maybe ([Located Name], [Name]) + get_scoped_tvs :: LSig GhcRn -> Maybe ([Located Name], [Name]) -- Returns (binders, scoped tvs for those binders) get_scoped_tvs (L _ (ClassOpSig _ names sig_ty)) = Just (names, hsScopedTvs sig_ty) @@ -601,7 +603,7 @@ mkSigTvFn sigs = \n -> lookupNameEnv env n `orElse` [] -- Note: for local fixity declarations, duplicates would also be checked in -- check_sigs below. But we also use this function at the top level. -makeMiniFixityEnv :: [LFixitySig RdrName] -> RnM MiniFixityEnv +makeMiniFixityEnv :: [LFixitySig GhcPs] -> RnM MiniFixityEnv makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls where @@ -637,9 +639,9 @@ dupFixityDecl loc rdr_name * * ********************************************************************* -} -rnPatSynBind :: (Name -> [Name]) -- Signature tyvar function - -> PatSynBind Name RdrName - -> RnM (PatSynBind Name Name, [Name], Uses) +rnPatSynBind :: (Name -> [Name]) -- Signature tyvar function + -> PatSynBind GhcRn GhcPs + -> RnM (PatSynBind GhcRn GhcRn, [Name], Uses) rnPatSynBind sig_fn bind@(PSB { psb_id = L l name , psb_args = details , psb_def = pat @@ -809,9 +811,9 @@ a binder. rnMethodBinds :: Bool -- True <=> is a class declaration -> Name -- Class name -> [Name] -- Type variables from the class/instance header - -> LHsBinds RdrName -- Binds - -> [LSig RdrName] -- and signatures/pragmas - -> RnM (LHsBinds Name, [LSig Name], FreeVars) + -> LHsBinds GhcPs -- Binds + -> [LSig GhcPs] -- and signatures/pragmas + -> RnM (LHsBinds GhcRn, [LSig GhcRn], FreeVars) -- Used for -- * the default method bindings in a class decl -- * the method bindings in an instance decl @@ -864,9 +866,9 @@ rnMethodBinds is_cls_decl cls ktv_names binds sigs | otherwise = thing_inside rnMethodBindLHS :: Bool -> Name - -> LHsBindLR RdrName RdrName - -> LHsBindsLR Name RdrName - -> RnM (LHsBindsLR Name RdrName) + -> LHsBindLR GhcPs GhcPs + -> LHsBindsLR GhcRn GhcPs + -> RnM (LHsBindsLR GhcRn GhcPs) rnMethodBindLHS _ cls (L loc bind@(FunBind { fun_id = name })) rest = setSrcSpan loc $ do do { sel_name <- wrapLocM (lookupInstDeclBndr cls (text "method")) name @@ -910,8 +912,8 @@ signatures. We'd only need this if we wanted to report unused tyvars. -} renameSigs :: HsSigCtxt - -> [LSig RdrName] - -> RnM ([LSig Name], FreeVars) + -> [LSig GhcPs] + -> RnM ([LSig GhcRn], FreeVars) -- Renames the signatures and performs error checks renameSigs ctxt sigs = do { mapM_ dupSigDeclErr (findDupSigs sigs) @@ -935,7 +937,7 @@ renameSigs ctxt sigs -- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.) -- Doesn't seem worth much trouble to sort this. -renameSig :: HsSigCtxt -> Sig RdrName -> RnM (Sig Name, FreeVars) +renameSig :: HsSigCtxt -> Sig GhcPs -> RnM (Sig GhcRn, FreeVars) -- FixitySig is renamed elsewhere. renameSig _ (IdSig x) = return (IdSig x, emptyFVs) -- Actually this never occurs @@ -1089,7 +1091,7 @@ okHsSig ctxt (L _ sig) (CompleteMatchSig {}, _) -> False ------------------- -findDupSigs :: [LSig RdrName] -> [[(Located RdrName, Sig RdrName)]] +findDupSigs :: [LSig GhcPs] -> [[(Located RdrName, Sig GhcPs)]] -- Check for duplicates on RdrName version, -- because renamed version has unboundName for -- not-in-scope binders, which gives bogus dup-sig errors @@ -1119,7 +1121,7 @@ findDupSigs sigs mtch _ _ = False -- Warn about multiple MINIMAL signatures -checkDupMinimalSigs :: [LSig RdrName] -> RnM () +checkDupMinimalSigs :: [LSig GhcPs] -> RnM () checkDupMinimalSigs sigs = case filter isMinimalLSig sigs of minSigs@(_:_:_) -> dupMinimalSigErr minSigs @@ -1133,26 +1135,26 @@ checkDupMinimalSigs sigs ************************************************************************ -} -rnMatchGroup :: Outputable (body RdrName) => HsMatchContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) - -> MatchGroup RdrName (Located (body RdrName)) - -> RnM (MatchGroup Name (Located (body Name)), FreeVars) +rnMatchGroup :: Outputable (body GhcPs) => HsMatchContext Name + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> MatchGroup GhcPs (Located (body GhcPs)) + -> RnM (MatchGroup GhcRn (Located (body GhcRn)), FreeVars) rnMatchGroup ctxt rnBody (MG { mg_alts = L _ ms, mg_origin = origin }) = do { empty_case_ok <- xoptM LangExt.EmptyCase ; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt)) ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms ; return (mkMatchGroup origin new_ms, ms_fvs) } -rnMatch :: Outputable (body RdrName) => HsMatchContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) - -> LMatch RdrName (Located (body RdrName)) - -> RnM (LMatch Name (Located (body Name)), FreeVars) +rnMatch :: Outputable (body GhcPs) => HsMatchContext Name + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> LMatch GhcPs (Located (body GhcPs)) + -> RnM (LMatch GhcRn (Located (body GhcRn)), FreeVars) rnMatch ctxt rnBody = wrapLocFstM (rnMatch' ctxt rnBody) -rnMatch' :: Outputable (body RdrName) => HsMatchContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) - -> Match RdrName (Located (body RdrName)) - -> RnM (Match Name (Located (body Name)), FreeVars) +rnMatch' :: Outputable (body GhcPs) => HsMatchContext Name + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> Match GhcPs (Located (body GhcPs)) + -> RnM (Match GhcRn (Located (body GhcRn)), FreeVars) rnMatch' ctxt rnBody match@(Match { m_ctxt = mf, m_pats = pats , m_type = maybe_rhs_sig, m_grhss = grhss }) = do { -- Result type signatures are no longer supported @@ -1183,7 +1185,7 @@ emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt) resSigErr :: Outputable body - => Match RdrName body -> HsType RdrName -> SDoc + => Match GhcPs body -> HsType GhcPs -> SDoc resSigErr match ty = vcat [ text "Illegal result type signature" <+> quotes (ppr ty) , nest 2 $ ptext (sLit @@ -1199,24 +1201,24 @@ resSigErr match ty -} rnGRHSs :: HsMatchContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) - -> GRHSs RdrName (Located (body RdrName)) - -> RnM (GRHSs Name (Located (body Name)), FreeVars) + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> GRHSs GhcPs (Located (body GhcPs)) + -> RnM (GRHSs GhcRn (Located (body GhcRn)), FreeVars) rnGRHSs ctxt rnBody (GRHSs grhss (L l binds)) = rnLocalBindsAndThen binds $ \ binds' _ -> do (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss return (GRHSs grhss' (L l binds'), fvGRHSs) rnGRHS :: HsMatchContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) - -> LGRHS RdrName (Located (body RdrName)) - -> RnM (LGRHS Name (Located (body Name)), FreeVars) + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> LGRHS GhcPs (Located (body GhcPs)) + -> RnM (LGRHS GhcRn (Located (body GhcRn)), FreeVars) rnGRHS ctxt rnBody = wrapLocFstM (rnGRHS' ctxt rnBody) rnGRHS' :: HsMatchContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) - -> GRHS RdrName (Located (body RdrName)) - -> RnM (GRHS Name (Located (body Name)), FreeVars) + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> GRHS GhcPs (Located (body GhcPs)) + -> RnM (GRHS GhcRn (Located (body GhcRn)), FreeVars) rnGRHS' ctxt rnBody (GRHS guards rhs) = do { pattern_guards_allowed <- xoptM LangExt.PatternGuards ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnLExpr guards $ \ _ -> @@ -1242,7 +1244,7 @@ rnGRHS' ctxt rnBody (GRHS guards rhs) ************************************************************************ -} -dupSigDeclErr :: [(Located RdrName, Sig RdrName)] -> RnM () +dupSigDeclErr :: [(Located RdrName, Sig GhcPs)] -> RnM () dupSigDeclErr pairs@((L loc name, sig) : _) = addErrAt loc $ vcat [ text "Duplicate" <+> what_it_is @@ -1253,32 +1255,32 @@ dupSigDeclErr pairs@((L loc name, sig) : _) dupSigDeclErr [] = panic "dupSigDeclErr" -misplacedSigErr :: LSig Name -> RnM () +misplacedSigErr :: LSig GhcRn -> RnM () misplacedSigErr (L loc sig) = addErrAt loc $ sep [text "Misplaced" <+> hsSigDoc sig <> colon, ppr sig] -defaultSigErr :: Sig RdrName -> SDoc +defaultSigErr :: Sig GhcPs -> SDoc defaultSigErr sig = vcat [ hang (text "Unexpected default signature:") 2 (ppr sig) , text "Use DefaultSignatures to enable default signatures" ] -bindsInHsBootFile :: LHsBindsLR Name RdrName -> SDoc +bindsInHsBootFile :: LHsBindsLR GhcRn GhcPs -> SDoc bindsInHsBootFile mbinds = hang (text "Bindings in hs-boot files are not allowed") 2 (ppr mbinds) -nonStdGuardErr :: Outputable body => [LStmtLR Name Name body] -> SDoc +nonStdGuardErr :: Outputable body => [LStmtLR GhcRn GhcRn body] -> SDoc nonStdGuardErr guards = hang (text "accepting non-standard pattern guards (use PatternGuards to suppress this message)") 4 (interpp'SP guards) -unusedPatBindWarn :: HsBind Name -> SDoc +unusedPatBindWarn :: HsBind GhcRn -> SDoc unusedPatBindWarn bind = hang (text "This pattern-binding binds no variables:") 2 (ppr bind) -dupMinimalSigErr :: [LSig RdrName] -> RnM () +dupMinimalSigErr :: [LSig GhcPs] -> RnM () dupMinimalSigErr sigs@(L loc _ : _) = addErrAt loc $ vcat [ text "Multiple minimal complete definitions" diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs index 902c10a379..2ad4413920 100644 --- a/compiler/rename/RnEnv.hs +++ b/compiler/rename/RnEnv.hs @@ -385,7 +385,8 @@ lookupInstDeclBndr cls what rdr doc = what <+> text "of class" <+> quotes (ppr cls) ----------------------------------------------- -lookupFamInstName :: Maybe Name -> Located RdrName -> RnM (Located Name) +lookupFamInstName :: Maybe Name -> Located RdrName + -> RnM (Located Name) -- Used for TyData and TySynonym family instances only, -- See Note [Family instance binders] lookupFamInstName (Just cls) tc_rdr -- Associated type; c.f RnBinds.rnMethodBind @@ -440,8 +441,8 @@ lookupExactOrOrig rdr_name res k -- unambiguous because there is only one field id 'fld' in scope. -- But currently it's rejected. -lookupRecFieldOcc :: Maybe Name -- Nothing => just look it up as usual - -- Just tycon => use tycon to disambiguate +lookupRecFieldOcc :: Maybe Name -- Nothing => just look it up as usual + -- Just tycon => use tycon to disambiguate -> SDoc -> RdrName -> RnM Name lookupRecFieldOcc parent doc rdr_name @@ -612,8 +613,8 @@ data ChildLookupResult Name -- Name of thing we were looking for SDoc -- How to print the name [Name] -- List of possible parents - | FoundName Parent Name -- We resolved to a normal name - | FoundFL FieldLabel -- We resolved to a FL + | FoundName Parent Name -- We resolved to a normal name + | FoundFL FieldLabel -- We resolved to a FL -- | Specialised version of msum for RnM ChildLookupResult combineChildLookupResult :: [RnM ChildLookupResult] -> RnM ChildLookupResult @@ -935,7 +936,8 @@ lookupOccRnX_maybe globalLookup wrapper rdr_name lookupOccRn_maybe :: RdrName -> RnM (Maybe Name) lookupOccRn_maybe = lookupOccRnX_maybe lookupGlobalOccRn_maybe id -lookupOccRn_overloaded :: Bool -> RdrName -> RnM (Maybe (Either Name [Name])) +lookupOccRn_overloaded :: Bool -> RdrName + -> RnM (Maybe (Either Name [Name])) lookupOccRn_overloaded overload_ok = lookupOccRnX_maybe global_lookup Left where @@ -1343,7 +1345,7 @@ instance Outputable HsSigCtxt where ppr (RoleAnnotCtxt ns) = text "RoleAnnotCtxt" <+> ppr ns lookupSigOccRn :: HsSigCtxt - -> Sig RdrName + -> Sig GhcPs -> Located RdrName -> RnM (Located Name) lookupSigOccRn ctxt sig = lookupSigCtxtOccRn ctxt (hsSigDoc sig) @@ -1507,10 +1509,10 @@ We treat the original (standard) names as free-vars too, because the type checke checks the type of the user thing against the type of the standard thing. -} -lookupIfThenElse :: RnM (Maybe (SyntaxExpr Name), FreeVars) +lookupIfThenElse :: RnM (Maybe (SyntaxExpr GhcRn), FreeVars) -- Different to lookupSyntaxName because in the non-rebindable -- case we desugar directly rather than calling an existing function --- Hence the (Maybe (SyntaxExpr Name)) return type +-- Hence the (Maybe (SyntaxExpr GhcRn)) return type lookupIfThenElse = do { rebindable_on <- xoptM LangExt.RebindableSyntax ; if not rebindable_on @@ -1529,8 +1531,9 @@ lookupSyntaxName' std_name -- Get the similarly named thing from the local environment lookupOccRn (mkRdrUnqual (nameOccName std_name)) } -lookupSyntaxName :: Name -- The standard name - -> RnM (SyntaxExpr Name, FreeVars) -- Possibly a non-standard name +lookupSyntaxName :: Name -- The standard name + -> RnM (SyntaxExpr GhcRn, FreeVars) -- Possibly a non-standard + -- name lookupSyntaxName std_name = do { rebindable_on <- xoptM LangExt.RebindableSyntax ; if not rebindable_on then @@ -1540,8 +1543,8 @@ lookupSyntaxName std_name do { usr_name <- lookupOccRn (mkRdrUnqual (nameOccName std_name)) ; return (mkRnSyntaxExpr usr_name, unitFV usr_name) } } -lookupSyntaxNames :: [Name] -- Standard names - -> RnM ([HsExpr Name], FreeVars) -- See comments with HsExpr.ReboundNames +lookupSyntaxNames :: [Name] -- Standard names + -> RnM ([HsExpr GhcRn], FreeVars) -- See comments with HsExpr.ReboundNames -- this works with CmdTop, which wants HsExprs, not SyntaxExprs lookupSyntaxNames std_names = do { rebindable_on <- xoptM LangExt.RebindableSyntax diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index 027f6dc178..e1a314f029 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -13,6 +13,7 @@ free variables. {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TypeFamilies #-} module RnExpr ( rnLExpr, rnExpr, rnStmts @@ -65,7 +66,7 @@ import Data.Array ************************************************************************ -} -rnExprs :: [LHsExpr RdrName] -> RnM ([LHsExpr Name], FreeVars) +rnExprs :: [LHsExpr GhcPs] -> RnM ([LHsExpr GhcRn], FreeVars) rnExprs ls = rnExprs' ls emptyUniqSet where rnExprs' [] acc = return ([], acc) @@ -79,12 +80,12 @@ rnExprs ls = rnExprs' ls emptyUniqSet -- Variables. We look up the variable and return the resulting name. -rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars) +rnLExpr :: LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars) rnLExpr = wrapLocFstM rnExpr -rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars) +rnExpr :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) -finishHsVar :: Located Name -> RnM (HsExpr Name, FreeVars) +finishHsVar :: Located Name -> RnM (HsExpr GhcRn, FreeVars) -- Separated from rnExpr because it's also used -- when renaming infix expressions finishHsVar (L l name) @@ -93,7 +94,7 @@ finishHsVar (L l name) checkThLocalName name ; return (HsVar (L l name), unitFV name) } -rnUnboundVar :: RdrName -> RnM (HsExpr Name, FreeVars) +rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars) rnUnboundVar v = do { if isUnqual v then -- Treat this as a "hole" @@ -145,11 +146,11 @@ rnExpr (HsLit lit@(HsString src s)) rnExpr (HsOverLit (mkHsIsString src s placeHolderType)) else do { ; rnLit lit - ; return (HsLit lit, emptyFVs) } } + ; return (HsLit (convertLit lit), emptyFVs) } } rnExpr (HsLit lit) = do { rnLit lit - ; return (HsLit lit, emptyFVs) } + ; return (HsLit (convertLit lit), emptyFVs) } rnExpr (HsOverLit lit) = do { ((lit', mb_neg), fvs) <- rnOverLit lit -- See Note [Negative zero] @@ -409,7 +410,7 @@ rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other) hsHoleExpr :: HsExpr id hsHoleExpr = HsUnboundVar (TrueExprHole (mkVarOcc "_")) -arrowFail :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars) +arrowFail :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) arrowFail e = do { addErr (vcat [ text "Arrow command found where an expression was expected:" , nest 2 (ppr e) ]) @@ -419,7 +420,7 @@ arrowFail e ---------------------- -- See Note [Parsing sections] in Parser.y -rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars) +rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) rnSection section@(SectionR op expr) = do { (op', fvs_op) <- rnLExpr op ; (expr', fvs_expr) <- rnLExpr expr @@ -442,14 +443,14 @@ rnSection other = pprPanic "rnSection" (ppr other) ************************************************************************ -} -rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars) +rnCmdArgs :: [LHsCmdTop GhcPs] -> RnM ([LHsCmdTop GhcRn], FreeVars) rnCmdArgs [] = return ([], emptyFVs) rnCmdArgs (arg:args) = do { (arg',fvArg) <- rnCmdTop arg ; (args',fvArgs) <- rnCmdArgs args ; return (arg':args', fvArg `plusFV` fvArgs) } -rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars) +rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars) rnCmdTop = wrapLocFstM rnCmdTop' where rnCmdTop' (HsCmdTop cmd _ _ _) @@ -463,10 +464,10 @@ rnCmdTop = wrapLocFstM rnCmdTop' (cmd_names `zip` cmd_names'), fvCmd `plusFV` cmd_fvs) } -rnLCmd :: LHsCmd RdrName -> RnM (LHsCmd Name, FreeVars) +rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars) rnLCmd = wrapLocFstM rnCmd -rnCmd :: HsCmd RdrName -> RnM (HsCmd Name, FreeVars) +rnCmd :: HsCmd GhcPs -> RnM (HsCmd GhcRn, FreeVars) rnCmd (HsCmdArrApp arrow arg _ ho rtl) = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow) @@ -541,10 +542,10 @@ type CmdNeeds = FreeVars -- Only inhabitants are -- appAName, choiceAName, loopAName -- find what methods the Cmd needs (loop, choice, apply) -methodNamesLCmd :: LHsCmd Name -> CmdNeeds +methodNamesLCmd :: LHsCmd GhcRn -> CmdNeeds methodNamesLCmd = methodNamesCmd . unLoc -methodNamesCmd :: HsCmd Name -> CmdNeeds +methodNamesCmd :: HsCmd GhcRn -> CmdNeeds methodNamesCmd (HsCmdArrApp _arrow _arg _ HsFirstOrderApp _rtl) = emptyFVs @@ -572,7 +573,7 @@ methodNamesCmd (HsCmdCase _ matches) -- The type checker will complain later --------------------------------------------------- -methodNamesMatch :: MatchGroup Name (LHsCmd Name) -> FreeVars +methodNamesMatch :: MatchGroup GhcRn (LHsCmd GhcRn) -> FreeVars methodNamesMatch (MG { mg_alts = L _ ms }) = plusFVs (map do_one ms) where @@ -580,23 +581,23 @@ methodNamesMatch (MG { mg_alts = L _ ms }) ------------------------------------------------- -- gaw 2004 -methodNamesGRHSs :: GRHSs Name (LHsCmd Name) -> FreeVars +methodNamesGRHSs :: GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss) ------------------------------------------------- -methodNamesGRHS :: Located (GRHS Name (LHsCmd Name)) -> CmdNeeds +methodNamesGRHS :: Located (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs --------------------------------------------------- -methodNamesStmts :: [Located (StmtLR Name Name (LHsCmd Name))] -> FreeVars +methodNamesStmts :: [Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn))] -> FreeVars methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts) --------------------------------------------------- -methodNamesLStmt :: Located (StmtLR Name Name (LHsCmd Name)) -> FreeVars +methodNamesLStmt :: Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn)) -> FreeVars methodNamesLStmt = methodNamesStmt . unLoc -methodNamesStmt :: StmtLR Name Name (LHsCmd Name) -> FreeVars +methodNamesStmt :: StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars methodNamesStmt (LastStmt cmd _ _) = methodNamesLCmd cmd methodNamesStmt (BodyStmt cmd _ _ _) = methodNamesLCmd cmd methodNamesStmt (BindStmt _ cmd _ _ _) = methodNamesLCmd cmd @@ -617,7 +618,7 @@ methodNamesStmt ApplicativeStmt{} = emptyFVs ************************************************************************ -} -rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars) +rnArithSeq :: ArithSeqInfo GhcPs -> RnM (ArithSeqInfo GhcRn, FreeVars) rnArithSeq (From expr) = do { (expr', fvExpr) <- rnLExpr expr ; return (From expr', fvExpr) } @@ -669,34 +670,34 @@ See Note [Deterministic UniqFM] to learn more about nondeterminism. -} -- | Rename some Stmts -rnStmts :: Outputable (body RdrName) +rnStmts :: Outputable (body GhcPs) => HsStmtContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -- ^ How to rename the body of each statement (e.g. rnLExpr) - -> [LStmt RdrName (Located (body RdrName))] + -> [LStmt GhcPs (Located (body GhcPs))] -- ^ Statements -> ([Name] -> RnM (thing, FreeVars)) -- ^ if these statements scope over something, this renames it -- and returns the result. - -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars) + -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars) rnStmts ctxt rnBody = rnStmtsWithPostProcessing ctxt rnBody noPostProcessStmts -- | like 'rnStmts' but applies a post-processing step to the renamed Stmts rnStmtsWithPostProcessing - :: Outputable (body RdrName) + :: Outputable (body GhcPs) => HsStmtContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -- ^ How to rename the body of each statement (e.g. rnLExpr) -> (HsStmtContext Name - -> [(LStmt Name (Located (body Name)), FreeVars)] - -> RnM ([LStmt Name (Located (body Name))], FreeVars)) + -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] + -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars)) -- ^ postprocess the statements - -> [LStmt RdrName (Located (body RdrName))] + -> [LStmt GhcPs (Located (body GhcPs))] -- ^ Statements -> ([Name] -> RnM (thing, FreeVars)) -- ^ if these statements scope over something, this renames it -- and returns the result. - -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars) + -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars) rnStmtsWithPostProcessing ctxt rnBody ppStmts stmts thing_inside = do { ((stmts', thing), fvs) <- rnStmtsWithFreeVars ctxt rnBody stmts thing_inside @@ -707,8 +708,8 @@ rnStmtsWithPostProcessing ctxt rnBody ppStmts stmts thing_inside -- | maybe rearrange statements according to the ApplicativeDo transformation postProcessStmtsForApplicativeDo :: HsStmtContext Name - -> [(ExprLStmt Name, FreeVars)] - -> RnM ([ExprLStmt Name], FreeVars) + -> [(ExprLStmt GhcRn, FreeVars)] + -> RnM ([ExprLStmt GhcRn], FreeVars) postProcessStmtsForApplicativeDo ctxt stmts = do { -- rearrange the statements using ApplicativeStmt if @@ -724,17 +725,17 @@ postProcessStmtsForApplicativeDo ctxt stmts -- | strip the FreeVars annotations from statements noPostProcessStmts :: HsStmtContext Name - -> [(LStmt Name (Located (body Name)), FreeVars)] - -> RnM ([LStmt Name (Located (body Name))], FreeVars) + -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] + -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars) noPostProcessStmts _ stmts = return (map fst stmts, emptyNameSet) -rnStmtsWithFreeVars :: Outputable (body RdrName) +rnStmtsWithFreeVars :: Outputable (body GhcPs) => HsStmtContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) - -> [LStmt RdrName (Located (body RdrName))] + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> [LStmt GhcPs (Located (body GhcPs))] -> ([Name] -> RnM (thing, FreeVars)) - -> RnM ( ([(LStmt Name (Located (body Name)), FreeVars)], thing) + -> RnM ( ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing) , FreeVars) -- Each Stmt body is annotated with its FreeVars, so that -- we can rearrange statements for ApplicativeDo. @@ -792,15 +793,15 @@ exhaustive list). How we deal with pattern match failure is context-dependent. At one point we failed to make this distinction, leading to #11216. -} -rnStmt :: Outputable (body RdrName) +rnStmt :: Outputable (body GhcPs) => HsStmtContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -- ^ How to rename the body of the statement - -> LStmt RdrName (Located (body RdrName)) + -> LStmt GhcPs (Located (body GhcPs)) -- ^ The statement -> ([Name] -> RnM (thing, FreeVars)) -- ^ Rename the stuff that this statement scopes over - -> RnM ( ([(LStmt Name (Located (body Name)), FreeVars)], thing) + -> RnM ( ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing) , FreeVars) -- Variables bound by the Stmt, and mentioned in thing_inside, -- do not appear in the result FreeVars @@ -938,18 +939,18 @@ rnStmt _ _ (L _ ApplicativeStmt{}) _ = panic "rnStmt: ApplicativeStmt" rnParallelStmts :: forall thing. HsStmtContext Name - -> SyntaxExpr Name - -> [ParStmtBlock RdrName RdrName] + -> SyntaxExpr GhcRn + -> [ParStmtBlock GhcPs GhcPs] -> ([Name] -> RnM (thing, FreeVars)) - -> RnM (([ParStmtBlock Name Name], thing), FreeVars) + -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars) -- Note [Renaming parallel Stmts] rnParallelStmts ctxt return_op segs thing_inside = do { orig_lcl_env <- getLocalRdrEnv ; rn_segs orig_lcl_env [] segs } where rn_segs :: LocalRdrEnv - -> [Name] -> [ParStmtBlock RdrName RdrName] - -> RnM (([ParStmtBlock Name Name], thing), FreeVars) + -> [Name] -> [ParStmtBlock GhcPs GhcPs] + -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars) rn_segs _ bndrs_so_far [] = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far ; mapM_ dupErr dups @@ -971,7 +972,7 @@ rnParallelStmts ctxt return_op segs thing_inside dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:" <+> quotes (ppr (head vs))) -lookupStmtName :: HsStmtContext Name -> Name -> RnM (SyntaxExpr Name, FreeVars) +lookupStmtName :: HsStmtContext Name -> Name -> RnM (SyntaxExpr GhcRn, FreeVars) -- Like lookupSyntaxName, but respects contexts lookupStmtName ctxt n | rebindableContext ctxt @@ -979,7 +980,7 @@ lookupStmtName ctxt n | otherwise = return (mkRnSyntaxExpr n, emptyFVs) -lookupStmtNamePoly :: HsStmtContext Name -> Name -> RnM (HsExpr Name, FreeVars) +lookupStmtNamePoly :: HsStmtContext Name -> Name -> RnM (HsExpr GhcRn, FreeVars) lookupStmtNamePoly ctxt name | rebindableContext ctxt = do { rebindable_on <- xoptM LangExt.RebindableSyntax @@ -1047,13 +1048,13 @@ type Segment stmts = (Defs, -- wrapper that does both the left- and right-hand sides -rnRecStmtsAndThen :: Outputable (body RdrName) => - (Located (body RdrName) - -> RnM (Located (body Name), FreeVars)) - -> [LStmt RdrName (Located (body RdrName))] +rnRecStmtsAndThen :: Outputable (body GhcPs) => + (Located (body GhcPs) + -> RnM (Located (body GhcRn), FreeVars)) + -> [LStmt GhcPs (Located (body GhcPs))] -- assumes that the FreeVars returned includes -- the FreeVars of the Segments - -> ([Segment (LStmt Name (Located (body Name)))] + -> ([Segment (LStmt GhcRn (Located (body GhcRn)))] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) rnRecStmtsAndThen rnBody s cont @@ -1077,7 +1078,7 @@ rnRecStmtsAndThen rnBody s cont ; return (res, fvs) }} -- get all the fixity decls in any Let stmt -collectRecStmtsFixities :: [LStmtLR RdrName RdrName body] -> [LFixitySig RdrName] +collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs] collectRecStmtsFixities l = foldr (\ s -> \acc -> case s of (L _ (LetStmt (L _ (HsValBinds (ValBindsIn _ sigs))))) -> @@ -1089,11 +1090,11 @@ collectRecStmtsFixities l = -- left-hand sides rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv - -> LStmt RdrName body + -> LStmt GhcPs body -- rename LHS, and return its FVs -- Warning: we will only need the FreeVars below in the case of a BindStmt, -- so we don't bother to compute it accurately in the other cases - -> RnM [(LStmtLR Name RdrName body, FreeVars)] + -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)] rn_rec_stmt_lhs _ (L loc (BodyStmt body a b c)) = return [(L loc (BodyStmt body a b c), emptyFVs)] @@ -1135,8 +1136,8 @@ rn_rec_stmt_lhs _ (L _ (LetStmt (L _ EmptyLocalBinds))) = panic "rn_rec_stmt LetStmt EmptyLocalBinds" rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv - -> [LStmt RdrName body] - -> RnM [(LStmtLR Name RdrName body, FreeVars)] + -> [LStmt GhcPs body] + -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)] rn_rec_stmts_lhs fix_env stmts = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts ; let boundNames = collectLStmtsBinders (map fst ls) @@ -1149,11 +1150,11 @@ rn_rec_stmts_lhs fix_env stmts -- right-hand-sides -rn_rec_stmt :: (Outputable (body RdrName)) => - (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) +rn_rec_stmt :: (Outputable (body GhcPs)) => + (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -> [Name] - -> (LStmtLR Name RdrName (Located (body RdrName)), FreeVars) - -> RnM [Segment (LStmt Name (Located (body Name)))] + -> (LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars) + -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))] -- Rename a Stmt that is inside a RecStmt (or mdo) -- Assumes all binders are already in scope -- Turns each stmt into a singleton Stmt @@ -1209,20 +1210,20 @@ rn_rec_stmt _ _ (L _ (LetStmt (L _ EmptyLocalBinds)), _) rn_rec_stmt _ _ stmt@(L _ (ApplicativeStmt {}), _) = pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt) -rn_rec_stmts :: Outputable (body RdrName) => - (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) +rn_rec_stmts :: Outputable (body GhcPs) => + (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -> [Name] - -> [(LStmtLR Name RdrName (Located (body RdrName)), FreeVars)] - -> RnM [Segment (LStmt Name (Located (body Name)))] + -> [(LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)] + -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))] rn_rec_stmts rnBody bndrs stmts = do { segs_s <- mapM (rn_rec_stmt rnBody bndrs) stmts ; return (concat segs_s) } --------------------------------------------- segmentRecStmts :: SrcSpan -> HsStmtContext Name - -> Stmt Name body - -> [Segment (LStmt Name body)] -> FreeVars - -> ([LStmt Name body], FreeVars) + -> Stmt GhcRn body + -> [Segment (LStmt GhcRn body)] -> FreeVars + -> ([LStmt GhcRn body], FreeVars) segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later | null segs @@ -1324,8 +1325,9 @@ glom it together with the first two groups -} glomSegments :: HsStmtContext Name - -> [Segment (LStmt Name body)] - -> [Segment [LStmt Name body]] -- Each segment has a non-empty list of Stmts + -> [Segment (LStmt GhcRn body)] + -> [Segment [LStmt GhcRn body]] + -- Each segment has a non-empty list of Stmts -- See Note [Glomming segments] glomSegments _ [] = [] @@ -1354,10 +1356,12 @@ glomSegments ctxt ((defs,uses,fwds,stmt) : segs) not_needed (defs,_,_,_) = not (intersectsNameSet defs uses) ---------------------------------------------------- -segsToStmts :: Stmt Name body -- A RecStmt with the SyntaxOps filled in - -> [Segment [LStmt Name body]] -- Each Segment has a non-empty list of Stmts - -> FreeVars -- Free vars used 'later' - -> ([LStmt Name body], FreeVars) +segsToStmts :: Stmt GhcRn body + -- A RecStmt with the SyntaxOps filled in + -> [Segment [LStmt GhcRn body]] + -- Each Segment has a non-empty list of Stmts + -> FreeVars -- Free vars used 'later' + -> ([LStmt GhcRn body], FreeVars) segsToStmts _ [] fvs_later = ([], fvs_later) segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later @@ -1499,8 +1503,8 @@ data MonadNames = MonadNames { return_name, pure_name :: Name } -- Note [ApplicativeDo]. rearrangeForApplicativeDo :: HsStmtContext Name - -> [(ExprLStmt Name, FreeVars)] - -> RnM ([ExprLStmt Name], FreeVars) + -> [(ExprLStmt GhcRn, FreeVars)] + -> RnM ([ExprLStmt GhcRn], FreeVars) rearrangeForApplicativeDo _ [] = return ([], emptyNameSet) rearrangeForApplicativeDo _ [(one,_)] = return ([one], emptyNameSet) @@ -1532,12 +1536,12 @@ flattenStmtTree t = go t [] go (StmtTreeBind l r) as = go l (go r as) go (StmtTreeApplicative ts) as = foldr go as ts -type ExprStmtTree = StmtTree (ExprLStmt Name, FreeVars) +type ExprStmtTree = StmtTree (ExprLStmt GhcRn, FreeVars) type Cost = Int -- | Turn a sequence of statements into an ExprStmtTree using a -- heuristic algorithm. /O(n^2)/ -mkStmtTreeHeuristic :: [(ExprLStmt Name, FreeVars)] -> ExprStmtTree +mkStmtTreeHeuristic :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree mkStmtTreeHeuristic [one] = StmtTreeOne one mkStmtTreeHeuristic stmts = case segments stmts of @@ -1551,7 +1555,7 @@ mkStmtTreeHeuristic stmts = -- | Turn a sequence of statements into an ExprStmtTree optimally, -- using dynamic programming. /O(n^3)/ -mkStmtTreeOptimal :: [(ExprLStmt Name, FreeVars)] -> ExprStmtTree +mkStmtTreeOptimal :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree mkStmtTreeOptimal stmts = ASSERT(not (null stmts)) -- the empty case is handled by the caller; -- we don't support empty StmtTrees. @@ -1618,9 +1622,9 @@ stmtTreeToStmts :: MonadNames -> HsStmtContext Name -> ExprStmtTree - -> [ExprLStmt Name] -- ^ the "tail" + -> [ExprLStmt GhcRn] -- ^ the "tail" -> FreeVars -- ^ free variables of the tail - -> RnM ( [ExprLStmt Name] -- ( output statements, + -> RnM ( [ExprLStmt GhcRn] -- ( output statements, , FreeVars ) -- , things we needed -- If we have a single bind, and we can do it without a join, transform @@ -1679,8 +1683,8 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do -- | Divide a sequence of statements into segments, where no segment -- depends on any variables defined by a statement in another segment. segments - :: [(ExprLStmt Name, FreeVars)] - -> [[(ExprLStmt Name, FreeVars)]] + :: [(ExprLStmt GhcRn, FreeVars)] + -> [[(ExprLStmt GhcRn, FreeVars)]] segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts) where allvars = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts) @@ -1702,7 +1706,7 @@ segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts) -- the sequence from the back to the front, and keeping track of -- the set of free variables of the current segment. Whenever -- this set of free variables is empty, we have a complete segment. - walk :: [(ExprLStmt Name, FreeVars)] -> [[(ExprLStmt Name, FreeVars)]] + walk :: [(ExprLStmt GhcRn, FreeVars)] -> [[(ExprLStmt GhcRn, FreeVars)]] walk [] = [] walk ((stmt,fvs) : stmts) = ((stmt,fvs) : seg) : walk rest where (seg,rest) = chunter fvs' stmts @@ -1732,9 +1736,9 @@ isLetStmt _ = False -- heuristic is to peel off the first group of independent statements -- and put the bind after those. splitSegment - :: [(ExprLStmt Name, FreeVars)] - -> ( [(ExprLStmt Name, FreeVars)] - , [(ExprLStmt Name, FreeVars)] ) + :: [(ExprLStmt GhcRn, FreeVars)] + -> ( [(ExprLStmt GhcRn, FreeVars)] + , [(ExprLStmt GhcRn, FreeVars)] ) splitSegment [one,two] = ([one],[two]) -- there is no choice when there are only two statements; this just saves -- some work in a common case. @@ -1749,10 +1753,10 @@ splitSegment stmts _other -> (stmts,[]) slurpIndependentStmts - :: [(LStmt Name (Located (body Name)), FreeVars)] - -> Maybe ( [(LStmt Name (Located (body Name)), FreeVars)] -- LetStmts - , [(LStmt Name (Located (body Name)), FreeVars)] -- BindStmts - , [(LStmt Name (Located (body Name)), FreeVars)] ) + :: [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] + -> Maybe ( [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -- LetStmts + , [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -- BindStmts + , [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] ) slurpIndependentStmts stmts = go [] [] emptyNameSet stmts where -- If we encounter a BindStmt that doesn't depend on a previous BindStmt @@ -1789,10 +1793,10 @@ slurpIndependentStmts stmts = go [] [] emptyNameSet stmts -- typechecker and the desugarer (I tried it that way first!). mkApplicativeStmt :: HsStmtContext Name - -> [ApplicativeArg Name Name] -- ^ The args + -> [ApplicativeArg GhcRn GhcRn] -- ^ The args -> Bool -- ^ True <=> need a join - -> [ExprLStmt Name] -- ^ The body statements - -> RnM ([ExprLStmt Name], FreeVars) + -> [ExprLStmt GhcRn] -- ^ The body statements + -> RnM ([ExprLStmt GhcRn], FreeVars) mkApplicativeStmt ctxt args need_join body_stmts = do { (fmap_op, fvs1) <- lookupStmtName ctxt fmapName ; (ap_op, fvs2) <- lookupStmtName ctxt apAName @@ -1812,8 +1816,8 @@ mkApplicativeStmt ctxt args need_join body_stmts -- | Given the statements following an ApplicativeStmt, determine whether -- we need a @join@ or not, and remove the @return@ if necessary. needJoin :: MonadNames - -> [ExprLStmt Name] - -> (Bool, [ExprLStmt Name]) + -> [ExprLStmt GhcRn] + -> (Bool, [ExprLStmt GhcRn]) needJoin _monad_names [] = (False, []) -- we're in an ApplicativeArg needJoin monad_names [L loc (LastStmt e _ t)] | Just arg <- isReturnApp monad_names e = @@ -1823,8 +1827,8 @@ needJoin _monad_names stmts = (True, stmts) -- | @Just e@, if the expression is @return e@ or @return $ e@, -- otherwise @Nothing@ isReturnApp :: MonadNames - -> LHsExpr Name - -> Maybe (LHsExpr Name) + -> LHsExpr GhcRn + -> Maybe (LHsExpr GhcRn) isReturnApp monad_names (L _ (HsPar expr)) = isReturnApp monad_names expr isReturnApp monad_names (L _ e) = case e of OpApp l op _ r | is_return l, is_dollar op -> Just r @@ -1864,9 +1868,9 @@ emptyErr (TransStmtCtxt {}) = text "Empty statement group preceding 'group' or ' emptyErr ctxt = text "Empty" <+> pprStmtContext ctxt ---------------------- -checkLastStmt :: Outputable (body RdrName) => HsStmtContext Name - -> LStmt RdrName (Located (body RdrName)) - -> RnM (LStmt RdrName (Located (body RdrName))) +checkLastStmt :: Outputable (body GhcPs) => HsStmtContext Name + -> LStmt GhcPs (Located (body GhcPs)) + -> RnM (LStmt GhcPs (Located (body GhcPs))) checkLastStmt ctxt lstmt@(L loc stmt) = case ctxt of ListComp -> check_comp @@ -1896,7 +1900,7 @@ checkLastStmt ctxt lstmt@(L loc stmt) -- Checking when a particular Stmt is ok checkStmt :: HsStmtContext Name - -> LStmt RdrName (Located (body RdrName)) + -> LStmt GhcPs (Located (body GhcPs)) -> RnM () checkStmt ctxt (L _ stmt) = do { dflags <- getDynFlags @@ -1923,7 +1927,7 @@ emptyInvalid = NotValid Outputable.empty okStmt, okDoStmt, okCompStmt, okParStmt, okPArrStmt :: DynFlags -> HsStmtContext Name - -> Stmt RdrName (Located (body RdrName)) -> Validity + -> Stmt GhcPs (Located (body GhcPs)) -> Validity -- Return Nothing if OK, (Just extra) if not ok -- The "extra" is an SDoc that is appended to an generic error message @@ -1941,7 +1945,7 @@ okStmt dflags ctxt stmt TransStmtCtxt ctxt -> okStmt dflags ctxt stmt ------------- -okPatGuardStmt :: Stmt RdrName (Located (body RdrName)) -> Validity +okPatGuardStmt :: Stmt GhcPs (Located (body GhcPs)) -> Validity okPatGuardStmt stmt = case stmt of BodyStmt {} -> IsValid @@ -1998,7 +2002,7 @@ okPArrStmt dflags _ stmt ApplicativeStmt {} -> emptyInvalid --------- -checkTupleSection :: [LHsTupArg RdrName] -> RnM () +checkTupleSection :: [LHsTupArg GhcPs] -> RnM () checkTupleSection args = do { tuple_section <- xoptM LangExt.TupleSections ; checkErr (all tupArgPresent args || tuple_section) msg } @@ -2006,12 +2010,12 @@ checkTupleSection args msg = text "Illegal tuple section: use TupleSections" --------- -sectionErr :: HsExpr RdrName -> SDoc +sectionErr :: HsExpr GhcPs -> SDoc sectionErr expr = hang (text "A section must be enclosed in parentheses") 2 (text "thus:" <+> (parens (ppr expr))) -patSynErr :: HsExpr RdrName -> SDoc -> RnM (HsExpr Name, FreeVars) +patSynErr :: HsExpr GhcPs -> SDoc -> RnM (HsExpr GhcRn, FreeVars) patSynErr e explanation = do { addErr (sep [text "Pattern syntax in expression context:", nest 4 (ppr e)] $$ explanation) diff --git a/compiler/rename/RnExpr.hs-boot b/compiler/rename/RnExpr.hs-boot index 5419870d38..a944d7124e 100644 --- a/compiler/rename/RnExpr.hs-boot +++ b/compiler/rename/RnExpr.hs-boot @@ -1,18 +1,18 @@ module RnExpr where +import Name import HsSyn -import Name ( Name ) -import NameSet ( FreeVars ) -import RdrName ( RdrName ) +import NameSet ( FreeVars ) import TcRnTypes -import SrcLoc ( Located ) -import Outputable ( Outputable ) +import SrcLoc ( Located ) +import Outputable ( Outputable ) +import HsExtension ( GhcPs, GhcRn ) -rnLExpr :: LHsExpr RdrName - -> RnM (LHsExpr Name, FreeVars) +rnLExpr :: LHsExpr GhcPs + -> RnM (LHsExpr GhcRn, FreeVars) rnStmts :: --forall thing body. - Outputable (body RdrName) => HsStmtContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) - -> [LStmt RdrName (Located (body RdrName))] + Outputable (body GhcPs) => HsStmtContext Name + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> [LStmt GhcPs (Located (body GhcPs))] -> ([Name] -> RnM (thing, FreeVars)) - -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars) + -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars) diff --git a/compiler/rename/RnFixity.hs b/compiler/rename/RnFixity.hs index 61566f0ba5..0bd08574a0 100644 --- a/compiler/rename/RnFixity.hs +++ b/compiler/rename/RnFixity.hs @@ -176,7 +176,7 @@ lookupTyFixityRn (L _ n) = lookupFixityRn n -- the field label, which might be different to the 'OccName' of the selector -- 'Name' if @DuplicateRecordFields@ is in use (Trac #1173). If there are -- multiple possible selectors with different fixities, generate an error. -lookupFieldFixityRn :: AmbiguousFieldOcc Name -> RnM Fixity +lookupFieldFixityRn :: AmbiguousFieldOcc GhcRn -> RnM Fixity lookupFieldFixityRn (Unambiguous (L _ rdr) n) = lookupFixityRn' n (rdrNameOcc rdr) lookupFieldFixityRn (Ambiguous (L _ rdr) _) = get_ambiguous_fixity rdr diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs index fa5f24fb46..3c1473402c 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -5,6 +5,10 @@ -} {-# LANGUAGE CPP, NondecreasingIndentation, MultiWayIf, NamedFieldPuns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} module RnNames ( rnImports, getLocalNonValBinders, newRecordSelector, @@ -15,7 +19,8 @@ module RnNames ( checkConName, mkChildEnv, findChildren, - dodgyMsg + dodgyMsg, + dodgyMsgInsert ) where #include "HsVersions.h" @@ -154,8 +159,8 @@ with yes we have gone with no for now. -- the return types represent. -- Note: Do the non SOURCE ones first, so that we get a helpful warning -- for SOURCE ones that are unnecessary -rnImports :: [LImportDecl RdrName] - -> RnM ([LImportDecl Name], GlobalRdrEnv, ImportAvails, AnyHpcUsage) +rnImports :: [LImportDecl GhcPs] + -> RnM ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage) rnImports imports = do tcg_env <- getGblEnv -- NB: want an identity module here, because it's OK for a signature @@ -170,8 +175,8 @@ rnImports imports = do return (decls, rdr_env, imp_avails, hpc_usage) where - combine :: [(LImportDecl Name, GlobalRdrEnv, ImportAvails, AnyHpcUsage)] - -> ([LImportDecl Name], GlobalRdrEnv, ImportAvails, AnyHpcUsage) + combine :: [(LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage)] + -> ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage) combine = foldr plus ([], emptyGlobalRdrEnv, emptyImportAvails, False) plus (decl, gbl_env1, imp_avails1,hpc_usage1) @@ -196,8 +201,8 @@ rnImports imports = do -- -- 4. A boolean 'AnyHpcUsage' which is true if the imported module -- used HPC. -rnImportDecl :: Module -> LImportDecl RdrName - -> RnM (LImportDecl Name, GlobalRdrEnv, ImportAvails, AnyHpcUsage) +rnImportDecl :: Module -> LImportDecl GhcPs + -> RnM (LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage) rnImportDecl this_mod (L loc decl@(ImportDecl { ideclName = loc_imp_mod_name, ideclPkgQual = mb_pkg , ideclSource = want_boot, ideclSafe = mod_safe @@ -543,7 +548,7 @@ extendGlobalRdrEnvRn avails new_fixities * * ********************************************************************* -} -getLocalNonValBinders :: MiniFixityEnv -> HsGroup RdrName +getLocalNonValBinders :: MiniFixityEnv -> HsGroup GhcPs -> RnM ((TcGblEnv, TcLclEnv), NameSet) -- Get all the top-level binders bound the group *except* -- for value bindings, which are treated separately @@ -614,7 +619,7 @@ getLocalNonValBinders fixity_env new_simple rdr_name = do{ nm <- newTopSrcBinder rdr_name ; return (avail nm) } - new_tc :: Bool -> LTyClDecl RdrName + new_tc :: Bool -> LTyClDecl GhcPs -> RnM (AvailInfo, [(Name, [FieldLabel])]) new_tc overload_ok tc_decl -- NOT for type/data instances = do { let (bndrs, flds) = hsLTyClDeclBinders tc_decl @@ -629,7 +634,8 @@ getLocalNonValBinders fixity_env -- Calculate the mapping from constructor names to fields, which -- will go in tcg_field_env. It's convenient to do this here where -- we are working with a single datatype definition. - mk_fld_env :: HsDataDefn RdrName -> [Name] -> [FieldLabel] -> [(Name, [FieldLabel])] + mk_fld_env :: HsDataDefn GhcPs -> [Name] -> [FieldLabel] + -> [(Name, [FieldLabel])] mk_fld_env d names flds = concatMap find_con_flds (dd_cons d) where find_con_flds (L _ (ConDeclH98 { con_name = L _ rdr @@ -662,7 +668,7 @@ getLocalNonValBinders fixity_env find (\ fl -> flLabel fl == lbl) flds where lbl = occNameFS (rdrNameOcc rdr) - new_assoc :: Bool -> LInstDecl RdrName + new_assoc :: Bool -> LInstDecl GhcPs -> RnM ([AvailInfo], [(Name, [FieldLabel])]) new_assoc _ (L _ (TyFamInstD {})) = return ([], []) -- type instances don't bind new names @@ -681,7 +687,7 @@ getLocalNonValBinders fixity_env = return ([], []) -- Do not crash on ill-formed instances -- Eg instance !Show Int Trac #3811c - new_di :: Bool -> Maybe Name -> DataFamInstDecl RdrName + new_di :: Bool -> Maybe Name -> DataFamInstDecl GhcPs -> RnM (AvailInfo, [(Name, [FieldLabel])]) new_di overload_ok mb_cls ti_decl = do { main_name <- lookupFamInstName mb_cls (dfid_tycon ti_decl) @@ -693,11 +699,11 @@ getLocalNonValBinders fixity_env fld_env = mk_fld_env (dfid_defn ti_decl) sub_names flds' ; return (avail, fld_env) } - new_loc_di :: Bool -> Maybe Name -> LDataFamInstDecl RdrName + new_loc_di :: Bool -> Maybe Name -> LDataFamInstDecl GhcPs -> RnM (AvailInfo, [(Name, [FieldLabel])]) new_loc_di overload_ok mb_cls (L _ d) = new_di overload_ok mb_cls d -newRecordSelector :: Bool -> [Name] -> LFieldOcc RdrName -> RnM FieldLabel +newRecordSelector :: Bool -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel newRecordSelector _ [] _ = error "newRecordSelector: datatype has no constructors!" newRecordSelector overload_ok (dc:_) (L loc (FieldOcc (L _ fld) _)) = do { selName <- newTopSrcBinder $ L loc $ field @@ -780,8 +786,8 @@ although we never look up data constructors. filterImports :: ModIface -> ImpDeclSpec -- The span for the entire import decl - -> Maybe (Bool, Located [LIE RdrName]) -- Import spec; True => hiding - -> RnM (Maybe (Bool, Located [LIE Name]), -- Import spec w/ Names + -> Maybe (Bool, Located [LIE GhcPs]) -- Import spec; True => hiding + -> RnM (Maybe (Bool, Located [LIE GhcRn]), -- Import spec w/ Names [GlobalRdrElt]) -- Same again, but in GRE form filterImports iface decl_spec Nothing = return (Nothing, gresFromAvails (Just imp_spec) (mi_exports iface)) @@ -793,7 +799,7 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) = do -- check for errors, convert RdrNames to Names items1 <- mapM lookup_lie import_items - let items2 :: [(LIE Name, AvailInfo)] + let items2 :: [(LIE GhcRn, AvailInfo)] items2 = concat items1 -- NB the AvailInfo may have duplicates, and several items -- for the same parent; e.g N(x) and N(y) @@ -811,7 +817,7 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) all_avails = mi_exports iface -- See Note [Dealing with imports] - imp_occ_env :: OccEnv (Name, -- the name + imp_occ_env :: OccEnv (Name, -- the name AvailInfo, -- the export item providing the name Maybe Name) -- the parent of associated types imp_occ_env = mkOccEnv_C combine [ (nameOccName n, (n, a, Nothing)) @@ -837,7 +843,7 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) where mb_success = lookupOccEnv imp_occ_env (rdrNameOcc rdr) - lookup_lie :: LIE RdrName -> TcRn [(LIE Name, AvailInfo)] + lookup_lie :: LIE GhcPs -> TcRn [(LIE GhcRn, AvailInfo)] lookup_lie (L loc ieRdr) = do (stuff, warns) <- setSrcSpan loc $ liftM (fromMaybe ([],[])) $ @@ -873,7 +879,8 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) -- data constructors of an associated family, we need separate -- AvailInfos for the data constructors and the family (as they have -- different parents). See Note [Dealing with imports] - lookup_ie :: IE RdrName -> IELookupM ([(IE Name, AvailInfo)], [IELookupWarning]) + lookup_ie :: IE GhcPs + -> IELookupM ([(IE GhcRn, AvailInfo)], [IELookupWarning]) lookup_ie ie = handle_bad_import $ do case ie of IEVar (L l n) -> do @@ -1007,7 +1014,7 @@ catIELookupM ms = [ a | Succeeded a <- ms ] -} -- | Given an import\/export spec, construct the appropriate 'GlobalRdrElt's. -gresFromIE :: ImpDeclSpec -> (LIE Name, AvailInfo) -> [GlobalRdrElt] +gresFromIE :: ImpDeclSpec -> (LIE GhcRn, AvailInfo) -> [GlobalRdrElt] gresFromIE decl_spec (L loc ie, avail) = gresFromAvail prov_fn avail where @@ -1081,7 +1088,7 @@ lookupChildren all_kids rdr_items ********************************************************* -} -reportUnusedNames :: Maybe (Located [LIE RdrName]) -- Export list +reportUnusedNames :: Maybe (Located [LIE GhcPs]) -- Export list -> TcGblEnv -> RnM () reportUnusedNames _export_decls gbl_env = do { traceRn "RUN" (ppr (tcg_dus gbl_env)) @@ -1137,9 +1144,9 @@ specification and implementation notes are here: -} type ImportDeclUsage - = ( LImportDecl Name -- The import declaration + = ( LImportDecl GhcRn -- The import declaration , [AvailInfo] -- What *is* used (normalised) - , [Name] ) -- What is imported but *not* used + , [Name] ) -- What is imported but *not* used warnUnusedImportDecls :: TcGblEnv -> RnM () warnUnusedImportDecls gbl_env @@ -1200,6 +1207,7 @@ warnMissingSignatures gbl_env name = patSynName p pp_ty = pprPatSynType p + add_bind_warn :: Id -> IOEnv (Env TcGblEnv TcLclEnv) () add_bind_warn id = do { env <- tcInitTidyEnv -- Why not use emptyTidyEnv? ; let name = idName id @@ -1242,7 +1250,7 @@ not normalised). type ImportMap = Map SrcLoc [AvailInfo] -- See [The ImportMap] -findImportUsage :: [LImportDecl Name] +findImportUsage :: [LImportDecl GhcRn] -> [GlobalRdrElt] -> [ImportDeclUsage] @@ -1267,7 +1275,7 @@ findImportUsage imports used_gres foldr (add_unused . unLoc) emptyNameSet imp_ies _other -> emptyNameSet -- No explicit import list => no unused-name list - add_unused :: IE Name -> NameSet -> NameSet + add_unused :: IE GhcRn -> NameSet -> NameSet add_unused (IEVar (L _ n)) acc = add_unused_name (ieWrappedName n) acc add_unused (IEThingAbs (L _ n)) acc @@ -1410,7 +1418,7 @@ printMinimalImports imports_w_usage where doc = text "Compute minimal imports for" <+> ppr decl - to_ie :: ModIface -> AvailInfo -> [IE Name] + to_ie :: ModIface -> AvailInfo -> [IE GhcRn] -- The main trick here is that if we're importing all the constructors -- we want to say "T(..)", but if we're importing only a subset we want -- to say "T(A,B,C)". So we have to find out what the module exports. @@ -1509,7 +1517,7 @@ qualImportItemErr rdr = hang (text "Illegal qualified name in import item:") 2 (ppr rdr) -badImportItemErrStd :: ModIface -> ImpDeclSpec -> IE RdrName -> SDoc +badImportItemErrStd :: ModIface -> ImpDeclSpec -> IE GhcPs -> SDoc badImportItemErrStd iface decl_spec ie = sep [text "Module", quotes (ppr (is_mod decl_spec)), source_import, text "does not export", quotes (ppr ie)] @@ -1517,7 +1525,8 @@ badImportItemErrStd iface decl_spec ie source_import | mi_boot iface = text "(hi-boot interface)" | otherwise = Outputable.empty -badImportItemErrDataCon :: OccName -> ModIface -> ImpDeclSpec -> IE RdrName -> SDoc +badImportItemErrDataCon :: OccName -> ModIface -> ImpDeclSpec -> IE GhcPs + -> SDoc badImportItemErrDataCon dataType_occ iface decl_spec ie = vcat [ text "In module" <+> quotes (ppr (is_mod decl_spec)) @@ -1542,7 +1551,7 @@ badImportItemErrDataCon dataType_occ iface decl_spec ie | otherwise = Outputable.empty parens_sp d = parens (space <> d <> space) -- T( f,g ) -badImportItemErr :: ModIface -> ImpDeclSpec -> IE RdrName -> [AvailInfo] -> SDoc +badImportItemErr :: ModIface -> ImpDeclSpec -> IE GhcPs -> [AvailInfo] -> SDoc badImportItemErr iface decl_spec ie avails = case find checkIfDataCon avails of Just con -> badImportItemErrDataCon (availOccName con) iface decl_spec ie @@ -1561,16 +1570,24 @@ illegalImportItemErr :: SDoc illegalImportItemErr = text "Illegal import item" dodgyImportWarn :: RdrName -> SDoc -dodgyImportWarn item = dodgyMsg (text "import") item +dodgyImportWarn item + = dodgyMsg (text "import") item (dodgyMsgInsert item :: IE GhcPs) -dodgyMsg :: (OutputableBndr n, HasOccName n) => SDoc -> n -> SDoc -dodgyMsg kind tc +dodgyMsg :: (Outputable a, Outputable b) => SDoc -> a -> b -> SDoc +dodgyMsg kind tc ie = sep [ text "The" <+> kind <+> ptext (sLit "item") - <+> quotes (ppr (IEThingAll (noLoc (IEName $ noLoc tc)))) + -- <+> quotes (ppr (IEThingAll (noLoc (IEName $ noLoc tc)))) + <+> quotes (ppr ie) <+> text "suggests that", quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,", text "but it has none" ] +dodgyMsgInsert :: forall p . IdP p -> IE p +dodgyMsgInsert tc = IEThingAll ii + where + ii :: LIEWrappedName (IdP p) + ii = noLoc (IEName $ noLoc tc) + addDupDeclErr :: [GlobalRdrElt] -> TcRn () addDupDeclErr [] = panic "addDupDeclErr: empty list" @@ -1594,7 +1611,7 @@ missingImportListWarn :: ModuleName -> SDoc missingImportListWarn mod = text "The module" <+> quotes (ppr mod) <+> ptext (sLit "does not have an explicit import list") -missingImportListItem :: IE RdrName -> SDoc +missingImportListItem :: IE GhcPs -> SDoc missingImportListItem ie = text "The import item" <+> quotes (ppr ie) <+> ptext (sLit "does not have an explicit import list") diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs index 30dd61bece..ff88dbffbc 100644 --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs @@ -210,7 +210,7 @@ matchNameMaker ctxt = LamMk report_unused ThPatQuote -> False _ -> True -rnHsSigCps :: LHsSigWcType RdrName -> CpsRn (LHsSigWcType Name) +rnHsSigCps :: LHsSigWcType GhcPs -> CpsRn (LHsSigWcType GhcRn) rnHsSigCps sig = CpsRn (rnHsSigWcTypeScoped PatCtx sig) newPatLName :: NameMaker -> Located RdrName -> CpsRn (Located Name) @@ -302,8 +302,8 @@ There are various entry points to renaming patterns, depending on -- * unused and duplicate checking -- * no fixities rnPats :: HsMatchContext Name -- for error messages - -> [LPat RdrName] - -> ([LPat Name] -> RnM (a, FreeVars)) + -> [LPat GhcPs] + -> ([LPat GhcRn] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) rnPats ctxt pats thing_inside = do { envs_before <- getRdrEnvs @@ -329,8 +329,8 @@ rnPats ctxt pats thing_inside doc_pat = text "In" <+> pprMatchContext ctxt rnPat :: HsMatchContext Name -- for error messages - -> LPat RdrName - -> (LPat Name -> RnM (a, FreeVars)) + -> LPat GhcPs + -> (LPat GhcRn -> RnM (a, FreeVars)) -> RnM (a, FreeVars) -- Variables bound by pattern do not -- appear in the result FreeVars rnPat ctxt pat thing_inside @@ -348,8 +348,8 @@ applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newPatLName mk rdr) -- * no unused and duplicate checking -- * fixities might be coming in rnBindPat :: NameMaker - -> LPat RdrName - -> RnM (LPat Name, FreeVars) + -> LPat GhcPs + -> RnM (LPat GhcRn, FreeVars) -- Returned FreeVars are the free variables of the pattern, -- of course excluding variables bound by this pattern @@ -366,17 +366,17 @@ rnBindPat name_maker pat = runCps (rnLPatAndThen name_maker pat) -- ----------- Entry point 3: rnLPatAndThen ------------------- -- General version: parametrized by how you make new names -rnLPatsAndThen :: NameMaker -> [LPat RdrName] -> CpsRn [LPat Name] +rnLPatsAndThen :: NameMaker -> [LPat GhcPs] -> CpsRn [LPat GhcRn] rnLPatsAndThen mk = mapM (rnLPatAndThen mk) -- Despite the map, the monad ensures that each pattern binds -- variables that may be mentioned in subsequent patterns in the list -------------------- -- The workhorse -rnLPatAndThen :: NameMaker -> LPat RdrName -> CpsRn (LPat Name) +rnLPatAndThen :: NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn) rnLPatAndThen nm lpat = wrapSrcSpanCps (rnPatAndThen nm) lpat -rnPatAndThen :: NameMaker -> Pat RdrName -> CpsRn (Pat Name) +rnPatAndThen :: NameMaker -> Pat GhcPs -> CpsRn (Pat GhcRn) rnPatAndThen _ (WildPat _) = return (WildPat placeHolderType) rnPatAndThen mk (ParPat pat) = do { pat' <- rnLPatAndThen mk pat; return (ParPat pat') } rnPatAndThen mk (LazyPat pat) = do { pat' <- rnLPatAndThen mk pat; return (LazyPat pat') } @@ -411,7 +411,7 @@ rnPatAndThen mk (LitPat lit) else normal_lit } | otherwise = normal_lit where - normal_lit = do { liftCps (rnLit lit); return (LitPat lit) } + normal_lit = do { liftCps (rnLit lit); return (LitPat (convertLit lit)) } rnPatAndThen _ (NPat (L l lit) mb_neg _eq _) = do { (lit', mb_neg') <- liftCpsFV $ rnOverLit lit @@ -502,9 +502,9 @@ rnPatAndThen _ pat = pprPanic "rnLPatAndThen" (ppr pat) -------------------- rnConPatAndThen :: NameMaker - -> Located RdrName -- the constructor - -> HsConPatDetails RdrName - -> CpsRn (Pat Name) + -> Located RdrName -- the constructor + -> HsConPatDetails GhcPs + -> CpsRn (Pat GhcRn) rnConPatAndThen mk con (PrefixCon pats) = do { con' <- lookupConCps con @@ -526,8 +526,8 @@ rnConPatAndThen mk con (RecCon rpats) -------------------- rnHsRecPatsAndThen :: NameMaker -> Located Name -- Constructor - -> HsRecFields RdrName (LPat RdrName) - -> CpsRn (HsRecFields Name (LPat Name)) + -> HsRecFields GhcPs (LPat GhcPs) + -> CpsRn (HsRecFields GhcRn (LPat GhcRn)) rnHsRecPatsAndThen mk (L _ con) hs_rec_fields@(HsRecFields { rec_dotdot = dd }) = do { flds <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) mkVarPat hs_rec_fields @@ -562,8 +562,8 @@ rnHsRecFields HsRecFieldContext -> (SrcSpan -> RdrName -> arg) -- When punning, use this to build a new field - -> HsRecFields RdrName (Located arg) - -> RnM ([LHsRecField Name (Located arg)], FreeVars) + -> HsRecFields GhcPs (Located arg) + -> RnM ([LHsRecField GhcRn (Located arg)], FreeVars) -- This surprisingly complicated pass -- a) looks up the field name (possibly using disambiguation) @@ -597,8 +597,8 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) Nothing -> text "constructor field name" Just con -> text "field of constructor" <+> quotes (ppr con) - rn_fld :: Bool -> Maybe Name -> LHsRecField RdrName (Located arg) - -> RnM (LHsRecField Name (Located arg)) + rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs (Located arg) + -> RnM (LHsRecField GhcRn (Located arg)) rn_fld pun_ok parent (L l (HsRecField { hsRecFieldLbl = L loc (FieldOcc (L ll lbl) _) , hsRecFieldArg = arg @@ -616,10 +616,10 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) , hsRecPun = pun })) } rn_dotdot :: Maybe Int -- See Note [DotDot fields] in HsPat - -> Maybe Name -- The constructor (Nothing for an + -> Maybe Name -- The constructor (Nothing for an -- out of scope constructor) - -> [LHsRecField Name (Located arg)] -- Explicit fields - -> RnM [LHsRecField Name (Located arg)] -- Filled in .. fields + -> [LHsRecField GhcRn (Located arg)] -- Explicit fields + -> RnM [LHsRecField GhcRn (Located arg)] -- Filled in .. fields rn_dotdot Nothing _mb_con _flds -- No ".." at all = return [] rn_dotdot (Just {}) Nothing _flds -- Constructor out of scope @@ -668,7 +668,8 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) = do { env <- getGlobalRdrEnv; return (find_tycon env con) } | otherwise = return Nothing - find_tycon :: GlobalRdrEnv -> Name {- DataCon -} -> Maybe Name {- TyCon -} + find_tycon :: GlobalRdrEnv -> Name {- DataCon -} + -> Maybe Name {- TyCon -} -- Return the parent *type constructor* of the data constructor -- (that is, the parent of the data constructor), -- or 'Nothing' if it is a pattern synonym or not in scope. @@ -713,8 +714,8 @@ fail. But there is no need for disambiguation anyway, so we just return Nothing -} rnHsRecUpdFields - :: [LHsRecUpdField RdrName] - -> RnM ([LHsRecUpdField Name], FreeVars) + :: [LHsRecUpdField GhcPs] + -> RnM ([LHsRecUpdField GhcRn], FreeVars) rnHsRecUpdFields flds = do { pun_ok <- xoptM LangExt.RecordPuns ; overload_ok <- xoptM LangExt.DuplicateRecordFields @@ -729,7 +730,8 @@ rnHsRecUpdFields flds where doc = text "constructor field name" - rn_fld :: Bool -> Bool -> LHsRecUpdField RdrName -> RnM (LHsRecUpdField Name, FreeVars) + rn_fld :: Bool -> Bool -> LHsRecUpdField GhcPs + -> RnM (LHsRecUpdField GhcRn, FreeVars) rn_fld pun_ok overload_ok (L l (HsRecField { hsRecFieldLbl = L loc f , hsRecFieldArg = arg , hsRecPun = pun })) @@ -775,7 +777,7 @@ rnHsRecUpdFields flds -getFieldIds :: [LHsRecField Name arg] -> [Name] +getFieldIds :: [LHsRecField GhcRn arg] -> [Name] getFieldIds flds = map (unLoc . hsRecFieldSel . unLoc) flds getFieldLbls :: [LHsRecField id arg] -> [RdrName] @@ -824,7 +826,7 @@ that the types and classes they involve are made available. -} -rnLit :: HsLit -> RnM () +rnLit :: HsLit p -> RnM () rnLit (HsChar _ c) = checkErr (inCharRange c) (bogusCharError c) rnLit _ = return () @@ -855,7 +857,7 @@ can apply it explicitly. In this case it stays negative zero. Trac #13211 -} rnOverLit :: HsOverLit t -> - RnM ((HsOverLit Name, Maybe (HsExpr Name)), FreeVars) + RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars) rnOverLit origLit = do { opt_NumDecimals <- xoptM LangExt.NumDecimals ; let { lit@(OverLit {ol_val=val}) @@ -895,6 +897,6 @@ bogusCharError :: Char -> SDoc bogusCharError c = text "character literal out of range: '\\" <> char c <> char '\'' -badViewPat :: Pat RdrName -> SDoc +badViewPat :: Pat GhcPs -> SDoc badViewPat pat = vcat [text "Illegal view pattern: " <+> ppr pat, text "Use ViewPatterns to enable view patterns"] diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index 572ed82814..ff7251e5d5 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -5,6 +5,8 @@ -} {-# LANGUAGE CPP, ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} module RnSource ( rnSrcDecls, addTcgDUs, findSplice @@ -81,7 +83,7 @@ It also does the following error checks: Brings the binders of the group into scope in the appropriate places; does NOT assume that anything is in scope already -} -rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name) +rnSrcDecls :: HsGroup GhcPs -> RnM (TcGblEnv, HsGroup GhcRn) -- Rename a top-level HsGroup; used for normal source files *and* hs-boot files rnSrcDecls group@(HsGroup { hs_valds = val_decls, hs_splcds = splice_decls, @@ -266,7 +268,7 @@ rnDocDecl (DocGroup lev doc) = do ********************************************************* -} -rnSrcFixityDecls :: NameSet -> [LFixitySig RdrName] -> RnM [LFixitySig Name] +rnSrcFixityDecls :: NameSet -> [LFixitySig GhcPs] -> RnM [LFixitySig GhcRn] -- Rename the fixity decls, so we can put -- the renamed decls in the renamed syntax tree -- Errors if the thing being fixed is not defined locally. @@ -279,7 +281,7 @@ rnSrcFixityDecls bndr_set fix_decls where sig_ctxt = TopSigCtxt bndr_set - rn_decl :: LFixitySig RdrName -> RnM [LFixitySig Name] + rn_decl :: LFixitySig GhcPs -> RnM [LFixitySig GhcRn] -- GHC extension: look up both the tycon and data con -- for con-like things; hence returning a list -- If neither are in scope, report an error; otherwise @@ -312,7 +314,7 @@ gather them together. -} -- checks that the deprecations are defined locally, and that there are no duplicates -rnSrcWarnDecls :: NameSet -> [LWarnDecls RdrName] -> RnM Warnings +rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM Warnings rnSrcWarnDecls _ [] = return NoWarnings @@ -360,7 +362,7 @@ dupWarnDecl (L loc _) rdr_name ********************************************************* -} -rnAnnDecl :: AnnDecl RdrName -> RnM (AnnDecl Name, FreeVars) +rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars) rnAnnDecl ann@(HsAnnotation s provenance expr) = addErrCtxt (annCtxt ann) $ do { (provenance', provenance_fvs) <- rnAnnProvenance provenance @@ -369,7 +371,8 @@ rnAnnDecl ann@(HsAnnotation s provenance expr) ; return (HsAnnotation s provenance' expr', provenance_fvs `plusFV` expr_fvs) } -rnAnnProvenance :: AnnProvenance RdrName -> RnM (AnnProvenance Name, FreeVars) +rnAnnProvenance :: AnnProvenance RdrName + -> RnM (AnnProvenance Name, FreeVars) rnAnnProvenance provenance = do provenance' <- traverse lookupTopBndrRn provenance return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance')) @@ -382,7 +385,7 @@ rnAnnProvenance provenance = do ********************************************************* -} -rnDefaultDecl :: DefaultDecl RdrName -> RnM (DefaultDecl Name, FreeVars) +rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars) rnDefaultDecl (DefaultDecl tys) = do { (tys', fvs) <- rnLHsTypes doc_str tys ; return (DefaultDecl tys', fvs) } @@ -397,7 +400,7 @@ rnDefaultDecl (DefaultDecl tys) ********************************************************* -} -rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars) +rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars) rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec }) = do { topEnv :: HscEnv <- getTopEnv ; name' <- lookupLocatedTopBndrRn name @@ -452,7 +455,7 @@ patchCCallTarget unitId callTarget = ********************************************************* -} -rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars) +rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars) rnSrcInstDecl (TyFamInstD { tfid_inst = tfi }) = do { (tfi', fvs) <- rnTyFamInstDecl Nothing tfi ; return (TyFamInstD { tfid_inst = tfi' }, fvs) } @@ -477,7 +480,7 @@ rnSrcInstDecl (ClsInstD { cid_inst = cid }) -- -- See also descriptions of 'checkCanonicalMonadInstances' and -- 'checkCanonicalMonoidInstances' -checkCanonicalInstances :: Name -> LHsSigType Name -> LHsBinds Name -> RnM () +checkCanonicalInstances :: Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> RnM () checkCanonicalInstances cls poly_ty mbinds = do whenWOptM Opt_WarnNonCanonicalMonadInstances checkCanonicalMonadInstances @@ -608,7 +611,7 @@ checkCanonicalInstances cls poly_ty mbinds = do -- | test whether MatchGroup represents a trivial \"lhsName = rhsName\" -- binding, and return @Just rhsName@ if this is the case - isAliasMG :: MatchGroup Name (LHsExpr Name) -> Maybe Name + isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name isAliasMG MG {mg_alts = L _ [L _ (Match { m_pats = [], m_grhss = grhss })]} | GRHSs [L _ (GRHS [] body)] lbinds <- grhss , L _ EmptyLocalBinds <- lbinds @@ -651,7 +654,7 @@ checkCanonicalInstances cls poly_ty mbinds = do ] -- stolen from TcInstDcls - instDeclCtxt1 :: LHsSigType Name -> SDoc + instDeclCtxt1 :: LHsSigType GhcRn -> SDoc instDeclCtxt1 hs_inst_ty = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty)) @@ -660,7 +663,7 @@ checkCanonicalInstances cls poly_ty mbinds = do 2 (quotes doc <> text ".") -rnClsInstDecl :: ClsInstDecl RdrName -> RnM (ClsInstDecl Name, FreeVars) +rnClsInstDecl :: ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, FreeVars) rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds , cid_sigs = uprags, cid_tyfam_insts = ats , cid_overlap_mode = oflag @@ -710,15 +713,15 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds -- to remove the context). rnFamInstDecl :: HsDocContext - -> Maybe (Name, [Name]) -- Nothing => not associated + -> Maybe (Name, [Name]) -- Nothing => not associated -- Just (cls,tvs) => associated, -- and gives class and tyvars of the -- parent instance delc -> Located RdrName - -> HsTyPats RdrName + -> HsTyPats GhcPs -> rhs -> (HsDocContext -> rhs -> RnM (rhs', FreeVars)) - -> RnM (Located Name, HsTyPats Name, rhs', FreeVars) + -> RnM (Located Name, HsTyPats GhcRn, rhs', FreeVars) rnFamInstDecl doc mb_cls tycon (HsIB { hsib_body = pats }) payload rnPayload = do { tycon' <- lookupFamInstName (fmap fst mb_cls) tycon ; let loc = case pats of @@ -789,16 +792,16 @@ rnFamInstDecl doc mb_cls tycon (HsIB { hsib_body = pats }) payload rnPayload -- type instance => use, hence addOneFV rnTyFamInstDecl :: Maybe (Name, [Name]) - -> TyFamInstDecl RdrName - -> RnM (TyFamInstDecl Name, FreeVars) + -> TyFamInstDecl GhcPs + -> RnM (TyFamInstDecl GhcRn, FreeVars) rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqn = L loc eqn }) = do { (eqn', fvs) <- rnTyFamInstEqn mb_cls eqn ; return (TyFamInstDecl { tfid_eqn = L loc eqn' , tfid_fvs = fvs }, fvs) } rnTyFamInstEqn :: Maybe (Name, [Name]) - -> TyFamInstEqn RdrName - -> RnM (TyFamInstEqn Name, FreeVars) + -> TyFamInstEqn GhcPs + -> RnM (TyFamInstEqn GhcRn, FreeVars) rnTyFamInstEqn mb_cls (TyFamEqn { tfe_tycon = tycon , tfe_pats = pats , tfe_fixity = fixity @@ -811,8 +814,8 @@ rnTyFamInstEqn mb_cls (TyFamEqn { tfe_tycon = tycon , tfe_rhs = rhs' }, fvs) } rnTyFamDefltEqn :: Name - -> TyFamDefltEqn RdrName - -> RnM (TyFamDefltEqn Name, FreeVars) + -> TyFamDefltEqn GhcPs + -> RnM (TyFamDefltEqn GhcRn, FreeVars) rnTyFamDefltEqn cls (TyFamEqn { tfe_tycon = tycon , tfe_pats = tyvars , tfe_fixity = fixity @@ -828,8 +831,8 @@ rnTyFamDefltEqn cls (TyFamEqn { tfe_tycon = tycon ctx = TyFamilyCtx tycon rnDataFamInstDecl :: Maybe (Name, [Name]) - -> DataFamInstDecl RdrName - -> RnM (DataFamInstDecl Name, FreeVars) + -> DataFamInstDecl GhcPs + -> RnM (DataFamInstDecl GhcRn, FreeVars) rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_tycon = tycon , dfid_pats = pats , dfid_fixity = fixity @@ -846,18 +849,18 @@ rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_tycon = tycon -- Rename associated type family decl in class rnATDecls :: Name -- Class - -> [LFamilyDecl RdrName] - -> RnM ([LFamilyDecl Name], FreeVars) + -> [LFamilyDecl GhcPs] + -> RnM ([LFamilyDecl GhcRn], FreeVars) rnATDecls cls at_decls = rnList (rnFamDecl (Just cls)) at_decls -rnATInstDecls :: (Maybe (Name, [Name]) -> -- The function that renames - decl RdrName -> -- an instance. rnTyFamInstDecl - RnM (decl Name, FreeVars)) -- or rnDataFamInstDecl +rnATInstDecls :: (Maybe (Name, [Name]) -> -- The function that renames + decl GhcPs -> -- an instance. rnTyFamInstDecl + RnM (decl GhcRn, FreeVars)) -- or rnDataFamInstDecl -> Name -- Class -> [Name] - -> [Located (decl RdrName)] - -> RnM ([Located (decl Name)], FreeVars) + -> [Located (decl GhcPs)] + -> RnM ([Located (decl GhcRn)], FreeVars) -- Used for data and type family defaults in a class decl -- and the family instance declarations in an instance -- @@ -954,7 +957,7 @@ Here 'k' is in scope in the kind signature, just like 'x'. ********************************************************* -} -rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars) +rnSrcDerivDecl :: DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars) rnSrcDerivDecl (DerivDecl ty deriv_strat overlap) = do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving ; deriv_strats_ok <- xoptM LangExt.DerivingStrategies @@ -977,12 +980,12 @@ standaloneDerivErr ********************************************************* -} -rnHsRuleDecls :: RuleDecls RdrName -> RnM (RuleDecls Name, FreeVars) +rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars) rnHsRuleDecls (HsRules src rules) = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules ; return (HsRules src rn_rules,fvs) } -rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars) +rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars) rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs) = do { let rdr_names_w_loc = map get_var vars ; checkDupRdrNames rdr_names_w_loc @@ -998,8 +1001,8 @@ rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs) get_var (L _ (RuleBndrSig v _)) = v get_var (L _ (RuleBndr v)) = v -bindHsRuleVars :: RuleName -> [LRuleBndr RdrName] -> [Name] - -> ([LRuleBndr Name] -> RnM (a, FreeVars)) +bindHsRuleVars :: RuleName -> [LRuleBndr GhcPs] -> [Name] + -> ([LRuleBndr GhcRn] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) bindHsRuleVars rule_name vars names thing_inside = go vars names $ \ vars' -> @@ -1035,7 +1038,7 @@ lambdas. So it seems simmpler not to check at all, and that is why check_e is commented out. -} -checkValidRule :: FastString -> [Name] -> LHsExpr Name -> NameSet -> RnM () +checkValidRule :: FastString -> [Name] -> LHsExpr GhcRn -> NameSet -> RnM () checkValidRule rule_name ids lhs' fv_lhs' = do { -- Check for the form of the LHS case (validRuleLhs ids lhs') of @@ -1046,7 +1049,7 @@ checkValidRule rule_name ids lhs' fv_lhs' ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')] ; mapM_ (addErr . badRuleVar rule_name) bad_vars } -validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name) +validRuleLhs :: [Name] -> LHsExpr GhcRn -> Maybe (HsExpr GhcRn) -- Nothing => OK -- Just e => Not ok, and e is the offending sub-expression validRuleLhs foralls lhs @@ -1084,7 +1087,7 @@ badRuleVar name var text "Forall'd variable" <+> quotes (ppr var) <+> text "does not appear on left hand side"] -badRuleLhsErr :: FastString -> LHsExpr Name -> HsExpr Name -> SDoc +badRuleLhsErr :: FastString -> LHsExpr GhcRn -> HsExpr GhcRn -> SDoc badRuleLhsErr name lhs bad_e = sep [text "Rule" <+> pprRuleName name <> colon, nest 4 (vcat [err, @@ -1104,7 +1107,7 @@ badRuleLhsErr name lhs bad_e ********************************************************* -} -rnHsVectDecl :: VectDecl RdrName -> RnM (VectDecl Name, FreeVars) +rnHsVectDecl :: VectDecl GhcPs -> RnM (VectDecl GhcRn, FreeVars) -- FIXME: For the moment, the right-hand side is restricted to be a variable as we cannot properly -- typecheck a complex right-hand side without invoking 'vectType' from the vectoriser. rnHsVectDecl (HsVect s var rhs@(L _ (HsVar _))) @@ -1286,8 +1289,8 @@ constructors] in TcEnv -} -rnTyClDecls :: [TyClGroup RdrName] - -> RnM ([TyClGroup Name], FreeVars) +rnTyClDecls :: [TyClGroup GhcPs] + -> RnM ([TyClGroup GhcRn], FreeVars) -- Rename the declarations and do dependency analysis on them rnTyClDecls tycl_ds = do { -- Rename the type/class, instance, and role declaraations @@ -1332,9 +1335,9 @@ rnTyClDecls tycl_ds ; return (all_groups, all_fvs) } where mk_group :: (InstDeclFreeVarsMap, RoleAnnotEnv) - -> SCC (LTyClDecl Name) + -> SCC (LTyClDecl GhcRn) -> ( (InstDeclFreeVarsMap, RoleAnnotEnv) - , TyClGroup Name ) + , TyClGroup GhcRn ) mk_group (inst_map, role_env) scc = ((inst_map', role_env'), group) where @@ -1348,13 +1351,13 @@ rnTyClDecls tycl_ds depAnalTyClDecls :: GlobalRdrEnv - -> [(LTyClDecl Name, FreeVars)] - -> [SCC (LTyClDecl Name)] + -> [(LTyClDecl GhcRn, FreeVars)] + -> [SCC (LTyClDecl GhcRn)] -- See Note [Dependency analysis of type, class, and instance decls] depAnalTyClDecls rdr_env ds_w_fvs = stronglyConnCompFromEdgedVerticesUniq edges where - edges :: [ Node Name (LTyClDecl Name) ] + edges :: [ Node Name (LTyClDecl GhcRn) ] edges = [ DigraphNode d (tcdName (unLoc d)) (map (getParent rdr_env) (nonDetEltsUniqSet fvs)) | (d, fvs) <- ds_w_fvs ] -- It's OK to use nonDetEltsUFM here as @@ -1469,21 +1472,24 @@ cannot infer a type to be polymorphically instantiated while we are inferring its kind), but no one has hollered about this (yet!) -} -addBootDeps :: [(LTyClDecl Name, FreeVars)] -> RnM [(LTyClDecl Name, FreeVars)] +addBootDeps :: [(LTyClDecl GhcRn, FreeVars)] + -> RnM [(LTyClDecl GhcRn, FreeVars)] -- See Note [Extra dependencies from .hs-boot files] addBootDeps ds_w_fvs = do { tcg_env <- getGblEnv ; let this_mod = tcg_mod tcg_env boot_info = tcg_self_boot tcg_env - add_boot_deps :: [(LTyClDecl Name, FreeVars)] -> [(LTyClDecl Name, FreeVars)] + add_boot_deps :: [(LTyClDecl GhcRn, FreeVars)] + -> [(LTyClDecl GhcRn, FreeVars)] add_boot_deps ds_w_fvs = case boot_info of SelfBoot { sb_tcs = tcs } | not (isEmptyNameSet tcs) -> map (add_one tcs) ds_w_fvs _ -> ds_w_fvs - add_one :: NameSet -> (LTyClDecl Name, FreeVars) -> (LTyClDecl Name, FreeVars) + add_one :: NameSet -> (LTyClDecl GhcRn, FreeVars) + -> (LTyClDecl GhcRn, FreeVars) add_one tcs pr@(decl,fvs) | has_local_imports fvs = (decl, fvs `plusFV` tcs) | otherwise = pr @@ -1505,8 +1511,8 @@ addBootDeps ds_w_fvs -- It is quite convenient to do both of these in the same place. -- See also Note [Role annotations in the renamer] rnRoleAnnots :: NameSet - -> [LRoleAnnotDecl RdrName] - -> RnM [LRoleAnnotDecl Name] + -> [LRoleAnnotDecl GhcPs] + -> RnM [LRoleAnnotDecl GhcRn] rnRoleAnnots tc_names role_annots = do { -- Check for duplicates *before* renaming, to avoid -- lumping together all the unboundNames @@ -1524,7 +1530,7 @@ rnRoleAnnots tc_names role_annots tycon ; return $ RoleAnnotDecl tycon' roles } -dupRoleAnnotErr :: [LRoleAnnotDecl RdrName] -> RnM () +dupRoleAnnotErr :: [LRoleAnnotDecl GhcPs] -> RnM () dupRoleAnnotErr [] = panic "dupRoleAnnotErr" dupRoleAnnotErr list = addErrAt loc $ @@ -1540,7 +1546,7 @@ dupRoleAnnotErr list cmp_annot (L loc1 _) (L loc2 _) = loc1 `compare` loc2 -orphanRoleAnnotErr :: LRoleAnnotDecl Name -> RnM () +orphanRoleAnnotErr :: LRoleAnnotDecl GhcRn -> RnM () orphanRoleAnnotErr (L loc decl) = addErrAt loc $ hang (text "Role annotation for a type previously declared:") @@ -1594,13 +1600,13 @@ modules), we get better error messages, too. -- the tycon names that are both -- a) free in the instance declaration -- b) bound by this group of type/class/instance decls -type InstDeclFreeVarsMap = [(LInstDecl Name, FreeVars)] +type InstDeclFreeVarsMap = [(LInstDecl GhcRn, FreeVars)] -- | Construct an @InstDeclFreeVarsMap@ by eliminating any @Name@s from the -- @FreeVars@ which are *not* the binders of a @TyClDecl@. mkInstDeclFreeVarsMap :: GlobalRdrEnv -> NameSet - -> [(LInstDecl Name, FreeVars)] + -> [(LInstDecl GhcRn, FreeVars)] -> InstDeclFreeVarsMap mkInstDeclFreeVarsMap rdr_env tycl_bndrs inst_ds_fvs = [ (inst_decl, toParents rdr_env fvs `intersectFVs` tycl_bndrs) @@ -1614,12 +1620,13 @@ mkInstDeclFreeVarsMap rdr_env tycl_bndrs inst_ds_fvs -- whose free vars are now defined -- instd_map' is the inst-decl map with 'tcs' removed from -- the free-var set -getInsts :: [Name] -> InstDeclFreeVarsMap -> ([LInstDecl Name], InstDeclFreeVarsMap) +getInsts :: [Name] -> InstDeclFreeVarsMap + -> ([LInstDecl GhcRn], InstDeclFreeVarsMap) getInsts bndrs inst_decl_map = partitionWith pick_me inst_decl_map where - pick_me :: (LInstDecl Name, FreeVars) - -> Either (LInstDecl Name) (LInstDecl Name, FreeVars) + pick_me :: (LInstDecl GhcRn, FreeVars) + -> Either (LInstDecl GhcRn) (LInstDecl GhcRn, FreeVars) pick_me (decl, fvs) | isEmptyNameSet depleted_fvs = Left decl | otherwise = Right (decl, depleted_fvs) @@ -1632,8 +1639,8 @@ getInsts bndrs inst_decl_map * * ****************************************************** -} -rnTyClDecl :: TyClDecl RdrName - -> RnM (TyClDecl Name, FreeVars) +rnTyClDecl :: TyClDecl GhcPs + -> RnM (TyClDecl GhcRn, FreeVars) -- All flavours of type family declarations ("type family", "newtype family", -- and "data family"), both top level and (for an associated type) @@ -1744,11 +1751,11 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls, cls_doc = ClassDeclCtx lcls -- "type" and "type instance" declarations -rnTySyn :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars) +rnTySyn :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) rnTySyn doc rhs = rnLHsType doc rhs -rnDataDefn :: HsDocContext -> HsDataDefn RdrName - -> RnM ((HsDataDefn Name, NameSet), FreeVars) +rnDataDefn :: HsDocContext -> HsDataDefn GhcPs + -> RnM ((HsDataDefn GhcRn, NameSet), FreeVars) -- the NameSet includes all Names free in the kind signature -- See Note [Complete user-supplied kind signatures] rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType @@ -1794,8 +1801,8 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause deriv_strats_ok doc) ds ; return (L loc ds', fvs) } -rnLHsDerivingClause :: Bool -> HsDocContext -> LHsDerivingClause RdrName - -> RnM (LHsDerivingClause Name, FreeVars) +rnLHsDerivingClause :: Bool -> HsDocContext -> LHsDerivingClause GhcPs + -> RnM (LHsDerivingClause GhcRn, FreeVars) rnLHsDerivingClause deriv_strats_ok doc (L loc (HsDerivingClause { deriv_clause_strategy = dcs , deriv_clause_tys = L loc' dct })) @@ -1824,8 +1831,8 @@ multipleDerivClausesErr rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested -- inside an *class decl* for cls -- used for associated types - -> FamilyDecl RdrName - -> RnM (FamilyDecl Name, FreeVars) + -> FamilyDecl GhcPs + -> RnM (FamilyDecl GhcRn, FreeVars) rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars , fdFixity = fixity , fdInfo = info, fdResultSig = res_sig @@ -1861,8 +1868,8 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars rnFamResultSig :: HsDocContext -> [Name] -- kind variables already in scope - -> FamilyResultSig RdrName - -> RnM (FamilyResultSig Name, FreeVars) + -> FamilyResultSig GhcPs + -> RnM (FamilyResultSig GhcRn, FreeVars) rnFamResultSig _ _ NoSig = return (NoSig, emptyFVs) rnFamResultSig doc _ (KindSig kind) @@ -1928,11 +1935,11 @@ rnFamResultSig doc kv_names (TyVarSig tvbndr) -- | Rename injectivity annotation. Note that injectivity annotation is just the -- part after the "|". Everything that appears before it is renamed in -- rnFamDecl. -rnInjectivityAnn :: LHsQTyVars Name -- ^ Type variables declared in +rnInjectivityAnn :: LHsQTyVars GhcRn -- ^ Type variables declared in -- type family head - -> LFamilyResultSig Name -- ^ Result signature - -> LInjectivityAnn RdrName -- ^ Injectivity annotation - -> RnM (LInjectivityAnn Name) + -> LFamilyResultSig GhcRn -- ^ Result signature + -> LInjectivityAnn GhcPs -- ^ Injectivity annotation + -> RnM (LInjectivityAnn GhcRn) rnInjectivityAnn tvBndrs (L _ (TyVarSig resTv)) (L srcSpan (InjectivityAnn injFrom injTo)) = do @@ -2013,10 +2020,10 @@ badAssocRhs ns 2 (text "All such variables must be bound on the LHS")) ----------------- -rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars) +rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars) rnConDecls = mapFvRn (wrapLocFstM rnConDecl) -rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name, FreeVars) +rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars) rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs , con_cxt = mcxt, con_details = details , con_doc = mb_doc }) @@ -2050,8 +2057,8 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs cxt = maybe [] unLoc mcxt get_rdr_tvs tys = extractHsTysRdrTyVars (cxt ++ tys) - get_con_qtvs :: [LHsType RdrName] - -> RnM ([Located RdrName], LHsQTyVars RdrName) + get_con_qtvs :: [LHsType GhcPs] + -> RnM ([Located RdrName], LHsQTyVars GhcPs) get_con_qtvs arg_tys | Just tvs <- qtvs -- data T = forall a. MkT (a -> a) = do { free_vars <- get_rdr_tvs arg_tys @@ -2076,8 +2083,9 @@ rnConDecl decl@(ConDeclGADT { con_names = names, con_type = ty rnConDeclDetails :: Name -> HsDocContext - -> HsConDetails (LHsType RdrName) (Located [LConDeclField RdrName]) - -> RnM (HsConDetails (LHsType Name) (Located [LConDeclField Name]), FreeVars) + -> HsConDetails (LHsType GhcPs) (Located [LConDeclField GhcPs]) + -> RnM (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]), + FreeVars) rnConDeclDetails _ doc (PrefixCon tys) = do { (new_tys, fvs) <- rnLHsTypes doc tys ; return (PrefixCon new_tys, fvs) } @@ -2098,7 +2106,7 @@ rnConDeclDetails con doc (RecCon (L l fields)) -- | Brings pattern synonym names and also pattern synonym selectors -- from record pattern synonyms into scope. -extendPatSynEnv :: HsValBinds RdrName -> MiniFixityEnv +extendPatSynEnv :: HsValBinds GhcPs -> MiniFixityEnv -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a extendPatSynEnv val_decls local_fix_env thing = do { names_with_fls <- new_ps val_decls @@ -2111,11 +2119,11 @@ extendPatSynEnv val_decls local_fix_env thing = do { final_gbl_env = gbl_env { tcg_field_env = field_env' } ; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) } where - new_ps :: HsValBinds RdrName -> TcM [(Name, [FieldLabel])] + new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])] new_ps (ValBindsIn binds _) = foldrBagM new_ps' [] binds new_ps _ = panic "new_ps" - new_ps' :: LHsBindLR RdrName RdrName + new_ps' :: LHsBindLR GhcPs GhcPs -> [(Name, [FieldLabel])] -> TcM [(Name, [FieldLabel])] new_ps' bind names @@ -2124,7 +2132,7 @@ extendPatSynEnv val_decls local_fix_env thing = do { = do bnd_name <- newTopSrcBinder (L bind_loc n) let rnames = map recordPatSynSelectorId as - mkFieldOcc :: Located RdrName -> LFieldOcc RdrName + mkFieldOcc :: Located RdrName -> LFieldOcc GhcPs mkFieldOcc (L l name) = L l (FieldOcc (L l name) PlaceHolder) field_occs = map mkFieldOcc rnames flds <- mapM (newRecordSelector False [bnd_name]) field_occs @@ -2175,18 +2183,19 @@ Template Haskell splice. As it does so it b) runs any top-level quasi-quotes -} -findSplice :: [LHsDecl RdrName] -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName])) +findSplice :: [LHsDecl GhcPs] + -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) findSplice ds = addl emptyRdrGroup ds -addl :: HsGroup RdrName -> [LHsDecl RdrName] - -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName])) +addl :: HsGroup GhcPs -> [LHsDecl GhcPs] + -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) -- This stuff reverses the declarations (again) but it doesn't matter addl gp [] = return (gp, Nothing) addl gp (L l d : ds) = add gp l d ds -add :: HsGroup RdrName -> SrcSpan -> HsDecl RdrName -> [LHsDecl RdrName] - -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName])) +add :: HsGroup GhcPs -> SrcSpan -> HsDecl GhcPs -> [LHsDecl GhcPs] + -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) -- #10047: Declaration QuasiQuoters are expanded immediately, without -- causing a group split diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs index e0f9493291..a03e4c88df 100644 --- a/compiler/rename/RnSplice.hs +++ b/compiler/rename/RnSplice.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} module RnSplice ( rnTopSpliceDecls, @@ -40,7 +41,6 @@ import FastString import ErrUtils ( dumpIfSet_dyn_printer ) import TcEnv ( tcMetaTy ) import Hooks -import Var ( Id ) import THNames ( quoteExpName, quotePatName, quoteDecName, quoteTypeName , decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, ) @@ -67,7 +67,7 @@ import qualified GHC.LanguageExtensions as LangExt ************************************************************************ -} -rnBracket :: HsExpr RdrName -> HsBracket RdrName -> RnM (HsExpr Name, FreeVars) +rnBracket :: HsExpr GhcPs -> HsBracket GhcPs -> RnM (HsExpr GhcRn, FreeVars) rnBracket e br_body = addErrCtxt (quotationCtxtDoc br_body) $ do { -- Check that -XTemplateHaskellQuotes is enabled and available @@ -112,7 +112,7 @@ rnBracket e br_body ; return (HsRnBracketOut body' pendings, fvs_e) } } -rn_bracket :: ThStage -> HsBracket RdrName -> RnM (HsBracket Name, FreeVars) +rn_bracket :: ThStage -> HsBracket GhcPs -> RnM (HsBracket GhcRn, FreeVars) rn_bracket outer_stage br@(VarBr flg rdr_name) = do { name <- lookupOccRn rdr_name ; this_mod <- getModule @@ -159,7 +159,7 @@ rn_bracket _ (DecBrL decls) ppr (duUses (tcg_dus tcg_env))) ; return (DecBrG group', duUses (tcg_dus tcg_env)) } where - groupDecls :: [LHsDecl RdrName] -> RnM (HsGroup RdrName) + groupDecls :: [LHsDecl GhcPs] -> RnM (HsGroup GhcPs) groupDecls decls = do { (group, mb_splice) <- findSplice decls ; case mb_splice of @@ -176,7 +176,7 @@ rn_bracket _ (DecBrG _) = panic "rn_bracket: unexpected DecBrG" rn_bracket _ (TExpBr e) = do { (e', fvs) <- rnLExpr e ; return (TExpBr e', fvs) } -quotationCtxtDoc :: HsBracket RdrName -> SDoc +quotationCtxtDoc :: HsBracket GhcPs -> SDoc quotationCtxtDoc br_body = hang (text "In the Template Haskell quotation") 2 (ppr br_body) @@ -194,7 +194,7 @@ illegalUntypedBracket :: SDoc illegalUntypedBracket = text "Untyped brackets may only appear in untyped splices." -quotedNameStageErr :: HsBracket RdrName -> SDoc +quotedNameStageErr :: HsBracket GhcPs -> SDoc quotedNameStageErr br = sep [ text "Stage error: the non-top-level quoted name" <+> ppr br , text "must be used at the same stage at which it is bound" ] @@ -236,9 +236,11 @@ returns a bogus term/type, so that it can report more than one error. We don't want the type checker to see these bogus unbound variables. -} -rnSpliceGen :: (HsSplice Name -> RnM (a, FreeVars)) -- Outside brackets, run splice - -> (HsSplice Name -> (PendingRnSplice, a)) -- Inside brackets, make it pending - -> HsSplice RdrName +rnSpliceGen :: (HsSplice GhcRn -> RnM (a, FreeVars)) + -- Outside brackets, run splice + -> (HsSplice GhcRn -> (PendingRnSplice, a)) + -- Inside brackets, make it pending + -> HsSplice GhcPs -> RnM (a, FreeVars) rnSpliceGen run_splice pend_splice splice = addErrCtxt (spliceCtxt splice) $ do @@ -281,10 +283,10 @@ rnSpliceGen run_splice pend_splice splice -- -- See Note [Delaying modFinalizers in untyped splices]. runRnSplice :: UntypedSpliceFlavour - -> (LHsExpr Id -> TcRn res) + -> (LHsExpr GhcTc -> TcRn res) -> (res -> SDoc) -- How to pretty-print res -- Usually just ppr, but not for [Decl] - -> HsSplice Name -- Always untyped + -> HsSplice GhcRn -- Always untyped -> TcRn (res, [ForeignRef (TH.Q ())]) runRnSplice flavour run_meta ppr_res splice = do { splice' <- getHooked runRnSpliceHook return >>= ($ splice) @@ -329,7 +331,7 @@ runRnSplice flavour run_meta ppr_res splice ------------------ makePending :: UntypedSpliceFlavour - -> HsSplice Name + -> HsSplice GhcRn -> PendingRnSplice makePending flavour (HsUntypedSplice _ n e) = PendingRnSplice flavour n e @@ -341,7 +343,8 @@ makePending _ splice@(HsSpliced {}) = pprPanic "makePending" (ppr splice) ------------------ -mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString -> LHsExpr Name +mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString + -> LHsExpr GhcRn -- Return the expression (quoter "...quote...") -- which is what we must run in a quasi-quote mkQuasiQuoteExpr flavour quoter q_span quote @@ -359,7 +362,7 @@ mkQuasiQuoteExpr flavour quoter q_span quote UntypedDeclSplice -> quoteDecName --------------------- -rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars) +rnSplice :: HsSplice GhcPs -> RnM (HsSplice GhcRn, FreeVars) -- Not exported...used for all rnSplice (HsTypedSplice hasParen splice_name expr) = do { checkTH expr "Template Haskell typed splice" @@ -391,15 +394,15 @@ rnSplice (HsQuasiQuote splice_name quoter q_loc quote) rnSplice splice@(HsSpliced {}) = pprPanic "rnSplice" (ppr splice) --------------------- -rnSpliceExpr :: HsSplice RdrName -> RnM (HsExpr Name, FreeVars) +rnSpliceExpr :: HsSplice GhcPs -> RnM (HsExpr GhcRn, FreeVars) rnSpliceExpr splice = rnSpliceGen run_expr_splice pend_expr_splice splice where - pend_expr_splice :: HsSplice Name -> (PendingRnSplice, HsExpr Name) + pend_expr_splice :: HsSplice GhcRn -> (PendingRnSplice, HsExpr GhcRn) pend_expr_splice rn_splice = (makePending UntypedExpSplice rn_splice, HsSpliceE rn_splice) - run_expr_splice :: HsSplice Name -> RnM (HsExpr Name, FreeVars) + run_expr_splice :: HsSplice GhcRn -> RnM (HsExpr GhcRn, FreeVars) run_expr_splice rn_splice | isTypedSplice rn_splice -- Run it later, in the type checker = do { -- Ugh! See Note [Splices] above @@ -516,8 +519,8 @@ References: -} ---------------------- -rnSpliceType :: HsSplice RdrName -> PostTc Name Kind - -> RnM (HsType Name, FreeVars) +rnSpliceType :: HsSplice GhcPs -> PostTc GhcRn Kind + -> RnM (HsType GhcRn, FreeVars) rnSpliceType splice k = rnSpliceGen run_type_splice pend_type_splice splice where @@ -583,7 +586,7 @@ whole signature, instead of as an arbitrary type. ---------------------- -- | Rename a splice pattern. See Note [rnSplicePat] -rnSplicePat :: HsSplice RdrName -> RnM ( Either (Pat RdrName) (Pat Name) +rnSplicePat :: HsSplice GhcPs -> RnM ( Either (Pat GhcPs) (Pat GhcRn) , FreeVars) rnSplicePat splice = rnSpliceGen run_pat_splice pend_pat_splice splice @@ -606,7 +609,7 @@ rnSplicePat splice -- lose the outermost location set by runQuasiQuote (#7918) ---------------------- -rnSpliceDecl :: SpliceDecl RdrName -> RnM (SpliceDecl Name, FreeVars) +rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars) rnSpliceDecl (SpliceDecl (L loc splice) flg) = rnSpliceGen run_decl_splice pend_decl_splice splice where @@ -615,7 +618,7 @@ rnSpliceDecl (SpliceDecl (L loc splice) flg) run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (ppr rn_splice) -rnTopSpliceDecls :: HsSplice RdrName -> RnM ([LHsDecl RdrName], FreeVars) +rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars) -- Declaration splice at the very top level of the module rnTopSpliceDecls splice = do { (rn_splice, fvs) <- checkNoErrs $ @@ -629,7 +632,7 @@ rnTopSpliceDecls splice ; add_mod_finalizers_now mod_finalizers ; return (decls,fvs) } where - ppr_decls :: [LHsDecl RdrName] -> SDoc + ppr_decls :: [LHsDecl GhcPs] -> SDoc ppr_decls ds = vcat (map ppr ds) -- Adds finalizers to the global environment instead of delaying them @@ -673,7 +676,7 @@ Pat RdrName (the result of running a top-level splice) or a Pat Name rnSplicePat. -} -spliceCtxt :: HsSplice RdrName -> SDoc +spliceCtxt :: HsSplice GhcPs -> SDoc spliceCtxt splice = hang (text "In the" <+> what) 2 (ppr splice) where @@ -686,12 +689,12 @@ spliceCtxt splice -- | The splice data to be logged data SpliceInfo = SpliceInfo - { spliceDescription :: String - , spliceSource :: Maybe (LHsExpr Name) -- Nothing <=> top-level decls - -- added by addTopDecls - , spliceIsDecl :: Bool -- True <=> put the generate code in a file - -- when -dth-dec-file is on - , spliceGenerated :: SDoc + { spliceDescription :: String + , spliceSource :: Maybe (LHsExpr GhcRn) -- Nothing <=> top-level decls + -- added by addTopDecls + , spliceIsDecl :: Bool -- True <=> put the generate code in a file + -- when -dth-dec-file is on + , spliceGenerated :: SDoc } -- Note that 'spliceSource' is *renamed* but not *typechecked* -- Reason (a) less typechecking crap diff --git a/compiler/rename/RnSplice.hs-boot b/compiler/rename/RnSplice.hs-boot index b079b30bd5..875ba05e52 100644 --- a/compiler/rename/RnSplice.hs-boot +++ b/compiler/rename/RnSplice.hs-boot @@ -2,16 +2,14 @@ module RnSplice where import HsSyn import TcRnMonad -import RdrName -import Name import NameSet import Kind -rnSpliceType :: HsSplice RdrName -> PostTc Name Kind - -> RnM (HsType Name, FreeVars) -rnSplicePat :: HsSplice RdrName -> RnM ( Either (Pat RdrName) (Pat Name) +rnSpliceType :: HsSplice GhcPs -> PostTc GhcRn Kind + -> RnM (HsType GhcRn, FreeVars) +rnSplicePat :: HsSplice GhcPs -> RnM ( Either (Pat GhcPs) (Pat GhcRn) , FreeVars ) -rnSpliceDecl :: SpliceDecl RdrName -> RnM (SpliceDecl Name, FreeVars) +rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars) -rnTopSpliceDecls :: HsSplice RdrName -> RnM ([LHsDecl RdrName], FreeVars) +rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars) diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index 7571684754..b75fcf2fc4 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -78,14 +78,14 @@ to break several loop. ********************************************************* -} -rnHsSigWcType :: HsDocContext -> LHsSigWcType RdrName - -> RnM (LHsSigWcType Name, FreeVars) +rnHsSigWcType :: HsDocContext -> LHsSigWcType GhcPs + -> RnM (LHsSigWcType GhcRn, FreeVars) rnHsSigWcType doc sig_ty = rn_hs_sig_wc_type True doc sig_ty $ \sig_ty' -> return (sig_ty', emptyFVs) -rnHsSigWcTypeScoped :: HsDocContext -> LHsSigWcType RdrName - -> (LHsSigWcType Name -> RnM (a, FreeVars)) +rnHsSigWcTypeScoped :: HsDocContext -> LHsSigWcType GhcPs + -> (LHsSigWcType GhcRn -> RnM (a, FreeVars)) -> RnM (a, FreeVars) -- Used for -- - Signatures on binders in a RULE @@ -104,8 +104,8 @@ rnHsSigWcTypeScoped ctx sig_ty thing_inside rn_hs_sig_wc_type :: Bool -- see rnImplicitBndrs -> HsDocContext - -> LHsSigWcType RdrName - -> (LHsSigWcType Name -> RnM (a, FreeVars)) + -> LHsSigWcType GhcPs + -> (LHsSigWcType GhcRn -> RnM (a, FreeVars)) -> RnM (a, FreeVars) -- rn_hs_sig_wc_type is used for source-language type signatures rn_hs_sig_wc_type no_implicit_if_forall ctxt @@ -120,7 +120,7 @@ rn_hs_sig_wc_type no_implicit_if_forall ctxt ; (res, fvs2) <- thing_inside sig_ty' ; return (res, fvs1 `plusFV` fvs2) } } -rnHsWcType :: HsDocContext -> LHsWcType RdrName -> RnM (LHsWcType Name, FreeVars) +rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars) rnHsWcType ctxt (HsWC { hswc_body = hs_ty }) = do { free_vars <- extractFilteredRdrTyVars hs_ty ; (_, nwc_rdrs) <- partition_nwcs free_vars @@ -128,8 +128,8 @@ rnHsWcType ctxt (HsWC { hswc_body = hs_ty }) ; let sig_ty' = HsWC { hswc_wcs = wcs, hswc_body = hs_ty' } ; return (sig_ty', fvs) } -rnWcBody :: HsDocContext -> [Located RdrName] -> LHsType RdrName - -> RnM ([Name], LHsType Name, FreeVars) +rnWcBody :: HsDocContext -> [Located RdrName] -> LHsType GhcPs + -> RnM ([Name], LHsType GhcRn, FreeVars) rnWcBody ctxt nwc_rdrs hs_ty = do { nwcs <- mapM newLocalBndrRn nwc_rdrs ; let env = RTKE { rtke_level = TypeLevel @@ -146,7 +146,7 @@ rnWcBody ctxt nwc_rdrs hs_ty do { (hs_ty', fvs) <- rn_ty env hs_ty ; return (L loc hs_ty', fvs) } - rn_ty :: RnTyKiEnv -> HsType RdrName -> RnM (HsType Name, FreeVars) + rn_ty :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) -- A lot of faff just to allow the extra-constraints wildcard to appear rn_ty env hs_ty@(HsForAllTy { hst_bndrs = tvs, hst_body = hs_body }) = bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc hs_ty) @@ -177,7 +177,7 @@ rnWcBody ctxt nwc_rdrs hs_ty rn_top_constraint env = rnLHsTyKi (env { rtke_what = RnTopConstraint }) -checkExtraConstraintWildCard :: RnTyKiEnv -> HsWildCardInfo RdrName +checkExtraConstraintWildCard :: RnTyKiEnv -> HsWildCardInfo GhcPs -> RnM () -- Rename the extra-constraint spot in a type signature -- (blah, _) => type @@ -204,7 +204,7 @@ extraConstraintWildCardsAllowed env -- without variables that are already in scope in LocalRdrEnv -- NB: this includes named wildcards, which look like perfectly -- ordinary type variables at this point -extractFilteredRdrTyVars :: LHsType RdrName -> RnM FreeKiTyVars +extractFilteredRdrTyVars :: LHsType GhcPs -> RnM FreeKiTyVars extractFilteredRdrTyVars hs_ty = do { rdr_env <- getLocalRdrEnv ; filterInScope rdr_env <$> extractHsTyRdrTyVars hs_ty } @@ -245,8 +245,8 @@ of the HsWildCardBndrs structure, and we are done. * * ****************************************************** -} -rnHsSigType :: HsDocContext -> LHsSigType RdrName - -> RnM (LHsSigType Name, FreeVars) +rnHsSigType :: HsDocContext -> LHsSigType GhcPs + -> RnM (LHsSigType GhcRn, FreeVars) -- Used for source-language type signatures -- that cannot have wildcards rnHsSigType ctx (HsIB { hsib_body = hs_ty }) @@ -260,7 +260,7 @@ rnImplicitBndrs :: Bool -- True <=> no implicit quantification -- E.g. f :: forall a. a->b -- Do not quantify over 'b' too. -> FreeKiTyVars - -> LHsType RdrName + -> LHsType GhcPs -> ([Name] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) rnImplicitBndrs no_implicit_if_forall free_vars hs_ty@(L loc _) thing_inside @@ -279,7 +279,7 @@ rnImplicitBndrs no_implicit_if_forall free_vars hs_ty@(L loc _) thing_inside ; bindLocalNamesFV vars $ thing_inside vars } -rnLHsInstType :: SDoc -> LHsSigType RdrName -> RnM (LHsSigType Name, FreeVars) +rnLHsInstType :: SDoc -> LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars) -- Rename the type in an instance or standalone deriving decl -- The 'doc_str' is "an instance declaration" or "a VECTORISE pragma" rnLHsInstType doc_str inst_ty @@ -297,10 +297,10 @@ rnLHsInstType doc_str inst_ty text "Malformed instance:" <+> ppr inst_ty ; rnHsSigType (GenericCtx doc_str) inst_ty } -mk_implicit_bndrs :: [Name] -- implicitly bound +mk_implicit_bndrs :: [Name] -- implicitly bound -> a -- payload -> FreeVars -- FreeVars of payload - -> HsImplicitBndrs Name a + -> HsImplicitBndrs GhcRn a mk_implicit_bndrs vars body fvs = HsIB { hsib_vars = vars , hsib_body = body @@ -428,40 +428,42 @@ isRnKindLevel (RTKE { rtke_level = KindLevel }) = True isRnKindLevel _ = False -------------- -rnLHsType :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars) +rnLHsType :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) rnLHsType ctxt ty = rnLHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty -rnLHsTypes :: HsDocContext -> [LHsType RdrName] -> RnM ([LHsType Name], FreeVars) +rnLHsTypes :: HsDocContext -> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars) rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys -rnHsType :: HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars) +rnHsType :: HsDocContext -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) rnHsType ctxt ty = rnHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty -rnLHsKind :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name, FreeVars) +rnLHsKind :: HsDocContext -> LHsKind GhcPs -> RnM (LHsKind GhcRn, FreeVars) rnLHsKind ctxt kind = rnLHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind -rnHsKind :: HsDocContext -> HsKind RdrName -> RnM (HsKind Name, FreeVars) +rnHsKind :: HsDocContext -> HsKind GhcPs -> RnM (HsKind GhcRn, FreeVars) rnHsKind ctxt kind = rnHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind -------------- -rnTyKiContext :: RnTyKiEnv -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars) +rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs + -> RnM (LHsContext GhcRn, FreeVars) rnTyKiContext env (L loc cxt) = do { traceRn "rncontext" (ppr cxt) ; let env' = env { rtke_what = RnConstraint } ; (cxt', fvs) <- mapFvRn (rnLHsTyKi env') cxt ; return (L loc cxt', fvs) } -rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars) +rnContext :: HsDocContext -> LHsContext GhcPs + -> RnM (LHsContext GhcRn, FreeVars) rnContext doc theta = rnTyKiContext (mkTyKiEnv doc TypeLevel RnConstraint) theta -------------- -rnLHsTyKi :: RnTyKiEnv -> LHsType RdrName -> RnM (LHsType Name, FreeVars) +rnLHsTyKi :: RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) rnLHsTyKi env (L loc ty) = setSrcSpan loc $ do { (ty', fvs) <- rnHsTyKi env ty ; return (L loc ty', fvs) } -rnHsTyKi :: RnTyKiEnv -> HsType RdrName -> RnM (HsType Name, FreeVars) +rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) rnHsTyKi env ty@(HsForAllTy { hst_bndrs = tyvars, hst_body = tau }) = do { checkTypeInType env ty @@ -593,9 +595,9 @@ rnHsTyKi env overall_ty@(HsAppsTy tys) ; return (res_ty, fvs1 `plusFV` fvs2) } where -- See Note [Dealing with *] - deal_with_star :: [[LHsType Name]] -> [Located Name] - -> [[LHsType Name]] -> [Located Name] - -> ([[LHsType Name]], [Located Name]) + deal_with_star :: [[LHsType GhcRn]] -> [Located Name] + -> [[LHsType GhcRn]] -> [Located Name] + -> ([[LHsType GhcRn]], [Located Name]) deal_with_star acc1 acc2 (non_syms1 : non_syms2 : non_syms) (L loc star : ops) | star `hasKey` starKindTyConKey || star `hasKey` unicodeStarKindTyConKey @@ -610,14 +612,14 @@ rnHsTyKi env overall_ty@(HsAppsTy tys) deal_with_star _ _ _ _ = pprPanic "deal_with_star" (ppr overall_ty) - -- collapse [LHsType Name] to LHsType Name by making applications + -- collapse [LHsType GhcRn] to LHsType GhcRn by making applications -- monadic only for failure - deal_with_non_syms :: [LHsType Name] -> RnM (LHsType Name) + deal_with_non_syms :: [LHsType GhcRn] -> RnM (LHsType GhcRn) deal_with_non_syms (non_sym : non_syms) = return $ mkHsAppTys non_sym non_syms deal_with_non_syms [] = failWith (emptyNonSymsErr overall_ty) -- assemble a right-biased OpTy for use in mkHsOpTyRn - build_res_ty :: [LHsType Name] -> [Located Name] -> RnM (LHsType Name) + build_res_ty :: [LHsType GhcRn] -> [Located Name] -> RnM (LHsType GhcRn) build_res_ty (arg1 : args) (op1 : ops) = do { rhs <- build_res_ty args ops ; fix <- lookupTyFixityRn op1 @@ -697,7 +699,8 @@ rnLTyVar (L loc rdr_name) -------------- rnHsTyOp :: Outputable a - => RnTyKiEnv -> a -> Located RdrName -> RnM (Located Name, FreeVars) + => RnTyKiEnv -> a -> Located RdrName + -> RnM (Located Name, FreeVars) rnHsTyOp env overall_ty (L loc op) = do { ops_ok <- xoptM LangExt.TypeOperators ; op' <- rnTyVar env op @@ -720,7 +723,7 @@ checkWildCard env (Just doc) checkWildCard _ Nothing = return () -checkAnonWildCard :: RnTyKiEnv -> HsWildCardInfo RdrName -> RnM () +checkAnonWildCard :: RnTyKiEnv -> HsWildCardInfo GhcPs -> RnM () -- Report an error if an anonymous wildcard is illegal here checkAnonWildCard env wc = checkWildCard env mb_bad @@ -770,7 +773,7 @@ wildCardsAllowed env HsTypeCtx {} -> True _ -> False -rnAnonWildCard :: HsWildCardInfo RdrName -> RnM (HsWildCardInfo Name) +rnAnonWildCard :: HsWildCardInfo GhcPs -> RnM (HsWildCardInfo GhcRn) rnAnonWildCard (AnonWildCard _) = do { loc <- getSrcSpanM ; uniq <- newUnique @@ -836,10 +839,10 @@ bindHsQTyVars :: forall a b. -> Maybe SDoc -- if we are to check for unused tvs, -- a phrase like "in the type ..." -> Maybe a -- Just _ => an associated type decl - -> [Located RdrName] -- Kind variables from scope, in l-to-r + -> [Located RdrName] -- Kind variables from scope, in l-to-r -- order, but not from ... - -> (LHsQTyVars RdrName) -- ... these user-written tyvars - -> (LHsQTyVars Name -> NameSet -> RnM (b, FreeVars)) + -> (LHsQTyVars GhcPs) -- ... these user-written tyvars + -> (LHsQTyVars GhcRn -> NameSet -> RnM (b, FreeVars)) -- also returns all names used in kind signatures, for the -- TypeInType clause of Note [Complete user-supplied kind -- signatures] in HsDecls @@ -861,11 +864,11 @@ bindLHsTyVarBndrs :: forall a b. -> Maybe SDoc -- if we are to check for unused tvs, -- a phrase like "in the type ..." -> Maybe a -- Just _ => an associated type decl - -> [Located RdrName] -- Unbound kind variables from scope, - -- in l-to-r order, but not from ... - -> [LHsTyVarBndr RdrName] -- ... these user-written tyvars + -> [Located RdrName] -- Unbound kind variables from scope, + -- in l-to-r order, but not from ... + -> [LHsTyVarBndr GhcPs] -- ... these user-written tyvars -> ( [Name] -- all kv names - -> [LHsTyVarBndr Name] + -> [LHsTyVarBndr GhcRn] -> NameSet -- which names, from the preceding list, -- are used dependently within that list -- See Note [Dependent LHsQTyVars] in TcHsType @@ -879,11 +882,11 @@ bindLHsTyVarBndrs doc mb_in_doc mb_assoc kv_bndrs tv_bndrs thing_inside tv_names_w_loc = map hsLTyVarLocName tv_bndrs go :: [Name] -- kind-vars found (in reverse order) - -> [LHsTyVarBndr Name] -- already renamed (in reverse order) + -> [LHsTyVarBndr GhcRn] -- already renamed (in reverse order) -> NameSet -- kind vars already in scope (for dup checking) -> NameSet -- type vars already in scope (for dup checking) -> NameSet -- (all) variables used dependently - -> [LHsTyVarBndr RdrName] -- still to be renamed, scoped + -> [LHsTyVarBndr GhcPs] -- still to be renamed, scoped -> RnM (b, FreeVars) go rn_kvs rn_tvs kv_names tv_names dep_vars (tv_bndr : tv_bndrs) = bindLHsTyVarBndr doc mb_assoc kv_names tv_names tv_bndr $ @@ -923,8 +926,9 @@ bindLHsTyVarBndr :: HsDocContext -> Maybe a -- associated class -> NameSet -- kind vars already in scope -> NameSet -- type vars already in scope - -> LHsTyVarBndr RdrName - -> ([Name] -> NameSet -> LHsTyVarBndr Name -> RnM (b, FreeVars)) + -> LHsTyVarBndr GhcPs + -> ([Name] -> NameSet -> LHsTyVarBndr GhcRn + -> RnM (b, FreeVars)) -- passed the newly-bound implicitly-declared kind vars, -- any other names used in a kind -- and the renamed LHsTyVarBndr @@ -1038,7 +1042,7 @@ newTyVarNameRn mb_assoc (L loc rdr) _ -> newLocalBndrRn (L loc rdr) } --------------------- -collectAnonWildCards :: LHsType Name -> [Name] +collectAnonWildCards :: LHsType GhcRn -> [Name] -- | Extract all wild cards from a type. collectAnonWildCards lty = go lty where @@ -1077,7 +1081,7 @@ collectAnonWildCards lty = go lty prefix_types_only (HsAppPrefix ty) = Just ty prefix_types_only (HsAppInfix _) = Nothing -collectAnonWildCardsBndrs :: [LHsTyVarBndr Name] -> [Name] +collectAnonWildCardsBndrs :: [LHsTyVarBndr GhcRn] -> [Name] collectAnonWildCardsBndrs ltvs = concatMap (go . unLoc) ltvs where go (UserTyVar _) = [] @@ -1097,8 +1101,8 @@ RnNames.getLocalNonValBinders), so we just take the list as an argument, build a map and look them up. -} -rnConDeclFields :: HsDocContext -> [FieldLabel] -> [LConDeclField RdrName] - -> RnM ([LConDeclField Name], FreeVars) +rnConDeclFields :: HsDocContext -> [FieldLabel] -> [LConDeclField GhcPs] + -> RnM ([LConDeclField GhcRn], FreeVars) -- Also called from RnSource -- No wildcards can appear in record fields rnConDeclFields ctxt fls fields @@ -1107,15 +1111,15 @@ rnConDeclFields ctxt fls fields env = mkTyKiEnv ctxt TypeLevel RnTypeBody fl_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ] -rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField RdrName - -> RnM (LConDeclField Name, FreeVars) +rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs + -> RnM (LConDeclField GhcRn, FreeVars) rnField fl_env env (L l (ConDeclField names ty haddock_doc)) = do { let new_names = map (fmap lookupField) names ; (new_ty, fvs) <- rnLHsTyKi env ty ; new_haddock_doc <- rnMbLHsDoc haddock_doc ; return (L l (ConDeclField new_names new_ty new_haddock_doc), fvs) } where - lookupField :: FieldOcc RdrName -> FieldOcc Name + lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn lookupField (FieldOcc (L lr rdr) _) = FieldOcc (L lr rdr) (flSelector fl) where lbl = occNameFS $ rdrNameOcc rdr @@ -1149,9 +1153,9 @@ by the presence of ->, which is a separate syntactic construct. --------------- -- Building (ty1 `op1` (ty21 `op2` ty22)) -mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name) - -> Name -> Fixity -> LHsType Name -> LHsType Name - -> RnM (HsType Name) +mkHsOpTyRn :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn) + -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn + -> RnM (HsType GhcRn) mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 op2 ty22)) = do { fix2 <- lookupTyFixityRn op2 @@ -1167,11 +1171,11 @@ mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment = return (mk1 ty1 ty2) --------------- -mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name) - -> Name -> Fixity -> LHsType Name - -> (LHsType Name -> LHsType Name -> HsType Name) - -> Name -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan - -> RnM (HsType Name) +mk_hs_op_ty :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn) + -> Name -> Fixity -> LHsType GhcRn + -> (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn) + -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn -> SrcSpan + -> RnM (HsType GhcRn) mk_hs_op_ty mk1 op1 fix1 ty1 mk2 op2 fix2 ty21 ty22 loc2 | nofix_error = do { precParseErr (NormalOp op1,fix1) (NormalOp op2,fix2) @@ -1185,11 +1189,11 @@ mk_hs_op_ty mk1 op1 fix1 ty1 --------------------------- -mkOpAppRn :: LHsExpr Name -- Left operand; already rearranged - -> LHsExpr Name -> Fixity -- Operator and fixity - -> LHsExpr Name -- Right operand (not an OpApp, but might - -- be a NegApp) - -> RnM (HsExpr Name) +mkOpAppRn :: LHsExpr GhcRn -- Left operand; already rearranged + -> LHsExpr GhcRn -> Fixity -- Operator and fixity + -> LHsExpr GhcRn -- Right operand (not an OpApp, but might + -- be a NegApp) + -> RnM (HsExpr GhcRn) -- (e11 `op1` e12) `op2` e2 mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2 @@ -1241,7 +1245,7 @@ mkOpAppRn e1 op fix e2 -- Default case, no rearrangment data OpName = NormalOp Name -- ^ A normal identifier | NegateOp -- ^ Prefix negation | UnboundOp UnboundVar -- ^ An unbound indentifier - | RecFldOp (AmbiguousFieldOcc Name) + | RecFldOp (AmbiguousFieldOcc GhcRn) -- ^ A (possibly ambiguous) record field occurrence instance Outputable OpName where @@ -1250,7 +1254,7 @@ instance Outputable OpName where ppr (UnboundOp uv) = ppr uv ppr (RecFldOp fld) = ppr fld -get_op :: LHsExpr Name -> OpName +get_op :: LHsExpr GhcRn -> OpName -- An unbound name could be either HsVar or HsUnboundVar -- See RnExpr.rnUnboundVar get_op (L _ (HsVar (L _ n))) = NormalOp n @@ -1261,7 +1265,7 @@ get_op other = pprPanic "get_op" (ppr other) -- Parser left-associates everything, but -- derived instances may have correctly-associated things to -- in the right operand. So we just check that the right operand is OK -right_op_ok :: Fixity -> HsExpr Name -> Bool +right_op_ok :: Fixity -> HsExpr GhcRn -> Bool right_op_ok fix1 (OpApp _ _ fix2 _) = not error_please && associate_right where @@ -1281,10 +1285,10 @@ not_op_app (OpApp _ _ _ _) = False not_op_app _ = True --------------------------- -mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged - -> LHsExpr Name -> Fixity -- Operator and fixity - -> LHsCmdTop Name -- Right operand (not an infix) - -> RnM (HsCmd Name) +mkOpFormRn :: LHsCmdTop GhcRn -- Left operand; already rearranged + -> LHsExpr GhcRn -> Fixity -- Operator and fixity + -> LHsCmdTop GhcRn -- Right operand (not an infix) + -> RnM (HsCmd GhcRn) -- (e11 `op1` e12) `op2` e2 mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 f (Just fix1) @@ -1309,8 +1313,8 @@ mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment -------------------------------------- -mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name - -> RnM (Pat Name) +mkConOpPatRn :: Located Name -> Fixity -> LPat GhcRn -> LPat GhcRn + -> RnM (Pat GhcRn) mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2 = do { fix1 <- lookupFixityRn (unLoc op1) @@ -1330,12 +1334,12 @@ mkConOpPatRn op _ p1 p2 -- Default case, no rearrangment = ASSERT( not_op_pat (unLoc p2) ) return (ConPatIn op (InfixCon p1 p2)) -not_op_pat :: Pat Name -> Bool +not_op_pat :: Pat GhcRn -> Bool not_op_pat (ConPatIn _ (InfixCon _ _)) = False not_op_pat _ = True -------------------------------------- -checkPrecMatch :: Name -> MatchGroup Name body -> RnM () +checkPrecMatch :: Name -> MatchGroup GhcRn body -> RnM () -- Check precedence of a function binding written infix -- eg a `op` b `C` c = ... -- See comments with rnExpr (OpApp ...) about "deriving" @@ -1357,7 +1361,7 @@ checkPrecMatch op (MG { mg_alts = L _ ms }) -- until the type checker). So we don't want to crash on the -- second eqn. -checkPrec :: Name -> Pat Name -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) () +checkPrec :: Name -> Pat GhcRn -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) () checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do op_fix@(Fixity _ op_prec op_dir) <- lookupFixityRn op op1_fix@(Fixity _ op1_prec op1_dir) <- lookupFixityRn (unLoc op1) @@ -1379,8 +1383,8 @@ checkPrec _ _ _ -- If arg is itself an operator application, then either -- (a) its precedence must be higher than that of op -- (b) its precedency & associativity must be the same as that of op -checkSectionPrec :: FixityDirection -> HsExpr RdrName - -> LHsExpr Name -> LHsExpr Name -> RnM () +checkSectionPrec :: FixityDirection -> HsExpr GhcPs + -> LHsExpr GhcRn -> LHsExpr GhcRn -> RnM () checkSectionPrec direction section op arg = case unLoc arg of OpApp _ op' fix _ -> go_for_it (get_op op') fix @@ -1417,7 +1421,7 @@ precParseErr op1@(n1,_) op2@(n2,_) ppr_opfix op2, text "in the same infix expression"]) -sectionPrecErr :: (OpName,Fixity) -> (OpName,Fixity) -> HsExpr RdrName -> RnM () +sectionPrecErr :: (OpName,Fixity) -> (OpName,Fixity) -> HsExpr GhcPs -> RnM () sectionPrecErr op@(n1,_) arg_op@(n2,_) section | is_unbound n1 || is_unbound n2 = return () -- Avoid error cascade @@ -1444,7 +1448,7 @@ ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity) * * ***************************************************** -} -unexpectedTypeSigErr :: LHsSigWcType RdrName -> SDoc +unexpectedTypeSigErr :: LHsSigWcType GhcPs -> SDoc unexpectedTypeSigErr ty = hang (text "Illegal type signature:" <+> quotes (ppr ty)) 2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables") @@ -1456,14 +1460,14 @@ badKindBndrs doc kvs <+> pprQuotedList kvs) 2 (text "Perhaps you intended to use PolyKinds") -badKindSigErr :: HsDocContext -> LHsType RdrName -> TcM () +badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM () badKindSigErr doc (L loc ty) = setSrcSpan loc $ addErr $ withHsDocContext doc $ hang (text "Illegal kind signature:" <+> quotes (ppr ty)) 2 (text "Perhaps you intended to use KindSignatures") -dataKindsErr :: RnTyKiEnv -> HsType RdrName -> SDoc +dataKindsErr :: RnTyKiEnv -> HsType GhcPs -> SDoc dataKindsErr env thing = hang (text "Illegal" <+> pp_what <> colon <+> quotes (ppr thing)) 2 (text "Perhaps you intended to use DataKinds") @@ -1471,10 +1475,10 @@ dataKindsErr env thing pp_what | isRnKindLevel env = text "kind" | otherwise = text "type" -inTypeDoc :: HsType RdrName -> SDoc +inTypeDoc :: HsType GhcPs -> SDoc inTypeDoc ty = text "In the type" <+> quotes (ppr ty) -warnUnusedForAll :: SDoc -> LHsTyVarBndr Name -> FreeVars -> TcM () +warnUnusedForAll :: SDoc -> LHsTyVarBndr GhcRn -> FreeVars -> TcM () warnUnusedForAll in_doc (L loc tv) used_names = whenWOptM Opt_WarnUnusedForalls $ unless (hsTyVarName tv `elemNameSet` used_names) $ @@ -1492,7 +1496,7 @@ opTyErr op overall_ty | otherwise = text "Use TypeOperators to allow operators in types" -emptyNonSymsErr :: HsType RdrName -> SDoc +emptyNonSymsErr :: HsType GhcPs -> SDoc emptyNonSymsErr overall_ty = text "Operator applied to too few arguments:" <+> ppr overall_ty @@ -1569,7 +1573,7 @@ filterInScope rdr_env (FKTV kis k_set tys t_set all) inScope :: LocalRdrEnv -> RdrName -> Bool inScope rdr_env rdr = rdr `elemLocalRdrEnv` rdr_env -extractHsTyRdrTyVars :: LHsType RdrName -> RnM FreeKiTyVars +extractHsTyRdrTyVars :: LHsType GhcPs -> RnM FreeKiTyVars -- extractHsTyRdrNames finds the free (kind, type) variables of a HsType -- or the free (sort, kind) variables of a HsKind -- It's used when making the for-alls explicit. @@ -1587,14 +1591,14 @@ extractHsTyRdrTyVars ty -- When the same name occurs multiple times in the types, only the first -- occurrence is returned and the rest is filtered out. -- See Note [Kind and type-variable binders] -extractHsTysRdrTyVars :: [LHsType RdrName] -> RnM FreeKiTyVars +extractHsTysRdrTyVars :: [LHsType GhcPs] -> RnM FreeKiTyVars extractHsTysRdrTyVars tys = rmDupsInRdrTyVars <$> extractHsTysRdrTyVarsDups tys -- | Extracts free type and kind variables from types in a list. -- When the same name occurs multiple times in the types, all occurrences -- are returned. -extractHsTysRdrTyVarsDups :: [LHsType RdrName] -> RnM FreeKiTyVars +extractHsTysRdrTyVarsDups :: [LHsType GhcPs] -> RnM FreeKiTyVars extractHsTysRdrTyVarsDups tys = extract_ltys TypeLevel tys emptyFKTV @@ -1603,14 +1607,14 @@ rmDupsInRdrTyVars :: FreeKiTyVars -> FreeKiTyVars rmDupsInRdrTyVars (FKTV kis k_set tys t_set all) = FKTV (nubL kis) k_set (nubL tys) t_set (nubL all) -extractRdrKindSigVars :: LFamilyResultSig RdrName -> RnM [Located RdrName] +extractRdrKindSigVars :: LFamilyResultSig GhcPs -> RnM [Located RdrName] extractRdrKindSigVars (L _ resultSig) | KindSig k <- resultSig = kindRdrNameFromSig k | TyVarSig (L _ (KindedTyVar _ k)) <- resultSig = kindRdrNameFromSig k | otherwise = return [] where kindRdrNameFromSig k = freeKiTyVarsAllVars <$> extractHsTyRdrTyVars k -extractDataDefnKindVars :: HsDataDefn RdrName -> RnM [Located RdrName] +extractDataDefnKindVars :: HsDataDefn GhcPs -> RnM [Located RdrName] -- Get the scoped kind variables mentioned free in the constructor decls -- Eg data T a = T1 (S (a :: k) | forall (b::k). T2 (S b) -- Here k should scope over the whole definition @@ -1629,21 +1633,21 @@ extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig extract_mlctxt ctxt =<< extract_ltys TypeLevel (hsConDeclArgTys details) emptyFKTV -extract_mlctxt :: Maybe (LHsContext RdrName) -> FreeKiTyVars -> RnM FreeKiTyVars +extract_mlctxt :: Maybe (LHsContext GhcPs) -> FreeKiTyVars -> RnM FreeKiTyVars extract_mlctxt Nothing acc = return acc extract_mlctxt (Just ctxt) acc = extract_lctxt TypeLevel ctxt acc extract_lctxt :: TypeOrKind - -> LHsContext RdrName -> FreeKiTyVars -> RnM FreeKiTyVars + -> LHsContext GhcPs -> FreeKiTyVars -> RnM FreeKiTyVars extract_lctxt t_or_k ctxt = extract_ltys t_or_k (unLoc ctxt) -extract_sig_tys :: [LHsSigType RdrName] -> FreeKiTyVars -> RnM FreeKiTyVars +extract_sig_tys :: [LHsSigType GhcPs] -> FreeKiTyVars -> RnM FreeKiTyVars extract_sig_tys sig_tys acc = foldrM (\sig_ty acc -> extract_lty TypeLevel (hsSigType sig_ty) acc) acc sig_tys extract_ltys :: TypeOrKind - -> [LHsType RdrName] -> FreeKiTyVars -> RnM FreeKiTyVars + -> [LHsType GhcPs] -> FreeKiTyVars -> RnM FreeKiTyVars extract_ltys t_or_k tys acc = foldrM (extract_lty t_or_k) acc tys extract_mb :: (a -> FreeKiTyVars -> RnM FreeKiTyVars) @@ -1651,10 +1655,10 @@ extract_mb :: (a -> FreeKiTyVars -> RnM FreeKiTyVars) extract_mb _ Nothing acc = return acc extract_mb f (Just x) acc = f x acc -extract_lkind :: LHsType RdrName -> FreeKiTyVars -> RnM FreeKiTyVars +extract_lkind :: LHsType GhcPs -> FreeKiTyVars -> RnM FreeKiTyVars extract_lkind = extract_lty KindLevel -extract_lty :: TypeOrKind -> LHsType RdrName -> FreeKiTyVars -> RnM FreeKiTyVars +extract_lty :: TypeOrKind -> LHsType GhcPs -> FreeKiTyVars -> RnM FreeKiTyVars extract_lty t_or_k (L _ ty) acc = case ty of HsTyVar _ ltv -> extract_tv t_or_k ltv acc @@ -1696,15 +1700,15 @@ extract_lty t_or_k (L _ ty) acc HsWildCardTy {} -> return acc extract_apps :: TypeOrKind - -> [LHsAppType RdrName] -> FreeKiTyVars -> RnM FreeKiTyVars + -> [LHsAppType GhcPs] -> FreeKiTyVars -> RnM FreeKiTyVars extract_apps t_or_k tys acc = foldrM (extract_app t_or_k) acc tys -extract_app :: TypeOrKind -> LHsAppType RdrName -> FreeKiTyVars +extract_app :: TypeOrKind -> LHsAppType GhcPs -> FreeKiTyVars -> RnM FreeKiTyVars extract_app t_or_k (L _ (HsAppInfix tv)) acc = extract_tv t_or_k tv acc extract_app t_or_k (L _ (HsAppPrefix ty)) acc = extract_lty t_or_k ty acc -extract_hs_tv_bndrs :: [LHsTyVarBndr RdrName] -> FreeKiTyVars +extract_hs_tv_bndrs :: [LHsTyVarBndr GhcPs] -> FreeKiTyVars -> FreeKiTyVars -> RnM FreeKiTyVars -- In (forall (a :: Maybe e). a -> b) we have -- 'a' is bound by the forall @@ -1731,7 +1735,8 @@ extract_hs_tv_bndrs tvs ((body_t_set `minusOccSet` locals) `unionOccSets` acc_t_set) (filterOut ((`elemOccSet` locals) . rdrNameOcc . unLoc) (bndr_kvs ++ body_all) ++ acc_all) } -extract_tv :: TypeOrKind -> Located RdrName -> FreeKiTyVars -> RnM FreeKiTyVars +extract_tv :: TypeOrKind -> Located RdrName -> FreeKiTyVars + -> RnM FreeKiTyVars extract_tv t_or_k ltv@(L _ tv) acc | isRdrTyVar tv = case acc of FKTV kvs k_set tvs t_set all diff --git a/compiler/rename/RnUtils.hs b/compiler/rename/RnUtils.hs index 85977d6073..7b2f74f1da 100644 --- a/compiler/rename/RnUtils.hs +++ b/compiler/rename/RnUtils.hs @@ -369,7 +369,7 @@ data HsDocContext | TypBrCtx | HsTypeCtx | GHCiCtx - | SpliceTypeCtx (LHsType RdrName) + | SpliceTypeCtx (LHsType GhcPs) | ClassInstanceCtx | VectDeclCtx (Located RdrName) | GenericCtx SDoc -- Maybe we want to use this more! diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs index a83bbae36f..cad7793f51 100644 --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -7,6 +7,7 @@ The @Inst@ type: dictionaries or method instances -} {-# LANGUAGE CPP, MultiWayIf, TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} module Inst ( deeplySkolemise, @@ -75,7 +76,7 @@ import Control.Monad( unless ) ************************************************************************ -} -newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr TcId) +newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr GhcTcId) -- Used when Name is the wired-in name for a wired-in class method, -- so the caller knows its type for sure, which should be of form -- forall a. C a => <blah> @@ -500,9 +501,9 @@ cases (the rest are caught in lookupInst). -} -newOverloadedLit :: HsOverLit Name +newOverloadedLit :: HsOverLit GhcRn -> ExpRhoType - -> TcM (HsOverLit TcId) + -> TcM (HsOverLit GhcTcId) newOverloadedLit lit@(OverLit { ol_val = val, ol_rebindable = rebindable }) res_ty | not rebindable @@ -528,9 +529,9 @@ newOverloadedLit -- Does not handle things that 'shortCutLit' can handle. See also -- newOverloadedLit in TcUnify newNonTrivialOverloadedLit :: CtOrigin - -> HsOverLit Name + -> HsOverLit GhcRn -> ExpRhoType - -> TcM (HsOverLit TcId) + -> TcM (HsOverLit GhcTcId) newNonTrivialOverloadedLit orig lit@(OverLit { ol_val = val, ol_witness = HsVar (L _ meth_name) , ol_rebindable = rebindable }) res_ty @@ -548,16 +549,17 @@ newNonTrivialOverloadedLit _ lit _ = pprPanic "newNonTrivialOverloadedLit" (ppr lit) ------------ -mkOverLit :: OverLitVal -> TcM HsLit +mkOverLit ::(HasDefaultX p, SourceTextX p) => OverLitVal -> TcM (HsLit p) mkOverLit (HsIntegral i) = do { integer_ty <- tcMetaTy integerTyConName - ; return (HsInteger (il_text i) (il_value i) integer_ty) } + ; return (HsInteger (setSourceText $ il_text i) + (il_value i) integer_ty) } mkOverLit (HsFractional r) = do { rat_ty <- tcMetaTy rationalTyConName - ; return (HsRat r rat_ty) } + ; return (HsRat def r rat_ty) } -mkOverLit (HsIsString src s) = return (HsString src s) +mkOverLit (HsIsString src s) = return (HsString (setSourceText src) s) {- ************************************************************************ @@ -592,9 +594,10 @@ just use the expression inline. -} tcSyntaxName :: CtOrigin - -> TcType -- Type to instantiate it at - -> (Name, HsExpr Name) -- (Standard name, user name) - -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression) + -> TcType -- ^ Type to instantiate it at + -> (Name, HsExpr GhcRn) -- ^ (Standard name, user name) + -> TcM (Name, HsExpr GhcTcId) + -- ^ (Standard name, suitable expression) -- USED ONLY FOR CmdTop (sigh) *** -- See Note [CmdSyntaxTable] in HsExpr @@ -621,7 +624,7 @@ tcSyntaxName orig ty (std_nm, user_nm_expr) = do expr <- tcPolyExpr (L span user_nm_expr) sigma1 return (std_nm, unLoc expr) -syntaxNameCtxt :: HsExpr Name -> CtOrigin -> Type -> TidyEnv +syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> TidyEnv -> TcRn (TidyEnv, SDoc) syntaxNameCtxt name orig ty tidy_env = do { inst_loc <- getCtLocM orig (Just TypeLevel) diff --git a/compiler/typecheck/TcAnnotations.hs b/compiler/typecheck/TcAnnotations.hs index bdf6646b1a..2c587e213f 100644 --- a/compiler/typecheck/TcAnnotations.hs +++ b/compiler/typecheck/TcAnnotations.hs @@ -16,8 +16,8 @@ import DynFlags import Control.Monad ( when ) import HsSyn -import Annotations import Name +import Annotations import TcRnMonad import SrcLoc import Outputable @@ -26,13 +26,13 @@ import Outputable -- compilation on those platforms shouldn't fail just due to -- annotations #ifndef GHCI -tcAnnotations :: [LAnnDecl Name] -> TcM [Annotation] +tcAnnotations :: [LAnnDecl GhcRn] -> TcM [Annotation] tcAnnotations anns = do dflags <- getDynFlags case gopt Opt_ExternalInterpreter dflags of True -> tcAnnotations' anns False -> warnAnns anns -warnAnns :: [LAnnDecl Name] -> TcM [Annotation] +warnAnns :: [LAnnDecl GhcRn] -> TcM [Annotation] --- No GHCI; emit a warning (not an error) and ignore. cf Trac #4268 warnAnns [] = return [] warnAnns anns@(L loc _ : _) @@ -41,14 +41,14 @@ warnAnns anns@(L loc _ : _) <+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi") ; return [] } #else -tcAnnotations :: [LAnnDecl Name] -> TcM [Annotation] +tcAnnotations :: [LAnnDecl GhcRn] -> TcM [Annotation] tcAnnotations = tcAnnotations' #endif -tcAnnotations' :: [LAnnDecl Name] -> TcM [Annotation] +tcAnnotations' :: [LAnnDecl GhcRn] -> TcM [Annotation] tcAnnotations' anns = mapM tcAnnotation anns -tcAnnotation :: LAnnDecl Name -> TcM Annotation +tcAnnotation :: LAnnDecl GhcRn -> TcM Annotation tcAnnotation (L loc ann@(HsAnnotation _ provenance expr)) = do -- Work out what the full target of this annotation was mod <- getModule @@ -64,11 +64,12 @@ tcAnnotation (L loc ann@(HsAnnotation _ provenance expr)) = do safeHsErr = vcat [ text "Annotations are not compatible with Safe Haskell." , text "See https://ghc.haskell.org/trac/ghc/ticket/10826" ] -annProvenanceToTarget :: Module -> AnnProvenance Name -> AnnTarget Name +annProvenanceToTarget :: Module -> AnnProvenance Name + -> AnnTarget Name annProvenanceToTarget _ (ValueAnnProvenance (L _ name)) = NamedTarget name annProvenanceToTarget _ (TypeAnnProvenance (L _ name)) = NamedTarget name annProvenanceToTarget mod ModuleAnnProvenance = ModuleTarget mod -annCtxt :: (OutputableBndrId id) => AnnDecl id -> SDoc +annCtxt :: (SourceTextX p, OutputableBndrId p) => AnnDecl p -> SDoc annCtxt ann = hang (text "In the annotation:") 2 (ppr ann) diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs index 7bb863d8f9..b72b9b193c 100644 --- a/compiler/typecheck/TcArrows.hs +++ b/compiler/typecheck/TcArrows.hs @@ -6,6 +6,7 @@ Typecheck arrow notation -} {-# LANGUAGE RankNTypes, TupleSections #-} +{-# LANGUAGE TypeFamilies #-} module TcArrows ( tcProc ) where @@ -76,9 +77,9 @@ Note that ************************************************************************ -} -tcProc :: InPat Name -> LHsCmdTop Name -- proc pat -> expr +tcProc :: InPat GhcRn -> LHsCmdTop GhcRn -- proc pat -> expr -> ExpRhoType -- Expected type of whole proc expression - -> TcM (OutPat TcId, LHsCmdTop TcId, TcCoercion) + -> TcM (OutPat GhcTcId, LHsCmdTop GhcTcId, TcCoercion) tcProc pat cmd exp_ty = newArrowScope $ @@ -114,9 +115,9 @@ mkCmdArrTy env t1 t2 = mkAppTys (cmd_arr env) [t1, t2] --------------------------------------- tcCmdTop :: CmdEnv - -> LHsCmdTop Name + -> LHsCmdTop GhcRn -> CmdType - -> TcM (LHsCmdTop TcId) + -> TcM (LHsCmdTop GhcTcId) tcCmdTop env (L loc (HsCmdTop cmd _ _ names)) cmd_ty@(cmd_stk, res_ty) = setSrcSpan loc $ @@ -124,14 +125,14 @@ tcCmdTop env (L loc (HsCmdTop cmd _ _ names)) cmd_ty@(cmd_stk, res_ty) ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names ; return (L loc $ HsCmdTop cmd' cmd_stk res_ty names') } ---------------------------------------- -tcCmd :: CmdEnv -> LHsCmd Name -> CmdType -> TcM (LHsCmd TcId) +tcCmd :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTcId) -- The main recursive function tcCmd env (L loc cmd) res_ty = setSrcSpan loc $ do { cmd' <- tc_cmd env cmd res_ty ; return (L loc cmd') } -tc_cmd :: CmdEnv -> HsCmd Name -> CmdType -> TcM (HsCmd TcId) +tc_cmd :: CmdEnv -> HsCmd GhcRn -> CmdType -> TcM (HsCmd GhcTcId) tc_cmd env (HsCmdPar cmd) res_ty = do { cmd' <- tcCmd env cmd res_ty ; return (HsCmdPar cmd') } @@ -304,7 +305,7 @@ tc_cmd env cmd@(HsCmdArrForm expr f fixity cmd_args) (cmd_stk, res_ty) ; return (HsCmdArrForm expr' f fixity cmd_args') } where - tc_cmd_arg :: LHsCmdTop Name -> TcM (LHsCmdTop TcId, TcType) + tc_cmd_arg :: LHsCmdTop GhcRn -> TcM (LHsCmdTop GhcTcId, TcType) tc_cmd_arg cmd = do { arr_ty <- newFlexiTyVarTy arrowTyConKind ; stk_ty <- newFlexiTyVarTy liftedTypeKind @@ -396,7 +397,7 @@ tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names tcArrDoStmt _ _ stmt _ _ = pprPanic "tcArrDoStmt: unexpected Stmt" (ppr stmt) -tc_arr_rhs :: CmdEnv -> LHsCmd Name -> TcM (LHsCmd TcId, TcType) +tc_arr_rhs :: CmdEnv -> LHsCmd GhcRn -> TcM (LHsCmd GhcTcId, TcType) tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind ; rhs' <- tcCmd env rhs (unitTy, ty) ; return (rhs', ty) } @@ -423,5 +424,5 @@ arrowTyConKind = mkFunTys [liftedTypeKind, liftedTypeKind] liftedTypeKind ************************************************************************ -} -cmdCtxt :: HsCmd Name -> SDoc +cmdCtxt :: HsCmd GhcRn -> SDoc cmdCtxt cmd = text "In the command:" <+> ppr cmd diff --git a/compiler/typecheck/TcBackpack.hs b/compiler/typecheck/TcBackpack.hs index a132f99119..a4b31db93a 100644 --- a/compiler/typecheck/TcBackpack.hs +++ b/compiler/typecheck/TcBackpack.hs @@ -3,6 +3,7 @@ {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} module TcBackpack ( findExtraSigImports', findExtraSigImports, diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index ec8f235fa0..0c8d9108cc 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -7,6 +7,7 @@ {-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds, tcHsBootSigs, tcPolyCheck, @@ -75,7 +76,7 @@ import Control.Monad * * ********************************************************************* -} -addTypecheckedBinds :: TcGblEnv -> [LHsBinds Id] -> TcGblEnv +addTypecheckedBinds :: TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv addTypecheckedBinds tcg_env binds | isHsBootOrSig (tcg_src tcg_env) = tcg_env -- Do not add the code for record-selector bindings @@ -176,7 +177,8 @@ Then we get fm -} -tcTopBinds :: [(RecFlag, LHsBinds Name)] -> [LSig Name] -> TcM (TcGblEnv, TcLclEnv) +tcTopBinds :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] + -> TcM (TcGblEnv, TcLclEnv) -- The TcGblEnv contains the new tcg_binds and tcg_spects -- The TcLclEnv has an extended type envt for the new bindings tcTopBinds binds sigs @@ -227,10 +229,10 @@ tcTopBinds binds sigs -- `Nothing` in the case that the type is fixed by a type signature data CompleteSigType = AcceptAny | Fixed (Maybe ConLike) TyCon -tcCompleteSigs :: [LSig Name] -> TcM [CompleteMatch] +tcCompleteSigs :: [LSig GhcRn] -> TcM [CompleteMatch] tcCompleteSigs sigs = let - doOne :: Sig Name -> TcM (Maybe CompleteMatch) + doOne :: Sig GhcRn -> TcM (Maybe CompleteMatch) doOne c@(CompleteMatchSig _ lns mtc) = fmap Just $ do addErrCtxt (text "In" <+> ppr c) $ @@ -302,7 +304,7 @@ tcCompleteSigs sigs = <+> quotes (ppr tc')) in mapMaybeM (addLocM doOne) sigs -tcRecSelBinds :: HsValBinds Name -> TcM TcGblEnv +tcRecSelBinds :: HsValBinds GhcRn -> TcM TcGblEnv tcRecSelBinds (ValBindsOut binds sigs) = tcExtendGlobalValEnv [sel_id | L _ (IdSig sel_id) <- sigs] $ do { (rec_sel_binds, tcg_env) <- discardWarnings $ @@ -311,7 +313,7 @@ tcRecSelBinds (ValBindsOut binds sigs) ; return tcg_env' } tcRecSelBinds (ValBindsIn {}) = panic "tcRecSelBinds" -tcHsBootSigs :: [(RecFlag, LHsBinds Name)] -> [LSig Name] -> TcM [Id] +tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id] -- A hs-boot file has only one BindGroup, and it only has type -- signatures in it. The renamer checked all this tcHsBootSigs binds sigs @@ -330,8 +332,8 @@ badBootDeclErr :: MsgDoc badBootDeclErr = text "Illegal declarations in an hs-boot file" ------------------------ -tcLocalBinds :: HsLocalBinds Name -> TcM thing - -> TcM (HsLocalBinds TcId, thing) +tcLocalBinds :: HsLocalBinds GhcRn -> TcM thing + -> TcM (HsLocalBinds GhcTcId, thing) tcLocalBinds EmptyLocalBinds thing_inside = do { thing <- thing_inside @@ -390,9 +392,9 @@ untouchable-range idea. -} tcValBinds :: TopLevelFlag - -> [(RecFlag, LHsBinds Name)] -> [LSig Name] + -> [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM thing - -> TcM ([(RecFlag, LHsBinds TcId)], thing) + -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing) tcValBinds top_lvl binds sigs thing_inside = do { let patsyns = getPatSynBinds binds @@ -419,8 +421,8 @@ tcValBinds top_lvl binds sigs thing_inside ------------------------ tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv - -> [(RecFlag, LHsBinds Name)] -> TcM thing - -> TcM ([(RecFlag, LHsBinds TcId)], thing) + -> [(RecFlag, LHsBinds GhcRn)] -> TcM thing + -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing) -- Typecheck a whole lot of value bindings, -- one strongly-connected component at a time -- Here a "strongly connected component" has the strightforward @@ -459,8 +461,8 @@ tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside ------------------------ tc_group :: forall thing. TopLevelFlag -> TcSigFun -> TcPragEnv - -> (RecFlag, LHsBinds Name) -> IsGroupClosed -> TcM thing - -> TcM ([(RecFlag, LHsBinds TcId)], thing) + -> (RecFlag, LHsBinds GhcRn) -> IsGroupClosed -> TcM thing + -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing) -- Typecheck one strongly-connected component of the original program. -- We get a list of groups back, because there may @@ -494,10 +496,10 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside isPatSyn PatSynBind{} = True isPatSyn _ = False - sccs :: [SCC (LHsBind Name)] + sccs :: [SCC (LHsBind GhcRn)] sccs = stronglyConnCompFromEdgedVerticesUniq (mkEdges sig_fn binds) - go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, thing) + go :: [SCC (LHsBind GhcRn)] -> TcM (LHsBinds GhcTcId, thing) go (scc:sccs) = do { (binds1, ids1) <- tc_scc scc ; (binds2, thing) <- tcExtendLetEnv top_lvl closed ids1 (go sccs) @@ -510,7 +512,7 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside tc_sub_group rec_tc binds = tcPolyBinds sig_fn prag_fn Recursive rec_tc closed binds -recursivePatSynErr :: OutputableBndr name => LHsBinds name -> TcM a +recursivePatSynErr :: OutputableBndrId name => LHsBinds name -> TcM a recursivePatSynErr binds = failWithTc $ hang (text "Recursive pattern synonym definition with following bindings:") @@ -522,8 +524,8 @@ recursivePatSynErr binds tc_single :: forall thing. TopLevelFlag -> TcSigFun -> TcPragEnv - -> LHsBind Name -> IsGroupClosed -> TcM thing - -> TcM (LHsBinds TcId, thing) + -> LHsBind GhcRn -> IsGroupClosed -> TcM thing + -> TcM (LHsBinds GhcTcId, thing) tc_single _top_lvl sig_fn _prag_fn (L _ (PatSynBind psb@PSB{ psb_id = L _ name })) _ thing_inside @@ -532,7 +534,7 @@ tc_single _top_lvl sig_fn _prag_fn ; return (aux_binds, thing) } where - tc_pat_syn_decl :: TcM (LHsBinds TcId, TcGblEnv) + tc_pat_syn_decl :: TcM (LHsBinds GhcTcId, TcGblEnv) tc_pat_syn_decl = case sig_fn name of Nothing -> tcInferPatSynDecl psb Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi @@ -549,7 +551,7 @@ tc_single top_lvl sig_fn prag_fn lbind closed thing_inside ------------------------ type BKey = Int -- Just number off the bindings -mkEdges :: TcSigFun -> LHsBinds Name -> [Node BKey (LHsBind Name)] +mkEdges :: TcSigFun -> LHsBinds GhcRn -> [Node BKey (LHsBind GhcRn)] -- See Note [Polymorphic recursion] in HsBinds. mkEdges sig_fn binds = [ DigraphNode bind key [key | n <- nonDetEltsUniqSet (bind_fvs (unLoc bind)), @@ -575,8 +577,8 @@ tcPolyBinds :: TcSigFun -> TcPragEnv -> RecFlag -- Whether it's recursive after breaking -- dependencies based on type signatures -> IsGroupClosed -- Whether the group is closed - -> [LHsBind Name] -- None are PatSynBind - -> TcM (LHsBinds TcId, [TcId]) + -> [LHsBind GhcRn] -- None are PatSynBind + -> TcM (LHsBinds GhcTcId, [TcId]) -- Typechecks a single bunch of values bindings all together, -- and generalises them. The bunch may be only part of a recursive @@ -620,7 +622,7 @@ tcPolyBinds sig_fn prag_fn rec_group rec_tc closed bind_list -- If typechecking the binds fails, then return with each -- signature-less binder given type (forall a.a), to minimise -- subsequent error messages -recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds TcId, [Id]) +recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds GhcTcId, [Id]) recoveryCode binder_names sig_fn = do { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names) ; let poly_ids = map mk_dummy binder_names @@ -646,8 +648,8 @@ tcPolyNoGen -- No generalisation whatsoever :: RecFlag -- Whether it's recursive after breaking -- dependencies based on type signatures -> TcPragEnv -> TcSigFun - -> [LHsBind Name] - -> TcM (LHsBinds TcId, [TcId]) + -> [LHsBind GhcRn] + -> TcM (LHsBinds GhcTcId, [TcId]) tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list = do { (binds', mono_infos) <- tcMonoBinds rec_tc tc_sig_fn @@ -673,8 +675,8 @@ tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list tcPolyCheck :: TcPragEnv -> TcIdSigInfo -- Must be a complete signature - -> LHsBind Name -- Must be a FunBind - -> TcM (LHsBinds TcId, [TcId]) + -> LHsBind GhcRn -- Must be a FunBind + -> TcM (LHsBinds GhcTcId, [TcId]) -- There is just one binding, -- it is a Funbind -- it has a complete type signature, @@ -726,7 +728,8 @@ tcPolyCheck prag_fn tcPolyCheck _prag_fn sig bind = pprPanic "tcPolyCheck" (ppr sig $$ ppr bind) -funBindTicks :: SrcSpan -> TcId -> Module -> [LSig Name] -> [Tickish TcId] +funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn] + -> [Tickish TcId] funBindTicks loc fun_id mod sigs | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ cc_name) <- sigs ] -- this can only be a singleton list, as duplicate pragmas are rejected @@ -767,8 +770,8 @@ tcPolyInfer -- dependencies based on type signatures -> TcPragEnv -> TcSigFun -> Bool -- True <=> apply the monomorphism restriction - -> [LHsBind Name] - -> TcM (LHsBinds TcId, [TcId]) + -> [LHsBind GhcRn] + -> TcM (LHsBinds GhcTcId, [TcId]) tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list = do { (tclvl, wanted, (binds', mono_infos)) <- pushLevelAndCaptureConstraints $ @@ -804,7 +807,7 @@ tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list mkExport :: TcPragEnv -> [TyVar] -> TcThetaType -- Both already zonked -> MonoBindInfo - -> TcM (ABExport Id) + -> TcM (ABExport GhcTc) -- Only called for generalisation plan InferGen, not by CheckGen or NoGen -- -- mkExport generates exports with @@ -1131,7 +1134,7 @@ where F is a non-injective type function. * * ********************************************************************* -} -tcVectDecls :: [LVectDecl Name] -> TcM ([LVectDecl TcId]) +tcVectDecls :: [LVectDecl GhcRn] -> TcM ([LVectDecl GhcTcId]) tcVectDecls decls = do { decls' <- mapM (wrapLocM tcVect) decls ; let ids = [lvectDeclName decl | decl <- decls', not $ lvectInstDecl decl] @@ -1147,7 +1150,7 @@ tcVectDecls decls reportVectDups _ = return () -------------- -tcVect :: VectDecl Name -> TcM (VectDecl TcId) +tcVect :: VectDecl GhcRn -> TcM (VectDecl GhcTcId) -- FIXME: We can't typecheck the expression of a vectorisation declaration against the vectorised -- type of the original definition as this requires internals of the vectoriser not available -- during type checking. Instead, constrain the rhs of a vectorisation declaration to be a single @@ -1242,8 +1245,8 @@ tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking pur -- i.e. the binders are mentioned in their RHSs, and -- we are not rescued by a type signature -> TcSigFun -> LetBndrSpec - -> [LHsBind Name] - -> TcM (LHsBinds TcId, [MonoBindInfo]) + -> [LHsBind GhcRn] + -> TcM (LHsBinds GhcTcId, [MonoBindInfo]) tcMonoBinds is_rec sig_fn no_gen [ L b_loc (FunBind { fun_id = L nm_loc name, fun_matches = matches, bind_fvs = fvs })] @@ -1317,10 +1320,11 @@ tcMonoBinds _ sig_fn no_gen binds -- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't data TcMonoBind -- Half completed; LHS done, RHS not done - = TcFunBind MonoBindInfo SrcSpan (MatchGroup Name (LHsExpr Name)) - | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name (LHsExpr Name)) TcSigmaType + = TcFunBind MonoBindInfo SrcSpan (MatchGroup GhcRn (LHsExpr GhcRn)) + | TcPatBind [MonoBindInfo] (LPat GhcTcId) (GRHSs GhcRn (LHsExpr GhcRn)) + TcSigmaType -tcLhs :: TcSigFun -> LetBndrSpec -> HsBind Name -> TcM TcMonoBind +tcLhs :: TcSigFun -> LetBndrSpec -> HsBind GhcRn -> TcM TcMonoBind -- Only called with plan InferGen (LetBndrSpec = LetLclBndr) -- or NoGen (LetBndrSpec = LetGblBndr) -- CheckGen is used only for functions with a complete type signature, @@ -1407,7 +1411,7 @@ newSigLetBndr no_gen name (TISI { sig_inst_tau = tau }) = newLetBndr no_gen name tau ------------------- -tcRhs :: TcMonoBind -> TcM (HsBind TcId) +tcRhs :: TcMonoBind -> TcM (HsBind GhcTcId) tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id }) loc matches) = tcExtendIdBinderStackForRhs [info] $ @@ -1595,7 +1599,7 @@ data GeneralisationPlan | InferGen -- Implicit generalisation; there is an AbsBinds Bool -- True <=> apply the MR; generalise only unconstrained type vars - | CheckGen (LHsBind Name) TcIdSigInfo + | CheckGen (LHsBind GhcRn) TcIdSigInfo -- One FunBind with a signature -- Explicit generalisation; there is an AbsBindsSig @@ -1608,7 +1612,7 @@ instance Outputable GeneralisationPlan where ppr (CheckGen _ s) = text "CheckGen" <+> ppr s decideGeneralisationPlan - :: DynFlags -> [LHsBind Name] -> IsGroupClosed -> TcSigFun + :: DynFlags -> [LHsBind GhcRn] -> IsGroupClosed -> TcSigFun -> GeneralisationPlan decideGeneralisationPlan dflags lbinds closed sig_fn | has_partial_sigs = InferGen (and partial_sig_mrs) @@ -1659,7 +1663,7 @@ decideGeneralisationPlan dflags lbinds closed sig_fn no_sig n = noCompleteSig (sig_fn n) -isClosedBndrGroup :: Bag (LHsBind Name) -> TcM IsGroupClosed +isClosedBndrGroup :: Bag (LHsBind GhcRn) -> TcM IsGroupClosed isClosedBndrGroup binds = do type_env <- getLclTypeEnv if foldUFM (is_closed_ns type_env) True fv_env @@ -1669,7 +1673,7 @@ isClosedBndrGroup binds = do fv_env :: NameEnv NameSet fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds - bindFvs :: HsBindLR Name idR -> [(Name, NameSet)] + bindFvs :: HsBindLR GhcRn idR -> [(Name, NameSet)] bindFvs (FunBind { fun_id = f, bind_fvs = fvs }) = [(unLoc f, fvs)] bindFvs (PatBind { pat_lhs = pat, bind_fvs = fvs }) @@ -1706,7 +1710,7 @@ isClosedBndrGroup binds = do -- This one is called on LHS, when pat and grhss are both Name -- and on RHS, when pat is TcId and grhss is still Name -patMonoBindsCtxt :: (OutputableBndrId id, Outputable body) - => LPat id -> GRHSs Name body -> SDoc +patMonoBindsCtxt :: (SourceTextX p, OutputableBndrId p, Outputable body) + => LPat p -> GRHSs GhcRn body -> SDoc patMonoBindsCtxt pat grhss = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss) diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs index 3b9e6ac431..4701197846 100644 --- a/compiler/typecheck/TcClassDcl.hs +++ b/compiler/typecheck/TcClassDcl.hs @@ -7,6 +7,7 @@ Typechecking class declarations -} {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} module TcClassDcl ( tcClassSigs, tcClassDecl2, findMethodBind, instantiateMethod, @@ -101,8 +102,8 @@ illegalHsigDefaultMethod n = text "Illegal default method(s) in class definition of" <+> ppr n <+> text "in hsig file" tcClassSigs :: Name -- Name of the class - -> [LSig Name] - -> LHsBinds Name + -> [LSig GhcRn] + -> LHsBinds GhcRn -> TcM [TcMethInfo] -- Exactly one for each method tcClassSigs clas sigs def_methods = do { traceTc "tcClassSigs 1" (ppr clas) @@ -137,10 +138,10 @@ tcClassSigs clas sigs def_methods where vanilla_sigs = [L loc (nm,ty) | L loc (ClassOpSig False nm ty) <- sigs] gen_sigs = [L loc (nm,ty) | L loc (ClassOpSig True nm ty) <- sigs] - dm_bind_names :: [Name] -- These ones have a value binding in the class decl + dm_bind_names :: [Name] -- These ones have a value binding in the class decl dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods] - tc_sig :: NameEnv (SrcSpan, Type) -> ([Located Name], LHsSigType Name) + tc_sig :: NameEnv (SrcSpan, Type) -> ([Located Name], LHsSigType GhcRn) -> TcM [TcMethInfo] tc_sig gen_dm_env (op_names, op_hs_ty) = do { traceTc "ClsSig 1" (ppr op_names) @@ -164,8 +165,8 @@ tcClassSigs clas sigs def_methods ************************************************************************ -} -tcClassDecl2 :: LTyClDecl Name -- The class declaration - -> TcM (LHsBinds Id) +tcClassDecl2 :: LTyClDecl GhcRn -- The class declaration + -> TcM (LHsBinds GhcTcId) tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs, tcdMeths = default_binds})) @@ -197,9 +198,9 @@ tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs, tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d) -tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name +tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds GhcRn -> HsSigFun -> TcPragEnv -> ClassOpItem - -> TcM (LHsBinds TcId) + -> TcM (LHsBinds GhcTcId) -- Generate code for default methods -- This is incompatible with Hugs, which expects a polymorphic -- default method for every class op, regardless of whether or not @@ -295,7 +296,7 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn -- they are all for meth_id --------------- -tcClassMinimalDef :: Name -> [LSig Name] -> [TcMethInfo] -> TcM ClassMinimalDef +tcClassMinimalDef :: Name -> [LSig GhcRn] -> [TcMethInfo] -> TcM ClassMinimalDef tcClassMinimalDef _clas sigs op_info = case findMinimalDef sigs of Nothing -> return defMindef @@ -317,7 +318,7 @@ tcClassMinimalDef _clas sigs op_info defMindef = mkAnd [ noLoc (mkVar name) | (name, _, Nothing) <- op_info ] -instantiateMethod :: Class -> Id -> [TcType] -> TcType +instantiateMethod :: Class -> TcId -> [TcType] -> TcType -- Take a class operation, say -- op :: forall ab. C a => forall c. Ix c => (b,c) -> a -- Instantiate it at [ty1,ty2] @@ -338,22 +339,22 @@ instantiateMethod clas sel_id inst_tys --------------------------- -type HsSigFun = Name -> Maybe (LHsSigType Name) +type HsSigFun = Name -> Maybe (LHsSigType GhcRn) -mkHsSigFun :: [LSig Name] -> HsSigFun +mkHsSigFun :: [LSig GhcRn] -> HsSigFun mkHsSigFun sigs = lookupNameEnv env where env = mkHsSigEnv get_classop_sig sigs - get_classop_sig :: LSig Name -> Maybe ([Located Name], LHsSigType Name) + get_classop_sig :: LSig GhcRn -> Maybe ([Located Name], LHsSigType GhcRn) get_classop_sig (L _ (ClassOpSig _ ns hs_ty)) = Just (ns, hs_ty) get_classop_sig _ = Nothing --------------------------- findMethodBind :: Name -- Selector - -> LHsBinds Name -- A group of bindings + -> LHsBinds GhcRn -- A group of bindings -> TcPragEnv - -> Maybe (LHsBind Name, SrcSpan, [LSig Name]) + -> Maybe (LHsBind GhcRn, SrcSpan, [LSig GhcRn]) -- Returns the binding, the binding -- site of the method binder, and any inline or -- specialisation pragmas @@ -368,10 +369,10 @@ findMethodBind sel_name binds prag_fn f _other = Nothing --------------------------- -findMinimalDef :: [LSig Name] -> Maybe ClassMinimalDef +findMinimalDef :: [LSig GhcRn] -> Maybe ClassMinimalDef findMinimalDef = firstJusts . map toMinimalDef where - toMinimalDef :: LSig Name -> Maybe ClassMinimalDef + toMinimalDef :: LSig GhcRn -> Maybe ClassMinimalDef toMinimalDef (L _ (MinimalSig _ (L _ bf))) = Just (fmap unLoc bf) toMinimalDef _ = Nothing @@ -410,11 +411,11 @@ This makes the error messages right. ************************************************************************ -} -tcMkDeclCtxt :: TyClDecl Name -> SDoc +tcMkDeclCtxt :: TyClDecl GhcRn -> SDoc tcMkDeclCtxt decl = hsep [text "In the", pprTyClDeclFlavour decl, text "declaration for", quotes (ppr (tcdName decl))] -tcAddDeclCtxt :: TyClDecl Name -> TcM a -> TcM a +tcAddDeclCtxt :: TyClDecl GhcRn -> TcM a -> TcM a tcAddDeclCtxt decl thing_inside = addErrCtxt (tcMkDeclCtxt decl) thing_inside @@ -447,7 +448,7 @@ dupGenericInsts tc_inst_infos where ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst) -} -badDmPrag :: Id -> Sig Name -> TcM () +badDmPrag :: TcId -> Sig GhcRn -> TcM () badDmPrag sel_id prag = addErrTc (text "The" <+> hsSigDoc prag <+> ptext (sLit "for default method") <+> quotes (ppr sel_id) diff --git a/compiler/typecheck/TcDefaults.hs b/compiler/typecheck/TcDefaults.hs index e33b8c53ea..8d005a09e6 100644 --- a/compiler/typecheck/TcDefaults.hs +++ b/compiler/typecheck/TcDefaults.hs @@ -4,11 +4,11 @@ \section[TcDefaults]{Typechecking \tr{default} declarations} -} +{-# LANGUAGE TypeFamilies #-} module TcDefaults ( tcDefaults ) where import HsSyn -import Name import Class import TcRnMonad import TcEnv @@ -23,7 +23,7 @@ import Outputable import FastString import qualified GHC.LanguageExtensions as LangExt -tcDefaults :: [LDefaultDecl Name] +tcDefaults :: [LDefaultDecl GhcRn] -> TcM (Maybe [Type]) -- Defaulting types to heave -- into Tc monad for later use -- in Disambig. @@ -66,7 +66,7 @@ tcDefaults decls@(L locn (DefaultDecl _) : _) failWithTc (dupDefaultDeclErr decls) -tc_default_ty :: [Class] -> LHsType Name -> TcM Type +tc_default_ty :: [Class] -> LHsType GhcRn -> TcM Type tc_default_ty deflt_clss hs_ty = do { (ty, _kind) <- solveEqualities $ tcLHsType hs_ty @@ -90,7 +90,7 @@ check_instance ty cls defaultDeclCtxt :: SDoc defaultDeclCtxt = text "When checking the types in a default declaration" -dupDefaultDeclErr :: [Located (DefaultDecl Name)] -> SDoc +dupDefaultDeclErr :: [Located (DefaultDecl GhcRn)] -> SDoc dupDefaultDeclErr (L _ (DefaultDecl _) : dup_things) = hang (text "Multiple default declarations") 2 (vcat (map pp dup_things)) diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs index 5bdfae70ac..946ef69efc 100644 --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -7,6 +7,7 @@ Handles @deriving@ clauses on @data@ declarations. -} {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} module TcDeriv ( tcDeriving, DerivInfo(..), mkDerivInfos ) where @@ -190,12 +191,12 @@ both of them. So we gather defs/uses from deriving just like anything else. data DerivInfo = DerivInfo { di_rep_tc :: TyCon -- ^ The data tycon for normal datatypes, -- or the *representation* tycon for data families - , di_clauses :: [LHsDerivingClause Name] + , di_clauses :: [LHsDerivingClause GhcRn] , di_ctxt :: SDoc -- ^ error context } -- | Extract `deriving` clauses of proper data type (skips data families) -mkDerivInfos :: [LTyClDecl Name] -> TcM [DerivInfo] +mkDerivInfos :: [LTyClDecl GhcRn] -> TcM [DerivInfo] mkDerivInfos decls = concatMapM (mk_deriv . unLoc) decls where @@ -217,8 +218,8 @@ mkDerivInfos decls = concatMapM (mk_deriv . unLoc) decls -} tcDeriving :: [DerivInfo] -- All `deriving` clauses - -> [LDerivDecl Name] -- All stand-alone deriving declarations - -> TcM (TcGblEnv, Bag (InstInfo Name), HsValBinds Name) + -> [LDerivDecl GhcRn] -- All stand-alone deriving declarations + -> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn) tcDeriving deriv_infos deriv_decls = recoverM (do { g <- getGblEnv ; return (g, emptyBag, emptyValBindsOut)}) $ @@ -278,7 +279,7 @@ tcDeriving deriv_infos deriv_decls ; let all_dus = rn_dus `plusDU` usesOnly (NameSet.mkFVs $ catMaybes maybe_fvs) ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) } } where - ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name + ddump_deriving :: Bag (InstInfo GhcRn) -> HsValBinds GhcRn -> Bag FamInst -- ^ Rep type family instances -> SDoc ddump_deriving inst_infos extra_binds repFamInsts @@ -292,8 +293,8 @@ tcDeriving deriv_infos deriv_decls -- Apply the suspended computations given by genInst calls. -- See Note [Staging of tcDeriving] - apply_inst_infos :: [ThetaType -> TcM (InstInfo RdrName)] - -> [DerivSpec ThetaType] -> TcM [InstInfo RdrName] + apply_inst_infos :: [ThetaType -> TcM (InstInfo GhcPs)] + -> [DerivSpec ThetaType] -> TcM [InstInfo GhcPs] apply_inst_infos = zipWithM (\f ds -> f (ds_theta ds)) -- Prints the representable type family instance @@ -304,9 +305,9 @@ pprRepTy fi@(FamInst { fi_tys = lhs }) where rhs = famInstRHS fi renameDeriv :: Bool - -> [InstInfo RdrName] - -> Bag (LHsBind RdrName, LSig RdrName) - -> TcM (Bag (InstInfo Name), HsValBinds Name, DefUses) + -> [InstInfo GhcPs] + -> Bag (LHsBind GhcPs, LSig GhcPs) + -> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses) renameDeriv is_boot inst_infos bagBinds | is_boot -- If we are compiling a hs-boot file, don't generate any derived bindings -- The inst-info bindings will all be empty, but it's easier to @@ -343,7 +344,7 @@ renameDeriv is_boot inst_infos bagBinds dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } } where - rn_inst_info :: InstInfo RdrName -> TcM (InstInfo Name, FreeVars) + rn_inst_info :: InstInfo GhcPs -> TcM (InstInfo GhcRn, FreeVars) rn_inst_info inst_info@(InstInfo { iSpec = inst , iBinds = InstBindings @@ -492,7 +493,7 @@ in derived code. makeDerivSpecs :: Bool -> [DerivInfo] - -> [LDerivDecl Name] + -> [LDerivDecl GhcRn] -> TcM [EarlyDerivSpec] makeDerivSpecs is_boot deriv_infos deriv_decls = do { eqns1 <- concatMapM (recoverM (return []) . deriveDerivInfo) deriv_infos @@ -526,13 +527,13 @@ deriveDerivInfo (DerivInfo { di_rep_tc = rep_tc, di_clauses = clauses _ -> (rep_tc, mkTyVarTys tvs) -- datatype - deriveForClause :: HsDerivingClause Name -> TcM [EarlyDerivSpec] + deriveForClause :: HsDerivingClause GhcRn -> TcM [EarlyDerivSpec] deriveForClause (HsDerivingClause { deriv_clause_strategy = dcs , deriv_clause_tys = L _ preds }) = concatMapM (deriveTyData tvs tc tys (fmap unLoc dcs)) preds ------------------------------------------------------------------ -deriveStandalone :: LDerivDecl Name -> TcM [EarlyDerivSpec] +deriveStandalone :: LDerivDecl GhcRn -> TcM [EarlyDerivSpec] -- Standalone deriving declarations -- e.g. deriving instance Show a => Show (T a) -- Rather like tcLocalInstDecl @@ -596,7 +597,7 @@ warnUselessTypeable deriveTyData :: [TyVar] -> TyCon -> [Type] -- LHS of data or data instance -- Can be a data instance, hence [Type] args -> Maybe DerivStrategy -- The optional deriving strategy - -> LHsSigType Name -- The deriving predicate + -> LHsSigType GhcRn -- The deriving predicate -> TcM [EarlyDerivSpec] -- The deriving clause of a data or newtype declaration -- I.e. not standalone deriving @@ -1522,7 +1523,7 @@ the renamer. What a great hack! -- case of instances for indexed families. -- genInst :: DerivSpec theta - -> TcM (ThetaType -> TcM (InstInfo RdrName), BagDerivStuff, Maybe Name) + -> TcM (ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, Maybe Name) -- We must use continuation-returning style here to get the order in which we -- typecheck family instances and derived instances right. -- See Note [Staging of tcDeriving] @@ -1610,7 +1611,7 @@ doDerivInstErrorChecks2 clas clas_inst mechanism genDerivStuff :: DerivSpecMechanism -> SrcSpan -> Class -> TyCon -> [Type] -> [TyVar] - -> TcM (LHsBinds RdrName, BagDerivStuff) + -> TcM (LHsBinds GhcPs, BagDerivStuff) genDerivStuff mechanism loc clas tycon inst_tys tyvars = case mechanism of -- See Note [Bindings for Generalised Newtype Deriving] @@ -1761,7 +1762,7 @@ derivable class, and C2 isn't a newtype). ************************************************************************ -} -nonUnaryErr :: LHsSigType Name -> SDoc +nonUnaryErr :: LHsSigType GhcRn -> SDoc nonUnaryErr ct = quotes (ppr ct) <+> text "is not a unary constraint, as expected by a deriving clause" @@ -1835,7 +1836,7 @@ derivingHiddenErr tc = hang (text "The data constructors of" <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope")) 2 (text "so you cannot derive an instance for it") -standaloneCtxt :: LHsSigType Name -> SDoc +standaloneCtxt :: LHsSigType GhcRn -> SDoc standaloneCtxt ty = hang (text "In the stand-alone deriving instance for") 2 (quotes (ppr ty)) diff --git a/compiler/typecheck/TcDerivUtils.hs b/compiler/typecheck/TcDerivUtils.hs index 1e10d147e3..3a662d9751 100644 --- a/compiler/typecheck/TcDerivUtils.hs +++ b/compiler/typecheck/TcDerivUtils.hs @@ -7,6 +7,7 @@ Error-checking and other utilities for @deriving@ clauses or declarations. -} {-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE TypeFamilies #-} module TcDerivUtils ( DerivSpec(..), pprDerivSpec, @@ -36,7 +37,6 @@ import Module (getModule) import Name import Outputable import PrelNames -import RdrName import SrcLoc import TcGenDeriv import TcGenFunctor @@ -108,7 +108,7 @@ instance Outputable theta => Outputable (DerivSpec theta) where -- NB: DerivSpecMechanism is purely local to this module data DerivSpecMechanism = DerivSpecStock -- "Standard" classes - (SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds RdrName, BagDerivStuff)) + (SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)) | DerivSpecNewtype -- -XGeneralizedNewtypeDeriving Type -- ^ The newtype rep type @@ -240,14 +240,14 @@ hasStockDeriving :: Class -> Maybe (SrcSpan -> TyCon -> [Type] - -> TcM (LHsBinds RdrName, BagDerivStuff)) + -> TcM (LHsBinds GhcPs, BagDerivStuff)) hasStockDeriving clas = assocMaybe gen_list (getUnique clas) where gen_list :: [(Unique, SrcSpan -> TyCon -> [Type] - -> TcM (LHsBinds RdrName, BagDerivStuff))] + -> TcM (LHsBinds GhcPs, BagDerivStuff))] gen_list = [ (eqClassKey, simpleM gen_Eq_binds) , (ordClassKey, simpleM gen_Ord_binds) , (enumClassKey, simpleM gen_Enum_binds) diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs index b4d873ae91..8d00eaad76 100644 --- a/compiler/typecheck/TcEnv.hs +++ b/compiler/typecheck/TcEnv.hs @@ -566,7 +566,7 @@ tcExtendIdBndrs bndrs thing_inside * * ********************************************************************* -} -tcAddDataFamConPlaceholders :: [LInstDecl Name] -> TcM a -> TcM a +tcAddDataFamConPlaceholders :: [LInstDecl GhcRn] -> TcM a -> TcM a -- See Note [AFamDataCon: not promoting data family constructors] tcAddDataFamConPlaceholders inst_decls thing_inside = tcExtendKindEnvList [ (con, APromotionErr FamDataConPE) @@ -575,30 +575,30 @@ tcAddDataFamConPlaceholders inst_decls thing_inside -- Note [AFamDataCon: not promoting data family constructors] where -- get_cons extracts the *constructor* bindings of the declaration - get_cons :: LInstDecl Name -> [Name] + get_cons :: LInstDecl GhcRn -> [Name] get_cons (L _ (TyFamInstD {})) = [] get_cons (L _ (DataFamInstD { dfid_inst = fid })) = get_fi_cons fid get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } })) = concatMap (get_fi_cons . unLoc) fids - get_fi_cons :: DataFamInstDecl Name -> [Name] + get_fi_cons :: DataFamInstDecl GhcRn -> [Name] get_fi_cons (DataFamInstDecl { dfid_defn = HsDataDefn { dd_cons = cons } }) = map unLoc $ concatMap (getConNames . unLoc) cons -tcAddPatSynPlaceholders :: [PatSynBind Name Name] -> TcM a -> TcM a +tcAddPatSynPlaceholders :: [PatSynBind GhcRn GhcRn] -> TcM a -> TcM a -- See Note [Don't promote pattern synonyms] tcAddPatSynPlaceholders pat_syns thing_inside = tcExtendKindEnvList [ (name, APromotionErr PatSynPE) | PSB{ psb_id = L _ name } <- pat_syns ] thing_inside -getTypeSigNames :: [LSig Name] -> NameSet +getTypeSigNames :: [LSig GhcRn] -> NameSet -- Get the names that have a user type sig getTypeSigNames sigs = foldr get_type_sig emptyNameSet sigs where - get_type_sig :: LSig Name -> NameSet -> NameSet + get_type_sig :: LSig GhcRn -> NameSet -> NameSet get_type_sig sig ns = case sig of L _ (TypeSig names _) -> extendNameSetList ns (map unLoc names) @@ -659,7 +659,7 @@ lookup of A won't fail. ************************************************************************ -} -tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a +tcExtendRules :: [LRuleDecl GhcTc] -> TcM a -> TcM a -- Just pop the new rules into the EPS and envt resp -- All the rules come from an interface file, not source -- Nevertheless, some may be for this module, if we read @@ -833,10 +833,10 @@ data InstBindings a -- Used only to improve error messages } -instance (OutputableBndrId a) => Outputable (InstInfo a) where +instance (SourceTextX a, OutputableBndrId a) => Outputable (InstInfo a) where ppr = pprInstInfoDetails -pprInstInfoDetails :: (OutputableBndrId a) => InstInfo a -> SDoc +pprInstInfoDetails :: (SourceTextX a, OutputableBndrId a) => InstInfo a -> SDoc pprInstInfoDetails info = hang (pprInstanceHdr (iSpec info) <+> text "where") 2 (details (iBinds info)) diff --git a/compiler/typecheck/TcEnv.hs-boot b/compiler/typecheck/TcEnv.hs-boot index 4d291e27ca..8cc90ae5a0 100644 --- a/compiler/typecheck/TcEnv.hs-boot +++ b/compiler/typecheck/TcEnv.hs-boot @@ -1,6 +1,7 @@ {- >module TcEnv where >import TcRnTypes +>import HsExtension ( GhcTcId, IdP ) > >tcExtendIdEnv :: [TcId] -> TcM a -> TcM a -} diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index 5eec0129df..960d181fec 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -8,6 +8,7 @@ {-# LANGUAGE CPP, TupleSections, ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} module TcExpr ( tcPolyExpr, tcMonoExpr, tcMonoExprNC, tcInferSigma, tcInferSigmaNC, tcInferRho, tcInferRhoNC, @@ -87,9 +88,9 @@ import qualified Data.Set as Set -} tcPolyExpr, tcPolyExprNC - :: LHsExpr Name -- Expression to type check - -> TcSigmaType -- Expected type (could be a polytype) - -> TcM (LHsExpr TcId) -- Generalised expr with expected type + :: LHsExpr GhcRn -- Expression to type check + -> TcSigmaType -- Expected type (could be a polytype) + -> TcM (LHsExpr GhcTcId) -- Generalised expr with expected type -- tcPolyExpr is a convenient place (frequent but not too frequent) -- place to add context information. @@ -100,7 +101,8 @@ tcPolyExpr expr res_ty = tc_poly_expr expr (mkCheckExpType res_ty) tcPolyExprNC expr res_ty = tc_poly_expr_nc expr (mkCheckExpType res_ty) -- these versions take an ExpType -tc_poly_expr, tc_poly_expr_nc :: LHsExpr Name -> ExpSigmaType -> TcM (LHsExpr TcId) +tc_poly_expr, tc_poly_expr_nc :: LHsExpr GhcRn -> ExpSigmaType + -> TcM (LHsExpr GhcTcId) tc_poly_expr expr res_ty = addExprErrCtxt expr $ do { traceTc "tcPolyExpr" (ppr res_ty); tc_poly_expr_nc expr res_ty } @@ -117,10 +119,10 @@ tc_poly_expr_nc (L loc expr) res_ty --------------- tcMonoExpr, tcMonoExprNC - :: LHsExpr Name -- Expression to type check + :: LHsExpr GhcRn -- Expression to type check -> ExpRhoType -- Expected type -- Definitely no foralls at the top - -> TcM (LHsExpr TcId) + -> TcM (LHsExpr GhcTcId) tcMonoExpr expr res_ty = addErrCtxt (exprCtxt expr) $ @@ -132,7 +134,7 @@ tcMonoExprNC (L loc expr) res_ty ; return (L loc expr') } --------------- -tcInferSigma, tcInferSigmaNC :: LHsExpr Name -> TcM ( LHsExpr TcId +tcInferSigma, tcInferSigmaNC :: LHsExpr GhcRn -> TcM ( LHsExpr GhcTcId , TcSigmaType ) -- Infer a *sigma*-type. tcInferSigma expr = addErrCtxt (exprCtxt expr) (tcInferSigmaNC expr) @@ -142,7 +144,7 @@ tcInferSigmaNC (L loc expr) do { (expr', sigma) <- tcInferNoInst (tcExpr expr) ; return (L loc expr', sigma) } -tcInferRho, tcInferRhoNC :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType) +tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcRhoType) -- Infer a *rho*-type. The return type is always (shallowly) instantiated. tcInferRho expr = addErrCtxt (exprCtxt expr) (tcInferRhoNC expr) @@ -162,15 +164,16 @@ tcInferRhoNC expr NB: The res_ty is always deeply skolemised. -} -tcExpr :: HsExpr Name -> ExpRhoType -> TcM (HsExpr TcId) +tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId) tcExpr (HsVar (L _ name)) res_ty = tcCheckId name res_ty tcExpr (HsUnboundVar uv) res_ty = tcUnboundId uv res_ty tcExpr e@(HsApp {}) res_ty = tcApp1 e res_ty tcExpr e@(HsAppType {}) res_ty = tcApp1 e res_ty -tcExpr e@(HsLit lit) res_ty = do { let lit_ty = hsLitType lit - ; tcWrapResult e (HsLit lit) lit_ty res_ty } +tcExpr e@(HsLit lit) res_ty + = do { let lit_ty = hsLitType lit + ; tcWrapResult e (HsLit (convertLit lit)) lit_ty res_ty } tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty ; return (HsPar expr') } @@ -1058,8 +1061,8 @@ tcExpr other _ = pprPanic "tcMonoExpr" (ppr other) ************************************************************************ -} -tcArithSeq :: Maybe (SyntaxExpr Name) -> ArithSeqInfo Name -> ExpRhoType - -> TcM (HsExpr TcId) +tcArithSeq :: Maybe (SyntaxExpr GhcRn) -> ArithSeqInfo GhcRn -> ExpRhoType + -> TcM (HsExpr GhcTcId) tcArithSeq witness seq@(From expr) res_ty = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty @@ -1098,8 +1101,8 @@ tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty ArithSeq eft wit' (FromThenTo expr1' expr2' expr3') } ----------------- -arithSeqEltType :: Maybe (SyntaxExpr Name) -> ExpRhoType - -> TcM (HsWrapper, TcType, Maybe (SyntaxExpr Id)) +arithSeqEltType :: Maybe (SyntaxExpr GhcRn) -> ExpRhoType + -> TcM (HsWrapper, TcType, Maybe (SyntaxExpr GhcTc)) arithSeqEltType Nothing res_ty = do { res_ty <- expTypeToType res_ty ; (coi, elt_ty) <- matchExpectedListTy res_ty @@ -1118,13 +1121,13 @@ arithSeqEltType (Just fl) res_ty ************************************************************************ -} -type LHsExprArgIn = Either (LHsExpr Name) (LHsWcType Name) -type LHsExprArgOut = Either (LHsExpr TcId) (LHsWcType Name) +type LHsExprArgIn = Either (LHsExpr GhcRn) (LHsWcType GhcRn) +type LHsExprArgOut = Either (LHsExpr GhcTcId) (LHsWcType GhcRn) -- Left e => argument expression -- Right ty => visible type application -tcApp1 :: HsExpr Name -- either HsApp or HsAppType - -> ExpRhoType -> TcM (HsExpr TcId) +tcApp1 :: HsExpr GhcRn -- either HsApp or HsAppType + -> ExpRhoType -> TcM (HsExpr GhcTcId) tcApp1 e res_ty = do { (wrap, fun, args) <- tcApp Nothing (noLoc e) [] res_ty ; return (mkHsWrap wrap $ unLoc $ foldl mk_hs_app fun args) } @@ -1134,8 +1137,8 @@ tcApp1 e res_ty tcApp :: Maybe SDoc -- like "The function `f' is applied to" -- or leave out to get exactly that message - -> LHsExpr Name -> [LHsExprArgIn] -- Function and args - -> ExpRhoType -> TcM (HsWrapper, LHsExpr TcId, [LHsExprArgOut]) + -> LHsExpr GhcRn -> [LHsExprArgIn] -- Function and args + -> ExpRhoType -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut]) -- (wrap, fun, args). For an ordinary function application, -- these should be assembled as (wrap (fun args)). -- But OpApp is slightly different, so that's why the caller @@ -1144,8 +1147,8 @@ tcApp :: Maybe SDoc -- like "The function `f' is applied to" tcApp m_herald orig_fun orig_args res_ty = go orig_fun orig_args where - go :: LHsExpr Name -> [LHsExprArgIn] - -> TcM (HsWrapper, LHsExpr TcId, [LHsExprArgOut]) + go :: LHsExpr GhcRn -> [LHsExprArgIn] + -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut]) go (L _ (HsPar e)) args = go e args go (L _ (HsApp e1 e2)) args = go e1 (Left e2:args) go (L _ (HsAppType e t)) args = go e (Right t:args) @@ -1188,15 +1191,15 @@ tcApp m_herald orig_fun orig_args res_ty mk_hs_app f (Left a) = mkHsApp f a mk_hs_app f (Right a) = mkHsAppType f a -mk_app_msg :: LHsExpr Name -> SDoc +mk_app_msg :: LHsExpr GhcRn -> SDoc mk_app_msg fun = sep [ text "The function" <+> quotes (ppr fun) , text "is applied to"] -mk_op_msg :: LHsExpr Name -> SDoc +mk_op_msg :: LHsExpr GhcRn -> SDoc mk_op_msg op = text "The operator" <+> quotes (ppr op) <+> text "takes" ---------------- -tcInferFun :: LHsExpr Name -> TcM (LHsExpr TcId, TcSigmaType) +tcInferFun :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType) -- Infer type of a function tcInferFun (L loc (HsVar (L _ name))) = do { (fun, ty) <- setSrcSpan loc (tcInferId name) @@ -1217,7 +1220,7 @@ tcInferFun fun ---------------- -- | Type-check the arguments to a function, possibly including visible type -- applications -tcArgs :: LHsExpr Name -- ^ The function itself (for err msgs only) +tcArgs :: LHsExpr GhcRn -- ^ The function itself (for err msgs only) -> TcSigmaType -- ^ the (uninstantiated) type of the function -> CtOrigin -- ^ the origin for the function's type -> [LHsExprArgIn] -- ^ the args @@ -1277,16 +1280,16 @@ tcArgs fun orig_fun_ty fun_orig orig_args herald text "to a visible type argument" <+> quotes (ppr arg) } ---------------- -tcArg :: LHsExpr Name -- The function (for error messages) - -> LHsExpr Name -- Actual arguments +tcArg :: LHsExpr GhcRn -- The function (for error messages) + -> LHsExpr GhcRn -- Actual arguments -> TcRhoType -- expected arg type -> Int -- # of argument - -> TcM (LHsExpr TcId) -- Resulting argument + -> TcM (LHsExpr GhcTcId) -- Resulting argument tcArg fun arg ty arg_no = addErrCtxt (funAppCtxt fun arg arg_no) $ tcPolyExprNC arg ty ---------------- -tcTupArgs :: [LHsTupArg Name] -> [TcSigmaType] -> TcM [LHsTupArg TcId] +tcTupArgs :: [LHsTupArg GhcRn] -> [TcSigmaType] -> TcM [LHsTupArg GhcTcId] tcTupArgs args tys = ASSERT( equalLength args tys ) mapM go (args `zip` tys) where @@ -1297,11 +1300,11 @@ tcTupArgs args tys --------------------------- -- See TcType.SyntaxOpType also for commentary tcSyntaxOp :: CtOrigin - -> SyntaxExpr Name + -> SyntaxExpr GhcRn -> [SyntaxOpType] -- ^ shape of syntax operator arguments -> ExpRhoType -- ^ overall result type -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments - -> TcM (a, SyntaxExpr TcId) + -> TcM (a, SyntaxExpr GhcTcId) -- ^ Typecheck a syntax operator -- The operator is always a variable at this stage (i.e. renamer output) tcSyntaxOp orig expr arg_tys res_ty @@ -1310,11 +1313,11 @@ tcSyntaxOp orig expr arg_tys res_ty -- | Slightly more general version of 'tcSyntaxOp' that allows the caller -- to specify the shape of the result of the syntax operator tcSyntaxOpGen :: CtOrigin - -> SyntaxExpr Name + -> SyntaxExpr GhcRn -> [SyntaxOpType] -> SyntaxOpType -> ([TcSigmaType] -> TcM a) - -> TcM (a, SyntaxExpr TcId) + -> TcM (a, SyntaxExpr GhcTcId) tcSyntaxOpGen orig (SyntaxExpr { syn_expr = HsVar (L _ op) }) arg_tys res_ty thing_inside = do { (expr, sigma) <- tcInferId op @@ -1495,7 +1498,7 @@ in the other order, the extra signature in f2 is reqd. * * ********************************************************************* -} -tcExprSig :: LHsExpr Name -> TcIdSigInfo -> TcM (LHsExpr TcId, TcType) +tcExprSig :: LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTcId, TcType) tcExprSig expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc }) = setSrcSpan loc $ -- Sets the location for the implication constraint do { (tv_prs, theta, tau) <- tcInstType tcInstSkolTyVars poly_id @@ -1584,14 +1587,14 @@ CLong, as it should. * * ********************************************************************* -} -tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr TcId) +tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTcId) tcCheckId name res_ty = do { (expr, actual_res_ty) <- tcInferId name ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty]) ; addFunResCtxt False (HsVar (noLoc name)) actual_res_ty res_ty $ tcWrapResultO (OccurrenceOf name) expr actual_res_ty res_ty } -tcCheckRecSelId :: AmbiguousFieldOcc Name -> ExpRhoType -> TcM (HsExpr TcId) +tcCheckRecSelId :: AmbiguousFieldOcc GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId) tcCheckRecSelId f@(Unambiguous (L _ lbl) _) res_ty = do { (expr, actual_res_ty) <- tcInferRecSelId f ; addFunResCtxt False (HsRecFld f) actual_res_ty res_ty $ @@ -1603,7 +1606,7 @@ tcCheckRecSelId (Ambiguous lbl _) res_ty ; tcCheckRecSelId (Unambiguous lbl sel_name) res_ty } ------------------------ -tcInferRecSelId :: AmbiguousFieldOcc Name -> TcM (HsExpr TcId, TcRhoType) +tcInferRecSelId :: AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTcId, TcRhoType) tcInferRecSelId (Unambiguous (L _ lbl) sel) = do { (expr', ty) <- tc_infer_id lbl sel ; return (expr', ty) } @@ -1611,7 +1614,7 @@ tcInferRecSelId (Ambiguous lbl _) = ambiguousSelector lbl ------------------------ -tcInferId :: Name -> TcM (HsExpr TcId, TcSigmaType) +tcInferId :: Name -> TcM (HsExpr GhcTcId, TcSigmaType) -- Look up an occurrence of an Id -- Do not instantiate its type tcInferId id_name @@ -1630,7 +1633,7 @@ tcInferId id_name ; traceTc "tcInferId" (ppr id_name <+> dcolon <+> ppr ty) ; return (expr, ty) } -tc_infer_assert :: Name -> TcM (HsExpr TcId, TcSigmaType) +tc_infer_assert :: Name -> TcM (HsExpr GhcTcId, TcSigmaType) -- Deal with an occurrence of 'assert' -- See Note [Adding the implicit parameter to 'assert'] tc_infer_assert assert_name @@ -1640,7 +1643,7 @@ tc_infer_assert assert_name ; return (mkHsWrap wrap (HsVar (noLoc assert_error_id)), id_rho) } -tc_infer_id :: RdrName -> Name -> TcM (HsExpr TcId, TcSigmaType) +tc_infer_id :: RdrName -> Name -> TcM (HsExpr GhcTcId, TcSigmaType) tc_infer_id lbl id_name = do { thing <- tcLookup id_name ; case thing of @@ -1690,7 +1693,7 @@ tc_infer_id lbl id_name | otherwise = return () -tcUnboundId :: UnboundVar -> ExpRhoType -> TcM (HsExpr TcId) +tcUnboundId :: UnboundVar -> ExpRhoType -> TcM (HsExpr GhcTcId) -- Typecheck an occurrence of an unbound Id -- -- Some of these started life as a true expression hole "_". @@ -1765,7 +1768,7 @@ the users that complain. -} tcSeq :: SrcSpan -> Name -> [LHsExprArgIn] - -> ExpRhoType -> TcM (HsWrapper, LHsExpr TcId, [LHsExprArgOut]) + -> ExpRhoType -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut]) -- (seq e1 e2) :: res_ty -- We need a special typing rule because res_ty can be unboxed -- See Note [Typing rule for seq] @@ -1798,7 +1801,7 @@ tcSeq loc fun_name args res_ty ; return (idHsWrapper, fun', [Left arg1', Left arg2']) } tcTagToEnum :: SrcSpan -> Name -> [LHsExprArgIn] -> ExpRhoType - -> TcM (HsWrapper, LHsExpr TcId, [LHsExprArgOut]) + -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut]) -- tagToEnum# :: forall a. Int# -> a -- See Note [tagToEnum#] Urgh! tcTagToEnum loc fun_name args res_ty @@ -2101,9 +2104,9 @@ ambiguousSelector (L _ rdr) -- Disambiguate the fields in a record update. -- See Note [Disambiguating record fields] -disambiguateRecordBinds :: LHsExpr Name -> TcRhoType - -> [LHsRecUpdField Name] -> ExpRhoType - -> TcM [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)] +disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType + -> [LHsRecUpdField GhcRn] -> ExpRhoType + -> TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] disambiguateRecordBinds record_expr record_rho rbnds res_ty -- Are all the fields unambiguous? = case mapM isUnambiguous rbnds of @@ -2121,13 +2124,13 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty ; checkNoErrs $ mapM (pickParent p) rbnds_with_parents } where -- Extract the selector name of a field update if it is unambiguous - isUnambiguous :: LHsRecUpdField Name -> Maybe (LHsRecUpdField Name, Name) + isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn,Name) isUnambiguous x = case unLoc (hsRecFieldLbl (unLoc x)) of Unambiguous _ sel_name -> Just (x, sel_name) Ambiguous{} -> Nothing -- Look up the possible parents and selector GREs for each field - getUpdFieldsParents :: TcM [(LHsRecUpdField Name + getUpdFieldsParents :: TcM [(LHsRecUpdField GhcRn , [(RecSelParent, GlobalRdrElt)])] getUpdFieldsParents = fmap (zip rbnds) $ mapM @@ -2164,8 +2167,8 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty -- r { x = e } :: T -- where T does not have field x. pickParent :: RecSelParent - -> (LHsRecUpdField Name, [(RecSelParent, GlobalRdrElt)]) - -> TcM (LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)) + -> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)]) + -> TcM (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)) pickParent p (upd, xs) = case lookup p xs of -- Phew! The parent is valid for this field. @@ -2185,8 +2188,8 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty -- Given a (field update, selector name) pair, look up the -- selector to give a field update with an unambiguous Id - lookupSelector :: (LHsRecUpdField Name, Name) - -> TcM (LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)) + lookupSelector :: (LHsRecUpdField GhcRn, Name) + -> TcM (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)) lookupSelector (L l upd, n) = do { i <- tcLookupId n ; let L loc af = hsRecFieldLbl upd @@ -2227,7 +2230,7 @@ lookupParents rdr -- A type signature on the argument of an ambiguous record selector or -- the record expression in an update must be "obvious", i.e. the -- outermost constructor ignoring parentheses. -obviousSig :: HsExpr Name -> Maybe (LHsSigWcType Name) +obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn) obviousSig (ExprWithTySig _ ty) = Just ty obviousSig (HsPar p) = obviousSig (unLoc p) obviousSig _ = Nothing @@ -2254,8 +2257,8 @@ This extends OK when the field types are universally quantified. tcRecordBinds :: ConLike -> [TcType] -- Expected type for each field - -> HsRecordBinds Name - -> TcM (HsRecordBinds TcId) + -> HsRecordBinds GhcRn + -> TcM (HsRecordBinds GhcTcId) tcRecordBinds con_like arg_tys (HsRecFields rbinds dd) = do { mb_binds <- mapM do_bind rbinds @@ -2264,8 +2267,8 @@ tcRecordBinds con_like arg_tys (HsRecFields rbinds dd) fields = map flLabel $ conLikeFieldLabels con_like flds_w_tys = zipEqual "tcRecordBinds" fields arg_tys - do_bind :: LHsRecField Name (LHsExpr Name) - -> TcM (Maybe (LHsRecField TcId (LHsExpr TcId))) + do_bind :: LHsRecField GhcRn (LHsExpr GhcRn) + -> TcM (Maybe (LHsRecField GhcTcId (LHsExpr GhcTcId))) do_bind (L l fld@(HsRecField { hsRecFieldLbl = f , hsRecFieldArg = rhs })) @@ -2278,14 +2281,15 @@ tcRecordBinds con_like arg_tys (HsRecFields rbinds dd) tcRecordUpd :: ConLike -> [TcType] -- Expected type for each field - -> [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)] - -> TcM [LHsRecUpdField TcId] + -> [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] + -> TcM [LHsRecUpdField GhcTcId] tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds where flds_w_tys = zipEqual "tcRecordUpd" (map flLabel $ conLikeFieldLabels con_like) arg_tys - do_bind :: LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name) -> TcM (Maybe (LHsRecUpdField TcId)) + do_bind :: LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn) + -> TcM (Maybe (LHsRecUpdField GhcTcId)) do_bind (L l fld@(HsRecField { hsRecFieldLbl = L loc af , hsRecFieldArg = rhs })) = do { let lbl = rdrNameAmbiguousFieldOcc af @@ -2301,8 +2305,9 @@ tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds (selectorFieldOcc (unLoc f'))) , hsRecFieldArg = rhs' }))) } -tcRecordField :: ConLike -> Assoc FieldLabelString Type -> LFieldOcc Name -> LHsExpr Name - -> TcM (Maybe (LFieldOcc Id, LHsExpr Id)) +tcRecordField :: ConLike -> Assoc FieldLabelString Type + -> LFieldOcc GhcRn -> LHsExpr GhcRn + -> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)) tcRecordField con_like flds_w_tys (L loc (FieldOcc lbl sel_name)) rhs | Just field_ty <- assocMaybe flds_w_tys field_lbl = addErrCtxt (fieldCtxt field_lbl) $ @@ -2322,7 +2327,7 @@ tcRecordField con_like flds_w_tys (L loc (FieldOcc lbl sel_name)) rhs field_lbl = occNameFS $ rdrNameOcc (unLoc lbl) -checkMissingFields :: ConLike -> HsRecordBinds Name -> TcM () +checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> TcM () checkMissingFields con_like rbinds | null field_labels -- Not declared as a record; -- But C{} is still valid if no strict fields @@ -2374,10 +2379,10 @@ checkMissingFields con_like rbinds Boring and alphabetical: -} -addExprErrCtxt :: LHsExpr Name -> TcM a -> TcM a +addExprErrCtxt :: LHsExpr GhcRn -> TcM a -> TcM a addExprErrCtxt expr = addErrCtxt (exprCtxt expr) -exprCtxt :: LHsExpr Name -> SDoc +exprCtxt :: LHsExpr GhcRn -> SDoc exprCtxt expr = hang (text "In the expression:") 2 (ppr expr) @@ -2386,7 +2391,7 @@ fieldCtxt field_name = text "In the" <+> quotes (ppr field_name) <+> ptext (sLit "field of a record") addFunResCtxt :: Bool -- There is at least one argument - -> HsExpr Name -> TcType -> ExpRhoType + -> HsExpr GhcRn -> TcType -> ExpRhoType -> TcM a -> TcM a -- When we have a mis-match in the return type of a function -- try to give a helpful message about too many/few arguments @@ -2442,7 +2447,8 @@ badFieldTypes prs 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ]) badFieldsUpd - :: [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)] -- Field names that don't belong to a single datacon + :: [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] + -- Field names that don't belong to a single datacon -> [ConLike] -- Data cons of the type which the first field name belongs to -> SDoc badFieldsUpd rbinds data_cons @@ -2562,7 +2568,7 @@ missingFields con fields -- callCtxt fun args = text "In the call" <+> parens (ppr (foldl mkHsApp fun args)) -noPossibleParents :: [LHsRecUpdField Name] -> SDoc +noPossibleParents :: [LHsRecUpdField GhcRn] -> SDoc noPossibleParents rbinds = hang (text "No type has all these fields:") 2 (pprQuotedList fields) diff --git a/compiler/typecheck/TcExpr.hs-boot b/compiler/typecheck/TcExpr.hs-boot index 78b8bc1df9..bb6b5d181c 100644 --- a/compiler/typecheck/TcExpr.hs-boot +++ b/compiler/typecheck/TcExpr.hs-boot @@ -1,40 +1,41 @@ module TcExpr where +import Name import HsSyn ( HsExpr, LHsExpr, SyntaxExpr ) -import Name ( Name ) import TcType ( TcRhoType, TcSigmaType, SyntaxOpType, ExpType, ExpRhoType ) -import TcRnTypes( TcM, TcId, CtOrigin ) +import TcRnTypes( TcM, CtOrigin ) +import HsExtension ( GhcRn, GhcTcId ) tcPolyExpr :: - LHsExpr Name + LHsExpr GhcRn -> TcSigmaType - -> TcM (LHsExpr TcId) + -> TcM (LHsExpr GhcTcId) tcMonoExpr, tcMonoExprNC :: - LHsExpr Name + LHsExpr GhcRn -> ExpRhoType - -> TcM (LHsExpr TcId) + -> TcM (LHsExpr GhcTcId) tcInferSigma, tcInferSigmaNC :: - LHsExpr Name - -> TcM (LHsExpr TcId, TcSigmaType) + LHsExpr GhcRn + -> TcM (LHsExpr GhcTcId, TcSigmaType) tcInferRho :: - LHsExpr Name - -> TcM (LHsExpr TcId, TcRhoType) + LHsExpr GhcRn + -> TcM (LHsExpr GhcTcId, TcRhoType) tcSyntaxOp :: CtOrigin - -> SyntaxExpr Name + -> SyntaxExpr GhcRn -> [SyntaxOpType] -- ^ shape of syntax operator arguments -> ExpType -- ^ overall result type -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments - -> TcM (a, SyntaxExpr TcId) + -> TcM (a, SyntaxExpr GhcTcId) tcSyntaxOpGen :: CtOrigin - -> SyntaxExpr Name + -> SyntaxExpr GhcRn -> [SyntaxOpType] -> SyntaxOpType -> ([TcSigmaType] -> TcM a) - -> TcM (a, SyntaxExpr TcId) + -> TcM (a, SyntaxExpr GhcTcId) -tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr TcId) +tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTcId) diff --git a/compiler/typecheck/TcForeign.hs b/compiler/typecheck/TcForeign.hs index 12bb71c1ba..9f560311ae 100644 --- a/compiler/typecheck/TcForeign.hs +++ b/compiler/typecheck/TcForeign.hs @@ -13,6 +13,7 @@ module checks to see if a foreign declaration has got a legal type. -} {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} module TcForeign ( tcForeignImports @@ -224,11 +225,13 @@ to the module's usages. ************************************************************************ -} -tcForeignImports :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id], Bag GlobalRdrElt) +tcForeignImports :: [LForeignDecl GhcRn] + -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt) tcForeignImports decls = getHooked tcForeignImportsHook tcForeignImports' >>= ($ decls) -tcForeignImports' :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id], Bag GlobalRdrElt) +tcForeignImports' :: [LForeignDecl GhcRn] + -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt) -- For the (Bag GlobalRdrElt) result, -- see Note [Newtype constructor usage in foreign declarations] tcForeignImports' decls @@ -236,7 +239,8 @@ tcForeignImports' decls filter isForeignImport decls ; return (ids, decls, unionManyBags gres) } -tcFImport :: LForeignDecl Name -> TcM (Id, LForeignDecl Id, Bag GlobalRdrElt) +tcFImport :: LForeignDecl GhcRn + -> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt) tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty , fd_fi = imp_decl })) = setSrcSpan dloc $ addErrCtxt (foreignDeclCtxt fo) $ @@ -362,13 +366,13 @@ checkMissingAmpersand dflags arg_tys res_ty ************************************************************************ -} -tcForeignExports :: [LForeignDecl Name] - -> TcM (LHsBinds TcId, [LForeignDecl TcId], Bag GlobalRdrElt) +tcForeignExports :: [LForeignDecl GhcRn] + -> TcM (LHsBinds GhcTcId, [LForeignDecl GhcTcId], Bag GlobalRdrElt) tcForeignExports decls = getHooked tcForeignExportsHook tcForeignExports' >>= ($ decls) -tcForeignExports' :: [LForeignDecl Name] - -> TcM (LHsBinds TcId, [LForeignDecl TcId], Bag GlobalRdrElt) +tcForeignExports' :: [LForeignDecl GhcRn] + -> TcM (LHsBinds GhcTcId, [LForeignDecl GhcTcId], Bag GlobalRdrElt) -- For the (Bag GlobalRdrElt) result, -- see Note [Newtype constructor usage in foreign declarations] tcForeignExports' decls @@ -378,7 +382,8 @@ tcForeignExports' decls (b, f, gres2) <- setSrcSpan loc (tcFExport fe) return (b `consBag` binds, L loc f : fs, gres1 `unionBags` gres2) -tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id, Bag GlobalRdrElt) +tcFExport :: ForeignDecl GhcRn + -> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt) tcFExport fo@(ForeignExport { fd_name = L loc nm, fd_sig_ty = hs_ty, fd_fe = spec }) = addErrCtxt (foreignDeclCtxt fo) $ do @@ -556,7 +561,7 @@ badCName :: CLabelString -> MsgDoc badCName target = sep [quotes (ppr target) <+> text "is not a valid C identifier"] -foreignDeclCtxt :: ForeignDecl Name -> SDoc +foreignDeclCtxt :: ForeignDecl GhcRn -> SDoc foreignDeclCtxt fo = hang (text "When checking declaration:") 2 (ppr fo) diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs index d46b67c248..7e79c12ed6 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -14,6 +14,7 @@ This is where we do all the grimy bindings' generation. {-# LANGUAGE CPP, ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} module TcGenDeriv ( BagDerivStuff, DerivStuff(..), @@ -93,7 +94,7 @@ data DerivStuff -- Please add this auxiliary stuff | DerivFamInst FamInst -- New type family instances -- New top-level auxiliary bindings - | DerivHsBind (LHsBind RdrName, LSig RdrName) -- Also used for SYB + | DerivHsBind (LHsBind GhcPs, LSig GhcPs) -- Also used for SYB {- @@ -155,7 +156,7 @@ for the instance decl, which it probably wasn't, so the decls produced don't get through the typechecker. -} -gen_Eq_binds :: SrcSpan -> TyCon -> TcM (LHsBinds RdrName, BagDerivStuff) +gen_Eq_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff) gen_Eq_binds loc tycon = do dflags <- getDynFlags return (method_binds dflags, aux_binds) @@ -305,7 +306,7 @@ ordMethRdr op OrdGT -> gt_RDR ------------ -ltResult :: OrdOp -> LHsExpr RdrName +ltResult :: OrdOp -> LHsExpr GhcPs -- Knowing a<b, what is the result for a `op` b? ltResult OrdCompare = ltTag_Expr ltResult OrdLT = true_Expr @@ -314,7 +315,7 @@ ltResult OrdGE = false_Expr ltResult OrdGT = false_Expr ------------ -eqResult :: OrdOp -> LHsExpr RdrName +eqResult :: OrdOp -> LHsExpr GhcPs -- Knowing a=b, what is the result for a `op` b? eqResult OrdCompare = eqTag_Expr eqResult OrdLT = false_Expr @@ -323,7 +324,7 @@ eqResult OrdGE = true_Expr eqResult OrdGT = false_Expr ------------ -gtResult :: OrdOp -> LHsExpr RdrName +gtResult :: OrdOp -> LHsExpr GhcPs -- Knowing a>b, what is the result for a `op` b? gtResult OrdCompare = gtTag_Expr gtResult OrdLT = false_Expr @@ -332,7 +333,7 @@ gtResult OrdGE = true_Expr gtResult OrdGT = true_Expr ------------ -gen_Ord_binds :: SrcSpan -> TyCon -> TcM (LHsBinds RdrName, BagDerivStuff) +gen_Ord_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff) gen_Ord_binds loc tycon = do dflags <- getDynFlags return $ if null tycon_data_cons -- No data-cons => invoke bale-out case @@ -374,12 +375,12 @@ gen_Ord_binds loc tycon = do (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons - mkOrdOp :: DynFlags -> OrdOp -> LHsBind RdrName + mkOrdOp :: DynFlags -> OrdOp -> LHsBind GhcPs -- Returns a binding op a b = ... compares a and b according to op .... mkOrdOp dflags op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat] (mkOrdOpRhs dflags op) - mkOrdOpRhs :: DynFlags -> OrdOp -> LHsExpr RdrName + mkOrdOpRhs :: DynFlags -> OrdOp -> LHsExpr GhcPs mkOrdOpRhs dflags op -- RHS for comparing 'a' and 'b' according to op | nullary_cons `lengthAtMost` 2 -- Two nullary or fewer, so use cases = nlHsCase (nlHsVar a_RDR) $ @@ -397,7 +398,7 @@ gen_Ord_binds loc tycon = do mkOrdOpAlt :: DynFlags -> OrdOp -> DataCon - -> LMatch RdrName (LHsExpr RdrName) + -> LMatch GhcPs (LHsExpr GhcPs) -- Make the alternative (Ki a1 a2 .. av -> mkOrdOpAlt dflags op data_con = mkHsCaseAlt (nlConVarPat data_con_RDR as_needed) @@ -445,7 +446,7 @@ gen_Ord_binds loc tycon = do tag = get_tag data_con tag_lit = noLoc (HsLit (HsIntPrim NoSourceText (toInteger tag))) - mkInnerEqAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName) + mkInnerEqAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs) -- First argument 'a' known to be built with K -- Returns a case alternative Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...) mkInnerEqAlt op data_con @@ -455,14 +456,14 @@ gen_Ord_binds loc tycon = do data_con_RDR = getRdrName data_con bs_needed = take (dataConSourceArity data_con) bs_RDRs - mkTagCmp :: DynFlags -> OrdOp -> LHsExpr RdrName + mkTagCmp :: DynFlags -> OrdOp -> LHsExpr GhcPs -- Both constructors known to be nullary -- genreates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b# mkTagCmp dflags op = untag_Expr dflags tycon[(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $ unliftedOrdOp tycon intPrimTy op ah_RDR bh_RDR -mkCompareFields :: TyCon -> OrdOp -> [Type] -> LHsExpr RdrName +mkCompareFields :: TyCon -> OrdOp -> [Type] -> LHsExpr GhcPs -- Generates nested comparisons for (a1,a2...) against (b1,b2,...) -- where the ai,bi have the given types mkCompareFields tycon op tys @@ -494,7 +495,7 @@ mkCompareFields tycon op tys b_expr = nlHsVar b (lt_op, _, eq_op, _, _) = primOrdOps "Ord" tycon ty -unliftedOrdOp :: TyCon -> Type -> OrdOp -> RdrName -> RdrName -> LHsExpr RdrName +unliftedOrdOp :: TyCon -> Type -> OrdOp -> RdrName -> RdrName -> LHsExpr GhcPs unliftedOrdOp tycon ty op a b = case op of OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr @@ -510,9 +511,10 @@ unliftedOrdOp tycon ty op a b b_expr = nlHsVar b unliftedCompare :: RdrName -> RdrName - -> LHsExpr RdrName -> LHsExpr RdrName -- What to cmpare - -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName -- Three results - -> LHsExpr RdrName + -> LHsExpr GhcPs -> LHsExpr GhcPs -- What to cmpare + -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs + -- Three results + -> LHsExpr GhcPs -- Return (if a < b then lt else if a == b then eq else gt) unliftedCompare lt_op eq_op a_expr b_expr lt eq gt = nlHsIf (ascribeBool $ genPrimOpApp a_expr lt_op b_expr) lt $ @@ -523,7 +525,7 @@ unliftedCompare lt_op eq_op a_expr b_expr lt eq gt where ascribeBool e = nlExprWithTySig e boolTy -nlConWildPat :: DataCon -> LPat RdrName +nlConWildPat :: DataCon -> LPat GhcPs -- The pattern (K {}) nlConWildPat con = noLoc (ConPatIn (noLoc (getRdrName con)) (RecCon (HsRecFields { rec_flds = [] @@ -572,7 +574,7 @@ instance ... Enum (Foo ...) where For @enumFromTo@ and @enumFromThenTo@, we use the default methods. -} -gen_Enum_binds :: SrcSpan -> TyCon -> TcM (LHsBinds RdrName, BagDerivStuff) +gen_Enum_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff) gen_Enum_binds loc tycon = do dflags <- getDynFlags return (method_binds dflags, aux_binds) @@ -608,8 +610,8 @@ gen_Enum_binds loc tycon = do (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration") (nlHsApp (nlHsVar (tag2con_RDR dflags tycon)) (nlHsApps plus_RDR - [ nlHsVarApps intDataCon_RDR [ah_RDR] - , nlHsLit (HsInt (mkIntegralLit (-1 :: Int)))])) + [ nlHsVarApps intDataCon_RDR [ah_RDR] + , nlHsLit (HsInt def (mkIntegralLit (-1 :: Int)))])) to_enum dflags = mk_easy_FunBind loc toEnum_RDR [a_Pat] $ @@ -655,7 +657,7 @@ gen_Enum_binds loc tycon = do ************************************************************************ -} -gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) +gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff) gen_Bounded_binds loc tycon | isEnumerationTyCon tycon = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag) @@ -742,7 +744,7 @@ we follow the scheme given in Figure~19 of the Haskell~1.2 report (p.~147). -} -gen_Ix_binds :: SrcSpan -> TyCon -> TcM (LHsBinds RdrName, BagDerivStuff) +gen_Ix_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff) gen_Ix_binds loc tycon = do dflags <- getDynFlags @@ -942,7 +944,8 @@ These instances are also useful for Read (Either Int Emp), where we want to be able to parse (Left 3) just fine. -} -gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) +gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon + -> (LHsBinds GhcPs, BagDerivStuff) gen_Read_binds get_fixity loc tycon = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag) @@ -1110,7 +1113,8 @@ Example -- the most tightly-binding operator -} -gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) +gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon + -> (LHsBinds GhcPs, BagDerivStuff) gen_Show_binds get_fixity loc tycon = (unitBag shows_prec, emptyBag) @@ -1125,8 +1129,8 @@ gen_Show_binds get_fixity loc tycon ([nlWildPat, con_pat], mk_showString_app op_con_str) | otherwise = ([a_Pat, con_pat], - showParen_Expr (genOpApp a_Expr ge_RDR - (nlHsLit (HsInt (mkIntegralLit con_prec_plus_one)))) + showParen_Expr (genOpApp a_Expr ge_RDR (nlHsLit + (HsInt def (mkIntegralLit con_prec_plus_one)))) (nlHsPar (nested_compose_Expr show_thingies))) where data_con_RDR = getRdrName data_con @@ -1172,7 +1176,7 @@ gen_Show_binds get_fixity loc tycon | (lbl,arg) <- zipEqual "gen_Show_binds" labels show_args ] - show_arg :: RdrName -> Type -> LHsExpr RdrName + show_arg :: RdrName -> Type -> LHsExpr GhcPs show_arg b arg_ty | isUnliftedType arg_ty -- See Note [Deriving and unboxed types] in TcDeriv @@ -1204,16 +1208,16 @@ isSym "" = False isSym (c : _) = startsVarSym c || startsConSym c -- | showString :: String -> ShowS -mk_showString_app :: String -> LHsExpr RdrName +mk_showString_app :: String -> LHsExpr GhcPs mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str)) -- | showsPrec :: Show a => Int -> a -> ShowS -mk_showsPrec_app :: Integer -> LHsExpr RdrName -> LHsExpr RdrName +mk_showsPrec_app :: Integer -> LHsExpr GhcPs -> LHsExpr GhcPs mk_showsPrec_app p x - = nlHsApps showsPrec_RDR [nlHsLit (HsInt (mkIntegralLit p)), x] + = nlHsApps showsPrec_RDR [nlHsLit (HsInt def (mkIntegralLit p)), x] -- | shows :: Show a => a -> ShowS -mk_shows_app :: LHsExpr RdrName -> LHsExpr RdrName +mk_shows_app :: LHsExpr GhcPs -> LHsExpr GhcPs mk_shows_app x = nlHsApp (nlHsVar shows_RDR) x getPrec :: Bool -> (Name -> Fixity) -> Name -> Integer @@ -1273,8 +1277,8 @@ we generate gen_Data_binds :: SrcSpan -> TyCon -- For data families, this is the -- *representation* TyCon - -> TcM (LHsBinds RdrName, -- The method bindings - BagDerivStuff) -- Auxiliary bindings + -> TcM (LHsBinds GhcPs, -- The method bindings + BagDerivStuff) -- Auxiliary bindings gen_Data_binds loc rep_tc = do { dflags <- getDynFlags @@ -1292,7 +1296,7 @@ gen_Data_binds loc rep_tc gen_data :: DynFlags -> RdrName -> [RdrName] -> SrcSpan -> TyCon - -> (LHsBinds RdrName, -- The method bindings + -> (LHsBinds GhcPs, -- The method bindings BagDerivStuff) -- Auxiliary bindings gen_data dflags data_type_name constr_names loc rep_tc = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind] @@ -1507,7 +1511,7 @@ Note that (mkNameG_d "package-name" "ModuleName" "Foo") is equivalent to what makeG_d. -} -gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) +gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff) gen_Lift_binds loc tycon | null data_cons = (unitBag (L loc $ mkFunBind (L loc lift_RDR) [mkMatch (mkPrefixFunRhs (L loc lift_RDR)) @@ -1561,7 +1565,7 @@ gen_Lift_binds loc tycon | otherwise = foldl mk_appE_app conE_Expr lifted_as (a1:a2:_) = lifted_as -mk_appE_app :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName +mk_appE_app :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs mk_appE_app a b = nlHsApps appE_RDR [a, b] {- @@ -1643,7 +1647,7 @@ gen_Newtype_binds :: SrcSpan -- newtype itself) -> [Type] -- instance head parameters (incl. newtype) -> Type -- the representation type - -> TcM (LHsBinds RdrName, BagDerivStuff) + -> TcM (LHsBinds GhcPs, BagDerivStuff) -- See Note [Newtype-deriving instances] gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty = do let ats = classATs cls @@ -1652,7 +1656,7 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty return ( listToBag $ map mk_bind (classMethods cls) , listToBag $ map DerivFamInst atf_insts ) where - mk_bind :: Id -> LHsBind RdrName + mk_bind :: Id -> LHsBind GhcPs mk_bind meth_id = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch (mkPrefixFunRhs (L loc meth_RDR)) @@ -1693,12 +1697,12 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty rep_tvs' = toposortTyVars rep_tvs rep_cvs' = toposortTyVars rep_cvs -nlHsAppType :: LHsExpr RdrName -> Type -> LHsExpr RdrName +nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs nlHsAppType e s = noLoc (e `HsAppType` hs_ty) where hs_ty = mkHsWildCardBndrs $ nlHsParTy (typeToLHsType s) -nlExprWithTySig :: LHsExpr RdrName -> Type -> LHsExpr RdrName +nlExprWithTySig :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs nlExprWithTySig e s = noLoc (e `ExprWithTySig` hs_ty) where hs_ty = mkLHsSigWcType (typeToLHsType s) @@ -1746,7 +1750,7 @@ fiddling around. -} genAuxBindSpec :: DynFlags -> SrcSpan -> AuxBindSpec - -> (LHsBind RdrName, LSig RdrName) + -> (LHsBind GhcPs, LSig GhcPs) genAuxBindSpec dflags loc (DerivCon2Tag tycon) = (mkFunBindSE 0 loc rdr_name eqns, L loc (TypeSig [L loc rdr_name] sig_ty)) @@ -1766,7 +1770,7 @@ genAuxBindSpec dflags loc (DerivCon2Tag tycon) get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr) - mk_eqn :: DataCon -> ([LPat RdrName], LHsExpr RdrName) + mk_eqn :: DataCon -> ([LPat GhcPs], LHsExpr GhcPs) mk_eqn con = ([nlWildConPat con], nlHsLit (HsIntPrim NoSourceText (toInteger ((dataConTag con) - fIRST_TAG)))) @@ -1796,7 +1800,7 @@ genAuxBindSpec dflags loc (DerivMaxTag tycon) type SeparateBagsDerivStuff = -- AuxBinds and SYB bindings - ( Bag (LHsBind RdrName, LSig RdrName) + ( Bag (LHsBind GhcPs, LSig GhcPs) -- Extra family instances (used by Generic and DeriveAnyClass) , Bag (FamInst) ) @@ -1839,8 +1843,8 @@ mkParentType tc -- | Make a function binding. If no equations are given, produce a function -- with the given arity that produces a stock error. mkFunBindSE :: Arity -> SrcSpan -> RdrName - -> [([LPat RdrName], LHsExpr RdrName)] - -> LHsBind RdrName + -> [([LPat GhcPs], LHsExpr GhcPs)] + -> LHsBind GhcPs mkFunBindSE arity loc fun pats_and_exprs = mkRdrFunBindSE arity (L loc fun) matches where @@ -1848,7 +1852,8 @@ mkFunBindSE arity loc fun pats_and_exprs (noLoc emptyLocalBinds) | (p,e) <-pats_and_exprs] -mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName +mkRdrFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] + -> LHsBind GhcPs mkRdrFunBind fun@(L loc _fun_rdr) matches = L loc (mkFunBind fun matches) @@ -1857,10 +1862,10 @@ mkRdrFunBind fun@(L loc _fun_rdr) matches -- for the last argument that it passes to the given function to produce -- the right-hand side. mkRdrFunBindEC :: Arity - -> (LHsExpr RdrName -> LHsExpr RdrName) + -> (LHsExpr GhcPs -> LHsExpr GhcPs) -> Located RdrName - -> [LMatch RdrName (LHsExpr RdrName)] - -> LHsBind RdrName + -> [LMatch GhcPs (LHsExpr GhcPs)] + -> LHsBind GhcPs mkRdrFunBindEC arity catch_all fun@(L loc _fun_rdr) matches = L loc (mkFunBind fun matches') where @@ -1884,7 +1889,7 @@ mkRdrFunBindEC arity catch_all -- a binding with the given arity that produces an error based on the name of -- the type of the last argument. mkRdrFunBindSE :: Arity -> Located RdrName -> - [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName + [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs mkRdrFunBindSE arity fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches') where @@ -1903,9 +1908,9 @@ mkRdrFunBindSE arity box :: String -- The class involved -> TyCon -- The tycon involved - -> LHsExpr RdrName -- The argument + -> LHsExpr GhcPs -- The argument -> Type -- The argument type - -> LHsExpr RdrName -- Boxed version of the arg + -> LHsExpr GhcPs -- Boxed version of the arg -- See Note [Deriving and unboxed types] in TcDeriv box cls_str tycon arg arg_ty = nlHsApp (nlHsVar box_con) arg where @@ -1922,8 +1927,8 @@ primOrdOps str tycon ty = assoc_ty_id str tycon ordOpTbl ty primLitOps :: String -- The class involved -> TyCon -- The tycon involved -> Type -- The type - -> ( LHsExpr RdrName -> LHsExpr RdrName -- Constructs a Q Exp value - , LHsExpr RdrName -> LHsExpr RdrName -- Constructs a boxed value + -> ( LHsExpr GhcPs -> LHsExpr GhcPs -- Constructs a Q Exp value + , LHsExpr GhcPs -> LHsExpr GhcPs -- Constructs a boxed value ) primLitOps str tycon ty = ( assoc_ty_id str tycon litConTbl ty , \v -> nlHsVar boxRDR `nlHsApp` v @@ -1961,7 +1966,7 @@ postfixModTbl ,(doublePrimTy, "##") ] -litConTbl :: [(Type, LHsExpr RdrName -> LHsExpr RdrName)] +litConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)] litConTbl = [(charPrimTy , nlHsApp (nlHsVar charPrimL_RDR)) ,(intPrimTy , nlHsApp (nlHsVar intPrimL_RDR) @@ -1996,12 +2001,12 @@ assoc_ty_id cls_str _ tbl ty ----------------------------------------------------------------------- -and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName +and_Expr :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs and_Expr a b = genOpApp a and_RDR b ----------------------------------------------------------------------- -eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName +eq_Expr :: TyCon -> Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs eq_Expr tycon ty a b | not (isUnliftedType ty) = genOpApp a eq_RDR b | otherwise = genPrimOpApp a prim_eq b @@ -2009,7 +2014,7 @@ eq_Expr tycon ty a b (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty untag_Expr :: DynFlags -> TyCon -> [( RdrName, RdrName)] - -> LHsExpr RdrName -> LHsExpr RdrName + -> LHsExpr GhcPs -> LHsExpr GhcPs untag_Expr _ _ [] expr = expr untag_Expr dflags tycon ((untag_this, put_tag_here) : more) expr = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR dflags tycon) @@ -2017,22 +2022,22 @@ untag_Expr dflags tycon ((untag_this, put_tag_here) : more) expr [mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr dflags tycon more expr)] enum_from_to_Expr - :: LHsExpr RdrName -> LHsExpr RdrName - -> LHsExpr RdrName + :: LHsExpr GhcPs -> LHsExpr GhcPs + -> LHsExpr GhcPs enum_from_then_to_Expr - :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName - -> LHsExpr RdrName + :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs + -> LHsExpr GhcPs enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2 showParen_Expr - :: LHsExpr RdrName -> LHsExpr RdrName - -> LHsExpr RdrName + :: LHsExpr GhcPs -> LHsExpr GhcPs + -> LHsExpr GhcPs showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2 -nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName +nested_compose_Expr :: [LHsExpr GhcPs] -> LHsExpr GhcPs nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty nested_compose_Expr [e] = parenify e @@ -2041,18 +2046,18 @@ nested_compose_Expr (e:es) -- impossible_Expr is used in case RHSs that should never happen. -- We generate these to keep the desugarer from complaining that they *might* happen! -error_Expr :: String -> LHsExpr RdrName +error_Expr :: String -> LHsExpr GhcPs error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string)) -- illegal_Expr is used when signalling error conditions in the RHS of a derived -- method. It is currently only used by Enum.{succ,pred} -illegal_Expr :: String -> String -> String -> LHsExpr RdrName +illegal_Expr :: String -> String -> String -> LHsExpr GhcPs illegal_Expr meth tp msg = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg))) -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you -- to include the value of a_RDR in the error string. -illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName +illegal_toEnum_tag :: String -> RdrName -> LHsExpr GhcPs illegal_toEnum_tag tp maxtag = nlHsApp (nlHsVar error_RDR) (nlHsApp (nlHsApp (nlHsVar append_RDR) @@ -2070,16 +2075,16 @@ illegal_toEnum_tag tp maxtag = (nlHsVar maxtag)) (nlHsLit (mkHsString ")")))))) -parenify :: LHsExpr RdrName -> LHsExpr RdrName +parenify :: LHsExpr GhcPs -> LHsExpr GhcPs parenify e@(L _ (HsVar _)) = e parenify e = mkHsPar e -- genOpApp wraps brackets round the operator application, so that the -- renamer won't subsequently try to re-associate it. -genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName +genOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2) -genPrimOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName +genPrimOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs genPrimOpApp e1 op e2 = nlHsPar (nlHsApp (nlHsVar tagToEnum_RDR) (nlHsOpApp e1 op e2)) a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR @@ -2102,7 +2107,7 @@ bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ] a_Expr, b_Expr, c_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr, - true_Expr :: LHsExpr RdrName + true_Expr :: LHsExpr GhcPs a_Expr = nlHsVar a_RDR b_Expr = nlHsVar b_RDR c_Expr = nlHsVar c_RDR @@ -2113,7 +2118,7 @@ gtTag_Expr = nlHsVar gtTag_RDR false_Expr = nlHsVar false_RDR true_Expr = nlHsVar true_RDR -a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat RdrName +a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat GhcPs a_Pat = nlVarPat a_RDR b_Pat = nlVarPat b_RDR c_Pat = nlVarPat c_RDR diff --git a/compiler/typecheck/TcGenFunctor.hs b/compiler/typecheck/TcGenFunctor.hs index dd39716f3e..5cb608b5f5 100644 --- a/compiler/typecheck/TcGenFunctor.hs +++ b/compiler/typecheck/TcGenFunctor.hs @@ -7,6 +7,7 @@ The deriving code for the Functor, Foldable, and Traversable classes -} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} module TcGenFunctor ( FFoldType(..), functorLikeTraverse, @@ -124,7 +125,7 @@ so it was eta expanded to `\x -> [| f $x |]`. This resulted in too much eta expa It is better to produce too many lambdas than to eta expand, see ticket #7436. -} -gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) +gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff) -- When the argument is phantom, we can use fmap _ = coerce -- See Note [Phantom types with Functor, Foldable, and Traversable] gen_Functor_binds loc tycon @@ -155,7 +156,7 @@ gen_Functor_binds loc tycon fmap_eqns = map fmap_eqn data_cons - ft_fmap :: FFoldType (State [RdrName] (LHsExpr RdrName)) + ft_fmap :: FFoldType (State [RdrName] (LHsExpr GhcPs)) ft_fmap = FT { ft_triv = mkSimpleLam $ \x -> return x -- fmap f = \x -> x , ft_var = return f_Expr @@ -220,14 +221,14 @@ gen_Functor_binds loc tycon -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ... match_for_con :: HsMatchContext RdrName - -> [LPat RdrName] -> DataCon -> [LHsExpr RdrName] - -> State [RdrName] (LMatch RdrName (LHsExpr RdrName)) + -> [LPat GhcPs] -> DataCon -> [LHsExpr GhcPs] + -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs)) match_for_con ctxt = mkSimpleConMatch ctxt $ \con_name xs -> return $ nlHsApps con_name xs -- Con x1 x2 .. -- See Note [Deriving <$] -data Replacer = Immediate {replace :: LHsExpr RdrName} - | Nested {replace :: LHsExpr RdrName} +data Replacer = Immediate {replace :: LHsExpr GhcPs} + | Nested {replace :: LHsExpr GhcPs} {- Note [Deriving <$] ~~~~~~~~~~~~~~~~~~ @@ -428,8 +429,8 @@ foldDataConArgs ft con -- The kind checks have ensured the last type parameter is of kind *. -- Make a HsLam using a fresh variable from a State monad -mkSimpleLam :: (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName)) - -> State [RdrName] (LHsExpr RdrName) +mkSimpleLam :: (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs)) + -> State [RdrName] (LHsExpr GhcPs) -- (mkSimpleLam fn) returns (\x. fn(x)) mkSimpleLam lam = do (n:names) <- get @@ -437,9 +438,9 @@ mkSimpleLam lam = do body <- lam (nlHsVar n) return (mkHsLam [nlVarPat n] body) -mkSimpleLam2 :: (LHsExpr RdrName -> LHsExpr RdrName - -> State [RdrName] (LHsExpr RdrName)) - -> State [RdrName] (LHsExpr RdrName) +mkSimpleLam2 :: (LHsExpr GhcPs -> LHsExpr GhcPs + -> State [RdrName] (LHsExpr GhcPs)) + -> State [RdrName] (LHsExpr GhcPs) mkSimpleLam2 lam = do (n1:n2:names) <- get put names @@ -454,11 +455,11 @@ mkSimpleLam2 lam = do -- and its arguments, applying an expression (from @insides@) to each of the -- respective arguments of @con@. mkSimpleConMatch :: Monad m => HsMatchContext RdrName - -> (RdrName -> [LHsExpr RdrName] -> m (LHsExpr RdrName)) - -> [LPat RdrName] + -> (RdrName -> [LHsExpr GhcPs] -> m (LHsExpr GhcPs)) + -> [LPat GhcPs] -> DataCon - -> [LHsExpr RdrName] - -> m (LMatch RdrName (LHsExpr RdrName)) + -> [LHsExpr GhcPs] + -> m (LMatch GhcPs (LHsExpr GhcPs)) mkSimpleConMatch ctxt fold extra_pats con insides = do let con_name = getRdrName con let vars_needed = takeList insides as_RDRs @@ -490,12 +491,12 @@ mkSimpleConMatch ctxt fold extra_pats con insides = do -- See Note [Generated code for DeriveFoldable and DeriveTraversable] mkSimpleConMatch2 :: Monad m => HsMatchContext RdrName - -> (LHsExpr RdrName -> [LHsExpr RdrName] - -> m (LHsExpr RdrName)) - -> [LPat RdrName] + -> (LHsExpr GhcPs -> [LHsExpr GhcPs] + -> m (LHsExpr GhcPs)) + -> [LPat GhcPs] -> DataCon - -> [Maybe (LHsExpr RdrName)] - -> m (LMatch RdrName (LHsExpr RdrName)) + -> [Maybe (LHsExpr GhcPs)] + -> m (LMatch GhcPs (LHsExpr GhcPs)) mkSimpleConMatch2 ctxt fold extra_pats con insides = do let con_name = getRdrName con vars_needed = takeList insides as_RDRs @@ -523,9 +524,9 @@ mkSimpleConMatch2 ctxt fold extra_pats con insides = do (noLoc emptyLocalBinds) -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]" -mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [a] - -> m (LMatch RdrName (LHsExpr RdrName))) - -> TyCon -> [a] -> LHsExpr RdrName -> m (LHsExpr RdrName) +mkSimpleTupleCase :: Monad m => ([LPat GhcPs] -> DataCon -> [a] + -> m (LMatch GhcPs (LHsExpr GhcPs))) + -> TyCon -> [a] -> LHsExpr GhcPs -> m (LHsExpr GhcPs) mkSimpleTupleCase match_for_con tc insides x = do { let data_con = tyConSingleDataCon tc ; match <- match_for_con [] data_con insides @@ -638,7 +639,7 @@ could surprise users if they switch to other types, but Ryan Scott seems to think it's okay to do it for now. -} -gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) +gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff) -- When the parameter is phantom, we can use foldMap _ _ = mempty -- See Note [Phantom types with Functor, Foldable, and Traversable] gen_Foldable_binds loc tycon @@ -708,7 +709,7 @@ gen_Foldable_binds loc tycon -- Yields 'Just' an expression if we're folding over a type that mentions -- the last type parameter of the datatype. Otherwise, yields 'Nothing'. -- See Note [FFoldType and functorLikeTraverse] - ft_foldr :: FFoldType (State [RdrName] (Maybe (LHsExpr RdrName))) + ft_foldr :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs))) ft_foldr = FT { ft_triv = return Nothing -- foldr f = \x z -> z @@ -730,19 +731,19 @@ gen_Foldable_binds loc tycon , ft_fun = panic "function in ft_foldr" , ft_bad_app = panic "in other argument in ft_foldr" } - match_foldr :: LHsExpr RdrName - -> [LPat RdrName] + match_foldr :: LHsExpr GhcPs + -> [LPat GhcPs] -> DataCon - -> [Maybe (LHsExpr RdrName)] - -> State [RdrName] (LMatch RdrName (LHsExpr RdrName)) + -> [Maybe (LHsExpr GhcPs)] + -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs)) match_foldr z = mkSimpleConMatch2 LambdaExpr $ \_ xs -> return (mkFoldr xs) where -- g1 v1 (g2 v2 (.. z)) - mkFoldr :: [LHsExpr RdrName] -> LHsExpr RdrName + mkFoldr :: [LHsExpr GhcPs] -> LHsExpr GhcPs mkFoldr = foldr nlHsApp z -- See Note [FFoldType and functorLikeTraverse] - ft_foldMap :: FFoldType (State [RdrName] (Maybe (LHsExpr RdrName))) + ft_foldMap :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs))) ft_foldMap = FT { ft_triv = return Nothing -- foldMap f = \x -> mempty @@ -760,14 +761,14 @@ gen_Foldable_binds loc tycon , ft_fun = panic "function in ft_foldMap" , ft_bad_app = panic "in other argument in ft_foldMap" } - match_foldMap :: [LPat RdrName] + match_foldMap :: [LPat GhcPs] -> DataCon - -> [Maybe (LHsExpr RdrName)] - -> State [RdrName] (LMatch RdrName (LHsExpr RdrName)) + -> [Maybe (LHsExpr GhcPs)] + -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs)) match_foldMap = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkFoldMap xs) where -- mappend v1 (mappend v2 ..) - mkFoldMap :: [LHsExpr RdrName] -> LHsExpr RdrName + mkFoldMap :: [LHsExpr GhcPs] -> LHsExpr GhcPs mkFoldMap [] = mempty_Expr mkFoldMap xs = foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs @@ -776,7 +777,7 @@ gen_Foldable_binds loc tycon -- that may or may not be null. Yields IsNull if it's certainly -- null, and yields NotNull if it's certainly not null. -- See Note [Deriving null] - ft_null :: FFoldType (State [RdrName] (NullM (LHsExpr RdrName))) + ft_null :: FFoldType (State [RdrName] (NullM (LHsExpr GhcPs))) ft_null = FT { ft_triv = return IsNull -- null = \_ -> True @@ -808,14 +809,14 @@ gen_Foldable_binds loc tycon , ft_fun = panic "function in ft_null" , ft_bad_app = panic "in other argument in ft_null" } - match_null :: [LPat RdrName] + match_null :: [LPat GhcPs] -> DataCon - -> [Maybe (LHsExpr RdrName)] - -> State [RdrName] (LMatch RdrName (LHsExpr RdrName)) + -> [Maybe (LHsExpr GhcPs)] + -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs)) match_null = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkNull xs) where -- v1 && v2 && .. - mkNull :: [LHsExpr RdrName] -> LHsExpr RdrName + mkNull :: [LHsExpr GhcPs] -> LHsExpr GhcPs mkNull [] = true_Expr mkNull xs = foldr1 (\x y -> nlHsApps and_RDR [x,y]) xs @@ -864,7 +865,7 @@ removes all such types from consideration. See Note [Generated code for DeriveFoldable and DeriveTraversable]. -} -gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) +gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff) -- When the argument is phantom, we can use traverse = pure . coerce -- See Note [Phantom types with Functor, Foldable, and Traversable] gen_Traversable_binds loc tycon @@ -898,7 +899,7 @@ gen_Traversable_binds loc tycon -- Yields 'Just' an expression if we're folding over a type that mentions -- the last type parameter of the datatype. Otherwise, yields 'Nothing'. -- See Note [FFoldType and functorLikeTraverse] - ft_trav :: FFoldType (State [RdrName] (Maybe (LHsExpr RdrName))) + ft_trav :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs))) ft_trav = FT { ft_triv = return Nothing -- traverse f = pure x @@ -919,15 +920,15 @@ gen_Traversable_binds loc tycon -- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1) -- (g2 a2) <*> ... - match_for_con :: [LPat RdrName] + match_for_con :: [LPat GhcPs] -> DataCon - -> [Maybe (LHsExpr RdrName)] - -> State [RdrName] (LMatch RdrName (LHsExpr RdrName)) + -> [Maybe (LHsExpr GhcPs)] + -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs)) match_for_con = mkSimpleConMatch2 CaseAlt $ \con xs -> return (mkApCon con xs) where -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> .. - mkApCon :: LHsExpr RdrName -> [LHsExpr RdrName] -> LHsExpr RdrName + mkApCon :: LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs mkApCon con [] = nlHsApps pure_RDR [con] mkApCon con [x] = nlHsApps fmap_RDR [con,x] mkApCon con (x1:x2:xs) = @@ -938,7 +939,7 @@ gen_Traversable_binds loc tycon f_Expr, z_Expr, fmap_Expr, replace_Expr, mempty_Expr, foldMap_Expr, traverse_Expr, coerce_Expr, pure_Expr, true_Expr, false_Expr, - all_Expr, null_Expr :: LHsExpr RdrName + all_Expr, null_Expr :: LHsExpr GhcPs f_Expr = nlHsVar f_RDR z_Expr = nlHsVar z_RDR fmap_Expr = nlHsVar fmap_RDR @@ -961,11 +962,11 @@ as_RDRs, bs_RDRs :: [RdrName] as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ] bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ] -as_Vars, bs_Vars :: [LHsExpr RdrName] +as_Vars, bs_Vars :: [LHsExpr GhcPs] as_Vars = map nlHsVar as_RDRs bs_Vars = map nlHsVar bs_RDRs -f_Pat, z_Pat :: LPat RdrName +f_Pat, z_Pat :: LPat GhcPs f_Pat = nlVarPat f_RDR z_Pat = nlVarPat z_RDR diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs index fc0209d805..a187a268fc 100644 --- a/compiler/typecheck/TcGenGenerics.hs +++ b/compiler/typecheck/TcGenGenerics.hs @@ -8,6 +8,7 @@ The deriving code for the Generic class {-# LANGUAGE CPP, ScopedTypeVariables, TupleSections #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} module TcGenGenerics (canDoGenerics, canDoGenerics1, GenericKind(..), @@ -65,7 +66,7 @@ For the generic representation we need to generate: -} gen_Generic_binds :: GenericKind -> TyCon -> [Type] - -> TcM (LHsBinds RdrName, FamInst) + -> TcM (LHsBinds GhcPs, FamInst) gen_Generic_binds gk tc inst_tys = do repTyInsts <- tc_mkRepFamInsts gk tc inst_tys return (mkBindsRep gk tc, repTyInsts) @@ -296,7 +297,7 @@ canDoGenerics1 rep_tc = -} type US = Int -- Local unique supply, just a plain Int -type Alt = (LPat RdrName, LHsExpr RdrName) +type Alt = (LPat GhcPs, LHsExpr GhcPs) -- GenericKind serves to mark if a datatype derives Generic (Gen0) or -- Generic1 (Gen1). @@ -320,7 +321,7 @@ gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d -- Bindings for the Generic instance -mkBindsRep :: GenericKind -> TyCon -> LHsBinds RdrName +mkBindsRep :: GenericKind -> TyCon -> LHsBinds GhcPs mkBindsRep gk tycon = unitBag (mkRdrFunBind (L loc from01_RDR) [from_eqn]) `unionBags` @@ -752,7 +753,7 @@ mk1Sum gk_ us i n datacon = (from_alt, to_alt) -- Generates the L1/R1 sum pattern -genLR_P :: Int -> Int -> LPat RdrName -> LPat RdrName +genLR_P :: Int -> Int -> LPat GhcPs -> LPat GhcPs genLR_P i n p | n == 0 = error "impossible" | n == 1 = p @@ -761,7 +762,7 @@ genLR_P i n p where m = div n 2 -- Generates the L1/R1 sum expression -genLR_E :: Int -> Int -> LHsExpr RdrName -> LHsExpr RdrName +genLR_E :: Int -> Int -> LHsExpr GhcPs -> LHsExpr GhcPs genLR_E i n e | n == 0 = error "impossible" | n == 1 = e @@ -778,8 +779,9 @@ genLR_E i n e -- Build a product expression mkProd_E :: GenericKind_DC -- Generic or Generic1? -> US -- Base for unique names - -> [(RdrName, Type)] -- List of variables matched on the lhs and their types - -> LHsExpr RdrName -- Resulting product expression + -> [(RdrName, Type)] + -- List of variables matched on the lhs and their types + -> LHsExpr GhcPs -- Resulting product expression mkProd_E _ _ [] = mkM1_E (nlHsVar u1DataCon_RDR) mkProd_E gk_ _ varTys = mkM1_E (foldBal prod appVars) -- These M1s are meta-information for the constructor @@ -787,7 +789,7 @@ mkProd_E gk_ _ varTys = mkM1_E (foldBal prod appVars) appVars = map (wrapArg_E gk_) varTys prod a b = prodDataCon_RDR `nlHsApps` [a,b] -wrapArg_E :: GenericKind_DC -> (RdrName, Type) -> LHsExpr RdrName +wrapArg_E :: GenericKind_DC -> (RdrName, Type) -> LHsExpr GhcPs wrapArg_E Gen0_DC (var, ty) = mkM1_E $ boxRepRDR ty `nlHsVarApps` [var] -- This M1 is meta-information for the selector @@ -824,7 +826,7 @@ mkProd_P :: GenericKind -- Gen0 or Gen1 -> US -- Base for unique names -> [(RdrName, Type)] -- List of variables to match, -- along with their types - -> LPat RdrName -- Resulting product pattern + -> LPat GhcPs -- Resulting product pattern mkProd_P _ _ [] = mkM1_P (nlNullaryConPat u1DataCon_RDR) mkProd_P gk _ varTys = mkM1_P (foldBal prod appVars) -- These M1s are meta-information for the constructor @@ -832,7 +834,7 @@ mkProd_P gk _ varTys = mkM1_P (foldBal prod appVars) appVars = unzipWith (wrapArg_P gk) varTys prod a b = nlParPat $ prodDataCon_RDR `nlConPat` [a,b] -wrapArg_P :: GenericKind -> RdrName -> Type -> LPat RdrName +wrapArg_P :: GenericKind -> RdrName -> Type -> LPat GhcPs wrapArg_P Gen0 v ty = mkM1_P (nlParPat $ boxRepRDR ty `nlConVarPat` [v]) -- This M1 is meta-information for the selector wrapArg_P Gen1 v _ = nlParPat $ m1DataCon_RDR `nlConVarPat` [v] @@ -843,19 +845,19 @@ mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u)) x_RDR :: RdrName x_RDR = mkVarUnqual (fsLit "x") -x_Expr :: LHsExpr RdrName +x_Expr :: LHsExpr GhcPs x_Expr = nlHsVar x_RDR -x_Pat :: LPat RdrName +x_Pat :: LPat GhcPs x_Pat = nlVarPat x_RDR -mkM1_E :: LHsExpr RdrName -> LHsExpr RdrName +mkM1_E :: LHsExpr GhcPs -> LHsExpr GhcPs mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e -mkM1_P :: LPat RdrName -> LPat RdrName +mkM1_P :: LPat GhcPs -> LPat GhcPs mkM1_P p = nlParPat $ m1DataCon_RDR `nlConPat` [p] -nlHsCompose :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName +nlHsCompose :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs nlHsCompose x y = compose_RDR `nlHsApps` [x, y] -- | Variant of foldr1 for producing balanced lists diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index b75d59be67..413751c440 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -10,6 +10,7 @@ checker. -} {-# LANGUAGE CPP, TupleSections #-} +{-# LANGUAGE CPP, TypeFamilies #-} module TcHsSyn ( -- * Extracting types from HsSyn @@ -81,10 +82,10 @@ import Control.Arrow ( second ) -} -hsLPatType :: OutPat Id -> Type +hsLPatType :: OutPat GhcTc -> Type hsLPatType (L _ pat) = hsPatType pat -hsPatType :: Pat Id -> Type +hsPatType :: Pat GhcTc -> Type hsPatType (ParPat pat) = hsLPatType pat hsPatType (WildPat ty) = ty hsPatType (VarPat (L _ var)) = idType var @@ -106,26 +107,26 @@ hsPatType (NPlusKPat _ _ _ _ _ ty) = ty hsPatType (CoPat _ _ ty) = ty hsPatType p = pprPanic "hsPatType" (ppr p) -hsLitType :: HsLit -> TcType +hsLitType :: HsLit p -> TcType hsLitType (HsChar _ _) = charTy hsLitType (HsCharPrim _ _) = charPrimTy hsLitType (HsString _ _) = stringTy hsLitType (HsStringPrim _ _) = addrPrimTy -hsLitType (HsInt _) = intTy +hsLitType (HsInt _ _) = intTy hsLitType (HsIntPrim _ _) = intPrimTy hsLitType (HsWordPrim _ _) = wordPrimTy hsLitType (HsInt64Prim _ _) = int64PrimTy hsLitType (HsWord64Prim _ _) = word64PrimTy hsLitType (HsInteger _ _ ty) = ty -hsLitType (HsRat _ ty) = ty -hsLitType (HsFloatPrim _) = floatPrimTy -hsLitType (HsDoublePrim _) = doublePrimTy +hsLitType (HsRat _ _ ty) = ty +hsLitType (HsFloatPrim _ _) = floatPrimTy +hsLitType (HsDoublePrim _ _) = doublePrimTy -- Overloaded literals. Here mainly because it uses isIntTy etc -shortCutLit :: DynFlags -> OverLitVal -> TcType -> Maybe (HsExpr TcId) +shortCutLit :: DynFlags -> OverLitVal -> TcType -> Maybe (HsExpr GhcTcId) shortCutLit dflags (HsIntegral int@(IL src neg i)) ty - | isIntTy ty && inIntRange dflags i = Just (HsLit (HsInt int)) + | isIntTy ty && inIntRange dflags i = Just (HsLit (HsInt def int)) | isWordTy ty && inWordRange dflags i = Just (mkLit wordDataCon (HsWordPrim src i)) | isIntegerTy ty = Just (HsLit (HsInteger src i ty)) | otherwise = shortCutLit dflags (HsFractional (integralFractionalLit neg i)) ty @@ -136,15 +137,15 @@ shortCutLit dflags (HsIntegral int@(IL src neg i)) ty -- literals, compiled without -O shortCutLit _ (HsFractional f) ty - | isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim f)) - | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim f)) + | isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim def f)) + | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim def f)) | otherwise = Nothing shortCutLit _ (HsIsString src s) ty | isStringTy ty = Just (HsLit (HsString src s)) | otherwise = Nothing -mkLit :: DataCon -> HsLit -> HsExpr Id +mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc mkLit con lit = HsApp (nlHsDataCon con) (nlHsLit lit) ------------------------------ @@ -304,7 +305,7 @@ zonkIdBndrs env ids = mapM (zonkIdBndr env) ids zonkTopBndrs :: [TcId] -> TcM [Id] zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids -zonkFieldOcc :: ZonkEnv -> FieldOcc TcId -> TcM (FieldOcc Id) +zonkFieldOcc :: ZonkEnv -> FieldOcc GhcTcId -> TcM (FieldOcc GhcTc) zonkFieldOcc env (FieldOcc lbl sel) = fmap (FieldOcc lbl) $ zonkIdBndr env sel zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var]) @@ -357,22 +358,23 @@ zonkTyVarBinderX env (TvBndr tv vis) = do { (env', tv') <- zonkTyBndrX env tv ; return (env', TvBndr tv' vis) } -zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id) +zonkTopExpr :: HsExpr GhcTcId -> TcM (HsExpr GhcTc) zonkTopExpr e = zonkExpr emptyZonkEnv e -zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id) +zonkTopLExpr :: LHsExpr GhcTcId -> TcM (LHsExpr GhcTc) zonkTopLExpr e = zonkLExpr emptyZonkEnv e zonkTopDecls :: Bag EvBind - -> LHsBinds TcId - -> [LRuleDecl TcId] -> [LVectDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId] + -> LHsBinds GhcTcId + -> [LRuleDecl GhcTcId] -> [LVectDecl GhcTcId] -> [LTcSpecPrag] + -> [LForeignDecl GhcTcId] -> TcM (TypeEnv, Bag EvBind, - LHsBinds Id, - [LForeignDecl Id], + LHsBinds GhcTc, + [LForeignDecl GhcTc], [LTcSpecPrag], - [LRuleDecl Id], - [LVectDecl Id]) + [LRuleDecl GhcTc], + [LVectDecl GhcTc]) zonkTopDecls ev_binds binds rules vects imp_specs fords = do { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds ; (env2, binds') <- zonkRecMonoBinds env1 binds @@ -384,7 +386,8 @@ zonkTopDecls ev_binds binds rules vects imp_specs fords ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules', vects') } --------------------------------------------- -zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id) +zonkLocalBinds :: ZonkEnv -> HsLocalBinds GhcTcId + -> TcM (ZonkEnv, HsLocalBinds GhcTc) zonkLocalBinds env EmptyLocalBinds = return (env, EmptyLocalBinds) @@ -415,7 +418,7 @@ zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds)) = do return (IPBind n' e') --------------------------------------------- -zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id) +zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (ZonkEnv, LHsBinds GhcTc) zonkRecMonoBinds env binds = fixM (\ ~(_, new_binds) -> do { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders new_binds) @@ -423,13 +426,13 @@ zonkRecMonoBinds env binds ; return (env1, binds') }) --------------------------------------------- -zonkMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (LHsBinds Id) +zonkMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (LHsBinds GhcTc) zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds -zonk_lbind :: ZonkEnv -> LHsBind TcId -> TcM (LHsBind Id) +zonk_lbind :: ZonkEnv -> LHsBind GhcTcId -> TcM (LHsBind GhcTc) zonk_lbind env = wrapLocM (zonk_bind env) -zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id) +zonk_bind :: ZonkEnv -> HsBind GhcTcId -> TcM (HsBind GhcTc) zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty}) = do { (_env, new_pat) <- zonkPat env pat -- Env already extended ; new_grhss <- zonkGRHSs env zonkLExpr grhss @@ -535,7 +538,8 @@ zonkPatSynDetails :: ZonkEnv -> TcM (HsPatSynDetails (Located Id)) zonkPatSynDetails env = traverse (wrapLocM $ zonkIdBndr env) -zonkPatSynDir :: ZonkEnv -> HsPatSynDir TcId -> TcM (ZonkEnv, HsPatSynDir Id) +zonkPatSynDir :: ZonkEnv -> HsPatSynDir GhcTcId + -> TcM (ZonkEnv, HsPatSynDir GhcTc) zonkPatSynDir env Unidirectional = return (env, Unidirectional) zonkPatSynDir env ImplicitBidirectional = return (env, ImplicitBidirectional) zonkPatSynDir env (ExplicitBidirectional mg) = do @@ -564,8 +568,9 @@ zonkLTcSpecPrags env ps -} zonkMatchGroup :: ZonkEnv - -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) - -> MatchGroup TcId (Located (body TcId)) -> TcM (MatchGroup Id (Located (body Id))) + -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) + -> MatchGroup GhcTcId (Located (body GhcTcId)) + -> TcM (MatchGroup GhcTc (Located (body GhcTc))) zonkMatchGroup env zBody (MG { mg_alts = L l ms, mg_arg_tys = arg_tys , mg_res_ty = res_ty, mg_origin = origin }) = do { ms' <- mapM (zonkMatch env zBody) ms @@ -575,8 +580,9 @@ zonkMatchGroup env zBody (MG { mg_alts = L l ms, mg_arg_tys = arg_tys , mg_res_ty = res_ty', mg_origin = origin }) } zonkMatch :: ZonkEnv - -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) - -> LMatch TcId (Located (body TcId)) -> TcM (LMatch Id (Located (body Id))) + -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) + -> LMatch GhcTcId (Located (body GhcTcId)) + -> TcM (LMatch GhcTc (Located (body GhcTc))) zonkMatch env zBody (L loc (Match mf pats _ grhss)) = do { (env1, new_pats) <- zonkPats env pats ; new_grhss <- zonkGRHSs env1 zBody grhss @@ -584,8 +590,9 @@ zonkMatch env zBody (L loc (Match mf pats _ grhss)) ------------------------------------------------------------------------- zonkGRHSs :: ZonkEnv - -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) - -> GRHSs TcId (Located (body TcId)) -> TcM (GRHSs Id (Located (body Id))) + -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) + -> GRHSs GhcTcId (Located (body GhcTcId)) + -> TcM (GRHSs GhcTc (Located (body GhcTc))) zonkGRHSs env zBody (GRHSs grhss (L l binds)) = do (new_env, new_binds) <- zonkLocalBinds env binds @@ -605,9 +612,9 @@ zonkGRHSs env zBody (GRHSs grhss (L l binds)) = do ************************************************************************ -} -zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id] -zonkLExpr :: ZonkEnv -> LHsExpr TcId -> TcM (LHsExpr Id) -zonkExpr :: ZonkEnv -> HsExpr TcId -> TcM (HsExpr Id) +zonkLExprs :: ZonkEnv -> [LHsExpr GhcTcId] -> TcM [LHsExpr GhcTc] +zonkLExpr :: ZonkEnv -> LHsExpr GhcTcId -> TcM (LHsExpr GhcTc) +zonkExpr :: ZonkEnv -> HsExpr GhcTcId -> TcM (HsExpr GhcTc) zonkLExprs env exprs = mapM (zonkLExpr env) exprs zonkLExpr env expr = wrapLocM (zonkExpr env) expr @@ -623,9 +630,9 @@ zonkExpr _ (HsIPVar id) zonkExpr _ e@HsOverLabel{} = return e -zonkExpr env (HsLit (HsRat f ty)) +zonkExpr env (HsLit (HsRat e f ty)) = do new_ty <- zonkTcTypeToType env ty - return (HsLit (HsRat f new_ty)) + return (HsLit (HsRat e f new_ty)) zonkExpr _ (HsLit lit) = return (HsLit lit) @@ -843,8 +850,8 @@ Now, we can safely just extend one environment. -} -- See Note [Skolems in zonkSyntaxExpr] -zonkSyntaxExpr :: ZonkEnv -> SyntaxExpr TcId - -> TcM (ZonkEnv, SyntaxExpr Id) +zonkSyntaxExpr :: ZonkEnv -> SyntaxExpr GhcTcId + -> TcM (ZonkEnv, SyntaxExpr GhcTc) zonkSyntaxExpr env (SyntaxExpr { syn_expr = expr , syn_arg_wraps = arg_wraps , syn_res_wrap = res_wrap }) @@ -857,8 +864,8 @@ zonkSyntaxExpr env (SyntaxExpr { syn_expr = expr ------------------------------------------------------------------------- -zonkLCmd :: ZonkEnv -> LHsCmd TcId -> TcM (LHsCmd Id) -zonkCmd :: ZonkEnv -> HsCmd TcId -> TcM (HsCmd Id) +zonkLCmd :: ZonkEnv -> LHsCmd GhcTcId -> TcM (LHsCmd GhcTc) +zonkCmd :: ZonkEnv -> HsCmd GhcTcId -> TcM (HsCmd GhcTc) zonkLCmd env cmd = wrapLocM (zonkCmd env) cmd @@ -919,10 +926,10 @@ zonkCmd env (HsCmdDo (L l stmts) ty) -zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id) +zonkCmdTop :: ZonkEnv -> LHsCmdTop GhcTcId -> TcM (LHsCmdTop GhcTc) zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd -zonk_cmd_top :: ZonkEnv -> HsCmdTop TcId -> TcM (HsCmdTop Id) +zonk_cmd_top :: ZonkEnv -> HsCmdTop GhcTcId -> TcM (HsCmdTop GhcTc) zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids) = do new_cmd <- zonkLCmd env cmd new_stack_tys <- zonkTcTypeToType env stack_tys @@ -961,14 +968,14 @@ zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkTcEvBinds env bs ; return (env1, WpLet bs') } ------------------------------------------------------------------------- -zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id) +zonkOverLit :: ZonkEnv -> HsOverLit GhcTcId -> TcM (HsOverLit GhcTc) zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty }) = do { ty' <- zonkTcTypeToType env ty ; e' <- zonkExpr env e ; return (lit { ol_witness = e', ol_type = ty' }) } ------------------------------------------------------------------------- -zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id) +zonkArithSeq :: ZonkEnv -> ArithSeqInfo GhcTcId -> TcM (ArithSeqInfo GhcTc) zonkArithSeq env (From e) = do new_e <- zonkLExpr env e @@ -993,16 +1000,18 @@ zonkArithSeq env (FromThenTo e1 e2 e3) ------------------------------------------------------------------------- zonkStmts :: ZonkEnv - -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) - -> [LStmt TcId (Located (body TcId))] -> TcM (ZonkEnv, [LStmt Id (Located (body Id))]) + -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) + -> [LStmt GhcTcId (Located (body GhcTcId))] + -> TcM (ZonkEnv, [LStmt GhcTc (Located (body GhcTc))]) zonkStmts env _ [] = return (env, []) zonkStmts env zBody (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env zBody) s ; (env2, ss') <- zonkStmts env1 zBody ss ; return (env2, s' : ss') } zonkStmt :: ZonkEnv - -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) - -> Stmt TcId (Located (body TcId)) -> TcM (ZonkEnv, Stmt Id (Located (body Id))) + -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) + -> Stmt GhcTcId (Located (body GhcTcId)) + -> TcM (ZonkEnv, Stmt GhcTc (Located (body GhcTc))) zonkStmt env _ (ParStmt stmts_w_bndrs mzip_op bind_op bind_ty) = do { (env1, new_bind_op) <- zonkSyntaxExpr env bind_op ; new_bind_ty <- zonkTcTypeToType env1 bind_ty @@ -1137,7 +1146,7 @@ zonkStmt env _zBody (ApplicativeStmt args mb_join body_ty) ; return (ApplicativeArgMany new_stmts new_ret pat) } ------------------------------------------------------------------------- -zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId) +zonkRecFields :: ZonkEnv -> HsRecordBinds GhcTcId -> TcM (HsRecordBinds GhcTcId) zonkRecFields env (HsRecFields flds dd) = do { flds' <- mapM zonk_rbind flds ; return (HsRecFields flds' dd) } @@ -1148,7 +1157,8 @@ zonkRecFields env (HsRecFields flds dd) ; return (L l (fld { hsRecFieldLbl = new_id , hsRecFieldArg = new_expr })) } -zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField TcId] -> TcM [LHsRecUpdField TcId] +zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField GhcTcId] + -> TcM [LHsRecUpdField GhcTcId] zonkRecUpdFields env = mapM zonk_rbind where zonk_rbind (L l fld) @@ -1172,13 +1182,13 @@ mapIPNameTc f (Right x) = do r <- f x ************************************************************************ -} -zonkPat :: ZonkEnv -> OutPat TcId -> TcM (ZonkEnv, OutPat Id) +zonkPat :: ZonkEnv -> OutPat GhcTcId -> TcM (ZonkEnv, OutPat GhcTc) -- Extend the environment as we go, because it's possible for one -- pattern to bind something that is used in another (inside or -- to the right) zonkPat env pat = wrapLocSndM (zonk_pat env) pat -zonk_pat :: ZonkEnv -> Pat TcId -> TcM (ZonkEnv, Pat Id) +zonk_pat :: ZonkEnv -> Pat GhcTcId -> TcM (ZonkEnv, Pat GhcTc) zonk_pat env (ParPat p) = do { (env', p') <- zonkPat env p ; return (env', ParPat p') } @@ -1308,9 +1318,9 @@ zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat) --------------------------- zonkConStuff :: ZonkEnv - -> HsConDetails (OutPat TcId) (HsRecFields id (OutPat TcId)) + -> HsConDetails (OutPat GhcTcId) (HsRecFields id (OutPat GhcTcId)) -> TcM (ZonkEnv, - HsConDetails (OutPat Id) (HsRecFields id (OutPat Id))) + HsConDetails (OutPat GhcTc) (HsRecFields id (OutPat GhcTc))) zonkConStuff env (PrefixCon pats) = do { (env', pats') <- zonkPats env pats ; return (env', PrefixCon pats') } @@ -1328,7 +1338,7 @@ zonkConStuff env (RecCon (HsRecFields rpats dd)) -- Field selectors have declared types; hence no zonking --------------------------- -zonkPats :: ZonkEnv -> [OutPat TcId] -> TcM (ZonkEnv, [OutPat Id]) +zonkPats :: ZonkEnv -> [OutPat GhcTcId] -> TcM (ZonkEnv, [OutPat GhcTc]) zonkPats env [] = return (env, []) zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat ; (env', pats') <- zonkPats env1 pats @@ -1342,10 +1352,11 @@ zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat ************************************************************************ -} -zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id] +zonkForeignExports :: ZonkEnv -> [LForeignDecl GhcTcId] + -> TcM [LForeignDecl GhcTc] zonkForeignExports env ls = mapM (wrapLocM (zonkForeignExport env)) ls -zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id) +zonkForeignExport :: ZonkEnv -> ForeignDecl GhcTcId -> TcM (ForeignDecl GhcTc) zonkForeignExport env (ForeignExport { fd_name = i, fd_co = co, fd_fe = spec }) = return (ForeignExport { fd_name = fmap (zonkIdOcc env) i , fd_sig_ty = undefined, fd_co = co @@ -1353,10 +1364,10 @@ zonkForeignExport env (ForeignExport { fd_name = i, fd_co = co, fd_fe = spec }) zonkForeignExport _ for_imp = return for_imp -- Foreign imports don't need zonking -zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id] +zonkRules :: ZonkEnv -> [LRuleDecl GhcTcId] -> TcM [LRuleDecl GhcTc] zonkRules env rs = mapM (wrapLocM (zonkRule env)) rs -zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id) +zonkRule :: ZonkEnv -> RuleDecl GhcTcId -> TcM (RuleDecl GhcTc) zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs) = do { (env_inside, new_bndrs) <- mapAccumLM zonk_bndr env vars @@ -1382,10 +1393,10 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs) -- wrong because we may need to go inside the kind -- of v and zonk there! -zonkVects :: ZonkEnv -> [LVectDecl TcId] -> TcM [LVectDecl Id] +zonkVects :: ZonkEnv -> [LVectDecl GhcTcId] -> TcM [LVectDecl GhcTc] zonkVects env = mapM (wrapLocM (zonkVect env)) -zonkVect :: ZonkEnv -> VectDecl TcId -> TcM (VectDecl Id) +zonkVect :: ZonkEnv -> VectDecl GhcTcId -> TcM (VectDecl GhcTc) zonkVect env (HsVect s v e) = do { v' <- wrapLocM (zonkIdBndr env) v ; e' <- zonkLExpr env e diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 9b313f0c60..46b306d130 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -151,13 +151,13 @@ funsSigCtxt :: [Located Name] -> UserTypeCtxt funsSigCtxt (L _ name1 : _) = FunSigCtxt name1 False funsSigCtxt [] = panic "funSigCtxt" -addSigCtxt :: UserTypeCtxt -> LHsType Name -> TcM a -> TcM a +addSigCtxt :: UserTypeCtxt -> LHsType GhcRn -> TcM a -> TcM a addSigCtxt ctxt hs_ty thing_inside = setSrcSpan (getLoc hs_ty) $ addErrCtxt (pprSigCtxt ctxt hs_ty) $ thing_inside -pprSigCtxt :: UserTypeCtxt -> LHsType Name -> SDoc +pprSigCtxt :: UserTypeCtxt -> LHsType GhcRn -> SDoc -- (pprSigCtxt ctxt <extra> <type>) -- prints In the type signature for 'f': -- f :: <type> @@ -171,13 +171,13 @@ pprSigCtxt ctxt hs_ty = hang (text "In" <+> pprUserTypeCtxt ctxt <> colon) 2 (ppr hs_ty) -tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType Name -> TcM Type +tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type -- This one is used when we have a LHsSigWcType, but in -- a place where wildards aren't allowed. The renamer has -- already checked this, so we can simply ignore it. tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty) -kcHsSigType :: [Located Name] -> LHsSigType Name -> TcM () +kcHsSigType :: [Located Name] -> LHsSigType GhcRn -> TcM () kcHsSigType names (HsIB { hsib_body = hs_ty , hsib_vars = sig_vars }) = addSigCtxt (funsSigCtxt names) hs_ty $ @@ -185,14 +185,14 @@ kcHsSigType names (HsIB { hsib_body = hs_ty tcImplicitTKBndrsType sig_vars $ tc_lhs_type typeLevelMode hs_ty liftedTypeKind -tcClassSigType :: [Located Name] -> LHsSigType Name -> TcM Type +tcClassSigType :: [Located Name] -> LHsSigType GhcRn -> TcM Type -- Does not do validity checking; this must be done outside -- the recursive class declaration "knot" tcClassSigType names sig_ty = addSigCtxt (funsSigCtxt names) (hsSigType sig_ty) $ tc_hs_sig_type_and_gen sig_ty liftedTypeKind -tcHsSigType :: UserTypeCtxt -> LHsSigType Name -> TcM Type +tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type -- Does validity checking tcHsSigType ctxt sig_ty = addSigCtxt ctxt (hsSigType sig_ty) $ @@ -212,7 +212,7 @@ tcHsSigType ctxt sig_ty ; checkValidType ctxt ty ; return ty } -tc_hs_sig_type_and_gen :: LHsSigType Name -> Kind -> TcM Type +tc_hs_sig_type_and_gen :: LHsSigType GhcRn -> Kind -> TcM Type -- Kind-checks/desugars an 'LHsSigType', -- solve equalities, -- and then kind-generalizes. @@ -226,7 +226,7 @@ tc_hs_sig_type_and_gen hs_ty kind -- kind generalisation ; kindGeneralizeType ty } -tc_hs_sig_type :: LHsSigType Name -> Kind -> TcM Type +tc_hs_sig_type :: LHsSigType GhcRn -> Kind -> TcM Type -- Kind-check/desugar a 'LHsSigType', but does not solve -- the equalities that arise from doing so; instead it may -- emit kind-equality constraints into the monad @@ -238,7 +238,7 @@ tc_hs_sig_type (HsIB { hsib_vars = sig_vars ; return (mkSpecForAllTys tkvs ty) } ----------------- -tcHsDeriv :: LHsSigType Name -> TcM ([TyVar], Class, [Type], [Kind]) +tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind]) -- Like tcHsSigType, but for the ...deriving( C t1 ty2 ) clause -- Returns the C, [ty1, ty2, and the kinds of C's remaining arguments -- E.g. class C (a::*) (b::k->k) @@ -259,7 +259,7 @@ tcHsDeriv hs_ty Nothing -> failWithTc (text "Illegal deriving item" <+> quotes (ppr hs_ty)) } tcHsClsInstType :: UserTypeCtxt -- InstDeclCtxt or SpecInstCtxt - -> LHsSigType Name + -> LHsSigType GhcRn -> TcM ([TyVar], ThetaType, Class, [Type]) -- Like tcHsSigType, but for a class instance declaration tcHsClsInstType user_ctxt hs_inst_ty @@ -268,7 +268,7 @@ tcHsClsInstType user_ctxt hs_inst_ty ; checkValidInstance user_ctxt hs_inst_ty inst_ty } -- Used for 'VECTORISE [SCALAR] instance' declarations -tcHsVectInst :: LHsSigType Name -> TcM (Class, [Type]) +tcHsVectInst :: LHsSigType GhcRn -> TcM (Class, [Type]) tcHsVectInst ty | Just (L _ cls_name, tys) <- hsTyGetAppHead_maybe (hsSigType ty) -- Ignoring the binders looks pretty dodgy to me @@ -284,7 +284,7 @@ tcHsVectInst ty ---------------------------------------------- -- | Type-check a visible type application -tcHsTypeApp :: LHsWcType Name -> Kind -> TcM Type +tcHsTypeApp :: LHsWcType GhcRn -> Kind -> TcM Type tcHsTypeApp wc_ty kind | HsWC { hswc_wcs = sig_wcs, hswc_body = hs_ty } <- wc_ty = do { ty <- tcWildCardBindersX newWildTyVar sig_wcs $ \ _ -> @@ -308,7 +308,7 @@ tcHsTypeApp wc_ty kind --------------------------- tcHsOpenType, tcHsLiftedType, - tcHsOpenTypeNC, tcHsLiftedTypeNC :: LHsType Name -> TcM TcType + tcHsOpenTypeNC, tcHsLiftedTypeNC :: LHsType GhcRn -> TcM TcType -- Used for type signatures -- Do not do validity checking tcHsOpenType ty = addTypeCtxt ty $ tcHsOpenTypeNC ty @@ -319,12 +319,12 @@ tcHsOpenTypeNC ty = do { ek <- newOpenTypeKind tcHsLiftedTypeNC ty = tc_lhs_type typeLevelMode ty liftedTypeKind -- Like tcHsType, but takes an expected kind -tcCheckLHsType :: LHsType Name -> Kind -> TcM Type +tcCheckLHsType :: LHsType GhcRn -> Kind -> TcM Type tcCheckLHsType hs_ty exp_kind = addTypeCtxt hs_ty $ tc_lhs_type typeLevelMode hs_ty exp_kind -tcLHsType :: LHsType Name -> TcM (TcType, TcKind) +tcLHsType :: LHsType GhcRn -> TcM (TcType, TcKind) -- Called from outside: set the context tcLHsType ty = addTypeCtxt ty (tc_infer_lhs_type typeLevelMode ty) @@ -333,7 +333,7 @@ tcLHsType ty = addTypeCtxt ty (tc_infer_lhs_type typeLevelMode ty) -- We *should* generalise if the type is closed -- or if NoMonoLocalBinds is set. Otherwise, nope. -- See Note [Kind generalisation plan] -decideKindGeneralisationPlan :: LHsSigType Name -> TcM Bool +decideKindGeneralisationPlan :: LHsSigType GhcRn -> TcM Bool decideKindGeneralisationPlan sig_ty@(HsIB { hsib_closed = closed }) = do { mono_locals <- xoptM LangExt.MonoLocalBinds ; let should_gen = not mono_locals || closed @@ -454,7 +454,7 @@ missing any patterns. -- | Check and desugar a type, returning the core type and its -- possibly-polymorphic kind. Much like 'tcInferRho' at the expression -- level. -tc_infer_lhs_type :: TcTyMode -> LHsType Name -> TcM (TcType, TcKind) +tc_infer_lhs_type :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind) tc_infer_lhs_type mode (L span ty) = setSrcSpan span $ do { (ty', kind) <- tc_infer_hs_type mode ty @@ -462,7 +462,7 @@ tc_infer_lhs_type mode (L span ty) -- | Infer the kind of a type and desugar. This is the "up" type-checker, -- as described in Note [Bidirectional type checking] -tc_infer_hs_type :: TcTyMode -> HsType Name -> TcM (TcType, TcKind) +tc_infer_hs_type :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind) tc_infer_hs_type mode (HsTyVar _ (L _ tv)) = tcTyVar mode tv tc_infer_hs_type mode (HsAppTy ty1 ty2) = do { let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2] @@ -495,14 +495,15 @@ tc_infer_hs_type mode other_ty ; return (ty', kv) } ------------------------------------------ -tc_lhs_type :: TcTyMode -> LHsType Name -> TcKind -> TcM TcType +tc_lhs_type :: TcTyMode -> LHsType GhcRn -> TcKind -> TcM TcType tc_lhs_type mode (L span ty) exp_kind = setSrcSpan span $ do { ty' <- tc_hs_type mode ty exp_kind ; return ty' } ------------------------------------------ -tc_fun_type :: TcTyMode -> LHsType Name -> LHsType Name -> TcKind -> TcM TcType +tc_fun_type :: TcTyMode -> LHsType GhcRn -> LHsType GhcRn -> TcKind + -> TcM TcType tc_fun_type mode ty1 ty2 exp_kind = case mode_level mode of TypeLevel -> do { arg_k <- newOpenTypeKind @@ -517,7 +518,7 @@ tc_fun_type mode ty1 ty2 exp_kind = case mode_level mode of ------------------------------------------ -- See also Note [Bidirectional type checking] -tc_hs_type :: TcTyMode -> HsType Name -> TcKind -> TcM TcType +tc_hs_type :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType tc_hs_type mode (HsParTy ty) exp_kind = tc_lhs_type mode ty exp_kind tc_hs_type mode (HsDocTy ty _) exp_kind = tc_lhs_type mode ty exp_kind tc_hs_type _ ty@(HsBangTy {}) _ @@ -709,7 +710,7 @@ tc_hs_type _ (HsWildCardTy wc) exp_kind tc_hs_type _ ty@(HsAppsTy {}) _ = pprPanic "tc_hs_tyep HsAppsTy" (ppr ty) -tcWildCardOcc :: HsWildCardInfo Name -> Kind -> TcM TcTyVar +tcWildCardOcc :: HsWildCardInfo GhcRn -> Kind -> TcM TcTyVar tcWildCardOcc wc_info exp_kind = do { wc_tv <- tcLookupTyVar (wildCardName wc_info) -- The wildcard's kind should be an un-filled-in meta tyvar @@ -719,7 +720,7 @@ tcWildCardOcc wc_info exp_kind --------------------------- -- | Call 'tc_infer_hs_type' and check its result against an expected kind. -tc_infer_hs_type_ek :: TcTyMode -> HsType Name -> TcKind -> TcM TcType +tc_infer_hs_type_ek :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType tc_infer_hs_type_ek mode ty ek = do { (ty', k) <- tc_infer_hs_type mode ty ; checkExpectedKind ty' k ek } @@ -733,7 +734,7 @@ tupKindSort_maybe k | isLiftedTypeKind k = Just BoxedTuple | otherwise = Nothing -tc_tuple :: TcTyMode -> TupleSort -> [LHsType Name] -> TcKind -> TcM TcType +tc_tuple :: TcTyMode -> TupleSort -> [LHsType GhcRn] -> TcKind -> TcM TcType tc_tuple mode tup_sort tys exp_kind = do { arg_kinds <- case tup_sort of BoxedTuple -> return (nOfThem arity liftedTypeKind) @@ -798,8 +799,8 @@ tcInferArgs :: Outputable fun => fun -- ^ the function -> [TyConBinder] -- ^ function kind's binders -> Maybe (VarEnv Kind) -- ^ possibly, kind info (see above) - -> [LHsType Name] -- ^ args - -> TcM (TCvSubst, [TyBinder], [TcType], [LHsType Name], Int) + -> [LHsType GhcRn] -- ^ args + -> TcM (TCvSubst, [TyBinder], [TcType], [LHsType GhcRn], Int) -- ^ (instantiating subst, un-insted leftover binders, -- typechecked args, untypechecked args, n) tcInferArgs fun tc_binders mb_kind_info args @@ -822,9 +823,9 @@ tc_infer_args :: Outputable fun -> fun -- ^ the function -> [TyBinder] -- ^ function kind's binders (zonked) -> Maybe (VarEnv Kind) -- ^ possibly, kind info (see above) - -> [LHsType Name] -- ^ args + -> [LHsType GhcRn] -- ^ args -> Int -- ^ number to start arg counter at - -> TcM (TCvSubst, [TyBinder], [TcType], [LHsType Name], Int) + -> TcM (TCvSubst, [TyBinder], [TcType], [LHsType GhcRn], Int) tc_infer_args mode orig_ty binders mb_kind_info orig_args n0 = go emptyTCvSubst binders orig_args n0 [] where @@ -861,7 +862,7 @@ tcInferApps :: Outputable fun -> fun -- ^ Function (for printing only) -> TcType -- ^ Function (could be knot-tied) -> TcKind -- ^ Function kind (zonked) - -> [LHsType Name] -- ^ Args + -> [LHsType GhcRn] -- ^ Args -> TcM (TcType, TcKind) -- ^ (f args, result kind) tcInferApps mode orig_ty ty ki args = go ty ki args 1 where @@ -936,16 +937,16 @@ instantiateTyN n ty ki ; return (mkNakedAppTys ty inst_args, ki') } --------------------------- -tcHsContext :: LHsContext Name -> TcM [PredType] +tcHsContext :: LHsContext GhcRn -> TcM [PredType] tcHsContext = tc_hs_context typeLevelMode -tcLHsPredType :: LHsType Name -> TcM PredType +tcLHsPredType :: LHsType GhcRn -> TcM PredType tcLHsPredType = tc_lhs_pred typeLevelMode -tc_hs_context :: TcTyMode -> LHsContext Name -> TcM [PredType] +tc_hs_context :: TcTyMode -> LHsContext GhcRn -> TcM [PredType] tc_hs_context mode ctxt = mapM (tc_lhs_pred mode) (unLoc ctxt) -tc_lhs_pred :: TcTyMode -> LHsType Name -> TcM PredType +tc_lhs_pred :: TcTyMode -> LHsType GhcRn -> TcM PredType tc_lhs_pred mode pred = tc_lhs_type mode pred constraintKind --------------------------- @@ -1224,7 +1225,7 @@ Help functions for type applications ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -} -addTypeCtxt :: LHsType Name -> TcM a -> TcM a +addTypeCtxt :: LHsType GhcRn -> TcM a -> TcM a -- Wrap a context around only if we want to show that contexts. -- Omit invisble ones and ones user's won't grok addTypeCtxt (L _ ty) thing @@ -1309,7 +1310,7 @@ kcHsTyVarBndrs :: Name -- ^ of the thing being checked -> Bool -- ^ True <=> the decl is an open type/data family -> Bool -- ^ True <=> all the hsq_implicit are *kind* vars -- (will give these kind * if -XNoTypeInType) - -> LHsQTyVars Name + -> LHsQTyVars GhcRn -> TcM (Kind, r) -- ^ The result kind, possibly with other info -> TcM (TcTyCon, r) -- ^ A suitably-kinded TcTyCon kcHsTyVarBndrs name unsat cusk open_fam all_kind_vars @@ -1383,7 +1384,7 @@ kcHsTyVarBndrs name unsat cusk open_fam all_kind_vars -- there may be dependency between the explicit "ty" vars. So, we have -- to handle them one at a time. - bind_telescope :: [LHsTyVarBndr Name] + bind_telescope :: [LHsTyVarBndr GhcRn] -> TcM (Kind, r) -> TcM ([TyConBinder], TcKind, r) bind_telescope [] thing @@ -1410,7 +1411,7 @@ kcHsTyVarBndrs name unsat cusk open_fam all_kind_vars bind_unless_scoped (tv, False) thing_inside = tcExtendTyVarEnv [tv] thing_inside - kc_hs_tv :: HsTyVarBndr Name -> TcM (TcTyVar, Bool) + kc_hs_tv :: HsTyVarBndr GhcRn -> TcM (TcTyVar, Bool) kc_hs_tv (UserTyVar (L _ name)) = do { tv_pair@(tv, scoped) <- tcHsTyVarName Nothing name @@ -1484,7 +1485,7 @@ tcImplicitTKBndrsX new_tv var_ns thing_inside ; return (final_tvs, result) } -tcExplicitTKBndrs :: [LHsTyVarBndr Name] +tcExplicitTKBndrs :: [LHsTyVarBndr GhcRn] -> ([TyVar] -> TcM (a, TyVarSet)) -- ^ Thing inside returns the set of variables bound -- in the scope. See Note [Scope-check inferred kinds] @@ -1494,7 +1495,7 @@ tcExplicitTKBndrs orig_hs_tvs thing_inside = tcExplicitTKBndrsX newSkolemTyVar orig_hs_tvs thing_inside tcExplicitTKBndrsX :: (Name -> Kind -> TcM TyVar) - -> [LHsTyVarBndr Name] + -> [LHsTyVarBndr GhcRn] -> ([TyVar] -> TcM (a, TyVarSet)) -- ^ Thing inside returns the set of variables bound -- in the scope. See Note [Scope-check inferred kinds] @@ -1523,7 +1524,7 @@ tcExplicitTKBndrsX new_tv orig_hs_tvs thing_inside thing (tv : tvs) } tcHsTyVarBndr :: (Name -> Kind -> TcM TyVar) - -> HsTyVarBndr Name -> TcM TcTyVar + -> HsTyVarBndr GhcRn -> TcM TcTyVar -- Return a SkolemTv TcTyVar, initialised with a kind variable. -- Typically the Kind inside the HsTyVarBndr will be a tyvar -- with a mutable kind in it. @@ -1800,7 +1801,7 @@ It isn't essential for correctness. tcHsPartialSigType :: UserTypeCtxt - -> LHsSigWcType Name -- The type signature + -> LHsSigWcType GhcRn -- The type signature -> TcM ( [(Name, TcTyVar)] -- Wildcards , Maybe TcTyVar -- Extra-constraints wildcard , [TcTyVar] -- Implicitly and explicitly bound type variables @@ -1844,7 +1845,7 @@ tcHsPartialSigType ctxt sig_ty ; tv <- newSigTyVar name kind ; return (tv, False) } -tcPartialContext :: HsContext Name -> TcM (TcThetaType, Maybe TcTyVar) +tcPartialContext :: HsContext GhcRn -> TcM (TcThetaType, Maybe TcTyVar) tcPartialContext hs_theta | Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta , L _ (HsWildCardTy wc) <- ignoreParens hs_ctxt_last @@ -1856,7 +1857,7 @@ tcPartialContext hs_theta ; return (theta, Nothing) } tcHsPatSigType :: UserTypeCtxt - -> LHsSigWcType Name -- The type signature + -> LHsSigWcType GhcRn -- The type signature -> TcM ( [(Name, TcTyVar)] -- Wildcards , [TcTyVar] -- The new bit of type environment, binding -- the scoped type variables @@ -1897,7 +1898,7 @@ tcHsPatSigType ctxt sig_ty tcPatSig :: Bool -- True <=> pattern binding - -> LHsSigWcType Name + -> LHsSigWcType GhcRn -> ExpSigmaType -> TcM (TcType, -- The type to use for "inside" the signature [TcTyVar], -- The new bit of type environment, binding @@ -2029,10 +2030,10 @@ tcLHsKind converts a user-written kind to an internal, sort-checked kind. It does sort checking and desugaring at the same time, in one single pass. -} -tcLHsKind :: LHsKind Name -> TcM Kind +tcLHsKind :: LHsKind GhcRn -> TcM Kind tcLHsKind = tc_lhs_kind kindLevelMode -tc_lhs_kind :: TcTyMode -> LHsKind Name -> TcM Kind +tc_lhs_kind :: TcTyMode -> LHsKind GhcRn -> TcM Kind tc_lhs_kind mode k = addErrCtxt (text "In the kind" <+> quotes (ppr k)) $ tc_lhs_type (kindLevel mode) k liftedTypeKind diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index 7c591a87d4..6f3a2c9163 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -7,6 +7,8 @@ TcInstDecls: Typechecking instance declarations -} {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} module TcInstDcls ( tcInstDecls1, tcInstDeclsDeriv, tcInstDecls2 ) where @@ -361,9 +363,9 @@ Gather up the instance declarations from their various sources -} tcInstDecls1 -- Deal with both source-code and imported instance decls - :: [LInstDecl Name] -- Source code instance decls + :: [LInstDecl GhcRn] -- Source code instance decls -> TcM (TcGblEnv, -- The full inst env - [InstInfo Name], -- Source-code instance decls to process; + [InstInfo GhcRn], -- Source-code instance decls to process; -- contains all dfuns for this module [DerivInfo]) -- From data family instances @@ -388,9 +390,9 @@ tcInstDecls1 inst_decls -- (DerivDecl) to check and process all derived class instances. tcInstDeclsDeriv :: [DerivInfo] - -> [LTyClDecl Name] - -> [LDerivDecl Name] - -> TcM (TcGblEnv, [InstInfo Name], HsValBinds Name) + -> [LTyClDecl GhcRn] + -> [LDerivDecl GhcRn] + -> TcM (TcGblEnv, [InstInfo GhcRn], HsValBinds GhcRn) tcInstDeclsDeriv datafam_deriv_infos tyclds derivds = do th_stage <- getStage -- See Note [Deriving inside TH brackets] if isBrackStage th_stage @@ -401,7 +403,7 @@ tcInstDeclsDeriv datafam_deriv_infos tyclds derivds ; (tcg_env, info_bag, valbinds) <- tcDeriving deriv_infos derivds ; return (tcg_env, bagToList info_bag, valbinds) } -addClsInsts :: [InstInfo Name] -> TcM a -> TcM a +addClsInsts :: [InstInfo GhcRn] -> TcM a -> TcM a addClsInsts infos thing_inside = tcExtendLocalInstEnv (map iSpec infos) thing_inside @@ -440,8 +442,8 @@ bindings.) This will become moot when we shift to the new TH plan, so the brutal solution will do. -} -tcLocalInstDecl :: LInstDecl Name - -> TcM ([InstInfo Name], [FamInst], [DerivInfo]) +tcLocalInstDecl :: LInstDecl GhcRn + -> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo]) -- A source-file instance declaration -- Type-check all the stuff before the "where" -- @@ -458,8 +460,8 @@ tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl })) = do { (insts, fam_insts, deriv_infos) <- tcClsInstDecl (L loc decl) ; return (insts, fam_insts, deriv_infos) } -tcClsInstDecl :: LClsInstDecl Name - -> TcM ([InstInfo Name], [FamInst], [DerivInfo]) +tcClsInstDecl :: LClsInstDecl GhcRn + -> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo]) -- The returned DerivInfos are for any associated data families tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds , cid_sigs = uprags, cid_tyfam_insts = ats @@ -511,7 +513,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds , deriv_infos ) } -doClsInstErrorChecks :: InstInfo Name -> TcM () +doClsInstErrorChecks :: InstInfo GhcRn -> TcM () doClsInstErrorChecks inst_info = do { traceTc "doClsInstErrorChecks" (ppr ispec) ; dflags <- getDynFlags @@ -593,7 +595,7 @@ tcFamInstDeclCombined mb_clsinfo fam_tc_lname ; return fam_tc } tcTyFamInstDecl :: Maybe ClsInstInfo - -> LTyFamInstDecl Name -> TcM FamInst + -> LTyFamInstDecl GhcRn -> TcM FamInst -- "type instance" tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn })) = setSrcSpan loc $ @@ -618,7 +620,7 @@ tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn })) ; newFamInst SynFamilyInst axiom } tcDataFamInstDecl :: Maybe ClsInstInfo - -> LDataFamInstDecl Name -> TcM (FamInst, Maybe DerivInfo) + -> LDataFamInstDecl GhcRn -> TcM (FamInst, Maybe DerivInfo) -- "newtype instance" and "data instance" tcDataFamInstDecl mb_clsinfo (L loc decl@(DataFamInstDecl @@ -735,8 +737,8 @@ tcDataFamInstDecl mb_clsinfo * * ********************************************************************* -} -tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name] - -> TcM (LHsBinds Id) +tcInstDecls2 :: [LTyClDecl GhcRn] -> [InstInfo GhcRn] + -> TcM (LHsBinds GhcTc) -- (a) From each class declaration, -- generate any default-method bindings -- (b) From each instance decl @@ -773,7 +775,7 @@ So right here in tcInstDecls2 we must re-extend the type envt with the default method Ids replete with their INLINE pragmas. Urk. -} -tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id) +tcInstDecl2 :: InstInfo GhcRn -> TcM (LHsBinds GhcTc) -- Returns a binding for the dfun tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) = recoverM (return emptyLHsBinds) $ @@ -851,7 +853,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) con_app_args = foldl app_to_meth con_app_tys sc_meth_ids - app_to_meth :: HsExpr Id -> Id -> HsExpr Id + app_to_meth :: HsExpr GhcTc -> Id -> HsExpr GhcTc app_to_meth fun meth_id = L loc fun `HsApp` L loc (wrapId arg_wrapper meth_id) inst_tv_tys = mkTyVarTys inst_tyvars @@ -914,7 +916,7 @@ addDFunPrags dfun_id sc_meth_ids [dict_con] = tyConDataCons clas_tc is_newtype = isNewTyCon clas_tc -wrapId :: HsWrapper -> id -> HsExpr id +wrapId :: HsWrapper -> IdP id -> HsExpr id wrapId wrapper id = mkHsWrap wrapper (HsVar (noLoc id)) {- Note [Typechecking plan for instance declarations] @@ -989,7 +991,7 @@ Notice that tcSuperClasses :: DFunId -> Class -> [TcTyVar] -> [EvVar] -> [TcType] -> TcEvBinds -> TcThetaType - -> TcM ([EvVar], LHsBinds Id, Bag Implication) + -> TcM ([EvVar], LHsBinds GhcTc, Bag Implication) -- Make a new top-level function binding for each superclass, -- something like -- $Ordp1 :: forall a. Ord a => Eq [a] @@ -1250,8 +1252,8 @@ tcMethods :: DFunId -> Class -> TcEvBinds -> ([Located TcSpecPrag], TcPragEnv) -> [ClassOpItem] - -> InstBindings Name - -> TcM ([Id], LHsBinds Id, Bag Implication) + -> InstBindings GhcRn + -> TcM ([Id], LHsBinds GhcTc, Bag Implication) -- The returned inst_meth_ids all have types starting -- forall tvs. theta => ... tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys @@ -1276,7 +1278,7 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys inst_loc = getSrcSpan dfun_id ---------------------- - tc_item :: ClassOpItem -> TcM (Id, LHsBind Id, Maybe Implication) + tc_item :: ClassOpItem -> TcM (Id, LHsBind GhcTc, Maybe Implication) tc_item (sel_id, dm_info) | Just (user_bind, bndr_loc, prags) <- findMethodBind (idName sel_id) binds prag_fn = tcMethodBody clas tyvars dfun_ev_vars inst_tys @@ -1288,7 +1290,8 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys ; tc_default sel_id dm_info } ---------------------- - tc_default :: Id -> DefMethInfo -> TcM (TcId, LHsBind Id, Maybe Implication) + tc_default :: Id -> DefMethInfo + -> TcM (TcId, LHsBind GhcTc, Maybe Implication) tc_default sel_id (Just (dm_name, _)) = do { (meth_bind, inline_prags) <- mkDefMethBind clas inst_tys sel_id dm_name @@ -1312,7 +1315,7 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys [ getRuntimeRep "tcInstanceMethods.tc_default" meth_tau , meth_tau]) nO_METHOD_BINDING_ERROR_ID - error_msg dflags = L inst_loc (HsLit (HsStringPrim NoSourceText + error_msg dflags = L inst_loc (HsLit (HsStringPrim noSourceText (unsafeMkByteString (error_string dflags)))) meth_tau = funResultTy (piResultTys (idType sel_id) inst_tys) error_string dflags = showSDoc dflags @@ -1331,9 +1334,9 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys tcMethodBody :: Class -> [TcTyVar] -> [EvVar] -> [TcType] -> TcEvBinds -> Bool -> HsSigFun - -> [LTcSpecPrag] -> [LSig Name] - -> Id -> LHsBind Name -> SrcSpan - -> TcM (TcId, LHsBind Id, Maybe Implication) + -> [LTcSpecPrag] -> [LSig GhcRn] + -> Id -> LHsBind GhcRn -> SrcSpan + -> TcM (TcId, LHsBind GhcTc, Maybe Implication) tcMethodBody clas tyvars dfun_ev_vars inst_tys dfun_ev_binds is_derived sig_fn spec_inst_prags prags @@ -1380,7 +1383,7 @@ tcMethodBody clas tyvars dfun_ev_vars inst_tys | otherwise = thing tcMethodBodyHelp :: HsSigFun -> Id -> TcId - -> LHsBind Name -> TcM (LHsBinds TcId) + -> LHsBind GhcRn -> TcM (LHsBinds GhcTcId) tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind | Just hs_sig_ty <- hs_sig_fn sel_name -- There is a signature in the instance @@ -1467,7 +1470,7 @@ methSigCtxt sel_name sig_ty meth_ty env0 , text " Class sig:" <+> ppr meth_ty ]) ; return (env2, msg) } -misplacedInstSig :: Name -> LHsSigType Name -> SDoc +misplacedInstSig :: Name -> LHsSigType GhcRn -> SDoc misplacedInstSig name hs_ty = vcat [ hang (text "Illegal type signature in instance declaration:") 2 (hang (pprPrefixName name) @@ -1543,7 +1546,8 @@ mk_meth_spec_prags meth_id spec_inst_prags spec_prags_for_me | L inst_loc (SpecPrag _ wrap inl) <- spec_inst_prags] -mkDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name, [LSig Name]) +mkDefMethBind :: Class -> [Type] -> Id -> Name + -> TcM (LHsBind GhcRn, [LSig GhcRn]) -- The is a default method (vanailla or generic) defined in the class -- So make a binding op = $dmop @t1 @t2 -- where $dmop is the name of the default method in the class, @@ -1574,7 +1578,7 @@ mkDefMethBind clas inst_tys sel_id dm_name ; return (bind, inline_prags) } where - mk_vta :: LHsExpr Name -> Type -> LHsExpr Name + mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn mk_vta fun ty = noLoc (HsAppType fun (mkEmptyWildCardBndrs $ nlHsParTy $ noLoc $ HsCoreTy ty)) -- NB: use visible type application @@ -1768,7 +1772,7 @@ Note that just once, and pass the result (in spec_inst_info) to tcMethods. -} -tcSpecInstPrags :: DFunId -> InstBindings Name +tcSpecInstPrags :: DFunId -> InstBindings GhcRn -> TcM ([Located TcSpecPrag], TcPragEnv) tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags }) = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $ @@ -1777,7 +1781,7 @@ tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags }) ; return (spec_inst_prags, mkPragEnv uprags binds) } ------------------------------ -tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag +tcSpecInst :: Id -> Sig GhcRn -> TcM TcSpecPrag tcSpecInst dfun_id prag@(SpecInstSig _ hs_ty) = addErrCtxt (spec_ctxt prag) $ do { (tyvars, theta, clas, tys) <- tcHsClsInstType SpecInstCtxt hs_ty @@ -1797,7 +1801,7 @@ tcSpecInst _ _ = panic "tcSpecInst" ************************************************************************ -} -instDeclCtxt1 :: LHsSigType Name -> SDoc +instDeclCtxt1 :: LHsSigType GhcRn -> SDoc instDeclCtxt1 hs_inst_ty = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty)) diff --git a/compiler/typecheck/TcInstDcls.hs-boot b/compiler/typecheck/TcInstDcls.hs-boot index 16db4e8e7a..e7240903e4 100644 --- a/compiler/typecheck/TcInstDcls.hs-boot +++ b/compiler/typecheck/TcInstDcls.hs-boot @@ -9,8 +9,9 @@ import HsSyn import TcRnTypes import TcEnv( InstInfo ) import TcDeriv -import Name +import HsExtension ( GhcRn ) -- We need this because of the mutual recursion -- between TcTyClsDecls and TcInstDcls -tcInstDecls1 :: [LInstDecl Name] -> TcM (TcGblEnv, [InstInfo Name], [DerivInfo]) +tcInstDecls1 :: [LInstDecl GhcRn] + -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo]) diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs index fa1f05136f..c228b53fa3 100644 --- a/compiler/typecheck/TcMatches.hs +++ b/compiler/typecheck/TcMatches.hs @@ -11,6 +11,7 @@ TcMatches: Typecheck some @Matches@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambda, TcMatchCtxt(..), TcStmtChecker, TcExprStmtChecker, TcCmdStmtChecker, @@ -70,9 +71,9 @@ See Note [sig_tau may be polymorphic] in TcPat. -} tcMatchesFun :: Located Name - -> MatchGroup Name (LHsExpr Name) + -> MatchGroup GhcRn (LHsExpr GhcRn) -> ExpRhoType -- Expected type of function - -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId)) + -> TcM (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId)) -- Returns type of body tcMatchesFun fn@(L _ fun_name) matches exp_ty = do { -- Check that they all have the same no of arguments @@ -104,23 +105,23 @@ tcMatchesFun fn@(L _ fun_name) matches exp_ty parser guarantees that each equation has exactly one argument. -} -tcMatchesCase :: (Outputable (body Name)) => - TcMatchCtxt body -- Case context - -> TcSigmaType -- Type of scrutinee - -> MatchGroup Name (Located (body Name)) -- The case alternatives - -> ExpRhoType -- Type of whole case expressions - -> TcM (MatchGroup TcId (Located (body TcId))) - -- Translated alternatives - -- wrapper goes from MatchGroup's ty to expected ty +tcMatchesCase :: (Outputable (body GhcRn)) => + TcMatchCtxt body -- Case context + -> TcSigmaType -- Type of scrutinee + -> MatchGroup GhcRn (Located (body GhcRn)) -- The case alternatives + -> ExpRhoType -- Type of whole case expressions + -> TcM (MatchGroup GhcTcId (Located (body GhcTcId))) + -- Translated alternatives + -- wrapper goes from MatchGroup's ty to expected ty tcMatchesCase ctxt scrut_ty matches res_ty = tcMatches ctxt [mkCheckExpType scrut_ty] res_ty matches tcMatchLambda :: SDoc -- see Note [Herald for matchExpectedFunTys] in TcUnify -> TcMatchCtxt HsExpr - -> MatchGroup Name (LHsExpr Name) + -> MatchGroup GhcRn (LHsExpr GhcRn) -> ExpRhoType -- deeply skolemised - -> TcM (MatchGroup TcId (LHsExpr TcId), HsWrapper) + -> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId), HsWrapper) tcMatchLambda herald match_ctxt match res_ty = matchExpectedFunTys herald n_pats res_ty $ \ pat_tys rhs_ty -> tcMatches match_ctxt pat_tys rhs_ty match @@ -130,8 +131,8 @@ tcMatchLambda herald match_ctxt match res_ty -- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@. -tcGRHSsPat :: GRHSs Name (LHsExpr Name) -> TcRhoType - -> TcM (GRHSs TcId (LHsExpr TcId)) +tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> TcRhoType + -> TcM (GRHSs GhcTcId (LHsExpr GhcTcId)) -- Used for pattern bindings tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss (mkCheckExpType res_ty) where @@ -187,18 +188,18 @@ tauifyMultipleMatches group exp_tys -- NB: In the empty-match case, this ensures we fill in the ExpType -- | Type-check a MatchGroup. -tcMatches :: (Outputable (body Name)) => TcMatchCtxt body +tcMatches :: (Outputable (body GhcRn)) => TcMatchCtxt body -> [ExpSigmaType] -- Expected pattern types -> ExpRhoType -- Expected result-type of the Match. - -> MatchGroup Name (Located (body Name)) - -> TcM (MatchGroup TcId (Located (body TcId))) + -> MatchGroup GhcRn (Located (body GhcRn)) + -> TcM (MatchGroup GhcTcId (Located (body GhcTcId))) data TcMatchCtxt body -- c.f. TcStmtCtxt, also in this module - = MC { mc_what :: HsMatchContext Name, -- What kind of thing this is - mc_body :: Located (body Name) -- Type checker for a body of + = MC { mc_what :: HsMatchContext Name, -- What kind of thing this is + mc_body :: Located (body GhcRn) -- Type checker for a body of -- an alternative -> ExpRhoType - -> TcM (Located (body TcId)) } + -> TcM (Located (body GhcTcId)) } tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches , mg_origin = origin }) @@ -214,11 +215,11 @@ tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches , mg_origin = origin }) } ------------- -tcMatch :: (Outputable (body Name)) => TcMatchCtxt body +tcMatch :: (Outputable (body GhcRn)) => TcMatchCtxt body -> [ExpSigmaType] -- Expected pattern types -> ExpRhoType -- Expected result-type of the Match. - -> LMatch Name (Located (body Name)) - -> TcM (LMatch TcId (Located (body TcId))) + -> LMatch GhcRn (Located (body GhcRn)) + -> TcM (LMatch GhcTcId (Located (body GhcTcId))) tcMatch ctxt pat_tys rhs_ty match = wrapLocM (tc_match ctxt pat_tys rhs_ty) match @@ -244,8 +245,8 @@ tcMatch ctxt pat_tys rhs_ty match _ -> addErrCtxt (pprMatchInCtxt match) thing_inside ------------- -tcGRHSs :: TcMatchCtxt body -> GRHSs Name (Located (body Name)) -> ExpRhoType - -> TcM (GRHSs TcId (Located (body TcId))) +tcGRHSs :: TcMatchCtxt body -> GRHSs GhcRn (Located (body GhcRn)) -> ExpRhoType + -> TcM (GRHSs GhcTcId (Located (body GhcTcId))) -- Notice that we pass in the full res_ty, so that we get -- good inference from simple things like @@ -261,8 +262,8 @@ tcGRHSs ctxt (GRHSs grhss (L l binds)) res_ty ; return (GRHSs grhss' (L l binds')) } ------------- -tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS Name (Located (body Name)) - -> TcM (GRHS TcId (Located (body TcId))) +tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS GhcRn (Located (body GhcRn)) + -> TcM (GRHS GhcTcId (Located (body GhcTcId))) tcGRHS ctxt res_ty (GRHS guards rhs) = do { (guards', rhs') @@ -281,9 +282,9 @@ tcGRHS ctxt res_ty (GRHS guards rhs) -} tcDoStmts :: HsStmtContext Name - -> Located [LStmt Name (LHsExpr Name)] + -> Located [LStmt GhcRn (LHsExpr GhcRn)] -> ExpRhoType - -> TcM (HsExpr TcId) -- Returns a HsDo + -> TcM (HsExpr GhcTcId) -- Returns a HsDo tcDoStmts ListComp (L l stmts) res_ty = do { res_ty <- expTypeToType res_ty ; (co, elt_ty) <- matchExpectedListTy res_ty @@ -317,7 +318,7 @@ tcDoStmts MonadComp (L l stmts) res_ty tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt) -tcBody :: LHsExpr Name -> ExpRhoType -> TcM (LHsExpr TcId) +tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId) tcBody body res_ty = do { traceTc "tcBody" (ppr res_ty) ; tcMonoExpr body res_ty @@ -336,27 +337,27 @@ type TcCmdStmtChecker = TcStmtChecker HsCmd TcRhoType type TcStmtChecker body rho_type = forall thing. HsStmtContext Name - -> Stmt Name (Located (body Name)) + -> Stmt GhcRn (Located (body GhcRn)) -> rho_type -- Result type for comprehension -> (rho_type -> TcM thing) -- Checker for what follows the stmt - -> TcM (Stmt TcId (Located (body TcId)), thing) + -> TcM (Stmt GhcTcId (Located (body GhcTcId)), thing) -tcStmts :: (Outputable (body Name)) => HsStmtContext Name +tcStmts :: (Outputable (body GhcRn)) => HsStmtContext Name -> TcStmtChecker body rho_type -- NB: higher-rank type - -> [LStmt Name (Located (body Name))] + -> [LStmt GhcRn (Located (body GhcRn))] -> rho_type - -> TcM [LStmt TcId (Located (body TcId))] + -> TcM [LStmt GhcTcId (Located (body GhcTcId))] tcStmts ctxt stmt_chk stmts res_ty = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $ const (return ()) ; return stmts' } -tcStmtsAndThen :: (Outputable (body Name)) => HsStmtContext Name +tcStmtsAndThen :: (Outputable (body GhcRn)) => HsStmtContext Name -> TcStmtChecker body rho_type -- NB: higher-rank type - -> [LStmt Name (Located (body Name))] + -> [LStmt GhcRn (Located (body GhcRn))] -> rho_type -> (rho_type -> TcM thing) - -> TcM ([LStmt TcId (Located (body TcId))], thing) + -> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing) -- Note the higher-rank type. stmt_chk is applied at different -- types in the equations for tcStmts @@ -457,7 +458,8 @@ tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _ _) elt_ty thing_inside = do { (pairs', thing) <- loop bndr_stmts_s ; return (ParStmt pairs' noExpr noSyntaxExpr unitTy, thing) } where - -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing) + -- loop :: [([LStmt GhcRn], [GhcRn])] + -- -> TcM ([([LStmt GhcTcId], [GhcTcId])], thing) loop [] = do { thing <- thing_inside elt_ty ; return ([], thing) } -- matching in the branches @@ -778,7 +780,7 @@ tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op _) res_ty thing_inside -- -> ExpRhoType -- inner_res_ty -- -> [TcType] -- tup_tys -- -> [ParStmtBlock Name] - -- -> TcM ([([LStmt TcId], [TcId])], thing) + -- -> TcM ([([LStmt GhcTcId], [GhcTcId])], thing) loop _ inner_res_ty [] [] = do { thing <- thing_inside inner_res_ty ; return ([], thing) } -- matching in the branches @@ -923,10 +925,10 @@ tcDoStmt _ stmt _ _ -- TcErrors.hs. tcMonadFailOp :: CtOrigin - -> LPat TcId - -> SyntaxExpr Name -- The fail op + -> LPat GhcTcId + -> SyntaxExpr GhcRn -- The fail op -> TcType -- Type of the whole do-expression - -> TcRn (SyntaxExpr TcId) -- Typechecked fail op + -> TcRn (SyntaxExpr GhcTcId) -- Typechecked fail op -- Get a 'fail' operator expression, to use if the pattern -- match fails. If the pattern is irrefutatable, just return -- noSyntaxExpr; it won't be used @@ -950,7 +952,7 @@ tcMonadFailOp orig pat fail_op res_ty ; snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy] (mkCheckExpType res_ty) $ \_ -> return ()) } -emitMonadFailConstraint :: LPat TcId -> TcType -> TcRn () +emitMonadFailConstraint :: LPat GhcTcId -> TcType -> TcRn () emitMonadFailConstraint pat res_ty = do { -- We expect res_ty to be of form (monad_ty arg_ty) (_co, (monad_ty, _arg_ty)) <- matchExpectedAppTy res_ty @@ -962,7 +964,7 @@ emitMonadFailConstraint pat res_ty (mkClassPred monadFailClass [monad_ty]) ; return () } -warnRebindableClash :: LPat TcId -> TcRn () +warnRebindableClash :: LPat GhcTcId -> TcRn () warnRebindableClash pattern = addWarnAt (Reason Opt_WarnMissingMonadFailInstances) (getLoc pattern) @@ -1004,10 +1006,10 @@ join :: tn -> res_ty tcApplicativeStmts :: HsStmtContext Name - -> [(SyntaxExpr Name, ApplicativeArg Name Name)] + -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn GhcRn)] -> ExpRhoType -- rhs_ty -> (TcRhoType -> TcM t) -- thing_inside - -> TcM ([(SyntaxExpr TcId, ApplicativeArg TcId TcId)], Type, t) + -> TcM ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId GhcTcId)], Type, t) tcApplicativeStmts ctxt pairs rhs_ty thing_inside = do { body_ty <- newFlexiTyVarTy liftedTypeKind @@ -1045,8 +1047,8 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside ; ops' <- goOps t_i ops ; return (op' : ops') } - goArg :: (ApplicativeArg Name Name, Type, Type) - -> TcM (ApplicativeArg TcId TcId) + goArg :: (ApplicativeArg GhcRn GhcRn, Type, Type) + -> TcM (ApplicativeArg GhcTcId GhcTcId) goArg (ApplicativeArgOne pat rhs, pat_ty, exp_ty) = setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $ @@ -1067,7 +1069,7 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside } ; return (ApplicativeArgMany stmts' ret' pat') } - get_arg_bndrs :: ApplicativeArg TcId TcId -> [Id] + get_arg_bndrs :: ApplicativeArg GhcTcId GhcTcId -> [Id] get_arg_bndrs (ApplicativeArgOne pat _) = collectPatBinders pat get_arg_bndrs (ApplicativeArgMany _ _ pat) = collectPatBinders pat @@ -1109,7 +1111,7 @@ the variables they bind into scope, and typecheck the thing_inside. number of args are used in each equation. -} -checkArgs :: Name -> MatchGroup Name body -> TcM () +checkArgs :: Name -> MatchGroup GhcRn body -> TcM () checkArgs _ (MG { mg_alts = L _ [] }) = return () checkArgs fun (MG { mg_alts = L _ (match1:matches) }) @@ -1124,5 +1126,5 @@ checkArgs fun (MG { mg_alts = L _ (match1:matches) }) n_args1 = args_in_match match1 bad_matches = [m | m <- matches, args_in_match m /= n_args1] - args_in_match :: LMatch Name body -> Int + args_in_match :: LMatch GhcRn body -> Int args_in_match (L _ (Match _ pats _ _)) = length pats diff --git a/compiler/typecheck/TcMatches.hs-boot b/compiler/typecheck/TcMatches.hs-boot index 3e8dc0277b..812b5107d3 100644 --- a/compiler/typecheck/TcMatches.hs-boot +++ b/compiler/typecheck/TcMatches.hs-boot @@ -3,14 +3,15 @@ import HsSyn ( GRHSs, MatchGroup, LHsExpr ) import TcEvidence( HsWrapper ) import Name ( Name ) import TcType ( ExpRhoType, TcRhoType ) -import TcRnTypes( TcM, TcId ) +import TcRnTypes( TcM ) import SrcLoc ( Located ) +import HsExtension ( GhcRn, GhcTcId ) -tcGRHSsPat :: GRHSs Name (LHsExpr Name) +tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> TcRhoType - -> TcM (GRHSs TcId (LHsExpr TcId)) + -> TcM (GRHSs GhcTcId (LHsExpr GhcTcId)) tcMatchesFun :: Located Name - -> MatchGroup Name (LHsExpr Name) + -> MatchGroup GhcRn (LHsExpr GhcRn) -> ExpRhoType - -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId)) + -> TcM (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId)) diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index 07f945ccf3..faadcb3fa3 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -8,6 +8,7 @@ TcPat: Typechecking patterns {-# LANGUAGE CPP, RankNTypes, TupleSections #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} module TcPat ( tcLetPat, newLetBndr, LetBndrSpec(..) , tcPat, tcPat_O, tcPats @@ -60,9 +61,9 @@ import ListSetOps ( getNth ) tcLetPat :: (Name -> Maybe TcId) -> LetBndrSpec - -> LPat Name -> ExpSigmaType + -> LPat GhcRn -> ExpSigmaType -> TcM a - -> TcM (LPat TcId, a) + -> TcM (LPat GhcTcId, a) tcLetPat sig_fn no_gen pat pat_ty thing_inside = do { bind_lvl <- getTcLevel ; let ctxt = LetPat { pc_lvl = bind_lvl @@ -76,10 +77,10 @@ tcLetPat sig_fn no_gen pat pat_ty thing_inside ----------------- tcPats :: HsMatchContext Name - -> [LPat Name] -- Patterns, + -> [LPat GhcRn] -- Patterns, -> [ExpSigmaType] -- and their types -> TcM a -- and the checker for the body - -> TcM ([LPat TcId], a) + -> TcM ([LPat GhcTcId], a) -- This is the externally-callable wrapper function -- Typecheck the patterns, extend the environment to bind the variables, @@ -98,17 +99,17 @@ tcPats ctxt pats pat_tys thing_inside penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin } tcPat :: HsMatchContext Name - -> LPat Name -> ExpSigmaType + -> LPat GhcRn -> ExpSigmaType -> TcM a -- Checker for body - -> TcM (LPat TcId, a) + -> TcM (LPat GhcTcId, a) tcPat ctxt = tcPat_O ctxt PatOrigin -- | A variant of 'tcPat' that takes a custom origin tcPat_O :: HsMatchContext Name -> CtOrigin -- ^ origin to use if the type needs inst'ing - -> LPat Name -> ExpSigmaType + -> LPat GhcRn -> ExpSigmaType -> TcM a -- Checker for body - -> TcM (LPat TcId, a) + -> TcM (LPat GhcTcId, a) tcPat_O ctxt orig pat pat_ty thing_inside = tc_lpat pat pat_ty penv thing_inside where @@ -292,11 +293,11 @@ tcMultiple tc_pat args penv thing_inside ; loop penv args } -------------------- -tc_lpat :: LPat Name +tc_lpat :: LPat GhcRn -> ExpSigmaType -> PatEnv -> TcM a - -> TcM (LPat TcId, a) + -> TcM (LPat GhcTcId, a) tc_lpat (L span pat) pat_ty penv thing_inside = setSrcSpan span $ do { (pat', res) <- maybeWrapPatCtxt pat (tc_pat penv pat pat_ty) @@ -304,9 +305,9 @@ tc_lpat (L span pat) pat_ty penv thing_inside ; return (L span pat', res) } tc_lpats :: PatEnv - -> [LPat Name] -> [ExpSigmaType] + -> [LPat GhcRn] -> [ExpSigmaType] -> TcM a - -> TcM ([LPat TcId], a) + -> TcM ([LPat GhcTcId], a) tc_lpats penv pats tys thing_inside = ASSERT2( equalLength pats tys, ppr pats $$ ppr tys ) tcMultiple (\(p,t) -> tc_lpat p t) @@ -315,10 +316,10 @@ tc_lpats penv pats tys thing_inside -------------------- tc_pat :: PatEnv - -> Pat Name + -> Pat GhcRn -> ExpSigmaType -- Fully refined result type -> TcM a -- Thing inside - -> TcM (Pat TcId, -- Translated pattern + -> TcM (Pat GhcTcId, -- Translated pattern a) -- Result of thing inside tc_pat penv (VarPat (L l name)) pat_ty thing_inside @@ -496,7 +497,7 @@ tc_pat penv (LitPat simple_lit) pat_ty thing_inside ; wrap <- tcSubTypePat penv pat_ty lit_ty ; res <- thing_inside ; pat_ty <- readExpType pat_ty - ; return ( mkHsWrapPat wrap (LitPat simple_lit) pat_ty + ; return ( mkHsWrapPat wrap (LitPat (convertLit simple_lit)) pat_ty , res) } ------------------------ @@ -702,8 +703,8 @@ to express the local scope of GADT refinements. tcConPat :: PatEnv -> Located Name -> ExpSigmaType -- Type of the pattern - -> HsConPatDetails Name -> TcM a - -> TcM (Pat TcId, a) + -> HsConPatDetails GhcRn -> TcM a + -> TcM (Pat GhcTcId, a) tcConPat penv con_lname@(L _ con_name) pat_ty arg_pats thing_inside = do { con_like <- tcLookupConLike con_name ; case con_like of @@ -715,8 +716,8 @@ tcConPat penv con_lname@(L _ con_name) pat_ty arg_pats thing_inside tcDataConPat :: PatEnv -> Located Name -> DataCon -> ExpSigmaType -- Type of the pattern - -> HsConPatDetails Name -> TcM a - -> TcM (Pat TcId, a) + -> HsConPatDetails GhcRn -> TcM a + -> TcM (Pat GhcTcId, a) tcDataConPat penv (L con_span con_name) data_con pat_ty arg_pats thing_inside = do { let tycon = dataConTyCon data_con -- For data families this is the representation tycon @@ -805,8 +806,8 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty arg_pats thing_inside tcPatSynPat :: PatEnv -> Located Name -> PatSyn -> ExpSigmaType -- Type of the pattern - -> HsConPatDetails Name -> TcM a - -> TcM (Pat TcId, a) + -> HsConPatDetails GhcRn -> TcM a + -> TcM (Pat GhcTcId, a) tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside = do { let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, ty) = patSynSig pat_syn @@ -945,7 +946,7 @@ Suppose (coi, tys) = matchExpectedConType data_tc pat_ty -} tcConArgs :: ConLike -> [TcSigmaType] - -> Checker (HsConPatDetails Name) (HsConPatDetails Id) + -> Checker (HsConPatDetails GhcRn) (HsConPatDetails GhcTc) tcConArgs con_like arg_tys (PrefixCon arg_pats) penv thing_inside = do { checkTc (con_arity == no_of_args) -- Check correct arity @@ -972,8 +973,8 @@ tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside = do { (rpats', res) <- tcMultiple tc_field rpats penv thing_inside ; return (RecCon (HsRecFields rpats' dd), res) } where - tc_field :: Checker (LHsRecField Name (LPat Name)) - (LHsRecField TcId (LPat TcId)) + tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn)) + (LHsRecField GhcTcId (LPat GhcTcId)) tc_field (L l (HsRecField (L loc (FieldOcc (L lr rdr) sel)) pat pun)) penv thing_inside = do { sel' <- tcLookupId sel @@ -1005,7 +1006,7 @@ tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside -- dataConFieldLabels will be empty (and each field in the pattern -- will generate an error below). -tcConArg :: Checker (LPat Name, TcSigmaType) (LPat Id) +tcConArg :: Checker (LPat GhcRn, TcSigmaType) (LPat GhcTc) tcConArg (arg_pat, arg_ty) penv thing_inside = tc_lpat arg_pat (mkCheckExpType arg_ty) penv thing_inside @@ -1129,7 +1130,7 @@ pattern (perhaps deeply) See also Note [Typechecking pattern bindings] in TcBinds -} -maybeWrapPatCtxt :: Pat Name -> (TcM a -> TcM b) -> TcM a -> TcM b +maybeWrapPatCtxt :: Pat GhcRn -> (TcM a -> TcM b) -> TcM a -> TcM b -- Not all patterns are worth pushing a context maybeWrapPatCtxt pat tcm thing_inside | not (worth_wrapping pat) = tcm thing_inside diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index 6d2426fe2a..8f99a23b08 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -7,6 +7,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} module TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl , tcPatSynBuilderBind, tcPatSynBuilderOcc, nonBidirectionalErr @@ -63,8 +64,8 @@ import Data.List( partition ) ************************************************************************ -} -tcInferPatSynDecl :: PatSynBind Name Name - -> TcM (LHsBinds Id, TcGblEnv) +tcInferPatSynDecl :: PatSynBind GhcRn GhcRn + -> TcM (LHsBinds GhcTc, TcGblEnv) tcInferPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details, psb_def = lpat, psb_dir = dir } = addPatSynCtxt lname $ @@ -99,9 +100,9 @@ tcInferPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details, pat_ty rec_fields } -tcCheckPatSynDecl :: PatSynBind Name Name +tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn -> TcPatSynInfo - -> TcM (LHsBinds Id, TcGblEnv) + -> TcM (LHsBinds GhcTc, TcGblEnv) tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details , psb_def = lpat, psb_dir = dir } TPSI{ patsig_implicit_bndrs = implicit_tvs @@ -187,7 +188,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details (args', arg_tys) pat_ty rec_fields } where - tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr TcId) + tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr GhcTcId) tc_arg subst arg_name arg_ty = do { -- Look up the variable actually bound by lpat -- and check that it has the expected type @@ -274,7 +275,8 @@ a pattern synonym. What about the /building/ side? a bad idea. -} -collectPatSynArgInfo :: HsPatSynDetails (Located Name) -> ([Name], [Name], Bool) +collectPatSynArgInfo :: HsPatSynDetails (Located Name) + -> ([Name], [Name], Bool) collectPatSynArgInfo details = case details of PrefixPatSyn names -> (map unLoc names, [], False) @@ -284,7 +286,8 @@ collectPatSynArgInfo details = in (vars, sels, False) where - splitRecordPatSyn :: RecordPatSynField (Located Name) -> (Name, Name) + splitRecordPatSyn :: RecordPatSynField (Located Name) + -> (Name, Name) splitRecordPatSyn (RecordPatSynField { recordPatSynPatVar = L _ patVar , recordPatSynSelectorId = L _ selId }) = (patVar, selId) @@ -305,17 +308,18 @@ wrongNumberOfParmsErr name decl_arity missing ------------------------- -- Shared by both tcInferPatSyn and tcCheckPatSyn -tc_patsyn_finish :: Located Name -- ^ PatSyn Name - -> HsPatSynDir Name -- ^ PatSyn type (Uni/Bidir/ExplicitBidir) +tc_patsyn_finish :: Located Name -- ^ PatSyn Name + -> HsPatSynDir GhcRn -- ^ PatSyn type (Uni/Bidir/ExplicitBidir) -> Bool -- ^ Whether infix - -> LPat Id -- ^ Pattern of the PatSyn + -> LPat GhcTc -- ^ Pattern of the PatSyn -> ([TcTyVarBinder], [PredType], TcEvBinds, [EvVar]) -> ([TcTyVarBinder], [TcType], [PredType], [EvTerm]) - -> ([LHsExpr TcId], [TcType]) -- ^ Pattern arguments and types - -> TcType -- ^ Pattern type - -> [Name] -- ^ Selector names + -> ([LHsExpr GhcTcId], [TcType]) -- ^ Pattern arguments and + -- types + -> TcType -- ^ Pattern type + -> [Name] -- ^ Selector names -- ^ Whether fields, empty if not record PatSyn - -> TcM (LHsBinds Id, TcGblEnv) + -> TcM (LHsBinds GhcTc, TcGblEnv) tc_patsyn_finish lname dir is_infix lpat' (univ_tvs, req_theta, req_ev_binds, req_dicts) (ex_tvs, ex_tys, prov_theta, prov_dicts) @@ -393,12 +397,12 @@ tc_patsyn_finish lname dir is_infix lpat' -} tcPatSynMatcher :: Located Name - -> LPat Id + -> LPat GhcTc -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar]) -> ([TcTyVar], [TcType], ThetaType, [EvTerm]) - -> ([LHsExpr TcId], [TcType]) + -> ([LHsExpr GhcTcId], [TcType]) -> TcType - -> TcM ((Id, Bool), LHsBinds Id) + -> TcM ((Id, Bool), LHsBinds GhcTc) -- See Note [Matchers and builders for pattern synonyms] in PatSyn tcPatSynMatcher (L loc name) lpat (univ_tvs, req_theta, req_ev_binds, req_dicts) @@ -460,6 +464,7 @@ tcPatSynMatcher (L loc name) lpat (mkHsLams (rr_tv:res_tv:univ_tvs) req_dicts body') (noLoc EmptyLocalBinds) + mg :: MatchGroup GhcTc (LHsExpr GhcTc) mg = MG{ mg_alts = L (getLoc match) [match] , mg_arg_tys = [] , mg_res_ty = res_ty @@ -480,7 +485,7 @@ tcPatSynMatcher (L loc name) lpat mkPatSynRecSelBinds :: PatSyn -> [FieldLabel] -- ^ Visible field labels - -> HsValBinds Name + -> HsValBinds GhcRn mkPatSynRecSelBinds ps fields = ValBindsOut selector_binds sigs where @@ -528,8 +533,8 @@ mkPatSynBuilderId dir (L _ name) ; return (Just (builder_id', need_dummy_arg)) } where -tcPatSynBuilderBind :: PatSynBind Name Name - -> TcM (LHsBinds Id) +tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn + -> TcM (LHsBinds GhcTc) -- See Note [Matchers and builders for pattern synonyms] in PatSyn tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat , psb_dir = dir, psb_args = details }) @@ -573,7 +578,7 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat ImplicitBidirectional -> fmap mk_mg (tcPatToExpr args lpat) Unidirectional -> panic "tcPatSynBuilderBind" - mk_mg :: LHsExpr Name -> MatchGroup Name (LHsExpr Name) + mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn) mk_mg body = mkMatchGroup Generated [builder_match] where builder_args = [L loc (VarPat (L loc n)) | L loc n <- args] @@ -586,14 +591,14 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat InfixPatSyn arg1 arg2 -> [arg1, arg2] RecordPatSyn args -> map recordPatSynPatVar args - add_dummy_arg :: MatchGroup Name (LHsExpr Name) - -> MatchGroup Name (LHsExpr Name) + add_dummy_arg :: MatchGroup GhcRn (LHsExpr GhcRn) + -> MatchGroup GhcRn (LHsExpr GhcRn) add_dummy_arg mg@(MG { mg_alts = L l [L loc match@(Match { m_pats = pats })] }) = mg { mg_alts = L l [L loc (match { m_pats = nlWildPatName : pats })] } add_dummy_arg other_mg = pprPanic "add_dummy_arg" $ pprMatches other_mg -tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr TcId, TcSigmaType) +tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr GhcTcId, TcSigmaType) -- monadic only for failure tcPatSynBuilderOcc ps | Just (builder_id, add_void_arg) <- builder @@ -617,7 +622,7 @@ add_void need_dummy_arg ty | need_dummy_arg = mkFunTy voidPrimTy ty | otherwise = ty -tcPatToExpr :: [Located Name] -> LPat Name -> Either MsgDoc (LHsExpr Name) +tcPatToExpr :: [Located Name] -> LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn) -- Given a /pattern/, return an /expression/ that builds a value -- that matches the pattern. E.g. if the pattern is (Just [x]), -- the expression is (Just [x]). They look the same, but the @@ -631,22 +636,23 @@ tcPatToExpr args pat = go pat lhsVars = mkNameSet (map unLoc args) -- Make a prefix con for prefix and infix patterns for simplicity - mkPrefixConExpr :: Located Name -> [LPat Name] -> Either MsgDoc (HsExpr Name) + mkPrefixConExpr :: Located Name -> [LPat GhcRn] + -> Either MsgDoc (HsExpr GhcRn) mkPrefixConExpr lcon@(L loc _) pats = do { exprs <- mapM go pats ; return (foldl (\x y -> HsApp (L loc x) y) (HsVar lcon) exprs) } - mkRecordConExpr :: Located Name -> HsRecFields Name (LPat Name) - -> Either MsgDoc (HsExpr Name) + mkRecordConExpr :: Located Name -> HsRecFields GhcRn (LPat GhcRn) + -> Either MsgDoc (HsExpr GhcRn) mkRecordConExpr con fields = do { exprFields <- mapM go fields ; return (RecordCon con PlaceHolder noPostTcExpr exprFields) } - go :: LPat Name -> Either MsgDoc (LHsExpr Name) + go :: LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn) go (L loc p) = L loc <$> go1 p - go1 :: Pat Name -> Either MsgDoc (HsExpr Name) + go1 :: Pat GhcRn -> Either MsgDoc (HsExpr GhcRn) go1 (ConPatIn con info) = case info of PrefixCon ps -> mkPrefixConExpr con ps @@ -766,13 +772,13 @@ Any change to this ordering should make sure to change deSugar/DsExpr.hs if you want to avoid difficult to decipher core lint errors! -} -tcCheckPatSynPat :: LPat Name -> TcM () +tcCheckPatSynPat :: LPat GhcRn -> TcM () tcCheckPatSynPat = go where - go :: LPat Name -> TcM () + go :: LPat GhcRn -> TcM () go = addLocM go1 - go1 :: Pat Name -> TcM () + go1 :: Pat GhcRn -> TcM () go1 (ConPatIn _ info) = mapM_ go (hsConPatArgs info) go1 VarPat{} = return () go1 WildPat{} = return () @@ -798,13 +804,13 @@ tcCheckPatSynPat = go go1 SigPatOut{} = panic "SigPatOut in output of renamer" go1 CoPat{} = panic "CoPat in output of renamer" -asPatInPatSynErr :: (OutputableBndrId name) => Pat name -> TcM a +asPatInPatSynErr :: (SourceTextX p, OutputableBndrId p) => Pat p -> TcM a asPatInPatSynErr pat = failWithTc $ hang (text "Pattern synonym definition cannot contain as-patterns (@):") 2 (ppr pat) -nPlusKPatInPatSynErr :: (OutputableBndrId name) => Pat name -> TcM a +nPlusKPatInPatSynErr :: (SourceTextX p, OutputableBndrId p) => Pat p -> TcM a nPlusKPatInPatSynErr pat = failWithTc $ hang (text "Pattern synonym definition cannot contain n+k-pattern:") @@ -822,17 +828,17 @@ nonBidirectionalErr name = failWithTc $ -- in generating matcher functions, since success continuations need -- to be passed these pattern-bound evidences. tcCollectEx - :: LPat Id + :: LPat GhcTc -> ( [TyVar] -- Existentially-bound type variables -- in correctly-scoped order; e.g. [ k:*, x:k ] , [EvVar] ) -- and evidence variables tcCollectEx pat = go pat where - go :: LPat Id -> ([TyVar], [EvVar]) + go :: LPat GhcTc -> ([TyVar], [EvVar]) go = go1 . unLoc - go1 :: Pat Id -> ([TyVar], [EvVar]) + go1 :: Pat GhcTc -> ([TyVar], [EvVar]) go1 (LazyPat p) = go p go1 (AsPat _ p) = go p go1 (ParPat p) = go p @@ -850,13 +856,13 @@ tcCollectEx pat = go pat = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract go1 _ = empty - goConDetails :: HsConPatDetails Id -> ([TyVar], [EvVar]) + goConDetails :: HsConPatDetails GhcTc -> ([TyVar], [EvVar]) goConDetails (PrefixCon ps) = mergeMany . map go $ ps goConDetails (InfixCon p1 p2) = go p1 `merge` go p2 goConDetails (RecCon HsRecFields{ rec_flds = flds }) = mergeMany . map goRecFd $ flds - goRecFd :: LHsRecField Id (LPat Id) -> ([TyVar], [EvVar]) + goRecFd :: LHsRecField GhcTc (LPat GhcTc) -> ([TyVar], [EvVar]) goRecFd (L _ HsRecField{ hsRecFieldArg = p }) = go p merge (vs1, evs1) (vs2, evs2) = (vs1 ++ vs2, evs1 ++ evs2) diff --git a/compiler/typecheck/TcPatSyn.hs-boot b/compiler/typecheck/TcPatSyn.hs-boot index 18914bc2ec..5db79fcbbb 100644 --- a/compiler/typecheck/TcPatSyn.hs-boot +++ b/compiler/typecheck/TcPatSyn.hs-boot @@ -1,19 +1,18 @@ module TcPatSyn where -import Name ( Name ) -import Id ( Id ) import HsSyn ( PatSynBind, LHsBinds ) import TcRnTypes ( TcM, TcPatSynInfo ) import TcRnMonad ( TcGblEnv) import Outputable ( Outputable ) +import HsExtension ( GhcRn, GhcTc ) -tcInferPatSynDecl :: PatSynBind Name Name - -> TcM (LHsBinds Id, TcGblEnv) +tcInferPatSynDecl :: PatSynBind GhcRn GhcRn + -> TcM (LHsBinds GhcTc, TcGblEnv) -tcCheckPatSynDecl :: PatSynBind Name Name +tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn -> TcPatSynInfo - -> TcM (LHsBinds Id, TcGblEnv) + -> TcM (LHsBinds GhcTc, TcGblEnv) -tcPatSynBuilderBind :: PatSynBind Name Name -> TcM (LHsBinds Id) +tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc) nonBidirectionalErr :: Outputable name => name -> TcM a diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index bd0ee17574..4948703174 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -12,6 +12,7 @@ https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/TypeChecker {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} module TcRnDriver ( tcRnStmt, tcRnExpr, TcRnExprMode(..), tcRnType, @@ -301,7 +302,7 @@ implicitPreludeWarn ************************************************************************ -} -tcRnImports :: HscEnv -> [LImportDecl RdrName] -> TcM TcGblEnv +tcRnImports :: HscEnv -> [LImportDecl GhcPs] -> TcM TcGblEnv tcRnImports hsc_env import_decls = do { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ; @@ -378,7 +379,7 @@ tcRnImports hsc_env import_decls -} tcRnSrcDecls :: Bool -- False => no 'module M(..) where' header at all - -> [LHsDecl RdrName] -- Declarations + -> [LHsDecl GhcPs] -- Declarations -> TcM TcGblEnv tcRnSrcDecls explicit_mod_hdr decls = do { -- Do all the declarations @@ -479,7 +480,7 @@ run_th_modfinalizers = do -- addTopDecls can add declarations which add new finalizers. run_th_modfinalizers -tc_rn_src_decls :: [LHsDecl RdrName] +tc_rn_src_decls :: [LHsDecl GhcPs] -> TcM (TcGblEnv, TcLclEnv) -- Loops around dealing with each top level inter-splice group -- in turn, until it's dealt with the entire module @@ -558,7 +559,7 @@ tc_rn_src_decls ds ************************************************************************ -} -tcRnHsBootDecls :: HscSource -> [LHsDecl RdrName] -> TcM TcGblEnv +tcRnHsBootDecls :: HscSource -> [LHsDecl GhcPs] -> TcM TcGblEnv tcRnHsBootDecls hsc_src decls = do { (first_group, group_tail) <- findSplice decls @@ -1288,7 +1289,7 @@ instMisMatch is_boot inst ************************************************************************ -} -rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name) +rnTopSrcDecls :: HsGroup GhcPs -> TcM (TcGblEnv, HsGroup GhcRn) -- Fails if there are any errors rnTopSrcDecls group = do { -- Rename the source decls @@ -1308,7 +1309,7 @@ rnTopSrcDecls group return (tcg_env', rn_decls) } -tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv) +tcTopSrcDecls :: HsGroup GhcRn -> TcM (TcGblEnv, TcLclEnv) tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, hs_derivds = deriv_decls, hs_fords = foreign_decls, @@ -1485,31 +1486,31 @@ tcPreludeClashWarn warnFlag name = do -- c) Prelude is imported hiding the name in question. Issue no warnings. -- d) Qualified import of Prelude, no warnings. importedViaPrelude :: Name - -> [ImportDecl Name] + -> [ImportDecl GhcRn] -> Bool importedViaPrelude name = any importViaPrelude where - isPrelude :: ImportDecl Name -> Bool + isPrelude :: ImportDecl GhcRn -> Bool isPrelude imp = unLoc (ideclName imp) == pRELUDE_NAME -- Implicit (Prelude) import? - isImplicit :: ImportDecl Name -> Bool + isImplicit :: ImportDecl GhcRn -> Bool isImplicit = ideclImplicit -- Unqualified import? - isUnqualified :: ImportDecl Name -> Bool + isUnqualified :: ImportDecl GhcRn -> Bool isUnqualified = not . ideclQualified -- List of explicitly imported (or hidden) Names from a single import. -- Nothing -> No explicit imports -- Just (False, <names>) -> Explicit import list of <names> -- Just (True , <names>) -> Explicit hiding of <names> - importListOf :: ImportDecl Name -> Maybe (Bool, [Name]) + importListOf :: ImportDecl GhcRn -> Maybe (Bool, [Name]) importListOf = fmap toImportList . ideclHiding where toImportList (h, loc) = (h, map (ieName . unLoc) (unLoc loc)) - isExplicit :: ImportDecl Name -> Bool + isExplicit :: ImportDecl GhcRn -> Bool isExplicit x = case importListOf x of Nothing -> False Just (False, explicit) @@ -1519,7 +1520,7 @@ tcPreludeClashWarn warnFlag name = do -- Check whether the given name would be imported (unqualified) from -- an import declaration. - importViaPrelude :: ImportDecl Name -> Bool + importViaPrelude :: ImportDecl GhcRn -> Bool importViaPrelude x = isPrelude x && isUnqualified x && (isImplicit x || isExplicit x) @@ -1598,13 +1599,15 @@ tcMissingParentClassWarn warnFlag isName shouldName --------------------------- -tcTyClsInstDecls :: [TyClGroup Name] - -> [LDerivDecl Name] - -> [(RecFlag, LHsBinds Name)] +tcTyClsInstDecls :: [TyClGroup GhcRn] + -> [LDerivDecl GhcRn] + -> [(RecFlag, LHsBinds GhcRn)] -> TcM (TcGblEnv, -- The full inst env - [InstInfo Name], -- Source-code instance decls to process; - -- contains all dfuns for this module - HsValBinds Name) -- Supporting bindings for derived instances + [InstInfo GhcRn], -- Source-code instance decls to + -- process; contains all dfuns for + -- this module + HsValBinds GhcRn) -- Supporting bindings for derived + -- instances tcTyClsInstDecls tycl_decls deriv_decls binds = tcAddDataFamConPlaceholders (tycl_decls >>= group_instds) $ @@ -1869,8 +1872,8 @@ We don't bother with the tcl_th_bndrs environment either. -- -- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound -- values, coerced to (). -tcRnStmt :: HscEnv -> GhciLStmt RdrName - -> IO (Messages, Maybe ([Id], LHsExpr Id, FixityEnv)) +tcRnStmt :: HscEnv -> GhciLStmt GhcPs + -> IO (Messages, Maybe ([Id], LHsExpr GhcTc, FixityEnv)) tcRnStmt hsc_env rdr_stmt = runTcInteractive hsc_env $ do { @@ -1945,7 +1948,7 @@ Here is the grand plan, implemented in tcUserStmt -} -- | A plan is an attempt to lift some code into the IO monad. -type PlanResult = ([Id], LHsExpr Id) +type PlanResult = ([Id], LHsExpr GhcTc) type Plan = TcM PlanResult -- | Try the plans in order. If one fails (by raising an exn), try the next. @@ -1963,7 +1966,7 @@ runPlans (p:ps) = tryTcDiscardingErrs (runPlans ps) p -- in GHCi] in HscTypes for more details. We do this lifting by trying -- different ways ('plans') of lifting the code into the IO monad and -- type checking each plan until one succeeds. -tcUserStmt :: GhciLStmt RdrName -> TcM (PlanResult, FixityEnv) +tcUserStmt :: GhciLStmt GhcPs -> TcM (PlanResult, FixityEnv) -- An expression typed at the prompt is treated very specially tcUserStmt (L loc (BodyStmt expr _ _ _)) @@ -2069,7 +2072,7 @@ tcUserStmt rdr_stmt@(L loc _) -- | Typecheck the statements given and then return the results of the -- statement in the form 'IO [()]'. -tcGhciStmts :: [GhciLStmt Name] -> TcM PlanResult +tcGhciStmts :: [GhciLStmt GhcRn] -> TcM PlanResult tcGhciStmts stmts = do { ioTyCon <- tcLookupTyCon ioTyConName ; ret_id <- tcLookupId returnIOName ; -- return @ IO @@ -2119,7 +2122,7 @@ tcGhciStmts stmts } -- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a) -getGhciStepIO :: TcM (LHsExpr Name) +getGhciStepIO :: TcM (LHsExpr GhcRn) getGhciStepIO = do ghciTy <- getGHCiMonad a_tv <- newName (mkTyVarOccFS (fsLit "a")) @@ -2129,7 +2132,7 @@ getGhciStepIO = do step_ty = noLoc $ HsForAllTy { hst_bndrs = [noLoc $ UserTyVar (noLoc a_tv)] , hst_body = nlHsFunTy ghciM ioM } - stepTy :: LHsSigWcType Name + stepTy :: LHsSigWcType GhcRn stepTy = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs step_ty) return (noLoc $ ExprWithTySig (nlHsVar ghciStepIoMName) stepTy) @@ -2159,7 +2162,7 @@ data TcRnExprMode = TM_Inst -- ^ Instantiate the type fully (:type) -- | tcRnExpr just finds the type of an expression tcRnExpr :: HscEnv -> TcRnExprMode - -> LHsExpr RdrName + -> LHsExpr GhcPs -> IO (Messages, Maybe Type) tcRnExpr hsc_env mode rdr_expr = runTcInteractive hsc_env $ @@ -2213,7 +2216,7 @@ tcRnExpr hsc_env mode rdr_expr -------------------------- tcRnImportDecls :: HscEnv - -> [LImportDecl RdrName] + -> [LImportDecl GhcPs] -> IO (Messages, Maybe GlobalRdrEnv) -- Find the new chunk of GlobalRdrEnv created by this list of import -- decls. In contract tcRnImports *extends* the TcGblEnv. @@ -2228,7 +2231,7 @@ tcRnImportDecls hsc_env import_decls -- tcRnType just finds the kind of a type tcRnType :: HscEnv -> Bool -- Normalise the returned type - -> LHsType RdrName + -> LHsType GhcPs -> IO (Messages, Maybe (Type, Kind)) tcRnType hsc_env normalise rdr_type = runTcInteractive hsc_env $ @@ -2352,7 +2355,7 @@ tcRnDeclsi exists to allow class, data, and other declarations in GHCi. -} tcRnDeclsi :: HscEnv - -> [LHsDecl RdrName] + -> [LHsDecl GhcPs] -> IO (Messages, Maybe TcGblEnv) tcRnDeclsi hsc_env local_decls = runTcInteractive hsc_env $ diff --git a/compiler/typecheck/TcRnExports.hs b/compiler/typecheck/TcRnExports.hs index 7fd9a51b1a..3965675b77 100644 --- a/compiler/typecheck/TcRnExports.hs +++ b/compiler/typecheck/TcRnExports.hs @@ -1,6 +1,8 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} module TcRnExports (tcRnExports, exports_from_avail) where import HsSyn @@ -89,22 +91,22 @@ You just have to use an explicit export list: data ExportAccum -- The type of the accumulating parameter of -- the main worker function in rnExports = ExportAccum - [LIE Name] -- Export items with Names + [LIE GhcRn] -- Export items with Names ExportOccMap -- Tracks exported occurrence names [AvailInfo] -- The accumulated exported stuff - -- Not nub'd! + -- Not nub'd! emptyExportAccum :: ExportAccum emptyExportAccum = ExportAccum [] emptyOccEnv [] -type ExportOccMap = OccEnv (Name, IE RdrName) +type ExportOccMap = OccEnv (Name, IE GhcPs) -- Tracks what a particular exported OccName -- in an export list refers to, and which item -- it came from. It's illegal to export two distinct things -- that have the same occurrence name tcRnExports :: Bool -- False => no 'module M(..) where' header at all - -> Maybe (Located [LIE RdrName]) -- Nothing => no explicit export list + -> Maybe (Located [LIE GhcPs]) -- Nothing => no explicit export list -> TcGblEnv -> RnM TcGblEnv @@ -160,7 +162,7 @@ tcRnExports explicit_mod exports ; failIfErrsM ; return new_tcg_env } -exports_from_avail :: Maybe (Located [LIE RdrName]) +exports_from_avail :: Maybe (Located [LIE GhcPs]) -- Nothing => no explicit export list -> GlobalRdrEnv -> ImportAvails @@ -168,7 +170,7 @@ exports_from_avail :: Maybe (Located [LIE RdrName]) -- 'module Foo' export is valid (it's not valid -- if we didn't import Foo!) -> Module - -> RnM (Maybe [LIE Name], [AvailInfo]) + -> RnM (Maybe [LIE GhcRn], [AvailInfo]) exports_from_avail Nothing rdr_env _imports _this_mod -- The same as (module M) where M is the current module name, @@ -200,7 +202,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod let final_exports = nubAvails exports -- Combine families return (Just ie_names, final_exports) where - do_litem :: ExportAccum -> LIE RdrName -> RnM ExportAccum + do_litem :: ExportAccum -> LIE GhcPs -> RnM ExportAccum do_litem acc lie = setSrcSpan (getLoc lie) (exports_from_item acc lie) -- Maps a parent to its in-scope children @@ -212,7 +214,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod | xs <- moduleEnvElts $ imp_mods imports , imv <- importedByUser xs ] - exports_from_item :: ExportAccum -> LIE RdrName -> RnM ExportAccum + exports_from_item :: ExportAccum -> LIE GhcPs -> RnM ExportAccum exports_from_item acc@(ExportAccum ie_names occs exports) (L loc (IEModuleContents (L lm mod))) | let earlier_mods = [ mod @@ -270,7 +272,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod return (ExportAccum (L loc new_ie : lie_names) occs' (avail : exports)) ------------- - lookup_ie :: IE RdrName -> RnM (IE Name, AvailInfo) + lookup_ie :: IE GhcPs -> RnM (IE GhcRn, AvailInfo) lookup_ie (IEVar (L l rdr)) = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr return (IEVar (L l (replaceWrappedName rdr name)), avail) @@ -318,7 +320,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod else return (L l name, non_flds , map unLoc non_flds , map unLoc flds) - lookup_ie_all :: IE RdrName -> LIEWrappedName RdrName + lookup_ie_all :: IE GhcPs -> LIEWrappedName RdrName -> RnM (Located Name, [Name], [FieldLabel]) lookup_ie_all ie (L l rdr) = do name <- lookupGlobalOccRn $ ieWrappedName rdr @@ -337,7 +339,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod return (L l name, non_flds, flds) ------------- - lookup_doc_ie :: IE RdrName -> RnM (IE Name) + lookup_doc_ie :: IE GhcPs -> RnM (IE GhcRn) lookup_doc_ie (IEGroup lev doc) = do rn_doc <- rnHsDoc doc return (IEGroup lev rn_doc) lookup_doc_ie (IEDoc doc) = do rn_doc <- rnHsDoc doc @@ -362,7 +364,7 @@ classifyGRE gre = case gre_par gre of where n = gre_name gre -isDoc :: IE RdrName -> Bool +isDoc :: IE GhcPs -> Bool isDoc (IEDoc _) = True isDoc (IEDocNamed _) = True isDoc (IEGroup _ _) = True @@ -580,7 +582,7 @@ checkPatSynParent parent mpat_syn {-===========================================================================-} -check_occs :: IE RdrName -> ExportOccMap -> [Name] -> RnM ExportOccMap +check_occs :: IE GhcPs -> ExportOccMap -> [Name] -> RnM ExportOccMap check_occs ie occs names -- 'names' are the entities specifed by 'ie' = foldlM check occs names where @@ -605,7 +607,7 @@ check_occs ie occs names -- 'names' are the entities specifed by 'ie' name_occ = nameOccName name -dupExport_ok :: Name -> IE RdrName -> IE RdrName -> Bool +dupExport_ok :: Name -> IE GhcPs -> IE GhcPs -> Bool -- The Name is exported by both IEs. Is that ok? -- "No" iff the name is mentioned explicitly in both IEs -- or one of the IEs mentions the name *alone* @@ -663,25 +665,26 @@ nullModuleExport mod dodgyExportWarn :: Name -> SDoc -dodgyExportWarn item = dodgyMsg (text "export") item +dodgyExportWarn item + = dodgyMsg (text "export") item (dodgyMsgInsert item :: IE GhcRn) exportErrCtxt :: Outputable o => String -> o -> SDoc exportErrCtxt herald exp = text "In the" <+> text (herald ++ ":") <+> ppr exp -addExportErrCtxt :: (HasOccName s, OutputableBndr s) => IE s -> TcM a -> TcM a +addExportErrCtxt :: (OutputableBndrId s) => IE s -> TcM a -> TcM a addExportErrCtxt ie = addErrCtxt exportCtxt where exportCtxt = text "In the export:" <+> ppr ie -exportItemErr :: IE RdrName -> SDoc +exportItemErr :: IE GhcPs -> SDoc exportItemErr export_item = sep [ text "The export item" <+> quotes (ppr export_item), text "attempts to export constructors or class methods that are not visible here" ] -dupExportWarn :: OccName -> IE RdrName -> IE RdrName -> SDoc +dupExportWarn :: OccName -> IE GhcPs -> IE GhcPs -> SDoc dupExportWarn occ_name ie1 ie2 = hsep [quotes (ppr occ_name), text "is exported by", quotes (ppr ie1), @@ -711,7 +714,7 @@ mkDcErrMsg parent thing thing_doc parents = do tyThingCategory' i = tyThingCategory i -exportClashErr :: GlobalRdrEnv -> Name -> Name -> IE RdrName -> IE RdrName +exportClashErr :: GlobalRdrEnv -> Name -> Name -> IE GhcPs -> IE GhcPs -> MsgDoc exportClashErr global_env name1 name2 ie1 ie2 = vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 651e73581c..8d59303883 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -410,8 +410,8 @@ data DsMetaVal -- Will be dynamically alpha renamed. -- The Id has type THSyntax.Var - | DsSplice (HsExpr Id) -- These bindings are introduced by - -- the PendingSplices on a HsBracketOut + | DsSplice (HsExpr GhcTc) -- These bindings are introduced by + -- the PendingSplices on a HsBracketOut {- @@ -616,22 +616,22 @@ data TcGblEnv -- The binds, rules and foreign-decl fields are collected -- initially in un-zonked form and are finally zonked in tcRnSrcDecls - tcg_rn_exports :: Maybe [Located (IE Name)], + tcg_rn_exports :: Maybe [Located (IE GhcRn)], -- Nothing <=> no explicit export list -- Is always Nothing if we don't want to retain renamed -- exports - tcg_rn_imports :: [LImportDecl Name], + tcg_rn_imports :: [LImportDecl GhcRn], -- Keep the renamed imports regardless. They are not -- voluminous and are needed if you want to report unused imports - tcg_rn_decls :: Maybe (HsGroup Name), + tcg_rn_decls :: Maybe (HsGroup GhcRn), -- ^ Renamed decls, maybe. @Nothing@ <=> Don't retain renamed -- decls. tcg_dependent_files :: TcRef [FilePath], -- ^ dependencies from addDependentFile - tcg_th_topdecls :: TcRef [LHsDecl RdrName], + tcg_th_topdecls :: TcRef [LHsDecl GhcPs], -- ^ Top-level declarations from addTopDecls tcg_th_foreign_files :: TcRef [(ForeignSrcLang, String)], @@ -655,10 +655,10 @@ data TcGblEnv -- Things defined in this module, or (in GHCi) -- in the declarations for a single GHCi command. -- For the latter, see Note [The interactive package] in HscTypes - tcg_tr_module :: Maybe Id, -- Id for $trModule :: GHC.Types.Module + tcg_tr_module :: Maybe Id, -- Id for $trModule :: GHC.Types.Module -- for which every module has a top-level defn -- except in GHCi in which case we have Nothing - tcg_binds :: LHsBinds Id, -- Value bindings in this module + tcg_binds :: LHsBinds GhcTc, -- Value bindings in this module tcg_sigs :: NameSet, -- ...Top-level names that *lack* a signature tcg_imp_specs :: [LTcSpecPrag], -- ...SPECIALISE prags for imported Ids tcg_warns :: Warnings, -- ...Warnings and deprecations @@ -666,10 +666,10 @@ data TcGblEnv tcg_tcs :: [TyCon], -- ...TyCons and Classes tcg_insts :: [ClsInst], -- ...Instances tcg_fam_insts :: [FamInst], -- ...Family instances - tcg_rules :: [LRuleDecl Id], -- ...Rules - tcg_fords :: [LForeignDecl Id], -- ...Foreign import & exports - tcg_vects :: [LVectDecl Id], -- ...Vectorisation declarations - tcg_patsyns :: [PatSyn], -- ...Pattern synonyms + tcg_rules :: [LRuleDecl GhcTc], -- ...Rules + tcg_fords :: [LForeignDecl GhcTc], -- ...Foreign import & exports + tcg_vects :: [LVectDecl GhcTc], -- ...Vectorisation declarations + tcg_patsyns :: [PatSyn], -- ...Pattern synonyms tcg_doc_hdr :: Maybe LHsDocString, -- ^ Maybe Haddock header docs tcg_hpc :: AnyHpcUsage, -- ^ @True@ if any part of the @@ -1385,8 +1385,9 @@ data TcIdSigInfo -- See Note [Complete and partial type signatures] -- wildcards). In this case it doesn't make sense to give -- the polymorphic Id, because we are going to /infer/ its -- type, so we can't make the polymorphic Id ab-initio - { psig_name :: Name -- Name of the function; used when report wildcards - , psig_hs_ty :: LHsSigWcType Name -- The original partial signature in HsSyn form + { psig_name :: Name -- Name of the function; used when report wildcards + , psig_hs_ty :: LHsSigWcType GhcRn -- The original partial signature in + -- HsSyn form , sig_ctxt :: UserTypeCtxt , sig_loc :: SrcSpan -- Location of the type signature } @@ -3101,19 +3102,19 @@ data CtOrigin | IPOccOrigin HsIPName -- Occurrence of an implicit parameter | OverLabelOrigin FastString -- Occurrence of an overloaded label - | LiteralOrigin (HsOverLit Name) -- Occurrence of a literal + | LiteralOrigin (HsOverLit GhcRn) -- Occurrence of a literal | NegateOrigin -- Occurrence of syntactic negation - | ArithSeqOrigin (ArithSeqInfo Name) -- [x..], [x..y] etc - | PArrSeqOrigin (ArithSeqInfo Name) -- [:x..y:] and [:x,y..z:] + | ArithSeqOrigin (ArithSeqInfo GhcRn) -- [x..], [x..y] etc + | PArrSeqOrigin (ArithSeqInfo GhcRn) -- [:x..y:] and [:x,y..z:] | SectionOrigin | TupleOrigin -- (..,..) | ExprSigOrigin -- e :: ty | PatSigOrigin -- p :: ty | PatOrigin -- Instantiating a polytyped pattern at a constructor | ProvCtxtOrigin -- The "provided" context of a pattern synonym signature - (PatSynBind Name Name) -- Information about the pattern synonym, in particular - -- the name and the right-hand side + (PatSynBind GhcRn GhcRn) -- Information about the pattern synonym, in + -- particular the name and the right-hand side | RecordUpdOrigin | ViewPatOrigin @@ -3131,11 +3132,11 @@ data CtOrigin | StandAloneDerivOrigin -- Typechecking stand-alone deriving | DefaultOrigin -- Typechecking a default decl | DoOrigin -- Arising from a do expression - | DoPatOrigin (LPat Name) -- Arising from a failable pattern in - -- a do expression + | DoPatOrigin (LPat GhcRn) -- Arising from a failable pattern in + -- a do expression | MCompOrigin -- Arising from a monad comprehension - | MCompPatOrigin (LPat Name) -- Arising from a failable pattern in a - -- monad comprehension + | MCompPatOrigin (LPat GhcRn) -- Arising from a failable pattern in a + -- monad comprehension | IfOrigin -- Arising from an if statement | ProcOrigin -- Arising from a proc expression | AnnOrigin -- An annotation @@ -3154,9 +3155,10 @@ data CtOrigin | UnboundOccurrenceOf OccName | ListOrigin -- An overloaded list | StaticOrigin -- A static form - | FailablePattern (LPat TcId) -- A failable pattern in do-notation for the - -- MonadFail Proposal (MFP). Obsolete when - -- actual desugaring to MonadFail.fail is live. + | FailablePattern (LPat GhcTcId) -- A failable pattern in do-notation for the + -- MonadFail Proposal (MFP). Obsolete when + -- actual desugaring to MonadFail.fail is + -- live. | Shouldn'tHappenOrigin String -- the user should never see this one, -- unless ImpredicativeTypes is on, where all @@ -3206,10 +3208,10 @@ ctoHerald :: SDoc ctoHerald = text "arising from" -- | Extract a suitable CtOrigin from a HsExpr -lexprCtOrigin :: LHsExpr Name -> CtOrigin +lexprCtOrigin :: LHsExpr GhcRn -> CtOrigin lexprCtOrigin (L _ e) = exprCtOrigin e -exprCtOrigin :: HsExpr Name -> CtOrigin +exprCtOrigin :: HsExpr GhcRn -> CtOrigin exprCtOrigin (HsVar (L _ name)) = OccurrenceOf name exprCtOrigin (HsUnboundVar uv) = UnboundOccurrenceOf (unboundVarOcc uv) exprCtOrigin (HsConLikeOut {}) = panic "exprCtOrigin HsConLikeOut" @@ -3264,7 +3266,7 @@ exprCtOrigin (ELazyPat {}) = panic "exprCtOrigin ELazyPat" exprCtOrigin (HsWrap {}) = panic "exprCtOrigin HsWrap" -- | Extract a suitable CtOrigin from a MatchGroup -matchesCtOrigin :: MatchGroup Name (LHsExpr Name) -> CtOrigin +matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin matchesCtOrigin (MG { mg_alts = alts }) | L _ [L _ match] <- alts , Match { m_grhss = grhss } <- match @@ -3274,11 +3276,11 @@ matchesCtOrigin (MG { mg_alts = alts }) = Shouldn'tHappenOrigin "multi-way match" -- | Extract a suitable CtOrigin from guarded RHSs -grhssCtOrigin :: GRHSs Name (LHsExpr Name) -> CtOrigin +grhssCtOrigin :: GRHSs GhcRn (LHsExpr GhcRn) -> CtOrigin grhssCtOrigin (GRHSs { grhssGRHSs = lgrhss }) = lGRHSCtOrigin lgrhss -- | Extract a suitable CtOrigin from a list of guarded RHSs -lGRHSCtOrigin :: [LGRHS Name (LHsExpr Name)] -> CtOrigin +lGRHSCtOrigin :: [LGRHS GhcRn (LHsExpr GhcRn)] -> CtOrigin lGRHSCtOrigin [L _ (GRHS _ (L _ e))] = exprCtOrigin e lGRHSCtOrigin _ = Shouldn'tHappenOrigin "multi-way GRHS" @@ -3482,9 +3484,9 @@ data TcPluginResult * * ********************************************************************* -} -type RoleAnnotEnv = NameEnv (LRoleAnnotDecl Name) +type RoleAnnotEnv = NameEnv (LRoleAnnotDecl GhcRn) -mkRoleAnnotEnv :: [LRoleAnnotDecl Name] -> RoleAnnotEnv +mkRoleAnnotEnv :: [LRoleAnnotDecl GhcRn] -> RoleAnnotEnv mkRoleAnnotEnv role_annot_decls = mkNameEnv [ (name, ra_decl) | ra_decl <- role_annot_decls @@ -3496,10 +3498,11 @@ mkRoleAnnotEnv role_annot_decls emptyRoleAnnotEnv :: RoleAnnotEnv emptyRoleAnnotEnv = emptyNameEnv -lookupRoleAnnot :: RoleAnnotEnv -> Name -> Maybe (LRoleAnnotDecl Name) +lookupRoleAnnot :: RoleAnnotEnv -> Name -> Maybe (LRoleAnnotDecl GhcRn) lookupRoleAnnot = lookupNameEnv -getRoleAnnots :: [Name] -> RoleAnnotEnv -> ([LRoleAnnotDecl Name], RoleAnnotEnv) +getRoleAnnots :: [Name] -> RoleAnnotEnv + -> ([LRoleAnnotDecl GhcRn], RoleAnnotEnv) getRoleAnnots bndrs role_env = ( mapMaybe (lookupRoleAnnot role_env) bndrs , delListFromNameEnv role_env bndrs ) diff --git a/compiler/typecheck/TcRules.hs b/compiler/typecheck/TcRules.hs index d80321cb39..5f47764aa8 100644 --- a/compiler/typecheck/TcRules.hs +++ b/compiler/typecheck/TcRules.hs @@ -7,6 +7,7 @@ TcRules: Typechecking transformation rules -} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} module TcRules ( tcRules ) where @@ -23,7 +24,6 @@ import TcEvidence( mkTcCoVarCo ) import Type import Id import Var( EvVar ) -import Name import BasicTypes ( RuleName ) import SrcLoc import Outputable @@ -49,15 +49,15 @@ an example (test simplCore/should_compile/rule2.hs) produced by Roman: He wanted the rule to typecheck. -} -tcRules :: [LRuleDecls Name] -> TcM [LRuleDecls TcId] +tcRules :: [LRuleDecls GhcRn] -> TcM [LRuleDecls GhcTcId] tcRules decls = mapM (wrapLocM tcRuleDecls) decls -tcRuleDecls :: RuleDecls Name -> TcM (RuleDecls TcId) +tcRuleDecls :: RuleDecls GhcRn -> TcM (RuleDecls GhcTcId) tcRuleDecls (HsRules src decls) = do { tc_decls <- mapM (wrapLocM tcRule) decls ; return (HsRules src tc_decls) } -tcRule :: RuleDecl Name -> TcM (RuleDecl TcId) +tcRule :: RuleDecl GhcRn -> TcM (RuleDecl GhcTcId) tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs) = addErrCtxt (ruleCtxt $ snd $ unLoc name) $ do { traceTc "---- Rule ------" (pprFullRuleName name) @@ -131,7 +131,7 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs) (mkHsDictLet lhs_binds lhs') fv_lhs (mkHsDictLet rhs_binds rhs') fv_rhs) } -tcRuleBndrs :: [LRuleBndr Name] -> TcM [Var] +tcRuleBndrs :: [LRuleBndr GhcRn] -> TcM [Var] tcRuleBndrs [] = return [] tcRuleBndrs (L _ (RuleBndr (L _ name)) : rule_bndrs) diff --git a/compiler/typecheck/TcSigs.hs b/compiler/typecheck/TcSigs.hs index 0a8fb5e35c..9cd8cfa690 100644 --- a/compiler/typecheck/TcSigs.hs +++ b/compiler/typecheck/TcSigs.hs @@ -5,6 +5,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} module TcSigs( TcSigInfo(..), @@ -171,7 +172,7 @@ completeSigPolyId_maybe sig * * ********************************************************************* -} -tcTySigs :: [LSig Name] -> TcM ([TcId], TcSigFun) +tcTySigs :: [LSig GhcRn] -> TcM ([TcId], TcSigFun) tcTySigs hs_sigs = checkNoErrs $ -- See Note [Fail eagerly on bad signatures] do { ty_sigs_s <- mapAndRecoverM tcTySig hs_sigs @@ -183,7 +184,7 @@ tcTySigs hs_sigs env = mkNameEnv [(tcSigInfoName sig, sig) | sig <- ty_sigs] ; return (poly_ids, lookupNameEnv env) } -tcTySig :: LSig Name -> TcM [TcSigInfo] +tcTySig :: LSig GhcRn -> TcM [TcSigInfo] tcTySig (L _ (IdSig id)) = do { let ctxt = FunSigCtxt (idName id) False -- False: do not report redundant constraints @@ -206,7 +207,8 @@ tcTySig (L loc (PatSynSig names sig_ty)) tcTySig _ = return [] -tcUserTypeSig :: SrcSpan -> LHsSigWcType Name -> Maybe Name -> TcM TcIdSigInfo +tcUserTypeSig :: SrcSpan -> LHsSigWcType GhcRn -> Maybe Name + -> TcM TcIdSigInfo -- A function or expression type signature -- Returns a fully quantified type signature; even the wildcards -- are quantified with ordinary skolems that should be instantiated @@ -251,7 +253,7 @@ completeSigFromId ctxt id , sig_ctxt = ctxt , sig_loc = getSrcSpan id } -isCompleteHsSig :: LHsSigWcType Name -> Bool +isCompleteHsSig :: LHsSigWcType GhcRn -> Bool -- ^ If there are no wildcards, return a LHsSigType isCompleteHsSig (HsWC { hswc_wcs = wcs }) = null wcs @@ -342,7 +344,7 @@ for example, in hs-boot file, we may need to think what to do... (eg don't have any implicitly-bound variables). -} -tcPatSynSig :: Name -> LHsSigType Name -> TcM TcPatSynInfo +tcPatSynSig :: Name -> LHsSigType GhcRn -> TcM TcPatSynInfo tcPatSynSig name sig_ty | HsIB { hsib_vars = implicit_hs_tvs , hsib_body = hs_ty } <- sig_ty @@ -484,25 +486,25 @@ signature, which doesn't use tcInstSig. See TcBinds.tcPolyCheck. * * ********************************************************************* -} -type TcPragEnv = NameEnv [LSig Name] +type TcPragEnv = NameEnv [LSig GhcRn] emptyPragEnv :: TcPragEnv emptyPragEnv = emptyNameEnv -lookupPragEnv :: TcPragEnv -> Name -> [LSig Name] +lookupPragEnv :: TcPragEnv -> Name -> [LSig GhcRn] lookupPragEnv prag_fn n = lookupNameEnv prag_fn n `orElse` [] -extendPragEnv :: TcPragEnv -> (Name, LSig Name) -> TcPragEnv +extendPragEnv :: TcPragEnv -> (Name, LSig GhcRn) -> TcPragEnv extendPragEnv prag_fn (n, sig) = extendNameEnv_Acc (:) singleton prag_fn n sig --------------- -mkPragEnv :: [LSig Name] -> LHsBinds Name -> TcPragEnv +mkPragEnv :: [LSig GhcRn] -> LHsBinds GhcRn -> TcPragEnv mkPragEnv sigs binds = foldl extendPragEnv emptyNameEnv prs where prs = mapMaybe get_sig sigs - get_sig :: LSig Name -> Maybe (Name, LSig Name) + get_sig :: LSig GhcRn -> Maybe (Name, LSig GhcRn) get_sig (L l (SpecSig lnm@(L _ nm) ty inl)) = Just (nm, L l $ SpecSig lnm ty (add_arity nm inl)) get_sig (L l (InlineSig lnm@(L _ nm) inl)) = Just (nm, L l $ InlineSig lnm (add_arity nm inl)) get_sig (L l (SCCFunSig st lnm@(L _ nm) str)) = Just (nm, L l $ SCCFunSig st lnm str) @@ -523,14 +525,14 @@ mkPragEnv sigs binds ar_env :: NameEnv Arity ar_env = foldrBag lhsBindArity emptyNameEnv binds -lhsBindArity :: LHsBind Name -> NameEnv Arity -> NameEnv Arity +lhsBindArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env = extendNameEnv env (unLoc id) (matchGroupArity ms) lhsBindArity _ env = env -- PatBind/VarBind ----------------- -addInlinePrags :: TcId -> [LSig Name] -> TcM TcId +addInlinePrags :: TcId -> [LSig GhcRn] -> TcM TcId addInlinePrags poly_id prags_for_me | inl@(L _ prag) : inls <- inl_prags = do { traceTc "addInlinePrag" (ppr poly_id $$ ppr prag) @@ -667,7 +669,7 @@ Some wrinkles well as the dict. That's what goes on in TcInstDcls.mk_meth_spec_prags -} -tcSpecPrags :: Id -> [LSig Name] +tcSpecPrags :: Id -> [LSig GhcRn] -> TcM [LTcSpecPrag] -- Add INLINE and SPECIALSE pragmas -- INLINE prags are added to the (polymorphic) Id directly @@ -690,7 +692,7 @@ tcSpecPrags poly_id prag_sigs 2 (vcat (map (ppr . getLoc) bad_sigs))) -------------- -tcSpecPrag :: TcId -> Sig Name -> TcM [TcSpecPrag] +tcSpecPrag :: TcId -> Sig GhcRn -> TcM [TcSpecPrag] tcSpecPrag poly_id prag@(SpecSig fun_name hs_tys inl) -- See Note [Handling SPECIALISE pragmas] -- @@ -737,7 +739,7 @@ tcSpecWrapper ctxt poly_ty spec_ty orig = SpecPragOrigin ctxt -------------- -tcImpPrags :: [LSig Name] -> TcM [LTcSpecPrag] +tcImpPrags :: [LSig GhcRn] -> TcM [LTcSpecPrag] -- SPECIALISE pragmas for imported things tcImpPrags prags = do { this_mod <- getModule @@ -762,7 +764,7 @@ tcImpPrags prags HscInterpreted -> True _other -> False -tcImpSpec :: (Name, Sig Name) -> TcM [TcSpecPrag] +tcImpSpec :: (Name, Sig GhcRn) -> TcM [TcSpecPrag] tcImpSpec (name, prag) = do { id <- tcLookupId name ; unless (isAnyInlinePragma (idInlinePragma id)) diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs index 2e49f2adf8..42c113610b 100644 --- a/compiler/typecheck/TcSimplify.hs +++ b/compiler/typecheck/TcSimplify.hs @@ -819,7 +819,8 @@ decideMonoTyVars infer_mode name_taus psigs candidates ; gbl_tvs <- tcGetGlobalTyCoVars ; let eq_constraints = filter isEqPred candidates mono_tvs1 = growThetaTyVars eq_constraints gbl_tvs - constrained_tvs = growThetaTyVars eq_constraints (tyCoVarsOfTypes no_quant) + constrained_tvs = growThetaTyVars eq_constraints + (tyCoVarsOfTypes no_quant) `minusVarSet` mono_tvs1 mono_tvs2 = mono_tvs1 `unionVarSet` constrained_tvs -- A type variable is only "constrained" (so that the MR bites) @@ -866,12 +867,13 @@ decideMonoTyVars infer_mode name_taus psigs candidates = False pp_bndrs = pprWithCommas (quotes . ppr . fst) name_taus - mr_msg = hang (sep [ text "The Monomorphism Restriction applies to the binding" - <> plural name_taus - , text "for" <+> pp_bndrs ]) - 2 (hsep [ text "Consider giving" - , text (if isSingleton name_taus then "it" else "them") - , text "a type signature"]) + mr_msg = + hang (sep [ text "The Monomorphism Restriction applies to the binding" + <> plural name_taus + , text "for" <+> pp_bndrs ]) + 2 (hsep [ text "Consider giving" + , text (if isSingleton name_taus then "it" else "them") + , text "a type signature"]) ------------------- defaultTyVarsAndSimplify :: TcLevel diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index b989aa18d6..6d687b6bcd 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -14,6 +14,7 @@ TcSplice: Template Haskell splices {-# LANGUAGE GADTs #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module TcSplice( @@ -134,9 +135,10 @@ import GHC.Exts ( unsafeCoerce# ) ************************************************************************ -} -tcTypedBracket :: HsBracket Name -> ExpRhoType -> TcM (HsExpr TcId) -tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> ExpRhoType -> TcM (HsExpr TcId) -tcSpliceExpr :: HsSplice Name -> ExpRhoType -> TcM (HsExpr TcId) +tcTypedBracket :: HsBracket GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId) +tcUntypedBracket :: HsBracket GhcRn -> [PendingRnSplice] -> ExpRhoType + -> TcM (HsExpr GhcTcId) +tcSpliceExpr :: HsSplice GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId) -- None of these functions add constraints to the LIE -- runQuasiQuoteExpr :: HsQuasiQuote RdrName -> RnM (LHsExpr RdrName) @@ -144,7 +146,7 @@ tcSpliceExpr :: HsSplice Name -> ExpRhoType -> TcM (HsExpr TcId) -- runQuasiQuoteType :: HsQuasiQuote RdrName -> RnM (LHsType RdrName) -- runQuasiQuoteDecl :: HsQuasiQuote RdrName -> RnM [LHsDecl RdrName] -runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation +runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation {- ************************************************************************ * * @@ -190,7 +192,7 @@ tcUntypedBracket brack ps res_ty (HsTcBracketOut brack ps') meta_ty res_ty } --------------- -tcBrackTy :: HsBracket Name -> TcM TcType +tcBrackTy :: HsBracket GhcRn -> TcM TcType tcBrackTy (VarBr _ _) = tcMetaTy nameTyConName -- Result type is Var (not Q-monadic) tcBrackTy (ExpBr _) = tcMetaTy expQTyConName -- Result type is ExpQ (= Q Exp) tcBrackTy (TypBr _) = tcMetaTy typeQTyConName -- Result type is Type (= Q Typ) @@ -226,7 +228,7 @@ tcTExpTy exp_ty , text "The type of a Typed Template Haskell expression must" <+> text "not have any quantification." ] -quotationCtxtDoc :: HsBracket Name -> SDoc +quotationCtxtDoc :: HsBracket GhcRn -> SDoc quotationCtxtDoc br_body = hang (text "In the Template Haskell quotation") 2 (ppr br_body) @@ -453,7 +455,7 @@ environment (with 'addModFinalizersWithLclEnv'). -} tcNestedSplice :: ThStage -> PendingStuff -> Name - -> LHsExpr Name -> ExpRhoType -> TcM (HsExpr Id) + -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) -- See Note [How brackets and nested splices are handled] -- A splice inside brackets tcNestedSplice pop_stage (TcPending ps_var lie_var) splice_name expr res_ty @@ -473,7 +475,7 @@ tcNestedSplice pop_stage (TcPending ps_var lie_var) splice_name expr res_ty tcNestedSplice _ _ splice_name _ _ = pprPanic "tcNestedSplice: rename stage found" (ppr splice_name) -tcTopSplice :: LHsExpr Name -> ExpRhoType -> TcM (HsExpr Id) +tcTopSplice :: LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) tcTopSplice expr res_ty = do { -- Typecheck the expression, -- making sure it has type Q (T res_ty) @@ -510,19 +512,19 @@ tcTopSplice expr res_ty ************************************************************************ -} -spliceCtxtDoc :: HsSplice Name -> SDoc +spliceCtxtDoc :: HsSplice GhcRn -> SDoc spliceCtxtDoc splice = hang (text "In the Template Haskell splice") 2 (pprSplice splice) -spliceResultDoc :: LHsExpr Name -> SDoc +spliceResultDoc :: LHsExpr GhcRn -> SDoc spliceResultDoc expr = sep [ text "In the result of the splice:" , nest 2 (char '$' <> ppr expr) , text "To see what the splice expanded to, use -ddump-splices"] ------------------- -tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr Id) -> TcM (LHsExpr Id) +tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc) -- Note [How top-level splices are handled] -- Type check an expression that is the body of a top-level splice -- (the caller will compile and run it) @@ -660,8 +662,8 @@ runQResult show_th f runQ expr_span hval ----------------- -runMeta :: (MetaHook TcM -> LHsExpr Id -> TcM hs_syn) - -> LHsExpr Id +runMeta :: (MetaHook TcM -> LHsExpr GhcTc -> TcM hs_syn) + -> LHsExpr GhcTc -> TcM hs_syn runMeta unwrap e = do { h <- getHooked runMetaHook defaultRunMeta @@ -682,31 +684,32 @@ defaultRunMeta (MetaAW r) -- the toAnnotationWrapper function that we slap around the user's code ---------------- -runMetaAW :: LHsExpr Id -- Of type AnnotationWrapper +runMetaAW :: LHsExpr GhcTc -- Of type AnnotationWrapper -> TcM Serialized runMetaAW = runMeta metaRequestAW -runMetaE :: LHsExpr Id -- Of type (Q Exp) - -> TcM (LHsExpr RdrName) +runMetaE :: LHsExpr GhcTc -- Of type (Q Exp) + -> TcM (LHsExpr GhcPs) runMetaE = runMeta metaRequestE -runMetaP :: LHsExpr Id -- Of type (Q Pat) - -> TcM (LPat RdrName) +runMetaP :: LHsExpr GhcTc -- Of type (Q Pat) + -> TcM (LPat GhcPs) runMetaP = runMeta metaRequestP -runMetaT :: LHsExpr Id -- Of type (Q Type) - -> TcM (LHsType RdrName) +runMetaT :: LHsExpr GhcTc -- Of type (Q Type) + -> TcM (LHsType GhcPs) runMetaT = runMeta metaRequestT -runMetaD :: LHsExpr Id -- Of type Q [Dec] - -> TcM [LHsDecl RdrName] +runMetaD :: LHsExpr GhcTc -- Of type Q [Dec] + -> TcM [LHsDecl GhcPs] runMetaD = runMeta metaRequestD --------------- runMeta' :: Bool -- Whether code should be printed in the exception message -> (hs_syn -> SDoc) -- how to print the code -> (SrcSpan -> ForeignHValue -> TcM (Either MsgDoc hs_syn)) -- How to run x - -> LHsExpr Id -- Of type x; typically x = Q TH.Exp, or something like that + -> LHsExpr GhcTc -- Of type x; typically x = Q TH.Exp, or + -- something like that -> TcM hs_syn -- Of type t runMeta' show_code ppr_hs run_and_convert expr = do { traceTc "About to run" (ppr expr) @@ -882,7 +885,7 @@ instance TH.Quasi TcM where th_topdecls_var <- fmap tcg_th_topdecls getGblEnv updTcRef th_topdecls_var (\topds -> ds ++ topds) where - checkTopDecl :: HsDecl RdrName -> TcM () + checkTopDecl :: HsDecl GhcPs -> TcM () checkTopDecl (ValD binds) = mapM_ bindName (collectHsBindBinders binds) checkTopDecl (SigD _) @@ -1165,7 +1168,7 @@ reifyInstances th_nm th_tys doc = ClassInstanceCtx bale_out msg = failWithTc msg - cvt :: SrcSpan -> TH.Type -> TcM (LHsType RdrName) + cvt :: SrcSpan -> TH.Type -> TcM (LHsType GhcPs) cvt loc th_ty = case convertToHsType loc th_ty of Left msg -> failWithTc msg Right ty -> return ty diff --git a/compiler/typecheck/TcSplice.hs-boot b/compiler/typecheck/TcSplice.hs-boot index db75436d4d..2aa51c8bcd 100644 --- a/compiler/typecheck/TcSplice.hs-boot +++ b/compiler/typecheck/TcSplice.hs-boot @@ -1,38 +1,38 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} module TcSplice where -import HsSyn ( HsSplice, HsBracket, HsExpr, LHsExpr ) +import Name import HsExpr ( PendingRnSplice ) -import Name ( Name ) -import TcRnTypes( TcM, TcId ) +import TcRnTypes( TcM , SpliceType ) import TcType ( ExpRhoType ) import Annotations ( Annotation, CoreAnnTarget ) +import HsExtension ( GhcTcId, GhcRn, GhcPs ) -import HsSyn ( LHsType, LPat, LHsDecl, ThModFinalizers ) -import RdrName ( RdrName ) -import TcRnTypes ( SpliceType ) +import HsSyn ( HsSplice, HsBracket, HsExpr, LHsExpr, LHsType, LPat, + LHsDecl, ThModFinalizers ) import qualified Language.Haskell.TH as TH -tcSpliceExpr :: HsSplice Name +tcSpliceExpr :: HsSplice GhcRn -> ExpRhoType - -> TcM (HsExpr TcId) + -> TcM (HsExpr GhcTcId) -tcUntypedBracket :: HsBracket Name +tcUntypedBracket :: HsBracket GhcRn -> [PendingRnSplice] -> ExpRhoType - -> TcM (HsExpr TcId) -tcTypedBracket :: HsBracket Name + -> TcM (HsExpr GhcTcId) +tcTypedBracket :: HsBracket GhcRn -> ExpRhoType - -> TcM (HsExpr TcId) + -> TcM (HsExpr GhcTcId) -runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation +runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation -tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr TcId) -> TcM (LHsExpr TcId) +tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId) -runMetaE :: LHsExpr TcId -> TcM (LHsExpr RdrName) -runMetaP :: LHsExpr TcId -> TcM (LPat RdrName) -runMetaT :: LHsExpr TcId -> TcM (LHsType RdrName) -runMetaD :: LHsExpr TcId -> TcM [LHsDecl RdrName] +runMetaE :: LHsExpr GhcTcId -> TcM (LHsExpr GhcPs) +runMetaP :: LHsExpr GhcTcId -> TcM (LPat GhcPs) +runMetaT :: LHsExpr GhcTcId -> TcM (LHsType GhcPs) +runMetaD :: LHsExpr GhcTcId -> TcM [LHsDecl GhcPs] lookupThName_maybe :: TH.Name -> TcM (Maybe Name) runQuasi :: TH.Q a -> TcM a diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 6076c75f30..c8aca39e4c 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -7,6 +7,7 @@ TcTyClsDecls: Typecheck type and class declarations -} {-# LANGUAGE CPP, TupleSections, MultiWayIf #-} +{-# LANGUAGE TypeFamilies #-} module TcTyClsDecls ( tcTyAndClassDecls, tcAddImplicits, @@ -106,12 +107,12 @@ Thus, we take two passes over the resulting tycons, first checking for general validity and then checking for valid role annotations. -} -tcTyAndClassDecls :: [TyClGroup Name] -- Mutually-recursive groups in +tcTyAndClassDecls :: [TyClGroup GhcRn] -- Mutually-recursive groups in -- dependency order -> TcM ( TcGblEnv -- Input env extended by types and -- classes -- and their implicit Ids,DataCons - , [InstInfo Name] -- Source-code instance decls info + , [InstInfo GhcRn] -- Source-code instance decls info , [DerivInfo] -- data family deriving info ) -- Fails if there are any errors @@ -121,10 +122,10 @@ tcTyAndClassDecls tyclds_s -- Type check each group in dependency order folding the global env = checkNoErrs $ fold_env [] [] tyclds_s where - fold_env :: [InstInfo Name] + fold_env :: [InstInfo GhcRn] -> [DerivInfo] - -> [TyClGroup Name] - -> TcM (TcGblEnv, [InstInfo Name], [DerivInfo]) + -> [TyClGroup GhcRn] + -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo]) fold_env inst_info deriv_info [] = do { gbl_env <- getGblEnv ; return (gbl_env, inst_info, deriv_info) } @@ -136,8 +137,8 @@ tcTyAndClassDecls tyclds_s (deriv_info' ++ deriv_info) tyclds_s } -tcTyClGroup :: TyClGroup Name - -> TcM (TcGblEnv, [InstInfo Name], [DerivInfo]) +tcTyClGroup :: TyClGroup GhcRn + -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo]) -- Typecheck one strongly-connected component of type, class, and instance decls -- See Note [TyClGroups and dependency analysis] in HsDecls tcTyClGroup (TyClGroup { group_tyclds = tyclds @@ -182,7 +183,7 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds ; return (gbl_env, inst_info, datafam_deriv_info) } } } -tcTyClDecls :: [LTyClDecl Name] -> RoleAnnotEnv -> TcM [TyCon] +tcTyClDecls :: [LTyClDecl GhcRn] -> RoleAnnotEnv -> TcM [TyCon] tcTyClDecls tyclds role_annots = do { -- Step 1: kind-check this group and returns the final -- (possibly-polymorphic) kind of each TyCon and Class @@ -322,7 +323,7 @@ See also Note [Kind checking recursive type and class declarations] -- Unfortunately this requires reworking a bit of the code in -- 'kcLTyClDecl' so I've decided to punt unless someone shouts about it. -- -kcTyClGroup :: [LTyClDecl Name] -> TcM [TcTyCon] +kcTyClGroup :: [LTyClDecl GhcRn] -> TcM [TcTyCon] -- Kind check this group, kind generalize, and return the resulting local env -- This binds the TyCons and Classes of the group, but not the DataCons @@ -385,7 +386,7 @@ kcTyClGroup decls (tcTyConScopedTyVars tc)) } generaliseTCD :: TcTypeEnv - -> LTyClDecl Name -> TcM [TcTyCon] + -> LTyClDecl GhcRn -> TcM [TcTyCon] generaliseTCD kind_env (L _ decl) | ClassDecl { tcdLName = (L _ name), tcdATs = ats } <- decl = do { first <- generalise kind_env name @@ -401,7 +402,7 @@ kcTyClGroup decls ; return [res] } generaliseFamDecl :: TcTypeEnv - -> FamilyDecl Name -> TcM TcTyCon + -> FamilyDecl GhcRn -> TcM TcTyCon generaliseFamDecl kind_env (FamilyDecl { fdLName = L _ name }) = generalise kind_env name @@ -418,7 +419,7 @@ extendEnvWithTcTyCon env tc = extendNameEnv env (getName tc) (ATcTyCon tc) -------------- -mkPromotionErrorEnv :: [LTyClDecl Name] -> TcTypeEnv +mkPromotionErrorEnv :: [LTyClDecl GhcRn] -> TcTypeEnv -- Maps each tycon/datacon to a suitable promotion error -- tc :-> APromotionErr TyConPE -- dc :-> APromotionErr RecDataConPE @@ -428,7 +429,7 @@ mkPromotionErrorEnv decls = foldr (plusNameEnv . mk_prom_err_env . unLoc) emptyNameEnv decls -mk_prom_err_env :: TyClDecl Name -> TcTypeEnv +mk_prom_err_env :: TyClDecl GhcRn -> TcTypeEnv mk_prom_err_env (ClassDecl { tcdLName = L _ nm, tcdATs = ats }) = unitNameEnv nm (APromotionErr ClassPE) `plusNameEnv` @@ -447,7 +448,7 @@ mk_prom_err_env decl -- Works for family declarations too -------------- -getInitialKinds :: [LTyClDecl Name] -> TcM (NameEnv TcTyThing) +getInitialKinds :: [LTyClDecl GhcRn] -> TcM (NameEnv TcTyThing) -- Maps each tycon to its initial kind, -- and each datacon to a suitable promotion error -- tc :-> ATcTyCon (tc:initial_kind) @@ -461,7 +462,7 @@ getInitialKinds decls where promotion_err_env = mkPromotionErrorEnv decls -getInitialKind :: TyClDecl Name +getInitialKind :: TyClDecl GhcRn -> TcM (NameEnv TcTyThing) -- Allocate a fresh kind variable for each TyCon and Class -- For each tycon, return a NameEnv with @@ -519,14 +520,14 @@ getInitialKind decl@(SynDecl { tcdLName = L _ name --------------------------------- getFamDeclInitialKinds :: Maybe Bool -- if assoc., CUSKness of assoc. class - -> [LFamilyDecl Name] + -> [LFamilyDecl GhcRn] -> TcM TcTypeEnv getFamDeclInitialKinds mb_cusk decls = do { tc_kinds <- mapM (addLocM (getFamDeclInitialKind mb_cusk)) decls ; return (foldr plusNameEnv emptyNameEnv tc_kinds) } getFamDeclInitialKind :: Maybe Bool -- if assoc., CUSKness of assoc. class - -> FamilyDecl Name + -> FamilyDecl GhcRn -> TcM TcTypeEnv getFamDeclInitialKind mb_cusk decl@(FamilyDecl { fdLName = L _ name , fdTyVars = ktvs @@ -552,7 +553,7 @@ getFamDeclInitialKind mb_cusk decl@(FamilyDecl { fdLName = L _ name ClosedTypeFamily _ -> (False, False) ------------------------------------------------------------------------ -kcLTyClDecl :: LTyClDecl Name -> TcM () +kcLTyClDecl :: LTyClDecl GhcRn -> TcM () -- See Note [Kind checking for type and class decls] kcLTyClDecl (L loc decl) = setSrcSpan loc $ @@ -561,7 +562,7 @@ kcLTyClDecl (L loc decl) ; kcTyClDecl decl ; traceTc "kcTyClDecl done }" (ppr (tyClDeclLName decl)) } -kcTyClDecl :: TyClDecl Name -> TcM () +kcTyClDecl :: TyClDecl GhcRn -> TcM () -- This function is used solely for its side effect on kind variables -- NB kind signatures on the type variables and -- result kind signature have already been dealt with @@ -609,7 +610,7 @@ kcTyClDecl (FamDecl (FamilyDecl { fdLName = L _ fam_tc_name _ -> return () ------------------- -kcConDecl :: ConDecl Name -> TcM () +kcConDecl :: ConDecl GhcRn -> TcM () kcConDecl (ConDeclH98 { con_name = name, con_qvars = ex_tvs , con_cxt = ex_ctxt, con_details = details }) = addErrCtxt (dataConCtxtName [name]) $ @@ -737,7 +738,7 @@ e.g. the need to make the data constructor worker name for a constraint tuple match the wired-in one -} -tcTyClDecl :: RolesInfo -> LTyClDecl Name -> TcM TyCon +tcTyClDecl :: RolesInfo -> LTyClDecl GhcRn -> TcM TyCon tcTyClDecl roles_info (L loc decl) | Just thing <- wiredInNameTyThing_maybe (tcdName decl) = case thing of -- See Note [Declarations for wired-in things] @@ -750,7 +751,7 @@ tcTyClDecl roles_info (L loc decl) ; tcTyClDecl1 Nothing roles_info decl } -- "type family" declarations -tcTyClDecl1 :: Maybe Class -> RolesInfo -> TyClDecl Name -> TcM TyCon +tcTyClDecl1 :: Maybe Class -> RolesInfo -> TyClDecl GhcRn -> TcM TyCon tcTyClDecl1 parent _roles_info (FamDecl { tcdFam = fd }) = tcFamDecl1 parent fd @@ -808,7 +809,7 @@ tcTyClDecl1 _parent roles_info ; tvs2' <- mapM (tcLookupTyVar . unLoc) tvs2 ; ; return (tvs1', tvs2') } -tcFamDecl1 :: Maybe Class -> FamilyDecl Name -> TcM TyCon +tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM TyCon tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info, fdLName = tc_lname@(L _ tc_name) , fdTyVars = tvs, fdResultSig = L _ sig , fdInjectivityAnn = inj }) @@ -899,7 +900,7 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info, fdLName = tc_lname@(L _ tc_na -- True on position -- N means that a function is injective in its Nth argument. False means it is -- not. -tcInjectivity :: [TyConBinder] -> Maybe (LInjectivityAnn Name) +tcInjectivity :: [TyConBinder] -> Maybe (LInjectivityAnn GhcRn) -> TcM Injectivity tcInjectivity _ Nothing = return NotInjective @@ -941,7 +942,7 @@ tcInjectivity tcbs (Just (L loc (InjectivityAnn _ lInjNames))) tcTySynRhs :: RolesInfo -> Name -> [TyConBinder] -> Kind - -> LHsType Name -> TcM TyCon + -> LHsType GhcRn -> TcM TyCon tcTySynRhs roles_info tc_name binders res_kind hs_ty = do { env <- getLclEnv ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env)) @@ -953,7 +954,7 @@ tcTySynRhs roles_info tc_name binders res_kind hs_ty tcDataDefn :: RolesInfo -> Name -> [TyConBinder] -> Kind - -> HsDataDefn Name -> TcM TyCon + -> HsDataDefn GhcRn -> TcM TyCon -- NB: not used for newtype/data instances (whether associated or not) tcDataDefn roles_info tc_name tycon_binders res_kind @@ -1029,10 +1030,10 @@ Note that we can get default definitions only for type families, not data families. -} -tcClassATs :: Name -- The class name (not knot-tied) - -> Class -- The class parent of this associated type - -> [LFamilyDecl Name] -- Associated types. - -> [LTyFamDefltEqn Name] -- Associated type defaults. +tcClassATs :: Name -- The class name (not knot-tied) + -> Class -- The class parent of this associated type + -> [LFamilyDecl GhcRn] -- Associated types. + -> [LTyFamDefltEqn GhcRn] -- Associated type defaults. -> TcM [ClassATItem] tcClassATs class_name cls ats at_defs = do { -- Complain about associated type defaults for non associated-types @@ -1041,15 +1042,15 @@ tcClassATs class_name cls ats at_defs , not (n `elemNameSet` at_names) ] ; mapM tc_at ats } where - at_def_tycon :: LTyFamDefltEqn Name -> Name + at_def_tycon :: LTyFamDefltEqn GhcRn -> Name at_def_tycon (L _ eqn) = unLoc (tfe_tycon eqn) - at_fam_name :: LFamilyDecl Name -> Name + at_fam_name :: LFamilyDecl GhcRn -> Name at_fam_name (L _ decl) = unLoc (fdLName decl) at_names = mkNameSet (map at_fam_name ats) - at_defs_map :: NameEnv [LTyFamDefltEqn Name] + at_defs_map :: NameEnv [LTyFamDefltEqn GhcRn] -- Maps an AT in 'ats' to a list of all its default defs in 'at_defs' at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv (at_def_tycon at_def) [at_def]) @@ -1063,7 +1064,7 @@ tcClassATs class_name cls ats at_defs ------------------------- tcDefaultAssocDecl :: TyCon -- ^ Family TyCon (not knot-tied) - -> [LTyFamDefltEqn Name] -- ^ Defaults + -> [LTyFamDefltEqn GhcRn] -- ^ Defaults -> TcM (Maybe (Type, SrcSpan)) -- ^ Type checked RHS tcDefaultAssocDecl _ [] = return Nothing -- No default declaration @@ -1139,7 +1140,7 @@ message isn't great, mind you. (Trac #11361 was caused by not doing a proper tcMatchTys here.) -} ------------------------- -kcTyFamInstEqn :: FamTyConShape -> LTyFamInstEqn Name -> TcM () +kcTyFamInstEqn :: FamTyConShape -> LTyFamInstEqn GhcRn -> TcM () kcTyFamInstEqn fam_tc_shape@(fam_tc_name,_,_,_) (L loc (TyFamEqn { tfe_tycon = L _ eqn_tc_name , tfe_pats = pats @@ -1151,7 +1152,8 @@ kcTyFamInstEqn fam_tc_shape@(fam_tc_name,_,_,_) tc_fam_ty_pats fam_tc_shape Nothing -- not an associated type pats (discardResult . (tcCheckLHsType hs_ty)) } -tcTyFamInstEqn :: FamTyConShape -> Maybe ClsInstInfo -> LTyFamInstEqn Name -> TcM CoAxBranch +tcTyFamInstEqn :: FamTyConShape -> Maybe ClsInstInfo -> LTyFamInstEqn GhcRn + -> TcM CoAxBranch -- Needs to be here, not in TcInstDcls, because closed families -- (typechecked here) have TyFamInstEqns tcTyFamInstEqn fam_tc_shape@(fam_tc_name,_,_,_) mb_clsinfo @@ -1175,8 +1177,8 @@ tcTyFamInstEqn fam_tc_shape@(fam_tc_name,_,_,_) mb_clsinfo loc) } kcDataDefn :: Name -- ^ the family name, for error msgs only - -> HsTyPats Name -- ^ the patterns, for error msgs only - -> HsDataDefn Name -- ^ the RHS + -> HsTyPats GhcRn -- ^ the patterns, for error msgs only + -> HsDataDefn GhcRn -- ^ the RHS -> TcKind -- ^ the expected kind -> TcM () -- Used for 'data instance' only @@ -1246,7 +1248,7 @@ famTyConShape fam_tc tc_fam_ty_pats :: FamTyConShape -> Maybe ClsInstInfo - -> HsTyPats Name -- Patterns + -> HsTyPats GhcRn -- Patterns -> (TcKind -> TcM ()) -- Kind checker for RHS -- result is ignored -> TcM ([Type], Kind) @@ -1289,7 +1291,7 @@ tc_fam_ty_pats (name, _, binders, res_kind) mb_clsinfo -- See Note [tc_fam_ty_pats vs tcFamTyPats] tcFamTyPats :: FamTyConShape -> Maybe ClsInstInfo - -> HsTyPats Name -- patterns + -> HsTyPats GhcRn -- patterns -> (TcKind -> TcM ()) -- kind-checker for RHS -> ( [TcTyVar] -- Kind and type variables -> [TcType] -- Kind and type arguments @@ -1436,7 +1438,7 @@ that 'a' must have that kind, and to bring 'k' into scope. ************************************************************************ -} -dataDeclChecks :: Name -> NewOrData -> ThetaType -> [LConDecl Name] -> TcM Bool +dataDeclChecks :: Name -> NewOrData -> ThetaType -> [LConDecl GhcRn] -> TcM Bool dataDeclChecks tc_name new_or_data stupid_theta cons = do { -- Check that we don't use GADT syntax in H98 world gadtSyntax_ok <- xoptM LangExt.GADTSyntax @@ -1469,7 +1471,7 @@ consUseGadtSyntax _ = False ----------------------------------- tcConDecls :: TyCon -> ([TyConBinder], Type) - -> [LConDecl Name] -> TcM [DataCon] + -> [LConDecl GhcRn] -> TcM [DataCon] -- Why both the tycon tyvars and binders? Because the tyvars -- have all the names and the binders have the visibilities. tcConDecls rep_tycon (tmpl_bndrs, res_tmpl) @@ -1480,7 +1482,7 @@ tcConDecl :: TyCon -- Representation tycon. Knot-tied! -> [TyConBinder] -> Type -- Return type template (with its template tyvars) -- (tvs, T tys), where T is the family TyCon - -> ConDecl Name + -> ConDecl GhcRn -> TcM [DataCon] tcConDecl rep_tycon tmpl_bndrs res_tmpl @@ -1620,10 +1622,10 @@ tcConDecl rep_tycon tmpl_bndrs res_tmpl } -tcGadtSigType :: SDoc -> Name -> LHsSigType Name +tcGadtSigType :: SDoc -> Name -> LHsSigType GhcRn -> TcM ( [TcTyVar], [PredType],[HsSrcBang], [FieldLabel], [Type], Type - , HsConDetails (LHsType Name) - (Located [LConDeclField Name]) ) + , HsConDetails (LHsType GhcRn) + (Located [LConDeclField GhcRn]) ) tcGadtSigType doc name ty@(HsIB { hsib_vars = vars }) = do { let (hs_details', res_ty', cxt, gtvs) = gadtDeclDetails ty ; (hs_details, res_ty) <- updateGadtResult failWithTc doc hs_details' res_ty' @@ -1645,7 +1647,7 @@ tcGadtSigType doc name ty@(HsIB { hsib_vars = vars }) } tcConIsInfixH98 :: Name - -> HsConDetails (LHsType Name) (Located [LConDeclField Name]) + -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]) -> TcM Bool tcConIsInfixH98 _ details = case details of @@ -1653,7 +1655,7 @@ tcConIsInfixH98 _ details _ -> return False tcConIsInfixGADT :: Name - -> HsConDetails (LHsType Name) (Located [LConDeclField Name]) + -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]) -> TcM Bool tcConIsInfixGADT con details = case details of @@ -1666,7 +1668,7 @@ tcConIsInfixGADT con details ; return (con `elemNameEnv` fix_env) } | otherwise -> return False -tcConArgs :: HsConDeclDetails Name +tcConArgs :: HsConDeclDetails GhcRn -> TcM [(TcType, HsSrcBang)] tcConArgs (PrefixCon btys) = mapM tcConArg btys @@ -1684,7 +1686,7 @@ tcConArgs (RecCon fields) (_,btys) = unzip exploded -tcConArg :: LHsType Name -> TcM (TcType, HsSrcBang) +tcConArg :: LHsType GhcRn -> TcM (TcType, HsSrcBang) tcConArg bty = do { traceTc "tcConArg 1" (ppr bty) ; arg_ty <- tcHsOpenType (getBangType bty) @@ -2909,16 +2911,16 @@ checkValidRoles tc ************************************************************************ -} -tcAddTyFamInstCtxt :: TyFamInstDecl Name -> TcM a -> TcM a +tcAddTyFamInstCtxt :: TyFamInstDecl GhcRn -> TcM a -> TcM a tcAddTyFamInstCtxt decl = tcAddFamInstCtxt (text "type instance") (tyFamInstDeclName decl) -tcMkDataFamInstCtxt :: DataFamInstDecl Name -> SDoc +tcMkDataFamInstCtxt :: DataFamInstDecl GhcRn -> SDoc tcMkDataFamInstCtxt decl = tcMkFamInstCtxt (pprDataFamInstFlavour decl <+> text "instance") (unLoc (dfid_tycon decl)) -tcAddDataFamInstCtxt :: DataFamInstDecl Name -> TcM a -> TcM a +tcAddDataFamInstCtxt :: DataFamInstDecl GhcRn -> TcM a -> TcM a tcAddDataFamInstCtxt decl = addErrCtxt (tcMkDataFamInstCtxt decl) @@ -3070,14 +3072,14 @@ badRoleAnnot var annot inferred , text "but role", ppr inferred , text "is required" ]) -wrongNumberOfRoles :: [a] -> LRoleAnnotDecl Name -> SDoc +wrongNumberOfRoles :: [a] -> LRoleAnnotDecl GhcRn -> SDoc wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ annots)) = hang (text "Wrong number of roles listed in role annotation;" $$ text "Expected" <+> (ppr $ length tyvars) <> comma <+> text "got" <+> (ppr $ length annots) <> colon) 2 (ppr d) -illegalRoleAnnotDecl :: LRoleAnnotDecl Name -> TcM () +illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcM () illegalRoleAnnotDecl (L loc (RoleAnnotDecl tycon _)) = setErrCtxt [] $ setSrcSpan loc $ diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs index 298dcbde8c..df33bb0f16 100644 --- a/compiler/typecheck/TcTyDecls.hs +++ b/compiler/typecheck/TcTyDecls.hs @@ -10,6 +10,7 @@ files for imported data types. -} {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} module TcTyDecls( RolesInfo, @@ -177,7 +178,7 @@ checkNameIsAcyclic n m = SynCycleM $ \s -> -- checking those TyCons: cycles never go through foreign packages) and -- the corresponding @LTyClDecl Name@ for each 'TyCon', so we -- can give better error messages. -checkSynCycles :: UnitId -> [TyCon] -> [LTyClDecl Name] -> TcM () +checkSynCycles :: UnitId -> [TyCon] -> [LTyClDecl GhcRn] -> TcM () checkSynCycles this_uid tcs tyclds = do case runSynCycleM (mapM_ (go emptyNameSet []) tcs) emptyNameSet of Left (loc, err) -> setSrcSpan loc $ failWithTc err @@ -662,7 +663,7 @@ data RoleInferenceState = RIS { role_env :: RoleEnv type VarPositions = VarEnv Int -- See [Role inference] -newtype RoleM a = RM { unRM :: Maybe Name -- of the tycon +newtype RoleM a = RM { unRM :: Maybe Name -- of the tycon -> VarPositions -> Int -- size of VarPositions -> RoleInferenceState @@ -809,7 +810,7 @@ when typechecking the [d| .. |] quote, and typecheck them later. ************************************************************************ -} -mkRecSelBinds :: [TyCon] -> HsValBinds Name +mkRecSelBinds :: [TyCon] -> HsValBinds GhcRn -- NB We produce *un-typechecked* bindings, rather like 'deriving' -- This makes life easier, because the later type checking will add -- all necessary type abstractions and applications @@ -821,14 +822,14 @@ mkRecSelBinds tycons | tc <- tycons , fld <- tyConFieldLabels tc ] -mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, (RecFlag, LHsBinds Name)) +mkRecSelBind :: (TyCon, FieldLabel) -> (LSig GhcRn, (RecFlag, LHsBinds GhcRn)) mkRecSelBind (tycon, fl) = mkOneRecordSelector all_cons (RecSelData tycon) fl where all_cons = map RealDataCon (tyConDataCons tycon) mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel - -> (LSig Name, (RecFlag, LHsBinds Name)) + -> (LSig GhcRn, (RecFlag, LHsBinds GhcRn)) mkOneRecordSelector all_cons idDetails fl = (L loc (IdSig sel_id), (NonRecursive, unitBag (L loc sel_bind))) where diff --git a/compiler/typecheck/TcTypeable.hs b/compiler/typecheck/TcTypeable.hs index 5b633ffdc0..64db97c610 100644 --- a/compiler/typecheck/TcTypeable.hs +++ b/compiler/typecheck/TcTypeable.hs @@ -5,11 +5,12 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} module TcTypeable(mkTypeableBinds) where -import BasicTypes ( SourceText(..), Boxity(..), neverInlinePragma ) +import BasicTypes ( Boxity(..), neverInlinePragma ) import TcBinds( addTypecheckedBinds ) import IfaceEnv( newGlobalBinder ) import TyCoRep( Type(..), TyLit(..) ) @@ -22,13 +23,13 @@ import TysPrim ( primTyCons ) import TysWiredIn ( tupleTyCon, sumTyCon, runtimeRepTyCon , vecCountTyCon, vecElemTyCon , nilDataCon, consDataCon ) +import Name import Id import Type import Kind ( isTYPEApp ) import TyCon import DataCon -import Name ( Name, getOccName ) -import OccName +import Name ( getOccName ) import Module import HsSyn import DynFlags @@ -193,7 +194,7 @@ mkModIdBindings ; return (tcg_env { tcg_tr_module = Just mod_id } `addTypecheckedBinds` [unitBag mod_bind]) } -mkModIdRHS :: Module -> TcM (LHsExpr Id) +mkModIdRHS :: Module -> TcM (LHsExpr GhcTc) mkModIdRHS mod = do { trModuleDataCon <- tcLookupDataCon trModuleDataConName ; trNameLit <- mkTrNameLit @@ -220,7 +221,7 @@ data TypeableTyCon -- | A group of 'TyCon's in need of type-rep bindings. data TypeRepTodo = TypeRepTodo - { mod_rep_expr :: LHsExpr Id -- ^ Module's typerep binding + { mod_rep_expr :: LHsExpr GhcTc -- ^ Module's typerep binding , pkg_fingerprint :: !Fingerprint -- ^ Package name fingerprint , mod_fingerprint :: !Fingerprint -- ^ Module name fingerprint , todo_tycons :: [TypeableTyCon] @@ -288,7 +289,7 @@ mkTypeRepTodoBinds todos ] ; gbl_env <- tcExtendGlobalValEnv produced_bndrs getGblEnv - ; let mk_binds :: TypeRepTodo -> KindRepM [LHsBinds Id] + ; let mk_binds :: TypeRepTodo -> KindRepM [LHsBinds GhcTc] mk_binds todo@(TypeRepTodo {}) = mapM (mkTyConRepBinds stuff todo) (todo_tycons todo) mk_binds (ExportedKindRepsTodo kinds) = @@ -352,7 +353,7 @@ ghcPrimTypeableTyCons = concat data TypeableStuff = Stuff { dflags :: DynFlags , trTyConDataCon :: DataCon -- ^ of @TyCon@ - , trNameLit :: FastString -> LHsExpr Id + , trNameLit :: FastString -> LHsExpr GhcTc -- ^ To construct @TrName@s -- The various TyCon and DataCons of KindRep , kindRepTyCon :: TyCon @@ -386,17 +387,17 @@ collect_stuff = do -- | Lookup the necessary pieces to construct the @trNameLit@. We do this so we -- can save the work of repeating lookups when constructing many TyCon -- representations. -mkTrNameLit :: TcM (FastString -> LHsExpr Id) +mkTrNameLit :: TcM (FastString -> LHsExpr GhcTc) mkTrNameLit = do trNameSDataCon <- tcLookupDataCon trNameSDataConName - let trNameLit :: FastString -> LHsExpr Id + let trNameLit :: FastString -> LHsExpr GhcTc trNameLit fs = nlHsPar $ nlHsDataCon trNameSDataCon `nlHsApp` nlHsLit (mkHsStringPrimLit fs) return trNameLit -- | Make Typeable bindings for the given 'TyCon'. mkTyConRepBinds :: TypeableStuff -> TypeRepTodo - -> TypeableTyCon -> KindRepM (LHsBinds Id) + -> TypeableTyCon -> KindRepM (LHsBinds GhcTc) mkTyConRepBinds stuff@(Stuff {..}) todo (TypeableTyCon {..}) = do -- Make a KindRep let (bndrs, kind) = splitForAllTyVarBndrs (tyConKind tycon) @@ -444,7 +445,7 @@ typeIsTypeable (CoercionTy{}) = panic "typeIsTypeable(Coercion)" -- some other module (in which case the @Maybe (LHsExpr Id@ will be 'Nothing') -- or a binding which we generated in the current module (in which case it will -- be 'Just' the RHS of the binding). -type KindRepEnv = TypeMap (Id, Maybe (LHsExpr Id)) +type KindRepEnv = TypeMap (Id, Maybe (LHsExpr GhcTc)) -- | A monad within which we will generate 'KindRep's. Here we keep an -- environment containing 'KindRep's which we've already generated so we can @@ -489,7 +490,7 @@ mkExportedKindReps stuff@(Stuff {..}) = mapM_ kindrep_binding rhs <- mkKindRepRhs stuff empty_scope kind addKindRepBind empty_scope kind rep_bndr rhs -addKindRepBind :: CmEnv -> Kind -> Id -> LHsExpr Id -> KindRepM () +addKindRepBind :: CmEnv -> Kind -> Id -> LHsExpr GhcTc -> KindRepM () addKindRepBind in_scope k bndr rhs = KindRepM $ modify' $ \env -> extendTypeMapWithScope env in_scope k (bndr, Just rhs) @@ -511,13 +512,13 @@ runKindRepM (KindRepM action) = do -- | Produce or find a 'KindRep' for the given kind. getKindRep :: TypeableStuff -> CmEnv -- ^ in-scope kind variables -> Kind -- ^ the kind we want a 'KindRep' for - -> KindRepM (LHsExpr Id) + -> KindRepM (LHsExpr GhcTc) getKindRep stuff@(Stuff {..}) in_scope = go where - go :: Kind -> KindRepM (LHsExpr Id) + go :: Kind -> KindRepM (LHsExpr GhcTc) go = KindRepM . StateT . go' - go' :: Kind -> KindRepEnv -> TcRn (LHsExpr Id, KindRepEnv) + go' :: Kind -> KindRepEnv -> TcRn (LHsExpr GhcTc, KindRepEnv) go' k env -- Look through type synonyms | Just k' <- tcView k = go' k' env @@ -544,7 +545,7 @@ getKindRep stuff@(Stuff {..}) in_scope = go mkKindRepRhs :: TypeableStuff -> CmEnv -- ^ in-scope kind variables -> Kind -- ^ the kind we want a 'KindRep' for - -> KindRepM (LHsExpr Id) -- ^ RHS expression + -> KindRepM (LHsExpr GhcTc) -- ^ RHS expression mkKindRepRhs stuff@(Stuff {..}) in_scope = new_kind_rep where new_kind_rep k @@ -605,8 +606,8 @@ mkKindRepRhs stuff@(Stuff {..}) in_scope = new_kind_rep -- | Produce the right-hand-side of a @TyCon@ representation. mkTyConRepTyConRHS :: TypeableStuff -> TypeRepTodo -> TyCon -- ^ the 'TyCon' we are producing a binding for - -> LHsExpr Id -- ^ its 'KindRep' - -> LHsExpr Id + -> LHsExpr GhcTc -- ^ its 'KindRep' + -> LHsExpr GhcTc mkTyConRepTyConRHS (Stuff {..}) todo tycon kind_rep = nlHsDataCon trTyConDataCon `nlHsApp` nlHsLit (word64 dflags high) @@ -628,13 +629,13 @@ mkTyConRepTyConRHS (Stuff {..}) todo tycon kind_rep , fingerprintString tycon_str ] - int :: Int -> HsLit - int n = HsIntPrim (SourceText $ show n) (toInteger n) + int :: Int -> HsLit GhcTc + int n = HsIntPrim (sourceText $ show n) (toInteger n) -word64 :: DynFlags -> Word64 -> HsLit +word64 :: DynFlags -> Word64 -> HsLit GhcTc word64 dflags n - | wORD_SIZE dflags == 4 = HsWord64Prim NoSourceText (toInteger n) - | otherwise = HsWordPrim NoSourceText (toInteger n) + | wORD_SIZE dflags == 4 = HsWord64Prim noSourceText (toInteger n) + | otherwise = HsWordPrim noSourceText (toInteger n) {- Note [Representing TyCon kinds: KindRep] @@ -692,15 +693,15 @@ polymorphic types. So instead ... -} -mkList :: Type -> [LHsExpr Id] -> LHsExpr Id +mkList :: Type -> [LHsExpr GhcTc] -> LHsExpr GhcTc mkList ty = foldr consApp (nilExpr ty) where cons = consExpr ty - consApp :: LHsExpr Id -> LHsExpr Id -> LHsExpr Id + consApp :: LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc consApp x xs = cons `nlHsApp` x `nlHsApp` xs - nilExpr :: Type -> LHsExpr Id + nilExpr :: Type -> LHsExpr GhcTc nilExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon nilDataCon) - consExpr :: Type -> LHsExpr Id + consExpr :: Type -> LHsExpr GhcTc consExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon consDataCon) diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs index a1a2add2b7..bfaacef5ad 100644 --- a/compiler/typecheck/TcUnify.hs +++ b/compiler/typecheck/TcUnify.hs @@ -59,7 +59,6 @@ import VarEnv import ErrUtils import DynFlags import BasicTypes -import Name ( Name ) import Bag import Util import Pair( pFst ) @@ -800,14 +799,14 @@ tc_sub_type_ds eq_orig inst_orig ctxt ty_actual ty_expected ----------------- -- needs both un-type-checked (for origins) and type-checked (for wrapping) -- expressions -tcWrapResult :: HsExpr Name -> HsExpr TcId -> TcSigmaType -> ExpRhoType - -> TcM (HsExpr TcId) +tcWrapResult :: HsExpr GhcRn -> HsExpr GhcTcId -> TcSigmaType -> ExpRhoType + -> TcM (HsExpr GhcTcId) tcWrapResult rn_expr = tcWrapResultO (exprCtOrigin rn_expr) -- | Sometimes we don't have a @HsExpr Name@ to hand, and this is more -- convenient. -tcWrapResultO :: CtOrigin -> HsExpr TcId -> TcSigmaType -> ExpRhoType - -> TcM (HsExpr TcId) +tcWrapResultO :: CtOrigin -> HsExpr GhcTcId -> TcSigmaType -> ExpRhoType + -> TcM (HsExpr GhcTcId) tcWrapResultO orig expr actual_ty res_ty = do { traceTc "tcWrapResult" (vcat [ text "Actual: " <+> ppr actual_ty , text "Expected:" <+> ppr res_ty ]) @@ -1198,7 +1197,7 @@ unifyType thing ty1 ty2 = traceTc "utype" (ppr ty1 $$ ppr ty2 $$ ppr thing) >> -- | Use this instead of 'Nothing' when calling 'unifyType' without -- a good "thing" (where the "thing" has the "actual" type passed in) -- This has an 'Outputable' instance, avoiding amgiguity problems. -noThing :: Maybe (HsExpr Name) +noThing :: Maybe (HsExpr GhcRn) noThing = Nothing unifyKind :: Outputable a => Maybe a -> TcKind -> TcKind -> TcM CoercionN diff --git a/compiler/typecheck/TcUnify.hs-boot b/compiler/typecheck/TcUnify.hs-boot index 4d36bfa2d9..9af4c27775 100644 --- a/compiler/typecheck/TcUnify.hs-boot +++ b/compiler/typecheck/TcUnify.hs-boot @@ -1,14 +1,14 @@ module TcUnify where -import TcType ( TcTauType ) -import TcRnTypes ( TcM ) -import TcEvidence ( TcCoercion ) -import Outputable ( Outputable ) -import HsExpr ( HsExpr ) -import Name ( Name ) +import TcType ( TcTauType ) +import TcRnTypes ( TcM ) +import TcEvidence ( TcCoercion ) +import Outputable ( Outputable ) +import HsExpr ( HsExpr ) +import HsExtension ( GhcRn ) -- This boot file exists only to tie the knot between -- TcUnify and Inst unifyType :: Outputable a => Maybe a -> TcTauType -> TcTauType -> TcM TcCoercion unifyKind :: Outputable a => Maybe a -> TcTauType -> TcTauType -> TcM TcCoercion -noThing :: Maybe (HsExpr Name) +noThing :: Maybe (HsExpr GhcRn) diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs index a938d12a08..4c2d1693e4 100644 --- a/compiler/typecheck/TcValidity.hs +++ b/compiler/typecheck/TcValidity.hs @@ -1274,7 +1274,7 @@ and we /really/ don't want that. So we carefully do /not/ expand synonyms, by matching on TyConApp directly. -} -checkValidInstance :: UserTypeCtxt -> LHsSigType Name -> Type +checkValidInstance :: UserTypeCtxt -> LHsSigType GhcRn -> Type -> TcM ([TyVar], ThetaType, Class, [Type]) checkValidInstance ctxt hs_type ty | not is_tc_app diff --git a/docs/users_guide/8.4.1-notes.rst b/docs/users_guide/8.4.1-notes.rst index 72d6901d18..5929998e95 100644 --- a/docs/users_guide/8.4.1-notes.rst +++ b/docs/users_guide/8.4.1-notes.rst @@ -94,3 +94,37 @@ Template Haskell ``ghc`` library ~~~~~~~~~~~~~~~ + +- hsSyn Abstract Syntax Tree (AST) is now extensible via the mechanism described in `Trees that Grow <http://www.jucs.org/jucs_23_1/trees_that_grow/jucs_23_01_0042_0062_najd.pdf>`_ + + The main change for users of the GHC API is that the AST is no longer indexed + by the type used as the identifier, but by a specific index type, :: + + type GhcPs = GhcPass 'Parsed -- Old 'RdrName' type param + type GhcRn = GhcPass 'Renamed -- Old 'Name' type param + type GhcTc = GhcPass 'Typechecked -- Old 'Id' type para, + type GhcTcId = GhcTc -- Old 'TcId' type param + + The simplest way to support the current GHC as well as earlier ones is to define :: + + #if MIN_VERSION_ghc(8,3,0) + type ParseI = GhcPs + type RenameI = GhcRn + type TypecheckI = GhcTc + #else + type ParseI = RdrName + type RenameI = Name + type TypecheckI = Var + #endif + + and then replace all hardcoded index types accordingly. For polymorphic types, + the constraint :: + + #if MIN_VERSION_ghc(8,3,0) + -- |bundle up the constraints required for a trees that grow pass + type IsPass pass = (DataId pass, OutputableBndrId pass, SourceTextX pass) + else + type IsPass pass = (DataId pass, OutputableBndrId pass) + #endif + + can be used. diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index 6954002645..5f81a2ce7c 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -59,7 +59,7 @@ import Packages ( trusted, getPackageDetails, getInstalledPackageDetails, import IfaceSyn ( showToHeader ) import PprTyThing import PrelNames -import RdrName ( RdrName, getGRE_NameQualifier_maybes, getRdrName ) +import RdrName ( getGRE_NameQualifier_maybes, getRdrName ) import SrcLoc import qualified Lexer @@ -1566,7 +1566,7 @@ cmdCmd str = handleSourceError GHC.printException $ do -- | Generate a typed ghciStepIO expression -- @ghciStepIO :: Ty String -> IO String@. -getGhciStepIO :: GHCi (LHsExpr RdrName) +getGhciStepIO :: GHCi (LHsExpr GhcPs) getGhciStepIO = do ghciTyConName <- GHC.getGHCiMonad let stringTy = nlHsTyVar stringTy_RDR @@ -2385,7 +2385,7 @@ iiModuleName (IIDecl d) = unLoc (ideclName d) preludeModuleName :: ModuleName preludeModuleName = GHC.mkModuleName "Prelude" -sameImpModule :: ImportDecl RdrName -> InteractiveImport -> Bool +sameImpModule :: ImportDecl GhcPs -> InteractiveImport -> Bool sameImpModule _ (IIModule _) = False -- we only care about imports here sameImpModule imp (IIDecl d) = unLoc (ideclName d) == unLoc (ideclName imp) diff --git a/ghc/GHCi/UI/Info.hs b/ghc/GHCi/UI/Info.hs index ef5e9ef207..a114ebff29 100644 --- a/ghc/GHCi/UI/Info.hs +++ b/ghc/GHCi/UI/Info.hs @@ -308,13 +308,13 @@ processAllTypeCheckedModule tcm = do tcs = tm_typechecked_source tcm -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsBind's - getTypeLHsBind :: LHsBind Id -> m (Maybe (Maybe Id,SrcSpan,Type)) + getTypeLHsBind :: LHsBind GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type)) getTypeLHsBind (L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _typ _}) = pure $ Just (Just (unLoc pid),getLoc pid,varType (unLoc pid)) getTypeLHsBind _ = pure Nothing -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsExpr's - getTypeLHsExpr :: LHsExpr Id -> m (Maybe (Maybe Id,SrcSpan,Type)) + getTypeLHsExpr :: LHsExpr GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type)) getTypeLHsExpr e = do hs_env <- getSession (_,mbe) <- liftIO $ deSugarExpr hs_env e @@ -328,7 +328,7 @@ processAllTypeCheckedModule tcm = do unwrapVar e' = e' -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LPats's - getTypeLPat :: LPat Id -> m (Maybe (Maybe Id,SrcSpan,Type)) + getTypeLPat :: LPat GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type)) getTypeLPat (L spn pat) = pure (Just (getMaybeId pat,spn,hsPatType pat)) where diff --git a/ghc/GHCi/UI/Monad.hs b/ghc/GHCi/UI/Monad.hs index bb946cc7b1..46f0860ab9 100644 --- a/ghc/GHCi/UI/Monad.hs +++ b/ghc/GHCi/UI/Monad.hs @@ -44,8 +44,7 @@ import SrcLoc import Module import GHCi import GHCi.RemoteTypes -import HsSyn (ImportDecl) -import RdrName (RdrName) +import HsSyn (ImportDecl, GhcPs) import Util import Exception @@ -109,7 +108,7 @@ data GHCiState = GHCiState -- :load, :reload, and :add. In between it may be modified -- by :module. - extra_imports :: [ImportDecl RdrName], + extra_imports :: [ImportDecl GhcPs], -- ^ These are "always-on" imports, added to the -- context regardless of what other imports we have. -- This is useful for adding imports that are required @@ -122,7 +121,7 @@ data GHCiState = GHCiState -- on the GHCi code. Potentially we could also expose -- this functionality via GHCi commands. - prelude_imports :: [ImportDecl RdrName], + prelude_imports :: [ImportDecl GhcPs], -- ^ These imports are added to the context when -- -XImplicitPrelude is on and we don't have a *-module -- in the context. They can also be overridden by another diff --git a/testsuite/tests/ghc-api/annotations-literals/parsed.hs b/testsuite/tests/ghc-api/annotations-literals/parsed.hs index d040a6d3b2..defa26569b 100644 --- a/testsuite/tests/ghc-api/annotations-literals/parsed.hs +++ b/testsuite/tests/ghc-api/annotations-literals/parsed.hs @@ -41,7 +41,7 @@ testOneFile libdir fileName = do where gq ast = everything (++) ([] `mkQ` doHsLit `extQ` doOverLit) ast - doHsLit :: HsLit -> [String] + doHsLit :: HsLit GhcPs -> [String] doHsLit (HsChar (SourceText src) c) = ["HsChar [" ++ src ++ "] " ++ show c] doHsLit (HsCharPrim (SourceText src) c) @@ -50,9 +50,9 @@ testOneFile libdir fileName = do = ["HsString [" ++ src ++ "] " ++ show c] doHsLit (HsStringPrim (SourceText src) c) = ["HsStringPrim [" ++ src ++ "] " ++ show c] - doHsLit (HsInt (IL (SourceText src) _ c)) + doHsLit (HsInt _ (IL (SourceText src) _ c)) = ["HsInt [" ++ src ++ "] " ++ show c] - doHsLit (HsIntPrim (SourceText src) c) + doHsLit (HsIntPrim (SourceText src) c) = ["HsIntPrim [" ++ src ++ "] " ++ show c] doHsLit (HsWordPrim (SourceText src) c) = ["HsWordPrim [" ++ src ++ "] " ++ show c] diff --git a/testsuite/tests/ghc-api/annotations/parseTree.hs b/testsuite/tests/ghc-api/annotations/parseTree.hs index 2794f22607..3a8a29abd4 100644 --- a/testsuite/tests/ghc-api/annotations/parseTree.hs +++ b/testsuite/tests/ghc-api/annotations/parseTree.hs @@ -50,7 +50,7 @@ testOneFile libdir fileName = do where gq ast = everything (++) ([] `mkQ` doLHsTupArg) ast - doLHsTupArg :: LHsTupArg RdrName -> [(SrcSpan,String,HsExpr RdrName)] + doLHsTupArg :: LHsTupArg GhcPs -> [(SrcSpan,String,HsExpr GhcPs)] doLHsTupArg (L l arg@(Present _)) = [(l,"p",ExplicitTuple [L l arg] Boxed)] doLHsTupArg (L l arg@(Missing _)) = [(l,"m",ExplicitTuple [L l arg] Boxed)] diff --git a/testsuite/tests/ghc-api/annotations/stringSource.hs b/testsuite/tests/ghc-api/annotations/stringSource.hs index bf691ae8ea..b89911d6c7 100644 --- a/testsuite/tests/ghc-api/annotations/stringSource.hs +++ b/testsuite/tests/ghc-api/annotations/stringSource.hs @@ -60,7 +60,7 @@ testOneFile libdir fileName = do doWarningTxt ((WarningTxt _ ss)) = [("w",map conv ss)] doWarningTxt ((DeprecatedTxt _ ss)) = [("d",map conv ss)] - doImportDecl :: ImportDecl RdrName + doImportDecl :: ImportDecl GhcPs -> [(String,[Located (SourceText,FastString)])] doImportDecl (ImportDecl _ _ Nothing _ _ _ _ _ _) = [] doImportDecl (ImportDecl _ _ (Just ss) _ _ _ _ _ _) @@ -71,7 +71,7 @@ testOneFile libdir fileName = do = [("c",[noLoc (hs,hf),noLoc c])] doCType (CType src Nothing c) = [("c",[noLoc c])] - doRuleDecl :: RuleDecl RdrName + doRuleDecl :: RuleDecl GhcPs -> [(String,[Located (SourceText,FastString)])] doRuleDecl (HsRule ss _ _ _ _ _ _) = [("r",[ss])] @@ -79,7 +79,7 @@ testOneFile libdir fileName = do -> [(String,[Located (SourceText,FastString)])] doCCallTarget (StaticTarget s f _ _) = [("st",[(noLoc (s,f))])] - doHsExpr :: HsExpr RdrName -> [(String,[Located (SourceText,FastString)])] + doHsExpr :: HsExpr GhcPs -> [(String,[Located (SourceText,FastString)])] doHsExpr (HsCoreAnn src ss _) = [("co",[conv (noLoc ss)])] doHsExpr (HsSCC src ss _) = [("sc",[conv (noLoc ss)])] doHsExpr (HsTickPragma src (ss,_,_) _ss2 _) = [("tp",[conv (noLoc ss)])] diff --git a/testsuite/tests/ghc-api/annotations/t11430.hs b/testsuite/tests/ghc-api/annotations/t11430.hs index 151efbe611..4b8119459b 100644 --- a/testsuite/tests/ghc-api/annotations/t11430.hs +++ b/testsuite/tests/ghc-api/annotations/t11430.hs @@ -58,7 +58,7 @@ testOneFile libdir fileName = do doFixity :: Fixity -> [(String,[String])] doFixity (Fixity (SourceText ss) _ _) = [("f",[ss])] - doRuleDecl :: RuleDecl RdrName + doRuleDecl :: RuleDecl GhcPs -> [(String,[String])] doRuleDecl (HsRule _ (ActiveBefore (SourceText ss) _) _ _ _ _ _) = [("rb",[ss])] @@ -66,7 +66,7 @@ testOneFile libdir fileName = do = [("ra",[ss])] doRuleDecl (HsRule _ _ _ _ _ _ _) = [] - doHsExpr :: HsExpr RdrName -> [(String,[String])] + doHsExpr :: HsExpr GhcPs -> [(String,[String])] doHsExpr (HsTickPragma src (_,_,_) ss _) = [("tp",[show ss])] doHsExpr _ = [] diff --git a/testsuite/tests/indexed-types/should_fail/T13784.hs b/testsuite/tests/indexed-types/should_fail/T13784.hs index 0a0ae044f4..36c72b98af 100644 --- a/testsuite/tests/indexed-types/should_fail/T13784.hs +++ b/testsuite/tests/indexed-types/should_fail/T13784.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, GADTs #-} -{-# LANGUAGE KindSignatures, MultiParamTypeClasses, TypeFamilies, TypeOperators #-} +{-# LANGUAGE KindSignatures, MultiParamTypeClasses, TypeFamilies, + TypeOperators #-} module T13784 where @@ -22,7 +23,8 @@ class Divideable a as where instance Divideable a (a : as) where -- type Divide a (a : as) = as - -- Conflicting type family instances, seems like OVERLAPS isn't a thing for type families. + -- Conflicting type family instances, seems like OVERLAPS isn't a thing for + -- type families. divide (a :* as) = (a, as) instance Divideable b as => Divideable b (a : as) where diff --git a/testsuite/tests/indexed-types/should_fail/T13784.stderr b/testsuite/tests/indexed-types/should_fail/T13784.stderr index 547809c63f..79007badb3 100644 --- a/testsuite/tests/indexed-types/should_fail/T13784.stderr +++ b/testsuite/tests/indexed-types/should_fail/T13784.stderr @@ -1,26 +1,26 @@ -T13784.hs:26:28: error: +T13784.hs:28:28: error: • Could not deduce: as1 ~ (a1 : Divide a1 as1) from the context: (a : as) ~ (a1 : as1) bound by a pattern with constructor: :* :: forall a (as :: [*]). a -> Product as -> Product (a : as), in an equation for ‘divide’ - at T13784.hs:26:13-19 + at T13784.hs:28:13-19 ‘as1’ is a rigid type variable bound by a pattern with constructor: :* :: forall a (as :: [*]). a -> Product as -> Product (a : as), in an equation for ‘divide’ - at T13784.hs:26:13-19 + at T13784.hs:28:13-19 Expected type: Product (Divide a (a : as)) Actual type: Product as1 • In the expression: as In the expression: (a, as) In an equation for ‘divide’: divide (a :* as) = (a, as) • Relevant bindings include - as :: Product as1 (bound at T13784.hs:26:18) - a :: a1 (bound at T13784.hs:26:13) + as :: Product as1 (bound at T13784.hs:28:18) + a :: a1 (bound at T13784.hs:28:13) -T13784.hs:30:24: error: +T13784.hs:32:24: error: • Couldn't match type ‘Product (a1 : as0)’ with ‘(b, Product (Divide b (a1 : as1)))’ Expected type: (b, Product (Divide b (a : as))) @@ -29,16 +29,16 @@ T13784.hs:30:24: error: In an equation for ‘divide’: divide (a :* as) = a :* divide as In the instance declaration for ‘Divideable b (a : as)’ • Relevant bindings include - as :: Product as1 (bound at T13784.hs:30:18) - a :: a1 (bound at T13784.hs:30:13) + as :: Product as1 (bound at T13784.hs:32:18) + a :: a1 (bound at T13784.hs:32:13) divide :: Product (a : as) -> (b, Product (Divide b (a : as))) - (bound at T13784.hs:30:5) + (bound at T13784.hs:32:5) -T13784.hs:30:29: error: +T13784.hs:32:29: error: • Couldn't match expected type ‘Product as0’ with actual type ‘(a0, Product (Divide a0 as1))’ • In the second argument of ‘(:*)’, namely ‘divide as’ In the expression: a :* divide as In an equation for ‘divide’: divide (a :* as) = a :* divide as • Relevant bindings include - as :: Product as1 (bound at T13784.hs:30:18) + as :: Product as1 (bound at T13784.hs:32:18) diff --git a/testsuite/tests/quasiquotation/T7918.hs b/testsuite/tests/quasiquotation/T7918.hs index 0f32699415..42bb1b05c8 100644 --- a/testsuite/tests/quasiquotation/T7918.hs +++ b/testsuite/tests/quasiquotation/T7918.hs @@ -28,19 +28,19 @@ traverse a = showPatVar (cast a) gmapM traverse a where - showVar :: Maybe (HsExpr Id) -> Traverse () + showVar :: Maybe (HsExpr GhcTc) -> Traverse () showVar (Just (HsVar (L _ v))) = modify $ \(loc, ids) -> (loc, (varName v, loc) : ids) showVar _ = return () - showTyVar :: Maybe (HsType Name) -> Traverse () + showTyVar :: Maybe (HsType GhcRn) -> Traverse () showTyVar (Just (HsTyVar _ (L _ v))) = modify $ \(loc, ids) -> (loc, (v, loc) : ids) showTyVar _ = return () - showPatVar :: Maybe (Pat Id) -> Traverse () + showPatVar :: Maybe (Pat GhcTc) -> Traverse () showPatVar (Just (VarPat (L _ v))) = modify $ \(loc, ids) -> (loc, (varName v, loc) : ids) showPatVar _ diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs index 138687e5fa..269e040d36 100644 --- a/utils/ghctags/Main.hs +++ b/utils/ghctags/Main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} module Main where import Prelude hiding ( mod, id, mapM ) @@ -248,7 +249,7 @@ fileData filename modname (group, _imports, _lie, _doc) = do line_map' <- evaluate line_map return $ FileData filename (boundValues modname group) line_map' -boundValues :: ModuleName -> HsGroup Name -> [FoundThing] +boundValues :: ModuleName -> HsGroup GhcRn -> [FoundThing] -- ^Finds all the top-level definitions in a module boundValues mod group = let vals = case hs_valds group of @@ -275,7 +276,7 @@ startOfLocated lHs = case getLoc lHs of foundOfLName :: ModuleName -> Located Name -> FoundThing foundOfLName mod id = FoundThing mod (getOccString $ unLoc id) (startOfLocated id) -boundThings :: ModuleName -> LHsBind Name -> [FoundThing] +boundThings :: ModuleName -> LHsBind GhcRn -> [FoundThing] boundThings modname lbinding = case unLoc lbinding of FunBind { fun_id = id } -> [thing id] diff --git a/utils/haddock b/utils/haddock -Subproject a1b57146c5678b32eb5ac37021e93a81a4b7300 +Subproject a9f774fa3c12f9b8e093e46d58e7872d3d47895 |