View patterns, record wildcards, and record puns

[ghc-hetmet.git] / compiler / deSugar / Check.lhs

diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs
index b8c61aa..3996678 100644 (file)
--- a/compiler/deSugar/Check.lhs
+++ b/compiler/deSugar/Check.lhs
@@ -5,6 +5,13 @@
 % Author: Juan J. Quintela    <quintela@krilin.dc.fi.udc.es>
 
 \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"
@@ -145,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
@@ -207,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.
@@ -378,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}) 
@@ -421,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
@@ -475,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
@@ -601,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
@@ -622,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 })
@@ -656,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)