match :: [Id]		  -- Variables rep\'ing the exprs we\'re matching with
      -> Type             -- Type of the case expression
      -> [EquationInfo]	  -- Info about patterns, etc. (type synonym below)
      -> DsM MatchResult  -- Desugared result!

match [] ty eqns
  = ASSERT2( not (null eqns), ppr ty )
    return (foldr1 combineMatchResults match_results)
  where
    match_results = [ ASSERT( null (eqn_pats eqn) ) 
		      eqn_rhs eqn
		    | eqn <- eqns ]

match vars@(v:_) ty eqns
  = ASSERT( not (null eqns ) )
    do	{ 	-- Tidy the first pattern, generating
		-- auxiliary bindings if necessary
          (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns

		-- Group the equations and match each group in turn
        ; let grouped = groupEquations tidy_eqns

         -- print the view patterns that are commoned up to help debug
        ; ifDOptM Opt_D_dump_view_pattern_commoning (debug grouped)

	; match_results <- mapM match_group grouped
	; return (adjustMatchResult (foldr1 (.) aux_binds) $
		  foldr1 combineMatchResults match_results) }
  where
    dropGroup :: [(PatGroup,EquationInfo)] -> [EquationInfo]
    dropGroup = map snd

    match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult
    match_group [] = panic "match_group"
    match_group eqns@((group,_) : _)
        = case group of
            PgCon _    -> matchConFamily  vars ty (subGroup [(c,e) | (PgCon c, e) <- eqns])
            PgLit _    -> matchLiterals   vars ty (subGroup [(l,e) | (PgLit l, e) <- eqns])
            PgAny      -> matchVariables  vars ty (dropGroup eqns)
            PgN _      -> matchNPats      vars ty (dropGroup eqns)
            PgNpK _    -> 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
-- No binding to do: they'll all be wildcards by now (done in tidy)
matchVariables (_:vars) ty eqns = match vars ty (shiftEqns eqns)
matchVariables [] _ _ = panic "matchVariables"

matchBangs :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
matchBangs (var:vars) ty eqns
  = do	{ match_result <- match (var:vars) ty $
                          map (decomposeFirstPat getBangPat) eqns
	; return (mkEvalMatchResult var ty match_result) }
matchBangs [] _ _ = panic "matchBangs"

matchCoercion :: [Id] -> 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
	; var' <- newUniqueId var (hsPatType pat)
	; match_result <- match (var':vars) ty $
                          map (decomposeFirstPat getCoPat) eqns
	; co' <- dsHsWrapper co
        ; let rhs' = co' (Var var)
	; return (mkCoLetMatchResult (NonRec var' rhs') match_result) }
matchCoercion _ _ _ = panic "matchCoercion"

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 var (hsPatType pat)
	; match_result <- match (var':vars) ty $
                          map (decomposeFirstPat getViewPat) eqns
         -- compile the view expressions
        ; viewExpr' <- dsLExpr viewExpr
	; return (mkViewMatchResult var' viewExpr' var match_result) }
matchView _ _ _ = panic "matchView"

-- decompose the first pattern and leave the rest alone
decomposeFirstPat :: (Pat Id -> Pat Id) -> EquationInfo -> EquationInfo
decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
	= eqn { eqn_pats = extractpat pat : pats}
decomposeFirstPat _ _ = panic "decomposeFirstPat"

getCoPat, getBangPat, getViewPat :: Pat Id -> Pat Id
getCoPat (CoPat _ pat _)     = pat
getCoPat _                   = panic "getCoPat"
getBangPat (BangPat pat  )   = unLoc pat
getBangPat _                 = panic "getBangPat"
getViewPat (ViewPat _ pat _) = unLoc pat
getViewPat _                 = panic "getBangPat"

tidyEqnInfo :: Id -> EquationInfo
	    -> DsM (DsWrapper, EquationInfo)
	-- DsM'd because of internal call to dsLHsBinds
	-- 	and mkSelectorBinds.
	-- "tidy1" does the interesting stuff, looking at
	-- one pattern and fiddling the list of bindings.
	--
	-- POST CONDITION: head pattern in the EqnInfo is
	--	WildPat
	--	ConPat
	--	NPat
	--	LitPat
	--	NPlusKPat
	-- but no other

tidyEqnInfo _ (EqnInfo { eqn_pats = [] }) 
  = panic "tidyEqnInfo"

tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats })
  = do { (wrap, pat') <- tidy1 v pat
       ; return (wrap, eqn { eqn_pats = do pat' : pats }) }

tidy1 :: Id 			-- The Id being scrutinised
      -> Pat Id 		-- The pattern against which it is to be matched
      -> DsM (DsWrapper,	-- Extra bindings to do before the match
	      Pat Id) 		-- Equivalent pattern

-------------------------------------------------------
--	(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)

	-- case v of { x -> mr[] }
	-- = case v of { _ -> let x=v in mr[] }
tidy1 v (VarPat 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)
  = do	{ (wrap, pat') <- tidy1 v (unLoc pat)
	; return (wrapBind var v . wrap, pat') }

{- now, here we handle lazy patterns:
    tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
			v2 = case v of p -> v2 : ... : bs )

    where the v_i's are the binders in the pattern.

    ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing?

    The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
-}

tidy1 v (LazyPat pat)
  = do	{ sel_prs <- mkSelectorBinds pat (Var v)
	; let sel_binds =  [NonRec b rhs | (b,rhs) <- sel_prs]
	; return (mkCoreLets sel_binds, WildPat (idType v)) }

tidy1 _ (ListPat pats ty)
  = return (idDsWrapper, unLoc list_ConPat)
  where
    list_ty     = mkListTy ty
    list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] list_ty)
	      	  	(mkNilPat list_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 (mkPArrTy ty)

tidy1 _ (TuplePat pats boxity ty)
  = return (idDsWrapper, unLoc tuple_ConPat)
  where
    arity = length pats
    tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats ty

-- LitPats: we *might* be able to replace these w/ a simpler form
tidy1 _ (LitPat lit)
  = return (idDsWrapper, tidyLitPat lit)

-- NPats: we *might* be able to replace these w/ a simpler form
tidy1 _ (NPat lit mb_neg eq)
  = return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq)

-- BangPatterns: Pattern matching is already strict in constructors,
-- tuples etc, so the last case strips off the bang for thoses patterns.
tidy1 v (BangPat (L _ (LazyPat p)))       = tidy1 v (BangPat p)
tidy1 v (BangPat (L _ (ParPat p)))        = tidy1 v (BangPat p)
tidy1 _ p@(BangPat (L _(VarPat _)))       = return (idDsWrapper, p)
tidy1 _ p@(BangPat (L _ (WildPat _)))     = return (idDsWrapper, p)
tidy1 _ p@(BangPat (L _ (CoPat _ _ _)))   = return (idDsWrapper, p)
tidy1 _ p@(BangPat (L _ (SigPatIn _ _)))  = return (idDsWrapper, p)
tidy1 _ p@(BangPat (L _ (SigPatOut _ _))) = return (idDsWrapper, p)
tidy1 v (BangPat (L _ (AsPat (L _ var) pat)))
  = do	{ (wrap, pat') <- tidy1 v (BangPat pat)
        ; return (wrapBind var v . wrap, pat') }
tidy1 v (BangPat (L _ p))                   = tidy1 v p

-- Everything else goes through unchanged...

tidy1 _ non_interesting_pat
  = return (idDsWrapper, non_interesting_pat)

matchWrapper :: HsMatchContext Name	-- For shadowing warning messages
	     -> MatchGroup Id		-- Matches being desugared
	     -> DsM ([Id], CoreExpr) 	-- Results

matchWrapper ctxt (MatchGroup matches match_ty)
  = ASSERT( notNull matches )
    do	{ eqns_info   <- mapM mk_eqn_info matches
	; new_vars    <- selectMatchVars arg_pats
	; result_expr <- matchEquations ctxt new_vars eqns_info rhs_ty
	; return (new_vars, result_expr) }
  where
    arg_pats    = map unLoc (hsLMatchPats (head matches))
    n_pats	= length arg_pats
    (_, rhs_ty) = splitFunTysN n_pats match_ty

    mk_eqn_info (L _ (Match pats _ grhss))
      = do { let upats = map unLoc pats
	   ; match_result <- dsGRHSs ctxt upats grhss rhs_ty
	   ; return (EqnInfo { eqn_pats = upats, eqn_rhs  = match_result}) }


matchEquations  :: HsMatchContext Name
		-> [Id]	-> [EquationInfo] -> Type
		-> DsM CoreExpr
matchEquations ctxt vars eqns_info rhs_ty
  = do	{ locn <- getSrcSpanDs
	; let   ds_ctxt   = DsMatchContext ctxt locn
		error_doc = matchContextErrString ctxt

	; match_result <- matchCheck ds_ctxt vars rhs_ty eqns_info

	; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc
	; extractMatchResult match_result fail_expr }

matchSimply :: CoreExpr			-- Scrutinee
	    -> HsMatchContext Name	-- Match kind
	    -> LPat Id			-- Pattern it should match
	    -> CoreExpr			-- Return this if it matches
	    -> CoreExpr			-- Return this if it doesn't
	    -> DsM CoreExpr
-- Do not warn about incomplete patterns; see matchSinglePat comments
matchSimply scrut hs_ctx pat result_expr fail_expr = do
    let
      match_result = cantFailMatchResult result_expr
      rhs_ty       = exprType fail_expr
        -- Use exprType of fail_expr, because won't refine in the case of failure!
    match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result
    extractMatchResult match_result' fail_expr

matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id
	       -> Type -> MatchResult -> DsM MatchResult
-- Do not warn about incomplete patterns
-- Used for things like [ e | pat <- stuff ], where 
-- incomplete patterns are just fine
matchSinglePat (Var var) ctx (L _ pat) ty match_result 
  = do { locn <- getSrcSpanDs
       ; matchCheck (DsMatchContext ctx locn)
                    [var] ty  
                    [EqnInfo { eqn_pats = [pat], eqn_rhs  = match_result }] }

matchSinglePat scrut hs_ctx pat ty match_result
  = do { var <- selectSimpleMatchVarL pat
       ; match_result' <- matchSinglePat (Var var) hs_ctx pat ty match_result
       ; return (adjustMatchResult (bindNonRec var scrut) match_result') }

data PatGroup
  = PgAny		-- Immediate match: variables, wildcards, 
			--		    lazy patterns
  | PgCon DataCon	-- Constructor patterns (incl list, tuple)
  | PgLit Literal	-- Literal patterns
  | PgN   Literal	-- Overloaded literals
  | PgNpK Literal	-- n+k patterns
  | 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], 
-- (a) all the (pg,eq) pairs in g1 have the same pg
-- (b) none of the gi are empty
-- The ordering of equations is unchanged
groupEquations eqns
  = runs same_gp [(patGroup (firstPat eqn), eqn) | eqn <- eqns]
  where
    same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool
    (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2

subGroup :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]]
-- Input is a particular group.  The result sub-groups the 
-- equations by with particular constructor, literal etc they match.
-- Each sub-list in the result has the same PatGroup
-- See Note [Take care with pattern order]
subGroup group 
    = map reverse $ Map.elems $ foldl accumulate Map.empty group
  where
    accumulate pg_map (pg, eqn)
      = case Map.lookup pg pg_map of
          Just eqns -> Map.insert pg (eqn:eqns) pg_map
          Nothing   -> Map.insert pg [eqn]      pg_map

    -- pg_map :: Map a [EquationInfo]
    -- Equations seen so far in reverse order of appearance

sameGroup :: PatGroup -> PatGroup -> Bool
-- Same group means that a single case expression 
-- or test will suffice to match both, *and* the order
-- of testing within the group is insignificant.
sameGroup PgAny      PgAny      = True
sameGroup PgBang     PgBang     = True
sameGroup (PgCon _)  (PgCon _)  = True		-- One case expression
sameGroup (PgLit _)  (PgLit _)  = True		-- One case expression
sameGroup (PgN l1)   (PgN l2)   = l1==l2	-- Order is significant
sameGroup (PgNpK l1) (PgNpK l2) = l1==l2	-- See Note [Grouping overloaded literal patterns]
sameGroup (PgCo	t1)  (PgCo t2)  = t1 `eqType` t2
	-- CoPats are in the same goup only if the type of the
	-- 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,_) (e2,_) = lexp e1 e2
  where
    lexp :: LHsExpr Id -> LHsExpr Id -> Bool
    lexp e e' = exp (unLoc e) (unLoc e')

    ---------
    exp :: HsExpr Id -> HsExpr Id -> 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'
    -- 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)
        eqType (overLitType l) (overLitType 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 (ExplicitTuple es1 _) (ExplicitTuple es2 _) =
        eq_list tup_arg es1 es2
    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
    --   if it seems useful
    -- But no need for HsLit, ExplicitList, ExplicitTuple, 
    -- because they cannot be functions
    exp _ _  = False

    ---------
    tup_arg (Present e1) (Present e2) = lexp e1 e2
    tup_arg (Missing t1) (Missing t2) = eqType t1 t2
    tup_arg _ _ = False

    ---------
    wrap :: HsWrapper -> HsWrapper -> Bool
    -- 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 (WpCast c)  (WpCast c')     = coreEqCoercion c c'
    wrap (WpEvApp et1) (WpEvApp et2) = ev_term et1 et2
    wrap (WpTyApp t) (WpTyApp t')    = eqType t t'
    -- Enhancement: could implement equality for more wrappers
    --   if it seems useful (lams and lets)
    wrap _ _ = False

    ---------
    ev_term :: EvTerm -> EvTerm -> Bool
    ev_term (EvId a)       (EvId b)       = a==b
    ev_term (EvCoercion a) (EvCoercion b) = coreEqCoercion a b
    ev_term _ _ = False	

    ---------
    eq_list :: (a->a->Bool) -> [a] -> [a] -> Bool
    eq_list _  []     []     = True
    eq_list _  []     (_:_)  = False
    eq_list _  (_:_)  []     = False
    eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys

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 (NPlusKPat _ olit _ _)	      = PgNpK (hsOverLitKey olit False)
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)