% (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}
-module Check ( check , ExhaustivePat, WarningPat, BoxedString(..) ) where
+module Check ( check , ExhaustivePat ) where
import HsSyn
import TcHsSyn ( TypecheckedPat )
import DsHsSyn ( outPatType )
-import CoreSyn
-
-import DsUtils ( EquationInfo(..),
- MatchResult(..),
- EqnNo,
- EqnSet,
- CanItFail(..)
+import DsUtils ( EquationInfo(..), MatchResult(..), EqnSet, CanItFail(..),
+ tidyLitPat
)
-import Id ( idType,
- Id,
- isTupleCon,
- getIdArity
- )
-import IdInfo ( ArityInfo(..) )
-import Lex ( isLexConSym )
-import Name ( occNameString,
- Name,
- getName,
- nameUnique,
- getOccName,
- getOccString
- )
-import Type ( Type,
- isUnboxedType,
- splitTyConApp_maybe
- )
-import TyVar ( TyVar )
-import TysPrim ( intPrimTy,
- charPrimTy,
- floatPrimTy,
- doublePrimTy,
- addrPrimTy,
- wordPrimTy
- )
+import Id ( idType )
+import DataCon ( DataCon, dataConTyCon, dataConArgTys,
+ dataConSourceArity, dataConFieldLabels )
+import Name ( Name, mkLocalName, getOccName, isDataSymOcc, getName, mkVarOcc )
+import Type ( splitAlgTyConApp, mkTyVarTys, splitTyConApp_maybe )
import TysWiredIn ( nilDataCon, consDataCon,
- mkTupleTy, tupleCon,
- mkListTy,
- charTy, charDataCon,
- intTy, intDataCon,
- floatTy, floatDataCon,
- doubleTy, doubleDataCon,
- addrTy, addrDataCon,
- wordTy, wordDataCon,
- stringTy
+ mkListTy, mkTupleTy, tupleCon
)
-import TyCon ( tyConDataCons )
+import PrelNames ( unboundKey )
+import TyCon ( tyConDataCons, tupleTyConBoxity, isTupleTyCon )
+import BasicTypes ( Boxity(..) )
+import SrcLoc ( noSrcLoc )
import UniqSet
-import Unique ( Unique )
import Outputable
#include "HsVersions.h"
\end{code}
This module performs checks about if one list of equations are:
- - Overlapped
- - Non exhaustive
-
+\begin{itemize}
+\item Overlapped
+\item Non exhaustive
+\end{itemize}
To discover that we go through the list of equations in a tree-like fashion.
If you like theory, a similar algorithm is described in:
- Two Techniques for Compiling Lazy Pattern Matching
- Luc Maranguet
+\begin{quotation}
+ {\em Two Techniques for Compiling Lazy Pattern Matching},
+ Luc Maranguet,
INRIA Rocquencourt (RR-2385, 1994)
-
-The algorithm is based in the first Technique, but there are some differences:
- - We don't generate code
- - We have constructors and literals (not only literals as in the
+\end{quotation}
+The algorithm is based on the first technique, but there are some differences:
+\begin{itemize}
+\item We don't generate code
+\item We have constructors and literals (not only literals as in the
article)
- - We don't use directions, we must select the columns from
+\item We don't use directions, we must select the columns from
left-to-right
-
+\end{itemize}
(By the way the second technique is really similar to the one used in
- Match.lhs to generate code)
+ @Match.lhs@ to generate code)
This function takes the equations of a pattern and returns:
- - The patterns that are not recognized
- - The equations that are not overlapped
-
-It simplify the patterns and then call check' (the same semantics),and it
+\begin{itemize}
+\item The patterns that are not recognized
+\item The equations that are not overlapped
+\end{itemize}
+It simplify the patterns and then call @check'@ (the same semantics), and it
needs to reconstruct the patterns again ....
The problem appear with things like:
+\begin{verbatim}
f [x,y] = ....
f (x:xs) = .....
-
+\end{verbatim}
We want to put the two patterns with the same syntax, (prefix form) and
then all the constructors are equal:
+\begin{verbatim}
f (: x (: y [])) = ....
f (: x xs) = .....
+\end{verbatim}
+(more about that in @simplify_eqns@)
-(more about that in simplify_eqns)
-
-We would prefer to have a WarningPat of type String, but Strings and the
+We would prefer to have a @WarningPat@ of type @String@, but Strings and the
Pretty Printer are not friends.
-We use InPat in WarningPat instead of OutPat because we need to print the
+We use @InPat@ in @WarningPat@ instead of @OutPat@
+because we need to print the
warning messages in the same way they are introduced, i.e. if the user
wrote:
+\begin{verbatim}
f [x,y] = ..
-
+\end{verbatim}
He don't want a warning message written:
-
+\begin{verbatim}
f (: x (: y [])) ........
-
+\end{verbatim}
Then we need to use InPats.
-
- Juan Quintela 5 JUL 1998
+\begin{quotation}
+ Juan Quintela 5 JUL 1998\\
User-friendliness and compiler writers are no friends.
-
+\end{quotation}
\begin{code}
-newtype BoxedString = BS String
-
-type WarningPat = InPat BoxedString
-type ExhaustivePat = ([WarningPat], [(BoxedString, [HsLit])])
-
-
-instance Outputable BoxedString where
- ppr (BS s) = text s
+type WarningPat = InPat Name
+type ExhaustivePat = ([WarningPat], [(Name, [HsLit])])
check :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
untidy_exhaustive (pats, messages) =
(map untidy_pars pats, map untidy_message messages)
-untidy_message :: (BoxedString, [HsLit]) -> (BoxedString, [HsLit])
+untidy_message :: (Name, [HsLit]) -> (Name, [HsLit])
untidy_message (string, lits) = (string, map untidy_lit lits)
\end{code}
untidy b (ConOpPatIn pat1 name fixity pat2) =
pars b (ConOpPatIn (untidy_pars pat1) name fixity (untidy_pars pat2))
untidy _ (ListPatIn pats) = ListPatIn (map untidy_no_pars pats)
-untidy _ (TuplePatIn pats) = TuplePatIn (map untidy_no_pars pats)
+untidy _ (TuplePatIn pats boxed) = TuplePatIn (map untidy_no_pars pats) boxed
-untidy _ (LazyPatIn pat) = panic "Check.untidy: LazyPatIn"
-untidy _ (AsPatIn name pat) = panic "Check.untidy: AsPatIn"
-untidy _ (NPlusKPatIn name lit) = panic "Check.untidy: NPlusKPatIn"
-untidy _ (NegPatIn ipat) = panic "Check.untidy: NegPatIn"
-untidy _ (ParPatIn pat) = panic "Check.untidy: ParPatIn"
-untidy _ (RecPatIn name fields) = panic "Check.untidy: RecPatIn"
--- [(name, InPat name, Bool)] -- True <=> source used punning
+untidy _ pat = pprPanic "Check.untidy: SigPatIn" (ppr pat)
pars :: NeedPars -> WarningPat -> WarningPat
pars True p = ParPatIn p
This equation is the same that check, the only difference is that the
boring work is done, that work needs to be done only once, this is
the reason top have two functions, check is the external interface,
-check' is called recursively.
+@check'@ is called recursively.
There are several cases:
-\begin{item}
+\begin{itemize}
\item There are no equations: Everything is OK.
\item There are only one equation, that can fail, and all the patterns are
variables. Then that equation is used and the same equation is
\item In the general case, there can exist literals ,constructors or only
vars in the first column, we actuate in consequence.
-\end{item}
+\end{itemize}
\begin{code}
check' :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
check' [] = ([([],[])],emptyUniqSet)
-check' [EqnInfo n ctx ps (MatchResult CanFail _ _)]
+check' [EqnInfo n ctx ps (MatchResult CanFail _)]
| all_vars ps = ([(take (length ps) (repeat new_wild_pat),[])], unitUniqSet n)
-check' qs@((EqnInfo n ctx ps (MatchResult CanFail _ _)):_)
+check' qs@((EqnInfo n ctx ps (MatchResult CanFail _)):rs)
| all_vars ps = (pats, addOneToUniqSet indexs n)
where
- (pats,indexs) = check' (tail qs)
+ (pats,indexs) = check' rs
check' qs@((EqnInfo n ctx ps result):_)
| all_vars ps = ([], unitUniqSet n)
| only_vars = first_column_only_vars qs
| otherwise = panic "Check.check': Not implemented :-("
where
+ -- Note: RecPats will have been simplified to ConPats
+ -- at this stage.
constructors = or (map is_con qs)
literals = or (map is_lit qs)
+ only_vars = and (map is_var qs)
-- npat = or (map is_npat qs)
-- nplusk = or (map is_nplusk qs)
- only_vars = and (map is_var qs)
\end{code}
Here begins the code to deal with literals, we need to split the matrix
used_lits = get_used_lits qs
\end{code}
-process_explicit_literals is a function that process each literal that appears
+@process_explicit_literals@ is a function that process each literal that appears
in the column of the matrix.
\begin{code}
\end{code}
-Process_literals calls process_explicit_literals to deal with the literals
+@process_literals@ calls @process_explicit_literals@ to deal with the literals
that appears in the matrix and deal also with the rest of the cases. It
must be one Variable to be complete.
\end{code}
This function splits the equations @qs@ in groups that deal with the
-same constructor
+same constructor.
\begin{code}
of the pattern matching.
We can need a default clause or not ...., it depends if we used all the
-constructors or not explicitly. The reasoning is similar to process_literals,
+constructors or not explicitly. The reasoning is similar to @process_literals@,
the difference is that here the default case is not always needed.
\begin{code}
pats_indexs = map (\x -> construct_matrix x qs) cons
(pats,indexs) = unzip pats_indexs
-need_default_case :: [TypecheckedPat] -> [Id] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
+need_default_case :: [TypecheckedPat] -> [DataCon] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
need_default_case used_cons unused_cons qs
| length default_eqns == 0 = (pats_default_no_eqns,indexs)
| otherwise = (pats_default,indexs_default)
construct_matrix :: TypecheckedPat -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
construct_matrix con qs =
-
(map (make_con con) pats,indexs)
where
(pats,indexs) = (check' (remove_first_column con qs))
that constructors can have arguments.
For instance, the matrix
-
+\begin{verbatim}
(: x xs) y
z y
-
+\end{verbatim}
is transformed in:
-
+\begin{verbatim}
x xs y
_ _ y
-
+\end{verbatim}
\begin{code}
remove_first_column :: TypecheckedPat -- Constructor
-> [EquationInfo]
-> [EquationInfo]
-remove_first_column (ConPat con _ con_pats) qs =
+remove_first_column (ConPat con _ _ _ con_pats) qs =
map shift_var (filter (is_var_con con) qs)
where
new_wilds = [WildPat (outPatType arg_pat) | arg_pat <- con_pats]
- shift_var (EqnInfo n ctx (ConPat _ _ ps':ps) result) =
- EqnInfo n ctx (ps'++ps) result
- shift_var (EqnInfo n ctx (WildPat _ :ps) result) =
- EqnInfo n ctx (new_wilds ++ ps) result
- shift_var _ = panic "Check.shift_var: Not implemented"
+ shift_var (EqnInfo n ctx (ConPat _ _ _ _ ps':ps) result) =
+ EqnInfo n ctx (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 _ ) =
(VarPatIn new_var:take (length (tail pats)) (repeat new_wild_pat),[(new_var,used_lits)])
- where new_var = BS "#x"
+ where new_var = hash_x
+
+hash_x = mkLocalName unboundKey {- doesn't matter much -}
+ (mkVarOcc SLIT("#x"))
+ noSrcLoc
make_row_vars_for_constructor :: EquationInfo -> [WarningPat]
make_row_vars_for_constructor (EqnInfo _ _ pats _ ) = take (length (tail pats)) (repeat new_wild_pat)
compare_cons :: TypecheckedPat -> TypecheckedPat -> Bool
-compare_cons (ConPat id1 _ _) (ConPat id2 _ _) = id1 == id2
+compare_cons (ConPat id1 _ _ _ _) (ConPat id2 _ _ _ _) = id1 == id2
remove_dups :: [TypecheckedPat] -> [TypecheckedPat]
remove_dups [] = []
| otherwise = x : remove_dups xs
get_used_cons :: [EquationInfo] -> [TypecheckedPat]
-get_used_cons qs = remove_dups [con | (EqnInfo _ _ (con@(ConPat _ _ _):_) _) <- qs]
+get_used_cons qs = remove_dups [con | (EqnInfo _ _ (con@(ConPat _ _ _ _ _):_) _) <- qs ]
remove_dups' :: [HsLit] -> [HsLit]
remove_dups' [] = []
get_used_lits' (q:qs) =
get_used_lits qs
-get_unused_cons :: [TypecheckedPat] -> [Id]
+get_unused_cons :: [TypecheckedPat] -> [DataCon]
get_unused_cons used_cons = unused_cons
where
- (ConPat _ ty _) = head used_cons
- Just (ty_con,_) = splitTyConApp_maybe ty
- all_cons = tyConDataCons ty_con
- used_cons_as_id = map (\ (ConPat id _ _) -> id) used_cons
- unused_cons = uniqSetToList (mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id)
+ (ConPat _ ty _ _ _) = head used_cons
+ Just (ty_con,_) = splitTyConApp_maybe ty
+ all_cons = tyConDataCons ty_con
+ used_cons_as_id = map (\ (ConPat d _ _ _ _) -> d) used_cons
+ unused_cons = uniqSetToList
+ (mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id)
+
all_vars :: [TypecheckedPat] -> Bool
all_vars [] = True
remove_var :: EquationInfo -> EquationInfo
remove_var (EqnInfo n ctx (WildPat _:ps) result) = EqnInfo n ctx ps result
-remove_var _ = panic "Check:remove_var: equation not begin with a variable"
+remove_var _ =
+ panic "Check.remove_var: equation does not begin with a variable"
is_con :: EquationInfo -> Bool
-is_con (EqnInfo _ _ ((ConPat _ _ _):_) _) = True
-is_con _ = False
+is_con (EqnInfo _ _ ((ConPat _ _ _ _ _):_) _) = True
+is_con _ = False
is_lit :: EquationInfo -> Bool
is_lit (EqnInfo _ _ ((LitPat _ _):_) _) = True
is_var (EqnInfo _ _ ((WildPat _):_) _) = True
is_var _ = False
-is_var_con :: Id -> EquationInfo -> Bool
-is_var_con con (EqnInfo _ _ ((WildPat _):_) _) = True
-is_var_con con (EqnInfo _ _ ((ConPat id _ _):_) _) | id == con = True
-is_var_con con _ = False
+is_var_con :: DataCon -> EquationInfo -> Bool
+is_var_con con (EqnInfo _ _ ((WildPat _):_) _) = True
+is_var_con con (EqnInfo _ _ ((ConPat id _ _ _ _):_) _) | id == con = True
+is_var_con con _ = False
is_var_lit :: HsLit -> EquationInfo -> Bool
is_var_lit lit (EqnInfo _ _ ((WildPat _):_) _) = True
is_var_lit lit _ = False
\end{code}
-The difference between make_con and make_whole_con is that make_whole_con
-creates a new constructor with all their arguments, and make_con takes a
-list of arguments, creates the constructor getting their arguments from the
-list. See where are used for details.
+The difference beteewn @make_con@ and @make_whole_con@ is that
+@make_wole_con@ creates a new constructor with all their arguments, and
+@make_con@ takes a list of argumntes, creates the contructor getting their
+arguments from the list. See where \fbox{\ ???\ } are used for details.
-We need to reconstruct the patterns (make the constructors infix and
+We need to reconstruct the patterns (make the constructors infix and
similar) at the same time that we create the constructors.
You can tell tuple constructors using
-
+\begin{verbatim}
Id.isTupleCon
-
+\end{verbatim}
You can see if one constructor is infix with this clearer code :-))))))))))
-
+\begin{verbatim}
Lex.isLexConSym (Name.occNameString (Name.getOccName con))
+\end{verbatim}
Rather clumsy but it works. (Simon Peyton Jones)
-We don't mind the nilDataCon because it doesn't change the way to print the
-message, we are searching only for things like: [1,2,3], not x:xs ....
-
+We don't mind the @nilDataCon@ because it doesn't change the way to
+print the messsage, we are searching only for things like: @[1,2,3]@,
+not @x:xs@ ....
-In reconstruct_pat we want to "undo" the work that we have done in simplify_pat
+In @reconstruct_pat@ we want to ``undo'' the work
+that we have done in @simplify_pat@.
In particular:
- ((,) x y) returns to be (x, y)
- ((:) x xs) returns to be (x:xs)
- (x:(...:[]) returns to be [x,...]
-
-The difficult case is the third one because we need to follow all the
-constructors until the [] to know that we need to use the second case,
-not the second.
-
+\begin{tabular}{lll}
+ @((,) x y)@ & returns to be & @(x, y)@
+\\ @((:) x xs)@ & returns to be & @(x:xs)@
+\\ @(x:(...:[])@ & returns to be & @[x,...]@
+\end{tabular}
+%
+The difficult case is the third one becouse we need to follow all the
+contructors until the @[]@ to know that we need to use the second case,
+not the second. \fbox{\ ???\ }
+%
\begin{code}
+isInfixCon con = isDataSymOcc (getOccName con)
-isInfixCon con = isLexConSym (occNameString (getOccName con))
-
-is_nil (ConPatIn (BS con) []) = con == getOccString nilDataCon
-is_nil _ = False
+is_nil (ConPatIn con []) = con == getName nilDataCon
+is_nil _ = False
is_list (ListPatIn _) = True
is_list _ = False
make_list _ _ = panic "Check.make_list: Invalid argument"
make_con :: TypecheckedPat -> ExhaustivePat -> ExhaustivePat
-make_con (ConPat id ty pats) (p:q:ps, constraints)
+make_con (ConPat id _ _ _ _) (p:q:ps, constraints)
| return_list id q = (make_list p q : ps, constraints)
| isInfixCon id = ((ConOpPatIn p name fixity q) : ps, constraints)
- where name = BS (getOccString id)
+ where name = getName id
fixity = panic "Check.make_con: Guessing fixity"
-make_con (ConPat id ty pats) (ps,constraints)
- | isTupleCon id = (TuplePatIn pats_con : rest_pats, constraints)
- | otherwise = (ConPatIn name pats_con : rest_pats, constraints)
+
+make_con (ConPat id _ _ _ pats) (ps,constraints)
+ | isTupleTyCon tc = (TuplePatIn pats_con (tupleTyConBoxity tc) : rest_pats, constraints)
+ | otherwise = (ConPatIn name pats_con : rest_pats, constraints)
where num_args = length pats
- name = BS (getOccString id)
+ name = getName id
pats_con = take num_args ps
rest_pats = drop num_args ps
+ tc = dataConTyCon id
-make_whole_con :: Id -> WarningPat
+make_whole_con :: DataCon -> WarningPat
make_whole_con con | isInfixCon con = ConOpPatIn new_wild_pat name fixity new_wild_pat
| otherwise = ConPatIn name pats
where
fixity = panic "Check.make_whole_con: Guessing fixity"
- name = BS (getOccString con)
- arity = get_int_arity con
+ name = getName con
+ arity = dataConSourceArity con
pats = take arity (repeat new_wild_pat)
new_wild_pat :: WarningPat
new_wild_pat = WildPatIn
-
-get_int_arity :: Id -> Int
-get_int_arity id = arity_to_int (getIdArity id)
- where
- arity_to_int (ArityExactly n) = n
- arity_to_int _ = panic "Check.getIntArity: Unknown arity"
-
\end{code}
-This equation makes the same thing that tidy in Match.lhs, the
+This equation makes the same thing as @tidy@ in @Match.lhs@, the
difference is that here we can do all the tidy in one place and in the
-Match tidy it must be done one column each time due to bookkeeping
+@Match@ tidy it must be done one column each time due to bookkeeping
constraints.
\begin{code}
simplify_pat pat@(WildPat gt) = pat
simplify_pat (VarPat id) = WildPat (idType id)
-simplify_pat (LazyPat p) = simplify_pat p
-
-simplify_pat (AsPat id p) = simplify_pat p
-
-simplify_pat (ConPat id ty ps) = ConPat id ty (map simplify_pat ps)
-
-simplify_pat (ConOpPat p1 id p2 ty) = ConPat id ty (map simplify_pat [p1,p2])
-
-simplify_pat (ListPat ty ps) = foldr (\ x -> \y -> ConPat consDataCon list_ty [x, y])
- (ConPat nilDataCon list_ty [])
- (map simplify_pat ps)
- where list_ty = mkListTy ty
+simplify_pat (LazyPat p) = simplify_pat p
+simplify_pat (AsPat id p) = simplify_pat p
+simplify_pat (ConPat id ty tvs dicts ps) = ConPat id ty tvs dicts (map simplify_pat ps)
-simplify_pat (TuplePat ps) = ConPat (tupleCon arity)
- (mkTupleTy arity (map outPatType ps))
+simplify_pat (ListPat ty ps) = foldr (\ x -> \y -> ConPat consDataCon list_ty [] [] [x, y])
+ (ConPat nilDataCon list_ty [] [] [])
(map simplify_pat ps)
- where
- arity = length ps
-
-simplify_pat (RecPat id ty []) = ConPat id ty [wild_pat]
- where
- wild_pat = WildPat gt
- gt = panic "Check.symplify_pat: gessing gt"
-simplify_pat (RecPat id ty idps) = ConPat id ty pats
- where
- pats = map (\ (id,p,_)-> simplify_pat p) idps
-
-simplify_pat pat@(LitPat lit lit_ty)
- | isUnboxedType lit_ty = pat
+ where list_ty = mkListTy ty
- | lit_ty == charTy = ConPat charDataCon charTy [LitPat (mk_char lit) charPrimTy]
- | otherwise = pprPanic "Check.simplify_pat: LitPat:" (ppr pat)
+simplify_pat (TuplePat ps boxity)
+ = ConPat (tupleCon boxity arity)
+ (mkTupleTy boxity arity (map outPatType ps)) [] []
+ (map simplify_pat ps)
where
- mk_char (HsChar c) = HsCharPrim c
+ arity = length ps
-simplify_pat (NPat lit lit_ty hsexpr) = better_pat
+simplify_pat (RecPat dc ty ex_tvs dicts [])
+ = ConPat dc ty ex_tvs dicts all_wild_pats
where
- better_pat
- | lit_ty == charTy = ConPat charDataCon lit_ty [LitPat (mk_char lit) charPrimTy]
- | lit_ty == intTy = ConPat intDataCon lit_ty [LitPat (mk_int lit) intPrimTy]
- | lit_ty == wordTy = ConPat wordDataCon lit_ty [LitPat (mk_word lit) wordPrimTy]
- | lit_ty == addrTy = ConPat addrDataCon lit_ty [LitPat (mk_addr lit) addrPrimTy]
- | lit_ty == floatTy = ConPat floatDataCon lit_ty [LitPat (mk_float lit) floatPrimTy]
- | lit_ty == doubleTy = ConPat doubleDataCon lit_ty [LitPat (mk_double lit) doublePrimTy]
-
- -- Convert the literal pattern "" to the constructor pattern [].
- | null_str_lit lit = ConPat nilDataCon lit_ty []
-
- | lit_ty == stringTy =
- foldr (\ x -> \y -> ConPat consDataCon list_ty [x, y])
- (ConPat nilDataCon list_ty [])
- (mk_string lit)
-
- | otherwise = NPat lit lit_ty hsexpr
-
- list_ty = mkListTy lit_ty
-
- mk_int (HsInt i) = HsIntPrim i
- mk_int l@(HsLitLit s) = l
+ all_wild_pats = map WildPat con_arg_tys
- mk_head_char (HsString s) = HsCharPrim (_HEAD_ s)
- mk_string (HsString s) =
- map (\ c -> ConPat charDataCon charTy
- [LitPat (HsCharPrim c) charPrimTy])
- (_UNPK_ s)
+ -- identical to machinations in Match.tidy1:
+ (_, inst_tys, _) = splitAlgTyConApp ty
+ con_arg_tys = dataConArgTys dc (inst_tys ++ mkTyVarTys ex_tvs)
- mk_char (HsChar c) = HsCharPrim c
- mk_char l@(HsLitLit s) = l
-
- mk_word l@(HsLitLit s) = l
-
- mk_addr l@(HsLitLit s) = l
-
- mk_float (HsInt i) = HsFloatPrim (fromInteger i)
- mk_float (HsFrac f) = HsFloatPrim f
- mk_float l@(HsLitLit s) = l
-
- mk_double (HsInt i) = HsDoublePrim (fromInteger i)
- mk_double (HsFrac f) = HsDoublePrim f
- mk_double l@(HsLitLit s) = l
-
- null_str_lit (HsString s) = _NULL_ s
- null_str_lit other_lit = False
+simplify_pat (RecPat dc ty ex_tvs dicts idps)
+ = ConPat dc ty ex_tvs dicts pats
+ where
+ pats = map (simplify_pat.snd) all_pats
+
+ -- pad out all the missing fields with WildPats.
+ field_pats = map (\ f -> (getName f, WildPat (panic "simplify_pat(RecPat-2)")))
+ (dataConFieldLabels dc)
+ all_pats =
+ foldr
+ ( \ (id,p,_) acc -> insertNm (getName id) p acc)
+ field_pats
+ idps
+
+ insertNm nm p [] = [(nm,p)]
+ insertNm nm p (x@(n,_):xs)
+ | nm == n = (nm,p):xs
+ | otherwise = x : insertNm nm p xs
- one_str_lit (HsString s) = _LENGTH_ s == (1::Int)
- one_str_lit other_lit = False
+simplify_pat pat@(LitPat lit lit_ty) = tidyLitPat lit pat
+simplify_pat pat@(NPat lit lit_ty hsexpr) = tidyLitPat lit pat
simplify_pat (NPlusKPat id hslit ty hsexpr1 hsexpr2) =
WildPat ty
simplify_pat (DictPat dicts methods) =
case num_of_d_and_ms of
- 0 -> simplify_pat (TuplePat [])
+ 0 -> simplify_pat (TuplePat [] Boxed)
1 -> simplify_pat (head dict_and_method_pats)
- _ -> simplify_pat (TuplePat dict_and_method_pats)
+ _ -> simplify_pat (TuplePat dict_and_method_pats Boxed)
where
num_of_d_and_ms = length dicts + length methods
dict_and_method_pats = map VarPat (dicts ++ methods)
projects / ghc-hetmet.git / blobdiff