import HsSyn
-import TcHsSyn ( TypecheckedPat, hsPatType )
+import TcHsSyn ( hsPatType )
import TcType ( tcTyConAppTyCon )
import DsUtils ( EquationInfo(..), MatchResult(..), EqnSet,
CanItFail(..), tidyLitPat, tidyNPat,
)
-import Id ( idType )
+import Id ( Id, idType )
import DataCon ( DataCon, dataConTyCon, dataConOrigArgTys, dataConFieldLabels )
import Name ( Name, mkInternalName, getOccName, isDataSymOcc, getName, mkVarOcc )
import TysWiredIn
import PrelNames ( unboundKey )
import TyCon ( tyConDataCons, tupleTyConBoxity, isTupleTyCon )
import BasicTypes ( Boxity(..) )
-import SrcLoc ( noSrcLoc )
+import SrcLoc ( noSrcLoc, Located(..), getLoc, unLoc, noLoc )
import UniqSet
import Util ( takeList, splitAtList, notNull )
import Outputable
untidy_pars p = untidy True p
untidy :: NeedPars -> WarningPat -> WarningPat
-untidy _ p@(WildPat _) = p
-untidy _ p@(VarPat name) = p
-untidy _ (LitPat lit) = LitPat (untidy_lit lit)
-untidy _ p@(ConPatIn name (PrefixCon [])) = p
-untidy b (ConPatIn name ps) = pars b (ConPatIn name (untidy_con ps))
-untidy _ (ListPat pats ty) = ListPat (map untidy_no_pars pats) ty
-untidy _ (TuplePat pats boxed) = TuplePat (map untidy_no_pars pats) boxed
-untidy _ (PArrPat _ _) = panic "Check.untidy: Shouldn't get a parallel array here!"
-untidy _ (SigPatIn _ _) = panic "Check.untidy: SigPat"
+untidy b (L loc p) = L loc (untidy' b p)
+ where
+ untidy' _ p@(WildPat _) = p
+ untidy' _ p@(VarPat name) = p
+ untidy' _ (LitPat lit) = LitPat (untidy_lit lit)
+ untidy' _ p@(ConPatIn name (PrefixCon [])) = p
+ untidy' b (ConPatIn name ps) = pars b (L loc (ConPatIn name (untidy_con ps)))
+ untidy' _ (ListPat pats ty) = ListPat (map untidy_no_pars pats) ty
+ untidy' _ (TuplePat pats boxed) = TuplePat (map untidy_no_pars pats) boxed
+ untidy' _ (PArrPat _ _) = panic "Check.untidy: Shouldn't get a parallel array here!"
+ untidy' _ (SigPatIn _ _) = panic "Check.untidy: SigPat"
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]
-pars :: NeedPars -> WarningPat -> WarningPat
+pars :: NeedPars -> WarningPat -> Pat Name
pars True p = ParPat p
-pars _ p = p
+pars _ p = unLoc p
untidy_lit :: HsLit -> HsLit
untidy_lit (HsCharPrim c) = HsChar c
check' [] = ([([],[])],emptyUniqSet)
check' [EqnInfo n ctx ps (MatchResult CanFail _)]
- | all_vars ps = ([(takeList ps (repeat new_wild_pat),[])], unitUniqSet n)
+ | all_vars ps = ([(takeList ps (repeat wildPat),[])], unitUniqSet n)
check' qs@((EqnInfo n ctx ps (MatchResult CanFail _)):rs)
| all_vars ps = (pats, addOneToUniqSet indexs n)
default_eqns = ASSERT2( okGroup qs, pprGroup qs )
map remove_var (filter (is_var . firstPat) qs)
(pats',indexs') = check' default_eqns
- pats_default = [(new_wild_pat:ps,constraints) | (ps,constraints) <- (pats')] ++ pats
+ pats_default = [(wildPat:ps,constraints) | (ps,constraints) <- (pats')] ++ pats
indexs_default = unionUniqSets indexs' indexs
\end{code}
(map (\ (xs,ys) -> (new_lit:xs,ys)) pats,indexs)
where
(pats,indexs) = (check' (remove_first_column_lit lit qs))
- new_lit = LitPat lit
+ new_lit = nlLitPat lit
remove_first_column_lit :: HsLit
-> [EquationInfo]
\begin{code}
first_column_only_vars :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
-first_column_only_vars qs = (map (\ (xs,ys) -> (new_wild_pat:xs,ys)) pats,indexs)
+first_column_only_vars qs = (map (\ (xs,ys) -> (wildPat:xs,ys)) pats,indexs)
where
(pats,indexs) = check' (map remove_var qs)
the difference is that here the default case is not always needed.
\begin{code}
-no_need_default_case :: [TypecheckedPat] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
+no_need_default_case :: [Pat Id] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
no_need_default_case cons qs = (concat pats, unionManyUniqSets indexs)
where
pats_indexs = map (\x -> construct_matrix x qs) cons
(pats,indexs) = unzip pats_indexs
-need_default_case :: [TypecheckedPat] -> [DataCon] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
+need_default_case :: [Pat Id] -> [DataCon] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
need_default_case used_cons unused_cons qs
| null default_eqns = (pats_default_no_eqns,indexs)
| otherwise = (pats_default,indexs_default)
pats_default_no_eqns = [(make_whole_con c:new_wilds,[]) | c <- unused_cons] ++ pats
indexs_default = unionUniqSets indexs' indexs
-construct_matrix :: TypecheckedPat -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
+construct_matrix :: Pat Id -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
construct_matrix con qs =
(map (make_con con) pats,indexs)
where
\end{verbatim}
\begin{code}
-remove_first_column :: TypecheckedPat -- Constructor
+remove_first_column :: Pat Id -- Constructor
-> [EquationInfo]
-> [EquationInfo]
remove_first_column (ConPatOut con (PrefixCon con_pats) _ _ _) qs
where
new_wilds = [WildPat (hsPatType arg_pat) | arg_pat <- con_pats]
shift_var (EqnInfo n ctx (ConPatOut _ (PrefixCon ps') _ _ _:ps) result) =
- EqnInfo n ctx (ps'++ps) result
+ EqnInfo n ctx (map unLoc ps'++ps) result
shift_var (EqnInfo n ctx (WildPat _ :ps) result) =
EqnInfo n ctx (new_wilds ++ ps) result
shift_var _ = panic "Check.Shift_var:No done"
make_row_vars :: [HsLit] -> EquationInfo -> ExhaustivePat
make_row_vars used_lits (EqnInfo _ _ pats _ ) =
- (VarPat new_var:takeList (tail pats) (repeat new_wild_pat),[(new_var,used_lits)])
+ (nlVarPat new_var:takeList (tail pats) (repeat wildPat),[(new_var,used_lits)])
where new_var = hash_x
hash_x = mkInternalName unboundKey {- doesn't matter much -}
noSrcLoc
make_row_vars_for_constructor :: EquationInfo -> [WarningPat]
-make_row_vars_for_constructor (EqnInfo _ _ pats _ ) = takeList (tail pats) (repeat new_wild_pat)
+make_row_vars_for_constructor (EqnInfo _ _ pats _ ) = takeList (tail pats) (repeat wildPat)
-compare_cons :: TypecheckedPat -> TypecheckedPat -> Bool
+compare_cons :: Pat Id -> Pat Id -> Bool
compare_cons (ConPatOut id1 _ _ _ _) (ConPatOut id2 _ _ _ _) = id1 == id2
-remove_dups :: [TypecheckedPat] -> [TypecheckedPat]
+remove_dups :: [Pat Id] -> [Pat Id]
remove_dups [] = []
remove_dups (x:xs) | or (map (\y -> compare_cons x y) xs) = remove_dups xs
| otherwise = x : remove_dups xs
-get_used_cons :: [EquationInfo] -> [TypecheckedPat]
+get_used_cons :: [EquationInfo] -> [Pat Id]
get_used_cons qs = remove_dups [con | (EqnInfo _ _ (con@(ConPatOut _ _ _ _ _):_) _) <- qs ]
remove_dups' :: [HsLit] -> [HsLit]
get_used_lits' (q:qs) =
get_used_lits qs
-get_unused_cons :: [TypecheckedPat] -> [DataCon]
+get_unused_cons :: [Pat Id] -> [DataCon]
get_unused_cons used_cons = unused_cons
where
(ConPatOut _ _ ty _ _) = head used_cons
unused_cons = uniqSetToList
(mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id)
-all_vars :: [TypecheckedPat] -> Bool
-all_vars [] = True
-all_vars (WildPat _:ps) = all_vars ps
-all_vars _ = False
+all_vars :: [Pat Id] -> Bool
+all_vars [] = True
+all_vars (WildPat _:ps) = all_vars ps
+all_vars _ = False
remove_var :: EquationInfo -> EquationInfo
remove_var (EqnInfo n ctx (WildPat _:ps) result) = EqnInfo n ctx ps result
panic "Check.remove_var: equation does not begin with a variable"
-----------------------
-eqnPats :: EquationInfo -> [TypecheckedPat]
+eqnPats :: EquationInfo -> [Pat Id]
eqnPats (EqnInfo _ _ ps _) = ps
-firstPat :: EquationInfo -> TypecheckedPat
+firstPat :: EquationInfo -> Pat Id
firstPat eqn_info = head (eqnPats eqn_info)
okGroup :: [EquationInfo] -> Bool
pprGroup es = vcat (map pprEqnInfo es)
pprEqnInfo e = ppr (eqnPats e)
-is_con :: TypecheckedPat -> Bool
+is_con :: Pat Id -> Bool
is_con (ConPatOut _ _ _ _ _) = True
is_con _ = False
-is_lit :: TypecheckedPat -> Bool
+is_lit :: Pat Id -> Bool
is_lit (LitPat _) = True
is_lit (NPatOut _ _ _) = True
is_lit _ = False
-is_npat :: TypecheckedPat -> Bool
+is_npat :: Pat Id -> Bool
is_npat (NPatOut _ _ _) = True
is_npat _ = False
-is_nplusk :: TypecheckedPat -> Bool
+is_nplusk :: Pat Id -> Bool
is_nplusk (NPlusKPatOut _ _ _ _) = True
is_nplusk _ = False
-is_var :: TypecheckedPat -> Bool
+is_var :: Pat Id -> Bool
is_var (WildPat _) = True
is_var _ = False
-is_var_con :: DataCon -> TypecheckedPat -> Bool
+is_var_con :: DataCon -> Pat Id -> Bool
is_var_con con (WildPat _) = True
is_var_con con (ConPatOut id _ _ _ _) | id == con = True
is_var_con con _ = False
-is_var_lit :: HsLit -> TypecheckedPat -> Bool
+is_var_lit :: HsLit -> Pat Id -> Bool
is_var_lit lit (WildPat _) = True
is_var_lit lit (LitPat lit') | lit == lit' = True
is_var_lit lit (NPatOut lit' _ _) | lit == lit' = True
\begin{code}
isInfixCon con = isDataSymOcc (getOccName con)
-is_nil (ConPatIn con (PrefixCon [])) = con == getName nilDataCon
+is_nil (ConPatIn con (PrefixCon [])) = unLoc con == getName nilDataCon
is_nil _ = False
is_list (ListPat _ _) = True
make_list p (ListPat ps ty) = ListPat (p:ps) ty
make_list _ _ = panic "Check.make_list: Invalid argument"
-make_con :: TypecheckedPat -> ExhaustivePat -> ExhaustivePat
-make_con (ConPatOut id _ _ _ _) (p:q:ps, constraints)
- | return_list id q = (make_list p q : ps, constraints)
- | isInfixCon id = (ConPatIn (getName id) (InfixCon p q) : ps, constraints)
+make_con :: Pat Id -> ExhaustivePat -> ExhaustivePat
+make_con (ConPatOut id _ _ _ _) (lp:lq:ps, constraints)
+ | return_list id q = (noLoc (make_list lp q) : ps, constraints)
+ | isInfixCon id = (nlInfixConPat (getName id) lp lq : ps, constraints)
+ where p = unLoc lp
+ q = unLoc lq
make_con (ConPatOut id (PrefixCon pats) _ _ _) (ps, constraints)
- | isTupleTyCon tc = (TuplePat pats_con (tupleTyConBoxity tc) : rest_pats, constraints)
- | isPArrFakeCon id = (PArrPat pats_con placeHolderType : rest_pats, constraints)
- | otherwise = (ConPatIn name (PrefixCon pats_con) : rest_pats, constraints)
+ | isTupleTyCon tc = (noLoc (TuplePat pats_con (tupleTyConBoxity tc)) : rest_pats, constraints)
+ | isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType) : rest_pats, constraints)
+ | otherwise = (nlConPat name pats_con : rest_pats, constraints)
where
name = getName id
(pats_con, rest_pats) = splitAtList pats ps
-- representation
make_whole_con :: DataCon -> WarningPat
-make_whole_con con | isInfixCon con = ConPatIn name (InfixCon new_wild_pat new_wild_pat)
- | otherwise = ConPatIn name (PrefixCon pats)
+make_whole_con con | isInfixCon con = nlInfixConPat name wildPat wildPat
+ | otherwise = nlConPat name pats
where
name = getName con
- pats = [new_wild_pat | t <- dataConOrigArgTys con]
-
-new_wild_pat :: WarningPat
-new_wild_pat = WildPat placeHolderType
+ pats = [wildPat | t <- dataConOrigArgTys con]
\end{code}
This equation makes the same thing as @tidy@ in @Match.lhs@, the
where
pats' = map simplify_pat pats
-simplify_pat :: TypecheckedPat -> TypecheckedPat
+simplify_lpat :: LPat Id -> LPat Id
+simplify_lpat p = fmap simplify_pat p
+simplify_pat :: Pat Id -> Pat Id
simplify_pat pat@(WildPat gt) = pat
simplify_pat (VarPat id) = WildPat (idType id)
-simplify_pat (ParPat p) = simplify_pat p
-simplify_pat (LazyPat p) = simplify_pat p
-simplify_pat (AsPat id p) = simplify_pat p
-simplify_pat (SigPatOut p ty fn) = simplify_pat p -- I'm not sure this is right
+simplify_pat (ParPat p) = unLoc (simplify_lpat p)
+simplify_pat (LazyPat p) = unLoc (simplify_lpat p)
+simplify_pat (AsPat id p) = unLoc (simplify_lpat p)
+simplify_pat (SigPatOut p ty fn) = unLoc (simplify_lpat p) -- I'm not sure this is right
simplify_pat (ConPatOut id ps ty tvs dicts) = ConPatOut id (simplify_con id ps) ty tvs dicts
-simplify_pat (ListPat ps ty) = foldr (\ x y -> mkPrefixConPat consDataCon [x,y] list_ty)
- (mkNilPat list_ty)
- (map simplify_pat ps)
- where list_ty = mkListTy ty
+simplify_pat (ListPat ps ty) =
+ unLoc $ foldr (\ x y -> mkPrefixConPat consDataCon [x,y] list_ty)
+ (mkNilPat list_ty)
+ (map simplify_lpat ps)
+ where list_ty = mkListTy ty
-- introduce fake parallel array constructors to be able to handle parallel
-- arrays with the existing machinery for constructor pattern
--
simplify_pat (PArrPat ps ty)
= ConPatOut (parrFakeCon arity)
- (PrefixCon (map simplify_pat ps))
+ (PrefixCon (map simplify_lpat ps))
(mkPArrTy ty) [] []
where
arity = length ps
simplify_pat (TuplePat ps boxity)
= ConPatOut (tupleCon boxity arity)
- (PrefixCon (map simplify_pat ps))
+ (PrefixCon (map simplify_lpat ps))
(mkTupleTy boxity arity (map hsPatType ps)) [] []
where
arity = length ps
-simplify_pat pat@(LitPat lit) = tidyLitPat lit pat
+simplify_pat pat@(LitPat lit) = unLoc (tidyLitPat lit (noLoc pat))
-- unpack string patterns fully, so we can see when they overlap with
-- each other, or even explicit lists of Chars.
simplify_pat pat@(NPatOut (HsString s) _ _) =
- foldr (\c pat -> ConPatOut consDataCon (PrefixCon [mk_char_lit c,pat]) stringTy [] [])
- (ConPatOut nilDataCon (PrefixCon []) stringTy [] []) (unpackIntFS s)
+ foldr (\c pat -> ConPatOut consDataCon (PrefixCon [mk_char_lit c,noLoc pat]) stringTy [] [])
+ (ConPatOut nilDataCon (PrefixCon []) stringTy [] []) (unpackFS s)
where
- mk_char_lit c = ConPatOut charDataCon (PrefixCon [LitPat (HsCharPrim c)])
+ mk_char_lit c = noLoc $
+ ConPatOut charDataCon (PrefixCon [nlLitPat (HsCharPrim c)])
charTy [] []
-simplify_pat pat@(NPatOut lit lit_ty hsexpr) = tidyNPat lit lit_ty pat
+simplify_pat pat@(NPatOut lit lit_ty hsexpr) = unLoc (tidyNPat lit lit_ty (noLoc pat))
simplify_pat (NPlusKPatOut id hslit hsexpr1 hsexpr2)
- = WildPat (idType id)
+ = WildPat (idType (unLoc id))
simplify_pat (DictPat dicts methods)
= case num_of_d_and_ms of
0 -> simplify_pat (TuplePat [] Boxed)
1 -> simplify_pat (head dict_and_method_pats)
- _ -> simplify_pat (TuplePat dict_and_method_pats Boxed)
+ _ -> simplify_pat (TuplePat (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_con con (PrefixCon ps) = PrefixCon (map simplify_pat ps)
-simplify_con con (InfixCon p1 p2) = PrefixCon [simplify_pat p1, simplify_pat p2]
+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)
- | null fs = PrefixCon [wild_pat | t <- dataConOrigArgTys con]
+ | null fs = PrefixCon [wildPat | t <- dataConOrigArgTys con]
-- Special case for null patterns; maybe not a record at all
- | otherwise = PrefixCon (map (simplify_pat.snd) all_pats)
+ | otherwise = PrefixCon (map (simplify_lpat.snd) all_pats)
where
-- pad out all the missing fields with WildPats.
- field_pats = map (\ f -> (getName f, wild_pat))
+ field_pats = map (\ f -> (getName f, wildPat))
(dataConFieldLabels con)
- all_pats = foldr (\ (id,p) acc -> insertNm (getName id) p acc)
+ all_pats = foldr (\ (id,p) acc -> insertNm (getName (unLoc id)) p acc)
field_pats fs
insertNm nm p [] = [(nm,p)]
insertNm nm p (x@(n,_):xs)
| nm == n = (nm,p):xs
| otherwise = x : insertNm nm p xs
-
- wild_pat = WildPat (panic "Check.simplify_con")
\end{code}
projects / ghc-hetmet.git / blobdiff