-tidy1 v (VarPat var) match_result
- = returnDs (WildPat (idType var), match_result')
- where
- match_result' | v == var = match_result
- | otherwise = adjustMatchResult (bindNonRec var (Var v)) match_result
-
-tidy1 v (AsPat var pat) match_result
- = tidy1 v pat match_result'
- where
- match_result' | v == var = match_result
- | otherwise = adjustMatchResult (bindNonRec var (Var v)) match_result
-
-tidy1 v (SigPat pat ty fn) match_result
- = selectMatchVar pat `thenDs` \ v' ->
- tidy1 v' pat match_result `thenDs` \ (WildPat _, match_result') ->
- -- The ice is a little thin here
- -- We only expect a SigPat (with a non-trivial coercion) wrapping
- -- a variable pattern. If it was a constructor or literal pattern
- -- there would be no interesting polymorphism, and hence no coercion.
- dsExpr (HsApp fn (HsVar v)) `thenDs` \ e ->
- returnDs (WildPat ty, adjustMatchResult (bindNonRec v' e) match_result')
-
-tidy1 v (WildPat ty) match_result
- = returnDs (WildPat ty, match_result)
+-- The extra bindings etc are all wrapped around the RHS of the match
+-- so they are only available when matching is complete. But that's ok
+-- becuase, for example, in the pattern x@(...), the x can only be
+-- used in the RHS, not in the nested pattern, nor subsquent patterns
+--
+-- However this does have an awkward consequence. The bindings in
+-- a VarPatOut get wrapped around the result in right to left order,
+-- rather than left to right. This only matters if one set of
+-- bindings can mention things used in another, and that can happen
+-- if we allow equality dictionary bindings of form d1=d2.
+-- bindIInstsOfLocalFuns is now careful not to do this, but it's a wart.
+-- (Without this care in bindInstsOfLocalFuns, compiling
+-- Data.Generics.Schemes.hs fails in function everywhereBut.)
+
+-------------------------------------------------------
+-- (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 wrap (ParPat pat) = tidy1 v wrap (unLoc pat)
+tidy1 v wrap (SigPatOut pat _) = tidy1 v wrap (unLoc pat)
+tidy1 v wrap (WildPat ty) = returnDs (wrap, WildPat ty)
+
+ -- case v of { x -> mr[] }
+ -- = case v of { _ -> let x=v in mr[] }
+tidy1 v wrap (VarPat var)
+ = returnDs (wrap . wrapBind var v, WildPat (idType var))
+
+tidy1 v wrap (VarPatOut var binds)
+ = do { prs <- dsLHsBinds binds
+ ; return (wrap . wrapBind var v . mkDsLet (Rec prs),
+ WildPat (idType var)) }
+
+ -- case v of { x@p -> mr[] }
+ -- = case v of { p -> let x=v in mr[] }
+tidy1 v wrap (AsPat (L _ var) pat)
+ = tidy1 v (wrap . wrapBind var v) (unLoc pat)
+
+tidy1 v wrap (BangPat pat)
+ = tidy1 v (wrap . seqVar v) (unLoc pat)