diff options
| author | Ian Lynagh <igloo@earth.li> | 2009-08-09 15:42:58 +0000 |
|---|---|---|
| committer | Ian Lynagh <igloo@earth.li> | 2009-08-09 15:42:58 +0000 |
| commit | a1895147d4d0480f65535c99488ba25873e97bff (patch) | |
| tree | d5c59248bb01bf1ee9eee5850665666236dd20f1 /compiler | |
| parent | cf924c1549880f9ada192d24342dc610dea1d727 (diff) | |
| download | haskell-a1895147d4d0480f65535c99488ba25873e97bff.tar.gz | |
Minor refactoring
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/deSugar/Check.lhs | 4 | ||||
| -rw-r--r-- | compiler/hsSyn/HsPat.lhs | 53 |
2 files changed, 27 insertions, 30 deletions
diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs index ec72287cea..63ce765c08 100644 --- a/compiler/deSugar/Check.lhs +++ b/compiler/deSugar/Check.lhs @@ -113,8 +113,8 @@ check :: [EquationInfo] -> ([ExhaustivePat], [EquationInfo]) check qs | has_view_pattern = ([],[]) | otherwise = (untidy_warns, shadowed_eqns) where - is_view x = hasViewPat x - has_view_pattern = any (\(EqnInfo p _) -> any is_view p) qs + eqnInfo_has_view_pattern (EqnInfo ps _) = any (hasViewPat . noLoc) ps + has_view_pattern = any eqnInfo_has_view_pattern qs (warns, used_nos) = check' ([1..] `zip` map simplify_eqn qs) untidy_warns = map untidy_exhaustive warns shadowed_eqns = [eqn | (eqn,i) <- qs `zip` [1..], diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs index 3df0160ae4..e87a6a27b4 100644 --- a/compiler/hsSyn/HsPat.lhs +++ b/compiler/hsSyn/HsPat.lhs @@ -369,36 +369,33 @@ patterns are treated specially, of course. The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are. \begin{code} -hasViewPat :: Pat id -> Bool -hasViewPat p = hasViewPat' (L undefined p) - -hasViewPat' :: LPat id -> Bool -hasViewPat' (L _ p) = go p where - go (WildPat _) = False - go (VarPat _) = False - go (VarPatOut _ _) = False - go (LazyPat p) = hasViewPat' p - go (AsPat _ p) = hasViewPat' p - go (ParPat p) = hasViewPat' p - go (BangPat p) = hasViewPat' p - go (ListPat p _) = any hasViewPat' p - go (TuplePat p _ _) = any hasViewPat' p - go (PArrPat p _) = any hasViewPat' p - go (ConPatIn _ p) = go' p +hasViewPat :: LPat id -> Bool +hasViewPat (L _ p) = go p where + go (WildPat _) = False + go (VarPat _) = False + go (VarPatOut _ _) = False + go (LazyPat p) = hasViewPat p + go (AsPat _ p) = hasViewPat p + go (ParPat p) = hasViewPat p + go (BangPat p) = hasViewPat p + go (ListPat p _) = any hasViewPat p + go (TuplePat p _ _) = any hasViewPat p + go (PArrPat p _) = any hasViewPat p + go (ConPatIn _ p) = go' p go (ConPatOut _ _ _ _ p _) = go' p - go (ViewPat _ _ _) = True - go (QuasiQuotePat _) = False - go (LitPat _) = False - go (NPat _ _ _) = False - go (NPlusKPat _ _ _ _) = False - go (TypePat _) = False - go (SigPatIn p _) = hasViewPat' p - go (SigPatOut p _) = hasViewPat' p - go (CoPat _ _ _) = False + go (ViewPat _ _ _) = True + go (QuasiQuotePat _) = False + go (LitPat _) = False + go (NPat _ _ _) = False + go (NPlusKPat _ _ _ _) = False + go (TypePat _) = False + go (SigPatIn p _) = hasViewPat p + go (SigPatOut p _) = hasViewPat p + go (CoPat _ _ _) = False go' p = case p of - PrefixCon ps -> any hasViewPat' ps - RecCon (HsRecFields fs _) -> any (hasViewPat' . hsRecFieldArg) fs - InfixCon p1 p2 -> hasViewPat' p1 || hasViewPat' p2 + PrefixCon ps -> any hasViewPat ps + RecCon (HsRecFields fs _) -> any (hasViewPat . hsRecFieldArg) fs + InfixCon p1 p2 -> hasViewPat p1 || hasViewPat p2 isWildPat :: Pat id -> Bool isWildPat (WildPat _) = True |