%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
%
% Author: Juan J. Quintela <quintela@krilin.dc.fi.udc.es>
-\section{Module @Check@ in @deSugar@}
\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 ( hsLPatType, mkVanillaTuplePat )
-import TcType ( tcTyConAppTyCon )
-import DsUtils ( EquationInfo(..), MatchResult(..),
- CanItFail(..), firstPat )
-import MatchLit ( tidyLitPat, tidyNPat )
-import Id ( Id, idType )
-import DataCon ( DataCon, dataConTyCon, dataConOrigArgTys, dataConFieldLabels )
-import Name ( Name, mkInternalName, getOccName, isDataSymOcc,
- getName, mkVarOccFS )
+import TcHsSyn
+import DsUtils
+import MatchLit
+import Id
+import DataCon
+import Name
import TysWiredIn
-import PrelNames ( unboundKey )
-import TyCon ( tyConDataCons, tupleTyConBoxity, isTupleTyCon )
-import BasicTypes ( Boxity(..) )
-import SrcLoc ( noSrcLoc, Located(..), unLoc, noLoc )
+import PrelNames
+import TyCon
+import BasicTypes
+import SrcLoc
import UniqSet
-import Util ( takeList, splitAtList, notNull )
+import Util
import Outputable
import FastString
-
-#include "HsVersions.h"
\end{code}
This module performs checks about if one list of equations are:
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 [(f,untidy_pars p) | (f,p) <- 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
| 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.
process_literals :: [HsLit] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
process_literals used_lits qs
- | null default_eqns = ([make_row_vars used_lits (head qs)] ++ pats,indexs)
+ | null default_eqns = ASSERT( not (null qs) ) ([make_row_vars used_lits (head qs)] ++ pats,indexs)
| otherwise = (pats_default,indexs_default)
where
(pats,indexs) = process_explicit_literals used_lits qs
(pats',indexs') = check' default_eqns
pats_default = [(make_whole_con c:ps,constraints) |
c <- unused_cons, (ps,constraints) <- pats'] ++ pats
- new_wilds = make_row_vars_for_constructor (head qs)
+ new_wilds = ASSERT( not (null qs) ) make_row_vars_for_constructor (head qs)
pats_default_no_eqns = [(make_whole_con c:new_wilds,[]) | c <- unused_cons] ++ pats
indexs_default = unionUniqSets indexs' indexs
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})
-- 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 (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
mb_neg (Just _) v = -v
get_unused_cons :: [Pat Id] -> [DataCon]
-get_unused_cons used_cons = unused_cons
+get_unused_cons used_cons = ASSERT( not (null used_cons) ) unused_cons
where
(ConPatOut { pat_con = l_con, pat_ty = ty }) = head used_cons
ty_con = dataConTyCon (unLoc l_con) -- Newtype observable
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
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
-- 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 })
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)
where
-- pad out all the missing fields with WildPats.
field_pats = map (\ f -> (f, nlWildPat)) (dataConFieldLabels con)
- all_pats = foldr (\ (id,p) acc -> insertNm (getName (unLoc id)) p acc)
+ all_pats = foldr (\(HsRecField id p _) acc -> insertNm (getName (unLoc id)) p acc)
field_pats fs
insertNm nm p [] = [(nm,p)]
projects / ghc-hetmet.git / blobdiff