X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FCheck.lhs;h=3996678b4e32308c18621eaee8fc29744c771fc9;hb=aafdba3bce91afb003f5f50e001e141744837bae;hp=32b47b6b04983c1da1594d18a00b48fa3379a462;hpb=2eb04ca0f8d0ec72b417cddc60672c696b4a3daa;p=ghc-hetmet.git

diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs
index 32b47b6..3996678 100644
--- 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"
@@ -209,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.
@@ -423,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
@@ -477,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
@@ -603,6 +612,7 @@ 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
@@ -624,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 })
@@ -658,7 +671,7 @@ 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))