Commit 6a05ec5e authored by Dan Licata's avatar Dan Licata

View patterns, record wildcards, and record puns

This patch implements three new features:
* view patterns (syntax: expression -> pat in a pattern)
* working versions of record wildcards and record puns
See the manual for detailed descriptions.

Other minor observable changes:
* There is a check prohibiting local fixity declarations
  when the variable being fixed is not defined in the same let
* The warn-unused-binds option now reports warnings for do and mdo stmts

Implementation notes: 

* The pattern renamer is now in its own module, RnPat, and the
implementation is now in a CPS style so that the correct context is
delivered to pattern expressions.

* These features required a fairly major upheaval to the renamer.
Whereas the old version used to collect up all the bindings from a let
(or top-level, or recursive do statement, ...) and put them into scope
before renaming anything, the new version does the collection as it
renames.  This allows us to do the right thing with record wildcard
patterns (which need to be expanded to see what names should be
collected), and it allows us to implement the desired semantics for view
patterns in lets.  This change had a bunch of domino effects brought on
by fiddling with the top-level renaming.

* Prior to this patch, there was a tricky bug in mkRecordSelId in HEAD,
which did not maintain the invariant necessary for loadDecl.  See note
[Tricky iface loop] for details.
parent 62023058
......@@ -87,15 +87,20 @@ differently, as follows.
Note [Data Constructor Naming]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Each data constructor C has two, and possibly three, Names associated with it:
Each data constructor C has two, and possibly up to four, Names associated with it:
OccName Name space Used for
OccName Name space Name of
---------------------------------------------------------------------------
* The "source data con" C DataName The DataCon itself
* The "real data con" C VarName Its worker Id
* The "wrapper data con" $WC VarName Wrapper Id (optional)
Each of these three has a distinct Unique. The "source data con" name
* The "data con itself" C DataName DataCon
* The "worker data con" C VarName Id (the worker)
* The "wrapper data con" $WC VarName Id (the wrapper)
* The "newtype coercion" :CoT TcClsName TyCon
EVERY data constructor (incl for newtypes) has the former two (the
data con itself, and its worker. But only some data constructors have a
wrapper (see Note [The need for a wrapper]).
Each of these three has a distinct Unique. The "data con itself" name
appears in the output of the renamer, and names the Haskell-source
data constructor. The type checker translates it into either the wrapper Id
(if it exists) or worker Id (otherwise).
......@@ -129,6 +134,8 @@ The "wrapper Id", $WC, goes as follows
nothing for the wrapper to do. That is, if its defn would be
$wC = C
Note [The need for a wrapper]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Why might the wrapper have anything to do? Two reasons:
* Unboxing strict fields (with -funbox-strict-fields)
......@@ -152,6 +159,8 @@ Why might the wrapper have anything to do? Two reasons:
The third argument is a coerion
[a] :: [a]:=:[a]
INVARIANT: the dictionary constructor for a class
never has a wrapper.
A note about the stupid context
......
%
\%
% (c) The University of Glasgow 2006
% (c) The AQUA Project, Glasgow University, 1998
%
......@@ -498,20 +498,37 @@ gotten by appying the eq_spec to the univ_tvs of the data con.
mkRecordSelId :: TyCon -> FieldLabel -> Id
mkRecordSelId tycon field_label
-- Assumes that all fields with the same field label have the same type
| is_naughty = naughty_id
| otherwise = sel_id
= sel_id
where
is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tv_set)
-- Because this function gets called by implicitTyThings, we need to
-- produce the OccName of the Id without doing any suspend type checks.
-- (see the note [Tricky iface loop]).
-- A suspended type-check is sometimes necessary to compute field_ty,
-- so we need to make sure that we suspend anything that depends on field_ty.
-- the overall result
sel_id = mkGlobalId sel_id_details field_label theType theInfo
-- check whether the type is naughty: this thunk does not get forced
-- until the type is actually needed
field_ty = dataConFieldType con1 field_label
is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tv_set)
-- it's important that this doesn't force the if
(theType, theInfo) = if is_naughty
-- Escapist case here for naughty constructors
-- We give it no IdInfo, and a type of forall a.a (never looked at)
then (forall_a_a, noCafIdInfo)
-- otherwise do the real case
else (selector_ty, info)
sel_id_details = RecordSelId { sel_tycon = tycon, sel_label = field_label, sel_naughty = is_naughty }
-- For a data type family, the tycon is the *instance* TyCon
-- For a data type family, the tycon is the *instance* TyCon
-- Escapist case here for naughty constructors
-- We give it no IdInfo, and a type of forall a.a (never looked at)
naughty_id = mkGlobalId sel_id_details field_label forall_a_a noCafIdInfo
-- for naughty case
forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar)
-- Normal case starts here
sel_id = mkGlobalId sel_id_details field_label selector_ty info
-- real case starts here:
data_cons = tyConDataCons tycon
data_cons_w_field = filter has_field data_cons -- Can't be empty!
has_field con = field_label `elem` dataConFieldLabels con
......@@ -522,7 +539,6 @@ mkRecordSelId tycon field_label
-- only the family TyCon, not the instance TyCon
data_tv_set = tyVarsOfType data_ty
data_tvs = varSetElems data_tv_set
field_ty = dataConFieldType con1 field_label
-- *Very* tiresomely, the selectors are (unnecessarily!) overloaded over
-- just the dictionaries in the types of the constructors that contain
......
......@@ -29,6 +29,7 @@ import Name
import Unique(Unique)
import UniqFM
import Maybes
import Outputable
\end{code}
%************************************************************************
......@@ -38,7 +39,7 @@ import Maybes
%************************************************************************
\begin{code}
type NameEnv a = UniqFM a -- Domain is Name
newtype NameEnv a = A (UniqFM a) -- Domain is Name
emptyNameEnv :: NameEnv a
mkNameEnv :: [(Name,a)] -> NameEnv a
......@@ -61,26 +62,31 @@ foldNameEnv :: (a -> b -> b) -> b -> NameEnv a -> b
filterNameEnv :: (elt -> Bool) -> NameEnv elt -> NameEnv elt
mapNameEnv :: (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2
emptyNameEnv = emptyUFM
foldNameEnv = foldUFM
mkNameEnv = listToUFM
nameEnvElts = eltsUFM
nameEnvUniqueElts = ufmToList
extendNameEnv_C = addToUFM_C
extendNameEnv_Acc = addToUFM_Acc
extendNameEnv = addToUFM
plusNameEnv = plusUFM
plusNameEnv_C = plusUFM_C
extendNameEnvList = addListToUFM
extendNameEnvList_C = addListToUFM_C
delFromNameEnv = delFromUFM
delListFromNameEnv = delListFromUFM
elemNameEnv = elemUFM
unitNameEnv = unitUFM
filterNameEnv = filterUFM
mapNameEnv = mapUFM
nameEnvElts (A x) = eltsUFM x
emptyNameEnv = A emptyUFM
unitNameEnv x y = A $ unitUFM x y
extendNameEnv (A x) y z = A $ addToUFM x y z
extendNameEnvList (A x) l = A $ addListToUFM x l
lookupNameEnv (A x) y = lookupUFM x y
mkNameEnv l = A $ listToUFM l
elemNameEnv x (A y) = elemUFM x y
foldNameEnv a b (A c) = foldUFM a b c
occEnvElts (A x) = eltsUFM x
plusNameEnv (A x) (A y) = A $ plusUFM x y
plusNameEnv_C f (A x) (A y) = A $ plusUFM_C f x y
extendNameEnv_C f (A x) y z = A $ addToUFM_C f x y z
mapNameEnv f (A x) = A $ mapUFM f x
mkNameEnv_C comb l = A $ addListToUFM_C comb emptyUFM l
nameEnvUniqueElts (A x) = ufmToList x
extendNameEnv_Acc x y (A z) a b = A $ addToUFM_Acc x y z a b
extendNameEnvList_C x (A y) z = A $ addListToUFM_C x y z
delFromNameEnv (A x) y = A $ delFromUFM x y
delListFromNameEnv (A x) y = A $ delListFromUFM x y
filterNameEnv x (A y) = A $ filterUFM x y
lookupNameEnv = lookupUFM
lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupUFM env n)
lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupNameEnv env n)
instance Outputable a => Outputable (NameEnv a) where
ppr (A x) = ppr x
\end{code}
......@@ -56,13 +56,14 @@ module OccName (
OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, mapOccEnv,
lookupOccEnv, mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv,
occEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C,
filterOccEnv, delListFromOccEnv, delFromOccEnv,
-- The OccSet type
OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet,
extendOccSetList,
unionOccSets, unionManyOccSets, minusOccSet, elemOccSet, occSetElts,
foldOccSet, isEmptyOccSet, intersectOccSet, intersectsOccSet,
-- Tidying up
TidyOccEnv, emptyTidyOccEnv, tidyOccName, initTidyOccEnv,
......@@ -262,7 +263,7 @@ instance Uniquable OccName where
TvName -> 'v'
TcClsName -> 't'
type OccEnv a = UniqFM a
newtype OccEnv a = A (UniqFM a)
emptyOccEnv :: OccEnv a
unitOccEnv :: OccName -> a -> OccEnv a
......@@ -278,22 +279,30 @@ extendOccEnv_C :: (a->a->a) -> OccEnv a -> OccName -> a -> OccEnv a
plusOccEnv :: OccEnv a -> OccEnv a -> OccEnv a
plusOccEnv_C :: (a->a->a) -> OccEnv a -> OccEnv a -> OccEnv a
mapOccEnv :: (a->b) -> OccEnv a -> OccEnv b
emptyOccEnv = emptyUFM
unitOccEnv = unitUFM
extendOccEnv = addToUFM
extendOccEnvList = addListToUFM
lookupOccEnv = lookupUFM
mkOccEnv = listToUFM
elemOccEnv = elemUFM
foldOccEnv = foldUFM
occEnvElts = eltsUFM
plusOccEnv = plusUFM
plusOccEnv_C = plusUFM_C
extendOccEnv_C = addToUFM_C
mapOccEnv = mapUFM
mkOccEnv_C comb l = addListToUFM_C comb emptyOccEnv l
delFromOccEnv :: OccEnv a -> OccName -> OccEnv a
delListFromOccEnv :: OccEnv a -> [OccName] -> OccEnv a
filterOccEnv :: (elt -> Bool) -> OccEnv elt -> OccEnv elt
emptyOccEnv = A emptyUFM
unitOccEnv x y = A $ unitUFM x y
extendOccEnv (A x) y z = A $ addToUFM x y z
extendOccEnvList (A x) l = A $ addListToUFM x l
lookupOccEnv (A x) y = lookupUFM x y
mkOccEnv l = A $ listToUFM l
elemOccEnv x (A y) = elemUFM x y
foldOccEnv a b (A c) = foldUFM a b c
occEnvElts (A x) = eltsUFM x
plusOccEnv (A x) (A y) = A $ plusUFM x y
plusOccEnv_C f (A x) (A y) = A $ plusUFM_C f x y
extendOccEnv_C f (A x) y z = A $ addToUFM_C f x y z
mapOccEnv f (A x) = A $ mapUFM f x
mkOccEnv_C comb l = A $ addListToUFM_C comb emptyUFM l
delFromOccEnv (A x) y = A $ delFromUFM x y
delListFromOccEnv (A x) y = A $ delListFromUFM x y
filterOccEnv x (A y) = A $ filterUFM x y
instance Outputable a => Outputable (OccEnv a) where
ppr (A x) = ppr x
type OccSet = UniqFM OccName
......
......@@ -216,7 +216,9 @@ check' qs
| literals = split_by_literals qs
| constructors = split_by_constructor qs
| only_vars = first_column_only_vars qs
| otherwise = pprPanic "Check.check': Not implemented :-(" (ppr first_pats)
-- FIXME: hack to get view patterns through for now
| otherwise = ([([],[])],emptyUniqSet)
-- pprPanic "Check.check': Not implemented :-(" (ppr first_pats)
where
-- Note: RecPats will have been simplified to ConPats
-- at this stage.
......@@ -430,9 +432,9 @@ get_lit :: Pat id -> Maybe HsLit
-- It doesn't matter which one, because they will only be compared
-- with other HsLits gotten in the same way
get_lit (LitPat lit) = Just lit
get_lit (NPat (HsIntegral i _) mb _ _) = Just (HsIntPrim (mb_neg mb i))
get_lit (NPat (HsFractional f _) mb _ _) = Just (HsFloatPrim (mb_neg mb f))
get_lit (NPat (HsIsString s _) _ _ _) = Just (HsStringPrim s)
get_lit (NPat (HsIntegral i _ _) mb _) = Just (HsIntPrim (mb_neg mb i))
get_lit (NPat (HsFractional f _ _) mb _) = Just (HsFloatPrim (mb_neg mb f))
get_lit (NPat (HsIsString s _ _) _ _) = Just (HsStringPrim s)
get_lit other_pat = Nothing
mb_neg :: Num a => Maybe b -> a -> a
......@@ -484,7 +486,7 @@ is_con _ = False
is_lit :: Pat Id -> Bool
is_lit (LitPat _) = True
is_lit (NPat _ _ _ _) = True
is_lit (NPat _ _ _) = True
is_lit _ = False
is_var :: Pat Id -> Bool
......@@ -610,6 +612,7 @@ has_nplusk_pat :: Pat Id -> Bool
has_nplusk_pat (NPlusKPat _ _ _ _) = True
has_nplusk_pat (ParPat p) = has_nplusk_lpat p
has_nplusk_pat (AsPat _ p) = has_nplusk_lpat p
has_nplusk_pat (ViewPat _ p _) = has_nplusk_lpat p
has_nplusk_pat (SigPatOut p _ ) = has_nplusk_lpat p
has_nplusk_pat (ListPat ps _) = any has_nplusk_lpat ps
has_nplusk_pat (TuplePat ps _ _) = any has_nplusk_lpat ps
......@@ -631,6 +634,9 @@ simplify_pat (LazyPat p) = WildPat (hsLPatType p) -- For overlap and exhaus
-- purposes, a ~pat is like a wildcard
simplify_pat (BangPat p) = unLoc (simplify_lpat p)
simplify_pat (AsPat id p) = unLoc (simplify_lpat p)
simplify_pat (ViewPat expr p ty) = ViewPat expr (simplify_lpat p) ty
simplify_pat (SigPatOut p _) = unLoc (simplify_lpat p) -- I'm not sure this is right
simplify_pat pat@(ConPatOut { pat_con = L loc id, pat_args = ps })
......@@ -665,7 +671,7 @@ simplify_pat pat@(LitPat (HsString s)) =
mk_char_lit c = mkPrefixConPat charDataCon [nlLitPat (HsCharPrim c)] charTy
simplify_pat (LitPat lit) = tidyLitPat lit
simplify_pat (NPat lit mb_neg eq lit_ty) = tidyNPat lit mb_neg eq lit_ty
simplify_pat (NPat lit mb_neg eq) = tidyNPat lit mb_neg eq
simplify_pat (NPlusKPat id hslit hsexpr1 hsexpr2)
= WildPat (idType (unLoc id))
......
......@@ -637,7 +637,7 @@ bindLocals :: [Id] -> TM a -> TM a
bindLocals new_ids (TM m)
= TM $ \ env st ->
case m env{ inScope = inScope env `extendVarSetList` new_ids } st of
(r, fv, st') -> (r, fv `delListFromUFM` occs, st')
(r, fv, st') -> (r, fv `delListFromOccEnv` occs, st')
where occs = [ nameOccName (idName id) | id <- new_ids ]
isBlackListed :: SrcSpan -> TM Bool
......
......@@ -1115,7 +1115,7 @@ collectl (L l pat) bndrs
collectHsBindLocatedBinders ds
++ foldr collectl bndrs (hsConPatArgs ps)
go (LitPat _) = bndrs
go (NPat _ _ _ _) = bndrs
go (NPat _ _ _) = bndrs
go (NPlusKPat n _ _ _) = n : bndrs
go (SigPatIn pat _) = collectl pat bndrs
......
......@@ -790,7 +790,7 @@ repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
do { xs <- repLPs ps; body <- repLE e; repLam xs body })
; wrapGenSyns ss lam }
repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch LambdaExpr m)
repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m)
-----------------------------------------------------------------------------
......@@ -831,8 +831,8 @@ repP (ConPatIn dc details)
p2' <- repLP p2;
repPinfix p1' con_str p2' }
}
repP (NPat l Nothing _ _) = do { a <- repOverloadedLiteral l; repPlit a }
repP p@(NPat l (Just _) _ _) = notHandled "Negative overloaded patterns" (ppr p)
repP (NPat l Nothing _) = do { a <- repOverloadedLiteral l; repPlit a }
repP p@(NPat l (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
repP p@(SigPatIn {}) = notHandled "Type signatures in patterns" (ppr p)
-- The problem is to do with scoped type variables.
-- To implement them, we have to implement the scoping rules
......@@ -1277,9 +1277,9 @@ mk_string s = do string_ty <- lookupType stringTyConName
return $ HsString s
repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
repOverloadedLiteral (HsIntegral i _) = do { lit <- mk_integer i; repLiteral lit }
repOverloadedLiteral (HsFractional f _) = do { lit <- mk_rational f; repLiteral lit }
repOverloadedLiteral (HsIsString s _) = do { lit <- mk_string s; repLiteral lit }
repOverloadedLiteral (HsIntegral i _ _) = do { lit <- mk_integer i; repLiteral lit }
repOverloadedLiteral (HsFractional f _ _) = do { lit <- mk_rational f; repLiteral lit }
repOverloadedLiteral (HsIsString s _ _) = do { lit <- mk_string s; repLiteral lit }
-- The type Rational will be in the environment, becuase
-- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
-- and rationalL is sucked in when any TH stuff is used
......
......@@ -16,7 +16,7 @@
module DsMonad (
DsM, mappM, mapAndUnzipM,
initDs, initDsTc, returnDs, thenDs, listDs, fixDs, mapAndUnzipDs,
foldlDs, foldrDs,
foldlDs, foldrDs, ifOptDs,
newTyVarsDs, newLocalName,
duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
......@@ -130,7 +130,7 @@ listDs = sequenceM
foldlDs = foldlM
foldrDs = foldrM
mapAndUnzipDs = mapAndUnzipM
ifOptDs = ifOptM
type DsWarning = (SrcSpan, SDoc)
-- Not quite the same as a WarnMsg, we have an SDoc here
......
......@@ -25,7 +25,7 @@ module DsUtils (
cantFailMatchResult, alwaysFailMatchResult,
extractMatchResult, combineMatchResults,
adjustMatchResult, adjustMatchResultDs,
mkCoLetMatchResult, mkGuardedMatchResult,
mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult,
matchCanFail, mkEvalMatchResult,
mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
wrapBind, wrapBinds,
......@@ -319,6 +319,12 @@ seqVar var body = Case (Var var) var (exprType body)
mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
mkCoLetMatchResult bind = adjustMatchResult (mkDsLet bind)
-- (mkViewMatchResult var' viewExpr var mr) makes the expression
-- let var' = viewExpr var in mr
mkViewMatchResult :: Id -> CoreExpr -> Id -> MatchResult -> MatchResult
mkViewMatchResult var' viewExpr var =
adjustMatchResult (mkDsLet (NonRec var' (mkDsApp viewExpr (Var var))))
mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult
mkEvalMatchResult var ty
= adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)])
......
......@@ -17,6 +17,8 @@ module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat
#include "HsVersions.h"
import {-#SOURCE#-} DsExpr (dsLExpr)
import DynFlags
import HsSyn
import TcHsSyn
......@@ -274,8 +276,13 @@ match vars@(v:_) ty eqns
(aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
-- Group the equations and match each group in turn
; match_results <- mapM match_group (groupEquations tidy_eqns)
; let grouped = (groupEquations tidy_eqns)
-- print the view patterns that are commoned up to help debug
; ifOptDs Opt_D_dump_view_pattern_commoning (debug grouped)
; match_results <- mapM match_group grouped
; return (adjustMatchResult (foldr1 (.) aux_binds) $
foldr1 combineMatchResults match_results) }
where
......@@ -284,14 +291,30 @@ match vars@(v:_) ty eqns
match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult
match_group eqns@((group,_) : _)
= case group of
PgAny -> matchVariables vars ty (dropGroup eqns)
PgCon _ -> matchConFamily vars ty (subGroups eqns)
PgLit _ -> matchLiterals vars ty (subGroups eqns)
PgN lit -> matchNPats vars ty (subGroups eqns)
PgNpK lit -> matchNPlusKPats vars ty (dropGroup eqns)
PgBang -> matchBangs vars ty (dropGroup eqns)
PgCo _ -> matchCoercion vars ty (dropGroup eqns)
= case group of
PgAny -> matchVariables vars ty (dropGroup eqns)
PgCon _ -> matchConFamily vars ty (subGroups eqns)
PgLit _ -> matchLiterals vars ty (subGroups eqns)
PgN lit -> matchNPats vars ty (subGroups eqns)
PgNpK lit -> matchNPlusKPats vars ty (dropGroup eqns)
PgBang -> matchBangs vars ty (dropGroup eqns)
PgCo _ -> matchCoercion vars ty (dropGroup eqns)
PgView _ _ -> matchView vars ty (dropGroup eqns)
-- FIXME: we should also warn about view patterns that should be
-- commoned up but are not
-- print some stuff to see what's getting grouped
-- use -dppr-debug to see the resolution of overloaded lits
debug eqns =
let gs = map (\group -> foldr (\ (p,_) -> \acc ->
case p of PgView e _ -> e:acc
_ -> acc) [] group) eqns
maybeWarn [] = return ()
maybeWarn l = warnDs (vcat l)
in
maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g))
(filter (not . null) gs))
matchVariables :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
-- Real true variables, just like in matchVar, SLPJ p 94
......@@ -300,23 +323,40 @@ matchVariables (var:vars) ty eqns = match vars ty (shiftEqns eqns)
matchBangs :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
matchBangs (var:vars) ty eqns
= do { match_result <- match (var:vars) ty (map shift eqns)
= do { match_result <- match (var:vars) ty (map decomposeFirst_Bang eqns)
; return (mkEvalMatchResult var ty match_result) }
where
shift eqn@(EqnInfo { eqn_pats = BangPat pat : pats })
= eqn { eqn_pats = unLoc pat : pats }
matchCoercion :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
-- Apply the coercion to the match variable and then match that
matchCoercion (var:vars) ty (eqn1:eqns)
matchCoercion (var:vars) ty (eqns@(eqn1:_))
= do { let CoPat co pat _ = firstPat eqn1
; var' <- newUniqueId (idName var) (hsPatType pat)
; match_result <- match (var':vars) ty (map shift (eqn1:eqns))
; match_result <- match (var':vars) ty (map decomposeFirst_Coercion eqns)
; rhs <- dsCoercion co (return (Var var))
; return (mkCoLetMatchResult (NonRec var' rhs) match_result) }
where
shift eqn@(EqnInfo { eqn_pats = CoPat _ pat _ : pats })
= eqn { eqn_pats = pat : pats }
matchView :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
-- Apply the view function to the match variable and then match that
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
-- do the rest of the compilation
; var' <- newUniqueId (idName var) (hsPatType pat)
; match_result <- match (var':vars) ty (map decomposeFirst_View eqns)
-- compile the view expressions
; viewExpr' <- dsLExpr viewExpr
; return (mkViewMatchResult var' viewExpr' var match_result) }
-- decompose the first pattern and leave the rest alone
decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
= eqn { eqn_pats = extractpat pat : pats}
decomposeFirst_Coercion = decomposeFirstPat (\ (CoPat _ pat _) -> pat)
decomposeFirst_Bang = decomposeFirstPat (\ (BangPat pat ) -> unLoc pat)
decomposeFirst_View = decomposeFirstPat (\ (ViewPat _ pat _) -> unLoc pat)
\end{code}
%************************************************************************
......@@ -459,8 +499,8 @@ tidy1 v (LitPat lit)
= returnDs (idDsWrapper, tidyLitPat lit)
-- NPats: we *might* be able to replace these w/ a simpler form
tidy1 v (NPat lit mb_neg eq lit_ty)
= returnDs (idDsWrapper, tidyNPat lit mb_neg eq lit_ty)
tidy1 v (NPat lit mb_neg eq)
= returnDs (idDsWrapper, tidyNPat lit mb_neg eq)
-- Everything else goes through unchanged...
......@@ -710,7 +750,9 @@ data PatGroup
| PgBang -- Bang patterns
| PgCo Type -- Coercion patterns; the type is the type
-- of the pattern *inside*
| PgView (LHsExpr Id) -- view pattern (e -> p):
-- the LHsExpr is the expression e
Type -- the Type is the type of p (equivalently, the result type of e)
groupEquations :: [EquationInfo] -> [[(PatGroup, EquationInfo)]]
-- If the result is of form [g1, g2, g3],
......@@ -750,16 +792,102 @@ sameGroup (PgCo t1) (PgCo t2) = t1 `coreEqType` t2
-- enclosed pattern is the same. The patterns outside the CoPat
-- always have the same type, so this boils down to saying that
-- the two coercions are identical.
sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2)
-- ViewPats are in the same gorup iff the expressions
-- are "equal"---conservatively, we use syntactic equality
sameGroup _ _ = False
-- an approximation of syntactic equality used for determining when view
-- exprs are in the same group.
-- this function can always safely return false;
-- but doing so will result in the application of the view function being repeated.
--
-- currently: compare applications of literals and variables
-- and anything else that we can do without involving other
-- HsSyn types in the recursion
--
-- NB we can't assume that the two view expressions have the same type. Consider
-- f (e1 -> True) = ...
-- f (e2 -> "hi") = ...
viewLExprEq :: (LHsExpr Id,Type) -> (LHsExpr Id,Type) -> Bool
viewLExprEq (e1,t1) (e2,t2) =
let
-- short name for recursive call on unLoc
lexp e e' = exp (unLoc e) (unLoc e')
-- check that two lists have the same length
-- and that they match up pairwise
lexps [] [] = True
lexps [] (_:_) = False
lexps (_:_) [] = False
lexps (x:xs) (y:ys) = lexp x y && lexps xs ys
-- conservative, in that it demands that wrappers be
-- syntactically identical and doesn't look under binders
--
-- coarser notions of equality are possible
-- (e.g., reassociating compositions,
-- equating different ways of writing a coercion)
wrap WpHole WpHole = True
wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'
wrap (WpCo c) (WpCo c') = tcEqType c c'
wrap (WpApp d) (WpApp d') = d == d'
wrap (WpTyApp t) (WpTyApp t') = tcEqType t t'
-- Enhancement: could implement equality for more wrappers
-- if it seems useful (lams and lets)
wrap _ _ = False
-- real comparison is on HsExpr's
-- strip parens
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'
-- the instance for IPName derives using the id, so this works if the
-- above does
exp (HsIPVar i) (HsIPVar i') = i == i'
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',
-- which resolve the overloading (e.g., fromInteger 1),
-- because these expressions get written as a bunch of different variables
-- (presumably to improve sharing)
tcEqType (overLitType l) (overLitType l') && l == l'
-- comparing the constants seems right
exp (HsLit l) (HsLit l') = l == l'
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') =
lexp l l' && lexp o o' && lexp ri ri'
exp (NegApp e n) (NegApp e' n') = lexp e e' && exp n n'
exp (SectionL e1 e2) (SectionL e1' e2') =
lexp e1 e1' && lexp e2 e2'
exp (SectionR e1 e2) (SectionR e1' e2') =
lexp e1 e1' && lexp e2 e2'
exp (HsIf e e1 e2) (HsIf e' e1' e2') =
lexp e e' && lexp e1 e1' && lexp e2 e2'
exp (ExplicitList _ ls) (ExplicitList _ ls') = lexps ls ls'
exp (ExplicitPArr _ ls) (ExplicitPArr _ ls') = lexps ls ls'
exp (ExplicitTuple ls _) (ExplicitTuple ls' _) = lexps ls ls'
-- Enhancement: could implement equality for more expressions
-- if it seems useful
exp _ _ = False
in
lexp e1 e2
patGroup :: Pat Id -> PatGroup
patGroup (WildPat {}) = PgAny
patGroup (BangPat {}) = PgBang
patGroup (ConPatOut { pat_con = dc }) = PgCon (unLoc dc)
patGroup (LitPat lit) = PgLit (hsLitKey lit)
patGroup (NPat olit mb_neg _ _) = PgN (hsOverLitKey olit (isJust mb_neg))
patGroup (NPat olit mb_neg _) = PgN (hsOverLitKey olit (isJust mb_neg))
patGroup (NPlusKPat _ olit _ _) = PgNpK (hsOverLitKey olit False)
patGroup (CoPat _ p _) = PgCo (hsPatType p) -- Type of inner pattern
patGroup (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern
patGroup (ViewPat expr p _) = PgView expr (hsPatType (unLoc p))
patGroup pat = pprPanic "patGroup" (ppr pat)
\end{code}
......
......@@ -90,9 +90,9 @@ dsLit (HsRat r ty)
dsOverLit :: HsOverLit Id -> DsM CoreExpr
-- Post-typechecker, the SyntaxExpr field of an OverLit contains
-- (an expression for) the literal value itself
dsOverLit (HsIntegral _ lit) = dsExpr lit
dsOverLit (HsFractional _ lit) = dsExpr lit
dsOverLit (HsIsString _ lit) = dsExpr lit
dsOverLit (HsIntegral _ lit _) = dsExpr lit
dsOverLit (HsFractional _ lit _) = dsExpr lit
dsOverLit (HsIsString _ lit _) = dsExpr lit
\end{code}
\begin{code}
......@@ -111,11 +111,11 @@ hsLitKey (HsString s) = MachStr s
hsOverLitKey :: HsOverLit a -> Bool -> Literal
-- Ditto for HsOverLit; the boolean indicates to negate
hsOverLitKey (HsIntegral i _) False = MachInt i