diff options
Diffstat (limited to 'compiler/deSugar')
| -rw-r--r-- | compiler/deSugar/Check.hs | 1226 | ||||
| -rw-r--r-- | compiler/deSugar/Coverage.hs | 415 | ||||
| -rw-r--r-- | compiler/deSugar/Desugar.hs | 106 | ||||
| -rw-r--r-- | compiler/deSugar/DsArrows.hs | 115 | ||||
| -rw-r--r-- | compiler/deSugar/DsBinds.hs | 443 | ||||
| -rw-r--r-- | compiler/deSugar/DsCCall.hs | 6 | ||||
| -rw-r--r-- | compiler/deSugar/DsExpr.hs | 282 | ||||
| -rw-r--r-- | compiler/deSugar/DsForeign.hs | 20 | ||||
| -rw-r--r-- | compiler/deSugar/DsGRHSs.hs | 69 | ||||
| -rw-r--r-- | compiler/deSugar/DsListComp.hs | 262 | ||||
| -rw-r--r-- | compiler/deSugar/DsMeta.hs | 1033 | ||||
| -rw-r--r-- | compiler/deSugar/DsMonad.hs | 211 | ||||
| -rw-r--r-- | compiler/deSugar/DsUsage.hs | 168 | ||||
| -rw-r--r-- | compiler/deSugar/DsUtils.hs | 229 | ||||
| -rw-r--r-- | compiler/deSugar/ExtractDocs.hs | 344 | ||||
| -rw-r--r-- | compiler/deSugar/Match.hs | 277 | ||||
| -rw-r--r-- | compiler/deSugar/Match.hs-boot | 6 | ||||
| -rw-r--r-- | compiler/deSugar/MatchCon.hs | 15 | ||||
| -rw-r--r-- | compiler/deSugar/MatchLit.hs | 130 | ||||
| -rw-r--r-- | compiler/deSugar/PmExpr.hs | 82 | ||||
| -rw-r--r-- | compiler/deSugar/TmOracle.hs | 6 |
21 files changed, 3219 insertions, 2226 deletions
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs index cb9837ed0c..24ce3a9ebb 100644 --- a/compiler/deSugar/Check.hs +++ b/compiler/deSugar/Check.hs @@ -9,17 +9,21 @@ Pattern Matching Coverage Checking. module Check ( -- Checking and printing - checkSingle, checkMatches, isAnyPmCheckEnabled, + checkSingle, checkMatches, checkGuardMatches, isAnyPmCheckEnabled, -- See Note [Type and Term Equality Propagation] - genCaseTmCs1, genCaseTmCs2 + genCaseTmCs1, genCaseTmCs2, + + -- Pattern-match-specific type operations + pmIsClosedType, pmTopNormaliseType_maybe ) where #include "HsVersions.h" -import TmOracle +import GhcPrelude -import BasicTypes +import TmOracle +import Unify( tcMatchTy ) import DynFlags import HsSyn import TcHsSyn @@ -27,6 +31,7 @@ import Id import ConLike import Name import FamInstEnv +import TysPrim (tYPETyCon) import TysWiredIn import TyCon import SrcLoc @@ -34,24 +39,29 @@ import Util import Outputable import FastString import DataCon +import PatSyn import HscTypes (CompleteMatch(..)) import DsMonad import TcSimplify (tcCheckSatisfiability) -import TcType (toTcType, isStringTy, isIntTy, isWordTy) +import TcType (isStringTy) import Bag import ErrUtils import Var (EvVar) +import TyCoRep import Type import UniqSupply -import DsGRHSs (isTrueLHsExpr) +import DsUtils (isTrueLHsExpr) +import Maybes (expectJust) +import qualified GHC.LanguageExtensions as LangExt import Data.List (find) -import Data.Maybe (isJust, fromMaybe) -import Control.Monad (forM, when, forM_) +import Data.Maybe (catMaybes, isJust, fromMaybe) +import Control.Monad (forM, when, forM_, zipWithM) import Coercion import TcEvidence import IOEnv +import qualified Data.Semigroup as Semi import ListT (ListT(..), fold, select) @@ -93,22 +103,27 @@ liftD m = ListT $ \sk fk -> m >>= \a -> sk a fk -- Pick the first match complete covered match or otherwise the "best" match. -- The best match is the one with the least uncovered clauses, ties broken -- by the number of inaccessible clauses followed by number of redundant --- clauses +-- clauses. +-- +-- This is specified in the +-- "Disambiguating between multiple ``COMPLETE`` pragmas" section of the +-- users' guide. If you update the implementation of this function, make sure +-- to update that section of the users' guide as well. getResult :: PmM PmResult -> DsM PmResult -getResult ls = do - res <- fold ls goM (pure Nothing) - case res of - Nothing -> panic "getResult is empty" - Just a -> return a +getResult ls + = do { res <- fold ls goM (pure Nothing) + ; case res of + Nothing -> panic "getResult is empty" + Just a -> return a } where goM :: PmResult -> DsM (Maybe PmResult) -> DsM (Maybe PmResult) - goM mpm dpm = do - pmr <- dpm - return $ go pmr mpm + goM mpm dpm = do { pmr <- dpm + ; return $ Just $ go pmr mpm } + -- Careful not to force unecessary results - go :: Maybe PmResult -> PmResult -> Maybe PmResult - go Nothing rs = Just rs - go old@(Just (PmResult prov rs (UncoveredPatterns us) is)) new + go :: Maybe PmResult -> PmResult -> PmResult + go Nothing rs = rs + go (Just old@(PmResult prov rs (UncoveredPatterns us) is)) new | null us && null rs && null is = old | otherwise = let PmResult prov' rs' (UncoveredPatterns us') is' = new @@ -116,8 +131,8 @@ getResult ls = do `mappend` (compareLength is is') `mappend` (compareLength rs rs') `mappend` (compare prov prov') of - GT -> Just new - EQ -> Just new + GT -> new + EQ -> new LT -> old go (Just (PmResult _ _ (TypeOfUncovered _) _)) _new = panic "getResult: No inhabitation candidates" @@ -141,6 +156,9 @@ data PmPat :: PatTy -> * where PmGrd :: { pm_grd_pv :: PatVec , pm_grd_expr :: PmExpr } -> PmPat 'PAT +instance Outputable (PmPat a) where + ppr = pprPmPatDebug + -- data T a where -- MkT :: forall p q. (Eq p, Ord q) => p -> q -> T [p] -- or MkT :: forall p q r. (Eq p, Ord q, [p] ~ r) => p -> q -> T r @@ -180,11 +198,14 @@ instance Outputable Covered where -- Like the or monoid for booleans -- Covered = True, Uncovered = False +instance Semi.Semigroup Covered where + Covered <> _ = Covered + _ <> Covered = Covered + NotCovered <> NotCovered = NotCovered + instance Monoid Covered where mempty = NotCovered - Covered `mappend` _ = Covered - _ `mappend` Covered = Covered - NotCovered `mappend` NotCovered = NotCovered + mappend = (Semi.<>) data Diverged = Diverged | NotDiverged deriving Show @@ -193,11 +214,14 @@ instance Outputable Diverged where ppr Diverged = text "Diverged" ppr NotDiverged = text "NotDiverged" +instance Semi.Semigroup Diverged where + Diverged <> _ = Diverged + _ <> Diverged = Diverged + NotDiverged <> NotDiverged = NotDiverged + instance Monoid Diverged where mempty = NotDiverged - Diverged `mappend` _ = Diverged - _ `mappend` Diverged = Diverged - NotDiverged `mappend` NotDiverged = NotDiverged + mappend = (Semi.<>) -- | When we learned that a given match group is complete data Provenance = @@ -209,17 +233,20 @@ data Provenance = instance Outputable Provenance where ppr = text . show +instance Semi.Semigroup Provenance where + FromComplete <> _ = FromComplete + _ <> FromComplete = FromComplete + _ <> _ = FromBuiltin + instance Monoid Provenance where mempty = FromBuiltin - FromComplete `mappend` _ = FromComplete - _ `mappend` FromComplete = FromComplete - _ `mappend` _ = FromBuiltin + mappend = (Semi.<>) data PartialResult = PartialResult { - presultProvenence :: Provenance + presultProvenance :: Provenance -- keep track of provenance because we don't want -- to warn about redundant matches if the result - -- is contaiminated with a COMPLETE pragma + -- is contaminated with a COMPLETE pragma , presultCovered :: Covered , presultUncovered :: Uncovered , presultDivergent :: Diverged } @@ -229,14 +256,19 @@ instance Outputable PartialResult where = text "PartialResult" <+> ppr prov <+> ppr c <+> ppr d <+> ppr vsa + +instance Semi.Semigroup PartialResult where + (PartialResult prov1 cs1 vsa1 ds1) + <> (PartialResult prov2 cs2 vsa2 ds2) + = PartialResult (prov1 Semi.<> prov2) + (cs1 Semi.<> cs2) + (vsa1 Semi.<> vsa2) + (ds1 Semi.<> ds2) + + instance Monoid PartialResult where mempty = PartialResult mempty mempty [] mempty - (PartialResult prov1 cs1 vsa1 ds1) - `mappend` (PartialResult prov2 cs2 vsa2 ds2) - = PartialResult (prov1 `mappend` prov2) - (cs1 `mappend` cs2) - (vsa1 `mappend` vsa2) - (ds1 `mappend` ds2) + mappend = (Semi.<>) -- newtype ChoiceOf a = ChoiceOf [a] @@ -253,9 +285,9 @@ instance Monoid PartialResult where -- data PmResult = PmResult { - pmresultProvenance :: Provenance - , pmresultRedundant :: [Located [LPat GhcTc]] - , pmresultUncovered :: UncoveredCandidates + pmresultProvenance :: Provenance + , pmresultRedundant :: [Located [LPat GhcTc]] + , pmresultUncovered :: UncoveredCandidates , pmresultInaccessible :: [Located [LPat GhcTc]] } -- | Either a list of patterns that are not covered, or their type, in case we @@ -314,6 +346,23 @@ checkSingle' locn var p = do (NotCovered, Diverged ) -> PmResult prov [] us' m -- inaccessible rhs where m = [L locn [L locn p]] +-- | Exhaustive for guard matches, is used for guards in pattern bindings and +-- in @MultiIf@ expressions. +checkGuardMatches :: HsMatchContext Name -- Match context + -> GRHSs GhcTc (LHsExpr GhcTc) -- Guarded RHSs + -> DsM () +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 { m_ext = noExt + , m_ctxt = hs_ctx + , m_pats = [] + , m_grhss = guards } + checkMatches dflags dsMatchContext [] [match] +checkGuardMatches _ (XGRHSs _) = panic "checkGuardMatches" + -- | Check a matchgroup (case, functions, etc.) checkMatches :: DynFlags -> DsMatchContext -> [Id] -> [LMatch GhcTc (LHsExpr GhcTc)] -> DsM () @@ -340,7 +389,7 @@ checkMatches' vars matches | otherwise = do liftD resetPmIterDs -- set the iter-no to zero missing <- mkInitialUncovered vars - tracePm "checkMatches: missing" (vcat (map pprValVecDebug missing)) + tracePm "checkMatches': missing" (vcat (map pprValVecDebug missing)) (prov, rs,us,ds) <- go matches missing return $ PmResult { pmresultProvenance = prov @@ -372,48 +421,363 @@ checkMatches' vars matches (NotCovered, Diverged ) -> (final_prov, rs, final_u, m:is) hsLMatchToLPats :: LMatch id body -> Located [LPat id] - hsLMatchToLPats (L l (Match _ pats _ _)) = L l pats + hsLMatchToLPats (L l (Match { m_pats = pats })) = L l pats + hsLMatchToLPats (L _ (XMatch _)) = 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] -- for details. checkEmptyCase' :: Id -> PmM PmResult checkEmptyCase' var = do - tm_css <- map toComplex . bagToList <$> liftD getTmCsDs - case tmOracle initialTmState tm_css of - Just tm_state -> do - ty_css <- liftD getDictsDs - fam_insts <- liftD dsGetFamInstEnvs - mb_candidates <- inhabitationCandidates fam_insts (idType var) - case mb_candidates of - -- Inhabitation checking failed / the type is trivially inhabited - Left ty -> return (uncoveredWithTy ty) - - -- A list of inhabitant candidates is available: Check for each - -- one for the satisfiability of the constraints it gives rise to. - Right candidates -> do - missing_m <- flip concatMapM candidates $ \(va,tm_ct,ty_cs) -> do - let all_ty_cs = unionBags ty_cs ty_css - sat_ty <- tyOracle all_ty_cs - return $ case (sat_ty, tmOracle tm_state (tm_ct:tm_css)) of - (True, Just tm_state') -> [(va, all_ty_cs, tm_state')] - _non_sat -> [] - let mkValVec (va,all_ty_cs,tm_state') - = ValVec [va] (MkDelta all_ty_cs tm_state') - uncovered = UncoveredPatterns (map mkValVec missing_m) - return $ if null missing_m - then emptyPmResult - else PmResult FromBuiltin [] uncovered [] - Nothing -> return emptyPmResult - --- | Generate all inhabitation candidates for a given type. The result is --- either (Left ty), if the type cannot be reduced to a closed algebraic type --- (or if it's one trivially inhabited, like Int), or (Right candidates), if it --- can. In this case, the candidates are the singnature of the tycon, each one --- accompanied by the term- and type- constraints it gives rise to. + tm_ty_css <- pmInitialTmTyCs + fam_insts <- liftD dsGetFamInstEnvs + mb_candidates <- inhabitationCandidates fam_insts (idType var) + case mb_candidates of + -- Inhabitation checking failed / the type is trivially inhabited + Left ty -> return (uncoveredWithTy ty) + + -- A list of inhabitant candidates is available: Check for each + -- one for the satisfiability of the constraints it gives rise to. + Right (_, candidates) -> do + missing_m <- flip mapMaybeM candidates $ + \InhabitationCandidate{ ic_val_abs = va, ic_tm_ct = tm_ct + , ic_ty_cs = ty_cs + , ic_strict_arg_tys = strict_arg_tys } -> do + mb_sat <- pmIsSatisfiable tm_ty_css tm_ct ty_cs strict_arg_tys + pure $ fmap (ValVec [va]) mb_sat + return $ if null missing_m + then emptyPmResult + else PmResult FromBuiltin [] (UncoveredPatterns missing_m) [] + +-- | Returns 'True' if the argument 'Type' is a fully saturated application of +-- a closed type constructor. +-- +-- Closed type constructors are those with a fixed right hand side, as +-- opposed to e.g. associated types. These are of particular interest for +-- pattern-match coverage checking, because GHC can exhaustively consider all +-- possible forms that values of a closed type can take on. +-- +-- Note that this function is intended to be used to check types of value-level +-- patterns, so as a consequence, the 'Type' supplied as an argument to this +-- function should be of kind @Type@. +pmIsClosedType :: Type -> Bool +pmIsClosedType ty + = case splitTyConApp_maybe ty of + Just (tc, ty_args) + | is_algebraic_like tc && not (isFamilyTyCon tc) + -> ASSERT2( ty_args `lengthIs` tyConArity tc, ppr ty ) True + _other -> False + where + -- This returns True for TyCons which /act like/ algebraic types. + -- (See "Type#type_classification" for what an algebraic type is.) + -- + -- This is qualified with \"like\" because of a particular special + -- case: TYPE (the underlyind kind behind Type, among others). TYPE + -- is conceptually a datatype (and thus algebraic), but in practice it is + -- a primitive builtin type, so we must check for it specially. + -- + -- NB: it makes sense to think of TYPE as a closed type in a value-level, + -- pattern-matching context. However, at the kind level, TYPE is certainly + -- not closed! Since this function is specifically tailored towards pattern + -- matching, however, it's OK to label TYPE as closed. + is_algebraic_like :: TyCon -> Bool + is_algebraic_like tc = isAlgTyCon tc || tc == tYPETyCon + +pmTopNormaliseType_maybe :: FamInstEnvs -> Type -> Maybe (Type, [DataCon], Type) +-- ^ Get rid of *outermost* (or toplevel) +-- * type function redex +-- * data family redex +-- * newtypes +-- +-- Behaves exactly like `topNormaliseType_maybe`, but instead of returning a +-- coercion, it returns useful information for issuing pattern matching +-- warnings. See Note [Type normalisation for EmptyCase] for details. +pmTopNormaliseType_maybe env typ + = do ((ty_f,tm_f), ty) <- topNormaliseTypeX stepper comb typ + return (eq_src_ty ty (typ : ty_f [ty]), tm_f [], ty) + where + -- Find the first type in the sequence of rewrites that is a data type, + -- newtype, or a data family application (not the representation tycon!). + -- This is the one that is equal (in source Haskell) to the initial type. + -- If none is found in the list, then all of them are type family + -- applications, so we simply return the last one, which is the *simplest*. + eq_src_ty :: Type -> [Type] -> Type + eq_src_ty ty tys = maybe ty id (find is_closed_or_data_family tys) + + is_closed_or_data_family :: Type -> Bool + is_closed_or_data_family ty = pmIsClosedType ty || isDataFamilyAppType ty + + -- For efficiency, represent both lists as difference lists. + -- comb performs the concatenation, for both lists. + comb (tyf1, tmf1) (tyf2, tmf2) = (tyf1 . tyf2, tmf1 . tmf2) + + stepper = newTypeStepper `composeSteppers` tyFamStepper + + -- A 'NormaliseStepper' that unwraps newtypes, careful not to fall into + -- a loop. If it would fall into a loop, it produces 'NS_Abort'. + newTypeStepper :: NormaliseStepper ([Type] -> [Type],[DataCon] -> [DataCon]) + newTypeStepper rec_nts tc tys + | Just (ty', _co) <- instNewTyCon_maybe tc tys + = case checkRecTc rec_nts tc of + Just rec_nts' -> let tyf = ((TyConApp tc tys):) + tmf = ((tyConSingleDataCon tc):) + in NS_Step rec_nts' ty' (tyf, tmf) + Nothing -> NS_Abort + | otherwise + = NS_Done + + tyFamStepper :: NormaliseStepper ([Type] -> [Type], [DataCon] -> [DataCon]) + tyFamStepper rec_nts tc tys -- Try to step a type/data family + = let (_args_co, ntys) = normaliseTcArgs env Representational tc tys in + -- NB: It's OK to use normaliseTcArgs here instead of + -- normalise_tc_args (which takes the LiftingContext described + -- in Note [Normalising types]) because the reduceTyFamApp below + -- works only at top level. We'll never recur in this function + -- after reducing the kind of a bound tyvar. + + case reduceTyFamApp_maybe env Representational tc ntys of + Just (_co, rhs) -> NS_Step rec_nts rhs ((rhs:), id) + _ -> NS_Done + +-- | Determine suitable constraints to use at the beginning of pattern-match +-- coverage checking by consulting the sets of term and type constraints +-- currently in scope. If one of these sets of constraints is unsatisfiable, +-- use an empty set in its place. (See +-- @Note [Recovering from unsatisfiable pattern-matching constraints]@ +-- for why this is done.) +pmInitialTmTyCs :: PmM Delta +pmInitialTmTyCs = do + ty_cs <- liftD getDictsDs + tm_cs <- map toComplex . bagToList <$> liftD getTmCsDs + sat_ty <- tyOracle ty_cs + let initTyCs = if sat_ty then ty_cs else emptyBag + initTmState = fromMaybe initialTmState (tmOracle initialTmState tm_cs) + pure $ MkDelta{ delta_tm_cs = initTmState, delta_ty_cs = initTyCs } + +{- +Note [Recovering from unsatisfiable pattern-matching constraints] +~~~~~~~~~~~~~~~~ +Consider the following code (see #12957 and #15450): + + f :: Int ~ Bool => () + f = case True of { False -> () } + +We want to warn that the pattern-matching in `f` is non-exhaustive. But GHC +used not to do this; in fact, it would warn that the match was /redundant/! +This is because the constraint (Int ~ Bool) in `f` is unsatisfiable, and the +coverage checker deems any matches with unsatifiable constraint sets to be +unreachable. + +We decide to better than this. When beginning coverage checking, we first +check if the constraints in scope are unsatisfiable, and if so, we start +afresh with an empty set of constraints. This way, we'll get the warnings +that we expect. +-} + +-- | Given a conlike's term constraints, type constraints, and strict argument +-- types, check if they are satisfiable. +-- (In other words, this is the ⊢_Sat oracle judgment from the GADTs Meet +-- Their Match paper.) +-- +-- For the purposes of efficiency, this takes as separate arguments the +-- ambient term and type constraints (which are known beforehand to be +-- satisfiable), as well as the new term and type constraints (which may not +-- be satisfiable). This lets us implement two mini-optimizations: +-- +-- * If there are no new type constraints, then don't bother initializing +-- the type oracle, since it's redundant to do so. +-- * Since the new term constraint is a separate argument, we only need to +-- execute one iteration of the term oracle (instead of traversing the +-- entire set of term constraints). +-- +-- Taking strict argument types into account is something which was not +-- discussed in GADTs Meet Their Match. For an explanation of what role they +-- serve, see @Note [Extensions to GADTs Meet Their Match]@. +pmIsSatisfiable + :: Delta -- ^ The ambient term and type constraints + -- (known to be satisfiable). + -> ComplexEq -- ^ The new term constraint. + -> Bag EvVar -- ^ The new type constraints. + -> [Type] -- ^ The strict argument types. + -> PmM (Maybe Delta) + -- ^ @'Just' delta@ if the constraints (@delta@) are + -- satisfiable, and each strict argument type is inhabitable. + -- 'Nothing' otherwise. +pmIsSatisfiable amb_cs new_tm_c new_ty_cs strict_arg_tys = do + mb_sat <- tmTyCsAreSatisfiable amb_cs new_tm_c new_ty_cs + case mb_sat of + Nothing -> pure Nothing + Just delta -> do + -- We know that the term and type constraints are inhabitable, so now + -- check if each strict argument type is inhabitable. + all_non_void <- checkAllNonVoid initRecTc delta strict_arg_tys + pure $ if all_non_void -- Check if each strict argument type + -- is inhabitable + then Just delta + else Nothing + +-- | Like 'pmIsSatisfiable', but only checks if term and type constraints are +-- satisfiable, and doesn't bother checking anything related to strict argument +-- types. +tmTyCsAreSatisfiable + :: Delta -- ^ The ambient term and type constraints + -- (known to be satisfiable). + -> ComplexEq -- ^ The new term constraint. + -> Bag EvVar -- ^ The new type constraints. + -> PmM (Maybe Delta) + -- ^ @'Just' delta@ if the constraints (@delta@) are + -- satisfiable. 'Nothing' otherwise. +tmTyCsAreSatisfiable + (MkDelta{ delta_tm_cs = amb_tm_cs, delta_ty_cs = amb_ty_cs }) + new_tm_c new_ty_cs = do + let ty_cs = new_ty_cs `unionBags` amb_ty_cs + sat_ty <- if isEmptyBag new_ty_cs + then pure True + else tyOracle ty_cs + pure $ case (sat_ty, solveOneEq amb_tm_cs new_tm_c) of + (True, Just term_cs) -> Just $ MkDelta{ delta_ty_cs = ty_cs + , delta_tm_cs = term_cs } + _unsat -> Nothing + +-- | Implements two performance optimizations, as described in the +-- \"Strict argument type constraints\" section of +-- @Note [Extensions to GADTs Meet Their Match]@. +checkAllNonVoid :: RecTcChecker -> Delta -> [Type] -> PmM Bool +checkAllNonVoid rec_ts amb_cs strict_arg_tys = do + fam_insts <- liftD dsGetFamInstEnvs + let tys_to_check = filterOut (definitelyInhabitedType fam_insts) + strict_arg_tys + rec_max_bound | tys_to_check `lengthExceeds` 1 + = 1 + | otherwise + = defaultRecTcMaxBound + rec_ts' = setRecTcMaxBound rec_max_bound rec_ts + allM (nonVoid rec_ts' amb_cs) tys_to_check + +-- | Checks if a strict argument type of a conlike is inhabitable by a +-- terminating value (i.e, an 'InhabitationCandidate'). +-- See @Note [Extensions to GADTs Meet Their Match]@. +nonVoid + :: RecTcChecker -- ^ The per-'TyCon' recursion depth limit. + -> Delta -- ^ The ambient term/type constraints (known to be + -- satisfiable). + -> Type -- ^ The strict argument type. + -> PmM Bool -- ^ 'True' if the strict argument type might be inhabited by + -- a terminating value (i.e., an 'InhabitationCandidate'). + -- 'False' if it is definitely uninhabitable by anything + -- (except bottom). +nonVoid rec_ts amb_cs strict_arg_ty = do + fam_insts <- liftD dsGetFamInstEnvs + mb_cands <- inhabitationCandidates fam_insts strict_arg_ty + case mb_cands of + Right (tc, cands) + | Just rec_ts' <- checkRecTc rec_ts tc + -> anyM (cand_is_inhabitable rec_ts' amb_cs) cands + -- A strict argument type is inhabitable by a terminating value if + -- at least one InhabitationCandidate is inhabitable. + _ -> pure True + -- Either the type is trivially inhabited or we have exceeded the + -- recursion depth for some TyCon (so bail out and conservatively + -- claim the type is inhabited). + where + -- Checks if an InhabitationCandidate for a strict argument type: + -- + -- (1) Has satisfiable term and type constraints. + -- (2) Has 'nonVoid' strict argument types (we bail out of this + -- check if recursion is detected). + -- + -- See Note [Extensions to GADTs Meet Their Match] + cand_is_inhabitable :: RecTcChecker -> Delta + -> InhabitationCandidate -> PmM Bool + cand_is_inhabitable rec_ts amb_cs + (InhabitationCandidate{ ic_tm_ct = new_term_c + , ic_ty_cs = new_ty_cs + , ic_strict_arg_tys = new_strict_arg_tys }) = do + mb_sat <- tmTyCsAreSatisfiable amb_cs new_term_c new_ty_cs + case mb_sat of + Nothing -> pure False + Just new_delta -> do + checkAllNonVoid rec_ts new_delta new_strict_arg_tys + +-- | @'definitelyInhabitedType' ty@ returns 'True' if @ty@ has at least one +-- constructor @C@ such that: +-- +-- 1. @C@ has no equality constraints. +-- 2. @C@ has no strict argument types. +-- +-- See the \"Strict argument type constraints\" section of +-- @Note [Extensions to GADTs Meet Their Match]@. +definitelyInhabitedType :: FamInstEnvs -> Type -> Bool +definitelyInhabitedType env ty + | Just (_, cons, _) <- pmTopNormaliseType_maybe env ty + = any meets_criteria cons + | otherwise + = False + where + meets_criteria :: DataCon -> Bool + meets_criteria con = + null (dataConEqSpec con) && -- (1) + null (dataConImplBangs con) -- (2) + +{- Note [Type normalisation for EmptyCase] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +EmptyCase is an exception for pattern matching, since it is strict. This means +that it boils down to checking whether the type of the scrutinee is inhabited. +Function pmTopNormaliseType_maybe gets rid of the outermost type function/data +family redex and newtypes, in search of an algebraic type constructor, which is +easier to check for inhabitation. + +It returns 3 results instead of one, because there are 2 subtle points: +1. Newtypes are isomorphic to the underlying type in core but not in the source + language, +2. The representational data family tycon is used internally but should not be + shown to the user + +Hence, if pmTopNormaliseType_maybe env ty = Just (src_ty, dcs, core_ty), then + (a) src_ty is the rewritten type which we can show to the user. That is, the + type we get if we rewrite type families but not data families or + newtypes. + (b) dcs is the list of data constructors "skipped", every time we normalise a + newtype to it's core representation, we keep track of the source data + constructor. + (c) core_ty is the rewritten type. That is, + pmTopNormaliseType_maybe env ty = Just (src_ty, dcs, core_ty) + implies + topNormaliseType_maybe env ty = Just (co, core_ty) + for some coercion co. + +To see how all cases come into play, consider the following example: + + data family T a :: * + data instance T Int = T1 | T2 Bool + -- Which gives rise to FC: + -- data T a + -- data R:TInt = T1 | T2 Bool + -- axiom ax_ti : T Int ~R R:TInt + + newtype G1 = MkG1 (T Int) + newtype G2 = MkG2 G1 + + type instance F Int = F Char + type instance F Char = G2 + +In this case pmTopNormaliseType_maybe env (F Int) results in + + Just (G2, [MkG2,MkG1], R:TInt) + +Which means that in source Haskell: + - G2 is equivalent to F Int (in contrast, G1 isn't). + - if (x : R:TInt) then (MkG2 (MkG1 x) : F Int). +-} + +-- | Generate all 'InhabitationCandidate's for a given type. The result is +-- either @'Left' ty@, if the type cannot be reduced to a closed algebraic type +-- (or if it's one trivially inhabited, like 'Int'), or @'Right' candidates@, +-- if it can. In this case, the candidates are the signature of the tycon, each +-- one accompanied by the term- and type- constraints it gives rise to. -- See also Note [Checking EmptyCase Expressions] inhabitationCandidates :: FamInstEnvs -> Type - -> PmM (Either Type [(ValAbs, ComplexEq, Bag EvVar)]) + -> PmM (Either Type (TyCon, [InhabitationCandidate])) inhabitationCandidates fam_insts ty = case pmTopNormaliseType_maybe fam_insts ty of Just (src_ty, dcs, core_ty) -> alts_to_check src_ty core_ty dcs @@ -431,18 +795,28 @@ inhabitationCandidates fam_insts ty -- Inhabitation candidates, using the result of pmTopNormaliseType_maybe alts_to_check :: Type -> Type -> [DataCon] - -> PmM (Either Type [(ValAbs, ComplexEq, Bag EvVar)]) + -> PmM (Either Type (TyCon, [InhabitationCandidate])) alts_to_check src_ty core_ty dcs = case splitTyConApp_maybe core_ty of Just (tc, _) - | tc `elem` trivially_inhabited -> case dcs of - [] -> return (Left src_ty) - (_:_) -> do var <- liftD $ mkPmId (toTcType core_ty) - let va = build_tm (PmVar var) dcs - return $ Right [(va, mkIdEq var, emptyBag)] - | isClosedAlgType core_ty -> liftD $ do - var <- mkPmId (toTcType core_ty) -- it would be wrong to unify x - alts <- mapM (mkOneConFull var . RealDataCon) (tyConDataCons tc) - return $ Right [(build_tm va dcs, eq, cs) | (va, eq, cs) <- alts] + | tc `elem` trivially_inhabited + -> case dcs of + [] -> return (Left src_ty) + (_:_) -> do var <- liftD $ mkPmId core_ty + let va = build_tm (PmVar var) dcs + return $ Right (tc, [InhabitationCandidate + { ic_val_abs = va, ic_tm_ct = mkIdEq var + , ic_ty_cs = emptyBag, ic_strict_arg_tys = [] }]) + + | pmIsClosedType core_ty && not (isAbstractTyCon tc) + -- Don't consider abstract tycons since we don't know what their + -- constructors are, which makes the results of coverage checking + -- them extremely misleading. + -> liftD $ do + var <- mkPmId core_ty -- it would be wrong to unify x + alts <- mapM (mkOneConFull var . RealDataCon) (tyConDataCons tc) + return $ Right + (tc, [ alt{ic_val_abs = build_tm (ic_val_abs alt) dcs} + | alt <- alts ]) -- For other types conservatively assume that they are inhabited. _other -> return (Left src_ty) @@ -505,12 +879,12 @@ truePattern = nullaryConPattern (RealDataCon trueDataCon) -- | A fake guard pattern (True <- _) used to represent cases we cannot handle fake_pat :: Pattern fake_pat = PmGrd { pm_grd_pv = [truePattern] - , pm_grd_expr = PmExprOther EWildPat } + , pm_grd_expr = PmExprOther (EWildPat noExt) } {-# INLINE fake_pat #-} -- | Check whether a guard pattern is generated by the checker (unhandled) isFakeGuard :: [Pattern] -> PmExpr -> Bool -isFakeGuard [PmCon { pm_con_con = RealDataCon c }] (PmExprOther EWildPat) +isFakeGuard [PmCon { pm_con_con = RealDataCon c }] (PmExprOther (EWildPat _)) | c == trueDataCon = True | otherwise = False isFakeGuard _pats _e = False @@ -553,25 +927,25 @@ mkLitPattern lit = PmLit { pm_lit_lit = PmSLit lit } translatePat :: FamInstEnvs -> Pat GhcTc -> DsM PatVec translatePat fam_insts pat = case pat of - WildPat ty -> mkPmVars [ty] - VarPat id -> return [PmVar (unLoc id)] - ParPat p -> translatePat fam_insts (unLoc p) - LazyPat _ -> mkPmVars [hsPatType pat] -- like a variable + WildPat ty -> mkPmVars [ty] + VarPat _ id -> return [PmVar (unLoc id)] + ParPat _ p -> translatePat fam_insts (unLoc p) + LazyPat _ _ -> mkPmVars [hsPatType pat] -- like a variable -- ignore strictness annotations for now - BangPat p -> translatePat fam_insts (unLoc p) + BangPat _ p -> translatePat fam_insts (unLoc p) - AsPat lid p -> do + AsPat _ lid p -> do -- Note [Translating As Patterns] ps <- translatePat fam_insts (unLoc p) let [e] = map vaToPmExpr (coercePatVec ps) g = PmGrd [PmVar (unLoc lid)] e return (ps ++ [g]) - SigPatOut p _ty -> translatePat fam_insts (unLoc p) + SigPat _ty p -> translatePat fam_insts (unLoc p) -- See Note [Translate CoPats] - CoPat wrapper p ty + CoPat _ wrapper p ty | isIdHsWrapper wrapper -> translatePat fam_insts p | WpCast co <- wrapper, isReflexiveCo co -> translatePat fam_insts p | otherwise -> do @@ -581,37 +955,50 @@ translatePat fam_insts pat = case pat of return [xp,g] -- (n + k) ===> x (True <- x >= k) (n <- x-k) - NPlusKPat (L _ _n) _k1 _k2 _ge _minus ty -> mkCanFailPmPat ty + NPlusKPat ty (L _ _n) _k1 _k2 _ge _minus -> mkCanFailPmPat ty -- (fun -> pat) ===> x (pat <- fun x) - ViewPat lexpr lpat arg_ty -> do + ViewPat arg_ty lexpr lpat -> do ps <- translatePat fam_insts (unLoc lpat) -- See Note [Guards and Approximation] case all cantFailPattern ps of True -> do (xp,xe) <- mkPmId2Forms arg_ty - let g = mkGuard ps (HsApp lexpr xe) + let g = mkGuard ps (HsApp noExt lexpr xe) return [xp,g] False -> mkCanFailPmPat arg_ty -- list - ListPat ps ty Nothing -> do + ListPat (ListPatTc ty Nothing) ps -> do foldr (mkListPatVec ty) [nilPattern ty] <$> translatePatVec fam_insts (map unLoc ps) -- overloaded list - ListPat lpats elem_ty (Just (pat_ty, _to_list)) - | Just e_ty <- splitListTyConApp_maybe pat_ty - , (_, norm_elem_ty) <- normaliseType fam_insts Nominal elem_ty - -- elem_ty is frequently something like - -- `Item [Int]`, but we prefer `Int` - , norm_elem_ty `eqType` e_ty -> - -- We have to ensure that the element types are exactly the same. - -- Otherwise, one may give an instance IsList [Int] (more specific than - -- the default IsList [a]) with a different implementation for `toList' - translatePat fam_insts (ListPat lpats e_ty Nothing) - -- See Note [Guards and Approximation] - | otherwise -> mkCanFailPmPat pat_ty + ListPat (ListPatTc _elem_ty (Just (pat_ty, _to_list))) lpats -> do + dflags <- getDynFlags + if xopt LangExt.RebindableSyntax dflags + then mkCanFailPmPat pat_ty + else case splitListTyConApp_maybe pat_ty of + Just e_ty -> translatePat fam_insts + (ListPat (ListPatTc e_ty Nothing) lpats) + Nothing -> mkCanFailPmPat pat_ty + -- (a) In the presence of RebindableSyntax, we don't know anything about + -- `toList`, we should treat `ListPat` as any other view pattern. + -- + -- (b) In the absence of RebindableSyntax, + -- - If the pat_ty is `[a]`, then we treat the overloaded list pattern + -- as ordinary list pattern. Although we can give an instance + -- `IsList [Int]` (more specific than the default `IsList [a]`), in + -- practice, we almost never do that. We assume the `_to_list` is + -- the `toList` from `instance IsList [a]`. + -- + -- - Otherwise, we treat the `ListPat` as ordinary view pattern. + -- + -- See Trac #14547, especially comment#9 and comment#10. + -- + -- Here we construct CanFailPmPat directly, rather can construct a view + -- pattern and do further translation as an optimization, for the reason, + -- see Note [Guards and Approximation]. ConPatOut { pat_con = L _ con , pat_arg_tys = arg_tys @@ -629,26 +1016,29 @@ translatePat fam_insts pat = case pat of , pm_con_dicts = dicts , pm_con_args = args }] - NPat (L _ ol) mb_neg _eq ty -> translateNPat fam_insts ol mb_neg ty + -- See Note [Translate Overloaded Literal for Exhaustiveness Checking] + NPat _ (L _ olit) mb_neg _ + | OverLit (OverLitTc False ty) (HsIsString src s) _ <- olit + , isStringTy ty -> + foldr (mkListPatVec charTy) [nilPattern charTy] <$> + translatePatVec fam_insts + (map (LitPat noExt . HsChar src) (unpackFS s)) + | otherwise -> return [PmLit { pm_lit_lit = PmOLit (isJust mb_neg) olit }] - LitPat lit - -- If it is a string then convert it to a list of characters + -- See Note [Translate Overloaded Literal for Exhaustiveness Checking] + LitPat _ lit | HsString src s <- lit -> foldr (mkListPatVec charTy) [nilPattern charTy] <$> - translatePatVec fam_insts (map (LitPat . HsChar src) (unpackFS s)) + translatePatVec fam_insts + (map (LitPat noExt . HsChar src) (unpackFS s)) | otherwise -> return [mkLitPattern lit] - PArrPat ps ty -> do - tidy_ps <- translatePatVec fam_insts (map unLoc ps) - let fake_con = RealDataCon (parrFakeCon (length ps)) - return [vanillaConPattern fake_con [ty] (concat tidy_ps)] - - TuplePat ps boxity tys -> do + TuplePat tys ps boxity -> do tidy_ps <- translatePatVec fam_insts (map unLoc ps) let tuple_con = RealDataCon (tupleDataCon boxity (length ps)) return [vanillaConPattern tuple_con tys (concat tidy_ps)] - SumPat p alt arity ty -> do + SumPat ty p alt arity -> do tidy_p <- translatePat fam_insts (unLoc p) let sum_con = RealDataCon (sumDataCon alt arity) return [vanillaConPattern sum_con ty tidy_p] @@ -657,31 +1047,92 @@ translatePat fam_insts pat = case pat of -- Not supposed to happen ConPatIn {} -> panic "Check.translatePat: ConPatIn" SplicePat {} -> panic "Check.translatePat: SplicePat" - SigPatIn {} -> panic "Check.translatePat: SigPatIn" - --- | Translate an overloaded literal (see `tidyNPat' in deSugar/MatchLit.hs) -translateNPat :: FamInstEnvs - -> HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> Type - -> DsM PatVec -translateNPat fam_insts (OverLit val False _ ty) mb_neg outer_ty - | not type_change, isStringTy ty, HsIsString src s <- val, Nothing <- mb_neg - = translatePat fam_insts (LitPat (HsString src s)) - | not type_change, isIntTy ty, HsIntegral i <- val - = translatePat fam_insts - (LitPat $ case mb_neg of - Nothing -> HsInt def i - Just _ -> HsInt def (negateIntegralLit i)) - | not type_change, isWordTy ty, HsIntegral i <- val - = translatePat fam_insts - (LitPat $ case mb_neg of - Nothing -> HsWordPrim (il_text i) (il_value i) - Just _ -> let ni = negateIntegralLit i in - HsWordPrim (il_text ni) (il_value ni)) - where - type_change = not (outer_ty `eqType` ty) - -translateNPat _ ol mb_neg _ - = return [PmLit { pm_lit_lit = PmOLit (isJust mb_neg) ol }] + XPat {} -> panic "Check.translatePat: XPat" + +{- Note [Translate Overloaded Literal for Exhaustiveness Checking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The translation of @NPat@ in exhaustiveness checker is a bit different +from translation in pattern matcher. + + * In pattern matcher (see `tidyNPat' in deSugar/MatchLit.hs), we + translate integral literals to HsIntPrim or HsWordPrim and translate + overloaded strings to HsString. + + * In exhaustiveness checker, in `genCaseTmCs1/genCaseTmCs2`, we use + `lhsExprToPmExpr` to generate uncovered set. In `hsExprToPmExpr`, + however we generate `PmOLit` for HsOverLit, rather than refine + `HsOverLit` inside `NPat` to HsIntPrim/HsWordPrim. If we do + the same thing in `translatePat` as in `tidyNPat`, the exhaustiveness + checker will fail to match the literals patterns correctly. See + Trac #14546. + + In Note [Undecidable Equality for Overloaded Literals], we say: "treat + overloaded literals that look different as different", but previously we + didn't do such things. + + Now, we translate the literal value to match and the literal patterns + consistently: + + * For integral literals, we parse both the integral literal value and + the patterns as OverLit HsIntegral. For example: + + case 0::Int of + 0 -> putStrLn "A" + 1 -> putStrLn "B" + _ -> putStrLn "C" + + When checking the exhaustiveness of pattern matching, we translate the 0 + in value position as PmOLit, but translate the 0 and 1 in pattern position + as PmSLit. The inconsistency leads to the failure of eqPmLit to detect the + equality and report warning of "Pattern match is redundant" on pattern 0, + as reported in Trac #14546. In this patch we remove the specialization of + OverLit patterns, and keep the overloaded number literal in pattern as it + is to maintain the consistency. We know nothing about the `fromInteger` + method (see Note [Undecidable Equality for Overloaded Literals]). Now we + can capture the exhaustiveness of pattern 0 and the redundancy of pattern + 1 and _. + + * For string literals, we parse the string literals as HsString. When + OverloadedStrings is enabled, it further be turned as HsOverLit HsIsString. + For example: + + case "foo" of + "foo" -> putStrLn "A" + "bar" -> putStrLn "B" + "baz" -> putStrLn "C" + + Previously, the overloaded string values are translated to PmOLit and the + non-overloaded string values are translated to PmSLit. However the string + patterns, both overloaded and non-overloaded, are translated to list of + characters. The inconsistency leads to wrong warnings about redundant and + non-exhaustive pattern matching warnings, as reported in Trac #14546. + + In order to catch the redundant pattern in following case: + + case "foo" of + ('f':_) -> putStrLn "A" + "bar" -> putStrLn "B" + + in this patch, we translate non-overloaded string literals, both in value + position and pattern position, as list of characters. For overloaded string + literals, we only translate it to list of characters only when it's type + is stringTy, since we know nothing about the toString methods. But we know + that if two overloaded strings are syntax equal, then they are equal. Then + if it's type is not stringTy, we just translate it to PmOLit. We can still + capture the exhaustiveness of pattern "foo" and the redundancy of pattern + "bar" and "baz" in the following code: + + {-# LANGUAGE OverloadedStrings #-} + main = do + case "foo" of + "foo" -> putStrLn "A" + "bar" -> putStrLn "B" + "baz" -> putStrLn "C" + + We must ensure that doing the same translation to literal values and patterns + in `translatePat` and `hsExprToPmExpr`. The previous inconsistent work led to + Trac #14546. +-} -- | Translate a list of patterns (Note: each pattern is translated -- to a pattern vector but we do not concatenate the results). @@ -747,16 +1198,18 @@ 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 _ lpats _ grhss)) = do +translateMatch fam_insts (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 _ (GRHS _ gs _)) = map unLoc gs + extractGuards (L _ (XGRHS _)) = panic "translateMatch" pats = map unLoc lpats guards = map extractGuards (grhssGRHSs grhss) +translateMatch _ (L _ (XMatch _)) = panic "translateMatch" -- ----------------------------------------------------------------------- -- * Transform source guards (GuardStmt Id) to PmPats (Pattern) @@ -804,14 +1257,15 @@ cantFailPattern _ = False -- | Translate a guard statement to Pattern translateGuard :: FamInstEnvs -> GuardStmt GhcTc -> DsM PatVec translateGuard fam_insts guard = case guard of - BodyStmt e _ _ _ -> translateBoolGuard e - LetStmt binds -> translateLet (unLoc binds) - BindStmt p e _ _ _ -> translateBind fam_insts p e + BodyStmt _ e _ _ -> translateBoolGuard e + LetStmt _ binds -> translateLet (unLoc binds) + BindStmt _ p e _ _ -> translateBind fam_insts p e LastStmt {} -> panic "translateGuard LastStmt" ParStmt {} -> panic "translateGuard ParStmt" TransStmt {} -> panic "translateGuard TransStmt" RecStmt {} -> panic "translateGuard RecStmt" ApplicativeStmt {} -> panic "translateGuard ApplicativeLastStmt" + XStmtLR {} -> panic "translateGuard RecStmt" -- | Translate let-bindings translateLet :: HsLocalBinds GhcTc -> DsM PatVec @@ -881,7 +1335,7 @@ An overloaded list @[...]@ should be translated to @x ([...] <- toList x)@. The problem is exactly like above, as its solution. For future reference, the code below is the *right thing to do*: - ListPat lpats elem_ty (Just (pat_ty, to_list)) + ListPat (ListPatTc elem_ty (Just (pat_ty, _to_list))) lpats otherwise -> do (xp, xe) <- mkPmId2Forms pat_ty ps <- translatePatVec (map unLoc lpats) @@ -894,7 +1348,7 @@ below is the *right thing to do*: The case with literals is a bit different. a literal @l@ should be translated to @x (True <- x == from l)@. Since we want to have better warnings for overloaded literals as it is a very common feature, we treat them differently. -They are mainly covered in Note [Undecidable Equality on Overloaded Literals] +They are mainly covered in Note [Undecidable Equality for Overloaded Literals] in PmExpr. 4. N+K Patterns & Pattern Synonyms @@ -952,9 +1406,168 @@ pmPatType (PmGrd { pm_grd_pv = pv }) = ASSERT(patVecArity pv == 1) (pmPatType p) where Just p = find ((==1) . patternArity) pv --- | Generate a value abstraction for a given constructor (generate +-- | Information about a conlike that is relevant to coverage checking. +-- It is called an \"inhabitation candidate\" since it is a value which may +-- possibly inhabit some type, but only if its term constraint ('ic_tm_ct') +-- and type constraints ('ic_ty_cs') are permitting, and if all of its strict +-- argument types ('ic_strict_arg_tys') are inhabitable. +-- See @Note [Extensions to GADTs Meet Their Match]@. +data InhabitationCandidate = + InhabitationCandidate + { ic_val_abs :: ValAbs + , ic_tm_ct :: ComplexEq + , ic_ty_cs :: Bag EvVar + , ic_strict_arg_tys :: [Type] + } + +{- +Note [Extensions to GADTs Meet Their Match] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The GADTs Meet Their Match paper presents the formalism that GHC's coverage +checker adheres to. Since the paper's publication, there have been some +additional features added to the coverage checker which are not described in +the paper. This Note serves as a reference for these new features. + +----- +-- Strict argument type constraints +----- + +In the ConVar case of clause processing, each conlike K traditionally +generates two different forms of constraints: + +* A term constraint (e.g., x ~ K y1 ... yn) +* Type constraints from the conlike's context (e.g., if K has type + forall bs. Q => s1 .. sn -> T tys, then Q would be its type constraints) + +As it turns out, these alone are not enough to detect a certain class of +unreachable code. Consider the following example (adapted from #15305): + + data K = K1 | K2 !Void + + f :: K -> () + f K1 = () + +Even though `f` doesn't match on `K2`, `f` is exhaustive in its patterns. Why? +Because it's impossible to construct a terminating value of type `K` using the +`K2` constructor, and thus it's impossible for `f` to ever successfully match +on `K2`. + +The reason is because `K2`'s field of type `Void` is //strict//. Because there +are no terminating values of type `Void`, any attempt to construct something +using `K2` will immediately loop infinitely or throw an exception due to the +strictness annotation. (If the field were not strict, then `f` could match on, +say, `K2 undefined` or `K2 (let x = x in x)`.) + +Since neither the term nor type constraints mentioned above take strict +argument types into account, we make use of the `nonVoid` function to +determine whether a strict type is inhabitable by a terminating value or not. + +`nonVoid ty` returns True when either: +1. `ty` has at least one InhabitationCandidate for which both its term and type + constraints are satifiable, and `nonVoid` returns `True` for all of the + strict argument types in that InhabitationCandidate. +2. We're unsure if it's inhabited by a terminating value. + +`nonVoid ty` returns False when `ty` is definitely uninhabited by anything +(except bottom). Some examples: + +* `nonVoid Void` returns False, since Void has no InhabitationCandidates. + (This is what lets us discard the `K2` constructor in the earlier example.) +* `nonVoid (Int :~: Int)` returns True, since it has an InhabitationCandidate + (through the Refl constructor), and its term constraint (x ~ Refl) and + type constraint (Int ~ Int) are satisfiable. +* `nonVoid (Int :~: Bool)` returns False. Although it has an + InhabitationCandidate (by way of Refl), its type constraint (Int ~ Bool) is + not satisfiable. +* Given the following definition of `MyVoid`: + + data MyVoid = MkMyVoid !Void + + `nonVoid MyVoid` returns False. The InhabitationCandidate for the MkMyVoid + constructor contains Void as a strict argument type, and since `nonVoid Void` + returns False, that InhabitationCandidate is discarded, leaving no others. + +* Performance considerations + +We must be careful when recursively calling `nonVoid` on the strict argument +types of an InhabitationCandidate, because doing so naïvely can cause GHC to +fall into an infinite loop. Consider the following example: + + data Abyss = MkAbyss !Abyss + + stareIntoTheAbyss :: Abyss -> a + stareIntoTheAbyss x = case x of {} + +In principle, stareIntoTheAbyss is exhaustive, since there is no way to +construct a terminating value using MkAbyss. However, both the term and type +constraints for MkAbyss are satisfiable, so the only way one could determine +that MkAbyss is unreachable is to check if `nonVoid Abyss` returns False. +There is only one InhabitationCandidate for Abyss—MkAbyss—and both its term +and type constraints are satisfiable, so we'd need to check if `nonVoid Abyss` +returns False... and now we've entered an infinite loop! + +To avoid this sort of conundrum, `nonVoid` uses a simple test to detect the +presence of recursive types (through `checkRecTc`), and if recursion is +detected, we bail out and conservatively assume that the type is inhabited by +some terminating value. This avoids infinite loops at the expense of making +the coverage checker incomplete with respect to functions like +stareIntoTheAbyss above. Then again, the same problem occurs with recursive +newtypes, like in the following code: + + newtype Chasm = MkChasm Chasm + + gazeIntoTheChasm :: Chasm -> a + gazeIntoTheChasm x = case x of {} -- Erroneously warned as non-exhaustive + +So this limitation is somewhat understandable. + +Note that even with this recursion detection, there is still a possibility that +`nonVoid` can run in exponential time. Consider the following data type: + + data T = MkT !T !T !T + +If we call `nonVoid` on each of its fields, that will require us to once again +check if `MkT` is inhabitable in each of those three fields, which in turn will +require us to check if `MkT` is inhabitable again... As you can see, the +branching factor adds up quickly, and if the recursion depth limit is, say, +100, then `nonVoid T` will effectively take forever. + +To mitigate this, we check the branching factor every time we are about to call +`nonVoid` on a list of strict argument types. If the branching factor exceeds 1 +(i.e., if there is potential for exponential runtime), then we limit the +maximum recursion depth to 1 to mitigate the problem. If the branching factor +is exactly 1 (i.e., we have a linear chain instead of a tree), then it's okay +to stick with a larger maximum recursion depth. + +Another microoptimization applies to data types like this one: + + data S a = ![a] !T + +Even though there is a strict field of type [a], it's quite silly to call +nonVoid on it, since it's "obvious" that it is inhabitable. To make this +intuition formal, we say that a type is definitely inhabitable (DI) if: + + * It has at least one constructor C such that: + 1. C has no equality constraints (since they might be unsatisfiable) + 2. C has no strict argument types (since they might be uninhabitable) + +It's relatively cheap to cheap if a type is DI, so before we call `nonVoid` +on a list of strict argument types, we filter out all of the DI ones. +-} + +instance Outputable InhabitationCandidate where + ppr (InhabitationCandidate { ic_val_abs = va, ic_tm_ct = tm_ct + , ic_ty_cs = ty_cs + , ic_strict_arg_tys = strict_arg_tys }) = + text "InhabitationCandidate" <+> + vcat [ text "ic_val_abs =" <+> ppr va + , text "ic_tm_ct =" <+> ppr tm_ct + , text "ic_ty_cs =" <+> ppr ty_cs + , text "ic_strict_arg_tys =" <+> ppr strict_arg_tys ] + +-- | Generate an 'InhabitationCandidate' for a given conlike (generate -- fresh variables of the appropriate type for arguments) -mkOneConFull :: Id -> ConLike -> DsM (ValAbs, ComplexEq, Bag EvVar) +mkOneConFull :: Id -> ConLike -> DsM InhabitationCandidate -- * x :: T tys, where T is an algebraic data type -- NB: in the case of a data family, T is the *representation* TyCon -- e.g. data instance T (a,b) = T1 a b @@ -962,28 +1575,32 @@ mkOneConFull :: Id -> ConLike -> DsM (ValAbs, ComplexEq, Bag EvVar) -- data TPair a b = T1 a b -- The "representation" type -- It is TPair, not T, that is given to mkOneConFull -- --- * 'con' K is a constructor of data type T +-- * 'con' K is a conlike of data type T -- -- After instantiating the universal tyvars of K we get -- K tys :: forall bs. Q => s1 .. sn -> T tys -- --- Results: ValAbs: K (y1::s1) .. (yn::sn) --- ComplexEq: x ~ K y1..yn --- [EvVar]: Q +-- Suppose y1 is a strict field. Then we get +-- Results: ic_val_abs: K (y1::s1) .. (yn::sn) +-- ic_tm_ct: x ~ K y1..yn +-- ic_ty_cs: Q +-- ic_strict_arg_tys: [s1] mkOneConFull x con = do - let -- res_ty == TyConApp (ConLikeTyCon cabs_con) cabs_arg_tys - res_ty = idType x - (univ_tvs, ex_tvs, eq_spec, thetas, _req_theta , arg_tys, _) + let res_ty = idType x + (univ_tvs, ex_tvs, eq_spec, thetas, _req_theta , arg_tys, con_res_ty) = conLikeFullSig con - tc_args = case splitTyConApp_maybe res_ty of - Just (_, tys) -> tys - Nothing -> pprPanic "mkOneConFull: Not TyConApp:" (ppr res_ty) - subst1 = zipTvSubst univ_tvs tc_args + arg_is_banged = map isBanged $ conLikeImplBangs con + tc_args = tyConAppArgs res_ty + subst1 = case con of + RealDataCon {} -> zipTvSubst univ_tvs tc_args + PatSynCon {} -> expectJust "mkOneConFull" (tcMatchTy con_res_ty res_ty) + -- See Note [Pattern synonym result type] in PatSyn (subst, ex_tvs') <- cloneTyVarBndrs subst1 ex_tvs <$> getUniqueSupplyM + let arg_tys' = substTys subst arg_tys -- Fresh term variables (VAs) as arguments to the constructor - arguments <- mapM mkPmVar (substTys subst arg_tys) + arguments <- mapM mkPmVar arg_tys' -- All constraints bound by the constructor (alpha-renamed) let theta_cs = substTheta subst (eqSpecPreds eq_spec ++ thetas) evvars <- mapM (nameType "pm") theta_cs @@ -992,7 +1609,13 @@ mkOneConFull x con = do , pm_con_tvs = ex_tvs' , pm_con_dicts = evvars , pm_con_args = arguments } - return (con_abs, (PmExprVar (idName x), vaToPmExpr con_abs), listToBag evvars) + strict_arg_tys = filterByList arg_is_banged arg_tys' + return $ InhabitationCandidate + { ic_val_abs = con_abs + , ic_tm_ct = (PmExprVar (idName x), vaToPmExpr con_abs) + , ic_ty_cs = listToBag evvars + , ic_strict_arg_tys = strict_arg_tys + } -- ---------------------------------------------------------------------------- -- * More smart constructors and fresh variable generation @@ -1046,7 +1669,7 @@ mkPmId ty = getUniqueM >>= \unique -> mkPmId2Forms :: Type -> DsM (Pattern, LHsExpr GhcTc) mkPmId2Forms ty = do x <- mkPmId ty - return (PmVar x, noLoc (HsVar (noLoc x))) + return (PmVar x, noLoc (HsVar noExt (noLoc x))) -- ---------------------------------------------------------------------------- -- * Converting between Value Abstractions, Patterns and PmExpr @@ -1093,30 +1716,94 @@ singleConstructor _ = False -- These come from two places. -- 1. From data constructors defined with the result type constructor. -- 2. From `COMPLETE` pragmas which have the same type as the result --- type constructor. +-- type constructor. Note that we only use `COMPLETE` pragmas +-- *all* of whose pattern types match. See #14135 allCompleteMatches :: ConLike -> [Type] -> DsM [(Provenance, [ConLike])] allCompleteMatches cl tys = do let fam = case cl of RealDataCon dc -> [(FromBuiltin, map RealDataCon (tyConDataCons (dataConTyCon dc)))] PatSynCon _ -> [] - - pragmas <- case splitTyConApp_maybe (conLikeResTy cl tys) of - Just (tc, _) -> dsGetCompleteMatches tc - Nothing -> return [] - let fams cm = fmap (FromComplete,) $ + ty = conLikeResTy cl tys + pragmas <- case splitTyConApp_maybe ty of + Just (tc, _) -> dsGetCompleteMatches tc + Nothing -> return [] + let fams cm = (FromComplete,) <$> mapM dsLookupConLike (completeMatchConLikes cm) - from_pragma <- mapM fams pragmas - + from_pragma <- filter (\(_,m) -> isValidCompleteMatch ty m) <$> + mapM fams pragmas let final_groups = fam ++ from_pragma - tracePmD "allCompleteMatches" (ppr final_groups) return final_groups + where + -- Check that all the pattern synonym return types in a `COMPLETE` + -- pragma subsume the type we're matching. + -- See Note [Filtering out non-matching COMPLETE sets] + isValidCompleteMatch :: Type -> [ConLike] -> Bool + isValidCompleteMatch ty = all go + where + go (RealDataCon {}) = True + go (PatSynCon psc) = isJust $ flip tcMatchTy ty $ patSynResTy + $ patSynSig psc + + patSynResTy (_, _, _, _, _, res_ty) = res_ty + +{- +Note [Filtering out non-matching COMPLETE sets] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Currently, conlikes in a COMPLETE set are simply grouped by the +type constructor heading the return type. This is nice and simple, but it does +mean that there are scenarios when a COMPLETE set might be incompatible with +the type of a scrutinee. For instance, consider (from #14135): + + data Foo a = Foo1 a | Foo2 a + + pattern MyFoo2 :: Int -> Foo Int + pattern MyFoo2 i = Foo2 i + + {-# COMPLETE Foo1, MyFoo2 #-} + + f :: Foo a -> a + f (Foo1 x) = x + +`f` has an incomplete pattern-match, so when choosing which constructors to +report as unmatched in a warning, GHC must choose between the original set of +data constructors {Foo1, Foo2} and the COMPLETE set {Foo1, MyFoo2}. But observe +that GHC shouldn't even consider the COMPLETE set as a possibility: the return +type of MyFoo2, Foo Int, does not match the type of the scrutinee, Foo a, since +there's no substitution `s` such that s(Foo Int) = Foo a. + +To ensure that GHC doesn't pick this COMPLETE set, it checks each pattern +synonym constructor's return type matches the type of the scrutinee, and if one +doesn't, then we remove the whole COMPLETE set from consideration. + +One might wonder why GHC only checks /pattern synonym/ constructors, and not +/data/ constructors as well. The reason is because that the type of a +GADT constructor very well may not match the type of a scrutinee, and that's +OK. Consider this example (from #14059): + + data SBool (z :: Bool) where + SFalse :: SBool False + STrue :: SBool True + + pattern STooGoodToBeTrue :: forall (z :: Bool). () + => z ~ True + => SBool z + pattern STooGoodToBeTrue = STrue + {-# COMPLETE SFalse, STooGoodToBeTrue #-} + + wobble :: SBool z -> Bool + wobble STooGoodToBeTrue = True + +In the incomplete pattern match for `wobble`, we /do/ want to warn that SFalse +should be matched against, even though its type, SBool False, does not match +the scrutinee type, SBool z. +-} -- ----------------------------------------------------------------------- -- * Types and constraints newEvVar :: Name -> Type -> EvVar -newEvVar name ty = mkLocalId name (toTcType ty) +newEvVar name ty = mkLocalId name ty nameType :: String -> Type -> DsM EvVar nameType name ty = do @@ -1211,15 +1898,9 @@ runMany pm (m:ms) = mappend <$> pm m <*> runMany pm ms -- delta with all term and type constraints in scope. mkInitialUncovered :: [Id] -> PmM Uncovered mkInitialUncovered vars = do - ty_cs <- liftD getDictsDs - tm_cs <- map toComplex . bagToList <$> liftD getTmCsDs - sat_ty <- tyOracle ty_cs - let initTyCs = if sat_ty then ty_cs else emptyBag - initTmState = fromMaybe initialTmState (tmOracle initialTmState tm_cs) - patterns = map PmVar vars - -- If any of the term/type constraints are non - -- satisfiable then return with the initialTmState. See #12957 - return [ValVec patterns (MkDelta initTyCs initTmState)] + delta <- pmInitialTmTyCs + let patterns = map PmVar vars + return [ValVec patterns delta] -- | Increase the counter for elapsed algorithm iterations, check that the -- limit is not exceeded and call `pmcheck` @@ -1309,12 +1990,28 @@ pmcheckHd (PmVar x) ps guards va (ValVec vva delta) | otherwise = return mempty -- ConCon -pmcheckHd ( p@(PmCon {pm_con_con = c1, pm_con_args = args1})) ps guards - (va@(PmCon {pm_con_con = c2, pm_con_args = args2})) (ValVec vva delta) +pmcheckHd ( p@(PmCon { pm_con_con = c1, pm_con_tvs = ex_tvs1 + , pm_con_args = args1})) ps guards + (va@(PmCon { pm_con_con = c2, pm_con_tvs = ex_tvs2 + , pm_con_args = args2})) (ValVec vva delta) | c1 /= c2 = return (usimple [ValVec (va:vva) delta]) - | otherwise = kcon c1 (pm_con_arg_tys p) (pm_con_tvs p) (pm_con_dicts p) - <$> pmcheckI (args1 ++ ps) guards (ValVec (args2 ++ vva) delta) + | otherwise = do + let to_evvar tv1 tv2 = nameType "pmConCon" $ + mkPrimEqPred (mkTyVarTy tv1) (mkTyVarTy tv2) + mb_to_evvar tv1 tv2 + -- If we have identical constructors but different existential + -- tyvars, then generate extra equality constraints to ensure the + -- existential tyvars. + -- See Note [Coverage checking and existential tyvars]. + | tv1 == tv2 = pure Nothing + | otherwise = Just <$> to_evvar tv1 tv2 + evvars <- (listToBag . catMaybes) <$> + ASSERT(ex_tvs1 `equalLength` ex_tvs2) + liftD (zipWithM mb_to_evvar ex_tvs1 ex_tvs2) + let delta' = delta { delta_ty_cs = evvars `unionBags` delta_ty_cs delta } + kcon c1 (pm_con_arg_tys p) (pm_con_tvs p) (pm_con_dicts p) + <$> pmcheckI (args1 ++ ps) guards (ValVec (args2 ++ vva) delta') -- LitLit pmcheckHd (PmLit l1) ps guards (va@(PmLit l2)) vva = @@ -1330,13 +2027,12 @@ pmcheckHd (p@(PmCon { pm_con_con = con, pm_con_arg_tys = tys })) cons_cs <- mapM (liftD . mkOneConFull x) complete_match - inst_vsa <- flip concatMapM cons_cs $ \(va, tm_ct, ty_cs) -> do - let ty_state = ty_cs `unionBags` delta_ty_cs delta -- not actually a state - sat_ty <- if isEmptyBag ty_cs then return True - else tyOracle ty_state - return $ case (sat_ty, solveOneEq (delta_tm_cs delta) tm_ct) of - (True, Just tm_state) -> [ValVec (va:vva) (MkDelta ty_state tm_state)] - _ty_or_tm_failed -> [] + inst_vsa <- flip mapMaybeM cons_cs $ + \InhabitationCandidate{ ic_val_abs = va, ic_tm_ct = tm_ct + , ic_ty_cs = ty_cs + , ic_strict_arg_tys = strict_arg_tys } -> do + mb_sat <- pmIsSatisfiable delta tm_ct ty_cs strict_arg_tys + pure $ fmap (ValVec (va:vva)) mb_sat set_provenance prov . force_if (canDiverge (idName x) (delta_tm_cs delta)) <$> @@ -1405,6 +2101,121 @@ pmcheckHd (p@(PmCon {})) ps guards (PmNLit { pm_lit_id = x }) vva -- Impossible: handled by pmcheck pmcheckHd (PmGrd {}) _ _ _ _ = panic "pmcheckHd: Guard" +{- +Note [Coverage checking and existential tyvars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC's implementation of the pattern-match coverage algorithm (as described in +the GADTs Meet Their Match paper) must take some care to emit enough type +constraints when handling data constructors with exisentially quantified type +variables. To better explain what the challenge is, consider a constructor K +of the form: + + K @e_1 ... @e_m ev_1 ... ev_v ty_1 ... ty_n :: T u_1 ... u_p + +Where: + +* e_1, ..., e_m are the existentially bound type variables. +* ev_1, ..., ev_v are evidence variables, which may inhabit a dictionary type + (e.g., Eq) or an equality constraint (e.g., e_1 ~ Int). +* ty_1, ..., ty_n are the types of K's fields. +* T u_1 ... u_p is the return type, where T is the data type constructor, and + u_1, ..., u_p are the universally quantified type variables. + +In the ConVar case, the coverage algorithm will have in hand the constructor +K as well as a pattern variable (pv :: T PV_1 ... PV_p), where PV_1, ..., PV_p +are some types that instantiate u_1, ... u_p. The idea is that we should +substitute PV_1 for u_1, ..., and PV_p for u_p when forming a PmCon (the +mkOneConFull function accomplishes this) and then hand this PmCon off to the +ConCon case. + +The presence of existentially quantified type variables adds a significant +wrinkle. We always grab e_1, ..., e_m from the definition of K to begin with, +but we don't want them to appear in the final PmCon, because then +calling (mkOneConFull K) for other pattern variables might reuse the same +existential tyvars, which is certainly wrong. + +Previously, GHC's solution to this wrinkle was to always create fresh names +for the existential tyvars and put them into the PmCon. This works well for +many cases, but it can break down if you nest GADT pattern matches in just +the right way. For instance, consider the following program: + + data App f a where + App :: f a -> App f (Maybe a) + + data Ty a where + TBool :: Ty Bool + TInt :: Ty Int + + data T f a where + C :: T Ty (Maybe Bool) + + foo :: T f a -> App f a -> () + foo C (App TBool) = () + +foo is a total program, but with the previous approach to handling existential +tyvars, GHC would mark foo's patterns as non-exhaustive. + +When foo is desugared to Core, it looks roughly like so: + + foo @f @a (C co1 _co2) (App @a1 _co3 (TBool |> co1)) = () + +(Where `a1` is an existential tyvar.) + +That, in turn, is processed by the coverage checker to become: + + foo @f @a (C co1 _co2) (App @a1 _co3 (pmvar123 :: f a1)) + | TBool <- pmvar123 |> co1 + = () + +Note that the type of pmvar123 is `f a1`—this will be important later. + +Now, we proceed with coverage-checking as usual. When we come to the +ConVar case for App, we create a fresh variable `a2` to represent its +existential tyvar. At this point, we have the equality constraints +`(a ~ Maybe a2, a ~ Maybe Bool, f ~ Ty)` in scope. + +However, when we check the guard, it will use the type of pmvar123, which is +`f a1`. Thus, when considering if pmvar123 can match the constructor TInt, +it will generate the constraint `a1 ~ Int`. This means our final set of +equality constraints would be: + + f ~ Ty + a ~ Maybe Bool + a ~ Maybe a2 + a1 ~ Int + +Which is satisfiable! Freshening the existential tyvar `a` to `a2` doomed us, +because GHC is unable to relate `a2` to `a1`, which really should be the same +tyvar. + +Luckily, we can avoid this pitfall. Recall that the ConVar case was where we +generated a PmCon with too-fresh existentials. But after ConVar, we have the +ConCon case, which considers whether each constructor of a particular data type +can be matched on in a particular spot. + +In the case of App, when we get to the ConCon case, we will compare our +original App PmCon (from the source program) to the App PmCon created from the +ConVar case. In the former PmCon, we have `a1` in hand, which is exactly the +existential tyvar we want! Thus, we can force `a1` to be the same as `a2` here +by emitting an additional `a1 ~ a2` constraint. Now our final set of equality +constraints will be: + + f ~ Ty + a ~ Maybe Bool + a ~ Maybe a2 + a1 ~ Int + a1 ~ a2 + +Which is unsatisfiable, as we desired, since we now have that +Int ~ a1 ~ a2 ~ Bool. + +In general, App might have more than one constructor, in which case we +couldn't reuse the existential tyvar for App for a different constructor. This +means that we can only use this trick in ConCon when the constructors are the +same. But this is fine, since this is the only scenario where this situation +arises in the first place! +-} + -- ---------------------------------------------------------------------------- -- * Utilities for main checking @@ -1470,7 +2281,7 @@ force_if True pres = forces pres force_if False pres = pres set_provenance :: Provenance -> PartialResult -> PartialResult -set_provenance prov pr = pr { presultProvenence = prov } +set_provenance prov pr = pr { presultProvenance = prov } -- ---------------------------------------------------------------------------- -- * Propagation of term constraints inwards when checking nested matches @@ -1715,9 +2526,10 @@ exhaustive dflags = maybe False (`wopt` dflags) . exhaustiveWarningFlag exhaustiveWarningFlag :: HsMatchContext id -> Maybe WarningFlag exhaustiveWarningFlag (FunRhs {}) = Just Opt_WarnIncompletePatterns exhaustiveWarningFlag CaseAlt = Just Opt_WarnIncompletePatterns -exhaustiveWarningFlag IfAlt = Nothing +exhaustiveWarningFlag IfAlt = Just Opt_WarnIncompletePatterns exhaustiveWarningFlag LambdaExpr = Just Opt_WarnIncompleteUniPatterns exhaustiveWarningFlag PatBindRhs = Just Opt_WarnIncompleteUniPatterns +exhaustiveWarningFlag PatBindGuards = Just Opt_WarnIncompletePatterns exhaustiveWarningFlag ProcExpr = Just Opt_WarnIncompleteUniPatterns exhaustiveWarningFlag RecUpd = Just Opt_WarnIncompletePatternsRecUpd exhaustiveWarningFlag ThPatSplice = Nothing @@ -1740,9 +2552,9 @@ pp_context singular (DsMatchContext kind _loc) msg rest_of_msg_fun (ppr_match, pref) = case kind of - FunRhs (L _ fun) _ _ -> (pprMatchContext kind, - \ pp -> ppr fun <+> pp) - _ -> (pprMatchContext kind, \ pp -> pp) + FunRhs { mc_fun = L _ fun } + -> (pprMatchContext kind, \ pp -> ppr fun <+> pp) + _ -> (pprMatchContext kind, \ pp -> pp) ppr_pats :: HsMatchContext Name -> [Pat GhcTc] -> SDoc ppr_pats kind pats diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index 16537bd7a5..99ba96755f 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -3,19 +3,17 @@ (c) University of Glasgow, 2007 -} -{-# LANGUAGE CPP, NondecreasingIndentation, RecordWildCards #-} +{-# LANGUAGE NondecreasingIndentation, RecordWildCards #-} module Coverage (addTicksToBinds, hpcInitCode) where +import GhcPrelude as Prelude + import qualified GHCi import GHCi.RemoteTypes import Data.Array import ByteCodeTypes -#if MIN_VERSION_base(4,9,0) import GHC.Stack.CCS -#else -import GHC.Stack as GHC.Stack.CCS -#endif import Type import HsSyn import Module @@ -29,6 +27,7 @@ import NameSet hiding (FreeVars) import Name import Bag import CostCentre +import CostCentreState import CoreSyn import Id import VarSet @@ -36,7 +35,6 @@ import Data.List import FastString import HscTypes import TyCon -import UniqSupply import BasicTypes import MonadUtils import Maybes @@ -77,7 +75,6 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds Just orig_file <- ml_hs_file mod_loc, not ("boot" `isSuffixOf` orig_file) = do - us <- mkSplitUniqSupply 'C' -- for cost centres let orig_file2 = guessSourceFile binds orig_file tickPass tickish (binds,st) = @@ -100,7 +97,7 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds initState = TT { tickBoxCount = 0 , mixEntries = [] - , uniqSupply = us + , ccIndices = newCostCentreState } (binds1,st) = foldr tickPass (binds, initState) passes @@ -281,31 +278,6 @@ addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds, | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports , isInlinePragma (idInlinePragma pid) ] } -addTickLHsBind (L pos bind@(AbsBindsSig { abs_sig_bind = val_bind - , abs_sig_export = poly_id })) - | L _ FunBind { fun_id = L _ mono_id } <- val_bind - = do withEnv (add_export mono_id) $ do - withEnv (add_inlines mono_id) $ do - val_bind' <- addTickLHsBind val_bind - return $ L pos $ bind { abs_sig_bind = val_bind' } - - | otherwise - = pprPanic "addTickLHsBind" (ppr bind) - where - -- see AbsBinds comments - add_export mono_id env - | idName poly_id `elemNameSet` exports env - = env { exports = exports env `extendNameSet` idName mono_id } - | otherwise - = env - - -- See Note [inline sccs] - add_inlines mono_id env - | isInlinePragma (idInlinePragma poly_id) - = env { inlines = inlines env `extendVarSet` mono_id } - | otherwise - = env - addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do let name = getOccString id decl_path <- getPathEntry @@ -320,11 +292,15 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do tickish <- tickishType `liftM` getEnv if inline && tickish == ProfNotes then return (L pos funBind) else do - (fvs, mg@(MG { mg_alts = matches' })) <- + (fvs, mg) <- getFreeVars $ addPathEntry name $ addTickMatchGroup False (fun_matches funBind) + case mg of + MG {} -> return () + _ -> panic "addTickLHsBind" + blackListed <- isBlackListed pos exported_names <- liftM exports getEnv @@ -343,7 +319,7 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do return Nothing let mbCons = maybe Prelude.id (:) - return $ L pos $ funBind { fun_matches = mg { mg_alts = matches' } + return $ L pos $ funBind { fun_matches = mg , fun_tick = tick `mbCons` fun_tick funBind } where @@ -379,6 +355,7 @@ addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs, pat_rhs = rhs }))) = do -- 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 bindTick @@ -397,14 +374,7 @@ bindTick density name pos fvs = do -- Note [inline sccs] -- --- It should be reasonable to add ticks to INLINE functions; however --- currently this tickles a bug later on because the SCCfinal pass --- does not look inside unfoldings to find CostCentres. It would be --- difficult to fix that, because SCCfinal currently works on STG and --- not Core (and since it also generates CostCentres for CAFs, --- changing this would be difficult too). --- --- Another reason not to add ticks to INLINE functions is that this +-- The reason not to add ticks to INLINE functions is that this is -- sometimes handy for avoiding adding a tick to a particular function -- (see #6131) -- @@ -486,15 +456,15 @@ addTickLHsExprNever (L pos e0) = do -- general heuristic: expressions which do not denote values are good -- break points isGoodBreakExpr :: HsExpr GhcTc -> Bool -isGoodBreakExpr (HsApp {}) = True -isGoodBreakExpr (HsAppTypeOut {}) = True -isGoodBreakExpr (OpApp {}) = True -isGoodBreakExpr _other = False +isGoodBreakExpr (HsApp {}) = True +isGoodBreakExpr (HsAppType {}) = True +isGoodBreakExpr (OpApp {}) = True +isGoodBreakExpr _other = False isCallSite :: HsExpr GhcTc -> Bool -isCallSite HsApp{} = True -isCallSite HsAppTypeOut{} = True -isCallSite OpApp{} = True +isCallSite HsApp{} = True +isCallSite HsAppType{} = True +isCallSite OpApp{} = True isCallSite _ = False addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) @@ -516,55 +486,58 @@ 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 (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar" -addTickHsExpr e@(HsConLikeOut con) +addTickHsExpr e@(HsVar _ (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 -addTickHsExpr e@(HsIPVar _) = return e -addTickHsExpr e@(HsOverLit _) = return e -addTickHsExpr e@(HsOverLabel{}) = return e -addTickHsExpr e@(HsLit _) = return e -addTickHsExpr (HsLam matchgroup) = liftM HsLam (addTickMatchGroup True matchgroup) -addTickHsExpr (HsLamCase mgs) = liftM HsLamCase (addTickMatchGroup True mgs) -addTickHsExpr (HsApp e1 e2) = liftM2 HsApp (addTickLHsExprNever e1) - (addTickLHsExpr e2) -addTickHsExpr (HsAppTypeOut e ty) = liftM2 HsAppTypeOut (addTickLHsExprNever e) - (return ty) - -addTickHsExpr (OpApp e1 e2 fix e3) = +addTickHsExpr e@(HsIPVar {}) = return e +addTickHsExpr e@(HsOverLit {}) = return e +addTickHsExpr e@(HsOverLabel{}) = return e +addTickHsExpr e@(HsLit {}) = return e +addTickHsExpr (HsLam x matchgroup) = liftM (HsLam x) + (addTickMatchGroup True matchgroup) +addTickHsExpr (HsLamCase x mgs) = liftM (HsLamCase x) + (addTickMatchGroup True mgs) +addTickHsExpr (HsApp x e1 e2) = liftM2 (HsApp x) (addTickLHsExprNever e1) + (addTickLHsExpr e2) +addTickHsExpr (HsAppType ty e) = liftM2 HsAppType (return ty) + (addTickLHsExprNever e) + + +addTickHsExpr (OpApp fix e1 e2 e3) = liftM4 OpApp + (return fix) (addTickLHsExpr e1) (addTickLHsExprNever e2) - (return fix) (addTickLHsExpr e3) -addTickHsExpr (NegApp e neg) = - liftM2 NegApp +addTickHsExpr (NegApp x e neg) = + liftM2 (NegApp x) (addTickLHsExpr e) (addTickSyntaxExpr hpcSrcSpan neg) -addTickHsExpr (HsPar e) = - liftM HsPar (addTickLHsExprEvalInner e) -addTickHsExpr (SectionL e1 e2) = - liftM2 SectionL +addTickHsExpr (HsPar x e) = + liftM (HsPar x) (addTickLHsExprEvalInner e) +addTickHsExpr (SectionL x e1 e2) = + liftM2 (SectionL x) (addTickLHsExpr e1) (addTickLHsExprNever e2) -addTickHsExpr (SectionR e1 e2) = - liftM2 SectionR +addTickHsExpr (SectionR x e1 e2) = + liftM2 (SectionR x) (addTickLHsExprNever e1) (addTickLHsExpr e2) -addTickHsExpr (ExplicitTuple es boxity) = - liftM2 ExplicitTuple +addTickHsExpr (ExplicitTuple x es boxity) = + liftM2 (ExplicitTuple x) (mapM addTickTupArg es) (return boxity) -addTickHsExpr (ExplicitSum tag arity e ty) = do +addTickHsExpr (ExplicitSum ty tag arity e) = do e' <- addTickLHsExpr e - return (ExplicitSum tag arity e' ty) -addTickHsExpr (HsCase e mgs) = - liftM2 HsCase + return (ExplicitSum ty tag arity e') +addTickHsExpr (HsCase x e mgs) = + liftM2 (HsCase x) (addTickLHsExpr e) -- not an EvalInner; e might not necessarily -- be evaluated. (addTickMatchGroup False mgs) -addTickHsExpr (HsIf cnd e1 e2 e3) = - liftM3 (HsIf cnd) +addTickHsExpr (HsIf x cnd e1 e2 e3) = + liftM3 (HsIf x cnd) (addBinTickLHsExpr (BinBox CondBinBox) e1) (addTickLHsExprOptAlt True e2) (addTickLHsExprOptAlt True e3) @@ -572,14 +545,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 (L l binds) e) = +addTickHsExpr (HsLet x (L l binds) e) = bindLocals (collectLocalBinders binds) $ - liftM2 (HsLet . L l) + liftM2 (HsLet x . L l) (addTickHsLocalBinds binds) -- to think about: !patterns. (addTickLHsExprLetBody e) -addTickHsExpr (HsDo cxt (L l stmts) srcloc) +addTickHsExpr (HsDo srcloc cxt (L l stmts)) = do { (stmts', _) <- addTickLStmts' forQual stmts (return ()) - ; return (HsDo cxt (L l stmts') srcloc) } + ; return (HsDo srcloc cxt (L l stmts')) } where forQual = case cxt of ListComp -> Just $ BinBox QualBinBox @@ -593,10 +566,6 @@ addTickHsExpr (ExplicitList ty wit es) = addTickWit (Just fln) = do fln' <- addTickSyntaxExpr hpcSrcSpan fln return (Just fln') -addTickHsExpr (ExplicitPArr ty es) = - liftM2 ExplicitPArr - (return ty) - (mapM (addTickLHsExpr) es) addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e @@ -609,12 +578,12 @@ addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds }) ; flds' <- mapM addTickHsRecField flds ; return (expr { rupd_expr = e', rupd_flds = flds' }) } -addTickHsExpr (ExprWithTySig e ty) = +addTickHsExpr (ExprWithTySig ty e) = liftM2 ExprWithTySig - (addTickLHsExprNever e) -- No need to tick the inner expression - -- for expressions with signatures (return ty) -addTickHsExpr (ArithSeq ty wit arith_seq) = + (addTickLHsExprNever e) -- No need to tick the inner expression + -- for expressions with signatures +addTickHsExpr (ArithSeq ty wit arith_seq) = liftM3 ArithSeq (return ty) (addTickWit wit) @@ -624,26 +593,22 @@ addTickHsExpr (ArithSeq ty wit arith_seq) = return (Just fl') -- We might encounter existing ticks (multiple Coverage passes) -addTickHsExpr (HsTick t e) = - liftM (HsTick t) (addTickLHsExprNever e) -addTickHsExpr (HsBinTick t0 t1 e) = - liftM (HsBinTick t0 t1) (addTickLHsExprNever e) +addTickHsExpr (HsTick x t e) = + liftM (HsTick x t) (addTickLHsExprNever e) +addTickHsExpr (HsBinTick x t0 t1 e) = + liftM (HsBinTick x t0 t1) (addTickLHsExprNever e) -addTickHsExpr (HsTickPragma _ _ _ (L pos e0)) = do +addTickHsExpr (HsTickPragma _ _ _ _ (L pos e0)) = do e2 <- allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0 return $ unLoc e2 -addTickHsExpr (PArrSeq ty arith_seq) = - liftM2 PArrSeq - (return ty) - (addTickArithSeqInfo arith_seq) -addTickHsExpr (HsSCC src nm e) = - liftM3 HsSCC +addTickHsExpr (HsSCC x src nm e) = + liftM3 (HsSCC x) (return src) (return nm) (addTickLHsExpr e) -addTickHsExpr (HsCoreAnn src nm e) = - liftM3 HsCoreAnn +addTickHsExpr (HsCoreAnn x src nm e) = + liftM3 (HsCoreAnn x) (return src) (return nm) (addTickLHsExpr e) @@ -651,27 +616,23 @@ addTickHsExpr e@(HsBracket {}) = return e addTickHsExpr e@(HsTcBracketOut {}) = return e addTickHsExpr e@(HsRnBracketOut {}) = return e addTickHsExpr e@(HsSpliceE {}) = return e -addTickHsExpr (HsProc pat cmdtop) = - liftM2 HsProc +addTickHsExpr (HsProc x pat cmdtop) = + liftM2 (HsProc x) (addTickLPat pat) (liftL (addTickHsCmdTop) cmdtop) -addTickHsExpr (HsWrap w e) = - liftM2 HsWrap +addTickHsExpr (HsWrap x w e) = + liftM2 (HsWrap x) (return w) (addTickHsExpr e) -- Explicitly no tick on inside -addTickHsExpr (ExprWithTySigOut e ty) = - liftM2 ExprWithTySigOut - (addTickLHsExprNever e) -- No need to tick the inner expression - (return ty) -- for expressions with signatures - -- Others should never happen in expression content. addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e) addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc) -addTickTupArg (L l (Present e)) = do { e' <- addTickLHsExpr e - ; return (L l (Present e')) } +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" addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc) -> TM (MatchGroup GhcTc (LHsExpr GhcTc)) @@ -679,30 +640,34 @@ addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do let isOneOfMany = matchesOneOfMany matches matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches return $ mg { mg_alts = L l matches' } +addTickMatchGroup _ (XMatchGroup _) = panic "addTickMatchGroup" addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc) -> TM (Match GhcTc (LHsExpr GhcTc)) -addTickMatch isOneOfMany isLambda (Match mf pats opSig gRHSs) = +addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats, m_grhss = gRHSs }) = bindLocals (collectPatsBinders pats) $ do gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs - return $ Match mf pats opSig gRHSs' + return $ match { m_grhss = gRHSs' } +addTickMatch _ _ (XMatch _) = panic "addTickMatch" addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc) -> TM (GRHSs GhcTc (LHsExpr GhcTc)) -addTickGRHSs isOneOfMany isLambda (GRHSs guarded (L l local_binds)) = do +addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (L l local_binds)) = do bindLocals binders $ do local_binds' <- addTickHsLocalBinds local_binds guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded - return $ GRHSs guarded' (L l local_binds') + return $ GRHSs x guarded' (L l local_binds') where binders = collectLocalBinders local_binds +addTickGRHSs _ _ (XGRHSs _) = panic "addTickGRHSs" addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc) -> TM (GRHS GhcTc (LHsExpr GhcTc)) -addTickGRHS isOneOfMany isLambda (GRHS stmts expr) = do +addTickGRHS isOneOfMany isLambda (GRHS x stmts expr) = do (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts (addTickGRHSBody isOneOfMany isLambda expr) - return $ GRHS stmts' expr' + return $ GRHS x stmts' expr' +addTickGRHS _ _ (XGRHS _) = panic "addTickGRHS" addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do @@ -732,36 +697,33 @@ addTickLStmts' isGuard lstmts res addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt GhcTc (LHsExpr GhcTc) -> TM (Stmt GhcTc (LHsExpr GhcTc)) -addTickStmt _isGuard (LastStmt e noret ret) = do - liftM3 LastStmt +addTickStmt _isGuard (LastStmt x e noret ret) = do + liftM3 (LastStmt x) (addTickLHsExpr e) (pure noret) (addTickSyntaxExpr hpcSrcSpan ret) -addTickStmt _isGuard (BindStmt pat e bind fail ty) = do - liftM5 BindStmt +addTickStmt _isGuard (BindStmt x pat e bind fail) = do + liftM4 (BindStmt x) (addTickLPat pat) (addTickLHsExprRHS e) (addTickSyntaxExpr hpcSrcSpan bind) (addTickSyntaxExpr hpcSrcSpan fail) - (return ty) -addTickStmt isGuard (BodyStmt e bind' guard' ty) = do - liftM4 BodyStmt +addTickStmt isGuard (BodyStmt x e bind' guard') = do + liftM3 (BodyStmt x) (addTick isGuard e) (addTickSyntaxExpr hpcSrcSpan bind') (addTickSyntaxExpr hpcSrcSpan guard') - (return ty) -addTickStmt _isGuard (LetStmt (L l binds)) = do - liftM (LetStmt . L l) +addTickStmt _isGuard (LetStmt x (L l binds)) = do + liftM (LetStmt x . L l) (addTickHsLocalBinds binds) -addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr ty) = do - liftM4 ParStmt +addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) = do + liftM3 (ParStmt x) (mapM (addTickStmtAndBinders isGuard) pairs) (unLoc <$> addTickLHsExpr (L hpcSrcSpan mzipExpr)) (addTickSyntaxExpr hpcSrcSpan bindExpr) - (return ty) -addTickStmt isGuard (ApplicativeStmt args mb_join body_ty) = do +addTickStmt isGuard (ApplicativeStmt body_ty args mb_join) = do args' <- mapM (addTickApplicativeArg isGuard) args - return (ApplicativeStmt args' mb_join body_ty) + return (ApplicativeStmt body_ty args' mb_join) addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts , trS_by = by, trS_using = using @@ -784,63 +746,75 @@ addTickStmt isGuard stmt@(RecStmt {}) ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret' , recS_mfix_fn = mfix', recS_bind_fn = bind' }) } +addTickStmt _ (XStmtLR _) = panic "addTickStmt" + addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e | otherwise = addTickLHsExprRHS e addTickApplicativeArg - :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc GhcTc) - -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc GhcTc) + :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc) + -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc) addTickApplicativeArg isGuard (op, arg) = liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg) where - addTickArg (ApplicativeArgOne pat expr) = - ApplicativeArgOne <$> addTickLPat pat <*> addTickLHsExpr expr - addTickArg (ApplicativeArgMany stmts ret pat) = - ApplicativeArgMany + addTickArg (ApplicativeArgOne x pat expr isBody) = + (ApplicativeArgOne x) + <$> addTickLPat pat + <*> addTickLHsExpr expr + <*> pure isBody + addTickArg (ApplicativeArgMany x stmts ret pat) = + (ApplicativeArgMany x) <$> addTickLStmts isGuard stmts <*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret)) <*> addTickLPat pat + addTickArg (XApplicativeArg _) = panic "addTickApplicativeArg" addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc -> TM (ParStmtBlock GhcTc GhcTc) -addTickStmtAndBinders isGuard (ParStmtBlock stmts ids returnExpr) = - liftM3 ParStmtBlock +addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) = + liftM3 (ParStmtBlock x) (addTickLStmts isGuard stmts) (return ids) (addTickSyntaxExpr hpcSrcSpan returnExpr) +addTickStmtAndBinders _ (XParStmtBlock{}) = panic "addTickStmtAndBinders" addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc) -addTickHsLocalBinds (HsValBinds binds) = - liftM HsValBinds +addTickHsLocalBinds (HsValBinds x binds) = + liftM (HsValBinds x) (addTickHsValBinds binds) -addTickHsLocalBinds (HsIPBinds binds) = - liftM HsIPBinds +addTickHsLocalBinds (HsIPBinds x binds) = + liftM (HsIPBinds x) (addTickHsIPBinds binds) -addTickHsLocalBinds (EmptyLocalBinds) = return EmptyLocalBinds +addTickHsLocalBinds (EmptyLocalBinds x) = return (EmptyLocalBinds x) +addTickHsLocalBinds (XHsLocalBindsLR x) = return (XHsLocalBindsLR x) -addTickHsValBinds :: HsValBindsLR GhcTc a -> TM (HsValBindsLR GhcTc b) -addTickHsValBinds (ValBindsOut binds sigs) = - liftM2 ValBindsOut +addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a) + -> TM (HsValBindsLR GhcTc (GhcPass b)) +addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do + b <- liftM2 NValBinds (mapM (\ (rec,binds') -> liftM2 (,) (return rec) (addTickLHsBinds binds')) binds) (return sigs) + return $ XValBindsLR b addTickHsValBinds _ = panic "addTickHsValBinds" addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc) -addTickHsIPBinds (IPBinds ipbinds dictbinds) = +addTickHsIPBinds (IPBinds dictbinds ipbinds) = liftM2 IPBinds - (mapM (liftL (addTickIPBind)) ipbinds) (return dictbinds) + (mapM (liftL (addTickIPBind)) ipbinds) +addTickHsIPBinds (XHsIPBinds x) = return (XHsIPBinds x) addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc) -addTickIPBind (IPBind nm e) = - liftM2 IPBind +addTickIPBind (IPBind x nm e) = + liftM2 (IPBind x) (return nm) (addTickLHsExpr e) +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) @@ -852,12 +826,11 @@ addTickLPat :: LPat GhcTc -> TM (LPat GhcTc) addTickLPat pat = return pat addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc) -addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) = - liftM4 HsCmdTop +addTickHsCmdTop (HsCmdTop x cmd) = + liftM2 HsCmdTop + (return x) (addTickLHsCmd cmd) - (return tys) - (return ty) - (return syntaxtable) +addTickHsCmdTop (XCmdTop{}) = panic "addTickHsCmdTop" addTickLHsCmd :: LHsCmd GhcTc -> TM (LHsCmd GhcTc) addTickLHsCmd (L pos c0) = do @@ -865,10 +838,10 @@ addTickLHsCmd (L pos c0) = do return $ L pos c1 addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc) -addTickHsCmd (HsCmdLam matchgroup) = - liftM HsCmdLam (addTickCmdMatchGroup matchgroup) -addTickHsCmd (HsCmdApp c e) = - liftM2 HsCmdApp (addTickLHsCmd c) (addTickLHsExpr e) +addTickHsCmd (HsCmdLam x matchgroup) = + liftM (HsCmdLam x) (addTickCmdMatchGroup matchgroup) +addTickHsCmd (HsCmdApp x c e) = + liftM2 (HsCmdApp x) (addTickLHsCmd c) (addTickLHsExpr e) {- addTickHsCmd (OpApp e1 c2 fix c3) = liftM4 OpApp @@ -877,41 +850,43 @@ addTickHsCmd (OpApp e1 c2 fix c3) = (return fix) (addTickLHsCmd c3) -} -addTickHsCmd (HsCmdPar e) = liftM HsCmdPar (addTickLHsCmd e) -addTickHsCmd (HsCmdCase e mgs) = - liftM2 HsCmdCase +addTickHsCmd (HsCmdPar x e) = liftM (HsCmdPar x) (addTickLHsCmd e) +addTickHsCmd (HsCmdCase x e mgs) = + liftM2 (HsCmdCase x) (addTickLHsExpr e) (addTickCmdMatchGroup mgs) -addTickHsCmd (HsCmdIf cnd e1 c2 c3) = - liftM3 (HsCmdIf cnd) +addTickHsCmd (HsCmdIf x cnd e1 c2 c3) = + liftM3 (HsCmdIf x cnd) (addBinTickLHsExpr (BinBox CondBinBox) e1) (addTickLHsCmd c2) (addTickLHsCmd c3) -addTickHsCmd (HsCmdLet (L l binds) c) = +addTickHsCmd (HsCmdLet x (L l binds) c) = bindLocals (collectLocalBinders binds) $ - liftM2 (HsCmdLet . L l) + liftM2 (HsCmdLet x . L l) (addTickHsLocalBinds binds) -- to think about: !patterns. (addTickLHsCmd c) -addTickHsCmd (HsCmdDo (L l stmts) srcloc) +addTickHsCmd (HsCmdDo srcloc (L l stmts)) = do { (stmts', _) <- addTickLCmdStmts' stmts (return ()) - ; return (HsCmdDo (L l stmts') srcloc) } + ; return (HsCmdDo srcloc (L l stmts')) } -addTickHsCmd (HsCmdArrApp e1 e2 ty1 arr_ty lr) = +addTickHsCmd (HsCmdArrApp arr_ty e1 e2 ty1 lr) = liftM5 HsCmdArrApp + (return arr_ty) (addTickLHsExpr e1) (addTickLHsExpr e2) (return ty1) - (return arr_ty) (return lr) -addTickHsCmd (HsCmdArrForm e f fix cmdtop) = - liftM4 HsCmdArrForm +addTickHsCmd (HsCmdArrForm x e f fix cmdtop) = + liftM4 (HsCmdArrForm x) (addTickLHsExpr e) (return f) (return fix) (mapM (liftL (addTickHsCmdTop)) cmdtop) -addTickHsCmd (HsCmdWrap w cmd) - = liftM2 HsCmdWrap (return w) (addTickHsCmd cmd) +addTickHsCmd (HsCmdWrap x w cmd) + = liftM2 (HsCmdWrap x) (return w) (addTickHsCmd cmd) + +addTickHsCmd e@(XCmd {}) = pprPanic "addTickHsCmd" (ppr e) -- Others should never happen in a command context. --addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e) @@ -921,29 +896,33 @@ addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc) addTickCmdMatchGroup mg@(MG { mg_alts = L l matches }) = do matches' <- mapM (liftL addTickCmdMatch) matches return $ mg { mg_alts = L l matches' } +addTickCmdMatchGroup (XMatchGroup _) = panic "addTickCmdMatchGroup" addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc)) -addTickCmdMatch (Match mf pats opSig gRHSs) = +addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) = bindLocals (collectPatsBinders pats) $ do gRHSs' <- addTickCmdGRHSs gRHSs - return $ Match mf pats opSig gRHSs' + return $ match { m_grhss = gRHSs' } +addTickCmdMatch (XMatch _) = panic "addTickCmdMatch" addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc)) -addTickCmdGRHSs (GRHSs guarded (L l local_binds)) = do +addTickCmdGRHSs (GRHSs x guarded (L l local_binds)) = do bindLocals binders $ do local_binds' <- addTickHsLocalBinds local_binds guarded' <- mapM (liftL addTickCmdGRHS) guarded - return $ GRHSs guarded' (L l local_binds') + return $ GRHSs x guarded' (L l local_binds') where binders = collectLocalBinders local_binds +addTickCmdGRHSs (XGRHSs _) = panic "addTickCmdGRHSs" addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc)) -- The *guards* are *not* Cmds, although the body is -- C.f. addTickGRHS for the BinBox stuff -addTickCmdGRHS (GRHS stmts cmd) +addTickCmdGRHS (GRHS x stmts cmd) = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts (addTickLHsCmd cmd) - ; return $ GRHS stmts' expr' } + ; return $ GRHS x stmts' expr' } +addTickCmdGRHS (XGRHS _) = panic "addTickCmdGRHS" addTickLCmdStmts :: [LStmt GhcTc (LHsCmd GhcTc)] -> TM [LStmt GhcTc (LHsCmd GhcTc)] @@ -962,26 +941,24 @@ addTickLCmdStmts' lstmts res binders = collectLStmtsBinders lstmts addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc)) -addTickCmdStmt (BindStmt pat c bind fail ty) = do - liftM5 BindStmt +addTickCmdStmt (BindStmt x pat c bind fail) = do + liftM4 (BindStmt x) (addTickLPat pat) (addTickLHsCmd c) (return bind) (return fail) - (return ty) -addTickCmdStmt (LastStmt c noret ret) = do - liftM3 LastStmt +addTickCmdStmt (LastStmt x c noret ret) = do + liftM3 (LastStmt x) (addTickLHsCmd c) (pure noret) (addTickSyntaxExpr hpcSrcSpan ret) -addTickCmdStmt (BodyStmt c bind' guard' ty) = do - liftM4 BodyStmt +addTickCmdStmt (BodyStmt x c bind' guard') = do + liftM3 (BodyStmt x) (addTickLHsCmd c) (addTickSyntaxExpr hpcSrcSpan bind') (addTickSyntaxExpr hpcSrcSpan guard') - (return ty) -addTickCmdStmt (LetStmt (L l binds)) = do - liftM (LetStmt . L l) +addTickCmdStmt (LetStmt x (L l binds)) = do + liftM (LetStmt x . L l) (addTickHsLocalBinds binds) addTickCmdStmt stmt@(RecStmt {}) = do { stmts' <- addTickLCmdStmts (recS_stmts stmt) @@ -992,6 +969,8 @@ addTickCmdStmt stmt@(RecStmt {}) , recS_mfix_fn = mfix', recS_bind_fn = bind' }) } addTickCmdStmt ApplicativeStmt{} = panic "ToDo: addTickCmdStmt ApplicativeLastStmt" +addTickCmdStmt XStmtLR{} = + panic "addTickCmdStmt XStmtLR" -- Others should never happen in a command context. addTickCmdStmt stmt = pprPanic "addTickHsCmd" (ppr stmt) @@ -1033,7 +1012,7 @@ liftL f (L loc a) = do data TickTransState = TT { tickBoxCount:: Int , mixEntries :: [MixEntry_] - , uniqSupply :: UniqSupply + , ccIndices :: CostCentreState } data TickTransEnv = TTE { fileName :: FastString @@ -1108,10 +1087,11 @@ instance Monad TM where instance HasDynFlags TM where getDynFlags = TM $ \ env st -> (tte_dflags env, noFVs, st) -instance MonadUnique TM where - getUniqueSupplyM = TM $ \_ st -> (uniqSupply st, noFVs, st) - getUniqueM = TM $ \_ st -> let (u, us') = takeUniqFromSupply (uniqSupply st) - in (u, noFVs, st { uniqSupply = us' }) +-- | Get the next HPC cost centre index for a given centre name +getCCIndexM :: FastString -> TM CostCentreIndex +getCCIndexM n = TM $ \_ st -> let (idx, is') = getCCIndex n $ + ccIndices st + in (idx, noFVs, st { ccIndices = is' }) getState :: TM TickTransState getState = TM $ \ _ st -> (st, noFVs, st) @@ -1191,7 +1171,7 @@ 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 tickish (L pos e))) + return (L pos (HsTick noExt tickish (L pos e))) ) (do e <- m return (L pos e) @@ -1239,8 +1219,9 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path = do return $ HpcTick (this_mod env) c ProfNotes -> do - ccUnique <- getUniqueM - let cc = mkUserCC (mkFastString cc_name) (this_mod env) pos ccUnique + let nm = mkFastString cc_name + flavour <- HpcCC <$> getCCIndexM nm + let cc = mkUserCC nm (this_mod env) pos flavour count = countEntries && gopt Opt_ProfCountEntries dflags return $ ProfNote cc count True{-scopes-} @@ -1277,13 +1258,14 @@ mkBinTickBoxHpc boxLabel pos e = c = tickBoxCount st mes = mixEntries st in - ( L pos $ HsTick (HpcTick (this_mod env) c) $ L pos $ HsBinTick (c+1) (c+2) e - -- notice that F and T are reversed, - -- because we are building the list in - -- reverse... - , noFVs - , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes} - ) + ( L pos $ HsTick noExt (HpcTick (this_mod env) c) + $ L pos $ HsBinTick noExt (c+1) (c+2) e + -- notice that F and T are reversed, + -- because we are building the list in + -- reverse... + , noFVs + , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes} + ) mkHpcPos :: SrcSpan -> HpcPos mkHpcPos pos@(RealSrcSpan s) @@ -1304,7 +1286,10 @@ hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals") matchesOneOfMany :: [LMatch GhcTc body] -> Bool matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1 where - matchCount (L _ (Match _ _pats _ty (GRHSs grhss _binds))) = length grhss + matchCount (L _ (Match { m_grhss = GRHSs _ grhss _ })) = length grhss + matchCount (L _ (Match { m_grhss = XGRHSs _ })) + = panic "matchesOneOfMany" + matchCount (L _ (XMatch _)) = panic "matchesOneOfMany" type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel) diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs index 3d8a28f7b0..c1e728b734 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -16,6 +16,8 @@ module Desugar ( #include "HsVersions.h" +import GhcPrelude + import DsUsage import DynFlags import HscTypes @@ -26,8 +28,6 @@ import TcRnDriver ( runTcInteractive ) import Id import Name import Type -import InstEnv -import Class import Avail import CoreSyn import CoreFVs ( exprsSomeFreeVarsList ) @@ -60,10 +60,12 @@ import Coverage import Util import MonadUtils import OrdList +import ExtractDocs import Data.List import Data.IORef import Control.Monad( when ) +import Plugins ( LoadedPlugin(..) ) {- ************************************************************************ @@ -101,7 +103,6 @@ deSugar hsc_env tcg_th_foreign_files = th_foreign_files_var, tcg_fords = fords, tcg_rules = rules, - tcg_vects = vects, tcg_patsyns = patsyns, tcg_tcs = tcs, tcg_insts = insts, @@ -131,24 +132,24 @@ deSugar hsc_env ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs ; (ds_fords, foreign_prs) <- dsForeigns fords ; ds_rules <- mapMaybeM dsRule rules - ; ds_vects <- mapM dsVect vects ; let hpc_init | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info | otherwise = empty ; return ( ds_ev_binds , foreign_prs `appOL` core_prs `appOL` spec_prs - , spec_rules ++ ds_rules, ds_vects + , spec_rules ++ ds_rules , ds_fords `appendStubC` hpc_init) } ; case mb_res of { Nothing -> return (msgs, Nothing) ; - Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords) -> + Just (ds_ev_binds, all_prs, all_rules, ds_fords) -> do { -- Add export flags to bindings keep_alive <- readIORef keep_var ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules final_prs = addExportFlagsAndRules target export_set keep_alive - rules_for_locals (fromOL all_prs) + mod rules_for_locals + (fromOL all_prs) final_pgm = combineEvBinds ds_ev_binds final_prs -- Notice that we put the whole lot in a big Rec, even the foreign binds @@ -157,24 +158,25 @@ deSugar hsc_env -- You might think it doesn't matter, but the simplifier brings all top-level -- things into the in-scope set before simplifying; so we get no unfolding for F#! -#if defined(DEBUG) - -- Debug only as pre-simple-optimisation program may be really big ; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps -#endif - ; (ds_binds, ds_rules_for_imps, ds_vects) - <- simpleOptPgm dflags mod final_pgm rules_for_imps vects0 + ; (ds_binds, ds_rules_for_imps) + <- simpleOptPgm dflags mod final_pgm rules_for_imps -- The simpleOptPgm gets rid of type -- bindings plus any stupid dead code ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps ; let used_names = mkUsedNames tcg_env - ; deps <- mkDependencies tcg_env + pluginModules = + map lpModule (plugins (hsc_dflags hsc_env)) + ; deps <- mkDependencies (thisInstalledUnitId (hsc_dflags hsc_env)) + (map mi_module pluginModules) tcg_env ; used_th <- readIORef tc_splice_used ; dep_files <- readIORef dependent_files ; safe_mode <- finalSafeMode dflags tcg_env - ; usages <- mkUsageInfo hsc_env mod (imp_mods imports) used_names dep_files merged + ; usages <- mkUsageInfo hsc_env mod (imp_mods imports) used_names + dep_files merged pluginModules -- id_mod /= mod when we are processing an hsig, but hsigs -- never desugared and compiled (there's no code!) -- Consequently, this should hold for any ModGuts that make @@ -183,6 +185,8 @@ deSugar hsc_env ; foreign_files <- readIORef th_foreign_files_var + ; let (doc_hdr, decl_docs, arg_docs) = extractDocs tcg_env + ; let mod_guts = ModGuts { mg_module = mod, mg_hsc_src = hsc_src, @@ -207,11 +211,12 @@ deSugar hsc_env mg_foreign_files = foreign_files, mg_hpc_info = ds_hpc_info, mg_modBreaks = modBreaks, - mg_vect_decls = ds_vects, - mg_vect_info = noVectInfo, mg_safe_haskell = safe_mode, mg_trust_pkg = imp_trust_own_pkg imports, - mg_complete_sigs = complete_matches + mg_complete_sigs = complete_matches, + mg_doc_hdr = doc_hdr, + mg_decl_docs = decl_docs, + mg_arg_docs = arg_docs } ; return (msgs, Just mod_guts) }}}} @@ -244,7 +249,7 @@ Note [Top-level evidence] ~~~~~~~~~~~~~~~~~~~~~~~~~ Top-level evidence bindings may be mutually recursive with the top-level value bindings, so we must put those in a Rec. But we can't put them *all* in a Rec -because the occurrence analyser doesn't teke account of type/coercion variables +because the occurrence analyser doesn't take account of type/coercion variables when computing dependencies. So we pull out the type/coercion variables (which are in dependency order), @@ -278,9 +283,9 @@ deSugarExpr hsc_env tc_expr = do { -} addExportFlagsAndRules - :: HscTarget -> NameSet -> NameSet -> [CoreRule] + :: HscTarget -> NameSet -> NameSet -> Module -> [CoreRule] -> [(Id, t)] -> [(Id, t)] -addExportFlagsAndRules target exports keep_alive rules prs +addExportFlagsAndRules target exports keep_alive mod rules prs = mapFst add_one prs where add_one bndr = add_rules name (add_export name bndr) @@ -313,10 +318,20 @@ addExportFlagsAndRules target exports keep_alive rules prs -- simplification), and retain them all in the TypeEnv so they are -- available from the command line. -- + -- Most of the time, this can be accomplished by use of + -- targetRetainsAllBindings, which returns True if the target is + -- HscInteractive. However, there are cases when one can use GHCi with + -- a target other than HscInteractive (e.g., with the -fobject-code + -- flag enabled, as in #12091). In such scenarios, + -- targetRetainsAllBindings can return False, so we must fall back on + -- isInteractiveModule to be doubly sure we export entities defined in + -- a GHCi session. + -- -- isExternalName separates the user-defined top-level names from those -- introduced by the type checker. is_exported :: Name -> Bool - is_exported | targetRetainsAllBindings target = isExternalName + is_exported | targetRetainsAllBindings target + || isInteractiveModule mod = isExternalName | otherwise = (`elemNameSet` exports) {- @@ -364,9 +379,9 @@ Reason -} dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule) -dsRule (L loc (HsRule name rule_act vars lhs _tv_lhs rhs _fv_rhs)) +dsRule (L loc (HsRule _ name rule_act vars lhs rhs)) = putSrcSpanDs loc $ - do { let bndrs' = [var | L _ (RuleBndr (L _ var)) <- vars] + do { let bndrs' = [var | L _ (RuleBndr _ (L _ var)) <- vars] ; lhs' <- unsetGOptM Opt_EnableRewriteRules $ unsetWOptM Opt_WarnIdentities $ @@ -379,7 +394,8 @@ dsRule (L loc (HsRule name rule_act vars lhs _tv_lhs rhs _fv_rhs)) -- Substitute the dict bindings eagerly, -- and take the body apart into a (f args) form - ; case decomposeRuleLhs bndrs'' lhs'' of { + ; dflags <- getDynFlags + ; case decomposeRuleLhs dflags bndrs'' lhs'' of { Left msg -> do { warnDs NoReason msg; return Nothing } ; Right (final_bndrs, fn_id, args) -> do @@ -388,13 +404,12 @@ dsRule (L loc (HsRule name rule_act vars lhs _tv_lhs rhs _fv_rhs)) -- we don't want to attach rules to the bindings of implicit Ids, -- because they don't show up in the bindings until just before code gen fn_name = idName fn_id - final_rhs = simpleOptExpr rhs'' -- De-crap it + final_rhs = simpleOptExpr dflags rhs'' -- De-crap it rule_name = snd (unLoc name) final_bndrs_set = mkVarSet final_bndrs arg_ids = filterOut (`elemVarSet` final_bndrs_set) $ exprsSomeFreeVarsList isId args - ; dflags <- getDynFlags ; rule <- dsMkUserRule this_mod is_local rule_name rule_act fn_name final_bndrs args final_rhs @@ -403,6 +418,7 @@ dsRule (L loc (HsRule name rule_act vars lhs _tv_lhs rhs _fv_rhs)) ; return (Just rule) } } } +dsRule (L _ (XRuleDecl _)) = panic "dsRule" warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM () @@ -424,7 +440,7 @@ warnRuleShadowing rule_name rule_act fn_id arg_ids <+> text "might inline first") , text "Probable fix: add an INLINE[n] or NOINLINE[n] pragma for" <+> quotes (ppr lhs_id) - , ifPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ]) + , whenPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ]) | check_rules_too , bad_rule : _ <- get_bad_rules lhs_id @@ -435,7 +451,7 @@ warnRuleShadowing rule_name rule_act fn_id arg_ids <+> text "for"<+> quotes (ppr lhs_id) <+> text "might fire first") , text "Probable fix: add phase [n] or [~n] to the competing rule" - , ifPprDebug (ppr bad_rule) ]) + , whenPprDebug (ppr bad_rule) ]) | otherwise = return () @@ -531,38 +547,6 @@ about this. For example in Control.Arrow we have and similar, which will elicit exactly these warnings, and risk never firing. But it's not clear what to do instead. We could make the -class methocd rules inactive in phase 2, but that would delay when +class method rules inactive in phase 2, but that would delay when subsequent transformations could fire. - - -************************************************************************ -* * -* Desugaring vectorisation declarations -* * -************************************************************************ -} - -dsVect :: LVectDecl GhcTc -> DsM CoreVect -dsVect (L loc (HsVect _ (L _ v) rhs)) - = putSrcSpanDs loc $ - do { rhs' <- dsLExpr rhs - ; return $ Vect v rhs' - } -dsVect (L _loc (HsNoVect _ (L _ v))) - = return $ NoVect v -dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon)) - = return $ VectType isScalar tycon' rhs_tycon - where - tycon' | Just ty <- coreView $ mkTyConTy tycon - , (tycon', []) <- splitTyConApp ty = tycon' - | otherwise = tycon -dsVect vd@(L _ (HsVectTypeIn _ _ _ _)) - = pprPanic "Desugar.dsVect: unexpected 'HsVectTypeIn'" (ppr vd) -dsVect (L _loc (HsVectClassOut cls)) - = return $ VectClass (classTyCon cls) -dsVect vc@(L _ (HsVectClassIn _ _)) - = pprPanic "Desugar.dsVect: unexpected 'HsVectClassIn'" (ppr vc) -dsVect (L _loc (HsVectInstOut inst)) - = return $ VectInst (instanceDFunId inst) -dsVect vi@(L _ (HsVectInstIn _)) - = pprPanic "Desugar.dsVect: unexpected 'HsVectInstIn'" (ppr vi) diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs index fb16d53e78..c69d7495d9 100644 --- a/compiler/deSugar/DsArrows.hs +++ b/compiler/deSugar/DsArrows.hs @@ -13,6 +13,8 @@ module DsArrows ( dsProcExpr ) where #include "HsVersions.h" +import GhcPrelude + import Match import DsUtils import DsMonad @@ -311,7 +313,7 @@ dsProcExpr :: LPat GhcTc -> LHsCmdTop GhcTc -> DsM CoreExpr -dsProcExpr pat (L _ (HsCmdTop cmd _unitTy cmd_ty ids)) = do +dsProcExpr pat (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 @@ -326,6 +328,7 @@ dsProcExpr pat (L _ (HsCmdTop cmd _unitTy cmd_ty ids)) = do (Lam var match_code) core_cmd return (mkLets meth_binds proc_code) +dsProcExpr _ (L _ XCmdTop{}) = panic "dsProcExpr" {- Translation of a command judgement of the form @@ -361,7 +364,7 @@ dsCmd :: DsCmdEnv -- arrow combinators -- ---> premap (\ ((xs), _stk) -> arg) fun dsCmd ids local_vars stack_ty res_ty - (HsCmdArrApp arrow arg arrow_ty HsFirstOrderApp _) + (HsCmdArrApp arrow_ty arrow arg HsFirstOrderApp _) env_ids = do let (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty @@ -386,7 +389,7 @@ dsCmd ids local_vars stack_ty res_ty -- ---> premap (\ ((xs), _stk) -> (fun, arg)) app dsCmd ids local_vars stack_ty res_ty - (HsCmdArrApp arrow arg arrow_ty HsHigherOrderApp _) + (HsCmdArrApp arrow_ty arrow arg HsHigherOrderApp _) env_ids = do let (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty @@ -414,7 +417,7 @@ dsCmd ids local_vars stack_ty res_ty -- -- ---> premap (\ ((xs),stk) -> ((ys),(e,stk))) cmd -dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do +dsCmd ids local_vars stack_ty res_ty (HsCmdApp _ cmd arg) env_ids = do core_arg <- dsLExpr arg let arg_ty = exprType core_arg @@ -447,8 +450,9 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do -- ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd dsCmd ids local_vars stack_ty res_ty - (HsCmdLam (MG { mg_alts = L _ [L _ (Match _ pats _ - (GRHSs [L _ (GRHS [] body)] _ ))] })) + (HsCmdLam _ (MG { mg_alts + = L _ [L _ (Match { m_pats = pats + , m_grhss = GRHSs _ [L _ (GRHS _ [] body)] _ })] })) env_ids = do let pat_vars = mkVarSet (collectPatsBinders pats) let @@ -477,7 +481,7 @@ dsCmd ids local_vars stack_ty res_ty return (do_premap ids in_ty in_ty' res_ty select_code core_body, free_vars `udfmMinusUFM` getUniqSet pat_vars) -dsCmd ids local_vars stack_ty res_ty (HsCmdPar cmd) env_ids +dsCmd ids local_vars stack_ty res_ty (HsCmdPar _ cmd) env_ids = dsLCmd ids local_vars stack_ty res_ty cmd env_ids -- D, xs |- e :: Bool @@ -490,7 +494,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdPar cmd) env_ids -- if e then Left ((xs1),stk) else Right ((xs2),stk)) -- (c1 ||| c2) -dsCmd ids local_vars stack_ty res_ty (HsCmdIf mb_fun cond then_cmd else_cmd) +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 @@ -551,8 +555,9 @@ case bodies, containing the following fields: -} dsCmd ids local_vars stack_ty res_ty - (HsCmdCase exp (MG { mg_alts = L l matches, mg_arg_tys = arg_tys - , mg_origin = origin })) + (HsCmdCase _ exp (MG { mg_alts = L l matches + , mg_ext = MatchGroupTc arg_tys _ + , mg_origin = origin })) env_ids = do stack_id <- newSysLocalDs stack_ty @@ -573,10 +578,12 @@ dsCmd ids local_vars stack_ty res_ty left_con <- dsLookupDataCon leftDataConName right_con <- dsLookupDataCon rightDataConName let - left_id = HsConLikeOut (RealDataCon left_con) - right_id = HsConLikeOut (RealDataCon right_con) - left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e - right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e + left_id = HsConLikeOut noExt (RealDataCon left_con) + right_id = HsConLikeOut noExt (RealDataCon right_con) + left_expr ty1 ty2 e = noLoc $ HsApp noExt + (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e + right_expr ty1 ty2 e = noLoc $ HsApp noExt + (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e -- Prefix each tuple with a distinct series of Left's and Right's, -- in a balanced way, keeping track of the types. @@ -595,9 +602,10 @@ dsCmd ids local_vars stack_ty res_ty (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches in_ty = envStackType env_ids stack_ty - core_body <- dsExpr (HsCase exp (MG { mg_alts = L l matches' - , mg_arg_tys = arg_tys - , mg_res_ty = sum_ty, mg_origin = origin })) + core_body <- dsExpr (HsCase noExt exp + (MG { mg_alts = L l matches' + , mg_ext = MatchGroupTc arg_tys sum_ty + , mg_origin = origin })) -- Note that we replace the HsCase result type by sum_ty, -- which is the type of matches' @@ -611,7 +619,8 @@ 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) env_ids = do +dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(L _ binds) body) + env_ids = do let defined_vars = mkVarSet (collectLocalBinders binds) local_vars' = defined_vars `unionVarSet` local_vars @@ -636,7 +645,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet lbinds@(L _ binds) body) env_ids -- -- ---> premap (\ (env,stk) -> env) c -dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo (L loc stmts) stmts_ty) env_ids = do +dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty (L loc stmts)) + env_ids = do putSrcSpanDs loc $ dsNoLevPoly stmts_ty (text "In the do-command:" <+> ppr do_block) @@ -656,14 +666,14 @@ dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo (L loc stmts) stmts_ty) e -- ----------------------------------- -- D; xs |-a (|e c1 ... cn|) :: stk --> t ---> e [t_xs] c1 ... cn -dsCmd _ids local_vars _stack_ty _res_ty (HsCmdArrForm op _ _ args) env_ids = do +dsCmd _ local_vars _stack_ty _res_ty (HsCmdArrForm _ op _ _ args) env_ids = do let env_ty = mkBigCoreVarTupTy env_ids core_op <- dsLExpr op (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args return (mkApps (App core_op (Type env_ty)) core_args, unionDVarSets fv_sets) -dsCmd ids local_vars stack_ty res_ty (HsCmdWrap wrap cmd) env_ids = do +dsCmd ids local_vars stack_ty res_ty (HsCmdWrap _ wrap cmd) env_ids = do (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids core_wrap <- dsHsWrapper wrap return (core_wrap core_cmd, env_ids') @@ -680,7 +690,8 @@ dsTrimCmdArg -> LHsCmdTop GhcTc -- command argument to desugar -> DsM (CoreExpr, -- desugared expression DIdSet) -- subset of local vars that occur free -dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack_ty cmd_ty ids)) = do +dsTrimCmdArg local_vars env_ids + (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 stack_id <- newSysLocalDs stack_ty @@ -691,6 +702,7 @@ dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack_ty cmd_ty ids)) = do 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" -- Given D; xs |-a c : stk --> t, builds c with xs fed back. -- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk)) @@ -748,7 +760,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 [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 @@ -806,7 +818,7 @@ dsCmdStmt -- ---> premap (\ ((xs)) -> (((xs1),()),(xs'))) -- (first c >>> arr snd) >>> ss -dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do +dsCmdStmt ids local_vars out_ids (BodyStmt c_ty cmd _ _) env_ids = do (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy c_ty cmd core_mux <- matchEnv env_ids (mkCorePairExpr @@ -837,7 +849,7 @@ dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do -- It would be simpler and more consistent to do this using second, -- but that's likely to be defined in terms of first. -dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _ _) env_ids = do +dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd _ _) env_ids = do let pat_ty = hsLPatType pat (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd let pat_vars = mkVarSet (collectPatBinders pat) @@ -888,7 +900,7 @@ dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _ _) env_ids = do -- -- ---> arr (\ (xs) -> let binds in (xs')) >>> ss -dsCmdStmt ids local_vars out_ids (LetStmt binds) env_ids = do +dsCmdStmt ids local_vars out_ids (LetStmt _ binds) env_ids = do -- build a new environment using the let bindings core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids) -- match the old environment against the input @@ -916,7 +928,8 @@ dsCmdStmt ids local_vars out_ids (LetStmt binds) env_ids = do dsCmdStmt ids local_vars out_ids (RecStmt { recS_stmts = stmts , recS_later_ids = later_ids, recS_rec_ids = rec_ids - , recS_later_rets = later_rets, recS_rec_rets = rec_rets }) + , recS_ext = RecStmtTc { recS_later_rets = later_rets + , recS_rec_rets = rec_rets } }) env_ids = do let later_ids_set = mkVarSet later_ids @@ -1106,7 +1119,7 @@ matchSimplys _ _ _ _ _ = panic "matchSimplys" leavesMatch :: LMatch GhcTc (Located (body GhcTc)) -> [(Located (body GhcTc), IdSet)] -leavesMatch (L _ (Match _ pats _ (GRHSs grhss (L _ binds)))) +leavesMatch (L _ (Match { m_pats = pats, m_grhss = GRHSs _ grhss (L _ binds) })) = let defined_vars = mkVarSet (collectPatsBinders pats) `unionVarSet` @@ -1115,7 +1128,9 @@ leavesMatch (L _ (Match _ pats _ (GRHSs grhss (L _ binds)))) [(body, mkVarSet (collectLStmtsBinders stmts) `unionVarSet` defined_vars) - | L _ (GRHS stmts body) <- grhss] + | L _ (GRHS _ stmts body) <- grhss] +leavesMatch (L _ (Match _ _ _ (XGRHSs _))) = panic "leavesMatch" +leavesMatch (L _ (XMatch _)) = panic "leavesMatch" -- Replace the leaf commands in a match @@ -1125,19 +1140,24 @@ replaceLeavesMatch -> LMatch GhcTc (Located (body GhcTc)) -- the matches of a case command -> ([Located (body' GhcTc)], -- remaining leaf expressions LMatch GhcTc (Located (body' GhcTc))) -- updated match -replaceLeavesMatch _res_ty leaves (L loc (Match mf pat mt (GRHSs grhss binds))) +replaceLeavesMatch _res_ty leaves + (L loc match@(Match { m_grhss = GRHSs x grhss binds })) = let (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss in - (leaves', L loc (Match mf pat mt (GRHSs grhss' binds))) + (leaves', L loc (match { m_ext = noExt, m_grhss = GRHSs x grhss' binds })) +replaceLeavesMatch _ _ (L _ (Match _ _ _ (XGRHSs _))) + = panic "replaceLeavesMatch" +replaceLeavesMatch _ _ (L _ (XMatch _)) = 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 stmts _)) - = (leaves, L loc (GRHS stmts leaf)) +replaceLeavesGRHS (leaf:leaves) (L loc (GRHS x stmts _)) + = (leaves, L loc (GRHS x stmts leaf)) +replaceLeavesGRHS _ (L _ (XGRHS _)) = panic "replaceLeavesGRHS" replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []" -- Balanced fold of a non-empty list. @@ -1185,31 +1205,30 @@ collectl :: LPat GhcTc -> [Id] -> [Id] collectl (L _ pat) bndrs = go pat where - go (VarPat (L _ var)) = var : bndrs + go (VarPat _ (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 (ParPat pat) = collectl pat bndrs + go (LazyPat _ pat) = collectl pat bndrs + go (BangPat _ pat) = collectl pat bndrs + go (AsPat _ (L _ a) pat) = a : collectl pat bndrs + go (ParPat _ pat) = collectl pat bndrs - go (ListPat pats _ _) = foldr collectl bndrs pats - go (PArrPat pats _) = foldr collectl bndrs pats - go (TuplePat pats _ _) = foldr collectl bndrs pats - go (SumPat pat _ _ _) = collectl pat bndrs + go (ListPat _ pats) = foldr collectl bndrs pats + go (TuplePat _ pats _) = foldr collectl bndrs pats + go (SumPat _ pat _ _) = collectl pat bndrs go (ConPatIn _ ps) = foldr collectl bndrs (hsConPatArgs ps) go (ConPatOut {pat_args=ps, pat_binds=ds}) = collectEvBinders ds ++ foldr collectl bndrs (hsConPatArgs ps) - go (LitPat _) = bndrs + go (LitPat _ _) = bndrs go (NPat {}) = bndrs - go (NPlusKPat (L _ n) _ _ _ _ _) = n : bndrs + go (NPlusKPat _ (L _ n) _ _ _ _) = n : bndrs - go (SigPatIn pat _) = collectl pat bndrs - go (SigPatOut pat _) = collectl pat bndrs - go (CoPat _ pat _) = collectl (noLoc pat) bndrs - go (ViewPat _ pat _) = collectl pat bndrs + go (SigPat _ pat) = collectl pat bndrs + go (CoPat _ _ pat _) = collectl (noLoc pat) bndrs + go (ViewPat _ _ pat) = collectl pat bndrs go p@(SplicePat {}) = pprPanic "collectl/go" (ppr p) + go p@(XPat {}) = pprPanic "collectl/go" (ppr p) collectEvBinders :: TcEvBinds -> [Id] collectEvBinders (EvBinds bs) = foldrBag add_ev_bndr [] bs diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index 5d9a33d660..421adcaccd 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -19,16 +19,18 @@ module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec, #include "HsVersions.h" +import GhcPrelude + import {-# SOURCE #-} DsExpr( dsLExpr ) import {-# SOURCE #-} Match( matchWrapper ) import DsMonad import DsGRHSs import DsUtils +import Check ( checkGuardMatches ) import HsSyn -- lots of things import CoreSyn -- lots of things -import Literal ( Literal(MachStr) ) import CoreOpt ( simpleOptExpr ) import OccurAnal ( occurAnalyseExpr ) import MkCore @@ -47,11 +49,11 @@ import Coercion import TysWiredIn ( typeNatKind, typeSymbolKind ) import Id import MkId(proxyHashId) -import Class import Name import VarSet import Rules import VarEnv +import Var( EvVar, varType ) import Outputable import Module import SrcLoc @@ -62,6 +64,7 @@ import BasicTypes import DynFlags import FastString import Util +import UniqSet( nonDetEltsUniqSet ) import MonadUtils import qualified GHC.LanguageExtensions as LangExt import Control.Monad @@ -79,7 +82,7 @@ dsTopLHsBinds binds -- see Note [Strict binds checks] | not (isEmptyBag unlifted_binds) || not (isEmptyBag bang_binds) = do { mapBagM_ (top_level_err "bindings for unlifted types") unlifted_binds - ; mapBagM_ (top_level_err "strict pattern bindings") bang_binds + ; mapBagM_ (top_level_err "strict bindings") bang_binds ; return nilOL } | otherwise @@ -93,7 +96,7 @@ dsTopLHsBinds binds where unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds - bang_binds = filterBag (isBangedPatBind . unLoc) binds + bang_binds = filterBag (isBangedHsBind . unLoc) binds top_level_err desc (L loc bind) = putSrcSpanDs loc $ @@ -105,8 +108,7 @@ dsTopLHsBinds binds -- later be forced in the binding group body, see Note [Desugar Strict binds] dsLHsBinds :: LHsBinds GhcTc -> DsM ([Id], [(Id,CoreExpr)]) dsLHsBinds binds - = do { MASSERT( allBag (not . isUnliftedHsBind . unLoc) binds ) - ; ds_bs <- mapBagM dsLHsBind binds + = do { ds_bs <- mapBagM dsLHsBind binds ; return (foldBag (\(a, a') (b, b') -> (a ++ b, a' ++ b')) id ([], []) ds_bs) } @@ -124,10 +126,9 @@ dsHsBind :: DynFlags -- binding group see Note [Desugar Strict binds] and all -- bindings and their desugared right hand sides. -dsHsBind dflags - (VarBind { var_id = var - , var_rhs = expr - , var_inline = inline_regardless }) +dsHsBind dflags (VarBind { var_id = var + , var_rhs = expr + , var_inline = inline_regardless }) = do { core_expr <- dsLExpr expr -- Dictionary bindings are always VarBinds, -- so we only need do this here @@ -139,9 +140,8 @@ dsHsBind dflags 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 = L _ fun, fun_matches = matches + , fun_co_fn = co_fn, fun_tick = tick }) = do { (args, body) <- matchWrapper (mkPrefixFunRhs (noLoc $ idName fun)) Nothing matches @@ -154,17 +154,20 @@ dsHsBind dflags | xopt LangExt.Strict dflags , matchGroupArity matches == 0 -- no need to force lambdas = [id] - | isBangedBind b + | isBangedHsBind b = [id] | otherwise = [] - ; --pprTrace "dsHsBind" (ppr fun <+> ppr (idInlinePragma fun) $$ ppr (mg_alts matches) $$ ppr args $$ ppr core_binds) $ - return (force_var, [core_binds]) } - -dsHsBind dflags - (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty - , pat_ticks = (rhs_tick, var_ticks) }) + ; --pprTrace "dsHsBind" (vcat [ ppr fun <+> ppr (idInlinePragma fun) + -- , ppr (mg_alts matches) + -- , ppr args, ppr core_binds]) $ + return (force_var, [core_binds]) } + +dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss + , pat_ext = NPatBindTc _ ty + , pat_ticks = (rhs_tick, var_ticks) }) = do { body_expr <- dsGuarded grhss ty + ; checkGuardMatches PatBindGuards grhss ; let body' = mkOptTickBox rhs_tick body_expr pat' = decideBangHood dflags pat ; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat body' @@ -175,47 +178,75 @@ dsHsBind dflags else [] ; return (force_var', sel_binds) } - -- A common case: one exported variable, only non-strict binds - -- Non-recursive bindings come through this way - -- So do self-recursive bindings - -- Bindings with complete signatures are AbsBindsSigs, below -dsHsBind dflags - (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts - , abs_exports = [export] - , abs_ev_binds = ev_binds, abs_binds = binds }) - | ABE { abe_wrap = wrap, abe_poly = global - , abe_mono = local, abe_prags = prags } <- export - , not (xopt LangExt.Strict dflags) -- Handle strict binds - , not (anyBag (isBangedBind . unLoc) binds) -- in the next case - = -- See Note [AbsBinds wrappers] in HsBinds - addDictsDs (toTcTypeBag (listToBag dicts)) $ - -- addDictsDs: push type constraints deeper for pattern match check - do { (force_vars, bind_prs) <- dsLHsBinds binds - ; ds_binds <- dsTcEvBinds_s ev_binds - ; core_wrap <- dsHsWrapper wrap -- Usually the identity +dsHsBind dflags (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts + , abs_exports = exports + , abs_ev_binds = ev_binds + , abs_binds = binds, abs_sig = has_sig }) + = do { ds_binds <- addDictsDs (listToBag dicts) $ + dsLHsBinds binds + -- addDictsDs: push type constraints deeper + -- for inner pattern match check + -- See Check, Note [Type and Term Equality Propagation] + + ; ds_ev_binds <- dsTcEvBinds_s ev_binds + + -- dsAbsBinds does the hard work + ; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds has_sig } + +dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind" +dsHsBind _ (XHsBindsLR{}) = panic "dsHsBind: XHsBindsLR" + + +----------------------- +dsAbsBinds :: DynFlags + -> [TyVar] -> [EvVar] -> [ABExport GhcTc] + -> [CoreBind] -- Desugared evidence bindings + -> ([Id], [(Id,CoreExpr)]) -- Desugared value bindings + -> Bool -- Single binding with signature + -> DsM ([Id], [(Id,CoreExpr)]) + +dsAbsBinds dflags tyvars dicts exports + ds_ev_binds (force_vars, bind_prs) has_sig + + -- A very important common case: one exported variable + -- Non-recursive bindings come through this way + -- So do self-recursive bindings + | [export] <- exports + , ABE { abe_poly = global_id, abe_mono = local_id + , abe_wrap = wrap, abe_prags = prags } <- export + , Just force_vars' <- case force_vars of + [] -> Just [] + [v] | v == local_id -> Just [global_id] + _ -> Nothing + -- If there is a variable to force, it's just the + -- single variable we are binding here + = do { core_wrap <- dsHsWrapper wrap -- Usually the identity ; let rhs = core_wrap $ mkLams tyvars $ mkLams dicts $ - mkCoreLets ds_binds $ - mkLetRec bind_prs $ - Var local + mkCoreLets ds_ev_binds $ + body + + body | has_sig + , [(_, lrhs)] <- bind_prs + = lrhs + | otherwise + = mkLetRec bind_prs (Var local_id) + ; (spec_binds, rules) <- dsSpecs rhs prags - ; let global' = addIdSpecialisations global rules - main_bind = makeCorePair dflags global' (isDefaultMethod prags) - (dictArity dicts) rhs + ; let global_id' = addIdSpecialisations global_id rules + main_bind = makeCorePair dflags global_id' + (isDefaultMethod prags) + (dictArity dicts) rhs - ; ASSERT(null force_vars) - return ([], main_bind : fromOL spec_binds) } + ; return (force_vars', main_bind : fromOL spec_binds) } - -- Another common case: no tyvars, no dicts - -- In this case we can have a much simpler desugaring -dsHsBind dflags - (AbsBinds { abs_tvs = [], abs_ev_vars = [] - , abs_exports = exports - , abs_ev_binds = ev_binds, abs_binds = binds }) - = do { (force_vars, bind_prs) <- dsLHsBinds binds - ; let mk_bind (ABE { abe_wrap = wrap + -- Another common case: no tyvars, no dicts + -- In this case we can have a much simpler desugaring + | null tyvars, null dicts + + = do { let mk_bind (ABE { abe_wrap = wrap , abe_poly = global , abe_mono = local , abe_prags = prags }) @@ -223,44 +254,38 @@ dsHsBind dflags ; return (makeCorePair dflags global (isDefaultMethod prags) 0 (core_wrap (Var local))) } + mk_bind (XABExport _) = panic "dsAbsBinds" ; main_binds <- mapM mk_bind exports - ; ds_binds <- dsTcEvBinds_s ev_binds - ; return (force_vars, flattenBinds ds_binds ++ bind_prs ++ main_binds) } - -dsHsBind dflags - (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts - , abs_exports = exports, abs_ev_binds = ev_binds - , abs_binds = binds }) - -- See Note [Desugaring AbsBinds] - = addDictsDs (toTcTypeBag (listToBag dicts)) $ - -- addDictsDs: push type constraints deeper for pattern match check - do { (local_force_vars, bind_prs) <- dsLHsBinds binds - ; let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs + ; return (force_vars, flattenBinds ds_ev_binds ++ bind_prs ++ main_binds) } + + -- The general case + -- See Note [Desugaring AbsBinds] + | otherwise + = do { let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs | (lcl_id, rhs) <- bind_prs ] -- Monomorphic recursion possible, hence Rec - new_force_vars = get_new_force_vars local_force_vars - locals = map abe_mono exports - all_locals = locals ++ new_force_vars - tup_expr = mkBigCoreVarTup all_locals - tup_ty = exprType tup_expr - ; ds_binds <- dsTcEvBinds_s ev_binds - ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $ - mkCoreLets ds_binds $ - mkLet core_bind $ - tup_expr - - ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs) + new_force_vars = get_new_force_vars force_vars + locals = map abe_mono exports + all_locals = locals ++ new_force_vars + tup_expr = mkBigCoreVarTup all_locals + tup_ty = exprType tup_expr + ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $ + mkCoreLets ds_ev_binds $ + mkLet core_bind $ + tup_expr + + ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs) -- Find corresponding global or make up a new one: sometimes -- we need to make new export to desugar strict binds, see -- Note [Desugar Strict binds] - ; (exported_force_vars, extra_exports) <- get_exports local_force_vars + ; (exported_force_vars, extra_exports) <- get_exports force_vars - ; let mk_bind (ABE { abe_wrap = wrap - , abe_poly = global - , abe_mono = local, abe_prags = spec_prags }) - -- See Note [AbsBinds wrappers] in HsBinds + ; let mk_bind (ABE { abe_wrap = wrap + , abe_poly = global + , abe_mono = local, abe_prags = spec_prags }) + -- See Note [AbsBinds wrappers] in HsBinds = do { tup_id <- newSysLocalDs tup_ty ; core_wrap <- dsHsWrapper wrap ; let rhs = core_wrap $ mkLams tyvars $ mkLams dicts $ @@ -274,11 +299,12 @@ dsHsBind dflags -- the user written (local) function. The global -- Id is just the selector. Hmm. ; return ((global', rhs) : fromOL spec_binds) } + mk_bind (XABExport _) = panic "dsAbsBinds" - ; export_binds_s <- mapM mk_bind (exports ++ extra_exports) + ; export_binds_s <- mapM mk_bind (exports ++ extra_exports) - ; return (exported_force_vars - ,(poly_tup_id, poly_tup_rhs) : + ; return ( exported_force_vars + , (poly_tup_id, poly_tup_rhs) : concat export_binds_s) } where inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with @@ -321,57 +347,11 @@ dsHsBind dflags mk_export local = do global <- newSysLocalDs (exprType (mkLams tyvars (mkLams dicts (Var local)))) - return (ABE {abe_poly = global - ,abe_mono = local - ,abe_wrap = WpHole - ,abe_prags = SpecPrags []}) - --- AbsBindsSig is a combination of AbsBinds and FunBind -dsHsBind dflags (AbsBindsSig { abs_tvs = tyvars, abs_ev_vars = dicts - , abs_sig_export = global - , abs_sig_prags = prags - , abs_sig_ev_bind = ev_bind - , abs_sig_bind = bind }) - | L bind_loc FunBind { fun_matches = matches - , fun_co_fn = co_fn - , fun_tick = tick } <- bind - = putSrcSpanDs bind_loc $ - addDictsDs (toTcTypeBag (listToBag dicts)) $ - -- addDictsDs: push type constraints deeper for pattern match check - do { (args, body) <- matchWrapper - (mkPrefixFunRhs (noLoc $ idName global)) - Nothing matches - ; core_wrap <- dsHsWrapper co_fn - ; let body' = mkOptTickBox tick body - fun_rhs = core_wrap (mkLams args body') - force_vars - | xopt LangExt.Strict dflags - , matchGroupArity matches == 0 -- no need to force lambdas - = [global] - | isBangedBind (unLoc bind) - = [global] - | otherwise - = [] - - ; ds_binds <- dsTcEvBinds ev_bind - ; let rhs = mkLams tyvars $ - mkLams dicts $ - mkCoreLets ds_binds $ - fun_rhs - - ; (spec_binds, rules) <- dsSpecs rhs prags - ; let global' = addIdSpecialisations global rules - main_bind = makeCorePair dflags global' (isDefaultMethod prags) - (dictArity dicts) rhs - - ; return (force_vars, main_bind : fromOL spec_binds) } - - | otherwise - = pprPanic "dsHsBind: AbsBindsSig" (ppr bind) - -dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind" - - + return (ABE { abe_ext = noExt + , abe_poly = global + , abe_mono = local + , abe_wrap = WpHole + , abe_prags = SpecPrags [] }) -- | This is where we apply INLINE and INLINABLE pragmas. All we need to -- do is to attach the unfolding information to the Id. @@ -384,15 +364,16 @@ dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind" makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr) makeCorePair dflags gbl_id is_default_method dict_arity rhs - | is_default_method -- Default methods are *always* inlined + | is_default_method -- Default methods are *always* inlined + -- See Note [INLINE and default methods] in TcInstDcls = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs) | otherwise = case inlinePragmaSpec inline_prag of - EmptyInlineSpec -> (gbl_id, rhs) - NoInline -> (gbl_id, rhs) - Inlinable -> (gbl_id `setIdUnfolding` inlinable_unf, rhs) - Inline -> inline_pair + NoUserInline -> (gbl_id, rhs) + NoInline -> (gbl_id, rhs) + Inlinable -> (gbl_id `setIdUnfolding` inlinable_unf, rhs) + Inline -> inline_pair where inline_prag = idInlinePragma gbl_id @@ -631,7 +612,7 @@ We define an "unlifted bind" to be any bind that binds an unlifted id. Note that is *not* an unlifted bind. Unlifted binds are detected by HsUtils.isUnliftedHsBind. -Define a "banged bind" to have a top-level bang. Detected by HsPat.isBangedPatBind. +Define a "banged bind" to have a top-level bang. Detected by HsPat.isBangedHsBind. Define a "strict bind" to be either an unlifted bind or a banged bind. The restrictions are: @@ -680,7 +661,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) = putSrcSpanDs loc $ do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for NOINLINE function:" <+> quotes (ppr poly_id)) - ; return Nothing } -- Function is NOINLINE, and the specialiation inherits that + ; return Nothing } -- Function is NOINLINE, and the specialisation inherits that -- See Note [Activation pragmas for SPECIALISE] | otherwise @@ -702,14 +683,14 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) ; -- pprTrace "dsRule" (vcat [ text "Id:" <+> ppr poly_id -- , text "spec_co:" <+> ppr spec_co -- , text "ds_rhs:" <+> ppr ds_lhs ]) $ - case decomposeRuleLhs spec_bndrs ds_lhs of { + dflags <- getDynFlags + ; case decomposeRuleLhs dflags spec_bndrs ds_lhs of { Left msg -> do { warnDs NoReason msg; return Nothing } ; Right (rule_bndrs, _fn, args) -> do - { dflags <- getDynFlags - ; this_mod <- getModule + { this_mod <- getModule ; let fn_unf = realIdUnfolding poly_id - spec_unf = specUnfolding spec_bndrs core_app arity_decrease fn_unf + spec_unf = specUnfolding dflags spec_bndrs core_app arity_decrease fn_unf spec_id = mkLocalId spec_name spec_ty `setInlinePragma` inl_prag `setIdUnfolding` spec_unf @@ -841,14 +822,15 @@ SPEC f :: ty [n] INLINE [k] ************************************************************************ -} -decomposeRuleLhs :: [Var] -> CoreExpr -> Either SDoc ([Var], Id, [CoreExpr]) +decomposeRuleLhs :: DynFlags -> [Var] -> CoreExpr + -> Either SDoc ([Var], Id, [CoreExpr]) -- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE, -- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs -- may add some extra dictionary binders (see Note [Free dictionaries]) -- -- Returns an error message if the LHS isn't of the expected shape -- Note [Decomposing the left-hand side of a RULE] -decomposeRuleLhs orig_bndrs orig_lhs +decomposeRuleLhs dflags orig_bndrs orig_lhs | not (null unbound) -- Check for things unbound on LHS -- See Note [Unused spec binders] = Left (vcat (map dead_msg unbound)) @@ -869,7 +851,7 @@ decomposeRuleLhs orig_bndrs orig_lhs = Left bad_shape_msg where lhs1 = drop_dicts orig_lhs - lhs2 = simpleOptExpr lhs1 -- See Note [Simplify rule LHS] + lhs2 = simpleOptExpr dflags lhs1 -- See Note [Simplify rule LHS] (fun2,args2) = collectArgs lhs2 lhs_fvs = exprFreeVars lhs2 @@ -1040,7 +1022,7 @@ drop_dicts drops dictionary bindings on the LHS where possible. RULE forall s (d :: MonadAbstractIOST (ReaderT s)). useAbstractMonad (ReaderT s) d = $suseAbstractMonad s - Trac #8848 is a good example of where there are some intersting + Trac #8848 is a good example of where there are some interesting dictionary bindings to discard. The drop_dicts algorithm is based on these observations: @@ -1165,15 +1147,39 @@ dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this dsTcEvBinds (EvBinds bs) = dsEvBinds bs dsEvBinds :: Bag EvBind -> DsM [CoreBind] -dsEvBinds bs = mapM ds_scc (sccEvBinds bs) +dsEvBinds bs + = do { ds_bs <- mapBagM dsEvBind bs + ; return (mk_ev_binds ds_bs) } + +mk_ev_binds :: Bag (Id,CoreExpr) -> [CoreBind] +-- We do SCC analysis of the evidence bindings, /after/ desugaring +-- them. This is convenient: it means we can use the CoreSyn +-- free-variable functions rather than having to do accurate free vars +-- for EvTerm. +mk_ev_binds ds_binds + = map ds_scc (stronglyConnCompFromEdgedVerticesUniq edges) where - ds_scc (AcyclicSCC (EvBind { eb_lhs = v, eb_rhs = r})) - = liftM (NonRec v) (dsEvTerm r) - ds_scc (CyclicSCC bs) = liftM Rec (mapM dsEvBind bs) + edges :: [ Node EvVar (EvVar,CoreExpr) ] + edges = foldrBag ((:) . mk_node) [] ds_binds + + mk_node :: (Id, CoreExpr) -> Node EvVar (EvVar,CoreExpr) + mk_node b@(var, rhs) + = DigraphNode { node_payload = b + , node_key = var + , node_dependencies = nonDetEltsUniqSet $ + exprFreeVars rhs `unionVarSet` + coVarsOfType (varType var) } + -- It's OK to use nonDetEltsUniqSet here as stronglyConnCompFromEdgedVertices + -- is still deterministic even if the edges are in nondeterministic order + -- as explained in Note [Deterministic SCC] in Digraph. + + ds_scc (AcyclicSCC (v,r)) = NonRec v r + ds_scc (CyclicSCC prs) = Rec prs dsEvBind :: EvBind -> DsM (Id, CoreExpr) dsEvBind (EvBind { eb_lhs = v, eb_rhs = r}) = liftM ((,) v) (dsEvTerm r) + {-********************************************************************** * * Desugaring EvTerms @@ -1181,41 +1187,15 @@ dsEvBind (EvBind { eb_lhs = v, eb_rhs = r}) = liftM ((,) v) (dsEvTerm r) **********************************************************************-} dsEvTerm :: EvTerm -> DsM CoreExpr -dsEvTerm (EvId v) = return (Var v) -dsEvTerm (EvCallStack cs) = dsEvCallStack cs -dsEvTerm (EvTypeable ty ev) = dsEvTypeable ty ev -dsEvTerm (EvLit (EvNum n)) = mkNaturalExpr n -dsEvTerm (EvLit (EvStr s)) = mkStringExprFS s - -dsEvTerm (EvCast tm co) - = do { tm' <- dsEvTerm tm - ; return $ mkCastDs tm' co } - -dsEvTerm (EvDFunApp df tys tms) - = do { tms' <- mapM dsEvTerm tms - ; return $ Var df `mkTyApps` tys `mkApps` tms' } - -- The use of mkApps here is OK vis-a-vis levity polymorphism because - -- the terms are always evidence variables with types of kind Constraint - -dsEvTerm (EvCoercion co) = return (Coercion co) -dsEvTerm (EvSuperClass d n) - = do { d' <- dsEvTerm d - ; let (cls, tys) = getClassPredTys (exprType d') - sc_sel_id = classSCSelId cls n -- Zero-indexed - ; return $ Var sc_sel_id `mkTyApps` tys `App` d' } - -dsEvTerm (EvSelector sel_id tys tms) - = do { tms' <- mapM dsEvTerm tms - ; return $ Var sel_id `mkTyApps` tys `mkApps` tms' } - -dsEvTerm (EvDelayedError ty msg) = return $ dsEvDelayedError ty msg - -dsEvDelayedError :: Type -> FastString -> CoreExpr -dsEvDelayedError ty msg - = Var errorId `mkTyApps` [getRuntimeRep "dsEvTerm" ty, ty] `mkApps` [litMsg] - where - errorId = tYPE_ERROR_ID - litMsg = Lit (MachStr (fastStringToByteString msg)) +dsEvTerm (EvExpr e) = return e +dsEvTerm (EvTypeable ty ev) = dsEvTypeable ty ev +dsEvTerm (EvFun { et_tvs = tvs, et_given = given + , et_binds = ev_binds, et_body = wanted_id }) + = do { ds_ev_binds <- dsTcEvBinds ev_binds + ; return $ (mkLams (tvs ++ given) $ + mkCoreLets ds_ev_binds $ + Var wanted_id) } + {-********************************************************************** * * @@ -1264,10 +1244,12 @@ ds_ev_typeable ty (EvTypeableTyCon tc kind_ev) -- Note that we use the kind of the type, not the TyCon from which it -- is constructed since the latter may be kind polymorphic whereas the -- former we know is not (we checked in the solver). - ; return $ mkApps (Var mkTrCon) [ Type (typeKind ty) - , Type ty - , tc_rep - , kind_args ] + ; let expr = mkApps (Var mkTrCon) [ Type (typeKind ty) + , Type ty + , tc_rep + , kind_args ] + -- ; pprRuntimeTrace "Trace mkTrTyCon" (ppr expr) expr + ; return expr } ds_ev_typeable ty (EvTypeableTyApp ev1 ev2) @@ -1278,8 +1260,11 @@ ds_ev_typeable ty (EvTypeableTyApp ev1 ev2) -- mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1). -- TypeRep a -> TypeRep b -> TypeRep (a b) ; let (k1, k2) = splitFunTy (typeKind t1) - ; return $ mkApps (mkTyApps (Var mkTrApp) [ k1, k2, t1, t2 ]) - [ e1, e2 ] } + ; let expr = mkApps (mkTyApps (Var mkTrApp) [ k1, k2, t1, t2 ]) + [ e1, e2 ] + -- ; pprRuntimeTrace "Trace mkTrApp" (ppr expr) expr + ; return expr + } ds_ev_typeable ty (EvTypeableTrFun ev1 ev2) | Just (t1,t2) <- splitFunTy_maybe ty @@ -1288,15 +1273,16 @@ ds_ev_typeable ty (EvTypeableTrFun ev1 ev2) ; mkTrFun <- dsLookupGlobalId mkTrFunName -- mkTrFun :: forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). -- TypeRep a -> TypeRep b -> TypeRep (a -> b) - ; let r1 = getRuntimeRep "ds_ev_typeable" t1 - r2 = getRuntimeRep "ds_ev_typeable" t2 + ; let r1 = getRuntimeRep t1 + r2 = getRuntimeRep t2 ; return $ mkApps (mkTyApps (Var mkTrFun) [r1, r2, t1, t2]) [ e1, e2 ] } ds_ev_typeable ty (EvTypeableTyLit ev) - = do { fun <- dsLookupGlobalId tr_fun - ; dict <- dsEvTerm ev -- Of type KnownNat/KnownSym + = -- See Note [Typeable for Nat and Symbol] in TcInteract + do { fun <- dsLookupGlobalId tr_fun + ; dict <- dsEvTerm ev -- Of type KnownNat/KnownSymbol ; let proxy = mkTyApps (Var proxyHashId) [ty_kind, ty] ; return (mkApps (mkTyApps (Var fun) [ty]) [ dict, proxy ]) } where @@ -1332,58 +1318,3 @@ tyConRep tc ; return (Var tc_rep_id) } | otherwise = pprPanic "tyConRep" (ppr tc) - -{- Note [Memoising typeOf] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #3245, #9203 - -IMPORTANT: we don't want to recalculate the TypeRep once per call with -the proxy argument. This is what went wrong in #3245 and #9203. So we -help GHC by manually keeping the 'rep' *outside* the lambda. --} - - -{-********************************************************************** -* * - Desugaring EvCallStack evidence -* * -**********************************************************************-} - -dsEvCallStack :: EvCallStack -> DsM CoreExpr --- See Note [Overview of implicit CallStacks] in TcEvidence.hs -dsEvCallStack cs = do - df <- getDynFlags - m <- getModule - srcLocDataCon <- dsLookupDataCon srcLocDataConName - let mkSrcLoc l = - liftM (mkCoreConApps srcLocDataCon) - (sequence [ mkStringExprFS (unitIdFS $ moduleUnitId m) - , mkStringExprFS (moduleNameFS $ moduleName m) - , mkStringExprFS (srcSpanFile l) - , return $ mkIntExprInt df (srcSpanStartLine l) - , return $ mkIntExprInt df (srcSpanStartCol l) - , return $ mkIntExprInt df (srcSpanEndLine l) - , return $ mkIntExprInt df (srcSpanEndCol l) - ]) - - emptyCS <- Var <$> dsLookupGlobalId emptyCallStackName - - pushCSVar <- dsLookupGlobalId pushCallStackName - let pushCS name loc rest = - mkCoreApps (Var pushCSVar) [mkCoreTup [name, loc], rest] - - let mkPush name loc tm = do - nameExpr <- mkStringExprFS name - locExpr <- mkSrcLoc loc - case tm of - EvCallStack EvCsEmpty -> return (pushCS nameExpr locExpr emptyCS) - _ -> do tmExpr <- dsEvTerm tm - -- at this point tmExpr :: IP sym CallStack - -- but we need the actual CallStack to pass to pushCS, - -- so we use unwrapIP to strip the dictionary wrapper - -- See Note [Overview of implicit CallStacks] - let ip_co = unwrapIP (exprType tmExpr) - return (pushCS nameExpr locExpr (mkCastDs tmExpr ip_co)) - case cs of - EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm - EvCsEmpty -> return emptyCS diff --git a/compiler/deSugar/DsCCall.hs b/compiler/deSugar/DsCCall.hs index 2a5769f6e2..7a634ac1ff 100644 --- a/compiler/deSugar/DsCCall.hs +++ b/compiler/deSugar/DsCCall.hs @@ -18,6 +18,8 @@ module DsCCall #include "HsVersions.h" +import GhcPrelude + import CoreSyn import DsMonad @@ -134,7 +136,7 @@ unboxArg :: CoreExpr -- The supplied argument, not levity-pol -- always returns a non-levity-polymorphic expression unboxArg arg - -- Primtive types: nothing to unbox + -- Primitive types: nothing to unbox | isPrimitiveType arg_ty = return (arg, \body -> body) @@ -202,7 +204,7 @@ boxResult :: Type -- Takes the result of the user-level ccall: -- either (IO t), --- or maybe just t for an side-effect-free call +-- or maybe just t for a side-effect-free call -- Returns a wrapper for the primitive ccall itself, along with the -- type of the result of the primitive ccall. This result type -- will be of the form diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index c3d9489476..f9ee3b4cb8 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -14,6 +14,8 @@ module DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds #include "HsVersions.h" +import GhcPrelude + import Match import MatchLit import DsBinds @@ -22,6 +24,7 @@ import DsListComp import DsUtils import DsArrows import DsMonad +import Check ( checkGuardMatches ) import Name import NameEnv import FamInstEnv( topNormaliseType ) @@ -68,29 +71,33 @@ import Control.Monad -} dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr -dsLocalBinds (L _ EmptyLocalBinds) body = return body -dsLocalBinds (L loc (HsValBinds binds)) body = putSrcSpanDs loc $ - dsValBinds binds body -dsLocalBinds (L _ (HsIPBinds binds)) body = dsIPBinds binds body +dsLocalBinds (L _ (EmptyLocalBinds _)) body = return body +dsLocalBinds (L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $ + dsValBinds binds body +dsLocalBinds (L _ (HsIPBinds _ binds)) body = dsIPBinds binds body +dsLocalBinds (L _ (XHsLocalBindsLR _)) _ = panic "dsLocalBinds" ------------------------- -- caller sets location dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr -dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds -dsValBinds (ValBindsIn {}) _ = panic "dsValBinds ValBindsIn" +dsValBinds (XValBindsLR (NValBinds binds _)) body + = foldrM ds_val_bind body binds +dsValBinds (ValBinds {}) _ = panic "dsValBinds ValBindsIn" ------------------------- dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr -dsIPBinds (IPBinds ip_binds ev_binds) body +dsIPBinds (IPBinds ev_binds ip_binds) body = do { ds_binds <- dsTcEvBinds ev_binds ; let inner = mkCoreLets ds_binds body -- The dict bindings may not be in -- dependency order; hence Rec ; foldrM ds_ip_bind inner ip_binds } where - ds_ip_bind (L _ (IPBind ~(Right n) e)) body + ds_ip_bind (L _ (IPBind _ ~(Right n) e)) body = do e' <- dsLExpr e return (Let (NonRec n e') body) + ds_ip_bind (L _ (XIPBind _)) _ = panic "dsIPBinds" +dsIPBinds (XHsIPBinds _) _ = panic "dsIPBinds" ------------------------- -- caller sets location @@ -130,8 +137,6 @@ ds_val_bind (NonRecursive, hsbinds) body where is_polymorphic (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }) = not (null tvs && null evs) - is_polymorphic (AbsBindsSig { abs_tvs = tvs, abs_ev_vars = evs }) - = not (null tvs && null evs) is_polymorphic _ = False unlifted_must_be_bang bind @@ -186,15 +191,6 @@ dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = [] ; ds_binds <- dsTcEvBinds_s ev_binds ; return (mkCoreLets ds_binds body2) } -dsUnliftedBind (AbsBindsSig { abs_tvs = [] - , abs_ev_vars = [] - , abs_sig_export = poly - , abs_sig_ev_bind = ev_bind - , abs_sig_bind = L _ bind }) body - = do { ds_binds <- dsTcEvBinds ev_bind - ; body' <- dsUnliftedBind (bind { fun_id = noLoc poly }) body - ; return (mkCoreLets ds_binds body') } - dsUnliftedBind (FunBind { fun_id = L l fun , fun_matches = matches , fun_co_fn = co_fn @@ -208,10 +204,12 @@ dsUnliftedBind (FunBind { fun_id = L l fun ; let rhs' = mkOptTickBox tick rhs ; return (bindNonRec fun rhs' body) } -dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body +dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss + , pat_ext = NPatBindTc _ ty }) body = -- let C x# y# = rhs in body -- ==> case rhs of C x# y# -> body do { rhs <- dsGuarded grhss ty + ; checkGuardMatches PatBindGuards grhss ; let upat = unLoc pat eqn = EqnInfo { eqn_pats = [upat], eqn_rhs = cantFailMatchResult body } @@ -258,18 +256,19 @@ dsExpr = ds_expr False ds_expr :: Bool -- are we directly inside an HsWrap? -- See Wrinkle in Note [Detecting forced eta expansion] -> HsExpr GhcTc -> DsM CoreExpr -ds_expr _ (HsPar e) = dsLExpr e -ds_expr _ (ExprWithTySigOut e _) = dsLExpr e -ds_expr w (HsVar (L _ var)) = dsHsVar w var +ds_expr _ (HsPar _ e) = dsLExpr e +ds_expr _ (ExprWithTySig _ e) = dsLExpr e +ds_expr w (HsVar _ (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" +ds_expr w (HsConLikeOut _ con) = dsConLike w con +ds_expr _ (HsIPVar {}) = panic "dsExpr: HsIPVar" ds_expr _ (HsOverLabel{}) = panic "dsExpr: HsOverLabel" -ds_expr _ (HsLit lit) = dsLit (convertLit lit) -ds_expr _ (HsOverLit lit) = dsOverLit lit +ds_expr _ (HsLit _ lit) = dsLit (convertLit lit) +ds_expr _ (HsOverLit _ lit) = dsOverLit lit -ds_expr _ (HsWrap co_fn e) - = do { e' <- ds_expr True e +ds_expr _ (HsWrap _ co_fn e) + = do { e' <- ds_expr True e -- This is the one place where we recurse to + -- ds_expr (passing True), rather than dsExpr ; wrap' <- dsHsWrapper co_fn ; dflags <- getDynFlags ; let wrapped_e = wrap' e' @@ -278,7 +277,7 @@ 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 _ (L loc (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i}))) neg_expr) = do { expr' <- putSrcSpanDs loc $ do { dflags <- getDynFlags @@ -287,27 +286,26 @@ ds_expr _ (NegApp (L loc (HsOverLit lit@(OverLit { ol_val = HsIntegral i }))) ; dsOverLit' dflags lit } ; dsSyntaxExpr neg_expr [expr'] } -ds_expr _ (NegApp expr neg_expr) +ds_expr _ (NegApp _ expr neg_expr) = do { expr' <- dsLExpr expr ; dsSyntaxExpr neg_expr [expr'] } -ds_expr _ (HsLam a_Match) +ds_expr _ (HsLam _ a_Match) = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match -ds_expr _ (HsLamCase matches) +ds_expr _ (HsLamCase _ matches) = do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches ; return $ Lam discrim_var matching_code } -ds_expr _ e@(HsApp fun arg) +ds_expr _ e@(HsApp _ fun arg) = do { fun' <- dsLExpr fun ; dsWhenNoErrs (dsLExprNoLP arg) (\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') } -ds_expr _ (HsAppTypeOut e _) +ds_expr _ (HsAppType _ e) -- ignore type arguments here; they're in the wrappers instead at this point = dsLExpr e - {- Note [Desugaring vars] ~~~~~~~~~~~~~~~~~~~~~~ @@ -347,19 +345,19 @@ If \tr{expr} is actually just a variable, say, then the simplifier will sort it out. -} -ds_expr _ e@(OpApp e1 op _ e2) +ds_expr _ e@(OpApp _ e1 op e2) = -- for the type of y, we need the type of op's 2nd argument do { op' <- dsLExpr op ; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2]) (\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') } -ds_expr _ (SectionL expr op) -- Desugar (e !) to ((!) e) +ds_expr _ (SectionL _ expr op) -- Desugar (e !) to ((!) e) = do { op' <- dsLExpr op ; dsWhenNoErrs (dsLExprNoLP expr) (\expr' -> mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr') } -- dsLExpr (SectionR op expr) -- \ x -> op x expr -ds_expr _ e@(SectionR op expr) = do +ds_expr _ e@(SectionR _ op expr) = do core_op <- dsLExpr op -- for the type of x, we need the type of op's 2nd argument let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op) @@ -370,67 +368,67 @@ ds_expr _ e@(SectionR op expr) = do Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e) core_op [Var x_id, Var y_id])) -ds_expr _ (ExplicitTuple tup_args boxity) +ds_expr _ (ExplicitTuple _ tup_args boxity) = do { let go (lam_vars, args) (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) (L _ (Present _ expr)) -- Expressions that are present don't generate -- lambdas, just arguments. - = do { core_expr <- dsLExpr expr + = do { core_expr <- dsLExprNoLP expr ; return (lam_vars, core_expr : args) } + go _ (L _ (XTupArg {})) = panic "ds_expr" - ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args) + ; dsWhenNoErrs (foldM go ([], []) (reverse tup_args)) -- The reverse is because foldM goes left-to-right + (\(lam_vars, args) -> mkCoreLams lam_vars $ + mkCoreTupBoxity boxity args) } - ; return $ mkCoreLams lam_vars $ - mkCoreTupBoxity boxity args } - -ds_expr _ (ExplicitSum alt arity expr types) - = do { core_expr <- dsLExpr expr - ; return $ mkCoreConApps (sumDataCon alt arity) - (map (Type . getRuntimeRep "dsExpr ExplicitSum") types ++ - map Type types ++ - [core_expr]) } +ds_expr _ (ExplicitSum types alt arity expr) + = do { dsWhenNoErrs (dsLExprNoLP expr) + (\core_expr -> mkCoreConApps (sumDataCon alt arity) + (map (Type . getRuntimeRep) types ++ + map Type types ++ + [core_expr]) ) } -ds_expr _ (HsSCC _ cc expr@(L loc _)) = do +ds_expr _ (HsSCC _ _ cc expr@(L loc _)) = do dflags <- getDynFlags if gopt Opt_SccProfilingOn dflags then do mod_name <- getModule count <- goptM Opt_ProfCountEntries - uniq <- newUnique - Tick (ProfNote (mkUserCC (sl_fs cc) mod_name loc uniq) count True) + let nm = sl_fs cc + flavour <- ExprCC <$> getCCIndexM nm + Tick (ProfNote (mkUserCC nm mod_name loc flavour) count True) <$> dsLExpr expr else dsLExpr expr -ds_expr _ (HsCoreAnn _ _ expr) +ds_expr _ (HsCoreAnn _ _ _ expr) = dsLExpr expr -ds_expr _ (HsCase discrim matches) +ds_expr _ (HsCase _ discrim matches) = do { core_discrim <- dsLExpr discrim ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just discrim) matches ; return (bindNonRec discrim_var core_discrim matching_code) } -- Pepe: The binds are in scope in the body but NOT in the binding group -- This is to avoid silliness in breakpoints -ds_expr _ (HsLet binds body) = do +ds_expr _ (HsLet _ binds body) = do body' <- dsLExpr body dsLocalBinds binds body' -- 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 ListComp (L _ stmts) res_ty) = dsListComp stmts res_ty -ds_expr _ (HsDo PArrComp (L _ stmts) _) = dsPArrComp (map unLoc stmts) -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 _ (HsIf mb_fun guard_expr then_expr else_expr) +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 _ (HsIf _ mb_fun guard_expr then_expr else_expr) = do { pred <- dsLExpr guard_expr ; b1 <- dsLExpr then_expr ; b2 <- dsLExpr else_expr @@ -445,6 +443,7 @@ ds_expr _ (HsMultiIf res_ty alts) | otherwise = do { match_result <- liftM (foldr1 combineMatchResults) (mapM (dsGRHS IfAlt res_ty) alts) + ; checkGuardMatches IfAlt (GRHSs noExt alts (noLoc emptyLocalBinds)) ; error_expr <- mkErrorExpr ; extractMatchResult match_result error_expr } where @@ -460,38 +459,12 @@ ds_expr _ (HsMultiIf res_ty alts) ds_expr _ (ExplicitList elt_ty wit xs) = dsExplicitList elt_ty wit xs --- We desugar [:x1, ..., xn:] as --- singletonP x1 +:+ ... +:+ singletonP xn --- -ds_expr _ (ExplicitPArr ty []) = do - emptyP <- dsDPHBuiltin emptyPVar - return (Var emptyP `App` Type ty) -ds_expr _ (ExplicitPArr ty xs) = do - singletonP <- dsDPHBuiltin singletonPVar - appP <- dsDPHBuiltin appPVar - xs' <- mapM dsLExprNoLP xs - let unary fn x = mkApps (Var fn) [Type ty, x] - binary fn x y = mkApps (Var fn) [Type ty, x, y] - - return . foldr1 (binary appP) $ map (unary singletonP) xs' - ds_expr _ (ArithSeq expr witness seq) = case witness of Nothing -> dsArithSeq expr seq Just fl -> do { newArithSeq <- dsArithSeq expr seq ; dsSyntaxExpr fl [newArithSeq] } -ds_expr _ (PArrSeq expr (FromTo from to)) - = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, to] - -ds_expr _ (PArrSeq expr (FromThenTo from thn to)) - = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn, to] - -ds_expr _ (PArrSeq _ _) - = panic "DsExpr.dsExpr: Infinite parallel array!" - -- the parser shouldn't have generated it and the renamer and typechecker - -- shouldn't have let it through - {- Static Pointers ~~~~~~~~~~~~~~~ @@ -545,8 +518,9 @@ We also handle @C{}@ as valid construction syntax for an unlabelled constructor @C@, setting all of @C@'s fields to bottom. -} -ds_expr _ (RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds - , rcon_con_like = con_like }) +ds_expr _ (RecordCon { rcon_flds = rbinds + , rcon_ext = RecordConTc { rcon_con_expr = con_expr + , rcon_con_like = con_like }}) = do { con_expr' <- dsExpr con_expr ; let (arg_tys, _) = tcSplitFunTys (exprType con_expr') @@ -605,9 +579,11 @@ So we need to cast (T a Int) to (T a b). Sigh. -} ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields - , rupd_cons = cons_to_upd - , rupd_in_tys = in_inst_tys, rupd_out_tys = out_inst_tys - , rupd_wrap = dict_req_wrap } ) + , rupd_ext = RecordUpdTc + { rupd_cons = cons_to_upd + , rupd_in_tys = in_inst_tys + , rupd_out_tys = out_inst_tys + , rupd_wrap = dict_req_wrap }} ) | null fields = dsLExpr record_expr | otherwise @@ -624,11 +600,12 @@ ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields -- constructor arguments. ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd ; ([discrim_var], matching_code) - <- matchWrapper RecUpd Nothing (MG { mg_alts = noLoc alts - , mg_arg_tys = [in_ty] - , mg_res_ty = out_ty, mg_origin = FromSource }) - -- FromSource is not strictly right, but we - -- want incomplete pattern-match warnings + <- matchWrapper RecUpd Nothing + (MG { mg_alts = noLoc alts + , mg_ext = MatchGroupTc [in_ty] out_ty + , mg_origin = FromSource }) + -- FromSource is not strictly right, but we + -- want incomplete pattern-match warnings ; return (add_field_binds field_binds' $ bindNonRec discrim_var record_expr' matching_code) } @@ -659,28 +636,37 @@ ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields mk_alt upd_fld_env con = do { let (univ_tvs, ex_tvs, eq_spec, prov_theta, _req_theta, arg_tys, _) = conLikeFullSig con - subst = zipTvSubst univ_tvs in_inst_tys + user_tvs = + case con of + RealDataCon data_con -> dataConUserTyVars data_con + PatSynCon _ -> univ_tvs ++ ex_tvs + -- The order here is because of the order in `TcPatSyn`. + in_subst = zipTvSubst univ_tvs in_inst_tys + out_subst = zipTvSubst univ_tvs out_inst_tys -- I'm not bothering to clone the ex_tvs - ; eqs_vars <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec)) - ; theta_vars <- mapM newPredVarDs (substTheta subst prov_theta) - ; arg_ids <- newSysLocalsDs (substTysUnchecked subst arg_tys) + ; eqs_vars <- mapM newPredVarDs (substTheta in_subst (eqSpecPreds eq_spec)) + ; theta_vars <- mapM newPredVarDs (substTheta in_subst prov_theta) + ; arg_ids <- newSysLocalsDs (substTysUnchecked in_subst arg_tys) ; let field_labels = conLikeFieldLabels con val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg field_labels arg_ids mk_val_arg fl pat_arg_id = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id) - inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut con) + inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut noExt con) -- Reconstruct with the WrapId so that unpacking happens - -- The order here is because of the order in `TcPatSyn`. wrap = mkWpEvVarApps theta_vars <.> dict_req_wrap <.> - mkWpTyApps (mkTyVarTys ex_tvs) <.> - mkWpTyApps [ ty - | (tv, ty) <- univ_tvs `zip` out_inst_tys + mkWpTyApps [ lookupTyVar out_subst tv + `orElse` mkTyVarTy tv + | tv <- user_tvs , not (tv `elemVarEnv` wrap_subst) ] - rhs = foldl (\a b -> nlHsApp a b) inst_con val_args + -- Be sure to use user_tvs (which may be ordered + -- differently than `univ_tvs ++ ex_tvs) above. + -- See Note [DataCon user type variable binders] + -- in DataCon. + rhs = foldl' (\a b -> nlHsApp a b) inst_con val_args -- Tediously wrap the application in a cast -- Note [Update for GADTs] @@ -723,16 +709,16 @@ ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields -- Template Haskell stuff -ds_expr _ (HsRnBracketOut _ _) = panic "dsExpr HsRnBracketOut" -ds_expr _ (HsTcBracketOut x ps) = dsBracket x ps -ds_expr _ (HsSpliceE s) = pprPanic "dsExpr:splice" (ppr s) +ds_expr _ (HsRnBracketOut _ _ _) = panic "dsExpr HsRnBracketOut" +ds_expr _ (HsTcBracketOut _ x ps) = dsBracket x ps +ds_expr _ (HsSpliceE _ s) = pprPanic "dsExpr:splice" (ppr s) -- Arrow notation extension -ds_expr _ (HsProc pat cmd) = dsProcExpr pat cmd +ds_expr _ (HsProc _ pat cmd) = dsProcExpr pat cmd -- Hpc Support -ds_expr _ (HsTick tickish e) = do +ds_expr _ (HsTick _ tickish e) = do e' <- dsLExpr e return (Tick tickish e') @@ -743,20 +729,19 @@ ds_expr _ (HsTick tickish e) = do -- (did you go here: YES or NO), but will effect accurate -- tick counting. -ds_expr _ (HsBinTick ixT ixF e) = do +ds_expr _ (HsBinTick _ ixT ixF e) = do e2 <- dsLExpr e do { ASSERT(exprType e2 `eqType` boolTy) mkBinaryTickBox ixT ixF e2 } -ds_expr _ (HsTickPragma _ _ _ expr) = do +ds_expr _ (HsTickPragma _ _ _ _ expr) = do dflags <- getDynFlags if gopt Opt_Hpc dflags then panic "dsExpr:HsTickPragma" else dsLExpr expr -- HsSyn constructs that just shouldn't be here: -ds_expr _ (ExprWithTySig {}) = panic "dsExpr:ExprWithTySig" ds_expr _ (HsBracket {}) = panic "dsExpr:HsBracket" ds_expr _ (HsArrApp {}) = panic "dsExpr:HsArrApp" ds_expr _ (HsArrForm {}) = panic "dsExpr:HsArrForm" @@ -764,9 +749,10 @@ ds_expr _ (EWildPat {}) = panic "dsExpr:EWildPat" ds_expr _ (EAsPat {}) = panic "dsExpr:EAsPat" ds_expr _ (EViewPat {}) = panic "dsExpr:EViewPat" ds_expr _ (ELazyPat {}) = panic "dsExpr:ELazyPat" -ds_expr _ (HsAppType {}) = panic "dsExpr:HsAppType" -- removed by typechecker ds_expr _ (HsDo {}) = panic "dsExpr:HsDo" ds_expr _ (HsRecFld {}) = panic "dsExpr:HsRecFld" +ds_expr _ (XExpr {}) = panic "dsExpr: XExpr" + ------------------------------ dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr @@ -906,50 +892,50 @@ dsDo stmts goL [] = panic "dsDo" goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts) - go _ (LastStmt body _ _) stmts + go _ (LastStmt _ body _ _) stmts = ASSERT( null stmts ) dsLExpr body -- The 'return' op isn't used for 'do' expressions - go _ (BodyStmt rhs then_expr _ _) stmts + go _ (BodyStmt _ rhs then_expr _) stmts = do { rhs2 <- dsLExpr rhs ; warnDiscardedDoBindings rhs (exprType rhs2) ; rest <- goL stmts ; dsSyntaxExpr then_expr [rhs2, rest] } - go _ (LetStmt binds) stmts + go _ (LetStmt _ binds) stmts = do { rest <- goL stmts ; dsLocalBinds binds rest } - go _ (BindStmt pat rhs bind_op fail_op res1_ty) stmts + go _ (BindStmt res1_ty pat rhs bind_op fail_op) stmts = do { body <- goL stmts ; rhs' <- dsLExpr rhs ; var <- selectSimpleMatchVarL pat - ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat + ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat res1_ty (cantFailMatchResult body) ; match_code <- handle_failure pat match fail_op ; dsSyntaxExpr bind_op [rhs', Lam var match_code] } - go _ (ApplicativeStmt args mb_join body_ty) stmts + go _ (ApplicativeStmt body_ty args mb_join) stmts = do { let (pats, rhss) = unzip (map (do_arg . snd) args) - do_arg (ApplicativeArgOne pat expr) = + do_arg (ApplicativeArgOne _ pat expr _) = (pat, dsLExpr expr) - do_arg (ApplicativeArgMany stmts ret pat) = + do_arg (ApplicativeArgMany _ stmts ret pat) = (pat, dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)])) + do_arg (XApplicativeArg _) = panic "dsDo" arg_tys = map hsLPatType pats ; rhss' <- sequence rhss - ; let body' = noLoc $ HsDo DoExpr (noLoc stmts) body_ty + ; let body' = noLoc $ HsDo body_ty DoExpr (noLoc stmts) - ; let fun = L noSrcSpan $ HsLam $ + ; let fun = L noSrcSpan $ HsLam noExt $ MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr pats body'] - , mg_arg_tys = arg_tys - , mg_res_ty = body_ty + , mg_ext = MatchGroupTc arg_tys body_ty , mg_origin = Generated } ; fun' <- dsLExpr fun @@ -962,14 +948,15 @@ dsDo stmts go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids , recS_rec_ids = rec_ids, recS_ret_fn = return_op , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op - , recS_bind_ty = bind_ty - , recS_rec_rets = rec_rets, recS_ret_ty = body_ty }) stmts + , recS_ext = RecStmtTc + { recS_bind_ty = bind_ty + , recS_rec_rets = rec_rets + , 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 (mkBigLHsPatTupId later_pats) + new_bind_stmt = L loc $ BindStmt bind_ty (mkBigLHsPatTupId later_pats) mfix_app bind_op noSyntaxExpr -- Tuple cannot fail - bind_ty tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids tup_ty = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case @@ -977,15 +964,15 @@ dsDo stmts later_pats = rec_tup_pats rets = map noLoc rec_rets mfix_app = nlHsSyntaxApps mfix_op [mfix_arg] - mfix_arg = noLoc $ HsLam + mfix_arg = noLoc $ HsLam noExt (MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr [mfix_pat] body] - , mg_arg_tys = [tup_ty], mg_res_ty = body_ty + , mg_ext = MatchGroupTc [tup_ty] body_ty , mg_origin = Generated }) - mfix_pat = noLoc $ LazyPat $ mkBigLHsPatTupId rec_tup_pats - body = noLoc $ HsDo - DoExpr (noLoc (rec_stmts ++ [ret_stmt])) body_ty + mfix_pat = noLoc $ LazyPat noExt $ mkBigLHsPatTupId rec_tup_pats + body = noLoc $ HsDo body_ty + DoExpr (noLoc (rec_stmts ++ [ret_stmt])) ret_app = nlHsSyntaxApps return_op [mkBigLHsTupId rets] ret_stmt = noLoc $ mkLastStmt ret_app -- This LastStmt will be desugared with dsDo, @@ -994,6 +981,7 @@ dsDo stmts go _ (ParStmt {}) _ = panic "dsDo ParStmt" go _ (TransStmt {}) _ = panic "dsDo TransStmt" + go _ (XStmtLR {}) _ = panic "dsDo XStmtLR" handle_failure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr -- In a do expression, pattern-match failure just calls @@ -1147,9 +1135,9 @@ 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 - HsConLikeOut (RealDataCon dc) -> Just (dataConWrapId dc) - _ -> Nothing + HsVar _ (L _ var) -> Just var + HsConLikeOut _ (RealDataCon dc) -> Just (dataConWrapId dc) + _ -> Nothing , let bad_tys = badUseOfLevPolyPrimop var ty , not (null bad_tys) = levPolyPrimopErr var ty bad_tys @@ -1172,6 +1160,6 @@ badUseOfLevPolyPrimop id ty levPolyPrimopErr :: Id -> Type -> [Type] -> DsM () levPolyPrimopErr primop ty bad_tys = errDs $ vcat [ hang (text "Cannot use primitive with levity-polymorphic arguments:") - 2 (ppr primop <+> dcolon <+> ppr ty) + 2 (ppr primop <+> dcolon <+> pprWithTYPE ty) , hang (text "Levity-polymorphic arguments:") - 2 (vcat (map (\t -> ppr t <+> dcolon <+> ppr (typeKind t)) bad_tys)) ] + 2 (vcat (map (\t -> pprWithTYPE t <+> dcolon <+> pprWithTYPE (typeKind t)) bad_tys)) ] diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs index 9b088b280d..5856ff2445 100644 --- a/compiler/deSugar/DsForeign.hs +++ b/compiler/deSugar/DsForeign.hs @@ -13,6 +13,8 @@ Desugaring foreign declarations (see also DsCCall). module DsForeign ( dsForeigns ) where #include "HsVersions.h" +import GhcPrelude + import TcRnMonad -- temp import CoreSyn @@ -97,17 +99,18 @@ dsForeigns' fos = do where do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl) - do_decl (ForeignImport { fd_name = id, fd_co = co, fd_fi = spec }) = do + do_decl (ForeignImport { fd_name = id, fd_i_ext = co, fd_fi = spec }) = do traceIf (text "fi start" <+> ppr id) let id' = unLoc id (bs, h, c) <- dsFImport id' co spec traceIf (text "fi end" <+> ppr id) return (h, c, [], bs) - do_decl (ForeignExport { fd_name = L _ id, fd_co = co + do_decl (ForeignExport { fd_name = L _ id, fd_e_ext = co , fd_fe = CExport (L _ (CExportStatic _ ext_nm cconv)) _ }) = do (h, c, _, _) <- dsFExport id co ext_nm cconv False return (h, c, [id], []) + do_decl (XForeignDecl _) = panic "dsForeigns'" {- ************************************************************************ @@ -200,7 +203,7 @@ dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header dsFCall fn_id co fcall mDeclHeader = do let ty = pFst $ coercionKind co - (tv_bndrs, rho) = tcSplitForAllTyVarBndrs ty + (tv_bndrs, rho) = tcSplitForAllVarBndrs ty (arg_tys, io_res_ty) = tcSplitFunTys rho args <- newSysLocalsDs arg_tys -- no FFI levity-polymorphism @@ -227,7 +230,8 @@ dsFCall fn_id co fcall mDeclHeader = do CApiConv safety) c = includes $$ fun_proto <+> braces (cRet <> semi) - includes = vcat [ text "#include <" <> ftext h <> text ">" + includes = vcat [ text "#include \"" <> ftext h + <> text "\"" | Header _ h <- nub headers ] fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes cRet @@ -601,7 +605,7 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc -- the expression we give to rts_evalIO expr_to_run - = foldl appArg the_cfun arg_info -- NOT aug_arg_info + = foldl' appArg the_cfun arg_info -- NOT aug_arg_info where appArg acc (arg_cname, _, arg_hty, _) = text "rts_apply" @@ -715,6 +719,12 @@ toCType = f False -- through one layer of type synonym etc. | Just t' <- coreView t = f voidOK t' + -- This may be an 'UnliftedFFITypes'-style ByteArray# argument + -- (which is marshalled like a Ptr) + | Just byteArrayPrimTyCon == tyConAppTyConPicky_maybe t + = (Nothing, text "const void*") + | Just mutableByteArrayPrimTyCon == tyConAppTyConPicky_maybe t + = (Nothing, text "void*") -- Otherwise we don't know the C type. If we are allowing -- void then return that; otherwise something has gone wrong. | voidOK = (Nothing, text "void") diff --git a/compiler/deSugar/DsGRHSs.hs b/compiler/deSugar/DsGRHSs.hs index c3dcdf6879..00658539d3 100644 --- a/compiler/deSugar/DsGRHSs.hs +++ b/compiler/deSugar/DsGRHSs.hs @@ -12,26 +12,27 @@ module DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS, isTrueLHsExpr ) where #include "HsVersions.h" +import GhcPrelude + import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds ) -import {-# SOURCE #-} Match ( matchSinglePat ) +import {-# SOURCE #-} Match ( matchSinglePatVar ) import HsSyn import MkCore import CoreSyn +import CoreUtils (bindNonRec) +import Check (genCaseTmCs2) import DsMonad import DsUtils -import TysWiredIn -import PrelNames import Type ( Type ) -import Module import Name import Util import SrcLoc import Outputable {- -@dsGuarded@ is used for both @case@ expressions and pattern bindings. +@dsGuarded@ is used for pattern bindings. It desugars: \begin{verbatim} | g1 -> e1 @@ -44,7 +45,6 @@ necessary. The type argument gives the type of the @ei@. -} dsGuarded :: GRHSs GhcTc (LHsExpr GhcTc) -> Type -> DsM CoreExpr - dsGuarded grhss rhs_ty = do match_result <- dsGRHSs PatBindRhs grhss rhs_ty error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty empty @@ -56,18 +56,20 @@ dsGRHSs :: HsMatchContext Name -> GRHSs GhcTc (LHsExpr GhcTc) -- Guarded RHSs -> Type -- Type of RHS -> DsM MatchResult -dsGRHSs hs_ctx (GRHSs grhss binds) rhs_ty +dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty = ASSERT( notNull grhss ) do { match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss ; let match_result1 = foldr1 combineMatchResults match_results match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1 -- NB: nested dsLet inside matchResult ; return match_result2 } +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 (L _ (GRHS _ guards rhs)) = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty +dsGRHS _ _ (L _ (XGRHS _)) = panic "dsGRHS" {- ************************************************************************ @@ -97,16 +99,16 @@ matchGuards [] _ rhs _ -- NB: The success of this clause depends on the typechecker not -- wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors -- If it does, you'll get bogus overlap warnings -matchGuards (BodyStmt e _ _ _ : stmts) ctx rhs rhs_ty +matchGuards (BodyStmt _ e _ _ : stmts) ctx rhs rhs_ty | Just addTicks <- isTrueLHsExpr e = do match_result <- matchGuards stmts ctx rhs rhs_ty return (adjustMatchResultDs addTicks match_result) -matchGuards (BodyStmt expr _ _ _ : stmts) ctx rhs rhs_ty = do +matchGuards (BodyStmt _ expr _ _ : stmts) ctx rhs rhs_ty = do match_result <- matchGuards stmts ctx rhs rhs_ty pred_expr <- dsLExpr expr return (mkGuardedMatchResult pred_expr match_result) -matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty = do +matchGuards (LetStmt _ binds : stmts) ctx rhs rhs_ty = do match_result <- matchGuards stmts ctx rhs rhs_ty return (adjustMatchResultDs (dsLocalBinds binds) match_result) -- NB the dsLet occurs inside the match_result @@ -114,10 +116,19 @@ matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty = do -- so we can't desugar the bindings without the -- body expression in hand -matchGuards (BindStmt pat bind_rhs _ _ _ : stmts) ctx rhs rhs_ty = do - match_result <- matchGuards stmts ctx rhs rhs_ty +matchGuards (BindStmt _ pat bind_rhs _ _ : stmts) ctx rhs rhs_ty = do + let upat = unLoc pat + dicts = collectEvVarsPat upat + match_var <- selectMatchVar upat + tm_cs <- genCaseTmCs2 (Just bind_rhs) [upat] [match_var] + match_result <- addDictsDs dicts $ + addTmCsDs tm_cs $ + -- See Note [Type and Term Equality Propagation] in Check + matchGuards stmts ctx rhs rhs_ty core_rhs <- dsLExpr bind_rhs - matchSinglePat core_rhs (StmtCtxt ctx) pat rhs_ty match_result + match_result' <- matchSinglePatVar match_var (StmtCtxt ctx) pat rhs_ty + match_result + pure $ adjustMatchResult (bindNonRec match_var core_rhs) match_result' matchGuards (LastStmt {} : _) _ _ _ = panic "matchGuards LastStmt" matchGuards (ParStmt {} : _) _ _ _ = panic "matchGuards ParStmt" @@ -125,34 +136,8 @@ matchGuards (TransStmt {} : _) _ _ _ = panic "matchGuards TransStmt" matchGuards (RecStmt {} : _) _ _ _ = panic "matchGuards RecStmt" matchGuards (ApplicativeStmt {} : _) _ _ _ = panic "matchGuards ApplicativeLastStmt" - -isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr) - --- Returns Just {..} if we're sure that the expression is True --- I.e. * 'True' datacon --- * 'otherwise' Id --- * 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 - = Just return - -- trueDataConId doesn't have the same unique as trueDataCon -isTrueLHsExpr (L _ (HsConLikeOut con)) | con `hasKey` getUnique trueDataCon = Just return -isTrueLHsExpr (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)) - | 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 _ = Nothing +matchGuards (XStmtLR {} : _) _ _ _ = + panic "matchGuards XStmtLR" {- Should {\em fail} if @e@ returns @D@ diff --git a/compiler/deSugar/DsListComp.hs b/compiler/deSugar/DsListComp.hs index dc24183537..f325b5672d 100644 --- a/compiler/deSugar/DsListComp.hs +++ b/compiler/deSugar/DsListComp.hs @@ -9,10 +9,12 @@ Desugaring list comprehensions, monad comprehensions and array comprehensions {-# LANGUAGE CPP, NamedFieldPuns #-} {-# LANGUAGE TypeFamilies #-} -module DsListComp ( dsListComp, dsPArrComp, dsMonadComp ) where +module DsListComp ( dsListComp, dsMonadComp ) where #include "HsVersions.h" +import GhcPrelude + import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr ) import HsSyn @@ -80,7 +82,7 @@ dsListComp lquals res_ty = do -- of that comprehension that we need in the outer comprehension into such an expression -- and the type of the elements that it outputs (tuples of binders) dsInnerListComp :: (ParStmtBlock GhcTc GhcTc) -> DsM (CoreExpr, Type) -dsInnerListComp (ParStmtBlock stmts bndrs _) +dsInnerListComp (ParStmtBlock _ stmts bndrs _) = do { let bndrs_tuple_type = mkBigCoreVarTupTy bndrs list_ty = mkListTy bndrs_tuple_type @@ -88,6 +90,7 @@ dsInnerListComp (ParStmtBlock stmts bndrs _) ; expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)]) list_ty ; return (expr, bndrs_tuple_type) } +dsInnerListComp (XParStmtBlock{}) = panic "dsInnerListComp" -- This function factors out commonality between the desugaring strategies for GroupStmt. -- Given such a statement it gives you back an expression representing how to compute the transformed @@ -103,7 +106,8 @@ dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderM to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders - (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock stmts from_bndrs noSyntaxExpr) + (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock noExt stmts + from_bndrs noSyntaxExpr) -- Work out what arguments should be supplied to that expression: i.e. is an extraction -- function required? If so, create that desugared function and add to arguments @@ -204,7 +208,7 @@ where (x1, .., xn) are the variables bound in p1, v1, p2 In the translation below, the ParStmt branch translates each parallel branch into a sub-comprehension, and desugars each independently. The resulting lists are fed to a zip function, we create a binding for all the variables bound in all -the comprehensions, and then we hand things off the the desugarer for bindings. +the comprehensions, and then we hand things off the desugarer for bindings. The zip function is generated here a) because it's small, and b) because then we don't have to deal with arbitrary limits on the number of zip functions in the prelude, nor which library the zip function came from. @@ -216,20 +220,20 @@ deListComp :: [ExprStmt GhcTc] -> CoreExpr -> DsM CoreExpr deListComp [] _ = panic "deListComp" -deListComp (LastStmt body _ _ : quals) list +deListComp (LastStmt _ body _ _ : quals) list = -- Figure 7.4, SLPJ, p 135, rule C above ASSERT( null quals ) do { core_body <- dsLExpr body ; return (mkConsExpr (exprType core_body) core_body list) } -- Non-last: must be a guard -deListComp (BodyStmt guard _ _ _ : quals) list = do -- rule B above +deListComp (BodyStmt _ guard _ _ : quals) list = do -- rule B above core_guard <- dsLExpr guard core_rest <- deListComp quals list return (mkIfThenElse core_guard core_rest list) -- [e | let B, qs] = let B in [e | qs] -deListComp (LetStmt binds : quals) list = do +deListComp (LetStmt _ binds : quals) list = do core_rest <- deListComp quals list dsLocalBinds binds core_rest @@ -237,11 +241,11 @@ deListComp (stmt@(TransStmt {}) : quals) list = do (inner_list_expr, pat) <- dsTransStmt stmt deBindComp pat inner_list_expr quals list -deListComp (BindStmt pat list1 _ _ _ : quals) core_list2 = do -- rule A' above +deListComp (BindStmt _ pat list1 _ _ : quals) core_list2 = do -- rule A' above core_list1 <- dsLExprNoLP list1 deBindComp pat core_list1 quals core_list2 -deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) list +deListComp (ParStmt _ stmtss_w_bndrs _ _ : quals) list = do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs ; let (exps, qual_tys) = unzip exps_and_qual_tys @@ -251,7 +255,7 @@ deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) list ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps)) quals list } where - bndrs_s = [bs | ParStmtBlock _ bs _ <- stmtss_w_bndrs] + bndrs_s = [bs | ParStmtBlock _ _ bs _ <- stmtss_w_bndrs] -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above pat = mkBigLHsPatTupId pats @@ -262,6 +266,9 @@ deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt" deListComp (ApplicativeStmt {} : _) _ = panic "deListComp ApplicativeStmt" +deListComp (XStmtLR {} : _) _ = + panic "deListComp XStmtLR" + deBindComp :: OutPat GhcTc -> CoreExpr -> [ExprStmt GhcTc] @@ -324,18 +331,18 @@ dfListComp :: Id -> Id -- 'c' and 'n' dfListComp _ _ [] = panic "dfListComp" -dfListComp c_id n_id (LastStmt body _ _ : quals) +dfListComp c_id n_id (LastStmt _ body _ _ : quals) = ASSERT( null quals ) do { core_body <- dsLExprNoLP body ; return (mkApps (Var c_id) [core_body, Var n_id]) } -- Non-last: must be a guard -dfListComp c_id n_id (BodyStmt guard _ _ _ : quals) = do +dfListComp c_id n_id (BodyStmt _ guard _ _ : quals) = do core_guard <- dsLExpr guard core_rest <- dfListComp c_id n_id quals return (mkIfThenElse core_guard core_rest (Var n_id)) -dfListComp c_id n_id (LetStmt binds : quals) = do +dfListComp c_id n_id (LetStmt _ binds : quals) = do -- new in 1.3, local bindings core_rest <- dfListComp c_id n_id quals dsLocalBinds binds core_rest @@ -345,7 +352,7 @@ dfListComp c_id n_id (stmt@(TransStmt {}) : quals) = do -- Anyway, we bind the newly grouped list via the generic binding function dfBindComp c_id n_id (pat, inner_list_expr) quals -dfListComp c_id n_id (BindStmt pat list1 _ _ _ : quals) = do +dfListComp c_id n_id (BindStmt _ pat list1 _ _ : quals) = do -- evaluate the two lists core_list1 <- dsLExpr list1 @@ -356,6 +363,8 @@ dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt" dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt" dfListComp _ _ (ApplicativeStmt {} : _) = panic "dfListComp ApplicativeStmt" +dfListComp _ _ (XStmtLR {} : _) = + panic "dfListComp XStmtLR" dfBindComp :: Id -> Id -- 'c' and 'n' -> (LPat GhcTc, CoreExpr) @@ -467,209 +476,6 @@ mkUnzipBind _ elt_tys mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail -{- -************************************************************************ -* * -\subsection[DsPArrComp]{Desugaring of array comprehensions} -* * -************************************************************************ --} - --- entry point for desugaring a parallel array comprehension --- --- [:e | qss:] = <<[:e | qss:]>> () [:():] --- -dsPArrComp :: [ExprStmt GhcTc] - -> DsM CoreExpr - --- Special case for parallel comprehension -dsPArrComp (ParStmt qss _ _ _ : quals) = dePArrParComp qss quals - --- Special case for simple generators: --- --- <<[:e' | p <- e, qs:]>> = <<[: e' | qs :]>> p e --- --- if matching again p cannot fail, or else --- --- <<[:e' | p <- e, qs:]>> = --- <<[:e' | qs:]>> p (filterP (\x -> case x of {p -> True; _ -> False}) e) --- -dsPArrComp (BindStmt p e _ _ _ : qs) = do - filterP <- dsDPHBuiltin filterPVar - ce <- dsLExprNoLP e - let ety'ce = parrElemType ce - false = Var falseDataConId - true = Var trueDataConId - v <- newSysLocalDs ety'ce - pred <- matchSimply (Var v) (StmtCtxt PArrComp) p true false - let gen | isIrrefutableHsPat p = ce - | otherwise = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce] - dePArrComp qs p gen - -dsPArrComp qs = do -- no ParStmt in `qs' - sglP <- dsDPHBuiltin singletonPVar - let unitArray = mkApps (Var sglP) [Type unitTy, mkCoreTup []] - dePArrComp qs (noLoc $ WildPat unitTy) unitArray - - - --- the work horse --- -dePArrComp :: [ExprStmt GhcTc] - -> LPat GhcTc -- the current generator pattern - -> CoreExpr -- the current generator expression - -> DsM CoreExpr - -dePArrComp [] _ _ = panic "dePArrComp" - --- --- <<[:e' | :]>> pa ea = mapP (\pa -> e') ea --- -dePArrComp (LastStmt e' _ _ : quals) pa cea - = ASSERT( null quals ) - do { mapP <- dsDPHBuiltin mapPVar - ; let ty = parrElemType cea - ; (clam, ty'e') <- deLambda ty pa e' - ; return $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea] } --- --- <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea) --- -dePArrComp (BodyStmt b _ _ _ : qs) pa cea = do - filterP <- dsDPHBuiltin filterPVar - let ty = parrElemType cea - (clam,_) <- deLambda ty pa b - dePArrComp qs pa (mkApps (Var filterP) [Type ty, clam, cea]) - --- --- <<[:e' | p <- e, qs:]>> pa ea = --- let ef = \pa -> e --- in --- <<[:e' | qs:]>> (pa, p) (crossMap ea ef) --- --- if matching again p cannot fail, or else --- --- <<[:e' | p <- e, qs:]>> pa ea = --- let ef = \pa -> filterP (\x -> case x of {p -> True; _ -> False}) e --- in --- <<[:e' | qs:]>> (pa, p) (crossMapP ea ef) --- -dePArrComp (BindStmt p e _ _ _ : qs) pa cea = do - filterP <- dsDPHBuiltin filterPVar - crossMapP <- dsDPHBuiltin crossMapPVar - ce <- dsLExpr e - let ety'cea = parrElemType cea - ety'ce = parrElemType ce - false = Var falseDataConId - true = Var trueDataConId - v <- newSysLocalDs ety'ce - pred <- matchSimply (Var v) (StmtCtxt PArrComp) p true false - let cef | isIrrefutableHsPat p = ce - | otherwise = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce] - (clam, _) <- mkLambda ety'cea pa cef - let ety'cef = ety'ce -- filter doesn't change the element type - pa' = mkLHsPatTup [pa, p] - - dePArrComp qs pa' (mkApps (Var crossMapP) - [Type ety'cea, Type ety'cef, cea, clam]) --- --- <<[:e' | let ds, qs:]>> pa ea = --- <<[:e' | qs:]>> (pa, (x_1, ..., x_n)) --- (mapP (\v@pa -> let ds in (v, (x_1, ..., x_n))) ea) --- where --- {x_1, ..., x_n} = DV (ds) -- Defined Variables --- -dePArrComp (LetStmt lds@(L _ ds) : qs) pa cea = do - mapP <- dsDPHBuiltin mapPVar - let xs = collectLocalBinders ds - ty'cea = parrElemType cea - v <- newSysLocalDs ty'cea - clet <- dsLocalBinds lds (mkCoreTup (map Var xs)) - let'v <- newSysLocalDs (exprType clet) - let projBody = mkCoreLet (NonRec let'v clet) $ - mkCoreTup [Var v, Var let'v] - errTy = exprType projBody - errMsg = text "DsListComp.dePArrComp: internal error!" - cerr <- mkErrorAppDs pAT_ERROR_ID errTy errMsg - ccase <- matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr - let pa' = mkLHsPatTup [pa, mkLHsPatTup (map nlVarPat xs)] - proj = mkLams [v] ccase - dePArrComp qs pa' (mkApps (Var mapP) - [Type ty'cea, Type errTy, proj, cea]) --- --- The parser guarantees that parallel comprehensions can only appear as --- singleton qualifier lists, which we already special case in the caller. --- So, encountering one here is a bug. --- -dePArrComp (ParStmt {} : _) _ _ = - panic "DsListComp.dePArrComp: malformed comprehension AST: ParStmt" -dePArrComp (TransStmt {} : _) _ _ = panic "DsListComp.dePArrComp: TransStmt" -dePArrComp (RecStmt {} : _) _ _ = panic "DsListComp.dePArrComp: RecStmt" -dePArrComp (ApplicativeStmt {} : _) _ _ = - panic "DsListComp.dePArrComp: ApplicativeStmt" - --- <<[:e' | qs | qss:]>> pa ea = --- <<[:e' | qss:]>> (pa, (x_1, ..., x_n)) --- (zipP ea <<[:(x_1, ..., x_n) | qs:]>>) --- where --- {x_1, ..., x_n} = DV (qs) --- -dePArrParComp :: [ParStmtBlock GhcTc GhcTc] -> [ExprStmt GhcTc] -> DsM CoreExpr -dePArrParComp qss quals = do - (pQss, ceQss) <- deParStmt qss - dePArrComp quals pQss ceQss - where - deParStmt [] = - -- empty parallel statement lists have no source representation - panic "DsListComp.dePArrComp: Empty parallel list comprehension" - deParStmt (ParStmtBlock qs xs _:qss) = do -- first statement - let res_expr = mkLHsVarTuple xs - cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr]) - parStmts qss (mkLHsVarPatTup xs) cqs - --- - parStmts [] pa cea = return (pa, cea) - parStmts (ParStmtBlock qs xs _:qss) pa cea = do -- subsequent statements (zip'ed) - zipP <- dsDPHBuiltin zipPVar - let pa' = mkLHsPatTup [pa, mkLHsVarPatTup xs] - ty'cea = parrElemType cea - res_expr = mkLHsVarTuple xs - cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr]) - let ty'cqs = parrElemType cqs - cea' = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs] - parStmts qss pa' cea' - --- generate Core corresponding to `\p -> e' --- -deLambda :: Type -- type of the argument (not levity-polymorphic) - -> LPat GhcTc -- argument pattern - -> LHsExpr GhcTc -- body - -> DsM (CoreExpr, Type) -deLambda ty p e = - mkLambda ty p =<< dsLExpr e - --- generate Core for a lambda pattern match, where the body is already in Core --- -mkLambda :: Type -- type of the argument (not levity-polymorphic) - -> LPat GhcTc -- argument pattern - -> CoreExpr -- desugared body - -> DsM (CoreExpr, Type) -mkLambda ty p ce = do - v <- newSysLocalDs ty - let errMsg = text "DsListComp.deLambda: internal error!" - ce'ty = exprType ce - cerr <- mkErrorAppDs pAT_ERROR_ID ce'ty errMsg - res <- matchSimply (Var v) (StmtCtxt PArrComp) p ce cerr - return (mkLams [v] res, ce'ty) - --- obtain the element type of the parallel array produced by the given Core --- expression --- -parrElemType :: CoreExpr -> Type -parrElemType e = - case splitTyConApp_maybe (exprType e) of - Just (tycon, [ty]) | tycon == parrTyCon -> ty - _ -> panic - "DsListComp.parrElemType: not a parallel array type" - -- Translation for monad comprehensions -- Entry point for monad comprehension desugaring @@ -683,18 +489,18 @@ dsMcStmts (L loc stmt : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts) --------------- dsMcStmt :: ExprStmt GhcTc -> [ExprLStmt GhcTc] -> DsM CoreExpr -dsMcStmt (LastStmt body _ ret_op) stmts +dsMcStmt (LastStmt _ body _ ret_op) stmts = ASSERT( null stmts ) do { body' <- dsLExpr body ; dsSyntaxExpr ret_op [body'] } -- [ .. | let binds, stmts ] -dsMcStmt (LetStmt binds) stmts +dsMcStmt (LetStmt _ binds) stmts = do { rest <- dsMcStmts stmts ; dsLocalBinds binds rest } -- [ .. | a <- m, stmts ] -dsMcStmt (BindStmt pat rhs bind_op fail_op bind_ty) stmts +dsMcStmt (BindStmt bind_ty pat rhs bind_op fail_op) stmts = do { rhs' <- dsLExpr rhs ; dsMcBindStmt pat rhs' bind_op fail_op bind_ty stmts } @@ -702,7 +508,7 @@ dsMcStmt (BindStmt pat rhs bind_op fail_op bind_ty) stmts -- -- [ .. | exp, stmts ] -- -dsMcStmt (BodyStmt exp then_exp guard_exp _) stmts +dsMcStmt (BodyStmt _ exp then_exp guard_exp) stmts = do { exp' <- dsLExpr exp ; rest <- dsMcStmts stmts ; guard_exp' <- dsSyntaxExpr guard_exp [exp'] @@ -725,7 +531,7 @@ dsMcStmt (BodyStmt exp then_exp guard_exp _) stmts dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs , trS_by = by, trS_using = using , trS_ret = return_op, trS_bind = bind_op - , trS_bind_arg_ty = n_tup_ty' -- n (a,b,c) + , trS_ext = n_tup_ty' -- n (a,b,c) , trS_fmap = fmap_op, trS_form = form }) stmts_rest = do { let (from_bndrs, to_bndrs) = unzip bndrs @@ -770,12 +576,12 @@ dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs -- mzip :: forall a b. m a -> m b -> m (a,b) -- NB: we need a polymorphic mzip because we call it several times -dsMcStmt (ParStmt blocks mzip_op bind_op bind_ty) stmts_rest +dsMcStmt (ParStmt bind_ty blocks mzip_op bind_op) stmts_rest = do { exps_w_tys <- mapM ds_inner blocks -- Pairs (exp :: m ty, ty) ; mzip_op' <- dsExpr mzip_op ; let -- The pattern variables - pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ bs _ <- blocks] + pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ _ bs _ <- blocks] -- Pattern with tuples of variables -- [v1,v2,v3] => (v1, (v2, v3)) pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats @@ -786,9 +592,10 @@ dsMcStmt (ParStmt blocks mzip_op bind_op bind_ty) stmts_rest ; dsMcBindStmt pat rhs bind_op noSyntaxExpr bind_ty stmts_rest } where - ds_inner (ParStmtBlock stmts bndrs return_op) + ds_inner (ParStmtBlock _ stmts bndrs return_op) = do { exp <- dsInnerMonadComp stmts bndrs return_op ; return (exp, mkBigCoreVarTupTy bndrs) } + ds_inner (XParStmtBlock{}) = panic "dsMcStmt" dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt) @@ -814,7 +621,7 @@ dsMcBindStmt :: LPat GhcTc dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts = do { body <- dsMcStmts stmts ; var <- selectSimpleMatchVarL pat - ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat + ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat res1_ty (cantFailMatchResult body) ; match_code <- handle_failure pat match fail_op ; dsSyntaxExpr bind_op [rhs', Lam var match_code] } @@ -846,7 +653,8 @@ dsInnerMonadComp :: [ExprLStmt GhcTc] -> SyntaxExpr GhcTc -- The monomorphic "return" operator -> DsM CoreExpr dsInnerMonadComp stmts bndrs ret_op - = dsMcStmts (stmts ++ [noLoc (LastStmt (mkBigLHsVarTupId bndrs) False ret_op)]) + = dsMcStmts (stmts ++ + [noLoc (LastStmt noExt (mkBigLHsVarTupId bndrs) False ret_op)]) -- The `unzip` function for `GroupStmt` in a monad comprehensions diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index c6799813df..d25a7cfd06 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -20,6 +20,8 @@ module DsMeta( dsBracket ) where #include "HsVersions.h" +import GhcPrelude + import {-# SOURCE #-} DsExpr ( dsExpr ) import MatchLit @@ -28,7 +30,6 @@ import DsMonad import qualified Language.Haskell.TH as TH import HsSyn -import Class import PrelNames -- To avoid clashes with DsMeta.varName we must make a local alias for -- OccName.varName we do this by removing varName from the import of @@ -75,13 +76,14 @@ dsBracket brack splices where 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 } - do_brack (PatBr p) = do { MkC p1 <- repTopP p ; return p1 } - do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 } - do_brack (DecBrG gp) = do { MkC ds1 <- repTopDs gp ; return ds1 } - do_brack (DecBrL _) = panic "dsBracket: unexpected DecBrL" - do_brack (TExpBr e) = do { MkC e1 <- repLE e ; return e1 } + do_brack (VarBr _ _ n) = do { MkC e1 <- lookupOcc n ; return e1 } + do_brack (ExpBr _ e) = do { MkC e1 <- repLE e ; return e1 } + do_brack (PatBr _ p) = do { MkC p1 <- repTopP p ; return p1 } + do_brack (TypBr _ t) = do { MkC t1 <- repLTy t ; return t1 } + do_brack (DecBrG _ gp) = do { MkC ds1 <- repTopDs gp ; return ds1 } + do_brack (DecBrL {}) = panic "dsBracket: unexpected DecBrL" + do_brack (TExpBr _ e) = do { MkC e1 <- repLE e ; return e1 } + do_brack (XBracket {}) = panic "dsBracket: unexpected XBracket" {- -------------- Examples -------------------- @@ -118,9 +120,8 @@ repTopDs group@(HsGroup { hs_valds = valds , hs_warnds = warnds , hs_annds = annds , hs_ruleds = ruleds - , hs_vects = vects , hs_docs = docs }) - = do { let { bndrs = hsSigTvBinders valds + = do { let { bndrs = hsScopedTvBinders valds ++ hsGroupBinders group ++ hsPatSynSelectors valds ; instds = tyclds >>= group_instds } ; @@ -148,7 +149,6 @@ repTopDs group@(HsGroup { hs_valds = valds ; ann_ds <- mapM repAnnD annds ; rule_ds <- mapM repRuleD (concatMap (rds_rules . unLoc) ruleds) - ; _ <- mapM no_vect vects ; _ <- mapM no_doc docs -- more needed @@ -171,33 +171,44 @@ repTopDs group@(HsGroup { hs_valds = valds = notHandledL loc "Splices within declaration brackets" empty no_default_decl (L loc decl) = notHandledL loc "Default declarations" (ppr decl) - no_warn (L loc (Warning thing _)) + no_warn (L loc (Warning _ thing _)) = notHandledL loc "WARNING and DEPRECATION pragmas" $ text "Pragma for declaration of" <+> ppr thing - no_vect (L loc decl) - = notHandledL loc "Vectorisation pragmas" (ppr decl) + no_warn (L _ (XWarnDecl _)) = panic "repTopDs" no_doc (L loc _) = notHandledL loc "Haddock documentation" empty +repTopDs (XHsGroup _) = panic "repTopDs" -hsSigTvBinders :: HsValBinds GhcRn -> [Name] +hsScopedTvBinders :: HsValBinds GhcRn -> [Name] -- See Note [Scoped type variables in bindings] -hsSigTvBinders binds +hsScopedTvBinders binds = concatMap get_scoped_tvs sigs where - get_scoped_tvs :: LSig GhcRn -> [Name] - -- Both implicit and explicit quantified variables - -- We need the implicit ones for f :: forall (a::k). blah - -- here 'k' scopes too - get_scoped_tvs (L _ (TypeSig _ sig)) - | HsIB { hsib_vars = implicit_vars - , hsib_body = hs_ty } <- hswc_body sig - , (explicit_vars, _) <- splitLHsForAllTy hs_ty - = implicit_vars ++ map hsLTyVarName explicit_vars - get_scoped_tvs _ = [] - sigs = case binds of - ValBindsIn _ sigs -> sigs - ValBindsOut _ sigs -> sigs + ValBinds _ _ sigs -> sigs + XValBindsLR (NValBinds _ sigs) -> sigs + +get_scoped_tvs :: LSig GhcRn -> [Name] +get_scoped_tvs (L _ signature) + | TypeSig _ _ sig <- signature + = get_scoped_tvs_from_sig (hswc_body sig) + | ClassOpSig _ _ _ sig <- signature + = get_scoped_tvs_from_sig sig + | PatSynSig _ _ sig <- signature + = get_scoped_tvs_from_sig sig + | otherwise + = [] + where + get_scoped_tvs_from_sig sig + -- Both implicit and explicit quantified variables + -- We need the implicit ones for f :: forall (a::k). blah + -- here 'k' scopes too + | HsIB { hsib_ext = implicit_vars + , hsib_body = hs_ty } <- sig + , (explicit_vars, _) <- splitLHsForAllTy hs_ty + = implicit_vars ++ map hsLTyVarName explicit_vars + get_scoped_tvs_from_sig (XHsImplicitBndrs _) + = panic "get_scoped_tvs_from_sig" {- Notes @@ -210,12 +221,37 @@ Here the 'forall a' brings 'a' into scope over the binding group. To achieve this we a) Gensym a binding for 'a' at the same time as we do one for 'f' - collecting the relevant binders with hsSigTvBinders + collecting the relevant binders with hsScopedTvBinders b) When processing the 'forall', don't gensym The relevant places are signposted with references to this Note +Note [Scoped type variables in class and instance declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Scoped type variables may occur in default methods and default +signatures. We need to bring the type variables in 'foralls' +into the scope of the method bindings. + +Consider + class Foo a where + foo :: forall (b :: k). a -> Proxy b -> Proxy b + foo _ x = (x :: Proxy b) + +We want to ensure that the 'b' in the type signature and the default +implementation are the same, so we do the following: + + a) Before desugaring the signature and binding of 'foo', use + get_scoped_tvs to collect type variables in 'forall' and + create symbols for them. + b) Use 'addBinds' to bring these symbols into the scope of the type + signatures and bindings. + c) Use these symbols to generate Core for the class/instance declaration. + +Note that when desugaring the signatures, we lookup the type variables +from the scope rather than recreate symbols for them. See more details +in "rep_ty_sig" and in Trac#14885. + Note [Binders and occurrences] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we desugar [d| data T = MkT |] @@ -251,10 +287,8 @@ and have Template Haskell turn it into this: idProxy :: forall k proxy (b :: k). proxy b -> proxy b idProxy x = x -Notice that we explicitly quantified the variable `k`! This is quite bad, as the -latter declaration requires -XTypeInType, while the former does not. Not to -mention that the latter declaration isn't even what the user wrote in the -first place. +Notice that we explicitly quantified the variable `k`! The latter declaration +isn't what the user wrote in the first place. Usually, the culprit behind these bugs is taking implicitly quantified type variables (often from the hsib_vars field of HsImplicitBinders) and putting @@ -286,28 +320,31 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, = do { cls1 <- lookupLOcc cls -- See note [Binders and occurrences] ; dec <- addTyVarBinds tvs $ \bndrs -> do { cxt1 <- repLContext cxt - ; sigs1 <- rep_sigs sigs - ; binds1 <- rep_binds meth_binds + -- 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 ; atds1 <- repAssocTyFamDefaults atds - ; decls1 <- coreList decQTyConName (ats1 ++ atds1 ++ sigs1 ++ binds1) - ; repClass cxt1 cls1 bndrs fds1 decls1 - } + ; decls1 <- coreList decQTyConName (ats1 ++ atds1 ++ sigs_binds) + ; decls2 <- repClass cxt1 cls1 bndrs fds1 decls1 + ; wrapGenSyms ss decls2 } ; return $ Just (loc, dec) } +repTyClD (L _ (XTyClDecl _)) = panic "repTyClD" + ------------------------- repRoleD :: LRoleAnnotDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) -repRoleD (L loc (RoleAnnotDecl tycon roles)) +repRoleD (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" ------------------------- -repDataDefn :: Core TH.Name -> Core [TH.TyVarBndr] +repDataDefn :: Core TH.Name -> Core [TH.TyVarBndrQ] -> Maybe (Core [TH.TypeQ]) -> HsDataDefn GhcRn -> DsM (Core TH.DecQ) @@ -318,20 +355,21 @@ repDataDefn tc bndrs opt_tys ; derivs1 <- repDerivs mb_derivs ; case (new_or_data, cons) of (NewType, [con]) -> do { con' <- repC con - ; ksig' <- repMaybeLKind ksig + ; ksig' <- repMaybeLTy ksig ; repNewtype cxt1 tc bndrs opt_tys ksig' con' derivs1 } (NewType, _) -> failWithDs (text "Multiple constructors for newtype:" <+> pprQuotedList (getConNames $ unLoc $ head cons)) - (DataType, _) -> do { ksig' <- repMaybeLKind ksig + (DataType, _) -> do { ksig' <- repMaybeLTy ksig ; consL <- mapM repC cons ; cons1 <- coreList conQTyConName consL ; repData cxt1 tc bndrs opt_tys ksig' cons1 derivs1 } } +repDataDefn _ _ _ (XHsDataDefn _) = panic "repDataDefn" -repSynDecl :: Core TH.Name -> Core [TH.TyVarBndr] +repSynDecl :: Core TH.Name -> Core [TH.TyVarBndrQ] -> LHsType GhcRn -> DsM (Core TH.DecQ) repSynDecl tc bndrs ty @@ -346,18 +384,20 @@ repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info, fdInjectivityAnn = injectivity })) = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] ; let mkHsQTvs :: [LHsTyVarBndr GhcRn] -> LHsQTyVars GhcRn - mkHsQTvs tvs = HsQTvs { hsq_implicit = [], hsq_explicit = tvs - , hsq_dependent = emptyNameSet } + mkHsQTvs tvs = HsQTvs { hsq_ext = HsQTvsRn + { hsq_implicit = [] + , hsq_dependent = emptyNameSet } + , hsq_explicit = tvs } resTyVar = case resultSig of - TyVarSig bndr -> mkHsQTvs [bndr] - _ -> mkHsQTvs [] + TyVarSig _ bndr -> mkHsQTvs [bndr] + _ -> mkHsQTvs [] ; dec <- addTyClTyVarBinds tvs $ \bndrs -> addTyClTyVarBinds resTyVar $ \_ -> case info of ClosedTypeFamily Nothing -> notHandled "abstract closed type family" (ppr decl) ClosedTypeFamily (Just eqns) -> - do { eqns1 <- mapM repTyFamEqn eqns + do { eqns1 <- mapM (repTyFamEqn . unLoc) eqns ; eqns2 <- coreList tySynEqnQTyConName eqns1 ; result <- repFamilyResultSig resultSig ; inj <- repInjectivityAnn injectivity @@ -371,25 +411,27 @@ repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info, ; repDataFamilyD tc1 bndrs kind } ; return (loc, dec) } +repFamilyDecl (L _ (XFamilyDecl _)) = panic "repFamilyDecl" -- | Represent result signature of a type family -repFamilyResultSig :: FamilyResultSig GhcRn -> DsM (Core TH.FamilyResultSig) -repFamilyResultSig NoSig = repNoSig -repFamilyResultSig (KindSig ki) = do { ki' <- repLKind ki - ; repKindSig ki' } -repFamilyResultSig (TyVarSig bndr) = do { bndr' <- repTyVarBndr bndr - ; repTyVarSig bndr' } +repFamilyResultSig :: FamilyResultSig GhcRn -> DsM (Core TH.FamilyResultSigQ) +repFamilyResultSig (NoSig _) = repNoSig +repFamilyResultSig (KindSig _ ki) = do { ki' <- repLTy ki + ; repKindSig ki' } +repFamilyResultSig (TyVarSig _ bndr) = do { bndr' <- repTyVarBndr bndr + ; repTyVarSig bndr' } +repFamilyResultSig (XFamilyResultSig _) = panic "repFamilyResultSig" -- | Represent result signature using a Maybe Kind. Used with data families, -- where the result signature can be either missing or a kind but never a named -- result variable. repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn - -> DsM (Core (Maybe TH.Kind)) -repFamilyResultSigToMaybeKind NoSig = - do { coreNothing kindTyConName } -repFamilyResultSigToMaybeKind (KindSig ki) = - do { ki' <- repLKind ki - ; coreJust kindTyConName ki' } + -> DsM (Core (Maybe TH.KindQ)) +repFamilyResultSigToMaybeKind (NoSig _) = + do { coreNothing kindQTyConName } +repFamilyResultSigToMaybeKind (KindSig _ ki) = + do { ki' <- repLTy ki + ; coreJust kindQTyConName ki' } repFamilyResultSigToMaybeKind _ = panic "repFamilyResultSigToMaybeKind" -- | Represent injectivity annotation of a type family @@ -412,9 +454,9 @@ repAssocTyFamDefaults = mapM rep_deflt where -- very like repTyFamEqn, but different in the details rep_deflt :: LTyFamDefltEqn GhcRn -> DsM (Core TH.DecQ) - rep_deflt (L _ (TyFamEqn { tfe_tycon = tc - , tfe_pats = bndrs - , tfe_rhs = rhs })) + rep_deflt (L _ (FamEqn { feqn_tycon = tc + , feqn_pats = bndrs + , feqn_rhs = rhs })) = addTyClTyVarBinds bndrs $ \ _ -> do { tc1 <- lookupLOcc tc ; tys1 <- repLTys (hsLTyVarBndrsToTypes bndrs) @@ -422,14 +464,15 @@ repAssocTyFamDefaults = mapM rep_deflt ; rhs1 <- repLTy rhs ; eqn1 <- repTySynEqn tys2 rhs1 ; repTySynInst tc1 eqn1 } + rep_deflt (L _ (XFamEqn _)) = panic "repAssocTyFamDefaults" ------------------------- -- represent fundeps -- -repLFunDeps :: [Located (FunDep (Located Name))] -> DsM (Core [TH.FunDep]) +repLFunDeps :: [LHsFunDep GhcRn] -> DsM (Core [TH.FunDep]) repLFunDeps fds = repList funDepTyConName repLFunDep fds -repLFunDep :: Located (FunDep (Located Name)) -> DsM (Core TH.FunDep) +repLFunDep :: LHsFunDep GhcRn -> DsM (Core TH.FunDep) repLFunDep (L _ (xs, ys)) = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs ys' <- repList nameTyConName (lookupBinder . unLoc) ys @@ -447,10 +490,11 @@ repInstD (L loc (DataFamInstD { dfid_inst = fi_decl })) repInstD (L loc (ClsInstD { cid_inst = cls_decl })) = do { dec <- repClsInstD cls_decl ; return (loc, dec) } +repInstD (L _ (XInstDecl _)) = panic "repInstD" repClsInstD :: ClsInstDecl GhcRn -> DsM (Core TH.DecQ) repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds - , cid_sigs = prags, cid_tyfam_insts = ats + , cid_sigs = sigs, cid_tyfam_insts = ats , cid_datafam_insts = adts , cid_overlap_mode = overlap }) @@ -464,17 +508,19 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds -- For example, the method names should be bound to -- the selector Ids, not to fresh names (Trac #5410) -- - do { cxt1 <- repLContext cxt + do { cxt1 <- repLContext cxt ; inst_ty1 <- repLTy inst_ty - ; binds1 <- rep_binds binds - ; prags1 <- rep_sigs prags - ; ats1 <- mapM (repTyFamInstD . unLoc) ats - ; adts1 <- mapM (repDataFamInstD . unLoc) adts - ; decls <- coreList decQTyConName (ats1 ++ adts1 ++ binds1 ++ prags1) - ; rOver <- repOverlap (fmap unLoc overlap) - ; repInst rOver cxt1 inst_ty1 decls } + -- 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 + ; decls1 <- coreList decQTyConName (ats1 ++ adts1 ++ sigs_binds) + ; rOver <- repOverlap (fmap unLoc overlap) + ; decls2 <- repInst rOver cxt1 inst_ty1 decls1 + ; wrapGenSyms ss decls2 } where (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty +repClsInstD (XClsInstDecl _) = panic "repClsInstD" repStandaloneDerivD :: LDerivDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat @@ -486,7 +532,8 @@ repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat ; repDeriv strat' cxt' inst_ty' } ; return (loc, dec) } where - (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty + (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty) +repStandaloneDerivD (L _ (XDerivDecl _)) = panic "repStandaloneDerivD" repTyFamInstD :: TyFamInstDecl GhcRn -> DsM (Core TH.DecQ) repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn }) @@ -495,30 +542,40 @@ repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn }) ; eqn1 <- repTyFamEqn eqn ; repTySynInst tc eqn1 } -repTyFamEqn :: LTyFamInstEqn GhcRn -> DsM (Core TH.TySynEqnQ) -repTyFamEqn (L _ (TyFamEqn { tfe_pats = HsIB { hsib_body = tys - , hsib_vars = var_names } - , tfe_rhs = rhs })) - = do { let hs_tvs = HsQTvs { hsq_implicit = var_names - , hsq_explicit = [] - , hsq_dependent = emptyNameSet } -- Yuk +repTyFamEqn :: TyFamInstEqn GhcRn -> DsM (Core TH.TySynEqnQ) +repTyFamEqn (HsIB { hsib_ext = var_names + , hsib_body = FamEqn { feqn_pats = tys + , feqn_rhs = rhs }}) + = do { let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn + { hsq_implicit = var_names + , hsq_dependent = emptyNameSet } -- Yuk + , hsq_explicit = [] } ; addTyClTyVarBinds hs_tvs $ \ _ -> do { tys1 <- repLTys tys ; tys2 <- coreList typeQTyConName tys1 ; rhs1 <- repLTy rhs ; repTySynEqn tys2 rhs1 } } +repTyFamEqn (XHsImplicitBndrs _) = panic "repTyFamEqn" +repTyFamEqn (HsIB _ (XFamEqn _)) = panic "repTyFamEqn" repDataFamInstD :: DataFamInstDecl GhcRn -> DsM (Core TH.DecQ) -repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name - , dfid_pats = HsIB { hsib_body = tys, hsib_vars = var_names } - , dfid_defn = defn }) +repDataFamInstD (DataFamInstDecl { dfid_eqn = + (HsIB { hsib_ext = var_names + , hsib_body = FamEqn { feqn_tycon = tc_name + , feqn_pats = tys + , feqn_rhs = defn }})}) = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences] - ; let hs_tvs = HsQTvs { hsq_implicit = var_names - , hsq_explicit = [] - , hsq_dependent = emptyNameSet } -- Yuk + ; let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn + { hsq_implicit = var_names + , hsq_dependent = emptyNameSet } -- Yuk + , hsq_explicit = [] } ; addTyClTyVarBinds hs_tvs $ \ bndrs -> do { tys1 <- repList typeQTyConName repLTy tys ; repDataDefn tc bndrs (Just tys1) defn } } +repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs _)) + = panic "repDataFamInstD" +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 @@ -562,7 +619,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 (L loc (FixitySig _ names (Fixity _ prec dir))) = do { MkC prec' <- coreIntLit prec ; let rep_fn = case dir of InfixL -> infixLDName @@ -573,9 +630,10 @@ 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" repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) -repRuleD (L loc (HsRule n act bndrs lhs _ rhs _)) +repRuleD (L loc (HsRule _ n act bndrs lhs rhs)) = do { let bndr_names = concatMap ruleBndrNames bndrs ; ss <- mkGenSyms bndr_names ; rule1 <- addBinds ss $ @@ -587,28 +645,36 @@ repRuleD (L loc (HsRule n act bndrs lhs _ rhs _)) ; repPragRule n' bndrs' lhs' rhs' act' } ; rule2 <- wrapGenSyms ss rule1 ; return (loc, rule2) } +repRuleD (L _ (XRuleDecl _)) = panic "repRuleD" ruleBndrNames :: LRuleBndr GhcRn -> [Name] -ruleBndrNames (L _ (RuleBndr n)) = [unLoc n] -ruleBndrNames (L _ (RuleBndrSig n sig)) - | HsWC { hswc_body = HsIB { hsib_vars = vars }} <- sig +ruleBndrNames (L _ (RuleBndr _ n)) = [unLoc n] +ruleBndrNames (L _ (RuleBndrSig _ n sig)) + | HsWC { hswc_body = HsIB { hsib_ext = vars }} <- sig = unLoc n : vars +ruleBndrNames (L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs _)))) + = panic "ruleBndrNames" +ruleBndrNames (L _ (RuleBndrSig _ _ (XHsWildCardBndrs _))) + = panic "ruleBndrNames" +ruleBndrNames (L _ (XRuleBndr _)) = panic "ruleBndrNames" repRuleBndr :: LRuleBndr GhcRn -> DsM (Core TH.RuleBndrQ) -repRuleBndr (L _ (RuleBndr n)) +repRuleBndr (L _ (RuleBndr _ n)) = do { MkC n' <- lookupLBinder n ; rep2 ruleVarName [n'] } -repRuleBndr (L _ (RuleBndrSig n sig)) +repRuleBndr (L _ (RuleBndrSig _ n sig)) = do { MkC n' <- lookupLBinder n ; MkC ty' <- repLTy (hsSigWcType sig) ; rep2 typedRuleVarName [n', ty'] } +repRuleBndr (L _ (XRuleBndr _)) = panic "repRuleBndr" repAnnD :: LAnnDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) -repAnnD (L loc (HsAnnotation _ ann_prov (L _ exp))) +repAnnD (L loc (HsAnnotation _ _ ann_prov (L _ exp))) = do { target <- repAnnProv ann_prov ; exp' <- repE exp ; dec <- repPragAnn target exp' ; return (loc, dec) } +repAnnD (L _ (XAnnDecl _)) = panic "repAnnD" repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget) repAnnProv (ValueAnnProvenance (L _ n)) @@ -626,51 +692,48 @@ repAnnProv ModuleAnnProvenance repC :: LConDecl GhcRn -> DsM (Core TH.ConQ) repC (L _ (ConDeclH98 { con_name = con - , con_qvars = Nothing, con_cxt = Nothing - , con_details = details })) - = repDataCon con details + , con_forall = L _ False + , con_mb_cxt = Nothing + , con_args = args })) + = repDataCon con args repC (L _ (ConDeclH98 { con_name = con - , con_qvars = mcon_tvs, con_cxt = mcxt - , con_details = details })) - = do { let con_tvs = fromMaybe emptyLHsQTvs mcon_tvs - ctxt = unLoc $ fromMaybe (noLoc []) mcxt - ; addTyVarBinds con_tvs $ \ ex_bndrs -> - do { c' <- repDataCon con details - ; ctxt' <- repContext ctxt - ; if isEmptyLHsQTvs con_tvs && null ctxt + , con_forall = 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 + ; if not is_existential && isNothing mcxt then return c' else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) } } repC (L _ (ConDeclGADT { con_names = cons - , con_type = res_ty@(HsIB { hsib_vars = imp_tvs })})) - | (details, res_ty', L _ [] , []) <- gadtDetails - , [] <- imp_tvs - -- no implicit or explicit variables, no context = no need for a forall - = do { let doc = text "In the constructor for " <+> ppr (head cons) - ; (hs_details, gadt_res_ty) <- - updateGadtResult failWithDs doc details res_ty' - ; repGadtDataCons cons hs_details gadt_res_ty } - - | (details,res_ty',ctxt, exp_tvs) <- gadtDetails - = do { let doc = text "In the constructor for " <+> ppr (head cons) - con_tvs = HsQTvs { hsq_implicit = imp_tvs - , hsq_explicit = exp_tvs - , hsq_dependent = emptyNameSet } - -- NB: Don't put imp_tvs into the hsq_explicit field above + , 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 + = repGadtDataCons cons args res_ty + + | otherwise + = addTyVarBinds qtvs $ \ ex_bndrs -> -- See Note [Don't quantify implicit type variables in quotes] - ; addTyVarBinds con_tvs $ \ ex_bndrs -> do - { (hs_details, gadt_res_ty) <- - updateGadtResult failWithDs doc details res_ty' - ; c' <- repGadtDataCons cons hs_details gadt_res_ty - ; ctxt' <- repContext (unLoc ctxt) - ; if null exp_tvs && null (unLoc ctxt) + do { c' <- repGadtDataCons cons args res_ty + ; ctxt' <- repMbContext mcxt + ; if null (hsQTvExplicit qtvs) && isNothing mcxt then return c' - else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) } } - where - gadtDetails = gadtDeclDetails res_ty + else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) } + +repC (L _ (XConDecl _)) = panic "repC" + + +repMbContext :: Maybe (LHsContext GhcRn) -> DsM (Core TH.CxtQ) +repMbContext Nothing = repContext [] +repMbContext (Just (L _ cxt)) = repContext cxt repSrcUnpackedness :: SrcUnpackedness -> DsM (Core TH.SourceUnpackednessQ) repSrcUnpackedness SrcUnpack = rep2 sourceUnpackName [] @@ -691,7 +754,7 @@ repBangTy ty = do rep2 bangTypeName [b, t] where (su', ss', ty') = case ty of - L _ (HsBangTy (HsSrcBang _ su ss) ty) -> (su, ss, ty) + L _ (HsBangTy _ (HsSrcBang _ su ss) ty) -> (su, ss, ty) _ -> (NoSrcUnpack, NoSrcStrict, ty) ------------------------------------------------------- @@ -711,76 +774,108 @@ repDerivClause (L _ (HsDerivingClause { deriv_clause_strategy = dcs where rep_deriv_ty :: LHsType GhcRn -> DsM (Core TH.TypeQ) rep_deriv_ty (L _ ty) = repTy ty +repDerivClause (L _ (XHsDerivingClause _)) = panic "repDerivClause" + +rep_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn + -> DsM ([GenSymBind], [Core TH.DecQ]) +-- Represent signatures and methods in class/instance declarations. +-- See Note [Scoped type variables in class and instance declarations] +-- +-- Why not use 'repBinds': we have already created symbols for methods in +-- 'repTopDs' via 'hsGroupBinders'. However in 'repBinds', we recreate +-- these fun_id via 'collectHsValBinders decs', which would lead to the +-- instance declarations failing in TH. +rep_sigs_binds sigs binds + = do { let tvs = concatMap get_scoped_tvs sigs + ; ss <- mkGenSyms tvs + ; sigs1 <- addBinds ss $ rep_sigs sigs + ; binds1 <- addBinds ss $ rep_binds binds + ; return (ss, de_loc (sort_by_loc (sigs1 ++ binds1))) } ------------------------------------------------------- -- Signatures in a class decl, or a group of bindings ------------------------------------------------------- -rep_sigs :: [LSig GhcRn] -> DsM [Core TH.DecQ] -rep_sigs sigs = do locs_cores <- rep_sigs' sigs - return $ de_loc $ sort_by_loc locs_cores - -rep_sigs' :: [LSig GhcRn] -> DsM [(SrcSpan, Core TH.DecQ)] +rep_sigs :: [LSig GhcRn] -> DsM [(SrcSpan, Core TH.DecQ)] -- We silently ignore ones we don't recognise -rep_sigs' = concatMapM rep_sig +rep_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)) +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 (L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc +rep_sig (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 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 loc (CompleteMatchSig _ _st cls mty)) = rep_complete_sig cls mty loc +rep_sig (L _ (XSig _)) = panic "rep_sig" rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name -> DsM (SrcSpan, Core TH.DecQ) +-- Don't create the implicit and explicit variables when desugaring signatures, +-- see Note [Scoped type variables in class and instance declarations]. +-- and Note [Don't quantify implicit type variables in quotes] rep_ty_sig mk_sig loc sig_ty nm + | HsIB { hsib_body = hs_ty } <- sig_ty + , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy hs_ty = do { nm1 <- lookupLOcc nm - ; ty1 <- repHsSigType sig_ty - ; sig <- repProto mk_sig nm1 ty1 + ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv) + ; repTyVarBndrWithKind tv name } + ; th_explicit_tvs <- repList tyVarBndrQTyConName rep_in_scope_tv + explicit_tvs + + -- NB: Don't pass any implicit type variables to repList above + -- See Note [Don't quantify implicit type variables in quotes] + + ; th_ctxt <- repLContext ctxt + ; th_ty <- repLTy ty + ; ty1 <- if null explicit_tvs && null (unLoc ctxt) + then return th_ty + else repTForall th_explicit_tvs th_ctxt th_ty + ; sig <- repProto mk_sig nm1 ty1 ; return (loc, sig) } +rep_ty_sig _ _ (XHsImplicitBndrs _) _ = panic "rep_ty_sig" rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name -> DsM (SrcSpan, Core TH.DecQ) -- represents a pattern synonym type signature; -- see Note [Pattern synonym type signatures and Template Haskell] in Convert +-- +-- Don't create the implicit and explicit variables when desugaring signatures, +-- see Note [Scoped type variables in class and instance declarations] +-- and Note [Don't quantify implicit type variables in quotes] rep_patsyn_ty_sig loc sig_ty nm - = do { nm1 <- lookupLOcc nm - ; ty1 <- repHsPatSynSigType sig_ty - ; sig <- repProto patSynSigDName nm1 ty1 - ; return (loc, sig) } - -rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> Located Name - -> DsM (SrcSpan, Core TH.DecQ) - -- We must special-case the top-level explicit for-all of a TypeSig - -- See Note [Scoped type variables in bindings] -rep_wc_ty_sig mk_sig loc sig_ty nm - | HsIB { hsib_body = hs_ty } <- hswc_body sig_ty - , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy hs_ty + | HsIB { hsib_body = hs_ty } <- sig_ty + , (univs, reqs, exis, provs, ty) <- splitLHsPatSynTy hs_ty = do { nm1 <- lookupLOcc nm ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv) ; repTyVarBndrWithKind tv name } - ; th_explicit_tvs <- repList tyVarBndrTyConName rep_in_scope_tv - explicit_tvs + ; th_univs <- repList tyVarBndrQTyConName rep_in_scope_tv univs + ; th_exis <- repList tyVarBndrQTyConName rep_in_scope_tv exis + -- NB: Don't pass any implicit type variables to repList above -- See Note [Don't quantify implicit type variables in quotes] - ; th_ctxt <- repLContext ctxt - ; th_ty <- repLTy ty - ; ty1 <- if null explicit_tvs && null (unLoc ctxt) - then return th_ty - else repTForall th_explicit_tvs th_ctxt th_ty - ; sig <- repProto mk_sig nm1 ty1 + ; th_reqs <- repLContext reqs + ; th_provs <- repLContext provs + ; th_ty <- repLTy ty + ; ty1 <- repTForall th_univs th_reqs =<< + repTForall th_exis th_provs th_ty + ; sig <- repProto patSynSigDName nm1 ty1 ; return (loc, sig) } +rep_patsyn_ty_sig _ (XHsImplicitBndrs _) _ = panic "rep_patsyn_ty_sig" + +rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> Located Name + -> DsM (SrcSpan, Core TH.DecQ) +rep_wc_ty_sig mk_sig loc sig_ty nm + = rep_ty_sig mk_sig loc (hswc_body sig_ty) nm rep_inline :: Located Name -> InlinePragma -- Never defaultInlinePragma @@ -803,7 +898,7 @@ rep_specialise nm ty ispec loc ; ty1 <- repHsSigType ty ; phases <- repPhases $ inl_act ispec ; let inline = inl_inline ispec - ; pragma <- if isEmptyInlineSpec inline + ; pragma <- if noUserInlineSpec inline then -- SPECIALISE repPragSpec nm1 ty1 phases else -- SPECIALISE INLINE @@ -863,27 +958,35 @@ addSimpleTyVarBinds names thing_inside ; term <- addBinds fresh_names thing_inside ; wrapGenSyms fresh_names term } +addHsTyVarBinds :: [LHsTyVarBndr GhcRn] -- the binders to be added + -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a))) -- action in the ext env + -> DsM (Core (TH.Q a)) +addHsTyVarBinds exp_tvs thing_inside + = do { fresh_exp_names <- mkGenSyms (map hsLTyVarName exp_tvs) + ; term <- addBinds fresh_exp_names $ + do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr + (exp_tvs `zip` fresh_exp_names) + ; thing_inside kbs } + ; wrapGenSyms fresh_exp_names term } + where + mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v) + addTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added - -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a))) -- action in the ext env + -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a))) -- action in the ext env -> DsM (Core (TH.Q a)) -- gensym a list of type variables and enter them into the meta environment; -- the computations passed as the second argument is executed in that extended -- meta environment and gets the *new* names on Core-level as an argument - -addTyVarBinds (HsQTvs { hsq_implicit = imp_tvs, hsq_explicit = exp_tvs }) m - = do { fresh_imp_names <- mkGenSyms imp_tvs - ; fresh_exp_names <- mkGenSyms (map hsLTyVarName exp_tvs) - ; let fresh_names = fresh_imp_names ++ fresh_exp_names - ; term <- addBinds fresh_names $ - do { kbs <- repList tyVarBndrTyConName mk_tv_bndr - (exp_tvs `zip` fresh_exp_names) - ; m kbs } - ; wrapGenSyms fresh_names term } - where - mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v) +addTyVarBinds (HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = imp_tvs} + , hsq_explicit = exp_tvs }) + thing_inside + = addSimpleTyVarBinds imp_tvs $ + addHsTyVarBinds exp_tvs $ + thing_inside +addTyVarBinds (XLHsQTyVars _) _ = panic "addTyVarBinds" addTyClTyVarBinds :: LHsQTyVars GhcRn - -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a))) + -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a))) -> DsM (Core (TH.Q a)) -- Used for data/newtype declarations, and family instances, @@ -899,30 +1002,34 @@ addTyClTyVarBinds tvs m -- This makes things work for family declarations ; term <- addBinds freshNames $ - do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvExplicit tvs) + do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr + (hsQTvExplicit tvs) ; m kbs } ; wrapGenSyms freshNames term } where + mk_tv_bndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ) mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv) ; repTyVarBndrWithKind tv v } -- Produce kinded binder constructors from the Haskell tyvar binders -- repTyVarBndrWithKind :: LHsTyVarBndr GhcRn - -> Core TH.Name -> DsM (Core TH.TyVarBndr) -repTyVarBndrWithKind (L _ (UserTyVar _)) nm + -> Core TH.Name -> DsM (Core TH.TyVarBndrQ) +repTyVarBndrWithKind (L _ (UserTyVar _ _)) nm = repPlainTV nm -repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm - = repLKind ki >>= repKindedTV nm +repTyVarBndrWithKind (L _ (KindedTyVar _ _ ki)) nm + = repLTy ki >>= repKindedTV nm +repTyVarBndrWithKind (L _ (XTyVarBndr{})) _ = panic "repTyVarBndrWithKind" -- | Represent a type variable binder -repTyVarBndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndr) -repTyVarBndr (L _ (UserTyVar (L _ nm)) )= do { nm' <- lookupBinder nm - ; repPlainTV nm' } -repTyVarBndr (L _ (KindedTyVar (L _ nm) ki)) = do { nm' <- lookupBinder nm - ; ki' <- repLKind ki - ; repKindedTV nm' ki' } +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" -- represent a type context -- @@ -934,43 +1041,23 @@ repContext ctxt = do preds <- repList typeQTyConName repLTy ctxt repCtxt preds repHsSigType :: LHsSigType GhcRn -> DsM (Core TH.TypeQ) -repHsSigType (HsIB { hsib_vars = implicit_tvs +repHsSigType (HsIB { hsib_ext = implicit_tvs , hsib_body = body }) | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy body - = addTyVarBinds (HsQTvs { hsq_implicit = implicit_tvs - , hsq_explicit = explicit_tvs - , hsq_dependent = emptyNameSet }) - -- NB: Don't pass implicit_tvs to the hsq_explicit field above - -- See Note [Don't quantify implicit type variables in quotes] - $ \ th_explicit_tvs -> + = addSimpleTyVarBinds implicit_tvs $ + -- See Note [Don't quantify implicit type variables in quotes] + addHsTyVarBinds explicit_tvs $ \ th_explicit_tvs -> do { th_ctxt <- repLContext ctxt ; th_ty <- repLTy ty ; if null explicit_tvs && null (unLoc ctxt) then return th_ty else repTForall th_explicit_tvs th_ctxt th_ty } - -repHsPatSynSigType :: LHsSigType GhcRn -> DsM (Core TH.TypeQ) -repHsPatSynSigType (HsIB { hsib_vars = implicit_tvs - , hsib_body = body }) - = addTyVarBinds (newTvs implicit_tvs univs) $ \th_univs -> - addTyVarBinds (newTvs [] exis) $ \th_exis -> - do { th_reqs <- repLContext reqs - ; th_provs <- repLContext provs - ; th_ty <- repLTy ty - ; repTForall th_univs th_reqs =<< (repTForall th_exis th_provs th_ty) } - where - newTvs impl_tvs expl_tvs = HsQTvs - { hsq_implicit = impl_tvs - , hsq_explicit = expl_tvs - , hsq_dependent = emptyNameSet } - -- NB: Don't pass impl_tvs to the hsq_explicit field above - -- See Note [Don't quantify implicit type variables in quotes] - - (univs, reqs, exis, provs, ty) = splitLHsPatSynTy body +repHsSigType (XHsImplicitBndrs _) = panic "repHsSigType" repHsSigWcType :: LHsSigWcType GhcRn -> DsM (Core TH.TypeQ) repHsSigWcType (HsWC { hswc_body = sig1 }) = repHsSigType sig1 +repHsSigWcType (XHsWildCardBndrs _) = panic "repHsSigWcType" -- yield the representation of a list of types repLTys :: [LHsType GhcRn] -> DsM [Core TH.TypeQ] @@ -984,8 +1071,7 @@ repForall :: HsType GhcRn -> DsM (Core TH.TypeQ) -- Arg of repForall is always HsForAllTy or HsQualTy repForall ty | (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty) - = addTyVarBinds (HsQTvs { hsq_implicit = [], hsq_explicit = tvs - , hsq_dependent = emptyNameSet }) $ \bndrs -> + = addHsTyVarBinds tvs $ \bndrs -> do { ctxt1 <- repLContext ctxt ; ty1 <- repLTy tau ; repTForall bndrs ctxt1 ty1 } @@ -994,7 +1080,10 @@ repTy :: HsType GhcRn -> DsM (Core TH.TypeQ) repTy ty@(HsForAllTy {}) = repForall ty repTy ty@(HsQualTy {}) = repForall ty -repTy (HsTyVar _ (L _ n)) +repTy (HsTyVar _ _ (L _ n)) + | isLiftedTypeKindTyConName n = repTStar + | n `hasKey` constraintKindTyConKey = repTConstraint + | n `hasKey` funTyConKey = repArrowTyCon | isTvOcc occ = do tv1 <- lookupOcc n repTvar tv1 | isDataOcc occ = do tc1 <- lookupOcc n @@ -1005,47 +1094,38 @@ repTy (HsTyVar _ (L _ n)) where occ = nameOccName n -repTy (HsAppTy f a) = do +repTy (HsAppTy _ f a) = do f1 <- repLTy f a1 <- repLTy a repTapp f1 a1 -repTy (HsFunTy f a) = do +repTy (HsFunTy _ f a) = do f1 <- repLTy f a1 <- repLTy a tcon <- repArrowTyCon repTapps tcon [f1, a1] -repTy (HsListTy t) = do +repTy (HsListTy _ t) = do t1 <- repLTy t tcon <- repListTyCon repTapp tcon t1 -repTy (HsPArrTy t) = do - t1 <- repLTy t - tcon <- repTy (HsTyVar NotPromoted - (noLoc (tyConName parrTyCon))) - repTapp tcon t1 -repTy (HsTupleTy HsUnboxedTuple tys) = do +repTy (HsTupleTy _ HsUnboxedTuple tys) = do tys1 <- repLTys tys tcon <- repUnboxedTupleTyCon (length tys) repTapps tcon tys1 -repTy (HsTupleTy _ tys) = do tys1 <- repLTys tys +repTy (HsTupleTy _ _ tys) = do tys1 <- repLTys tys tcon <- repTupleTyCon (length tys) repTapps tcon tys1 -repTy (HsSumTy tys) = do tys1 <- repLTys tys +repTy (HsSumTy _ tys) = do tys1 <- repLTys tys tcon <- repUnboxedSumTyCon (length tys) repTapps tcon tys1 -repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) +repTy (HsOpTy _ ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) `nlHsAppTy` ty2) -repTy (HsParTy t) = repLTy t -repTy (HsEqTy t1 t2) = do - t1' <- repLTy t1 - t2' <- repLTy t2 - eq <- repTequality - repTapps eq [t1', t2'] -repTy (HsKindSig t k) = do +repTy (HsParTy _ t) = repLTy t +repTy (HsStarTy _ _) = repTStar +repTy (HsKindSig _ t k) = do t1 <- repLTy t - k1 <- repLKind k + k1 <- repLTy k repTSig t1 k1 -repTy (HsSpliceTy splice _) = repSplice splice +repTy (HsSpliceTy _ splice) = repSplice splice repTy (HsExplicitListTy _ _ tys) = do tys1 <- repLTys tys repTPromotedList tys1 @@ -1053,10 +1133,14 @@ repTy (HsExplicitTupleTy _ tys) = do tys1 <- repLTys tys tcon <- repPromotedTupleTyCon (length tys) repTapps tcon tys1 -repTy (HsTyLit lit) = do - lit' <- repTyLit lit - repTLit lit' +repTy (HsTyLit _ lit) = do + lit' <- repTyLit lit + repTLit lit' repTy (HsWildCardTy (AnonWildCard _)) = repTWildCard +repTy (HsIParamTy _ n t) = do + n' <- rep_implicit_param_name (unLoc n) + t' <- repLTy t + repTImplicitParam n' t' repTy ty = notHandled "Exotic form of type" (ppr ty) @@ -1067,59 +1151,14 @@ repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s ; rep2 strTyLitName [s'] } --- represent a kind --- --- It would be great to scrap this function in favor of repLTy, since Types --- and Kinds are the same things. We have not done so yet for engineering --- reasons, as repLTy returns a monadic TypeQ, whereas repLKind returns a pure --- Kind, so in order to replace repLKind with repLTy, we'd need to go through --- and purify repLTy and every monadic function it calls. This is the subject --- GHC Trac #11785. -repLKind :: LHsKind GhcRn -> DsM (Core TH.Kind) -repLKind ki - = do { let (kis, ki') = splitHsFunType ki - ; kis_rep <- mapM repLKind kis - ; ki'_rep <- repNonArrowLKind ki' - ; kcon <- repKArrow - ; let f k1 k2 = repKApp kcon k1 >>= flip repKApp k2 - ; foldrM f ki'_rep kis_rep - } - --- | Represent a kind wrapped in a Maybe -repMaybeLKind :: Maybe (LHsKind GhcRn) - -> DsM (Core (Maybe TH.Kind)) -repMaybeLKind Nothing = - do { coreNothing kindTyConName } -repMaybeLKind (Just ki) = - do { ki' <- repLKind ki - ; coreJust kindTyConName ki' } - -repNonArrowLKind :: LHsKind GhcRn -> DsM (Core TH.Kind) -repNonArrowLKind (L _ ki) = repNonArrowKind ki - -repNonArrowKind :: HsKind GhcRn -> DsM (Core TH.Kind) -repNonArrowKind (HsTyVar _ (L _ name)) - | isLiftedTypeKindTyConName name = repKStar - | name `hasKey` constraintKindTyConKey = repKConstraint - | isTvOcc (nameOccName name) = lookupOcc name >>= repKVar - | otherwise = lookupOcc name >>= repKCon -repNonArrowKind (HsAppTy f a) = do { f' <- repLKind f - ; a' <- repLKind a - ; repKApp f' a' - } -repNonArrowKind (HsListTy k) = do { k' <- repLKind k - ; kcon <- repKList - ; repKApp kcon k' - } -repNonArrowKind (HsTupleTy _ ks) = do { ks' <- mapM repLKind ks - ; kcon <- repKTuple (length ks) - ; repKApps kcon ks' - } -repNonArrowKind (HsKindSig k sort) = do { k' <- repLKind k - ; sort' <- repLKind sort - ; repKSig k' sort' - } -repNonArrowKind k = notHandled "Exotic form of kind" (ppr k) +-- | Represent a type wrapped in a Maybe +repMaybeLTy :: Maybe (LHsKind GhcRn) + -> DsM (Core (Maybe TH.TypeQ)) +repMaybeLTy Nothing = + do { coreNothing kindQTyConName } +repMaybeLTy (Just ki) = + do { ki' <- repLTy ki + ; coreJust kindQTyConName ki' } repRole :: Located (Maybe Role) -> DsM (Core TH.Role) repRole (L _ (Just Nominal)) = rep2 nominalRName [] @@ -1134,10 +1173,11 @@ repRole (L _ Nothing) = rep2 inferRName [] repSplice :: HsSplice GhcRn -> DsM (Core a) -- See Note [How brackets and nested splices are handled] in TcSplice -- We return a CoreExpr of any old type; the context should know -repSplice (HsTypedSplice _ n _) = rep_splice n -repSplice (HsUntypedSplice _ n _) = rep_splice n -repSplice (HsQuasiQuote n _ _ _) = rep_splice n -repSplice e@(HsSpliced _ _) = pprPanic "repSplice" (ppr e) +repSplice (HsTypedSplice _ _ n _) = rep_splice n +repSplice (HsUntypedSplice _ _ n _) = rep_splice n +repSplice (HsQuasiQuote _ n _ _ _) = rep_splice n +repSplice e@(HsSpliced {}) = pprPanic "repSplice" (ppr e) +repSplice e@(XSplice {}) = pprPanic "repSplice" (ppr e) rep_splice :: Name -> DsM (Core a) rep_splice splice_name @@ -1162,7 +1202,7 @@ repLE :: LHsExpr GhcRn -> DsM (Core TH.ExpQ) repLE (L loc e) = putSrcSpanDs loc (repE e) repE :: HsExpr GhcRn -> DsM (Core TH.ExpQ) -repE (HsVar (L _ x)) = +repE (HsVar _ (L _ x)) = do { mb_val <- dsLookupMetaEnv x ; case mb_val of Nothing -> do { str <- globalVar x @@ -1170,45 +1210,46 @@ repE (HsVar (L _ x)) = Just (DsBound y) -> repVarOrCon x (coreVar y) Just (DsSplice e) -> do { e' <- dsExpr e ; return (MkC e') } } -repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e) -repE (HsOverLabel _ s) = repOverLabel s +repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar +repE (HsOverLabel _ _ s) = repOverLabel s -repE e@(HsRecFld f) = case f of - Unambiguous _ x -> repE (HsVar (noLoc x)) +repE e@(HsRecFld _ f) = case f of + Unambiguous x _ -> repE (HsVar noExt (noLoc x)) Ambiguous{} -> notHandled "Ambiguous record selectors" (ppr e) + XAmbiguousFieldOcc{} -> notHandled "XAmbiguous record selectors" (ppr e) -- Remember, we're desugaring renamer output here, so -- 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 (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 })) = do { ms' <- mapM repMatchTup ms ; core_ms <- coreList matchQTyConName ms' ; repLamCase core_ms } -repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b} -repE (HsAppType e t) = do { a <- repLE e +repE (HsApp _ x y) = do {a <- repLE x; b <- repLE y; repApp a b} +repE (HsAppType t e) = do { a <- repLE e ; s <- repLTy (hswc_body t) ; repAppType a s } -repE (OpApp e1 op _ e2) = +repE (OpApp _ e1 op e2) = do { arg1 <- repLE e1; arg2 <- repLE e2; the_op <- repLE op ; repInfixApp arg1 the_op arg2 } -repE (NegApp x _) = do +repE (NegApp _ x _) = do a <- repLE x negateVar <- lookupOcc negateName >>= repVar negateVar `repApp` a -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 (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 })) = do { arg <- repLE e ; ms2 <- mapM repMatchTup ms ; core_ms2 <- coreList matchQTyConName ms2 ; repCaseE arg core_ms2 } -repE (HsIf _ x y z) = do +repE (HsIf _ _ x y z) = do a <- repLE x b <- repLE y c <- repLE z @@ -1217,13 +1258,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 _ (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 (L _ sts)) | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False } = do { (ss,zs) <- repLSts sts; e' <- repDoE (nonEmptyCoreList zs); @@ -1234,18 +1275,22 @@ repE e@(HsDo ctxt (L _ sts) _) e' <- repComp (nonEmptyCoreList zs); wrapGenSyms ss e' } + | MDoExpr <- ctxt + = do { (ss,zs) <- repLSts sts; + e' <- repMDoE (nonEmptyCoreList zs); + wrapGenSyms ss e' } + | otherwise - = notHandled "mdo, monad comprehension and [: :]" (ppr e) + = notHandled "monad comprehension and [: :]" (ppr e) repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs } -repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e) -repE e@(ExplicitTuple es boxed) +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] - ; repUnboxedTup xs } + | isBoxed boxed = do { xs <- repLEs [e | L _ (Present _ e) <- es]; repTup xs } + | otherwise = do { xs <- repLEs [e | L _ (Present _ e) <- es] + ; repUnboxedTup xs } -repE (ExplicitSum alt arity e _) +repE (ExplicitSum _ alt arity e) = do { e1 <- repLE e ; repUnboxedSum e1 alt arity } @@ -1258,7 +1303,7 @@ repE (RecordUpd { rupd_expr = e, rupd_flds = flds }) fs <- repUpdFields flds; repRecUpd x fs } -repE (ExprWithTySig e ty) +repE (ExprWithTySig ty e) = do { e1 <- repLE e ; t1 <- repHsSigWcType ty ; repSigExp e1 t1 } @@ -1280,25 +1325,24 @@ repE (ArithSeq _ _ aseq) = ds3 <- repLE e3 repFromThenTo ds1 ds2 ds3 -repE (HsSpliceE splice) = repSplice splice +repE (HsSpliceE _ splice) = repSplice splice repE (HsStatic _ e) = repLE e >>= rep2 staticEName . (:[]) . unC -repE (HsUnboundVar uv) = do +repE (HsUnboundVar _ uv) = do occ <- occNameLit (unboundVarOcc uv) sname <- repNameS occ repUnboundVar sname -repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e) repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e) repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e) repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e) -repE e@(HsTcBracketOut {}) = notHandled "TH brackets" (ppr e) 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 _ [p] _ (GRHSs guards (L _ wheres)))) = +repMatchTup (L _ (Match { m_pats = [p] + , m_grhss = GRHSs _ guards (L _ wheres) })) = do { ss1 <- mkGenSyms (collectPatBinders p) ; addBinds ss1 $ do { ; p1 <- repLP p @@ -1310,7 +1354,8 @@ repMatchTup (L _ (Match _ [p] _ (GRHSs guards (L _ wheres)))) = repMatchTup _ = panic "repMatchTup: case alt with more than one arg" repClauseTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ClauseQ) -repClauseTup (L _ (Match _ ps _ (GRHSs guards (L _ wheres)))) = +repClauseTup (L _ (Match { m_pats = ps + , m_grhss = GRHSs _ guards (L _ wheres) })) = do { ss1 <- mkGenSyms (collectPatsBinders ps) ; addBinds ss1 $ do { ps1 <- repLPs ps @@ -1319,9 +1364,11 @@ repClauseTup (L _ (Match _ ps _ (GRHSs guards (L _ wheres)))) = gs <- repGuards guards ; clause <- repClause ps1 gs ds ; wrapGenSyms (ss1++ss2) clause }}} +repClauseTup (L _ (Match _ _ _ (XGRHSs _))) = panic "repClauseTup" +repClauseTup (L _ (XMatch _)) = panic "repClauseTup" repGuards :: [LGRHS GhcRn (LHsExpr GhcRn)] -> DsM (Core TH.BodyQ) -repGuards [L _ (GRHS [] e)] +repGuards [L _ (GRHS _ [] e)] = do {a <- repLE e; repNormal a } repGuards other = do { zs <- mapM repLGRHS other @@ -1331,14 +1378,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 (L _ (GRHS _ [L _ (BodyStmt _ e1 _ _)] e2)) = do { guarded <- repLNormalGE e1 e2 ; return ([], guarded) } -repLGRHS (L _ (GRHS ss rhs)) +repLGRHS (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" repFields :: HsRecordBinds GhcRn -> DsM (Core [TH.Q TH.FieldExp]) repFields (HsRecFields { rec_flds = flds }) @@ -1355,7 +1403,7 @@ 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) + Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name) ; e <- repLE (hsRecFieldArg fld) ; repFieldExp fn e } _ -> notHandled "Ambiguous record updates" (ppr fld) @@ -1391,7 +1439,7 @@ repLSts :: [LStmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ]) repLSts stmts = repSts (map unLoc stmts) repSts :: [Stmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ]) -repSts (BindStmt p e _ _ _ : ss) = +repSts (BindStmt _ p e _ _ : ss) = do { e2 <- repLE e ; ss1 <- mkGenSyms (collectPatBinders p) ; addBinds ss1 $ do { @@ -1399,17 +1447,17 @@ 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 _ (L _ bs) : ss) = do { (ss1,ds) <- repBinds bs ; z <- repLetSt ds ; (ss2,zs) <- addBinds ss1 (repSts ss) ; return (ss1++ss2, z : zs) } -repSts (BodyStmt e _ _ _ : ss) = +repSts (BodyStmt _ e _ _ : ss) = do { e2 <- repLE e ; z <- repNoBindSt e2 ; (ss2,zs) <- repSts ss ; return (ss2, z : zs) } -repSts (ParStmt stmt_blocks _ _ _ : ss) = +repSts (ParStmt _ stmt_blocks _ _ : ss) = do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1 ss1 = concat ss_s @@ -1419,14 +1467,25 @@ repSts (ParStmt stmt_blocks _ _ _ : ss) = where rep_stmt_block :: ParStmtBlock GhcRn GhcRn -> DsM ([GenSymBind], Core [TH.StmtQ]) - rep_stmt_block (ParStmtBlock stmts _ _) = + rep_stmt_block (ParStmtBlock _ stmts _ _) = do { (ss1, zs) <- repSts (map unLoc stmts) ; zs1 <- coreList stmtQTyConName zs ; return (ss1, zs1) } -repSts [LastStmt e _ _] + rep_stmt_block (XParStmtBlock{}) = panic "repSts" +repSts [LastStmt _ e _ _] = do { e2 <- repLE e ; z <- repNoBindSt e2 ; return ([], [z]) } +repSts (stmt@RecStmt{} : ss) + = do { let binders = collectLStmtsBinders (recS_stmts stmt) + ; ss1 <- mkGenSyms binders + -- Bring all of binders in the recursive group into scope for the + -- whole group. + ; (ss1_other,rss) <- addBinds ss1 $ repSts (map unLoc (recS_stmts stmt)) + ; MASSERT(sort ss1 == sort ss1_other) + ; z <- repRecSt (nonEmptyCoreList rss) + ; (ss2,zs) <- addBinds ss1 (repSts ss) + ; return (ss1++ss2, z : zs) } repSts [] = return ([],[]) repSts other = notHandled "Exotic statement" (ppr other) @@ -1436,40 +1495,60 @@ repSts other = notHandled "Exotic statement" (ppr other) ----------------------------------------------------------- repBinds :: HsLocalBinds GhcRn -> DsM ([GenSymBind], Core [TH.DecQ]) -repBinds EmptyLocalBinds +repBinds (EmptyLocalBinds _) = do { core_list <- coreList decQTyConName [] ; return ([], core_list) } -repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b) +repBinds (HsIPBinds _ (IPBinds _ decs)) + = do { ips <- mapM rep_implicit_param_bind decs + ; core_list <- coreList decQTyConName + (de_loc (sort_by_loc ips)) + ; return ([], core_list) + } + +repBinds b@(HsIPBinds _ XHsIPBinds {}) + = notHandled "Implicit parameter binds extension" (ppr b) -repBinds (HsValBinds decs) - = do { let { bndrs = hsSigTvBinders decs ++ collectHsValBinders decs } +repBinds (HsValBinds _ decs) + = do { let { bndrs = hsScopedTvBinders decs ++ collectHsValBinders decs } -- No need to worry about detailed scopes within -- the binding group, because we are talking Names -- here, so we can safely treat it as a mutually -- recursive group - -- For hsSigTvBinders see Note [Scoped type variables in bindings] + -- For hsScopedTvBinders see Note [Scoped type variables in bindings] ; ss <- mkGenSyms bndrs ; prs <- addBinds ss (rep_val_binds decs) ; core_list <- coreList decQTyConName (de_loc (sort_by_loc prs)) ; return (ss, core_list) } +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))) + = do { name <- case ename of + Left (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 _)) + = notHandled "Implicit parameter bind extension" (ppr b) + +rep_implicit_param_name :: HsIPName -> DsM (Core String) +rep_implicit_param_name (HsIPName name) = coreStringLit (unpackFS name) rep_val_binds :: HsValBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)] -- Assumes: all the binders of the binding are already in the meta-env -rep_val_binds (ValBindsOut binds sigs) - = do { core1 <- rep_binds' (unionManyBags (map snd binds)) - ; core2 <- rep_sigs' sigs +rep_val_binds (XValBindsLR (NValBinds binds sigs)) + = do { core1 <- rep_binds (unionManyBags (map snd binds)) + ; core2 <- rep_sigs sigs ; return (core1 ++ core2) } -rep_val_binds (ValBindsIn _ _) - = panic "rep_val_binds: ValBindsIn" +rep_val_binds (ValBinds _ _ _) + = panic "rep_val_binds: ValBinds" -rep_binds :: LHsBinds GhcRn -> DsM [Core TH.DecQ] -rep_binds binds = do { binds_w_locs <- rep_binds' binds - ; return (de_loc (sort_by_loc binds_w_locs)) } - -rep_binds' :: LHsBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)] -rep_binds' = mapM rep_bind . bagToList +rep_binds :: LHsBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)] +rep_binds = mapM rep_bind . bagToList rep_bind :: LHsBind GhcRn -> DsM (SrcSpan, Core TH.DecQ) -- Assumes: all the binders of the binding are already in the meta-env @@ -1480,8 +1559,10 @@ rep_bind :: LHsBind GhcRn -> DsM (SrcSpan, Core TH.DecQ) rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MG { mg_alts - = L _ [L _ (Match _ [] _ - (GRHSs guards (L _ wheres)))] } })) + = L _ [L _ (Match + { m_pats = [] + , m_grhss = GRHSs _ guards (L _ wheres) } + )] } })) = do { (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) ; fn' <- lookupLBinder fn @@ -1497,14 +1578,17 @@ rep_bind (L loc (FunBind { fun_id = fn ; ans <- repFun fn' (nonEmptyCoreList ms1) ; return (loc, ans) } +rep_bind (L _ (FunBind { fun_matches = XMatchGroup _ })) = panic "rep_bind" + rep_bind (L loc (PatBind { pat_lhs = pat - , pat_rhs = GRHSs guards (L _ wheres) })) + , pat_rhs = GRHSs _ guards (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 (L _ (VarBind { var_id = v, var_rhs = e})) = do { v' <- lookupBinder v @@ -1516,12 +1600,10 @@ rep_bind (L _ (VarBind { var_id = v, var_rhs = e})) ; return (srcLocSpan (getSrcLoc v), ans) } rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds" -rep_bind (L _ (AbsBindsSig {})) = panic "rep_bind: AbsBindsSig" -rep_bind (L loc (PatSynBind (PSB { psb_id = syn - , psb_fvs = _fvs - , psb_args = args - , psb_def = pat - , psb_dir = dir }))) +rep_bind (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 @@ -1538,10 +1620,10 @@ rep_bind (L loc (PatSynBind (PSB { psb_id = syn -- API. Whereas inside GHC, record pattern synonym selectors and -- their pattern-only bound right hand sides have different names, -- we want to treat them the same in TH. This is the reason why we - -- need an adjusted mkGenArgSyms in the `RecordPatSyn` case below. - mkGenArgSyms (PrefixPatSyn args) = mkGenSyms (map unLoc args) - mkGenArgSyms (InfixPatSyn arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2] - mkGenArgSyms (RecordPatSyn fields) + -- need an adjusted mkGenArgSyms in the `RecCon` case below. + mkGenArgSyms (PrefixCon args) = mkGenSyms (map unLoc args) + mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2] + mkGenArgSyms (RecCon fields) = do { let pats = map (unLoc . recordPatSynPatVar) fields sels = map (unLoc . recordPatSynSelectorId) fields ; ss <- mkGenSyms sels @@ -1553,8 +1635,11 @@ rep_bind (L loc (PatSynBind (PSB { psb_id = syn wrapGenArgSyms :: HsPatSynDetails (Located Name) -> [GenSymBind] -> Core TH.DecQ -> DsM (Core TH.DecQ) - wrapGenArgSyms (RecordPatSyn _) _ dec = return dec - wrapGenArgSyms _ ss dec = wrapGenSyms ss dec + 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" repPatSynD :: Core TH.Name -> Core TH.PatSynArgsQ @@ -1565,14 +1650,14 @@ repPatSynD (MkC syn) (MkC args) (MkC dir) (MkC pat) = rep2 patSynDName [syn, args, dir, pat] repPatSynArgs :: HsPatSynDetails (Located Name) -> DsM (Core TH.PatSynArgsQ) -repPatSynArgs (PrefixPatSyn args) +repPatSynArgs (PrefixCon args) = do { args' <- repList nameTyConName lookupLOcc args ; repPrefixPatSynArgs args' } -repPatSynArgs (InfixPatSyn arg1 arg2) +repPatSynArgs (InfixCon arg1 arg2) = do { arg1' <- lookupLOcc arg1 ; arg2' <- lookupLOcc arg2 ; repInfixPatSynArgs arg1' arg2' } -repPatSynArgs (RecordPatSyn fields) +repPatSynArgs (RecCon fields) = do { sels' <- repList nameTyConName lookupLOcc sels ; repRecordPatSynArgs sels' } where sels = map recordPatSynSelectorId fields @@ -1593,6 +1678,7 @@ repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName [] repPatSynDir (ExplicitBidirectional (MG { mg_alts = L _ clauses })) = do { clauses' <- mapM repClauseTup clauses ; repExplBidirPatSynDir (nonEmptyCoreList clauses') } +repPatSynDir (ExplicitBidirectional (XMatchGroup _)) = panic "repPatSynDir" repExplBidirPatSynDir :: Core [TH.ClauseQ] -> DsM (Core TH.PatSynDirQ) repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls] @@ -1623,7 +1709,9 @@ 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 _ ps _ (GRHSs [L _ (GRHS [] e)] (L _ EmptyLocalBinds)))) +repLambda (L _ (Match { m_pats = ps + , m_grhss = GRHSs _ [L _ (GRHS _ [] e)] + (L _ (EmptyLocalBinds _)) } )) = do { let bndrs = collectPatsBinders ps ; ; ss <- mkGenSyms bndrs ; lam <- addBinds ss ( @@ -1648,19 +1736,23 @@ repLP :: LPat GhcRn -> DsM (Core TH.PatQ) repLP (L _ p) = repP 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 (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; repPaspat x' p1 } -repP (ParPat p) = repLP p -repP (ListPat ps _ Nothing) = do { qs <- repLPs ps; repPlist qs } -repP (ListPat ps ty1 (Just (_,e))) = do { p <- repP (ListPat ps ty1 Nothing); e' <- repE (syn_expr e); repPview e' p} -repP (TuplePat ps boxed _) +repP (WildPat _) = repPwild +repP (LitPat _ l) = do { l2 <- repLiteral l; repPlit l2 } +repP (VarPat _ (L _ x)) = do { x' <- lookupBinder 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 + ; repPaspat x' p1 } +repP (ParPat _ p) = repLP p +repP (ListPat Nothing ps) = do { qs <- repLPs ps; repPlist qs } +repP (ListPat (Just e) ps) = do { p <- repP (ListPat Nothing ps) + ; e' <- repE (syn_expr e) + ; repPview e' p} +repP (TuplePat _ ps boxed) | isBoxed boxed = do { qs <- repLPs ps; repPtup qs } | otherwise = do { qs <- repLPs ps; repPunboxedTup qs } -repP (SumPat p alt arity _) = do { p1 <- repLP p; repPunboxedSum p1 alt arity } +repP (SumPat _ p alt arity) = do { p1 <- repLP p + ; repPunboxedSum p1 alt arity } repP (ConPatIn dc details) = do { con_str <- lookupLOcc dc ; case details of @@ -1677,13 +1769,13 @@ repP (ConPatIn dc details) ; MkC p <- repLP (hsRecFieldArg fld) ; rep2 fieldPatName [v,p] } -repP (NPat (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 (SigPatIn p t) = do { p' <- repLP p - ; t' <- repLTy (hsSigWcType t) - ; repPsig p' t' } -repP (SplicePat splice) = repSplice splice +repP (NPat _ (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 t p) = do { p' <- repLP p + ; t' <- repLTy (hsSigWcType t) + ; repPsig p' t' } +repP (SplicePat _ splice) = repSplice splice repP other = notHandled "Exotic pattern" (ppr other) @@ -1836,7 +1928,7 @@ unC (MkC x) = x rep2 :: Name -> [ CoreExpr ] -> DsM (Core a) rep2 n xs = do { id <- dsLookupGlobalId n - ; return (MkC (foldl App (Var id) xs)) } + ; return (MkC (foldl' App (Var id) xs)) } dataCon' :: Name -> [CoreExpr] -> DsM (Core a) dataCon' n args = do { id <- dsLookupDataCon n @@ -1958,6 +2050,9 @@ repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms] repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ) repDoE (MkC ss) = rep2 doEName [ss] +repMDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ) +repMDoE (MkC ss) = rep2 mdoEName [ss] + repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ) repComp (MkC ss) = rep2 compEName [ss] @@ -1985,6 +2080,9 @@ repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y] repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y] +repImplicitParamVar :: Core String -> DsM (Core TH.ExpQ) +repImplicitParamVar (MkC x) = rep2 implicitParamVarEName [x] + ------------ Right hand sides (guarded expressions) ---- repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ) repGuarded (MkC pairs) = rep2 guardedBName [pairs] @@ -2018,6 +2116,9 @@ repNoBindSt (MkC e) = rep2 noBindSName [e] repParSt :: Core [[TH.StmtQ]] -> DsM (Core TH.StmtQ) repParSt (MkC sss) = rep2 parSName [sss] +repRecSt :: Core [TH.StmtQ] -> DsM (Core TH.StmtQ) +repRecSt (MkC ss) = rep2 recSName [ss] + -------------- Range (Arithmetic sequences) ----------- repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ) repFrom (MkC x) = rep2 fromEName [x] @@ -2045,8 +2146,8 @@ repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds] repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ) repFun (MkC nm) (MkC b) = rep2 funDName [nm, b] -repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] - -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.Kind) +repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ] + -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.KindQ) -> Core [TH.ConQ] -> Core [TH.DerivClauseQ] -> DsM (Core TH.DecQ) repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC cons) (MkC derivs) = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs] @@ -2054,8 +2155,8 @@ repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC cons) (MkC derivs) = rep2 dataInstDName [cxt, nm, tys, ksig, cons, derivs] -repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] - -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.Kind) +repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ] + -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.KindQ) -> Core TH.ConQ -> Core [TH.DerivClauseQ] -> DsM (Core TH.DecQ) repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC con) (MkC derivs) @@ -2064,7 +2165,7 @@ repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC con) (MkC derivs) = rep2 newtypeInstDName [cxt, nm, tys, ksig, con, derivs] -repTySyn :: Core TH.Name -> Core [TH.TyVarBndr] +repTySyn :: Core TH.Name -> Core [TH.TyVarBndrQ] -> Core TH.TypeQ -> DsM (Core TH.DecQ) repTySyn (MkC nm) (MkC tvs) (MkC rhs) = rep2 tySynDName [nm, tvs, rhs] @@ -2074,19 +2175,34 @@ repInst :: Core (Maybe TH.Overlap) -> repInst (MkC o) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithOverlapDName [o, cxt, ty, ds] -repDerivStrategy :: Maybe (Located DerivStrategy) - -> DsM (Core (Maybe TH.DerivStrategy)) +repDerivStrategy :: Maybe (LDerivStrategy GhcRn) + -> DsM (Core (Maybe TH.DerivStrategyQ)) repDerivStrategy mds = case mds of Nothing -> nothing Just (L _ ds) -> case ds of - StockStrategy -> just =<< dataCon stockStrategyDataConName - AnyclassStrategy -> just =<< dataCon anyclassStrategyDataConName - NewtypeStrategy -> just =<< dataCon newtypeStrategyDataConName + StockStrategy -> just =<< repStockStrategy + AnyclassStrategy -> just =<< repAnyclassStrategy + NewtypeStrategy -> just =<< repNewtypeStrategy + ViaStrategy ty -> do ty' <- repLTy (hsSigType ty) + via_strat <- repViaStrategy ty' + just via_strat where - nothing = coreNothing derivStrategyTyConName - just = coreJust derivStrategyTyConName + nothing = coreNothing derivStrategyQTyConName + just = coreJust derivStrategyQTyConName + +repStockStrategy :: DsM (Core TH.DerivStrategyQ) +repStockStrategy = rep2 stockStrategyName [] + +repAnyclassStrategy :: DsM (Core TH.DerivStrategyQ) +repAnyclassStrategy = rep2 anyclassStrategyName [] + +repNewtypeStrategy :: DsM (Core TH.DerivStrategyQ) +repNewtypeStrategy = rep2 newtypeStrategyName [] + +repViaStrategy :: Core TH.TypeQ -> DsM (Core TH.DerivStrategyQ) +repViaStrategy (MkC t) = rep2 viaStrategyName [t] repOverlap :: Maybe OverlapMode -> DsM (Core (Maybe TH.Overlap)) repOverlap mb = @@ -2104,13 +2220,13 @@ repOverlap mb = just = coreJust overlapTyConName -repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] +repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ] -> Core [TH.FunDep] -> Core [TH.DecQ] -> DsM (Core TH.DecQ) repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) = rep2 classDName [cxt, cls, tvs, fds, ds] -repDeriv :: Core (Maybe TH.DerivStrategy) +repDeriv :: Core (Maybe TH.DerivStrategyQ) -> Core TH.CxtQ -> Core TH.TypeQ -> DsM (Core TH.DecQ) repDeriv (MkC ds) (MkC cxt) (MkC ty) @@ -2149,22 +2265,22 @@ repTySynInst :: Core TH.Name -> Core TH.TySynEqnQ -> DsM (Core TH.DecQ) repTySynInst (MkC nm) (MkC eqn) = rep2 tySynInstDName [nm, eqn] -repDataFamilyD :: Core TH.Name -> Core [TH.TyVarBndr] - -> Core (Maybe TH.Kind) -> DsM (Core TH.DecQ) +repDataFamilyD :: Core TH.Name -> Core [TH.TyVarBndrQ] + -> Core (Maybe TH.KindQ) -> DsM (Core TH.DecQ) repDataFamilyD (MkC nm) (MkC tvs) (MkC kind) = rep2 dataFamilyDName [nm, tvs, kind] repOpenFamilyD :: Core TH.Name - -> Core [TH.TyVarBndr] - -> Core TH.FamilyResultSig + -> Core [TH.TyVarBndrQ] + -> Core TH.FamilyResultSigQ -> Core (Maybe TH.InjectivityAnn) -> DsM (Core TH.DecQ) repOpenFamilyD (MkC nm) (MkC tvs) (MkC result) (MkC inj) = rep2 openTypeFamilyDName [nm, tvs, result, inj] repClosedFamilyD :: Core TH.Name - -> Core [TH.TyVarBndr] - -> Core TH.FamilyResultSig + -> Core [TH.TyVarBndrQ] + -> Core TH.FamilyResultSigQ -> Core (Maybe TH.InjectivityAnn) -> Core [TH.TySynEqnQ] -> DsM (Core TH.DecQ) @@ -2184,6 +2300,9 @@ repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys] repProto :: Name -> Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ) repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty] +repImplicitParamBind :: Core String -> Core TH.ExpQ -> DsM (Core TH.DecQ) +repImplicitParamBind (MkC n) (MkC e) = rep2 implicitParamBindDName [n, e] + repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ) repCtxt (MkC tys) = rep2 cxtName [tys] @@ -2234,7 +2353,7 @@ repConstr (RecCon (L _ ips)) resTy cons rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip) rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> DsM (Core a) - rep_one_ip t n = do { MkC v <- lookupOcc (selectorFieldOcc $ unLoc n) + rep_one_ip t n = do { MkC v <- lookupOcc (extFieldOcc $ unLoc n) ; MkC ty <- repBangTy t ; rep2 varBangTypeName [v,ty] } @@ -2250,7 +2369,7 @@ repConstr _ _ _ = ------------ Types ------------------- -repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ +repTForall :: Core [TH.TyVarBndrQ] -> Core TH.CxtQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ) repTForall (MkC tvars) (MkC ctxt) (MkC ty) = rep2 forallTName [tvars, ctxt, ty] @@ -2265,7 +2384,7 @@ repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ) repTapps f [] = return f repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts } -repTSig :: Core TH.TypeQ -> Core TH.Kind -> DsM (Core TH.TypeQ) +repTSig :: Core TH.TypeQ -> Core TH.KindQ -> DsM (Core TH.TypeQ) repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki] repTequality :: DsM (Core TH.TypeQ) @@ -2285,6 +2404,15 @@ repTLit (MkC lit) = rep2 litTName [lit] repTWildCard :: DsM (Core TH.TypeQ) repTWildCard = rep2 wildCardTName [] +repTImplicitParam :: Core String -> Core TH.TypeQ -> DsM (Core TH.TypeQ) +repTImplicitParam (MkC n) (MkC e) = rep2 implicitParamTName [n, e] + +repTStar :: DsM (Core TH.TypeQ) +repTStar = rep2 starKName [] + +repTConstraint :: DsM (Core TH.TypeQ) +repTConstraint = rep2 constraintKName [] + --------- Type constructors -------------- repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ) @@ -2324,56 +2452,24 @@ repPromotedNilTyCon = rep2 promotedNilTName [] repPromotedConsTyCon :: DsM (Core TH.TypeQ) repPromotedConsTyCon = rep2 promotedConsTName [] ------------- Kinds ------------------- +------------ TyVarBndrs ------------------- -repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndr) +repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndrQ) repPlainTV (MkC nm) = rep2 plainTVName [nm] -repKindedTV :: Core TH.Name -> Core TH.Kind -> DsM (Core TH.TyVarBndr) +repKindedTV :: Core TH.Name -> Core TH.KindQ -> DsM (Core TH.TyVarBndrQ) repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki] -repKVar :: Core TH.Name -> DsM (Core TH.Kind) -repKVar (MkC s) = rep2 varKName [s] - -repKCon :: Core TH.Name -> DsM (Core TH.Kind) -repKCon (MkC s) = rep2 conKName [s] - -repKTuple :: Int -> DsM (Core TH.Kind) -repKTuple i = do dflags <- getDynFlags - rep2 tupleKName [mkIntExprInt dflags i] - -repKArrow :: DsM (Core TH.Kind) -repKArrow = rep2 arrowKName [] - -repKList :: DsM (Core TH.Kind) -repKList = rep2 listKName [] - -repKApp :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind) -repKApp (MkC k1) (MkC k2) = rep2 appKName [k1, k2] - -repKApps :: Core TH.Kind -> [Core TH.Kind] -> DsM (Core TH.Kind) -repKApps f [] = return f -repKApps f (k:ks) = do { f' <- repKApp f k; repKApps f' ks } - -repKStar :: DsM (Core TH.Kind) -repKStar = rep2 starKName [] - -repKConstraint :: DsM (Core TH.Kind) -repKConstraint = rep2 constraintKName [] - -repKSig :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind) -repKSig (MkC k) (MkC sort) = rep2 sigTDataConName [k, sort] - ---------------------------------------------------------- -- Type family result signature -repNoSig :: DsM (Core TH.FamilyResultSig) +repNoSig :: DsM (Core TH.FamilyResultSigQ) repNoSig = rep2 noSigName [] -repKindSig :: Core TH.Kind -> DsM (Core TH.FamilyResultSig) +repKindSig :: Core TH.KindQ -> DsM (Core TH.FamilyResultSigQ) repKindSig (MkC ki) = rep2 kindSigName [ki] -repTyVarSig :: Core TH.TyVarBndr -> DsM (Core TH.FamilyResultSig) +repTyVarSig :: Core TH.TyVarBndrQ -> DsM (Core TH.FamilyResultSigQ) repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr] ---------------------------------------------------------- @@ -2416,16 +2512,16 @@ repLiteral lit mk_integer :: Integer -> DsM (HsLit GhcRn) mk_integer i = do integer_ty <- lookupType integerTyConName - return $ HsInteger noSourceText i integer_ty + return $ HsInteger NoSourceText i integer_ty mk_rational :: FractionalLit -> DsM (HsLit GhcRn) mk_rational r = do rat_ty <- lookupType rationalTyConName - return $ HsRat def r rat_ty + return $ HsRat noExt r rat_ty mk_string :: FastString -> DsM (HsLit GhcRn) -mk_string s = return $ HsString noSourceText s +mk_string s = return $ HsString NoSourceText s mk_char :: Char -> DsM (HsLit GhcRn) -mk_char c = return $ HsChar noSourceText c +mk_char c = return $ HsChar NoSourceText c repOverloadedLiteral :: HsOverLit GhcRn -> DsM (Core TH.Lit) repOverloadedLiteral (OverLit { ol_val = val}) @@ -2433,6 +2529,7 @@ repOverloadedLiteral (OverLit { ol_val = val}) -- The type Rational will be in the environment, because -- the smart constructor 'TH.Syntax.rationalL' uses it in its type, -- and rationalL is sucked in when any TH stuff is used +repOverloadedLiteral XOverLit{} = panic "repOverloadedLiteral" mk_lit :: OverLitVal -> DsM (HsLit GhcRn) mk_lit (HsIntegral i) = mk_integer (il_value i) diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs index c3a29733be..921276e4d8 100644 --- a/compiler/deSugar/DsMonad.hs +++ b/compiler/deSugar/DsMonad.hs @@ -23,13 +23,9 @@ module DsMonad ( newUnique, UniqSupply, newUniqueSupply, getGhcModeDs, dsGetFamInstEnvs, - dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon, + dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon, dsLookupConLike, - PArrBuiltin(..), - dsLookupDPHRdrEnv, dsLookupDPHRdrEnv_maybe, - dsInitPArrBuiltin, - DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv, -- Getting and setting EvVars and term constraints in local environment @@ -49,9 +45,14 @@ module DsMonad ( CanItFail(..), orFail, -- Levity polymorphism - dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs + dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs, + + -- Trace injection + pprRuntimeTrace ) where +import GhcPrelude + import TcRnMonad import FamInstEnv import CoreSyn @@ -60,8 +61,6 @@ import CoreUtils ( exprType, isExprLevPoly ) import HsSyn import TcIface import TcMType ( checkForLevPolyX, formatLevPolyErr ) -import LoadIface -import Finder import PrelNames import RdrName import HscTypes @@ -81,13 +80,12 @@ import NameEnv import DynFlags import ErrUtils import FastString -import Maybes import Var (EvVar) -import qualified GHC.LanguageExtensions as LangExt import UniqFM ( lookupWithDefaultUFM ) +import Literal ( mkMachString ) +import CostCentreState import Data.IORef -import Control.Monad {- ************************************************************************ @@ -106,6 +104,9 @@ instance Outputable DsMatchContext where data EquationInfo = EqnInfo { eqn_pats :: [Pat GhcTc], -- The patterns for an eqn + -- NB: We have /already/ applied decideBangHood to + -- these patterns. See Note [decideBangHood] in DsUtils + eqn_rhs :: MatchResult } -- What to do after match instance Outputable EquationInfo where @@ -159,7 +160,7 @@ initDsTc thing_inside ; msg_var <- getErrsVar ; hsc_env <- getTopEnv ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env - ; setEnvs envs $ initDPH thing_inside + ; setEnvs envs thing_inside } -- | Run a 'DsM' action inside the 'IO' monad. @@ -176,6 +177,7 @@ mkDsEnvsFromTcGbl :: MonadIO m -> m (DsGblEnv, DsLclEnv) mkDsEnvsFromTcGbl hsc_env msg_var tcg_env = do { pm_iter_var <- liftIO $ newIORef 0 + ; cc_st_var <- liftIO $ newIORef newCostCentreState ; let dflags = hsc_dflags hsc_env this_mod = tcg_mod tcg_env type_env = tcg_type_env tcg_env @@ -184,13 +186,13 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env complete_matches = hptCompleteSigs hsc_env ++ tcg_complete_matches tcg_env ; return $ mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env - msg_var pm_iter_var complete_matches + msg_var pm_iter_var cc_st_var complete_matches } runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a) runDs hsc_env (ds_gbl, ds_lcl) thing_inside = do { res <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl - (initDPH $ tryM thing_inside) + (tryM thing_inside) ; msgs <- readIORef (ds_msgs ds_gbl) ; let final_res | errorsFound dflags msgs = Nothing @@ -204,6 +206,7 @@ runDs hsc_env (ds_gbl, ds_lcl) thing_inside initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a) initDsWithModGuts hsc_env guts thing_inside = do { pm_iter_var <- newIORef 0 + ; cc_st_var <- newIORef newCostCentreState ; msg_var <- newIORef emptyMessages ; let dflags = hsc_dflags hsc_env type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts) @@ -219,7 +222,7 @@ initDsWithModGuts hsc_env guts thing_inside envs = mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env msg_var pm_iter_var - complete_matches + cc_st_var complete_matches ; runDs hsc_env envs thing_inside } @@ -247,9 +250,9 @@ initTcDsForSolver thing_inside thing_inside } mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv - -> IORef Messages -> IORef Int -> [CompleteMatch] - -> (DsGblEnv, DsLclEnv) -mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar + -> IORef Messages -> IORef Int -> IORef CostCentreState + -> [CompleteMatch] -> (DsGblEnv, DsLclEnv) +mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar cc_st_var complete_matches = let if_genv = IfGblEnv { if_doc = text "mkDsEnvs", if_rec_types = Just (mod, return type_env) } @@ -262,9 +265,8 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar , ds_if_env = (if_genv, if_lenv) , ds_unqual = mkPrintUnqualified dflags rdr_env , ds_msgs = msg_var - , ds_dph_env = emptyGlobalRdrEnv - , ds_parr_bi = panic "DsMonad: uninitialised ds_parr_bi" , ds_complete_matches = completeMatchMap + , ds_cc_st = cc_st_var } lcl_env = DsLclEnv { dsl_meta = emptyNameEnv , dsl_loc = real_span @@ -490,23 +492,6 @@ mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where lookupThing = dsLookupGlobal --- | Attempt to load the given module and return its exported entities if --- successful. -dsLoadModule :: SDoc -> Module -> DsM GlobalRdrEnv -dsLoadModule doc mod - = do { env <- getGblEnv - ; setEnvs (ds_if_env env) $ do - { iface <- loadInterface doc mod ImportBySystem - ; case iface of - Failed err -> pprPanic "DsMonad.dsLoadModule: failed to load" (err $$ doc) - Succeeded iface -> return $ mkGlobalRdrEnv . gresFromAvails prov . mi_exports $ iface - } } - where - prov = Just (ImpSpec { is_decl = imp_spec, is_item = ImpAll }) - imp_spec = ImpDeclSpec { is_mod = name, is_qual = True, - is_dloc = wiredInSrcSpan, is_as = name } - name = moduleName mod - dsLookupGlobal :: Name -> DsM TyThing -- Very like TcEnv.tcLookupGlobal dsLookupGlobal name @@ -599,134 +584,30 @@ dsWhenNoErrs thing_inside mk_expr then mk_expr result else unitExpr } --------------------------------------------------------------------------- --- Data Parallel Haskell --------------------------------------------------------------------------- - --- | Run a 'DsM' with DPH things in scope if necessary. -initDPH :: DsM a -> DsM a -initDPH = loadDAP . initDPHBuiltins - --- | Extend the global environment with a 'GlobalRdrEnv' containing the exported --- entities of, +-- | Inject a trace message into the compiled program. Whereas +-- pprTrace prints out information *while compiling*, pprRuntimeTrace +-- captures that information and causes it to be printed *at runtime* +-- using Debug.Trace.trace. -- --- * 'Data.Array.Parallel' iff '-XParallelArrays' specified (see also 'checkLoadDAP'). --- * 'Data.Array.Parallel.Prim' iff '-fvectorise' specified. -loadDAP :: DsM a -> DsM a -loadDAP thing_inside - = do { dapEnv <- loadOneModule dATA_ARRAY_PARALLEL_NAME checkLoadDAP paErr - ; dappEnv <- loadOneModule dATA_ARRAY_PARALLEL_PRIM_NAME (goptM Opt_Vectorise) veErr - ; updGblEnv (\env -> env {ds_dph_env = dapEnv `plusOccEnv` dappEnv }) thing_inside - } - where - loadOneModule :: ModuleName -- the module to load - -> DsM Bool -- under which condition - -> MsgDoc -- error message if module not found - -> DsM GlobalRdrEnv -- empty if condition 'False' - loadOneModule modname check err - = do { doLoad <- check - ; if not doLoad - then return emptyGlobalRdrEnv - else do { - ; hsc_env <- getTopEnv - ; result <- liftIO $ findImportedModule hsc_env modname Nothing - ; case result of - Found _ mod -> dsLoadModule err mod - _ -> pprPgmError "Unable to use Data Parallel Haskell (DPH):" err - } } - - paErr = text "To use ParallelArrays," <+> specBackend $$ hint1 $$ hint2 - veErr = text "To use -fvectorise," <+> specBackend $$ hint1 $$ hint2 - specBackend = text "you must specify a DPH backend package" - hint1 = text "Look for packages named 'dph-lifted-*' with 'ghc-pkg'" - hint2 = text "You may need to install them with 'cabal install dph-examples'" - --- | If '-XParallelArrays' given, we populate the builtin table for desugaring --- those. -initDPHBuiltins :: DsM a -> DsM a -initDPHBuiltins thing_inside - = do { doInitBuiltins <- checkLoadDAP - ; if doInitBuiltins - then dsInitPArrBuiltin thing_inside - else thing_inside - } - -checkLoadDAP :: DsM Bool -checkLoadDAP - = do { paEnabled <- xoptM LangExt.ParallelArrays - ; mod <- getModule - -- do not load 'Data.Array.Parallel' iff compiling 'base:GHC.PArr' or a - -- module called 'dATA_ARRAY_PARALLEL_NAME'; see also the comments at the top - -- of 'base:GHC.PArr' and 'Data.Array.Parallel' in the DPH libraries - ; return $ paEnabled && - mod /= gHC_PARR' && - moduleName mod /= dATA_ARRAY_PARALLEL_NAME - } - --- | Populate 'ds_parr_bi' from 'ds_dph_env'. +-- pprRuntimeTrace hdr doc expr -- -dsInitPArrBuiltin :: DsM a -> DsM a -dsInitPArrBuiltin thing_inside - = do { lengthPVar <- externalVar (fsLit "lengthP") - ; replicatePVar <- externalVar (fsLit "replicateP") - ; singletonPVar <- externalVar (fsLit "singletonP") - ; mapPVar <- externalVar (fsLit "mapP") - ; filterPVar <- externalVar (fsLit "filterP") - ; zipPVar <- externalVar (fsLit "zipP") - ; crossMapPVar <- externalVar (fsLit "crossMapP") - ; indexPVar <- externalVar (fsLit "!:") - ; emptyPVar <- externalVar (fsLit "emptyP") - ; appPVar <- externalVar (fsLit "+:+") - -- ; enumFromToPVar <- externalVar (fsLit "enumFromToP") - -- ; enumFromThenToPVar <- externalVar (fsLit "enumFromThenToP") - ; enumFromToPVar <- return arithErr - ; enumFromThenToPVar <- return arithErr - - ; updGblEnv (\env -> env {ds_parr_bi = PArrBuiltin - { lengthPVar = lengthPVar - , replicatePVar = replicatePVar - , singletonPVar = singletonPVar - , mapPVar = mapPVar - , filterPVar = filterPVar - , zipPVar = zipPVar - , crossMapPVar = crossMapPVar - , indexPVar = indexPVar - , emptyPVar = emptyPVar - , appPVar = appPVar - , enumFromToPVar = enumFromToPVar - , enumFromThenToPVar = enumFromThenToPVar - } }) - thing_inside - } - where - externalVar :: FastString -> DsM Var - externalVar fs = dsLookupDPHRdrEnv (mkVarOccFS fs) >>= dsLookupGlobalId - - arithErr = panic "Arithmetic sequences have to wait until we support type classes" - --- |Get a name from "Data.Array.Parallel" for the desugarer, from the --- 'ds_parr_bi' component of the global desugerar environment. +-- will produce an expression that looks like -- -dsDPHBuiltin :: (PArrBuiltin -> a) -> DsM a -dsDPHBuiltin sel = (sel . ds_parr_bi) <$> getGblEnv - --- |Lookup a name exported by 'Data.Array.Parallel.Prim' or 'Data.Array.Parallel.Prim'. --- Panic if there isn't one, or if it is defined multiple times. -dsLookupDPHRdrEnv :: OccName -> DsM Name -dsLookupDPHRdrEnv occ - = liftM (fromMaybe (pprPanic nameNotFound (ppr occ))) - $ dsLookupDPHRdrEnv_maybe occ - where nameNotFound = "Name not found in 'Data.Array.Parallel' or 'Data.Array.Parallel.Prim':" - --- |Lookup a name exported by 'Data.Array.Parallel.Prim' or 'Data.Array.Parallel.Prim', --- returning `Nothing` if it's not defined. Panic if it's defined multiple times. -dsLookupDPHRdrEnv_maybe :: OccName -> DsM (Maybe Name) -dsLookupDPHRdrEnv_maybe occ - = do { env <- ds_dph_env <$> getGblEnv - ; let gres = lookupGlobalRdrEnv env occ - ; case gres of - [] -> return $ Nothing - [gre] -> return $ Just $ gre_name gre - _ -> pprPanic multipleNames (ppr occ) - } - where multipleNames = "Multiple definitions in 'Data.Array.Parallel' and 'Data.Array.Parallel.Prim':" +-- trace (hdr + doc) expr +-- +-- When using this to debug a module that Debug.Trace depends on, +-- it is necessary to import {-# SOURCE #-} Debug.Trace () in that +-- module. We could avoid this inconvenience by wiring in Debug.Trace.trace, +-- but that doesn't seem worth the effort and maintenance cost. +pprRuntimeTrace :: String -- ^ header + -> SDoc -- ^ information to output + -> CoreExpr -- ^ expression + -> DsM CoreExpr +pprRuntimeTrace str doc expr = do + traceId <- dsLookupGlobalId traceName + unpackCStringId <- dsLookupGlobalId unpackCStringName + dflags <- getDynFlags + let message :: CoreExpr + message = App (Var unpackCStringId) $ + Lit $ mkMachString $ showSDoc dflags (hang (text str) 4 doc) + return $ mkApps (Var traceId) [Type (exprType expr), message, expr] diff --git a/compiler/deSugar/DsUsage.hs b/compiler/deSugar/DsUsage.hs index 8158a8e122..58c31eee44 100644 --- a/compiler/deSugar/DsUsage.hs +++ b/compiler/deSugar/DsUsage.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE TupleSections #-} module DsUsage ( -- * Dependency/fingerprinting code (used by MkIface) @@ -7,6 +8,8 @@ module DsUsage ( #include "HsVersions.h" +import GhcPrelude + import DynFlags import HscTypes import TcRnTypes @@ -19,26 +22,54 @@ import UniqSet import UniqFM import Fingerprint import Maybes +import Packages +import Finder +import Control.Monad (filterM) import Data.List import Data.IORef import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Set as Set +import System.Directory +import System.FilePath + +{- Note [Module self-dependency] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +RnNames.calculateAvails asserts the invariant that a module must not occur in +its own dep_orphs or dep_finsts. However, if we aren't careful this can occur +in the presence of hs-boot files: Consider that we have two modules, A and B, +both with hs-boot files, + + A.hs contains a SOURCE import of B B.hs-boot contains a SOURCE import of A + A.hs-boot declares an orphan instance A.hs defines the orphan instance + +In this case, B's dep_orphs will contain A due to its SOURCE import of A. +Consequently, A will contain itself in its imp_orphs due to its import of B. +This fact would end up being recorded in A's interface file. This would then +break the invariant asserted by calculateAvails that a module does not itself in +its dep_orphs. This was the cause of Trac #14128. + +-} -- | Extract information from the rename and typecheck phases to produce -- a dependencies information for the module being compiled. -mkDependencies :: TcGblEnv -> IO Dependencies -mkDependencies - TcGblEnv{ tcg_mod = mod, +-- +-- The first argument is additional dependencies from plugins +mkDependencies :: InstalledUnitId -> [Module] -> TcGblEnv -> IO Dependencies +mkDependencies iuid pluginModules + (TcGblEnv{ tcg_mod = mod, tcg_imports = imports, tcg_th_used = th_var - } + }) = do -- Template Haskell used? + let (dep_plgins, ms) = unzip [ (moduleName mn, mn) | mn <- pluginModules ] + plugin_dep_pkgs = filter (/= iuid) (map (toInstalledUnitId . moduleUnitId) ms) th_used <- readIORef th_var let dep_mods = modDepsElts (delFromUFM (imp_dep_mods imports) - (moduleName mod)) + (moduleName mod)) -- M.hi-boot can be in the imp_dep_mods, but we must remove -- it before recording the modules on which this one depends! -- (We want to retain M.hi-boot in imp_dep_mods so that @@ -46,8 +77,14 @@ mkDependencies -- on M.hi-boot, and hence that we should do the hi-boot consistency -- check.) - pkgs | th_used = Set.insert (toInstalledUnitId thUnitId) (imp_dep_pkgs imports) - | otherwise = imp_dep_pkgs imports + dep_orphs = filter (/= mod) (imp_orphs imports) + -- We must also remove self-references from imp_orphs. See + -- Note [Module self-dependency] + + raw_pkgs = foldr Set.insert (imp_dep_pkgs imports) plugin_dep_pkgs + + pkgs | th_used = Set.insert (toInstalledUnitId thUnitId) raw_pkgs + | otherwise = raw_pkgs -- Set the packages required to be Safe according to Safe Haskell. -- See Note [RnNames . Tracking Trust Transitively] @@ -57,7 +94,8 @@ mkDependencies return Deps { dep_mods = dep_mods, dep_pkgs = dep_pkgs', - dep_orphs = sortBy stableModuleCmp (imp_orphs imports), + dep_orphs = dep_orphs, + dep_plgins = dep_plgins, dep_finsts = sortBy stableModuleCmp (imp_finsts imports) } -- sort to get into canonical order -- NB. remember to use lexicographic ordering @@ -65,11 +103,14 @@ mkDependencies mkUsedNames :: TcGblEnv -> NameSet mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus -mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath] -> [(Module, Fingerprint)] -> IO [Usage] +mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath] + -> [(Module, Fingerprint)] -> [ModIface] -> IO [Usage] mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files merged + pluginModules = do eps <- hscEPS hsc_env hashes <- mapM getFileHash dependent_files + plugin_usages <- mapM (mkPluginUsage hsc_env) pluginModules let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod dir_imp_mods used_names usages = mod_usages ++ [ UsageFile { usg_file_path = f @@ -80,11 +121,120 @@ mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files merged usg_mod_hash = hash } | (mod, hash) <- merged ] + ++ concat plugin_usages usages `seqList` return usages -- seq the list of Usages returned: occasionally these -- don't get evaluated for a while and we can end up hanging on to -- the entire collection of Ifaces. +{- Note [Plugin dependencies] +Modules for which plugins were used in the compilation process, should be +recompiled whenever one of those plugins changes. But how do we know if a +plugin changed from the previous time a module was compiled? + +We could try storing the fingerprints of the interface files of plugins in +the interface file of the module. And see if there are changes between +compilation runs. However, this is pretty much a non-option because interface +fingerprints of plugin modules are fairly stable, unless you compile plugins +with optimisations turned on, and give basically all binders an INLINE pragma. + +So instead: + + * For plugins that were build locally: we store the filepath and hash of the + object files of the module with the `plugin` binder, and the object files of + modules that are dependencies of the plugin module and belong to the same + `UnitId` as the plugin + * For plugins in an external package: we store the filepath and hash of + the dynamic library containing the plugin module. + +During recompilation we then compare the hashes of those files again to see +if anything has changed. + +One issue with this approach is that object files are currently (GHC 8.6.1) +not created fully deterministicly, which could sometimes induce accidental +recompilation of a module for which plugins were used in the compile process. + +One way to improve this is to either: + + * Have deterministic object file creation + * Create and store implementation hashes, which would be based on the Core + of the module and the implementation hashes of its dependencies, and then + compare implementation hashes for recompilation. Creation of implementation + hashes is however potentially expensive. +-} +mkPluginUsage :: HscEnv -> ModIface -> IO [Usage] +mkPluginUsage hsc_env pluginModule + = case lookupPluginModuleWithSuggestions dflags pNm Nothing of + -- The plug is from an external package, we just look up the dylib that + -- contains the plugin + LookupFound _ pkg -> do + let searchPaths = collectLibraryPaths dflags [pkg] + libs = packageHsLibs dflags pkg + dynlibLocs = [ searchPath </> mkHsSOName platform lib + | searchPath <- searchPaths + , lib <- libs + ] + dynlibs <- filterM doesFileExist dynlibLocs + case dynlibs of + [] -> pprPanic + ("mkPluginUsage: no dylibs, tried:\n" ++ unlines dynlibLocs) + (ppr pNm) + _ -> mapM hashFile (nub dynlibs) + _ -> do + foundM <- findPluginModule hsc_env pNm + case foundM of + -- The plugin was built locally, look up the object file containing + -- the `plugin` binder, and all object files belong to modules that are + -- transitive dependencies of the plugin that belong to the same package + Found ml _ -> do + pluginObject <- hashFile (ml_obj_file ml) + depObjects <- catMaybes <$> mapM lookupObjectFile deps + return (nub (pluginObject : depObjects)) + _ -> pprPanic "mkPluginUsage: no object or dylib" (ppr pNm) + where + -- plugins are shared libraries, so WayDyn should be part of the dflags in + -- order to get the correct filenames and library paths. + -- + -- We can distinguish two scenarios: + -- + -- 1. The dflags do not contain WayDyn, in this case we need to remove + -- all other ways and only add WayDyn. Why? Because other ways change + -- the library tags, i.e. WayProf adds `_p`, and we would end up looking + -- for a profiled plugin which might not be installed. See #15492 + -- + -- 2. The dflags do contain WayDyn, in this case we can leave the ways as + -- is, because the plugin must be compiled with the same ways as the + -- module that is currently being build, e.g., if the module is + -- build with WayDyn and WayProf, then the plugin that was used + -- would've also had to been build with WayProf (and WayDyn). + dflags1 = hsc_dflags hsc_env + dflags = if WayDyn `elem` ways dflags1 + then dflags1 + else updateWays (addWay' WayDyn (dflags1 {ways = []})) + platform = targetPlatform dflags + pNm = moduleName (mi_module pluginModule) + pPkg = moduleUnitId (mi_module pluginModule) + deps = map fst (dep_mods (mi_deps pluginModule)) + + -- loopup object file for a plugin dependencies from the same package as the + -- the plugin + lookupObjectFile nm = do + foundM <- findImportedModule hsc_env nm Nothing + case foundM of + Found ml m + | moduleUnitId m == pPkg -> Just <$> hashFile (ml_obj_file ml) + | otherwise -> return Nothing + _ -> pprPanic "mkPluginUsage: no object for dependency" + (ppr pNm <+> ppr nm) + + hashFile f = do + fExist <- doesFileExist f + if fExist + then do + h <- getFileHash f + return (UsageFile f h) + else pprPanic "mkPluginUsage: file not found" (ppr pNm <+> text f) + mk_mod_usage_info :: PackageIfaceTable -> HscEnv -> Module diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs index a1f3a143f3..001b36151c 100644 --- a/compiler/deSugar/DsUtils.hs +++ b/compiler/deSugar/DsUtils.hs @@ -9,6 +9,8 @@ This module exports some utility functions of no great interest. -} {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} -- | Utility functions for constructing Core syntax, principally for desugaring module DsUtils ( @@ -35,11 +37,14 @@ module DsUtils ( mkSelectorBinds, selectSimpleMatchVarL, selectMatchVars, selectMatchVar, - mkOptTickBox, mkBinaryTickBox, decideBangHood, addBang + mkOptTickBox, mkBinaryTickBox, decideBangHood, addBang, + isTrueLHsExpr ) where #include "HsVersions.h" +import GhcPrelude + import {-# SOURCE #-} Match ( matchSimply ) import {-# SOURCE #-} DsExpr ( dsLExpr ) @@ -93,6 +98,7 @@ otherwise, make one up. -} selectSimpleMatchVarL :: LPat GhcTc -> DsM Id +-- Postcondition: the returned Id has an Internal Name selectSimpleMatchVarL pat = selectMatchVar (unLoc pat) -- (selectMatchVars ps tys) chooses variables of type tys @@ -112,21 +118,22 @@ selectSimpleMatchVarL pat = selectMatchVar (unLoc pat) -- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat selectMatchVars :: [Pat GhcTc] -> DsM [Id] +-- Postcondition: the returned Ids have Internal Names selectMatchVars ps = mapM selectMatchVar ps selectMatchVar :: Pat GhcTc -> DsM Id -selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat) -selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat) -selectMatchVar (ParPat pat) = selectMatchVar (unLoc pat) -selectMatchVar (VarPat var) = return (localiseId (unLoc var)) +-- Postcondition: the returned Id has an Internal Name +selectMatchVar (BangPat _ pat) = selectMatchVar (unLoc pat) +selectMatchVar (LazyPat _ pat) = selectMatchVar (unLoc pat) +selectMatchVar (ParPat _ pat) = selectMatchVar (unLoc pat) +selectMatchVar (VarPat _ var) = return (localiseId (unLoc var)) -- Note [Localise pattern binders] -selectMatchVar (AsPat var _) = return (unLoc var) -selectMatchVar other_pat = newSysLocalDsNoLP (hsPatType other_pat) +selectMatchVar (AsPat _ var _) = return (unLoc var) +selectMatchVar other_pat = newSysLocalDsNoLP (hsPatType other_pat) -- OK, better make up one... -{- -Note [Localise pattern binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Localise pattern binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider module M where [Just a] = e After renaming it looks like @@ -162,6 +169,7 @@ In fact, even CoreSubst.simplOptExpr will do this, and simpleOptExpr runs on the output of the desugarer, so all is well by the end of the desugaring pass. +See also Note [MatchIds] in Match.hs ************************************************************************ * * @@ -278,18 +286,15 @@ data CaseAlt a = MkCaseAlt{ alt_pat :: a, alt_result :: MatchResult } mkCoAlgCaseMatchResult - :: DynFlags - -> Id -- Scrutinee + :: Id -- Scrutinee -> Type -- Type of exp -> [CaseAlt DataCon] -- Alternatives (bndrs *include* tyvars, dicts) -> MatchResult -mkCoAlgCaseMatchResult dflags var ty match_alts +mkCoAlgCaseMatchResult var ty match_alts | isNewtype -- Newtype case; use a let = ASSERT( null (tail match_alts) && null (tail arg_ids1) ) mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1 - | isPArrFakeAlts match_alts - = MatchResult CanFail $ mkPArrCase dflags var ty (sort_alts match_alts) | otherwise = mkDataConCase var ty match_alts where @@ -307,34 +312,6 @@ mkCoAlgCaseMatchResult dflags var ty match_alts -- (not that splitTyConApp does, these days) newtype_rhs = unwrapNewTypeBody tc ty_args (Var var) - --- Stuff for parallel arrays - -- - -- Concerning `isPArrFakeAlts': - -- - -- * it is *not* sufficient to just check the type of the type - -- constructor, as we have to be careful not to confuse the real - -- representation of parallel arrays with the fake constructors; - -- moreover, a list of alternatives must not mix fake and real - -- constructors (this is checked earlier on) - -- - -- FIXME: We actually go through the whole list and make sure that - -- either all or none of the constructors are fake parallel - -- array constructors. This is to spot equations that mix fake - -- constructors with the real representation defined in - -- `PrelPArr'. It would be nicer to spot this situation - -- earlier and raise a proper error message, but it can really - -- only happen in `PrelPArr' anyway. - -- - - isPArrFakeAlts :: [CaseAlt DataCon] -> Bool - isPArrFakeAlts [alt] = isPArrFakeCon (alt_pat alt) - isPArrFakeAlts (alt:alts) = - case (isPArrFakeCon (alt_pat alt), isPArrFakeAlts alts) of - (True , True ) -> True - (False, False) -> False - _ -> panic "DsUtils: you may not mix `[:...:]' with `PArr' patterns" - isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives" - mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult mkCoSynCaseMatchResult var ty alt = MatchResult CanFail $ mkPatSynCase var ty alt @@ -344,7 +321,7 @@ sort_alts = sortWith (dataConTag . alt_pat) mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr mkPatSynCase var ty alt fail = do matcher <- dsLExpr $ mkLHsWrap wrapper $ - nlHsTyApp matcher [getRuntimeRep "mkPatSynCase" ty, ty] + nlHsTyApp matcher [getRuntimeRep ty, ty] let MatchResult _ mkCont = match_result cont <- mkCoreLams bndrs <$> mkCont fail return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail] @@ -408,49 +385,6 @@ mkDataConCase var ty alts@(alt1:_) = MatchResult fail_flag mk_case = mkUniqSet data_cons `minusUniqSet` mentioned_constructors exhaustive_case = isEmptyUniqSet un_mentioned_constructors ---- Stuff for parallel arrays --- --- * the following is to desugar cases over fake constructors for --- parallel arrays, which are introduced by `tidy1' in the `PArrPat' --- case --- -mkPArrCase :: DynFlags -> Id -> Type -> [CaseAlt DataCon] -> CoreExpr - -> DsM CoreExpr -mkPArrCase dflags var ty sorted_alts fail = do - lengthP <- dsDPHBuiltin lengthPVar - alt <- unboxAlt - return (mkWildCase (len lengthP) intTy ty [alt]) - where - elemTy = case splitTyConApp (idType var) of - (_, [elemTy]) -> elemTy - _ -> panic panicMsg - panicMsg = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?" - len lengthP = mkApps (Var lengthP) [Type elemTy, Var var] - -- - unboxAlt = do - l <- newSysLocalDs intPrimTy - indexP <- dsDPHBuiltin indexPVar - alts <- mapM (mkAlt indexP) sorted_alts - return (DataAlt intDataCon, [l], mkWildCase (Var l) intPrimTy ty (dft : alts)) - where - dft = (DEFAULT, [], fail) - - -- - -- each alternative matches one array length (corresponding to one - -- fake array constructor), so the match is on a literal; each - -- alternative's body is extended by a local binding for each - -- constructor argument, which are bound to array elements starting - -- with the first - -- - mkAlt indexP alt@MkCaseAlt{alt_result = MatchResult _ bodyFun} = do - body <- bodyFun fail - return (LitAlt lit, [], mkCoreLets binds body) - where - lit = MachInt $ toInteger (dataConSourceArity (alt_pat alt)) - binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] (alt_bndrs alt)] - -- - indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr dflags i] - {- ************************************************************************ * * @@ -471,7 +405,7 @@ mkErrorAppDs err_id ty msg = do full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg]) core_msg = Lit (mkMachString full_msg) -- mkMachString returns a result of type String# - return (mkApps (Var err_id) [Type (getRuntimeRep "mkErrorAppDs" ty), Type ty, core_msg]) + return (mkApps (Var err_id) [Type (getRuntimeRep ty), Type ty, core_msg]) {- 'mkCoreAppDs' and 'mkCoreAppsDs' hand the special-case desugaring of 'seq'. @@ -556,7 +490,7 @@ mkCoreAppDs s fun arg = mkCoreApp s fun arg -- The rest is done in MkCore -- NB: No argument can be levity polymorphic mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr -mkCoreAppsDs s fun args = foldl (mkCoreAppDs s) fun args +mkCoreAppsDs s fun args = foldl' (mkCoreAppDs s) fun args mkCastDs :: CoreExpr -> Coercion -> CoreExpr -- We define a desugarer-specific version of CoreUtils.mkCast, @@ -734,7 +668,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) + | L _ (VarPat _ (L _ v)) <- pat' -- Special case (A) = return (v, [(v, val_expr)]) | is_flat_prod_lpat pat' -- Special case (B) @@ -758,7 +692,7 @@ mkSelectorBinds ticks pat val_expr | otherwise -- General case (C) = do { tuple_var <- newSysLocalDs tuple_ty - ; error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (ppr pat') + ; error_expr <- mkErrorAppDs pAT_ERROR_ID tuple_ty (ppr pat') ; tuple_expr <- matchSimply val_expr PatBindRhs pat local_tuple error_expr ; let mk_tup_bind tick binder @@ -781,17 +715,17 @@ mkSelectorBinds ticks pat val_expr strip_bangs :: LPat a -> LPat a -- 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 (L _ (ParPat _ p)) = strip_bangs p +strip_bangs (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_pat :: Pat a -> 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 (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}) | RealDataCon con <- pcon , isProductTyCon (dataConTyCon con) = all is_triv_lpat (hsConPatArgs ps) @@ -801,10 +735,10 @@ is_triv_lpat :: LPat a -> Bool is_triv_lpat p = is_triv_pat (unLoc p) is_triv_pat :: Pat a -> Bool -is_triv_pat (VarPat _) = True -is_triv_pat (WildPat _) = True -is_triv_pat (ParPat p) = is_triv_lpat p -is_triv_pat _ = False +is_triv_pat (VarPat {}) = True +is_triv_pat (WildPat{}) = True +is_triv_pat (ParPat _ p) = is_triv_lpat p +is_triv_pat _ = False {- ********************************************************************* @@ -826,7 +760,7 @@ mkLHsVarPatTup bs = mkLHsPatTup (map nlVarPat bs) mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc -- A vanilla tuple pattern simply gets its type from its sub-patterns -mkVanillaTuplePat pats box = TuplePat pats box (map hsLPatType pats) +mkVanillaTuplePat pats box = TuplePat (map hsLPatType pats) pats box -- The Big equivalents for the source tuple expressions mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc @@ -973,16 +907,41 @@ mkBinaryTickBox ixT ixF e = do -- ******************************************************************* +{- Note [decideBangHood] +~~~~~~~~~~~~~~~~~~~~~~~~ +With -XStrict we may make /outermost/ patterns more strict. +E.g. + let (Just x) = e in ... + ==> + let !(Just x) = e in ... +and + f x = e + ==> + f !x = e + +This adjustment is done by decideBangHood, + + * Just before constructing an EqnInfo, in Match + (matchWrapper and matchSinglePat) + + * When desugaring a pattern-binding in DsBinds.dsHsBind + +Note that it is /not/ done recursively. See the -XStrict +spec in the user manual. + +Specifically: + ~pat => pat -- when -XStrict (even if pat = ~pat') + !pat => !pat -- always + pat => !pat -- when -XStrict + pat => pat -- otherwise +-} + + -- | Use -XStrict to add a ! or remove a ~ --- --- Examples: --- ~pat => pat -- when -XStrict (even if pat = ~pat') --- !pat => !pat -- always --- pat => !pat -- when -XStrict --- pat => pat -- otherwise +-- See Note [decideBangHood] decideBangHood :: DynFlags - -> LPat id -- ^ Original pattern - -> LPat id -- Pattern with bang if necessary + -> LPat GhcTc -- ^ Original pattern + -> LPat GhcTc -- Pattern with bang if necessary decideBangHood dflags lpat | not (xopt LangExt.Strict dflags) = lpat @@ -991,19 +950,49 @@ decideBangHood dflags lpat where go lp@(L l p) = case p of - ParPat p -> L l (ParPat (go p)) - LazyPat lp' -> lp' - BangPat _ -> lp - _ -> L l (BangPat lp) + ParPat x p -> L l (ParPat x (go p)) + LazyPat _ lp' -> lp' + BangPat _ _ -> lp + _ -> L l (BangPat noExt lp) -- | Unconditionally make a 'Pat' strict. -addBang :: LPat id -- ^ Original pattern - -> LPat id -- ^ Banged pattern +addBang :: LPat GhcTc -- ^ Original pattern + -> LPat GhcTc -- ^ Banged pattern addBang = go where go lp@(L l p) = case p of - ParPat p -> L l (ParPat (go p)) - LazyPat lp' -> L l (BangPat lp') - BangPat _ -> lp - _ -> L l (BangPat lp) + ParPat x p -> L l (ParPat x (go p)) + LazyPat _ lp' -> L l (BangPat noExt lp') + -- Should we bring the extension value over? + BangPat _ _ -> lp + _ -> L l (BangPat noExt lp) + +isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr) + +-- Returns Just {..} if we're sure that the expression is True +-- I.e. * 'True' datacon +-- * 'otherwise' Id +-- * 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 + = Just return + -- trueDataConId doesn't have the same unique as trueDataCon +isTrueLHsExpr (L _ (HsConLikeOut _ con)) + | con `hasKey` getUnique trueDataCon = Just return +isTrueLHsExpr (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)) + | 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 _ = Nothing diff --git a/compiler/deSugar/ExtractDocs.hs b/compiler/deSugar/ExtractDocs.hs new file mode 100644 index 0000000000..fc57f98569 --- /dev/null +++ b/compiler/deSugar/ExtractDocs.hs @@ -0,0 +1,344 @@ +-- | Extract docs from the renamer output so they can be be serialized. +{-# language LambdaCase #-} +{-# language TypeFamilies #-} +module ExtractDocs (extractDocs) where + +import GhcPrelude +import Bag +import HsBinds +import HsDoc +import HsDecls +import HsExtension +import HsTypes +import HsUtils +import Name +import NameSet +import SrcLoc +import TcRnTypes + +import Control.Applicative +import Data.List +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe +import Data.Semigroup + +-- | Extract docs from renamer output. +extractDocs :: TcGblEnv + -> (Maybe HsDocString, DeclDocMap, ArgDocMap) + -- ^ + -- 1. Module header + -- 2. Docs on top level declarations + -- 3. Docs on arguments +extractDocs TcGblEnv { tcg_semantic_mod = mod + , tcg_rn_decls = mb_rn_decls + , tcg_insts = insts + , tcg_fam_insts = fam_insts + , tcg_doc_hdr = mb_doc_hdr + } = + (unLoc <$> mb_doc_hdr, DeclDocMap doc_map, ArgDocMap arg_map) + where + (doc_map, arg_map) = maybe (M.empty, M.empty) + (mkMaps local_insts) + mb_decls_with_docs + mb_decls_with_docs = topDecls <$> mb_rn_decls + local_insts = filter (nameIsLocalOrFrom mod) + $ map getName insts ++ map getName fam_insts + +-- | Create decl and arg doc-maps by looping through the declarations. +-- For each declaration, find its names, its subordinates, and its doc strings. +mkMaps :: [Name] + -> [(LHsDecl GhcRn, [HsDocString])] + -> (Map Name (HsDocString), Map Name (Map Int (HsDocString))) +mkMaps instances decls = + ( f' (map (nubByName fst) decls') + , f (filterMapping (not . M.null) args) + ) + where + (decls', args) = unzip (map mappings decls) + + f :: (Ord a, Semigroup b) => [[(a, b)]] -> Map a b + f = M.fromListWith (<>) . concat + + f' :: Ord a => [[(a, HsDocString)]] -> Map a HsDocString + f' = M.fromListWith appendDocs . concat + + filterMapping :: (b -> Bool) -> [[(a, b)]] -> [[(a, b)]] + filterMapping p = map (filter (p . snd)) + + mappings :: (LHsDecl GhcRn, [HsDocString]) + -> ( [(Name, HsDocString)] + , [(Name, Map Int (HsDocString))] + ) + mappings (L l decl, docStrs) = + (dm, am) + where + doc = concatDocs docStrs + args = declTypeDocs decl + + subs :: [(Name, [(HsDocString)], Map Int (HsDocString))] + subs = subordinates instanceMap decl + + (subDocs, subArgs) = + unzip (map (\(_, strs, m) -> (concatDocs strs, m)) subs) + + ns = names l decl + subNs = [ n | (n, _, _) <- subs ] + dm = [(n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs] + am = [(n, args) | n <- ns] ++ zip subNs subArgs + + instanceMap :: Map SrcSpan Name + instanceMap = M.fromList [(getSrcSpan n, n) | n <- instances] + + names :: SrcSpan -> HsDecl GhcRn -> [Name] + names l (InstD _ d) = maybeToList (M.lookup loc instanceMap) -- See + -- Note [1]. + where loc = case d of + TyFamInstD _ _ -> l -- The CoAx's loc is the whole line, but only + -- for TFs + _ -> getInstLoc d + names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See Note [1]. + names _ decl = getMainDeclBinder decl + +{- +Note [1]: +--------- +We relate ClsInsts to InstDecls and DerivDecls using the SrcSpans buried +inside them. That should work for normal user-written instances (from +looking at GHC sources). We can assume that commented instances are +user-written. This lets us relate Names (from ClsInsts) to comments +(associated with InstDecls and DerivDecls). +-} + +getMainDeclBinder :: HsDecl pass -> [IdP pass] +getMainDeclBinder (TyClD _ d) = [tcdName d] +getMainDeclBinder (ValD _ d) = + case collectHsBindBinders d of + [] -> [] + (name:_) -> [name] +getMainDeclBinder (SigD _ d) = sigNameNoLoc d +getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name] +getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = [] +getMainDeclBinder _ = [] + +sigNameNoLoc :: Sig pass -> [IdP pass] +sigNameNoLoc (TypeSig _ ns _) = map unLoc ns +sigNameNoLoc (ClassOpSig _ _ ns _) = map unLoc ns +sigNameNoLoc (PatSynSig _ ns _) = map unLoc ns +sigNameNoLoc (SpecSig _ n _ _) = [unLoc n] +sigNameNoLoc (InlineSig _ n _) = [unLoc n] +sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map unLoc ns +sigNameNoLoc _ = [] + +-- Extract the source location where an instance is defined. This is used +-- to correlate InstDecls with their Instance/CoAxiom Names, via the +-- instanceMap. +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 + 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 + ClsInstD _ (XClsInstDecl _) -> error "getInstLoc" + DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc" + TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc" + XInstDecl _ -> error "getInstLoc" + DataFamInstD _ (DataFamInstDecl (XHsImplicitBndrs _)) -> error "getInstLoc" + TyFamInstD _ (TyFamInstDecl (XHsImplicitBndrs _)) -> error "getInstLoc" + +-- | Get all subordinate declarations inside a declaration, and their docs. +-- A subordinate declaration is something like the associate type or data +-- family of a type class. +subordinates :: Map SrcSpan Name + -> HsDecl GhcRn + -> [(Name, [(HsDocString)], Map Int (HsDocString))] +subordinates instMap decl = case decl of + InstD _ (ClsInstD _ d) -> do + DataFamInstDecl { dfid_eqn = HsIB { hsib_body = + FamEqn { feqn_tycon = L l _ + , feqn_rhs = defn }}} <- unLoc <$> cid_datafam_insts d + [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn + + InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = d }))) + -> dataSubs (feqn_rhs d) + TyClD _ d | isClassDecl d -> classSubs d + | isDataDecl d -> dataSubs (tcdDataDefn d) + _ -> [] + where + classSubs dd = [ (name, doc, declTypeDocs d) | (L _ d, doc) <- classDecls dd + , name <- getMainDeclBinder d, not (isValD d) + ] + dataSubs :: HsDataDefn GhcRn + -> [(Name, [HsDocString], Map Int (HsDocString))] + dataSubs dd = constrs ++ fields ++ derivs + where + cons = map unLoc $ (dd_cons dd) + constrs = [ ( unLoc cname + , maybeToList $ fmap unLoc $ con_doc c + , conArgDocs c) + | 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 ] + derivs = [ (instName, [unLoc doc], M.empty) + | HsIB { hsib_body = L l (HsDocTy _ _ doc) } + <- concatMap (unLoc . deriv_clause_tys . unLoc) $ + unLoc $ dd_derivs dd + , Just instName <- [M.lookup l instMap] ] + +-- | Extract constructor argument docs from inside constructor decls. +conArgDocs :: ConDecl GhcRn -> Map Int (HsDocString) +conArgDocs con = case getConArgs con of + PrefixCon args -> go 0 (map unLoc args ++ ret) + 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 (_ : tys) = go (n+1) tys + go _ [] = M.empty + + ret = case con of + ConDeclGADT { con_res_ty = res_ty } -> [ unLoc res_ty ] + _ -> [] + +isValD :: HsDecl a -> Bool +isValD (ValD _ _) = True +isValD _ = False + +-- | All the sub declarations of a class (that we handle), ordered by +-- source location, with documentation attached if it exists. +classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])] +classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls + where + decls = docs ++ defs ++ sigs ++ ats + docs = mkDecls tcdDocs (DocD noExt) class_ + defs = mkDecls (bagToList . tcdMeths) (ValD noExt) class_ + sigs = mkDecls tcdSigs (SigD noExt) class_ + ats = mkDecls tcdATs (TyClD noExt . FamDecl noExt) class_ + +-- | Extract function argument docs from inside top-level decls. +declTypeDocs :: HsDecl GhcRn -> Map Int (HsDocString) +declTypeDocs = \case + SigD _ (TypeSig _ _ ty) -> typeDocs (unLoc (hsSigWcType ty)) + SigD _ (ClassOpSig _ _ _ ty) -> typeDocs (unLoc (hsSigType ty)) + SigD _ (PatSynSig _ _ ty) -> typeDocs (unLoc (hsSigType ty)) + ForD _ (ForeignImport _ _ ty _) -> typeDocs (unLoc (hsSigType ty)) + TyClD _ (SynDecl { tcdRhs = ty }) -> typeDocs (unLoc ty) + _ -> M.empty + +nubByName :: (a -> Name) -> [a] -> [a] +nubByName f ns = go emptyNameSet ns + where + go _ [] = [] + go s (x:xs) + | y `elemNameSet` s = go s xs + | otherwise = let s' = extendNameSet s y + in x : go s' xs + where + y = f x + +-- | Extract function argument docs from inside types. +typeDocs :: HsType GhcRn -> Map Int (HsDocString) +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)) = + 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 _ _ = M.empty + +-- | The top-level declarations of a module that we care about, +-- ordered by source location, with documentation attached if it exists. +topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])] +topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup + +-- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. +ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn] +ungroup group_ = + mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExt) group_ ++ + mkDecls hs_derivds (DerivD noExt) group_ ++ + mkDecls hs_defds (DefD noExt) group_ ++ + mkDecls hs_fords (ForD noExt) group_ ++ + mkDecls hs_docs (DocD noExt) group_ ++ + mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExt) group_ ++ + mkDecls (typesigs . hs_valds) (SigD noExt) group_ ++ + mkDecls (valbinds . hs_valds) (ValD noExt) group_ + where + typesigs (XValBindsLR (NValBinds _ sigs)) = filter (isUserSig . unLoc) sigs + typesigs _ = error "expected ValBindsOut" + + valbinds (XValBindsLR (NValBinds binds _)) = + concatMap bagToList . snd . unzip $ binds + valbinds _ = error "expected ValBindsOut" + +-- | Sort by source location +sortByLoc :: [Located a] -> [Located a] +sortByLoc = sortOn getLoc + +-- | Collect docs and attach them to the right declarations. +-- +-- A declaration may have multiple doc strings attached to it. +collectDocs :: [LHsDecl pass] -> [(LHsDecl pass, [HsDocString])] +-- ^ This is an example. +collectDocs = go Nothing [] + where + go Nothing _ [] = [] + go (Just prev) docs [] = finished prev docs [] + go prev docs (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 (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) + + finished decl docs rest = (decl, reverse docs) : rest + +-- | Filter out declarations that we don't handle in Haddock +filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] +filterDecls = filter (isHandled . unLoc . fst) + where + isHandled (ForD _ (ForeignImport {})) = True + isHandled (TyClD {}) = True + isHandled (InstD {}) = True + isHandled (DerivD {}) = True + isHandled (SigD _ d) = isUserSig d + isHandled (ValD {}) = True + -- we keep doc declarations to be able to get at named docs + isHandled (DocD {}) = True + isHandled _ = False + + +-- | 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 ] + where + filterClass (TyClD x c) = + TyClD x $ c { tcdSigs = + filter (liftA2 (||) (isUserSig . unLoc) isMinimalLSig) (tcdSigs c) } + filterClass _ = error "expected TyClD" + +-- | Was this signature given by the user? +isUserSig :: Sig name -> Bool +isUserSig TypeSig {} = True +isUserSig ClassOpSig {} = True +isUserSig PatSynSig {} = True +isUserSig _ = False + +isClassD :: HsDecl a -> Bool +isClassD (TyClD _ d) = isClassDecl d +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 ] diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs index a870c6f9c3..ec982f6b25 100644 --- a/compiler/deSugar/Match.hs +++ b/compiler/deSugar/Match.hs @@ -9,10 +9,13 @@ The @match@ function {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} -module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where +module Match ( match, matchEquations, matchWrapper, matchSimply + , matchSinglePat, matchSinglePatVar ) where #include "HsVersions.h" +import GhcPrelude + import {-#SOURCE#-} DsExpr (dsLExpr, dsSyntaxExpr) import DynFlags @@ -37,7 +40,6 @@ import MatchCon import MatchLit import Type import Coercion ( eqCoercion ) -import TcType ( toTcTypeBag ) import TyCon( isNewTyCon ) import TysWiredIn import SrcLoc @@ -51,8 +53,8 @@ import Unique import UniqDFM import Control.Monad( when, unless ) +import Data.List ( groupBy ) import qualified Data.Map as Map -import Data.List (groupBy) {- ************************************************************************ @@ -61,7 +63,8 @@ import Data.List (groupBy) * * ************************************************************************ -The function @match@ is basically the same as in the Wadler chapter, +The function @match@ is basically the same as in the Wadler chapter +from "The Implementation of Functional Programming Languages", except it is monadised, to carry around the name supply, info about annotations, etc. @@ -123,40 +126,25 @@ patterns that is examined. The steps carried out are roughly: \item Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add bindings to the second component of the equation-info): -\begin{itemize} -\item -Remove the `as' patterns from column~1. -\item -Make all constructor patterns in column~1 into @ConPats@, notably -@ListPats@ and @TuplePats@. -\item -Handle any irrefutable (or ``twiddle'') @LazyPats@. -\end{itemize} \item Now {\em unmix} the equations into {\em blocks} [w\/ local function -@unmix_eqns@], in which the equations in a block all have variable -patterns in column~1, or they all have constructor patterns in ... +@match_groups@], in which the equations in a block all have the same + match group. (see ``the mixture rule'' in SLPJ). \item -Call @matchEqnBlock@ on each block of equations; it will do the -appropriate thing for each kind of column-1 pattern, usually ending up -in a recursive call to @match@. +Call the right match variant on each block of equations; it will do the +appropriate thing for each kind of column-1 pattern. \end{enumerate} We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87) than the Wadler-chapter code for @match@ (p.~93, first @match@ clause). And gluing the ``success expressions'' together isn't quite so pretty. -This (more interesting) clause of @match@ uses @tidy_and_unmix_eqns@ -(a)~to get `as'- and `twiddle'-patterns out of the way (tidying), and -(b)~to do ``the mixture rule'' (SLPJ, p.~88) [which really {\em +This @match@ uses @tidyEqnInfo@ +to get `as'- and `twiddle'-patterns out of the way (tidying), before +applying ``the mixture rule'' (SLPJ, p.~88) [which really {\em un}mixes the equations], producing a list of equation-info -blocks, each block having as its first column of patterns either all -constructors, or all variables (or similar beasts), etc. - -@match_unmixed_eqn_blks@ simply takes the place of the @foldr@ in the -Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@ -corresponds roughly to @matchVarCon@. +blocks, each block having as its first column patterns compatible with each other. Note [Match Ids] ~~~~~~~~~~~~~~~~ @@ -165,6 +153,8 @@ is the scrutinee(s) of the match. The desugared expression may sometimes use that Id in a local binding or as a case binder. So it should not have an External name; Lint rejects non-top-level binders with External names (Trac #13043). + +See also Note [Localise pattern binders] in DsUtils -} type MatchId = Id -- See Note [Match Ids] @@ -263,7 +253,7 @@ matchBangs [] _ _ = panic "matchBangs" matchCoercion :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult -- Apply the coercion to the match variable and then match that matchCoercion (var:vars) ty (eqns@(eqn1:_)) - = do { let CoPat co pat _ = firstPat eqn1 + = do { let CoPat _ co pat _ = firstPat eqn1 ; let pat_ty' = hsPatType pat ; var' <- newUniqueId var pat_ty' ; match_result <- match (var':vars) ty $ @@ -279,7 +269,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 (L _ pat) = firstPat eqn1 -- do the rest of the compilation ; let pat_ty' = hsPatType pat ; var' <- newUniqueId var pat_ty' @@ -296,7 +286,7 @@ matchOverloadedList :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult matchOverloadedList (var:vars) ty (eqns@(eqn1:_)) -- Since overloaded list patterns are treated as view patterns, -- the code is roughly the same as for matchView - = do { let ListPat _ elt_ty (Just (_,e)) = firstPat eqn1 + = do { let ListPat (ListPatTc elt_ty (Just (_,e))) _ = firstPat eqn1 ; var' <- newUniqueId var (mkListTy elt_ty) -- we construct the overall type by hand ; match_result <- match (var':vars) ty $ map (decomposeFirstPat getOLPat) eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern @@ -311,13 +301,14 @@ decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats })) decomposeFirstPat _ _ = panic "decomposeFirstPat" getCoPat, getBangPat, getViewPat, getOLPat :: Pat GhcTc -> Pat GhcTc -getCoPat (CoPat _ pat _) = pat +getCoPat (CoPat _ _ pat _) = pat getCoPat _ = panic "getCoPat" -getBangPat (BangPat pat ) = unLoc pat +getBangPat (BangPat _ pat ) = unLoc pat getBangPat _ = panic "getBangPat" -getViewPat (ViewPat _ pat _) = unLoc pat +getViewPat (ViewPat _ _ pat) = unLoc pat getViewPat _ = panic "getViewPat" -getOLPat (ListPat pats ty (Just _)) = ListPat pats ty Nothing +getOLPat (ListPat (ListPatTc ty (Just _)) pats) + = ListPat (ListPatTc ty Nothing) pats getOLPat _ = panic "getOLPat" {- @@ -346,39 +337,40 @@ See also Note [Case elimination: lifted case] in Simplify. ************************************************************************ Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@ -which will be scrutinised. This means: -\begin{itemize} -\item -Replace variable patterns @x@ (@x /= v@) with the pattern @_@, -together with the binding @x = v@. -\item -Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@. -\item -Removing lazy (irrefutable) patterns (you don't want to know...). -\item -Converting explicit tuple-, list-, and parallel-array-pats into ordinary -@ConPats@. -\item -Convert the literal pat "" to []. -\end{itemize} +which will be scrutinised. -The result of this tidying is that the column of patterns will include -{\em only}: -\begin{description} -\item[@WildPats@:] -The @VarPat@ information isn't needed any more after this. +This makes desugaring the pattern match simpler by transforming some of +the patterns to simpler forms. (Tuples to Constructor Patterns) -\item[@ConPats@:] -@ListPats@, @TuplePats@, etc., are all converted into @ConPats@. +Among other things in the resulting Pattern: +* Variables and irrefutable(lazy) patterns are replaced by Wildcards +* As patterns are replaced by the patterns they wrap. + +The bindings created by the above patterns are put into the returned wrapper +instead. + +This means a definition of the form: + f x = rhs +when called with v get's desugared to the equivalent of: + let x = v + in + f _ = rhs + +The same principle holds for as patterns (@) and +irrefutable/lazy patterns (~). +In the case of irrefutable patterns the irrefutable pattern is pushed into +the binding. + +Pattern Constructors which only represent syntactic sugar are converted into +their desugared representation. +This usually means converting them to Constructor patterns but for some +depends on enabled extensions. (Eg OverloadedLists) + +GHC also tries to convert overloaded Literals into regular ones. + +The result of this tidying is that the column of patterns will include +only these which can be assigned a PatternGroup (see patGroup). -\item[@LitPats@ and @NPats@:] -@LitPats@/@NPats@ of ``known friendly types'' (Int, Char, -Float, Double, at least) are converted to unboxed form; e.g., -\tr{(NPat (HsInt i) _ _)} is converted to: -\begin{verbatim} -(ConPat I# _ _ [LitPat (HsIntPrim i)]) -\end{verbatim} -\end{description} -} tidyEqnInfo :: Id -> EquationInfo @@ -389,12 +381,7 @@ tidyEqnInfo :: Id -> EquationInfo -- one pattern and fiddling the list of bindings. -- -- POST CONDITION: head pattern in the EqnInfo is - -- WildPat - -- ConPat - -- NPat - -- LitPat - -- NPlusKPat - -- but no other + -- one of these for which patGroup is defined. tidyEqnInfo _ (EqnInfo { eqn_pats = [] }) = panic "tidyEqnInfo" @@ -412,26 +399,21 @@ tidy1 :: Id -- The Id being scrutinised -- (pat', mr') = tidy1 v pat mr -- tidies the *outer level only* of pat, giving pat' -- It eliminates many pattern forms (as-patterns, variable patterns, --- list patterns, etc) yielding one of: --- WildPat --- ConPatOut --- LitPat --- NPat --- NPlusKPat - -tidy1 v (ParPat pat) = tidy1 v (unLoc pat) -tidy1 v (SigPatOut pat _) = tidy1 v (unLoc pat) -tidy1 _ (WildPat ty) = return (idDsWrapper, WildPat ty) -tidy1 v (BangPat (L l p)) = tidy_bang_pat v l p +-- 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 -- case v of { x -> mr[] } -- = case v of { _ -> let x=v in mr[] } -tidy1 v (VarPat (L _ var)) +tidy1 v (VarPat _ (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 _ (L _ var) pat) = do { (wrap, pat') <- tidy1 v (unLoc pat) ; return (wrapBind var v . wrap, pat') } @@ -446,7 +428,7 @@ tidy1 v (AsPat (L _ var) pat) The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr -} -tidy1 v (LazyPat pat) +tidy1 v (LazyPat _ pat) -- This is a convenient place to check for unlifted types under a lazy pattern. -- Doing this check during type-checking is unsatisfactory because we may -- not fully know the zonked types yet. We sure do here. @@ -462,39 +444,31 @@ tidy1 v (LazyPat pat) ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs] ; return (mkCoreLets sel_binds, WildPat (idType v)) } -tidy1 _ (ListPat pats ty Nothing) +tidy1 _ (ListPat (ListPatTc ty Nothing) pats ) = return (idDsWrapper, unLoc list_ConPat) where list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty]) (mkNilPat ty) pats --- Introduce fake parallel array constructors to be able to handle parallel --- arrays with the existing machinery for constructor pattern -tidy1 _ (PArrPat pats ty) - = return (idDsWrapper, unLoc parrConPat) - where - arity = length pats - parrConPat = mkPrefixConPat (parrFakeCon arity) pats [ty] - -tidy1 _ (TuplePat pats boxity tys) +tidy1 _ (TuplePat tys pats boxity) = return (idDsWrapper, unLoc tuple_ConPat) where arity = length pats tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys -tidy1 _ (SumPat pat alt arity tys) +tidy1 _ (SumPat tys pat alt arity) = return (idDsWrapper, unLoc sum_ConPat) where sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] tys -- LitPats: we *might* be able to replace these w/ a simpler form -tidy1 _ (LitPat lit) +tidy1 _ (LitPat _ lit) = return (idDsWrapper, tidyLitPat lit) -- NPats: we *might* be able to replace these w/ a simpler form -tidy1 _ (NPat (L _ lit) mb_neg eq ty) - = return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq ty) +tidy1 _ (NPat ty (L _ lit) mb_neg eq) + = return (idDsWrapper, tidyNPat lit mb_neg eq ty) -- Everything else goes through unchanged... @@ -505,20 +479,20 @@ 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 _ (SigPatOut (L l p) _) = tidy_bang_pat v l p +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 -- Push the bang-pattern inwards, in the hope that -- it may disappear next time -tidy_bang_pat v l (AsPat v' p) = tidy1 v (AsPat v' (L l (BangPat p))) -tidy_bang_pat v l (CoPat w p t) = tidy1 v (CoPat w (BangPat (L l p)) t) +tidy_bang_pat v l (AsPat x v' p) = tidy1 v (AsPat x v' (L 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) -- Discard bang around strict pattern tidy_bang_pat v _ p@(LitPat {}) = tidy1 v p tidy_bang_pat v _ p@(ListPat {}) = tidy1 v p tidy_bang_pat v _ p@(TuplePat {}) = tidy1 v p tidy_bang_pat v _ p@(SumPat {}) = tidy1 v p -tidy_bang_pat v _ p@(PArrPat {}) = tidy1 v p -- Data/newtype constructors tidy_bang_pat v l p@(ConPatOut { pat_con = L _ (RealDataCon dc) @@ -547,7 +521,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 (L l p)) +tidy_bang_pat _ l p = return (idDsWrapper, BangPat noExt (L l p)) ------------------- push_bang_into_newtype_arg :: SrcSpan @@ -558,15 +532,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 arg)] + PrefixCon [L l (BangPat noExt arg)] push_bang_into_newtype_arg l _ty (RecCon rf) | HsRecFields { rec_flds = L lf fld : flds } <- rf , HsRecField { hsRecFieldArg = arg } <- fld = ASSERT( null flds) - RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg = L l (BangPat arg) })] }) + RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg + = L 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 (noLoc (WildPat ty)))] + = PrefixCon [L l (BangPat noExt (noLoc (WildPat ty)))] push_bang_into_newtype_arg _ _ cd = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd) @@ -726,8 +701,7 @@ JJQC 30-Nov-1997 -} matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches - , mg_arg_tys = arg_tys - , mg_res_ty = rhs_ty + , mg_ext = MatchGroupTc arg_tys rhs_ty , mg_origin = origin }) = do { dflags <- getDynFlags ; locn <- getSrcSpanDs @@ -749,25 +723,21 @@ 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 ctx pats _ grhss)) + mk_eqn_info vars (L _ (Match { m_pats = pats, m_grhss = grhss })) = do { dflags <- getDynFlags - ; let add_bang - | FunRhs {mc_strictness=SrcStrict} <- ctx - = pprTrace "addBang" empty addBang - | otherwise - = decideBangHood dflags - upats = map (unLoc . add_bang) pats - dicts = toTcTypeBag (collectEvVarsPats upats) -- Only TcTyVars + ; let upats = map (unLoc . decideBangHood dflags) pats + dicts = collectEvVarsPats upats ; tm_cs <- genCaseTmCs2 mb_scr upats vars ; match_result <- addDictsDs dicts $ -- See Note [Type and Term Equality Propagation] addTmCsDs tm_cs $ -- See Note [Type and Term Equality Propagation] dsGRHSs ctxt grhss rhs_ty - ; return (EqnInfo { eqn_pats = upats, eqn_rhs = match_result}) } + ; return (EqnInfo { eqn_pats = upats, eqn_rhs = match_result}) } + mk_eqn_info _ (L _ (XMatch _)) = panic "matchWrapper" handleWarnings = if isGenerated origin then discardWarningsDs else id - +matchWrapper _ _ (XMatchGroup _) = panic "matchWrapper" matchEquations :: HsMatchContext Name -> [MatchId] -> [EquationInfo] -> Type @@ -810,7 +780,7 @@ matchSimply scrut hs_ctx pat result_expr fail_expr = do matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat GhcTc -> Type -> MatchResult -> DsM MatchResult -- matchSinglePat ensures that the scrutinee is a variable --- and then calls match_single_pat_var +-- and then calls matchSinglePatVar -- -- matchSinglePat does not warn about incomplete patterns -- Used for things like [ e | pat <- stuff ], where @@ -818,17 +788,17 @@ matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat GhcTc matchSinglePat (Var var) ctx pat ty match_result | not (isExternalName (idName var)) - = match_single_pat_var var ctx pat ty match_result + = matchSinglePatVar var ctx pat ty match_result matchSinglePat scrut hs_ctx pat ty match_result = do { var <- selectSimpleMatchVarL pat - ; match_result' <- match_single_pat_var var hs_ctx pat ty match_result + ; match_result' <- matchSinglePatVar var hs_ctx pat ty match_result ; return (adjustMatchResult (bindNonRec var scrut) match_result') } -match_single_pat_var :: Id -- See Note [Match Ids] - -> HsMatchContext Name -> LPat GhcTc - -> Type -> MatchResult -> DsM MatchResult -match_single_pat_var var ctx pat ty match_result +matchSinglePatVar :: Id -- See Note [Match Ids] + -> HsMatchContext Name -> LPat GhcTc + -> Type -> MatchResult -> DsM MatchResult +matchSinglePatVar var ctx pat ty match_result = ASSERT2( isInternalName (idName var), ppr var ) do { dflags <- getDynFlags ; locn <- getSrcSpanDs @@ -910,7 +880,7 @@ subGroup :: (m -> [[EquationInfo]]) -- Map.elems -- Parameterized by map operations to allow different implementations -- and constraints, eg. types without Ord instance. subGroup elems empty lookup insert group - = map reverse $ elems $ foldl accumulate empty group + = map reverse $ elems $ foldl' accumulate empty group where accumulate pg_map (pg, eqn) = case lookup pg pg_map of @@ -1001,18 +971,18 @@ 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 _ (L _ e)) e' = exp e e' + exp e (HsPar _ (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' - exp (HsVar i) (HsVar i') = i == i' - exp (HsConLikeOut c) (HsConLikeOut c') = c == c' + exp (HsWrap _ h e) (HsWrap _ h' e') = wrap h h' && exp e e' + exp (HsVar _ i) (HsVar _ i') = i == i' + exp (HsConLikeOut _ c) (HsConLikeOut _ c') = c == c' -- the instance for IPName derives using the id, so this works if the -- above does - exp (HsIPVar i) (HsIPVar i') = i == i' - exp (HsOverLabel l x) (HsOverLabel l' x') = l == l' && x == x' - exp (HsOverLit l) (HsOverLit l') = + exp (HsIPVar _ i) (HsIPVar _ i') = i == i' + exp (HsOverLabel _ l x) (HsOverLabel _ l' x') = l == l' && x == x' + exp (HsOverLit _ l) (HsOverLit _ l') = -- Overloaded lits are equal if they have the same type -- and the data is the same. -- this is coarser than comparing the SyntaxExpr's in l and l', @@ -1020,20 +990,20 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 -- because these expressions get written as a bunch of different variables -- (presumably to improve sharing) eqType (overLitType l) (overLitType l') && l == l' - exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2' + exp (HsApp _ e1 e2) (HsApp _ e1' e2') = lexp e1 e1' && lexp e2 e2' -- the fixities have been straightened out by now, so it's safe -- to ignore them? - exp (OpApp l o _ ri) (OpApp l' o' _ ri') = + exp (OpApp _ l o ri) (OpApp _ l' o' ri') = lexp l l' && lexp o o' && lexp ri ri' - exp (NegApp e n) (NegApp e' n') = lexp e e' && syn_exp n n' - exp (SectionL e1 e2) (SectionL e1' e2') = + exp (NegApp _ e n) (NegApp _ e' n') = lexp e e' && syn_exp n n' + exp (SectionL _ e1 e2) (SectionL _ e1' e2') = lexp e1 e1' && lexp e2 e2' - exp (SectionR e1 e2) (SectionR e1' e2') = + exp (SectionR _ e1 e2) (SectionR _ e1' e2') = lexp e1 e1' && lexp e2 e2' - exp (ExplicitTuple es1 _) (ExplicitTuple es2 _) = + exp (ExplicitTuple _ es1 _) (ExplicitTuple _ es2 _) = eq_list tup_arg es1 es2 - exp (ExplicitSum _ _ e _) (ExplicitSum _ _ e' _) = lexp e e' - exp (HsIf _ e e1 e2) (HsIf _ e' e1' e2') = + exp (ExplicitSum _ _ _ e) (ExplicitSum _ _ _ e') = lexp e e' + exp (HsIf _ _ e e1 e2) (HsIf _ _ e' e1' e2') = lexp e e' && lexp e1 e1' && lexp e2 e2' -- Enhancement: could implement equality for more expressions @@ -1055,8 +1025,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 (L _ (Present _ e1)) (L _ (Present _ e2)) = lexp e1 e2 + tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2 tup_arg _ _ = False --------- @@ -1079,8 +1049,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 --------- ev_term :: EvTerm -> EvTerm -> Bool - ev_term (EvId a) (EvId b) = a==b - ev_term (EvCoercion a) (EvCoercion b) = a `eqCoercion` b + ev_term (EvExpr (Var a)) (EvExpr (Var b)) = a==b + ev_term (EvExpr (Coercion a)) (EvExpr (Coercion b)) = a `eqCoercion` b ev_term _ _ = False --------- @@ -1097,7 +1067,7 @@ patGroup _ (ConPatOut { pat_con = L _ con | PatSynCon psyn <- con = PgSyn psyn tys patGroup _ (WildPat {}) = PgAny patGroup _ (BangPat {}) = PgBang -patGroup _ (NPat (L _ OverLit {ol_val=oval}) mb_neg _ _) = +patGroup _ (NPat _ (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)) @@ -1105,14 +1075,15 @@ 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 _ _ (L _ OverLit {ol_val=oval}) _ _ _) = case oval of HsIntegral i -> PgNpK (il_value i) _ -> pprPanic "patGroup NPlusKPat" (ppr oval) -patGroup _ (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern -patGroup _ (ViewPat expr p _) = PgView expr (hsPatType (unLoc p)) -patGroup _ (ListPat _ _ (Just _)) = PgOverloadedList -patGroup dflags (LitPat lit) = PgLit (hsLitKey dflags lit) +patGroup _ (CoPat _ _ p _) = PgCo (hsPatType p) + -- Type of innelexp pattern +patGroup _ (ViewPat _ expr p) = PgView expr (hsPatType (unLoc p)) +patGroup _ (ListPat (ListPatTc _ (Just _)) _) = PgOverloadedList +patGroup dflags (LitPat _ lit) = PgLit (hsLitKey dflags lit) patGroup _ pat = pprPanic "patGroup" (ppr pat) {- diff --git a/compiler/deSugar/Match.hs-boot b/compiler/deSugar/Match.hs-boot index 4096b9cd0b..e77ad548b6 100644 --- a/compiler/deSugar/Match.hs-boot +++ b/compiler/deSugar/Match.hs-boot @@ -1,4 +1,6 @@ module Match where + +import GhcPrelude import Var ( Id ) import TcType ( Type ) import DsMonad ( DsM, EquationInfo, MatchResult ) @@ -26,8 +28,8 @@ matchSimply -> CoreExpr -> DsM CoreExpr -matchSinglePat - :: CoreExpr +matchSinglePatVar + :: Id -> HsMatchContext Name -> LPat GhcTc -> Type diff --git a/compiler/deSugar/MatchCon.hs b/compiler/deSugar/MatchCon.hs index 7923ae4eb5..af542340fa 100644 --- a/compiler/deSugar/MatchCon.hs +++ b/compiler/deSugar/MatchCon.hs @@ -13,6 +13,8 @@ module MatchCon ( matchConFamily, matchPatSyn ) where #include "HsVersions.h" +import GhcPrelude + import {-# SOURCE #-} Match ( match ) import HsSyn @@ -27,7 +29,6 @@ import Id import NameEnv import FieldLabel ( flSelector ) import SrcLoc -import DynFlags import Outputable import Control.Monad(liftM) import Data.List (groupBy) @@ -91,9 +92,8 @@ matchConFamily :: [Id] -> DsM MatchResult -- Each group of eqns is for a single constructor matchConFamily (var:vars) ty groups - = do dflags <- getDynFlags - alts <- mapM (fmap toRealAlt . matchOneConLike vars ty) groups - return (mkCoAlgCaseMatchResult dflags var ty alts) + = do alts <- mapM (fmap toRealAlt . matchOneConLike vars ty) groups + return (mkCoAlgCaseMatchResult var ty alts) where toRealAlt alt = case alt_pat alt of RealDataCon dcon -> alt{ alt_pat = dcon } @@ -120,7 +120,10 @@ matchOneConLike :: [Id] -> [EquationInfo] -> DsM (CaseAlt ConLike) matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor - = do { let inst_tys = ASSERT( tvs1 `equalLength` ex_tvs ) + = do { let inst_tys = ASSERT( all tcIsTcTyVar ex_tvs ) + -- ex_tvs can only be tyvars as data types in source + -- Haskell cannot mention covar yet (Aug 2018). + ASSERT( tvs1 `equalLength` ex_tvs ) arg_tys ++ mkTyVarTys tvs1 val_arg_tys = conLikeInstOrigArgTys con1 inst_tys @@ -169,7 +172,7 @@ matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor = firstPat eqn1 fields1 = map flSelector (conLikeFieldLabels con1) - ex_tvs = conLikeExTyVars con1 + ex_tvs = conLikeExTyCoVars con1 -- Choose the right arg_vars in the right order for this group -- Note [Record patterns] diff --git a/compiler/deSugar/MatchLit.hs b/compiler/deSugar/MatchLit.hs index c3ba420232..ca7ef0af2f 100644 --- a/compiler/deSugar/MatchLit.hs +++ b/compiler/deSugar/MatchLit.hs @@ -17,6 +17,8 @@ module MatchLit ( dsLit, dsOverLit, dsOverLit', hsLitKey #include "HsVersions.h" +import GhcPrelude + import {-# SOURCE #-} Match ( match ) import {-# SOURCE #-} DsExpr ( dsExpr, dsSyntaxExpr ) @@ -75,30 +77,32 @@ See also below where we look for @DictApps@ for \tr{plusInt}, etc. -} dsLit :: HsLit GhcRn -> DsM CoreExpr -dsLit (HsStringPrim _ s) = return (Lit (MachStr s)) -dsLit (HsCharPrim _ c) = return (Lit (MachChar c)) -dsLit (HsIntPrim _ i) = return (Lit (MachInt i)) -dsLit (HsWordPrim _ w) = return (Lit (MachWord w)) -dsLit (HsInt64Prim _ i) = return (Lit (MachInt64 i)) -dsLit (HsWord64Prim _ w) = return (Lit (MachWord64 w)) -dsLit (HsFloatPrim _ f) = return (Lit (MachFloat (fl_value f))) -dsLit (HsDoublePrim _ d) = return (Lit (MachDouble (fl_value d))) -dsLit (HsChar _ c) = return (mkCharExpr c) -dsLit (HsString _ str) = mkStringExprFS str -dsLit (HsInteger _ i _) = mkIntegerExpr i -dsLit (HsInt _ i) = do dflags <- getDynFlags - return (mkIntExpr dflags (il_value i)) - -dsLit (HsRat _ (FL _ _ val) ty) = do - num <- mkIntegerExpr (numerator val) - denom <- mkIntegerExpr (denominator val) - return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom]) - where - (ratio_data_con, integer_ty) - = case tcSplitTyConApp ty of - (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey) - (head (tyConDataCons tycon), i_ty) - x -> pprPanic "dsLit" (ppr x) +dsLit l = do + dflags <- getDynFlags + case l of + HsStringPrim _ s -> return (Lit (MachStr s)) + HsCharPrim _ c -> return (Lit (MachChar c)) + HsIntPrim _ i -> return (Lit (mkMachIntWrap dflags i)) + HsWordPrim _ w -> return (Lit (mkMachWordWrap dflags w)) + HsInt64Prim _ i -> return (Lit (mkMachInt64Wrap dflags i)) + HsWord64Prim _ w -> return (Lit (mkMachWord64Wrap dflags w)) + HsFloatPrim _ f -> return (Lit (MachFloat (fl_value f))) + HsDoublePrim _ d -> return (Lit (MachDouble (fl_value d))) + HsChar _ c -> return (mkCharExpr c) + HsString _ str -> mkStringExprFS str + HsInteger _ i _ -> mkIntegerExpr i + HsInt _ i -> return (mkIntExpr dflags (il_value i)) + XLit x -> pprPanic "dsLit" (ppr x) + HsRat _ (FL _ _ val) ty -> do + num <- mkIntegerExpr (numerator val) + denom <- mkIntegerExpr (denominator val) + return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom]) + where + (ratio_data_con, integer_ty) + = case tcSplitTyConApp ty of + (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey) + (head (tyConDataCons tycon), i_ty) + x -> pprPanic "dsLit" (ppr x) dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr dsOverLit lit = do { dflags <- getDynFlags @@ -108,12 +112,12 @@ dsOverLit lit = do { dflags <- getDynFlags dsOverLit' :: DynFlags -> HsOverLit GhcTc -> DsM CoreExpr -- Post-typechecker, the HsExpr field of an OverLit contains -- (an expression for) the literal value itself -dsOverLit' dflags (OverLit { ol_val = val, ol_rebindable = rebindable - , ol_witness = witness, ol_type = ty }) +dsOverLit' dflags (OverLit { ol_val = val, ol_ext = OverLitTc rebindable ty + , ol_witness = witness }) | not rebindable , Just expr <- shortCutLit dflags val ty = dsExpr expr -- Note [Literal short cut] | otherwise = dsExpr witness - +dsOverLit' _ XOverLit{} = panic "dsOverLit'" {- Note [Literal short cut] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -157,20 +161,30 @@ warnAboutOverflowedLiterals :: DynFlags -> HsOverLit GhcTc -> DsM () warnAboutOverflowedLiterals dflags lit | wopt Opt_WarnOverflowedLiterals dflags , Just (i, tc) <- getIntegralLit lit - = if tc == intTyConName then check i tc (Proxy :: Proxy Int) - else if tc == int8TyConName then check i tc (Proxy :: Proxy Int8) - else if tc == int16TyConName then check i tc (Proxy :: Proxy Int16) - else if tc == int32TyConName then check i tc (Proxy :: Proxy Int32) - else if tc == int64TyConName then check i tc (Proxy :: Proxy Int64) - else if tc == wordTyConName then check i tc (Proxy :: Proxy Word) - else if tc == word8TyConName then check i tc (Proxy :: Proxy Word8) - else if tc == word16TyConName then check i tc (Proxy :: Proxy Word16) - else if tc == word32TyConName then check i tc (Proxy :: Proxy Word32) - else if tc == word64TyConName then check i tc (Proxy :: Proxy Word64) + = if tc == intTyConName then check i tc (Proxy :: Proxy Int) + else if tc == int8TyConName then check i tc (Proxy :: Proxy Int8) + else if tc == int16TyConName then check i tc (Proxy :: Proxy Int16) + else if tc == int32TyConName then check i tc (Proxy :: Proxy Int32) + else if tc == int64TyConName then check i tc (Proxy :: Proxy Int64) + else if tc == wordTyConName then check i tc (Proxy :: Proxy Word) + else if tc == word8TyConName then check i tc (Proxy :: Proxy Word8) + else if tc == word16TyConName then check i tc (Proxy :: Proxy Word16) + else if tc == word32TyConName then check i tc (Proxy :: Proxy Word32) + else if tc == word64TyConName then check i tc (Proxy :: Proxy Word64) + else if tc == naturalTyConName then checkPositive i tc else return () | otherwise = return () where + checkPositive :: Integer -> Name -> DsM () + checkPositive i tc + = when (i < 0) $ do + warnDs (Reason Opt_WarnOverflowedLiterals) + (vcat [ text "Literal" <+> integer i + <+> text "is negative but" <+> ppr tc + <+> ptext (sLit "only supports positive numbers") + ]) + check :: forall a. (Bounded a, Integral a) => Integer -> Name -> Proxy a -> DsM () check i tc _proxy = when (i < minB || i > maxB) $ do @@ -237,14 +251,14 @@ 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 (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 _ = Nothing getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Name) -getIntegralLit (OverLit { ol_val = HsIntegral i, ol_type = ty }) +getIntegralLit (OverLit { ol_val = HsIntegral i, ol_ext = OverLitTc _ ty }) | Just tc <- tyConAppTyCon_maybe ty = Just (il_value i, tyConName tc) getIntegralLit _ = Nothing @@ -271,18 +285,13 @@ tidyLitPat (HsString src s) (mkNilPat charTy) (unpackFS s) -- The stringTy is the type of the whole pattern, not -- the type to instantiate (:) or [] with! -tidyLitPat lit = LitPat lit +tidyLitPat lit = LitPat noExt lit ---------------- -tidyNPat :: (HsLit GhcTc -> Pat GhcTc) -- How to tidy a LitPat - -- We need this argument because tidyNPat is called - -- both by Match and by Check, but they tidy LitPats - -- slightly differently; and we must desugar - -- literals consistently (see Trac #5117) - -> HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> SyntaxExpr GhcTc +tidyNPat :: HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> SyntaxExpr GhcTc -> Type -> Pat GhcTc -tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty +tidyNPat (OverLit (OverLitTc False ty) val _) mb_neg _eq outer_ty -- False: Take short cuts only if the literal is not using rebindable syntax -- -- Once that is settled, look for cases where the type of the @@ -298,7 +307,7 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty | not type_change, isWordTy ty, Just int_lit <- mb_int_lit = mk_con_pat wordDataCon (HsWordPrim NoSourceText int_lit) | not type_change, isStringTy ty, Just str_lit <- mb_str_lit - = tidy_lit_pat (HsString NoSourceText str_lit) + = tidyLitPat (HsString NoSourceText str_lit) -- NB: do /not/ convert Float or Double literals to F# 3.8 or D# 5.3 -- If we do convert to the constructor form, we'll generate a case -- expression on a Float# or Double# and that's not allowed in Core; see @@ -311,7 +320,8 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty type_change = not (outer_ty `eqType` ty) mk_con_pat :: DataCon -> HsLit GhcTc -> Pat GhcTc - mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] []) + mk_con_pat con lit + = unLoc (mkPrefixConPat con [noLoc $ LitPat noExt lit] []) mb_int_lit :: Maybe Integer mb_int_lit = case (mb_neg, val) of @@ -324,8 +334,8 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty (Nothing, HsIsString _ s) -> Just s _ -> Nothing -tidyNPat _ over_lit mb_neg eq outer_ty - = NPat (noLoc over_lit) mb_neg eq outer_ty +tidyNPat over_lit mb_neg eq outer_ty + = NPat outer_ty (noLoc over_lit) mb_neg eq {- ************************************************************************ @@ -359,7 +369,7 @@ matchLiterals (var:vars) ty sub_groups match_group :: [EquationInfo] -> DsM (Literal, MatchResult) match_group eqns = do dflags <- getDynFlags - let LitPat hs_lit = firstPat (head eqns) + let LitPat _ hs_lit = firstPat (head eqns) match_result <- match vars ty (shiftEqns eqns) return (hsLitKey dflags hs_lit, match_result) @@ -389,8 +399,8 @@ hsLitKey :: DynFlags -> HsLit GhcTc -> Literal -- HsLit does not. hsLitKey dflags (HsIntPrim _ i) = mkMachIntWrap dflags i hsLitKey dflags (HsWordPrim _ w) = mkMachWordWrap dflags w -hsLitKey _ (HsInt64Prim _ i) = mkMachInt64Wrap i -hsLitKey _ (HsWord64Prim _ w) = mkMachWord64Wrap w +hsLitKey dflags (HsInt64Prim _ i) = mkMachInt64Wrap dflags i +hsLitKey dflags (HsWord64Prim _ w) = mkMachWord64Wrap dflags w hsLitKey _ (HsCharPrim _ c) = mkMachChar c hsLitKey _ (HsFloatPrim _ f) = mkMachFloat (fl_value f) hsLitKey _ (HsDoublePrim _ d) = mkMachDouble (fl_value d) @@ -407,7 +417,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 _ (L _ lit) mb_neg eq_chk = firstPat eqn1 ; lit_expr <- dsOverLit lit ; neg_lit <- case mb_neg of Nothing -> return lit_expr @@ -438,7 +448,7 @@ 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 _ (L _ n1) (L _ lit1) lit2 ge minus = firstPat eqn1 ; lit1_expr <- dsOverLit lit1 ; lit2_expr <- dsOverLit lit2 ; pred_expr <- dsSyntaxExpr ge [Var var, lit1_expr] @@ -450,7 +460,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 _ (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 e9af145183..fbacb989a1 100644 --- a/compiler/deSugar/PmExpr.hs +++ b/compiler/deSugar/PmExpr.hs @@ -15,12 +15,17 @@ module PmExpr ( #include "HsVersions.h" +import GhcPrelude + +import BasicTypes (SourceText) +import FastString (FastString, unpackFS) import HsSyn import Id import Name import NameSet import DataCon import ConLike +import TcType (isStringTy) import TysWiredIn import Outputable import Util @@ -234,35 +239,45 @@ lhsExprToPmExpr (L _ e) = hsExprToPmExpr e hsExprToPmExpr :: HsExpr GhcTc -> PmExpr -hsExprToPmExpr (HsVar x) = PmExprVar (idName (unLoc x)) -hsExprToPmExpr (HsConLikeOut c) = PmExprVar (conLikeName c) -hsExprToPmExpr (HsOverLit olit) = PmExprLit (PmOLit False olit) -hsExprToPmExpr (HsLit lit) = PmExprLit (PmSLit lit) - -hsExprToPmExpr e@(NegApp _ neg_e) - | PmExprLit (PmOLit False ol) <- synExprToPmExpr neg_e - = PmExprLit (PmOLit True ol) +hsExprToPmExpr (HsVar _ x) = PmExprVar (idName (unLoc x)) +hsExprToPmExpr (HsConLikeOut _ c) = PmExprVar (conLikeName c) + +-- Desugar literal strings as a list of characters. For other literal values, +-- keep it as it is. +-- See `translatePat` in Check.hs (the `NPat` and `LitPat` case), and +-- Note [Translate Overloaded Literal for Exhaustiveness Checking]. +hsExprToPmExpr (HsOverLit _ olit) + | OverLit (OverLitTc False ty) (HsIsString src s) _ <- olit, isStringTy ty + = stringExprToList src s + | otherwise = PmExprLit (PmOLit False olit) +hsExprToPmExpr (HsLit _ lit) + | HsString src s <- lit + = stringExprToList src s + | otherwise = PmExprLit (PmSLit lit) + +hsExprToPmExpr e@(NegApp _ (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 e@(ExplicitTuple ps boxity) +hsExprToPmExpr (HsPar _ (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 | L _ (Present _ e) <- ps ] -hsExprToPmExpr e@(ExplicitList _elem_ty mb_ol elems) +hsExprToPmExpr e@(ExplicitList _ mb_ol elems) | Nothing <- mb_ol = foldr cons nil (map lhsExprToPmExpr elems) | otherwise = PmExprOther e {- overloaded list: No PmExprApp -} where cons x xs = mkPmExprData consDataCon [x,xs] nil = mkPmExprData nilDataCon [] -hsExprToPmExpr (ExplicitPArr _elem_ty elems) - = mkPmExprData (parrFakeCon (length elems)) (map lhsExprToPmExpr elems) - - -- we want this but we would have to make everything monadic :/ -- ./compiler/deSugar/DsMonad.hs:397:dsLookupDataCon :: Name -> DsM DataCon -- @@ -270,20 +285,23 @@ hsExprToPmExpr (ExplicitPArr _elem_ty elems) -- con <- dsLookupDataCon (unLoc c) -- args <- mapM lhsExprToPmExpr (hsRecFieldsArgs binds) -- return (PmExprCon con args) -hsExprToPmExpr e@(RecordCon _ _ _ _) = PmExprOther e - -hsExprToPmExpr (HsTick _ e) = lhsExprToPmExpr e -hsExprToPmExpr (HsBinTick _ _ e) = lhsExprToPmExpr e -hsExprToPmExpr (HsTickPragma _ _ _ e) = lhsExprToPmExpr e -hsExprToPmExpr (HsSCC _ _ e) = lhsExprToPmExpr e -hsExprToPmExpr (HsCoreAnn _ _ e) = lhsExprToPmExpr e -hsExprToPmExpr (ExprWithTySig e _) = lhsExprToPmExpr e -hsExprToPmExpr (ExprWithTySigOut e _) = lhsExprToPmExpr e -hsExprToPmExpr (HsWrap _ e) = hsExprToPmExpr e +hsExprToPmExpr e@(RecordCon {}) = PmExprOther e + +hsExprToPmExpr (HsTick _ _ e) = lhsExprToPmExpr e +hsExprToPmExpr (HsBinTick _ _ _ e) = lhsExprToPmExpr e +hsExprToPmExpr (HsTickPragma _ _ _ _ e) = lhsExprToPmExpr e +hsExprToPmExpr (HsSCC _ _ _ e) = lhsExprToPmExpr e +hsExprToPmExpr (HsCoreAnn _ _ _ e) = lhsExprToPmExpr e +hsExprToPmExpr (ExprWithTySig _ e) = lhsExprToPmExpr e +hsExprToPmExpr (HsWrap _ _ e) = hsExprToPmExpr e hsExprToPmExpr e = PmExprOther e -- the rest are not handled by the oracle -synExprToPmExpr :: SyntaxExpr GhcTc -> PmExpr -synExprToPmExpr = hsExprToPmExpr . syn_expr -- ignore the wrappers +stringExprToList :: SourceText -> FastString -> PmExpr +stringExprToList src s = foldr cons nil (map charToPmExpr (unpackFS s)) + where + cons x xs = mkPmExprData consDataCon [x,xs] + nil = mkPmExprData nilDataCon [] + charToPmExpr c = PmExprLit (PmSLit (HsChar src c)) {- %************************************************************************ @@ -394,7 +412,7 @@ needsParens (PmExprLit l) = isNegatedPmLit l needsParens (PmExprEq {}) = False -- will become a wildcard needsParens (PmExprOther {}) = False -- will become a wildcard needsParens (PmExprCon (RealDataCon c) es) - | isTupleDataCon c || isPArrFakeCon c + | isTupleDataCon c || isConsDataCon c || null es = False | otherwise = True needsParens (PmExprCon (PatSynCon _) es) = not (null es) @@ -407,12 +425,10 @@ pprPmExprWithParens expr pprPmExprCon :: ConLike -> [PmExpr] -> PmPprM SDoc pprPmExprCon (RealDataCon con) args | isTupleDataCon con = mkTuple <$> mapM pprPmExpr args - | isPArrFakeCon con = mkPArr <$> mapM pprPmExpr args - | isConsDataCon con = pretty_list + | isConsDataCon con = pretty_list where - mkTuple, mkPArr :: [SDoc] -> SDoc + mkTuple :: [SDoc] -> SDoc mkTuple = parens . fsep . punctuate comma - mkPArr = paBrackets . fsep . punctuate comma -- lazily, to be used in the list case only pretty_list :: PmPprM SDoc diff --git a/compiler/deSugar/TmOracle.hs b/compiler/deSugar/TmOracle.hs index 115c0a882f..d6364bef52 100644 --- a/compiler/deSugar/TmOracle.hs +++ b/compiler/deSugar/TmOracle.hs @@ -22,6 +22,8 @@ module TmOracle ( #include "HsVersions.h" +import GhcPrelude + import PmExpr import Id @@ -98,6 +100,10 @@ solveOneEq solver_env@(_,(_,env)) complex $ applySubstComplexEq env complex -- replace everything we already know -- | Solve a complex equality. +-- Nothing => definitely unsatisfiable +-- Just tms => I have added the complex equality and added +-- it to the tmstate; the result may or may not be +-- satisfiable solveComplexEq :: TmState -> ComplexEq -> Maybe TmState solveComplexEq solver_state@(standby, (unhandled, env)) eq@(e1, e2) = case eq of -- We cannot do a thing about these cases |