Commit 314bc314 authored by Ben Gamari's avatar Ben Gamari 🐢

Revert "trees that grow" work

As documented in #14490, the Data instances currently blow up
compilation time by too much to stomach. Alan will continue working on
this in a branch and we will perhaps merge to 8.2 before 8.2.1 to avoid
having to perform painful cherry-picks in 8.2 minor releases.

Reverts haddock submodule.

This reverts commit 47ad6578.
This reverts commit e3ec2e7a.
This reverts commit 438dd1cb.
This reverts commit 0ff152c9.
parent 0b20d9c5
......@@ -675,12 +675,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 noExt) }
, pm_grd_expr = PmExprOther EWildPat }
{-# 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
......@@ -723,25 +723,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])
SigPat _ty p -> translatePat fam_insts (unLoc p)
SigPatOut p _ty -> 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
......@@ -751,26 +751,26 @@ translatePat fam_insts pat = case pat of
return [xp,g]
-- (n + k) ===> x (True <- x >= k) (n <- x-k)
NPlusKPat ty (L _ _n) _k1 _k2 _ge _minus -> mkCanFailPmPat ty
NPlusKPat (L _ _n) _k1 _k2 _ge _minus ty -> mkCanFailPmPat ty
-- (fun -> pat) ===> x (pat <- fun x)
ViewPat arg_ty lexpr lpat -> do
ViewPat lexpr lpat arg_ty -> 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 noExt lexpr xe)
let g = mkGuard ps (HsApp lexpr xe)
return [xp,g]
False -> mkCanFailPmPat arg_ty
-- list
ListPat _ ps ty Nothing -> do
ListPat ps ty Nothing -> do
foldr (mkListPatVec ty) [nilPattern ty]
<$> translatePatVec fam_insts (map unLoc ps)
-- overloaded list
ListPat x lpats elem_ty (Just (pat_ty, _to_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
......@@ -779,7 +779,7 @@ translatePat fam_insts pat = case pat of
-- 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 x lpats e_ty Nothing)
translatePat fam_insts (ListPat lpats e_ty Nothing)
-- See Note [Guards and Approximation]
| otherwise -> mkCanFailPmPat pat_ty
......@@ -799,27 +799,26 @@ translatePat fam_insts pat = case pat of
, pm_con_dicts = dicts
, pm_con_args = args }]
NPat ty (L _ ol) mb_neg _eq -> translateNPat fam_insts ol mb_neg ty
NPat (L _ ol) mb_neg _eq ty -> translateNPat fam_insts ol mb_neg ty
LitPat _ lit
LitPat lit
-- If it is a string then convert it to a list of characters
| HsString src s <- lit ->
foldr (mkListPatVec charTy) [nilPattern charTy] <$>
translatePatVec fam_insts
(map (LitPat noExt . HsChar src) (unpackFS s))
translatePatVec fam_insts (map (LitPat . HsChar src) (unpackFS s))
| otherwise -> return [mkLitPattern lit]
PArrPat ty ps -> do
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 tys ps boxity -> do
TuplePat ps boxity tys -> 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 ty p alt arity -> do
SumPat p alt arity ty -> do
tidy_p <- translatePat fam_insts (unLoc p)
let sum_con = RealDataCon (sumDataCon alt arity)
return [vanillaConPattern sum_con ty tidy_p]
......@@ -828,23 +827,23 @@ translatePat fam_insts pat = case pat of
-- Not supposed to happen
ConPatIn {} -> panic "Check.translatePat: ConPatIn"
SplicePat {} -> panic "Check.translatePat: SplicePat"
XPat {} -> panic "Check.translatePat: XPat"
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 (OverLitTc False ty) val _ ) mb_neg outer_ty
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 noExt (HsString src s))
= translatePat fam_insts (LitPat (HsString src s))
| not type_change, isIntTy ty, HsIntegral i <- val
= translatePat fam_insts
(LitPat noExt $ case mb_neg of
Nothing -> HsInt noExt i
Just _ -> HsInt noExt (negateIntegralLit i))
(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 noExt $ case mb_neg of
(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))
......@@ -1217,7 +1216,7 @@ mkPmId ty = getUniqueM >>= \unique ->
mkPmId2Forms :: Type -> DsM (Pattern, LHsExpr GhcTc)
mkPmId2Forms ty = do
x <- mkPmId ty
return (PmVar x, noLoc (HsVar noExt (noLoc x)))
return (PmVar x, noLoc (HsVar (noLoc x)))
-- ----------------------------------------------------------------------------
-- * Converting between Value Abstractions, Patterns and PmExpr
......
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
......@@ -136,25 +136,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
= Just return
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))
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))
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 (L _ (HsPar e)) = isTrueLHsExpr e
isTrueLHsExpr _ = Nothing
{-
......
......@@ -82,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
......@@ -90,7 +90,6 @@ 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
......@@ -106,8 +105,7 @@ 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 noExt stmts
from_bndrs noSyntaxExpr)
(expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock 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
......@@ -255,7 +253,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
......@@ -625,15 +623,13 @@ dePArrParComp qss quals = do
deParStmt [] =
-- empty parallel statement lists have no source representation
panic "DsListComp.dePArrComp: Empty parallel list comprehension"
deParStmt (ParStmtBlock _ qs xs _:qss) = do -- first statement
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
deParStmt (XParStmtBlock{}:_) = panic "dePArrParComp"
---
parStmts [] pa cea = return (pa, cea)
parStmts (ParStmtBlock _ qs xs _:qss) pa cea = do
-- subsequent statements (zip'ed)
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
......@@ -642,7 +638,6 @@ dePArrParComp qss quals = do
let ty'cqs = parrElemType cqs
cea' = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs]
parStmts qss pa' cea'
parStmts (XParStmtBlock{}:_) _ _ = panic "dePArrParComp"
-- generate Core corresponding to `\p -> e'
--
......@@ -782,7 +777,7 @@ dsMcStmt (ParStmt blocks mzip_op bind_op bind_ty) stmts_rest
; 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
......@@ -793,10 +788,9 @@ 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)
......
This diff is collapsed.
......@@ -9,8 +9,6 @@ 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 (
......@@ -119,13 +117,13 @@ selectMatchVars :: [Pat GhcTc] -> DsM [Id]
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))
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...
{-
......@@ -738,7 +736,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)
......@@ -785,17 +783,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)
......@@ -805,10 +803,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
{- *********************************************************************
......@@ -830,7 +828,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 (map hsLPatType pats) pats box
mkVanillaTuplePat pats box = TuplePat pats box (map hsLPatType pats)
-- The Big equivalents for the source tuple expressions
mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc
......@@ -985,8 +983,8 @@ mkBinaryTickBox ixT ixF e = do
-- pat => !pat -- when -XStrict
-- pat => pat -- otherwise
decideBangHood :: DynFlags
-> LPat GhcTc -- ^ Original pattern
-> LPat GhcTc -- Pattern with bang if necessary
-> LPat id -- ^ Original pattern
-> LPat id -- Pattern with bang if necessary
decideBangHood dflags lpat
| not (xopt LangExt.Strict dflags)
= lpat
......@@ -995,20 +993,19 @@ decideBangHood dflags lpat
where
go lp@(L l p)
= case p of
ParPat x p -> L l (ParPat x (go p))
LazyPat _ lp' -> lp'
BangPat _ _ -> lp
_ -> L l (BangPat noExt lp)
ParPat p -> L l (ParPat (go p))
LazyPat lp' -> lp'
BangPat _ -> lp
_ -> L l (BangPat lp)
-- | Unconditionally make a 'Pat' strict.
addBang :: LPat GhcTc -- ^ Original pattern
-> LPat GhcTc -- ^ Banged pattern
addBang :: LPat id -- ^ Original pattern
-> LPat id -- ^ Banged pattern
addBang = go
where
go lp@(L l p)
= case p of
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)
ParPat p -> L l (ParPat (go p))
LazyPat lp' -> L l (BangPat lp')
BangPat _ -> lp
_ -> L l (BangPat lp)
This diff is collapsed.
......@@ -102,8 +102,6 @@ dsLit (HsRat _ (FL _ _ val) ty) = do
(head (tyConDataCons tycon), i_ty)
x -> pprPanic "dsLit" (ppr x)
dsLit (XLit x) = pprPanic "dsLit" (ppr x)
dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr
dsOverLit lit = do { dflags <- getDynFlags
; warnAboutOverflowedLiterals dflags lit
......@@ -112,12 +110,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_ext = OverLitTc rebindable ty
, ol_witness = witness })
dsOverLit' dflags (OverLit { ol_val = val, ol_rebindable = rebindable
, ol_witness = witness, ol_type = ty })
| 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]
~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -241,14 +239,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_ext = OverLitTc _ ty })
getIntegralLit (OverLit { ol_val = HsIntegral i, ol_type = ty })
| Just tc <- tyConAppTyCon_maybe ty
= Just (il_value i, tyConName tc)
getIntegralLit _ = Nothing
......@@ -275,7 +273,7 @@ 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 noExt lit
tidyLitPat lit = LitPat lit
----------------
tidyNPat :: (HsLit GhcTc -> Pat GhcTc) -- How to tidy a LitPat
......@@ -286,7 +284,7 @@ tidyNPat :: (HsLit GhcTc -> Pat GhcTc) -- How to tidy a LitPat
-> HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> SyntaxExpr GhcTc
-> Type
-> Pat GhcTc
tidyNPat tidy_lit_pat (OverLit (OverLitTc False ty) val _) mb_neg _eq outer_ty
tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty
-- False: Take short cuts only if the literal is not using rebindable syntax
--
-- Once that is settled, look for cases where the type of the
......@@ -315,8 +313,7 @@ tidyNPat tidy_lit_pat (OverLit (OverLitTc False ty) val _) 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 noExt lit] [])
mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] [])
mb_int_lit :: Maybe Integer
mb_int_lit = case (mb_neg, val) of
......@@ -330,7 +327,7 @@ tidyNPat tidy_lit_pat (OverLit (OverLitTc False ty) val _) mb_neg _eq outer_ty
_ -> Nothing
tidyNPat _ over_lit mb_neg eq outer_ty
= NPat outer_ty (noLoc over_lit) mb_neg eq
= NPat (noLoc over_lit) mb_neg eq outer_ty
{-
************************************************************************
......@@ -364,7 +361,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)
......@@ -412,7 +409,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
......@@ -443,7 +440,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]
......@@ -455,7 +452,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)
......
......@@ -236,32 +236,32 @@ 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 (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)
hsExprToPmExpr e@(NegApp _ neg_e)
| PmExprLit (PmOLit False ol) <- synExprToPmExpr neg_e
= PmExprLit (PmOLit True ol)
| otherwise = PmExprOther e
hsExprToPmExpr (HsPar _ (L _ e)) = hsExprToPmExpr e
hsExprToPmExpr (HsPar (L _ e)) = hsExprToPmExpr e
hsExprToPmExpr e@(ExplicitTuple _ ps boxity)
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 _ mb_ol elems)
hsExprToPmExpr e@(ExplicitList _elem_ty 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 _ elems)
hsExprToPmExpr (ExplicitPArr _elem_ty elems)
= mkPmExprData (parrFakeCon (length elems)) (map lhsExprToPmExpr elems)
......@@ -272,15 +272,16 @@ hsExprToPmExpr (ExplicitPArr _ 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 (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 (ExprWithTySigOut e _) = lhsExprToPmExpr e
hsExprToPmExpr (HsWrap _ e) = hsExprToPmExpr e
hsExprToPmExpr e = PmExprOther e -- the rest are not handled by the oracle
synExprToPmExpr :: SyntaxExpr GhcTc -> PmExpr
......
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
......@@ -5,7 +5,6 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
module HsExpr where
......@@ -13,7 +12,7 @@ import SrcLoc ( Located )
import Outputable ( SDoc, Outputable )
import {-# SOURCE #-} HsPat ( LPat )
import BasicTypes ( SpliceExplicitFlag(..))
import HsExtension ( OutputableBndrId, DataIdLR, SourceTextX, GhcPass )
import HsExtension ( OutputableBndrId, DataId, SourceTextX )
import Data.Data hiding ( Fixity )
type role HsExpr nominal
......@@ -29,39 +28,32 @@ data MatchGroup (a :: *) (body :: *)
data GRHSs (a :: *) (body :: *)
data SyntaxExpr (i :: *)
instance (DataIdLR p p) => Data (HsSplice p)
instance (DataIdLR p p) => Data (HsExpr p)
instance (DataIdLR p p) => Data (HsCmd p)
instance (Data body,DataIdLR p p) => Data (MatchGroup p body)
instance (Data body,DataIdLR p p) => Data (GRHSs p body)
instance (DataIdLR p p) => Data (SyntaxExpr p)
instance (DataId p) => Data (HsSplice p)
instance (DataId p) => Data (HsExpr p)
instance (DataId p) => Data (HsCmd p)
instance (Data body,DataId p) => Data (MatchGroup p body)
instance (Data body,DataId p) => Data (GRHSs p body)
instance (DataId p) => Data (SyntaxExpr p)
instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
=> Outputable (HsExpr (GhcPass p))
instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
=> Outputable (HsCmd (GhcPass p))
instance (SourceTextX p, OutputableBndrId p) => Outputable (HsExpr p)
instance (SourceTextX p, OutputableBndrId p) => Outputable (HsCmd p)
type LHsExpr a = Located (HsExpr a)
pprLExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
=> LHsExpr (GhcPass p) -> SDoc
pprLExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc
pprExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
=> HsExpr (GhcPass p) -> SDoc
pprExpr :: (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc
pprSplice :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
=> HsSplice (GhcPass p) -> SDoc
pprSplice :: (SourceTextX p, OutputableBndrId p) => HsSplice p -> SDoc
pprSpliceDecl :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
=> HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc