diff options
Diffstat (limited to 'compiler/deSugar/DsUtils.hs')
| -rw-r--r-- | compiler/deSugar/DsUtils.hs | 55 |
1 files changed, 29 insertions, 26 deletions
diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs index ca22387b59..b78eef4c37 100644 --- a/compiler/deSugar/DsUtils.hs +++ b/compiler/deSugar/DsUtils.hs @@ -11,6 +11,7 @@ This module exports some utility functions of no great interest. {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} -- | Utility functions for constructing Core syntax, principally for desugaring module DsUtils ( @@ -668,7 +669,7 @@ mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly -- and all the desugared binds mkSelectorBinds ticks pat val_expr - | L _ (VarPat _ (L _ v)) <- pat' -- Special case (A) + | (dL->L _ (VarPat _ (dL->L _ v))) <- pat' -- Special case (A) = return (v, [(v, val_expr)]) | is_flat_prod_lpat pat' -- Special case (B) @@ -713,28 +714,29 @@ mkSelectorBinds ticks pat val_expr local_tuple = mkBigCoreVarTup1 binders tuple_ty = exprType local_tuple -strip_bangs :: LPat a -> LPat a +strip_bangs :: LPat (GhcPass p) -> LPat (GhcPass p) -- Remove outermost bangs and parens -strip_bangs (L _ (ParPat _ p)) = strip_bangs p -strip_bangs (L _ (BangPat _ p)) = strip_bangs p -strip_bangs lp = lp +strip_bangs (dL->L _ (ParPat _ p)) = strip_bangs p +strip_bangs (dL->L _ (BangPat _ p)) = strip_bangs p +strip_bangs lp = lp -is_flat_prod_lpat :: LPat a -> Bool -is_flat_prod_lpat p = is_flat_prod_pat (unLoc p) +is_flat_prod_lpat :: LPat (GhcPass p) -> Bool +is_flat_prod_lpat = is_flat_prod_pat . unLoc -is_flat_prod_pat :: Pat a -> Bool +is_flat_prod_pat :: Pat (GhcPass p) -> Bool is_flat_prod_pat (ParPat _ p) = is_flat_prod_lpat p is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps -is_flat_prod_pat (ConPatOut { pat_con = L _ pcon, pat_args = ps}) +is_flat_prod_pat (ConPatOut { pat_con = (dL->L _ pcon) + , pat_args = ps}) | RealDataCon con <- pcon , isProductTyCon (dataConTyCon con) = all is_triv_lpat (hsConPatArgs ps) is_flat_prod_pat _ = False -is_triv_lpat :: LPat a -> Bool -is_triv_lpat p = is_triv_pat (unLoc p) +is_triv_lpat :: LPat (GhcPass p) -> Bool +is_triv_lpat = is_triv_pat . unLoc -is_triv_pat :: Pat a -> Bool +is_triv_pat :: Pat (GhcPass p) -> Bool is_triv_pat (VarPat {}) = True is_triv_pat (WildPat{}) = True is_triv_pat (ParPat _ p) = is_triv_lpat p @@ -752,7 +754,7 @@ is_triv_pat _ = False mkLHsPatTup :: [LPat GhcTc] -> LPat GhcTc mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed mkLHsPatTup [lpat] = lpat -mkLHsPatTup lpats = L (getLoc (head lpats)) $ +mkLHsPatTup lpats = cL (getLoc (head lpats)) $ mkVanillaTuplePat lpats Boxed mkLHsVarPatTup :: [Id] -> LPat GhcTc @@ -948,25 +950,25 @@ decideBangHood dflags lpat | otherwise -- -XStrict = go lpat where - go lp@(L l p) + go lp@(dL->L l p) = case p of - ParPat x p -> L l (ParPat x (go p)) + ParPat x p -> cL l (ParPat x (go p)) LazyPat _ lp' -> lp' BangPat _ _ -> lp - _ -> L l (BangPat noExt lp) + _ -> cL l (BangPat noExt lp) -- | Unconditionally make a 'Pat' strict. addBang :: LPat GhcTc -- ^ Original pattern -> LPat GhcTc -- ^ Banged pattern addBang = go where - go lp@(L l p) + go lp@(dL->L l p) = case p of - ParPat x p -> L l (ParPat x (go p)) - LazyPat _ lp' -> L l (BangPat noExt lp') + ParPat x p -> cL l (ParPat x (go p)) + LazyPat _ lp' -> cL l (BangPat noExt lp') -- Should we bring the extension value over? BangPat _ _ -> lp - _ -> L l (BangPat noExt lp) + _ -> cL l (BangPat noExt lp) isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr) @@ -976,23 +978,24 @@ isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr) -- * Trivial wappings of these -- The arguments to Just are any HsTicks that we have found, -- because we still want to tick then, even it they are always evaluated. -isTrueLHsExpr (L _ (HsVar _ (L _ v))) | v `hasKey` otherwiseIdKey - || v `hasKey` getUnique trueDataConId +isTrueLHsExpr (dL->L _ (HsVar _ (dL->L _ v))) + | v `hasKey` otherwiseIdKey + || v `hasKey` getUnique trueDataConId = Just return -- trueDataConId doesn't have the same unique as trueDataCon -isTrueLHsExpr (L _ (HsConLikeOut _ con)) +isTrueLHsExpr (dL->L _ (HsConLikeOut _ con)) | con `hasKey` getUnique trueDataCon = Just return -isTrueLHsExpr (L _ (HsTick _ tickish e)) +isTrueLHsExpr (dL->L _ (HsTick _ tickish e)) | Just ticks <- isTrueLHsExpr e = Just (\x -> do wrapped <- ticks x return (Tick tickish wrapped)) -- This encodes that the result is constant True for Hpc tick purposes; -- which is specifically what isTrueLHsExpr is trying to find out. -isTrueLHsExpr (L _ (HsBinTick _ ixT _ e)) +isTrueLHsExpr (dL->L _ (HsBinTick _ ixT _ e)) | Just ticks <- isTrueLHsExpr e = Just (\x -> do e <- ticks x this_mod <- getModule return (Tick (HpcTick this_mod ixT) e)) -isTrueLHsExpr (L _ (HsPar _ e)) = isTrueLHsExpr e +isTrueLHsExpr (dL->L _ (HsPar _ e)) = isTrueLHsExpr e isTrueLHsExpr _ = Nothing |