diff options
| author | Shayan-Najd <sh.najd@gmail.com> | 2018-11-22 01:23:29 +0000 |
|---|---|---|
| committer | Alan Zimmerman <alan.zimm@gmail.com> | 2018-11-24 12:30:21 +0200 |
| commit | 509d5be69c7507ba5d0a5f39ffd1613a59e73eea (patch) | |
| tree | b3db08f371014cbf235525843a312f67dea77354 | |
| parent | ad2d7612dbdf0e928318394ec0606da3b85a8837 (diff) | |
| download | haskell-509d5be69c7507ba5d0a5f39ffd1613a59e73eea.tar.gz | |
[TTG: Handling Source Locations] Foundation and Pat
This patch removes the ping-pong style from HsPat (only, for now),
using the plan laid out at
https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow/HandlingSourceLocations (solution
A).
- the class `HasSrcSpan`, and its functions (e.g., `cL` and `dL`), are introduced
- some instances of `HasSrcSpan` are introduced
- some constructors `L` are replaced with `cL`
- some patterns `L` are replaced with `dL->L` view pattern
- some type annotation are necessarily updated (e.g., `Pat p` --> `Pat (GhcPass p)`)
Phab diff: D5036
Trac Issues #15495
Updates haddock submodule
59 files changed, 2478 insertions, 1950 deletions
diff --git a/compiler/basicTypes/Name.hs b/compiler/basicTypes/Name.hs index d9eacd9af6..445606dc69 100644 --- a/compiler/basicTypes/Name.hs +++ b/compiler/basicTypes/Name.hs @@ -6,6 +6,9 @@ -} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms #-} -- | -- #name_types# @@ -202,6 +205,12 @@ nameOccName name = n_occ name nameSrcLoc name = srcSpanStart (n_loc name) nameSrcSpan name = n_loc name +type instance SrcSpanLess Name = Name +instance HasSrcSpan Name where + composeSrcSpan (L sp n) = n {n_loc = sp} + decomposeSrcSpan n = L (n_loc n) n + + {- ************************************************************************ * * @@ -668,7 +677,7 @@ class NamedThing a where getOccName n = nameOccName (getName n) -- Default method -instance NamedThing e => NamedThing (GenLocated l e) where +instance NamedThing e => NamedThing (Located e) where getName = getName . unLoc getSrcLoc :: NamedThing a => a -> SrcLoc diff --git a/compiler/basicTypes/SrcLoc.hs b/compiler/basicTypes/SrcLoc.hs index 3276f41f14..696395f82f 100644 --- a/compiler/basicTypes/SrcLoc.hs +++ b/compiler/basicTypes/SrcLoc.hs @@ -7,6 +7,11 @@ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} + -- | This module contains types that relate to the positions of things -- in source files, and allow tagging of those things with locations @@ -70,11 +75,16 @@ module SrcLoc ( -- ** Deconstructing Located getLoc, unLoc, + unRealSrcSpan, getRealSrcSpan, -- ** Combining and comparing Located values eqLocated, cmpLocated, combineLocs, addCLoc, leftmost_smallest, leftmost_largest, rightmost, - spans, isSubspanOf, sortLocated + spans, isSubspanOf, sortLocated, + + -- ** HasSrcSpan + HasSrcSpan(..), SrcSpanLess, dL, cL, + pattern LL, onHasSrcSpan, liftL ) where import GhcPrelude @@ -169,7 +179,7 @@ advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1) ************************************************************************ -} -sortLocated :: [Located a] -> [Located a] +sortLocated :: HasSrcSpan a => [a] -> [a] sortLocated things = sortBy (comparing getLoc) things instance Outputable RealSrcLoc where @@ -517,35 +527,36 @@ data GenLocated l e = L l e type Located = GenLocated SrcSpan type RealLocated = GenLocated RealSrcSpan -unLoc :: GenLocated l e -> e -unLoc (L _ e) = e +unLoc :: HasSrcSpan a => a -> SrcSpanLess a +unLoc (dL->L _ e) = e -getLoc :: GenLocated l e -> l -getLoc (L l _) = l +getLoc :: HasSrcSpan a => a -> SrcSpan +getLoc (dL->L l _) = l -noLoc :: e -> Located e -noLoc e = L noSrcSpan e +noLoc :: HasSrcSpan a => SrcSpanLess a -> a +noLoc e = cL noSrcSpan e -mkGeneralLocated :: String -> e -> Located e -mkGeneralLocated s e = L (mkGeneralSrcSpan (fsLit s)) e +mkGeneralLocated :: HasSrcSpan e => String -> SrcSpanLess e -> e +mkGeneralLocated s e = cL (mkGeneralSrcSpan (fsLit s)) e -combineLocs :: Located a -> Located b -> SrcSpan +combineLocs :: (HasSrcSpan a , HasSrcSpan b) => a -> b -> SrcSpan combineLocs a b = combineSrcSpans (getLoc a) (getLoc b) -- | Combine locations from two 'Located' things and add them to a third thing -addCLoc :: Located a -> Located b -> c -> Located c -addCLoc a b c = L (combineSrcSpans (getLoc a) (getLoc b)) c +addCLoc :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) => + a -> b -> SrcSpanLess c -> c +addCLoc a b c = cL (combineSrcSpans (getLoc a) (getLoc b)) c -- not clear whether to add a general Eq instance, but this is useful sometimes: -- | Tests whether the two located things are equal -eqLocated :: Eq a => Located a -> Located a -> Bool +eqLocated :: (HasSrcSpan a , Eq (SrcSpanLess a)) => a -> a -> Bool eqLocated a b = unLoc a == unLoc b -- not clear whether to add a general Ord instance, but this is useful sometimes: -- | Tests the ordering of the two located things -cmpLocated :: Ord a => Located a -> Located a -> Ordering +cmpLocated :: (HasSrcSpan a , Ord (SrcSpanLess a)) => a -> a -> Ordering cmpLocated a b = unLoc a `compare` unLoc b instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where @@ -586,3 +597,94 @@ isSubspanOf src parent | srcSpanFileName_maybe parent /= srcSpanFileName_maybe src = False | otherwise = srcSpanStart parent <= srcSpanStart src && srcSpanEnd parent >= srcSpanEnd src + + +{- +************************************************************************ +* * +\subsection{HasSrcSpan Typeclass to Set/Get Source Location Spans} +* * +************************************************************************ +-} + +{- +Note [HasSrcSpan Typeclass] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +To be able to uniformly set/get source location spans (of `SrcSpan`) in +syntactic entities (`HsSyn`), we use the typeclass `HasSrcSpan`. +More details can be found at the following wiki page + ImplementingTreesThatGrow/HandlingSourceLocations + +For most syntactic entities, the source location spans are stored in +a syntactic entity by a wapper constuctor (introduced by TTG's +new constructor extension), e.g., by `NewPat (WrapperPat sp pat)` +for a source location span `sp` and a pattern `pat`. +-} + +-- | Determines the type of undecorated syntactic entities +-- For most syntactic entities `E`, where source location spans are +-- introduced by a wrapper construtor of the same syntactic entity, +-- we have `SrcSpanLess E = E`. +-- However, some syntactic entities have a different type compared to +-- a syntactic entity `e :: E` may have the type `Located E` when +-- decorated by wrapping it with `L sp e` for a source span `sp`. +type family SrcSpanLess a + +-- | A typeclass to set/get SrcSpans +class HasSrcSpan a where + -- | Composes a `SrcSpan` decoration with an undecorated syntactic + -- entity to form its decorated variant + composeSrcSpan :: Located (SrcSpanLess a) -> a + + -- | Decomposes a decorated syntactic entity into its `SrcSpan` + -- decoration and its undecorated variant + decomposeSrcSpan :: a -> Located (SrcSpanLess a) + {- laws: + composeSrcSpan . decomposeSrcSpan = id + decomposeSrcSpan . composeSrcSpan = id + + in other words, `HasSrcSpan` defines an iso relation between + a `SrcSpan`-decorated syntactic entity and its undecorated variant + (together with the `SrcSpan`). + -} + +type instance SrcSpanLess (GenLocated l e) = e +instance HasSrcSpan (Located a) where + composeSrcSpan = id + decomposeSrcSpan = id + + +-- | An abbreviated form of decomposeSrcSpan, +-- mainly to be used in ViewPatterns +dL :: HasSrcSpan a => a -> Located (SrcSpanLess a) +dL = decomposeSrcSpan + +-- | An abbreviated form of composeSrcSpan, +-- mainly to replace the hardcoded `L` +cL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a +cL sp e = composeSrcSpan (L sp e) + +-- | A Pattern Synonym to Set/Get SrcSpans +pattern LL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a +pattern LL sp e <- (dL->L sp e) + where + LL sp e = cL sp e + +-- | Lifts a function of undecorated entities to one of decorated ones +onHasSrcSpan :: (HasSrcSpan a , HasSrcSpan b) => + (SrcSpanLess a -> SrcSpanLess b) -> a -> b +onHasSrcSpan f (dL->L l e) = cL l (f e) + +liftL :: (HasSrcSpan a, HasSrcSpan b, Monad m) => + (SrcSpanLess a -> m (SrcSpanLess b)) -> a -> m b +liftL f (dL->L loc a) = do + a' <- f a + return $ cL loc a' + + +getRealSrcSpan :: RealLocated a -> RealSrcSpan +getRealSrcSpan (L l _) = l + +unRealSrcSpan :: RealLocated a -> a +unRealSrcSpan (L _ e) = e diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs index cba86dfe4d..c1c260d0c8 100644 --- a/compiler/deSugar/Check.hs +++ b/compiler/deSugar/Check.hs @@ -6,6 +6,7 @@ Pattern Matching Coverage Checking. {-# LANGUAGE CPP, GADTs, DataKinds, KindSignatures #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} module Check ( -- Checking and printing @@ -342,7 +343,7 @@ checkSingle' locn var p = do (Covered, _ ) -> PmResult prov [] us' [] -- useful (NotCovered, NotDiverged) -> PmResult prov m us' [] -- redundant (NotCovered, Diverged ) -> PmResult prov [] us' m -- inaccessible rhs - where m = [L locn [L locn p]] + where m = [cL locn [cL locn p]] -- | Exhaustive for guard matches, is used for guards in pattern bindings and -- in @MultiIf@ expressions. @@ -353,7 +354,7 @@ checkGuardMatches hs_ctx guards@(GRHSs _ grhss _) = do dflags <- getDynFlags let combinedLoc = foldl1 combineSrcSpans (map getLoc grhss) dsMatchContext = DsMatchContext hs_ctx combinedLoc - match = L combinedLoc $ + match = cL combinedLoc $ Match { m_ext = noExt , m_ctxt = hs_ctx , m_pats = [] @@ -419,8 +420,8 @@ checkMatches' vars matches (NotCovered, Diverged ) -> (final_prov, rs, final_u, m:is) hsLMatchToLPats :: LMatch id body -> Located [LPat id] - hsLMatchToLPats (L l (Match { m_pats = pats })) = L l pats - hsLMatchToLPats (L _ (XMatch _)) = panic "checMatches'" + hsLMatchToLPats (dL->L l (Match { m_pats = pats })) = cL l pats + hsLMatchToLPats _ = panic "checMatches'" -- | Check an empty case expression. Since there are no clauses to process, we -- only compute the uncovered set. See Note [Checking EmptyCase Expressions] @@ -986,7 +987,7 @@ translatePat fam_insts pat = case pat of return [xp,g] -- (n + k) ===> x (True <- x >= k) (n <- x-k) - NPlusKPat ty (L _ _n) _k1 _k2 _ge _minus -> mkCanFailPmPat ty + NPlusKPat ty (dL->L _ _n) _k1 _k2 _ge _minus -> mkCanFailPmPat ty -- (fun -> pat) ===> x (pat <- fun x) ViewPat arg_ty lexpr lpat -> do @@ -1031,7 +1032,7 @@ translatePat fam_insts pat = case pat of -- pattern and do further translation as an optimization, for the reason, -- see Note [Guards and Approximation]. - ConPatOut { pat_con = L _ con + ConPatOut { pat_con = (dL->L _ con) , pat_arg_tys = arg_tys , pat_tvs = ex_tvs , pat_dicts = dicts @@ -1048,7 +1049,7 @@ translatePat fam_insts pat = case pat of , pm_con_args = args }] -- See Note [Translate Overloaded Literal for Exhaustiveness Checking] - NPat _ (L _ olit) mb_neg _ + NPat _ (dL->L _ olit) mb_neg _ | OverLit (OverLitTc False ty) (HsIsString src s) _ <- olit , isStringTy ty -> foldr (mkListPatVec charTy) [nilPattern charTy] <$> @@ -1216,7 +1217,7 @@ translateConPatVec fam_insts univ_tys ex_tvs c (RecCon (HsRecFields fs _)) -- Some label information orig_lbls = map flSelector $ conLikeFieldLabels c matched_pats = [ (getName (unLoc (hsRecFieldId x)), unLoc (hsRecFieldArg x)) - | L _ x <- fs] + | (dL->L _ x) <- fs] matched_lbls = [ name | (name, _pat) <- matched_pats ] subsetOf :: Eq a => [a] -> [a] -> Bool @@ -1229,18 +1230,19 @@ translateConPatVec fam_insts univ_tys ex_tvs c (RecCon (HsRecFields fs _)) -- Translate a single match translateMatch :: FamInstEnvs -> LMatch GhcTc (LHsExpr GhcTc) -> DsM (PatVec,[PatVec]) -translateMatch fam_insts (L _ (Match { m_pats = lpats, m_grhss = grhss })) = do +translateMatch fam_insts (dL->L _ (Match { m_pats = lpats, m_grhss = grhss })) = + do pats' <- concat <$> translatePatVec fam_insts pats guards' <- mapM (translateGuards fam_insts) guards return (pats', guards') where extractGuards :: LGRHS GhcTc (LHsExpr GhcTc) -> [GuardStmt GhcTc] - extractGuards (L _ (GRHS _ gs _)) = map unLoc gs - extractGuards (L _ (XGRHS _)) = panic "translateMatch" + extractGuards (dL->L _ (GRHS _ gs _)) = map unLoc gs + extractGuards _ = panic "translateMatch" pats = map unLoc lpats guards = map extractGuards (grhssGRHSs grhss) -translateMatch _ (L _ (XMatch _)) = panic "translateMatch" +translateMatch _ _ = panic "translateMatch" -- ----------------------------------------------------------------------- -- * Transform source guards (GuardStmt Id) to PmPats (Pattern) @@ -1304,7 +1306,7 @@ translateLet _binds = return [] -- | Translate a pattern guard translateBind :: FamInstEnvs -> LPat GhcTc -> LHsExpr GhcTc -> DsM PatVec -translateBind fam_insts (L _ p) e = do +translateBind fam_insts (dL->L _ p) e = do ps <- translatePat fam_insts p return [mkGuard ps (unLoc e)] @@ -2457,10 +2459,10 @@ dsPmWarn dflags ctx@(DsMatchContext kind loc) pm_result TypeOfUncovered _ -> True UncoveredPatterns u -> notNull u) - when exists_r $ forM_ redundant $ \(L l q) -> do + when exists_r $ forM_ redundant $ \(dL->L l q) -> do putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns) (pprEqn q "is redundant")) - when exists_i $ forM_ inaccessible $ \(L l q) -> do + when exists_i $ forM_ inaccessible $ \(dL->L l q) -> do putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns) (pprEqn q "has inaccessible right hand side")) when exists_u $ putSrcSpanDs loc $ warnDs flag_u_reason $ @@ -2583,7 +2585,7 @@ pp_context singular (DsMatchContext kind _loc) msg rest_of_msg_fun (ppr_match, pref) = case kind of - FunRhs { mc_fun = L _ fun } + FunRhs { mc_fun = (dL->L _ fun) } -> (pprMatchContext kind, \ pp -> ppr fun <+> pp) _ -> (pprMatchContext kind, \ pp -> pp) diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index 7ca18c7d2e..1dbacfc47f 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -4,6 +4,8 @@ -} {-# LANGUAGE NondecreasingIndentation, RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} module Coverage (addTicksToBinds, hpcInitCode) where @@ -119,7 +121,7 @@ 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. - let top_pos = catMaybes $ foldrBag (\ (L pos _) rest -> + let top_pos = catMaybes $ foldrBag (\ (dL->L pos _) rest -> srcSpanFileName_maybe pos : rest) [] binds in case top_pos of @@ -253,12 +255,12 @@ addTickLHsBinds :: LHsBinds GhcTc -> TM (LHsBinds GhcTc) addTickLHsBinds = mapBagM addTickLHsBind addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc) -addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds, +addTickLHsBind (dL->L pos bind@(AbsBinds { abs_binds = binds, abs_exports = abs_exports })) = do withEnv add_exports $ do withEnv add_inlines $ do binds' <- addTickLHsBinds binds - return $ L pos $ bind { abs_binds = binds' } + return $ cL pos $ bind { abs_binds = binds' } where -- in AbsBinds, the Id on each binding is not the actual top-level -- Id that we are defining, they are related by the abs_exports @@ -278,7 +280,7 @@ addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds, | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports , isInlinePragma (idInlinePragma pid) ] } -addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do +addTickLHsBind (dL->L pos (funBind@(FunBind { fun_id = (dL->L _ id) }))) = do let name = getOccString id decl_path <- getPathEntry density <- getDensity @@ -290,7 +292,7 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do -- See Note [inline sccs] tickish <- tickishType `liftM` getEnv - if inline && tickish == ProfNotes then return (L pos funBind) else do + if inline && tickish == ProfNotes then return (cL pos funBind) else do (fvs, mg) <- getFreeVars $ @@ -319,8 +321,8 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do return Nothing let mbCons = maybe Prelude.id (:) - return $ L pos $ funBind { fun_matches = mg - , fun_tick = tick `mbCons` fun_tick funBind } + return $ cL pos $ funBind { fun_matches = mg + , fun_tick = tick `mbCons` fun_tick funBind } where -- a binding is a simple pattern binding if it is a funbind with @@ -329,7 +331,8 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0 -- TODO: Revisit this -addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs, pat_rhs = rhs }))) = do +addTickLHsBind (dL->L pos (pat@(PatBind { pat_lhs = lhs + , pat_rhs = rhs }))) = do let name = "(...)" (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs let pat' = pat { pat_rhs = rhs'} @@ -338,7 +341,9 @@ addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs, pat_rhs = rhs }))) = do density <- getDensity decl_path <- getPathEntry let top_lev = null decl_path - if not (shouldTickPatBind density top_lev) then return (L pos pat') else do + if not (shouldTickPatBind density top_lev) + then return (cL pos pat') + else do -- Allocate the ticks rhs_tick <- bindTick density name pos fvs @@ -350,12 +355,14 @@ addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs, pat_rhs = rhs }))) = do rhs_ticks = rhs_tick `mbCons` fst (pat_ticks pat') patvar_tickss = zipWith mbCons patvar_ticks (snd (pat_ticks pat') ++ repeat []) - return $ L pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) } + return $ cL pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) } -- Only internal stuff, not from source, uses VarBind, so we ignore it. -addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind -addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind -addTickLHsBind bind@(L _ (XHsBindsLR {})) = return bind +addTickLHsBind var_bind@(dL->L _ (VarBind {})) = return var_bind +addTickLHsBind patsyn_bind@(dL->L _ (PatSynBind {})) = return patsyn_bind +addTickLHsBind bind@(dL->L _ (XHsBindsLR {})) = return bind +addTickLHsBind _ = panic "addTickLHsBind: Impossible Match" -- due to #15884 + bindTick @@ -390,7 +397,7 @@ bindTick density name pos fvs = do -- selectively add ticks to interesting expressions addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickLHsExpr e@(L pos e0) = do +addTickLHsExpr e@(dL->L pos e0) = do d <- getDensity case d of TickForBreakPoints | isGoodBreakExpr e0 -> tick_it @@ -406,7 +413,7 @@ addTickLHsExpr e@(L pos e0) = do -- (because the body will definitely have a tick somewhere). ToDo: perhaps -- we should treat 'case' and 'if' the same way? addTickLHsExprRHS :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickLHsExprRHS e@(L pos e0) = do +addTickLHsExprRHS e@(dL->L pos e0) = do d <- getDensity case d of TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it @@ -435,7 +442,7 @@ addTickLHsExprEvalInner e = do -- break012. This gives the user the opportunity to inspect the -- values of the let-bound variables. addTickLHsExprLetBody :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickLHsExprLetBody e@(L pos e0) = do +addTickLHsExprLetBody e@(dL->L pos e0) = do d <- getDensity case d of TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it @@ -449,9 +456,9 @@ addTickLHsExprLetBody e@(L pos e0) = do -- because the scope of this tick is completely subsumed by -- another. addTickLHsExprNever :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickLHsExprNever (L pos e0) = do +addTickLHsExprNever (dL->L pos e0) = do e1 <- addTickHsExpr e0 - return $ L pos e1 + return $ cL pos e1 -- general heuristic: expressions which do not denote values are good -- break points @@ -468,16 +475,16 @@ isCallSite OpApp{} = True isCallSite _ = False addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickLHsExprOptAlt oneOfMany (L pos e0) +addTickLHsExprOptAlt oneOfMany (dL->L pos e0) = ifDensity TickForCoverage (allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0) - (addTickLHsExpr (L pos e0)) + (addTickLHsExpr (cL pos e0)) addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addBinTickLHsExpr boxLabel (L pos e0) +addBinTickLHsExpr boxLabel (dL->L pos e0) = ifDensity TickForCoverage (allocBinTickBox boxLabel pos $ addTickHsExpr e0) - (addTickLHsExpr (L pos e0)) + (addTickLHsExpr (cL pos e0)) -- ----------------------------------------------------------------------------- @@ -486,7 +493,7 @@ addBinTickLHsExpr boxLabel (L pos e0) -- in the addTickLHsExpr family of functions.) addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc) -addTickHsExpr e@(HsVar _ (L _ id)) = do freeVar id; return e +addTickHsExpr e@(HsVar _ (dL->L _ id)) = do freeVar id; return e addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar" addTickHsExpr e@(HsConLikeOut _ con) | Just id <- conLikeWrapId_maybe con = do freeVar id; return e @@ -545,14 +552,14 @@ addTickHsExpr (HsMultiIf ty alts) = do { let isOneOfMany = case alts of [_] -> False; _ -> True ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts ; return $ HsMultiIf ty alts' } -addTickHsExpr (HsLet x (L l binds) e) = +addTickHsExpr (HsLet x (dL->L l binds) e) = bindLocals (collectLocalBinders binds) $ - liftM2 (HsLet x . L l) + liftM2 (HsLet x . cL l) (addTickHsLocalBinds binds) -- to think about: !patterns. (addTickLHsExprLetBody e) -addTickHsExpr (HsDo srcloc cxt (L l stmts)) +addTickHsExpr (HsDo srcloc cxt (dL->L l stmts)) = do { (stmts', _) <- addTickLStmts' forQual stmts (return ()) - ; return (HsDo srcloc cxt (L l stmts')) } + ; return (HsDo srcloc cxt (cL l stmts')) } where forQual = case cxt of ListComp -> Just $ BinBox QualBinBox @@ -599,7 +606,7 @@ addTickHsExpr (HsTick x t e) = addTickHsExpr (HsBinTick x t0 t1 e) = liftM (HsBinTick x t0 t1) (addTickLHsExprNever e) -addTickHsExpr (HsTickPragma _ _ _ _ (L pos e0)) = do +addTickHsExpr (HsTickPragma _ _ _ _ (dL->L pos e0)) = do e2 <- allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0 return $ unLoc e2 @@ -630,22 +637,25 @@ addTickHsExpr (HsWrap x w e) = addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e) addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc) -addTickTupArg (L l (Present x e)) = do { e' <- addTickLHsExpr e - ; return (L l (Present x e')) } -addTickTupArg (L l (Missing ty)) = return (L l (Missing ty)) -addTickTupArg (L _ (XTupArg _)) = panic "addTickTupArg" +addTickTupArg (dL->L l (Present x e)) = do { e' <- addTickLHsExpr e + ; return (cL l (Present x e')) } +addTickTupArg (dL->L l (Missing ty)) = return (cL l (Missing ty)) +addTickTupArg (dL->L _ (XTupArg _)) = panic "addTickTupArg" +addTickTupArg _ = panic "addTickTupArg: Impossible Match" -- due to #15884 + addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc) -> TM (MatchGroup GhcTc (LHsExpr GhcTc)) -addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do +addTickMatchGroup is_lam mg@(MG { mg_alts = dL->L l matches }) = do let isOneOfMany = matchesOneOfMany matches matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches - return $ mg { mg_alts = L l matches' } + return $ mg { mg_alts = cL l matches' } addTickMatchGroup _ (XMatchGroup _) = panic "addTickMatchGroup" addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc) -> TM (Match GhcTc (LHsExpr GhcTc)) -addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats, m_grhss = gRHSs }) = +addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats + , m_grhss = gRHSs }) = bindLocals (collectPatsBinders pats) $ do gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs return $ match { m_grhss = gRHSs' } @@ -653,11 +663,11 @@ addTickMatch _ _ (XMatch _) = panic "addTickMatch" addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc) -> TM (GRHSs GhcTc (LHsExpr GhcTc)) -addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (L l local_binds)) = do +addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (dL->L l local_binds)) = do bindLocals binders $ do local_binds' <- addTickHsLocalBinds local_binds guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded - return $ GRHSs x guarded' (L l local_binds') + return $ GRHSs x guarded' (cL l local_binds') where binders = collectLocalBinders local_binds addTickGRHSs _ _ (XGRHSs _) = panic "addTickGRHSs" @@ -671,7 +681,7 @@ addTickGRHS isOneOfMany isLambda (GRHS x stmts expr) = do addTickGRHS _ _ (XGRHS _) = panic "addTickGRHS" addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do +addTickGRHSBody isOneOfMany isLambda expr@(dL->L pos e0) = do d <- getDensity case d of TickForCoverage -> addTickLHsExprOptAlt isOneOfMany expr @@ -714,13 +724,13 @@ addTickStmt isGuard (BodyStmt x e bind' guard') = do (addTick isGuard e) (addTickSyntaxExpr hpcSrcSpan bind') (addTickSyntaxExpr hpcSrcSpan guard') -addTickStmt _isGuard (LetStmt x (L l binds)) = do - liftM (LetStmt x . L l) +addTickStmt _isGuard (LetStmt x (dL->L l binds)) = do + liftM (LetStmt x . cL l) (addTickHsLocalBinds binds) addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) = do liftM3 (ParStmt x) (mapM (addTickStmtAndBinders isGuard) pairs) - (unLoc <$> addTickLHsExpr (L hpcSrcSpan mzipExpr)) + (unLoc <$> addTickLHsExpr (cL hpcSrcSpan mzipExpr)) (addTickSyntaxExpr hpcSrcSpan bindExpr) addTickStmt isGuard (ApplicativeStmt body_ty args mb_join) = do args' <- mapM (addTickApplicativeArg isGuard) args @@ -735,7 +745,7 @@ addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts t_u <- addTickLHsExprRHS using t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr - L _ t_m <- addTickLHsExpr (L hpcSrcSpan liftMExpr) + t_m <- fmap unLoc (addTickLHsExpr (cL hpcSrcSpan liftMExpr)) return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m } @@ -767,7 +777,7 @@ addTickApplicativeArg isGuard (op, arg) = addTickArg (ApplicativeArgMany x stmts ret pat) = (ApplicativeArgMany x) <$> addTickLStmts isGuard stmts - <*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret)) + <*> (unLoc <$> addTickLHsExpr (cL hpcSrcSpan ret)) <*> addTickLPat pat addTickArg (XApplicativeArg _) = panic "addTickApplicativeArg" @@ -820,7 +830,7 @@ addTickIPBind (XIPBind x) = return (XIPBind x) -- There is no location here, so we might need to use a context location?? addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc) addTickSyntaxExpr pos syn@(SyntaxExpr { syn_expr = x }) = do - L _ x' <- addTickLHsExpr (L pos x) + x' <- fmap unLoc (addTickLHsExpr (cL pos x)) return $ syn { syn_expr = x' } -- we do not walk into patterns. addTickLPat :: LPat GhcTc -> TM (LPat GhcTc) @@ -834,9 +844,9 @@ addTickHsCmdTop (HsCmdTop x cmd) = addTickHsCmdTop (XCmdTop{}) = panic "addTickHsCmdTop" addTickLHsCmd :: LHsCmd GhcTc -> TM (LHsCmd GhcTc) -addTickLHsCmd (L pos c0) = do +addTickLHsCmd (dL->L pos c0) = do c1 <- addTickHsCmd c0 - return $ L pos c1 + return $ cL pos c1 addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc) addTickHsCmd (HsCmdLam x matchgroup) = @@ -861,14 +871,14 @@ addTickHsCmd (HsCmdIf x cnd e1 c2 c3) = (addBinTickLHsExpr (BinBox CondBinBox) e1) (addTickLHsCmd c2) (addTickLHsCmd c3) -addTickHsCmd (HsCmdLet x (L l binds) c) = +addTickHsCmd (HsCmdLet x (dL->L l binds) c) = bindLocals (collectLocalBinders binds) $ - liftM2 (HsCmdLet x . L l) + liftM2 (HsCmdLet x . cL l) (addTickHsLocalBinds binds) -- to think about: !patterns. (addTickLHsCmd c) -addTickHsCmd (HsCmdDo srcloc (L l stmts)) +addTickHsCmd (HsCmdDo srcloc (dL->L l stmts)) = do { (stmts', _) <- addTickLCmdStmts' stmts (return ()) - ; return (HsCmdDo srcloc (L l stmts')) } + ; return (HsCmdDo srcloc (cL l stmts')) } addTickHsCmd (HsCmdArrApp arr_ty e1 e2 ty1 lr) = liftM5 HsCmdArrApp @@ -894,9 +904,9 @@ addTickHsCmd e@(XCmd {}) = pprPanic "addTickHsCmd" (ppr e) addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc) -> TM (MatchGroup GhcTc (LHsCmd GhcTc)) -addTickCmdMatchGroup mg@(MG { mg_alts = L l matches }) = do +addTickCmdMatchGroup mg@(MG { mg_alts = (dL->L l matches) }) = do matches' <- mapM (liftL addTickCmdMatch) matches - return $ mg { mg_alts = L l matches' } + return $ mg { mg_alts = cL l matches' } addTickCmdMatchGroup (XMatchGroup _) = panic "addTickCmdMatchGroup" addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc)) @@ -907,11 +917,11 @@ addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) = addTickCmdMatch (XMatch _) = panic "addTickCmdMatch" addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc)) -addTickCmdGRHSs (GRHSs x guarded (L l local_binds)) = do +addTickCmdGRHSs (GRHSs x guarded (dL->L l local_binds)) = do bindLocals binders $ do local_binds' <- addTickHsLocalBinds local_binds guarded' <- mapM (liftL addTickCmdGRHS) guarded - return $ GRHSs x guarded' (L l local_binds') + return $ GRHSs x guarded' (cL l local_binds') where binders = collectLocalBinders local_binds addTickCmdGRHSs (XGRHSs _) = panic "addTickCmdGRHSs" @@ -958,8 +968,8 @@ addTickCmdStmt (BodyStmt x c bind' guard') = do (addTickLHsCmd c) (addTickSyntaxExpr hpcSrcSpan bind') (addTickSyntaxExpr hpcSrcSpan guard') -addTickCmdStmt (LetStmt x (L l binds)) = do - liftM (LetStmt x . L l) +addTickCmdStmt (LetStmt x (dL->L l binds)) = do + liftM (LetStmt x . cL l) (addTickHsLocalBinds binds) addTickCmdStmt stmt@(RecStmt {}) = do { stmts' <- addTickLCmdStmts (recS_stmts stmt) @@ -983,9 +993,9 @@ addTickHsRecordBinds (HsRecFields fields dd) addTickHsRecField :: LHsRecField' id (LHsExpr GhcTc) -> TM (LHsRecField' id (LHsExpr GhcTc)) -addTickHsRecField (L l (HsRecField id expr pun)) +addTickHsRecField (dL->L l (HsRecField id expr pun)) = do { expr' <- addTickLHsExpr expr - ; return (L l (HsRecField id expr' pun)) } + ; return (cL l (HsRecField id expr' pun)) } addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc) @@ -1006,11 +1016,6 @@ addTickArithSeqInfo (FromThenTo e1 e2 e3) = (addTickLHsExpr e2) (addTickLHsExpr e3) -liftL :: (Monad m) => (a -> m a) -> Located a -> m (Located a) -liftL f (L loc a) = do - a' <- f a - return $ L loc a' - data TickTransState = TT { tickBoxCount:: Int , mixEntries :: [MixEntry_] , ccIndices :: CostCentreState @@ -1172,10 +1177,10 @@ allocTickBox boxLabel countEntries topOnly pos m = (fvs, e) <- getFreeVars m env <- getEnv tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env) - return (L pos (HsTick noExt tickish (L pos e))) + return (cL pos (HsTick noExt tickish (cL pos e))) ) (do e <- m - return (L pos e) + return (cL pos e) ) -- the tick application inherits the source position of its @@ -1243,7 +1248,7 @@ allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr GhcTc) allocBinTickBox boxLabel pos m = do env <- getEnv case tickishType env of - HpcTicks -> do e <- liftM (L pos) m + HpcTicks -> do e <- liftM (cL pos) m ifGoodTickSrcSpan pos (mkBinTickBoxHpc boxLabel pos e) (return e) @@ -1259,8 +1264,8 @@ mkBinTickBoxHpc boxLabel pos e = c = tickBoxCount st mes = mixEntries st in - ( L pos $ HsTick noExt (HpcTick (this_mod env) c) - $ L pos $ HsBinTick noExt (c+1) (c+2) e + ( cL pos $ HsTick noExt (HpcTick (this_mod env) c) + $ cL pos $ HsBinTick noExt (c+1) (c+2) e -- notice that F and T are reversed, -- because we are building the list in -- reverse... @@ -1287,10 +1292,12 @@ hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals") matchesOneOfMany :: [LMatch GhcTc body] -> Bool matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1 where - matchCount (L _ (Match { m_grhss = GRHSs _ grhss _ })) = length grhss - matchCount (L _ (Match { m_grhss = XGRHSs _ })) + matchCount (dL->L _ (Match { m_grhss = GRHSs _ grhss _ })) + = length grhss + matchCount (dL->L _ (Match { m_grhss = XGRHSs _ })) = panic "matchesOneOfMany" - matchCount (L _ (XMatch _)) = panic "matchesOneOfMany" + matchCount (dL->L _ (XMatch _)) = panic "matchesOneOfMany" + matchCount _ = panic "matchCount: Impossible Match" -- due to #15884 type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel) diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs index c7973ca4f3..0ed35f2d4c 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -8,6 +8,7 @@ The Desugarer: turning HsSyn into Core. {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module Desugar ( -- * Desugaring operations @@ -379,13 +380,13 @@ Reason -} dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule) -dsRule (L loc (HsRule { rd_name = name - , rd_act = rule_act - , rd_tmvs = vars - , rd_lhs = lhs - , rd_rhs = rhs })) +dsRule (dL->L loc (HsRule { rd_name = name + , rd_act = rule_act + , rd_tmvs = vars + , rd_lhs = lhs + , rd_rhs = rhs })) = putSrcSpanDs loc $ - do { let bndrs' = [var | L _ (RuleBndr _ (L _ var)) <- vars] + do { let bndrs' = [var | (dL->L _ (RuleBndr _ (dL->L _ var))) <- vars] ; lhs' <- unsetGOptM Opt_EnableRewriteRules $ unsetWOptM Opt_WarnIdentities $ @@ -422,8 +423,8 @@ dsRule (L loc (HsRule { rd_name = name ; return (Just rule) } } } -dsRule (L _ (XRuleDecl _)) = panic "dsRule" - +dsRule (dL->L _ (XRuleDecl _)) = panic "dsRule" +dsRule _ = panic "dsRule: Impossible Match" -- due to #15884 warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM () -- See Note [Rules and inlining/other rules] diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs index 5bafcbf001..f86f364cb2 100644 --- a/compiler/deSugar/DsArrows.hs +++ b/compiler/deSugar/DsArrows.hs @@ -8,6 +8,7 @@ Desugaring arrow commands {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module DsArrows ( dsProcExpr ) where @@ -19,7 +20,9 @@ import Match import DsUtils import DsMonad -import HsSyn hiding (collectPatBinders, collectPatsBinders, collectLStmtsBinders, collectLStmtBinders, collectStmtBinders ) +import HsSyn hiding (collectPatBinders, collectPatsBinders, + collectLStmtsBinders, collectLStmtBinders, + collectStmtBinders ) import TcHsSyn import qualified HsUtils @@ -28,7 +31,8 @@ import qualified HsUtils -- So WATCH OUT; check each use of split*Ty functions. -- Sigh. This is a pain. -import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr ) +import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, + dsSyntaxExpr ) import TcType import Type ( splitPiTy ) @@ -103,7 +107,8 @@ mkCmdEnv tc_meths where mk_bind (std_name, expr) = do { rhs <- dsExpr expr - ; id <- newSysLocalDs (exprType rhs) -- no check needed; these are functions + ; id <- newSysLocalDs (exprType rhs) + -- no check needed; these are functions ; return (NonRec id rhs, (std_name, id)) } unmaybe Nothing name = pprPanic "mkCmdEnv" (text "Not found:" <+> ppr name) @@ -312,10 +317,11 @@ dsProcExpr :: LPat GhcTc -> LHsCmdTop GhcTc -> DsM CoreExpr -dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do +dsProcExpr pat (dL->L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do (meth_binds, meth_ids) <- mkCmdEnv ids let locals = mkVarSet (collectPatBinders pat) - (core_cmd, _free_vars, env_ids) <- dsfixCmd meth_ids locals unitTy cmd_ty cmd + (core_cmd, _free_vars, env_ids) + <- dsfixCmd meth_ids locals unitTy cmd_ty cmd let env_ty = mkBigCoreVarTupTy env_ids let env_stk_ty = mkCorePairTy env_ty unitTy let env_stk_expr = mkCorePairExpr (mkBigCoreVarTup env_ids) mkCoreUnitExpr @@ -327,7 +333,7 @@ dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do (Lam var match_code) core_cmd return (mkLets meth_binds proc_code) -dsProcExpr _ (L _ XCmdTop{}) = panic "dsProcExpr" +dsProcExpr _ _ = panic "dsProcExpr" {- Translation of a command judgement of the form @@ -450,14 +456,15 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdApp _ cmd arg) env_ids = do dsCmd ids local_vars stack_ty res_ty (HsCmdLam _ (MG { mg_alts - = L _ [L _ (Match { m_pats = pats - , m_grhss = GRHSs _ [L _ (GRHS _ [] body)] _ })] })) + = (dL->L _ [dL->L _ (Match { m_pats = pats + , m_grhss = GRHSs _ [dL->L _ (GRHS _ [] body)] _ })]) })) env_ids = do let pat_vars = mkVarSet (collectPatsBinders pats) let local_vars' = pat_vars `unionVarSet` local_vars (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty - (core_body, free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty' res_ty body + (core_body, free_vars, env_ids') + <- dsfixCmd ids local_vars' stack_ty' res_ty body param_ids <- mapM newSysLocalDsNoLP pat_tys stack_id' <- newSysLocalDs stack_ty' @@ -472,7 +479,8 @@ dsCmd ids local_vars stack_ty res_ty fail_expr <- mkFailExpr LambdaExpr in_ty' -- match the patterns against the parameters - match_code <- matchSimplys (map Var param_ids) LambdaExpr pats core_expr fail_expr + match_code <- matchSimplys (map Var param_ids) LambdaExpr pats core_expr + fail_expr -- match the parameters against the top of the old stack (stack_id, param_code) <- matchVarStack param_ids stack_id' match_code -- match the old environment and stack against the input @@ -496,27 +504,33 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdPar _ cmd) env_ids dsCmd ids local_vars stack_ty res_ty (HsCmdIf _ mb_fun cond then_cmd else_cmd) env_ids = do core_cond <- dsLExpr cond - (core_then, fvs_then, then_ids) <- dsfixCmd ids local_vars stack_ty res_ty then_cmd - (core_else, fvs_else, else_ids) <- dsfixCmd ids local_vars stack_ty res_ty else_cmd + (core_then, fvs_then, then_ids) + <- dsfixCmd ids local_vars stack_ty res_ty then_cmd + (core_else, fvs_else, else_ids) + <- dsfixCmd ids local_vars stack_ty res_ty else_cmd stack_id <- newSysLocalDs stack_ty either_con <- dsLookupTyCon eitherTyConName left_con <- dsLookupDataCon leftDataConName right_con <- dsLookupDataCon rightDataConName - let mk_left_expr ty1 ty2 e = mkCoreConApps left_con [Type ty1, Type ty2, e] - mk_right_expr ty1 ty2 e = mkCoreConApps right_con [Type ty1, Type ty2, e] + let mk_left_expr ty1 ty2 e = mkCoreConApps left_con [Type ty1,Type ty2, e] + mk_right_expr ty1 ty2 e = mkCoreConApps right_con [Type ty1,Type ty2, e] in_ty = envStackType env_ids stack_ty then_ty = envStackType then_ids stack_ty else_ty = envStackType else_ids stack_ty sum_ty = mkTyConApp either_con [then_ty, else_ty] - fvs_cond = exprFreeIdsDSet core_cond `uniqDSetIntersectUniqSet` local_vars + fvs_cond = exprFreeIdsDSet core_cond + `uniqDSetIntersectUniqSet` local_vars - core_left = mk_left_expr then_ty else_ty (buildEnvStack then_ids stack_id) - core_right = mk_right_expr then_ty else_ty (buildEnvStack else_ids stack_id) + core_left = mk_left_expr then_ty else_ty + (buildEnvStack then_ids stack_id) + core_right = mk_right_expr then_ty else_ty + (buildEnvStack else_ids stack_id) core_if <- case mb_fun of - Just fun -> do { fun_apps <- dsSyntaxExpr fun [core_cond, core_left, core_right] + Just fun -> do { fun_apps <- dsSyntaxExpr fun + [core_cond, core_left, core_right] ; matchEnvStack env_ids stack_id fun_apps } Nothing -> matchEnvStack env_ids stack_id $ mkIfThenElse core_cond core_left core_right @@ -554,7 +568,7 @@ case bodies, containing the following fields: -} dsCmd ids local_vars stack_ty res_ty - (HsCmdCase _ exp (MG { mg_alts = L l matches + (HsCmdCase _ exp (MG { mg_alts = (dL->L l matches) , mg_ext = MatchGroupTc arg_tys _ , mg_origin = origin })) env_ids = do @@ -566,8 +580,9 @@ dsCmd ids local_vars stack_ty res_ty let leaves = concatMap leavesMatch matches make_branch (leaf, bound_vars) = do - (core_leaf, _fvs, leaf_ids) <- - dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack_ty res_ty leaf + (core_leaf, _fvs, leaf_ids) + <- dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack_ty + res_ty leaf return ([mkHsEnvStackExpr leaf_ids stack_id], envStackType leaf_ids stack_ty, core_leaf) @@ -602,7 +617,7 @@ dsCmd ids local_vars stack_ty res_ty in_ty = envStackType env_ids stack_ty core_body <- dsExpr (HsCase noExt exp - (MG { mg_alts = L l matches' + (MG { mg_alts = cL l matches' , mg_ext = MatchGroupTc arg_tys sum_ty , mg_origin = origin })) -- Note that we replace the HsCase result type by sum_ty, @@ -618,13 +633,14 @@ dsCmd ids local_vars stack_ty res_ty -- -- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c -dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(L _ binds) body) +dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(dL->L _ binds) body) env_ids = do let defined_vars = mkVarSet (collectLocalBinders binds) local_vars' = defined_vars `unionVarSet` local_vars - (core_body, _free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty res_ty body + (core_body, _free_vars, env_ids') + <- dsfixCmd ids local_vars' stack_ty res_ty body stack_id <- newSysLocalDs stack_ty -- build a new environment, plus the stack, using the let bindings core_binds <- dsLocalBinds lbinds (buildEnvStack env_ids' stack_id) @@ -644,7 +660,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(L _ binds) body) -- -- ---> premap (\ (env,stk) -> env) c -dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty (L loc stmts)) +dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty + (dL->L loc stmts)) env_ids = do putSrcSpanDs loc $ dsNoLevPoly stmts_ty @@ -690,18 +707,21 @@ dsTrimCmdArg -> DsM (CoreExpr, -- desugared expression DIdSet) -- subset of local vars that occur free dsTrimCmdArg local_vars env_ids - (L _ (HsCmdTop (CmdTopTc stack_ty cmd_ty ids) cmd )) = do + (dL->L _ (HsCmdTop + (CmdTopTc stack_ty cmd_ty ids) cmd )) = do (meth_binds, meth_ids) <- mkCmdEnv ids - (core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd + (core_cmd, free_vars, env_ids') + <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd stack_id <- newSysLocalDs stack_ty - trim_code <- matchEnvStack env_ids stack_id (buildEnvStack env_ids' stack_id) + trim_code + <- matchEnvStack env_ids stack_id (buildEnvStack env_ids' stack_id) let in_ty = envStackType env_ids stack_ty in_ty' = envStackType env_ids' stack_ty arg_code = if env_ids' == env_ids then core_cmd else do_premap meth_ids in_ty in_ty' cmd_ty trim_code core_cmd return (mkLets meth_binds arg_code, free_vars) -dsTrimCmdArg _ _ (L _ XCmdTop{}) = panic "dsTrimCmdArg" +dsTrimCmdArg _ _ _ = panic "dsTrimCmdArg" -- Given D; xs |-a c : stk --> t, builds c with xs fed back. -- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk)) @@ -759,7 +779,7 @@ dsCmdDo _ _ _ [] _ = panic "dsCmdDo" -- -- ---> premap (\ (xs) -> ((xs), ())) c -dsCmdDo ids local_vars res_ty [L loc (LastStmt _ body _ _)] env_ids = do +dsCmdDo ids local_vars res_ty [dL->L loc (LastStmt _ body _ _)] env_ids = do putSrcSpanDs loc $ dsNoLevPoly res_ty (text "In the command:" <+> ppr body) (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids @@ -870,13 +890,14 @@ dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd _ _) env_ids = do env_id <- newSysLocalDs env_ty2 uniqs <- newUniqueSupply let - after_c_ty = mkCorePairTy pat_ty env_ty2 - out_ty = mkBigCoreVarTupTy out_ids - body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids) + after_c_ty = mkCorePairTy pat_ty env_ty2 + out_ty = mkBigCoreVarTupTy out_ids + body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids) fail_expr <- mkFailExpr (StmtCtxt DoExpr) out_ty pat_id <- selectSimpleMatchVarL pat - match_code <- matchSimply (Var pat_id) (StmtCtxt DoExpr) pat body_expr fail_expr + match_code + <- matchSimply (Var pat_id) (StmtCtxt DoExpr) pat body_expr fail_expr pair_id <- newSysLocalDs after_c_ty let proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code) @@ -891,7 +912,8 @@ dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd _ _) env_ids = do do_compose ids before_c_ty after_c_ty out_ty (do_first ids in_ty1 pat_ty in_ty2 core_cmd) $ do_arr ids after_c_ty out_ty proj_expr, - fv_cmd `unionDVarSet` (mkDVarSet out_ids `uniqDSetMinusUniqSet` pat_vars)) + fv_cmd `unionDVarSet` (mkDVarSet out_ids + `uniqDSetMinusUniqSet` pat_vars)) -- D; xs' |-a do { ss } : t -- -------------------------------------- @@ -1118,7 +1140,8 @@ matchSimplys _ _ _ _ _ = panic "matchSimplys" leavesMatch :: LMatch GhcTc (Located (body GhcTc)) -> [(Located (body GhcTc), IdSet)] -leavesMatch (L _ (Match { m_pats = pats, m_grhss = GRHSs _ grhss (L _ binds) })) +leavesMatch (dL->L _ (Match { m_pats = pats + , m_grhss = GRHSs _ grhss (dL->L _ binds) })) = let defined_vars = mkVarSet (collectPatsBinders pats) `unionVarSet` @@ -1127,9 +1150,8 @@ leavesMatch (L _ (Match { m_pats = pats, m_grhss = GRHSs _ grhss (L _ binds) })) [(body, mkVarSet (collectLStmtsBinders stmts) `unionVarSet` defined_vars) - | L _ (GRHS _ stmts body) <- grhss] -leavesMatch (L _ (Match _ _ _ (XGRHSs _))) = panic "leavesMatch" -leavesMatch (L _ (XMatch _)) = panic "leavesMatch" + | (dL->L _ (GRHS _ stmts body)) <- grhss] +leavesMatch _ = panic "leavesMatch" -- Replace the leaf commands in a match @@ -1140,24 +1162,23 @@ replaceLeavesMatch -> ([Located (body' GhcTc)], -- remaining leaf expressions LMatch GhcTc (Located (body' GhcTc))) -- updated match replaceLeavesMatch _res_ty leaves - (L loc match@(Match { m_grhss = GRHSs x grhss binds })) + (dL->L loc + match@(Match { m_grhss = GRHSs x grhss binds })) = let (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss in - (leaves', L loc (match { m_ext = noExt, m_grhss = GRHSs x grhss' binds })) -replaceLeavesMatch _ _ (L _ (Match _ _ _ (XGRHSs _))) - = panic "replaceLeavesMatch" -replaceLeavesMatch _ _ (L _ (XMatch _)) = panic "replaceLeavesMatch" + (leaves', cL loc (match { m_ext = noExt, m_grhss = GRHSs x grhss' binds })) +replaceLeavesMatch _ _ _ = panic "replaceLeavesMatch" replaceLeavesGRHS :: [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 x stmts _)) - = (leaves, L loc (GRHS x stmts leaf)) -replaceLeavesGRHS _ (L _ (XGRHS _)) = panic "replaceLeavesGRHS" +replaceLeavesGRHS (leaf:leaves) (dL->L loc (GRHS x stmts _)) + = (leaves, cL loc (GRHS x stmts leaf)) replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []" +replaceLeavesGRHS _ _ = panic "replaceLeavesGRHS" -- Balanced fold of a non-empty list. @@ -1201,14 +1222,14 @@ collectPatsBinders pats = foldr collectl [] pats --------------------- collectl :: LPat GhcTc -> [Id] -> [Id] -- See Note [Dictionary binders in ConPatOut] -collectl (L _ pat) bndrs +collectl (dL->L _ pat) bndrs = go pat where - go (VarPat _ (L _ var)) = var : bndrs + go (VarPat _ (dL->L _ var)) = var : bndrs go (WildPat _) = bndrs go (LazyPat _ pat) = collectl pat bndrs go (BangPat _ pat) = collectl pat bndrs - go (AsPat _ (L _ a) pat) = a : collectl pat bndrs + go (AsPat _ (dL->L _ a) pat) = a : collectl pat bndrs go (ParPat _ pat) = collectl pat bndrs go (ListPat _ pats) = foldr collectl bndrs pats @@ -1221,7 +1242,7 @@ collectl (L _ pat) bndrs ++ foldr collectl bndrs (hsConPatArgs ps) go (LitPat _ _) = bndrs go (NPat {}) = bndrs - go (NPlusKPat _ (L _ n) _ _ _ _) = n : bndrs + go (NPlusKPat _ (dL->L _ n) _ _ _ _) = n : bndrs go (SigPat _ pat _) = collectl pat bndrs go (CoPat _ _ pat _) = collectl (noLoc pat) bndrs diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index f322e1457c..d62706ef00 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -12,6 +12,8 @@ lower levels it is preserved with @let@/@letrec@s). {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleContexts #-} module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec, dsHsWrapper, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule @@ -98,7 +100,7 @@ dsTopLHsBinds binds unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds bang_binds = filterBag (isBangedHsBind . unLoc) binds - top_level_err desc (L loc bind) + top_level_err desc (dL->L loc bind) = putSrcSpanDs loc $ errDs (hang (text "Top-level" <+> text desc <+> text "aren't allowed:") 2 (ppr bind)) @@ -115,8 +117,8 @@ dsLHsBinds binds ------------------------ dsLHsBind :: LHsBind GhcTc -> DsM ([Id], [(Id,CoreExpr)]) -dsLHsBind (L loc bind) = do dflags <- getDynFlags - putSrcSpanDs loc $ dsHsBind dflags bind +dsLHsBind (dL->L loc bind) = do dflags <- getDynFlags + putSrcSpanDs loc $ dsHsBind dflags bind -- | Desugar a single binding (or group of recursive binds). dsHsBind :: DynFlags @@ -140,8 +142,10 @@ dsHsBind dflags (VarBind { var_id = var else [] ; return (force_var, [core_bind]) } -dsHsBind dflags b@(FunBind { fun_id = L _ fun, fun_matches = matches - , fun_co_fn = co_fn, fun_tick = tick }) +dsHsBind dflags b@(FunBind { fun_id = (dL->L _ fun) + , fun_matches = matches + , fun_co_fn = co_fn + , fun_tick = tick }) = do { (args, body) <- matchWrapper (mkPrefixFunRhs (noLoc $ idName fun)) Nothing matches @@ -648,7 +652,7 @@ dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding -- rhs is in the Id's unfolding -> Located TcSpecPrag -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule)) -dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) +dsSpec mb_poly_rhs (dL->L loc (SpecPrag poly_id spec_co spec_inl)) | isJust (isClassOpId_maybe poly_id) = putSrcSpanDs loc $ do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for class method selector" diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index bdba4e06eb..08822df60b 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -8,6 +8,7 @@ Desugaring exporessions. {-# LANGUAGE CPP, MultiWayIf #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds , dsValBinds, dsLit, dsSyntaxExpr ) where @@ -71,11 +72,11 @@ import Control.Monad -} dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr -dsLocalBinds (L _ (EmptyLocalBinds _)) body = return body -dsLocalBinds (L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $ +dsLocalBinds (dL->L _ (EmptyLocalBinds _)) body = return body +dsLocalBinds (dL->L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $ dsValBinds binds body -dsLocalBinds (L _ (HsIPBinds _ binds)) body = dsIPBinds binds body -dsLocalBinds (L _ (XHsLocalBindsLR _)) _ = panic "dsLocalBinds" +dsLocalBinds (dL->L _ (HsIPBinds _ binds)) body = dsIPBinds binds body +dsLocalBinds _ _ = panic "dsLocalBinds" ------------------------- -- caller sets location @@ -93,10 +94,10 @@ dsIPBinds (IPBinds ev_binds ip_binds) body -- dependency order; hence Rec ; foldrM ds_ip_bind inner ip_binds } where - ds_ip_bind (L _ (IPBind _ ~(Right n) e)) body + ds_ip_bind (dL->L _ (IPBind _ ~(Right n) e)) body = do e' <- dsLExpr e return (Let (NonRec n e') body) - ds_ip_bind (L _ (XIPBind _)) _ = panic "dsIPBinds" + ds_ip_bind _ _ = panic "dsIPBinds" dsIPBinds (XHsIPBinds _) _ = panic "dsIPBinds" ------------------------- @@ -107,7 +108,7 @@ ds_val_bind :: (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr -- a tuple and doing selections. -- Silently ignore INLINE and SPECIALISE pragmas... ds_val_bind (NonRecursive, hsbinds) body - | [L loc bind] <- bagToList hsbinds + | [dL->L loc bind] <- bagToList hsbinds -- Non-recursive, non-overloaded bindings only come in ones -- ToDo: in some bizarre case it's conceivable that there -- could be dict binds in the 'binds'. (See the notes @@ -191,13 +192,13 @@ dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = [] ; ds_binds <- dsTcEvBinds_s ev_binds ; return (mkCoreLets ds_binds body2) } -dsUnliftedBind (FunBind { fun_id = L l fun +dsUnliftedBind (FunBind { fun_id = (dL->L l fun) , fun_matches = matches , fun_co_fn = co_fn , fun_tick = tick }) body -- Can't be a bang pattern (that looks like a PatBind) -- so must be simply unboxed - = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun)) + = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (cL l $ idName fun)) Nothing matches ; MASSERT( null args ) -- Functions aren't lifted ; MASSERT( isIdHsWrapper co_fn ) @@ -229,7 +230,7 @@ dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body) dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr -dsLExpr (L loc e) +dsLExpr (dL->L loc e) = putSrcSpanDs loc $ do { core_expr <- dsExpr e -- uncomment this check to test the hsExprType function in TcHsSyn @@ -244,7 +245,7 @@ dsLExpr (L loc e) -- See Note [Levity polymorphism checking] in DsMonad -- See Note [Levity polymorphism invariants] in CoreSyn dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr -dsLExprNoLP (L loc e) +dsLExprNoLP (dL->L loc e) = putSrcSpanDs loc $ do { e' <- dsExpr e ; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e) @@ -258,7 +259,7 @@ ds_expr :: Bool -- are we directly inside an HsWrap? -> HsExpr GhcTc -> DsM CoreExpr ds_expr _ (HsPar _ e) = dsLExpr e ds_expr _ (ExprWithTySig _ e _) = dsLExpr e -ds_expr w (HsVar _ (L _ var)) = dsHsVar w var +ds_expr w (HsVar _ (dL->L _ var)) = dsHsVar w var ds_expr _ (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them ds_expr w (HsConLikeOut _ con) = dsConLike w con ds_expr _ (HsIPVar {}) = panic "dsExpr: HsIPVar" @@ -277,7 +278,8 @@ ds_expr _ (HsWrap _ co_fn e) ; warnAboutIdentities dflags e' wrapped_ty ; return wrapped_e } -ds_expr _ (NegApp _ (L loc (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i}))) +ds_expr _ (NegApp _ (dL->L loc + (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i}))) neg_expr) = do { expr' <- putSrcSpanDs loc $ do { dflags <- getDynFlags @@ -369,17 +371,17 @@ ds_expr _ e@(SectionR _ op expr) = do core_op [Var x_id, Var y_id])) ds_expr _ (ExplicitTuple _ tup_args boxity) - = do { let go (lam_vars, args) (L _ (Missing ty)) + = do { let go (lam_vars, args) (dL->L _ (Missing ty)) -- For every missing expression, we need -- another lambda in the desugaring. = do { lam_var <- newSysLocalDsNoLP ty ; return (lam_var : lam_vars, Var lam_var : args) } - go (lam_vars, args) (L _ (Present _ expr)) + go (lam_vars, args) (dL->L _ (Present _ expr)) -- Expressions that are present don't generate -- lambdas, just arguments. = do { core_expr <- dsLExprNoLP expr ; return (lam_vars, core_expr : args) } - go _ (L _ (XTupArg {})) = panic "ds_expr" + go _ _ = panic "ds_expr" ; dsWhenNoErrs (foldM go ([], []) (reverse tup_args)) -- The reverse is because foldM goes left-to-right @@ -393,7 +395,7 @@ ds_expr _ (ExplicitSum types alt arity expr) map Type types ++ [core_expr]) ) } -ds_expr _ (HsSCC _ _ cc expr@(L loc _)) = do +ds_expr _ (HsSCC _ _ cc expr@(dL->L loc _)) = do dflags <- getDynFlags if gopt Opt_SccProfilingOn dflags then do @@ -422,11 +424,11 @@ ds_expr _ (HsLet _ binds body) = do -- We need the `ListComp' form to use `deListComp' (rather than the "do" form) -- because the interpretation of `stmts' depends on what sort of thing it is. -- -ds_expr _ (HsDo res_ty ListComp (L _ stmts)) = dsListComp stmts res_ty -ds_expr _ (HsDo _ DoExpr (L _ stmts)) = dsDo stmts -ds_expr _ (HsDo _ GhciStmtCtxt (L _ stmts)) = dsDo stmts -ds_expr _ (HsDo _ MDoExpr (L _ stmts)) = dsDo stmts -ds_expr _ (HsDo _ MonadComp (L _ stmts)) = dsMonadComp stmts +ds_expr _ (HsDo res_ty ListComp (dL->L _ stmts)) = dsListComp stmts res_ty +ds_expr _ (HsDo _ DoExpr (dL->L _ stmts)) = dsDo stmts +ds_expr _ (HsDo _ GhciStmtCtxt (dL->L _ stmts)) = dsDo stmts +ds_expr _ (HsDo _ MDoExpr (dL->L _ stmts)) = dsDo stmts +ds_expr _ (HsDo _ MonadComp (dL->L _ stmts)) = dsMonadComp stmts ds_expr _ (HsIf _ mb_fun guard_expr then_expr else_expr) = do { pred <- dsLExpr guard_expr @@ -476,7 +478,7 @@ See Note [Grand plan for static forms] in StaticPtrTable for an overview. g = ... makeStatic loc f ... -} -ds_expr _ (HsStatic _ expr@(L loc _)) = do +ds_expr _ (HsStatic _ expr@(dL->L loc _)) = do expr_ds <- dsLExprNoLP expr let ty = exprType expr_ds makeStaticId <- dsLookupGlobalId makeStaticName @@ -615,10 +617,11 @@ ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields -- of the record selector, and we must not make that a local binder -- else we shadow other uses of the record selector -- Hence 'lcl_id'. Cf Trac #2735 - ds_field (L _ rec_field) = do { rhs <- dsLExpr (hsRecFieldArg rec_field) - ; let fld_id = unLoc (hsRecUpdFieldId rec_field) - ; lcl_id <- newSysLocalDs (idType fld_id) - ; return (idName fld_id, lcl_id, rhs) } + ds_field (dL->L _ rec_field) + = do { rhs <- dsLExpr (hsRecFieldArg rec_field) + ; let fld_id = unLoc (hsRecUpdFieldId rec_field) + ; lcl_id <- newSysLocalDs (idType fld_id) + ; return (idName fld_id, lcl_id, rhs) } add_field_binds [] expr = expr add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr) @@ -771,7 +774,7 @@ dsSyntaxExpr (SyntaxExpr { syn_expr = expr findField :: [LHsRecField GhcTc arg] -> Name -> [arg] findField rbinds sel - = [hsRecFieldArg fld | L _ fld <- rbinds + = [hsRecFieldArg fld | (dL->L _ fld) <- rbinds , sel == idName (unLoc $ hsRecFieldId fld) ] {- @@ -890,7 +893,7 @@ dsDo stmts = goL stmts where goL [] = panic "dsDo" - goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts) + goL ((dL->L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts) go _ (LastStmt _ body _ _) stmts = ASSERT( null stmts ) dsLExpr body @@ -932,7 +935,7 @@ dsDo stmts ; let body' = noLoc $ HsDo body_ty DoExpr (noLoc stmts) - ; let fun = L noSrcSpan $ HsLam noExt $ + ; let fun = cL noSrcSpan $ HsLam noExt $ MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr pats body'] , mg_ext = MatchGroupTc arg_tys body_ty @@ -954,7 +957,7 @@ dsDo stmts , recS_ret_ty = body_ty} }) stmts = goL (new_bind_stmt : stmts) -- rec_ids can be empty; eg rec { print 'x' } where - new_bind_stmt = L loc $ BindStmt bind_ty (mkBigLHsPatTupId later_pats) + new_bind_stmt = cL loc $ BindStmt bind_ty (mkBigLHsPatTupId later_pats) mfix_app bind_op noSyntaxExpr -- Tuple cannot fail @@ -995,7 +998,7 @@ handle_failure pat match fail_op | otherwise = extractMatchResult match (error "It can't fail") -mk_fail_msg :: DynFlags -> Located e -> String +mk_fail_msg :: HasSrcSpan e => DynFlags -> e -> String mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++ showPpr dflags (getLoc pat) @@ -1135,7 +1138,7 @@ we're not directly in an HsWrap, reject. checkForcedEtaExpansion :: HsExpr GhcTc -> Type -> DsM () checkForcedEtaExpansion expr ty | Just var <- case expr of - HsVar _ (L _ var) -> Just var + HsVar _ (dL->L _ var) -> Just var HsConLikeOut _ (RealDataCon dc) -> Just (dataConWrapId dc) _ -> Nothing , let bad_tys = badUseOfLevPolyPrimop var ty diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs index 2e20cc7f35..d34c3a791a 100644 --- a/compiler/deSugar/DsForeign.hs +++ b/compiler/deSugar/DsForeign.hs @@ -9,6 +9,7 @@ Desugaring foreign declarations (see also DsCCall). {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module DsForeign ( dsForeigns ) where @@ -97,7 +98,7 @@ dsForeigns' fos = do (vcat cs $$ vcat fe_init_code), foldr (appOL . toOL) nilOL bindss) where - do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl) + do_ldecl (dL->L loc decl) = putSrcSpanDs loc (do_decl decl) do_decl (ForeignImport { fd_name = id, fd_i_ext = co, fd_fi = spec }) = do traceIf (text "fi start" <+> ppr id) @@ -106,8 +107,10 @@ dsForeigns' fos = do traceIf (text "fi end" <+> ppr id) return (h, c, [], bs) - do_decl (ForeignExport { fd_name = L _ id, fd_e_ext = co - , fd_fe = CExport (L _ (CExportStatic _ ext_nm cconv)) _ }) = do + do_decl (ForeignExport { fd_name = (dL->L _ id) + , fd_e_ext = co + , fd_fe = CExport + (dL->L _ (CExportStatic _ ext_nm cconv)) _ }) = do (h, c, _, _) <- dsFExport id co ext_nm cconv False return (h, c, [id], []) do_decl (XForeignDecl _) = panic "dsForeigns'" diff --git a/compiler/deSugar/DsGRHSs.hs b/compiler/deSugar/DsGRHSs.hs index 00658539d3..277ea00044 100644 --- a/compiler/deSugar/DsGRHSs.hs +++ b/compiler/deSugar/DsGRHSs.hs @@ -7,6 +7,7 @@ Matching guarded right-hand-sides (GRHSs) -} {-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} module DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS, isTrueLHsExpr ) where @@ -67,9 +68,10 @@ dsGRHSs _ (XGRHSs _) _ = panic "dsGRHSs" dsGRHS :: HsMatchContext Name -> Type -> LGRHS GhcTc (LHsExpr GhcTc) -> DsM MatchResult -dsGRHS hs_ctx rhs_ty (L _ (GRHS _ guards rhs)) +dsGRHS hs_ctx rhs_ty (dL->L _ (GRHS _ guards rhs)) = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty -dsGRHS _ _ (L _ (XGRHS _)) = panic "dsGRHS" +dsGRHS _ _ (dL->L _ (XGRHS _)) = panic "dsGRHS" +dsGRHS _ _ _ = panic "dsGRHS: Impossible Match" -- due to #15884 {- ************************************************************************ diff --git a/compiler/deSugar/DsListComp.hs b/compiler/deSugar/DsListComp.hs index f325b5672d..def390c6c7 100644 --- a/compiler/deSugar/DsListComp.hs +++ b/compiler/deSugar/DsListComp.hs @@ -8,6 +8,7 @@ Desugaring list comprehensions, monad comprehensions and array comprehensions {-# LANGUAGE CPP, NamedFieldPuns #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module DsListComp ( dsListComp, dsMonadComp ) where @@ -483,8 +484,8 @@ dsMonadComp :: [ExprLStmt GhcTc] -> DsM CoreExpr dsMonadComp stmts = dsMcStmts stmts dsMcStmts :: [ExprLStmt GhcTc] -> DsM CoreExpr -dsMcStmts [] = panic "dsMcStmts" -dsMcStmts (L loc stmt : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts) +dsMcStmts [] = panic "dsMcStmts" +dsMcStmts ((dL->L loc stmt) : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts) --------------- dsMcStmt :: ExprStmt GhcTc -> [ExprLStmt GhcTc] -> DsM CoreExpr @@ -638,7 +639,7 @@ dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts | otherwise = extractMatchResult match (error "It can't fail") - mk_fail_msg :: DynFlags -> Located e -> String + mk_fail_msg :: HasSrcSpan e => DynFlags -> e -> String mk_fail_msg dflags pat = "Pattern match failure in monad comprehension at " ++ showPpr dflags (getLoc pat) diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index dfcfc3d9d6..9b2256e913 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP, TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- @@ -74,7 +75,8 @@ dsBracket :: HsBracket GhcRn -> [PendingTcSplice] -> DsM CoreExpr dsBracket brack splices = dsExtendMetaEnv new_bit (do_brack brack) where - new_bit = mkNameEnv [(n, DsSplice (unLoc e)) | PendingTcSplice n e <- splices] + new_bit = mkNameEnv [(n, DsSplice (unLoc e)) + | PendingTcSplice n e <- splices] do_brack (VarBr _ _ n) = do { MkC e1 <- lookupOcc n ; return e1 } do_brack (ExpBr _ e) = do { MkC e1 <- repLE e ; return e1 } @@ -167,15 +169,15 @@ repTopDs group@(HsGroup { hs_valds = valds wrapGenSyms ss q_decs } where - no_splice (L loc _) + no_splice (dL->L loc _) = notHandledL loc "Splices within declaration brackets" empty - no_default_decl (L loc decl) + no_default_decl (dL->L loc decl) = notHandledL loc "Default declarations" (ppr decl) - no_warn (L loc (Warning _ thing _)) + no_warn (dL->L loc (Warning _ thing _)) = notHandledL loc "WARNING and DEPRECATION pragmas" $ text "Pragma for declaration of" <+> ppr thing - no_warn (L _ (XWarnDecl _)) = panic "repTopDs" - no_doc (L loc _) + no_warn _ = panic "repTopDs" + no_doc (dL->L loc _) = notHandledL loc "Haddock documentation" empty repTopDs (XHsGroup _) = panic "repTopDs" @@ -189,7 +191,7 @@ hsScopedTvBinders binds XValBindsLR (NValBinds _ sigs) -> sigs get_scoped_tvs :: LSig GhcRn -> [Name] -get_scoped_tvs (L _ signature) +get_scoped_tvs (dL->L _ signature) | TypeSig _ _ sig <- signature = get_scoped_tvs_from_sig (hswc_body sig) | ClassOpSig _ _ _ sig <- signature @@ -299,28 +301,31 @@ them into a `ForallT` or `ForallC`. Doing so caused #13018 and #13123. -- repTyClD :: LTyClDecl GhcRn -> DsM (Maybe (SrcSpan, Core TH.DecQ)) -repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $ repFamilyDecl (L loc fam) +repTyClD (dL->L loc (FamDecl { tcdFam = fam })) = liftM Just $ + repFamilyDecl (L loc fam) -repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs })) +repTyClD (dL->L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs })) = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] ; dec <- addTyClTyVarBinds tvs $ \bndrs -> repSynDecl tc1 bndrs rhs ; return (Just (loc, dec)) } -repTyClD (L loc (DataDecl { tcdLName = tc, tcdTyVars = tvs, tcdDataDefn = defn })) +repTyClD (dL->L loc (DataDecl { tcdLName = tc + , tcdTyVars = tvs + , tcdDataDefn = defn })) = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] ; dec <- addTyClTyVarBinds tvs $ \bndrs -> repDataDefn tc1 (Left bndrs) defn ; return (Just (loc, dec)) } -repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, +repTyClD (dL->L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tvs, tcdFDs = fds, tcdSigs = sigs, tcdMeths = meth_binds, tcdATs = ats, tcdATDefs = atds })) = do { cls1 <- lookupLOcc cls -- See note [Binders and occurrences] ; dec <- addTyVarBinds tvs $ \bndrs -> do { cxt1 <- repLContext cxt - -- See Note [Scoped type variables in class and instance declarations] + -- See Note [Scoped type variables in class and instance declarations] ; (ss, sigs_binds) <- rep_sigs_binds sigs meth_binds ; fds1 <- repLFunDeps fds ; ats1 <- repFamilyDecls ats @@ -331,17 +336,17 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, ; return $ Just (loc, dec) } -repTyClD (L _ (XTyClDecl _)) = panic "repTyClD" +repTyClD _ = panic "repTyClD" ------------------------- repRoleD :: LRoleAnnotDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) -repRoleD (L loc (RoleAnnotDecl _ tycon roles)) +repRoleD (dL->L loc (RoleAnnotDecl _ tycon roles)) = do { tycon1 <- lookupLOcc tycon ; roles1 <- mapM repRole roles ; roles2 <- coreList roleTyConName roles1 ; dec <- repRoleAnnotD tycon1 roles2 ; return (loc, dec) } -repRoleD (L _ (XRoleAnnotDecl _)) = panic "repRoleD" +repRoleD _ = panic "repRoleD" ------------------------- repDataDefn :: Core TH.Name @@ -380,11 +385,11 @@ repSynDecl tc bndrs ty ; repTySyn tc bndrs ty1 } repFamilyDecl :: LFamilyDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) -repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info, - fdLName = tc, - fdTyVars = tvs, - fdResultSig = L _ resultSig, - fdInjectivityAnn = injectivity })) +repFamilyDecl decl@(dL->L loc (FamilyDecl { fdInfo = info + , fdLName = tc + , fdTyVars = tvs + , fdResultSig = dL->L _ resultSig + , fdInjectivityAnn = injectivity })) = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] ; let mkHsQTvs :: [LHsTyVarBndr GhcRn] -> LHsQTyVars GhcRn mkHsQTvs tvs = HsQTvs { hsq_ext = HsQTvsRn @@ -414,7 +419,7 @@ repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info, ; repDataFamilyD tc1 bndrs kind } ; return (loc, dec) } -repFamilyDecl (L _ (XFamilyDecl _)) = panic "repFamilyDecl" +repFamilyDecl _ = panic "repFamilyDecl" -- | Represent result signature of a type family repFamilyResultSig :: FamilyResultSig GhcRn -> DsM (Core TH.FamilyResultSigQ) @@ -442,7 +447,7 @@ repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn) -> DsM (Core (Maybe TH.InjectivityAnn)) repInjectivityAnn Nothing = do { coreNothing injAnnTyConName } -repInjectivityAnn (Just (L _ (InjectivityAnn lhs rhs))) = +repInjectivityAnn (Just (dL->L _ (InjectivityAnn lhs rhs))) = do { lhs' <- lookupBinder (unLoc lhs) ; rhs1 <- mapM (lookupBinder . unLoc) rhs ; rhs2 <- coreList nameTyConName rhs1 @@ -457,10 +462,10 @@ repAssocTyFamDefaults = mapM rep_deflt where -- very like repTyFamEqn, but different in the details rep_deflt :: LTyFamDefltEqn GhcRn -> DsM (Core TH.DecQ) - rep_deflt (L _ (FamEqn { feqn_tycon = tc - , feqn_bndrs = bndrs - , feqn_pats = tys - , feqn_rhs = rhs })) + rep_deflt (dL->L _ (FamEqn { feqn_tycon = tc + , feqn_bndrs = bndrs + , feqn_pats = tys + , feqn_rhs = rhs })) = addTyClTyVarBinds tys $ \ _ -> do { tc1 <- lookupLOcc tc ; no_bndrs <- ASSERT( isNothing bndrs ) @@ -470,7 +475,7 @@ repAssocTyFamDefaults = mapM rep_deflt ; rhs1 <- repLTy rhs ; eqn1 <- repTySynEqn no_bndrs tys2 rhs1 ; repTySynInst tc1 eqn1 } - rep_deflt (L _ (XFamEqn _)) = panic "repAssocTyFamDefaults" + rep_deflt _ = panic "repAssocTyFamDefaults" ------------------------- -- represent fundeps @@ -479,7 +484,7 @@ repLFunDeps :: [LHsFunDep GhcRn] -> DsM (Core [TH.FunDep]) repLFunDeps fds = repList funDepTyConName repLFunDep fds repLFunDep :: LHsFunDep GhcRn -> DsM (Core TH.FunDep) -repLFunDep (L _ (xs, ys)) +repLFunDep (dL->L _ (xs, ys)) = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs ys' <- repList nameTyConName (lookupBinder . unLoc) ys repFunDep xs' ys' @@ -487,16 +492,16 @@ repLFunDep (L _ (xs, ys)) -- Represent instance declarations -- repInstD :: LInstDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) -repInstD (L loc (TyFamInstD { tfid_inst = fi_decl })) +repInstD (dL->L loc (TyFamInstD { tfid_inst = fi_decl })) = do { dec <- repTyFamInstD fi_decl ; return (loc, dec) } -repInstD (L loc (DataFamInstD { dfid_inst = fi_decl })) +repInstD (dL->L loc (DataFamInstD { dfid_inst = fi_decl })) = do { dec <- repDataFamInstD fi_decl ; return (loc, dec) } -repInstD (L loc (ClsInstD { cid_inst = cls_decl })) +repInstD (dL->L loc (ClsInstD { cid_inst = cls_decl })) = do { dec <- repClsInstD cls_decl ; return (loc, dec) } -repInstD (L _ (XInstDecl _)) = panic "repInstD" +repInstD _ = panic "repInstD" repClsInstD :: ClsInstDecl GhcRn -> DsM (Core TH.DecQ) repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds @@ -516,7 +521,7 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds -- do { cxt1 <- repLContext cxt ; inst_ty1 <- repLTy inst_ty - -- See Note [Scoped type variables in class and instance declarations] + -- See Note [Scoped type variables in class and instance declarations] ; (ss, sigs_binds) <- rep_sigs_binds sigs binds ; ats1 <- mapM (repTyFamInstD . unLoc) ats ; adts1 <- mapM (repDataFamInstD . unLoc) adts @@ -529,8 +534,8 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds repClsInstD (XClsInstDecl _) = panic "repClsInstD" repStandaloneDerivD :: LDerivDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) -repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat - , deriv_type = ty })) +repStandaloneDerivD (dL->L loc (DerivDecl { deriv_strategy = strat + , deriv_type = ty })) = do { dec <- addSimpleTyVarBinds tvs $ do { cxt' <- repLContext cxt ; strat' <- repDerivStrategy strat @@ -539,12 +544,12 @@ repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat ; return (loc, dec) } where (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty) -repStandaloneDerivD (L _ (XDerivDecl _)) = panic "repStandaloneDerivD" +repStandaloneDerivD _ = panic "repStandaloneDerivD" 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] + ; tc <- lookupLOcc tc_name -- See note [Binders and occurrences] ; eqn1 <- repTyFamEqn eqn ; repTySynInst tc eqn1 } @@ -575,7 +580,7 @@ repDataFamInstD (DataFamInstDecl { dfid_eqn = , feqn_bndrs = mb_bndrs , feqn_pats = tys , feqn_rhs = defn }})}) - = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences] + = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences] ; let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = var_names , hsq_dependent = emptyNameSet } -- Yuk @@ -592,8 +597,9 @@ repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn _))) = panic "repDataFamInstD" 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 _ })) +repForD (dL->L loc (ForeignImport { fd_name = name, fd_sig_ty = typ + , fd_fi = CImport (dL->L _ cc) + (dL->L _ s) mch cis _ })) = do MkC name' <- lookupLOcc name MkC typ' <- repHsSigType typ MkC cc' <- repCCallConv cc @@ -603,7 +609,8 @@ repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ dec <- rep2 forImpDName [cc', s', str, name', typ'] return (loc, dec) where - conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls)) + conv_cimportspec (CLabel cls) + = notHandled "Foreign label" (doubleQuotes (ppr cls)) conv_cimportspec (CFunction DynamicTarget) = return "dynamic" conv_cimportspec (CFunction (StaticTarget _ fs _ True)) = return (unpackFS fs) @@ -633,7 +640,7 @@ repSafety PlayInterruptible = rep2 interruptibleName [] repSafety PlaySafe = rep2 safeName [] repFixD :: LFixitySig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)] -repFixD (L loc (FixitySig _ names (Fixity _ prec dir))) +repFixD (dL->L loc (FixitySig _ names (Fixity _ prec dir))) = do { MkC prec' <- coreIntLit prec ; let rep_fn = case dir of InfixL -> infixLDName @@ -644,22 +651,23 @@ repFixD (L loc (FixitySig _ names (Fixity _ prec dir))) ; dec <- rep2 rep_fn [prec', name'] ; return (loc,dec) } ; mapM do_one names } -repFixD (L _ (XFixitySig _)) = panic "repFixD" +repFixD _ = panic "repFixD" repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) -repRuleD (L loc (HsRule { rd_name = n - , rd_act = act - , rd_tyvs = ty_bndrs - , rd_tmvs = tm_bndrs - , rd_lhs = lhs - , rd_rhs = rhs })) +repRuleD (dL->L loc (HsRule { rd_name = n + , rd_act = act + , rd_tyvs = ty_bndrs + , rd_tmvs = tm_bndrs + , rd_lhs = lhs + , rd_rhs = rhs })) = do { rule <- addHsTyVarBinds (fromMaybe [] ty_bndrs) $ \ ex_bndrs -> do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs ; ss <- mkGenSyms tm_bndr_names ; rule <- addBinds ss $ do { ty_bndrs' <- case ty_bndrs of Nothing -> coreNothingList tyVarBndrQTyConName - Just _ -> coreJustList tyVarBndrQTyConName ex_bndrs + Just _ -> coreJustList tyVarBndrQTyConName + ex_bndrs ; tm_bndrs' <- repList ruleBndrQTyConName repRuleBndr tm_bndrs @@ -670,42 +678,43 @@ repRuleD (L loc (HsRule { rd_name = n ; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' } ; wrapGenSyms ss rule } ; return (loc, rule) } -repRuleD (L _ (XRuleDecl _)) = panic "repRuleD" +repRuleD _ = panic "repRuleD" ruleBndrNames :: LRuleBndr GhcRn -> [Name] -ruleBndrNames (L _ (RuleBndr _ n)) = [unLoc n] -ruleBndrNames (L _ (RuleBndrSig _ n sig)) +ruleBndrNames (dL->L _ (RuleBndr _ n)) = [unLoc n] +ruleBndrNames (dL->L _ (RuleBndrSig _ n sig)) | HsWC { hswc_body = HsIB { hsib_ext = vars }} <- sig = unLoc n : vars -ruleBndrNames (L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs _)))) +ruleBndrNames (dL->L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs _)))) = panic "ruleBndrNames" -ruleBndrNames (L _ (RuleBndrSig _ _ (XHsWildCardBndrs _))) +ruleBndrNames (dL->L _ (RuleBndrSig _ _ (XHsWildCardBndrs _))) = panic "ruleBndrNames" -ruleBndrNames (L _ (XRuleBndr _)) = panic "ruleBndrNames" +ruleBndrNames (dL->L _ (XRuleBndr _)) = panic "ruleBndrNames" +ruleBndrNames _ = panic "ruleBndrNames: Impossible Match" -- due to #15884 repRuleBndr :: LRuleBndr GhcRn -> DsM (Core TH.RuleBndrQ) -repRuleBndr (L _ (RuleBndr _ n)) +repRuleBndr (dL->L _ (RuleBndr _ n)) = do { MkC n' <- lookupLBinder n ; rep2 ruleVarName [n'] } -repRuleBndr (L _ (RuleBndrSig _ n sig)) +repRuleBndr (dL->L _ (RuleBndrSig _ n sig)) = do { MkC n' <- lookupLBinder n ; MkC ty' <- repLTy (hsSigWcType sig) ; rep2 typedRuleVarName [n', ty'] } -repRuleBndr (L _ (XRuleBndr _)) = panic "repRuleBndr" +repRuleBndr _ = panic "repRuleBndr" repAnnD :: LAnnDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) -repAnnD (L loc (HsAnnotation _ _ ann_prov (L _ exp))) +repAnnD (dL->L loc (HsAnnotation _ _ ann_prov (dL->L _ exp))) = do { target <- repAnnProv ann_prov ; exp' <- repE exp ; dec <- repPragAnn target exp' ; return (loc, dec) } -repAnnD (L _ (XAnnDecl _)) = panic "repAnnD" +repAnnD _ = panic "repAnnD" repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget) -repAnnProv (ValueAnnProvenance (L _ n)) +repAnnProv (ValueAnnProvenance (dL->L _ n)) = do { MkC n' <- globalVar n -- ANNs are allowed only at top-level ; rep2 valueAnnotationName [ n' ] } -repAnnProv (TypeAnnProvenance (L _ n)) +repAnnProv (TypeAnnProvenance (dL->L _ n)) = do { MkC n' <- globalVar n ; rep2 typeAnnotationName [ n' ] } repAnnProv ModuleAnnProvenance @@ -716,17 +725,17 @@ repAnnProv ModuleAnnProvenance ------------------------------------------------------- repC :: LConDecl GhcRn -> DsM (Core TH.ConQ) -repC (L _ (ConDeclH98 { con_name = con - , con_forall = L _ False - , con_mb_cxt = Nothing - , con_args = args })) +repC (dL->L _ (ConDeclH98 { con_name = con + , con_forall = (dL->L _ False) + , con_mb_cxt = Nothing + , con_args = args })) = repDataCon con args -repC (L _ (ConDeclH98 { con_name = con - , con_forall = L _ is_existential - , con_ex_tvs = con_tvs - , con_mb_cxt = mcxt - , con_args = args })) +repC (dL->L _ (ConDeclH98 { con_name = con + , con_forall = (dL->L _ is_existential) + , con_ex_tvs = con_tvs + , con_mb_cxt = mcxt + , con_args = args })) = do { addHsTyVarBinds con_tvs $ \ ex_bndrs -> do { c' <- repDataCon con args ; ctxt' <- repMbContext mcxt @@ -736,9 +745,11 @@ repC (L _ (ConDeclH98 { con_name = con } } -repC (L _ (ConDeclGADT { con_names = cons - , con_qvars = qtvs, con_mb_cxt = mcxt - , con_args = args, con_res_ty = res_ty })) +repC (dL->L _ (ConDeclGADT { con_names = cons + , con_qvars = qtvs + , con_mb_cxt = mcxt + , con_args = args + , con_res_ty = res_ty })) | isEmptyLHsQTvs qtvs -- No implicit or explicit variables , Nothing <- mcxt -- No context -- ==> no need for a forall @@ -753,12 +764,12 @@ repC (L _ (ConDeclGADT { con_names = cons then return c' else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) } -repC (L _ (XConDecl _)) = panic "repC" +repC _ = panic "repC" repMbContext :: Maybe (LHsContext GhcRn) -> DsM (Core TH.CxtQ) repMbContext Nothing = repContext [] -repMbContext (Just (L _ cxt)) = repContext cxt +repMbContext (Just (dL->L _ cxt)) = repContext cxt repSrcUnpackedness :: SrcUnpackedness -> DsM (Core TH.SourceUnpackednessQ) repSrcUnpackedness SrcUnpack = rep2 sourceUnpackName [] @@ -778,8 +789,8 @@ repBangTy ty = do MkC t <- repLTy ty' rep2 bangTypeName [b, t] where - (su', ss', ty') = case ty of - L _ (HsBangTy _ (HsSrcBang _ su ss) ty) -> (su, ss, ty) + (su', ss', ty') = case unLoc ty of + HsBangTy _ (HsSrcBang _ su ss) ty -> (su, ss, ty) _ -> (NoSrcUnpack, NoSrcStrict, ty) ------------------------------------------------------- @@ -787,19 +798,21 @@ repBangTy ty = do ------------------------------------------------------- repDerivs :: HsDeriving GhcRn -> DsM (Core [TH.DerivClauseQ]) -repDerivs (L _ clauses) = repList derivClauseQTyConName repDerivClause clauses +repDerivs (dL->L _ clauses) + = repList derivClauseQTyConName repDerivClause clauses repDerivClause :: LHsDerivingClause GhcRn -> DsM (Core TH.DerivClauseQ) -repDerivClause (L _ (HsDerivingClause { deriv_clause_strategy = dcs - , deriv_clause_tys = L _ dct })) +repDerivClause (dL->L _ (HsDerivingClause + { deriv_clause_strategy = dcs + , deriv_clause_tys = (dL->L _ dct) })) = do MkC dcs' <- repDerivStrategy dcs MkC dct' <- repList typeQTyConName (rep_deriv_ty . hsSigType) dct rep2 derivClauseName [dcs',dct'] where rep_deriv_ty :: LHsType GhcRn -> DsM (Core TH.TypeQ) - rep_deriv_ty (L _ ty) = repTy ty -repDerivClause (L _ (XHsDerivingClause _)) = panic "repDerivClause" + rep_deriv_ty ty = repLTy ty +repDerivClause _ = panic "repDerivClause" rep_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn -> DsM ([GenSymBind], [Core TH.DecQ]) @@ -826,21 +839,24 @@ rep_sigs :: [LSig GhcRn] -> DsM [(SrcSpan, Core TH.DecQ)] rep_sigs = concatMapM rep_sig 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)) - | is_deflt = mapM (rep_ty_sig defaultSigDName loc ty) nms - | otherwise = mapM (rep_ty_sig sigDName loc ty) nms -rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d) -rep_sig (L _ (FixSig {})) = return [] -- fixity sigs at top level -rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc -rep_sig (L loc (SpecSig _ nm tys ispec)) +rep_sig (dL->L loc (TypeSig _ nms ty)) + = mapM (rep_wc_ty_sig sigDName loc ty) nms +rep_sig (dL->L loc (PatSynSig _ nms ty)) + = mapM (rep_patsyn_ty_sig loc ty) nms +rep_sig (dL->L loc (ClassOpSig _ is_deflt nms ty)) + | is_deflt = mapM (rep_ty_sig defaultSigDName loc ty) nms + | otherwise = mapM (rep_ty_sig sigDName loc ty) nms +rep_sig d@(dL->L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d) +rep_sig (dL->L _ (FixSig {})) = return [] -- fixity sigs at top level +rep_sig (dL->L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc +rep_sig (dL->L loc (SpecSig _ nm tys ispec)) = concatMapM (\t -> rep_specialise nm t ispec loc) tys -rep_sig (L loc (SpecInstSig _ _ ty)) = rep_specialiseInst ty loc -rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty -rep_sig (L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty -rep_sig (L loc (CompleteMatchSig _ _st cls mty)) = rep_complete_sig cls mty loc -rep_sig (L _ (XSig _)) = panic "rep_sig" +rep_sig (dL->L loc (SpecInstSig _ _ ty)) = rep_specialiseInst ty loc +rep_sig (dL->L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty +rep_sig (dL->L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty +rep_sig (dL->L loc (CompleteMatchSig _ _st cls mty)) + = rep_complete_sig cls mty loc +rep_sig _ = panic "rep_sig" rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name -> DsM (SrcSpan, Core TH.DecQ) @@ -960,7 +976,7 @@ rep_complete_sig :: Located [Located Name] -> Maybe (Located Name) -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)] -rep_complete_sig (L _ cls) mty loc +rep_complete_sig (dL->L _ cls) mty loc = do { mty' <- repMaybe nameTyConName lookupLOcc mty ; cls' <- repList nameTyConName lookupLOcc cls ; sig <- repPragComplete cls' mty' @@ -1036,25 +1052,27 @@ addTyClTyVarBinds tvs m -- repTyVarBndrWithKind :: LHsTyVarBndr GhcRn -> Core TH.Name -> DsM (Core TH.TyVarBndrQ) -repTyVarBndrWithKind (L _ (UserTyVar _ _)) nm +repTyVarBndrWithKind (dL->L _ (UserTyVar _ _)) nm = repPlainTV nm -repTyVarBndrWithKind (L _ (KindedTyVar _ _ ki)) nm +repTyVarBndrWithKind (dL->L _ (KindedTyVar _ _ ki)) nm = repLTy ki >>= repKindedTV nm -repTyVarBndrWithKind (L _ (XTyVarBndr{})) _ = panic "repTyVarBndrWithKind" +repTyVarBndrWithKind _ _ = panic "repTyVarBndrWithKind" -- | Represent a type variable binder repTyVarBndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ) -repTyVarBndr (L _ (UserTyVar _ (L _ nm)) )= do { nm' <- lookupBinder nm - ; repPlainTV nm' } -repTyVarBndr (L _ (KindedTyVar _ (L _ nm) ki)) = do { nm' <- lookupBinder nm - ; ki' <- repLTy ki - ; repKindedTV nm' ki' } -repTyVarBndr (L _ (XTyVarBndr{})) = panic "repTyVarBndr" +repTyVarBndr (dL->L _ (UserTyVar _ (dL->L _ nm)) ) + = do { nm' <- lookupBinder nm + ; repPlainTV nm' } +repTyVarBndr (dL->L _ (KindedTyVar _ (dL->L _ nm) ki)) + = do { nm' <- lookupBinder nm + ; ki' <- repLTy ki + ; repKindedTV nm' ki' } +repTyVarBndr _ = panic "repTyVarBndr" -- represent a type context -- repLContext :: LHsContext GhcRn -> DsM (Core TH.CxtQ) -repLContext (L _ ctxt) = repContext ctxt +repLContext ctxt = repContext (unLoc ctxt) repContext :: HsContext GhcRn -> DsM (Core TH.CxtQ) repContext ctxt = do preds <- repList typeQTyConName repLTy ctxt @@ -1085,7 +1103,7 @@ repLTys tys = mapM repLTy tys -- represent a type repLTy :: LHsType GhcRn -> DsM (Core TH.TypeQ) -repLTy (L _ ty) = repTy ty +repLTy ty = repTy (unLoc ty) repForall :: HsType GhcRn -> DsM (Core TH.TypeQ) -- Arg of repForall is always HsForAllTy or HsQualTy @@ -1100,7 +1118,7 @@ repTy :: HsType GhcRn -> DsM (Core TH.TypeQ) repTy ty@(HsForAllTy {}) = repForall ty repTy ty@(HsQualTy {}) = repForall ty -repTy (HsTyVar _ _ (L _ n)) +repTy (HsTyVar _ _ (dL->L _ n)) | isLiftedTypeKindTyConName n = repTStar | n `hasKey` constraintKindTyConKey = repTConstraint | n `hasKey` funTyConKey = repArrowTyCon @@ -1177,10 +1195,11 @@ repMaybeLTy :: Maybe (LHsKind GhcRn) repMaybeLTy = repMaybe kindQTyConName repLTy repRole :: Located (Maybe Role) -> DsM (Core TH.Role) -repRole (L _ (Just Nominal)) = rep2 nominalRName [] -repRole (L _ (Just Representational)) = rep2 representationalRName [] -repRole (L _ (Just Phantom)) = rep2 phantomRName [] -repRole (L _ Nothing) = rep2 inferRName [] +repRole (dL->L _ (Just Nominal)) = rep2 nominalRName [] +repRole (dL->L _ (Just Representational)) = rep2 representationalRName [] +repRole (dL->L _ (Just Phantom)) = rep2 phantomRName [] +repRole (dL->L _ Nothing) = rep2 inferRName [] +repRole _ = panic "repRole: Impossible Match" -- due to #15884 ----------------------------------------------------------------------------- -- Splices @@ -1215,10 +1234,10 @@ repLEs es = repList expQTyConName repLE es -- 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 GhcRn -> DsM (Core TH.ExpQ) -repLE (L loc e) = putSrcSpanDs loc (repE e) +repLE (dL->L loc e) = putSrcSpanDs loc (repE e) repE :: HsExpr GhcRn -> DsM (Core TH.ExpQ) -repE (HsVar _ (L _ x)) = +repE (HsVar _ (dL->L _ x)) = do { mb_val <- dsLookupMetaEnv x ; case mb_val of Nothing -> do { str <- globalVar x @@ -1238,8 +1257,8 @@ repE e@(HsRecFld _ f) = case f of -- HsOverlit can definitely occur repE (HsOverLit _ l) = do { a <- repOverloadedLiteral l; repLit a } repE (HsLit _ l) = do { a <- repLiteral l; repLit a } -repE (HsLam _ (MG { mg_alts = L _ [m] })) = repLambda m -repE (HsLamCase _ (MG { mg_alts = L _ ms })) +repE (HsLam _ (MG { mg_alts = (dL->L _ [m]) })) = repLambda m +repE (HsLamCase _ (MG { mg_alts = (dL->L _ ms) })) = do { ms' <- mapM repMatchTup ms ; core_ms <- coreList matchQTyConName ms' ; repLamCase core_ms } @@ -1260,7 +1279,7 @@ repE (NegApp _ x _) = do repE (HsPar _ x) = repLE x repE (SectionL _ x y) = do { a <- repLE x; b <- repLE y; repSectionL a b } repE (SectionR _ x y) = do { a <- repLE x; b <- repLE y; repSectionR a b } -repE (HsCase _ e (MG { mg_alts = L _ ms })) +repE (HsCase _ e (MG { mg_alts = (dL->L _ ms) })) = do { arg <- repLE e ; ms2 <- mapM repMatchTup ms ; core_ms2 <- coreList matchQTyConName ms2 @@ -1274,13 +1293,13 @@ repE (HsMultiIf _ alts) = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts ; expr' <- repMultiIf (nonEmptyCoreList alts') ; wrapGenSyms (concat binds) expr' } -repE (HsLet _ (L _ bs) e) = do { (ss,ds) <- repBinds bs +repE (HsLet _ (dL->L _ bs) e) = do { (ss,ds) <- repBinds bs ; e2 <- addBinds ss (repLE e) ; z <- repLetE ds e2 ; wrapGenSyms ss z } -- FIXME: I haven't got the types here right yet -repE e@(HsDo _ ctxt (L _ sts)) +repE e@(HsDo _ ctxt (dL->L _ sts)) | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False } = do { (ss,zs) <- repLSts sts; e' <- repDoE (nonEmptyCoreList zs); @@ -1302,8 +1321,9 @@ repE e@(HsDo _ ctxt (L _ sts)) repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs } repE e@(ExplicitTuple _ es boxed) | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e) - | isBoxed boxed = do { xs <- repLEs [e | L _ (Present _ e) <- es]; repTup xs } - | otherwise = do { xs <- repLEs [e | L _ (Present _ e) <- es] + | isBoxed boxed = do { xs <- repLEs [e | (dL->L _ (Present _ e)) <- es] + ; repTup xs } + | otherwise = do { xs <- repLEs [e | (dL->L _ (Present _ e)) <- es] ; repUnboxedTup xs } repE (ExplicitSum _ alt arity e) @@ -1357,8 +1377,8 @@ repE e = notHandled "Expression form" (ppr e) -- Building representations of auxillary structures like Match, Clause, Stmt, repMatchTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.MatchQ) -repMatchTup (L _ (Match { m_pats = [p] - , m_grhss = GRHSs _ guards (L _ wheres) })) = +repMatchTup (dL->L _ (Match { m_pats = [p] + , m_grhss = GRHSs _ guards (dL->L _ wheres) })) = do { ss1 <- mkGenSyms (collectPatBinders p) ; addBinds ss1 $ do { ; p1 <- repLP p @@ -1370,8 +1390,8 @@ repMatchTup (L _ (Match { m_pats = [p] repMatchTup _ = panic "repMatchTup: case alt with more than one arg" repClauseTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ClauseQ) -repClauseTup (L _ (Match { m_pats = ps - , m_grhss = GRHSs _ guards (L _ wheres) })) = +repClauseTup (dL->L _ (Match { m_pats = ps + , m_grhss = GRHSs _ guards (dL->L _ wheres) })) = do { ss1 <- mkGenSyms (collectPatsBinders ps) ; addBinds ss1 $ do { ps1 <- repLPs ps @@ -1380,11 +1400,11 @@ repClauseTup (L _ (Match { m_pats = ps gs <- repGuards guards ; clause <- repClause ps1 gs ds ; wrapGenSyms (ss1++ss2) clause }}} -repClauseTup (L _ (Match _ _ _ (XGRHSs _))) = panic "repClauseTup" -repClauseTup (L _ (XMatch _)) = panic "repClauseTup" +repClauseTup (dL->L _ (Match _ _ _ (XGRHSs _))) = panic "repClauseTup" +repClauseTup _ = panic "repClauseTup" repGuards :: [LGRHS GhcRn (LHsExpr GhcRn)] -> DsM (Core TH.BodyQ) -repGuards [L _ (GRHS _ [] e)] +repGuards [dL->L _ (GRHS _ [] e)] = do {a <- repLE e; repNormal a } repGuards other = do { zs <- mapM repLGRHS other @@ -1394,15 +1414,15 @@ repGuards other repLGRHS :: LGRHS GhcRn (LHsExpr GhcRn) -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp)))) -repLGRHS (L _ (GRHS _ [L _ (BodyStmt _ e1 _ _)] e2)) +repLGRHS (dL->L _ (GRHS _ [dL->L _ (BodyStmt _ e1 _ _)] e2)) = do { guarded <- repLNormalGE e1 e2 ; return ([], guarded) } -repLGRHS (L _ (GRHS _ ss rhs)) +repLGRHS (dL->L _ (GRHS _ ss rhs)) = do { (gs, ss') <- repLSts ss ; rhs' <- addBinds gs $ repLE rhs ; guarded <- repPatGE (nonEmptyCoreList ss') rhs' ; return (gs, guarded) } -repLGRHS (L _ (XGRHS _)) = panic "repLGRHS" +repLGRHS _ = panic "repLGRHS" repFields :: HsRecordBinds GhcRn -> DsM (Core [TH.Q TH.FieldExp]) repFields (HsRecFields { rec_flds = flds }) @@ -1410,16 +1430,16 @@ repFields (HsRecFields { rec_flds = flds }) where 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 } + rep_fld (dL->L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld) + ; e <- repLE (hsRecFieldArg fld) + ; repFieldExp fn e } repUpdFields :: [LHsRecUpdField GhcRn] -> DsM (Core [TH.Q TH.FieldExp]) repUpdFields = repList fieldExpQTyConName rep_fld where 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) + rep_fld (dL->L l fld) = case unLoc (hsRecFieldLbl fld) of + Unambiguous sel_name _ -> do { fn <- lookupLOcc (cL l sel_name) ; e <- repLE (hsRecFieldArg fld) ; repFieldExp fn e } _ -> notHandled "Ambiguous record updates" (ppr fld) @@ -1463,7 +1483,7 @@ repSts (BindStmt _ p e _ _ : ss) = ; (ss2,zs) <- repSts ss ; z <- repBindSt p1 e2 ; return (ss1++ss2, z : zs) }} -repSts (LetStmt _ (L _ bs) : ss) = +repSts (LetStmt _ (dL->L _ bs) : ss) = do { (ss1,ds) <- repBinds bs ; z <- repLetSt ds ; (ss2,zs) <- addBinds ss1 (repSts ss) @@ -1540,16 +1560,18 @@ repBinds (HsValBinds _ decs) repBinds b@(XHsLocalBindsLR {}) = notHandled "Local binds extensions" (ppr b) rep_implicit_param_bind :: LIPBind GhcRn -> DsM (SrcSpan, Core TH.DecQ) -rep_implicit_param_bind (L loc (IPBind _ ename (L _ rhs))) +rep_implicit_param_bind (dL->L loc (IPBind _ ename (dL->L _ rhs))) = do { name <- case ename of - Left (L _ n) -> rep_implicit_param_name n + Left (dL->L _ n) -> rep_implicit_param_name n Right _ -> panic "rep_implicit_param_bind: post typechecking" ; rhs' <- repE rhs ; ipb <- repImplicitParamBind name rhs' ; return (loc, ipb) } -rep_implicit_param_bind (L _ b@(XIPBind _)) +rep_implicit_param_bind (dL->L _ b@(XIPBind _)) = notHandled "Implicit parameter bind extension" (ppr b) +rep_implicit_param_bind _ = panic "rep_implicit_param_bind: Impossible Match" + -- due to #15884 rep_implicit_param_name :: HsIPName -> DsM (Core String) rep_implicit_param_name (HsIPName name) = coreStringLit (unpackFS name) @@ -1572,13 +1594,14 @@ rep_bind :: LHsBind GhcRn -> DsM (SrcSpan, Core TH.DecQ) -- Note GHC treats declarations of a variable (not a pattern) -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match -- with an empty list of patterns -rep_bind (L loc (FunBind +rep_bind (dL->L loc (FunBind { fun_id = fn, fun_matches = MG { mg_alts - = L _ [L _ (Match + = (dL->L _ [dL->L _ (Match { m_pats = [] - , m_grhss = GRHSs _ guards (L _ wheres) } - )] } })) + , m_grhss = GRHSs _ guards + (dL->L _ wheres) } + )]) } })) = do { (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) ; fn' <- lookupLBinder fn @@ -1587,26 +1610,26 @@ rep_bind (L loc (FunBind ; ans' <- wrapGenSyms ss ans ; return (loc, ans') } -rep_bind (L loc (FunBind { fun_id = fn - , fun_matches = MG { mg_alts = L _ ms } })) +rep_bind (dL->L loc (FunBind { fun_id = fn + , fun_matches = MG { mg_alts = (dL->L _ ms) } })) = do { ms1 <- mapM repClauseTup ms ; fn' <- lookupLBinder fn ; ans <- repFun fn' (nonEmptyCoreList ms1) ; return (loc, ans) } -rep_bind (L _ (FunBind { fun_matches = XMatchGroup _ })) = panic "rep_bind" +rep_bind (dL->L _ (FunBind { fun_matches = XMatchGroup _ })) = panic "rep_bind" -rep_bind (L loc (PatBind { pat_lhs = pat - , pat_rhs = GRHSs _ guards (L _ wheres) })) +rep_bind (dL->L loc (PatBind { pat_lhs = pat + , pat_rhs = GRHSs _ guards (dL->L _ wheres) })) = do { patcore <- repLP pat ; (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) ; ans <- repVal patcore guardcore wherecore ; ans' <- wrapGenSyms ss ans ; return (loc, ans') } -rep_bind (L _ (PatBind _ _ (XGRHSs _) _)) = panic "rep_bind" +rep_bind (dL->L _ (PatBind _ _ (XGRHSs _) _)) = panic "rep_bind" -rep_bind (L _ (VarBind { var_id = v, var_rhs = e})) +rep_bind (dL->L _ (VarBind { var_id = v, var_rhs = e})) = do { v' <- lookupBinder v ; e2 <- repLE e ; x <- repNormal e2 @@ -1615,11 +1638,11 @@ rep_bind (L _ (VarBind { var_id = v, var_rhs = e})) ; ans <- repVal patcore x empty_decls ; return (srcLocSpan (getSrcLoc v), ans) } -rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds" -rep_bind (L loc (PatSynBind _ (PSB { psb_id = syn - , psb_args = args - , psb_def = pat - , psb_dir = dir }))) +rep_bind (dL->L _ (AbsBinds {})) = panic "rep_bind: AbsBinds" +rep_bind (dL->L loc (PatSynBind _ (PSB { psb_id = syn + , psb_args = args + , psb_def = pat + , psb_dir = dir }))) = do { syn' <- lookupLBinder syn ; dir' <- repPatSynDir dir ; ss <- mkGenArgSyms args @@ -1654,8 +1677,11 @@ rep_bind (L loc (PatSynBind _ (PSB { psb_id = syn wrapGenArgSyms (RecCon _) _ dec = return dec wrapGenArgSyms _ ss dec = wrapGenSyms ss dec -rep_bind (L _ (PatSynBind _ (XPatSynBind _))) = panic "rep_bind: XPatSynBind" -rep_bind (L _ (XHsBindsLR {})) = panic "rep_bind: XHsBindsLR" +rep_bind (dL->L _ (PatSynBind _ (XPatSynBind _))) + = panic "rep_bind: XPatSynBind" +rep_bind (dL->L _ (XHsBindsLR {})) = panic "rep_bind: XHsBindsLR" +rep_bind _ = panic "rep_bind: Impossible match!" + -- due to #15884 repPatSynD :: Core TH.Name -> Core TH.PatSynArgsQ @@ -1691,7 +1717,7 @@ repRecordPatSynArgs (MkC sels) = rep2 recordPatSynName [sels] repPatSynDir :: HsPatSynDir GhcRn -> DsM (Core TH.PatSynDirQ) repPatSynDir Unidirectional = rep2 unidirPatSynName [] repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName [] -repPatSynDir (ExplicitBidirectional (MG { mg_alts = L _ clauses })) +repPatSynDir (ExplicitBidirectional (MG { mg_alts = (dL->L _ clauses) })) = do { clauses' <- mapM repClauseTup clauses ; repExplBidirPatSynDir (nonEmptyCoreList clauses') } repPatSynDir (ExplicitBidirectional (XMatchGroup _)) = panic "repPatSynDir" @@ -1725,16 +1751,16 @@ repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls] -- (\ p1 .. pn -> exp) by causing an error. repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ExpQ) -repLambda (L _ (Match { m_pats = ps - , m_grhss = GRHSs _ [L _ (GRHS _ [] e)] - (L _ (EmptyLocalBinds _)) } )) +repLambda (dL->L _ (Match { m_pats = ps + , m_grhss = GRHSs _ [dL->L _ (GRHS _ [] e)] + (dL->L _ (EmptyLocalBinds _)) } )) = do { let bndrs = collectPatsBinders ps ; ; ss <- mkGenSyms bndrs ; lam <- addBinds ss ( do { xs <- repLPs ps; body <- repLE e; repLam xs body }) ; wrapGenSyms ss lam } -repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch m) +repLambda (dL->L _ m) = notHandled "Guarded labmdas" (pprMatch m) ----------------------------------------------------------------------------- @@ -1749,12 +1775,12 @@ repLPs :: [LPat GhcRn] -> DsM (Core [TH.PatQ]) repLPs ps = repList patQTyConName repLP ps repLP :: LPat GhcRn -> DsM (Core TH.PatQ) -repLP (L _ p) = repP p +repLP p = repP (unLoc p) 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' } +repP (VarPat _ x) = do { x' <- lookupBinder (unLoc x); repPvar x' } repP (LazyPat _ p) = do { p1 <- repLP p; repPtilde p1 } repP (BangPat _ p) = do { p1 <- repLP p; repPbang p1 } repP (AsPat _ x p) = do { x' <- lookupLBinder x; p1 <- repLP p @@ -1781,11 +1807,12 @@ repP (ConPatIn dc details) } where 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] } + rep_fld (dL->L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld) + ; MkC p <- repLP (hsRecFieldArg fld) + ; rep2 fieldPatName [v,p] } -repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l; repPlit a } +repP (NPat _ (dL->L _ l) Nothing _) = do { a <- repOverloadedLiteral l + ; repPlit a } repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' } repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p) repP (SigPat _ p t) = do { p' <- repLP p @@ -1839,7 +1866,7 @@ addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) <- bs]) m -- Look up a locally bound name -- lookupLBinder :: Located Name -> DsM (Core TH.Name) -lookupLBinder (L _ n) = lookupBinder n +lookupLBinder n = lookupBinder (unLoc n) lookupBinder :: Name -> DsM (Core TH.Name) lookupBinder = lookupOcc @@ -1856,7 +1883,7 @@ lookupBinder = lookupOcc lookupLOcc :: Located Name -> DsM (Core TH.Name) -- Lookup an occurrence; it can't be a splice. -- Use the in-scope bindings if they exist -lookupLOcc (L _ n) = lookupOcc n +lookupLOcc n = lookupOcc (unLoc n) lookupOcc :: Name -> DsM (Core TH.Name) lookupOcc n @@ -2200,8 +2227,8 @@ repDerivStrategy :: Maybe (LDerivStrategy GhcRn) repDerivStrategy mds = case mds of Nothing -> nothing - Just (L _ ds) -> - case ds of + Just ds -> + case unLoc ds of StockStrategy -> just =<< repStockStrategy AnyclassStrategy -> just =<< repAnyclassStrategy NewtypeStrategy -> just =<< repNewtypeStrategy @@ -2356,18 +2383,18 @@ repConstr (PrefixCon ps) Nothing [con] = do arg_tys <- repList bangTypeQTyConName repBangTy ps rep2 normalCName [unC con, unC arg_tys] -repConstr (PrefixCon ps) (Just (L _ res_ty)) cons +repConstr (PrefixCon ps) (Just res_ty) cons = do arg_tys <- repList bangTypeQTyConName repBangTy ps - res_ty' <- repTy res_ty + res_ty' <- repLTy res_ty rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_ty'] -repConstr (RecCon (L _ ips)) resTy cons - = do args <- concatMapM rep_ip ips +repConstr (RecCon ips) resTy cons + = do args <- concatMapM rep_ip (unLoc ips) arg_vtys <- coreList varBangTypeQTyConName args case resTy of Nothing -> rep2 recCName [unC (head cons), unC arg_vtys] - Just (L _ res_ty) -> do - res_ty' <- repTy res_ty + Just res_ty -> do + res_ty' <- repLTy res_ty rep2 recGadtCName [unC (nonEmptyCoreList cons), unC arg_vtys, unC res_ty'] diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs index e93b2c30d6..5d597912e5 100644 --- a/compiler/deSugar/DsMonad.hs +++ b/compiler/deSugar/DsMonad.hs @@ -8,6 +8,7 @@ {-# LANGUAGE FlexibleInstances, FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an orphan +{-# LANGUAGE ViewPatterns #-} module DsMonad ( DsM, mapM, mapAndUnzipM, diff --git a/compiler/deSugar/DsUsage.hs b/compiler/deSugar/DsUsage.hs index 39b4855edc..a6b94c98a0 100644 --- a/compiler/deSugar/DsUsage.hs +++ b/compiler/deSugar/DsUsage.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} module DsUsage ( -- * Dependency/fingerprinting code (used by MkIface) diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs index ca22387b59..b78eef4c37 100644 --- a/compiler/deSugar/DsUtils.hs +++ b/compiler/deSugar/DsUtils.hs @@ -11,6 +11,7 @@ This module exports some utility functions of no great interest. {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} -- | Utility functions for constructing Core syntax, principally for desugaring module DsUtils ( @@ -668,7 +669,7 @@ mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly -- and all the desugared binds mkSelectorBinds ticks pat val_expr - | L _ (VarPat _ (L _ v)) <- pat' -- Special case (A) + | (dL->L _ (VarPat _ (dL->L _ v))) <- pat' -- Special case (A) = return (v, [(v, val_expr)]) | is_flat_prod_lpat pat' -- Special case (B) @@ -713,28 +714,29 @@ mkSelectorBinds ticks pat val_expr local_tuple = mkBigCoreVarTup1 binders tuple_ty = exprType local_tuple -strip_bangs :: LPat a -> LPat a +strip_bangs :: LPat (GhcPass p) -> LPat (GhcPass p) -- Remove outermost bangs and parens -strip_bangs (L _ (ParPat _ p)) = strip_bangs p -strip_bangs (L _ (BangPat _ p)) = strip_bangs p -strip_bangs lp = lp +strip_bangs (dL->L _ (ParPat _ p)) = strip_bangs p +strip_bangs (dL->L _ (BangPat _ p)) = strip_bangs p +strip_bangs lp = lp -is_flat_prod_lpat :: LPat a -> Bool -is_flat_prod_lpat p = is_flat_prod_pat (unLoc p) +is_flat_prod_lpat :: LPat (GhcPass p) -> Bool +is_flat_prod_lpat = is_flat_prod_pat . unLoc -is_flat_prod_pat :: Pat a -> Bool +is_flat_prod_pat :: Pat (GhcPass p) -> Bool is_flat_prod_pat (ParPat _ p) = is_flat_prod_lpat p is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps -is_flat_prod_pat (ConPatOut { pat_con = L _ pcon, pat_args = ps}) +is_flat_prod_pat (ConPatOut { pat_con = (dL->L _ pcon) + , pat_args = ps}) | RealDataCon con <- pcon , isProductTyCon (dataConTyCon con) = all is_triv_lpat (hsConPatArgs ps) is_flat_prod_pat _ = False -is_triv_lpat :: LPat a -> Bool -is_triv_lpat p = is_triv_pat (unLoc p) +is_triv_lpat :: LPat (GhcPass p) -> Bool +is_triv_lpat = is_triv_pat . unLoc -is_triv_pat :: Pat a -> Bool +is_triv_pat :: Pat (GhcPass p) -> Bool is_triv_pat (VarPat {}) = True is_triv_pat (WildPat{}) = True is_triv_pat (ParPat _ p) = is_triv_lpat p @@ -752,7 +754,7 @@ is_triv_pat _ = False mkLHsPatTup :: [LPat GhcTc] -> LPat GhcTc mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed mkLHsPatTup [lpat] = lpat -mkLHsPatTup lpats = L (getLoc (head lpats)) $ +mkLHsPatTup lpats = cL (getLoc (head lpats)) $ mkVanillaTuplePat lpats Boxed mkLHsVarPatTup :: [Id] -> LPat GhcTc @@ -948,25 +950,25 @@ decideBangHood dflags lpat | otherwise -- -XStrict = go lpat where - go lp@(L l p) + go lp@(dL->L l p) = case p of - ParPat x p -> L l (ParPat x (go p)) + ParPat x p -> cL l (ParPat x (go p)) LazyPat _ lp' -> lp' BangPat _ _ -> lp - _ -> L l (BangPat noExt lp) + _ -> cL l (BangPat noExt lp) -- | Unconditionally make a 'Pat' strict. addBang :: LPat GhcTc -- ^ Original pattern -> LPat GhcTc -- ^ Banged pattern addBang = go where - go lp@(L l p) + go lp@(dL->L l p) = case p of - ParPat x p -> L l (ParPat x (go p)) - LazyPat _ lp' -> L l (BangPat noExt lp') + ParPat x p -> cL l (ParPat x (go p)) + LazyPat _ lp' -> cL l (BangPat noExt lp') -- Should we bring the extension value over? BangPat _ _ -> lp - _ -> L l (BangPat noExt lp) + _ -> cL l (BangPat noExt lp) isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr) @@ -976,23 +978,24 @@ isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr) -- * Trivial wappings of these -- The arguments to Just are any HsTicks that we have found, -- because we still want to tick then, even it they are always evaluated. -isTrueLHsExpr (L _ (HsVar _ (L _ v))) | v `hasKey` otherwiseIdKey - || v `hasKey` getUnique trueDataConId +isTrueLHsExpr (dL->L _ (HsVar _ (dL->L _ v))) + | v `hasKey` otherwiseIdKey + || v `hasKey` getUnique trueDataConId = Just return -- trueDataConId doesn't have the same unique as trueDataCon -isTrueLHsExpr (L _ (HsConLikeOut _ con)) +isTrueLHsExpr (dL->L _ (HsConLikeOut _ con)) | con `hasKey` getUnique trueDataCon = Just return -isTrueLHsExpr (L _ (HsTick _ tickish e)) +isTrueLHsExpr (dL->L _ (HsTick _ tickish e)) | Just ticks <- isTrueLHsExpr e = Just (\x -> do wrapped <- ticks x return (Tick tickish wrapped)) -- This encodes that the result is constant True for Hpc tick purposes; -- which is specifically what isTrueLHsExpr is trying to find out. -isTrueLHsExpr (L _ (HsBinTick _ ixT _ e)) +isTrueLHsExpr (dL->L _ (HsBinTick _ ixT _ e)) | Just ticks <- isTrueLHsExpr e = Just (\x -> do e <- ticks x this_mod <- getModule return (Tick (HpcTick this_mod ixT) e)) -isTrueLHsExpr (L _ (HsPar _ e)) = isTrueLHsExpr e +isTrueLHsExpr (dL->L _ (HsPar _ e)) = isTrueLHsExpr e isTrueLHsExpr _ = Nothing diff --git a/compiler/deSugar/ExtractDocs.hs b/compiler/deSugar/ExtractDocs.hs index fc57f98569..4a5e890553 100644 --- a/compiler/deSugar/ExtractDocs.hs +++ b/compiler/deSugar/ExtractDocs.hs @@ -1,6 +1,9 @@ -- | Extract docs from the renamer output so they can be be serialized. -{-# language LambdaCase #-} -{-# language TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} + module ExtractDocs (extractDocs) where import GhcPrelude @@ -110,7 +113,7 @@ user-written. This lets us relate Names (from ClsInsts) to comments (associated with InstDecls and DerivDecls). -} -getMainDeclBinder :: HsDecl pass -> [IdP pass] +getMainDeclBinder :: HsDecl (GhcPass p) -> [IdP (GhcPass p)] getMainDeclBinder (TyClD _ d) = [tcdName d] getMainDeclBinder (ValD _ d) = case collectHsBindBinders d of @@ -137,13 +140,13 @@ getInstLoc :: InstDecl name -> SrcSpan getInstLoc = \case ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLoc (hsSigType ty) DataFamInstD _ (DataFamInstDecl - { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}}) -> l + { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = (dL->L l _) }}}) -> l TyFamInstD _ (TyFamInstDecl -- Since CoAxioms' Names refer to the whole line for type family instances -- in particular, we need to dig a bit deeper to pull out the entire -- equation. This does not happen for data family instances, for some -- reason. - { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = L l _ }}}) -> l + { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = (dL->L l _) }}}) -> l ClsInstD _ (XClsInstDecl _) -> error "getInstLoc" DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc" TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc" @@ -160,7 +163,7 @@ subordinates :: Map SrcSpan Name subordinates instMap decl = case decl of InstD _ (ClsInstD _ d) -> do DataFamInstDecl { dfid_eqn = HsIB { hsib_body = - FamEqn { feqn_tycon = L l _ + FamEqn { feqn_tycon = (dL->L l _) , feqn_rhs = defn }}} <- unLoc <$> cid_datafam_insts d [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn @@ -170,7 +173,8 @@ subordinates instMap decl = case decl of | isDataDecl d -> dataSubs (tcdDataDefn d) _ -> [] where - classSubs dd = [ (name, doc, declTypeDocs d) | (L _ d, doc) <- classDecls dd + classSubs dd = [ (name, doc, declTypeDocs d) + | (dL->L _ d, doc) <- classDecls dd , name <- getMainDeclBinder d, not (isValD d) ] dataSubs :: HsDataDefn GhcRn @@ -184,10 +188,10 @@ subordinates instMap decl = case decl of | c <- cons, cname <- getConNames c ] fields = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty) | RecCon flds <- map getConArgs cons - , L _ (ConDeclField _ ns _ doc) <- (unLoc flds) - , L _ n <- ns ] + , (dL->L _ (ConDeclField _ ns _ doc)) <- (unLoc flds) + , (dL->L _ n) <- ns ] derivs = [ (instName, [unLoc doc], M.empty) - | HsIB { hsib_body = L l (HsDocTy _ _ doc) } + | HsIB { hsib_body = (dL->L l (HsDocTy _ _ doc)) } <- concatMap (unLoc . deriv_clause_tys . unLoc) $ unLoc $ dd_derivs dd , Just instName <- [M.lookup l instMap] ] @@ -199,7 +203,7 @@ conArgDocs con = case getConArgs con of InfixCon arg1 arg2 -> go 0 ([unLoc arg1, unLoc arg2] ++ ret) RecCon _ -> go 1 ret where - go n (HsDocTy _ _ (L _ ds) : tys) = M.insert n ds $ go (n+1) tys + go n (HsDocTy _ _ (dL->L _ ds) : tys) = M.insert n ds $ go (n+1) tys go n (_ : tys) = go (n+1) tys go _ [] = M.empty @@ -249,10 +253,11 @@ typeDocs = go 0 where go n (HsForAllTy { hst_body = ty }) = go n (unLoc ty) go n (HsQualTy { hst_body = ty }) = go n (unLoc ty) - go n (HsFunTy _ (L _ (HsDocTy _ _ (L _ x))) (L _ ty)) = + go n (HsFunTy _ (dL->L _ + (HsDocTy _ _ (dL->L _ x))) (dL->L _ ty)) = M.insert n x $ go (n+1) ty go n (HsFunTy _ _ ty) = go (n+1) (unLoc ty) - go n (HsDocTy _ _ (L _ doc)) = M.singleton n doc + go n (HsDocTy _ _ (dL->L _ doc)) = M.singleton n doc go _ _ = M.empty -- | The top-level declarations of a module that we care about, @@ -292,10 +297,10 @@ collectDocs = go Nothing [] where go Nothing _ [] = [] go (Just prev) docs [] = finished prev docs [] - go prev docs (L _ (DocD _ (DocCommentNext str)) : ds) + go prev docs ((dL->L _ (DocD _ (DocCommentNext str))) : ds) | Nothing <- prev = go Nothing (str:docs) ds | Just decl <- prev = finished decl docs (go Nothing [str] ds) - go prev docs (L _ (DocD _ (DocCommentPrev str)) : ds) = + go prev docs ((dL->L _ (DocD _ (DocCommentPrev str))) : ds) = go prev (str:docs) ds go Nothing docs (d:ds) = go (Just d) docs ds go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds) @@ -319,8 +324,8 @@ filterDecls = filter (isHandled . unLoc . fst) -- | Go through all class declarations and filter their sub-declarations filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] -filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x - | x@(L loc d, doc) <- decls ] +filterClasses decls = [ if isClassD d then (cL loc (filterClass d), doc) else x + | x@(dL->L loc d, doc) <- decls ] where filterClass (TyClD x c) = TyClD x $ c { tcdSigs = @@ -341,4 +346,5 @@ isClassD _ = False -- | Take a field of declarations from a data structure and create HsDecls -- using the given constructor mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c] -mkDecls field con struct = [ L loc (con decl) | L loc decl <- field struct ] +mkDecls field con struct = [ cL loc (con decl) + | (dL->L loc decl) <- field struct ] diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs index f207d6039d..11fcbf20b6 100644 --- a/compiler/deSugar/Match.hs +++ b/compiler/deSugar/Match.hs @@ -8,6 +8,7 @@ The @match@ function {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module Match ( match, matchEquations, matchWrapper, matchSimply , matchSinglePat, matchSinglePatVar ) where @@ -269,7 +270,7 @@ matchView (var:vars) ty (eqns@(eqn1:_)) = do { -- we could pass in the expr from the PgView, -- but this needs to extract the pat anyway -- to figure out the type of the fresh variable - let ViewPat _ viewExpr (L _ pat) = firstPat eqn1 + let ViewPat _ viewExpr (dL->L _ pat) = firstPat eqn1 -- do the rest of the compilation ; let pat_ty' = hsPatType pat ; var' <- newUniqueId var pat_ty' @@ -401,19 +402,19 @@ tidy1 :: Id -- The Id being scrutinised -- It eliminates many pattern forms (as-patterns, variable patterns, -- list patterns, etc) and returns any created bindings in the wrapper. -tidy1 v (ParPat _ pat) = tidy1 v (unLoc pat) -tidy1 v (SigPat _ pat _) = tidy1 v (unLoc pat) -tidy1 _ (WildPat ty) = return (idDsWrapper, WildPat ty) -tidy1 v (BangPat _ (L l p)) = tidy_bang_pat v l p +tidy1 v (ParPat _ pat) = tidy1 v (unLoc pat) +tidy1 v (SigPat _ pat _) = tidy1 v (unLoc pat) +tidy1 _ (WildPat ty) = return (idDsWrapper, WildPat ty) +tidy1 v (BangPat _ (dL->L l p)) = tidy_bang_pat v l p -- case v of { x -> mr[] } -- = case v of { _ -> let x=v in mr[] } -tidy1 v (VarPat _ (L _ var)) +tidy1 v (VarPat _ (dL->L _ var)) = return (wrapBind var v, WildPat (idType var)) -- case v of { x@p -> mr[] } -- = case v of { p -> let x=v in mr[] } -tidy1 v (AsPat _ (L _ var) pat) +tidy1 v (AsPat _ (dL->L _ var) pat) = do { (wrap, pat') <- tidy1 v (unLoc pat) ; return (wrapBind var v . wrap, pat') } @@ -467,7 +468,7 @@ tidy1 _ (LitPat _ lit) = return (idDsWrapper, tidyLitPat lit) -- NPats: we *might* be able to replace these w/ a simpler form -tidy1 _ (NPat ty (L _ lit) mb_neg eq) +tidy1 _ (NPat ty (dL->L _ lit) mb_neg eq) = return (idDsWrapper, tidyNPat lit mb_neg eq ty) -- Everything else goes through unchanged... @@ -479,14 +480,14 @@ tidy1 _ non_interesting_pat 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 -tidy_bang_pat v _ (SigPat _ (L l p) _) = tidy_bang_pat v l p +tidy_bang_pat v _ (ParPat _ (dL->L l p)) = tidy_bang_pat v l p +tidy_bang_pat v _ (SigPat _ (dL->L l p) _) = tidy_bang_pat v l p -- Push the bang-pattern inwards, in the hope that -- it may disappear next time -tidy_bang_pat v l (AsPat x v' p) = tidy1 v (AsPat x v' (L l (BangPat noExt p))) +tidy_bang_pat v l (AsPat x v' p) = tidy1 v (AsPat x v' (cL l (BangPat noExt p))) tidy_bang_pat v l (CoPat x w p t) - = tidy1 v (CoPat x w (BangPat noExt (L l p)) t) + = tidy1 v (CoPat x w (BangPat noExt (cL l p)) t) -- Discard bang around strict pattern tidy_bang_pat v _ p@(LitPat {}) = tidy1 v p @@ -495,7 +496,7 @@ tidy_bang_pat v _ p@(TuplePat {}) = tidy1 v p tidy_bang_pat v _ p@(SumPat {}) = tidy1 v p -- Data/newtype constructors -tidy_bang_pat v l p@(ConPatOut { pat_con = L _ (RealDataCon dc) +tidy_bang_pat v l p@(ConPatOut { pat_con = (dL->L _ (RealDataCon dc)) , pat_args = args , pat_arg_tys = arg_tys }) -- Newtypes: push bang inwards (Trac #9844) @@ -521,7 +522,7 @@ tidy_bang_pat v l p@(ConPatOut { pat_con = L _ (RealDataCon dc) -- -- NB: SigPatIn, ConPatIn should not happen -tidy_bang_pat _ l p = return (idDsWrapper, BangPat noExt (L l p)) +tidy_bang_pat _ l p = return (idDsWrapper, BangPat noExt (cL l p)) ------------------- push_bang_into_newtype_arg :: SrcSpan @@ -532,16 +533,16 @@ push_bang_into_newtype_arg :: SrcSpan -- We are transforming !(N p) into (N !p) push_bang_into_newtype_arg l _ty (PrefixCon (arg:args)) = ASSERT( null args) - PrefixCon [L l (BangPat noExt arg)] + PrefixCon [cL l (BangPat noExt arg)] push_bang_into_newtype_arg l _ty (RecCon rf) - | HsRecFields { rec_flds = L lf fld : flds } <- rf + | HsRecFields { rec_flds = (dL->L lf fld) : flds } <- rf , HsRecField { hsRecFieldArg = arg } <- fld = ASSERT( null flds) - RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg - = L l (BangPat noExt arg) })] }) + RecCon (rf { rec_flds = [cL lf (fld { hsRecFieldArg + = cL l (BangPat noExt arg) })] }) push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {}) | HsRecFields { rec_flds = [] } <- rf - = PrefixCon [L l (BangPat noExt (noLoc (WildPat ty)))] + = PrefixCon [cL l (BangPat noExt (noLoc (WildPat ty)))] push_bang_into_newtype_arg _ _ cd = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd) @@ -700,7 +701,7 @@ one pattern, and match simply only accepts one pattern. JJQC 30-Nov-1997 -} -matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches +matchWrapper ctxt mb_scr (MG { mg_alts = (dL->L _ matches) , mg_ext = MatchGroupTc arg_tys rhs_ty , mg_origin = origin }) = do { dflags <- getDynFlags @@ -723,7 +724,7 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches matchEquations ctxt new_vars eqns_info rhs_ty ; return (new_vars, result_expr) } where - mk_eqn_info vars (L _ (Match { m_pats = pats, m_grhss = grhss })) + mk_eqn_info vars (dL->L _ (Match { m_pats = pats, m_grhss = grhss })) = do { dflags <- getDynFlags ; let upats = map (unLoc . decideBangHood dflags) pats dicts = collectEvVarsPats upats @@ -732,7 +733,8 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches addTmCsDs tm_cs $ -- See Note [Type and Term Equality Propagation] dsGRHSs ctxt grhss rhs_ty ; return (EqnInfo { eqn_pats = upats, eqn_rhs = match_result}) } - mk_eqn_info _ (L _ (XMatch _)) = panic "matchWrapper" + mk_eqn_info _ (dL->L _ (XMatch _)) = panic "matchWrapper" + mk_eqn_info _ _ = panic "mk_eqn_info: Impossible Match" -- due to #15884 handleWarnings = if isGenerated origin then discardWarningsDs @@ -971,8 +973,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool -- real comparison is on HsExpr's -- strip parens - exp (HsPar _ (L _ e)) e' = exp e e' - exp e (HsPar _ (L _ e')) = exp e e' + exp (HsPar _ (dL->L _ e)) e' = exp e e' + exp e (HsPar _ (dL->L _ e')) = exp e e' -- because the expressions do not necessarily have the same type, -- we have to compare the wrappers exp (HsWrap _ h e) (HsWrap _ h' e') = wrap h h' && exp e e' @@ -1025,8 +1027,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 wrap res_wrap1 res_wrap2 --------- - tup_arg (L _ (Present _ e1)) (L _ (Present _ e2)) = lexp e1 e2 - tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2 + tup_arg (dL->L _ (Present _ e1)) (dL->L _ (Present _ e2)) = lexp e1 e2 + tup_arg (dL->L _ (Missing t1)) (dL->L _ (Missing t2)) = eqType t1 t2 tup_arg _ _ = False --------- @@ -1061,13 +1063,13 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys patGroup :: DynFlags -> Pat GhcTc -> PatGroup -patGroup _ (ConPatOut { pat_con = L _ con +patGroup _ (ConPatOut { pat_con = (dL->L _ con) , pat_arg_tys = tys }) | RealDataCon dcon <- con = PgCon dcon | PatSynCon psyn <- con = PgSyn psyn tys patGroup _ (WildPat {}) = PgAny patGroup _ (BangPat {}) = PgBang -patGroup _ (NPat _ (L _ OverLit {ol_val=oval}) mb_neg _) = +patGroup _ (NPat _ (dL->L _ (OverLit {ol_val=oval})) mb_neg _) = case (oval, isJust mb_neg) of (HsIntegral i, False) -> PgN (fromInteger (il_value i)) (HsIntegral i, True ) -> PgN (-fromInteger (il_value i)) @@ -1075,7 +1077,7 @@ patGroup _ (NPat _ (L _ OverLit {ol_val=oval}) mb_neg _) = (HsFractional r, True ) -> PgN (-fl_value r) (HsIsString _ s, _) -> ASSERT(isNothing mb_neg) PgOverS s -patGroup _ (NPlusKPat _ _ (L _ OverLit {ol_val=oval}) _ _ _) = +patGroup _ (NPlusKPat _ _ (dL->L _ (OverLit {ol_val=oval})) _ _ _) = case oval of HsIntegral i -> PgNpK (il_value i) _ -> pprPanic "patGroup NPlusKPat" (ppr oval) diff --git a/compiler/deSugar/MatchCon.hs b/compiler/deSugar/MatchCon.hs index af542340fa..ddb8000442 100644 --- a/compiler/deSugar/MatchCon.hs +++ b/compiler/deSugar/MatchCon.hs @@ -8,6 +8,7 @@ Pattern-matching constructors {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module MatchCon ( matchConFamily, matchPatSyn ) where @@ -167,7 +168,8 @@ matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor alt_wrapper = wrapper1, alt_result = foldr1 combineMatchResults match_results } } where - ConPatOut { pat_con = L _ con1, pat_arg_tys = arg_tys, pat_wrap = wrapper1, + ConPatOut { pat_con = (dL->L _ con1) + , pat_arg_tys = arg_tys, pat_wrap = wrapper1, pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 } = firstPat eqn1 fields1 = map flSelector (conLikeFieldLabels con1) @@ -188,7 +190,7 @@ matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor = arg_vars where fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars - lookup_fld (L _ rpat) = lookupNameEnv_NF fld_var_env + lookup_fld (dL->L _ rpat) = lookupNameEnv_NF fld_var_env (idName (unLoc (hsRecFieldId rpat))) select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []" matchOneConLike _ _ [] = panic "matchOneCon []" @@ -205,7 +207,7 @@ compatible_pats _ _ = True -- Prefix or infix co same_fields :: HsRecFields GhcTc (LPat GhcTc) -> HsRecFields GhcTc (LPat GhcTc) -> Bool same_fields flds1 flds2 - = all2 (\(L _ f1) (L _ f2) + = all2 (\(dL->L _ f1) (dL->L _ f2) -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2)) (rec_flds flds1) (rec_flds flds2) diff --git a/compiler/deSugar/MatchLit.hs b/compiler/deSugar/MatchLit.hs index b91f44de26..94ffe81781 100644 --- a/compiler/deSugar/MatchLit.hs +++ b/compiler/deSugar/MatchLit.hs @@ -7,6 +7,7 @@ Pattern-matching literal patterns -} {-# LANGUAGE CPP, ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} module MatchLit ( dsLit, dsOverLit, dsOverLit', hsLitKey , tidyLitPat, tidyNPat @@ -251,10 +252,10 @@ warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr 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 -getLHsIntegralLit (L _ (HsTick _ _ e)) = getLHsIntegralLit e -getLHsIntegralLit (L _ (HsBinTick _ _ _ e)) = getLHsIntegralLit e -getLHsIntegralLit (L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit +getLHsIntegralLit (dL->L _ (HsPar _ e)) = getLHsIntegralLit e +getLHsIntegralLit (dL->L _ (HsTick _ _ e)) = getLHsIntegralLit e +getLHsIntegralLit (dL->L _ (HsBinTick _ _ _ e)) = getLHsIntegralLit e +getLHsIntegralLit (dL->L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit getLHsIntegralLit _ = Nothing getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Name) @@ -417,7 +418,7 @@ hsLitKey _ l = pprPanic "hsLitKey" (ppr l) matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult matchNPats (var:vars) ty (eqn1:eqns) -- All for the same literal - = do { let NPat _ (L _ lit) mb_neg eq_chk = firstPat eqn1 + = do { let NPat _ (dL->L _ lit) mb_neg eq_chk = firstPat eqn1 ; lit_expr <- dsOverLit lit ; neg_lit <- case mb_neg of Nothing -> return lit_expr @@ -448,7 +449,8 @@ We generate: matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult -- All NPlusKPats, for the *same* literal k matchNPlusKPats (var:vars) ty (eqn1:eqns) - = do { let NPlusKPat _ (L _ n1) (L _ lit1) lit2 ge minus = firstPat eqn1 + = do { let NPlusKPat _ (dL->L _ n1) (dL->L _ lit1) lit2 ge minus + = firstPat eqn1 ; lit1_expr <- dsOverLit lit1 ; lit2_expr <- dsOverLit lit2 ; pred_expr <- dsSyntaxExpr ge [Var var, lit1_expr] @@ -460,7 +462,7 @@ matchNPlusKPats (var:vars) ty (eqn1:eqns) adjustMatchResult (foldr1 (.) wraps) $ match_result) } where - shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (L _ n) _ _ _ _ : pats }) + shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (dL->L _ n) _ _ _ _ : pats }) = (wrapBind n n1, eqn { eqn_pats = pats }) -- The wrapBind is a no-op for the first equation shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e) diff --git a/compiler/deSugar/PmExpr.hs b/compiler/deSugar/PmExpr.hs index 7fa941add1..bd0e12e850 100644 --- a/compiler/deSugar/PmExpr.hs +++ b/compiler/deSugar/PmExpr.hs @@ -5,6 +5,7 @@ Haskell expressions (as used by the pattern matching checker) and utilities. -} {-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} module PmExpr ( PmExpr(..), PmLit(..), SimpleEq, ComplexEq, toComplex, eqPmLit, @@ -235,7 +236,7 @@ substComplexEq x e (ex, ey) -- ** Lift source expressions (HsExpr Id) to PmExpr lhsExprToPmExpr :: LHsExpr GhcTc -> PmExpr -lhsExprToPmExpr (L _ e) = hsExprToPmExpr e +lhsExprToPmExpr (dL->L _ e) = hsExprToPmExpr e hsExprToPmExpr :: HsExpr GhcTc -> PmExpr @@ -255,21 +256,21 @@ hsExprToPmExpr (HsLit _ lit) = stringExprToList src s | otherwise = PmExprLit (PmSLit lit) -hsExprToPmExpr e@(NegApp _ (L _ neg_expr) _) +hsExprToPmExpr e@(NegApp _ (dL->L _ neg_expr) _) | PmExprLit (PmOLit False olit) <- hsExprToPmExpr neg_expr -- NB: DON'T simply @(NegApp (NegApp olit))@ as @x@. when extension -- @RebindableSyntax@ enabled, (-(-x)) may not equals to x. = PmExprLit (PmOLit True olit) | otherwise = PmExprOther e -hsExprToPmExpr (HsPar _ (L _ e)) = hsExprToPmExpr e +hsExprToPmExpr (HsPar _ (dL->L _ e)) = hsExprToPmExpr e hsExprToPmExpr e@(ExplicitTuple _ ps boxity) | all tupArgPresent ps = mkPmExprData tuple_con tuple_args | otherwise = PmExprOther e where tuple_con = tupleDataCon boxity (length ps) - tuple_args = [ lhsExprToPmExpr e | L _ (Present _ e) <- ps ] + tuple_args = [ lhsExprToPmExpr e | (dL->L _ (Present _ e)) <- ps ] hsExprToPmExpr e@(ExplicitList _ mb_ol elems) | Nothing <- mb_ol = foldr cons nil (map lhsExprToPmExpr elems) diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 92fc77ed6c..3c78a4c3d8 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -9,6 +9,7 @@ This module converts Template Haskell syntax into HsSyn {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module Convert( convertToHsExpr, convertToPat, convertToHsDecls, convertToHsType, @@ -106,14 +107,15 @@ getL = CvtM (\loc -> Right (loc,loc)) setL :: SrcSpan -> CvtM () setL loc = CvtM (\_ -> Right (loc, ())) -returnL :: a -> CvtM (Located a) -returnL x = CvtM (\loc -> Right (loc, L loc x)) +returnL :: HasSrcSpan a => SrcSpanLess a -> CvtM a +returnL x = CvtM (\loc -> Right (loc, cL loc x)) -returnJustL :: a -> CvtM (Maybe (Located a)) +returnJustL :: HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a) returnJustL = fmap Just . returnL -wrapParL :: (Located a -> a) -> a -> CvtM a -wrapParL add_par x = CvtM (\loc -> Right (loc, add_par (L loc x))) +wrapParL :: HasSrcSpan a => + (a -> SrcSpanLess a) -> SrcSpanLess a -> CvtM (SrcSpanLess a) +wrapParL add_par x = CvtM (\loc -> Right (loc, add_par (cL loc x))) wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b -- E.g wrapMsg "declaration" dec thing @@ -129,10 +131,10 @@ wrapMsg what item (CvtM m) then text (show item) else text (pprint item)) -wrapL :: CvtM a -> CvtM (Located a) +wrapL :: HasSrcSpan a => CvtM (SrcSpanLess a) -> CvtM a wrapL (CvtM m) = CvtM (\loc -> case m loc of Left err -> Left err - Right (loc',v) -> Right (loc',L loc v)) + Right (loc',v) -> Right (loc',cL loc v)) ------------------------------------------------------------------- cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs] @@ -150,7 +152,8 @@ cvtDec (TH.ValD pat body ds) ; body' <- cvtGuard body ; ds' <- cvtLocalDecs (text "a where clause") ds ; returnJustL $ Hs.ValD noExt $ - PatBind { pat_lhs = pat', pat_rhs = GRHSs noExt body' (noLoc ds') + PatBind { pat_lhs = pat' + , pat_rhs = GRHSs noExt body' (noLoc ds') , pat_ext = noExt , pat_ticks = ([],[]) } } @@ -264,14 +267,14 @@ cvtDec (InstanceD o ctxt ty decs) ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs ; unless (null fams') (failWith (mkBadDecMsg doc fams')) ; ctxt' <- cvtContext ctxt - ; L loc ty' <- cvtType ty - ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ L loc ty' + ; (dL->L loc ty') <- cvtType ty + ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ cL loc ty' ; returnJustL $ InstD noExt $ ClsInstD noExt $ ClsInstDecl { cid_ext = noExt, cid_poly_ty = mkLHsSigType inst_ty' , cid_binds = binds' , cid_sigs = Hs.mkClassOpSigs sigs' , cid_tyfam_insts = ats', cid_datafam_insts = adts' - , cid_overlap_mode = fmap (L loc . overlap) o } } + , cid_overlap_mode = fmap (cL loc . overlap) o } } where overlap pragma = case pragma of @@ -336,7 +339,7 @@ cvtDec (NewtypeInstD ctxt tc bndrs tys ksig constr derivs) cvtDec (TySynInstD tc eqn) = do { tc' <- tconNameL tc - ; L _ eqn' <- cvtTySynEqn tc' eqn + ; (dL->L _ eqn') <- cvtTySynEqn tc' eqn ; returnJustL $ InstD noExt $ TyFamInstD { tfid_ext = noExt , tfid_inst = TyFamInstDecl { tfid_eqn = eqn' } } } @@ -362,8 +365,8 @@ cvtDec (TH.RoleAnnotD tc roles) cvtDec (TH.StandaloneDerivD ds cxt ty) = do { cxt' <- cvtContext cxt ; ds' <- traverse cvtDerivStrategy ds - ; L loc ty' <- cvtType ty - ; let inst_ty' = mkHsQualTy cxt loc cxt' $ L loc ty' + ; (dL->L loc ty') <- cvtType ty + ; let inst_ty' = mkHsQualTy cxt loc cxt' $ cL loc ty' ; returnJustL $ DerivD noExt $ DerivDecl { deriv_ext =noExt , deriv_strategy = ds' @@ -485,29 +488,29 @@ cvt_tyfam_head (TypeFamilyHead tc tyvars result injectivity) ------------------------------------------------------------------- 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 (dL->L loc (TyClD _ (FamDecl { tcdFam = d }))) = Left (cL loc d) is_fam_decl decl = Right decl 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 (dL->L loc (Hs.InstD _ (TyFamInstD { tfid_inst = d }))) + = Left (cL loc d) is_tyfam_inst decl = Right decl 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 (dL->L loc (Hs.InstD _ (DataFamInstD { dfid_inst = d }))) + = Left (cL loc d) is_datafam_inst decl = Right decl 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_sig (dL->L loc (Hs.SigD _ sig)) = Left (cL loc sig) +is_sig decl = Right decl 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 +is_bind (dL->L loc (Hs.ValD _ bind)) = Left (cL loc bind) +is_bind decl = Right decl is_ip_bind :: TH.Dec -> Either (String, TH.Exp) TH.Dec is_ip_bind (TH.ImplicitParamBindD n e) = Left (n, e) @@ -544,11 +547,12 @@ cvtConstr (InfixC st1 c st2) cvtConstr (ForallC tvs ctxt con) = do { tvs' <- cvtTvs tvs ; ctxt' <- cvtContext ctxt - ; L _ con' <- cvtConstr con + ; (dL->L _ con') <- cvtConstr con ; returnL $ add_forall tvs' ctxt' con' } where add_cxt lcxt Nothing = Just lcxt - add_cxt (L loc cxt1) (Just (L _ cxt2)) = Just (L loc (cxt1 ++ cxt2)) + add_cxt (dL->L loc cxt1) (Just (dL->L _ cxt2)) + = Just (cL loc (cxt1 ++ cxt2)) add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt }) = con { con_forall = noLoc $ not (null all_tvs) @@ -569,7 +573,7 @@ cvtConstr (ForallC tvs ctxt con) cvtConstr (GadtC c strtys ty) = do { c' <- mapM cNameL c ; args <- mapM cvt_arg strtys - ; L _ ty' <- cvtType ty + ; (dL->L _ ty') <- cvtType ty ; c_ty <- mk_arr_apps args ty' ; returnL $ fst $ mkGadtDecl c' c_ty} @@ -601,12 +605,12 @@ cvt_arg (Bang su ss, ty) cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs) cvt_id_arg (i, str, ty) - = do { L li i' <- vNameL i + = do { (dL->L li i') <- vNameL i ; ty' <- cvt_arg (str,ty) ; return $ noLoc (ConDeclField { cd_fld_ext = noExt , cd_fld_names - = [L li $ FieldOcc noExt (L li i')] + = [cL li $ FieldOcc noExt (cL li i')] , cd_fld_type = ty' , cd_fld_doc = Nothing}) } @@ -908,15 +912,18 @@ cvtl e = wrapL (cvt e) } -- Infix expressions - cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y - ; let px = parenthesizeHsExpr opPrec x' - py = parenthesizeHsExpr opPrec y' - ; wrapParL (HsPar noExt) $ - OpApp noExt px s' py } - -- Parenthesise both arguments and result, - -- to ensure this operator application does - -- does not get re-associated - -- See Note [Operator association] + cvt (InfixE (Just x) s (Just y)) = + do { x' <- cvtl x + ; s' <- cvtl s + ; y' <- cvtl y + ; let px = parenthesizeHsExpr opPrec x' + py = parenthesizeHsExpr opPrec y' + ; wrapParL (HsPar noExt) + $ OpApp noExt px s' py } + -- Parenthesise both arguments and result, + -- to ensure this operator application does + -- does not get re-associated + -- See Note [Operator association] cvt (InfixE Nothing s (Just y)) = do { s' <- cvtl s; y' <- cvtl y ; wrapParL (HsPar noExt) $ SectionR noExt s' y' } @@ -931,8 +938,8 @@ cvtl e = wrapL (cvt e) -- Note [Dropping constructors] cvt (UInfixE x s y) = do { x' <- cvtl x - ; let x'' = case x' of - L _ (OpApp {}) -> x' + ; let x'' = case unLoc x' of + OpApp {} -> x' _ -> mkLHsPar x' ; cvtOpApp x'' s y } -- Note [Converting UInfix] @@ -1060,8 +1067,8 @@ cvtHsDo do_or_lc stmts ; let Just (stmts'', last') = snocView stmts' ; last'' <- case last' of - L loc (BodyStmt _ body _ _) - -> return (L loc (mkLastStmt body)) + (dL->L loc (BodyStmt _ body _ _)) + -> return (cL loc (mkLastStmt body)) _ -> failWith (bad_last last') ; return $ HsDo noExt do_or_lc (noLoc (stmts'' ++ [last''])) } @@ -1090,8 +1097,8 @@ cvtMatch :: HsMatchContext RdrName cvtMatch ctxt (TH.Match p body decs) = do { p' <- cvtPat p ; let lp = case p' of - L loc SigPat{} -> L loc (ParPat NoExt p') -- #14875 - _ -> p' + (dL->L loc SigPat{}) -> cL loc (ParPat NoExt p') -- #14875 + _ -> p' ; g' <- cvtGuard body ; decs' <- cvtLocalDecs (text "a where clause") decs ; returnL $ Hs.Match noExt ctxt [lp] (GRHSs noExt g' (noLoc decs')) } @@ -1202,9 +1209,9 @@ cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2 -- See Note [Operator association] cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix] cvtp (ParensP p) = do { p' <- cvtPat p; - ; case p' of -- may be wrapped ConPatIn - (L _ (ParPat {})) -> return $ unLoc p' - _ -> return $ ParPat noExt p' } + ; case unLoc p' of -- may be wrapped ConPatIn + ParPat {} -> return $ unLoc p' + _ -> return $ ParPat noExt p' } cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat noExt p' } cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat noExt p' } cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p @@ -1223,9 +1230,10 @@ cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs)) cvtPatFld (s,p) - = do { L ls s' <- vNameL s; p' <- cvtPat p + = do { (dL->L ls s') <- vNameL s + ; p' <- cvtPat p ; return (noLoc $ HsRecField { hsRecFieldLbl - = L ls $ mkFieldOcc (L ls s') + = cL ls $ mkFieldOcc (cL ls s') , hsRecFieldArg = p' , hsRecPun = False}) } @@ -1323,13 +1331,11 @@ cvtTypeKind ty_str ty tys' ArrowT | [x',y'] <- tys' -> do - x'' <- case x' of - L _ HsFunTy{} -> returnL (HsParTy noExt x') - L _ HsForAllTy{} -> returnL (HsParTy noExt x') - -- #14646 - L _ HsQualTy{} -> returnL (HsParTy noExt x') - -- #15324 - _ -> return x' + x'' <- case unLoc x' of + HsFunTy{} -> returnL (HsParTy noExt x') + HsForAllTy{} -> returnL (HsParTy noExt x') -- #14646 + HsQualTy{} -> returnL (HsParTy noExt x') -- #15324 + _ -> return x' returnL (HsFunTy noExt x'' y') | otherwise -> mk_apps (HsTyVar noExt NotPromoted @@ -1417,7 +1423,7 @@ cvtTypeKind ty_str ty PromotedConsT -- See Note [Representing concrete syntax in types] -- in Language.Haskell.TH.Syntax - | [ty1, L _ (HsExplicitListTy _ ip tys2)] <- tys' + | [ty1, dL->L _ (HsExplicitListTy _ ip tys2)] <- tys' -> returnL (HsExplicitListTy noExt ip (ty1:tys2)) | otherwise -> mk_apps (HsTyVar noExt IsPromoted @@ -1464,13 +1470,13 @@ mk_apps head_ty (ty:tys) = ; mk_apps (HsAppTy noExt head_ty' p_ty) tys } where -- See Note [Adding parens for splices] - add_parens lt@(L _ t) + add_parens lt@(dL->L _ t) | hsTypeNeedsParens appPrec t = returnL (HsParTy noExt lt) | otherwise = return lt wrap_apps :: LHsType GhcPs -> CvtM (LHsType GhcPs) -wrap_apps t@(L _ HsAppTy {}) = returnL (HsParTy noExt t) -wrap_apps t = return t +wrap_apps t@(dL->L _ HsAppTy {}) = returnL (HsParTy noExt t) +wrap_apps t = return t -- --------------------------------------------------------------------- -- Note [Adding parens for splices] @@ -1564,19 +1570,20 @@ cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty)) | null exis, null provs = cvtType (ForallT univs reqs ty) | null univs, null reqs = do { l <- getL ; ty' <- cvtType (ForallT exis provs ty) - ; return $ L l (HsQualTy { hst_ctxt = L l [] - , hst_xqual = noExt - , hst_body = ty' }) } + ; return $ cL l (HsQualTy { hst_ctxt = cL l [] + , hst_xqual = noExt + , hst_body = ty' }) } | null reqs = do { l <- getL ; univs' <- hsQTvExplicit <$> cvtTvs univs ; ty' <- cvtType (ForallT exis provs ty) - ; let forTy = HsForAllTy { hst_bndrs = univs' - , hst_xforall = noExt - , hst_body = L l cxtTy } - cxtTy = HsQualTy { hst_ctxt = L l [] + ; let forTy = HsForAllTy + { hst_bndrs = univs' + , hst_xforall = noExt + , hst_body = cL l cxtTy } + cxtTy = HsQualTy { hst_ctxt = cL l [] , hst_xqual = noExt , hst_body = ty' } - ; return $ L l forTy } + ; return $ cL l forTy } | otherwise = cvtType (ForallT univs reqs (ForallT exis provs ty)) cvtPatSynSigTy ty = cvtType ty @@ -1632,9 +1639,9 @@ mkHsForAllTy :: [TH.TyVarBndr] -- ^ The complete type, quantified with a forall if necessary mkHsForAllTy tvs loc tvs' rho_ty | null tvs = rho_ty - | otherwise = L loc $ HsForAllTy { hst_bndrs = hsQTvExplicit tvs' - , hst_xforall = noExt - , hst_body = rho_ty } + | otherwise = cL loc $ HsForAllTy { hst_bndrs = hsQTvExplicit tvs' + , hst_xforall = noExt + , hst_body = rho_ty } -- | If passed an empty 'TH.Cxt', this simply returns the third argument -- (an 'LHsType'). Otherwise, return an 'HsQualTy' using the provided @@ -1656,8 +1663,9 @@ mkHsQualTy :: TH.Cxt -- ^ The complete type, qualified with a context if necessary mkHsQualTy ctxt loc ctxt' ty | null ctxt = ty - | otherwise = L loc $ HsQualTy { hst_xqual = noExt, hst_ctxt = ctxt' - , hst_body = ty } + | otherwise = cL loc $ HsQualTy { hst_xqual = noExt + , hst_ctxt = ctxt' + , hst_body = ty } -------------------------------------------------------------------- -- Turning Name back into RdrName @@ -1769,8 +1777,9 @@ thRdrNameGuesses (TH.Name occ flavour) | gns <- guessed_nss] where -- guessed_ns are the name spaces guessed from looking at the TH name - guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName, OccName.dataName] - | otherwise = [OccName.varName, OccName.tvName] + guessed_nss + | isLexCon (mkFastString occ_str) = [OccName.tcName, OccName.dataName] + | otherwise = [OccName.varName, OccName.tvName] occ_str = TH.occString occ -- The packing and unpacking is rather turgid :-( diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs index 5c7a6f1b81..8ec39bc1f5 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -15,6 +15,8 @@ -- in module PlaceHolder {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleInstances #-} module HsPat ( Pat(..), InPat, OutPat, LPat, @@ -70,7 +72,7 @@ import Data.Data hiding (TyCon,Fixity) type InPat p = LPat p -- No 'Out' constructors type OutPat p = LPat p -- No 'In' constructors -type LPat p = Located (Pat p) +type LPat p = Pat p -- | Pattern -- @@ -324,7 +326,34 @@ type instance XSigPat GhcRn = NoExt type instance XSigPat GhcTc = Type type instance XCoPat (GhcPass _) = NoExt -type instance XXPat (GhcPass _) = NoExt +type instance XXPat (GhcPass p) = Located (Pat (GhcPass p)) + + +{- +************************************************************************ +* * +* HasSrcSpan Instance +* * +************************************************************************ +-} + +type instance SrcSpanLess (LPat (GhcPass p)) = Pat (GhcPass p) +instance HasSrcSpan (LPat (GhcPass p)) where + -- NB: The following chooses the behaviour of the outer location + -- wrapper replacing the inner ones. + composeSrcSpan (L sp p) = if sp == noSrcSpan + then p + else XPat (L sp (stripSrcSpanPat p)) + + -- NB: The following only returns the top-level location, if any. + decomposeSrcSpan (XPat (L sp p)) = L sp (stripSrcSpanPat p) + decomposeSrcSpan p = L noSrcSpan p + +stripSrcSpanPat :: LPat (GhcPass p) -> Pat (GhcPass p) +stripSrcSpanPat (XPat (L _ p)) = stripSrcSpanPat p +stripSrcSpanPat p = p + + -- --------------------------------------------------------------------- @@ -489,7 +518,7 @@ pprPatBndr var -- Print with type info if -dppr-debug is on pprParendLPat :: (OutputableBndrId (GhcPass p)) => PprPrec -> LPat (GhcPass p) -> SDoc -pprParendLPat p (L _ pat) = pprParendPat p pat +pprParendLPat p = pprParendPat p . unLoc pprParendPat :: (OutputableBndrId (GhcPass p)) => PprPrec -> Pat (GhcPass p) -> SDoc @@ -507,7 +536,7 @@ pprParendPat p pat = sdocWithDynFlags $ \ dflags -> -- is the pattern inside that matters. Sigh. pprPat :: (OutputableBndrId (GhcPass p)) => Pat (GhcPass p) -> SDoc -pprPat (VarPat _ (L _ var)) = pprPatBndr var +pprPat (VarPat _ lvar) = pprPatBndr (unLoc lvar) pprPat (WildPat _) = char '_' pprPat (LazyPat _ pat) = char '~' <> pprParendLPat appPrec pat pprPat (BangPat _ pat) = char '!' <> pprParendLPat appPrec pat @@ -530,8 +559,11 @@ pprPat (TuplePat _ pats bx) = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats) pprPat (SumPat _ pat alt arity) = sumParens (pprAlternative ppr pat alt arity) pprPat (ConPatIn con details) = pprUserCon (unLoc con) details -pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts, - pat_binds = binds, pat_args = details }) +pprPat (ConPatOut { pat_con = con + , pat_tvs = tvs + , pat_dicts = dicts + , pat_binds = binds + , pat_args = details }) = sdocWithDynFlags $ \dflags -> -- Tiresome; in TcBinds.tcRhs we print out a -- typechecked Pat in an error message, @@ -581,14 +613,19 @@ instance (Outputable p, Outputable arg) ************************************************************************ -} -mkPrefixConPat :: DataCon -> [OutPat p] -> [Type] -> OutPat p +mkPrefixConPat :: DataCon -> + [OutPat (GhcPass p)] -> [Type] -> OutPat (GhcPass 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 p + = 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 (GhcPass p) mkNilPat ty = mkPrefixConPat nilDataCon [] [ty] mkCharLitPat :: SourceText -> Char -> OutPat (GhcPass p) @@ -627,12 +664,15 @@ patterns are treated specially, of course. The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are. -} -isBangedLPat :: LPat p -> Bool -isBangedLPat (L _ (ParPat _ p)) = isBangedLPat p -isBangedLPat (L _ (BangPat {})) = True -isBangedLPat _ = False +isBangedLPat :: LPat (GhcPass p) -> Bool +isBangedLPat = isBangedPat . unLoc -looksLazyPatBind :: HsBind p -> Bool +isBangedPat :: Pat (GhcPass p) -> Bool +isBangedPat (ParPat _ p) = isBangedLPat p +isBangedPat (BangPat {}) = True +isBangedPat _ = False + +looksLazyPatBind :: HsBind (GhcPass p) -> Bool -- Returns True of anything *except* -- a StrictHsBind (as above) or -- a VarPat @@ -645,15 +685,18 @@ looksLazyPatBind (AbsBinds { abs_binds = binds }) looksLazyPatBind _ = False -looksLazyLPat :: LPat p -> Bool -looksLazyLPat (L _ (ParPat _ p)) = looksLazyLPat p -looksLazyLPat (L _ (AsPat _ _ p)) = looksLazyLPat p -looksLazyLPat (L _ (BangPat {})) = False -looksLazyLPat (L _ (VarPat {})) = False -looksLazyLPat (L _ (WildPat {})) = False -looksLazyLPat _ = True +looksLazyLPat :: LPat (GhcPass p) -> Bool +looksLazyLPat = looksLazyPat . unLoc + +looksLazyPat :: Pat (GhcPass p) -> Bool +looksLazyPat (ParPat _ p) = looksLazyLPat p +looksLazyPat (AsPat _ _ p) = looksLazyLPat p +looksLazyPat (BangPat {}) = False +looksLazyPat (VarPat {}) = False +looksLazyPat (WildPat {}) = False +looksLazyPat _ = True -isIrrefutableHsPat :: (OutputableBndrId p) => LPat p -> Bool +isIrrefutableHsPat :: (OutputableBndrId (GhcPass p)) => LPat (GhcPass 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 @@ -666,43 +709,47 @@ isIrrefutableHsPat :: (OutputableBndrId p) => LPat p -> Bool -- tuple patterns are considered irrefuable at the renamer stage. -- -- But if it returns True, the pattern is definitely irrefutable -isIrrefutableHsPat pat - = go pat +isIrrefutableHsPat + = goL where - go (L _ pat) = go1 pat - - go1 (WildPat {}) = True - go1 (VarPat {}) = True - go1 (LazyPat {}) = True - go1 (BangPat _ pat) = go pat - go1 (CoPat _ _ pat _) = go1 pat - go1 (ParPat _ pat) = go pat - go1 (AsPat _ _ pat) = go pat - go1 (ViewPat _ _ pat) = go pat - go1 (SigPat _ pat _) = go pat - go1 (TuplePat _ pats _) = all go pats - go1 (SumPat {}) = False + goL = go . unLoc + + go (WildPat {}) = True + go (VarPat {}) = True + go (LazyPat {}) = True + go (BangPat _ pat) = goL pat + go (CoPat _ _ pat _) = go pat + go (ParPat _ pat) = goL pat + go (AsPat _ _ pat) = goL pat + go (ViewPat _ _ pat) = goL pat + go (SigPat _ pat _) = goL pat + go (TuplePat _ pats _) = all goL pats + go (SumPat {}) = False -- See Note [Unboxed sum patterns aren't irrefutable] - go1 (ListPat {}) = False - - go1 (ConPatIn {}) = False -- Conservative - go1 (ConPatOut{ pat_con = L _ (RealDataCon con), pat_args = details }) - = isJust (tyConSingleDataCon_maybe (dataConTyCon con)) - -- NB: tyConSingleDataCon_maybe, *not* isProductTyCon, because - -- the latter is false of existentials. See Trac #4439 - && all go (hsConPatArgs details) - go1 (ConPatOut{ pat_con = L _ (PatSynCon _pat) }) - = False -- Conservative - - go1 (LitPat {}) = False - go1 (NPat {}) = False - go1 (NPlusKPat {}) = False + go (ListPat {}) = False + + go (ConPatIn {}) = False -- Conservative + go (ConPatOut + { pat_con = (dL->L _ (RealDataCon con)) + , pat_args = details }) + = + isJust (tyConSingleDataCon_maybe (dataConTyCon con)) + -- NB: tyConSingleDataCon_maybe, *not* isProductTyCon, because + -- the latter is false of existentials. See Trac #4439 + && all goL (hsConPatArgs details) + go (ConPatOut + { pat_con = (dL->L _ (PatSynCon _pat)) }) + = False -- Conservative + go (ConPatOut{}) = panic "ConPatOut:Impossible Match" -- due to #15884 + go (LitPat {}) = False + go (NPat {}) = False + go (NPlusKPat {}) = False -- We conservatively assume that no TH splices are irrefutable -- since we cannot know until the splice is evaluated. - go1 (SplicePat {}) = False + go (SplicePat {}) = False - go1 (XPat {}) = False + go (XPat {}) = False {- Note [Unboxed sum patterns aren't irrefutable] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -731,25 +778,25 @@ is the only thing that could possibly be matched! patNeedsParens :: PprPrec -> Pat p -> Bool patNeedsParens p = go where - go (NPlusKPat {}) = p > opPrec - go (SplicePat {}) = False - go (ConPatIn _ ds) = conPatNeedsParens p ds - go cp@(ConPatOut {}) = conPatNeedsParens p (pat_args cp) - go (SigPat {}) = p >= sigPrec - go (ViewPat {}) = True - go (CoPat _ _ p _) = go p - go (WildPat {}) = False - go (VarPat {}) = False - go (LazyPat {}) = False - go (BangPat {}) = False - go (ParPat {}) = False - go (AsPat {}) = False - go (TuplePat {}) = False - go (SumPat {}) = False - go (ListPat {}) = False - go (LitPat _ l) = hsLitNeedsParens p l - go (NPat _ (L _ ol) _ _) = hsOverLitNeedsParens p ol - go (XPat {}) = True -- conservative default + go (NPlusKPat {}) = p > opPrec + go (SplicePat {}) = False + go (ConPatIn _ ds) = conPatNeedsParens p ds + go cp@(ConPatOut {}) = conPatNeedsParens p (pat_args cp) + go (SigPat {}) = p >= sigPrec + go (ViewPat {}) = True + go (CoPat _ _ p _) = go p + go (WildPat {}) = False + go (VarPat {}) = False + go (LazyPat {}) = False + go (BangPat {}) = False + go (ParPat {}) = False + go (AsPat {}) = False + go (TuplePat {}) = False + go (SumPat {}) = False + go (ListPat {}) = False + go (LitPat _ l) = hsLitNeedsParens p l + go (NPat _ lol _ _) = hsOverLitNeedsParens p (unLoc lol) + go (XPat {}) = True -- conservative default -- | @'conPatNeedsParens' p cp@ returns 'True' if the constructor patterns @cp@ -- needs parentheses under precedence @p@. @@ -763,8 +810,8 @@ conPatNeedsParens p = go -- | @'parenthesizePat' p pat@ checks if @'patNeedsParens' p pat@ is true, and -- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat@. parenthesizePat :: PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p) -parenthesizePat p lpat@(L loc pat) - | patNeedsParens p pat = L loc (ParPat NoExt lpat) +parenthesizePat p lpat@(dL->L loc pat) + | patNeedsParens p pat = cL loc (ParPat NoExt lpat) | otherwise = lpat {- @@ -776,7 +823,7 @@ collectEvVarsPats :: [Pat GhcTc] -> Bag EvVar collectEvVarsPats = unionManyBags . map collectEvVarsPat collectEvVarsLPat :: LPat GhcTc -> Bag EvVar -collectEvVarsLPat (L _ pat) = collectEvVarsPat pat +collectEvVarsLPat = collectEvVarsPat . unLoc collectEvVarsPat :: Pat GhcTc -> Bag EvVar collectEvVarsPat pat = diff --git a/compiler/hsSyn/HsPat.hs-boot b/compiler/hsSyn/HsPat.hs-boot index b7efb1c28c..a1067d5dc5 100644 --- a/compiler/hsSyn/HsPat.hs-boot +++ b/compiler/hsSyn/HsPat.hs-boot @@ -7,13 +7,12 @@ {-# LANGUAGE TypeFamilies #-} module HsPat where -import SrcLoc( Located ) import Outputable import HsExtension ( OutputableBndrId, GhcPass ) type role Pat nominal data Pat (i :: *) -type LPat i = Located (Pat i) +type LPat i = Pat i instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Pat p) diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index 1d44bffa2f..bc909cfe90 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -982,14 +982,14 @@ hsAllLTyVarNames (HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = kvs } hsAllLTyVarNames (XLHsQTyVars _) = panic "hsAllLTyVarNames" hsLTyVarLocName :: LHsTyVarBndr pass -> Located (IdP pass) -hsLTyVarLocName = fmap hsTyVarName +hsLTyVarLocName = onHasSrcSpan hsTyVarName hsLTyVarLocNames :: LHsQTyVars pass -> [Located (IdP pass)] hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs) -- | Convert a LHsTyVarBndr to an equivalent LHsType. hsLTyVarBndrToType :: LHsTyVarBndr (GhcPass p) -> LHsType (GhcPass p) -hsLTyVarBndrToType = fmap cvt +hsLTyVarBndrToType = onHasSrcSpan cvt where cvt (UserTyVar _ n) = HsTyVar noExt NotPromoted n cvt (KindedTyVar _ (L name_loc n) kind) = HsKindSig noExt diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index e5e4ba66e6..ac046683c2 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -17,6 +17,7 @@ which deal with the instantiated versions are located elsewhere: {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module HsUtils( -- Terms @@ -139,13 +140,13 @@ just attach noSrcSpan to everything. -} mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -mkHsPar e = L (getLoc e) (HsPar noExt e) +mkHsPar e = cL (getLoc e) (HsPar noExt e) mkSimpleMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p))) -> [LPat (GhcPass p)] -> Located (body (GhcPass p)) -> LMatch (GhcPass p) (Located (body (GhcPass p))) mkSimpleMatch ctxt pats rhs - = L loc $ + = cL loc $ Match { m_ext = noExt, m_ctxt = ctxt, m_pats = pats , m_grhss = unguardedGRHSs rhs } where @@ -155,12 +156,12 @@ mkSimpleMatch ctxt pats rhs unguardedGRHSs :: Located (body (GhcPass p)) -> GRHSs (GhcPass p) (Located (body (GhcPass p))) -unguardedGRHSs rhs@(L loc _) +unguardedGRHSs rhs@(dL->L loc _) = GRHSs noExt (unguardedRHS loc rhs) (noLoc emptyLocalBinds) unguardedRHS :: SrcSpan -> Located (body (GhcPass p)) -> [LGRHS (GhcPass p) (Located (body (GhcPass p)))] -unguardedRHS loc rhs = [L loc (GRHS noExt [] rhs)] +unguardedRHS loc rhs = [cL loc (GRHS noExt [] rhs)] mkMatchGroup :: (XMG name (Located (body name)) ~ NoExt) => Origin -> [LMatch name (Located (body name))] @@ -171,7 +172,7 @@ mkMatchGroup origin matches = MG { mg_ext = noExt mkLocatedList :: [Located a] -> Located [Located a] mkLocatedList [] = noLoc [] -mkLocatedList ms = L (combineLocs (head ms) (last ms)) ms +mkLocatedList ms = cL (combineLocs (head ms) (last ms)) ms mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) mkHsApp e1 e2 = addCLoc e1 e2 (HsApp noExt e1 e2) @@ -187,7 +188,7 @@ mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn mkHsAppTypes = foldl' mkHsAppType mkHsLam :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs -mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noExt matches)) +mkHsLam pats body = mkHsPar (cL (getLoc body) (HsLam noExt matches)) where matches = mkMatchGroup Generated [mkSimpleMatch LambdaExpr pats' body] @@ -216,12 +217,14 @@ nlHsTyApps fun_id tys xs = foldl' nlHsApp (nlHsTyApp fun_id tys) xs mkLHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -- Wrap in parens if (hsExprNeedsParens appPrec) says it needs them -- So 'f x' becomes '(f x)', but '3' stays as '3' -mkLHsPar le@(L loc e) | hsExprNeedsParens appPrec e = L loc (HsPar noExt le) - | otherwise = le +mkLHsPar le@(dL->L loc e) + | hsExprNeedsParens appPrec e = cL loc (HsPar noExt le) + | otherwise = le mkParPat :: LPat (GhcPass name) -> LPat (GhcPass name) -mkParPat lp@(L loc p) | patNeedsParens appPrec p = L loc (ParPat noExt lp) - | otherwise = lp +mkParPat lp@(dL->L loc p) + | patNeedsParens appPrec p = cL loc (ParPat noExt lp) + | otherwise = lp nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name) nlParPat p = noLoc (ParPat noExt p) @@ -266,7 +269,7 @@ mkHsIsString src s = OverLit noExt (HsIsString src s) noExpr mkHsDo ctxt stmts = HsDo noExt ctxt (mkLocatedList stmts) mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt]) where - last_stmt = L (getLoc expr) $ mkLastStmt expr + last_stmt = cL (getLoc expr) $ mkLastStmt expr mkHsIf :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> HsExpr (GhcPass p) @@ -373,11 +376,11 @@ mkHsStringPrimLit fs userHsLTyVarBndrs :: SrcSpan -> [Located (IdP (GhcPass p))] -> [LHsTyVarBndr (GhcPass p)] -- Caller sets location -userHsLTyVarBndrs loc bndrs = [ L loc (UserTyVar noExt v) | v <- bndrs ] +userHsLTyVarBndrs loc bndrs = [ cL loc (UserTyVar noExt v) | v <- bndrs ] userHsTyVarBndrs :: SrcSpan -> [IdP (GhcPass p)] -> [LHsTyVarBndr (GhcPass p)] -- Caller sets location -userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar noExt (L loc v)) +userHsTyVarBndrs loc bndrs = [ cL loc (UserTyVar noExt (cL loc v)) | v <- bndrs ] @@ -452,7 +455,7 @@ nlConPatName :: Name -> [LPat GhcRn] -> LPat GhcRn nlConPatName con pats = noLoc (ConPatIn (noLoc con) (PrefixCon (map (parenthesizePat appPrec) pats))) -nlNullaryConPat :: IdP id -> LPat id +nlNullaryConPat :: IdP (GhcPass p) -> LPat (GhcPass p) nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon [])) nlWildConPat :: DataCon -> LPat GhcPs @@ -503,8 +506,8 @@ nlHsTyVar x = noLoc (HsTyVar noExt NotPromoted (noLoc x)) nlHsFunTy a b = noLoc (HsFunTy noExt (parenthesizeHsType funPrec a) (parenthesize_fun_tail b)) where - parenthesize_fun_tail (L loc (HsFunTy ext ty1 ty2)) - = L loc (HsFunTy ext (parenthesizeHsType funPrec ty1) + parenthesize_fun_tail (dL->L loc (HsFunTy ext ty1 ty2)) + = cL loc (HsFunTy ext (parenthesizeHsType funPrec ty1) (parenthesize_fun_tail ty2)) parenthesize_fun_tail lty = lty nlHsParTy t = noLoc (HsParTy noExt t) @@ -535,7 +538,7 @@ missingTupArg = Missing noExt mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn mkLHsPatTup [] = noLoc $ TuplePat noExt [] Boxed mkLHsPatTup [lpat] = lpat -mkLHsPatTup lpats = L (getLoc (head lpats)) $ TuplePat noExt lpats Boxed +mkLHsPatTup lpats = cL (getLoc (head lpats)) $ TuplePat noExt lpats Boxed -- The Big equivalents for the source tuple expressions mkBigLHsVarTup :: [IdP (GhcPass id)] -> LHsExpr (GhcPass id) @@ -624,12 +627,12 @@ mkHsSigEnv get_info sigs -- of which use this function where (gen_dm_sigs, ordinary_sigs) = partition is_gen_dm_sig sigs - is_gen_dm_sig (L _ (ClassOpSig _ True _ _)) = True - is_gen_dm_sig _ = False + is_gen_dm_sig (dL->L _ (ClassOpSig _ True _ _)) = True + is_gen_dm_sig _ = False mk_pairs :: [LSig GhcRn] -> [(Name, a)] mk_pairs sigs = [ (n,a) | Just (ns,a) <- map get_info sigs - , L _ n <- ns ] + , (dL->L _ n) <- ns ] mkClassOpSigs :: [LSig GhcPs] -> [LSig GhcPs] -- Convert TypeSig to ClassOpSig @@ -638,8 +641,8 @@ mkClassOpSigs :: [LSig GhcPs] -> [LSig GhcPs] mkClassOpSigs sigs = map fiddle sigs where - fiddle (L loc (TypeSig _ nms ty)) - = L loc (ClassOpSig noExt False nms (dropWildCards ty)) + fiddle (dL->L loc (TypeSig _ nms ty)) + = cL loc (ClassOpSig noExt False nms (dropWildCards ty)) fiddle sig = sig typeToLHsType :: Type -> LHsType GhcPs @@ -746,7 +749,7 @@ to make those work. ********************************************************************* -} mkLHsWrap :: HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e) +mkLHsWrap co_fn (dL->L loc e) = cL loc (mkHsWrap co_fn e) -- Avoid (HsWrap co (HsWrap co' _)). -- See Note [Detecting forced eta expansion] in DsExpr @@ -764,14 +767,14 @@ mkHsWrapCoR :: TcCoercionR -- A Representational coercion a ~R b mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e mkLHsWrapCo :: TcCoercionN -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e) +mkLHsWrapCo co (dL->L loc e) = cL loc (mkHsWrapCo co e) mkHsCmdWrap :: HsWrapper -> HsCmd (GhcPass p) -> HsCmd (GhcPass p) mkHsCmdWrap w cmd | isIdHsWrapper w = cmd | otherwise = HsCmdWrap noExt w cmd mkLHsCmdWrap :: HsWrapper -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p) -mkLHsCmdWrap w (L loc c) = L loc (mkHsCmdWrap w c) +mkLHsCmdWrap w (dL->L loc c) = cL loc (mkHsCmdWrap w c) mkHsWrapPat :: HsWrapper -> Pat (GhcPass id) -> Type -> Pat (GhcPass id) mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p @@ -816,7 +819,7 @@ mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs mkVarBind :: IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p) -mkVarBind var rhs = L (getLoc rhs) $ +mkVarBind var rhs = cL (getLoc rhs) $ VarBind { var_ext = noExt, var_id = var, var_rhs = rhs, var_inline = False } @@ -842,8 +845,8 @@ isInfixFunBind _ = False 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 + = cL loc $ mkFunBind (cL loc fun) + [mkMatch (mkPrefixFunRhs (cL loc fun)) pats expr (noLoc emptyLocalBinds)] -- | Make a prefix, non-strict function 'HsMatchContext' @@ -863,8 +866,9 @@ mkMatch ctxt pats expr lbinds , m_pats = map paren pats , m_grhss = GRHSs noExt (unguardedRHS noSrcSpan expr) lbinds }) where - paren lp@(L l p) | patNeedsParens appPrec p = L l (ParPat noExt lp) - | otherwise = lp + paren lp@(dL->L l p) + | patNeedsParens appPrec p = cL l (ParPat noExt lp) + | otherwise = lp {- ************************************************************************ @@ -943,7 +947,7 @@ isBangedHsBind :: HsBind GhcTc -> Bool isBangedHsBind (AbsBinds { abs_binds = binds }) = anyBag (isBangedHsBind . unLoc) binds isBangedHsBind (FunBind {fun_matches = matches}) - | [L _ match] <- unLoc $ mg_alts matches + | [dL->L _ match] <- unLoc $ mg_alts matches , FunRhs{mc_strictness = SrcStrict} <- m_ctxt match = True isBangedHsBind (PatBind {pat_lhs = pat}) @@ -965,14 +969,15 @@ collectHsIdBinders, collectHsValBinders collectHsIdBinders = collect_hs_val_binders True collectHsValBinders = collect_hs_val_binders False -collectHsBindBinders :: HsBindLR idL idR -> [IdP idL] +collectHsBindBinders :: (SrcSpanLess (LPat p) ~ Pat p, HasSrcSpan (LPat p))=> + HsBindLR p idR -> [IdP p] -- Collect both Ids and pattern-synonym binders collectHsBindBinders b = collect_bind False b [] -collectHsBindsBinders :: LHsBindsLR idL idR -> [IdP idL] +collectHsBindsBinders :: LHsBindsLR (GhcPass p) idR -> [IdP (GhcPass p)] collectHsBindsBinders binds = collect_binds False binds [] -collectHsBindListBinders :: [LHsBindLR idL idR] -> [IdP idL] +collectHsBindListBinders :: [LHsBindLR (GhcPass p) idR] -> [IdP (GhcPass p)] -- Same as collectHsBindsBinders, but works over a list of bindings collectHsBindListBinders = foldr (collect_bind False . unLoc) [] @@ -982,22 +987,25 @@ collect_hs_val_binders ps (ValBinds _ binds _) = collect_binds ps binds [] collect_hs_val_binders ps (XValBindsLR (NValBinds binds _)) = collect_out_binds ps binds -collect_out_binds :: Bool -> [(RecFlag, LHsBinds p)] -> [IdP p] +collect_out_binds :: Bool -> [(RecFlag, LHsBinds (GhcPass p))] -> + [IdP (GhcPass p)] collect_out_binds ps = foldr (collect_binds ps . snd) [] -collect_binds :: Bool -> LHsBindsLR idL idR -> [IdP idL] -> [IdP idL] +collect_binds :: Bool -> LHsBindsLR (GhcPass p) idR -> + [IdP (GhcPass p)] -> [IdP (GhcPass p)] -- 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 -> [IdP idL] -> [IdP idL] +collect_bind :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) => + Bool -> HsBindLR p idR -> [IdP p] -> [IdP p] collect_bind _ (PatBind { pat_lhs = p }) acc = collect_lpat p acc -collect_bind _ (FunBind { fun_id = L _ f }) acc = f : acc +collect_bind _ (FunBind { fun_id = (dL->L _ f) }) acc = f : acc collect_bind _ (VarBind { var_id = f }) acc = f : acc collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc -- I don't think we want the binders from the abe_binds -- binding (hence see AbsBinds) is in zonking in TcHsSyn -collect_bind omitPatSyn (PatSynBind _ (PSB { psb_id = L _ ps })) acc +collect_bind omitPatSyn (PatSynBind _ (PSB { psb_id = (dL->L _ ps) })) acc | omitPatSyn = acc | otherwise = ps : acc collect_bind _ (PatSynBind _ (XPatSynBind _)) acc = acc @@ -1028,7 +1036,7 @@ collectStmtBinders :: StmtLR (GhcPass idL) (GhcPass idR) body -> [IdP (GhcPass idL)] -- Id Binders for a Stmt... [but what about pattern-sig type vars]? collectStmtBinders (BindStmt _ pat _ _ _) = collectPatBinders pat -collectStmtBinders (LetStmt _ (L _ binds)) = collectLocalBinders binds +collectStmtBinders (LetStmt _ binds) = collectLocalBinders (unLoc binds) collectStmtBinders (BodyStmt {}) = [] collectStmtBinders (LastStmt {}) = [] collectStmtBinders (ParStmt _ xs _ _) = collectLStmtsBinders @@ -1044,22 +1052,23 @@ collectStmtBinders XStmtLR{} = panic "collectStmtBinders" ----------------- Patterns -------------------------- -collectPatBinders :: LPat a -> [IdP a] +collectPatBinders :: LPat (GhcPass p) -> [IdP (GhcPass p)] collectPatBinders pat = collect_lpat pat [] -collectPatsBinders :: [LPat a] -> [IdP a] +collectPatsBinders :: [LPat (GhcPass p)] -> [IdP (GhcPass p)] collectPatsBinders pats = foldr collect_lpat [] pats ------------- -collect_lpat :: LPat pass -> [IdP pass] -> [IdP pass] -collect_lpat (L _ pat) bndrs - = go pat +collect_lpat :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) => + LPat p -> [IdP p] -> [IdP p] +collect_lpat p bndrs + = go (unLoc p) where - go (VarPat _ (L _ var)) = var : bndrs + go (VarPat _ var) = unLoc var : bndrs go (WildPat _) = bndrs go (LazyPat _ pat) = collect_lpat pat bndrs go (BangPat _ pat) = collect_lpat pat bndrs - go (AsPat _ (L _ a) pat) = a : collect_lpat pat bndrs + go (AsPat _ a pat) = unLoc a : collect_lpat pat bndrs go (ViewPat _ _ pat) = collect_lpat pat bndrs go (ParPat _ pat) = collect_lpat pat bndrs @@ -1070,11 +1079,11 @@ collect_lpat (L _ pat) bndrs go (ConPatIn _ ps) = foldr collect_lpat bndrs (hsConPatArgs ps) go (ConPatOut {pat_args=ps}) = foldr collect_lpat bndrs (hsConPatArgs ps) -- See Note [Dictionary binders in ConPatOut] - go (LitPat _ _) = bndrs - go (NPat {}) = bndrs - go (NPlusKPat _ (L _ n) _ _ _ _)= n : bndrs + go (LitPat _ _) = bndrs + go (NPat {}) = bndrs + go (NPlusKPat _ n _ _ _ _) = unLoc n : bndrs - go (SigPat _ pat _) = collect_lpat pat bndrs + go (SigPat _ pat _) = collect_lpat pat bndrs go (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat))) = go pat @@ -1144,28 +1153,40 @@ hsLTyClDeclBinders :: Located (TyClDecl pass) -- Each returned (Located name) has a SrcSpan for the /whole/ declaration. -- See Note [SrcSpan for binders] -hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl { fdLName = L _ name } })) - = ([L loc name], []) -hsLTyClDeclBinders (L _ (FamDecl { tcdFam = XFamilyDecl _ })) +hsLTyClDeclBinders (dL->L loc (FamDecl { tcdFam = FamilyDecl + { fdLName = (dL->L _ name) } })) + = ([cL loc name], []) +hsLTyClDeclBinders (dL->L _ (FamDecl { tcdFam = XFamilyDecl _ })) = panic "hsLTyClDeclBinders" -hsLTyClDeclBinders (L loc (SynDecl { tcdLName = L _ name })) = ([L loc name], []) -hsLTyClDeclBinders (L loc (ClassDecl { tcdLName = L _ cls_name - , tcdSigs = sigs, tcdATs = ats })) - = (L loc cls_name : - [ L fam_loc fam_name | L fam_loc (FamilyDecl { fdLName = L _ fam_name }) <- ats ] ++ - [ L mem_loc mem_name | L mem_loc (ClassOpSig _ False ns _) <- sigs - , L _ mem_name <- ns ] +hsLTyClDeclBinders (dL->L loc (SynDecl + { tcdLName = (dL->L _ name) })) + = ([cL loc name], []) +hsLTyClDeclBinders (dL->L loc (ClassDecl + { tcdLName = (dL->L _ cls_name) + , tcdSigs = sigs + , tcdATs = ats })) + = (cL loc cls_name : + [ cL fam_loc fam_name | (dL->L fam_loc (FamilyDecl + { fdLName = L _ fam_name })) <- ats ] + ++ + [ cL mem_loc mem_name | (dL->L mem_loc (ClassOpSig _ False ns _)) <- sigs + , (dL->L _ mem_name) <- ns ] , []) -hsLTyClDeclBinders (L loc (DataDecl { tcdLName = L _ name, tcdDataDefn = defn })) - = (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn -hsLTyClDeclBinders (L _ (XTyClDecl _)) = panic "hsLTyClDeclBinders" +hsLTyClDeclBinders (dL->L loc (DataDecl { tcdLName = (dL->L _ name) + , tcdDataDefn = defn })) + = (\ (xs, ys) -> (cL loc name : xs, ys)) $ hsDataDefnBinders defn +hsLTyClDeclBinders (dL->L _ (XTyClDecl _)) = panic "hsLTyClDeclBinders" +hsLTyClDeclBinders _ = panic "hsLTyClDeclBinders: Impossible Match" + -- due to #15884 + ------------------- hsForeignDeclsBinders :: [LForeignDecl pass] -> [Located (IdP pass)] -- See Note [SrcSpan for binders] hsForeignDeclsBinders foreign_decls - = [ L decl_loc n - | L decl_loc (ForeignImport { fd_name = L _ n }) <- foreign_decls] + = [ cL decl_loc n + | (dL->L decl_loc (ForeignImport { fd_name = (dL->L _ n) })) + <- foreign_decls] ------------------- @@ -1178,27 +1199,31 @@ hsPatSynSelectors (XValBindsLR (NValBinds binds _)) addPatSynSelector:: LHsBind p -> [IdP p] -> [IdP p] addPatSynSelector bind sels - | L _ (PatSynBind _ (PSB { psb_args = RecCon as })) <- bind + | PatSynBind _ (PSB { psb_args = RecCon as }) <- unLoc bind = map (unLoc . recordPatSynSelectorId) as ++ sels | otherwise = sels getPatSynBinds :: [(RecFlag, LHsBinds id)] -> [PatSynBind id id] getPatSynBinds binds = [ psb | (_, lbinds) <- binds - , L _ (PatSynBind _ psb) <- bagToList lbinds ] + , (dL->L _ (PatSynBind _ psb)) <- bagToList lbinds ] ------------------- hsLInstDeclBinders :: LInstDecl (GhcPass p) -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) -hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } })) +hsLInstDeclBinders (dL->L _ (ClsInstD + { cid_inst = ClsInstDecl + { cid_datafam_insts = dfis }})) = foldMap (hsDataFamInstBinders . unLoc) dfis -hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi })) +hsLInstDeclBinders (dL->L _ (DataFamInstD { dfid_inst = fi })) = hsDataFamInstBinders fi -hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty -hsLInstDeclBinders (L _ (ClsInstD _ (XClsInstDecl {}))) +hsLInstDeclBinders (dL->L _ (TyFamInstD {})) = mempty +hsLInstDeclBinders (dL->L _ (ClsInstD _ (XClsInstDecl {}))) = panic "hsLInstDeclBinders" -hsLInstDeclBinders (L _ (XInstDecl _)) +hsLInstDeclBinders (dL->L _ (XInstDecl _)) = panic "hsLInstDeclBinders" +hsLInstDeclBinders _ = panic "hsLInstDeclBinders: Impossible Match" + -- due to #15884 ------------------- -- the SrcLoc returned are for the whole declarations, not just the names @@ -1239,22 +1264,23 @@ hsConDeclsBinders cons go remSeen (r:rs) -- Don't re-mangle the location of field names, because we don't -- have a record of the full location of the field declaration anyway - = case r of + = let loc = getLoc r + in case unLoc r of -- remove only the first occurrence of any seen field in order to -- avoid circumventing detection of duplicate fields (#9156) - L loc (ConDeclGADT { con_names = names, con_args = args }) - -> (map (L loc . unLoc) names ++ ns, flds ++ fs) + ConDeclGADT { con_names = names, con_args = args } + -> (map (cL loc . unLoc) names ++ ns, flds ++ fs) where (remSeen', flds) = get_flds remSeen args (ns, fs) = go remSeen' rs - L loc (ConDeclH98 { con_name = name, con_args = args }) - -> ([L loc (unLoc name)] ++ ns, flds ++ fs) + ConDeclH98 { con_name = name, con_args = args } + -> ([cL loc (unLoc name)] ++ ns, flds ++ fs) where (remSeen', flds) = get_flds remSeen args (ns, fs) = go remSeen' rs - L _ (XConDecl _) -> panic "hsConDeclsBinders" + XConDecl _ -> panic "hsConDeclsBinders" get_flds :: Seen pass -> HsConDeclDetails pass -> (Seen pass, [LFieldOcc pass]) @@ -1344,7 +1370,7 @@ lhsBindsImplicits = foldBag unionNameSet (lhs_bind . unLoc) emptyNameSet lPatImplicits :: LPat GhcRn -> NameSet lPatImplicits = hs_lpat where - hs_lpat (L _ pat) = hs_pat pat + hs_lpat lpat = hs_pat (unLoc lpat) hs_lpats = foldr (\pat rest -> hs_lpat pat `unionNameSet` rest) emptyNameSet diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index da5ef8ba2d..8817b41c8a 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -1,5 +1,7 @@ {-# LANGUAGE CPP, NondecreasingIndentation, ScopedTypeVariables #-} {-# LANGUAGE TupleSections, NamedFieldPuns #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} -- ----------------------------------------------------------------------------- -- @@ -250,6 +252,10 @@ module GHC ( -- *** Deconstructing Located getLoc, unLoc, + getRealSrcSpan, unRealSrcSpan, + + -- ** HasSrcSpan + HasSrcSpan(..), SrcSpanLess, dL, cL, -- *** Combining and comparing Located values eqLocated, cmpLocated, combineLocs, addCLoc, @@ -1380,7 +1386,7 @@ getRichTokenStream mod = do addSourceToTokens :: RealSrcLoc -> StringBuffer -> [Located Token] -> [(Located Token, String)] addSourceToTokens _ _ [] = [] -addSourceToTokens loc buf (t@(L span _) : ts) +addSourceToTokens loc buf (t@(dL->L span _) : ts) = case span of UnhelpfulSpan _ -> (t,"") : addSourceToTokens loc buf ts RealSrcSpan s -> (t,str) : addSourceToTokens newLoc newBuf ts @@ -1406,7 +1412,7 @@ showRichTokenStream ts = go startLoc ts "" getFile (RealSrcSpan s : _) = srcSpanFile s startLoc = mkRealSrcLoc sourceFile 1 1 go _ [] = id - go loc ((L span _, str):ts) + go loc ((dL->L span _, str):ts) = case span of UnhelpfulSpan _ -> go loc ts RealSrcSpan s diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index 127cc6d911..3fd510bb86 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- @@ -76,23 +78,24 @@ getImports dflags buf filename source_filename = do if errorsFound dflags ms then throwIO $ mkSrcErr errs else - case rdr_module of - L _ hsmod -> - let + let hsmod = unLoc rdr_module mb_mod = hsmodName hsmod imps = hsmodImports hsmod - main_loc = srcLocSpan (mkSrcLoc (mkFastString source_filename) 1 1) - mod = mb_mod `orElse` L main_loc mAIN_NAME + main_loc = srcLocSpan (mkSrcLoc (mkFastString source_filename) + 1 1) + mod = mb_mod `orElse` cL main_loc mAIN_NAME (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps - -- GHC.Prim doesn't exist physically, so don't go looking for it. - ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc) + -- GHC.Prim doesn't exist physically, so don't go looking for it. + ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc + . ideclName . unLoc) ord_idecls implicit_prelude = xopt LangExt.ImplicitPrelude dflags implicit_imports = mkPrelImports (unLoc mod) main_loc implicit_prelude imps - convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i) + convImport (dL->L _ i) = (fmap sl_fs (ideclPkgQual i) + , ideclName i) in return (map convImport src_idecls, map convImport (implicit_imports ++ ordinary_imps), @@ -115,23 +118,23 @@ mkPrelImports this_mod loc implicit_prelude import_decls | otherwise = [preludeImportDecl] where explicit_prelude_import - = notNull [ () | L _ (ImportDecl { ideclName = mod - , ideclPkgQual = Nothing }) + = notNull [ () | (dL->L _ (ImportDecl { ideclName = mod + , ideclPkgQual = Nothing })) <- import_decls , unLoc mod == pRELUDE_NAME ] preludeImportDecl :: LImportDecl GhcPs preludeImportDecl - = L loc $ ImportDecl { ideclExt = noExt, - ideclSourceSrc = NoSourceText, - ideclName = L loc pRELUDE_NAME, - ideclPkgQual = Nothing, - ideclSource = False, - ideclSafe = False, -- Not a safe import - ideclQualified = False, - ideclImplicit = True, -- Implicit! - ideclAs = Nothing, - ideclHiding = Nothing } + = cL loc $ ImportDecl { ideclExt = noExt, + ideclSourceSrc = NoSourceText, + ideclName = cL loc pRELUDE_NAME, + ideclPkgQual = Nothing, + ideclSource = False, + ideclSafe = False, -- Not a safe import + ideclQualified = False, + ideclImplicit = True, -- Implicit! + ideclAs = Nothing, + ideclHiding = Nothing } parseError :: DynFlags -> SrcSpan -> MsgDoc -> IO a parseError dflags span err = throwOneError $ mkPlainErrMsg dflags span err @@ -185,12 +188,12 @@ lazyGetToks dflags filename handle = do -- necessarily read up to the end of the file, then the token might -- be truncated, so read some more of the file and lex it again. then getMore handle state size - else case t of - L _ ITeof -> return [t] - _other -> do rest <- lazyLexBuf handle state' eof size - return (t : rest) + else case unLoc t of + ITeof -> return [t] + _other -> do rest <- lazyLexBuf handle state' eof size + return (t : rest) _ | not eof -> getMore handle state size - | otherwise -> return [L (RealSrcSpan (last_loc state)) ITeof] + | otherwise -> return [cL (RealSrcSpan (last_loc state)) ITeof] -- parser assumes an ITeof sentinel at the end getMore :: Handle -> PState -> Int -> IO [Located Token] @@ -212,9 +215,9 @@ getToks dflags filename buf = lexAll (pragState dflags buf loc) loc = mkRealSrcLoc (mkFastString filename) 1 1 lexAll state = case unP (lexer False return) state of - POk _ t@(L _ ITeof) -> [t] + POk _ t@(dL->L _ ITeof) -> [t] POk state' t -> t : lexAll state' - _ -> [L (RealSrcSpan (last_loc state)) ITeof] + _ -> [cL (RealSrcSpan (last_loc state)) ITeof] -- | Parse OPTIONS and LANGUAGE pragmas of the source file. @@ -237,39 +240,36 @@ getOptions' :: DynFlags getOptions' dflags toks = parseToks toks where - getToken (L _loc tok) = tok - getLoc (L loc _tok) = loc - parseToks (open:close:xs) - | IToptions_prag str <- getToken open - , ITclose_prag <- getToken close + | IToptions_prag str <- unLoc open + , ITclose_prag <- unLoc close = case toArgs str of Left _err -> optionsParseError str dflags $ -- #15053 combineSrcSpans (getLoc open) (getLoc close) - Right args -> map (L (getLoc open)) args ++ parseToks xs + Right args -> map (cL (getLoc open)) args ++ parseToks xs parseToks (open:close:xs) - | ITinclude_prag str <- getToken open - , ITclose_prag <- getToken close - = map (L (getLoc open)) ["-#include",removeSpaces str] ++ + | ITinclude_prag str <- unLoc open + , ITclose_prag <- unLoc close + = map (cL (getLoc open)) ["-#include",removeSpaces str] ++ parseToks xs parseToks (open:close:xs) - | ITdocOptions str <- getToken open - , ITclose_prag <- getToken close - = map (L (getLoc open)) ["-haddock-opts", removeSpaces str] + | ITdocOptions str <- unLoc open + , ITclose_prag <- unLoc close + = map (cL (getLoc open)) ["-haddock-opts", removeSpaces str] ++ parseToks xs parseToks (open:xs) - | ITlanguage_prag <- getToken open + | ITlanguage_prag <- unLoc open = parseLanguage xs parseToks (comment:xs) -- Skip over comments - | isComment (getToken comment) + | isComment (unLoc comment) = parseToks xs parseToks _ = [] - parseLanguage (L loc (ITconid fs):rest) - = checkExtension dflags (L loc fs) : + parseLanguage ((dL->L loc (ITconid fs)):rest) + = checkExtension dflags (cL loc fs) : case rest of - (L _loc ITcomma):more -> parseLanguage more - (L _loc ITclose_prag):more -> parseToks more - (L loc _):_ -> languagePragParseError dflags loc + (dL->L _loc ITcomma):more -> parseLanguage more + (dL->L _loc ITclose_prag):more -> parseToks more + (dL->L loc _):_ -> languagePragParseError dflags loc [] -> panic "getOptions'.parseLanguage(1) went past eof token" parseLanguage (tok:_) = languagePragParseError dflags (getLoc tok) @@ -297,7 +297,7 @@ checkProcessArgsResult :: MonadIO m => DynFlags -> [Located String] -> m () checkProcessArgsResult dflags flags = when (notNull flags) $ liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags - where mkMsg (L loc flag) + where mkMsg (dL->L loc flag) = mkPlainErrMsg dflags loc $ (text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag) @@ -305,12 +305,12 @@ checkProcessArgsResult dflags flags ----------------------------------------------------------------------------- checkExtension :: DynFlags -> Located FastString -> Located String -checkExtension dflags (L l ext) +checkExtension dflags (dL->L l ext) -- Checks if a given extension is valid, and if so returns -- its corresponding flag. Otherwise it throws an exception. = let ext' = unpackFS ext in if ext' `elem` supportedLanguagesAndExtensions - then L l ("-X"++ext') + then cL l ("-X"++ext') else unsupportedExtnError dflags l ext' languagePragParseError :: DynFlags -> SrcSpan -> a @@ -333,9 +333,12 @@ unsupportedExtnError dflags loc unsup = optionsErrorMsgs :: DynFlags -> [String] -> [Located String] -> FilePath -> Messages optionsErrorMsgs dflags unhandled_flags flags_lines _filename = (emptyBag, listToBag (map mkMsg unhandled_flags_lines)) - where unhandled_flags_lines = [ L l f | f <- unhandled_flags, - L l f' <- flags_lines, f == f' ] - mkMsg (L flagSpan flag) = + where unhandled_flags_lines :: [Located String] + unhandled_flags_lines = [ cL l f + | f <- unhandled_flags + , (dL->L l f') <- flags_lines + , f == f' ] + mkMsg (dL->L flagSpan flag) = ErrUtils.mkPlainErrMsg dflags flagSpan $ text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs index 72f45346d1..44edb82c5e 100644 --- a/compiler/main/HscStats.hs +++ b/compiler/main/HscStats.hs @@ -4,7 +4,9 @@ -- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 -- -{-# LANGUAGE FlexibleContexts, TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module HscStats ( ppSourceStats ) where @@ -20,7 +22,7 @@ import Data.Char -- | Source Statistics ppSourceStats :: Bool -> Located (HsModule GhcPs) -> SDoc -ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) +ppSourceStats short (dL->L _ (HsModule _ exports imports ldecls _ _)) = (if short then hcat else vcat) (map pp_val [("ExportAll ", export_all), -- 1 if no export list @@ -82,9 +84,10 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) default_ds = count (\ x -> case x of { DefD{} -> True; _ -> False}) decls val_decls = [d | ValD _ d <- decls] - real_exports = case exports of { Nothing -> []; Just (L _ es) -> es } + real_exports = case exports of { Nothing -> []; Just (dL->L _ es) -> es } n_exports = length real_exports - export_ms = count (\ e -> case unLoc e of { IEModuleContents{} -> True;_ -> False}) + export_ms = count (\ e -> case unLoc e of { IEModuleContents{} -> True + ; _ -> False}) real_exports export_ds = n_exports - export_ms export_all = case exports of { Nothing -> 1; _ -> 0 } @@ -101,7 +104,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) (inst_method_ds, method_specs, method_inlines, inst_type_ds, inst_data_ds) = sum5 (map inst_info inst_decls) - count_bind (PatBind { pat_lhs = L _ (VarPat{}) }) = (1,0,0) + count_bind (PatBind { pat_lhs = (dL->L _ (VarPat{})) }) = (1,0,0) count_bind (PatBind {}) = (0,1,0) count_bind (FunBind {}) = (0,1,0) count_bind (PatSynBind {}) = (0,0,1) @@ -116,10 +119,13 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) sig_info (ClassOpSig {}) = (0,0,0,0,1) sig_info _ = (0,0,0,0,0) - import_info (L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual - , ideclAs = as, ideclHiding = spec })) + import_info (dL->L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual + , ideclAs = as, ideclHiding = spec })) = add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec) - import_info (L _ (XImportDecl _)) = panic "import_info" + import_info (dL->L _ (XImportDecl _)) = panic "import_info" + import_info _ = panic " import_info: Impossible Match" + -- due to #15884 + safe_info = qual_info qual_info False = 0 qual_info True = 1 @@ -129,8 +135,9 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) spec_info (Just (False, _)) = (0,0,0,0,0,1,0) spec_info (Just (True, _)) = (0,0,0,0,0,0,1) - data_info (DataDecl { tcdDataDefn = HsDataDefn { dd_cons = cs - , dd_derivs = L _ derivs}}) + data_info (DataDecl { tcdDataDefn = HsDataDefn + { dd_cons = cs + , dd_derivs = (dL->L _ derivs)}}) = ( length cs , foldl' (\s dc -> length (deriv_clause_tys $ unLoc dc) + s) 0 derivs ) diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index bb89c58344..d57d69bda6 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -6,6 +6,7 @@ {-# LANGUAGE CPP, ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} -- | Types for the per-module compiler module HscTypes ( @@ -344,7 +345,7 @@ handleFlagWarnings dflags warns = do -- It would be nicer if warns :: [Located MsgDoc], but that -- has circular import problems. bag = listToBag [ mkPlainWarnMsg dflags loc (text warn) - | Warn _ (L loc warn) <- warns' ] + | Warn _ (dL->L loc warn) <- warns' ] printOrThrowWarnings dflags bag diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 9597f10b0a..a75566ea39 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -48,7 +48,7 @@ module Lexer ( Token(..), lexer, pragState, mkPState, mkPStatePure, PState(..), - P(..), ParseResult(..), mkParserFlags, ParserFlags(..), getSrcLoc, + P(..), ParseResult(..), mkParserFlags, ParserFlags(..), getRealSrcLoc, getPState, extopt, withThisPackage, failLocMsgP, failSpanMsgP, srcParseFail, getMessages, @@ -1155,7 +1155,7 @@ parseNestedPragma input@(AI _ buf) = do setExts (.&. complement (xbit InNestedCommentBit)) postInput@(AI _ postBuf) <- getInput setInput origInput - case unLoc lt of + case unRealSrcSpan lt of ITcomment_line_prag -> do let bytes = byteDiff buf postBuf diff = lexemeToString buf bytes @@ -1570,9 +1570,9 @@ alrInitialLoc file = mkRealSrcSpan loc loc lex_string_prag :: (String -> Token) -> Action lex_string_prag mkTok span _buf _len = do input <- getInput - start <- getSrcLoc + start <- getRealSrcLoc tok <- go [] input - end <- getSrcLoc + end <- getRealSrcLoc return (L (mkRealSrcSpan start end) tok) where go acc input = if isString input "#-}" @@ -1844,9 +1844,9 @@ getCharOrFail i = do lex_qquasiquote_tok :: Action lex_qquasiquote_tok span buf len = do let (qual, quoter) = splitQualName (stepOn buf) (len - 2) False - quoteStart <- getSrcLoc + quoteStart <- getRealSrcLoc quote <- lex_quasiquote quoteStart "" - end <- getSrcLoc + end <- getRealSrcLoc return (L (mkRealSrcSpan (realSrcSpanStart span) end) (ITqQuasiQuote (qual, quoter, @@ -1858,9 +1858,9 @@ lex_quasiquote_tok span buf len = do let quoter = tail (lexemeToString buf (len - 1)) -- 'tail' drops the initial '[', -- while the -1 drops the trailing '|' - quoteStart <- getSrcLoc + quoteStart <- getRealSrcLoc quote <- lex_quasiquote quoteStart "" - end <- getSrcLoc + end <- getRealSrcLoc return (L (mkRealSrcSpan (realSrcSpanStart span) end) (ITquasiQuote (mkFastString quoter, mkFastString (reverse quote), @@ -2074,8 +2074,8 @@ setExts f = P $ \s -> POk s { setSrcLoc :: RealSrcLoc -> P () setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} () -getSrcLoc :: P RealSrcLoc -getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc +getRealSrcLoc :: P RealSrcLoc +getRealSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc addSrcFile :: FastString -> P () addSrcFile f = P $ \s -> POk s{ srcfiles = f : srcfiles s } () @@ -2626,7 +2626,7 @@ srcParseFail = P $ \s@PState{ buffer = buf, options = o, last_len = len, -- not over a token range. lexError :: String -> P a lexError str = do - loc <- getSrcLoc + loc <- getRealSrcLoc (AI end buf) <- getInput reportLexError loc end buf str @@ -2664,8 +2664,8 @@ lexTokenAlr = do mPending <- popPendingImplicitToken alternativeLayoutRuleToken t Just t -> return t - setAlrLastLoc (getLoc t) - case unLoc t of + setAlrLastLoc (getRealSrcSpan t) + case unRealSrcSpan t of ITwhere -> setAlrExpectingOCurly (Just ALRLayoutWhere) ITlet -> setAlrExpectingOCurly (Just ALRLayoutLet) ITof -> setAlrExpectingOCurly (Just ALRLayoutOf) @@ -2684,10 +2684,10 @@ alternativeLayoutRuleToken t transitional <- getALRTransitional justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock setJustClosedExplicitLetBlock False - let thisLoc = getLoc t + let thisLoc = getRealSrcSpan t thisCol = srcSpanStartCol thisLoc newLine = srcSpanStartLine thisLoc > srcSpanEndLine lastLoc - case (unLoc t, context, mExpectingOCurly) of + case (unRealSrcSpan t, context, mExpectingOCurly) of -- This case handles a GHC extension to the original H98 -- layout rule... (ITocurly, _, Just alrLayout) -> @@ -2895,7 +2895,7 @@ lexToken = do let bytes = byteDiff buf buf2 span `seq` setLastToken span bytes lt <- t span buf bytes - case unLoc lt of + case unRealSrcSpan lt of ITlineComment _ -> return lt ITblockComment _ -> return lt lt' -> do diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index f5082174ab..cd41da53eb 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -9,6 +9,9 @@ -- --------------------------------------------------------------------------- { +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} + -- | This module provides the generated Happy parser for Haskell. It exports -- a number of parsers which may be used in any library that uses the GHC API. -- A common usage pattern is to initialize the parser state with a given string @@ -747,7 +750,7 @@ unitdecl :: { LHsUnitDecl PackageName } signature :: { Located (HsModule GhcPs) } : maybedocheader 'signature' modid maybemodwarning maybeexports 'where' body {% fileSrcSpan >>= \ loc -> - ams (L loc (HsModule (Just $3) $5 (fst $ snd $7) + ams (cL loc (HsModule (Just $3) $5 (fst $ snd $7) (snd $ snd $7) $4 $1) ) ([mj AnnSignature $2, mj AnnWhere $6] ++ fst $7) } @@ -755,13 +758,13 @@ signature :: { Located (HsModule GhcPs) } module :: { Located (HsModule GhcPs) } : maybedocheader 'module' modid maybemodwarning maybeexports 'where' body {% fileSrcSpan >>= \ loc -> - ams (L loc (HsModule (Just $3) $5 (fst $ snd $7) + ams (cL loc (HsModule (Just $3) $5 (fst $ snd $7) (snd $ snd $7) $4 $1) ) ([mj AnnModule $2, mj AnnWhere $6] ++ fst $7) } | body2 {% fileSrcSpan >>= \ loc -> - ams (L loc (HsModule Nothing Nothing + ams (cL loc (HsModule Nothing Nothing (fst $ snd $1) (snd $ snd $1) Nothing Nothing)) (fst $1) } @@ -812,15 +815,15 @@ top1 :: { ([LImportDecl GhcPs], [LHsDecl GhcPs]) } header :: { Located (HsModule GhcPs) } : maybedocheader 'module' modid maybemodwarning maybeexports 'where' header_body {% fileSrcSpan >>= \ loc -> - ams (L loc (HsModule (Just $3) $5 $7 [] $4 $1 + ams (cL loc (HsModule (Just $3) $5 $7 [] $4 $1 )) [mj AnnModule $2,mj AnnWhere $6] } | maybedocheader 'signature' modid maybemodwarning maybeexports 'where' header_body {% fileSrcSpan >>= \ loc -> - ams (L loc (HsModule (Just $3) $5 $7 [] $4 $1 + ams (cL loc (HsModule (Just $3) $5 $7 [] $4 $1 )) [mj AnnModule $2,mj AnnWhere $6] } | header_body2 {% fileSrcSpan >>= \ loc -> - return (L loc (HsModule Nothing Nothing $1 [] Nothing + return (cL loc (HsModule Nothing Nothing $1 [] Nothing Nothing)) } header_body :: { [LImportDecl GhcPs] } @@ -842,7 +845,7 @@ header_top_importdecls :: { [LImportDecl GhcPs] } -- The Export List maybeexports :: { (Maybe (Located [LIE GhcPs])) } - : '(' exportlist ')' {% ams (sLL $1 $> ()) [mop $1,mcp $3] >> + : '(' exportlist ')' {% amsL (comb2 $1 $>) [mop $1,mcp $3] >> return (Just (sLL $1 $> (fromOL $2))) } | {- empty -} { Nothing } @@ -892,7 +895,7 @@ qcnames :: { ([AddAnn], [Located ImpExpQcSpec]) } qcnames1 :: { ([AddAnn], [Located ImpExpQcSpec]) } -- A reversed list : qcnames1 ',' qcname_ext_w_wildcard {% case (head (snd $1)) of - l@(L _ ImpExpQcWildcard) -> + l@(dL->L _ ImpExpQcWildcard) -> return ([mj AnnComma $2, mj AnnDotdot l] ,(snd (unLoc $3) : snd $1)) l -> (ams (head (snd $1)) [mj AnnComma $2] >> @@ -952,7 +955,7 @@ importdecls_semi importdecl :: { LImportDecl GhcPs } : 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec - {% ams (L (comb4 $1 $6 (snd $7) $8) $ + {% ams (cL (comb4 $1 $6 (snd $7) $8) $ ImportDecl { ideclExt = noExt , ideclSourceSrc = snd $ fst $2 , ideclName = $6, ideclPkgQual = snd $5 @@ -995,7 +998,7 @@ maybeimpspec :: { Located (Maybe (Bool, Located [LIE GhcPs])) } : impspec {% let (b, ie) = unLoc $1 in checkImportSpec ie >>= \checkedIe -> - return (L (gl $1) (Just (b, checkedIe))) } + return (cL (gl $1) (Just (b, checkedIe))) } | {- empty -} { noLoc Nothing } impspec :: { Located (Bool, Located [LIE GhcPs]) } @@ -1129,7 +1132,7 @@ inst_decl :: { LInstDecl GhcPs } , cid_tyfam_insts = ats , cid_overlap_mode = $2 , cid_datafam_insts = adts } - ; ams (L (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_d_ext = noExt, cid_inst = cid })) + ; ams (cL (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_d_ext = noExt, cid_inst = cid })) (mj AnnInstance $1 : (fst $ unLoc $4)) } } -- type instance declarations @@ -1216,24 +1219,24 @@ where_type_family :: { Located ([AddAnn],FamilyInfo GhcPs) } 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 - L loc ([],Just (unLoc $2)) } + | vocurly ty_fam_inst_eqns close { let (dL->L loc _) = $2 in + cL loc ([],Just (unLoc $2)) } | '{' '..' '}' { sLL $1 $> ([moc $1,mj AnnDotdot $2 ,mcc $3],Nothing) } - | vocurly '..' close { let L loc _ = $2 in - L loc ([mj AnnDotdot $2],Nothing) } + | vocurly '..' close { let (dL->L loc _) = $2 in + cL loc ([mj AnnDotdot $2],Nothing) } ty_fam_inst_eqns :: { Located [LTyFamInstEqn GhcPs] } : ty_fam_inst_eqns ';' ty_fam_inst_eqn - {% let L loc (anns, eqn) = $3 in - asl (unLoc $1) $2 (L loc eqn) + {% let (dL->L loc (anns, eqn)) = $3 in + asl (unLoc $1) $2 (cL loc eqn) >> ams $3 anns - >> return (sLL $1 $> (L loc eqn : unLoc $1)) } + >> return (sLL $1 $> (cL loc eqn : unLoc $1)) } | ty_fam_inst_eqns ';' {% addAnnotation (gl $1) AnnSemi (gl $2) >> return (sLL $1 $> (unLoc $1)) } - | ty_fam_inst_eqn {% let L loc (anns, eqn) = $1 in + | ty_fam_inst_eqn {% let (dL->L loc (anns, eqn)) = $1 in ams $1 anns - >> return (sLL $1 $> [L loc eqn]) } + >> return (sLL $1 $> [cL loc eqn]) } | {- empty -} { noLoc [] } ty_fam_inst_eqn :: { Located ([AddAnn],TyFamInstEqn GhcPs) } @@ -1485,7 +1488,7 @@ where_decls :: { Located ([AddAnn] , 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)) + | 'where' vocurly decls close { cL (comb2 $1 $3) ((mj AnnWhere $1:(fst $ unLoc $3)) ,sL1 $3 (snd $ unLoc $3)) } pattern_synonym_sig :: { LSig GhcPs } @@ -1568,7 +1571,7 @@ decllist_inst :: { Located ([AddAnn] , 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) } + | vocurly decls_inst close { cL (gl $2) (unLoc $2) } -- Instance body -- @@ -1604,7 +1607,7 @@ decls :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) } 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) } + | vocurly decls close { cL (gl $2) (fst $ unLoc $2,sL1 $2 $ snd $ unLoc $2) } -- Binding groups other than those of class and instance declarations -- @@ -1618,7 +1621,7 @@ binds :: { Located ([AddAnn],Located (HsLocalBinds GhcPs)) } | '{' dbinds '}' { sLL $1 $> ([moc $1,mcc $3] ,sL1 $2 $ HsIPBinds noExt (IPBinds noExt (reverse $ unLoc $2))) } - | vocurly dbinds close { L (getLoc $2) ([] + | vocurly dbinds close { cL (getLoc $2) ([] ,sL1 $2 $ HsIPBinds noExt (IPBinds noExt (reverse $ unLoc $2))) } @@ -1644,7 +1647,7 @@ rules :: { OrdList (LRuleDecl GhcPs) } rule :: { LRuleDecl GhcPs } : STRING rule_activation rule_foralls infixexp '=' exp {%ams (sLL $1 $> $ HsRule { rd_ext = noExt - , rd_name = L (gl $1) (getSTRINGs $1, getSTRING $1) + , rd_name = cL (gl $1) (getSTRINGs $1, getSTRING $1) , rd_act = (snd $2) `orElse` AlwaysActive , rd_tyvs = sndOf3 $3, rd_tmvs = thdOf3 $3 , rd_lhs = $4, rd_rhs = $6 }) @@ -1739,14 +1742,14 @@ deprecation :: { OrdList (LWarnDecl GhcPs) } (fst $ unLoc $2) } strings :: { Located ([AddAnn],[Located StringLiteral]) } - : STRING { sL1 $1 ([],[L (gl $1) (getStringLiteral $1)]) } + : STRING { sL1 $1 ([],[cL (gl $1) (getStringLiteral $1)]) } | '[' stringlist ']' { sLL $1 $> $ ([mos $1,mcs $3],fromOL (unLoc $2)) } stringlist :: { Located (OrdList (Located StringLiteral)) } : stringlist ',' STRING {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >> return (sLL $1 $> (unLoc $1 `snocOL` - (L (gl $3) (getStringLiteral $3)))) } - | STRING { sLL $1 $> (unitOL (L (gl $1) (getStringLiteral $1))) } + (cL (gl $3) (getStringLiteral $3)))) } + | STRING { sLL $1 $> (unitOL (cL (gl $1) (getStringLiteral $1))) } | {- empty -} { noLoc nilOL } ----------------------------------------------------------------------------- @@ -1797,7 +1800,7 @@ safety :: { Located Safety } fspec :: { Located ([AddAnn] ,(Located StringLiteral, Located RdrName, LHsSigType GhcPs)) } : STRING var '::' sigtypedoc { sLL $1 $> ([mu AnnDcolon $3] - ,(L (getLoc $1) + ,(cL (getLoc $1) (getStringLiteral $1), $2, mkLHsSigType $4)) } | var '::' sigtypedoc { sLL $1 $> ([mu AnnDcolon $2] ,(noLoc (StringLiteral NoSourceText nilFS), $1, mkLHsSigType $3)) } @@ -1953,13 +1956,13 @@ typedoc :: { LHsType GhcPs } [mu AnnRarrow $2] } | btype docprev '->' ctypedoc {% ams $1 [mu AnnRarrow $3] -- See note [GADT decl discards annotations] >> ams (sLL $1 $> $ - HsFunTy noExt (L (comb2 $1 $2) + HsFunTy noExt (cL (comb2 $1 $2) (HsDocTy noExt $1 $2)) $4) [mu AnnRarrow $3] } | docnext btype '->' ctypedoc {% ams $2 [mu AnnRarrow $3] -- See note [GADT decl discards annotations] >> ams (sLL $1 $> $ - HsFunTy noExt (L (comb2 $1 $2) + HsFunTy noExt (cL (comb2 $1 $2) (HsDocTy noExt $2 $1)) $4) [mu AnnRarrow $3] } @@ -2102,7 +2105,7 @@ fds1 :: { Located [Located (FunDep (Located RdrName))] } | fd { sL1 $1 [$1] } fd :: { Located (FunDep (Located RdrName)) } - : varids0 '->' varids0 {% ams (L (comb3 $1 $2 $3) + : varids0 '->' varids0 {% ams (cL (comb3 $1 $2 $3) (reverse (unLoc $1), reverse (unLoc $3))) [mu AnnRarrow $2] } @@ -2145,13 +2148,13 @@ gadt_constrlist :: { Located ([AddAnn] ,[LConDecl GhcPs]) } -- Returned in order : 'where' '{' gadt_constrs '}' {% checkEmptyGADTs $ - L (comb2 $1 $3) + cL (comb2 $1 $3) ([mj AnnWhere $1 ,moc $2 ,mcc $4] , unLoc $3) } | 'where' vocurly gadt_constrs close {% checkEmptyGADTs $ - L (comb2 $1 $3) + cL (comb2 $1 $3) ([mj AnnWhere $1] , unLoc $3) } | {- empty -} { noLoc ([],[]) } @@ -2159,8 +2162,8 @@ gadt_constrlist :: { Located ([AddAnn] 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)) } - | gadt_constr_with_doc { L (gl $1) [$1] } + >> return (cL (comb2 $1 $3) ($1 : unLoc $3)) } + | gadt_constr_with_doc { cL (gl $1) [$1] } | {- empty -} { noLoc [] } -- We allow the following forms: @@ -2197,7 +2200,7 @@ allowed in usual data constructors, but not in GADTs). -} constrs :: { Located ([AddAnn],[LConDecl GhcPs]) } - : maybe_docnext '=' constrs1 { L (comb2 $2 $3) ([mj AnnEqual $2] + : maybe_docnext '=' constrs1 { cL (comb2 $2 $3) ([mj AnnEqual $2] ,addConDocs (unLoc $3) $1)} constrs1 :: { Located [LConDecl GhcPs] } @@ -2261,7 +2264,7 @@ They must be kept identical except for their treatment of 'docprev'. constr :: { LConDecl GhcPs } : maybe_docnext forall constr_context '=>' constr_stuff {% ams (let (con,details,doc_prev) = unLoc $5 in - addConDoc (L (comb4 $2 $3 $4 $5) (mkConDeclH98 con + addConDoc (cL (comb4 $2 $3 $4 $5) (mkConDeclH98 con (snd $ unLoc $2) (Just $3) details)) @@ -2269,7 +2272,7 @@ constr :: { LConDecl GhcPs } (mu AnnDarrow $4:(fst $ unLoc $2)) } | maybe_docnext forall constr_stuff {% ams ( let (con,details,doc_prev) = unLoc $3 in - addConDoc (L (comb2 $2 $3) (mkConDeclH98 con + addConDoc (cL (comb2 $2 $3) (mkConDeclH98 con (snd $ unLoc $2) Nothing -- No context details)) @@ -2297,8 +2300,8 @@ fielddecls1 :: { [LConDeclField GhcPs] } fielddecl :: { LConDeclField GhcPs } -- A list because of f,g :: Int : maybe_docnext sig_vars '::' ctype maybe_docprev - {% ams (L (comb2 $2 $4) - (ConDeclField noExt (reverse (map (\ln@(L l n) -> L l $ FieldOcc noExt ln) (unLoc $2))) $4 ($1 `mplus` $5))) + {% ams (cL (comb2 $2 $4) + (ConDeclField noExt (reverse (map (\ln@(dL->L l n) -> cL l $ FieldOcc noExt ln) (unLoc $2))) $4 ($1 `mplus` $5))) [mu AnnDcolon $3] } -- Reversed! @@ -2316,17 +2319,17 @@ derivings :: { HsDeriving GhcPs } deriving :: { LHsDerivingClause GhcPs } : 'deriving' deriv_clause_types {% let { full_loc = comb2 $1 $> } - in ams (L full_loc $ HsDerivingClause noExt Nothing $2) + in ams (cL full_loc $ HsDerivingClause noExt Nothing $2) [mj AnnDeriving $1] } | 'deriving' deriv_strategy_no_via deriv_clause_types {% let { full_loc = comb2 $1 $> } - in ams (L full_loc $ HsDerivingClause noExt (Just $2) $3) + in ams (cL full_loc $ HsDerivingClause noExt (Just $2) $3) [mj AnnDeriving $1] } | 'deriving' deriv_clause_types deriv_strategy_via {% let { full_loc = comb2 $1 $> } - in ams (L full_loc $ HsDerivingClause noExt (Just $3) $2) + in ams (cL full_loc $ HsDerivingClause noExt (Just $3) $2) [mj AnnDeriving $1] } deriv_clause_types :: { Located [LHsSigType GhcPs] } @@ -2384,11 +2387,11 @@ decl_no_th :: { LHsDecl GhcPs } -- [FunBind vs PatBind] case r of { (FunBind _ n _ _ _) -> - ams (L l ()) [mj AnnFunId n] >> return () ; - (PatBind _ (L lh _lhs) _rhs _) -> - ams (L lh ()) [] >> return () } ; + amsL l [mj AnnFunId n] >> return () ; + (PatBind _ (dL->L l _) _rhs _) -> + amsL l [] >> return () } ; - _ <- ams (L l ()) (ann ++ fst (unLoc $3) ++ [mj AnnBang $1]) ; + _ <- amsL l (ann ++ fst (unLoc $3) ++ [mj AnnBang $1]) ; return $! (sL l $ ValD noExt r) } } | infixexp_top opt_sig rhs {% do { (ann,r) <- checkValDef empty NoSrcStrict $1 (snd $2) $3; @@ -2398,10 +2401,10 @@ decl_no_th :: { LHsDecl GhcPs } -- [FunBind vs PatBind] case r of { (FunBind _ n _ _ _) -> - ams (L l ()) (mj AnnFunId n:(fst $2)) >> return () ; - (PatBind _ (L lh _lhs) _rhs _) -> - ams (L lh ()) (fst $2) >> return () } ; - _ <- ams (L l ()) (ann ++ (fst $ unLoc $3)); + amsL l (mj AnnFunId n:(fst $2)) >> return () ; + (PatBind _ (dL->L lh _lhs) _rhs _) -> + amsL lh (fst $2) >> return () } ; + _ <- amsL l (ann ++ (fst $ unLoc $3)); return $! (sL l $ ValD noExt r) } } | pattern_synonym_decl { $1 } | docdecl { $1 } @@ -2435,10 +2438,10 @@ sigdecl :: { LHsDecl GhcPs } : -- See Note [Declaration/signature overlap] for why we need infixexp here infixexp_top '::' sigtypedoc - {% do v <- checkValSigLhs $1 - ; _ <- ams (sLL $1 $> ()) [mu AnnDcolon $2] - ; return (sLL $1 $> $ SigD noExt $ - TypeSig noExt [v] (mkLHsSigWcType $3)) } + {% do { v <- checkValSigLhs $1 + ; _ <- amsL (comb2 $1 $>) [mu AnnDcolon $2] + ; return (sLL $1 $> $ SigD noExt $ + TypeSig noExt [v] (mkLHsSigWcType $3))} } | var ',' sig_vars '::' sigtypedoc {% do { let sig = TypeSig noExt ($1 : reverse (unLoc $3)) @@ -2664,15 +2667,15 @@ aexp :: { LHsExpr GhcPs } ams (sLL $1 $> $ HsMultiIf noExt (reverse $ snd $ unLoc $2)) (mj AnnIf $1:(fst $ unLoc $2)) } - | 'case' exp 'of' altslist {% ams (L (comb3 $1 $3 $4) $ + | 'case' exp 'of' altslist {% ams (cL (comb3 $1 $3 $4) $ HsCase noExt $2 (mkMatchGroup FromSource (snd $ unLoc $4))) (mj AnnCase $1:mj AnnOf $3 :(fst $ unLoc $4)) } - | 'do' stmtlist {% ams (L (comb2 $1 $2) + | 'do' stmtlist {% ams (cL (comb2 $1 $2) (mkHsDo DoExpr (snd $ unLoc $2))) (mj AnnDo $1:(fst $ unLoc $2)) } - | 'mdo' stmtlist {% ams (L (comb2 $1 $2) + | 'mdo' stmtlist {% ams (cL (comb2 $1 $2) (mkHsDo MDoExpr (snd $ unLoc $2))) (mj AnnMdo $1:(fst $ unLoc $2)) } | 'proc' aexp '->' exp @@ -2687,7 +2690,7 @@ aexp :: { LHsExpr GhcPs } aexp1 :: { LHsExpr GhcPs } : aexp1 '{' fbinds '}' {% do { r <- mkRecConstrOrUpdate $1 (comb2 $2 $4) (snd $3) - ; _ <- ams (sLL $1 $> ()) (moc $2:mcc $4:(fst $3)) + ; _ <- amsL (comb2 $1 $>) (moc $2:mcc $4:(fst $3)) ; checkRecordSyntax (sLL $1 $> r) }} | aexp2 { $1 } @@ -2712,7 +2715,7 @@ aexp2 :: { LHsExpr GhcPs } | '(' tup_exprs ')' {% do { e <- mkSumOrTuple Boxed (comb2 $1 $3) (snd $2) ; ams (sLL $1 $> e) ((mop $1:fst $2) ++ [mcp $3]) } } - | '(#' texp '#)' {% ams (sLL $1 $> (ExplicitTuple noExt [L (gl $2) + | '(#' texp '#)' {% ams (sLL $1 $> (ExplicitTuple noExt [cL (gl $2) (Present noExt $2)] Unboxed)) [mo $1,mc $3] } | '(#' tup_exprs '#)' {% do { e <- mkSumOrTuple Unboxed (comb2 $1 $3) (snd $2) @@ -2815,7 +2818,7 @@ tup_exprs :: { ([AddAnn],SumOrTuple) } | commas tup_tail {% do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (fst $1) ; return - ([],Tuple (map (\l -> L l missingTupArg) (fst $1) ++ $2)) } } + ([],Tuple (map (\l -> cL l missingTupArg) (fst $1) ++ $2)) } } | bars texp bars0 { (mvbars (fst $1) ++ mvbars (fst $3), Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2) } @@ -2826,13 +2829,13 @@ commas_tup_tail : commas tup_tail {% do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (tail $ fst $1) ; return ( (head $ fst $1 - ,(map (\l -> L l missingTupArg) (tail $ fst $1)) ++ $2)) } } + ,(map (\l -> cL l missingTupArg) (tail $ fst $1)) ++ $2)) } } -- Always follows a comma tup_tail :: { [LHsTupArg GhcPs] } : texp commas_tup_tail {% addAnnotation (gl $1) AnnComma (fst $2) >> - return ((L (gl $1) (Present noExt $1)) : snd $2) } - | texp { [L (gl $1) (Present noExt $1)] } + return ((cL (gl $1) (Present noExt $1)) : snd $2) } + | texp { [cL (gl $1) (Present noExt $1)] } | {- empty -} { [noLoc missingTupArg] } ----------------------------------------------------------------------------- @@ -2886,19 +2889,19 @@ 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 { cL (getLoc $1) [reverse (unLoc $1)] } 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) >> - ams (sLL $1 $> ()) (fst $ unLoc $3) >> + amsL (comb2 $1 $>) (fst $ unLoc $3) >> return (sLL $1 $> [sLL $1 $> ((snd $ unLoc $3) (reverse (unLoc $1)))]) } | squals ',' qual {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >> return (sLL $1 $> ($3 : unLoc $1)) } | transformqual {% ams $1 (fst $ unLoc $1) >> - return (sLL $1 $> [L (getLoc $1) ((snd $ unLoc $1) [])]) } + return (sLL $1 $> [cL (getLoc $1) ((snd $ unLoc $1) [])]) } | qual { sL1 $1 [$1] } -- | transformquals1 ',' '{|' pquals '|}' { sLL $1 $> ($4 : unLoc $1) } -- | '{|' pquals '|}' { sL1 $1 [$2] } @@ -2927,7 +2930,7 @@ transformqual :: { Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs -- Guards guardquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } - : guardquals1 { L (getLoc $1) (reverse (unLoc $1)) } + : guardquals1 { cL (getLoc $1) (reverse (unLoc $1)) } guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } : guardquals1 ',' qual {% addAnnotation (gl $ head $ unLoc $1) AnnComma @@ -2941,7 +2944,7 @@ guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } 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 + | vocurly alts close { cL (getLoc $2) (fst $ unLoc $2 ,(reverse (snd $ unLoc $2))) } | '{' '}' { sLL $1 $> ([moc $1,mcc $2],[]) } | vocurly close { noLoc ([],[]) } @@ -3033,7 +3036,7 @@ apats :: { [LPat GhcPs] } 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 + | vocurly stmts close { cL (gl $2) (fst $ unLoc $2 ,reverse $ snd $ unLoc $2) } -- do { ;; s ; s ; ; s ;; } @@ -3254,11 +3257,14 @@ oqtycon_no_varcon :: { Located RdrName } -- Type constructor which cannot be mi -- for variable constructor in export lists -- see Note [Type constructors in export list] : qtycon { $1 } - | '(' QCONSYM ')' {% let name = sL1 $2 $! mkQual tcClsName (getQCONSYM $2) + | '(' QCONSYM ')' {% let { name :: Located RdrName + ; name = sL1 $2 $! mkQual tcClsName (getQCONSYM $2) } in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] } - | '(' CONSYM ')' {% let name = sL1 $2 $! mkUnqual tcClsName (getCONSYM $2) + | '(' CONSYM ')' {% let { name :: Located RdrName + ; name = sL1 $2 $! mkUnqual tcClsName (getCONSYM $2) } in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] } - | '(' ':' ')' {% let name = sL1 $2 $! consDataCon_RDR + | '(' ':' ')' {% let { name :: Located RdrName + ; name = sL1 $2 $! consDataCon_RDR } in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] } | '(' '~' ')' {% ams (sLL $1 $> $ eqTyCon_RDR) [mop $1,mj AnnTilde $2,mcp $3] } @@ -3572,89 +3578,89 @@ maybe_docnext :: { Maybe LHsDocString } happyError :: P a happyError = srcParseFail -getVARID (L _ (ITvarid x)) = x -getCONID (L _ (ITconid x)) = x -getVARSYM (L _ (ITvarsym x)) = x -getCONSYM (L _ (ITconsym x)) = x -getQVARID (L _ (ITqvarid x)) = x -getQCONID (L _ (ITqconid x)) = x -getQVARSYM (L _ (ITqvarsym x)) = x -getQCONSYM (L _ (ITqconsym x)) = x -getIPDUPVARID (L _ (ITdupipvarid x)) = x -getLABELVARID (L _ (ITlabelvarid x)) = x -getCHAR (L _ (ITchar _ x)) = x -getSTRING (L _ (ITstring _ x)) = x -getINTEGER (L _ (ITinteger x)) = x -getRATIONAL (L _ (ITrational x)) = x -getPRIMCHAR (L _ (ITprimchar _ x)) = x -getPRIMSTRING (L _ (ITprimstring _ x)) = x -getPRIMINTEGER (L _ (ITprimint _ x)) = x -getPRIMWORD (L _ (ITprimword _ x)) = x -getPRIMFLOAT (L _ (ITprimfloat x)) = x -getPRIMDOUBLE (L _ (ITprimdouble x)) = x -getTH_ID_SPLICE (L _ (ITidEscape x)) = x -getTH_ID_TY_SPLICE (L _ (ITidTyEscape x)) = x -getINLINE (L _ (ITinline_prag _ inl conl)) = (inl,conl) -getSPEC_INLINE (L _ (ITspec_inline_prag _ True)) = (Inline, FunLike) -getSPEC_INLINE (L _ (ITspec_inline_prag _ False)) = (NoInline,FunLike) -getCOMPLETE_PRAGs (L _ (ITcomplete_prag x)) = x - -getDOCNEXT (L _ (ITdocCommentNext x)) = x -getDOCPREV (L _ (ITdocCommentPrev x)) = x -getDOCNAMED (L _ (ITdocCommentNamed x)) = x -getDOCSECTION (L _ (ITdocSection n x)) = (n, x) - -getINTEGERs (L _ (ITinteger (IL src _ _))) = src -getCHARs (L _ (ITchar src _)) = src -getSTRINGs (L _ (ITstring src _)) = src -getPRIMCHARs (L _ (ITprimchar src _)) = src -getPRIMSTRINGs (L _ (ITprimstring src _)) = src -getPRIMINTEGERs (L _ (ITprimint src _)) = src -getPRIMWORDs (L _ (ITprimword src _)) = src +getVARID (dL->L _ (ITvarid x)) = x +getCONID (dL->L _ (ITconid x)) = x +getVARSYM (dL->L _ (ITvarsym x)) = x +getCONSYM (dL->L _ (ITconsym x)) = x +getQVARID (dL->L _ (ITqvarid x)) = x +getQCONID (dL->L _ (ITqconid x)) = x +getQVARSYM (dL->L _ (ITqvarsym x)) = x +getQCONSYM (dL->L _ (ITqconsym x)) = x +getIPDUPVARID (dL->L _ (ITdupipvarid x)) = x +getLABELVARID (dL->L _ (ITlabelvarid x)) = x +getCHAR (dL->L _ (ITchar _ x)) = x +getSTRING (dL->L _ (ITstring _ x)) = x +getINTEGER (dL->L _ (ITinteger x)) = x +getRATIONAL (dL->L _ (ITrational x)) = x +getPRIMCHAR (dL->L _ (ITprimchar _ x)) = x +getPRIMSTRING (dL->L _ (ITprimstring _ x)) = x +getPRIMINTEGER (dL->L _ (ITprimint _ x)) = x +getPRIMWORD (dL->L _ (ITprimword _ x)) = x +getPRIMFLOAT (dL->L _ (ITprimfloat x)) = x +getPRIMDOUBLE (dL->L _ (ITprimdouble x)) = x +getTH_ID_SPLICE (dL->L _ (ITidEscape x)) = x +getTH_ID_TY_SPLICE (dL->L _ (ITidTyEscape x)) = x +getINLINE (dL->L _ (ITinline_prag _ inl conl)) = (inl,conl) +getSPEC_INLINE (dL->L _ (ITspec_inline_prag _ True)) = (Inline, FunLike) +getSPEC_INLINE (dL->L _ (ITspec_inline_prag _ False)) = (NoInline,FunLike) +getCOMPLETE_PRAGs (dL->L _ (ITcomplete_prag x)) = x + +getDOCNEXT (dL->L _ (ITdocCommentNext x)) = x +getDOCPREV (dL->L _ (ITdocCommentPrev x)) = x +getDOCNAMED (dL->L _ (ITdocCommentNamed x)) = x +getDOCSECTION (dL->L _ (ITdocSection n x)) = (n, x) + +getINTEGERs (dL->L _ (ITinteger (IL src _ _))) = src +getCHARs (dL->L _ (ITchar src _)) = src +getSTRINGs (dL->L _ (ITstring src _)) = src +getPRIMCHARs (dL->L _ (ITprimchar src _)) = src +getPRIMSTRINGs (dL->L _ (ITprimstring src _)) = src +getPRIMINTEGERs (dL->L _ (ITprimint src _)) = src +getPRIMWORDs (dL->L _ (ITprimword src _)) = src -- See Note [Pragma source text] in BasicTypes for the following -getINLINE_PRAGs (L _ (ITinline_prag src _ _)) = src -getSPEC_PRAGs (L _ (ITspec_prag src)) = src -getSPEC_INLINE_PRAGs (L _ (ITspec_inline_prag src _)) = src -getSOURCE_PRAGs (L _ (ITsource_prag src)) = src -getRULES_PRAGs (L _ (ITrules_prag src)) = src -getWARNING_PRAGs (L _ (ITwarning_prag src)) = src -getDEPRECATED_PRAGs (L _ (ITdeprecated_prag src)) = src -getSCC_PRAGs (L _ (ITscc_prag src)) = src -getGENERATED_PRAGs (L _ (ITgenerated_prag src)) = src -getCORE_PRAGs (L _ (ITcore_prag src)) = src -getUNPACK_PRAGs (L _ (ITunpack_prag src)) = src -getNOUNPACK_PRAGs (L _ (ITnounpack_prag src)) = src -getANN_PRAGs (L _ (ITann_prag src)) = src -getMINIMAL_PRAGs (L _ (ITminimal_prag src)) = src -getOVERLAPPABLE_PRAGs (L _ (IToverlappable_prag src)) = src -getOVERLAPPING_PRAGs (L _ (IToverlapping_prag src)) = src -getOVERLAPS_PRAGs (L _ (IToverlaps_prag src)) = src -getINCOHERENT_PRAGs (L _ (ITincoherent_prag src)) = src -getCTYPEs (L _ (ITctype src)) = src +getINLINE_PRAGs (dL->L _ (ITinline_prag src _ _)) = src +getSPEC_PRAGs (dL->L _ (ITspec_prag src)) = src +getSPEC_INLINE_PRAGs (dL->L _ (ITspec_inline_prag src _)) = src +getSOURCE_PRAGs (dL->L _ (ITsource_prag src)) = src +getRULES_PRAGs (dL->L _ (ITrules_prag src)) = src +getWARNING_PRAGs (dL->L _ (ITwarning_prag src)) = src +getDEPRECATED_PRAGs (dL->L _ (ITdeprecated_prag src)) = src +getSCC_PRAGs (dL->L _ (ITscc_prag src)) = src +getGENERATED_PRAGs (dL->L _ (ITgenerated_prag src)) = src +getCORE_PRAGs (dL->L _ (ITcore_prag src)) = src +getUNPACK_PRAGs (dL->L _ (ITunpack_prag src)) = src +getNOUNPACK_PRAGs (dL->L _ (ITnounpack_prag src)) = src +getANN_PRAGs (dL->L _ (ITann_prag src)) = src +getMINIMAL_PRAGs (dL->L _ (ITminimal_prag src)) = src +getOVERLAPPABLE_PRAGs (dL->L _ (IToverlappable_prag src)) = src +getOVERLAPPING_PRAGs (dL->L _ (IToverlapping_prag src)) = src +getOVERLAPS_PRAGs (dL->L _ (IToverlaps_prag src)) = src +getINCOHERENT_PRAGs (dL->L _ (ITincoherent_prag src)) = src +getCTYPEs (dL->L _ (ITctype src)) = src getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l) isUnicode :: Located Token -> Bool -isUnicode (L _ (ITforall iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITdarrow iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITdcolon iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITlarrow iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITrarrow iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITlarrowtail iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITrarrowtail iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITLarrowtail iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITRarrowtail iu)) = iu == UnicodeSyntax -isUnicode (L _ (IToparenbar iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITcparenbar iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITopenExpQuote _ iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITcloseQuote iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITstar iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITforall iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITdarrow iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITdcolon iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITlarrow iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITrarrow iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITlarrowtail iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITrarrowtail iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITLarrowtail iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITRarrowtail iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (IToparenbar iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITcparenbar iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITopenExpQuote _ iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITcloseQuote iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITstar iu)) = iu == UnicodeSyntax isUnicode _ = False hasE :: Located Token -> Bool -hasE (L _ (ITopenExpQuote HasE _)) = True -hasE (L _ (ITopenTExpQuote HasE)) = True +hasE (dL->L _ (ITopenExpQuote HasE _)) = True +hasE (dL->L _ (ITopenTExpQuote HasE)) = True hasE _ = False getSCC :: Located Token -> P FastString @@ -3666,36 +3672,39 @@ getSCC lt = do let s = getSTRING lt else return s -- Utilities for combining source spans -comb2 :: Located a -> Located b -> SrcSpan +comb2 :: (HasSrcSpan a , HasSrcSpan b) => a -> b -> SrcSpan comb2 a b = a `seq` b `seq` combineLocs a b -comb3 :: Located a -> Located b -> Located c -> SrcSpan +comb3 :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) => + a -> b -> c -> SrcSpan comb3 a b c = a `seq` b `seq` c `seq` combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c)) -comb4 :: Located a -> Located b -> Located c -> Located d -> SrcSpan +comb4 :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c , HasSrcSpan d) => + a -> b -> c -> d -> SrcSpan comb4 a b c d = a `seq` b `seq` c `seq` d `seq` (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $ combineSrcSpans (getLoc c) (getLoc d)) -- strict constructor version: {-# INLINE sL #-} -sL :: SrcSpan -> a -> Located a -sL span a = span `seq` a `seq` L span a +sL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a +sL span a = span `seq` a `seq` cL span a -- See Note [Adding location info] for how these utility functions are used -- replaced last 3 CPP macros in this file {-# INLINE sL0 #-} -sL0 :: a -> Located a -sL0 = L noSrcSpan -- #define L0 L noSrcSpan +sL0 :: HasSrcSpan a => SrcSpanLess a -> a +sL0 = cL noSrcSpan -- #define L0 L noSrcSpan {-# INLINE sL1 #-} -sL1 :: Located a -> b -> Located b +sL1 :: (HasSrcSpan a , HasSrcSpan b) => a -> SrcSpanLess b -> b sL1 x = sL (getLoc x) -- #define sL1 sL (getLoc $1) {-# INLINE sLL #-} -sLL :: Located a -> Located b -> c -> Located c +sLL :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) => + a -> b -> SrcSpanLess c -> c sLL x y = sL (comb2 x y) -- #define LL sL (comb2 $1 $>) {- Note [Adding location info] @@ -3739,7 +3748,7 @@ incorrect. -- try to find the span of the whole file (ToDo). fileSrcSpan :: P SrcSpan fileSrcSpan = do - l <- getSrcLoc; + l <- getRealSrcLoc; let loc = mkSrcLoc (srcLocFile l) 1 1; return (mkSrcSpan loc loc) @@ -3770,7 +3779,7 @@ hintExplicitForall span = do ] -- Hint about explicit-forall, assuming UnicodeSyntax is off -hintExplicitForall' :: SrcSpan -> P (GenLocated SrcSpan RdrName) +hintExplicitForall' :: SrcSpan -> P (Located RdrName) hintExplicitForall' span = do forall <- extension explicitForallEnabled let illegalDot = "Illegal symbol '.' in type" @@ -3786,7 +3795,7 @@ hintExplicitForall' span = do ] checkIfBang :: LHsExpr GhcPs -> Bool -checkIfBang (L _ (HsVar _ (L _ op))) = op == bang_RDR +checkIfBang (dL->L _ (HsVar _ (dL->L _ op))) = op == bang_RDR checkIfBang _ = False -- | Warn about missing space after bang @@ -3803,7 +3812,7 @@ warnSpaceAfterBang span = do -- When two single quotes don't followed by tyvar or gtycon, we report the -- error as empty character literal, or TH quote that missing proper type -- variable or constructor. See Trac #13450. -reportEmptyDoubleQuotes :: SrcSpan -> P (GenLocated SrcSpan (HsExpr GhcPs)) +reportEmptyDoubleQuotes :: SrcSpan -> P (Located (HsExpr GhcPs)) reportEmptyDoubleQuotes span = do thEnabled <- liftM ((LangExt.TemplateHaskellQuotes `extopt`) . options) getPState if thEnabled @@ -3832,31 +3841,37 @@ in ApiAnnotation.hs -- |Construct an AddAnn from the annotation keyword and the location -- of the keyword itself -mj :: AnnKeywordId -> Located e -> AddAnn +mj :: HasSrcSpan e => AnnKeywordId -> e -> AddAnn mj a l s = addAnnotation s a (gl l) +mjL :: AnnKeywordId -> SrcSpan -> AddAnn +mjL a l s = addAnnotation s a l + + + -- |Construct an AddAnn from the annotation keyword and the Located Token. If -- the token has a unicode equivalent and this has been used, provide the -- unicode variant of the annotation. mu :: AnnKeywordId -> Located Token -> AddAnn -mu a lt@(L l t) = (\s -> addAnnotation s (toUnicodeAnn a lt) l) +mu a lt@(dL->L l t) = (\s -> addAnnotation s (toUnicodeAnn a lt) l) -- | If the 'Token' is using its unicode variant return the unicode variant of -- the annotation toUnicodeAnn :: AnnKeywordId -> Located Token -> AnnKeywordId toUnicodeAnn a t = if isUnicode t then unicodeAnn a else a +gl :: HasSrcSpan a => a -> SrcSpan gl = getLoc -- |Add an annotation to the located element, and return the located -- element as a pass through -aa :: Located a -> (AnnKeywordId,Located c) -> P (Located a) -aa a@(L l _) (b,s) = addAnnotation l b (gl s) >> return a +aa :: (HasSrcSpan a , HasSrcSpan c) => a -> (AnnKeywordId, c) -> P a +aa a@(dL->L l _) (b,s) = addAnnotation l b (gl s) >> return a -- |Add an annotation to a located element resulting from a monadic action -am :: P (Located a) -> (AnnKeywordId, Located b) -> P (Located a) +am :: (HasSrcSpan a , HasSrcSpan b) => P a -> (AnnKeywordId, b) -> P a am a (b,s) = do - av@(L l _) <- a + av@(dL->L l _) <- a addAnnotation l b (gl s) return av @@ -3874,26 +3889,25 @@ am a (b,s) = do -- and closing braces if they are used to delimit the let expressions. -- ams :: Located a -> [AddAnn] -> P (Located a) -ams a@(L l _) bs = addAnnsAt l bs >> return a +ams a@(dL->L l _) bs = addAnnsAt l bs >> return a --- |Add all [AddAnn] to an AST element wrapped in a Just -aljs :: Located (Maybe a) -> [AddAnn] -> P (Located (Maybe a)) -aljs a@(L l _) bs = addAnnsAt l bs >> return a +amsL :: SrcSpan -> [AddAnn] -> P () +amsL sp bs = addAnnsAt sp bs >> return () -- |Add all [AddAnn] to an AST element wrapped in a Just -ajs a@(Just (L l _)) bs = addAnnsAt l bs >> return a +ajs a@(Just (dL->L l _)) bs = addAnnsAt l bs >> return a -- |Add a list of AddAnns to the given AST element, where the AST element is the -- result of a monadic action -amms :: P (Located a) -> [AddAnn] -> P (Located a) -amms a bs = do { av@(L l _) <- a +amms :: HasSrcSpan a => P a -> [AddAnn] -> P a +amms a bs = do { av@(dL->L l _) <- a ; addAnnsAt l bs ; return av } -- |Add a list of AddAnns to the AST element, and return the element as a -- OrdList -amsu :: Located a -> [AddAnn] -> P (OrdList (Located a)) -amsu a@(L l _) bs = addAnnsAt l bs >> return (unitOL a) +amsu :: HasSrcSpan a => a -> [AddAnn] -> P (OrdList a) +amsu a@(dL->L l _) bs = addAnnsAt l bs >> return (unitOL a) -- |Synonyms for AddAnn versions of AnnOpen and AnnClose mo,mc :: Located Token -> AddAnn @@ -3915,22 +3929,22 @@ mcs ll = mj AnnCloseS ll -- |Given a list of the locations of commas, provide a [AddAnn] with an AnnComma -- entry for each SrcSpan mcommas :: [SrcSpan] -> [AddAnn] -mcommas ss = map (\s -> mj AnnCommaTuple (L s ())) ss +mcommas ss = map (mjL AnnCommaTuple) ss -- |Given a list of the locations of '|'s, provide a [AddAnn] with an AnnVbar -- entry for each SrcSpan mvbars :: [SrcSpan] -> [AddAnn] -mvbars ss = map (\s -> mj AnnVbar (L s ())) ss +mvbars ss = map (mjL AnnVbar) ss -- |Get the location of the last element of a OrdList, or noSrcSpan -oll :: OrdList (Located a) -> SrcSpan +oll :: HasSrcSpan a => OrdList a -> SrcSpan oll l = if isNilOL l then noSrcSpan else getLoc (lastOL l) -- |Add a semicolon annotation in the right place in a list. If the -- leading list is empty, add it to the tail -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 +asl :: (HasSrcSpan a , HasSrcSpan b) => [a] -> b -> a -> P() +asl [] (dL->L ls _) (dL->L l _) = addAnnotation l AnnSemi ls +asl (x:_xs) (dL->L ls _) _x = addAnnotation (getLoc x) AnnSemi ls } diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 1ac21c6c2d..8c78fb5a0e 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -8,6 +8,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE ViewPatterns #-} module RdrHsSyn ( mkHsOpApp, @@ -36,8 +37,8 @@ module RdrHsSyn ( mkImport, parseCImport, mkExport, - mkExtName, -- RdrName -> CLabelString - mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName + mkExtName, -- RdrName -> CLabelString + mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName mkConDeclH98, mkATDefault, @@ -136,10 +137,10 @@ import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs ) -- *** See Note [The Naming story] in HsDecls **** mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p) -mkTyClD (L loc d) = L loc (TyClD noExt d) +mkTyClD (dL->L loc d) = cL loc (TyClD noExt d) mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p) -mkInstD (L loc d) = L loc (InstD noExt d) +mkInstD (dL->L loc d) = cL loc (InstD noExt d) mkClassDecl :: SrcSpan -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) @@ -147,7 +148,7 @@ mkClassDecl :: SrcSpan -> OrdList (LHsDecl GhcPs) -> P (LTyClDecl GhcPs) -mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls +mkClassDecl loc (dL->L _ (mcxt, tycl_hdr)) fds where_cls = do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs where_cls ; let cxt = fromMaybe (noLoc []) mcxt ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr @@ -155,14 +156,14 @@ mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls ; tyvars <- checkTyVarsP (text "class") whereDots cls tparams ; (at_defs, anns) <- fmap unzip $ mapM (eitherToP . mkATDefault) at_insts ; sequence_ anns - ; return (L loc (ClassDecl { tcdCExt = noExt, tcdCtxt = cxt - , tcdLName = cls, tcdTyVars = tyvars - , tcdFixity = fixity - , tcdFDs = snd (unLoc fds) - , tcdSigs = mkClassOpSigs sigs - , tcdMeths = binds - , tcdATs = ats, tcdATDefs = at_defs - , tcdDocs = docs })) } + ; return (cL loc (ClassDecl { tcdCExt = noExt, tcdCtxt = cxt + , tcdLName = cls, tcdTyVars = tyvars + , tcdFixity = fixity + , tcdFDs = snd (unLoc fds) + , tcdSigs = mkClassOpSigs sigs + , tcdMeths = binds + , tcdATs = ats, tcdATDefs = at_defs + , tcdDocs = docs })) } mkATDefault :: LTyFamInstDecl GhcPs -> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs, P ()) @@ -175,20 +176,22 @@ mkATDefault :: LTyFamInstDecl GhcPs -- The @P ()@ we return corresponds represents an action which will add -- some necessary paren annotations to the parsing context. Naturally, this -- is not something that the "Convert" use cares about. -mkATDefault (L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_body = e }})) +mkATDefault (dL->L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_body = e }})) | FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs, feqn_pats = pats , feqn_fixity = fixity, feqn_rhs = rhs } <- e = do { (tvs, anns) <- checkTyVars (text "default") equalsDots tc pats - ; let f = L loc (FamEqn { feqn_ext = noExt - , feqn_tycon = tc - , feqn_bndrs = ASSERT( isNothing bndrs ) - Nothing - , feqn_pats = tvs - , feqn_fixity = fixity - , feqn_rhs = rhs }) + ; let f = cL loc (FamEqn { feqn_ext = noExt + , feqn_tycon = tc + , feqn_bndrs = ASSERT( isNothing bndrs ) + Nothing + , feqn_pats = tvs + , feqn_fixity = fixity + , feqn_rhs = rhs }) ; pure (f, anns) } -mkATDefault (L _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "mkATDefault" -mkATDefault (L _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "mkATDefault" +mkATDefault (dL->L _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "mkATDefault" +mkATDefault (dL->L _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "mkATDefault" +mkATDefault _ = panic "mkATDefault: Impossible Match" + -- due to #15884 mkTyData :: SrcSpan -> NewOrData @@ -198,15 +201,16 @@ mkTyData :: SrcSpan -> [LConDecl GhcPs] -> HsDeriving GhcPs -> P (LTyClDecl GhcPs) -mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv +mkTyData loc new_or_data cType (dL->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 ; tyvars <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv - ; return (L loc (DataDecl { tcdDExt = noExt, - tcdLName = tc, tcdTyVars = tyvars, - tcdFixity = fixity, - tcdDataDefn = defn })) } + ; return (cL loc (DataDecl { tcdDExt = noExt, + tcdLName = tc, tcdTyVars = tyvars, + tcdFixity = fixity, + tcdDataDefn = defn })) } mkDataDefn :: NewOrData -> Maybe (Located CType) @@ -234,10 +238,10 @@ 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 ; tyvars <- checkTyVarsP (text "type") equalsDots tc tparams - ; return (L loc (SynDecl { tcdSExt = noExt - , tcdLName = tc, tcdTyVars = tyvars - , tcdFixity = fixity - , tcdRhs = rhs })) } + ; return (cL loc (SynDecl { tcdSExt = noExt + , tcdLName = tc, tcdTyVars = tyvars + , tcdFixity = fixity + , tcdRhs = rhs })) } mkTyFamInstEqn :: Maybe [LHsTyVarBndr GhcPs] -> LHsType GhcPs @@ -257,16 +261,18 @@ mkTyFamInstEqn bndrs lhs rhs mkDataFamInst :: SrcSpan -> NewOrData -> Maybe (Located CType) - -> Located (Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs], LHsType GhcPs) + -> Located ( Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs] + , LHsType GhcPs) -> Maybe (LHsKind GhcPs) -> [LConDecl GhcPs] -> HsDeriving GhcPs -> P (LInstDecl GhcPs) -mkDataFamInst loc new_or_data cType (L _ (mcxt, bndrs, tycl_hdr)) ksig data_cons maybe_deriv +mkDataFamInst loc new_or_data cType (dL->L _ (mcxt, bndrs, 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 ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv - ; return (L loc (DataFamInstD noExt (DataFamInstDecl (mkHsImplicitBndrs + ; return (cL loc (DataFamInstD noExt (DataFamInstDecl (mkHsImplicitBndrs (FamEqn { feqn_ext = noExt , feqn_tycon = tc , feqn_bndrs = bndrs @@ -278,7 +284,7 @@ mkTyFamInst :: SrcSpan -> TyFamInstEqn GhcPs -> P (LInstDecl GhcPs) mkTyFamInst loc eqn - = return (L loc (TyFamInstD noExt (TyFamInstDecl eqn))) + = return (cL loc (TyFamInstD noExt (TyFamInstDecl eqn))) mkFamDecl :: SrcSpan -> FamilyInfo GhcPs @@ -290,7 +296,7 @@ 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 ; tyvars <- checkTyVarsP (ppr info) equals_or_where tc tparams - ; return (L loc (FamDecl noExt (FamilyDecl + ; return (cL loc (FamDecl noExt (FamilyDecl { fdExt = noExt , fdInfo = info, fdLName = tc , fdTyVars = tyvars @@ -313,15 +319,15 @@ mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs -- -- Typed splices are not allowed at the top level, thus we do not represent them -- as spliced declaration. See #10945 -mkSpliceDecl lexpr@(L loc expr) +mkSpliceDecl lexpr@(dL->L loc expr) | HsSpliceE _ splice@(HsUntypedSplice {}) <- expr - = SpliceD noExt (SpliceDecl noExt (L loc splice) ExplicitSplice) + = SpliceD noExt (SpliceDecl noExt (cL loc splice) ExplicitSplice) | HsSpliceE _ splice@(HsQuasiQuote {}) <- expr - = SpliceD noExt (SpliceDecl noExt (L loc splice) ExplicitSplice) + = SpliceD noExt (SpliceDecl noExt (cL loc splice) ExplicitSplice) | otherwise - = SpliceD noExt (SpliceDecl noExt (L loc (mkUntypedSplice NoParens lexpr)) + = SpliceD noExt (SpliceDecl noExt (cL loc (mkUntypedSplice NoParens lexpr)) ImplicitSplice) mkRoleAnnotDecl :: SrcSpan @@ -330,21 +336,25 @@ mkRoleAnnotDecl :: SrcSpan -> P (LRoleAnnotDecl GhcPs) mkRoleAnnotDecl loc tycon roles = do { roles' <- mapM parse_role roles - ; return $ L loc $ RoleAnnotDecl noExt tycon roles' } + ; return $ cL loc $ RoleAnnotDecl noExt tycon roles' } where role_data_type = dataTypeOf (undefined :: Role) all_roles = map fromConstr $ dataTypeConstrs role_data_type possible_roles = [(fsFromRole role, role) | role <- all_roles] - parse_role (L loc_role Nothing) = return $ L loc_role Nothing - parse_role (L loc_role (Just role)) + parse_role (dL->L loc_role Nothing) = return $ cL loc_role Nothing + parse_role (dL->L loc_role (Just role)) = case lookup role possible_roles of - Just found_role -> return $ L loc_role $ Just found_role + Just found_role -> return $ cL loc_role $ Just found_role Nothing -> - let nearby = fuzzyLookup (unpackFS role) (mapFst unpackFS possible_roles) in + let nearby = fuzzyLookup (unpackFS role) + (mapFst unpackFS possible_roles) + in parseErrorSDoc loc_role (text "Illegal role name" <+> quotes (ppr role) $$ suggestions nearby) + parse_role _ = panic "parse_role: Impossible Match" + -- due to #15884 suggestions [] = empty suggestions [r] = text "Perhaps you meant" <+> quotes (ppr r) @@ -369,14 +379,16 @@ cvTopDecls decls = go (fromOL decls) where go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs] go [] = [] - go (L l (ValD x b) : ds) = L l' (ValD x b') : go ds' - where (L l' b', ds') = getMonoBind (L l b) ds - go (d : ds) = d : go ds + go ((dL->L l (ValD x b)) : ds) + = cL l' (ValD x b') : go ds' + where (dL->L l' b', ds') = getMonoBind (cL l b) ds + go (d : ds) = d : go ds -- Declaration list may only contain value bindings and signatures. cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs) cvBindGroup binding - = do { (mbs, sigs, fam_ds, tfam_insts, dfam_insts, _) <- cvBindsAndSigs binding + = do { (mbs, sigs, fam_ds, tfam_insts + , dfam_insts, _) <- cvBindsAndSigs binding ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts) return $ ValBinds noExt mbs sigs } @@ -389,24 +401,24 @@ cvBindsAndSigs :: OrdList (LHsDecl GhcPs) cvBindsAndSigs fb = go (fromOL fb) where go [] = return (emptyBag, [], [], [], [], []) - go (L l (ValD _ b) : ds) + go ((dL->L l (ValD _ b)) : ds) = do { (bs, ss, ts, tfis, dfis, docs) <- go ds' ; return (b' `consBag` bs, ss, ts, tfis, dfis, docs) } where - (b', ds') = getMonoBind (L l b) ds - go (L l decl : ds) + (b', ds') = getMonoBind (cL l b) ds + go ((dL->L l decl) : ds) = do { (bs, ss, ts, tfis, dfis, docs) <- go ds ; case decl of SigD _ s - -> return (bs, L l s : ss, ts, tfis, dfis, docs) + -> return (bs, cL l s : ss, ts, tfis, dfis, docs) TyClD _ (FamDecl _ t) - -> return (bs, ss, L l t : ts, tfis, dfis, docs) + -> return (bs, ss, cL l t : ts, tfis, dfis, docs) InstD _ (TyFamInstD { tfid_inst = tfi }) - -> return (bs, ss, ts, L l tfi : tfis, dfis, docs) + -> return (bs, ss, ts, cL l tfi : tfis, dfis, docs) InstD _ (DataFamInstD { dfid_inst = dfi }) - -> return (bs, ss, ts, tfis, L l dfi : dfis, docs) + -> return (bs, ss, ts, tfis, cL l dfi : dfis, docs) DocD _ d - -> return (bs, ss, ts, tfis, dfis, L l d : docs) + -> return (bs, ss, ts, tfis, dfis, cL l d : docs) SpliceD _ d -> parseErrorSDoc l $ hang (text "Declaration splices are allowed only" <+> @@ -432,23 +444,25 @@ getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs] -- -- No AndMonoBinds or EmptyMonoBinds here; just single equations -getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), - fun_matches - = MG { mg_alts = L _ mtchs1 } })) binds +getMonoBind (dL->L loc1 (FunBind { fun_id = fun_id1@(dL->L _ f1) + , fun_matches = + MG { mg_alts = (dL->L _ mtchs1) } })) + binds | has_args mtchs1 = go mtchs1 loc1 binds [] where go mtchs loc - (L loc2 (ValD _ (FunBind { fun_id = L _ f2, - fun_matches - = MG { mg_alts = L _ mtchs2 } })) : binds) _ + ((dL->L loc2 (ValD _ (FunBind { fun_id = (dL->L _ f2) + , fun_matches = + MG { mg_alts = (dL->L _ mtchs2) } }))) + : binds) _ | f1 == f2 = go (mtchs2 ++ mtchs) (combineSrcSpans loc loc2) binds [] - go mtchs loc (doc_decl@(L loc2 (DocD {})) : binds) doc_decls + go mtchs loc (doc_decl@(dL->L loc2 (DocD {})) : binds) doc_decls = let doc_decls' = doc_decl : doc_decls in go mtchs (combineSrcSpans loc loc2) binds doc_decls' go mtchs loc binds doc_decls - = ( L loc (makeFunBind fun_id1 (reverse mtchs)) + = ( cL loc (makeFunBind fun_id1 (reverse mtchs)) , (reverse doc_decls) ++ binds) -- Reverse the final matches, to get it back in the right order -- Do the same thing with the trailing doc comments @@ -457,12 +471,13 @@ getMonoBind bind binds = (bind, binds) has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool has_args [] = panic "RdrHsSyn:has_args" -has_args ((L _ (Match { m_pats = args })) : _) = not (null args) +has_args ((dL->L _ (Match { m_pats = args })) : _) = not (null args) -- Don't group together FunBinds if they have -- no arguments. This is necessary now that variable bindings -- with no arguments are now treated as FunBinds rather -- than pattern bindings (tests/rename/should_fail/rnfail002). -has_args ((L _ (XMatch _)) : _) = panic "has_args" +has_args ((dL->L _ (XMatch _)) : _) = panic "has_args" +has_args (_ : _) = panic "has_args:Impossible Match" -- due to #15884 {- ********************************************************************** @@ -554,7 +569,7 @@ tyConToDataCon :: SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName) tyConToDataCon loc tc | isTcOcc occ || isDataOcc occ , isLexCon (occNameFS occ) - = return (L loc (setRdrNameSpace tc srcDataName)) + = return (cL loc (setRdrNameSpace tc srcDataName)) | otherwise = Left (loc, msg $$ extra) @@ -569,13 +584,13 @@ tyConToDataCon loc tc mkPatSynMatchGroup :: Located RdrName -> Located (OrdList (LHsDecl GhcPs)) -> P (MatchGroup GhcPs (LHsExpr GhcPs)) -mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) = +mkPatSynMatchGroup (dL->L loc patsyn_name) (dL->L _ decls) = do { matches <- mapM fromDecl (fromOL decls) ; when (null matches) (wrongNumberErr loc) ; return $ mkMatchGroup FromSource matches } where - fromDecl (L loc decl@(ValD _ (PatBind _ - pat@(L _ (ConPatIn ln@(L _ name) details)) + fromDecl (dL->L loc decl@(ValD _ (PatBind _ + pat@(dL->L _ (ConPatIn ln@(dL->L _ name) details)) rhs _))) = do { unless (name == patsyn_name) $ wrongNameBindingErr loc decl @@ -584,18 +599,22 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) = , m_ctxt = ctxt, m_pats = pats , m_grhss = rhs } where - ctxt = FunRhs { mc_fun = ln, mc_fixity = Prefix, mc_strictness = NoSrcStrict } + ctxt = FunRhs { mc_fun = ln + , mc_fixity = Prefix + , mc_strictness = NoSrcStrict } InfixCon p1 p2 -> return $ Match { m_ext = noExt , m_ctxt = ctxt , m_pats = [p1, p2] , m_grhss = rhs } where - ctxt = FunRhs { mc_fun = ln, mc_fixity = Infix, mc_strictness = NoSrcStrict } + ctxt = FunRhs { mc_fun = ln + , mc_fixity = Infix + , mc_strictness = NoSrcStrict } RecCon{} -> recordPatSynErr loc pat - ; return $ L loc match } - fromDecl (L loc decl) = extraDeclErr loc decl + ; return $ cL loc match } + fromDecl (dL->L loc decl) = extraDeclErr loc decl extraDeclErr loc decl = parseErrorSDoc loc $ @@ -603,9 +622,9 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) = ppr decl wrongNameBindingErr loc decl = - parseErrorSDoc loc $ - text "pattern synonym 'where' clause must bind the pattern synonym's name" <+> - quotes (ppr patsyn_name) $$ ppr decl + parseErrorSDoc loc $ + text "pattern synonym 'where' clause must bind the pattern synonym's name" + <+> quotes (ppr patsyn_name) $$ ppr decl wrongNumberErr loc = parseErrorSDoc loc $ @@ -639,7 +658,7 @@ mkGadtDecl :: [Located RdrName] mkGadtDecl names ty = (ConDeclGADT { con_g_ext = noExt , con_names = names - , con_forall = L l $ isLHsForAllTy ty' + , con_forall = cL l $ isLHsForAllTy ty' , con_qvars = mkHsQTvs tvs , con_mb_cxt = mcxt , con_args = args' @@ -647,24 +666,27 @@ mkGadtDecl names ty , con_doc = Nothing } , anns1 ++ anns2) where - (ty'@(L l _),anns1) = peel_parens ty [] + (ty'@(dL->L l _),anns1) = peel_parens ty [] (tvs, rho) = splitLHsForAllTy ty' (mcxt, tau, anns2) = split_rho rho [] - split_rho (L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann - = (Just cxt, tau, ann) - split_rho (L l (HsParTy _ ty)) ann = split_rho ty (ann++mkParensApiAnn l) - split_rho tau ann = (Nothing, tau, ann) + split_rho (dL->L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann + = (Just cxt, tau, ann) + split_rho (dL->L l (HsParTy _ ty)) ann + = split_rho ty (ann++mkParensApiAnn l) + split_rho tau ann + = (Nothing, tau, ann) (args, res_ty) = split_tau tau args' = nudgeHsSrcBangs args -- See Note [GADT abstract syntax] in HsDecls - split_tau (L _ (HsFunTy _ (L loc (HsRecTy _ rf)) res_ty)) - = (RecCon (L loc rf), res_ty) - split_tau tau = (PrefixCon [], tau) + split_tau (dL->L _ (HsFunTy _ (dL->L loc (HsRecTy _ rf)) res_ty)) + = (RecCon (cL loc rf), res_ty) + split_tau tau + = (PrefixCon [], tau) - peel_parens (L l (HsParTy _ ty)) ann = peel_parens ty + peel_parens (dL->L l (HsParTy _ ty)) ann = peel_parens ty (ann++mkParensApiAnn l) peel_parens ty ann = (ty, ann) @@ -685,8 +707,8 @@ nudgeHsSrcBangs details RecCon r -> RecCon r InfixCon a1 a2 -> InfixCon (go a1) (go a2) where - go (L l (HsDocTy _ (L _ (HsBangTy _ s lty)) lds)) = - L l (HsBangTy noExt s (addCLoc lty lds (HsDocTy noExt lty lds))) + go (dL->L l (HsDocTy _ (dL->L _ (HsBangTy _ s lty)) lds)) = + cL l (HsBangTy noExt s (addCLoc lty lds (HsDocTy noExt lty lds))) go lty = lty @@ -811,24 +833,29 @@ checkTyVars pp_what equals_or_where tc tparms -- Keep around an action for adjusting the annotations of extra parens chkParens :: [AddAnn] -> LHsType GhcPs -> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, P ()) - chkParens acc (L l (HsParTy _ ty)) = chkParens (mkParensApiAnn l ++ acc) ty + chkParens acc (dL->L l (HsParTy _ ty)) = chkParens (mkParensApiAnn l + ++ acc) ty chkParens acc ty = case chk ty of Left err -> Left err - Right tv@(L l _) -> Right (tv, addAnnsAt l (reverse acc)) + Right tv@(dL->L l _) -> Right (tv, addAnnsAt l (reverse acc)) -- Check that the name space is correct! - chk (L l (HsKindSig _ (L lv (HsTyVar _ _ (L _ tv))) k)) - | isRdrTyVar tv = return (L l (KindedTyVar noExt (L lv tv) k)) - chk (L l (HsTyVar _ _ (L ltv tv))) - | isRdrTyVar tv = return (L l (UserTyVar noExt (L ltv tv))) - chk t@(L loc _) + chk (dL->L l (HsKindSig _ (dL->L lv (HsTyVar _ _ (dL->L _ tv))) k)) + | isRdrTyVar tv = return (cL l (KindedTyVar noExt (cL lv tv) k)) + chk (dL->L l (HsTyVar _ _ (dL->L ltv tv))) + | isRdrTyVar tv = return (cL l (UserTyVar noExt (cL ltv tv))) + chk t@(dL->L loc _) = Left (loc, vcat [ text "Unexpected type" <+> quotes (ppr t) - , text "In the" <+> pp_what <+> ptext (sLit "declaration for") <+> quotes tc' - , vcat[ (text "A" <+> pp_what <+> ptext (sLit "declaration should have form")) - , nest 2 (pp_what <+> tc' - <+> hsep (map text (takeList tparms allNameStrings)) - <+> equals_or_where) ] ]) + , text "In the" <+> pp_what + <+> ptext (sLit "declaration for") <+> quotes tc' + , vcat[ (text "A" <+> pp_what + <+> ptext (sLit "declaration should have form")) + , nest 2 + (pp_what + <+> tc' + <+> hsep (map text (takeList tparms allNameStrings)) + <+> equals_or_where) ] ]) -- Avoid printing a constraint tuple in the error message. Print -- a plain old tuple instead (since that's what the user probably @@ -844,7 +871,7 @@ equalsDots = text "= ..." checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P () checkDatatypeContext Nothing = return () -checkDatatypeContext (Just (L loc c)) +checkDatatypeContext (Just (dL->L loc c)) = do allowed <- extension datatypeContextsEnabled unless allowed $ parseErrorSDoc loc @@ -859,39 +886,42 @@ data RuleTyTmVar = RuleTyTmVar (Located RdrName) (Maybe (LHsType GhcPs)) mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs] mkRuleBndrs = fmap (fmap cvt_one) where cvt_one (RuleTyTmVar v Nothing) = RuleBndr noExt v - cvt_one (RuleTyTmVar v (Just sig)) = RuleBndrSig noExt v (mkLHsSigWcType sig) + cvt_one (RuleTyTmVar v (Just sig)) = + RuleBndrSig noExt v (mkLHsSigWcType sig) -- turns RuleTyTmVars into HsTyVarBndrs - this is more interesting mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr GhcPs] mkRuleTyVarBndrs = fmap (fmap cvt_one) where cvt_one (RuleTyTmVar v Nothing) = UserTyVar noExt (fmap tm_to_ty v) - cvt_one (RuleTyTmVar v (Just sig)) = KindedTyVar noExt (fmap tm_to_ty v) sig - -- takes something in namespace 'varName' to something in namespace 'tvName' + cvt_one (RuleTyTmVar v (Just sig)) + = KindedTyVar noExt (fmap tm_to_ty v) sig + -- takes something in namespace 'varName' to something in namespace 'tvName' tm_to_ty (Unqual occ) = Unqual (setOccNameSpace tvName occ) tm_to_ty _ = panic "mkRuleTyVarBndrs" -- See note [Parsing explicit foralls in Rules] in Parser.y checkRuleTyVarBndrNames :: [LHsTyVarBndr GhcPs] -> P () checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName) - where check (L loc (Unqual occ)) = do + where check (dL->L loc (Unqual occ)) = do when ((occNameString occ ==) `any` ["forall","family","role"]) - (parseErrorSDoc loc (text $ "parse error on input " ++ occNameString occ)) + (parseErrorSDoc loc (text $ "parse error on input " + ++ occNameString occ)) check _ = panic "checkRuleTyVarBndrNames" checkRecordSyntax :: Outputable a => Located a -> P (Located a) -checkRecordSyntax lr@(L loc r) +checkRecordSyntax lr@(dL->L loc r) = do allowed <- extension traditionalRecordSyntaxEnabled if allowed then return lr else parseErrorSDoc loc - (text "Illegal record syntax (use TraditionalRecordSyntax):" <+> - ppr r) + (text "Illegal record syntax (use TraditionalRecordSyntax):" + <+> ppr r) -- | Check if the gadt_constrlist is empty. Only raise parse error for -- `data T where` to avoid affecting existing error message, see #8258. checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs]) -> P (Located ([AddAnn], [LConDecl GhcPs])) -checkEmptyGADTs gadts@(L span (_, [])) -- Empty GADT declaration. +checkEmptyGADTs gadts@(dL->L span (_, [])) -- Empty GADT declaration. = do opts <- fmap options getPState if LangExt.GADTSyntax `extopt` opts -- GADTs implies GADTSyntax then return gadts @@ -916,28 +946,28 @@ checkTyClHdr :: Bool -- True <=> class header checkTyClHdr is_cls ty = goL ty [] [] Prefix where - goL (L l ty) acc ann fix = go l ty acc ann fix + goL (dL->L l ty) acc ann fix = go l ty acc ann fix -- workaround to define '*' despite StarIsType - go _ (HsParTy _ (L l (HsStarTy _ isUni))) acc ann fix + go _ (HsParTy _ (dL->L l (HsStarTy _ isUni))) acc ann fix = do { warnStarBndr l ; let name = mkOccName tcClsName (if isUni then "★" else "*") - ; return (L l (Unqual name), acc, fix, ann) } + ; return (cL l (Unqual name), acc, fix, ann) } - go l (HsTyVar _ _ (L _ tc)) acc ann fix - | isRdrTc tc = return (L l tc, acc, fix, ann) - go _ (HsOpTy _ t1 ltc@(L _ tc) t2) acc ann _fix + go l (HsTyVar _ _ (dL->L _ tc)) acc ann fix + | isRdrTc tc = return (cL l tc, acc, fix, ann) + go _ (HsOpTy _ t1 ltc@(dL->L _ tc) t2) acc ann _fix | isRdrTc tc = return (ltc, t1:t2:acc, Infix, ann) go l (HsParTy _ ty) acc ann fix = goL ty acc (ann ++mkParensApiAnn l) fix go _ (HsAppTy _ t1 t2) acc ann fix = goL t1 (t2:acc) ann fix go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ann fix - = return (L l (nameRdrName tup_name), ts, fix, ann) + = return (cL l (nameRdrName tup_name), ts, fix, ann) where arity = length ts tup_name | is_cls = cTupleTyConName arity | otherwise = getName (tupleTyCon Boxed arity) - -- See Note [Unit tuples] in HsTypes (TODO: is this still relevant?) + -- See Note [Unit tuples] in HsTypes (TODO: is this still relevant?) go l _ _ _ _ = parseErrorSDoc l (text "Malformed head of type or class declaration:" <+> ppr ty) @@ -975,22 +1005,22 @@ checkBlockArguments expr = case unLoc expr of -- (((Eq a))) --> [Eq a] -- @ checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs) -checkContext (L l orig_t) - = check [] (L l orig_t) +checkContext (dL->L l orig_t) + = check [] (cL l orig_t) where - check anns (L lp (HsTupleTy _ HsBoxedOrConstraintTuple ts)) + check anns (dL->L lp (HsTupleTy _ HsBoxedOrConstraintTuple ts)) -- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can -- be used as context constraints. - = return (anns ++ mkParensApiAnn lp,L l ts) -- Ditto () + = return (anns ++ mkParensApiAnn lp,cL l ts) -- Ditto () - check anns (L lp1 (HsParTy _ ty)) + check anns (dL->L lp1 (HsParTy _ ty)) -- to be sure HsParTy doesn't get into the way = check anns' ty where anns' = if l == lp1 then anns else (anns ++ mkParensApiAnn lp1) -- no need for anns, returning original - check _anns t = checkNoDocs msg t *> return ([],L l [L l orig_t]) + check _anns t = checkNoDocs msg t *> return ([],cL l [cL l orig_t]) msg = text "data constructor context" @@ -999,8 +1029,8 @@ checkContext (L l orig_t) checkNoDocs :: SDoc -> LHsType GhcPs -> P () checkNoDocs msg ty = go ty where - go (L _ (HsAppTy _ t1 t2)) = go t1 *> go t2 - go (L l (HsDocTy _ t ds)) = parseErrorSDoc l $ hsep + go (dL->L _ (HsAppTy _ t1 t2)) = go t1 *> go t2 + go (dL->L l (HsDocTy _ t ds)) = parseErrorSDoc l $ hsep [ text "Unexpected haddock", quotes (ppr ds) , text "on", msg, quotes (ppr t) ] go _ = pure () @@ -1018,12 +1048,12 @@ checkPatterns :: SDoc -> [LHsExpr GhcPs] -> P [LPat GhcPs] checkPatterns msg es = mapM (checkPattern msg) es checkLPat :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs) -checkLPat msg e@(L l _) = checkPat msg l e [] +checkLPat msg e@(dL->L l _) = checkPat msg l e [] 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))) +checkPat _ loc (dL->L l e@(HsVar _ (dL->L _ c))) args + | isRdrDataCon c = return (cL loc (ConPatIn (cL l c) (PrefixCon args))) | not (null args) && patIsRec c = patFail (text "Perhaps you intended to use RecursiveDo") l e checkPat msg loc e args -- OK to let this happen even if bang-patterns @@ -1032,12 +1062,12 @@ checkPat msg loc e args -- OK to let this happen even if bang-patterns | Just (e', args') <- splitBang e = do { args'' <- checkPatterns msg args' ; checkPat msg loc e' (args'' ++ args) } -checkPat msg loc (L _ (HsApp _ f e)) args +checkPat msg loc (dL->L _ (HsApp _ f e)) args = do p <- checkLPat msg e checkPat msg loc f (p : args) -checkPat msg loc (L _ e) [] +checkPat msg loc (dL->L _ e) [] = do p <- checkAPat msg loc e - return (L loc p) + return (cL loc p) checkPat msg loc e _ = patFail msg loc (unLoc e) @@ -1049,18 +1079,19 @@ checkAPat msg loc e0 = do EWildPat _ -> return (WildPat noExt) HsVar _ x -> return (VarPat noExt x) HsLit _ (HsStringPrim _ _) -- (#13260) - -> parseErrorSDoc loc (text "Illegal unboxed string literal in pattern:" $$ ppr e0) + -> parseErrorSDoc loc (text "Illegal unboxed string literal in pattern:" + $$ ppr e0) HsLit _ l -> return (LitPat noExt l) -- Overloaded numeric patterns (e.g. f 0 x = x) -- Negation is recorded separately, so that the literal is zero or +ve -- NB. Negative *primitive* literals are already handled by the lexer - HsOverLit _ pos_lit -> return (mkNPat (L loc pos_lit) Nothing) - NegApp _ (L l (HsOverLit _ pos_lit)) _ - -> return (mkNPat (L l pos_lit) (Just noSyntaxExpr)) + HsOverLit _ pos_lit -> return (mkNPat (cL loc pos_lit) Nothing) + NegApp _ (dL->L l (HsOverLit _ pos_lit)) _ + -> return (mkNPat (cL l pos_lit) (Just noSyntaxExpr)) - SectionR _ (L lb (HsVar _ (L _ bang))) e -- (! x) + SectionR _ (dL->L lb (HsVar _ (dL->L _ bang))) e -- (! x) | bang == bang_RDR -> do { hintBangPat loc e0 ; e' <- checkLPat msg e @@ -1076,16 +1107,16 @@ checkAPat msg loc e0 = do return (SigPat noExt e t) -- n+k patterns - OpApp _ (L nloc (HsVar _ (L _ n))) (L _ (HsVar _ (L _ plus))) - (L lloc (HsOverLit _ lit@(OverLit {ol_val = HsIntegral {}}))) + OpApp _ (dL->L nloc (HsVar _ (dL->L _ n))) + (dL->L _ (HsVar _ (dL->L _ plus))) + (dL->L lloc (HsOverLit _ lit@(OverLit {ol_val = HsIntegral {}}))) | extopt LangExt.NPlusKPatterns opts && (plus == plus_RDR) - -> return (mkNPlusKPat (L nloc n) (L lloc lit)) - - OpApp _ l (L cl (HsVar _ (L _ c))) r + -> return (mkNPlusKPat (cL nloc n) (cL lloc lit)) + OpApp _ l (dL->L cl (HsVar _ (dL->L _ c))) r | isDataOcc (rdrNameOcc c) -> do l <- checkLPat msg l r <- checkLPat msg r - return (ConPatIn (L cl c) (InfixCon l r)) + return (ConPatIn (cL cl c) (InfixCon l r)) OpApp {} -> patFail msg loc e0 @@ -1096,9 +1127,10 @@ checkAPat msg loc e0 = do ExplicitTuple _ es b | all tupArgPresent es -> do ps <- mapM (checkLPat msg) - [e | L _ (Present _ e) <- es] + [e | (dL->L _ (Present _ e)) <- es] return (TuplePat noExt ps b) - | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0) + | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" + $$ ppr e0) ExplicitSum _ alt arity expr -> do p <- checkLPat msg expr @@ -1113,7 +1145,8 @@ checkAPat msg loc e0 = do 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 +-- It's better not to make it an error, in case we want to print it when +-- debugging placeHolderPunRhs = noLoc (HsVar noExt (noLoc pun_RDR)) plus_RDR, bang_RDR, pun_RDR :: RdrName @@ -1123,8 +1156,8 @@ pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side") 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 })) +checkPatField msg (dL->L l fld) = do p <- checkLPat msg (hsRecFieldArg fld) + return (cL l (fld { hsRecFieldArg = p })) patFail :: SDoc -> SrcSpan -> HsExpr GhcPs -> P a patFail msg loc e = parseErrorSDoc loc err @@ -1147,15 +1180,15 @@ checkValDef :: SDoc checkValDef msg _strictness lhs (Just sig) grhss -- x :: ty = rhs parses as a *pattern* binding - = checkPatBind msg (L (combineLocs lhs sig) + = checkPatBind msg (cL (combineLocs lhs sig) (ExprWithTySig noExt lhs (mkLHsSigWcType sig))) grhss -checkValDef msg strictness lhs Nothing g@(L l (_,grhss)) +checkValDef msg strictness lhs Nothing g@(dL->L l (_,grhss)) = do { mb_fun <- isFunLhs lhs ; case mb_fun of Just (fun, is_infix, pats, ann) -> checkFunBind msg strictness ann (getLoc lhs) - fun is_infix pats (L l grhss) + fun is_infix pats (cL l grhss) Nothing -> checkPatBind msg lhs g } checkFunBind :: SDoc @@ -1167,18 +1200,19 @@ checkFunBind :: SDoc -> [LHsExpr GhcPs] -> Located (GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn],HsBind GhcPs) -checkFunBind msg strictness ann lhs_loc fun is_infix pats (L rhs_span grhss) +checkFunBind msg strictness ann lhs_loc fun is_infix pats (dL->L rhs_span grhss) = do ps <- checkPatterns msg pats let match_span = combineSrcSpans lhs_loc rhs_span -- Add back the annotations stripped from any HsPar values in the lhs -- mapM_ (\a -> a match_span) ann return (ann, makeFunBind fun - [L match_span (Match { m_ext = noExt - , m_ctxt = FunRhs { mc_fun = fun - , mc_fixity = is_infix - , mc_strictness = strictness } - , m_pats = ps - , m_grhss = grhss })]) + [cL match_span (Match { m_ext = noExt + , m_ctxt = FunRhs + { mc_fun = fun + , mc_fixity = is_infix + , mc_strictness = strictness } + , m_pats = ps + , m_grhss = grhss })]) -- The span of the match covers the entire equation. -- That isn't quite right, but it'll do for now. @@ -1196,18 +1230,18 @@ checkPatBind :: SDoc -> LHsExpr GhcPs -> Located (a,GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn],HsBind GhcPs) -checkPatBind msg lhs (L _ (_,grhss)) +checkPatBind msg lhs (dL->L _ (_,grhss)) = do { lhs <- checkPattern msg lhs ; return ([],PatBind noExt lhs grhss ([],[])) } checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName) -checkValSigLhs (L _ (HsVar _ lrdr@(L _ v))) +checkValSigLhs (dL->L _ (HsVar _ lrdr@(dL->L _ v))) | isUnqual v , not (isDataOcc (rdrNameOcc v)) = return lrdr -checkValSigLhs lhs@(L l _) +checkValSigLhs lhs@(dL->L l _) = parseErrorSDoc l ((text "Invalid type signature:" <+> ppr lhs <+> text ":: ...") $$ text hint) @@ -1223,9 +1257,10 @@ checkValSigLhs lhs@(L l _) -- A common error is to forget the ForeignFunctionInterface flag -- so check for that, and suggest. cf Trac #3805 - -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword - looks_like s (L _ (HsVar _ (L _ v))) = v == s - looks_like s (L _ (HsApp _ lhs _)) = looks_like s lhs + -- Sadly 'foreign import' still barfs 'parse error' because + -- 'import' is a keyword + looks_like s (dL->L _ (HsVar _ (dL->L _ v))) = v == s + looks_like s (dL->L _ (HsApp _ lhs _)) = looks_like s lhs looks_like _ _ = False foreign_RDR = mkUnqual varName (fsLit "foreign") @@ -1259,13 +1294,13 @@ checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr -- not be any OpApps inside the e's 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 noExt bang arg1) : argns) +splitBang (dL->L _ (OpApp _ l_arg bang@(dL->L _ (HsVar _ (dL->L _ op))) r_arg)) + | op == bang_RDR = Just (l_arg, cL l' (SectionR noExt bang arg1) : argns) where l' = combineLocs bang arg1 (arg1,argns) = split_bang r_arg [] - split_bang (L _ (HsApp _ f e)) es = split_bang f (e:es) - split_bang e es = (e,es) + split_bang (dL->L _ (HsApp _ f e)) es = split_bang f (e:es) + split_bang e es = (e,es) splitBang _ = Nothing -- See Note [isFunLhs vs mergeDataCon] @@ -1285,47 +1320,47 @@ isFunLhs :: LHsExpr GhcPs isFunLhs e = go e [] [] where - go (L loc (HsVar _ (L _ f))) es ann - | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, ann)) - go (L _ (HsApp _ f e)) es ann = go f (e:es) ann - go (L l (HsPar _ e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l) + go (dL->L loc (HsVar _ (dL->L _ f))) es ann + | not (isRdrDataCon f) = return (Just (cL loc f, Prefix, es, ann)) + go (dL->L _ (HsApp _ f e)) es ann = go f (e:es) ann + go (dL->L l (HsPar _ e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l) -- Things of the form `!x` are also FunBinds -- See Note [FunBind vs PatBind] - go (L _ (SectionR _ (L _ (HsVar _ (L _ bang))) (L l (HsVar _ (L _ var))))) - [] ann + go (dL->L _ (SectionR _ (dL->L _ (HsVar _ (dL->L _ bang))) + (dL->L l (HsVar _ (L _ var))))) [] ann | bang == bang_RDR - , not (isRdrDataCon var) = return (Just (L l var, Prefix, [], ann)) - - -- For infix function defns, there should be only one infix *function* - -- (though there may be infix *datacons* involved too). So we don't - -- need fixity info to figure out which function is being defined. - -- a `K1` b `op` c `K2` d - -- must parse as - -- (a `K1` b) `op` (c `K2` d) - -- The renamer checks later that the precedences would yield such a parse. - -- - -- There is a complication to deal with bang patterns. - -- - -- ToDo: what about this? - -- x + 1 `op` y = ... - - go e@(L loc (OpApp _ l (L loc' (HsVar _ (L _ op))) r)) es ann + , not (isRdrDataCon var) = return (Just (cL l var, Prefix, [], ann)) + + -- For infix function defns, there should be only one infix *function* + -- (though there may be infix *datacons* involved too). So we don't + -- need fixity info to figure out which function is being defined. + -- a `K1` b `op` c `K2` d + -- must parse as + -- (a `K1` b) `op` (c `K2` d) + -- The renamer checks later that the precedences would yield such a parse. + -- + -- There is a complication to deal with bang patterns. + -- + -- ToDo: what about this? + -- x + 1 `op` y = ... + + go e@(L loc (OpApp _ l (dL->L loc' (HsVar _ (dL->L _ op))) r)) es ann | Just (e',es') <- splitBang e = do { bang_on <- extension bangPatEnabled ; if bang_on then go e' (es' ++ es) ann - else return (Just (L loc' op, Infix, (l:r:es), ann)) } + else return (Just (cL loc' op, Infix, (l:r:es), ann)) } -- No bangs; behave just like the next case | not (isRdrDataCon op) -- We have found the function! - = return (Just (L loc' op, Infix, (l:r:es), ann)) + = return (Just (cL loc' op, Infix, (l:r:es), ann)) | otherwise -- Infix data con; keep going = do { mb_l <- go l es ann ; case mb_l of Just (op', Infix, j : k : es', ann') -> return (Just (op', Infix, j : op_app : es', ann')) where - op_app = L loc (OpApp noExt k - (L loc' (HsVar noExt (L loc' op))) r) + op_app = cL loc (OpApp noExt k + (cL loc' (HsVar noExt (cL loc' op))) r) _ -> return Nothing } go _ _ _ = return Nothing @@ -1355,20 +1390,20 @@ pStrictMark -> Maybe ( Located HsSrcBang {- a strictness/upnackedness marker -} , [AddAnn] , [Located TyEl] {- remaining TyEl -}) -pStrictMark (L l1 x1 : L l2 x2 : xs) +pStrictMark ((dL->L l1 x1) : (dL->L l2 x2) : xs) | Just (strAnnId, str) <- tyElStrictness x1 , TyElUnpackedness (unpkAnns, prag, unpk) <- x2 - = Just ( L (combineSrcSpans l1 l2) (HsSrcBang prag unpk str) + = Just ( cL (combineSrcSpans l1 l2) (HsSrcBang prag unpk str) , unpkAnns ++ [\s -> addAnnotation s strAnnId l1] , xs ) -pStrictMark (L l x1 : xs) +pStrictMark ((dL->L l x1) : xs) | Just (strAnnId, str) <- tyElStrictness x1 - = Just ( L l (HsSrcBang NoSourceText NoSrcUnpack str) + = Just ( cL l (HsSrcBang NoSourceText NoSrcUnpack str) , [\s -> addAnnotation s strAnnId l] , xs ) -pStrictMark (L l x1 : xs) +pStrictMark ((dL->L l x1) : xs) | TyElUnpackedness (anns, prag, unpk) <- x1 - = Just ( L l (HsSrcBang prag unpk NoSrcStrict) + = Just ( cL l (HsSrcBang prag unpk NoSrcStrict) , anns , xs ) pStrictMark _ = Nothing @@ -1380,13 +1415,13 @@ pBangTy , LHsType GhcPs {- the resulting BangTy -} , P () {- add annotations -} , [Located TyEl] {- remaining TyEl -}) -pBangTy lt@(L l1 _) xs = +pBangTy lt@(dL->L l1 _) xs = case pStrictMark xs of Nothing -> (False, lt, pure (), xs) - Just (L l2 strictMark, anns, xs') -> + Just (dL->L l2 strictMark, anns, xs') -> let bl = combineSrcSpans l1 l2 bt = HsBangTy noExt strictMark lt - in (True, L bl bt, addAnnsAt bl anns, xs') + in (True, cL bl bt, addAnnsAt bl anns, xs') -- | Merge a /reversed/ and /non-empty/ soup of operators and operands -- into a type. @@ -1401,8 +1436,8 @@ pBangTy lt@(L l1 _) xs = -- -- See Note [Parsing data constructors is hard] mergeOps :: [Located TyEl] -> P (LHsType GhcPs) -mergeOps (L l1 (TyElOpd t) : xs) - | (_, t', addAnns, xs') <- pBangTy (L l1 t) xs +mergeOps ((dL->L l1 (TyElOpd t)) : xs) + | (_, t', addAnns, xs') <- pBangTy (cL l1 t) xs , null xs' -- We accept a BangTy only when there are no preceding TyEl. = addAnns >> return t' mergeOps all_xs = go (0 :: Int) [] id all_xs @@ -1412,14 +1447,14 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs -- clause [unpk]: -- handle (NO)UNPACK pragmas - go k acc ops_acc (L l (TyElUnpackedness (anns, unpkSrc, unpk)):xs) = + go k acc ops_acc ((dL->L l (TyElUnpackedness (anns, unpkSrc, unpk))):xs) = if not (null acc) && null xs then do { let a = ops_acc (mergeAcc acc) strictMark = HsSrcBang unpkSrc unpk NoSrcStrict bl = combineSrcSpans l (getLoc a) bt = HsBangTy noExt strictMark a ; addAnnsAt bl anns - ; return (L bl bt) } + ; return (cL bl bt) } else parseErrorSDoc l unpkError where unpkSDoc = case unpkSrc of @@ -1434,57 +1469,63 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs -- clause [doc]: -- we do not expect to encounter any docs - go _ _ _ (L l (TyElDocPrev _):_) = + go _ _ _ ((dL->L l (TyElDocPrev _)):_) = failOpDocPrev l -- to improve error messages, we do a bit of guesswork to determine if the -- user intended a '!' or a '~' as a strictness annotation - go k acc ops_acc (L l x : xs) + go k acc ops_acc ((dL->L l x) : xs) | Just (_, str) <- tyElStrictness x , let guess [] = True - guess (L _ (TyElOpd _):_) = False - guess (L _ (TyElOpr _):_) = True - guess (L _ (TyElTilde):_) = True - guess (L _ (TyElBang):_) = True - guess (L _ (TyElUnpackedness _):_) = True - guess (L _ (TyElDocPrev _):xs') = guess xs' + guess ((dL->L _ (TyElOpd _)):_) = False + guess ((dL->L _ (TyElOpr _)):_) = True + guess ((dL->L _ (TyElTilde)):_) = True + guess ((dL->L _ (TyElBang)):_) = True + guess ((dL->L _ (TyElUnpackedness _)):_) = True + guess ((dL->L _ (TyElDocPrev _)):xs') = guess xs' + guess _ = panic "mergeOps.go.guess: Impossible Match" + -- due to #15884 in guess xs = if not (null acc) && (k > 1 || length acc > 1) - then failOpStrictnessCompound (L l str) (ops_acc (mergeAcc acc)) - else failOpStrictnessPosition (L l str) + then failOpStrictnessCompound (cL l str) (ops_acc (mergeAcc acc)) + else failOpStrictnessPosition (cL l str) -- clause [opr]: -- when we encounter an operator, we must have accumulated -- something for its rhs, and there must be something left -- to build its lhs. - go k acc ops_acc (L l (TyElOpr op):xs) = + go k acc ops_acc ((dL->L l (TyElOpr op)):xs) = if null acc || null (filter isTyElOpd xs) - then failOpFewArgs (L l op) + then failOpFewArgs (cL l op) else do { let a = mergeAcc acc - ; go (k + 1) [] (\c -> mkLHsOpTy c (L l op) (ops_acc a)) xs } + ; go (k + 1) [] (\c -> mkLHsOpTy c (cL l op) (ops_acc a)) xs } where - isTyElOpd (L _ (TyElOpd _)) = True + isTyElOpd (dL->L _ (TyElOpd _)) = True isTyElOpd _ = False -- clause [opr.1]: interpret 'TyElTilde' as an operator - go k acc ops_acc (L l TyElTilde:xs) = + go k acc ops_acc ((dL->L l TyElTilde):xs) = let op = eqTyCon_RDR - in go k acc ops_acc (L l (TyElOpr op):xs) + in go k acc ops_acc (cL l (TyElOpr op):xs) -- clause [opr.2]: interpret 'TyElBang' as an operator - go k acc ops_acc (L l TyElBang:xs) = + go k acc ops_acc ((dL->L l TyElBang):xs) = let op = mkUnqual tcClsName (fsLit "!") - in go k acc ops_acc (L l (TyElOpr op):xs) + in go k acc ops_acc (cL l (TyElOpr op):xs) -- clause [opd]: -- whenever an operand is encountered, it is added to the accumulator - go k acc ops_acc (L l (TyElOpd a):xs) = go k (L l a:acc) ops_acc xs + go k acc ops_acc ((dL->L l (TyElOpd a)):xs) = go k (cL l a:acc) ops_acc xs -- clause [end]: -- See Note [Non-empty 'acc' in mergeOps clause [end]] go _ acc ops_acc [] = return (ops_acc (mergeAcc acc)) + go _ _ _ _ = panic "mergeOps.go: Impossible Match" + -- due to #15884 + + mergeAcc [] = panic "mergeOps.mergeAcc: empty input" mergeAcc (x:xs) = mkHsAppTys x xs @@ -1542,12 +1583,12 @@ Therefore, it is safe to omit a check for non-emptiness of 'acc' in clause -} pInfixSide :: [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl]) -pInfixSide (L l (TyElOpd t):xs) - | (True, t', addAnns, xs') <- pBangTy (L l t) xs +pInfixSide ((dL->L l (TyElOpd t)):xs) + | (True, t', addAnns, xs') <- pBangTy (cL l t) xs = Just (t', addAnns, xs') -pInfixSide (L l1 (TyElOpd t1):xs1) = go [L l1 t1] xs1 +pInfixSide ((dL->L l1 (TyElOpd t1)):xs1) = go [cL l1 t1] xs1 where - go acc (L l (TyElOpd t):xs) = go (L l t:acc) xs + go acc ((dL->L l (TyElOpd t)):xs) = go (cL l t:acc) xs go acc xs = Just (mergeAcc acc, pure (), xs) mergeAcc [] = panic "pInfixSide.mergeAcc: empty input" mergeAcc (x:xs) = mkHsAppTys x xs @@ -1556,8 +1597,8 @@ pInfixSide _ = Nothing pDocPrev :: [Located TyEl] -> (Maybe LHsDocString, [Located TyEl]) pDocPrev = go Nothing where - go mTrailingDoc (L l (TyElDocPrev doc):xs) = - go (mTrailingDoc `mplus` Just (L l doc)) xs + go mTrailingDoc ((dL->L l (TyElDocPrev doc)):xs) = + go (mTrailingDoc `mplus` Just (cL l doc)) xs go mTrailingDoc xs = (mTrailingDoc, xs) orErr :: Maybe a -> b -> Either b a @@ -1655,7 +1696,7 @@ mergeDataCon all_xs = -- A -- ^ Comment on A -- B -- ^ Comment on B (singleDoc == False) singleDoc = isJust mTrailingDoc && - null [ () | L _ (TyElDocPrev _) <- all_xs' ] + null [ () | (dL->L _ (TyElDocPrev _)) <- all_xs' ] -- The result of merging the list of reversed TyEl into a -- data constructor, along with [AddAnn]. @@ -1677,36 +1718,36 @@ mergeDataCon all_xs = trailingFieldDoc | singleDoc = Nothing | otherwise = mTrailingDoc - goFirst [ L l (TyElOpd (HsTyVar _ _ (L _ tc))) ] + goFirst [ dL->L l (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ] = do { data_con <- tyConToDataCon l tc ; return (pure (), (data_con, PrefixCon [], mTrailingDoc)) } - goFirst (L l (TyElOpd (HsRecTy _ fields)):xs) + goFirst ((dL->L l (TyElOpd (HsRecTy _ fields))):xs) | (mConDoc, xs') <- pDocPrev xs - , [ L l' (TyElOpd (HsTyVar _ _ (L _ tc))) ] <- xs' + , [ dL->L l' (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ] <- xs' = do { data_con <- tyConToDataCon l' tc ; let mDoc = mTrailingDoc `mplus` mConDoc - ; return (pure (), (data_con, RecCon (L l fields), mDoc)) } - goFirst [L l (TyElOpd (HsTupleTy _ HsBoxedOrConstraintTuple ts))] + ; return (pure (), (data_con, RecCon (cL l fields), mDoc)) } + goFirst [dL->L l (TyElOpd (HsTupleTy _ HsBoxedOrConstraintTuple ts))] = return ( pure () - , ( L l (getRdrName (tupleDataCon Boxed (length ts))) + , ( cL l (getRdrName (tupleDataCon Boxed (length ts))) , PrefixCon ts , mTrailingDoc ) ) - goFirst (L l (TyElOpd t):xs) - | (_, t', addAnns, xs') <- pBangTy (L l t) xs + goFirst ((dL->L l (TyElOpd t)):xs) + | (_, t', addAnns, xs') <- pBangTy (cL l t) xs = go addAnns Nothing [mkLHsDocTyMaybe t' trailingFieldDoc] xs' goFirst xs = go (pure ()) mTrailingDoc [] xs - go addAnns mLastDoc ts [ L l (TyElOpd (HsTyVar _ _ (L _ tc))) ] + go addAnns mLastDoc ts [ dL->L l (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ] = do { data_con <- tyConToDataCon l tc ; return (addAnns, (data_con, PrefixCon ts, mkConDoc mLastDoc)) } - go addAnns mLastDoc ts (L l (TyElDocPrev doc):xs) = - go addAnns (mLastDoc `mplus` Just (L l doc)) ts xs - go addAnns mLastDoc ts (L l (TyElOpd t):xs) - | (_, t', addAnns', xs') <- pBangTy (L l t) xs + go addAnns mLastDoc ts ((dL->L l (TyElDocPrev doc)):xs) = + go addAnns (mLastDoc `mplus` Just (cL l doc)) ts xs + go addAnns mLastDoc ts ((dL->L l (TyElOpd t)):xs) + | (_, t', addAnns', xs') <- pBangTy (cL l t) xs , t'' <- mkLHsDocTyMaybe t' mLastDoc = go (addAnns >> addAnns') Nothing (t'':ts) xs' - go _ _ _ (L _ (TyElOpr _):_) = + go _ _ _ ((dL->L _ (TyElOpr _)):_) = -- Encountered an operator: backtrack to the beginning and attempt -- to parse as an infix definition. goInfix @@ -1723,7 +1764,7 @@ mergeDataCon all_xs = ; (rhs_t, rhs_addAnns, xs1) <- pInfixSide xs0 `orErr` malformedErr ; let (mOpDoc, xs2) = pDocPrev xs1 ; (op, xs3) <- case xs2 of - L l (TyElOpr op) : xs3 -> + (dL->L l (TyElOpr op)) : xs3 -> do { data_con <- tyConToDataCon l op ; return (data_con, xs3) } _ -> Left malformedErr @@ -1764,7 +1805,7 @@ 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) +locMap f (dL->L l a) = f l a >>= (\b -> return $ cL l b) checkCmd :: SrcSpan -> HsExpr GhcPs -> P (HsCmd GhcPs) checkCmd _ (HsArrApp _ e1 e2 haat b) = @@ -1785,16 +1826,16 @@ checkCmd _ (HsIf _ cf ep et ee) = do return $ HsCmdIf noExt cf ep pt pe checkCmd _ (HsLet _ lb e) = checkCommand e >>= (\c -> return $ HsCmdLet noExt lb c) -checkCmd _ (HsDo _ DoExpr (L l stmts)) = +checkCmd _ (HsDo _ DoExpr (dL->L l stmts)) = mapM checkCmdLStmt stmts >>= - (\ss -> return $ HsCmdDo noExt (L l ss) ) + (\ss -> return $ HsCmdDo noExt (cL l ss) ) checkCmd _ (OpApp _ eLeft op eRight) = do -- OpApp becomes a HsCmdArrForm with a (Just fixity) in it c1 <- checkCommand eLeft c2 <- checkCommand eRight - let arg1 = L (getLoc c1) $ HsCmdTop noExt c1 - arg2 = L (getLoc c2) $ HsCmdTop noExt c2 + let arg1 = cL (getLoc c1) $ HsCmdTop noExt c1 + arg2 = cL (getLoc c2) $ HsCmdTop noExt c2 return $ HsCmdArrForm noExt op Infix Nothing [arg1, arg2] checkCmd l e = cmdFail l e @@ -1818,9 +1859,10 @@ checkCmdStmt l stmt = cmdStmtFail l stmt checkCmdMatchGroup :: MatchGroup GhcPs (LHsExpr GhcPs) -> P (MatchGroup GhcPs (LHsCmd GhcPs)) -checkCmdMatchGroup mg@(MG { mg_alts = L l ms }) = do +checkCmdMatchGroup mg@(MG { mg_alts = (dL->L l ms) }) = do ms' <- mapM (locMap $ const convert) ms - return $ mg { mg_ext = noExt, mg_alts = L l ms' } + return $ mg { mg_ext = noExt + , mg_alts = cL l ms' } where convert match@(Match { m_grhss = grhss }) = do grhss' <- checkCmdGRHSs grhss return $ match { m_ext = noExt, m_grhss = grhss'} @@ -1858,7 +1900,7 @@ checkPrecP :: Located (SourceText,Int) -- ^ precedence -> Located (OrdList (Located RdrName)) -- ^ operators -> P () -checkPrecP (L l (_,i)) (L _ ol) +checkPrecP (dL->L l (_,i)) (dL->L _ ol) | 0 <= i, i <= maxPrecedence = pure () | all specialOp ol = pure () | otherwise = parseErrorSDoc l (text ("Precedence out of range: " ++ show i)) @@ -1872,10 +1914,10 @@ mkRecConstrOrUpdate -> ([LHsRecField GhcPs (LHsExpr GhcPs)], Bool) -> P (HsExpr GhcPs) -mkRecConstrOrUpdate (L l (HsVar _ (L _ c))) _ (fs,dd) +mkRecConstrOrUpdate (dL->L l (HsVar _ (dL->L _ c))) _ (fs,dd) | isRdrDataCon c - = return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd)) -mkRecConstrOrUpdate exp@(L l _) _ (fs,dd) + = return (mkRdrRecordCon (cL l c) (mk_rec_fields fs dd)) +mkRecConstrOrUpdate exp@(dL->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)) @@ -1891,13 +1933,16 @@ mkRdrRecordCon con flds 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_fields fs True = HsRecFields { rec_flds = fs + , rec_dotdot = Just (length fs) } mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs -mk_rec_upd_field (HsRecField (L loc (FieldOcc _ rdr)) arg pun) +mk_rec_upd_field (HsRecField (dL->L loc (FieldOcc _ rdr)) arg pun) = HsRecField (L loc (Unambiguous noExt rdr)) arg pun -mk_rec_upd_field (HsRecField (L _ (XFieldOcc _)) _ _) +mk_rec_upd_field (HsRecField (dL->L _ (XFieldOcc _)) _ _) = panic "mk_rec_upd_field" +mk_rec_upd_field (HsRecField _ _ _) + = panic "mk_rec_upd_field: Impossible Match" -- due to #15884 mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation -> InlinePragma @@ -1927,12 +1972,12 @@ mkImport :: Located CCallConv -> (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 - L _ CApiConv -> mkCImport - L _ StdCallConv -> mkCImport - L _ PrimCallConv -> mkOtherImport - L _ JavaScriptCallConv -> mkOtherImport + case unLoc cconv of + CCallConv -> mkCImport + CApiConv -> mkCImport + StdCallConv -> mkCImport + PrimCallConv -> mkOtherImport + JavaScriptCallConv -> mkOtherImport where -- Parse a C-like entity string of the following form: -- "[static] [chname] [&] [cid]" | "dynamic" | "wrapper" @@ -1940,7 +1985,7 @@ mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) = -- name (cf section 8.5.1 in Haskell 2010 report). mkCImport = do let e = unpackFS entity - case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of + case parseCImport cconv safety (mkExtName (unLoc v)) e (cL loc esrc) of Nothing -> parseErrorSDoc loc (text "Malformed entity string") Just importSpec -> returnSpec importSpec @@ -1952,7 +1997,7 @@ mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) = then mkExtName (unLoc v) else entity funcTarget = CFunction (StaticTarget esrc entity' Nothing True) - importSpec = CImport cconv safety Nothing funcTarget (L loc esrc) + importSpec = CImport cconv safety Nothing funcTarget (cL loc esrc) returnSpec spec = return $ ForD noExt $ ForeignImport { fd_i_ext = noExt @@ -1997,20 +2042,21 @@ parseCImport cconv safety nm str sourceText = mk h n = CImport cconv safety h n sourceText - hdr_char c = not (isSpace c) -- header files are filenames, which can contain - -- pretty much any char (depending on the platform), - -- so just accept any non-space character + hdr_char c = not (isSpace c) + -- header files are filenames, which can contain + -- pretty much any char (depending on the platform), + -- so just accept any non-space character id_first_char c = isAlpha c || c == '_' id_char c = isAlphaNum c || c == '_' cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid) - +++ (do isFun <- case cconv of - L _ CApiConv -> + +++ (do isFun <- case unLoc cconv of + CApiConv -> option True (do token "value" skipSpaces return False) - _ -> return True + _ -> return True cid' <- cid return (CFunction (StaticTarget NoSourceText cid' Nothing isFun))) @@ -2026,11 +2072,11 @@ parseCImport cconv safety nm str sourceText = mkExport :: Located CCallConv -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs) -> P (HsDecl GhcPs) -mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty) +mkExport (dL->L lc cconv) (dL->L le (StringLiteral esrc entity), v, ty) = return $ ForD noExt $ ForeignExport { fd_e_ext = noExt, fd_name = v, fd_sig_ty = ty - , fd_fe = CExport (L lc (CExportStatic esrc entity' cconv)) - (L le esrc) } + , fd_fe = CExport (cL lc (CExportStatic esrc entity' cconv)) + (cL le esrc) } where entity' | nullFS entity = mkExtName (unLoc v) | otherwise = entity @@ -2057,16 +2103,16 @@ data ImpExpQcSpec = ImpExpQcName (Located RdrName) | ImpExpQcWildcard mkModuleImpExp :: Located ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs) -mkModuleImpExp (L l specname) subs = +mkModuleImpExp (dL->L l specname) subs = case subs of ImpExpAbs | isVarNameSpace (rdrNameSpace name) - -> return $ IEVar noExt (L l (ieNameFromSpec specname)) - | otherwise -> IEThingAbs noExt . L l <$> nameT - ImpExpAll -> IEThingAll noExt . L l <$> nameT - ImpExpList xs -> - (\newName -> IEThingWith noExt (L l newName) NoIEWildcard (wrapped xs) []) - <$> nameT + -> return $ IEVar noExt (cL l (ieNameFromSpec specname)) + | otherwise -> IEThingAbs noExt . cL l <$> nameT + ImpExpAll -> IEThingAll noExt . cL l <$> nameT + ImpExpList xs -> + (\newName -> IEThingWith noExt (cL l newName) + NoIEWildcard (wrapped xs) []) <$> nameT ImpExpAllWith xs -> do allowed <- extension patternSynonymsEnabled if allowed @@ -2076,7 +2122,8 @@ mkModuleImpExp (L l specname) subs = (findIndex isImpExpQcWildcard withs) ies = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs in (\newName - -> IEThingWith noExt (L l newName) pos ies []) <$> nameT + -> IEThingWith noExt (cL l newName) pos ies []) + <$> nameT else parseErrorSDoc l (text "Illegal export form (use PatternSynonyms to enable)") where @@ -2087,8 +2134,9 @@ mkModuleImpExp (L l specname) subs = (text "Expecting a type constructor but found a variable," <+> quotes (ppr name) <> text "." $$ if isSymOcc $ rdrNameOcc name - then text "If" <+> quotes (ppr name) <+> text "is a type constructor" - <+> text "then enable ExplicitNamespaces and use the 'type' keyword." + then text "If" <+> quotes (ppr name) + <+> text "is a type constructor" + <+> text "then enable ExplicitNamespaces and use the 'type' keyword." else empty) else return $ ieNameFromSpec specname @@ -2100,7 +2148,7 @@ mkModuleImpExp (L l specname) subs = ieNameFromSpec (ImpExpQcType ln) = IEType ln ieNameFromSpec (ImpExpQcWildcard) = panic "ieName got wildcard" - wrapped = map (\(L l x) -> L l (ieNameFromSpec x)) + wrapped = map (onHasSrcSpan ieNameFromSpec) mkTypeImpExp :: Located RdrName -- TcCls or Var name space -> P (Located RdrName) @@ -2112,8 +2160,8 @@ mkTypeImpExp name = (text "Illegal keyword 'type' (use ExplicitNamespaces to enable)") checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs]) -checkImportSpec ie@(L _ specs) = - case [l | (L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of +checkImportSpec ie@(dL->L _ specs) = + case [l | (dL->L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of [] -> return ie (l:_) -> importSpecError l where @@ -2125,7 +2173,7 @@ checkImportSpec ie@(L _ specs) = -- In the correct order mkImpExpSubSpec :: [Located ImpExpQcSpec] -> P ([AddAnn], ImpExpSubSpec) mkImpExpSubSpec [] = return ([], ImpExpList []) -mkImpExpSubSpec [L _ ImpExpQcWildcard] = +mkImpExpSubSpec [dL->L _ ImpExpQcWildcard] = return ([], ImpExpAll) mkImpExpSubSpec xs = if (any (isImpExpQcWildcard . unLoc) xs) @@ -2160,7 +2208,7 @@ warnStarBndr span = addWarning Opt_WarnStarBinder span msg $$ text " including the definition module, you must qualify it." failOpFewArgs :: Located RdrName -> P a -failOpFewArgs (L loc op) = +failOpFewArgs (dL->L loc op) = do { star_is_type <- extension starIsTypeEnabled ; let msg = too_few $$ starInfo star_is_type op ; parseErrorSDoc loc msg } @@ -2173,14 +2221,14 @@ failOpDocPrev loc = parseErrorSDoc loc msg msg = text "Unexpected documentation comment." failOpStrictnessCompound :: Located SrcStrictness -> LHsType GhcPs -> P a -failOpStrictnessCompound (L _ str) (L loc ty) = parseErrorSDoc loc msg +failOpStrictnessCompound (dL->L _ str) (dL->L loc ty) = parseErrorSDoc loc msg where msg = text "Strictness annotation applied to a compound type." $$ text "Did you mean to add parentheses?" $$ nest 2 (ppr str <> parens (ppr ty)) failOpStrictnessPosition :: Located SrcStrictness -> P a -failOpStrictnessPosition (L loc _) = parseErrorSDoc loc msg +failOpStrictnessPosition (dL->L loc _) = parseErrorSDoc loc msg where msg = text "Strictness annotation cannot appear in this position." @@ -2210,24 +2258,26 @@ mkSumOrTuple boxity _ (Tuple es) = return (ExplicitTuple noExt es boxity) -- Sum mkSumOrTuple Unboxed _ (Sum alt arity e) = return (ExplicitSum noExt 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)) +mkSumOrTuple Boxed l (Sum alt arity (dL->L _ e)) = + parseErrorSDoc l (hang (text "Boxed sums not supported:") 2 + (ppr_boxed_sum alt arity e)) where 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 ")" + text "(" <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt) + <+> text ")" ppr_bars n = hsep (replicate n (Outputable.char '|')) mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs mkLHsOpTy x op y = let loc = getLoc x `combineSrcSpans` getLoc op `combineSrcSpans` getLoc y - in L loc (mkHsOpTy x op y) + in cL loc (mkHsOpTy x op y) mkLHsDocTy :: LHsType GhcPs -> LHsDocString -> LHsType GhcPs mkLHsDocTy t doc = let loc = getLoc t `combineSrcSpans` getLoc doc - in L loc (HsDocTy noExt t doc) + in cL loc (HsDocTy noExt t doc) mkLHsDocTyMaybe :: LHsType GhcPs -> Maybe LHsDocString -> LHsType GhcPs mkLHsDocTyMaybe t = maybe t (mkLHsDocTy t) diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs index 60dead089b..ade67b7a49 100644 --- a/compiler/rename/RnBinds.hs +++ b/compiler/rename/RnBinds.hs @@ -469,11 +469,11 @@ rnBind _ bind@(PatBind { pat_lhs = pat ok_nobind_pat = -- See Note [Pattern bindings that bind no variables] - case pat of - L _ (WildPat {}) -> True - L _ (BangPat {}) -> True -- #9127, #13646 - L _ (SplicePat {}) -> True - _ -> False + case unLoc pat of + WildPat {} -> True + BangPat {} -> True -- #9127, #13646 + SplicePat {} -> True + _ -> False -- Warn if the pattern binds no variables -- See Note [Pattern bindings that bind no variables] diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index 46ac6b8724..cc69e43603 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -14,6 +14,7 @@ free variables. {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module RnExpr ( rnLExpr, rnExpr, rnStmts @@ -1412,7 +1413,7 @@ segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later where (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later new_stmt | non_rec = head ss - | otherwise = L (getLoc (head ss)) rec_stmt + | otherwise = cL (getLoc (head ss)) rec_stmt rec_stmt = empty_rec_stmt { recS_stmts = ss , recS_later_ids = nameSetElemsStable used_later , recS_rec_ids = nameSetElemsStable fwds } @@ -1811,9 +1812,9 @@ parallel" in an ApplicativeStmt, but doesn't otherwise affect what we can do with the rest of the statements in the same "do" expression. -} -isStrictPattern :: LPat id -> Bool -isStrictPattern (L _ pat) = - case pat of +isStrictPattern :: LPat (GhcPass p) -> Bool +isStrictPattern lpat = + case unLoc lpat of WildPat{} -> False VarPat{} -> False LazyPat{} -> False diff --git a/compiler/rename/RnFixity.hs b/compiler/rename/RnFixity.hs index f1bfb380a5..19d8bb4c5a 100644 --- a/compiler/rename/RnFixity.hs +++ b/compiler/rename/RnFixity.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ViewPatterns #-} + {- This module contains code which maintains and manipulates the @@ -78,8 +80,8 @@ addLocalFixities mini_fix_env names thing_inside where find_fixity name = case lookupFsEnv mini_fix_env (occNameFS occ) of - Just (L _ fix) -> Just (name, FixItem occ fix) - Nothing -> Nothing + Just lfix -> Just (name, FixItem occ (unLoc lfix)) + Nothing -> Nothing where occ = nameOccName name @@ -171,7 +173,7 @@ lookupFixityRn_help' name occ --------------- lookupTyFixityRn :: Located Name -> RnM Fixity -lookupTyFixityRn (L _ n) = lookupFixityRn n +lookupTyFixityRn = lookupFixityRn . unLoc -- | Look up the fixity of a (possibly ambiguous) occurrence of a record field -- selector. We use 'lookupFixityRn'' so that we can specifiy the 'OccName' as @@ -179,9 +181,9 @@ lookupTyFixityRn (L _ n) = lookupFixityRn n -- 'Name' if @DuplicateRecordFields@ is in use (Trac #1173). If there are -- multiple possible selectors with different fixities, generate an error. lookupFieldFixityRn :: AmbiguousFieldOcc GhcRn -> RnM Fixity -lookupFieldFixityRn (Unambiguous n (L _ rdr)) - = lookupFixityRn' n (rdrNameOcc rdr) -lookupFieldFixityRn (Ambiguous _ (L _ rdr)) = get_ambiguous_fixity rdr +lookupFieldFixityRn (Unambiguous n lrdr) + = lookupFixityRn' n (rdrNameOcc (unLoc lrdr)) +lookupFieldFixityRn (Ambiguous _ lrdr) = get_ambiguous_fixity (unLoc lrdr) where get_ambiguous_fixity :: RdrName -> RnM Fixity get_ambiguous_fixity rdr_name = do diff --git a/compiler/rename/RnHsDoc.hs b/compiler/rename/RnHsDoc.hs index ac2589df4e..348f87fca5 100644 --- a/compiler/rename/RnHsDoc.hs +++ b/compiler/rename/RnHsDoc.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ViewPatterns #-} module RnHsDoc ( rnHsDoc, rnLHsDoc, rnMbLHsDoc ) where @@ -16,10 +17,9 @@ rnMbLHsDoc mb_doc = case mb_doc of Nothing -> return Nothing rnLHsDoc :: LHsDocString -> RnM LHsDocString -rnLHsDoc (L pos doc) = do +rnLHsDoc (dL->L pos doc) = do doc' <- rnHsDoc doc - return (L pos doc') + return (cL pos doc') rnHsDoc :: HsDocString -> RnM HsDocString rnHsDoc = pure - diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs index a80a6982eb..ba19c4ebff 100644 --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs @@ -10,9 +10,12 @@ general, all of these functions return a renamed thing, and a set of free variables. -} -{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} module RnPat (-- main entry points rnPat, rnPats, rnBindPat, rnPatAndThen, @@ -126,12 +129,13 @@ liftCpsFV rn_thing = CpsRn (\k -> do { (v,fvs1) <- rn_thing ; (r,fvs2) <- k v ; return (r, fvs1 `plusFV` fvs2) }) -wrapSrcSpanCps :: (a -> CpsRn b) -> Located a -> CpsRn (Located b) +wrapSrcSpanCps :: (HasSrcSpan a, HasSrcSpan b) => + (SrcSpanLess a -> CpsRn (SrcSpanLess b)) -> a -> CpsRn b -- Set the location, and also wrap it around the value returned -wrapSrcSpanCps fn (L loc a) +wrapSrcSpanCps fn (dL->L loc a) = CpsRn (\k -> setSrcSpan loc $ unCpsRn (fn a) $ \v -> - k (L loc v)) + k (cL loc v)) lookupConCps :: Located RdrName -> CpsRn (Located Name) lookupConCps con_rdr @@ -216,9 +220,9 @@ rnHsSigCps :: LHsSigWcType GhcPs -> CpsRn (LHsSigWcType GhcRn) rnHsSigCps sig = CpsRn (rnHsSigWcTypeScoped AlwaysBind PatCtx sig) newPatLName :: NameMaker -> Located RdrName -> CpsRn (Located Name) -newPatLName name_maker rdr_name@(L loc _) +newPatLName name_maker rdr_name@(dL->L loc _) = do { name <- newPatName name_maker rdr_name - ; return (L loc name) } + ; return (cL loc name) } newPatName :: NameMaker -> Located RdrName -> CpsRn Name newPatName (LamMk report_unused) rdr_name @@ -387,9 +391,10 @@ rnPatAndThen mk (LazyPat x pat) = do { pat' <- rnLPatAndThen mk pat ; return (LazyPat x pat') } rnPatAndThen mk (BangPat x pat) = do { pat' <- rnLPatAndThen mk pat ; return (BangPat x pat') } -rnPatAndThen mk (VarPat x (L l rdr)) = do { loc <- liftCps getSrcSpanM - ; name <- newPatName mk (L loc rdr) - ; return (VarPat x (L l name)) } +rnPatAndThen mk (VarPat x (dL->L l rdr)) + = do { loc <- liftCps getSrcSpanM + ; name <- newPatName mk (cL loc rdr) + ; return (VarPat x (cL l name)) } -- we need to bind pattern variables for view pattern expressions -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple) @@ -419,7 +424,7 @@ rnPatAndThen mk (LitPat x lit) where normal_lit = do { liftCps (rnLit lit); return (LitPat x (convertLit lit)) } -rnPatAndThen _ (NPat x (L l lit) mb_neg _eq) +rnPatAndThen _ (NPat x (dL->L l lit) mb_neg _eq) = do { (lit', mb_neg') <- liftCpsFV $ rnOverLit lit ; mb_neg' -- See Note [Negative zero] <- let negative = do { (neg, fvs) <- lookupSyntaxName negateName @@ -431,9 +436,9 @@ rnPatAndThen _ (NPat x (L l lit) mb_neg _eq) (Nothing, Nothing) -> positive (Just _ , Just _ ) -> positive ; eq' <- liftCpsFV $ lookupSyntaxName eqName - ; return (NPat x (L l lit') mb_neg' eq') } + ; return (NPat x (cL l lit') mb_neg' eq') } -rnPatAndThen mk (NPlusKPat x rdr (L l lit) _ _ _ ) +rnPatAndThen mk (NPlusKPat x rdr (dL->L l lit) _ _ _ ) = do { new_name <- newPatName mk rdr ; (lit', _) <- liftCpsFV $ rnOverLit lit -- See Note [Negative zero] -- We skip negateName as @@ -441,8 +446,8 @@ rnPatAndThen mk (NPlusKPat x rdr (L l lit) _ _ _ ) -- sense in n + k patterns ; minus <- liftCpsFV $ lookupSyntaxName minusName ; ge <- liftCpsFV $ lookupSyntaxName geName - ; return (NPlusKPat x (L (nameSrcSpan new_name) new_name) - (L l lit') lit' ge minus) } + ; return (NPlusKPat x (cL (nameSrcSpan new_name) new_name) + (cL l lit') lit' ge minus) } -- The Report says that n+k patterns must be in Integral rnPatAndThen mk (AsPat x rdr pat) @@ -529,16 +534,17 @@ rnHsRecPatsAndThen :: NameMaker -> Located Name -- Constructor -> HsRecFields GhcPs (LPat GhcPs) -> CpsRn (HsRecFields GhcRn (LPat GhcRn)) -rnHsRecPatsAndThen mk (L _ con) hs_rec_fields@(HsRecFields { rec_dotdot = dd }) +rnHsRecPatsAndThen mk (dL->L _ con) + hs_rec_fields@(HsRecFields { rec_dotdot = dd }) = do { flds <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) mkVarPat hs_rec_fields ; flds' <- mapM rn_field (flds `zip` [1..]) ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) } where - mkVarPat l n = VarPat noExt (L l n) - rn_field (L l fld, n') = do { arg' <- rnLPatAndThen (nested_mk dd mk n') - (hsRecFieldArg fld) - ; return (L l (fld { hsRecFieldArg = arg' })) } + mkVarPat l n = VarPat noExt (cL l n) + rn_field (dL->L l fld, n') = + do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hsRecFieldArg fld) + ; return (cL l (fld { hsRecFieldArg = arg' })) } -- Suppress unused-match reporting for fields introduced by ".." nested_mk Nothing mk _ = mk @@ -559,12 +565,12 @@ data HsRecFieldContext | HsRecFieldUpd rnHsRecFields - :: forall arg. + :: forall arg. HasSrcSpan arg => HsRecFieldContext - -> (SrcSpan -> RdrName -> arg) + -> (SrcSpan -> RdrName -> SrcSpanLess arg) -- When punning, use this to build a new field - -> HsRecFields GhcPs (Located arg) - -> RnM ([LHsRecField GhcRn (Located arg)], FreeVars) + -> HsRecFields GhcPs arg + -> RnM ([LHsRecField GhcRn arg], FreeVars) -- This surprisingly complicated pass -- a) looks up the field name (possibly using disambiguation) @@ -590,31 +596,37 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) HsRecFieldPat con -> Just con _ {- update -} -> Nothing - 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 - , hsRecPun = pun })) + rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs arg + -> RnM (LHsRecField GhcRn arg) + rn_fld pun_ok parent (dL->L l + (HsRecField + { hsRecFieldLbl = + (dL->L loc (FieldOcc _ (dL->L ll lbl))) + , hsRecFieldArg = arg + , hsRecPun = pun })) = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent lbl ; arg' <- if pun - then do { checkErr pun_ok (badPun (L loc lbl)) + then do { checkErr pun_ok (badPun (cL loc lbl)) -- Discard any module qualifier (#11662) ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) - ; return (L loc (mk_arg loc arg_rdr)) } + ; return (cL loc (mk_arg loc arg_rdr)) } else return arg - ; return (L l (HsRecField { hsRecFieldLbl - = L loc (FieldOcc sel (L ll lbl)) - , hsRecFieldArg = arg' - , hsRecPun = pun })) } - rn_fld _ _ (L _ (HsRecField (L _ (XFieldOcc _)) _ _)) + ; return (cL l (HsRecField + { hsRecFieldLbl = (cL loc (FieldOcc + sel (cL ll lbl))) + , hsRecFieldArg = arg' + , hsRecPun = pun })) } + rn_fld _ _ (dL->L _ (HsRecField (dL->L _ (XFieldOcc _)) _ _)) = panic "rnHsRecFields" + rn_fld _ _ _ = panic "rn_fld: Impossible Match" + -- due to #15884 + rn_dotdot :: Maybe Int -- See Note [DotDot fields] in HsPat -> Maybe Name -- The constructor (Nothing for an -- out of scope constructor) - -> [LHsRecField GhcRn (Located arg)] -- Explicit fields - -> RnM [LHsRecField GhcRn (Located arg)] -- Filled in .. fields + -> [LHsRecField GhcRn arg] -- Explicit fields + -> RnM [LHsRecField GhcRn arg] -- Filled in .. fields rn_dotdot (Just n) (Just con) flds -- ".." on record construction / pat match | not (isUnboundName con) -- This test is because if the constructor -- isn't in scope the constructor lookup will add @@ -648,9 +660,9 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) _other -> True ] ; addUsedGREs dot_dot_gres - ; return [ L loc (HsRecField - { hsRecFieldLbl = L loc (FieldOcc sel (L loc arg_rdr)) - , hsRecFieldArg = L loc (mk_arg loc arg_rdr) + ; return [ cL loc (HsRecField + { hsRecFieldLbl = cL loc (FieldOcc sel (cL loc arg_rdr)) + , hsRecFieldArg = cL loc (mk_arg loc arg_rdr) , hsRecPun = False }) | fl <- dot_dot_fields , let sel = flSelector fl @@ -695,25 +707,28 @@ rnHsRecUpdFields flds 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 })) + rn_fld pun_ok overload_ok (dL->L l (HsRecField { hsRecFieldLbl = dL->L loc f + , hsRecFieldArg = arg + , hsRecPun = pun })) = do { let lbl = rdrNameAmbiguousFieldOcc f ; sel <- setSrcSpan loc $ -- Defer renaming of overloaded fields to the typechecker -- See Note [Disambiguating record fields] in TcExpr if overload_ok - then do { mb <- lookupGlobalOccRn_overloaded overload_ok lbl + then do { mb <- lookupGlobalOccRn_overloaded + overload_ok lbl ; case mb of - Nothing -> do { addErr (unknownSubordinateErr doc lbl) - ; return (Right []) } + Nothing -> + do { addErr + (unknownSubordinateErr doc lbl) + ; return (Right []) } Just r -> return r } else fmap Left $ lookupGlobalOccRn lbl ; arg' <- if pun - then do { checkErr pun_ok (badPun (L loc lbl)) + then do { checkErr pun_ok (badPun (cL loc lbl)) -- Discard any module qualifier (#11662) ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) - ; return (L loc (HsVar noExt (L loc arg_rdr))) } + ; return (cL loc (HsVar noExt (cL loc arg_rdr))) } else return arg ; (arg'', fvs) <- rnLExpr arg' @@ -723,14 +738,14 @@ rnHsRecUpdFields flds Right _ -> fvs lbl' = case sel of Left sel_name -> - L loc (Unambiguous sel_name (L loc lbl)) + cL loc (Unambiguous sel_name (cL loc lbl)) Right [sel_name] -> - L loc (Unambiguous sel_name (L loc lbl)) - Right _ -> L loc (Ambiguous noExt (L loc lbl)) + cL loc (Unambiguous sel_name (cL loc lbl)) + Right _ -> cL loc (Ambiguous noExt (cL loc lbl)) - ; return (L l (HsRecField { hsRecFieldLbl = lbl' - , hsRecFieldArg = arg'' - , hsRecPun = pun }), fvs') } + ; return (cL l (HsRecField { hsRecFieldLbl = lbl' + , hsRecFieldArg = arg'' + , hsRecPun = pun }), fvs') } dup_flds :: [NE.NonEmpty RdrName] -- Each list represents a RdrName that occurred more than once @@ -797,7 +812,9 @@ rnLit _ = return () -- Integer-looking literal. generalizeOverLitVal :: OverLitVal -> OverLitVal generalizeOverLitVal (HsFractional (FL {fl_text=src,fl_neg=neg,fl_value=val})) - | denominator val == 1 = HsIntegral (IL {il_text=src,il_neg=neg,il_value=numerator val}) + | denominator val == 1 = HsIntegral (IL { il_text=src + , il_neg=neg + , il_value=numerator val}) generalizeOverLitVal lit = lit isNegativeZeroOverLit :: HsOverLit t -> Bool @@ -831,8 +848,8 @@ rnOverLit origLit ; (SyntaxExpr { syn_expr = from_thing_name }, fvs1) <- lookupSyntaxName std_name ; let rebindable = case from_thing_name of - HsVar _ (L _ v) -> v /= std_name - _ -> panic "rnOverLit" + HsVar _ lv -> (unLoc lv) /= std_name + _ -> panic "rnOverLit" ; let lit' = lit { ol_witness = from_thing_name , ol_ext = rebindable } ; if isNegativeZeroOverLit lit' diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index 5ecb1a68e7..7a205ba3b9 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -4,9 +4,11 @@ \section[RnSource]{Main pass of renamer} -} -{-# LANGUAGE CPP, ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module RnSource ( rnSrcDecls, addTcgDUs, findSplice @@ -280,13 +282,13 @@ rnSrcWarnDecls _ [] rnSrcWarnDecls bndr_set decls' = do { -- check for duplicates - ; mapM_ (\ dups -> let (L loc rdr :| (lrdr':_)) = dups + ; mapM_ (\ dups -> let ((dL->L loc rdr) :| (lrdr':_)) = dups in addErrAt loc (dupWarnDecl lrdr' rdr)) warn_rdr_dups ; pairs_s <- mapM (addLocM rn_deprec) decls ; return (WarnSome ((concat pairs_s))) } where - decls = concatMap (\(L _ d) -> wd_warnings d) decls' + decls = concatMap (wd_warnings . unLoc) decls' sig_ctxt = TopSigCtxt bndr_set @@ -299,8 +301,8 @@ rnSrcWarnDecls bndr_set decls' what = text "deprecation" - warn_rdr_dups = findDupRdrNames $ concatMap (\(L _ (Warning _ ns _)) -> ns) - decls + warn_rdr_dups = findDupRdrNames + $ concatMap (\(dL->L _ (Warning _ ns _)) -> ns) decls findDupRdrNames :: [Located RdrName] -> [NonEmpty (Located RdrName)] findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y)) @@ -311,9 +313,9 @@ findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc ( dupWarnDecl :: Located RdrName -> RdrName -> SDoc -- Located RdrName -> DeprecDecl RdrName -> SDoc -dupWarnDecl (L loc _) rdr_name +dupWarnDecl d rdr_name = vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name), - text "also at " <+> ppr loc] + text "also at " <+> ppr (getLoc d)] {- ********************************************************* @@ -476,9 +478,10 @@ checkCanonicalInstances cls poly_ty mbinds = do -- checkCanonicalMonadInstances | cls == applicativeClassName = do - forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do + forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do case mbind of - FunBind { fun_id = L _ name, fun_matches = mg } + FunBind { fun_id = (dL->L _ name) + , fun_matches = mg } | name == pureAName, isAliasMG mg == Just returnMName -> addWarnNonCanonicalMethod1 Opt_WarnNonCanonicalMonadInstances "pure" "return" @@ -490,9 +493,10 @@ checkCanonicalInstances cls poly_ty mbinds = do _ -> return () | cls == monadClassName = do - forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do + forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do case mbind of - FunBind { fun_id = L _ name, fun_matches = mg } + FunBind { fun_id = (dL->L _ name) + , fun_matches = mg } | name == returnMName, isAliasMG mg /= Just pureAName -> addWarnNonCanonicalMethod2 Opt_WarnNonCanonicalMonadInstances "return" "pure" @@ -520,9 +524,10 @@ checkCanonicalInstances cls poly_ty mbinds = do -- checkCanonicalMonadFailInstances | cls == monadFailClassName = do - forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do + forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do case mbind of - FunBind { fun_id = L _ name, fun_matches = mg } + FunBind { fun_id = (dL->L _ name) + , fun_matches = mg } | name == failMName, isAliasMG mg == Just failMName_preMFP -> addWarnNonCanonicalMethod1 Opt_WarnNonCanonicalMonadFailInstances "fail" @@ -531,9 +536,10 @@ checkCanonicalInstances cls poly_ty mbinds = do _ -> return () | cls == monadClassName = do - forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do + forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do case mbind of - FunBind { fun_id = L _ name, fun_matches = mg } + FunBind { fun_id = (dL->L _ name) + , fun_matches = mg } | name == failMName_preMFP, isAliasMG mg /= Just failMName -> addWarnNonCanonicalMethod2 Opt_WarnNonCanonicalMonadFailInstances "fail" @@ -557,9 +563,10 @@ checkCanonicalInstances cls poly_ty mbinds = do -- checkCanonicalMonoidInstances | cls == semigroupClassName = do - forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do + forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do case mbind of - FunBind { fun_id = L _ name, fun_matches = mg } + FunBind { fun_id = (dL->L _ name) + , fun_matches = mg } | name == sappendName, isAliasMG mg == Just mappendName -> addWarnNonCanonicalMethod1 Opt_WarnNonCanonicalMonoidInstances "(<>)" "mappend" @@ -567,9 +574,10 @@ checkCanonicalInstances cls poly_ty mbinds = do _ -> return () | cls == monoidClassName = do - forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do + forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do case mbind of - FunBind { fun_id = L _ name, fun_matches = mg } + FunBind { fun_id = (dL->L _ name) + , fun_matches = mg } | name == mappendName, isAliasMG mg /= Just sappendName -> addWarnNonCanonicalMethod2NoDefault Opt_WarnNonCanonicalMonoidInstances "mappend" "(<>)" @@ -581,10 +589,12 @@ 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 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 - , L _ (HsVar _ (L _ rhsName)) <- body = Just rhsName + isAliasMG MG {mg_alts = (dL->L _ + [dL->L _ (Match { m_pats = [] + , m_grhss = grhss })])} + | GRHSs _ [dL->L _ (GRHS _ [] body)] lbinds <- grhss + , EmptyLocalBinds _ <- unLoc lbinds + , HsVar _ lrhsName <- unLoc body = Just (unLoc lrhsName) isAliasMG _ = Nothing -- got "lhs = rhs" but expected something different @@ -641,7 +651,7 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty' ; let cls = case hsTyGetAppHead_maybe head_ty' of Nothing -> mkUnboundName (mkTcOccFS (fsLit "<class>")) - Just (L _ cls, _) -> cls + Just (dL->L _ cls, _) -> cls -- rnLHsInstType has added an error message -- if hsTyGetAppHead_maybe fails @@ -1007,7 +1017,7 @@ rnHsRuleDecl (HsRule { rd_name = rule_name , rd_tmvs = tmvs , rd_lhs = lhs , rd_rhs = rhs }) - = do { let rdr_names_w_loc = map get_var tmvs + = do { let rdr_names_w_loc = map (get_var . unLoc) tmvs ; checkDupRdrNames rdr_names_w_loc ; checkShadowedRdrNames rdr_names_w_loc ; names <- newLocalBndrsRn rdr_names_w_loc @@ -1025,9 +1035,9 @@ rnHsRuleDecl (HsRule { rd_name = rule_name , rd_lhs = lhs' , rd_rhs = rhs' }, fv_lhs' `plusFV` fv_rhs') } } where - get_var (L _ (RuleBndrSig _ v _)) = v - get_var (L _ (RuleBndr _ v)) = v - get_var (L _ (XRuleBndr _)) = panic "rnHsRuleDecl" + get_var (RuleBndrSig _ v _) = v + get_var (RuleBndr _ v) = v + get_var (XRuleBndr _) = panic "rnHsRuleDecl" in_rule = text "in the rule" <+> pprFullRuleName rule_name rnHsRuleDecl (XRuleDecl _) = panic "rnHsRuleDecl" @@ -1039,14 +1049,15 @@ bindRuleTmVars doc tyvs vars names thing_inside = go vars names $ \ vars' -> bindLocalNamesFV names (thing_inside vars') where - go (L l (RuleBndr _ (L loc _)) : vars) (n : ns) thing_inside + go ((dL->L l (RuleBndr _ (dL->L loc _))) : vars) (n : ns) thing_inside = go vars ns $ \ vars' -> - thing_inside (L l (RuleBndr noExt (L loc n)) : vars') + thing_inside (cL l (RuleBndr noExt (cL loc n)) : vars') - go (L l (RuleBndrSig _ (L loc _) bsig) : vars) (n : ns) thing_inside + go ((dL->L l (RuleBndrSig _ (dL->L loc _) bsig)) : vars) + (n : ns) thing_inside = rnHsSigWcTypeScoped bind_free_tvs doc bsig $ \ bsig' -> go vars ns $ \ vars' -> - thing_inside (L l (RuleBndrSig noExt (L loc n) bsig') : vars') + thing_inside (cL l (RuleBndrSig noExt (cL loc n) bsig') : vars') go [] [] thing_inside = thing_inside [] go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names) @@ -1094,17 +1105,19 @@ validRuleLhs :: [Name] -> LHsExpr GhcRn -> Maybe (HsExpr GhcRn) validRuleLhs foralls lhs = checkl lhs where - checkl (L _ e) = check e + checkl = check . unLoc check (OpApp _ e1 op e2) = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2 check (HsApp _ e1 e2) = checkl e1 `mplus` checkl_e e2 check (HsAppType _ e _) = checkl e - check (HsVar _ (L _ v)) | v `notElem` foralls = Nothing + check (HsVar _ lv) + | (unLoc lv) `notElem` foralls = Nothing check other = Just other -- Failure -- Check an argument - checkl_e (L _ _e) = Nothing -- Was (check_e e); see Note [Rule LHS validity checking] + checkl_e _ = Nothing + -- Was (check_e e); see Note [Rule LHS validity checking] {- Commented out; see Note [Rule LHS validity checking] above check_e (HsVar v) = Nothing @@ -1389,7 +1402,7 @@ rnRoleAnnots tc_names role_annots = do { -- Check for duplicates *before* renaming, to avoid -- lumping together all the unboundNames let (no_dups, dup_annots) = removeDups role_annots_cmp role_annots - role_annots_cmp (L _ annot1) (L _ annot2) + role_annots_cmp (dL->L _ annot1) (dL->L _ annot2) = roleAnnotDeclName annot1 `compare` roleAnnotDeclName annot2 ; mapM_ dupRoleAnnotErr dup_annots ; mapM (wrapLocM rn_role_annot1) no_dups } @@ -1411,15 +1424,15 @@ dupRoleAnnotErr list 2 (vcat $ map pp_role_annot $ NE.toList sorted_list) where sorted_list = NE.sortBy cmp_annot list - (L loc first_decl :| _) = sorted_list + ((dL->L loc first_decl) :| _) = sorted_list - pp_role_annot (L loc decl) = hang (ppr decl) + pp_role_annot (dL->L loc decl) = hang (ppr decl) 4 (text "-- written at" <+> ppr loc) - cmp_annot (L loc1 _) (L loc2 _) = loc1 `compare` loc2 + cmp_annot (dL->L loc1 _) (dL->L loc2 _) = loc1 `compare` loc2 orphanRoleAnnotErr :: LRoleAnnotDecl GhcRn -> RnM () -orphanRoleAnnotErr (L loc decl) +orphanRoleAnnotErr (dL->L loc decl) = addErrAt loc $ hang (text "Role annotation for a type previously declared:") 2 (ppr decl) $$ @@ -1583,8 +1596,9 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls, -- Check the signatures -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). - ; let sig_rdr_names_w_locs = [op |L _ (ClassOpSig _ False ops _) <- sigs - , op <- ops] + ; let sig_rdr_names_w_locs = + [op | (dL->L _ (ClassOpSig _ False ops _)) <- sigs + , op <- ops] ; checkDupRdrNames sig_rdr_names_w_locs -- Typechecker is responsible for checking that we only -- give default-method bindings for things in this class. @@ -1659,39 +1673,42 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType } where h98_style = case condecls of -- Note [Stupid theta] - L _ (ConDeclGADT {}) : _ -> False - _ -> True + (dL->L _ (ConDeclGADT {})) : _ -> False + _ -> True - rn_derivs (L loc ds) + rn_derivs (dL->L loc ds) = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies ; failIfTc (lengthExceeds ds 1 && not deriv_strats_ok) multipleDerivClausesErr ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause doc) ds - ; return (L loc ds', fvs) } + ; return (cL loc ds', fvs) } rnDataDefn _ (XHsDataDefn _) = panic "rnDataDefn" rnLHsDerivingClause :: HsDocContext -> LHsDerivingClause GhcPs -> RnM (LHsDerivingClause GhcRn, FreeVars) rnLHsDerivingClause doc - (L loc (HsDerivingClause { deriv_clause_ext = noExt - , deriv_clause_strategy = dcs - , deriv_clause_tys = L loc' dct })) + (dL->L loc (HsDerivingClause + { deriv_clause_ext = noExt + , deriv_clause_strategy = dcs + , deriv_clause_tys = (dL->L loc' dct) })) = do { (dcs', dct', fvs) <- rnLDerivStrategy doc dcs $ \strat_tvs ppr_via_ty -> mapFvRn (rn_deriv_ty strat_tvs ppr_via_ty) dct - ; pure ( L loc (HsDerivingClause { deriv_clause_ext = noExt - , deriv_clause_strategy = dcs' - , deriv_clause_tys = L loc' dct' }) + ; pure ( cL loc (HsDerivingClause { deriv_clause_ext = noExt + , deriv_clause_strategy = dcs' + , deriv_clause_tys = cL loc' dct' }) , fvs ) } where rn_deriv_ty :: [Name] -> SDoc -> LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars) - rn_deriv_ty strat_tvs ppr_via_ty deriv_ty@(HsIB {hsib_body = L loc _}) = + rn_deriv_ty strat_tvs ppr_via_ty deriv_ty@(HsIB {hsib_body = dL->L loc _}) = rnAndReportFloatingViaTvs strat_tvs loc ppr_via_ty "class" $ rnHsSigType doc deriv_ty rn_deriv_ty _ _ (XHsImplicitBndrs _) = panic "rn_deriv_ty" -rnLHsDerivingClause _ (L _ (XHsDerivingClause _)) +rnLHsDerivingClause _ (dL->L _ (XHsDerivingClause _)) = panic "rnLHsDerivingClause" +rnLHsDerivingClause _ _ = panic "rnLHsDerivingClause: Impossible Match" + -- due to #15884 rnLDerivStrategy :: forall a. HsDocContext @@ -1709,7 +1726,7 @@ rnLDerivStrategy doc mds thing_inside where rn_deriv_strat :: LDerivStrategy GhcPs -> RnM (LDerivStrategy GhcRn, a, FreeVars) - rn_deriv_strat (L loc ds) = do + rn_deriv_strat (dL->L loc ds) = do let extNeeded :: LangExt.Extension extNeeded | ViaStrategy{} <- ds @@ -1721,9 +1738,9 @@ rnLDerivStrategy doc mds thing_inside failWith $ illegalDerivStrategyErr ds case ds of - StockStrategy -> boring_case (L loc StockStrategy) - AnyclassStrategy -> boring_case (L loc AnyclassStrategy) - NewtypeStrategy -> boring_case (L loc NewtypeStrategy) + StockStrategy -> boring_case (cL loc StockStrategy) + AnyclassStrategy -> boring_case (cL loc AnyclassStrategy) + NewtypeStrategy -> boring_case (cL loc NewtypeStrategy) ViaStrategy via_ty -> do (via_ty', fvs1) <- rnHsSigType doc via_ty let HsIB { hsib_ext = via_imp_tvs @@ -1733,7 +1750,7 @@ rnLDerivStrategy doc mds thing_inside via_tvs = via_imp_tvs ++ via_exp_tvs (thing, fvs2) <- extendTyVarEnvFVRn via_tvs $ thing_inside via_tvs (ppr via_ty') - pure (L loc (ViaStrategy via_ty'), thing, fvs1 `plusFV` fvs2) + pure (cL loc (ViaStrategy via_ty'), thing, fvs1 `plusFV` fvs2) boring_case :: mds -> RnM (mds, a, FreeVars) @@ -1924,17 +1941,17 @@ rnInjectivityAnn :: LHsQTyVars GhcRn -- ^ Type variables declared in -> LFamilyResultSig GhcRn -- ^ Result signature -> LInjectivityAnn GhcPs -- ^ Injectivity annotation -> RnM (LInjectivityAnn GhcRn) -rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv)) - (L srcSpan (InjectivityAnn injFrom injTo)) +rnInjectivityAnn tvBndrs (dL->L _ (TyVarSig _ resTv)) + (dL->L srcSpan (InjectivityAnn injFrom injTo)) = do - { (injDecl'@(L _ (InjectivityAnn injFrom' injTo')), noRnErrors) + { (injDecl'@(dL->L _ (InjectivityAnn injFrom' injTo')), noRnErrors) <- askNoErrs $ bindLocalNames [hsLTyVarName resTv] $ -- The return type variable scopes over the injectivity annotation -- e.g. type family F a = (r::*) | r -> a do { injFrom' <- rnLTyVar injFrom ; injTo' <- mapM rnLTyVar injTo - ; return $ L srcSpan (InjectivityAnn injFrom' injTo') } + ; return $ cL srcSpan (InjectivityAnn injFrom' injTo') } ; let tvNames = Set.fromList $ hsAllLTyVarNames tvBndrs resName = hsLTyVarName resTv @@ -1970,12 +1987,12 @@ rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv)) -- -- So we rename injectivity annotation like we normally would except that -- this time we expect "result" to be reported not in scope by rnLTyVar. -rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn injFrom injTo)) = +rnInjectivityAnn _ _ (dL->L srcSpan (InjectivityAnn injFrom injTo)) = setSrcSpan srcSpan $ do (injDecl', _) <- askNoErrs $ do injFrom' <- rnLTyVar injFrom injTo' <- mapM rnLTyVar injTo - return $ L srcSpan (InjectivityAnn injFrom' injTo') + return $ cL srcSpan (InjectivityAnn injFrom' injTo') return $ injDecl' {- @@ -2042,7 +2059,7 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs all_fvs) }} rnConDecl decl@(ConDeclGADT { con_names = names - , con_forall = L _ explicit_forall + , con_forall = (dL->L _ explicit_forall) , con_qvars = qtvs , con_mb_cxt = mcxt , con_args = args @@ -2120,12 +2137,12 @@ rnConDeclDetails _ doc (InfixCon ty1 ty2) ; (new_ty2, fvs2) <- rnLHsType doc ty2 ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) } -rnConDeclDetails con doc (RecCon (L l fields)) +rnConDeclDetails con doc (RecCon (dL->L l fields)) = do { fls <- lookupConstructorFields con ; (new_fields, fvs) <- rnConDeclFields doc fls fields -- No need to check for duplicate fields -- since that is done by RnNames.extendGlobalRdrEnvRn - ; return (RecCon (L l new_fields), fvs) } + ; return (RecCon (cL l new_fields), fvs) } ------------------------------------------------- @@ -2152,19 +2169,20 @@ extendPatSynEnv val_decls local_fix_env thing = do { -> [(Name, [FieldLabel])] -> TcM [(Name, [FieldLabel])] new_ps' bind names - | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n - , psb_args = RecCon as })) <- bind + | (dL->L bind_loc (PatSynBind _ (PSB { psb_id = (dL->L _ n) + , psb_args = RecCon as }))) <- bind = do - bnd_name <- newTopSrcBinder (L bind_loc n) + bnd_name <- newTopSrcBinder (cL bind_loc n) let rnames = map recordPatSynSelectorId as mkFieldOcc :: Located RdrName -> LFieldOcc GhcPs - mkFieldOcc (L l name) = L l (FieldOcc noExt (L l name)) + mkFieldOcc (dL->L l name) = cL l (FieldOcc noExt (cL l name)) field_occs = map mkFieldOcc rnames flds <- mapM (newRecordSelector False [bnd_name]) field_occs return ((bnd_name, flds): names) - | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n})) <- bind + | (dL->L bind_loc (PatSynBind _ + (PSB { psb_id = (dL->L _ n)}))) <- bind = do - bnd_name <- newTopSrcBinder (L bind_loc n) + bnd_name <- newTopSrcBinder (cL bind_loc n) return ((bnd_name, []): names) | otherwise = return names @@ -2190,9 +2208,9 @@ rnHsTyVars :: [Located RdrName] -> RnM [Located Name] rnHsTyVars tvs = mapM rnHsTyVar tvs rnHsTyVar :: Located RdrName -> RnM (Located Name) -rnHsTyVar (L l tyvar) = do +rnHsTyVar (dL->L l tyvar) = do tyvar' <- lookupOccRn tyvar - return (L l tyvar') + return (cL l tyvar') {- ********************************************************* @@ -2215,7 +2233,7 @@ 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 +addl gp ((dL->L l d) : ds) = add gp l d ds add :: HsGroup GhcPs -> SrcSpan -> HsDecl GhcPs -> [LHsDecl GhcPs] @@ -2223,7 +2241,7 @@ add :: HsGroup GhcPs -> SrcSpan -> HsDecl GhcPs -> [LHsDecl GhcPs] -- #10047: Declaration QuasiQuoters are expanded immediately, without -- causing a group split -add gp _ (SpliceD _ (SpliceDecl _ (L _ qq@HsQuasiQuote{}) _)) ds +add gp _ (SpliceD _ (SpliceDecl _ (dL->L _ qq@HsQuasiQuote{}) _)) ds = do { (ds', _) <- rnTopSpliceDecls qq ; addl gp (ds' ++ ds) } @@ -2249,46 +2267,47 @@ add gp loc (SpliceD _ splice@(SpliceDecl _ _ flag)) ds -- Class declarations: pull out the fixity signatures to the top add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD _ d) ds | isClassDecl d - = let fsigs = [ L l f | L l (FixSig _ f) <- tcdSigs d ] in - addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds + = let fsigs = [ cL l f + | (dL->L l (FixSig _ f)) <- tcdSigs d ] in + addl (gp { hs_tyclds = add_tycld (cL l d) ts, hs_fixds = fsigs ++ fs}) ds | otherwise - = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds + = addl (gp { hs_tyclds = add_tycld (cL l d) ts }) ds -- Signatures: fixity sigs go a different place than all others add gp@(HsGroup {hs_fixds = ts}) l (SigD _ (FixSig _ f)) ds - = addl (gp {hs_fixds = L l f : ts}) ds + = addl (gp {hs_fixds = cL l f : ts}) ds add gp@(HsGroup {hs_valds = ts}) l (SigD _ d) ds - = addl (gp {hs_valds = add_sig (L l d) ts}) ds + = addl (gp {hs_valds = add_sig (cL l d) ts}) ds -- Value declarations: use add_bind add gp@(HsGroup {hs_valds = ts}) l (ValD _ d) ds - = addl (gp { hs_valds = add_bind (L l d) ts }) ds + = addl (gp { hs_valds = add_bind (cL l d) ts }) ds -- Role annotations: added to the TyClGroup add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD _ d) ds - = addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds + = addl (gp { hs_tyclds = add_role_annot (cL l d) ts }) ds -- NB instance declarations go into TyClGroups. We throw them into the first -- group, just as we do for the TyClD case. The renamer will go on to group -- and order them later. add gp@(HsGroup {hs_tyclds = ts}) l (InstD _ d) ds - = addl (gp { hs_tyclds = add_instd (L l d) ts }) ds + = addl (gp { hs_tyclds = add_instd (cL l d) ts }) ds -- The rest are routine add gp@(HsGroup {hs_derivds = ts}) l (DerivD _ d) ds - = addl (gp { hs_derivds = L l d : ts }) ds + = addl (gp { hs_derivds = cL l d : ts }) ds add gp@(HsGroup {hs_defds = ts}) l (DefD _ d) ds - = addl (gp { hs_defds = L l d : ts }) ds + = addl (gp { hs_defds = cL l d : ts }) ds add gp@(HsGroup {hs_fords = ts}) l (ForD _ d) ds - = addl (gp { hs_fords = L l d : ts }) ds + = addl (gp { hs_fords = cL l d : ts }) ds add gp@(HsGroup {hs_warnds = ts}) l (WarningD _ d) ds - = addl (gp { hs_warnds = L l d : ts }) ds + = addl (gp { hs_warnds = cL l d : ts }) ds add gp@(HsGroup {hs_annds = ts}) l (AnnD _ d) ds - = addl (gp { hs_annds = L l d : ts }) ds + = addl (gp { hs_annds = cL l d : ts }) ds add gp@(HsGroup {hs_ruleds = ts}) l (RuleD _ d) ds - = addl (gp { hs_ruleds = L l d : ts }) ds + = addl (gp { hs_ruleds = cL l d : ts }) ds add gp l (DocD _ d) ds - = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds + = addl (gp { hs_docs = (cL l d) : (hs_docs gp) }) ds add (HsGroup {}) _ (SpliceD _ (XSpliceDecl _)) _ = panic "RnSource.add" add (HsGroup {}) _ (XHsDecl _) _ = panic "RnSource.add" add (XHsGroup _) _ _ _ = panic "RnSource.add" diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs index c26d03a645..6adee1c735 100644 --- a/compiler/rename/RnSplice.hs +++ b/compiler/rename/RnSplice.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module RnSplice ( rnTopSpliceDecls, @@ -354,13 +355,13 @@ mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString -- Return the expression (quoter "...quote...") -- which is what we must run in a quasi-quote mkQuasiQuoteExpr flavour quoter q_span quote - = L q_span $ HsApp noExt (L q_span $ - HsApp noExt (L q_span (HsVar noExt (L q_span quote_selector))) + = cL q_span $ HsApp noExt (cL q_span + $ HsApp noExt (cL q_span (HsVar noExt (cL q_span quote_selector))) quoterExpr) quoteExpr where - quoterExpr = L q_span $! HsVar noExt $! (L q_span quoter) - quoteExpr = L q_span $! HsLit noExt $! HsString NoSourceText quote + quoterExpr = cL q_span $! HsVar noExt $! (cL q_span quoter) + quoteExpr = cL q_span $! HsLit noExt $! HsString NoSourceText quote quote_selector = case flavour of UntypedExpSplice -> quoteExpName UntypedPatSplice -> quotePatName @@ -373,21 +374,21 @@ rnSplice :: HsSplice GhcPs -> RnM (HsSplice GhcRn, FreeVars) rnSplice (HsTypedSplice x hasParen splice_name expr) = do { checkTH expr "Template Haskell typed splice" ; loc <- getSrcSpanM - ; n' <- newLocalBndrRn (L loc splice_name) + ; n' <- newLocalBndrRn (cL loc splice_name) ; (expr', fvs) <- rnLExpr expr ; return (HsTypedSplice x hasParen n' expr', fvs) } rnSplice (HsUntypedSplice x hasParen splice_name expr) = do { checkTH expr "Template Haskell untyped splice" ; loc <- getSrcSpanM - ; n' <- newLocalBndrRn (L loc splice_name) + ; n' <- newLocalBndrRn (cL loc splice_name) ; (expr', fvs) <- rnLExpr expr ; return (HsUntypedSplice x hasParen n' expr', fvs) } rnSplice (HsQuasiQuote x splice_name quoter q_loc quote) = do { checkTH quoter "Template Haskell quasi-quote" ; loc <- getSrcSpanM - ; splice_name' <- newLocalBndrRn (L loc splice_name) + ; splice_name' <- newLocalBndrRn (cL loc splice_name) -- Rename the quoter; akin to the HsVar case of rnExpr ; quoter' <- lookupOccRn quoter @@ -599,18 +600,22 @@ rnSplicePat :: HsSplice GhcPs -> RnM ( Either (Pat GhcPs) (Pat GhcRn) rnSplicePat splice = rnSpliceGen run_pat_splice pend_pat_splice splice where + pend_pat_splice :: HsSplice GhcRn -> + (PendingRnSplice, Either b (Pat GhcRn)) pend_pat_splice rn_splice = (makePending UntypedPatSplice rn_splice , Right (SplicePat noExt rn_splice)) + run_pat_splice :: HsSplice GhcRn -> + RnM (Either (Pat GhcPs) (Pat GhcRn), FreeVars) run_pat_splice rn_splice = do { traceRn "rnSplicePat: untyped pattern splice" empty ; (pat, mod_finalizers) <- runRnSplice UntypedPatSplice runMetaP ppr rn_splice -- See Note [Delaying modFinalizers in untyped splices]. - ; return ( Left $ ParPat noExt $ (SplicePat noExt) + ; return ( Left $ ParPat noExt $ ((SplicePat noExt) . HsSpliced noExt (ThModFinalizers mod_finalizers) - . HsSplicedPat <$> + . HsSplicedPat) `onHasSrcSpan` pat , emptyFVs ) } @@ -619,12 +624,12 @@ rnSplicePat splice ---------------------- rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars) -rnSpliceDecl (SpliceDecl _ (L loc splice) flg) +rnSpliceDecl (SpliceDecl _ (dL->L loc splice) flg) = rnSpliceGen run_decl_splice pend_decl_splice splice where pend_decl_splice rn_splice = ( makePending UntypedDeclSplice rn_splice - , SpliceDecl noExt (L loc rn_splice) flg) + , SpliceDecl noExt (cL loc rn_splice) flg) run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (ppr rn_splice) rnSpliceDecl (XSpliceDecl _) = panic "rnSpliceDecl" @@ -728,8 +733,8 @@ traceSplice :: SpliceInfo -> TcM () traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src , spliceGenerated = gen, spliceIsDecl = is_decl }) = do { loc <- case mb_src of - Nothing -> getSrcSpanM - Just (L loc _) -> return loc + Nothing -> getSrcSpanM + Just (dL->L loc _) -> return loc ; traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc) ; when is_decl $ -- Raw material for -dth-dec-file diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index f9ce0199c2..a3062f1d76 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -6,6 +6,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} module RnTypes ( -- Type related stuff @@ -167,10 +169,10 @@ rnWcBody ctxt nwc_rdrs hs_ty ; let awcs = collectAnonWildCards hs_ty' ; return (nwcs ++ awcs, hs_ty', fvs) } where - rn_lty env (L loc hs_ty) + rn_lty env (dL->L loc hs_ty) = setSrcSpan loc $ do { (hs_ty', fvs) <- rn_ty env hs_ty - ; return (L loc hs_ty', fvs) } + ; return (cL loc hs_ty', fvs) } rn_ty :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) -- A lot of faff just to allow the extra-constraints wildcard to appear @@ -180,24 +182,26 @@ rnWcBody ctxt nwc_rdrs hs_ty ; return (HsForAllTy { hst_xforall = noExt, hst_bndrs = tvs' , hst_body = hs_body' }, fvs) } - rn_ty env (HsQualTy { hst_ctxt = L cx hs_ctxt, hst_body = hs_ty }) + rn_ty env (HsQualTy { hst_ctxt = dL->L cx hs_ctxt + , hst_body = hs_ty }) | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt - , L lx (HsWildCardTy _) <- ignoreParens hs_ctxt_last + , (dL->L lx (HsWildCardTy _)) <- ignoreParens hs_ctxt_last = do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1 ; wc' <- setSrcSpan lx $ do { checkExtraConstraintWildCard env hs_ctxt1 ; rnAnonWildCard } - ; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy wc')] + ; let hs_ctxt' = hs_ctxt1' ++ [cL lx (HsWildCardTy wc')] ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty ; return (HsQualTy { hst_xqual = noExt - , hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' } + , hst_ctxt = cL cx hs_ctxt', hst_body = hs_ty' } , fvs1 `plusFV` fvs2) } | otherwise = do { (hs_ctxt', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty ; return (HsQualTy { hst_xqual = noExt - , hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' } + , hst_ctxt = cL cx hs_ctxt' + , hst_body = hs_ty' } , fvs1 `plusFV` fvs2) } rn_ty env hs_ty = rnHsTyKi env hs_ty @@ -354,7 +358,7 @@ rnImplicitBndrs bind_free_tvs ; loc <- getSrcSpanM -- NB: kinds before tvs, as mandated by -- Note [Ordering of implicit variables] - ; vars <- mapM (newLocalBndrRn . L loc . unLoc) (kvs ++ real_tvs) + ; vars <- mapM (newLocalBndrRn . cL loc . unLoc) (kvs ++ real_tvs) ; traceRn "checkMixedVars2" $ vcat [ text "kvs_with_dups" <+> ppr kvs_with_dups @@ -489,11 +493,11 @@ rnHsKind ctxt kind = rnHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind -------------- rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs -> RnM (LHsContext GhcRn, FreeVars) -rnTyKiContext env (L loc cxt) +rnTyKiContext env (dL->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) } + ; return (cL loc cxt', fvs) } rnContext :: HsDocContext -> LHsContext GhcPs -> RnM (LHsContext GhcRn, FreeVars) @@ -501,10 +505,10 @@ rnContext doc theta = rnTyKiContext (mkTyKiEnv doc TypeLevel RnConstraint) theta -------------- rnLHsTyKi :: RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) -rnLHsTyKi env (L loc ty) +rnLHsTyKi env (dL->L loc ty) = setSrcSpan loc $ do { (ty', fvs) <- rnHsTyKi env ty - ; return (L loc ty', fvs) } + ; return (cL loc ty', fvs) } rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) @@ -525,7 +529,7 @@ rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau }) , hst_body = tau' } , fvs1 `plusFV` fvs2) } -rnHsTyKi env (HsTyVar _ ip (L loc rdr_name)) +rnHsTyKi env (HsTyVar _ ip (dL->L loc rdr_name)) = do { when (isRnKindLevel env && isRdrTyVar rdr_name) $ unlessXOptM LangExt.PolyKinds $ addErr $ withHsDocContext (rtke_ctxt env) $ @@ -534,7 +538,7 @@ rnHsTyKi env (HsTyVar _ ip (L loc rdr_name)) -- Any type variable at the kind level is illegal without the use -- of PolyKinds (see #14710) ; name <- rnTyVar env rdr_name - ; return (HsTyVar noExt ip (L loc name), unitFV name) } + ; return (HsTyVar noExt ip (cL loc name), unitFV name) } rnHsTyKi env ty@(HsOpTy _ ty1 l_op ty2) = setSrcSpan (getLoc l_op) $ @@ -678,20 +682,20 @@ rnTyVar env rdr_name rnLTyVar :: Located RdrName -> RnM (Located Name) -- Called externally; does not deal with wildards -rnLTyVar (L loc rdr_name) +rnLTyVar (dL->L loc rdr_name) = do { tyvar <- lookupTypeOccRn rdr_name - ; return (L loc tyvar) } + ; return (cL loc tyvar) } -------------- rnHsTyOp :: Outputable a => RnTyKiEnv -> a -> Located RdrName -> RnM (Located Name, FreeVars) -rnHsTyOp env overall_ty (L loc op) +rnHsTyOp env overall_ty (dL->L loc op) = do { ops_ok <- xoptM LangExt.TypeOperators ; op' <- rnTyVar env op ; unless (ops_ok || op' `hasKey` eqTyConKey) $ addErr (opTyErr op overall_ty) - ; let l_op' = L loc op' + ; let l_op' = cL loc op' ; return (l_op', unitFV op') } -------------- @@ -761,7 +765,7 @@ rnAnonWildCard = do { loc <- getSrcSpanM ; uniq <- newUnique ; let name = mkInternalName uniq (mkTyVarOcc "_") loc - ; return (AnonWildCard (L loc name)) } + ; return (AnonWildCard (cL loc name)) } --------------- -- | Ensures either that we're in a type or that -XPolyKinds is set @@ -1018,39 +1022,43 @@ bindLHsTyVarBndr :: HsDocContext -> LHsTyVarBndr GhcPs -> (LHsTyVarBndr GhcRn -> RnM (b, FreeVars)) -> RnM (b, FreeVars) -bindLHsTyVarBndr _doc mb_assoc (L loc (UserTyVar x lrdr@(L lv _))) thing_inside +bindLHsTyVarBndr _doc mb_assoc (dL->L loc + (UserTyVar x + lrdr@(dL->L lv _))) thing_inside = do { nm <- newTyVarNameRn mb_assoc lrdr ; bindLocalNamesFV [nm] $ - thing_inside (L loc (UserTyVar x (L lv nm))) } + thing_inside (cL loc (UserTyVar x (cL lv nm))) } -bindLHsTyVarBndr doc mb_assoc (L loc (KindedTyVar x lrdr@(L lv _) kind)) +bindLHsTyVarBndr doc mb_assoc (dL->L loc (KindedTyVar x lrdr@(dL->L lv _) kind)) thing_inside = do { sig_ok <- xoptM LangExt.KindSignatures ; unless sig_ok (badKindSigErr doc kind) ; (kind', fvs1) <- rnLHsKind doc kind ; tv_nm <- newTyVarNameRn mb_assoc lrdr - ; (b, fvs2) <- bindLocalNamesFV [tv_nm] $ - thing_inside (L loc (KindedTyVar x (L lv tv_nm) kind')) + ; (b, fvs2) <- bindLocalNamesFV [tv_nm] + $ thing_inside (cL loc (KindedTyVar x (cL lv tv_nm) kind')) ; return (b, fvs1 `plusFV` fvs2) } -bindLHsTyVarBndr _ _ (L _ (XTyVarBndr{})) _ = panic "bindLHsTyVarBndr" +bindLHsTyVarBndr _ _ (dL->L _ (XTyVarBndr{})) _ = panic "bindLHsTyVarBndr" +bindLHsTyVarBndr _ _ _ _ = panic "bindLHsTyVarBndr: Impossible Match" + -- due to #15884 newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name -newTyVarNameRn mb_assoc (L loc rdr) +newTyVarNameRn mb_assoc (dL->L loc rdr) = do { rdr_env <- getLocalRdrEnv ; case (mb_assoc, lookupLocalRdrEnv rdr_env rdr) of (Just _, Just n) -> return n -- Use the same Name as the parent class decl - _ -> newLocalBndrRn (L loc rdr) } + _ -> newLocalBndrRn (cL loc rdr) } --------------------- collectAnonWildCards :: LHsType GhcRn -> [Name] -- | Extract all wild cards from a type. collectAnonWildCards lty = go lty where - go (L _ ty) = case ty of - HsWildCardTy (AnonWildCard (L _ wc)) -> [wc] + go lty = case unLoc lty of + HsWildCardTy (AnonWildCard wc) -> [unLoc wc] HsAppTy _ ty1 ty2 -> go ty1 `mappend` go ty2 HsFunTy _ ty1 ty2 -> go ty1 `mappend` go ty2 HsListTy _ ty -> go ty @@ -1066,11 +1074,11 @@ collectAnonWildCards lty = go lty HsExplicitListTy _ _ tys -> gos tys HsExplicitTupleTy _ tys -> gos tys HsForAllTy { hst_bndrs = bndrs - , hst_body = ty } -> collectAnonWildCardsBndrs bndrs - `mappend` go ty - HsQualTy { hst_ctxt = L _ ctxt - , hst_body = ty } -> gos ctxt `mappend` go ty - HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)) -> go $ L noSrcSpan ty + , hst_body = ty } -> collectAnonWildCardsBndrs bndrs + `mappend` go ty + HsQualTy { hst_ctxt = ctxt + , hst_body = ty } -> gos (unLoc ctxt) `mappend` go ty + HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)) -> go $ cL noSrcSpan ty HsSpliceTy{} -> mempty HsTyLit{} -> mempty HsTyVar{} -> mempty @@ -1112,20 +1120,23 @@ rnConDeclFields ctxt fls fields rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs -> RnM (LConDeclField GhcRn, FreeVars) -rnField fl_env env (L l (ConDeclField _ names ty haddock_doc)) +rnField fl_env env (dL->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 noExt new_names new_ty new_haddock_doc) + ; return (cL l (ConDeclField noExt new_names new_ty new_haddock_doc) , fvs) } where lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn - lookupField (FieldOcc _ (L lr rdr)) = FieldOcc (flSelector fl) (L lr rdr) + lookupField (FieldOcc _ (dL->L lr rdr)) = + FieldOcc (flSelector fl) (cL lr rdr) where lbl = occNameFS $ rdrNameOcc rdr fl = expectJust "rnField" $ lookupFsEnv fl_env lbl lookupField (XFieldOcc{}) = panic "rnField" -rnField _ _ (L _ (XConDeclField _)) = panic "rnField" +rnField _ _ (dL->L _ (XConDeclField _)) = panic "rnField" +rnField _ _ _ = panic "rnField: Impossible Match" + -- due to #15884 {- ************************************************************************ @@ -1159,13 +1170,13 @@ 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 noExt ty21 op2 ty22)) +mkHsOpTyRn mk1 pp_op1 fix1 ty1 (dL->L loc2 (HsOpTy noExt ty21 op2 ty22)) = do { fix2 <- lookupTyFixityRn op2 ; mk_hs_op_ty mk1 pp_op1 fix1 ty1 (\t1 t2 -> HsOpTy noExt t1 op2 t2) (unLoc op2) fix2 ty21 ty22 loc2 } -mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy _ ty21 ty22)) +mkHsOpTyRn mk1 pp_op1 fix1 ty1 (dL->L loc2 (HsFunTy _ ty21 ty22)) = mk_hs_op_ty mk1 pp_op1 fix1 ty1 (HsFunTy noExt) funTyConName funTyFixity ty21 ty22 loc2 @@ -1181,8 +1192,8 @@ mk_hs_op_ty :: (LHsType GhcRn -> LHsType GhcRn -> 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) - ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) } - | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) + ; return (mk1 ty1 (cL loc2 (mk2 ty21 ty22))) } + | associate_right = return (mk1 ty1 (cL loc2 (mk2 ty21 ty22))) | otherwise = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22) new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21 ; return (mk2 (noLoc new_ty) ty22) } @@ -1198,36 +1209,36 @@ mkOpAppRn :: LHsExpr GhcRn -- Left operand; already rearranged -> RnM (HsExpr GhcRn) -- (e11 `op1` e12) `op2` e2 -mkOpAppRn e1@(L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2 +mkOpAppRn e1@(dL->L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2 | nofix_error = do precParseErr (get_op op1,fix1) (get_op op2,fix2) return (OpApp fix2 e1 op2 e2) | associate_right = do new_e <- mkOpAppRn e12 op2 fix2 e2 - return (OpApp fix1 e11 op1 (L loc' new_e)) + return (OpApp fix1 e11 op1 (cL loc' new_e)) where loc'= combineLocs e12 e2 (nofix_error, associate_right) = compareFixity fix1 fix2 --------------------------- -- (- neg_arg) `op` e2 -mkOpAppRn e1@(L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2 +mkOpAppRn e1@(dL->L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2 | nofix_error = do precParseErr (NegateOp,negateFixity) (get_op op2,fix2) return (OpApp fix2 e1 op2 e2) | associate_right = do new_e <- mkOpAppRn neg_arg op2 fix2 e2 - return (NegApp noExt (L loc' new_e) neg_name) + return (NegApp noExt (cL loc' new_e) neg_name) where loc' = combineLocs neg_arg e2 (nofix_error, associate_right) = compareFixity negateFixity fix2 --------------------------- -- e1 `op` - neg_arg -mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp {})) -- NegApp can occur on the right - | not associate_right -- We *want* right association +mkOpAppRn e1 op1 fix1 e2@(dL->L _ (NegApp {})) -- NegApp can occur on the right + | not associate_right -- We *want* right association = do precParseErr (get_op op1, fix1) (NegateOp, negateFixity) return (OpApp fix1 e1 op1 e2) where @@ -1259,10 +1270,10 @@ instance Outputable OpName where 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 -get_op (L _ (HsUnboundVar _ uv)) = UnboundOp uv -get_op (L _ (HsRecFld _ fld)) = RecFldOp fld -get_op other = pprPanic "get_op" (ppr other) +get_op (dL->L _ (HsVar _ n)) = NormalOp (unLoc n) +get_op (dL->L _ (HsUnboundVar _ uv)) = UnboundOp uv +get_op (dL->L _ (HsRecFld _ fld)) = RecFldOp fld +get_op other = pprPanic "get_op" (ppr other) -- Parser left-associates everything, but -- derived instances may have correctly-associated things to @@ -1294,8 +1305,10 @@ mkOpFormRn :: LHsCmdTop GhcRn -- Left operand; already rearranged -> RnM (HsCmd GhcRn) -- (e11 `op1` e12) `op2` e2 -mkOpFormRn a1@(L loc (HsCmdTop _ (L _ (HsCmdArrForm x op1 f (Just fix1) - [a11,a12])))) +mkOpFormRn a1@(dL->L loc + (HsCmdTop _ + (dL->L _ (HsCmdArrForm x op1 f (Just fix1) + [a11,a12])))) op2 fix2 a2 | nofix_error = do precParseErr (get_op op1,fix1) (get_op op2,fix2) @@ -1304,7 +1317,7 @@ mkOpFormRn a1@(L loc (HsCmdTop _ (L _ (HsCmdArrForm x op1 f (Just fix1) | associate_right = do new_c <- mkOpFormRn a12 op2 fix2 a2 return (HsCmdArrForm noExt op1 f (Just fix1) - [a11, L loc (HsCmdTop [] (L loc new_c))]) + [a11, cL loc (HsCmdTop [] (cL loc new_c))]) -- TODO: locs are wrong where (nofix_error, associate_right) = compareFixity fix1 fix2 @@ -1318,7 +1331,7 @@ mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment mkConOpPatRn :: Located Name -> Fixity -> LPat GhcRn -> LPat GhcRn -> RnM (Pat GhcRn) -mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2 +mkConOpPatRn op2 fix2 p1@(dL->L loc (ConPatIn op1 (InfixCon p11 p12))) p2 = do { fix1 <- lookupFixityRn (unLoc op1) ; let (nofix_error, associate_right) = compareFixity fix1 fix2 @@ -1329,7 +1342,8 @@ mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2 else if associate_right then do { new_p <- mkConOpPatRn op2 fix2 p12 p2 - ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right? + ; return (ConPatIn op1 (InfixCon p11 (cL loc new_p))) } + -- XXX loc right? else return (ConPatIn op2 (InfixCon p1 p2)) } mkConOpPatRn op _ p1 p2 -- Default case, no rearrangment @@ -1346,10 +1360,12 @@ checkPrecMatch :: Name -> MatchGroup GhcRn body -> RnM () -- eg a `op` b `C` c = ... -- See comments with rnExpr (OpApp ...) about "deriving" -checkPrecMatch op (MG { mg_alts = L _ ms }) +checkPrecMatch op (MG { mg_alts = (dL->L _ ms) }) = mapM_ check ms where - check (L _ (Match { m_pats = L l1 p1 : L l2 p2 :_ })) + check (dL->L _ (Match { m_pats = (dL->L l1 p1) + : (dL->L l2 p2) + : _ })) = setSrcSpan (combineSrcSpans l1 l2) $ do checkPrec op p1 False checkPrec op p2 True @@ -1458,7 +1474,7 @@ unexpectedTypeSigErr ty 2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables") badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM () -badKindSigErr doc (L loc ty) +badKindSigErr doc (dL->L loc ty) = setSrcSpan loc $ addErr $ withHsDocContext doc $ hang (text "Illegal kind signature:" <+> quotes (ppr ty)) @@ -1476,7 +1492,7 @@ inTypeDoc :: HsType GhcPs -> SDoc inTypeDoc ty = text "In the type" <+> quotes (ppr ty) warnUnusedForAll :: SDoc -> LHsTyVarBndr GhcRn -> FreeVars -> TcM () -warnUnusedForAll in_doc (L loc tv) used_names +warnUnusedForAll in_doc (dL->L loc tv) used_names = whenWOptM Opt_WarnUnusedForalls $ unless (hsTyVarName tv `elemNameSet` used_names) $ addWarnAt (Reason Opt_WarnUnusedForalls) loc $ @@ -1718,10 +1734,10 @@ extractRdrKindSigVars :: LFamilyResultSig GhcPs -> [Located RdrName] -- Returns the free kind variables in a type family result signature, returning -- variable occurrences in left-to-right order. -- See Note [Ordering of implicit variables]. -extractRdrKindSigVars (L _ resultSig) - | KindSig _ k <- resultSig = kindRdrNameFromSig k - | TyVarSig _ (L _ (KindedTyVar _ _ k)) <- resultSig = kindRdrNameFromSig k - | otherwise = [] +extractRdrKindSigVars (dL->L _ resultSig) + | KindSig _ k <- resultSig = kindRdrNameFromSig k + | TyVarSig _ (dL->L _ (KindedTyVar _ _ k)) <- resultSig = kindRdrNameFromSig k + | otherwise = [] where kindRdrNameFromSig k = freeKiTyVarsAllVars (extractHsTyRdrTyVars k) @@ -1783,7 +1799,7 @@ extract_lkind = extract_lty KindLevel extract_lty :: TypeOrKind -> LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups -extract_lty t_or_k (L _ ty) acc +extract_lty t_or_k (dL->L _ ty) acc = case ty of HsTyVar _ _ ltv -> extract_tv t_or_k ltv acc HsBangTy _ _ ty -> extract_lty t_or_k ty acc @@ -1867,11 +1883,11 @@ extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr GhcPs] -> [Located RdrName] extract_hs_tv_bndrs_kvs tv_bndrs = freeKiTyVarsKindVars $ -- There will /be/ no free tyvars! foldr extract_lkind emptyFKTV - [k | L _ (KindedTyVar _ _ k) <- tv_bndrs] + [k | (dL->L _ (KindedTyVar _ _ k)) <- tv_bndrs] extract_tv :: TypeOrKind -> Located RdrName -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups -extract_tv t_or_k ltv@(L _ tv) acc@(FKTV kvs tvs) +extract_tv t_or_k ltv@(dL->L _ tv) acc@(FKTV kvs tvs) | not (isRdrTyVar tv) = acc | isTypeLevel t_or_k = FKTV { fktv_kis = kvs, fktv_tys = ltv : tvs } | otherwise = FKTV { fktv_kis = ltv : kvs, fktv_tys = tvs } diff --git a/compiler/rename/RnUtils.hs b/compiler/rename/RnUtils.hs index 2f27720ee5..0201822638 100644 --- a/compiler/rename/RnUtils.hs +++ b/compiler/rename/RnUtils.hs @@ -3,6 +3,9 @@ This module contains miscellaneous functions related to renaming. -} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} + module RnUtils ( checkDupRdrNames, checkShadowedRdrNames, checkDupNames, checkDupAndShadowedNames, dupNamesErr, @@ -61,7 +64,7 @@ import qualified GHC.LanguageExtensions as LangExt newLocalBndrRn :: Located RdrName -> RnM Name -- Used for non-top-level binders. These should -- never be qualified. -newLocalBndrRn (L loc rdr_name) +newLocalBndrRn (dL->L loc rdr_name) | Just name <- isExact_maybe rdr_name = return name -- This happens in code generated by Template Haskell -- See Note [Binders in Template Haskell] in Convert.hs @@ -122,7 +125,7 @@ checkShadowedRdrNames loc_rdr_names where filtered_rdrs = filterOut (isExact . unLoc) loc_rdr_names -- See Note [Binders in Template Haskell] in Convert - get_loc_occ (L loc rdr) = (loc,rdrNameOcc rdr) + get_loc_occ (dL->L loc rdr) = (loc,rdrNameOcc rdr) checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM () checkDupAndShadowedNames envs names diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index c476eb4597..11a0e20828 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -8,6 +8,7 @@ {-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module TcBinds ( tcLocalBinds, tcTopBinds, tcValBinds, tcHsBootSigs, tcPolyCheck, @@ -312,7 +313,7 @@ tcHsBootSigs binds sigs where tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames where - f (L _ name) + f (dL->L _ name) = do { sigma_ty <- tcHsSigWcType (FunSigCtxt name False) hs_ty ; return (mkVanillaGlobal name sigma_ty) } -- Notice that we make GlobalIds, not LocalIds @@ -347,12 +348,12 @@ tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside ; return (HsIPBinds x (IPBinds ev_binds ip_binds') , result) } where - ips = [ip | L _ (IPBind _ (Left (L _ ip)) _) <- ip_binds] + ips = [ip | (dL->L _ (IPBind _ (Left (dL->L _ ip)) _)) <- ip_binds] -- I wonder if we should do these one at at time -- Consider ?x = 4 -- ?y = ?x + 1 - tc_ip_bind ipClass (IPBind _ (Left (L _ ip)) expr) + tc_ip_bind ipClass (IPBind _ (Left (dL->L _ ip)) expr) = do { ty <- newOpenFlexiTyVarTy ; let p = mkStrLitTy $ hsIPNameFS ip ; ip_id <- newDict ipClass [ p, ty ] @@ -508,22 +509,23 @@ 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 :: OutputableBndrId name => LHsBinds name -> TcM a +recursivePatSynErr :: OutputableBndrId (GhcPass p) => + LHsBinds (GhcPass p) -> TcM a recursivePatSynErr binds = failWithTc $ hang (text "Recursive pattern synonym definition with following bindings:") 2 (vcat $ map pprLBind . bagToList $ binds) where pprLoc loc = parens (text "defined at" <+> ppr loc) - pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) <+> - pprLoc loc + pprLBind (dL->L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) + <+> pprLoc loc tc_single :: forall thing. TopLevelFlag -> TcSigFun -> TcPragEnv -> 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 })) + (dL->L _ (PatSynBind _ psb@PSB{ psb_id = (dL->L _ name) })) _ thing_inside = do { (aux_binds, tcg_env) <- tcPatSynDecl psb (sig_fn name) ; thing <- setGblEnv tcg_env thing_inside @@ -562,7 +564,7 @@ mkEdges sig_fn binds keyd_binds = bagToList binds `zip` [0::BKey ..] key_map :: NameEnv BKey -- Which binding it comes from - key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds + key_map = mkNameEnv [(bndr, key) | (dL->L _ bind, key) <- keyd_binds , bndr <- collectHsBindBinders bind ] ------------------------ @@ -684,8 +686,8 @@ tcPolyCheck prag_fn (CompleteSig { sig_bndr = poly_id , sig_ctxt = ctxt , sig_loc = sig_loc }) - (L loc (FunBind { fun_id = L nm_loc name - , fun_matches = matches })) + (dL->L loc (FunBind { fun_id = (dL->L nm_loc name) + , fun_matches = matches })) = setSrcSpan sig_loc $ do { traceTc "tcPolyCheck" (ppr poly_id $$ ppr sig_loc) ; (tv_prs, theta, tau) <- tcInstType tcInstSkolTyVars poly_id @@ -702,7 +704,7 @@ tcPolyCheck prag_fn tcExtendBinderStack [TcIdBndr mono_id NotTopLevel] $ tcExtendNameTyVarEnv tv_prs $ setSrcSpan loc $ - tcMatchesFun (L nm_loc mono_name) matches (mkCheckExpType tau) + tcMatchesFun (cL nm_loc mono_name) matches (mkCheckExpType tau) ; let prag_sigs = lookupPragEnv prag_fn name ; spec_prags <- tcSpecPrags poly_id prag_sigs @@ -710,7 +712,7 @@ tcPolyCheck prag_fn ; mod <- getModule ; tick <- funBindTicks nm_loc mono_id mod prag_sigs - ; let bind' = FunBind { fun_id = L nm_loc mono_id + ; let bind' = FunBind { fun_id = cL nm_loc mono_id , fun_matches = matches' , fun_co_fn = co_fn , fun_ext = placeHolderNamesTc @@ -722,13 +724,13 @@ tcPolyCheck prag_fn , abe_mono = mono_id , abe_prags = SpecPrags spec_prags } - abs_bind = L loc $ + abs_bind = cL loc $ AbsBinds { abs_ext = noExt , abs_tvs = skol_tvs , abs_ev_vars = ev_vars , abs_ev_binds = [ev_binds] , abs_exports = [export] - , abs_binds = unitBag (L loc bind') + , abs_binds = unitBag (cL loc bind') , abs_sig = True } ; return (unitBag abs_bind, [poly_id]) } @@ -739,7 +741,7 @@ tcPolyCheck _prag_fn sig bind funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn] -> TcM [Tickish TcId] funBindTicks loc fun_id mod sigs - | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ _ cc_name) <- sigs ] + | (mb_cc_str : _) <- [ cc_name | (dL->L _ (SCCFunSig _ _ _ cc_name)) <- sigs ] -- this can only be a singleton list, as duplicate pragmas are rejected -- by the renamer , let cc_str @@ -805,7 +807,7 @@ tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list ; loc <- getSrcSpanM ; let poly_ids = map abe_poly exports - abs_bind = L loc $ + abs_bind = cL loc $ AbsBinds { abs_ext = noExt , abs_tvs = qtvs , abs_ev_vars = givens, abs_ev_binds = [ev_binds] @@ -1248,8 +1250,9 @@ tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking pur -> [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, fun_ext = fvs })] + [ dL->L b_loc (FunBind { fun_id = (dL->L nm_loc name) + , fun_matches = matches + , fun_ext = fvs })] -- Single function binding, | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS , Nothing <- sig_fn name -- ...with no type signature @@ -1269,11 +1272,11 @@ tcMonoBinds is_rec sig_fn no_gen -- We extend the error context even for a non-recursive -- function so that in type error messages we show the -- type of the thing whose rhs we are type checking - tcMatchesFun (L nm_loc name) matches exp_ty + tcMatchesFun (cL nm_loc name) matches exp_ty ; mono_id <- newLetBndr no_gen name rhs_ty - ; return (unitBag $ L b_loc $ - FunBind { fun_id = L nm_loc mono_id, + ; return (unitBag $ cL b_loc $ + FunBind { fun_id = cL nm_loc mono_id, fun_matches = matches', fun_ext = fvs, fun_co_fn = co_fn, fun_tick = [] }, [MBI { mbi_poly_name = name @@ -1330,7 +1333,8 @@ tcLhs :: TcSigFun -> LetBndrSpec -> HsBind GhcRn -> TcM TcMonoBind -- CheckGen is used only for functions with a complete type signature, -- and tcPolyCheck doesn't use tcMonoBinds at all -tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_matches = matches }) +tcLhs sig_fn no_gen (FunBind { fun_id = (dL->L nm_loc name) + , fun_matches = matches }) | Just (TcIdSig sig) <- sig_fn name = -- There is a type signature. -- It must be partial; if complete we'd be in tcPolyCheck! @@ -1417,9 +1421,9 @@ tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id }) = tcExtendIdBinderStackForRhs [info] $ tcExtendTyVarEnvForRhs mb_sig $ do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id)) - ; (co_fn, matches') <- tcMatchesFun (L loc (idName mono_id)) + ; (co_fn, matches') <- tcMatchesFun (cL loc (idName mono_id)) matches (mkCheckExpType $ idType mono_id) - ; return ( FunBind { fun_id = L loc mono_id + ; return ( FunBind { fun_id = cL loc mono_id , fun_matches = matches' , fun_co_fn = co_fn , fun_ext = placeHolderNamesTc @@ -1655,7 +1659,7 @@ decideGeneralisationPlan dflags lbinds closed sig_fn = [ null theta | TcIdSig (PartialSig { psig_hs_ty = hs_ty }) <- mapMaybe sig_fn (collectHsBindListBinders lbinds) - , let (_, L _ theta, _) = splitLHsSigmaTy (hsSigWcType hs_ty) ] + , let (_, dL->L _ theta, _) = splitLHsSigmaTy (hsSigWcType hs_ty) ] has_partial_sigs = not (null partial_sig_mrs) @@ -1671,7 +1675,7 @@ decideGeneralisationPlan dflags lbinds closed sig_fn -- With OutsideIn, all nested bindings are monomorphic -- except a single function binding with a signature one_funbind_with_sig - | [lbind@(L _ (FunBind { fun_id = v }))] <- lbinds + | [lbind@(dL->L _ (FunBind { fun_id = v }))] <- lbinds , Just (TcIdSig sig) <- sig_fn (unLoc v) = Just (lbind, sig) | otherwise @@ -1700,7 +1704,8 @@ isClosedBndrGroup type_env binds fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds bindFvs :: HsBindLR GhcRn GhcRn -> [(Name, NameSet)] - bindFvs (FunBind { fun_id = L _ f, fun_ext = fvs }) + bindFvs (FunBind { fun_id = (dL->L _ f) + , fun_ext = fvs }) = let open_fvs = get_open_fvs fvs in [(f, open_fvs)] bindFvs (PatBind { pat_lhs = pat, pat_ext = fvs }) diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs index 6443fbdc8a..7c3383469d 100644 --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE CPP, ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} module TcErrors( reportUnsolved, reportAllUnsolved, warnAllUnsolved, @@ -2497,7 +2499,7 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over mb_patsyn_prov :: Maybe SDoc mb_patsyn_prov | not lead_with_ambig - , ProvCtxtOrigin PSB{ psb_def = L _ pat } <- orig + , ProvCtxtOrigin PSB{ psb_def = (dL->L _ pat) } <- orig = Just (vcat [ text "In other words, a successful match on the pattern" , nest 2 $ ppr pat , text "does not provide the constraint" <+> pprParendType pred ]) @@ -2626,7 +2628,7 @@ ctxtFixes has_ambig_tvs pred implics discardProvCtxtGivens :: CtOrigin -> [UserGiven] -> [UserGiven] discardProvCtxtGivens orig givens -- See Note [discardProvCtxtGivens] - | ProvCtxtOrigin (PSB {psb_id = L _ name}) <- orig + | ProvCtxtOrigin (PSB {psb_id = (dL->L _ name)}) <- orig = filterOut (discard name) givens | otherwise = givens diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs index c3e7372278..b194eac59a 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -2148,16 +2148,26 @@ primLitOps str ty = (assoc_ty_id str litConTbl ty, \v -> boxed v) ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))] ordOpTbl - = [(charPrimTy , (ltChar_RDR , leChar_RDR , eqChar_RDR , geChar_RDR , gtChar_RDR )) - ,(intPrimTy , (ltInt_RDR , leInt_RDR , eqInt_RDR , geInt_RDR , gtInt_RDR )) - ,(int8PrimTy , (ltInt8_RDR , leInt8_RDR , eqInt8_RDR , geInt8_RDR , gtInt8_RDR )) - ,(int16PrimTy , (ltInt16_RDR , leInt16_RDR , eqInt16_RDR , geInt16_RDR , gtInt16_RDR )) - ,(wordPrimTy , (ltWord_RDR , leWord_RDR , eqWord_RDR , geWord_RDR , gtWord_RDR )) - ,(word8PrimTy , (ltWord8_RDR , leWord8_RDR , eqWord8_RDR , geWord8_RDR , gtWord8_RDR )) - ,(word16PrimTy, (ltWord16_RDR, leWord16_RDR, eqWord16_RDR, geWord16_RDR, gtWord16_RDR )) - ,(addrPrimTy , (ltAddr_RDR , leAddr_RDR , eqAddr_RDR , geAddr_RDR , gtAddr_RDR )) - ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR , eqFloat_RDR , geFloat_RDR , gtFloat_RDR )) - ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR, eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ] + = [(charPrimTy , (ltChar_RDR , leChar_RDR + , eqChar_RDR , geChar_RDR , gtChar_RDR )) + ,(intPrimTy , (ltInt_RDR , leInt_RDR + , eqInt_RDR , geInt_RDR , gtInt_RDR )) + ,(int8PrimTy , (ltInt8_RDR , leInt8_RDR + , eqInt8_RDR , geInt8_RDR , gtInt8_RDR )) + ,(int16PrimTy , (ltInt16_RDR , leInt16_RDR + , eqInt16_RDR , geInt16_RDR , gtInt16_RDR )) + ,(wordPrimTy , (ltWord_RDR , leWord_RDR + , eqWord_RDR , geWord_RDR , gtWord_RDR )) + ,(word8PrimTy , (ltWord8_RDR , leWord8_RDR + , eqWord8_RDR , geWord8_RDR , gtWord8_RDR )) + ,(word16PrimTy, (ltWord16_RDR, leWord16_RDR + , eqWord16_RDR, geWord16_RDR, gtWord16_RDR )) + ,(addrPrimTy , (ltAddr_RDR , leAddr_RDR + , eqAddr_RDR , geAddr_RDR , gtAddr_RDR )) + ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR + , eqFloat_RDR , geFloat_RDR , gtFloat_RDR )) + ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR + , eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ] -- A mapping from a primitive type to a function that constructs its boxed -- version. diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 69f51b8758..450a7d9a86 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -12,6 +12,7 @@ checker. {-# LANGUAGE CPP, TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} module TcHsSyn ( -- * Extracting types from HsSyn @@ -93,12 +94,12 @@ import Control.Arrow ( second ) -} hsLPatType :: OutPat GhcTc -> Type -hsLPatType (L _ pat) = hsPatType pat +hsLPatType lpat = hsPatType (unLoc lpat) hsPatType :: Pat GhcTc -> Type hsPatType (ParPat _ pat) = hsLPatType pat hsPatType (WildPat ty) = ty -hsPatType (VarPat _ (L _ var)) = idType var +hsPatType (VarPat _ lvar) = idType (unLoc lvar) hsPatType (BangPat _ pat) = hsLPatType pat hsPatType (LazyPat _ pat) = hsLPatType pat hsPatType (LitPat _ lit) = hsLitType lit @@ -108,8 +109,9 @@ hsPatType (ListPat (ListPatTc ty Nothing) _) = mkListTy ty hsPatType (ListPat (ListPatTc _ (Just (ty,_))) _) = ty hsPatType (TuplePat tys _ bx) = mkTupleTy bx tys hsPatType (SumPat tys _ _ _ ) = mkSumTy tys -hsPatType (ConPatOut { pat_con = L _ con, pat_arg_tys = tys }) - = conLikeResTy con tys +hsPatType (ConPatOut { pat_con = lcon + , pat_arg_tys = tys }) + = conLikeResTy (unLoc lcon) tys hsPatType (SigPat ty _ _) = ty hsPatType (NPat ty _ _ _) = ty hsPatType (NPlusKPat ty _ _ _ _ _) = ty @@ -328,7 +330,7 @@ zonkEnvIds (ZonkEnv { ze_id_env = id_env}) -- immediately by creating a TypeEnv zonkLIdOcc :: ZonkEnv -> Located TcId -> Located Id -zonkLIdOcc env (L loc id) = L loc (zonkIdOcc env id) +zonkLIdOcc env = onHasSrcSpan (zonkIdOcc env) zonkIdOcc :: ZonkEnv -> TcId -> Id -- Ids defined in this module should be in the envt; @@ -491,8 +493,8 @@ zonkLocalBinds env (HsValBinds x (XValBindsLR (NValBinds binds sigs))) zonkLocalBinds env (HsIPBinds x (IPBinds dict_binds binds )) = do new_binds <- mapM (wrapLocM zonk_ip_bind) binds let - env1 = extendIdZonkEnvRec env [ n - | L _ (IPBind _ (Right n) _) <- new_binds] + env1 = extendIdZonkEnvRec env + [ n | (dL->L _ (IPBind _ (Right n) _)) <- new_binds] (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds return (env2, HsIPBinds x (IPBinds new_dict_binds new_binds)) where @@ -540,12 +542,14 @@ zonk_bind env (VarBind { var_ext = x , var_rhs = new_expr , var_inline = inl }) } -zonk_bind env bind@(FunBind { fun_id = L loc var, fun_matches = ms +zonk_bind env bind@(FunBind { fun_id = (dL->L loc var) + , fun_matches = ms , fun_co_fn = co_fn }) = do { new_var <- zonkIdBndr env var ; (env1, new_co_fn) <- zonkCoFn env co_fn ; new_ms <- zonkMatchGroup env1 zonkLExpr ms - ; return (bind { fun_id = L loc new_var, fun_matches = new_ms + ; return (bind { fun_id = cL loc new_var + , fun_matches = new_ms , fun_co_fn = new_co_fn }) } zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs @@ -571,16 +575,16 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs where zonk_val_bind env lbind | has_sig - , L loc bind@(FunBind { fun_id = L mloc mono_id - , fun_matches = ms - , fun_co_fn = co_fn }) <- lbind + , (dL->L loc bind@(FunBind { fun_id = (dL->L mloc mono_id) + , fun_matches = ms + , fun_co_fn = co_fn })) <- lbind = do { new_mono_id <- updateVarTypeM (zonkTcTypeToTypeX env) mono_id -- Specifically /not/ zonkIdBndr; we do not -- want to complain about a levity-polymorphic binder ; (env', new_co_fn) <- zonkCoFn env co_fn ; new_ms <- zonkMatchGroup env' zonkLExpr ms - ; return $ L loc $ - bind { fun_id = L mloc new_mono_id + ; return $ cL loc $ + bind { fun_id = cL mloc new_mono_id , fun_matches = new_ms , fun_co_fn = new_co_fn } } | otherwise @@ -601,7 +605,7 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs , abe_prags = new_prags }) zonk_export _ (XABExport _) = panic "zonk_bind: XABExport" -zonk_bind env (PatSynBind x bind@(PSB { psb_id = L loc id +zonk_bind env (PatSynBind x bind@(PSB { psb_id = (dL->L loc id) , psb_args = details , psb_def = lpat , psb_dir = dir })) @@ -610,7 +614,7 @@ zonk_bind env (PatSynBind x bind@(PSB { psb_id = L loc id ; let details' = zonkPatSynDetails env1 details ; (_env2, dir') <- zonkPatSynDir env1 dir ; return $ PatSynBind x $ - bind { psb_id = L loc id' + bind { psb_id = cL loc id' , psb_args = details' , psb_def = lpat' , psb_dir = dir' } } @@ -645,9 +649,9 @@ zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag] zonkLTcSpecPrags env ps = mapM zonk_prag ps where - zonk_prag (L loc (SpecPrag id co_fn inl)) + zonk_prag (dL->L loc (SpecPrag id co_fn inl)) = do { (_, co_fn') <- zonkCoFn env co_fn - ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) } + ; return (cL loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) } {- ************************************************************************ @@ -661,13 +665,13 @@ zonkMatchGroup :: ZonkEnv -> (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 +zonkMatchGroup env zBody (MG { mg_alts = (dL->L l ms) , mg_ext = MatchGroupTc arg_tys res_ty , mg_origin = origin }) = do { ms' <- mapM (zonkMatch env zBody) ms ; arg_tys' <- zonkTcTypesToTypesX env arg_tys ; res_ty' <- zonkTcTypeToTypeX env res_ty - ; return (MG { mg_alts = L l ms' + ; return (MG { mg_alts = cL l ms' , mg_ext = MatchGroupTc arg_tys' res_ty' , mg_origin = origin }) } zonkMatchGroup _ _ (XMatchGroup {}) = panic "zonkMatchGroup" @@ -676,11 +680,14 @@ zonkMatch :: ZonkEnv -> (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@(Match { m_pats = pats, m_grhss = grhss })) +zonkMatch env zBody (dL->L loc match@(Match { m_pats = pats + , m_grhss = grhss })) = do { (env1, new_pats) <- zonkPats env pats ; new_grhss <- zonkGRHSs env1 zBody grhss - ; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) } -zonkMatch _ _ (L _ (XMatch _)) = panic "zonkMatch" + ; return (cL loc (match { m_pats = new_pats, m_grhss = new_grhss })) } +zonkMatch _ _ (dL->L _ (XMatch _)) = panic "zonkMatch" +zonkMatch _ _ _ = panic "zonkMatch: Impossible Match" + -- due to #15884 ------------------------------------------------------------------------- zonkGRHSs :: ZonkEnv @@ -688,7 +695,7 @@ zonkGRHSs :: ZonkEnv -> GRHSs GhcTcId (Located (body GhcTcId)) -> TcM (GRHSs GhcTc (Located (body GhcTc))) -zonkGRHSs env zBody (GRHSs x grhss (L l binds)) = do +zonkGRHSs env zBody (GRHSs x grhss (dL->L l binds)) = do (new_env, new_binds) <- zonkLocalBinds env binds let zonk_grhs (GRHS xx guarded rhs) @@ -697,7 +704,7 @@ zonkGRHSs env zBody (GRHSs x grhss (L l binds)) = do return (GRHS xx new_guarded new_rhs) zonk_grhs (XGRHS _) = panic "zonkGRHSs" new_grhss <- mapM (wrapLocM zonk_grhs) grhss - return (GRHSs x new_grhss (L l new_binds)) + return (GRHSs x new_grhss (cL l new_binds)) zonkGRHSs _ _ (XGRHSs _) = panic "zonkGRHSs" {- @@ -715,9 +722,9 @@ zonkExpr :: ZonkEnv -> HsExpr GhcTcId -> TcM (HsExpr GhcTc) zonkLExprs env exprs = mapM (zonkLExpr env) exprs zonkLExpr env expr = wrapLocM (zonkExpr env) expr -zonkExpr env (HsVar x (L l id)) +zonkExpr env (HsVar x (dL->L l id)) = ASSERT2( isNothing (isDataConId_maybe id), ppr id ) - return (HsVar x (L l (zonkIdOcc env id))) + return (HsVar x (cL l (zonkIdOcc env id))) zonkExpr _ e@(HsConLikeOut {}) = return e @@ -797,11 +804,14 @@ zonkExpr env (ExplicitTuple x tup_args boxed) = do { new_tup_args <- mapM zonk_tup_arg tup_args ; return (ExplicitTuple x new_tup_args boxed) } where - zonk_tup_arg (L l (Present x e)) = do { e' <- zonkLExpr env e - ; return (L l (Present x e')) } - zonk_tup_arg (L l (Missing t)) = do { t' <- zonkTcTypeToTypeX env t - ; return (L l (Missing t')) } - zonk_tup_arg (L _ (XTupArg{})) = panic "zonkExpr.XTupArg" + zonk_tup_arg (dL->L l (Present x e)) = do { e' <- zonkLExpr env e + ; return (cL l (Present x e')) } + zonk_tup_arg (dL->L l (Missing t)) = do { t' <- zonkTcTypeToTypeX env t + ; return (cL l (Missing t')) } + zonk_tup_arg (dL->L _ (XTupArg{})) = panic "zonkExpr.XTupArg" + zonk_tup_arg _ = panic "zonk_tup_arg: Impossible Match" + -- due to #15884 + zonkExpr env (ExplicitSum args alt arity expr) = do new_args <- mapM (zonkTcTypeToTypeX env) args @@ -836,15 +846,15 @@ zonkExpr env (HsMultiIf ty alts) ; return $ GRHS x guard' expr' } zonk_alt (XGRHS _) = panic "zonkExpr.HsMultiIf" -zonkExpr env (HsLet x (L l binds) expr) +zonkExpr env (HsLet x (dL->L l binds) expr) = do (new_env, new_binds) <- zonkLocalBinds env binds new_expr <- zonkLExpr new_env expr - return (HsLet x (L l new_binds) new_expr) + return (HsLet x (cL l new_binds) new_expr) -zonkExpr env (HsDo ty do_or_lc (L l stmts)) +zonkExpr env (HsDo ty do_or_lc (dL->L l stmts)) = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts new_ty <- zonkTcTypeToTypeX env ty - return (HsDo new_ty do_or_lc (L l new_stmts)) + return (HsDo new_ty do_or_lc (cL l new_stmts)) zonkExpr env (ExplicitList ty wit exprs) = do (env1, new_wit) <- zonkWit env wit @@ -1004,15 +1014,15 @@ zonkCmd env (HsCmdIf x eCond ePred cThen cElse) zonkWit env Nothing = return (env, Nothing) zonkWit env (Just w) = second Just <$> zonkSyntaxExpr env w -zonkCmd env (HsCmdLet x (L l binds) cmd) +zonkCmd env (HsCmdLet x (dL->L l binds) cmd) = do (new_env, new_binds) <- zonkLocalBinds env binds new_cmd <- zonkLCmd new_env cmd - return (HsCmdLet x (L l new_binds) new_cmd) + return (HsCmdLet x (cL l new_binds) new_cmd) -zonkCmd env (HsCmdDo ty (L l stmts)) +zonkCmd env (HsCmdDo ty (dL->L l stmts)) = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts new_ty <- zonkTcTypeToTypeX env ty - return (HsCmdDo new_ty (L l new_stmts)) + return (HsCmdDo new_ty (cL l new_stmts)) zonkCmd _ (XCmd{}) = panic "zonkCmd" @@ -1195,9 +1205,9 @@ zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap newBinder' <- zonkIdBndr env newBinder return (oldBinder', newBinder') -zonkStmt env _ (LetStmt x (L l binds)) +zonkStmt env _ (LetStmt x (dL->L l binds)) = do (env1, new_binds) <- zonkLocalBinds env binds - return (env1, LetStmt x (L l new_binds)) + return (env1, LetStmt x (cL l new_binds)) zonkStmt env zBody (BindStmt bind_ty pat body bind_op fail_op) = do { (env1, new_bind) <- zonkSyntaxExpr env bind_op @@ -1261,21 +1271,21 @@ zonkRecFields env (HsRecFields flds dd) = do { flds' <- mapM zonk_rbind flds ; return (HsRecFields flds' dd) } where - zonk_rbind (L l fld) + zonk_rbind (dL->L l fld) = do { new_id <- wrapLocM (zonkFieldOcc env) (hsRecFieldLbl fld) ; new_expr <- zonkLExpr env (hsRecFieldArg fld) - ; return (L l (fld { hsRecFieldLbl = new_id + ; return (cL l (fld { hsRecFieldLbl = new_id , hsRecFieldArg = new_expr })) } zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField GhcTcId] -> TcM [LHsRecUpdField GhcTcId] zonkRecUpdFields env = mapM zonk_rbind where - zonk_rbind (L l fld) + zonk_rbind (dL->L l fld) = do { new_id <- wrapLocM (zonkFieldOcc env) (hsRecUpdFieldOcc fld) ; new_expr <- zonkLExpr env (hsRecFieldArg fld) - ; return (L l (fld { hsRecFieldLbl = fmap ambiguousFieldOcc new_id - , hsRecFieldArg = new_expr })) } + ; return (cL l (fld { hsRecFieldLbl = fmap ambiguousFieldOcc new_id + , hsRecFieldArg = new_expr })) } ------------------------------------------------------------------------- mapIPNameTc :: (a -> TcM b) -> Either (Located HsIPName) a @@ -1309,9 +1319,9 @@ zonk_pat env (WildPat ty) (text "In a wildcard pattern") ; return (env, WildPat ty') } -zonk_pat env (VarPat x (L l v)) +zonk_pat env (VarPat x (dL->L l v)) = do { v' <- zonkIdBndr env v - ; return (extendIdZonkEnv1 env v', VarPat x (L l v')) } + ; return (extendIdZonkEnv1 env v', VarPat x (cL l v')) } zonk_pat env (LazyPat x pat) = do { (env', pat') <- zonkPat env pat @@ -1321,10 +1331,10 @@ zonk_pat env (BangPat x pat) = do { (env', pat') <- zonkPat env pat ; return (env', BangPat x pat') } -zonk_pat env (AsPat x (L loc v) pat) +zonk_pat env (AsPat x (dL->L loc v) pat) = do { v' <- zonkIdBndr env v ; (env', pat') <- zonkPat (extendIdZonkEnv1 env v') pat - ; return (env', AsPat x (L loc v') pat') } + ; return (env', AsPat x (cL loc v') pat') } zonk_pat env (ViewPat ty expr pat) = do { expr' <- zonkLExpr env expr @@ -1354,10 +1364,13 @@ zonk_pat env (SumPat tys pat alt arity ) ; (env', pat') <- zonkPat env pat ; return (env', SumPat tys' pat' alt arity) } -zonk_pat env p@(ConPatOut { pat_arg_tys = tys, pat_tvs = tyvars - , pat_dicts = evs, pat_binds = binds - , pat_args = args, pat_wrap = wrapper - , pat_con = L _ con }) +zonk_pat env p@(ConPatOut { pat_arg_tys = tys + , pat_tvs = tyvars + , pat_dicts = evs + , pat_binds = binds + , pat_args = args + , pat_wrap = wrapper + , pat_con = (dL->L _ con) }) = ASSERT( all isImmutableTyVar tyvars ) do { new_tys <- mapM (zonkTcTypeToTypeX env) tys @@ -1393,7 +1406,7 @@ zonk_pat env (SigPat ty pat hs_ty) ; (env', pat') <- zonkPat env pat ; return (env', SigPat ty' pat' hs_ty) } -zonk_pat env (NPat ty (L l lit) mb_neg eq_expr) +zonk_pat env (NPat ty (dL->L l lit) mb_neg eq_expr) = do { (env1, eq_expr') <- zonkSyntaxExpr env eq_expr ; (env2, mb_neg') <- case mb_neg of Nothing -> return (env1, Nothing) @@ -1401,9 +1414,9 @@ zonk_pat env (NPat ty (L l lit) mb_neg eq_expr) ; lit' <- zonkOverLit env2 lit ; ty' <- zonkTcTypeToTypeX env2 ty - ; return (env2, NPat ty' (L l lit') mb_neg' eq_expr') } + ; return (env2, NPat ty' (cL l lit') mb_neg' eq_expr') } -zonk_pat env (NPlusKPat ty (L loc n) (L l lit1) lit2 e1 e2) +zonk_pat env (NPlusKPat ty (dL->L loc n) (dL->L l lit1) lit2 e1 e2) = do { (env1, e1') <- zonkSyntaxExpr env e1 ; (env2, e2') <- zonkSyntaxExpr env1 e2 ; n' <- zonkIdBndr env2 n @@ -1411,7 +1424,7 @@ zonk_pat env (NPlusKPat ty (L loc n) (L l lit1) lit2 e1 e2) ; lit2' <- zonkOverLit env2 lit2 ; ty' <- zonkTcTypeToTypeX env2 ty ; return (extendIdZonkEnv1 env2 n', - NPlusKPat ty' (L loc n') (L l lit1') lit2' e1' e2') } + NPlusKPat ty' (cL loc n') (cL l lit1') lit2' e1' e2') } zonk_pat env (CoPat x co_fn pat ty) = do { (env', co_fn') <- zonkCoFn env co_fn @@ -1437,7 +1450,8 @@ zonkConStuff env (InfixCon p1 p2) zonkConStuff env (RecCon (HsRecFields rpats dd)) = do { (env', pats') <- zonkPats env (map (hsRecFieldArg . unLoc) rpats) - ; let rpats' = zipWith (\(L l rp) p' -> L l (rp { hsRecFieldArg = p' })) + ; let rpats' = zipWith (\(dL->L l rp) p' -> + cL l (rp { hsRecFieldArg = p' })) rpats pats' ; return (env', RecCon (HsRecFields rpats' dd)) } -- Field selectors have declared types; hence no zonking @@ -1489,11 +1503,13 @@ zonkRule env rule@(HsRule { rd_tmvs = tm_bndrs{-::[RuleBndr TcId]-} , rd_lhs = new_lhs , rd_rhs = new_rhs } } where - zonk_tm_bndr env (L l (RuleBndr x (L loc v))) + zonk_tm_bndr env (dL->L l (RuleBndr x (dL->L loc v))) = do { (env', v') <- zonk_it env v - ; return (env', L l (RuleBndr x (L loc v'))) } - zonk_tm_bndr _ (L _ (RuleBndrSig {})) = panic "zonk_tm_bndr RuleBndrSig" - zonk_tm_bndr _ (L _ (XRuleBndr {})) = panic "zonk_tm_bndr XRuleBndr" + ; return (env', cL l (RuleBndr x (cL loc v'))) } + zonk_tm_bndr _ (dL->L _ (RuleBndrSig {})) = panic "zonk_tm_bndr RuleBndrSig" + zonk_tm_bndr _ (dL->L _ (XRuleBndr {})) = panic "zonk_tm_bndr XRuleBndr" + zonk_tm_bndr _ _ = panic "zonk_tm_bndr: Impossible Match" + -- due to #15884 zonk_it env v | isId v = do { v' <- zonkIdBndr env v diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 07c3a27668..1181f384fa 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -7,6 +7,7 @@ {-# LANGUAGE CPP, TupleSections, MultiWayIf, RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} module TcHsType ( -- Type signatures diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index c8d0075bcf..7ac0dd4356 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -9,6 +9,7 @@ TcPat: Typechecking patterns {-# LANGUAGE CPP, RankNTypes, TupleSections #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module TcPat ( tcLetPat, newLetBndr, LetBndrSpec(..) , tcPat, tcPat_O, tcPats @@ -300,11 +301,11 @@ tc_lpat :: LPat GhcRn -> PatEnv -> TcM a -> TcM (LPat GhcTcId, a) -tc_lpat (L span pat) pat_ty penv thing_inside +tc_lpat (dL->L span pat) pat_ty penv thing_inside = setSrcSpan span $ do { (pat', res) <- maybeWrapPatCtxt pat (tc_pat penv pat pat_ty) thing_inside - ; return (L span pat', res) } + ; return (cL span pat', res) } tc_lpats :: PatEnv -> [LPat GhcRn] -> [ExpSigmaType] @@ -324,11 +325,11 @@ tc_pat :: PatEnv -> TcM (Pat GhcTcId, -- Translated pattern a) -- Result of thing inside -tc_pat penv (VarPat x (L l name)) pat_ty thing_inside +tc_pat penv (VarPat x (dL->L l name)) pat_ty thing_inside = do { (wrap, id) <- tcPatBndr penv name pat_ty ; res <- tcExtendIdEnv1 name id thing_inside ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) } + ; return (mkHsWrapPat wrap (VarPat x (cL l id)) pat_ty, res) } tc_pat penv (ParPat x pat) pat_ty thing_inside = do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside @@ -359,7 +360,7 @@ tc_pat _ (WildPat _) pat_ty thing_inside ; pat_ty <- expTypeToType pat_ty ; return (WildPat pat_ty, res) } -tc_pat penv (AsPat x (L nm_loc name) pat) pat_ty thing_inside +tc_pat penv (AsPat x (dL->L nm_loc name) pat) pat_ty thing_inside = do { (wrap, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty) ; (pat', res) <- tcExtendIdEnv1 name bndr_id $ tc_lpat pat (mkCheckExpType $ idType bndr_id) @@ -372,7 +373,7 @@ tc_pat penv (AsPat x (L nm_loc name) pat) pat_ty thing_inside -- -- If you fix it, don't forget the bindInstsOfPatIds! ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap (AsPat x (L nm_loc bndr_id) pat') pat_ty, + ; return (mkHsWrapPat wrap (AsPat x (cL nm_loc bndr_id) pat') pat_ty, res) } tc_pat penv (ViewPat _ expr pat) overall_pat_ty thing_inside @@ -519,7 +520,7 @@ tc_pat penv (LitPat x simple_lit) pat_ty thing_inside -- where lit_ty is the type of the overloaded literal 5. -- -- When there is no negation, neg_lit_ty and lit_ty are the same -tc_pat _ (NPat _ (L l over_lit) mb_neg eq) pat_ty thing_inside +tc_pat _ (NPat _ (dL->L l over_lit) mb_neg eq) pat_ty thing_inside = do { let orig = LiteralOrigin over_lit ; ((lit', mb_neg'), eq') <- tcSyntaxOp orig eq [SynType pat_ty, SynAny] @@ -537,7 +538,7 @@ tc_pat _ (NPat _ (L l over_lit) mb_neg eq) pat_ty thing_inside ; res <- thing_inside ; pat_ty <- readExpType pat_ty - ; return (NPat pat_ty (L l lit') mb_neg' eq', res) } + ; return (NPat pat_ty (cL l lit') mb_neg' eq', res) } {- Note [NPlusK patterns] @@ -568,7 +569,8 @@ AST is used for the subtraction operation. -} -- See Note [NPlusK patterns] -tc_pat penv (NPlusKPat _ (L nm_loc name) (L loc lit) _ ge minus) pat_ty +tc_pat penv (NPlusKPat _ (dL->L nm_loc name) + (dL->L loc lit) _ ge minus) pat_ty thing_inside = do { pat_ty <- expTypeToType pat_ty ; let orig = LiteralOrigin lit @@ -598,7 +600,7 @@ tc_pat penv (NPlusKPat _ (L nm_loc name) (L loc lit) _ ge minus) pat_ty ; let minus'' = minus' { syn_res_wrap = minus_wrap <.> syn_res_wrap minus' } - pat' = NPlusKPat pat_ty (L nm_loc bndr_id) (L loc lit1') lit2' + pat' = NPlusKPat pat_ty (cL nm_loc bndr_id) (cL loc lit1') lit2' ge' minus'' ; return (pat', res) } @@ -707,7 +709,7 @@ tcConPat :: PatEnv -> Located Name -> ExpSigmaType -- Type of the pattern -> HsConPatDetails GhcRn -> TcM a -> TcM (Pat GhcTcId, a) -tcConPat penv con_lname@(L _ con_name) pat_ty arg_pats thing_inside +tcConPat penv con_lname@(dL->L _ con_name) pat_ty arg_pats thing_inside = do { con_like <- tcLookupConLike con_name ; case con_like of RealDataCon data_con -> tcDataConPat penv con_lname data_con @@ -720,12 +722,13 @@ tcDataConPat :: PatEnv -> Located Name -> DataCon -> ExpSigmaType -- Type of the pattern -> HsConPatDetails GhcRn -> TcM a -> TcM (Pat GhcTcId, a) -tcDataConPat penv (L con_span con_name) data_con pat_ty arg_pats thing_inside +tcDataConPat penv (dL->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 (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con - header = L con_span (RealDataCon data_con) + header = cL con_span (RealDataCon data_con) -- Instantiate the constructor type variables [a->ty] -- This may involve doing a family-instance coercion, @@ -815,7 +818,7 @@ tcPatSynPat :: PatEnv -> Located Name -> PatSyn -> ExpSigmaType -- Type of the pattern -> HsConPatDetails GhcRn -> TcM a -> TcM (Pat GhcTcId, a) -tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside +tcPatSynPat penv (dL->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 ; (subst, univ_tvs') <- newMetaTyVars univ_tvs @@ -852,7 +855,7 @@ tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside tcConArgs (PatSynCon pat_syn) arg_tys' arg_pats penv thing_inside ; traceTc "checkConstraints }" (ppr ev_binds) - ; let res_pat = ConPatOut { pat_con = L con_span $ PatSynCon pat_syn, + ; let res_pat = ConPatOut { pat_con = cL con_span $ PatSynCon pat_syn, pat_tvs = ex_tvs', pat_dicts = prov_dicts', pat_binds = ev_binds, @@ -982,16 +985,20 @@ tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside where tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn)) (LHsRecField GhcTcId (LPat GhcTcId)) - tc_field (L l (HsRecField (L loc (FieldOcc sel (L lr rdr))) pat pun)) penv - thing_inside + tc_field (dL->L l (HsRecField (dL->L loc + (FieldOcc sel (dL->L lr rdr))) pat pun)) + penv thing_inside = do { sel' <- tcLookupId sel ; pat_ty <- setSrcSpan loc $ find_field_ty sel (occNameFS $ rdrNameOcc rdr) ; (pat', res) <- tcConArg (pat, pat_ty) penv thing_inside - ; return (L l (HsRecField (L loc (FieldOcc sel' (L lr rdr))) pat' + ; return (cL l (HsRecField (cL loc (FieldOcc sel' (cL lr rdr))) pat' pun), res) } - tc_field (L _ (HsRecField (L _ (XFieldOcc _)) _ _)) _ _ + tc_field (dL->L _ (HsRecField (dL->L _ (XFieldOcc _)) _ _)) _ _ = panic "tcConArgs" + tc_field _ _ _ = panic "tc_field: Impossible Match" + -- due to #15884 + find_field_ty :: Name -> FieldLabelString -> TcM TcType find_field_ty sel lbl diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index 5fad219a90..eefdb97f16 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -8,6 +8,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module TcPatSyn ( tcPatSynDecl, tcPatSynBuilderBind , tcPatSynBuilderOcc, nonBidirectionalErr @@ -79,7 +80,8 @@ tcPatSynDecl psb mb_sig recoverPSB :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc, TcGblEnv) -- See Note [Pattern synonym error recovery] -recoverPSB (PSB { psb_id = L _ name, psb_args = details }) +recoverPSB (PSB { psb_id = (dL->L _ name) + , psb_args = details }) = do { matcher_name <- newImplicitBinder name mkMatcherOcc ; let placeholder = AConLike $ PatSynCon $ mk_placeholder matcher_name @@ -132,7 +134,7 @@ pattern.) But it'll do for now. tcInferPatSynDecl :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc, TcGblEnv) -tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details +tcInferPatSynDecl (PSB { psb_id = lname@(dL->L _ name), psb_args = details , psb_def = lpat, psb_dir = dir }) = addPatSynCtxt lname $ do { traceTc "tcInferPatSynDecl {" $ ppr name @@ -302,7 +304,7 @@ is not very helpful, but at least we don't get a Lint error. tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn -> TcPatSynInfo -> TcM (LHsBinds GhcTc, TcGblEnv) -tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details +tcCheckPatSynDecl psb@PSB{ psb_id = lname@(dL->L _ name), psb_args = details , psb_def = lpat, psb_dir = dir } TPSI{ patsig_implicit_bndrs = implicit_tvs , patsig_univ_bndrs = explicit_univ_tvs, patsig_prov = prov_theta @@ -580,12 +582,13 @@ collectPatSynArgInfo details = where splitRecordPatSyn :: RecordPatSynField (Located Name) -> (Name, Name) - splitRecordPatSyn (RecordPatSynField { recordPatSynPatVar = L _ patVar - , recordPatSynSelectorId = L _ selId }) + splitRecordPatSyn (RecordPatSynField + { recordPatSynPatVar = (dL->L _ patVar) + , recordPatSynSelectorId = (dL->L _ selId) }) = (patVar, selId) addPatSynCtxt :: Located Name -> TcM a -> TcM a -addPatSynCtxt (L loc name) thing_inside +addPatSynCtxt (dL->L loc name) thing_inside = setSrcSpan loc $ addErrCtxt (text "In the declaration for pattern synonym" <+> quotes (ppr name)) $ @@ -696,7 +699,7 @@ tcPatSynMatcher :: Located Name -> TcType -> TcM ((Id, Bool), LHsBinds GhcTc) -- See Note [Matchers and builders for pattern synonyms] in PatSyn -tcPatSynMatcher (L loc name) lpat +tcPatSynMatcher (dL->L loc name) lpat (univ_tvs, req_theta, req_ev_binds, req_dicts) (ex_tvs, ex_tys, prov_theta, prov_dicts) (args, arg_tys) pat_ty @@ -737,9 +740,9 @@ tcPatSynMatcher (L loc name) lpat else [mkHsCaseAlt lpat cont', mkHsCaseAlt lwpat fail'] body = mkLHsWrap (mkWpLet req_ev_binds) $ - L (getLoc lpat) $ + cL (getLoc lpat) $ HsCase noExt (nlHsVar scrutinee) $ - MG{ mg_alts = L (getLoc lpat) cases + MG{ mg_alts = cL (getLoc lpat) cases , mg_ext = MatchGroupTc [pat_ty] res_ty , mg_origin = Generated } @@ -750,18 +753,18 @@ tcPatSynMatcher (L loc name) lpat , mg_ext = MatchGroupTc [pat_ty, cont_ty, fail_ty] res_ty , mg_origin = Generated } - match = mkMatch (mkPrefixFunRhs (L loc name)) [] + match = mkMatch (mkPrefixFunRhs (cL loc name)) [] (mkHsLams (rr_tv:res_tv:univ_tvs) req_dicts body') (noLoc (EmptyLocalBinds noExt)) mg :: MatchGroup GhcTc (LHsExpr GhcTc) - mg = MG{ mg_alts = L (getLoc match) [match] + mg = MG{ mg_alts = cL (getLoc match) [match] , mg_ext = MatchGroupTc [] res_ty , mg_origin = Generated } ; let bind = FunBind{ fun_ext = emptyNameSet - , fun_id = L loc matcher_id + , fun_id = cL loc matcher_id , fun_matches = mg , fun_co_fn = idHsWrapper , fun_tick = [] } @@ -797,7 +800,7 @@ mkPatSynBuilderId :: HsPatSynDir a -> Located Name -> [TyVarBinder] -> ThetaType -> [Type] -> Type -> TcM (Maybe (Id, Bool)) -mkPatSynBuilderId dir (L _ name) +mkPatSynBuilderId dir (dL->L _ name) univ_bndrs req_theta ex_bndrs prov_theta arg_tys pat_ty | isUnidirectional dir @@ -823,8 +826,10 @@ mkPatSynBuilderId dir (L _ name) 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 }) +tcPatSynBuilderBind (PSB { psb_id = (dL->L loc name) + , psb_def = lpat + , psb_dir = dir + , psb_args = details }) | isUnidirectional dir = return emptyBag @@ -849,7 +854,7 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat | otherwise = match_group bind = FunBind { fun_ext = placeHolderNamesTc - , fun_id = L loc (idName builder_id) + , fun_id = cL loc (idName builder_id) , fun_matches = match_group' , fun_co_fn = idHsWrapper , fun_tick = [] } @@ -873,8 +878,9 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn) mk_mg body = mkMatchGroup Generated [builder_match] where - builder_args = [L loc (VarPat noExt (L loc n)) | L loc n <- args] - builder_match = mkMatch (mkPrefixFunRhs (L loc name)) + builder_args = [cL loc (VarPat noExt (cL loc n)) + | (dL->L loc n) <- args] + builder_match = mkMatch (mkPrefixFunRhs (cL loc name)) builder_args body (noLoc (EmptyLocalBinds noExt)) @@ -885,8 +891,10 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat 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 mg@(MG { mg_alts = + (dL->L l [dL->L loc + match@(Match { m_pats = pats })]) }) + = mg { mg_alts = cL l [cL loc (match { m_pats = nlWildPatName : pats })] } add_dummy_arg other_mg = pprPanic "add_dummy_arg" $ pprMatches other_mg tcPatSynBuilderBind (XPatSynBind _) = panic "tcPatSynBuilderBind" @@ -932,9 +940,9 @@ tcPatToExpr name args pat = go pat -- Make a prefix con for prefix and infix patterns for simplicity mkPrefixConExpr :: Located Name -> [LPat GhcRn] -> Either MsgDoc (HsExpr GhcRn) - mkPrefixConExpr lcon@(L loc _) pats + mkPrefixConExpr lcon@(dL->L loc _) pats = do { exprs <- mapM go pats - ; return (foldl' (\x y -> HsApp noExt (L loc x) y) + ; return (foldl' (\x y -> HsApp noExt (cL loc x) y) (HsVar noExt lcon) exprs) } mkRecordConExpr :: Located Name -> HsRecFields GhcRn (LPat GhcRn) @@ -944,7 +952,7 @@ tcPatToExpr name args pat = go pat ; return (RecordCon noExt con exprFields) } go :: LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn) - go (L loc p) = L loc <$> go1 p + go (dL->L loc p) = cL loc <$> go1 p go1 :: Pat GhcRn -> Either MsgDoc (HsExpr GhcRn) go1 (ConPatIn con info) @@ -956,9 +964,9 @@ tcPatToExpr name args pat = go pat go1 (SigPat _ pat _) = go1 (unLoc pat) -- See Note [Type signatures and the builder expression] - go1 (VarPat _ (L l var)) + go1 (VarPat _ (dL->L l var)) | var `elemNameSet` lhsVars - = return $ HsVar noExt (L l var) + = return $ HsVar noExt (cL l var) | otherwise = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym") go1 (ParPat _ pat) = fmap (HsPar noExt) $ go pat @@ -975,7 +983,7 @@ tcPatToExpr name args pat = go pat (noLoc expr) } go1 (LitPat _ lit) = return $ HsLit noExt lit - go1 (NPat _ (L _ n) mb_neg _) + go1 (NPat _ (dL->L _ n) mb_neg _) | Just neg <- mb_neg = return $ unLoc $ nlHsSyntaxApps neg [noLoc (HsOverLit noExt n)] | otherwise = return $ HsOverLit noExt n @@ -1147,7 +1155,7 @@ tcCollectEx pat = go pat = mergeMany . map goRecFd $ flds goRecFd :: LHsRecField GhcTc (LPat GhcTc) -> ([TyVar], [EvVar]) - goRecFd (L _ HsRecField{ hsRecFieldArg = p }) = go p + goRecFd (dL->L _ HsRecField{ hsRecFieldArg = p }) = go p merge (vs1, evs1) (vs2, evs2) = (vs1 ++ vs2, evs1 ++ evs2) mergeMany = foldr merge empty diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index 3e8d043276..c65a3b9724 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -15,6 +15,7 @@ https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/TypeChecker {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} module TcRnDriver ( tcRnStmt, tcRnExpr, TcRnExprMode(..), tcRnType, @@ -157,7 +158,7 @@ tcRnModule :: HscEnv -> IO (Messages, Maybe TcGblEnv) tcRnModule hsc_env mod_sum save_rn_syntax - parsedModule@HsParsedModule {hpm_module=L loc this_module} + parsedModule@HsParsedModule {hpm_module= (dL->L loc this_module)} | RealSrcSpan real_loc <- loc = withTiming (pure dflags) (text "Renamer/typechecker"<+>brackets (ppr this_mod)) @@ -180,7 +181,7 @@ tcRnModule hsc_env mod_sum save_rn_syntax pair :: (Module, SrcSpan) pair@(this_mod,_) - | Just (L mod_loc mod) <- hsmodName this_module + | Just (dL->L mod_loc mod) <- hsmodName this_module = (mkModule this_pkg mod, mod_loc) | otherwise -- 'module M where' is omitted @@ -199,7 +200,7 @@ tcRnModuleTcRnM :: HscEnv tcRnModuleTcRnM hsc_env mod_sum (HsParsedModule { hpm_module = - (L loc (HsModule maybe_mod export_ies + (dL->L loc (HsModule maybe_mod export_ies import_decls local_decls mod_deprec maybe_doc_hdr)), hpm_src_files = src_files @@ -207,97 +208,97 @@ tcRnModuleTcRnM hsc_env mod_sum (this_mod, prel_imp_loc) = setSrcSpan loc $ do { let { explicit_mod_hdr = isJust maybe_mod - ; hsc_src = ms_hsc_src mod_sum }; - -- Load the hi-boot interface for this module, if any - -- We do this now so that the boot_names can be passed - -- to tcTyAndClassDecls, because the boot_names are - -- automatically considered to be loop breakers - tcg_env <- getGblEnv ; - boot_info <- tcHiBootIface hsc_src this_mod ; - setGblEnv (tcg_env { tcg_self_boot = boot_info }) $ do { - - -- Deal with imports; first add implicit prelude - implicit_prelude <- xoptM LangExt.ImplicitPrelude; - let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc - implicit_prelude import_decls } ; - - whenWOptM Opt_WarnImplicitPrelude $ + ; hsc_src = ms_hsc_src mod_sum } + ; -- Load the hi-boot interface for this module, if any + -- We do this now so that the boot_names can be passed + -- to tcTyAndClassDecls, because the boot_names are + -- automatically considered to be loop breakers + tcg_env <- getGblEnv + ; boot_info <- tcHiBootIface hsc_src this_mod + ; setGblEnv (tcg_env { tcg_self_boot = boot_info }) + $ do + { -- Deal with imports; first add implicit prelude + implicit_prelude <- xoptM LangExt.ImplicitPrelude + ; let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc + implicit_prelude import_decls } + + ; whenWOptM Opt_WarnImplicitPrelude $ when (notNull prel_imports) $ - addWarn (Reason Opt_WarnImplicitPrelude) (implicitPreludeWarn) ; - - -- TODO This is a little skeevy; maybe handle a bit more directly - let { simplifyImport (L _ idecl) = (fmap sl_fs (ideclPkgQual idecl), ideclName idecl) } ; - raw_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src (moduleName this_mod) ; - raw_req_imports <- liftIO $ - implicitRequirements hsc_env (map simplifyImport (prel_imports ++ import_decls)) ; - let { mkImport (Nothing, L _ mod_name) = noLoc $ (simpleImportDecl mod_name) { - ideclHiding = Just (False, noLoc []) - } ; - mkImport _ = panic "mkImport" } ; - - let { all_imports = prel_imports ++ import_decls - ++ map mkImport (raw_sig_imports ++ raw_req_imports) } ; - - -- OK now finally rename the imports - tcg_env <- {-# SCC "tcRnImports" #-} - tcRnImports hsc_env all_imports ; - - -- If the whole module is warned about or deprecated + addWarn (Reason Opt_WarnImplicitPrelude) (implicitPreludeWarn) + + ; -- TODO This is a little skeevy; maybe handle a bit more directly + let { simplifyImport (dL->L _ idecl) = + ( fmap sl_fs (ideclPkgQual idecl) , ideclName idecl) + } + ; raw_sig_imports <- liftIO + $ findExtraSigImports hsc_env hsc_src + (moduleName this_mod) + ; raw_req_imports <- liftIO + $ implicitRequirements hsc_env + (map simplifyImport (prel_imports + ++ import_decls)) + ; let { mkImport (Nothing, dL->L _ mod_name) = noLoc + $ (simpleImportDecl mod_name) + { ideclHiding = Just (False, noLoc [])} + ; mkImport _ = panic "mkImport" } + ; let { all_imports = prel_imports ++ import_decls + ++ map mkImport (raw_sig_imports ++ raw_req_imports) } + ; -- OK now finally rename the imports + tcg_env <- {-# SCC "tcRnImports" #-} + tcRnImports hsc_env all_imports + + ; -- If the whole module is warned about or deprecated -- (via mod_deprec) record that in tcg_warns. If we do thereby add -- a WarnAll, it will override any subsequent deprecations added to tcg_warns - let { tcg_env1 = case mod_deprec of - Just (L _ txt) -> tcg_env { tcg_warns = WarnAll txt } - Nothing -> tcg_env - } ; - - setGblEnv tcg_env1 $ do { - - -- Rename and type check the declarations - traceRn "rn1a" empty ; - tcg_env <- if isHsBootOrSig hsc_src then - tcRnHsBootDecls hsc_src local_decls - else - {-# SCC "tcRnSrcDecls" #-} - tcRnSrcDecls explicit_mod_hdr local_decls ; - setGblEnv tcg_env $ do { - - -- Process the export list - traceRn "rn4a: before exports" empty; - tcg_env <- tcRnExports explicit_mod_hdr export_ies tcg_env ; - traceRn "rn4b: after exports" empty ; - - -- Check that main is exported (must be after tcRnExports) - checkMainExported tcg_env ; - - -- Compare the hi-boot iface (if any) with the real thing - -- Must be done after processing the exports - tcg_env <- checkHiBootIface tcg_env boot_info ; - - -- The new type env is already available to stuff slurped from - -- interface files, via TcEnv.setGlobalTypeEnv - -- It's important that this includes the stuff in checkHiBootIface, - -- because the latter might add new bindings for boot_dfuns, - -- which may be mentioned in imported unfoldings - - -- Don't need to rename the Haddock documentation, - -- it's not parsed by GHC anymore. - tcg_env <- return (tcg_env { tcg_doc_hdr = maybe_doc_hdr }) ; - - -- Report unused names - -- Do this /after/ type inference, so that when reporting - -- a function with no type signature we can give the - -- inferred type - reportUnusedNames export_ies tcg_env ; - - -- add extra source files to tcg_dependent_files - addDependentFiles src_files ; - - tcg_env <- runTypecheckerPlugin mod_sum hsc_env tcg_env ; - - -- Dump output and return - tcDump tcg_env ; - return tcg_env - }}}} + let { tcg_env1 = case mod_deprec of + Just (dL->L _ txt) -> + tcg_env {tcg_warns = WarnAll txt} + Nothing -> tcg_env + } + ; setGblEnv tcg_env1 + $ do { -- Rename and type check the declarations + traceRn "rn1a" empty + ; tcg_env <- if isHsBootOrSig hsc_src + then tcRnHsBootDecls hsc_src local_decls + else {-# SCC "tcRnSrcDecls" #-} + tcRnSrcDecls explicit_mod_hdr local_decls + ; setGblEnv tcg_env + $ do { -- Process the export list + traceRn "rn4a: before exports" empty + ; tcg_env <- tcRnExports explicit_mod_hdr export_ies + tcg_env + ; traceRn "rn4b: after exports" empty + ; -- Check main is exported(must be after tcRnExports) + checkMainExported tcg_env + ; -- Compare hi-boot iface (if any) with the real thing + -- Must be done after processing the exports + tcg_env <- checkHiBootIface tcg_env boot_info + ; -- The new type env is already available to stuff + -- slurped from interface files, via + -- TcEnv.setGlobalTypeEnv. It's important that this + -- includes the stuff in checkHiBootIface, + -- because the latter might add new bindings for + -- boot_dfuns, which may be mentioned in imported + -- unfoldings. + + -- Don't need to rename the Haddock documentation, + -- it's not parsed by GHC anymore. + tcg_env <- return (tcg_env + { tcg_doc_hdr = maybe_doc_hdr }) + ; -- Report unused names + -- Do this /after/ typeinference, so that when reporting + -- a function with no type signature we can give the + -- inferred type + reportUnusedNames export_ies tcg_env + ; -- add extra source files to tcg_dependent_files + addDependentFiles src_files + ; tcg_env <- runTypecheckerPlugin mod_sum hsc_env tcg_env + ; -- Dump output and return + tcDump tcg_env + ; return tcg_env } + } + } + } implicitPreludeWarn :: SDoc implicitPreludeWarn @@ -515,24 +516,26 @@ tc_rn_src_decls ds then return (tcg_env, rn_decls) else do { (th_group, th_group_tail) <- findSplice th_ds ; case th_group_tail of - { Nothing -> return () ; - ; Just (SpliceDecl _ (L loc _) _, _) - -> setSrcSpan loc $ - addErr (text "Declaration splices are not permitted inside top-level declarations added with addTopDecls") + { Nothing -> return () + ; Just (SpliceDecl _ (dL->L loc _) _, _) -> + setSrcSpan loc + $ addErr (text + ("Declaration splices are not " + ++ "permitted inside top-level " + ++ "declarations added with addTopDecls")) ; Just (XSpliceDecl _, _) -> panic "tc_rn_src_decls" - } ; - - -- Rename TH-generated top-level declarations - ; (tcg_env, th_rn_decls) <- setGblEnv tcg_env $ - rnTopSrcDecls th_group + } + -- Rename TH-generated top-level declarations + ; (tcg_env, th_rn_decls) <- setGblEnv tcg_env + $ rnTopSrcDecls th_group - -- Dump generated top-level declarations + -- Dump generated top-level declarations ; let msg = "top-level declarations added with addTopDecls" - ; traceSplice $ SpliceInfo { spliceDescription = msg - , spliceIsDecl = True - , spliceSource = Nothing - , spliceGenerated = ppr th_rn_decls } - + ; traceSplice + $ SpliceInfo { spliceDescription = msg + , spliceIsDecl = True + , spliceSource = Nothing + , spliceGenerated = ppr th_rn_decls } ; return (tcg_env, appendGroups rn_decls th_rn_decls) } @@ -550,7 +553,7 @@ tc_rn_src_decls ds { Nothing -> return (tcg_env, tcl_env, lie1) -- If there's a splice, we must carry on - ; Just (SpliceDecl _ (L loc splice) _, rest_ds) -> + ; Just (SpliceDecl _ (dL->L loc splice) _, rest_ds) -> do { recordTopLevelSpliceLoc loc -- Rename the splice expression, and get its supporting decls @@ -638,7 +641,7 @@ tcRnHsBootDecls hsc_src decls ; traceTc "boot" (ppr lie); return gbl_env } badBootDecl :: HscSource -> String -> Located decl -> TcM () -badBootDecl hsc_src what (L loc _) +badBootDecl hsc_src what (dL->L loc _) = addErrAt loc (char 'A' <+> text what <+> text "declaration is not (currently) allowed in a" <+> (case hsc_src of @@ -1696,7 +1699,7 @@ check_main dflags tcg_env explicit_mod_hdr ; (ev_binds, main_expr) <- checkConstraints skol_info [] [] $ addErrCtxt mainCtxt $ - tcMonoExpr (L loc (HsVar noExt (L loc main_name))) + tcMonoExpr (cL loc (HsVar noExt (cL loc main_name))) (mkCheckExpType io_ty) -- See Note [Root-main Id] @@ -2007,52 +2010,53 @@ runPlans (p:ps) = tryTcDiscardingErrs (runPlans ps) p tcUserStmt :: GhciLStmt GhcPs -> TcM (PlanResult, FixityEnv) -- An expression typed at the prompt is treated very specially -tcUserStmt (L loc (BodyStmt _ expr _ _)) +tcUserStmt (dL->L loc (BodyStmt _ expr _ _)) = do { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr) -- Don't try to typecheck if the renamer fails! ; ghciStep <- getGhciStepIO ; uniq <- newUnique ; interPrintName <- getInteractivePrintName ; let fresh_it = itName uniq loc - matches = [mkMatch (mkPrefixFunRhs (L loc fresh_it)) [] rn_expr + matches = [mkMatch (mkPrefixFunRhs (cL loc fresh_it)) [] rn_expr (noLoc emptyLocalBinds)] -- [it = expr] - the_bind = L loc $ (mkTopFunBind FromSource - (L loc fresh_it) matches) { fun_ext = fvs } - -- Care here! In GHCi the expression might have - -- free variables, and they in turn may have free type variables - -- (if we are at a breakpoint, say). We must put those free vars + the_bind = cL loc $ (mkTopFunBind FromSource + (cL loc fresh_it) matches) + { fun_ext = fvs } + -- Care here! In GHCi the expression might have + -- free variables, and they in turn may have free type variables + -- (if we are at a breakpoint, say). We must put those free vars -- [let it = expr] - let_stmt = L loc $ LetStmt noExt $ noLoc $ HsValBinds noExt + let_stmt = cL loc $ LetStmt noExt $ noLoc $ HsValBinds noExt $ XValBindsLR (NValBinds [(NonRecursive,unitBag the_bind)] []) -- [it <- e] - bind_stmt = L loc $ BindStmt noExt - (L loc (VarPat noExt (L loc fresh_it))) + bind_stmt = cL loc $ BindStmt noExt + (cL loc (VarPat noExt (cL loc fresh_it))) (nlHsApp ghciStep rn_expr) (mkRnSyntaxExpr bindIOName) noSyntaxExpr -- [; print it] - print_it = L loc $ BodyStmt noExt + print_it = cL loc $ BodyStmt noExt (nlHsApp (nlHsVar interPrintName) (nlHsVar fresh_it)) (mkRnSyntaxExpr thenIOName) noSyntaxExpr -- NewA - no_it_a = L loc $ BodyStmt noExt (nlHsApps bindIOName + no_it_a = cL loc $ BodyStmt noExt (nlHsApps bindIOName [rn_expr , nlHsVar interPrintName]) (mkRnSyntaxExpr thenIOName) noSyntaxExpr - no_it_b = L loc $ BodyStmt noExt (rn_expr) + no_it_b = cL loc $ BodyStmt noExt (rn_expr) (mkRnSyntaxExpr thenIOName) noSyntaxExpr - no_it_c = L loc $ BodyStmt noExt + no_it_c = cL loc $ BodyStmt noExt (nlHsApp (nlHsVar interPrintName) rn_expr) (mkRnSyntaxExpr thenIOName) noSyntaxExpr @@ -2152,7 +2156,7 @@ But for naked expressions, you will have In an equation for ‘x’: x = putStrLn True -} -tcUserStmt rdr_stmt@(L loc _) +tcUserStmt rdr_stmt@(dL->L loc _) = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $ rnStmts GhciStmtCtxt rnLExpr [rdr_stmt] $ \_ -> do fix_env <- getFixityEnv @@ -2163,8 +2167,8 @@ tcUserStmt rdr_stmt@(L loc _) ; ghciStep <- getGhciStepIO ; let gi_stmt - | (L loc (BindStmt ty pat expr op1 op2)) <- rn_stmt - = L loc $ BindStmt ty pat (nlHsApp ghciStep expr) op1 op2 + | (dL->L loc (BindStmt ty pat expr op1 op2)) <- rn_stmt + = cL loc $ BindStmt ty pat (nlHsApp ghciStep expr) op1 op2 | otherwise = rn_stmt ; opt_pr_flag <- goptM Opt_PrintBindResult @@ -2186,7 +2190,7 @@ tcUserStmt rdr_stmt@(L loc _) ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM ; return stuff } where - print_v = L loc $ BodyStmt noExt (nlHsApp (nlHsVar printName) + print_v = cL loc $ BodyStmt noExt (nlHsApp (nlHsVar printName) (nlHsVar v)) (mkRnSyntaxExpr thenIOName) noSyntaxExpr @@ -2533,7 +2537,7 @@ getModuleInterface hsc_env mod tcRnLookupRdrName :: HscEnv -> Located RdrName -> IO (Messages, Maybe [Name]) -- ^ Find all the Names that this RdrName could mean, in GHCi -tcRnLookupRdrName hsc_env (L loc rdr_name) +tcRnLookupRdrName hsc_env (dL->L loc rdr_name) = runTcInteractive hsc_env $ setSrcSpan loc $ do { -- If the identifier is a constructor (begins with an diff --git a/compiler/typecheck/TcRnExports.hs b/compiler/typecheck/TcRnExports.hs index 4d05037dfa..28c1773308 100644 --- a/compiler/typecheck/TcRnExports.hs +++ b/compiler/typecheck/TcRnExports.hs @@ -3,6 +3,8 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + module TcRnExports (tcRnExports, exports_from_avail) where import GhcPrelude @@ -215,7 +217,7 @@ exports_from_avail Nothing rdr_env _imports _this_mod fix_faminst avail = avail -exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod +exports_from_avail (Just (dL->L _ rdr_items)) rdr_env imports this_mod = do ie_avails <- accumExports do_litem rdr_items let final_exports = nubAvails (concat (map snd ie_avails)) -- Combine families return (Just ie_avails, final_exports) @@ -236,7 +238,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod exports_from_item :: ExportAccum -> LIE GhcPs -> RnM (Maybe (ExportAccum, (LIE GhcRn, Avails))) exports_from_item (ExportAccum occs earlier_mods) - (L loc ie@(IEModuleContents _ lmod@(L _ mod))) + (dL->L loc ie@(IEModuleContents _ lmod@(dL->L _ mod))) | mod `elementOfUniqSet` earlier_mods -- Duplicate export of M = do { warnIfFlag Opt_WarnDuplicateExports True (dupModuleExport mod) ; @@ -271,13 +273,13 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod , ppr new_exports ]) ; return (Just ( ExportAccum occs' mods - , ( L loc (IEModuleContents noExt lmod) + , ( cL loc (IEModuleContents noExt lmod) , new_exports))) } - exports_from_item acc@(ExportAccum occs mods) (L loc ie) + exports_from_item acc@(ExportAccum occs mods) (dL->L loc ie) | isDoc ie = do new_ie <- lookup_doc_ie ie - return (Just (acc, (L loc new_ie, []))) + return (Just (acc, (cL loc new_ie, []))) | otherwise = do (new_ie, avail) <- lookup_ie ie @@ -288,17 +290,17 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod occs' <- check_occs ie occs [avail] return (Just ( ExportAccum occs' mods - , (L loc new_ie, [avail]))) + , (cL loc new_ie, [avail]))) ------------- lookup_ie :: IE GhcPs -> RnM (IE GhcRn, AvailInfo) - lookup_ie (IEVar _ (L l rdr)) + lookup_ie (IEVar _ (dL->L l rdr)) = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr - return (IEVar noExt (L l (replaceWrappedName rdr name)), avail) + return (IEVar noExt (cL l (replaceWrappedName rdr name)), avail) - lookup_ie (IEThingAbs _ (L l rdr)) + lookup_ie (IEThingAbs _ (dL->L l rdr)) = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr - return (IEThingAbs noExt (L l (replaceWrappedName rdr name)) + return (IEThingAbs noExt (cL l (replaceWrappedName rdr name)) , avail) lookup_ie ie@(IEThingAll _ n') @@ -330,18 +332,18 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod lookup_ie_with :: LIEWrappedName RdrName -> [LIEWrappedName RdrName] -> RnM (Located Name, [LIEWrappedName Name], [Name], [Located FieldLabel]) - lookup_ie_with (L l rdr) sub_rdrs + lookup_ie_with (dL->L l rdr) sub_rdrs = do name <- lookupGlobalOccRn $ ieWrappedName rdr (non_flds, flds) <- lookupChildrenExport name sub_rdrs if isUnboundName name - then return (L l name, [], [name], []) - else return (L l name, non_flds + then return (cL l name, [], [name], []) + else return (cL l name, non_flds , map (ieWrappedName . unLoc) non_flds , flds) lookup_ie_all :: IE GhcPs -> LIEWrappedName RdrName -> RnM (Located Name, [Name], [FieldLabel]) - lookup_ie_all ie (L l rdr) = + lookup_ie_all ie (dL->L l rdr) = do name <- lookupGlobalOccRn $ ieWrappedName rdr let gres = findChildren kids_env name (non_flds, flds) = classifyGREs gres @@ -355,7 +357,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod else -- This occurs when you export T(..), but -- only import T abstractly, or T is a synonym. addErr (exportItemErr ie) - return (L l name, non_flds, flds) + return (cL l name, non_flds, flds) ------------- lookup_doc_ie :: IE GhcPs -> RnM (IE GhcRn) @@ -456,10 +458,11 @@ lookupChildrenExport spec_parent rdr_items = case name of NameNotFound -> do { ub <- reportUnboundName unboundName ; let l = getLoc n - ; return (Left (L l (IEName (L l ub))))} - FoundFL fls -> return $ Right (L (getLoc n) fls) + ; return (Left (cL l (IEName (cL l ub))))} + FoundFL fls -> return $ Right (cL (getLoc n) fls) FoundName par name -> do { checkPatSynParent spec_parent par name - ; return $ Left (replaceLWrappedName n name) } + ; return + $ Left (replaceLWrappedName n name) } IncorrectParent p g td gs -> failWithDcErr p g td gs diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index a033bc44a5..667d8664a3 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -8,6 +8,8 @@ Functions for working with the typechecker environment (setters, getters...). {-# LANGUAGE CPP, ExplicitForAll, FlexibleInstances, BangPatterns #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE ViewPatterns #-} + module TcRnMonad( -- * Initalisation @@ -56,7 +58,7 @@ module TcRnMonad( -- * Error management getSrcSpanM, setSrcSpan, addLocM, - wrapLocM, wrapLocFstM, wrapLocSndM, + wrapLocM, wrapLocFstM, wrapLocSndM,wrapLocM_, getErrsVar, setErrsVar, addErr, failWith, failAt, @@ -835,23 +837,31 @@ setSrcSpan (RealSrcSpan real_loc) thing_inside -- Don't overwrite useful info with useless: setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside -addLocM :: (a -> TcM b) -> Located a -> TcM b -addLocM fn (L loc a) = setSrcSpan loc $ fn a - -wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b) -wrapLocM fn (L loc a) = setSrcSpan loc $ do b <- fn a; return (L loc b) - -wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c) -wrapLocFstM fn (L loc a) = +addLocM :: HasSrcSpan a => (SrcSpanLess a -> TcM b) -> a -> TcM b +addLocM fn (dL->L loc a) = setSrcSpan loc $ fn a + +wrapLocM :: (HasSrcSpan a, HasSrcSpan b) => + (SrcSpanLess a -> TcM (SrcSpanLess b)) -> a -> TcM b +-- wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b) +wrapLocM fn (dL->L loc a) = setSrcSpan loc $ do { b <- fn a + ; return (cL loc b) } +wrapLocFstM :: (HasSrcSpan a, HasSrcSpan b) => + (SrcSpanLess a -> TcM (SrcSpanLess b,c)) -> a -> TcM (b, c) +wrapLocFstM fn (dL->L loc a) = setSrcSpan loc $ do (b,c) <- fn a - return (L loc b, c) + return (cL loc b, c) -wrapLocSndM :: (a -> TcM (b,c)) -> Located a -> TcM (b, Located c) -wrapLocSndM fn (L loc a) = +wrapLocSndM :: (HasSrcSpan a, HasSrcSpan c) => + (SrcSpanLess a -> TcM (b, SrcSpanLess c)) -> a -> TcM (b, c) +wrapLocSndM fn (dL->L loc a) = setSrcSpan loc $ do (b,c) <- fn a - return (b, L loc c) + return (b, cL loc c) + +wrapLocM_ :: HasSrcSpan a => + (SrcSpanLess a -> TcM ()) -> a -> TcM () +wrapLocM_ fn (dL->L loc a) = setSrcSpan loc (fn a) -- Reporting errors @@ -1910,7 +1920,8 @@ forkM doc thing_inside Just r -> r) } setImplicitEnvM :: TypeEnv -> IfL a -> IfL a -setImplicitEnvM tenv m = updLclEnv (\lcl -> lcl { if_implicits_env = Just tenv }) m +setImplicitEnvM tenv m = updLclEnv (\lcl -> lcl + { if_implicits_env = Just tenv }) m {- Note [Masking exceptions in forkM_maybe] diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 5725cfd703..8fbfc33895 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -8,6 +8,7 @@ TcTyClsDecls: Typecheck type and class declarations {-# LANGUAGE CPP, TupleSections, MultiWayIf #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module TcTyClsDecls ( tcTyAndClassDecls, @@ -484,7 +485,8 @@ kcTyClGroup :: [LTyClDecl GhcRn] -> TcM [TcTyCon] -- the arity kcTyClGroup decls = do { mod <- getModule - ; traceTc "---- kcTyClGroup ---- {" (text "module" <+> ppr mod $$ vcat (map ppr decls)) + ; traceTc "---- kcTyClGroup ---- {" + (text "module" <+> ppr mod $$ vcat (map ppr decls)) -- Kind checking; -- 1. Bind kind variables for decls @@ -762,14 +764,15 @@ mk_prom_err_env (ClassDecl { tcdLName = L _ nm, tcdATs = ats }) = unitNameEnv nm (APromotionErr ClassPE) `plusNameEnv` mkNameEnv [ (name, APromotionErr TyConPE) - | L _ (FamilyDecl { fdLName = L _ name }) <- ats ] + | (dL->L _ (FamilyDecl { fdLName = (dL->L _ name) })) <- ats ] -mk_prom_err_env (DataDecl { tcdLName = L _ name +mk_prom_err_env (DataDecl { tcdLName = (dL->L _ name) , tcdDataDefn = HsDataDefn { dd_cons = cons } }) = unitNameEnv name (APromotionErr TyConPE) `plusNameEnv` mkNameEnv [ (con, APromotionErr RecDataConPE) - | L _ con' <- cons, L _ con <- getConNames con' ] + | (dL->L _ con') <- cons + , (dL->L _ con) <- getConNames con' ] mk_prom_err_env decl = unitNameEnv (tcdName decl) (APromotionErr TyConPE) @@ -797,7 +800,9 @@ getInitialKind :: TyClDecl GhcRn -> TcM [TcTyCon] -- -- No family instances are passed to getInitialKinds -getInitialKind decl@(ClassDecl { tcdLName = L _ name, tcdTyVars = ktvs, tcdATs = ats }) +getInitialKind decl@(ClassDecl { tcdLName = (dL->L _ name) + , tcdTyVars = ktvs + , tcdATs = ats }) = do { let cusk = hsDeclHasCusk decl ; tycon <- kcLHsQTyVars name ClassFlavour cusk ktvs $ return constraintKind @@ -807,7 +812,7 @@ getInitialKind decl@(ClassDecl { tcdLName = L _ name, tcdTyVars = ktvs, tcdATs = getFamDeclInitialKinds (Just tycon) ats ; return (tycon : inner_tcs) } -getInitialKind decl@(DataDecl { tcdLName = L _ name +getInitialKind decl@(DataDecl { tcdLName = (dL->L _ name) , tcdTyVars = ktvs , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig , dd_ND = new_or_data } }) @@ -823,7 +828,7 @@ getInitialKind (FamDecl { tcdFam = decl }) = do { tc <- getFamDeclInitialKind Nothing decl ; return [tc] } -getInitialKind decl@(SynDecl { tcdLName = L _ name +getInitialKind decl@(SynDecl { tcdLName = (dL->L _ name) , tcdTyVars = ktvs , tcdRhs = rhs }) = do { tycon <- kcLHsQTyVars name TypeSynonymFlavour (hsDeclHasCusk decl) @@ -834,12 +839,12 @@ getInitialKind decl@(SynDecl { tcdLName = L _ name ; return [tycon] } where -- Keep this synchronized with 'hsDeclHasCusk'. - kind_annotation (L _ ty) = case ty of + kind_annotation (dL->L _ ty) = case ty of HsParTy _ lty -> kind_annotation lty HsKindSig _ _ k -> Just k _ -> Nothing -getInitialKind (DataDecl _ (L _ _) _ _ (XHsDataDefn _)) = panic "getInitialKind" +getInitialKind (DataDecl _ _ _ _ (XHsDataDefn _)) = panic "getInitialKind" getInitialKind (XTyClDecl _) = panic "getInitialKind" --------------------------------- @@ -855,14 +860,14 @@ getFamDeclInitialKind -> FamilyDecl GhcRn -> TcM TcTyCon getFamDeclInitialKind mb_parent_tycon - decl@(FamilyDecl { fdLName = L _ name + decl@(FamilyDecl { fdLName = (dL->L _ name) , fdTyVars = ktvs - , fdResultSig = L _ resultSig + , fdResultSig = (dL->L _ resultSig) , fdInfo = info }) = kcLHsQTyVars name flav cusk ktvs $ case resultSig of - KindSig _ ki -> tcLHsKindSig ctxt ki - TyVarSig _ (L _ (KindedTyVar _ _ ki)) -> tcLHsKindSig ctxt ki + KindSig _ ki -> tcLHsKindSig ctxt ki + TyVarSig _ (dL->L _ (KindedTyVar _ _ ki)) -> tcLHsKindSig ctxt ki _ -- open type families have * return kind by default | tcFlavourIsOpen flav -> return liftedTypeKind -- closed type families have their return kind inferred @@ -882,7 +887,7 @@ getFamDeclInitialKind _ (XFamilyDecl _) = panic "getFamDeclInitialKind" ------------------------------------------------------------------------ kcLTyClDecl :: LTyClDecl GhcRn -> TcM () -- See Note [Kind checking for type and class decls] -kcLTyClDecl (L loc decl) +kcLTyClDecl (dL->L loc decl) | hsDeclHasCusk decl -- See Note [Skip decls with CUSKs in kcLTyClDecl] = traceTc "kcTyClDecl skipped due to cusk:" (ppr tc_name) @@ -901,9 +906,11 @@ kcTyClDecl :: TyClDecl GhcRn -> TcM () -- result kind signature have already been dealt with -- by getInitialKind, so we can ignore them here. -kcTyClDecl (DataDecl { tcdLName = L _ name, tcdDataDefn = defn }) - | HsDataDefn { dd_cons = cons@(L _ (ConDeclGADT {}) : _), dd_ctxt = L _ [] } <- defn - = mapM_ (wrapLocM kcConDecl) cons +kcTyClDecl (DataDecl { tcdLName = (dL->L _ name) + , tcdDataDefn = defn }) + | HsDataDefn { dd_cons = cons@((dL->L _ (ConDeclGADT {})) : _) + , dd_ctxt = (dL->L _ []) } <- defn + = mapM_ (wrapLocM_ kcConDecl) cons -- hs_tvs and dd_kindSig already dealt with in getInitialKind -- This must be a GADT-style decl, -- (see invariants of DataDefn declaration) @@ -914,26 +921,27 @@ kcTyClDecl (DataDecl { tcdLName = L _ name, tcdDataDefn = defn }) | HsDataDefn { dd_ctxt = ctxt, dd_cons = cons } <- defn = kcTyClTyVars name $ do { _ <- tcHsContext ctxt - ; mapM_ (wrapLocM kcConDecl) cons } + ; mapM_ (wrapLocM_ kcConDecl) cons } -kcTyClDecl (SynDecl { tcdLName = L _ name, tcdRhs = lrhs }) +kcTyClDecl (SynDecl { tcdLName = (dL->L _ name) + , tcdRhs = lrhs }) = kcTyClTyVars name $ do { syn_tc <- kcLookupTcTyCon name -- NB: check against the result kind that we allocated -- in getInitialKinds. ; discardResult $ tcCheckLHsType lrhs (tyConResKind syn_tc) } -kcTyClDecl (ClassDecl { tcdLName = L _ name +kcTyClDecl (ClassDecl { tcdLName = (dL->L _ name) , tcdCtxt = ctxt, tcdSigs = sigs }) = kcTyClTyVars name $ do { _ <- tcHsContext ctxt - ; mapM_ (wrapLocM kc_sig) sigs } + ; mapM_ (wrapLocM_ kc_sig) sigs } where kc_sig (ClassOpSig _ _ nms op_ty) = kcHsSigType (TyConSkol ClassFlavour name) nms op_ty kc_sig _ = return () -kcTyClDecl (FamDecl _ (FamilyDecl { fdLName = L _ fam_tc_name +kcTyClDecl (FamDecl _ (FamilyDecl { fdLName = (dL->L _ fam_tc_name) , fdInfo = fd_info })) -- closed type families look at their equations, but other families don't -- do anything here @@ -943,7 +951,7 @@ kcTyClDecl (FamDecl _ (FamilyDecl { fdLName = L _ fam_tc_name ; mapM_ (kcTyFamInstEqn fam_tc) eqns } _ -> return () kcTyClDecl (FamDecl _ (XFamilyDecl _)) = panic "kcTyClDecl" -kcTyClDecl (DataDecl _ (L _ _) _ _ (XHsDataDefn _)) = panic "kcTyClDecl" +kcTyClDecl (DataDecl _ _ _ _ (XHsDataDefn _)) = panic "kcTyClDecl" kcTyClDecl (XTyClDecl _) = panic "kcTyClDecl" ------------------- @@ -1128,7 +1136,7 @@ e.g. the need to make the data constructor worker name for -} tcTyClDecl :: RolesInfo -> LTyClDecl GhcRn -> TcM TyCon -tcTyClDecl roles_info (L loc decl) +tcTyClDecl roles_info (dL->L loc decl) | Just thing <- wiredInNameTyThing_maybe (tcdName decl) = case thing of -- See Note [Declarations for wired-in things] ATyCon tc -> return tc @@ -1148,24 +1156,28 @@ tcTyClDecl1 parent _roles_info (FamDecl { tcdFam = fd }) -- "type" synonym declaration tcTyClDecl1 _parent roles_info - (SynDecl { tcdLName = L _ tc_name, tcdRhs = rhs }) + (SynDecl { tcdLName = (dL->L _ tc_name) + , tcdRhs = rhs }) = ASSERT( isNothing _parent ) tcTyClTyVars tc_name $ \ binders res_kind -> tcTySynRhs roles_info tc_name binders res_kind rhs -- "data/newtype" declaration tcTyClDecl1 _parent roles_info - (DataDecl { tcdLName = L _ tc_name + (DataDecl { tcdLName = (dL->L _ tc_name) , tcdDataDefn = defn }) = ASSERT( isNothing _parent ) tcTyClTyVars tc_name $ \ tycon_binders res_kind -> tcDataDefn roles_info tc_name tycon_binders res_kind defn tcTyClDecl1 _parent roles_info - (ClassDecl { tcdLName = L _ class_name - , tcdCtxt = hs_ctxt, tcdMeths = meths - , tcdFDs = fundeps, tcdSigs = sigs - , tcdATs = ats, tcdATDefs = at_defs }) + (ClassDecl { tcdLName = (dL->L _ class_name) + , tcdCtxt = hs_ctxt + , tcdMeths = meths + , tcdFDs = fundeps + , tcdSigs = sigs + , tcdATs = ats + , tcdATDefs = at_defs }) = ASSERT( isNothing _parent ) do { clas <- tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs @@ -1260,10 +1272,10 @@ tcClassATs class_name cls ats at_defs ; mapM tc_at ats } where at_def_tycon :: LTyFamDefltEqn GhcRn -> Name - at_def_tycon (L _ eqn) = unLoc (feqn_tycon eqn) + at_def_tycon (dL->L _ eqn) = unLoc (feqn_tycon eqn) at_fam_name :: LFamilyDecl GhcRn -> Name - at_fam_name (L _ decl) = unLoc (fdLName decl) + at_fam_name (dL->L _ decl) = unLoc (fdLName decl) at_names = mkNameSet (map at_fam_name ats) @@ -1290,9 +1302,9 @@ tcDefaultAssocDecl _ (d1:_:_) = failWithTc (text "More than one default declaration for" <+> ppr (feqn_tycon (unLoc d1))) -tcDefaultAssocDecl fam_tc [L loc (FamEqn { feqn_tycon = L _ tc_name - , feqn_pats = hs_tvs - , feqn_rhs = rhs })] +tcDefaultAssocDecl fam_tc [dL->L loc (FamEqn { feqn_tycon = (dL->L _ tc_name) + , feqn_pats = hs_tvs + , feqn_rhs = rhs })] | HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = imp_vars} , hsq_explicit = exp_vars } <- hs_tvs = -- See Note [Type-checking default assoc decls] @@ -1342,9 +1354,12 @@ tcDefaultAssocDecl fam_tc [L loc (FamEqn { feqn_tycon = L _ tc_name -- We check for well-formedness and validity later, -- in checkValidClass } -tcDefaultAssocDecl _ [L _ (XFamEqn _)] = panic "tcDefaultAssocDecl" -tcDefaultAssocDecl _ [L _ (FamEqn _ (L _ _) _ (XLHsQTyVars _) _ _)] +tcDefaultAssocDecl _ [dL->L _ (XFamEqn _)] = panic "tcDefaultAssocDecl" +tcDefaultAssocDecl _ [dL->L _ (FamEqn _ _ _ (XLHsQTyVars _) _ _)] = panic "tcDefaultAssocDecl" +tcDefaultAssocDecl _ [_] + = panic "tcDefaultAssocDecl: Impossible Match" -- due to #15884 + {- Note [Type-checking default assoc decls] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1382,8 +1397,10 @@ but it works. ********************************************************************* -} tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM TyCon -tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info, fdLName = tc_lname@(L _ tc_name) - , fdResultSig = L _ sig, fdTyVars = user_tyvars +tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info + , fdLName = tc_lname@(dL->L _ tc_name) + , fdResultSig = (dL->L _ sig) + , fdTyVars = user_tyvars , fdInjectivityAnn = inj }) | DataFamily <- fam_info = tcTyClTyVars tc_name $ \ binders res_kind -> do @@ -1499,7 +1516,7 @@ tcInjectivity _ Nothing -- therefore we can always infer the result kind if we know the result type. -- But this does not seem to be useful in any way so we don't do it. (Another -- reason is that the implementation would not be straightforward.) -tcInjectivity tcbs (Just (L loc (InjectivityAnn _ lInjNames))) +tcInjectivity tcbs (Just (dL->L loc (InjectivityAnn _ lInjNames))) = setSrcSpan loc $ do { let tvs = binderVars tcbs ; dflags <- getDynFlags @@ -1597,8 +1614,9 @@ tcDataDefn _ _ _ _ (XHsDataDefn _) = panic "tcDataDefn" ------------------------- kcTyFamInstEqn :: TcTyCon -> LTyFamInstEqn GhcRn -> TcM () kcTyFamInstEqn tc_fam_tc - (L loc (HsIB { hsib_ext = imp_vars - , hsib_body = FamEqn { feqn_tycon = L _ eqn_tc_name + (dL->L loc + (HsIB { hsib_ext = imp_vars + , hsib_body = FamEqn { feqn_tycon = (dL->L _ eqn_tc_name) , feqn_bndrs = mb_expl_bndrs , feqn_pats = pats , feqn_rhs = hs_ty }})) @@ -1619,8 +1637,9 @@ kcTyFamInstEqn tc_fam_tc where fam_name = tyConName tc_fam_tc vis_arity = length (tyConVisibleTyVars tc_fam_tc) -kcTyFamInstEqn _ (L _ (XHsImplicitBndrs _)) = panic "kcTyFamInstEqn" -kcTyFamInstEqn _ (L _ (HsIB _ (XFamEqn _))) = panic "kcTyFamInstEqn" +kcTyFamInstEqn _ (dL->L _ (XHsImplicitBndrs _)) = panic "kcTyFamInstEqn" +kcTyFamInstEqn _ (dL->L _ (HsIB _ (XFamEqn _))) = panic "kcTyFamInstEqn" +kcTyFamInstEqn _ _ = panic "kcTyFamInstEqn: Impossible Match" -- due to #15884 -- Infer the kind of the type on the RHS of a type family eqn. Then use -- this kind to check the kind of the LHS of the equation. This is useful @@ -1654,11 +1673,11 @@ tcTyFamInstEqn :: TcTyCon -> Maybe ClsInstInfo -> LTyFamInstEqn GhcRn -- Needs to be here, not in TcInstDcls, because closed families -- (typechecked here) have TyFamInstEqns tcTyFamInstEqn fam_tc mb_clsinfo - (L loc (HsIB { hsib_ext = imp_vars - , hsib_body = FamEqn { feqn_tycon = L _ eqn_tc_name - , feqn_bndrs = mb_expl_bndrs - , feqn_pats = pats - , feqn_rhs = hs_ty }})) + (dL->L loc (HsIB { hsib_ext = imp_vars + , hsib_body = FamEqn { feqn_tycon = (dL->L _ eqn_tc_name) + , feqn_bndrs = mb_expl_bndrs + , feqn_pats = pats + , feqn_rhs = hs_ty }})) = ASSERT( getName fam_tc == eqn_tc_name ) setSrcSpan loc $ tcFamTyPats fam_tc mb_clsinfo imp_vars mb_expl_bndrs pats @@ -1676,8 +1695,9 @@ tcTyFamInstEqn fam_tc mb_clsinfo ; return (mkCoAxBranch tvs' [] pats' rhs_ty' (map (const Nominal) tvs') loc) } -tcTyFamInstEqn _ _ (L _ (XHsImplicitBndrs _)) = panic "tcTyFamInstEqn" -tcTyFamInstEqn _ _ (L _ (HsIB _ (XFamEqn _))) = panic "tcTyFamInstEqn" +tcTyFamInstEqn _ _ (dL->L _ (XHsImplicitBndrs _)) = panic "tcTyFamInstEqn" +tcTyFamInstEqn _ _ (dL->L _ (HsIB _ (XFamEqn _))) = panic "tcTyFamInstEqn" +tcTyFamInstEqn _ _ _ = panic "tcTyFamInstEqn: Impossible Match" -- due to #15884 kcDataDefn :: Maybe (VarEnv Kind) -- ^ Possibly, instantiations for vars -- (associated types only) @@ -1700,7 +1720,7 @@ kcDataDefn mb_kind_env , dd_kindSig = mb_kind } }}}) res_k = do { _ <- tcHsContext ctxt - ; checkNoErrs $ mapM_ (wrapLocM kcConDecl) cons + ; checkNoErrs $ mapM_ (wrapLocM_ kcConDecl) cons -- See Note [Failing early in kcDataDefn] ; exp_res_kind <- case mb_kind of Nothing -> return liftedTypeKind @@ -1798,7 +1818,7 @@ kcFamTyPats tc_fam_tc imp_vars mb_expl_bndrs arg_pats kind_checker kcExplicitTKBndrs (fromMaybe [] mb_expl_bndrs) $ do { let name = tyConName tc_fam_tc loc = nameSrcSpan name - lhs_fun = L loc (HsTyVar noExt NotPromoted (L loc name)) + lhs_fun = cL loc (HsTyVar noExt NotPromoted (cL loc name)) -- lhs_fun is for error messages only no_fun = pprPanic "kcFamTyPats" (ppr name) fun_kind = tyConKind tc_fam_tc @@ -1852,8 +1872,8 @@ tcFamTyPats fam_tc mb_clsinfo tcImplicitQTKBndrs FamInstSkol imp_vars $ tcExplicitTKBndrs FamInstSkol (fromMaybe [] mb_expl_bndrs) $ do { let loc = nameSrcSpan fam_name - lhs_fun = L loc (HsTyVar noExt NotPromoted - (L loc fam_name)) + lhs_fun = cL loc (HsTyVar noExt NotPromoted + (cL loc fam_name)) fun_ty = mkTyConApp fam_tc [] fun_kind = tyConKind fam_tc mb_kind_env = thdOf3 <$> mb_clsinfo @@ -1862,7 +1882,9 @@ tcFamTyPats fam_tc mb_clsinfo <- tcInferApps typeLevelMode mb_kind_env lhs_fun fun_ty fun_kind arg_pats - ; traceTc "tcFamTyPats 1" (vcat [ ppr fam_tc, ppr arg_pats, ppr res_kind_out ]) + ; traceTc "tcFamTyPats 1" (vcat [ ppr fam_tc + , ppr arg_pats + , ppr res_kind_out ]) ; stuff <- kind_checker res_kind_out ; return (args, stuff) } @@ -2098,8 +2120,8 @@ dataDeclChecks tc_name new_or_data stupid_theta cons ----------------------------------- consUseGadtSyntax :: [LConDecl a] -> Bool -consUseGadtSyntax (L _ (ConDeclGADT { }) : _) = True -consUseGadtSyntax _ = False +consUseGadtSyntax ((dL->L _ (ConDeclGADT {})) : _) = True +consUseGadtSyntax _ = False -- All constructors have same shape ----------------------------------- @@ -2181,7 +2203,7 @@ tcConDecl rep_tycon tag_map tmpl_bndrs res_tmpl -- the universals followed by the existentials. -- See Note [DataCon user type variable binders] in DataCon. user_tvbs = univ_tvbs ++ ex_tvbs - buildOneDataCon (L _ name) = do + buildOneDataCon (dL->L _ name) = do { is_infix <- tcConIsInfixH98 name hs_args ; rep_nm <- newTyConRepName name @@ -2209,8 +2231,8 @@ tcConDecl rep_tycon tag_map tmpl_bndrs res_tmpl , hsq_explicit = explicit_tkv_nms } <- qtvs = addErrCtxt (dataConCtxtName names) $ do { traceTc "tcConDecl 1" (ppr names) - ; let (L _ name : _) = names - skol_info = DataConSkol name + ; let ((dL->L _ name) : _) = names + skol_info = DataConSkol name ; (imp_tvs, (exp_tvs, (ctxt, arg_tys, res_ty, field_lbls, stricts))) <- failIfEmitsConstraints $ -- we won't get another crack, and we don't @@ -2261,7 +2283,7 @@ tcConDecl rep_tycon tag_map tmpl_bndrs res_tmpl -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here ; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls) ; let - buildOneDataCon (L _ name) = do + buildOneDataCon (dL->L _ name) = do { is_infix <- tcConIsInfixGADT name hs_args ; rep_nm <- newTyConRepName name @@ -2324,7 +2346,8 @@ tcConArgs (RecCon fields) = mapM tcConArg btys where -- We need a one-to-one mapping from field_names to btys - combined = map (\(L _ f) -> (cd_fld_names f,cd_fld_type f)) (unLoc fields) + combined = map (\(dL->L _ f) -> (cd_fld_names f,cd_fld_type f)) + (unLoc fields) explode (ns,ty) = zip ns (repeat ty) exploded = concatMap explode combined (_,btys) = unzip exploded @@ -3476,7 +3499,7 @@ checkValidRoleAnnots role_annots tc check_roles = whenIsJust role_annot_decl_maybe $ - \decl@(L loc (RoleAnnotDecl _ _ the_role_annots)) -> + \decl@(dL->L loc (RoleAnnotDecl _ _ the_role_annots)) -> addRoleAnnotCtxt name $ setSrcSpan loc $ do { role_annots_ok <- xoptM LangExt.RoleAnnotations @@ -3500,10 +3523,11 @@ checkValidRoleAnnots role_annots tc = whenIsJust role_annot_decl_maybe illegalRoleAnnotDecl checkRoleAnnot :: TyVar -> Located (Maybe Role) -> Role -> TcM () -checkRoleAnnot _ (L _ Nothing) _ = return () -checkRoleAnnot tv (L _ (Just r1)) r2 +checkRoleAnnot _ (dL->L _ Nothing) _ = return () +checkRoleAnnot tv (dL->L _ (Just r1)) r2 = when (r1 /= r2) $ addErrTc $ badRoleAnnot (tyVarName tv) r1 r2 +checkRoleAnnot _ _ _ = panic "checkRoleAnnot: Impossible Match" -- due to #15884 -- This is a double-check on the role inference algorithm. It is only run when -- -dcore-lint is enabled. See Note [Role inference] in TcTyDecls @@ -3801,20 +3825,25 @@ badRoleAnnot var annot inferred , text "is required" ]) wrongNumberOfRoles :: [a] -> LRoleAnnotDecl GhcRn -> SDoc -wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ _ annots)) +wrongNumberOfRoles tyvars d@(dL->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) -wrongNumberOfRoles _ (L _ (XRoleAnnotDecl _)) = panic "wrongNumberOfRoles" +wrongNumberOfRoles _ (dL->L _ (XRoleAnnotDecl _)) = panic "wrongNumberOfRoles" +wrongNumberOfRoles _ _ = panic "wrongNumberOfRoles: Impossible Match" + -- due to #15884 + illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcM () -illegalRoleAnnotDecl (L loc (RoleAnnotDecl _ tycon _)) +illegalRoleAnnotDecl (dL->L loc (RoleAnnotDecl _ tycon _)) = setErrCtxt [] $ setSrcSpan loc $ addErrTc (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$ text "they are allowed only for datatypes and classes.") -illegalRoleAnnotDecl (L _ (XRoleAnnotDecl _)) = panic "illegalRoleAnnotDecl" +illegalRoleAnnotDecl (dL->L _ (XRoleAnnotDecl _)) = panic "illegalRoleAnnotDecl" +illegalRoleAnnotDecl _ = panic "illegalRoleAnnotDecl: Impossible Match" + -- due to #15884 needXRoleAnnotations :: TyCon -> SDoc needXRoleAnnotations tc diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs index f64b9f3e73..a973cafa8d 100644 --- a/compiler/typecheck/TcTyDecls.hs +++ b/compiler/typecheck/TcTyDecls.hs @@ -11,6 +11,7 @@ files for imported data types. {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module TcTyDecls( RolesInfo, @@ -224,8 +225,9 @@ checkSynCycles this_uid tcs tyclds = do mod = nameModule n ppr_decl tc = case lookupNameEnv lcl_decls n of - Just (L loc decl) -> ppr loc <> colon <+> ppr decl - Nothing -> ppr (getSrcSpan n) <> colon <+> ppr n <+> text "from external module" + Just (dL->L loc decl) -> ppr loc <> colon <+> ppr decl + Nothing -> ppr (getSrcSpan n) <> colon <+> ppr n + <+> text "from external module" where n = tyConName tc @@ -484,7 +486,7 @@ initialRoleEnv1 hsc_src annots_env tc -- is wrong, just ignore it. We check this in the validity check. role_annots = case lookupRoleAnnot annots_env name of - Just (L _ (RoleAnnotDecl _ _ annots)) + Just (dL->L _ (RoleAnnotDecl _ _ annots)) | annots `lengthIs` num_exps -> map unLoc annots _ -> replicate num_exps Nothing default_roles = build_default_roles argflags role_annots @@ -828,12 +830,12 @@ when typechecking the [d| .. |] quote, and typecheck them later. tcRecSelBinds :: [(Id, LHsBind GhcRn)] -> TcM TcGblEnv tcRecSelBinds sel_bind_prs - = tcExtendGlobalValEnv [sel_id | L _ (IdSig _ sel_id) <- sigs] $ + = tcExtendGlobalValEnv [sel_id | (dL->L _ (IdSig _ sel_id)) <- sigs] $ do { (rec_sel_binds, tcg_env) <- discardWarnings $ tcValBinds TopLevel binds sigs getGblEnv ; return (tcg_env `addTypecheckedBinds` map snd rec_sel_binds) } where - sigs = [ L loc (IdSig noExt sel_id) | (sel_id, _) <- sel_bind_prs + sigs = [ cL loc (IdSig noExt sel_id) | (sel_id, _) <- sel_bind_prs , let loc = getSrcSpan sel_id ] binds = [(NonRecursive, unitBag bind) | (_, bind) <- sel_bind_prs] @@ -854,7 +856,7 @@ mkRecSelBind (tycon, fl) mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel -> (Id, LHsBind GhcRn) mkOneRecordSelector all_cons idDetails fl - = (sel_id, L loc sel_bind) + = (sel_id, cL loc sel_bind) where loc = getSrcSpan sel_name lbl = flLabel fl @@ -892,17 +894,18 @@ mkOneRecordSelector all_cons idDetails fl [] unit_rhs] | otherwise = map mk_match cons_w_field ++ deflt mk_match con = mkSimpleMatch (mkPrefixFunRhs sel_lname) - [L loc (mk_sel_pat con)] - (L loc (HsVar noExt (L loc field_var))) - mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields) + [cL loc (mk_sel_pat con)] + (cL loc (HsVar noExt (cL loc field_var))) + mk_sel_pat con = ConPatIn (cL loc (getName con)) (RecCon rec_fields) rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing } rec_field = noLoc (HsRecField { hsRecFieldLbl - = L loc (FieldOcc sel_name (L loc $ mkVarUnqual lbl)) + = cL loc (FieldOcc sel_name + (cL loc $ mkVarUnqual lbl)) , hsRecFieldArg - = L loc (VarPat noExt (L loc field_var)) + = cL loc (VarPat noExt (cL loc field_var)) , hsRecPun = False }) - sel_lname = L loc sel_name + sel_lname = cL loc sel_name field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc -- Add catch-all default case unless the case is exhaustive @@ -910,10 +913,10 @@ mkOneRecordSelector all_cons idDetails fl -- mentions this particular record selector deflt | all dealt_with all_cons = [] | otherwise = [mkSimpleMatch CaseAlt - [L loc (WildPat noExt)] - (mkHsApp (L loc (HsVar noExt - (L loc (getName rEC_SEL_ERROR_ID)))) - (L loc (HsLit noExt msg_lit)))] + [cL loc (WildPat noExt)] + (mkHsApp (cL loc (HsVar noExt + (cL loc (getName rEC_SEL_ERROR_ID)))) + (cL loc (HsLit noExt msg_lit)))] -- Do not add a default case unless there are unmatched -- constructors. We must take account of GADTs, else we diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index 9e8133e5e8..c8b4989bf3 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -1137,7 +1137,7 @@ instance Binary StringLiteral where fs <- get bh return (StringLiteral st fs) -instance Binary a => Binary (GenLocated SrcSpan a) where +instance Binary a => Binary (Located a) where put_ bh (L l x) = do put_ bh l put_ bh x diff --git a/ghc/GHCi/UI/Info.hs b/ghc/GHCi/UI/Info.hs index 0b354f93e7..d608aadb74 100644 --- a/ghc/GHCi/UI/Info.hs +++ b/ghc/GHCi/UI/Info.hs @@ -2,6 +2,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} -- | Get information on modules, expressions, and identifiers module GHCi.UI.Info @@ -311,7 +312,7 @@ processAllTypeCheckedModule tcm = do -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsBind's getTypeLHsBind :: LHsBind GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type)) - getTypeLHsBind (L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _}) + getTypeLHsBind (dL->L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _}) = pure $ Just (Just (unLoc pid),getLoc pid,varType (unLoc pid)) getTypeLHsBind _ = pure Nothing @@ -323,25 +324,25 @@ processAllTypeCheckedModule tcm = do return $ fmap (\expr -> (mid, getLoc e, CoreUtils.exprType expr)) mbe where mid :: Maybe Id - mid | HsVar _ (L _ i) <- unwrapVar (unLoc e) = Just i - | otherwise = Nothing + mid | HsVar _ (dL->L _ i) <- unwrapVar (unLoc e) = Just i + | otherwise = Nothing unwrapVar (HsWrap _ _ var) = var unwrapVar e' = e' -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LPats's getTypeLPat :: LPat GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type)) - getTypeLPat (L spn pat) = + getTypeLPat (dL->L spn pat) = pure (Just (getMaybeId pat,spn,hsPatType pat)) where - getMaybeId (VarPat _ (L _ vid)) = Just vid - getMaybeId _ = Nothing + getMaybeId (VarPat _ (dL->L _ vid)) = Just vid + getMaybeId _ = Nothing -- | Get ALL source spans in the source. - listifyAllSpans :: Typeable a => TypecheckedSource -> [Located a] + listifyAllSpans :: (HasSrcSpan a , Typeable a) => TypecheckedSource -> [a] listifyAllSpans = everythingAllSpans (++) [] ([] `mkQ` (\x -> [x | p x])) where - p (L spn _) = isGoodSrcSpan spn + p (dL->L spn _) = isGoodSrcSpan spn -- | Variant of @syb@'s @everything@ (which summarises all nodes -- in top-down, left-to-right order) with a stop-condition on 'NameSet's diff --git a/testsuite/tests/ghc-api/T6145.hs b/testsuite/tests/ghc-api/T6145.hs index 3f4afc449e..184070c630 100644 --- a/testsuite/tests/ghc-api/T6145.hs +++ b/testsuite/tests/ghc-api/T6145.hs @@ -1,4 +1,7 @@ {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} module Main where import System.IO @@ -32,12 +35,12 @@ main = do removeFile "Test.hs" print ok where - isDataCon (L _ (AbsBinds { abs_binds = bs })) + isDataCon (dL->L _ (AbsBinds { abs_binds = bs })) = not (isEmptyBag (filterBag isDataCon bs)) - isDataCon (L l (f@FunBind {})) - | (MG _ (L _ (m:_)) _) <- fun_matches f, - (L _ (c@ConPatOut{}):_)<-hsLMatchPats m, - (L l _)<-pat_con c + isDataCon (dL->L l (f@FunBind {})) + | (MG _ (dL->L _ (m:_)) _) <- fun_matches f, + ((dL->L _ (c@ConPatOut{})):_)<-hsLMatchPats m, + (dL->L l _)<-pat_con c = isGoodSrcSpan l -- Check that the source location is a good one isDataCon _ = False diff --git a/testsuite/tests/parser/should_compile/KindSigs.stderr b/testsuite/tests/parser/should_compile/KindSigs.stderr index ebbec08ad5..125e88084a 100644 --- a/testsuite/tests/parser/should_compile/KindSigs.stderr +++ b/testsuite/tests/parser/should_compile/KindSigs.stderr @@ -338,12 +338,14 @@ {OccName: qux})) (Prefix) (NoSrcStrict)) - [({ KindSigs.hs:23:5 } + [(XPat + ({ KindSigs.hs:23:5 } (WildPat - (NoExt))) - ,({ KindSigs.hs:23:7 } + (NoExt)))) + ,(XPat + ({ KindSigs.hs:23:7 } (WildPat - (NoExt)))] + (NoExt))))] (GRHSs (NoExt) [({ KindSigs.hs:23:9-12 } @@ -605,5 +607,3 @@ [])))] (Nothing) (Nothing))) - - diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs index 6020f41d27..f84139fa0d 100644 --- a/utils/ghctags/Main.hs +++ b/utils/ghctags/Main.hs @@ -270,7 +270,7 @@ boundValues mod group = in vals ++ tys ++ fors where found = foundOfLName mod -startOfLocated :: Located a -> RealSrcLoc +startOfLocated :: HasSrcSpan a => a -> RealSrcLoc startOfLocated lHs = case getLoc lHs of RealSrcSpan l -> realSrcSpanStart l UnhelpfulSpan _ -> panic "startOfLocated UnhelpfulSpan" diff --git a/utils/haddock b/utils/haddock -Subproject 0b379984f7898ab0656f71f05fb0163a6a2ddb2 +Subproject 6414b46e1ac8b63cad20d662311788a80e3b29b |