X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FCheck.lhs;h=3996678b4e32308c18621eaee8fc29744c771fc9;hp=a81123ec41359622e3cdcc9d83da4dda8ef4b0fe;hb=6a05ec5ef5373f61b7f9f5bdc344483417fa801b;hpb=4ae1e17253f4417303e46d59f5a737cc1d7fd78e diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs index a81123e..3996678 100644 --- a/compiler/deSugar/Check.lhs +++ b/compiler/deSugar/Check.lhs @@ -5,13 +5,19 @@ % Author: Juan J. Quintela \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module Check ( check , ExhaustivePat ) where #include "HsVersions.h" import HsSyn import TcHsSyn -import TcType import DsUtils import MatchLit import Id @@ -146,7 +152,9 @@ untidy b (L loc p) = L loc (untidy' b p) untidy_con (PrefixCon pats) = PrefixCon (map untidy_pars pats) untidy_con (InfixCon p1 p2) = InfixCon (untidy_pars p1) (untidy_pars p2) -untidy_con (RecCon bs) = RecCon [ HsRecField f (untidy_pars p) d | HsRecField f p d <- bs ] +untidy_con (RecCon (HsRecFields flds dd)) + = RecCon (HsRecFields [ fld { hsRecFieldArg = untidy_pars (hsRecFieldArg fld) } + | fld <- flds ] dd) pars :: NeedPars -> WarningPat -> Pat Name pars True p = ParPat p @@ -208,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. @@ -379,7 +389,7 @@ make_row_vars used_lits (_, EqnInfo { eqn_pats = pats}) hash_x = mkInternalName unboundKey {- doesn't matter much -} (mkVarOccFS FSLIT("#x")) - noSrcLoc + noSrcSpan make_row_vars_for_constructor :: (EqnNo, EquationInfo) -> [WarningPat] make_row_vars_for_constructor (_, EqnInfo { eqn_pats = pats}) @@ -422,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 @@ -476,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 @@ -602,14 +612,15 @@ 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 has_nplusk_pat (PArrPat ps _) = any has_nplusk_lpat ps has_nplusk_pat (LazyPat p) = False -- Why? has_nplusk_pat (BangPat p) = has_nplusk_lpat p -- I think -has_nplusk_pat (ConPatOut { pat_args = ps }) = any has_nplusk_lpat (hsConArgs ps) -has_nplusk_pat p = False -- VarPat, VarPatOut, WildPat, LitPat, NPat, TypePat, DictPat +has_nplusk_pat (ConPatOut { pat_args = ps }) = any has_nplusk_lpat (hsConPatArgs ps) +has_nplusk_pat p = False -- VarPat, VarPatOut, WildPat, LitPat, NPat, TypePat simplify_lpat :: LPat Id -> LPat Id simplify_lpat p = fmap simplify_pat p @@ -623,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 }) @@ -657,26 +671,17 @@ 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)) -simplify_pat (DictPat dicts methods) - = case num_of_d_and_ms of - 0 -> simplify_pat (TuplePat [] Boxed unitTy) - 1 -> simplify_pat (head dict_and_method_pats) - _ -> simplify_pat (mkVanillaTuplePat (map noLoc dict_and_method_pats) Boxed) - where - num_of_d_and_ms = length dicts + length methods - dict_and_method_pats = map VarPat (dicts ++ methods) - simplify_pat (CoPat co pat ty) = simplify_pat pat ----------------- simplify_con con (PrefixCon ps) = PrefixCon (map simplify_lpat ps) simplify_con con (InfixCon p1 p2) = PrefixCon [simplify_lpat p1, simplify_lpat p2] -simplify_con con (RecCon fs) +simplify_con con (RecCon (HsRecFields fs _)) | null fs = PrefixCon [nlWildPat | t <- dataConOrigArgTys con] -- Special case for null patterns; maybe not a record at all | otherwise = PrefixCon (map (simplify_lpat.snd) all_pats)