#include "HsVersions.h"
+import {-# SOURCE #-} DsExpr( dsExpr )
import CmdLineOpts ( DynFlag(..), dopt )
import HsSyn
-import TcHsSyn ( TypecheckedPat, TypecheckedMatch, TypecheckedMatchContext )
-import DsHsSyn ( outPatType )
+import TcHsSyn ( TypecheckedPat, TypecheckedMatch, TypecheckedMatchContext, outPatType )
import Check ( check, ExhaustivePat )
import CoreSyn
import CoreUtils ( bindNonRec )
import MatchCon ( matchConFamily )
import MatchLit ( matchLiterals )
import PrelInfo ( pAT_ERROR_ID )
-import Type ( splitAlgTyConApp, mkTyVarTys, Type )
-import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy, tupleCon )
+import TcType ( mkTyVarTys, Type, tcTyConAppArgs, tcEqType )
+import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy,
+ tupleCon, parrFakeCon, mkPArrTy )
import BasicTypes ( Boxity(..) )
import UniqSet
import ErrUtils ( addWarnLocHdrLine, dontAddErrLoc )
+import Util ( lengthExceeds )
import Outputable
\end{code}
match vars qs
where (pats,indexs) = check qs
incomplete = dopt Opt_WarnIncompletePatterns dflags
- && (length pats /= 0)
+ && (not (null pats))
shadow = dopt Opt_WarnOverlappingPatterns dflags
&& sizeUniqSet indexs < no_eqns
no_eqns = length qs
dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM ()
dsShadowWarn ctx@(DsMatchContext kind _ _) qs = dsWarn warn
where
- warn | length qs > maximum_output
+ warn | qs `lengthExceeds` maximum_output
= pp_context ctx (ptext SLIT("are overlapped"))
(\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$
ptext SLIT("..."))
(take maximum_output pats))
$$ dots))
- dots | length pats > maximum_output = ptext SLIT("...")
- | otherwise = empty
+ dots | pats `lengthExceeds` maximum_output = ptext SLIT("...")
+ | otherwise = empty
pp_context NoMatchContext msg rest_of_msg_fun
= dontAddErrLoc (ptext SLIT("Some match(es)") <+> hang msg 8 (rest_of_msg_fun id))
\begin{code}
match [] eqns_info
- = complete_matches eqns_info
+ = returnDs (foldr1 combineMatchResults match_results)
where
- complete_matches [eqn]
- = complete_match eqn
-
- complete_matches (eqn:eqns)
- = complete_match eqn `thenDs` \ match_result1 ->
- complete_matches eqns `thenDs` \ match_result2 ->
- returnDs (combineMatchResults match_result1 match_result2)
-
- complete_match (EqnInfo _ _ pats match_result)
- = ASSERT( null pats )
- returnDs match_result
+ match_results = [ ASSERT( null pats) mr
+ | EqnInfo _ _ pats mr <- eqns_info ]
\end{code}
+
%************************************************************************
%* *
%* match: non-empty rule *
\item
Removing lazy (irrefutable) patterns (you don't want to know...).
\item
-Converting explicit tuple- and list-pats into ordinary @ConPats@.
+Converting explicit tuple-, list-, and parallel-array-pats into ordinary
+@ConPats@.
\item
Convert the literal pat "" to [].
\end{itemize}
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)
pats = map mk_pat tagged_arg_tys
-- Boring stuff to find the arg-tys of the constructor
- (_, inst_tys, _) = splitAlgTyConApp pat_ty
+ inst_tys = tcTyConAppArgs pat_ty -- Newtypes must be opaque
con_arg_tys' = dataConInstOrigArgTys data_con (inst_tys ++ mkTyVarTys ex_tvs)
tagged_arg_tys = con_arg_tys' `zip` (dataConFieldLabels data_con)
(ConPat nilDataCon list_ty [] [] [])
pats
+-- introduce fake parallel array constructors to be able to handle parallel
+-- arrays with the existing machinery for constructor pattern
+--
+tidy1 v (PArrPat ty pats) match_result
+ = returnDs (parrConPat, match_result)
+ where
+ arity = length pats
+ parrConPat = ConPat (parrFakeCon arity) (mkPArrTy ty) [] [] pats
+
tidy1 v (TuplePat pats boxity) match_result
= returnDs (tuple_ConPat, match_result)
where
where
first_pat = head column_1_pats
- column_1_pats = [pat | EqnInfo _ _ (pat:_) _ <- eqns_info]
+ column_1_pats = [pat | EqnInfo _ _ (pat:_) _ <- eqns_info]
remaining_eqns_info = [EqnInfo n ctx pats match_result | EqnInfo n ctx (_:pats) match_result <- eqns_info]
\end{code}
let
result_ty = head result_tys
in
- ASSERT( all (== result_ty) result_tys )
+ ASSERT( all (tcEqType result_ty) result_tys )
returnDs (result_ty, eqn_infos)
where
- flatten_match (Match _ pats _ grhss, n)
+ flatten_match (Match pats _ grhss, n)
= dsGRHSs kind pats grhss `thenDs` \ (ty, match_result) ->
getSrcLocDs `thenDs` \ locn ->
returnDs (ty, EqnInfo n (DsMatchContext kind pats locn) pats match_result)