summaryrefslogtreecommitdiff
path: root/compiler/deSugar
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/deSugar')
-rw-r--r--compiler/deSugar/Check.lhs698
-rw-r--r--compiler/deSugar/Desugar.lhs298
-rw-r--r--compiler/deSugar/DsArrows.lhs1055
-rw-r--r--compiler/deSugar/DsBinds.lhs417
-rw-r--r--compiler/deSugar/DsCCall.lhs456
-rw-r--r--compiler/deSugar/DsExpr.hi-boot-55
-rw-r--r--compiler/deSugar/DsExpr.hi-boot-66
-rw-r--r--compiler/deSugar/DsExpr.lhs781
-rw-r--r--compiler/deSugar/DsExpr.lhs-boot11
-rw-r--r--compiler/deSugar/DsForeign.lhs646
-rw-r--r--compiler/deSugar/DsGRHSs.lhs128
-rw-r--r--compiler/deSugar/DsListComp.lhs516
-rw-r--r--compiler/deSugar/DsMeta.hs1732
-rw-r--r--compiler/deSugar/DsMonad.lhs285
-rw-r--r--compiler/deSugar/DsUtils.lhs884
-rw-r--r--compiler/deSugar/Match.hi-boot-56
-rw-r--r--compiler/deSugar/Match.hi-boot-627
-rw-r--r--compiler/deSugar/Match.lhs740
-rw-r--r--compiler/deSugar/Match.lhs-boot35
-rw-r--r--compiler/deSugar/MatchCon.lhs174
-rw-r--r--compiler/deSugar/MatchLit.lhs329
-rw-r--r--compiler/deSugar/deSugar.tex23
22 files changed, 9252 insertions, 0 deletions
diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs
new file mode 100644
index 0000000000..9aac5ce777
--- /dev/null
+++ b/compiler/deSugar/Check.lhs
@@ -0,0 +1,698 @@
+%
+% (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 ) where
+
+
+import HsSyn
+import TcHsSyn ( hsPatType, 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 TysWiredIn
+import PrelNames ( unboundKey )
+import TyCon ( tyConDataCons, tupleTyConBoxity, isTupleTyCon )
+import BasicTypes ( Boxity(..) )
+import SrcLoc ( noSrcLoc, Located(..), unLoc, noLoc )
+import UniqSet
+import Util ( takeList, splitAtList, notNull )
+import Outputable
+import FastString
+
+#include "HsVersions.h"
+\end{code}
+
+This module performs checks about if one list of equations are:
+\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:
+\begin{quotation}
+ {\em Two Techniques for Compiling Lazy Pattern Matching},
+ Luc Maranguet,
+ INRIA Rocquencourt (RR-2385, 1994)
+\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)
+\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)
+
+This function takes the equations of a pattern and returns:
+\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@)
+
+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
+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.
+\begin{quotation}
+ Juan Quintela 5 JUL 1998\\
+ User-friendliness and compiler writers are no friends.
+\end{quotation}
+
+\begin{code}
+type WarningPat = InPat Name
+type ExhaustivePat = ([WarningPat], [(Name, [HsLit])])
+type EqnNo = Int
+type EqnSet = UniqSet EqnNo
+
+
+check :: [EquationInfo] -> ([ExhaustivePat], [EquationInfo])
+ -- Second result is the shadowed equations
+check qs = (untidy_warns, shadowed_eqns)
+ where
+ (warns, used_nos) = check' ([1..] `zip` map simplify_eqn qs)
+ untidy_warns = map untidy_exhaustive warns
+ shadowed_eqns = [eqn | (eqn,i) <- qs `zip` [1..],
+ not (i `elementOfUniqSet` used_nos)]
+
+untidy_exhaustive :: ExhaustivePat -> ExhaustivePat
+untidy_exhaustive ([pat], messages) =
+ ([untidy_no_pars pat], map untidy_message messages)
+untidy_exhaustive (pats, messages) =
+ (map untidy_pars pats, map untidy_message messages)
+
+untidy_message :: (Name, [HsLit]) -> (Name, [HsLit])
+untidy_message (string, lits) = (string, map untidy_lit lits)
+\end{code}
+
+The function @untidy@ does the reverse work of the @simplify_pat@ funcion.
+
+\begin{code}
+
+type NeedPars = Bool
+
+untidy_no_pars :: WarningPat -> WarningPat
+untidy_no_pars p = untidy False p
+
+untidy_pars :: WarningPat -> WarningPat
+untidy_pars p = untidy True p
+
+untidy :: NeedPars -> WarningPat -> WarningPat
+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 box ty) = TuplePat (map untidy_no_pars pats) box ty
+ 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 -> Pat Name
+pars True p = ParPat p
+pars _ p = unLoc p
+
+untidy_lit :: HsLit -> HsLit
+untidy_lit (HsCharPrim c) = HsChar c
+untidy_lit lit = lit
+\end{code}
+
+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.
+
+There are several cases:
+
+\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
+ non-exhaustive.
+\item All the patterns are variables, and the match can fail, there are
+ more equations then the results is the result of the rest of equations
+ and this equation is used also.
+
+\item The general case, if all the patterns are variables (here the match
+ can't fail) then the result is that this equation is used and this
+ equation doesn't generate non-exhaustive cases.
+
+\item In the general case, there can exist literals ,constructors or only
+ vars in the first column, we actuate in consequence.
+
+\end{itemize}
+
+
+\begin{code}
+
+check' :: [(EqnNo, EquationInfo)]
+ -> ([ExhaustivePat], -- Pattern scheme that might not be matched at all
+ EqnSet) -- Eqns that are used (others are overlapped)
+
+check' [] = ([([],[])],emptyUniqSet)
+
+check' ((n, EqnInfo { eqn_pats = ps, eqn_rhs = MatchResult can_fail _ }) : rs)
+ | first_eqn_all_vars && case can_fail of { CantFail -> True; CanFail -> False }
+ = ([], unitUniqSet n) -- One eqn, which can't fail
+
+ | first_eqn_all_vars && null rs -- One eqn, but it can fail
+ = ([(takeList ps (repeat nlWildPat),[])], unitUniqSet n)
+
+ | first_eqn_all_vars -- Several eqns, first can fail
+ = (pats, addOneToUniqSet indexs n)
+ where
+ first_eqn_all_vars = all_vars ps
+ (pats,indexs) = check' rs
+
+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)
+ where
+ -- Note: RecPats will have been simplified to ConPats
+ -- at this stage.
+ first_pats = ASSERT2( okGroup qs, pprGroup qs ) map firstPatN qs
+ constructors = any is_con first_pats
+ literals = any is_lit first_pats
+ only_vars = all is_var first_pats
+\end{code}
+
+Here begins the code to deal with literals, we need to split the matrix
+in different matrix beginning by each literal and a last matrix with the
+rest of values.
+
+\begin{code}
+split_by_literals :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet)
+split_by_literals qs = process_literals used_lits qs
+ where
+ used_lits = get_used_lits qs
+\end{code}
+
+@process_explicit_literals@ is a function that process each literal that appears
+in the column of the matrix.
+
+\begin{code}
+process_explicit_literals :: [HsLit] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
+process_explicit_literals lits qs = (concat pats, unionManyUniqSets indexs)
+ where
+ pats_indexs = map (\x -> construct_literal_matrix x qs) lits
+ (pats,indexs) = unzip pats_indexs
+\end{code}
+
+
+@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.
+
+\begin{code}
+
+process_literals :: [HsLit] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
+process_literals used_lits qs
+ | null default_eqns = ([make_row_vars used_lits (head qs)] ++ pats,indexs)
+ | otherwise = (pats_default,indexs_default)
+ where
+ (pats,indexs) = process_explicit_literals used_lits qs
+ default_eqns = ASSERT2( okGroup qs, pprGroup qs )
+ [remove_var q | q <- qs, is_var (firstPatN q)]
+ (pats',indexs') = check' default_eqns
+ pats_default = [(nlWildPat:ps,constraints) | (ps,constraints) <- (pats')] ++ pats
+ indexs_default = unionUniqSets indexs' indexs
+\end{code}
+
+Here we have selected the literal and we will select all the equations that
+begins for that literal and create a new matrix.
+
+\begin{code}
+construct_literal_matrix :: HsLit -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
+construct_literal_matrix lit qs =
+ (map (\ (xs,ys) -> (new_lit:xs,ys)) pats,indexs)
+ where
+ (pats,indexs) = (check' (remove_first_column_lit lit qs))
+ new_lit = nlLitPat lit
+
+remove_first_column_lit :: HsLit
+ -> [(EqnNo, EquationInfo)]
+ -> [(EqnNo, EquationInfo)]
+remove_first_column_lit lit qs
+ = ASSERT2( okGroup qs, pprGroup qs )
+ [(n, shift_pat eqn) | q@(n,eqn) <- qs, is_var_lit lit (firstPatN q)]
+ where
+ shift_pat eqn@(EqnInfo { eqn_pats = _:ps}) = eqn { eqn_pats = ps }
+ shift_pat eqn@(EqnInfo { eqn_pats = []}) = panic "Check.shift_var: no patterns"
+\end{code}
+
+This function splits the equations @qs@ in groups that deal with the
+same constructor.
+
+\begin{code}
+split_by_constructor :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet)
+split_by_constructor qs
+ | notNull unused_cons = need_default_case used_cons unused_cons qs
+ | otherwise = no_need_default_case used_cons qs
+ where
+ used_cons = get_used_cons qs
+ unused_cons = get_unused_cons used_cons
+\end{code}
+
+The first column of the patterns matrix only have vars, then there is
+nothing to do.
+
+\begin{code}
+first_column_only_vars :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
+first_column_only_vars qs = (map (\ (xs,ys) -> (nlWildPat:xs,ys)) pats,indexs)
+ where
+ (pats, indexs) = check' (map remove_var qs)
+\end{code}
+
+This equation takes a matrix of patterns and split the equations by
+constructor, using all the constructors that appears in the first column
+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@,
+the difference is that here the default case is not always needed.
+
+\begin{code}
+no_need_default_case :: [Pat Id] -> [(EqnNo, 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 :: [Pat Id] -> [DataCon] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
+need_default_case used_cons unused_cons qs
+ | null default_eqns = (pats_default_no_eqns,indexs)
+ | otherwise = (pats_default,indexs_default)
+ where
+ (pats,indexs) = no_need_default_case used_cons qs
+ default_eqns = ASSERT2( okGroup qs, pprGroup qs )
+ [remove_var q | q <- qs, is_var (firstPatN q)]
+ (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)
+ pats_default_no_eqns = [(make_whole_con c:new_wilds,[]) | c <- unused_cons] ++ pats
+ indexs_default = unionUniqSets indexs' indexs
+
+construct_matrix :: Pat Id -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
+construct_matrix con qs =
+ (map (make_con con) pats,indexs)
+ where
+ (pats,indexs) = (check' (remove_first_column con qs))
+\end{code}
+
+Here remove first column is more difficult that with literals due to the fact
+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 :: Pat Id -- Constructor
+ -> [(EqnNo, EquationInfo)]
+ -> [(EqnNo, EquationInfo)]
+remove_first_column (ConPatOut (L _ con) _ _ _ (PrefixCon con_pats) _) qs
+ = ASSERT2( okGroup qs, pprGroup qs )
+ [(n, shift_var eqn) | q@(n, eqn) <- qs, is_var_con con (firstPatN q)]
+ where
+ new_wilds = [WildPat (hsPatType arg_pat) | arg_pat <- con_pats]
+ shift_var eqn@(EqnInfo { eqn_pats = ConPatOut _ _ _ _ (PrefixCon ps') _ : ps})
+ = eqn { eqn_pats = map unLoc ps' ++ ps }
+ shift_var eqn@(EqnInfo { eqn_pats = WildPat _ : ps })
+ = eqn { eqn_pats = new_wilds ++ ps }
+ shift_var _ = panic "Check.Shift_var:No done"
+
+make_row_vars :: [HsLit] -> (EqnNo, EquationInfo) -> ExhaustivePat
+make_row_vars used_lits (_, EqnInfo { eqn_pats = pats})
+ = (nlVarPat new_var:takeList (tail pats) (repeat nlWildPat),[(new_var,used_lits)])
+ where
+ new_var = hash_x
+
+hash_x = mkInternalName unboundKey {- doesn't matter much -}
+ (mkVarOccFS FSLIT("#x"))
+ noSrcLoc
+
+make_row_vars_for_constructor :: (EqnNo, EquationInfo) -> [WarningPat]
+make_row_vars_for_constructor (_, EqnInfo { eqn_pats = pats})
+ = takeList (tail pats) (repeat nlWildPat)
+
+compare_cons :: Pat Id -> Pat Id -> Bool
+compare_cons (ConPatOut (L _ id1) _ _ _ _ _) (ConPatOut (L _ id2) _ _ _ _ _) = id1 == id2
+
+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 :: [(EqnNo, EquationInfo)] -> [Pat Id]
+get_used_cons qs = remove_dups [pat | q <- qs, let pat = firstPatN q,
+ isConPatOut pat]
+
+isConPatOut (ConPatOut {}) = True
+isConPatOut other = False
+
+remove_dups' :: [HsLit] -> [HsLit]
+remove_dups' [] = []
+remove_dups' (x:xs) | x `elem` xs = remove_dups' xs
+ | otherwise = x : remove_dups' xs
+
+
+get_used_lits :: [(EqnNo, EquationInfo)] -> [HsLit]
+get_used_lits qs = remove_dups' all_literals
+ where
+ all_literals = get_used_lits' qs
+
+get_used_lits' :: [(EqnNo, EquationInfo)] -> [HsLit]
+get_used_lits' [] = []
+get_used_lits' (q:qs)
+ | Just lit <- get_lit (firstPatN q) = lit : get_used_lits' qs
+ | otherwise = get_used_lits qs
+
+get_lit :: Pat id -> Maybe HsLit
+-- Get a representative HsLit to stand for the OverLit
+-- 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 other_pat = Nothing
+
+mb_neg :: Num a => Maybe b -> a -> a
+mb_neg Nothing v = v
+mb_neg (Just _) v = -v
+
+get_unused_cons :: [Pat Id] -> [DataCon]
+get_unused_cons used_cons = unused_cons
+ where
+ (ConPatOut _ _ _ _ _ ty) = head used_cons
+ ty_con = tcTyConAppTyCon ty -- Newtype observable
+ all_cons = tyConDataCons ty_con
+ used_cons_as_id = map (\ (ConPatOut (L _ d) _ _ _ _ _) -> d) used_cons
+ unused_cons = uniqSetToList
+ (mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id)
+
+all_vars :: [Pat Id] -> Bool
+all_vars [] = True
+all_vars (WildPat _:ps) = all_vars ps
+all_vars _ = False
+
+remove_var :: (EqnNo, EquationInfo) -> (EqnNo, EquationInfo)
+remove_var (n, eqn@(EqnInfo { eqn_pats = WildPat _ : ps})) = (n, eqn { eqn_pats = ps })
+remove_var _ = panic "Check.remove_var: equation does not begin with a variable"
+
+-----------------------
+eqnPats :: (EqnNo, EquationInfo) -> [Pat Id]
+eqnPats (_, eqn) = eqn_pats eqn
+
+okGroup :: [(EqnNo, EquationInfo)] -> Bool
+-- True if all equations have at least one pattern, and
+-- all have the same number of patterns
+okGroup [] = True
+okGroup (e:es) = n_pats > 0 && and [length (eqnPats e) == n_pats | e <- es]
+ where
+ n_pats = length (eqnPats e)
+
+-- Half-baked print
+pprGroup es = vcat (map pprEqnInfo es)
+pprEqnInfo e = ppr (eqnPats e)
+
+
+firstPatN :: (EqnNo, EquationInfo) -> Pat Id
+firstPatN (_, eqn) = firstPat eqn
+
+is_con :: Pat Id -> Bool
+is_con (ConPatOut _ _ _ _ _ _) = True
+is_con _ = False
+
+is_lit :: Pat Id -> Bool
+is_lit (LitPat _) = True
+is_lit (NPat _ _ _ _) = True
+is_lit _ = False
+
+is_var :: Pat Id -> Bool
+is_var (WildPat _) = True
+is_var _ = False
+
+is_var_con :: DataCon -> Pat Id -> Bool
+is_var_con con (WildPat _) = True
+is_var_con con (ConPatOut (L _ id) _ _ _ _ _) | id == con = True
+is_var_con con _ = False
+
+is_var_lit :: HsLit -> Pat Id -> Bool
+is_var_lit lit (WildPat _) = True
+is_var_lit lit pat
+ | Just lit' <- get_lit pat = lit == lit'
+ | otherwise = False
+\end{code}
+
+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
+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 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 particular:
+\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)
+
+is_nil (ConPatIn con (PrefixCon [])) = unLoc con == getName nilDataCon
+is_nil _ = False
+
+is_list (ListPat _ _) = True
+is_list _ = False
+
+return_list id q = id == consDataCon && (is_nil q || is_list q)
+
+make_list p q | is_nil q = ListPat [p] placeHolderType
+make_list p (ListPat ps ty) = ListPat (p:ps) ty
+make_list _ _ = panic "Check.make_list: Invalid argument"
+
+make_con :: Pat Id -> ExhaustivePat -> ExhaustivePat
+make_con (ConPatOut (L _ 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 q = unLoc lq
+
+make_con (ConPatOut (L _ id) _ _ _ (PrefixCon pats) ty) (ps, constraints)
+ | isTupleTyCon tc = (noLoc (TuplePat pats_con (tupleTyConBoxity tc) ty) : 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
+ tc = dataConTyCon id
+
+-- reconstruct parallel array pattern
+--
+-- * don't check for the type only; we need to make sure that we are really
+-- dealing with one of the fake constructors and not with the real
+-- representation
+
+make_whole_con :: DataCon -> WarningPat
+make_whole_con con | isInfixCon con = nlInfixConPat name nlWildPat nlWildPat
+ | otherwise = nlConPat name pats
+ where
+ name = getName con
+ pats = [nlWildPat | t <- dataConOrigArgTys con]
+\end{code}
+
+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
+constraints.
+
+\begin{code}
+
+simplify_eqn :: EquationInfo -> EquationInfo
+simplify_eqn eqn = eqn { eqn_pats = map simplify_pat (eqn_pats eqn),
+ eqn_rhs = simplify_rhs (eqn_rhs eqn) }
+ where
+ -- Horrible hack. The simplify_pat stuff converts NPlusK pats to WildPats
+ -- which of course loses the info that they can fail to match. So we
+ -- stick in a CanFail as if it were a guard.
+ -- The Right Thing to do is for the whole system to treat NPlusK pats properly
+ simplify_rhs (MatchResult can_fail body)
+ | any has_nplusk_pat (eqn_pats eqn) = MatchResult CanFail body
+ | otherwise = MatchResult can_fail body
+
+has_nplusk_lpat :: LPat Id -> Bool
+has_nplusk_lpat (L _ p) = has_nplusk_pat p
+
+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 (SigPatOut p _ ) = has_nplusk_lpat p
+has_nplusk_pat (ConPatOut _ _ _ _ ps ty) = any has_nplusk_lpat (hsConArgs ps)
+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 p = False -- VarPat, VarPatOut, WildPat, LitPat, NPat, TypePat, DictPat
+
+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 (VarPatOut id _) = WildPat (idType id) -- Ignore the bindings
+simplify_pat (ParPat p) = unLoc (simplify_lpat p)
+simplify_pat (LazyPat p) = unLoc (simplify_lpat p)
+simplify_pat (BangPat p) = unLoc (simplify_lpat p)
+simplify_pat (AsPat id p) = unLoc (simplify_lpat p)
+simplify_pat (SigPatOut p _) = unLoc (simplify_lpat p) -- I'm not sure this is right
+
+simplify_pat (ConPatOut (L loc id) tvs dicts binds ps ty)
+ = ConPatOut (L loc id) tvs dicts binds (simplify_con id ps) 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)
+ = mk_simple_con_pat (parrFakeCon (length ps))
+ (PrefixCon (map simplify_lpat ps))
+ (mkPArrTy ty)
+
+simplify_pat (TuplePat ps boxity ty)
+ = mk_simple_con_pat (tupleCon boxity arity)
+ (PrefixCon (map simplify_lpat ps))
+ ty
+ where
+ arity = length ps
+
+-- unpack string patterns fully, so we can see when they overlap with
+-- each other, or even explicit lists of Chars.
+simplify_pat pat@(LitPat (HsString s)) =
+ foldr (\c pat -> mk_simple_con_pat consDataCon (PrefixCon [mk_char_lit c,noLoc pat]) stringTy)
+ (mk_simple_con_pat nilDataCon (PrefixCon []) stringTy) (unpackFS s)
+ where
+ mk_char_lit c = noLoc (mk_simple_con_pat charDataCon (PrefixCon [nlLitPat (HsCharPrim c)]) charTy)
+
+simplify_pat pat@(LitPat lit) = unLoc (tidyLitPat lit (noLoc pat))
+
+simplify_pat pat@(NPat lit mb_neg _ lit_ty) = unLoc (tidyNPat lit mb_neg lit_ty (noLoc pat))
+
+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)
+
+mk_simple_con_pat con args ty = ConPatOut (noLoc con) [] [] emptyLHsBinds args ty
+
+-----------------
+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 [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)
+ 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
+\end{code}
diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
new file mode 100644
index 0000000000..45dc113cc1
--- /dev/null
+++ b/compiler/deSugar/Desugar.lhs
@@ -0,0 +1,298 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[Desugar]{@deSugar@: the main function}
+
+\begin{code}
+module Desugar ( deSugar, deSugarExpr ) where
+
+#include "HsVersions.h"
+
+import DynFlags ( DynFlag(..), DynFlags(..), dopt, GhcMode(..) )
+import StaticFlags ( opt_SccProfilingOn )
+import DriverPhases ( isHsBoot )
+import HscTypes ( ModGuts(..), HscEnv(..),
+ Dependencies(..), ForeignStubs(..), TypeEnv, IsBootInterface )
+import HsSyn ( RuleDecl(..), RuleBndr(..), LHsExpr, LRuleDecl )
+import TcRnTypes ( TcGblEnv(..), ImportAvails(..) )
+import MkIface ( mkUsageInfo )
+import Id ( Id, setIdExported, idName )
+import Name ( Name, isExternalName, nameIsLocalOrFrom, nameOccName )
+import CoreSyn
+import PprCore ( pprRules, pprCoreExpr )
+import DsMonad
+import DsExpr ( dsLExpr )
+import DsBinds ( dsTopLHsBinds, decomposeRuleLhs, AutoScc(..) )
+import DsForeign ( dsForeigns )
+import DsExpr () -- Forces DsExpr to be compiled; DsBinds only
+ -- depends on DsExpr.hi-boot.
+import Module ( Module, moduleEnvElts, delModuleEnv, moduleFS )
+import RdrName ( GlobalRdrEnv )
+import NameSet
+import VarSet
+import Bag ( Bag, isEmptyBag, emptyBag )
+import Rules ( roughTopNames )
+import CoreLint ( showPass, endPass )
+import CoreFVs ( ruleRhsFreeVars, exprsFreeNames )
+import Packages ( PackageState(thPackageId), PackageIdH(..) )
+import ErrUtils ( doIfSet, dumpIfSet_dyn, printBagOfWarnings,
+ errorsFound, WarnMsg )
+import ListSetOps ( insertList )
+import Outputable
+import UniqSupply ( mkSplitUniqSupply )
+import SrcLoc ( Located(..) )
+import DATA_IOREF ( readIORef )
+import Maybes ( catMaybes )
+import FastString
+import Util ( sortLe )
+\end{code}
+
+%************************************************************************
+%* *
+%* The main function: deSugar
+%* *
+%************************************************************************
+
+\begin{code}
+deSugar :: HscEnv -> TcGblEnv -> IO (Bag WarnMsg, Maybe ModGuts)
+-- Can modify PCS by faulting in more declarations
+
+deSugar hsc_env
+ tcg_env@(TcGblEnv { tcg_mod = mod,
+ tcg_src = hsc_src,
+ tcg_type_env = type_env,
+ tcg_imports = imports,
+ tcg_home_mods = home_mods,
+ tcg_exports = exports,
+ tcg_dus = dus,
+ tcg_inst_uses = dfun_uses_var,
+ tcg_th_used = th_var,
+ tcg_keep = keep_var,
+ tcg_rdr_env = rdr_env,
+ tcg_fix_env = fix_env,
+ tcg_deprecs = deprecs,
+ tcg_binds = binds,
+ tcg_fords = fords,
+ tcg_rules = rules,
+ tcg_insts = insts })
+ = do { showPass dflags "Desugar"
+
+ -- Desugar the program
+ ; ((all_prs, ds_rules, ds_fords), warns)
+ <- case ghcMode (hsc_dflags hsc_env) of
+ JustTypecheck -> return (([], [], NoStubs), emptyBag)
+ _ -> initDs hsc_env mod rdr_env type_env $ do
+ { core_prs <- dsTopLHsBinds auto_scc binds
+ ; (ds_fords, foreign_prs) <- dsForeigns fords
+ ; let all_prs = foreign_prs ++ core_prs
+ local_bndrs = mkVarSet (map fst all_prs)
+ ; ds_rules <- mappM (dsRule mod local_bndrs) rules
+ ; return (all_prs, catMaybes ds_rules, ds_fords)
+ }
+
+ -- If warnings are considered errors, leave.
+ ; if errorsFound dflags (warns, emptyBag)
+ then return (warns, Nothing)
+ else do
+
+ { -- Add export flags to bindings
+ keep_alive <- readIORef keep_var
+ ; let final_prs = addExportFlags ghci_mode exports keep_alive
+ all_prs ds_rules
+ ds_binds = [Rec final_prs]
+ -- Notice that we put the whole lot in a big Rec, even the foreign binds
+ -- When compiling PrelFloat, which defines data Float = F# Float#
+ -- we want F# to be in scope in the foreign marshalling code!
+ -- You might think it doesn't matter, but the simplifier brings all top-level
+ -- things into the in-scope set before simplifying; so we get no unfolding for F#!
+
+ -- Lint result if necessary
+ ; endPass dflags "Desugar" Opt_D_dump_ds ds_binds
+
+ -- Dump output
+ ; doIfSet (dopt Opt_D_dump_ds dflags)
+ (printDump (ppr_ds_rules ds_rules))
+
+ ; dfun_uses <- readIORef dfun_uses_var -- What dfuns are used
+ ; th_used <- readIORef th_var -- Whether TH is used
+ ; let used_names = allUses dus `unionNameSets` dfun_uses
+ thPackage = thPackageId (pkgState dflags)
+ pkgs | ExtPackage th_id <- thPackage, th_used
+ = insertList th_id (imp_dep_pkgs imports)
+ | otherwise
+ = imp_dep_pkgs imports
+
+ dep_mods = moduleEnvElts (delModuleEnv (imp_dep_mods imports) mod)
+ -- M.hi-boot can be in the imp_dep_mods, but we must remove
+ -- it before recording the modules on which this one depends!
+ -- (We want to retain M.hi-boot in imp_dep_mods so that
+ -- loadHiBootInterface can see if M's direct imports depend
+ -- on M.hi-boot, and hence that we should do the hi-boot consistency
+ -- check.)
+
+ dir_imp_mods = imp_mods imports
+
+ ; usages <- mkUsageInfo hsc_env home_mods dir_imp_mods dep_mods used_names
+
+ ; let
+ -- Modules don't compare lexicographically usually,
+ -- but we want them to do so here.
+ le_mod :: Module -> Module -> Bool
+ le_mod m1 m2 = moduleFS m1 <= moduleFS m2
+ le_dep_mod :: (Module, IsBootInterface) -> (Module, IsBootInterface) -> Bool
+ le_dep_mod (m1,_) (m2,_) = m1 `le_mod` m2
+
+ deps = Deps { dep_mods = sortLe le_dep_mod dep_mods,
+ dep_pkgs = sortLe (<=) pkgs,
+ dep_orphs = sortLe le_mod (imp_orphs imports) }
+ -- sort to get into canonical order
+
+ mod_guts = ModGuts {
+ mg_module = mod,
+ mg_boot = isHsBoot hsc_src,
+ mg_exports = exports,
+ mg_deps = deps,
+ mg_home_mods = home_mods,
+ mg_usages = usages,
+ mg_dir_imps = [m | (m,_,_) <- moduleEnvElts dir_imp_mods],
+ mg_rdr_env = rdr_env,
+ mg_fix_env = fix_env,
+ mg_deprecs = deprecs,
+ mg_types = type_env,
+ mg_insts = insts,
+ mg_rules = ds_rules,
+ mg_binds = ds_binds,
+ mg_foreign = ds_fords }
+
+ ; return (warns, Just mod_guts)
+ }}
+
+ where
+ dflags = hsc_dflags hsc_env
+ ghci_mode = ghcMode (hsc_dflags hsc_env)
+ auto_scc | opt_SccProfilingOn = TopLevel
+ | otherwise = NoSccs
+
+deSugarExpr :: HscEnv
+ -> Module -> GlobalRdrEnv -> TypeEnv
+ -> LHsExpr Id
+ -> IO CoreExpr
+deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
+ = do { showPass dflags "Desugar"
+ ; us <- mkSplitUniqSupply 'd'
+
+ -- Do desugaring
+ ; (core_expr, ds_warns) <- initDs hsc_env this_mod rdr_env type_env $
+ dsLExpr tc_expr
+
+ -- Display any warnings
+ -- Note: if -Werror is used, we don't signal an error here.
+ ; doIfSet (not (isEmptyBag ds_warns))
+ (printBagOfWarnings dflags ds_warns)
+
+ -- Dump output
+ ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr core_expr)
+
+ ; return core_expr
+ }
+ where
+ dflags = hsc_dflags hsc_env
+
+
+-- addExportFlags
+-- Set the no-discard flag if either
+-- a) the Id is exported
+-- b) it's mentioned in the RHS of an orphan rule
+-- c) it's in the keep-alive set
+--
+-- It means that the binding won't be discarded EVEN if the binding
+-- ends up being trivial (v = w) -- the simplifier would usually just
+-- substitute w for v throughout, but we don't apply the substitution to
+-- the rules (maybe we should?), so this substitution would make the rule
+-- bogus.
+
+-- You might wonder why exported Ids aren't already marked as such;
+-- it's just because the type checker is rather busy already and
+-- I didn't want to pass in yet another mapping.
+
+addExportFlags ghci_mode exports keep_alive prs rules
+ = [(add_export bndr, rhs) | (bndr,rhs) <- prs]
+ where
+ add_export bndr
+ | dont_discard bndr = setIdExported bndr
+ | otherwise = bndr
+
+ orph_rhs_fvs = unionVarSets [ ruleRhsFreeVars rule
+ | rule <- rules,
+ not (isLocalRule rule) ]
+ -- A non-local rule keeps alive the free vars of its right-hand side.
+ -- (A "non-local" is one whose head function is not locally defined.)
+ -- Local rules are (later, after gentle simplification)
+ -- attached to the Id, and that keeps the rhs free vars alive.
+
+ dont_discard bndr = is_exported name
+ || name `elemNameSet` keep_alive
+ || bndr `elemVarSet` orph_rhs_fvs
+ where
+ name = idName bndr
+
+ -- In interactive mode, we don't want to discard any top-level
+ -- entities at all (eg. do not inline them away during
+ -- simplification), and retain them all in the TypeEnv so they are
+ -- available from the command line.
+ --
+ -- isExternalName separates the user-defined top-level names from those
+ -- introduced by the type checker.
+ is_exported :: Name -> Bool
+ is_exported | ghci_mode == Interactive = isExternalName
+ | otherwise = (`elemNameSet` exports)
+
+ppr_ds_rules [] = empty
+ppr_ds_rules rules
+ = text "" $$ text "-------------- DESUGARED RULES -----------------" $$
+ pprRules rules
+\end{code}
+
+
+
+%************************************************************************
+%* *
+%* Desugaring transformation rules
+%* *
+%************************************************************************
+
+\begin{code}
+dsRule :: Module -> IdSet -> LRuleDecl Id -> DsM (Maybe CoreRule)
+dsRule mod in_scope (L loc (HsRule name act vars lhs tv_lhs rhs fv_rhs))
+ = putSrcSpanDs loc $
+ do { let bndrs = [var | RuleBndr (L _ var) <- vars]
+ ; lhs' <- dsLExpr lhs
+ ; rhs' <- dsLExpr rhs
+
+ ; case decomposeRuleLhs bndrs lhs' of {
+ Nothing -> do { dsWarn msg; return Nothing } ;
+ Just (bndrs', fn_id, args) -> do
+
+ -- Substitute the dict bindings eagerly,
+ -- and take the body apart into a (f args) form
+ { let local_rule = nameIsLocalOrFrom mod fn_name
+ -- NB we can't use isLocalId in the orphan test,
+ -- because isLocalId isn't true of class methods
+ fn_name = idName fn_id
+ lhs_names = fn_name : nameSetToList (exprsFreeNames args)
+ -- No need to delete bndrs, because
+ -- exprsFreeNames finds only External names
+ orph = case filter (nameIsLocalOrFrom mod) lhs_names of
+ (n:ns) -> Just (nameOccName n)
+ [] -> Nothing
+
+ rule = Rule { ru_name = name, ru_fn = fn_name, ru_act = act,
+ ru_bndrs = bndrs', ru_args = args, ru_rhs = rhs',
+ ru_rough = roughTopNames args,
+ ru_local = local_rule, ru_orph = orph }
+ ; return (Just rule)
+ } } }
+ where
+ msg = hang (ptext SLIT("RULE left-hand side too complicated to desugar; ignored"))
+ 2 (ppr lhs)
+\end{code}
diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs
new file mode 100644
index 0000000000..111e0bccd0
--- /dev/null
+++ b/compiler/deSugar/DsArrows.lhs
@@ -0,0 +1,1055 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[DsArrows]{Desugaring arrow commands}
+
+\begin{code}
+module DsArrows ( dsProcExpr ) where
+
+#include "HsVersions.h"
+
+import Match ( matchSimply )
+import DsUtils ( mkErrorAppDs,
+ mkCoreTupTy, mkCoreTup, selectSimpleMatchVarL,
+ mkTupleCase, mkBigCoreTup, mkTupleType,
+ mkTupleExpr, mkTupleSelector,
+ dsSyntaxTable, lookupEvidence )
+import DsMonad
+
+import HsSyn
+import TcHsSyn ( hsPatType )
+
+-- NB: The desugarer, which straddles the source and Core worlds, sometimes
+-- needs to see source types (newtypes etc), and sometimes not
+-- So WATCH OUT; check each use of split*Ty functions.
+-- Sigh. This is a pain.
+
+import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds )
+
+import TcType ( Type, tcSplitAppTy, mkFunTy )
+import Type ( mkTyConApp, funArgTy )
+import CoreSyn
+import CoreFVs ( exprFreeVars )
+import CoreUtils ( mkIfThenElse, bindNonRec, exprType )
+
+import Id ( Id, idType )
+import Name ( Name )
+import PrelInfo ( pAT_ERROR_ID )
+import DataCon ( dataConWrapId )
+import TysWiredIn ( tupleCon )
+import BasicTypes ( Boxity(..) )
+import PrelNames ( eitherTyConName, leftDataConName, rightDataConName,
+ arrAName, composeAName, firstAName,
+ appAName, choiceAName, loopAName )
+import Util ( mapAccumL )
+import Outputable
+
+import HsUtils ( collectPatBinders, collectPatsBinders )
+import VarSet ( IdSet, mkVarSet, varSetElems,
+ intersectVarSet, minusVarSet, extendVarSetList,
+ unionVarSet, unionVarSets, elemVarSet )
+import SrcLoc ( Located(..), unLoc, noLoc )
+\end{code}
+
+\begin{code}
+data DsCmdEnv = DsCmdEnv {
+ meth_binds :: [CoreBind],
+ arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr
+ }
+
+mkCmdEnv :: SyntaxTable Id -> DsM DsCmdEnv
+mkCmdEnv ids
+ = dsSyntaxTable ids `thenDs` \ (meth_binds, ds_meths) ->
+ return $ DsCmdEnv {
+ meth_binds = meth_binds,
+ arr_id = Var (lookupEvidence ds_meths arrAName),
+ compose_id = Var (lookupEvidence ds_meths composeAName),
+ first_id = Var (lookupEvidence ds_meths firstAName),
+ app_id = Var (lookupEvidence ds_meths appAName),
+ choice_id = Var (lookupEvidence ds_meths choiceAName),
+ loop_id = Var (lookupEvidence ds_meths loopAName)
+ }
+
+bindCmdEnv :: DsCmdEnv -> CoreExpr -> CoreExpr
+bindCmdEnv ids body = foldr Let body (meth_binds ids)
+
+-- arr :: forall b c. (b -> c) -> a b c
+do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr
+do_arr ids b_ty c_ty f = mkApps (arr_id ids) [Type b_ty, Type c_ty, f]
+
+-- (>>>) :: forall b c d. a b c -> a c d -> a b d
+do_compose :: DsCmdEnv -> Type -> Type -> Type ->
+ CoreExpr -> CoreExpr -> CoreExpr
+do_compose ids b_ty c_ty d_ty f g
+ = mkApps (compose_id ids) [Type b_ty, Type c_ty, Type d_ty, f, g]
+
+-- first :: forall b c d. a b c -> a (b,d) (c,d)
+do_first :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
+do_first ids b_ty c_ty d_ty f
+ = mkApps (first_id ids) [Type b_ty, Type c_ty, Type d_ty, f]
+
+-- app :: forall b c. a (a b c, b) c
+do_app :: DsCmdEnv -> Type -> Type -> CoreExpr
+do_app ids b_ty c_ty = mkApps (app_id ids) [Type b_ty, Type c_ty]
+
+-- (|||) :: forall b d c. a b d -> a c d -> a (Either b c) d
+-- note the swapping of d and c
+do_choice :: DsCmdEnv -> Type -> Type -> Type ->
+ CoreExpr -> CoreExpr -> CoreExpr
+do_choice ids b_ty c_ty d_ty f g
+ = mkApps (choice_id ids) [Type b_ty, Type d_ty, Type c_ty, f, g]
+
+-- loop :: forall b d c. a (b,d) (c,d) -> a b c
+-- note the swapping of d and c
+do_loop :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
+do_loop ids b_ty c_ty d_ty f
+ = mkApps (loop_id ids) [Type b_ty, Type d_ty, Type c_ty, f]
+
+-- map_arrow (f :: b -> c) (g :: a c d) = arr f >>> g :: a b d
+do_map_arrow :: DsCmdEnv -> Type -> Type -> Type ->
+ CoreExpr -> CoreExpr -> CoreExpr
+do_map_arrow ids b_ty c_ty d_ty f c
+ = do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) c
+
+mkFailExpr :: HsMatchContext Id -> Type -> DsM CoreExpr
+mkFailExpr ctxt ty
+ = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt)
+
+-- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> b
+mkSndExpr :: Type -> Type -> DsM CoreExpr
+mkSndExpr a_ty b_ty
+ = newSysLocalDs a_ty `thenDs` \ a_var ->
+ newSysLocalDs b_ty `thenDs` \ b_var ->
+ newSysLocalDs (mkCorePairTy a_ty b_ty) `thenDs` \ pair_var ->
+ returnDs (Lam pair_var
+ (coreCasePair pair_var a_var b_var (Var b_var)))
+\end{code}
+
+Build case analysis of a tuple. This cannot be done in the DsM monad,
+because the list of variables is typically not yet defined.
+
+\begin{code}
+-- coreCaseTuple [u1..] v [x1..xn] body
+-- = case v of v { (x1, .., xn) -> body }
+-- But the matching may be nested if the tuple is very big
+
+coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr
+coreCaseTuple uniqs scrut_var vars body
+ = mkTupleCase uniqs vars body scrut_var (Var scrut_var)
+
+coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr
+coreCasePair scrut_var var1 var2 body
+ = Case (Var scrut_var) scrut_var (exprType body)
+ [(DataAlt (tupleCon Boxed 2), [var1, var2], body)]
+\end{code}
+
+\begin{code}
+mkCorePairTy :: Type -> Type -> Type
+mkCorePairTy t1 t2 = mkCoreTupTy [t1, t2]
+
+mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr
+mkCorePairExpr e1 e2 = mkCoreTup [e1, e2]
+\end{code}
+
+The input is divided into a local environment, which is a flat tuple
+(unless it's too big), and a stack, each element of which is paired
+with the stack in turn. In general, the input has the form
+
+ (...((x1,...,xn),s1),...sk)
+
+where xi are the environment values, and si the ones on the stack,
+with s1 being the "top", the first one to be matched with a lambda.
+
+\begin{code}
+envStackType :: [Id] -> [Type] -> Type
+envStackType ids stack_tys = foldl mkCorePairTy (mkTupleType ids) stack_tys
+
+----------------------------------------------
+-- buildEnvStack
+--
+-- (...((x1,...,xn),s1),...sk)
+
+buildEnvStack :: [Id] -> [Id] -> CoreExpr
+buildEnvStack env_ids stack_ids
+ = foldl mkCorePairExpr (mkTupleExpr env_ids) (map Var stack_ids)
+
+----------------------------------------------
+-- matchEnvStack
+--
+-- \ (...((x1,...,xn),s1),...sk) -> e
+-- =>
+-- \ zk ->
+-- case zk of (zk-1,sk) ->
+-- ...
+-- case z1 of (z0,s1) ->
+-- case z0 of (x1,...,xn) ->
+-- e
+
+matchEnvStack :: [Id] -- x1..xn
+ -> [Id] -- s1..sk
+ -> CoreExpr -- e
+ -> DsM CoreExpr
+matchEnvStack env_ids stack_ids body
+ = newUniqueSupply `thenDs` \ uniqs ->
+ newSysLocalDs (mkTupleType env_ids) `thenDs` \ tup_var ->
+ matchVarStack tup_var stack_ids
+ (coreCaseTuple uniqs tup_var env_ids body)
+
+
+----------------------------------------------
+-- matchVarStack
+--
+-- \ (...(z0,s1),...sk) -> e
+-- =>
+-- \ zk ->
+-- case zk of (zk-1,sk) ->
+-- ...
+-- case z1 of (z0,s1) ->
+-- e
+
+matchVarStack :: Id -- z0
+ -> [Id] -- s1..sk
+ -> CoreExpr -- e
+ -> DsM CoreExpr
+matchVarStack env_id [] body
+ = returnDs (Lam env_id body)
+matchVarStack env_id (stack_id:stack_ids) body
+ = newSysLocalDs (mkCorePairTy (idType env_id) (idType stack_id))
+ `thenDs` \ pair_id ->
+ matchVarStack pair_id stack_ids
+ (coreCasePair pair_id env_id stack_id body)
+\end{code}
+
+\begin{code}
+mkHsTupleExpr :: [HsExpr Id] -> HsExpr Id
+mkHsTupleExpr [e] = e
+mkHsTupleExpr es = ExplicitTuple (map noLoc es) Boxed
+
+mkHsPairExpr :: HsExpr Id -> HsExpr Id -> HsExpr Id
+mkHsPairExpr e1 e2 = mkHsTupleExpr [e1, e2]
+
+mkHsEnvStackExpr :: [Id] -> [Id] -> HsExpr Id
+mkHsEnvStackExpr env_ids stack_ids
+ = foldl mkHsPairExpr (mkHsTupleExpr (map HsVar env_ids)) (map HsVar stack_ids)
+\end{code}
+
+Translation of arrow abstraction
+
+\begin{code}
+
+-- A | xs |- c :: [] t' ---> c'
+-- --------------------------
+-- A |- proc p -> c :: a t t' ---> arr (\ p -> (xs)) >>> c'
+--
+-- where (xs) is the tuple of variables bound by p
+
+dsProcExpr
+ :: LPat Id
+ -> LHsCmdTop Id
+ -> DsM CoreExpr
+dsProcExpr pat (L _ (HsCmdTop cmd [] cmd_ty ids))
+ = mkCmdEnv ids `thenDs` \ meth_ids ->
+ let
+ locals = mkVarSet (collectPatBinders pat)
+ in
+ dsfixCmd meth_ids locals [] cmd_ty cmd
+ `thenDs` \ (core_cmd, free_vars, env_ids) ->
+ let
+ env_ty = mkTupleType env_ids
+ in
+ mkFailExpr ProcExpr env_ty `thenDs` \ fail_expr ->
+ selectSimpleMatchVarL pat `thenDs` \ var ->
+ matchSimply (Var var) ProcExpr pat (mkTupleExpr env_ids) fail_expr
+ `thenDs` \ match_code ->
+ let
+ pat_ty = hsPatType pat
+ proc_code = do_map_arrow meth_ids pat_ty env_ty cmd_ty
+ (Lam var match_code)
+ core_cmd
+ in
+ returnDs (bindCmdEnv meth_ids proc_code)
+\end{code}
+
+Translation of command judgements of the form
+
+ A | xs |- c :: [ts] t
+
+\begin{code}
+dsLCmd ids local_vars env_ids stack res_ty cmd
+ = dsCmd ids local_vars env_ids stack res_ty (unLoc cmd)
+
+dsCmd :: DsCmdEnv -- arrow combinators
+ -> IdSet -- set of local vars available to this command
+ -> [Id] -- list of vars in the input to this command
+ -- This is typically fed back,
+ -- so don't pull on it too early
+ -> [Type] -- type of the stack
+ -> Type -- return type of the command
+ -> HsCmd Id -- command to desugar
+ -> DsM (CoreExpr, -- desugared expression
+ IdSet) -- set of local vars that occur free
+
+-- A |- f :: a (t*ts) t'
+-- A, xs |- arg :: t
+-- -----------------------------
+-- A | xs |- f -< arg :: [ts] t'
+--
+-- ---> arr (\ ((xs)*ts) -> (arg*ts)) >>> f
+
+dsCmd ids local_vars env_ids stack res_ty
+ (HsArrApp arrow arg arrow_ty HsFirstOrderApp _)
+ = let
+ (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
+ (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
+ env_ty = mkTupleType env_ids
+ in
+ dsLExpr arrow `thenDs` \ core_arrow ->
+ dsLExpr arg `thenDs` \ core_arg ->
+ mappM newSysLocalDs stack `thenDs` \ stack_ids ->
+ matchEnvStack env_ids stack_ids
+ (foldl mkCorePairExpr core_arg (map Var stack_ids))
+ `thenDs` \ core_make_arg ->
+ returnDs (do_map_arrow ids
+ (envStackType env_ids stack)
+ arg_ty
+ res_ty
+ core_make_arg
+ core_arrow,
+ exprFreeVars core_arg `intersectVarSet` local_vars)
+
+-- A, xs |- f :: a (t*ts) t'
+-- A, xs |- arg :: t
+-- ------------------------------
+-- A | xs |- f -<< arg :: [ts] t'
+--
+-- ---> arr (\ ((xs)*ts) -> (f,(arg*ts))) >>> app
+
+dsCmd ids local_vars env_ids stack res_ty
+ (HsArrApp arrow arg arrow_ty HsHigherOrderApp _)
+ = let
+ (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
+ (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
+ env_ty = mkTupleType env_ids
+ in
+ dsLExpr arrow `thenDs` \ core_arrow ->
+ dsLExpr arg `thenDs` \ core_arg ->
+ mappM newSysLocalDs stack `thenDs` \ stack_ids ->
+ matchEnvStack env_ids stack_ids
+ (mkCorePairExpr core_arrow
+ (foldl mkCorePairExpr core_arg (map Var stack_ids)))
+ `thenDs` \ core_make_pair ->
+ returnDs (do_map_arrow ids
+ (envStackType env_ids stack)
+ (mkCorePairTy arrow_ty arg_ty)
+ res_ty
+ core_make_pair
+ (do_app ids arg_ty res_ty),
+ (exprFreeVars core_arrow `unionVarSet` exprFreeVars core_arg)
+ `intersectVarSet` local_vars)
+
+-- A | ys |- c :: [t:ts] t'
+-- A, xs |- e :: t
+-- ------------------------
+-- A | xs |- c e :: [ts] t'
+--
+-- ---> arr (\ ((xs)*ts) -> let z = e in (((ys),z)*ts)) >>> c
+
+dsCmd ids local_vars env_ids stack res_ty (HsApp cmd arg)
+ = dsLExpr arg `thenDs` \ core_arg ->
+ let
+ arg_ty = exprType core_arg
+ stack' = arg_ty:stack
+ in
+ dsfixCmd ids local_vars stack' res_ty cmd
+ `thenDs` \ (core_cmd, free_vars, env_ids') ->
+ mappM newSysLocalDs stack `thenDs` \ stack_ids ->
+ newSysLocalDs arg_ty `thenDs` \ arg_id ->
+ -- push the argument expression onto the stack
+ let
+ core_body = bindNonRec arg_id core_arg
+ (buildEnvStack env_ids' (arg_id:stack_ids))
+ in
+ -- match the environment and stack against the input
+ matchEnvStack env_ids stack_ids core_body
+ `thenDs` \ core_map ->
+ returnDs (do_map_arrow ids
+ (envStackType env_ids stack)
+ (envStackType env_ids' stack')
+ res_ty
+ core_map
+ core_cmd,
+ (exprFreeVars core_arg `intersectVarSet` local_vars)
+ `unionVarSet` free_vars)
+
+-- A | ys |- c :: [ts] t'
+-- -----------------------------------------------
+-- A | xs |- \ p1 ... pk -> c :: [t1:...:tk:ts] t'
+--
+-- ---> arr (\ ((((xs), p1), ... pk)*ts) -> ((ys)*ts)) >>> c
+
+dsCmd ids local_vars env_ids stack res_ty
+ (HsLam (MatchGroup [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] _))
+ = let
+ pat_vars = mkVarSet (collectPatsBinders pats)
+ local_vars' = local_vars `unionVarSet` pat_vars
+ stack' = drop (length pats) stack
+ in
+ dsfixCmd ids local_vars' stack' res_ty body
+ `thenDs` \ (core_body, free_vars, env_ids') ->
+ mappM newSysLocalDs stack `thenDs` \ stack_ids ->
+
+ -- the expression is built from the inside out, so the actions
+ -- are presented in reverse order
+
+ let
+ (actual_ids, stack_ids') = splitAt (length pats) stack_ids
+ -- build a new environment, plus what's left of the stack
+ core_expr = buildEnvStack env_ids' stack_ids'
+ in_ty = envStackType env_ids stack
+ in_ty' = envStackType env_ids' stack'
+ in
+ mkFailExpr LambdaExpr in_ty' `thenDs` \ fail_expr ->
+ -- match the patterns against the top of the old stack
+ matchSimplys (map Var actual_ids) LambdaExpr pats core_expr fail_expr
+ `thenDs` \ match_code ->
+ -- match the old environment and stack against the input
+ matchEnvStack env_ids stack_ids match_code
+ `thenDs` \ select_code ->
+ returnDs (do_map_arrow ids in_ty in_ty' res_ty select_code core_body,
+ free_vars `minusVarSet` pat_vars)
+
+dsCmd ids local_vars env_ids stack res_ty (HsPar cmd)
+ = dsLCmd ids local_vars env_ids stack res_ty cmd
+
+-- A, xs |- e :: Bool
+-- A | xs1 |- c1 :: [ts] t
+-- A | xs2 |- c2 :: [ts] t
+-- ----------------------------------------
+-- A | xs |- if e then c1 else c2 :: [ts] t
+--
+-- ---> arr (\ ((xs)*ts) ->
+-- if e then Left ((xs1)*ts) else Right ((xs2)*ts)) >>>
+-- c1 ||| c2
+
+dsCmd ids local_vars env_ids stack res_ty (HsIf cond then_cmd else_cmd)
+ = dsLExpr cond `thenDs` \ core_cond ->
+ dsfixCmd ids local_vars stack res_ty then_cmd
+ `thenDs` \ (core_then, fvs_then, then_ids) ->
+ dsfixCmd ids local_vars stack res_ty else_cmd
+ `thenDs` \ (core_else, fvs_else, else_ids) ->
+ mappM newSysLocalDs stack `thenDs` \ stack_ids ->
+ dsLookupTyCon eitherTyConName `thenDs` \ either_con ->
+ dsLookupDataCon leftDataConName `thenDs` \ left_con ->
+ dsLookupDataCon rightDataConName `thenDs` \ right_con ->
+ let
+ left_expr ty1 ty2 e = mkConApp left_con [Type ty1, Type ty2, e]
+ right_expr ty1 ty2 e = mkConApp right_con [Type ty1, Type ty2, e]
+
+ in_ty = envStackType env_ids stack
+ then_ty = envStackType then_ids stack
+ else_ty = envStackType else_ids stack
+ sum_ty = mkTyConApp either_con [then_ty, else_ty]
+ fvs_cond = exprFreeVars core_cond `intersectVarSet` local_vars
+ in
+ matchEnvStack env_ids stack_ids
+ (mkIfThenElse core_cond
+ (left_expr then_ty else_ty (buildEnvStack then_ids stack_ids))
+ (right_expr then_ty else_ty (buildEnvStack else_ids stack_ids)))
+ `thenDs` \ core_if ->
+ returnDs(do_map_arrow ids in_ty sum_ty res_ty
+ core_if
+ (do_choice ids then_ty else_ty res_ty core_then core_else),
+ fvs_cond `unionVarSet` fvs_then `unionVarSet` fvs_else)
+\end{code}
+
+Case commands are treated in much the same way as if commands
+(see above) except that there are more alternatives. For example
+
+ case e of { p1 -> c1; p2 -> c2; p3 -> c3 }
+
+is translated to
+
+ arr (\ ((xs)*ts) -> case e of
+ p1 -> (Left (Left (xs1)*ts))
+ p2 -> Left ((Right (xs2)*ts))
+ p3 -> Right ((xs3)*ts)) >>>
+ (c1 ||| c2) ||| c3
+
+The idea is to extract the commands from the case, build a balanced tree
+of choices, and replace the commands with expressions that build tagged
+tuples, obtaining a case expression that can be desugared normally.
+To build all this, we use quadruples decribing segments of the list of
+case bodies, containing the following fields:
+1. an IdSet containing the environment variables free in the case bodies
+2. a list of expressions of the form (Left|Right)* ((xs)*ts), to be put
+ into the case replacing the commands
+3. a sum type that is the common type of these expressions, and also the
+ input type of the arrow
+4. a CoreExpr for an arrow built by combining the translated command
+ bodies with |||.
+
+\begin{code}
+dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ty))
+ = dsLExpr exp `thenDs` \ core_exp ->
+ mappM newSysLocalDs stack `thenDs` \ stack_ids ->
+
+ -- Extract and desugar the leaf commands in the case, building tuple
+ -- expressions that will (after tagging) replace these leaves
+
+ let
+ leaves = concatMap leavesMatch matches
+ make_branch (leaf, bound_vars)
+ = dsfixCmd ids (local_vars `unionVarSet` bound_vars) stack res_ty leaf
+ `thenDs` \ (core_leaf, fvs, leaf_ids) ->
+ returnDs (fvs `minusVarSet` bound_vars,
+ [noLoc $ mkHsEnvStackExpr leaf_ids stack_ids],
+ envStackType leaf_ids stack,
+ core_leaf)
+ in
+ mappM make_branch leaves `thenDs` \ branches ->
+ dsLookupTyCon eitherTyConName `thenDs` \ either_con ->
+ dsLookupDataCon leftDataConName `thenDs` \ left_con ->
+ dsLookupDataCon rightDataConName `thenDs` \ right_con ->
+ let
+ left_id = nlHsVar (dataConWrapId left_con)
+ right_id = nlHsVar (dataConWrapId right_con)
+ left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ TyApp left_id [ty1, ty2]) e
+ right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ TyApp right_id [ty1, ty2]) e
+
+ -- Prefix each tuple with a distinct series of Left's and Right's,
+ -- in a balanced way, keeping track of the types.
+
+ merge_branches (fvs1, builds1, in_ty1, core_exp1)
+ (fvs2, builds2, in_ty2, core_exp2)
+ = (fvs1 `unionVarSet` fvs2,
+ map (left_expr in_ty1 in_ty2) builds1 ++
+ map (right_expr in_ty1 in_ty2) builds2,
+ mkTyConApp either_con [in_ty1, in_ty2],
+ do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2)
+ (fvs_alts, leaves', sum_ty, core_choices)
+ = foldb merge_branches branches
+
+ -- Replace the commands in the case with these tagged tuples,
+ -- yielding a HsExpr Id we can feed to dsExpr.
+
+ (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
+ in_ty = envStackType env_ids stack
+ fvs_exp = exprFreeVars core_exp `intersectVarSet` local_vars
+
+ pat_ty = funArgTy match_ty
+ match_ty' = mkFunTy pat_ty sum_ty
+ -- Note that we replace the HsCase result type by sum_ty,
+ -- which is the type of matches'
+ in
+ dsExpr (HsCase exp (MatchGroup matches' match_ty')) `thenDs` \ core_body ->
+ matchEnvStack env_ids stack_ids core_body
+ `thenDs` \ core_matches ->
+ returnDs(do_map_arrow ids in_ty sum_ty res_ty core_matches core_choices,
+ fvs_exp `unionVarSet` fvs_alts)
+
+-- A | ys |- c :: [ts] t
+-- ----------------------------------
+-- A | xs |- let binds in c :: [ts] t
+--
+-- ---> arr (\ ((xs)*ts) -> let binds in ((ys)*ts)) >>> c
+
+dsCmd ids local_vars env_ids stack res_ty (HsLet binds body)
+ = let
+ defined_vars = mkVarSet (map unLoc (collectLocalBinders binds))
+ local_vars' = local_vars `unionVarSet` defined_vars
+ in
+ dsfixCmd ids local_vars' stack res_ty body
+ `thenDs` \ (core_body, free_vars, env_ids') ->
+ mappM newSysLocalDs stack `thenDs` \ stack_ids ->
+ -- build a new environment, plus the stack, using the let bindings
+ dsLocalBinds binds (buildEnvStack env_ids' stack_ids)
+ `thenDs` \ core_binds ->
+ -- match the old environment and stack against the input
+ matchEnvStack env_ids stack_ids core_binds
+ `thenDs` \ core_map ->
+ returnDs (do_map_arrow ids
+ (envStackType env_ids stack)
+ (envStackType env_ids' stack)
+ res_ty
+ core_map
+ core_body,
+ exprFreeVars core_binds `intersectVarSet` local_vars)
+
+dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts body _)
+ = dsCmdDo ids local_vars env_ids res_ty stmts body
+
+-- A |- e :: forall e. a1 (e*ts1) t1 -> ... an (e*tsn) tn -> a (e*ts) t
+-- A | xs |- ci :: [tsi] ti
+-- -----------------------------------
+-- A | xs |- (|e c1 ... cn|) :: [ts] t ---> e [t_xs] c1 ... cn
+
+dsCmd _ids local_vars env_ids _stack _res_ty (HsArrForm op _ args)
+ = let
+ env_ty = mkTupleType env_ids
+ in
+ dsLExpr op `thenDs` \ core_op ->
+ mapAndUnzipDs (dsTrimCmdArg local_vars env_ids) args
+ `thenDs` \ (core_args, fv_sets) ->
+ returnDs (mkApps (App core_op (Type env_ty)) core_args,
+ unionVarSets fv_sets)
+
+-- A | ys |- c :: [ts] t (ys <= xs)
+-- ---------------------
+-- A | xs |- c :: [ts] t ---> arr_ts (\ (xs) -> (ys)) >>> c
+
+dsTrimCmdArg
+ :: IdSet -- set of local vars available to this command
+ -> [Id] -- list of vars in the input to this command
+ -> LHsCmdTop Id -- command argument to desugar
+ -> DsM (CoreExpr, -- desugared expression
+ IdSet) -- set of local vars that occur free
+dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack cmd_ty ids))
+ = mkCmdEnv ids `thenDs` \ meth_ids ->
+ dsfixCmd meth_ids local_vars stack cmd_ty cmd
+ `thenDs` \ (core_cmd, free_vars, env_ids') ->
+ mappM newSysLocalDs stack `thenDs` \ stack_ids ->
+ matchEnvStack env_ids stack_ids (buildEnvStack env_ids' stack_ids)
+ `thenDs` \ trim_code ->
+ let
+ in_ty = envStackType env_ids stack
+ in_ty' = envStackType env_ids' stack
+ arg_code = if env_ids' == env_ids then core_cmd else
+ do_map_arrow meth_ids in_ty in_ty' cmd_ty trim_code core_cmd
+ in
+ returnDs (bindCmdEnv meth_ids arg_code, free_vars)
+
+-- Given A | xs |- c :: [ts] t, builds c with xs fed back.
+-- Typically needs to be prefixed with arr (\p -> ((xs)*ts))
+
+dsfixCmd
+ :: DsCmdEnv -- arrow combinators
+ -> IdSet -- set of local vars available to this command
+ -> [Type] -- type of the stack
+ -> Type -- return type of the command
+ -> LHsCmd Id -- command to desugar
+ -> DsM (CoreExpr, -- desugared expression
+ IdSet, -- set of local vars that occur free
+ [Id]) -- set as a list, fed back
+dsfixCmd ids local_vars stack cmd_ty cmd
+ = fixDs (\ ~(_,_,env_ids') ->
+ dsLCmd ids local_vars env_ids' stack cmd_ty cmd
+ `thenDs` \ (core_cmd, free_vars) ->
+ returnDs (core_cmd, free_vars, varSetElems free_vars))
+
+\end{code}
+
+Translation of command judgements of the form
+
+ A | xs |- do { ss } :: [] t
+
+\begin{code}
+
+dsCmdDo :: DsCmdEnv -- arrow combinators
+ -> IdSet -- set of local vars available to this statement
+ -> [Id] -- list of vars in the input to this statement
+ -- This is typically fed back,
+ -- so don't pull on it too early
+ -> Type -- return type of the statement
+ -> [LStmt Id] -- statements to desugar
+ -> LHsExpr Id -- body
+ -> DsM (CoreExpr, -- desugared expression
+ IdSet) -- set of local vars that occur free
+
+-- A | xs |- c :: [] t
+-- --------------------------
+-- A | xs |- do { c } :: [] t
+
+dsCmdDo ids local_vars env_ids res_ty [] body
+ = dsLCmd ids local_vars env_ids [] res_ty body
+
+dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) body
+ = let
+ bound_vars = mkVarSet (map unLoc (collectLStmtBinders stmt))
+ local_vars' = local_vars `unionVarSet` bound_vars
+ in
+ fixDs (\ ~(_,_,env_ids') ->
+ dsCmdDo ids local_vars' env_ids' res_ty stmts body
+ `thenDs` \ (core_stmts, fv_stmts) ->
+ returnDs (core_stmts, fv_stmts, varSetElems fv_stmts))
+ `thenDs` \ (core_stmts, fv_stmts, env_ids') ->
+ dsCmdLStmt ids local_vars env_ids env_ids' stmt
+ `thenDs` \ (core_stmt, fv_stmt) ->
+ returnDs (do_compose ids
+ (mkTupleType env_ids)
+ (mkTupleType env_ids')
+ res_ty
+ core_stmt
+ core_stmts,
+ fv_stmt)
+
+\end{code}
+A statement maps one local environment to another, and is represented
+as an arrow from one tuple type to another. A statement sequence is
+translated to a composition of such arrows.
+\begin{code}
+dsCmdLStmt ids local_vars env_ids out_ids cmd
+ = dsCmdStmt ids local_vars env_ids out_ids (unLoc cmd)
+
+dsCmdStmt
+ :: DsCmdEnv -- arrow combinators
+ -> IdSet -- set of local vars available to this statement
+ -> [Id] -- list of vars in the input to this statement
+ -- This is typically fed back,
+ -- so don't pull on it too early
+ -> [Id] -- list of vars in the output of this statement
+ -> Stmt Id -- statement to desugar
+ -> DsM (CoreExpr, -- desugared expression
+ IdSet) -- set of local vars that occur free
+
+-- A | xs1 |- c :: [] t
+-- A | xs' |- do { ss } :: [] t'
+-- ------------------------------
+-- A | xs |- do { c; ss } :: [] t'
+--
+-- ---> arr (\ (xs) -> ((xs1),(xs'))) >>> first c >>>
+-- arr snd >>> ss
+
+dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ c_ty)
+ = dsfixCmd ids local_vars [] c_ty cmd
+ `thenDs` \ (core_cmd, fv_cmd, env_ids1) ->
+ matchEnvStack env_ids []
+ (mkCorePairExpr (mkTupleExpr env_ids1) (mkTupleExpr out_ids))
+ `thenDs` \ core_mux ->
+ let
+ in_ty = mkTupleType env_ids
+ in_ty1 = mkTupleType env_ids1
+ out_ty = mkTupleType out_ids
+ before_c_ty = mkCorePairTy in_ty1 out_ty
+ after_c_ty = mkCorePairTy c_ty out_ty
+ in
+ mkSndExpr c_ty out_ty `thenDs` \ snd_fn ->
+ returnDs (do_map_arrow ids in_ty before_c_ty out_ty core_mux $
+ do_compose ids before_c_ty after_c_ty out_ty
+ (do_first ids in_ty1 c_ty out_ty core_cmd) $
+ do_arr ids after_c_ty out_ty snd_fn,
+ extendVarSetList fv_cmd out_ids)
+ where
+
+-- A | xs1 |- c :: [] t
+-- A | xs' |- do { ss } :: [] t' xs2 = xs' - defs(p)
+-- -----------------------------------
+-- A | xs |- do { p <- c; ss } :: [] t'
+--
+-- ---> arr (\ (xs) -> ((xs1),(xs2))) >>> first c >>>
+-- arr (\ (p, (xs2)) -> (xs')) >>> ss
+--
+-- It would be simpler and more consistent to do this using second,
+-- but that's likely to be defined in terms of first.
+
+dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _ _)
+ = dsfixCmd ids local_vars [] (hsPatType pat) cmd
+ `thenDs` \ (core_cmd, fv_cmd, env_ids1) ->
+ let
+ pat_ty = hsPatType pat
+ pat_vars = mkVarSet (collectPatBinders pat)
+ env_ids2 = varSetElems (mkVarSet out_ids `minusVarSet` pat_vars)
+ env_ty2 = mkTupleType env_ids2
+ in
+
+ -- multiplexing function
+ -- \ (xs) -> ((xs1),(xs2))
+
+ matchEnvStack env_ids []
+ (mkCorePairExpr (mkTupleExpr env_ids1) (mkTupleExpr env_ids2))
+ `thenDs` \ core_mux ->
+
+ -- projection function
+ -- \ (p, (xs2)) -> (zs)
+
+ newSysLocalDs env_ty2 `thenDs` \ env_id ->
+ newUniqueSupply `thenDs` \ uniqs ->
+ let
+ after_c_ty = mkCorePairTy pat_ty env_ty2
+ out_ty = mkTupleType out_ids
+ body_expr = coreCaseTuple uniqs env_id env_ids2 (mkTupleExpr out_ids)
+ in
+ mkFailExpr (StmtCtxt DoExpr) out_ty `thenDs` \ fail_expr ->
+ selectSimpleMatchVarL pat `thenDs` \ pat_id ->
+ matchSimply (Var pat_id) (StmtCtxt DoExpr) pat body_expr fail_expr
+ `thenDs` \ match_code ->
+ newSysLocalDs after_c_ty `thenDs` \ pair_id ->
+ let
+ proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code)
+ in
+
+ -- put it all together
+ let
+ in_ty = mkTupleType env_ids
+ in_ty1 = mkTupleType env_ids1
+ in_ty2 = mkTupleType env_ids2
+ before_c_ty = mkCorePairTy in_ty1 in_ty2
+ in
+ returnDs (do_map_arrow ids in_ty before_c_ty out_ty core_mux $
+ do_compose ids before_c_ty after_c_ty out_ty
+ (do_first ids in_ty1 pat_ty in_ty2 core_cmd) $
+ do_arr ids after_c_ty out_ty proj_expr,
+ fv_cmd `unionVarSet` (mkVarSet out_ids `minusVarSet` pat_vars))
+
+-- A | xs' |- do { ss } :: [] t
+-- --------------------------------------
+-- A | xs |- do { let binds; ss } :: [] t
+--
+-- ---> arr (\ (xs) -> let binds in (xs')) >>> ss
+
+dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds)
+ -- build a new environment using the let bindings
+ = dsLocalBinds binds (mkTupleExpr out_ids) `thenDs` \ core_binds ->
+ -- match the old environment against the input
+ matchEnvStack env_ids [] core_binds `thenDs` \ core_map ->
+ returnDs (do_arr ids
+ (mkTupleType env_ids)
+ (mkTupleType out_ids)
+ core_map,
+ exprFreeVars core_binds `intersectVarSet` local_vars)
+
+-- A | ys |- do { ss; returnA -< ((xs1), (ys2)) } :: [] ...
+-- A | xs' |- do { ss' } :: [] t
+-- ------------------------------------
+-- A | xs |- do { rec ss; ss' } :: [] t
+--
+-- xs1 = xs' /\ defs(ss)
+-- xs2 = xs' - defs(ss)
+-- ys1 = ys - defs(ss)
+-- ys2 = ys /\ defs(ss)
+--
+-- ---> arr (\(xs) -> ((ys1),(xs2))) >>>
+-- first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>>
+-- arr (\((xs1),(xs2)) -> (xs')) >>> ss'
+
+dsCmdStmt ids local_vars env_ids out_ids (RecStmt stmts later_ids rec_ids rhss binds)
+ = let -- ToDo: ****** binds not desugared; ROSS PLEASE FIX ********
+ env2_id_set = mkVarSet out_ids `minusVarSet` mkVarSet later_ids
+ env2_ids = varSetElems env2_id_set
+ env2_ty = mkTupleType env2_ids
+ in
+
+ -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids)
+
+ newUniqueSupply `thenDs` \ uniqs ->
+ newSysLocalDs env2_ty `thenDs` \ env2_id ->
+ let
+ later_ty = mkTupleType later_ids
+ post_pair_ty = mkCorePairTy later_ty env2_ty
+ post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkTupleExpr out_ids)
+ in
+ matchEnvStack later_ids [env2_id] post_loop_body
+ `thenDs` \ post_loop_fn ->
+
+ --- loop (...)
+
+ dsRecCmd ids local_vars stmts later_ids rec_ids rhss
+ `thenDs` \ (core_loop, env1_id_set, env1_ids) ->
+
+ -- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids))
+
+ let
+ env1_ty = mkTupleType env1_ids
+ pre_pair_ty = mkCorePairTy env1_ty env2_ty
+ pre_loop_body = mkCorePairExpr (mkTupleExpr env1_ids)
+ (mkTupleExpr env2_ids)
+
+ in
+ matchEnvStack env_ids [] pre_loop_body
+ `thenDs` \ pre_loop_fn ->
+
+ -- arr pre_loop_fn >>> first (loop (...)) >>> arr post_loop_fn
+
+ let
+ env_ty = mkTupleType env_ids
+ out_ty = mkTupleType out_ids
+ core_body = do_map_arrow ids env_ty pre_pair_ty out_ty
+ pre_loop_fn
+ (do_compose ids pre_pair_ty post_pair_ty out_ty
+ (do_first ids env1_ty later_ty env2_ty
+ core_loop)
+ (do_arr ids post_pair_ty out_ty
+ post_loop_fn))
+ in
+ returnDs (core_body, env1_id_set `unionVarSet` env2_id_set)
+
+-- loop (arr (\ ((env1_ids), ~(rec_ids)) -> (env_ids)) >>>
+-- ss >>>
+-- arr (\ (out_ids) -> ((later_ids),(rhss))) >>>
+
+dsRecCmd ids local_vars stmts later_ids rec_ids rhss
+ = let
+ rec_id_set = mkVarSet rec_ids
+ out_ids = varSetElems (mkVarSet later_ids `unionVarSet` rec_id_set)
+ out_ty = mkTupleType out_ids
+ local_vars' = local_vars `unionVarSet` rec_id_set
+ in
+
+ -- mk_pair_fn = \ (out_ids) -> ((later_ids),(rhss))
+
+ mappM dsExpr rhss `thenDs` \ core_rhss ->
+ let
+ later_tuple = mkTupleExpr later_ids
+ later_ty = mkTupleType later_ids
+ rec_tuple = mkBigCoreTup core_rhss
+ rec_ty = mkTupleType rec_ids
+ out_pair = mkCorePairExpr later_tuple rec_tuple
+ out_pair_ty = mkCorePairTy later_ty rec_ty
+ in
+ matchEnvStack out_ids [] out_pair
+ `thenDs` \ mk_pair_fn ->
+
+ -- ss
+
+ dsfixCmdStmts ids local_vars' out_ids stmts
+ `thenDs` \ (core_stmts, fv_stmts, env_ids) ->
+
+ -- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids)
+
+ newSysLocalDs rec_ty `thenDs` \ rec_id ->
+ let
+ env1_id_set = fv_stmts `minusVarSet` rec_id_set
+ env1_ids = varSetElems env1_id_set
+ env1_ty = mkTupleType env1_ids
+ in_pair_ty = mkCorePairTy env1_ty rec_ty
+ core_body = mkBigCoreTup (map selectVar env_ids)
+ where
+ selectVar v
+ | v `elemVarSet` rec_id_set
+ = mkTupleSelector rec_ids v rec_id (Var rec_id)
+ | otherwise = Var v
+ in
+ matchEnvStack env1_ids [rec_id] core_body
+ `thenDs` \ squash_pair_fn ->
+
+ -- loop (arr squash_pair_fn >>> ss >>> arr mk_pair_fn)
+
+ let
+ env_ty = mkTupleType env_ids
+ core_loop = do_loop ids env1_ty later_ty rec_ty
+ (do_map_arrow ids in_pair_ty env_ty out_pair_ty
+ squash_pair_fn
+ (do_compose ids env_ty out_ty out_pair_ty
+ core_stmts
+ (do_arr ids out_ty out_pair_ty mk_pair_fn)))
+ in
+ returnDs (core_loop, env1_id_set, env1_ids)
+
+\end{code}
+A sequence of statements (as in a rec) is desugared to an arrow between
+two environments
+\begin{code}
+
+dsfixCmdStmts
+ :: DsCmdEnv -- arrow combinators
+ -> IdSet -- set of local vars available to this statement
+ -> [Id] -- output vars of these statements
+ -> [LStmt Id] -- statements to desugar
+ -> DsM (CoreExpr, -- desugared expression
+ IdSet, -- set of local vars that occur free
+ [Id]) -- input vars
+
+dsfixCmdStmts ids local_vars out_ids stmts
+ = fixDs (\ ~(_,_,env_ids) ->
+ dsCmdStmts ids local_vars env_ids out_ids stmts
+ `thenDs` \ (core_stmts, fv_stmts) ->
+ returnDs (core_stmts, fv_stmts, varSetElems fv_stmts))
+
+dsCmdStmts
+ :: DsCmdEnv -- arrow combinators
+ -> IdSet -- set of local vars available to this statement
+ -> [Id] -- list of vars in the input to these statements
+ -> [Id] -- output vars of these statements
+ -> [LStmt Id] -- statements to desugar
+ -> DsM (CoreExpr, -- desugared expression
+ IdSet) -- set of local vars that occur free
+
+dsCmdStmts ids local_vars env_ids out_ids [stmt]
+ = dsCmdLStmt ids local_vars env_ids out_ids stmt
+
+dsCmdStmts ids local_vars env_ids out_ids (stmt:stmts)
+ = let
+ bound_vars = mkVarSet (map unLoc (collectLStmtBinders stmt))
+ local_vars' = local_vars `unionVarSet` bound_vars
+ in
+ dsfixCmdStmts ids local_vars' out_ids stmts
+ `thenDs` \ (core_stmts, fv_stmts, env_ids') ->
+ dsCmdLStmt ids local_vars env_ids env_ids' stmt
+ `thenDs` \ (core_stmt, fv_stmt) ->
+ returnDs (do_compose ids
+ (mkTupleType env_ids)
+ (mkTupleType env_ids')
+ (mkTupleType out_ids)
+ core_stmt
+ core_stmts,
+ fv_stmt)
+
+\end{code}
+
+Match a list of expressions against a list of patterns, left-to-right.
+
+\begin{code}
+matchSimplys :: [CoreExpr] -- Scrutinees
+ -> HsMatchContext Name -- Match kind
+ -> [LPat Id] -- Patterns they should match
+ -> CoreExpr -- Return this if they all match
+ -> CoreExpr -- Return this if they don't
+ -> DsM CoreExpr
+matchSimplys [] _ctxt [] result_expr _fail_expr = returnDs result_expr
+matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr
+ = matchSimplys exps ctxt pats result_expr fail_expr
+ `thenDs` \ match_code ->
+ matchSimply exp ctxt pat match_code fail_expr
+\end{code}
+
+List of leaf expressions, with set of variables bound in each
+
+\begin{code}
+leavesMatch :: LMatch Id -> [(LHsExpr Id, IdSet)]
+leavesMatch (L _ (Match pats _ (GRHSs grhss binds)))
+ = let
+ defined_vars = mkVarSet (collectPatsBinders pats)
+ `unionVarSet`
+ mkVarSet (map unLoc (collectLocalBinders binds))
+ in
+ [(expr,
+ mkVarSet (map unLoc (collectLStmtsBinders stmts))
+ `unionVarSet` defined_vars)
+ | L _ (GRHS stmts expr) <- grhss]
+\end{code}
+
+Replace the leaf commands in a match
+
+\begin{code}
+replaceLeavesMatch
+ :: Type -- new result type
+ -> [LHsExpr Id] -- replacement leaf expressions of that type
+ -> LMatch Id -- the matches of a case command
+ -> ([LHsExpr Id],-- remaining leaf expressions
+ LMatch Id) -- updated match
+replaceLeavesMatch res_ty leaves (L loc (Match pat mt (GRHSs grhss binds)))
+ = let
+ (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
+ in
+ (leaves', L loc (Match pat mt (GRHSs grhss' binds)))
+
+replaceLeavesGRHS
+ :: [LHsExpr Id] -- replacement leaf expressions of that type
+ -> LGRHS Id -- rhss of a case command
+ -> ([LHsExpr Id],-- remaining leaf expressions
+ LGRHS Id) -- updated GRHS
+replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts rhs))
+ = (leaves, L loc (GRHS stmts leaf))
+\end{code}
+
+Balanced fold of a non-empty list.
+
+\begin{code}
+foldb :: (a -> a -> a) -> [a] -> a
+foldb _ [] = error "foldb of empty list"
+foldb _ [x] = x
+foldb f xs = foldb f (fold_pairs xs)
+ where
+ fold_pairs [] = []
+ fold_pairs [x] = [x]
+ fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs
+\end{code}
diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
new file mode 100644
index 0000000000..8f3006d0f3
--- /dev/null
+++ b/compiler/deSugar/DsBinds.lhs
@@ -0,0 +1,417 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[DsBinds]{Pattern-matching bindings (HsBinds and MonoBinds)}
+
+Handles @HsBinds@; those at the top level require different handling,
+in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at
+lower levels it is preserved with @let@/@letrec@s).
+
+\begin{code}
+module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs,
+ dsCoercion,
+ AutoScc(..)
+ ) where
+
+#include "HsVersions.h"
+
+
+import {-# SOURCE #-} DsExpr( dsLExpr, dsExpr )
+import {-# SOURCE #-} Match( matchWrapper )
+
+import DsMonad
+import DsGRHSs ( dsGuarded )
+import DsUtils
+
+import HsSyn -- lots of things
+import CoreSyn -- lots of things
+import CoreUtils ( exprType, mkInlineMe, mkSCC )
+
+import StaticFlags ( opt_AutoSccsOnAllToplevs,
+ opt_AutoSccsOnExportedToplevs )
+import OccurAnal ( occurAnalyseExpr )
+import CostCentre ( mkAutoCC, IsCafCC(..) )
+import Id ( Id, DictId, idType, idName, isExportedId, mkLocalId, setInlinePragma )
+import Rules ( addIdSpecialisations, mkLocalRule )
+import Var ( TyVar, Var, isGlobalId, setIdNotExported )
+import VarEnv
+import Type ( mkTyVarTy, substTyWith )
+import TysWiredIn ( voidTy )
+import Outputable
+import SrcLoc ( Located(..) )
+import Maybes ( isJust, catMaybes, orElse )
+import Bag ( bagToList )
+import BasicTypes ( Activation(..), InlineSpec(..), isAlwaysActive, defaultInlineSpec )
+import Monad ( foldM )
+import FastString ( mkFastString )
+import List ( (\\) )
+import Util ( mapSnd )
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
+%* *
+%************************************************************************
+
+\begin{code}
+dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
+dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds
+
+dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
+dsLHsBinds binds = ds_lhs_binds NoSccs binds
+
+
+------------------------
+ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
+ -- scc annotation policy (see below)
+ds_lhs_binds auto_scc binds = foldM (dsLHsBind auto_scc) [] (bagToList binds)
+
+dsLHsBind :: AutoScc
+ -> [(Id,CoreExpr)] -- Put this on the end (avoid quadratic append)
+ -> LHsBind Id
+ -> DsM [(Id,CoreExpr)] -- Result
+dsLHsBind auto_scc rest (L loc bind)
+ = putSrcSpanDs loc $ dsHsBind auto_scc rest bind
+
+dsHsBind :: AutoScc
+ -> [(Id,CoreExpr)] -- Put this on the end (avoid quadratic append)
+ -> HsBind Id
+ -> DsM [(Id,CoreExpr)] -- Result
+
+dsHsBind auto_scc rest (VarBind var expr)
+ = dsLExpr expr `thenDs` \ core_expr ->
+
+ -- Dictionary bindings are always VarMonoBinds, so
+ -- we only need do this here
+ addDictScc var core_expr `thenDs` \ core_expr' ->
+ returnDs ((var, core_expr') : rest)
+
+dsHsBind auto_scc rest (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn })
+ = matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, body) ->
+ dsCoercion co_fn (return (mkLams args body)) `thenDs` \ rhs ->
+ addAutoScc auto_scc (fun, rhs) `thenDs` \ pair ->
+ returnDs (pair : rest)
+
+dsHsBind auto_scc rest (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })
+ = dsGuarded grhss ty `thenDs` \ body_expr ->
+ mkSelectorBinds pat body_expr `thenDs` \ sel_binds ->
+ mappM (addAutoScc auto_scc) sel_binds `thenDs` \ sel_binds ->
+ returnDs (sel_binds ++ rest)
+
+ -- Common special case: no type or dictionary abstraction
+ -- For the (rare) case when there are some mixed-up
+ -- dictionary bindings (for which a Rec is convenient)
+ -- we reply on the enclosing dsBind to wrap a Rec around.
+dsHsBind auto_scc rest (AbsBinds [] [] exports binds)
+ = ds_lhs_binds (addSccs auto_scc exports) binds `thenDs` \ core_prs ->
+ let
+ core_prs' = addLocalInlines exports core_prs
+ exports' = [(global, Var local) | (_, global, local, _) <- exports]
+ in
+ returnDs (core_prs' ++ exports' ++ rest)
+
+ -- Another common case: one exported variable
+ -- Non-recursive bindings come through this way
+dsHsBind auto_scc rest
+ (AbsBinds all_tyvars dicts exports@[(tyvars, global, local, prags)] binds)
+ = ASSERT( all (`elem` tyvars) all_tyvars )
+ ds_lhs_binds (addSccs auto_scc exports) binds `thenDs` \ core_prs ->
+ let
+ -- Always treat the binds as recursive, because the typechecker
+ -- makes rather mixed-up dictionary bindings
+ core_bind = Rec core_prs
+ in
+ mappM (dsSpec all_tyvars dicts tyvars global local core_bind)
+ prags `thenDs` \ mb_specs ->
+ let
+ (spec_binds, rules) = unzip (catMaybes mb_specs)
+ global' = addIdSpecialisations global rules
+ rhs' = mkLams tyvars $ mkLams dicts $ Let core_bind (Var local)
+ inl = case [inl | InlinePrag inl <- prags] of
+ [] -> defaultInlineSpec
+ (inl:_) -> inl
+ in
+ returnDs (addInlineInfo inl global' rhs' : spec_binds ++ rest)
+
+dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
+ = ds_lhs_binds (addSccs auto_scc exports) binds `thenDs` \ core_prs ->
+ let
+ -- Rec because of mixed-up dictionary bindings
+ core_bind = Rec (addLocalInlines exports core_prs)
+
+ tup_expr = mkTupleExpr locals
+ tup_ty = exprType tup_expr
+ poly_tup_expr = mkLams all_tyvars $ mkLams dicts $
+ Let core_bind tup_expr
+ locals = [local | (_, _, local, _) <- exports]
+ local_tys = map idType locals
+ in
+ newSysLocalDs (exprType poly_tup_expr) `thenDs` \ poly_tup_id ->
+ let
+ dict_args = map Var dicts
+
+ mk_bind ((tyvars, global, local, prags), n) -- locals !! n == local
+ = -- Need to make fresh locals to bind in the selector, because
+ -- some of the tyvars will be bound to voidTy
+ newSysLocalsDs (map substitute local_tys) `thenDs` \ locals' ->
+ newSysLocalDs (substitute tup_ty) `thenDs` \ tup_id ->
+ mapM (dsSpec all_tyvars dicts tyvars global local core_bind)
+ prags `thenDs` \ mb_specs ->
+ let
+ (spec_binds, rules) = unzip (catMaybes mb_specs)
+ global' = addIdSpecialisations global rules
+ rhs = mkLams tyvars $ mkLams dicts $
+ mkTupleSelector locals' (locals' !! n) tup_id $
+ mkApps (mkTyApps (Var poly_tup_id) ty_args) dict_args
+ in
+ returnDs ((global', rhs) : spec_binds)
+ where
+ mk_ty_arg all_tyvar | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
+ | otherwise = voidTy
+ ty_args = map mk_ty_arg all_tyvars
+ substitute = substTyWith all_tyvars ty_args
+ in
+ mappM mk_bind (exports `zip` [0..]) `thenDs` \ export_binds_s ->
+ -- don't scc (auto-)annotate the tuple itself.
+
+ returnDs ((poly_tup_id, poly_tup_expr) : (concat export_binds_s ++ rest))
+
+dsSpec :: [TyVar] -> [DictId] -> [TyVar]
+ -> Id -> Id -- Global, local
+ -> CoreBind -> Prag
+ -> DsM (Maybe ((Id,CoreExpr), -- Binding for specialised Id
+ CoreRule)) -- Rule for the Global Id
+
+-- Example:
+-- f :: (Eq a, Ix b) => a -> b -> b
+-- {-# SPECIALISE f :: Ix b => Int -> b -> b #-}
+--
+-- AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
+--
+-- SpecPrag (/\b.\(d:Ix b). f Int b dInt d)
+-- (forall b. Ix b => Int -> b -> b)
+--
+-- Rule: forall b,(d:Ix b). f Int b dInt d = f_spec b d
+--
+-- Spec bind: f_spec = Let f = /\ab \(d1:Eq a)(d2:Ix b). let binds in f_mono
+-- /\b.\(d:Ix b). in f Int b dInt d
+-- The idea is that f occurs just once, so it'll be
+-- inlined and specialised
+
+dsSpec all_tvs dicts tvs poly_id mono_id mono_bind (InlinePrag {})
+ = return Nothing
+
+dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
+ (SpecPrag spec_expr spec_ty const_dicts inl)
+ = do { let poly_name = idName poly_id
+ ; spec_name <- newLocalName poly_name
+ ; ds_spec_expr <- dsExpr spec_expr
+ ; let (bndrs, body) = collectBinders ds_spec_expr
+ mb_lhs = decomposeRuleLhs (bndrs ++ const_dicts) body
+
+ ; case mb_lhs of
+ Nothing -> do { dsWarn msg; return Nothing }
+
+ Just (bndrs', var, args) -> return (Just (addInlineInfo inl spec_id spec_rhs, rule))
+ where
+ local_poly = setIdNotExported poly_id
+ -- Very important to make the 'f' non-exported,
+ -- else it won't be inlined!
+ spec_id = mkLocalId spec_name spec_ty
+ spec_rhs = Let (NonRec local_poly poly_f_body) ds_spec_expr
+ poly_f_body = mkLams (tvs ++ dicts) $
+ fix_up (Let mono_bind (Var mono_id))
+
+ -- Quantify over constant dicts on the LHS, since
+ -- their value depends only on their type
+ -- The ones we are interested in may even be imported
+ -- e.g. GHC.Base.dEqInt
+
+ rule = mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
+ AlwaysActive poly_name
+ bndrs' -- Includes constant dicts
+ args
+ (mkVarApps (Var spec_id) bndrs)
+ }
+ where
+ -- Bind to voidTy any of all_ptvs that aren't
+ -- relevant for this particular function
+ fix_up body | null void_tvs = body
+ | otherwise = mkTyApps (mkLams void_tvs body)
+ (map (const voidTy) void_tvs)
+ void_tvs = all_tvs \\ tvs
+
+ msg = hang (ptext SLIT("Specialisation too complicated to desugar; ignored"))
+ 2 (ppr spec_expr)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Adding inline pragmas}
+%* *
+%************************************************************************
+
+\begin{code}
+decomposeRuleLhs :: [Var] -> CoreExpr -> Maybe ([Var], Id, [CoreExpr])
+-- Returns Nothing if the LHS isn't of the expected shape
+-- The argument 'all_bndrs' includes the "constant dicts" of the LHS,
+-- and they may be GlobalIds, which we can't forall-ify.
+-- So we substitute them out instead
+decomposeRuleLhs all_bndrs lhs
+ = go init_env (occurAnalyseExpr lhs) -- Occurrence analysis sorts out the dict
+ -- bindings so we know if they are recursive
+ where
+
+ -- all_bndrs may include top-level imported dicts,
+ -- imported things with a for-all.
+ -- So we localise them and subtitute them out
+ bndr_prs = [ (id, Var (localise id)) | id <- all_bndrs, isGlobalId id ]
+ localise d = mkLocalId (idName d) (idType d)
+
+ init_env = mkVarEnv bndr_prs
+ all_bndrs' = map subst_bndr all_bndrs
+ subst_bndr bndr = case lookupVarEnv init_env bndr of
+ Just (Var bndr') -> bndr'
+ Just other -> panic "decomposeRuleLhs"
+ Nothing -> bndr
+
+ -- Substitute dicts in the LHS args, so that there
+ -- aren't any lets getting in the way
+ -- Note that we substitute the function too; we might have this as
+ -- a LHS: let f71 = M.f Int in f71
+ go env (Let (NonRec dict rhs) body)
+ = go (extendVarEnv env dict (simpleSubst env rhs)) body
+ go env body
+ = case collectArgs (simpleSubst env body) of
+ (Var fn, args) -> Just (all_bndrs', fn, args)
+ other -> Nothing
+
+simpleSubst :: IdEnv CoreExpr -> CoreExpr -> CoreExpr
+-- Similar to CoreSubst.substExpr, except that
+-- (a) takes no account of capture; dictionary bindings use new names
+-- (b) can have a GlobalId (imported) in its domain
+-- (c) Ids only; no types are substituted
+
+simpleSubst subst expr
+ = go expr
+ where
+ go (Var v) = lookupVarEnv subst v `orElse` Var v
+ go (Type ty) = Type ty
+ go (Lit lit) = Lit lit
+ go (App fun arg) = App (go fun) (go arg)
+ go (Note note e) = Note note (go e)
+ go (Lam bndr body) = Lam bndr (go body)
+ go (Let (NonRec bndr rhs) body) = Let (NonRec bndr (go rhs)) (go body)
+ go (Let (Rec pairs) body) = Let (Rec (mapSnd go pairs)) (go body)
+ go (Case scrut bndr ty alts) = Case (go scrut) bndr ty
+ [(c,bs,go r) | (c,bs,r) <- alts]
+
+addLocalInlines exports core_prs
+ = map add_inline core_prs
+ where
+ add_inline (bndr,rhs) | Just inl <- lookupVarEnv inline_env bndr
+ = addInlineInfo inl bndr rhs
+ | otherwise
+ = (bndr,rhs)
+ inline_env = mkVarEnv [(mono_id, prag)
+ | (_, _, mono_id, prags) <- exports,
+ InlinePrag prag <- prags]
+
+addInlineInfo :: InlineSpec -> Id -> CoreExpr -> (Id,CoreExpr)
+addInlineInfo (Inline phase is_inline) bndr rhs
+ = (attach_phase bndr phase, wrap_inline is_inline rhs)
+ where
+ attach_phase bndr phase
+ | isAlwaysActive phase = bndr -- Default phase
+ | otherwise = bndr `setInlinePragma` phase
+
+ wrap_inline True body = mkInlineMe body
+ wrap_inline False body = body
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[addAutoScc]{Adding automatic sccs}
+%* *
+%************************************************************************
+
+\begin{code}
+data AutoScc
+ = TopLevel
+ | TopLevelAddSccs (Id -> Maybe Id)
+ | NoSccs
+
+addSccs :: AutoScc -> [(a,Id,Id,[Prag])] -> AutoScc
+addSccs auto_scc@(TopLevelAddSccs _) exports = auto_scc
+addSccs NoSccs exports = NoSccs
+addSccs TopLevel exports
+ = TopLevelAddSccs (\id -> case [ exp | (_,exp,loc,_) <- exports, loc == id ] of
+ (exp:_) | opt_AutoSccsOnAllToplevs ||
+ (isExportedId exp &&
+ opt_AutoSccsOnExportedToplevs)
+ -> Just exp
+ _ -> Nothing)
+
+addAutoScc :: AutoScc -- if needs be, decorate toplevs?
+ -> (Id, CoreExpr)
+ -> DsM (Id, CoreExpr)
+
+addAutoScc (TopLevelAddSccs auto_scc_fn) pair@(bndr, core_expr)
+ | do_auto_scc
+ = getModuleDs `thenDs` \ mod ->
+ returnDs (bndr, mkSCC (mkAutoCC top_bndr mod NotCafCC) core_expr)
+ where do_auto_scc = isJust maybe_auto_scc
+ maybe_auto_scc = auto_scc_fn bndr
+ (Just top_bndr) = maybe_auto_scc
+
+addAutoScc _ pair
+ = returnDs pair
+\end{code}
+
+If profiling and dealing with a dict binding,
+wrap the dict in @_scc_ DICT <dict>@:
+
+\begin{code}
+addDictScc var rhs = returnDs rhs
+
+{- DISABLED for now (need to somehow make up a name for the scc) -- SDM
+ | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
+ || not (isDictId var)
+ = returnDs rhs -- That's easy: do nothing
+
+ | otherwise
+ = getModuleAndGroupDs `thenDs` \ (mod, grp) ->
+ -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
+ returnDs (Note (SCC (mkAllDictsCC mod grp False)) rhs)
+-}
+\end{code}
+
+
+%************************************************************************
+%* *
+ Desugaring coercions
+%* *
+%************************************************************************
+
+
+\begin{code}
+dsCoercion :: ExprCoFn -> DsM CoreExpr -> DsM CoreExpr
+dsCoercion CoHole thing_inside = thing_inside
+dsCoercion (CoCompose c1 c2) thing_inside = dsCoercion c1 (dsCoercion c2 thing_inside)
+dsCoercion (CoLams ids c) thing_inside = do { expr <- dsCoercion c thing_inside
+ ; return (mkLams ids expr) }
+dsCoercion (CoTyLams tvs c) thing_inside = do { expr <- dsCoercion c thing_inside
+ ; return (mkLams tvs expr) }
+dsCoercion (CoApps c ids) thing_inside = do { expr <- dsCoercion c thing_inside
+ ; return (mkVarApps expr ids) }
+dsCoercion (CoTyApps c tys) thing_inside = do { expr <- dsCoercion c thing_inside
+ ; return (mkTyApps expr tys) }
+dsCoercion (CoLet bs c) thing_inside = do { prs <- dsLHsBinds bs
+ ; expr <- dsCoercion c thing_inside
+ ; return (Let (Rec prs) expr) }
+\end{code}
+
+
diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs
new file mode 100644
index 0000000000..3554197fb8
--- /dev/null
+++ b/compiler/deSugar/DsCCall.lhs
@@ -0,0 +1,456 @@
+%
+% (c) The AQUA Project, Glasgow University, 1994-1998
+%
+\section[DsCCall]{Desugaring C calls}
+
+\begin{code}
+module DsCCall
+ ( dsCCall
+ , mkFCall
+ , unboxArg
+ , boxResult
+ , resultWrapper
+ ) where
+
+#include "HsVersions.h"
+
+
+import CoreSyn
+
+import DsMonad
+
+import CoreUtils ( exprType, coreAltType, mkCoerce2 )
+import Id ( Id, mkWildId )
+import MkId ( mkFCallId, realWorldPrimId, mkPrimOpId )
+import Maybes ( maybeToBool )
+import ForeignCall ( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety,
+ CCallConv(..), CLabelString )
+import DataCon ( splitProductType_maybe, dataConSourceArity, dataConWrapId )
+
+import TcType ( tcSplitTyConApp_maybe )
+import Type ( Type, isUnLiftedType, mkFunTys, mkFunTy,
+ tyVarsOfType, mkForAllTys, mkTyConApp,
+ isPrimitiveType, splitTyConApp_maybe,
+ splitRecNewType_maybe, splitForAllTy_maybe,
+ isUnboxedTupleType
+ )
+
+import PrimOp ( PrimOp(..) )
+import TysPrim ( realWorldStatePrimTy, intPrimTy,
+ byteArrayPrimTyCon, mutableByteArrayPrimTyCon,
+ addrPrimTy
+ )
+import TyCon ( TyCon, tyConDataCons, tyConName )
+import TysWiredIn ( unitDataConId,
+ unboxedSingletonDataCon, unboxedPairDataCon,
+ unboxedSingletonTyCon, unboxedPairTyCon,
+ trueDataCon, falseDataCon,
+ trueDataConId, falseDataConId,
+ listTyCon, charTyCon, boolTy,
+ tupleTyCon, tupleCon
+ )
+import BasicTypes ( Boxity(..) )
+import Literal ( mkMachInt )
+import PrelNames ( Unique, hasKey, ioTyConKey, boolTyConKey, unitTyConKey,
+ int8TyConKey, int16TyConKey, int32TyConKey,
+ word8TyConKey, word16TyConKey, word32TyConKey
+ -- dotnet interop
+ , marshalStringName, unmarshalStringName
+ , marshalObjectName, unmarshalObjectName
+ , objectTyConName
+ )
+import VarSet ( varSetElems )
+import Constants ( wORD_SIZE)
+import Outputable
+
+#ifdef DEBUG
+import TypeRep
+#endif
+
+\end{code}
+
+Desugaring of @ccall@s consists of adding some state manipulation,
+unboxing any boxed primitive arguments and boxing the result if
+desired.
+
+The state stuff just consists of adding in
+@PrimIO (\ s -> case s of { S# s# -> ... })@ in an appropriate place.
+
+The unboxing is straightforward, as all information needed to unbox is
+available from the type. For each boxed-primitive argument, we
+transform:
+\begin{verbatim}
+ _ccall_ foo [ r, t1, ... tm ] e1 ... em
+ |
+ |
+ V
+ case e1 of { T1# x1# ->
+ ...
+ case em of { Tm# xm# -> xm#
+ ccall# foo [ r, t1#, ... tm# ] x1# ... xm#
+ } ... }
+\end{verbatim}
+
+The reboxing of a @_ccall_@ result is a bit tricker: the types don't
+contain information about the state-pairing functions so we have to
+keep a list of \tr{(type, s-p-function)} pairs. We transform as
+follows:
+\begin{verbatim}
+ ccall# foo [ r, t1#, ... tm# ] e1# ... em#
+ |
+ |
+ V
+ \ s# -> case (ccall# foo [ r, t1#, ... tm# ] s# e1# ... em#) of
+ (StateAnd<r># result# state#) -> (R# result#, realWorld#)
+\end{verbatim}
+
+\begin{code}
+dsCCall :: CLabelString -- C routine to invoke
+ -> [CoreExpr] -- Arguments (desugared)
+ -> Safety -- Safety of the call
+ -> Type -- Type of the result: IO t
+ -> DsM CoreExpr
+
+dsCCall lbl args may_gc result_ty
+ = mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) ->
+ boxResult id Nothing result_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
+ newUnique `thenDs` \ uniq ->
+ let
+ target = StaticTarget lbl
+ the_fcall = CCall (CCallSpec target CCallConv may_gc)
+ the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty
+ in
+ returnDs (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
+
+mkFCall :: Unique -> ForeignCall
+ -> [CoreExpr] -- Args
+ -> Type -- Result type
+ -> CoreExpr
+-- Construct the ccall. The only tricky bit is that the ccall Id should have
+-- no free vars, so if any of the arg tys do we must give it a polymorphic type.
+-- [I forget *why* it should have no free vars!]
+-- For example:
+-- mkCCall ... [s::StablePtr (a->b), x::Addr, c::Char]
+--
+-- Here we build a ccall thus
+-- (ccallid::(forall a b. StablePtr (a -> b) -> Addr -> Char -> IO Addr))
+-- a b s x c
+mkFCall uniq the_fcall val_args res_ty
+ = mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args
+ where
+ arg_tys = map exprType val_args
+ body_ty = (mkFunTys arg_tys res_ty)
+ tyvars = varSetElems (tyVarsOfType body_ty)
+ ty = mkForAllTys tyvars body_ty
+ the_fcall_id = mkFCallId uniq the_fcall ty
+\end{code}
+
+\begin{code}
+unboxArg :: CoreExpr -- The supplied argument
+ -> DsM (CoreExpr, -- To pass as the actual argument
+ CoreExpr -> CoreExpr -- Wrapper to unbox the arg
+ )
+-- Example: if the arg is e::Int, unboxArg will return
+-- (x#::Int#, \W. case x of I# x# -> W)
+-- where W is a CoreExpr that probably mentions x#
+
+unboxArg arg
+ -- Primtive types: nothing to unbox
+ | isPrimitiveType arg_ty
+ = returnDs (arg, \body -> body)
+
+ -- Recursive newtypes
+ | Just rep_ty <- splitRecNewType_maybe arg_ty
+ = unboxArg (mkCoerce2 rep_ty arg_ty arg)
+
+ -- Booleans
+ | Just (tc,_) <- splitTyConApp_maybe arg_ty,
+ tc `hasKey` boolTyConKey
+ = newSysLocalDs intPrimTy `thenDs` \ prim_arg ->
+ returnDs (Var prim_arg,
+ \ body -> Case (Case arg (mkWildId arg_ty) intPrimTy
+ [(DataAlt falseDataCon,[],mkIntLit 0),
+ (DataAlt trueDataCon, [],mkIntLit 1)])
+ -- In increasing tag order!
+ prim_arg
+ (exprType body)
+ [(DEFAULT,[],body)])
+
+ -- Data types with a single constructor, which has a single, primitive-typed arg
+ -- This deals with Int, Float etc; also Ptr, ForeignPtr
+ | is_product_type && data_con_arity == 1
+ = ASSERT2(isUnLiftedType data_con_arg_ty1, pprType arg_ty)
+ -- Typechecker ensures this
+ newSysLocalDs arg_ty `thenDs` \ case_bndr ->
+ newSysLocalDs data_con_arg_ty1 `thenDs` \ prim_arg ->
+ returnDs (Var prim_arg,
+ \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)]
+ )
+
+ -- Byte-arrays, both mutable and otherwise; hack warning
+ -- We're looking for values of type ByteArray, MutableByteArray
+ -- data ByteArray ix = ByteArray ix ix ByteArray#
+ -- data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s)
+ | is_product_type &&
+ data_con_arity == 3 &&
+ maybeToBool maybe_arg3_tycon &&
+ (arg3_tycon == byteArrayPrimTyCon ||
+ arg3_tycon == mutableByteArrayPrimTyCon)
+ = newSysLocalDs arg_ty `thenDs` \ case_bndr ->
+ newSysLocalsDs data_con_arg_tys `thenDs` \ vars@[l_var, r_var, arr_cts_var] ->
+ returnDs (Var arr_cts_var,
+ \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)]
+
+ )
+
+ | Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty,
+ tc == listTyCon,
+ Just (cc,[]) <- splitTyConApp_maybe arg_ty,
+ cc == charTyCon
+ -- String; dotnet only
+ = dsLookupGlobalId marshalStringName `thenDs` \ unpack_id ->
+ newSysLocalDs addrPrimTy `thenDs` \ prim_string ->
+ returnDs (Var prim_string,
+ \ body ->
+ let
+ io_ty = exprType body
+ (Just (_,[io_arg])) = tcSplitTyConApp_maybe io_ty
+ in
+ mkApps (Var unpack_id)
+ [ Type io_arg
+ , arg
+ , Lam prim_string body
+ ])
+ | Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty,
+ tyConName tc == objectTyConName
+ -- Object; dotnet only
+ = dsLookupGlobalId marshalObjectName `thenDs` \ unpack_id ->
+ newSysLocalDs addrPrimTy `thenDs` \ prim_obj ->
+ returnDs (Var prim_obj,
+ \ body ->
+ let
+ io_ty = exprType body
+ (Just (_,[io_arg])) = tcSplitTyConApp_maybe io_ty
+ in
+ mkApps (Var unpack_id)
+ [ Type io_arg
+ , arg
+ , Lam prim_obj body
+ ])
+
+ | otherwise
+ = getSrcSpanDs `thenDs` \ l ->
+ pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
+ where
+ arg_ty = exprType arg
+ maybe_product_type = splitProductType_maybe arg_ty
+ is_product_type = maybeToBool maybe_product_type
+ Just (_, _, data_con, data_con_arg_tys) = maybe_product_type
+ data_con_arity = dataConSourceArity data_con
+ (data_con_arg_ty1 : _) = data_con_arg_tys
+
+ (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys
+ maybe_arg3_tycon = splitTyConApp_maybe data_con_arg_ty3
+ Just (arg3_tycon,_) = maybe_arg3_tycon
+\end{code}
+
+
+\begin{code}
+boxResult :: ((Maybe Type, CoreExpr -> CoreExpr) -> (Maybe Type, CoreExpr -> CoreExpr))
+ -> Maybe Id
+ -> Type
+ -> DsM (Type, CoreExpr -> CoreExpr)
+
+-- Takes the result of the user-level ccall:
+-- either (IO t),
+-- or maybe just t for an side-effect-free call
+-- Returns a wrapper for the primitive ccall itself, along with the
+-- type of the result of the primitive ccall. This result type
+-- will be of the form
+-- State# RealWorld -> (# State# RealWorld, t' #)
+-- where t' is the unwrapped form of t. If t is simply (), then
+-- the result type will be
+-- State# RealWorld -> (# State# RealWorld #)
+
+boxResult augment mbTopCon result_ty
+ = case tcSplitTyConApp_maybe result_ty of
+ -- This split absolutely has to be a tcSplit, because we must
+ -- see the IO type; and it's a newtype which is transparent to splitTyConApp.
+
+ -- The result is IO t, so wrap the result in an IO constructor
+ Just (io_tycon, [io_res_ty]) | io_tycon `hasKey` ioTyConKey
+ -> resultWrapper io_res_ty `thenDs` \ res ->
+ let aug_res = augment res
+ extra_result_tys =
+ case aug_res of
+ (Just ty,_)
+ | isUnboxedTupleType ty ->
+ let (Just (_, ls)) = splitTyConApp_maybe ty in tail ls
+ _ -> []
+ in
+ mk_alt (return_result extra_result_tys) aug_res
+ `thenDs` \ (ccall_res_ty, the_alt) ->
+ newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
+ let
+ io_data_con = head (tyConDataCons io_tycon)
+ toIOCon =
+ case mbTopCon of
+ Nothing -> dataConWrapId io_data_con
+ Just x -> x
+ wrap = \ the_call ->
+ mkApps (Var toIOCon)
+ [ Type io_res_ty,
+ Lam state_id $
+ Case (App the_call (Var state_id))
+ (mkWildId ccall_res_ty)
+ (coreAltType the_alt)
+ [the_alt]
+ ]
+ in
+ returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
+ where
+ return_result ts state anss
+ = mkConApp (tupleCon Unboxed (2 + length ts))
+ (Type realWorldStatePrimTy : Type io_res_ty : map Type ts ++
+ state : anss)
+ -- It isn't, so do unsafePerformIO
+ -- It's not conveniently available, so we inline it
+ other -> resultWrapper result_ty `thenDs` \ res ->
+ mk_alt return_result (augment res) `thenDs` \ (ccall_res_ty, the_alt) ->
+ let
+ wrap = \ the_call -> Case (App the_call (Var realWorldPrimId))
+ (mkWildId ccall_res_ty)
+ (coreAltType the_alt)
+ [the_alt]
+ in
+ returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
+ where
+ return_result state [ans] = ans
+ return_result _ _ = panic "return_result: expected single result"
+ where
+ mk_alt return_result (Nothing, wrap_result)
+ = -- The ccall returns ()
+ newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
+ let
+ the_rhs = return_result (Var state_id)
+ [wrap_result (panic "boxResult")]
+
+ ccall_res_ty = mkTyConApp unboxedSingletonTyCon [realWorldStatePrimTy]
+ the_alt = (DataAlt unboxedSingletonDataCon, [state_id], the_rhs)
+ in
+ returnDs (ccall_res_ty, the_alt)
+
+ mk_alt return_result (Just prim_res_ty, wrap_result)
+ -- The ccall returns a non-() value
+ | isUnboxedTupleType prim_res_ty
+ = let
+ Just (_, ls) = splitTyConApp_maybe prim_res_ty
+ arity = 1 + length ls
+ in
+ mappM newSysLocalDs ls `thenDs` \ args_ids@(result_id:as) ->
+ newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
+ let
+ the_rhs = return_result (Var state_id)
+ (wrap_result (Var result_id) : map Var as)
+ ccall_res_ty = mkTyConApp (tupleTyCon Unboxed arity)
+ (realWorldStatePrimTy : ls)
+ the_alt = ( DataAlt (tupleCon Unboxed arity)
+ , (state_id : args_ids)
+ , the_rhs
+ )
+ in
+ returnDs (ccall_res_ty, the_alt)
+ | otherwise
+ = newSysLocalDs prim_res_ty `thenDs` \ result_id ->
+ newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
+ let
+ the_rhs = return_result (Var state_id)
+ [wrap_result (Var result_id)]
+
+ ccall_res_ty = mkTyConApp unboxedPairTyCon [realWorldStatePrimTy, prim_res_ty]
+ the_alt = (DataAlt unboxedPairDataCon, [state_id, result_id], the_rhs)
+ in
+ returnDs (ccall_res_ty, the_alt)
+
+
+resultWrapper :: Type
+ -> DsM (Maybe Type, -- Type of the expected result, if any
+ CoreExpr -> CoreExpr) -- Wrapper for the result
+resultWrapper result_ty
+ -- Base case 1: primitive types
+ | isPrimitiveType result_ty
+ = returnDs (Just result_ty, \e -> e)
+
+ -- Base case 2: the unit type ()
+ | Just (tc,_) <- maybe_tc_app, tc `hasKey` unitTyConKey
+ = returnDs (Nothing, \e -> Var unitDataConId)
+
+ -- Base case 3: the boolean type
+ | Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey
+ = returnDs
+ (Just intPrimTy, \e -> Case e (mkWildId intPrimTy)
+ boolTy
+ [(DEFAULT ,[],Var trueDataConId ),
+ (LitAlt (mkMachInt 0),[],Var falseDataConId)])
+
+ -- Recursive newtypes
+ | Just rep_ty <- splitRecNewType_maybe result_ty
+ = resultWrapper rep_ty `thenDs` \ (maybe_ty, wrapper) ->
+ returnDs (maybe_ty, \e -> mkCoerce2 result_ty rep_ty (wrapper e))
+
+ -- The type might contain foralls (eg. for dummy type arguments,
+ -- referring to 'Ptr a' is legal).
+ | Just (tyvar, rest) <- splitForAllTy_maybe result_ty
+ = resultWrapper rest `thenDs` \ (maybe_ty, wrapper) ->
+ returnDs (maybe_ty, \e -> Lam tyvar (wrapper e))
+
+ -- Data types with a single constructor, which has a single arg
+ -- This includes types like Ptr and ForeignPtr
+ | Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitProductType_maybe result_ty,
+ dataConSourceArity data_con == 1
+ = let
+ (unwrapped_res_ty : _) = data_con_arg_tys
+ narrow_wrapper = maybeNarrow tycon
+ in
+ resultWrapper unwrapped_res_ty `thenDs` \ (maybe_ty, wrapper) ->
+ returnDs
+ (maybe_ty, \e -> mkApps (Var (dataConWrapId data_con))
+ (map Type tycon_arg_tys ++ [wrapper (narrow_wrapper e)]))
+
+ -- Strings; 'dotnet' only.
+ | Just (tc, [arg_ty]) <- maybe_tc_app, tc == listTyCon,
+ Just (cc,[]) <- splitTyConApp_maybe arg_ty, cc == charTyCon
+ = dsLookupGlobalId unmarshalStringName `thenDs` \ pack_id ->
+ returnDs (Just addrPrimTy,
+ \ e -> App (Var pack_id) e)
+
+ -- Objects; 'dotnet' only.
+ | Just (tc, [arg_ty]) <- maybe_tc_app,
+ tyConName tc == objectTyConName
+ = dsLookupGlobalId unmarshalObjectName `thenDs` \ pack_id ->
+ returnDs (Just addrPrimTy,
+ \ e -> App (Var pack_id) e)
+
+ | otherwise
+ = pprPanic "resultWrapper" (ppr result_ty)
+ where
+ maybe_tc_app = splitTyConApp_maybe result_ty
+
+-- When the result of a foreign call is smaller than the word size, we
+-- need to sign- or zero-extend the result up to the word size. The C
+-- standard appears to say that this is the responsibility of the
+-- caller, not the callee.
+
+maybeNarrow :: TyCon -> (CoreExpr -> CoreExpr)
+maybeNarrow tycon
+ | tycon `hasKey` int8TyConKey = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e
+ | tycon `hasKey` int16TyConKey = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e
+ | tycon `hasKey` int32TyConKey
+ && wORD_SIZE > 4 = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e
+
+ | tycon `hasKey` word8TyConKey = \e -> App (Var (mkPrimOpId Narrow8WordOp)) e
+ | tycon `hasKey` word16TyConKey = \e -> App (Var (mkPrimOpId Narrow16WordOp)) e
+ | tycon `hasKey` word32TyConKey
+ && wORD_SIZE > 4 = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e
+ | otherwise = id
+\end{code}
diff --git a/compiler/deSugar/DsExpr.hi-boot-5 b/compiler/deSugar/DsExpr.hi-boot-5
new file mode 100644
index 0000000000..7e5bbaab7f
--- /dev/null
+++ b/compiler/deSugar/DsExpr.hi-boot-5
@@ -0,0 +1,5 @@
+__interface DsExpr 1 0 where
+__export DsExpr dsExpr dsLet;
+1 dsExpr :: HsExpr.HsExpr Var.Id -> DsMonad.DsM CoreSyn.CoreExpr ;
+1 dsLExpr :: HsExpr.HsLExpr Var.Id -> DsMonad.DsM CoreSyn.CoreExpr ;
+1 dsLet :: [HsBinds.HsBindGroup Var.Id] -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr ;
diff --git a/compiler/deSugar/DsExpr.hi-boot-6 b/compiler/deSugar/DsExpr.hi-boot-6
new file mode 100644
index 0000000000..c7ddb2ddfd
--- /dev/null
+++ b/compiler/deSugar/DsExpr.hi-boot-6
@@ -0,0 +1,6 @@
+module DsExpr where
+
+dsExpr :: HsExpr.HsExpr Var.Id -> DsMonad.DsM CoreSyn.CoreExpr
+dsLExpr :: HsExpr.LHsExpr Var.Id -> DsMonad.DsM CoreSyn.CoreExpr
+dsLocalBinds :: HsBinds.HsLocalBinds Var.Id -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr
+dsValBinds :: HsBinds.HsValBinds Var.Id -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
new file mode 100644
index 0000000000..e8e9e7b370
--- /dev/null
+++ b/compiler/deSugar/DsExpr.lhs
@@ -0,0 +1,781 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[DsExpr]{Matching expressions (Exprs)}
+
+\begin{code}
+module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where
+
+#include "HsVersions.h"
+#if defined(GHCI) && defined(BREAKPOINT)
+import Foreign.StablePtr ( newStablePtr, castStablePtrToPtr )
+import GHC.Exts ( Ptr(..), Int(..), addr2Int# )
+import IOEnv ( ioToIOEnv )
+import PrelNames ( breakpointJumpName )
+import TysWiredIn ( unitTy )
+import TypeRep ( Type(..) )
+#endif
+
+import Match ( matchWrapper, matchSinglePat, matchEquations )
+import MatchLit ( dsLit, dsOverLit )
+import DsBinds ( dsLHsBinds, dsCoercion )
+import DsGRHSs ( dsGuarded )
+import DsListComp ( dsListComp, dsPArrComp )
+import DsUtils ( mkErrorAppDs, mkStringExpr, mkConsExpr, mkNilExpr,
+ extractMatchResult, cantFailMatchResult, matchCanFail,
+ mkCoreTupTy, selectSimpleMatchVarL, lookupEvidence, selectMatchVar )
+import DsArrows ( dsProcExpr )
+import DsMonad
+
+#ifdef GHCI
+ -- Template Haskell stuff iff bootstrapped
+import DsMeta ( dsBracket )
+#endif
+
+import HsSyn
+import TcHsSyn ( hsPatType, mkVanillaTuplePat )
+
+-- NB: The desugarer, which straddles the source and Core worlds, sometimes
+-- needs to see source types (newtypes etc), and sometimes not
+-- So WATCH OUT; check each use of split*Ty functions.
+-- Sigh. This is a pain.
+
+import TcType ( tcSplitAppTy, tcSplitFunTys, tcTyConAppTyCon,
+ tcTyConAppArgs, isUnLiftedType, Type, mkAppTy )
+import Type ( funArgTy, splitFunTys, isUnboxedTupleType, mkFunTy )
+import CoreSyn
+import CoreUtils ( exprType, mkIfThenElse, bindNonRec )
+
+import CostCentre ( mkUserCC )
+import Id ( Id, idType, idName, idDataCon )
+import PrelInfo ( rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID )
+import DataCon ( DataCon, dataConWrapId, dataConFieldLabels, dataConInstOrigArgTys )
+import DataCon ( isVanillaDataCon )
+import TyCon ( FieldLabel, tyConDataCons )
+import TysWiredIn ( tupleCon )
+import BasicTypes ( RecFlag(..), Boxity(..), ipNameName )
+import PrelNames ( toPName,
+ returnMName, bindMName, thenMName, failMName,
+ mfixName )
+import SrcLoc ( Located(..), unLoc, getLoc, noLoc )
+import Util ( zipEqual, zipWithEqual )
+import Bag ( bagToList )
+import Outputable
+import FastString
+\end{code}
+
+
+%************************************************************************
+%* *
+ dsLocalBinds, dsValBinds
+%* *
+%************************************************************************
+
+\begin{code}
+dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr
+dsLocalBinds EmptyLocalBinds body = return body
+dsLocalBinds (HsValBinds binds) body = dsValBinds binds body
+dsLocalBinds (HsIPBinds binds) body = dsIPBinds binds body
+
+-------------------------
+dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
+dsValBinds (ValBindsOut binds _) body = foldrDs ds_val_bind body binds
+
+-------------------------
+dsIPBinds (IPBinds ip_binds dict_binds) body
+ = do { prs <- dsLHsBinds dict_binds
+ ; let inner = foldr (\(x,r) e -> Let (NonRec x r) e) body prs
+ ; foldrDs ds_ip_bind inner ip_binds }
+ where
+ ds_ip_bind (L _ (IPBind n e)) body
+ = dsLExpr e `thenDs` \ e' ->
+ returnDs (Let (NonRec (ipNameName n) e') body)
+
+-------------------------
+ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
+-- Special case for bindings which bind unlifted variables
+-- We need to do a case right away, rather than building
+-- a tuple and doing selections.
+-- Silently ignore INLINE and SPECIALISE pragmas...
+ds_val_bind (NonRecursive, hsbinds) body
+ | [L _ (AbsBinds [] [] exports binds)] <- bagToList hsbinds,
+ (L loc bind : null_binds) <- bagToList binds,
+ isBangHsBind bind
+ || isUnboxedTupleBind bind
+ || or [isUnLiftedType (idType g) | (_, g, _, _) <- exports]
+ = let
+ body_w_exports = foldr bind_export body exports
+ bind_export (tvs, g, l, _) body = ASSERT( null tvs )
+ bindNonRec g (Var l) body
+ in
+ ASSERT (null null_binds)
+ -- Non-recursive, non-overloaded bindings only come in ones
+ -- ToDo: in some bizarre case it's conceivable that there
+ -- could be dict binds in the 'binds'. (See the notes
+ -- below. Then pattern-match would fail. Urk.)
+ putSrcSpanDs loc $
+ case bind of
+ FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn }
+ -> matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, rhs) ->
+ ASSERT( null args ) -- Functions aren't lifted
+ ASSERT( isIdCoercion co_fn )
+ returnDs (bindNonRec fun rhs body_w_exports)
+
+ PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }
+ -> -- let C x# y# = rhs in body
+ -- ==> case rhs of C x# y# -> body
+ putSrcSpanDs loc $
+ do { rhs <- dsGuarded grhss ty
+ ; let upat = unLoc pat
+ eqn = EqnInfo { eqn_wrap = idWrapper, eqn_pats = [upat],
+ eqn_rhs = cantFailMatchResult body_w_exports }
+ ; var <- selectMatchVar upat ty
+ ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
+ ; return (scrungleMatch var rhs result) }
+
+ other -> pprPanic "dsLet: unlifted" (pprLHsBinds hsbinds $$ ppr body)
+
+
+-- Ordinary case for bindings; none should be unlifted
+ds_val_bind (is_rec, binds) body
+ = do { prs <- dsLHsBinds binds
+ ; ASSERT( not (any (isUnLiftedType . idType . fst) prs) )
+ case prs of
+ [] -> return body
+ other -> return (Let (Rec prs) body) }
+ -- Use a Rec regardless of is_rec.
+ -- Why? Because it allows the binds to be all
+ -- mixed up, which is what happens in one rare case
+ -- Namely, for an AbsBind with no tyvars and no dicts,
+ -- but which does have dictionary bindings.
+ -- See notes with TcSimplify.inferLoop [NO TYVARS]
+ -- It turned out that wrapping a Rec here was the easiest solution
+ --
+ -- NB The previous case dealt with unlifted bindings, so we
+ -- only have to deal with lifted ones now; so Rec is ok
+
+isUnboxedTupleBind :: HsBind Id -> Bool
+isUnboxedTupleBind (PatBind { pat_rhs_ty = ty }) = isUnboxedTupleType ty
+isUnboxedTupleBind other = False
+
+scrungleMatch :: Id -> CoreExpr -> CoreExpr -> CoreExpr
+-- Returns something like (let var = scrut in body)
+-- but if var is an unboxed-tuple type, it inlines it in a fragile way
+-- Special case to handle unboxed tuple patterns; they can't appear nested
+-- The idea is that
+-- case e of (# p1, p2 #) -> rhs
+-- should desugar to
+-- case e of (# x1, x2 #) -> ... match p1, p2 ...
+-- NOT
+-- let x = e in case x of ....
+--
+-- But there may be a big
+-- let fail = ... in case e of ...
+-- wrapping the whole case, which complicates matters slightly
+-- It all seems a bit fragile. Test is dsrun013.
+
+scrungleMatch var scrut body
+ | isUnboxedTupleType (idType var) = scrungle body
+ | otherwise = bindNonRec var scrut body
+ where
+ scrungle (Case (Var x) bndr ty alts)
+ | x == var = Case scrut bndr ty alts
+ scrungle (Let binds body) = Let binds (scrungle body)
+ scrungle other = panic ("scrungleMatch: tuple pattern:\n" ++ showSDoc (ppr other))
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
+%* *
+%************************************************************************
+
+\begin{code}
+dsLExpr :: LHsExpr Id -> DsM CoreExpr
+dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
+
+dsExpr :: HsExpr Id -> DsM CoreExpr
+
+dsExpr (HsPar e) = dsLExpr e
+dsExpr (ExprWithTySigOut e _) = dsLExpr e
+dsExpr (HsVar var) = returnDs (Var var)
+dsExpr (HsIPVar ip) = returnDs (Var (ipNameName ip))
+dsExpr (HsLit lit) = dsLit lit
+dsExpr (HsOverLit lit) = dsOverLit lit
+
+dsExpr (NegApp expr neg_expr)
+ = do { core_expr <- dsLExpr expr
+ ; core_neg <- dsExpr neg_expr
+ ; return (core_neg `App` core_expr) }
+
+dsExpr expr@(HsLam a_Match)
+ = matchWrapper LambdaExpr a_Match `thenDs` \ (binders, matching_code) ->
+ returnDs (mkLams binders matching_code)
+
+#if defined(GHCI) && defined(BREAKPOINT)
+dsExpr (HsApp (L _ (HsApp realFun@(L _ (HsCoerce _ fun)) (L loc arg))) _)
+ | HsVar funId <- fun
+ , idName funId == breakpointJumpName
+ , ids <- filter (not.hasTyVar.idType) (extractIds arg)
+ = do dsWarn (text "Extracted ids:" <+> ppr ids <+> ppr (map idType ids))
+ stablePtr <- ioToIOEnv $ newStablePtr ids
+ -- Yes, I know... I'm gonna burn in hell.
+ let Ptr addr# = castStablePtrToPtr stablePtr
+ funCore <- dsLExpr realFun
+ argCore <- dsLExpr (L loc (HsLit (HsInt (fromIntegral (I# (addr2Int# addr#))))))
+ hvalCore <- dsLExpr (L loc (extractHVals ids))
+ return ((funCore `App` argCore) `App` hvalCore)
+ where extractIds :: HsExpr Id -> [Id]
+ extractIds (HsApp fn arg)
+ | HsVar argId <- unLoc arg
+ = argId:extractIds (unLoc fn)
+ | TyApp arg' ts <- unLoc arg
+ , HsVar argId <- unLoc arg'
+ = error (showSDoc (ppr ts)) -- argId:extractIds (unLoc fn)
+ extractIds x = []
+ extractHVals ids = ExplicitList unitTy (map (L loc . HsVar) ids)
+ hasTyVar (TyVarTy _) = True
+ hasTyVar (FunTy a b) = hasTyVar a || hasTyVar b
+ hasTyVar (NoteTy _ t) = hasTyVar t
+ hasTyVar (AppTy a b) = hasTyVar a || hasTyVar b
+ hasTyVar (TyConApp _ ts) = any hasTyVar ts
+ hasTyVar _ = False
+#endif
+
+dsExpr expr@(HsApp fun arg)
+ = dsLExpr fun `thenDs` \ core_fun ->
+ dsLExpr arg `thenDs` \ core_arg ->
+ returnDs (core_fun `App` core_arg)
+\end{code}
+
+Operator sections. At first it looks as if we can convert
+\begin{verbatim}
+ (expr op)
+\end{verbatim}
+to
+\begin{verbatim}
+ \x -> op expr x
+\end{verbatim}
+
+But no! expr might be a redex, and we can lose laziness badly this
+way. Consider
+\begin{verbatim}
+ map (expr op) xs
+\end{verbatim}
+for example. So we convert instead to
+\begin{verbatim}
+ let y = expr in \x -> op y x
+\end{verbatim}
+If \tr{expr} is actually just a variable, say, then the simplifier
+will sort it out.
+
+\begin{code}
+dsExpr (OpApp e1 op _ e2)
+ = dsLExpr op `thenDs` \ core_op ->
+ -- for the type of y, we need the type of op's 2nd argument
+ dsLExpr e1 `thenDs` \ x_core ->
+ dsLExpr e2 `thenDs` \ y_core ->
+ returnDs (mkApps core_op [x_core, y_core])
+
+dsExpr (SectionL expr op)
+ = dsLExpr op `thenDs` \ core_op ->
+ -- for the type of y, we need the type of op's 2nd argument
+ let
+ (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
+ -- Must look through an implicit-parameter type;
+ -- newtype impossible; hence Type.splitFunTys
+ in
+ dsLExpr expr `thenDs` \ x_core ->
+ newSysLocalDs x_ty `thenDs` \ x_id ->
+ newSysLocalDs y_ty `thenDs` \ y_id ->
+
+ returnDs (bindNonRec x_id x_core $
+ Lam y_id (mkApps core_op [Var x_id, Var y_id]))
+
+-- dsLExpr (SectionR op expr) -- \ x -> op x expr
+dsExpr (SectionR op expr)
+ = dsLExpr op `thenDs` \ core_op ->
+ -- for the type of x, we need the type of op's 2nd argument
+ let
+ (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
+ -- See comment with SectionL
+ in
+ dsLExpr expr `thenDs` \ y_core ->
+ newSysLocalDs x_ty `thenDs` \ x_id ->
+ newSysLocalDs y_ty `thenDs` \ y_id ->
+
+ returnDs (bindNonRec y_id y_core $
+ Lam x_id (mkApps core_op [Var x_id, Var y_id]))
+
+dsExpr (HsSCC cc expr)
+ = dsLExpr expr `thenDs` \ core_expr ->
+ getModuleDs `thenDs` \ mod_name ->
+ returnDs (Note (SCC (mkUserCC cc mod_name)) core_expr)
+
+
+-- hdaume: core annotation
+
+dsExpr (HsCoreAnn fs expr)
+ = dsLExpr expr `thenDs` \ core_expr ->
+ returnDs (Note (CoreNote $ unpackFS fs) core_expr)
+
+dsExpr (HsCase discrim matches)
+ = dsLExpr discrim `thenDs` \ core_discrim ->
+ matchWrapper CaseAlt matches `thenDs` \ ([discrim_var], matching_code) ->
+ returnDs (scrungleMatch discrim_var core_discrim matching_code)
+
+dsExpr (HsLet binds body)
+ = dsLExpr body `thenDs` \ body' ->
+ dsLocalBinds binds body'
+
+-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
+-- because the interpretation of `stmts' depends on what sort of thing it is.
+--
+dsExpr (HsDo ListComp stmts body result_ty)
+ = -- Special case for list comprehensions
+ dsListComp stmts body elt_ty
+ where
+ [elt_ty] = tcTyConAppArgs result_ty
+
+dsExpr (HsDo DoExpr stmts body result_ty)
+ = dsDo stmts body result_ty
+
+dsExpr (HsDo (MDoExpr tbl) stmts body result_ty)
+ = dsMDo tbl stmts body result_ty
+
+dsExpr (HsDo PArrComp stmts body result_ty)
+ = -- Special case for array comprehensions
+ dsPArrComp (map unLoc stmts) body elt_ty
+ where
+ [elt_ty] = tcTyConAppArgs result_ty
+
+dsExpr (HsIf guard_expr then_expr else_expr)
+ = dsLExpr guard_expr `thenDs` \ core_guard ->
+ dsLExpr then_expr `thenDs` \ core_then ->
+ dsLExpr else_expr `thenDs` \ core_else ->
+ returnDs (mkIfThenElse core_guard core_then core_else)
+\end{code}
+
+
+\noindent
+\underline{\bf Type lambda and application}
+% ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+dsExpr (TyLam tyvars expr)
+ = dsLExpr expr `thenDs` \ core_expr ->
+ returnDs (mkLams tyvars core_expr)
+
+dsExpr (TyApp expr tys)
+ = dsLExpr expr `thenDs` \ core_expr ->
+ returnDs (mkTyApps core_expr tys)
+\end{code}
+
+
+\noindent
+\underline{\bf Various data construction things}
+% ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+dsExpr (ExplicitList ty xs)
+ = go xs
+ where
+ go [] = returnDs (mkNilExpr ty)
+ go (x:xs) = dsLExpr x `thenDs` \ core_x ->
+ go xs `thenDs` \ core_xs ->
+ returnDs (mkConsExpr ty core_x core_xs)
+
+-- we create a list from the array elements and convert them into a list using
+-- `PrelPArr.toP'
+--
+-- * the main disadvantage to this scheme is that `toP' traverses the list
+-- twice: once to determine the length and a second time to put to elements
+-- into the array; this inefficiency could be avoided by exposing some of
+-- the innards of `PrelPArr' to the compiler (ie, have a `PrelPArrBase') so
+-- that we can exploit the fact that we already know the length of the array
+-- here at compile time
+--
+dsExpr (ExplicitPArr ty xs)
+ = dsLookupGlobalId toPName `thenDs` \toP ->
+ dsExpr (ExplicitList ty xs) `thenDs` \coreList ->
+ returnDs (mkApps (Var toP) [Type ty, coreList])
+
+dsExpr (ExplicitTuple expr_list boxity)
+ = mappM dsLExpr expr_list `thenDs` \ core_exprs ->
+ returnDs (mkConApp (tupleCon boxity (length expr_list))
+ (map (Type . exprType) core_exprs ++ core_exprs))
+
+dsExpr (ArithSeq expr (From from))
+ = dsExpr expr `thenDs` \ expr2 ->
+ dsLExpr from `thenDs` \ from2 ->
+ returnDs (App expr2 from2)
+
+dsExpr (ArithSeq expr (FromTo from two))
+ = dsExpr expr `thenDs` \ expr2 ->
+ dsLExpr from `thenDs` \ from2 ->
+ dsLExpr two `thenDs` \ two2 ->
+ returnDs (mkApps expr2 [from2, two2])
+
+dsExpr (ArithSeq expr (FromThen from thn))
+ = dsExpr expr `thenDs` \ expr2 ->
+ dsLExpr from `thenDs` \ from2 ->
+ dsLExpr thn `thenDs` \ thn2 ->
+ returnDs (mkApps expr2 [from2, thn2])
+
+dsExpr (ArithSeq expr (FromThenTo from thn two))
+ = dsExpr expr `thenDs` \ expr2 ->
+ dsLExpr from `thenDs` \ from2 ->
+ dsLExpr thn `thenDs` \ thn2 ->
+ dsLExpr two `thenDs` \ two2 ->
+ returnDs (mkApps expr2 [from2, thn2, two2])
+
+dsExpr (PArrSeq expr (FromTo from two))
+ = dsExpr expr `thenDs` \ expr2 ->
+ dsLExpr from `thenDs` \ from2 ->
+ dsLExpr two `thenDs` \ two2 ->
+ returnDs (mkApps expr2 [from2, two2])
+
+dsExpr (PArrSeq expr (FromThenTo from thn two))
+ = dsExpr expr `thenDs` \ expr2 ->
+ dsLExpr from `thenDs` \ from2 ->
+ dsLExpr thn `thenDs` \ thn2 ->
+ dsLExpr two `thenDs` \ two2 ->
+ returnDs (mkApps expr2 [from2, thn2, two2])
+
+dsExpr (PArrSeq expr _)
+ = panic "DsExpr.dsExpr: Infinite parallel array!"
+ -- the parser shouldn't have generated it and the renamer and typechecker
+ -- shouldn't have let it through
+\end{code}
+
+\noindent
+\underline{\bf Record construction and update}
+% ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For record construction we do this (assuming T has three arguments)
+\begin{verbatim}
+ T { op2 = e }
+==>
+ let err = /\a -> recConErr a
+ T (recConErr t1 "M.lhs/230/op1")
+ e
+ (recConErr t1 "M.lhs/230/op3")
+\end{verbatim}
+@recConErr@ then converts its arugment string into a proper message
+before printing it as
+\begin{verbatim}
+ M.lhs, line 230: missing field op1 was evaluated
+\end{verbatim}
+
+We also handle @C{}@ as valid construction syntax for an unlabelled
+constructor @C@, setting all of @C@'s fields to bottom.
+
+\begin{code}
+dsExpr (RecordCon (L _ data_con_id) con_expr rbinds)
+ = dsExpr con_expr `thenDs` \ con_expr' ->
+ let
+ (arg_tys, _) = tcSplitFunTys (exprType con_expr')
+ -- A newtype in the corner should be opaque;
+ -- hence TcType.tcSplitFunTys
+
+ mk_arg (arg_ty, lbl) -- Selector id has the field label as its name
+ = case [rhs | (L _ sel_id, rhs) <- rbinds, lbl == idName sel_id] of
+ (rhs:rhss) -> ASSERT( null rhss )
+ dsLExpr rhs
+ [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showSDoc (ppr lbl))
+ unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty ""
+
+ labels = dataConFieldLabels (idDataCon data_con_id)
+ -- The data_con_id is guaranteed to be the wrapper id of the constructor
+ in
+
+ (if null labels
+ then mappM unlabelled_bottom arg_tys
+ else mappM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels))
+ `thenDs` \ con_args ->
+
+ returnDs (mkApps con_expr' con_args)
+\end{code}
+
+Record update is a little harder. Suppose we have the decl:
+\begin{verbatim}
+ data T = T1 {op1, op2, op3 :: Int}
+ | T2 {op4, op2 :: Int}
+ | T3
+\end{verbatim}
+Then we translate as follows:
+\begin{verbatim}
+ r { op2 = e }
+===>
+ let op2 = e in
+ case r of
+ T1 op1 _ op3 -> T1 op1 op2 op3
+ T2 op4 _ -> T2 op4 op2
+ other -> recUpdError "M.lhs/230"
+\end{verbatim}
+It's important that we use the constructor Ids for @T1@, @T2@ etc on the
+RHSs, and do not generate a Core constructor application directly, because the constructor
+might do some argument-evaluation first; and may have to throw away some
+dictionaries.
+
+\begin{code}
+dsExpr (RecordUpd record_expr [] record_in_ty record_out_ty)
+ = dsLExpr record_expr
+
+dsExpr expr@(RecordUpd record_expr rbinds record_in_ty record_out_ty)
+ = dsLExpr record_expr `thenDs` \ record_expr' ->
+
+ -- Desugar the rbinds, and generate let-bindings if
+ -- necessary so that we don't lose sharing
+
+ let
+ in_inst_tys = tcTyConAppArgs record_in_ty -- Newtype opaque
+ out_inst_tys = tcTyConAppArgs record_out_ty -- Newtype opaque
+ in_out_ty = mkFunTy record_in_ty record_out_ty
+
+ mk_val_arg field old_arg_id
+ = case [rhs | (L _ sel_id, rhs) <- rbinds, field == idName sel_id] of
+ (rhs:rest) -> ASSERT(null rest) rhs
+ [] -> nlHsVar old_arg_id
+
+ mk_alt con
+ = newSysLocalsDs (dataConInstOrigArgTys con in_inst_tys) `thenDs` \ arg_ids ->
+ -- This call to dataConInstOrigArgTys won't work for existentials
+ -- but existentials don't have record types anyway
+ let
+ val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
+ (dataConFieldLabels con) arg_ids
+ rhs = foldl (\a b -> nlHsApp a b)
+ (noLoc $ TyApp (nlHsVar (dataConWrapId con))
+ out_inst_tys)
+ val_args
+ in
+ returnDs (mkSimpleMatch [noLoc $ ConPatOut (noLoc con) [] [] emptyLHsBinds
+ (PrefixCon (map nlVarPat arg_ids)) record_in_ty]
+ rhs)
+ in
+ -- Record stuff doesn't work for existentials
+ -- The type checker checks for this, but we need
+ -- worry only about the constructors that are to be updated
+ ASSERT2( all isVanillaDataCon cons_to_upd, ppr expr )
+
+ -- It's important to generate the match with matchWrapper,
+ -- and the right hand sides with applications of the wrapper Id
+ -- so that everything works when we are doing fancy unboxing on the
+ -- constructor aguments.
+ mappM mk_alt cons_to_upd `thenDs` \ alts ->
+ matchWrapper RecUpd (MatchGroup alts in_out_ty) `thenDs` \ ([discrim_var], matching_code) ->
+
+ returnDs (bindNonRec discrim_var record_expr' matching_code)
+
+ where
+ updated_fields :: [FieldLabel]
+ updated_fields = [ idName sel_id | (L _ sel_id,_) <- rbinds]
+
+ -- Get the type constructor from the record_in_ty
+ -- so that we are sure it'll have all its DataCons
+ -- (In GHCI, it's possible that some TyCons may not have all
+ -- their constructors, in a module-loop situation.)
+ tycon = tcTyConAppTyCon record_in_ty
+ data_cons = tyConDataCons tycon
+ cons_to_upd = filter has_all_fields data_cons
+
+ has_all_fields :: DataCon -> Bool
+ has_all_fields con_id
+ = all (`elem` con_fields) updated_fields
+ where
+ con_fields = dataConFieldLabels con_id
+\end{code}
+
+
+\noindent
+\underline{\bf Dictionary lambda and application}
+% ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+@DictLam@ and @DictApp@ turn into the regular old things.
+(OLD:) @DictFunApp@ also becomes a curried application, albeit slightly more
+complicated; reminiscent of fully-applied constructors.
+\begin{code}
+dsExpr (DictLam dictvars expr)
+ = dsLExpr expr `thenDs` \ core_expr ->
+ returnDs (mkLams dictvars core_expr)
+
+------------------
+
+dsExpr (DictApp expr dicts) -- becomes a curried application
+ = dsLExpr expr `thenDs` \ core_expr ->
+ returnDs (foldl (\f d -> f `App` (Var d)) core_expr dicts)
+
+dsExpr (HsCoerce co_fn e) = dsCoercion co_fn (dsExpr e)
+\end{code}
+
+Here is where we desugar the Template Haskell brackets and escapes
+
+\begin{code}
+-- Template Haskell stuff
+
+#ifdef GHCI /* Only if bootstrapping */
+dsExpr (HsBracketOut x ps) = dsBracket x ps
+dsExpr (HsSpliceE s) = pprPanic "dsExpr:splice" (ppr s)
+#endif
+
+-- Arrow notation extension
+dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
+\end{code}
+
+
+\begin{code}
+
+#ifdef DEBUG
+-- HsSyn constructs that just shouldn't be here:
+dsExpr (ExprWithTySig _ _) = panic "dsExpr:ExprWithTySig"
+#endif
+
+\end{code}
+
+%--------------------------------------------------------------------
+
+Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
+handled in DsListComp). Basically does the translation given in the
+Haskell 98 report:
+
+\begin{code}
+dsDo :: [LStmt Id]
+ -> LHsExpr Id
+ -> Type -- Type of the whole expression
+ -> DsM CoreExpr
+
+dsDo stmts body result_ty
+ = go (map unLoc stmts)
+ where
+ go [] = dsLExpr body
+
+ go (ExprStmt rhs then_expr _ : stmts)
+ = do { rhs2 <- dsLExpr rhs
+ ; then_expr2 <- dsExpr then_expr
+ ; rest <- go stmts
+ ; returnDs (mkApps then_expr2 [rhs2, rest]) }
+
+ go (LetStmt binds : stmts)
+ = do { rest <- go stmts
+ ; dsLocalBinds binds rest }
+
+ go (BindStmt pat rhs bind_op fail_op : stmts)
+ = do { body <- go stmts
+ ; var <- selectSimpleMatchVarL pat
+ ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
+ result_ty (cantFailMatchResult body)
+ ; match_code <- handle_failure pat match fail_op
+ ; rhs' <- dsLExpr rhs
+ ; bind_op' <- dsExpr bind_op
+ ; returnDs (mkApps bind_op' [rhs', Lam var match_code]) }
+
+ -- In a do expression, pattern-match failure just calls
+ -- the monadic 'fail' rather than throwing an exception
+ handle_failure pat match fail_op
+ | matchCanFail match
+ = do { fail_op' <- dsExpr fail_op
+ ; fail_msg <- mkStringExpr (mk_fail_msg pat)
+ ; extractMatchResult match (App fail_op' fail_msg) }
+ | otherwise
+ = extractMatchResult match (error "It can't fail")
+
+mk_fail_msg pat = "Pattern match failure in do expression at " ++
+ showSDoc (ppr (getLoc pat))
+\end{code}
+
+Translation for RecStmt's:
+-----------------------------
+We turn (RecStmt [v1,..vn] stmts) into:
+
+ (v1,..,vn) <- mfix (\~(v1,..vn). do stmts
+ return (v1,..vn))
+
+\begin{code}
+dsMDo :: PostTcTable
+ -> [LStmt Id]
+ -> LHsExpr Id
+ -> Type -- Type of the whole expression
+ -> DsM CoreExpr
+
+dsMDo tbl stmts body result_ty
+ = go (map unLoc stmts)
+ where
+ (m_ty, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b)
+ mfix_id = lookupEvidence tbl mfixName
+ return_id = lookupEvidence tbl returnMName
+ bind_id = lookupEvidence tbl bindMName
+ then_id = lookupEvidence tbl thenMName
+ fail_id = lookupEvidence tbl failMName
+ ctxt = MDoExpr tbl
+
+ go [] = dsLExpr body
+
+ go (LetStmt binds : stmts)
+ = do { rest <- go stmts
+ ; dsLocalBinds binds rest }
+
+ go (ExprStmt rhs _ rhs_ty : stmts)
+ = do { rhs2 <- dsLExpr rhs
+ ; rest <- go stmts
+ ; returnDs (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
+
+ go (BindStmt pat rhs _ _ : stmts)
+ = do { body <- go stmts
+ ; var <- selectSimpleMatchVarL pat
+ ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
+ result_ty (cantFailMatchResult body)
+ ; fail_msg <- mkStringExpr (mk_fail_msg pat)
+ ; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg]
+ ; match_code <- extractMatchResult match fail_expr
+
+ ; rhs' <- dsLExpr rhs
+ ; returnDs (mkApps (Var bind_id) [Type (hsPatType pat), Type b_ty,
+ rhs', Lam var match_code]) }
+
+ go (RecStmt rec_stmts later_ids rec_ids rec_rets binds : stmts)
+ = ASSERT( length rec_ids > 0 )
+ ASSERT( length rec_ids == length rec_rets )
+ go (new_bind_stmt : let_stmt : stmts)
+ where
+ new_bind_stmt = mkBindStmt (mk_tup_pat later_pats) mfix_app
+ let_stmt = LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
+
+
+ -- Remove the later_ids that appear (without fancy coercions)
+ -- in rec_rets, because there's no need to knot-tie them separately
+ -- See Note [RecStmt] in HsExpr
+ later_ids' = filter (`notElem` mono_rec_ids) later_ids
+ mono_rec_ids = [ id | HsVar id <- rec_rets ]
+
+ mfix_app = nlHsApp (noLoc $ TyApp (nlHsVar mfix_id) [tup_ty]) mfix_arg
+ mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
+ (mkFunTy tup_ty body_ty))
+
+ -- The rec_tup_pat must bind the rec_ids only; remember that the
+ -- trimmed_laters may share the same Names
+ -- Meanwhile, the later_pats must bind the later_vars
+ rec_tup_pats = map mk_wild_pat later_ids' ++ map nlVarPat rec_ids
+ later_pats = map nlVarPat later_ids' ++ map mk_later_pat rec_ids
+ rets = map nlHsVar later_ids' ++ map noLoc rec_rets
+
+ mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
+ body = noLoc $ HsDo ctxt rec_stmts return_app body_ty
+ body_ty = mkAppTy m_ty tup_ty
+ tup_ty = mkCoreTupTy (map idType (later_ids' ++ rec_ids))
+ -- mkCoreTupTy deals with singleton case
+
+ return_app = nlHsApp (noLoc $ TyApp (nlHsVar return_id) [tup_ty])
+ (mk_ret_tup rets)
+
+ mk_wild_pat :: Id -> LPat Id
+ mk_wild_pat v = noLoc $ WildPat $ idType v
+
+ mk_later_pat :: Id -> LPat Id
+ mk_later_pat v | v `elem` later_ids' = mk_wild_pat v
+ | otherwise = nlVarPat v
+
+ mk_tup_pat :: [LPat Id] -> LPat Id
+ mk_tup_pat [p] = p
+ mk_tup_pat ps = noLoc $ mkVanillaTuplePat ps Boxed
+
+ mk_ret_tup :: [LHsExpr Id] -> LHsExpr Id
+ mk_ret_tup [r] = r
+ mk_ret_tup rs = noLoc $ ExplicitTuple rs Boxed
+\end{code}
diff --git a/compiler/deSugar/DsExpr.lhs-boot b/compiler/deSugar/DsExpr.lhs-boot
new file mode 100644
index 0000000000..c65e99d80d
--- /dev/null
+++ b/compiler/deSugar/DsExpr.lhs-boot
@@ -0,0 +1,11 @@
+\begin{code}
+module DsExpr where
+import HsSyn ( HsExpr, LHsExpr, HsLocalBinds )
+import Var ( Id )
+import DsMonad ( DsM )
+import CoreSyn ( CoreExpr )
+
+dsExpr :: HsExpr Id -> DsM CoreExpr
+dsLExpr :: LHsExpr Id -> DsM CoreExpr
+dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr
+\end{code}
diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
new file mode 100644
index 0000000000..52956a09ff
--- /dev/null
+++ b/compiler/deSugar/DsForeign.lhs
@@ -0,0 +1,646 @@
+%
+% (c) The AQUA Project, Glasgow University, 1998
+%
+\section[DsCCall]{Desugaring \tr{foreign} declarations}
+
+Expanding out @foreign import@ and @foreign export@ declarations.
+
+\begin{code}
+module DsForeign ( dsForeigns ) where
+
+#include "HsVersions.h"
+import TcRnMonad -- temp
+
+import CoreSyn
+
+import DsCCall ( dsCCall, mkFCall, boxResult, unboxArg, resultWrapper )
+import DsMonad
+
+import HsSyn ( ForeignDecl(..), ForeignExport(..), LForeignDecl,
+ ForeignImport(..), CImportSpec(..) )
+import DataCon ( splitProductType_maybe )
+#ifdef DEBUG
+import DataCon ( dataConSourceArity )
+import Type ( isUnLiftedType )
+#endif
+import MachOp ( machRepByteWidth, MachRep(..) )
+import SMRep ( argMachRep, typeCgRep )
+import CoreUtils ( exprType, mkInlineMe )
+import Id ( Id, idType, idName, mkSysLocal, setInlinePragma )
+import Literal ( Literal(..), mkStringLit )
+import Module ( moduleFS )
+import Name ( getOccString, NamedThing(..) )
+import Type ( repType, coreEqType )
+import TcType ( Type, mkFunTys, mkForAllTys, mkTyConApp,
+ mkFunTy, tcSplitTyConApp_maybe,
+ tcSplitForAllTys, tcSplitFunTys, tcTyConAppArgs,
+ )
+
+import BasicTypes ( Boxity(..) )
+import HscTypes ( ForeignStubs(..) )
+import ForeignCall ( ForeignCall(..), CCallSpec(..),
+ Safety(..), playSafe,
+ CExportSpec(..), CLabelString,
+ CCallConv(..), ccallConvToInt,
+ ccallConvAttribute
+ )
+import TysWiredIn ( unitTy, tupleTyCon )
+import TysPrim ( addrPrimTy, mkStablePtrPrimTy, alphaTy )
+import PrelNames ( hasKey, ioTyConKey, stablePtrTyConName, newStablePtrName, bindIOName,
+ checkDotnetResName )
+import BasicTypes ( Activation( NeverActive ) )
+import SrcLoc ( Located(..), unLoc )
+import Outputable
+import Maybe ( fromJust, isNothing )
+import FastString
+\end{code}
+
+Desugaring of @foreign@ declarations is naturally split up into
+parts, an @import@ and an @export@ part. A @foreign import@
+declaration
+\begin{verbatim}
+ foreign import cc nm f :: prim_args -> IO prim_res
+\end{verbatim}
+is the same as
+\begin{verbatim}
+ f :: prim_args -> IO prim_res
+ f a1 ... an = _ccall_ nm cc a1 ... an
+\end{verbatim}
+so we reuse the desugaring code in @DsCCall@ to deal with these.
+
+\begin{code}
+type Binding = (Id, CoreExpr) -- No rec/nonrec structure;
+ -- the occurrence analyser will sort it all out
+
+dsForeigns :: [LForeignDecl Id]
+ -> DsM (ForeignStubs, [Binding])
+dsForeigns []
+ = returnDs (NoStubs, [])
+dsForeigns fos
+ = foldlDs combine (ForeignStubs empty empty [] [], []) fos
+ where
+ combine stubs (L loc decl) = putSrcSpanDs loc (combine1 stubs decl)
+
+ combine1 (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f)
+ (ForeignImport id _ spec depr)
+ = traceIf (text "fi start" <+> ppr id) `thenDs` \ _ ->
+ dsFImport (unLoc id) spec `thenDs` \ (bs, h, c, mbhd) ->
+ warnDepr depr `thenDs` \ _ ->
+ traceIf (text "fi end" <+> ppr id) `thenDs` \ _ ->
+ returnDs (ForeignStubs (h $$ acc_h)
+ (c $$ acc_c)
+ (addH mbhd acc_hdrs)
+ acc_feb,
+ bs ++ acc_f)
+
+ combine1 (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f)
+ (ForeignExport (L _ id) _ (CExport (CExportStatic ext_nm cconv)) depr)
+ = dsFExport id (idType id)
+ ext_nm cconv False `thenDs` \(h, c, _, _) ->
+ warnDepr depr `thenDs` \_ ->
+ returnDs (ForeignStubs (h $$ acc_h) (c $$ acc_c) acc_hdrs (id:acc_feb),
+ acc_f)
+
+ addH Nothing ls = ls
+ addH (Just e) ls
+ | e `elem` ls = ls
+ | otherwise = e:ls
+
+ warnDepr False = returnDs ()
+ warnDepr True = dsWarn msg
+ where
+ msg = ptext SLIT("foreign declaration uses deprecated non-standard syntax")
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Foreign import}
+%* *
+%************************************************************************
+
+Desugaring foreign imports is just the matter of creating a binding
+that on its RHS unboxes its arguments, performs the external call
+(using the @CCallOp@ primop), before boxing the result up and returning it.
+
+However, we create a worker/wrapper pair, thus:
+
+ foreign import f :: Int -> IO Int
+==>
+ f x = IO ( \s -> case x of { I# x# ->
+ case fw s x# of { (# s1, y# #) ->
+ (# s1, I# y# #)}})
+
+ fw s x# = ccall f s x#
+
+The strictness/CPR analyser won't do this automatically because it doesn't look
+inside returned tuples; but inlining this wrapper is a Really Good Idea
+because it exposes the boxing to the call site.
+
+\begin{code}
+dsFImport :: Id
+ -> ForeignImport
+ -> DsM ([Binding], SDoc, SDoc, Maybe FastString)
+dsFImport id (CImport cconv safety header lib spec)
+ = dsCImport id spec cconv safety no_hdrs `thenDs` \(ids, h, c) ->
+ returnDs (ids, h, c, if no_hdrs then Nothing else Just header)
+ where
+ no_hdrs = nullFS header
+
+ -- FIXME: the `lib' field is needed for .NET ILX generation when invoking
+ -- routines that are external to the .NET runtime, but GHC doesn't
+ -- support such calls yet; if `nullFastString lib', the value was not given
+dsFImport id (DNImport spec)
+ = dsFCall id (DNCall spec) True {- No headers -} `thenDs` \(ids, h, c) ->
+ returnDs (ids, h, c, Nothing)
+
+dsCImport :: Id
+ -> CImportSpec
+ -> CCallConv
+ -> Safety
+ -> Bool -- True <=> no headers in the f.i decl
+ -> DsM ([Binding], SDoc, SDoc)
+dsCImport id (CLabel cid) _ _ no_hdrs
+ = resultWrapper (idType id) `thenDs` \ (resTy, foRhs) ->
+ ASSERT(fromJust resTy `coreEqType` addrPrimTy) -- typechecker ensures this
+ let rhs = foRhs (mkLit (MachLabel cid Nothing)) in
+ returnDs ([(setImpInline no_hdrs id, rhs)], empty, empty)
+dsCImport id (CFunction target) cconv safety no_hdrs
+ = dsFCall id (CCall (CCallSpec target cconv safety)) no_hdrs
+dsCImport id CWrapper cconv _ _
+ = dsFExportDynamic id cconv
+
+setImpInline :: Bool -- True <=> No #include headers
+ -- in the foreign import declaration
+ -> Id -> Id
+-- If there is a #include header in the foreign import
+-- we make the worker non-inlinable, because we currently
+-- don't keep the #include stuff in the CCallId, and hence
+-- it won't be visible in the importing module, which can be
+-- fatal.
+-- (The #include stuff is just collected from the foreign import
+-- decls in a module.)
+-- If you want to do cross-module inlining of the c-calls themselves,
+-- put the #include stuff in the package spec, not the foreign
+-- import decl.
+setImpInline True id = id
+setImpInline False id = id `setInlinePragma` NeverActive
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Foreign calls}
+%* *
+%************************************************************************
+
+\begin{code}
+dsFCall fn_id fcall no_hdrs
+ = let
+ ty = idType fn_id
+ (tvs, fun_ty) = tcSplitForAllTys ty
+ (arg_tys, io_res_ty) = tcSplitFunTys fun_ty
+ -- Must use tcSplit* functions because we want to
+ -- see that (IO t) in the corner
+ in
+ newSysLocalsDs arg_tys `thenDs` \ args ->
+ mapAndUnzipDs unboxArg (map Var args) `thenDs` \ (val_args, arg_wrappers) ->
+
+ let
+ work_arg_ids = [v | Var v <- val_args] -- All guaranteed to be vars
+
+ forDotnet =
+ case fcall of
+ DNCall{} -> True
+ _ -> False
+
+ topConDs
+ | forDotnet =
+ dsLookupGlobalId checkDotnetResName `thenDs` \ check_id ->
+ return (Just check_id)
+ | otherwise = return Nothing
+
+ augmentResultDs
+ | forDotnet =
+ newSysLocalDs addrPrimTy `thenDs` \ err_res ->
+ returnDs (\ (mb_res_ty, resWrap) ->
+ case mb_res_ty of
+ Nothing -> (Just (mkTyConApp (tupleTyCon Unboxed 1)
+ [ addrPrimTy ]),
+ resWrap)
+ Just x -> (Just (mkTyConApp (tupleTyCon Unboxed 2)
+ [ x, addrPrimTy ]),
+ resWrap))
+ | otherwise = returnDs id
+ in
+ augmentResultDs `thenDs` \ augment ->
+ topConDs `thenDs` \ topCon ->
+ boxResult augment topCon io_res_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
+
+ newUnique `thenDs` \ ccall_uniq ->
+ newUnique `thenDs` \ work_uniq ->
+ let
+ -- Build the worker
+ worker_ty = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
+ the_ccall_app = mkFCall ccall_uniq fcall val_args ccall_result_ty
+ work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app)
+ work_id = setImpInline no_hdrs $ -- See comments with setImpInline
+ mkSysLocal FSLIT("$wccall") work_uniq worker_ty
+
+ -- Build the wrapper
+ work_app = mkApps (mkVarApps (Var work_id) tvs) val_args
+ wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
+ wrap_rhs = mkInlineMe (mkLams (tvs ++ args) wrapper_body)
+ in
+ returnDs ([(work_id, work_rhs), (fn_id, wrap_rhs)], empty, empty)
+
+unsafe_call (CCall (CCallSpec _ _ safety)) = playSafe safety
+unsafe_call (DNCall _) = False
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Foreign export}
+%* *
+%************************************************************************
+
+The function that does most of the work for `@foreign export@' declarations.
+(see below for the boilerplate code a `@foreign export@' declaration expands
+ into.)
+
+For each `@foreign export foo@' in a module M we generate:
+\begin{itemize}
+\item a C function `@foo@', which calls
+\item a Haskell stub `@M.$ffoo@', which calls
+\end{itemize}
+the user-written Haskell function `@M.foo@'.
+
+\begin{code}
+dsFExport :: Id -- Either the exported Id,
+ -- or the foreign-export-dynamic constructor
+ -> Type -- The type of the thing callable from C
+ -> CLabelString -- The name to export to C land
+ -> CCallConv
+ -> Bool -- True => foreign export dynamic
+ -- so invoke IO action that's hanging off
+ -- the first argument's stable pointer
+ -> DsM ( SDoc -- contents of Module_stub.h
+ , SDoc -- contents of Module_stub.c
+ , [MachRep] -- primitive arguments expected by stub function
+ , Int -- size of args to stub function
+ )
+
+dsFExport fn_id ty ext_name cconv isDyn
+ =
+ let
+ (_tvs,sans_foralls) = tcSplitForAllTys ty
+ (fe_arg_tys', orig_res_ty) = tcSplitFunTys sans_foralls
+ -- We must use tcSplits here, because we want to see
+ -- the (IO t) in the corner of the type!
+ fe_arg_tys | isDyn = tail fe_arg_tys'
+ | otherwise = fe_arg_tys'
+ in
+ -- Look at the result type of the exported function, orig_res_ty
+ -- If it's IO t, return (t, True)
+ -- If it's plain t, return (t, False)
+ (case tcSplitTyConApp_maybe orig_res_ty of
+ -- We must use tcSplit here so that we see the (IO t) in
+ -- the type. [IO t is transparent to plain splitTyConApp.]
+
+ Just (ioTyCon, [res_ty])
+ -> ASSERT( ioTyCon `hasKey` ioTyConKey )
+ -- The function already returns IO t
+ returnDs (res_ty, True)
+
+ other -> -- The function returns t
+ returnDs (orig_res_ty, False)
+ )
+ `thenDs` \ (res_ty, -- t
+ is_IO_res_ty) -> -- Bool
+ returnDs $
+ mkFExportCBits ext_name
+ (if isDyn then Nothing else Just fn_id)
+ fe_arg_tys res_ty is_IO_res_ty cconv
+\end{code}
+
+@foreign export dynamic@ lets you dress up Haskell IO actions
+of some fixed type behind an externally callable interface (i.e.,
+as a C function pointer). Useful for callbacks and stuff.
+
+\begin{verbatim}
+foreign export dynamic f :: (Addr -> Int -> IO Int) -> IO Addr
+
+-- Haskell-visible constructor, which is generated from the above:
+-- SUP: No check for NULL from createAdjustor anymore???
+
+f :: (Addr -> Int -> IO Int) -> IO Addr
+f cback =
+ bindIO (newStablePtr cback)
+ (\StablePtr sp# -> IO (\s1# ->
+ case _ccall_ createAdjustor cconv sp# ``f_helper'' s1# of
+ (# s2#, a# #) -> (# s2#, A# a# #)))
+
+foreign export "f_helper" f_helper :: StablePtr (Addr -> Int -> IO Int) -> Addr -> Int -> IO Int
+-- `special' foreign export that invokes the closure pointed to by the
+-- first argument.
+\end{verbatim}
+
+\begin{code}
+dsFExportDynamic :: Id
+ -> CCallConv
+ -> DsM ([Binding], SDoc, SDoc)
+dsFExportDynamic id cconv
+ = newSysLocalDs ty `thenDs` \ fe_id ->
+ getModuleDs `thenDs` \ mod_name ->
+ let
+ -- hack: need to get at the name of the C stub we're about to generate.
+ fe_nm = mkFastString (unpackFS (zEncodeFS (moduleFS mod_name)) ++ "_" ++ toCName fe_id)
+ in
+ newSysLocalDs arg_ty `thenDs` \ cback ->
+ dsLookupGlobalId newStablePtrName `thenDs` \ newStablePtrId ->
+ dsLookupTyCon stablePtrTyConName `thenDs` \ stable_ptr_tycon ->
+ let
+ mk_stbl_ptr_app = mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
+ stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]
+ export_ty = mkFunTy stable_ptr_ty arg_ty
+ in
+ dsLookupGlobalId bindIOName `thenDs` \ bindIOId ->
+ newSysLocalDs stable_ptr_ty `thenDs` \ stbl_value ->
+ dsFExport id export_ty fe_nm cconv True
+ `thenDs` \ (h_code, c_code, arg_reps, args_size) ->
+ let
+ stbl_app cont ret_ty = mkApps (Var bindIOId)
+ [ Type stable_ptr_ty
+ , Type ret_ty
+ , mk_stbl_ptr_app
+ , cont
+ ]
+ {-
+ The arguments to the external function which will
+ create a little bit of (template) code on the fly
+ for allowing the (stable pointed) Haskell closure
+ to be entered using an external calling convention
+ (stdcall, ccall).
+ -}
+ adj_args = [ mkIntLitInt (ccallConvToInt cconv)
+ , Var stbl_value
+ , mkLit (MachLabel fe_nm mb_sz_args)
+ , mkLit (mkStringLit arg_type_info)
+ ]
+ -- name of external entry point providing these services.
+ -- (probably in the RTS.)
+ adjustor = FSLIT("createAdjustor")
+
+ arg_type_info = map repCharCode arg_reps
+ repCharCode F32 = 'f'
+ repCharCode F64 = 'd'
+ repCharCode I64 = 'l'
+ repCharCode _ = 'i'
+
+ -- Determine the number of bytes of arguments to the stub function,
+ -- so that we can attach the '@N' suffix to its label if it is a
+ -- stdcall on Windows.
+ mb_sz_args = case cconv of
+ StdCallConv -> Just args_size
+ _ -> Nothing
+
+ in
+ dsCCall adjustor adj_args PlayRisky io_res_ty `thenDs` \ ccall_adj ->
+ -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
+ let ccall_adj_ty = exprType ccall_adj
+ ccall_io_adj = mkLams [stbl_value] $
+ Note (Coerce io_res_ty ccall_adj_ty)
+ ccall_adj
+ io_app = mkLams tvs $
+ mkLams [cback] $
+ stbl_app ccall_io_adj res_ty
+ fed = (id `setInlinePragma` NeverActive, io_app)
+ -- Never inline the f.e.d. function, because the litlit
+ -- might not be in scope in other modules.
+ in
+ returnDs ([fed], h_code, c_code)
+
+ where
+ ty = idType id
+ (tvs,sans_foralls) = tcSplitForAllTys ty
+ ([arg_ty], io_res_ty) = tcSplitFunTys sans_foralls
+ [res_ty] = tcTyConAppArgs io_res_ty
+ -- Must use tcSplit* to see the (IO t), which is a newtype
+
+toCName :: Id -> String
+toCName i = showSDoc (pprCode CStyle (ppr (idName i)))
+\end{code}
+
+%*
+%
+\subsection{Generating @foreign export@ stubs}
+%
+%*
+
+For each @foreign export@ function, a C stub function is generated.
+The C stub constructs the application of the exported Haskell function
+using the hugs/ghc rts invocation API.
+
+\begin{code}
+mkFExportCBits :: FastString
+ -> Maybe Id -- Just==static, Nothing==dynamic
+ -> [Type]
+ -> Type
+ -> Bool -- True <=> returns an IO type
+ -> CCallConv
+ -> (SDoc,
+ SDoc,
+ [MachRep], -- the argument reps
+ Int -- total size of arguments
+ )
+mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
+ = (header_bits, c_bits,
+ [rep | (_,_,_,rep) <- arg_info], -- just the real args
+ sum [ machRepByteWidth rep | (_,_,_,rep) <- aug_arg_info] -- all the args
+ )
+ where
+ -- list the arguments to the C function
+ arg_info :: [(SDoc, -- arg name
+ SDoc, -- C type
+ Type, -- Haskell type
+ MachRep)] -- the MachRep
+ arg_info = [ (text ('a':show n), showStgType ty, ty,
+ typeMachRep (getPrimTyOf ty))
+ | (ty,n) <- zip arg_htys [1..] ]
+
+ -- add some auxiliary args; the stable ptr in the wrapper case, and
+ -- a slot for the dummy return address in the wrapper + ccall case
+ aug_arg_info
+ | isNothing maybe_target = stable_ptr_arg : insertRetAddr cc arg_info
+ | otherwise = arg_info
+
+ stable_ptr_arg =
+ (text "the_stableptr", text "StgStablePtr", undefined,
+ typeMachRep (mkStablePtrPrimTy alphaTy))
+
+ -- stuff to do with the return type of the C function
+ res_hty_is_unit = res_hty `coreEqType` unitTy -- Look through any newtypes
+
+ cResType | res_hty_is_unit = text "void"
+ | otherwise = showStgType res_hty
+
+ -- Now we can cook up the prototype for the exported function.
+ pprCconv = case cc of
+ CCallConv -> empty
+ StdCallConv -> text (ccallConvAttribute cc)
+
+ header_bits = ptext SLIT("extern") <+> fun_proto <> semi
+
+ fun_proto = cResType <+> pprCconv <+> ftext c_nm <>
+ parens (hsep (punctuate comma (map (\(nm,ty,_,_) -> ty <+> nm)
+ aug_arg_info)))
+
+ -- the target which will form the root of what we ask rts_evalIO to run
+ the_cfun
+ = case maybe_target of
+ Nothing -> text "(StgClosure*)deRefStablePtr(the_stableptr)"
+ Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure"
+
+ cap = text "cap" <> comma
+
+ -- the expression we give to rts_evalIO
+ expr_to_run
+ = foldl appArg the_cfun arg_info -- NOT aug_arg_info
+ where
+ appArg acc (arg_cname, _, arg_hty, _)
+ = text "rts_apply"
+ <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname))
+
+ -- various other bits for inside the fn
+ declareResult = text "HaskellObj ret;"
+ declareCResult | res_hty_is_unit = empty
+ | otherwise = cResType <+> text "cret;"
+
+ assignCResult | res_hty_is_unit = empty
+ | otherwise =
+ text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi
+
+ -- an extern decl for the fn being called
+ extern_decl
+ = case maybe_target of
+ Nothing -> empty
+ Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi
+
+
+ -- Initialise foreign exports by registering a stable pointer from an
+ -- __attribute__((constructor)) function.
+ -- The alternative is to do this from stginit functions generated in
+ -- codeGen/CodeGen.lhs; however, stginit functions have a negative impact
+ -- on binary sizes and link times because the static linker will think that
+ -- all modules that are imported directly or indirectly are actually used by
+ -- the program.
+ -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)
+
+ initialiser
+ = case maybe_target of
+ Nothing -> empty
+ Just hs_fn ->
+ vcat
+ [ text "static void stginit_export_" <> ppr hs_fn
+ <> text "() __attribute__((constructor));"
+ , text "static void stginit_export_" <> ppr hs_fn <> text "()"
+ , braces (text "getStablePtr"
+ <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure")
+ <> semi)
+ ]
+
+ -- finally, the whole darn thing
+ c_bits =
+ space $$
+ extern_decl $$
+ fun_proto $$
+ vcat
+ [ lbrace
+ , text "Capability *cap;"
+ , declareResult
+ , declareCResult
+ , text "cap = rts_lock();"
+ -- create the application + perform it.
+ , text "cap=rts_evalIO" <> parens (
+ cap <>
+ text "rts_apply" <> parens (
+ cap <>
+ text "(HaskellObj)"
+ <> text (if is_IO_res_ty
+ then "runIO_closure"
+ else "runNonIO_closure")
+ <> comma
+ <> expr_to_run
+ ) <+> comma
+ <> text "&ret"
+ ) <> semi
+ , text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm)
+ <> comma <> text "cap") <> semi
+ , assignCResult
+ , text "rts_unlock(cap);"
+ , if res_hty_is_unit then empty
+ else text "return cret;"
+ , rbrace
+ ] $$
+ initialiser
+
+-- NB. the calculation here isn't strictly speaking correct.
+-- We have a primitive Haskell type (eg. Int#, Double#), and
+-- we want to know the size, when passed on the C stack, of
+-- the associated C type (eg. HsInt, HsDouble). We don't have
+-- this information to hand, but we know what GHC's conventions
+-- are for passing around the primitive Haskell types, so we
+-- use that instead. I hope the two coincide --SDM
+typeMachRep ty = argMachRep (typeCgRep ty)
+
+mkHObj :: Type -> SDoc
+mkHObj t = text "rts_mk" <> text (showFFIType t)
+
+unpackHObj :: Type -> SDoc
+unpackHObj t = text "rts_get" <> text (showFFIType t)
+
+showStgType :: Type -> SDoc
+showStgType t = text "Hs" <> text (showFFIType t)
+
+showFFIType :: Type -> String
+showFFIType t = getOccString (getName tc)
+ where
+ tc = case tcSplitTyConApp_maybe (repType t) of
+ Just (tc,_) -> tc
+ Nothing -> pprPanic "showFFIType" (ppr t)
+
+#if !defined(x86_64_TARGET_ARCH)
+insertRetAddr CCallConv args = ret_addr_arg : args
+insertRetAddr _ args = args
+#else
+-- On x86_64 we insert the return address after the 6th
+-- integer argument, because this is the point at which we
+-- need to flush a register argument to the stack (See rts/Adjustor.c for
+-- details).
+insertRetAddr CCallConv args = go 0 args
+ where go 6 args = ret_addr_arg : args
+ go n (arg@(_,_,_,rep):args)
+ | I64 <- rep = arg : go (n+1) args
+ | otherwise = arg : go n args
+ go n [] = []
+insertRetAddr _ args = args
+#endif
+
+ret_addr_arg = (text "original_return_addr", text "void*", undefined,
+ typeMachRep addrPrimTy)
+
+-- This function returns the primitive type associated with the boxed
+-- type argument to a foreign export (eg. Int ==> Int#). It assumes
+-- that all the types we are interested in have a single constructor
+-- with a single primitive-typed argument, which is true for all of the legal
+-- foreign export argument types (see TcType.legalFEArgTyCon).
+getPrimTyOf :: Type -> Type
+getPrimTyOf ty =
+ case splitProductType_maybe (repType ty) of
+ Just (_, _, data_con, [prim_ty]) ->
+ ASSERT(dataConSourceArity data_con == 1)
+ ASSERT2(isUnLiftedType prim_ty, ppr prim_ty)
+ prim_ty
+ _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty)
+\end{code}
diff --git a/compiler/deSugar/DsGRHSs.lhs b/compiler/deSugar/DsGRHSs.lhs
new file mode 100644
index 0000000000..eea61bafb2
--- /dev/null
+++ b/compiler/deSugar/DsGRHSs.lhs
@@ -0,0 +1,128 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[DsGRHSs]{Matching guarded right-hand-sides (GRHSs)}
+
+\begin{code}
+module DsGRHSs ( dsGuarded, dsGRHSs ) where
+
+#include "HsVersions.h"
+
+import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds )
+import {-# SOURCE #-} Match ( matchSinglePat )
+
+import HsSyn ( Stmt(..), HsExpr(..), GRHSs(..), GRHS(..),
+ LHsExpr, HsMatchContext(..), Pat(..) )
+import CoreSyn ( CoreExpr )
+import Var ( Id )
+import Type ( Type )
+
+import DsMonad
+import DsUtils
+import Unique ( Uniquable(..) )
+import PrelInfo ( nON_EXHAUSTIVE_GUARDS_ERROR_ID )
+import TysWiredIn ( trueDataConId )
+import PrelNames ( otherwiseIdKey, hasKey )
+import Name ( Name )
+import SrcLoc ( unLoc, Located(..) )
+\end{code}
+
+@dsGuarded@ is used for both @case@ expressions and pattern bindings.
+It desugars:
+\begin{verbatim}
+ | g1 -> e1
+ ...
+ | gn -> en
+ where binds
+\end{verbatim}
+producing an expression with a runtime error in the corner if
+necessary. The type argument gives the type of the @ei@.
+
+\begin{code}
+dsGuarded :: GRHSs Id -> Type -> DsM CoreExpr
+
+dsGuarded grhss rhs_ty
+ = dsGRHSs PatBindRhs [] grhss rhs_ty `thenDs` \ match_result ->
+ mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty "" `thenDs` \ error_expr ->
+ extractMatchResult match_result error_expr
+\end{code}
+
+In contrast, @dsGRHSs@ produces a @MatchResult@.
+
+\begin{code}
+dsGRHSs :: HsMatchContext Name -> [Pat Id] -- These are to build a MatchContext from
+ -> GRHSs Id -- Guarded RHSs
+ -> Type -- Type of RHS
+ -> DsM MatchResult
+
+dsGRHSs hs_ctx pats (GRHSs grhss binds) rhs_ty
+ = mappM (dsGRHS hs_ctx pats rhs_ty) grhss `thenDs` \ match_results ->
+ let
+ match_result1 = foldr1 combineMatchResults match_results
+ match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1
+ -- NB: nested dsLet inside matchResult
+ in
+ returnDs match_result2
+
+dsGRHS hs_ctx pats rhs_ty (L loc (GRHS guards rhs))
+ = matchGuards (map unLoc guards) hs_ctx rhs rhs_ty
+\end{code}
+
+
+%************************************************************************
+%* *
+%* matchGuard : make a MatchResult from a guarded RHS *
+%* *
+%************************************************************************
+
+\begin{code}
+matchGuards :: [Stmt Id] -- Guard
+ -> HsMatchContext Name -- Context
+ -> LHsExpr Id -- RHS
+ -> Type -- Type of RHS of guard
+ -> DsM MatchResult
+
+-- See comments with HsExpr.Stmt re what an ExprStmt means
+-- Here we must be in a guard context (not do-expression, nor list-comp)
+
+matchGuards [] ctx rhs rhs_ty
+ = do { core_rhs <- dsLExpr rhs
+ ; return (cantFailMatchResult core_rhs) }
+
+ -- ExprStmts must be guards
+ -- Turn an "otherwise" guard is a no-op. This ensures that
+ -- you don't get a "non-exhaustive eqns" message when the guards
+ -- finish in "otherwise".
+ -- NB: The success of this clause depends on the typechecker not
+ -- wrapping the 'otherwise' in empty HsTyApp or HsCoerce constructors
+ -- If it does, you'll get bogus overlap warnings
+matchGuards (ExprStmt (L _ (HsVar v)) _ _ : stmts) ctx rhs rhs_ty
+ | v `hasKey` otherwiseIdKey
+ || v `hasKey` getUnique trueDataConId
+ -- trueDataConId doesn't have the same unique as trueDataCon
+ = matchGuards stmts ctx rhs rhs_ty
+
+matchGuards (ExprStmt expr _ _ : stmts) ctx rhs rhs_ty
+ = matchGuards stmts ctx rhs rhs_ty `thenDs` \ match_result ->
+ dsLExpr expr `thenDs` \ pred_expr ->
+ returnDs (mkGuardedMatchResult pred_expr match_result)
+
+matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty
+ = matchGuards stmts ctx rhs rhs_ty `thenDs` \ match_result ->
+ returnDs (adjustMatchResultDs (dsLocalBinds binds) match_result)
+ -- NB the dsLet occurs inside the match_result
+ -- Reason: dsLet takes the body expression as its argument
+ -- so we can't desugar the bindings without the
+ -- body expression in hand
+
+matchGuards (BindStmt pat bind_rhs _ _ : stmts) ctx rhs rhs_ty
+ = matchGuards stmts ctx rhs rhs_ty `thenDs` \ match_result ->
+ dsLExpr bind_rhs `thenDs` \ core_rhs ->
+ matchSinglePat core_rhs ctx pat rhs_ty match_result
+\end{code}
+
+Should {\em fail} if @e@ returns @D@
+\begin{verbatim}
+f x | p <- e', let C y# = e, f y# = r1
+ | otherwise = r2
+\end{verbatim}
diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs
new file mode 100644
index 0000000000..6bb41a92e4
--- /dev/null
+++ b/compiler/deSugar/DsListComp.lhs
@@ -0,0 +1,516 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[DsListComp]{Desugaring list comprehensions and array comprehensions}
+
+\begin{code}
+module DsListComp ( dsListComp, dsPArrComp ) where
+
+#include "HsVersions.h"
+
+import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds )
+
+import BasicTypes ( Boxity(..) )
+import HsSyn
+import TcHsSyn ( hsPatType, mkVanillaTuplePat )
+import CoreSyn
+
+import DsMonad -- the monadery used in the desugarer
+import DsUtils
+
+import DynFlags ( DynFlag(..), dopt )
+import StaticFlags ( opt_RulesOff )
+import CoreUtils ( exprType, mkIfThenElse )
+import Id ( idType )
+import Var ( Id )
+import Type ( mkTyVarTy, mkFunTys, mkFunTy, Type,
+ splitTyConApp_maybe )
+import TysPrim ( alphaTyVar )
+import TysWiredIn ( nilDataCon, consDataCon, trueDataConId, falseDataConId,
+ unitDataConId, unitTy, mkListTy, parrTyCon )
+import Match ( matchSimply )
+import PrelNames ( foldrName, buildName, replicatePName, mapPName,
+ filterPName, zipPName, crossPName )
+import PrelInfo ( pAT_ERROR_ID )
+import SrcLoc ( noLoc, unLoc )
+import Panic ( panic )
+\end{code}
+
+List comprehensions may be desugared in one of two ways: ``ordinary''
+(as you would expect if you read SLPJ's book) and ``with foldr/build
+turned on'' (if you read Gill {\em et al.}'s paper on the subject).
+
+There will be at least one ``qualifier'' in the input.
+
+\begin{code}
+dsListComp :: [LStmt Id]
+ -> LHsExpr Id
+ -> Type -- Type of list elements
+ -> DsM CoreExpr
+dsListComp lquals body elt_ty
+ = getDOptsDs `thenDs` \dflags ->
+ let
+ quals = map unLoc lquals
+ in
+ if opt_RulesOff || dopt Opt_IgnoreInterfacePragmas dflags
+ -- Either rules are switched off, or we are ignoring what there are;
+ -- Either way foldr/build won't happen, so use the more efficient
+ -- Wadler-style desugaring
+ || isParallelComp quals
+ -- Foldr-style desugaring can't handle
+ -- parallel list comprehensions
+ then deListComp quals body (mkNilExpr elt_ty)
+
+ else -- Foldr/build should be enabled, so desugar
+ -- into foldrs and builds
+ newTyVarsDs [alphaTyVar] `thenDs` \ [n_tyvar] ->
+ let
+ n_ty = mkTyVarTy n_tyvar
+ c_ty = mkFunTys [elt_ty, n_ty] n_ty
+ in
+ newSysLocalsDs [c_ty,n_ty] `thenDs` \ [c, n] ->
+ dfListComp c n quals body `thenDs` \ result ->
+ dsLookupGlobalId buildName `thenDs` \ build_id ->
+ returnDs (Var build_id `App` Type elt_ty
+ `App` mkLams [n_tyvar, c, n] result)
+
+ where isParallelComp (ParStmt bndrstmtss : _) = True
+ isParallelComp _ = False
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[DsListComp-ordinary]{Ordinary desugaring of list comprehensions}
+%* *
+%************************************************************************
+
+Just as in Phil's chapter~7 in SLPJ, using the rules for
+optimally-compiled list comprehensions. This is what Kevin followed
+as well, and I quite happily do the same. The TQ translation scheme
+transforms a list of qualifiers (either boolean expressions or
+generators) into a single expression which implements the list
+comprehension. Because we are generating 2nd-order polymorphic
+lambda-calculus, calls to NIL and CONS must be applied to a type
+argument, as well as their usual value arguments.
+\begin{verbatim}
+TE << [ e | qs ] >> = TQ << [ e | qs ] ++ Nil (typeOf e) >>
+
+(Rule C)
+TQ << [ e | ] ++ L >> = Cons (typeOf e) TE <<e>> TE <<L>>
+
+(Rule B)
+TQ << [ e | b , qs ] ++ L >> =
+ if TE << b >> then TQ << [ e | qs ] ++ L >> else TE << L >>
+
+(Rule A')
+TQ << [ e | p <- L1, qs ] ++ L2 >> =
+ letrec
+ h = \ u1 ->
+ case u1 of
+ [] -> TE << L2 >>
+ (u2 : u3) ->
+ (( \ TE << p >> -> ( TQ << [e | qs] ++ (h u3) >> )) u2)
+ [] (h u3)
+ in
+ h ( TE << L1 >> )
+
+"h", "u1", "u2", and "u3" are new variables.
+\end{verbatim}
+
+@deListComp@ is the TQ translation scheme. Roughly speaking, @dsExpr@
+is the TE translation scheme. Note that we carry around the @L@ list
+already desugared. @dsListComp@ does the top TE rule mentioned above.
+
+To the above, we add an additional rule to deal with parallel list
+comprehensions. The translation goes roughly as follows:
+ [ e | p1 <- e11, let v1 = e12, p2 <- e13
+ | q1 <- e21, let v2 = e22, q2 <- e23]
+ =>
+ [ e | ((x1, .., xn), (y1, ..., ym)) <-
+ zip [(x1,..,xn) | p1 <- e11, let v1 = e12, p2 <- e13]
+ [(y1,..,ym) | q1 <- e21, let v2 = e22, q2 <- e23]]
+where (x1, .., xn) are the variables bound in p1, v1, p2
+ (y1, .., ym) are the variables bound in q1, v2, q2
+
+In the translation below, the ParStmt branch translates each parallel branch
+into a sub-comprehension, and desugars each independently. The resulting lists
+are fed to a zip function, we create a binding for all the variables bound in all
+the comprehensions, and then we hand things off the the desugarer for bindings.
+The zip function is generated here a) because it's small, and b) because then we
+don't have to deal with arbitrary limits on the number of zip functions in the
+prelude, nor which library the zip function came from.
+The introduced tuples are Boxed, but only because I couldn't get it to work
+with the Unboxed variety.
+
+\begin{code}
+deListComp :: [Stmt Id] -> LHsExpr Id -> CoreExpr -> DsM CoreExpr
+
+deListComp (ParStmt stmtss_w_bndrs : quals) body list
+ = mappM do_list_comp stmtss_w_bndrs `thenDs` \ exps ->
+ mkZipBind qual_tys `thenDs` \ (zip_fn, zip_rhs) ->
+
+ -- Deal with [e | pat <- zip l1 .. ln] in example above
+ deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps))
+ quals body list
+
+ where
+ bndrs_s = map snd stmtss_w_bndrs
+
+ -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
+ pat = mkTuplePat pats
+ pats = map mk_hs_tuple_pat bndrs_s
+
+ -- Types of (x1,..,xn), (y1,..,yn) etc
+ qual_tys = map mk_bndrs_tys bndrs_s
+
+ do_list_comp (stmts, bndrs)
+ = dsListComp stmts (mk_hs_tuple_expr bndrs)
+ (mk_bndrs_tys bndrs)
+
+ mk_bndrs_tys bndrs = mkCoreTupTy (map idType bndrs)
+
+ -- Last: the one to return
+deListComp [] body list -- Figure 7.4, SLPJ, p 135, rule C above
+ = dsLExpr body `thenDs` \ core_body ->
+ returnDs (mkConsExpr (exprType core_body) core_body list)
+
+ -- Non-last: must be a guard
+deListComp (ExprStmt guard _ _ : quals) body list -- rule B above
+ = dsLExpr guard `thenDs` \ core_guard ->
+ deListComp quals body list `thenDs` \ core_rest ->
+ returnDs (mkIfThenElse core_guard core_rest list)
+
+-- [e | let B, qs] = let B in [e | qs]
+deListComp (LetStmt binds : quals) body list
+ = deListComp quals body list `thenDs` \ core_rest ->
+ dsLocalBinds binds core_rest
+
+deListComp (BindStmt pat list1 _ _ : quals) body core_list2 -- rule A' above
+ = dsLExpr list1 `thenDs` \ core_list1 ->
+ deBindComp pat core_list1 quals body core_list2
+\end{code}
+
+
+\begin{code}
+deBindComp pat core_list1 quals body core_list2
+ = let
+ u3_ty@u1_ty = exprType core_list1 -- two names, same thing
+
+ -- u1_ty is a [alpha] type, and u2_ty = alpha
+ u2_ty = hsPatType pat
+
+ res_ty = exprType core_list2
+ h_ty = u1_ty `mkFunTy` res_ty
+ in
+ newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty] `thenDs` \ [h, u1, u2, u3] ->
+
+ -- the "fail" value ...
+ let
+ core_fail = App (Var h) (Var u3)
+ letrec_body = App (Var h) core_list1
+ in
+ deListComp quals body core_fail `thenDs` \ rest_expr ->
+ matchSimply (Var u2) (StmtCtxt ListComp) pat
+ rest_expr core_fail `thenDs` \ core_match ->
+ let
+ rhs = Lam u1 $
+ Case (Var u1) u1 res_ty
+ [(DataAlt nilDataCon, [], core_list2),
+ (DataAlt consDataCon, [u2, u3], core_match)]
+ -- Increasing order of tag
+ in
+ returnDs (Let (Rec [(h, rhs)]) letrec_body)
+\end{code}
+
+
+\begin{code}
+mkZipBind :: [Type] -> DsM (Id, CoreExpr)
+-- mkZipBind [t1, t2]
+-- = (zip, \as1:[t1] as2:[t2]
+-- -> case as1 of
+-- [] -> []
+-- (a1:as'1) -> case as2 of
+-- [] -> []
+-- (a2:as'2) -> (a2,a2) : zip as'1 as'2)]
+
+mkZipBind elt_tys
+ = mappM newSysLocalDs list_tys `thenDs` \ ass ->
+ mappM newSysLocalDs elt_tys `thenDs` \ as' ->
+ mappM newSysLocalDs list_tys `thenDs` \ as's ->
+ newSysLocalDs zip_fn_ty `thenDs` \ zip_fn ->
+ let
+ inner_rhs = mkConsExpr ret_elt_ty
+ (mkCoreTup (map Var as'))
+ (mkVarApps (Var zip_fn) as's)
+ zip_body = foldr mk_case inner_rhs (zip3 ass as' as's)
+ in
+ returnDs (zip_fn, mkLams ass zip_body)
+ where
+ list_tys = map mkListTy elt_tys
+ ret_elt_ty = mkCoreTupTy elt_tys
+ list_ret_ty = mkListTy ret_elt_ty
+ zip_fn_ty = mkFunTys list_tys list_ret_ty
+
+ mk_case (as, a', as') rest
+ = Case (Var as) as list_ret_ty
+ [(DataAlt nilDataCon, [], mkNilExpr ret_elt_ty),
+ (DataAlt consDataCon, [a', as'], rest)]
+ -- Increasing order of tag
+-- Helper functions that makes an HsTuple only for non-1-sized tuples
+mk_hs_tuple_expr :: [Id] -> LHsExpr Id
+mk_hs_tuple_expr [] = nlHsVar unitDataConId
+mk_hs_tuple_expr [id] = nlHsVar id
+mk_hs_tuple_expr ids = noLoc $ ExplicitTuple [ nlHsVar i | i <- ids ] Boxed
+
+mk_hs_tuple_pat :: [Id] -> LPat Id
+mk_hs_tuple_pat bs = mkTuplePat (map nlVarPat bs)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions}
+%* *
+%************************************************************************
+
+@dfListComp@ are the rules used with foldr/build turned on:
+
+\begin{verbatim}
+TE[ e | ] c n = c e n
+TE[ e | b , q ] c n = if b then TE[ e | q ] c n else n
+TE[ e | p <- l , q ] c n = let
+ f = \ x b -> case x of
+ p -> TE[ e | q ] c b
+ _ -> b
+ in
+ foldr f n l
+\end{verbatim}
+
+\begin{code}
+dfListComp :: Id -> Id -- 'c' and 'n'
+ -> [Stmt Id] -- the rest of the qual's
+ -> LHsExpr Id
+ -> DsM CoreExpr
+
+ -- Last: the one to return
+dfListComp c_id n_id [] body
+ = dsLExpr body `thenDs` \ core_body ->
+ returnDs (mkApps (Var c_id) [core_body, Var n_id])
+
+ -- Non-last: must be a guard
+dfListComp c_id n_id (ExprStmt guard _ _ : quals) body
+ = dsLExpr guard `thenDs` \ core_guard ->
+ dfListComp c_id n_id quals body `thenDs` \ core_rest ->
+ returnDs (mkIfThenElse core_guard core_rest (Var n_id))
+
+dfListComp c_id n_id (LetStmt binds : quals) body
+ -- new in 1.3, local bindings
+ = dfListComp c_id n_id quals body `thenDs` \ core_rest ->
+ dsLocalBinds binds core_rest
+
+dfListComp c_id n_id (BindStmt pat list1 _ _ : quals) body
+ -- evaluate the two lists
+ = dsLExpr list1 `thenDs` \ core_list1 ->
+
+ -- find the required type
+ let x_ty = hsPatType pat
+ b_ty = idType n_id
+ in
+
+ -- create some new local id's
+ newSysLocalsDs [b_ty,x_ty] `thenDs` \ [b,x] ->
+
+ -- build rest of the comprehesion
+ dfListComp c_id b quals body `thenDs` \ core_rest ->
+
+ -- build the pattern match
+ matchSimply (Var x) (StmtCtxt ListComp)
+ pat core_rest (Var b) `thenDs` \ core_expr ->
+
+ -- now build the outermost foldr, and return
+ dsLookupGlobalId foldrName `thenDs` \ foldr_id ->
+ returnDs (
+ Var foldr_id `App` Type x_ty
+ `App` Type b_ty
+ `App` mkLams [x, b] core_expr
+ `App` Var n_id
+ `App` core_list1
+ )
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[DsPArrComp]{Desugaring of array comprehensions}
+%* *
+%************************************************************************
+
+\begin{code}
+
+-- entry point for desugaring a parallel array comprehension
+--
+-- [:e | qss:] = <<[:e | qss:]>> () [:():]
+--
+dsPArrComp :: [Stmt Id]
+ -> LHsExpr Id
+ -> Type -- Don't use; called with `undefined' below
+ -> DsM CoreExpr
+dsPArrComp qs body _ =
+ dsLookupGlobalId replicatePName `thenDs` \repP ->
+ let unitArray = mkApps (Var repP) [Type unitTy,
+ mkIntExpr 1,
+ mkCoreTup []]
+ in
+ dePArrComp qs body (mkTuplePat []) unitArray
+
+-- the work horse
+--
+dePArrComp :: [Stmt Id]
+ -> LHsExpr Id
+ -> LPat Id -- the current generator pattern
+ -> CoreExpr -- the current generator expression
+ -> DsM CoreExpr
+--
+-- <<[:e' | :]>> pa ea = mapP (\pa -> e') ea
+--
+dePArrComp [] e' pa cea =
+ dsLookupGlobalId mapPName `thenDs` \mapP ->
+ let ty = parrElemType cea
+ in
+ deLambda ty pa e' `thenDs` \(clam,
+ ty'e') ->
+ returnDs $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea]
+--
+-- <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea)
+--
+dePArrComp (ExprStmt b _ _ : qs) body pa cea =
+ dsLookupGlobalId filterPName `thenDs` \filterP ->
+ let ty = parrElemType cea
+ in
+ deLambda ty pa b `thenDs` \(clam,_) ->
+ dePArrComp qs body pa (mkApps (Var filterP) [Type ty, clam, cea])
+--
+-- <<[:e' | p <- e, qs:]>> pa ea =
+-- let ef = filterP (\x -> case x of {p -> True; _ -> False}) e
+-- in
+-- <<[:e' | qs:]>> (pa, p) (crossP ea ef)
+--
+dePArrComp (BindStmt p e _ _ : qs) body pa cea =
+ dsLookupGlobalId filterPName `thenDs` \filterP ->
+ dsLookupGlobalId crossPName `thenDs` \crossP ->
+ dsLExpr e `thenDs` \ce ->
+ let ty'cea = parrElemType cea
+ ty'ce = parrElemType ce
+ false = Var falseDataConId
+ true = Var trueDataConId
+ in
+ newSysLocalDs ty'ce `thenDs` \v ->
+ matchSimply (Var v) (StmtCtxt PArrComp) p true false `thenDs` \pred ->
+ let cef = mkApps (Var filterP) [Type ty'ce, mkLams [v] pred, ce]
+ ty'cef = ty'ce -- filterP preserves the type
+ pa' = mkTuplePat [pa, p]
+ in
+ dePArrComp qs body pa' (mkApps (Var crossP) [Type ty'cea, Type ty'cef, cea, cef])
+--
+-- <<[:e' | let ds, qs:]>> pa ea =
+-- <<[:e' | qs:]>> (pa, (x_1, ..., x_n))
+-- (mapP (\v@pa -> (v, let ds in (x_1, ..., x_n))) ea)
+-- where
+-- {x_1, ..., x_n} = DV (ds) -- Defined Variables
+--
+dePArrComp (LetStmt ds : qs) body pa cea =
+ dsLookupGlobalId mapPName `thenDs` \mapP ->
+ let xs = map unLoc (collectLocalBinders ds)
+ ty'cea = parrElemType cea
+ in
+ newSysLocalDs ty'cea `thenDs` \v ->
+ dsLocalBinds ds (mkCoreTup (map Var xs)) `thenDs` \clet ->
+ newSysLocalDs (exprType clet) `thenDs` \let'v ->
+ let projBody = mkDsLet (NonRec let'v clet) $
+ mkCoreTup [Var v, Var let'v]
+ errTy = exprType projBody
+ errMsg = "DsListComp.dePArrComp: internal error!"
+ in
+ mkErrorAppDs pAT_ERROR_ID errTy errMsg `thenDs` \cerr ->
+ matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr`thenDs` \ccase ->
+ let pa' = mkTuplePat [pa, mkTuplePat (map nlVarPat xs)]
+ proj = mkLams [v] ccase
+ in
+ dePArrComp qs body pa' (mkApps (Var mapP) [Type ty'cea, proj, cea])
+--
+-- <<[:e' | qs | qss:]>> pa ea =
+-- <<[:e' | qss:]>> (pa, (x_1, ..., x_n))
+-- (zipP ea <<[:(x_1, ..., x_n) | qs:]>>)
+-- where
+-- {x_1, ..., x_n} = DV (qs)
+--
+dePArrComp (ParStmt qss : qs) body pa cea =
+ dsLookupGlobalId crossPName `thenDs` \crossP ->
+ deParStmt qss `thenDs` \(pQss,
+ ceQss) ->
+ let ty'cea = parrElemType cea
+ ty'ceQss = parrElemType ceQss
+ pa' = mkTuplePat [pa, pQss]
+ in
+ dePArrComp qs body pa' (mkApps (Var crossP) [Type ty'cea, Type ty'ceQss,
+ cea, ceQss])
+ where
+ deParStmt [] =
+ -- empty parallel statement lists have not source representation
+ panic "DsListComp.dePArrComp: Empty parallel list comprehension"
+ deParStmt ((qs, xs):qss) = -- first statement
+ let res_expr = mkExplicitTuple (map nlHsVar xs)
+ in
+ dsPArrComp (map unLoc qs) res_expr undefined `thenDs` \cqs ->
+ parStmts qss (mkTuplePat (map nlVarPat xs)) cqs
+ ---
+ parStmts [] pa cea = return (pa, cea)
+ parStmts ((qs, xs):qss) pa cea = -- subsequent statements (zip'ed)
+ dsLookupGlobalId zipPName `thenDs` \zipP ->
+ let pa' = mkTuplePat [pa, mkTuplePat (map nlVarPat xs)]
+ ty'cea = parrElemType cea
+ res_expr = mkExplicitTuple (map nlHsVar xs)
+ in
+ dsPArrComp (map unLoc qs) res_expr undefined `thenDs` \cqs ->
+ let ty'cqs = parrElemType cqs
+ cea' = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs]
+ in
+ parStmts qss pa' cea'
+
+-- generate Core corresponding to `\p -> e'
+--
+deLambda :: Type -- type of the argument
+ -> LPat Id -- argument pattern
+ -> LHsExpr Id -- body
+ -> DsM (CoreExpr, Type)
+deLambda ty p e =
+ newSysLocalDs ty `thenDs` \v ->
+ dsLExpr e `thenDs` \ce ->
+ let errTy = exprType ce
+ errMsg = "DsListComp.deLambda: internal error!"
+ in
+ mkErrorAppDs pAT_ERROR_ID errTy errMsg `thenDs` \cerr ->
+ matchSimply (Var v) (StmtCtxt PArrComp) p ce cerr `thenDs` \res ->
+ returnDs (mkLams [v] res, errTy)
+
+-- obtain the element type of the parallel array produced by the given Core
+-- expression
+--
+parrElemType :: CoreExpr -> Type
+parrElemType e =
+ case splitTyConApp_maybe (exprType e) of
+ Just (tycon, [ty]) | tycon == parrTyCon -> ty
+ _ -> panic
+ "DsListComp.parrElemType: not a parallel array type"
+
+-- Smart constructor for source tuple patterns
+--
+mkTuplePat :: [LPat Id] -> LPat Id
+mkTuplePat [lpat] = lpat
+mkTuplePat lpats = noLoc $ mkVanillaTuplePat lpats Boxed
+
+-- Smart constructor for source tuple expressions
+--
+mkExplicitTuple :: [LHsExpr id] -> LHsExpr id
+mkExplicitTuple [lexp] = lexp
+mkExplicitTuple lexps = noLoc $ ExplicitTuple lexps Boxed
+\end{code}
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
new file mode 100644
index 0000000000..88b0ba9c8e
--- /dev/null
+++ b/compiler/deSugar/DsMeta.hs
@@ -0,0 +1,1732 @@
+-----------------------------------------------------------------------------
+-- The purpose of this module is to transform an HsExpr into a CoreExpr which
+-- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the
+-- input HsExpr. We do this in the DsM monad, which supplies access to
+-- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.
+--
+-- It also defines a bunch of knownKeyNames, in the same way as is done
+-- in prelude/PrelNames. It's much more convenient to do it here, becuase
+-- otherwise we have to recompile PrelNames whenever we add a Name, which is
+-- a Royal Pain (triggers other recompilation).
+-----------------------------------------------------------------------------
+
+
+module DsMeta( dsBracket,
+ templateHaskellNames, qTyConName, nameTyConName,
+ liftName, expQTyConName, decQTyConName, typeQTyConName,
+ decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName
+ ) where
+
+#include "HsVersions.h"
+
+import {-# SOURCE #-} DsExpr ( dsExpr )
+
+import MatchLit ( dsLit )
+import DsUtils ( mkListExpr, mkStringExpr, mkCoreTup, mkIntExpr )
+import DsMonad
+
+import qualified Language.Haskell.TH as TH
+
+import HsSyn
+import Class (FunDep)
+import PrelNames ( rationalTyConName, integerTyConName, negateName )
+import OccName ( isDataOcc, isTvOcc, occNameString )
+-- To avoid clashes with DsMeta.varName we must make a local alias for OccName.varName
+-- we do this by removing varName from the import of OccName above, making
+-- a qualified instance of OccName and using OccNameAlias.varName where varName
+-- ws previously used in this file.
+import qualified OccName
+
+import Module ( Module, mkModule, moduleString )
+import Id ( Id, mkLocalId )
+import OccName ( mkOccNameFS )
+import Name ( Name, mkExternalName, localiseName, nameOccName, nameModule,
+ isExternalName, getSrcLoc )
+import NameEnv
+import Type ( Type, mkTyConApp )
+import TcType ( tcTyConAppArgs )
+import TyCon ( tyConName )
+import TysWiredIn ( parrTyCon )
+import CoreSyn
+import CoreUtils ( exprType )
+import SrcLoc ( noSrcLoc, unLoc, Located(..), SrcSpan, srcLocSpan )
+import Maybe ( catMaybes )
+import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique, getKey, Uniquable(..) )
+import BasicTypes ( isBoxed )
+import Outputable
+import Bag ( bagToList, unionManyBags )
+import FastString ( unpackFS )
+import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..) )
+
+import Monad ( zipWithM )
+import List ( sortBy )
+
+-----------------------------------------------------------------------------
+dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
+-- Returns a CoreExpr of type TH.ExpQ
+-- The quoted thing is parameterised over Name, even though it has
+-- been type checked. We don't want all those type decorations!
+
+dsBracket brack splices
+ = dsExtendMetaEnv new_bit (do_brack brack)
+ where
+ new_bit = mkNameEnv [(n, Splice (unLoc e)) | (n,e) <- splices]
+
+ do_brack (VarBr n) = do { MkC e1 <- lookupOcc n ; return e1 }
+ do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 }
+ do_brack (PatBr p) = do { MkC p1 <- repLP p ; return p1 }
+ do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 }
+ do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 }
+
+{- -------------- Examples --------------------
+
+ [| \x -> x |]
+====>
+ gensym (unpackString "x"#) `bindQ` \ x1::String ->
+ lam (pvar x1) (var x1)
+
+
+ [| \x -> $(f [| x |]) |]
+====>
+ gensym (unpackString "x"#) `bindQ` \ x1::String ->
+ lam (pvar x1) (f (var x1))
+-}
+
+
+-------------------------------------------------------
+-- Declarations
+-------------------------------------------------------
+
+repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
+repTopDs group
+ = do { let { bndrs = map unLoc (groupBinders group) } ;
+ ss <- mkGenSyms bndrs ;
+
+ -- Bind all the names mainly to avoid repeated use of explicit strings.
+ -- Thus we get
+ -- do { t :: String <- genSym "T" ;
+ -- return (Data t [] ...more t's... }
+ -- The other important reason is that the output must mention
+ -- only "T", not "Foo:T" where Foo is the current module
+
+
+ decls <- addBinds ss (do {
+ val_ds <- rep_val_binds (hs_valds group) ;
+ tycl_ds <- mapM repTyClD (hs_tyclds group) ;
+ inst_ds <- mapM repInstD' (hs_instds group) ;
+ for_ds <- mapM repForD (hs_fords group) ;
+ -- more needed
+ return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds ++ for_ds) }) ;
+
+ decl_ty <- lookupType decQTyConName ;
+ let { core_list = coreList' decl_ty decls } ;
+
+ dec_ty <- lookupType decTyConName ;
+ q_decs <- repSequenceQ dec_ty core_list ;
+
+ wrapNongenSyms ss q_decs
+ -- Do *not* gensym top-level binders
+ }
+
+groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
+ hs_fords = foreign_decls })
+-- Collect the binders of a Group
+ = collectHsValBinders val_decls ++
+ [n | d <- tycl_decls, n <- tyClDeclNames (unLoc d)] ++
+ [n | L _ (ForeignImport n _ _ _) <- foreign_decls]
+
+
+{- Note [Binders and occurrences]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we desugar [d| data T = MkT |]
+we want to get
+ Data "T" [] [Con "MkT" []] []
+and *not*
+ Data "Foo:T" [] [Con "Foo:MkT" []] []
+That is, the new data decl should fit into whatever new module it is
+asked to fit in. We do *not* clone, though; no need for this:
+ Data "T79" ....
+
+But if we see this:
+ data T = MkT
+ foo = reifyDecl T
+
+then we must desugar to
+ foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
+
+So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
+And we use lookupOcc, rather than lookupBinder
+in repTyClD and repC.
+
+-}
+
+repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
+
+repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt,
+ tcdLName = tc, tcdTyVars = tvs,
+ tcdCons = cons, tcdDerivs = mb_derivs }))
+ = do { tc1 <- lookupLOcc tc ; -- See note [Binders and occurrences]
+ dec <- addTyVarBinds tvs $ \bndrs -> do {
+ cxt1 <- repLContext cxt ;
+ cons1 <- mapM repC cons ;
+ cons2 <- coreList conQTyConName cons1 ;
+ derivs1 <- repDerivs mb_derivs ;
+ bndrs1 <- coreList nameTyConName bndrs ;
+ repData cxt1 tc1 bndrs1 cons2 derivs1 } ;
+ return $ Just (loc, dec) }
+
+repTyClD (L loc (TyData { tcdND = NewType, tcdCtxt = cxt,
+ tcdLName = tc, tcdTyVars = tvs,
+ tcdCons = [con], tcdDerivs = mb_derivs }))
+ = do { tc1 <- lookupLOcc tc ; -- See note [Binders and occurrences]
+ dec <- addTyVarBinds tvs $ \bndrs -> do {
+ cxt1 <- repLContext cxt ;
+ con1 <- repC con ;
+ derivs1 <- repDerivs mb_derivs ;
+ bndrs1 <- coreList nameTyConName bndrs ;
+ repNewtype cxt1 tc1 bndrs1 con1 derivs1 } ;
+ return $ Just (loc, dec) }
+
+repTyClD (L loc (TySynonym { tcdLName = tc, tcdTyVars = tvs, tcdSynRhs = ty }))
+ = do { tc1 <- lookupLOcc tc ; -- See note [Binders and occurrences]
+ dec <- addTyVarBinds tvs $ \bndrs -> do {
+ ty1 <- repLTy ty ;
+ bndrs1 <- coreList nameTyConName bndrs ;
+ repTySyn tc1 bndrs1 ty1 } ;
+ return (Just (loc, dec)) }
+
+repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
+ tcdTyVars = tvs,
+ tcdFDs = fds,
+ tcdSigs = sigs, tcdMeths = meth_binds }))
+ = do { cls1 <- lookupLOcc cls ; -- See note [Binders and occurrences]
+ dec <- addTyVarBinds tvs $ \bndrs -> do {
+ cxt1 <- repLContext cxt ;
+ sigs1 <- rep_sigs sigs ;
+ binds1 <- rep_binds meth_binds ;
+ fds1 <- repLFunDeps fds;
+ decls1 <- coreList decQTyConName (sigs1 ++ binds1) ;
+ bndrs1 <- coreList nameTyConName bndrs ;
+ repClass cxt1 cls1 bndrs1 fds1 decls1 } ;
+ return $ Just (loc, dec) }
+
+-- Un-handled cases
+repTyClD (L loc d) = putSrcSpanDs loc $
+ do { dsWarn (hang ds_msg 4 (ppr d))
+ ; return Nothing }
+
+-- represent fundeps
+--
+repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])
+repLFunDeps fds = do fds' <- mapM repLFunDep fds
+ fdList <- coreList funDepTyConName fds'
+ return fdList
+
+repLFunDep :: Located (FunDep Name) -> DsM (Core TH.FunDep)
+repLFunDep (L _ (xs, ys)) = do xs' <- mapM lookupBinder xs
+ ys' <- mapM lookupBinder ys
+ xs_list <- coreList nameTyConName xs'
+ ys_list <- coreList nameTyConName ys'
+ repFunDep xs_list ys_list
+
+repInstD' (L loc (InstDecl ty binds _)) -- Ignore user pragmas for now
+ = do { i <- addTyVarBinds tvs $ \tv_bndrs ->
+ -- We must bring the type variables into scope, so their occurrences
+ -- don't fail, even though the binders don't appear in the resulting
+ -- data structure
+ do { cxt1 <- repContext cxt
+ ; inst_ty1 <- repPred (HsClassP cls tys)
+ ; ss <- mkGenSyms (collectHsBindBinders binds)
+ ; binds1 <- addBinds ss (rep_binds binds)
+ ; decls1 <- coreList decQTyConName binds1
+ ; decls2 <- wrapNongenSyms ss decls1
+ -- wrapNonGenSyms: do not clone the class op names!
+ -- They must be called 'op' etc, not 'op34'
+ ; repInst cxt1 inst_ty1 decls2 }
+
+ ; return (loc, i)}
+ where
+ (tvs, cxt, cls, tys) = splitHsInstDeclTy (unLoc ty)
+
+repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
+repForD (L loc (ForeignImport name typ (CImport cc s ch cn cis) _))
+ = do MkC name' <- lookupLOcc name
+ MkC typ' <- repLTy typ
+ MkC cc' <- repCCallConv cc
+ MkC s' <- repSafety s
+ MkC str <- coreStringLit $ static
+ ++ unpackFS ch ++ " "
+ ++ unpackFS cn ++ " "
+ ++ conv_cimportspec cis
+ dec <- rep2 forImpDName [cc', s', str, name', typ']
+ return (loc, dec)
+ where
+ conv_cimportspec (CLabel cls) = panic "repForD': CLabel Not handled"
+ conv_cimportspec (CFunction DynamicTarget) = "dynamic"
+ conv_cimportspec (CFunction (StaticTarget fs)) = unpackFS fs
+ conv_cimportspec CWrapper = "wrapper"
+ static = case cis of
+ CFunction (StaticTarget _) -> "static "
+ _ -> ""
+
+repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
+repCCallConv CCallConv = rep2 cCallName []
+repCCallConv StdCallConv = rep2 stdCallName []
+
+repSafety :: Safety -> DsM (Core TH.Safety)
+repSafety PlayRisky = rep2 unsafeName []
+repSafety (PlaySafe False) = rep2 safeName []
+repSafety (PlaySafe True) = rep2 threadsafeName []
+
+ds_msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")
+
+-------------------------------------------------------
+-- Constructors
+-------------------------------------------------------
+
+repC :: LConDecl Name -> DsM (Core TH.ConQ)
+repC (L loc (ConDecl con expl [] (L _ []) details ResTyH98))
+ = do { con1 <- lookupLOcc con ; -- See note [Binders and occurrences]
+ repConstr con1 details }
+repC (L loc (ConDecl con expl tvs (L cloc ctxt) details ResTyH98))
+ = do { addTyVarBinds tvs $ \bndrs -> do {
+ c' <- repC (L loc (ConDecl con expl [] (L cloc []) details ResTyH98));
+ ctxt' <- repContext ctxt;
+ bndrs' <- coreList nameTyConName bndrs;
+ rep2 forallCName [unC bndrs', unC ctxt', unC c']
+ }
+ }
+repC (L loc con_decl) -- GADTs
+ = putSrcSpanDs loc $
+ do { dsWarn (hang ds_msg 4 (ppr con_decl))
+ ; return (panic "DsMeta:repC") }
+
+repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
+repBangTy ty= do
+ MkC s <- rep2 str []
+ MkC t <- repLTy ty'
+ rep2 strictTypeName [s, t]
+ where
+ (str, ty') = case ty of
+ L _ (HsBangTy _ ty) -> (isStrictName, ty)
+ other -> (notStrictName, ty)
+
+-------------------------------------------------------
+-- Deriving clause
+-------------------------------------------------------
+
+repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name])
+repDerivs Nothing = coreList nameTyConName []
+repDerivs (Just ctxt)
+ = do { strs <- mapM rep_deriv ctxt ;
+ coreList nameTyConName strs }
+ where
+ rep_deriv :: LHsType Name -> DsM (Core TH.Name)
+ -- Deriving clauses must have the simple H98 form
+ rep_deriv (L _ (HsPredTy (HsClassP cls []))) = lookupOcc cls
+ rep_deriv other = panic "rep_deriv"
+
+
+-------------------------------------------------------
+-- Signatures in a class decl, or a group of bindings
+-------------------------------------------------------
+
+rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]
+rep_sigs sigs = do locs_cores <- rep_sigs' sigs
+ return $ de_loc $ sort_by_loc locs_cores
+
+rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)]
+ -- We silently ignore ones we don't recognise
+rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
+ return (concat sigs1) }
+
+rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
+ -- Singleton => Ok
+ -- Empty => Too hard, signature ignored
+rep_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc
+rep_sig other = return []
+
+rep_proto :: Located Name -> LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
+rep_proto nm ty loc = do { nm1 <- lookupLOcc nm ;
+ ty1 <- repLTy ty ;
+ sig <- repProto nm1 ty1 ;
+ return [(loc, sig)] }
+
+
+-------------------------------------------------------
+-- Types
+-------------------------------------------------------
+
+-- gensym a list of type variables and enter them into the meta environment;
+-- the computations passed as the second argument is executed in that extended
+-- meta environment and gets the *new* names on Core-level as an argument
+--
+addTyVarBinds :: [LHsTyVarBndr Name] -- the binders to be added
+ -> ([Core TH.Name] -> DsM (Core (TH.Q a))) -- action in the ext env
+ -> DsM (Core (TH.Q a))
+addTyVarBinds tvs m =
+ do
+ let names = map (hsTyVarName.unLoc) tvs
+ freshNames <- mkGenSyms names
+ term <- addBinds freshNames $ do
+ bndrs <- mapM lookupBinder names
+ m bndrs
+ wrapGenSyns freshNames term
+
+-- represent a type context
+--
+repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
+repLContext (L _ ctxt) = repContext ctxt
+
+repContext :: HsContext Name -> DsM (Core TH.CxtQ)
+repContext ctxt = do
+ preds <- mapM repLPred ctxt
+ predList <- coreList typeQTyConName preds
+ repCtxt predList
+
+-- represent a type predicate
+--
+repLPred :: LHsPred Name -> DsM (Core TH.TypeQ)
+repLPred (L _ p) = repPred p
+
+repPred :: HsPred Name -> DsM (Core TH.TypeQ)
+repPred (HsClassP cls tys) = do
+ tcon <- repTy (HsTyVar cls)
+ tys1 <- repLTys tys
+ repTapps tcon tys1
+repPred (HsIParam _ _) =
+ panic "DsMeta.repTy: Can't represent predicates with implicit parameters"
+
+-- yield the representation of a list of types
+--
+repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
+repLTys tys = mapM repLTy tys
+
+-- represent a type
+--
+repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
+repLTy (L _ ty) = repTy ty
+
+repTy :: HsType Name -> DsM (Core TH.TypeQ)
+repTy (HsForAllTy _ tvs ctxt ty) =
+ addTyVarBinds tvs $ \bndrs -> do
+ ctxt1 <- repLContext ctxt
+ ty1 <- repLTy ty
+ bndrs1 <- coreList nameTyConName bndrs
+ repTForall bndrs1 ctxt1 ty1
+
+repTy (HsTyVar n)
+ | isTvOcc (nameOccName n) = do
+ tv1 <- lookupBinder n
+ repTvar tv1
+ | otherwise = do
+ tc1 <- lookupOcc n
+ repNamedTyCon tc1
+repTy (HsAppTy f a) = do
+ f1 <- repLTy f
+ a1 <- repLTy a
+ repTapp f1 a1
+repTy (HsFunTy f a) = do
+ f1 <- repLTy f
+ a1 <- repLTy a
+ tcon <- repArrowTyCon
+ repTapps tcon [f1, a1]
+repTy (HsListTy t) = do
+ t1 <- repLTy t
+ tcon <- repListTyCon
+ repTapp tcon t1
+repTy (HsPArrTy t) = do
+ t1 <- repLTy t
+ tcon <- repTy (HsTyVar (tyConName parrTyCon))
+ repTapp tcon t1
+repTy (HsTupleTy tc tys) = do
+ tys1 <- repLTys tys
+ tcon <- repTupleTyCon (length tys)
+ repTapps tcon tys1
+repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
+ `nlHsAppTy` ty2)
+repTy (HsParTy t) = repLTy t
+repTy (HsNumTy i) =
+ panic "DsMeta.repTy: Can't represent number types (for generics)"
+repTy (HsPredTy pred) = repPred pred
+repTy (HsKindSig ty kind) =
+ panic "DsMeta.repTy: Can't represent explicit kind signatures yet"
+
+
+-----------------------------------------------------------------------------
+-- Expressions
+-----------------------------------------------------------------------------
+
+repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])
+repLEs es = do { es' <- mapM repLE es ;
+ coreList expQTyConName es' }
+
+-- FIXME: some of these panics should be converted into proper error messages
+-- unless we can make sure that constructs, which are plainly not
+-- supported in TH already lead to error messages at an earlier stage
+repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)
+repLE (L _ e) = repE e
+
+repE :: HsExpr Name -> DsM (Core TH.ExpQ)
+repE (HsVar x) =
+ do { mb_val <- dsLookupMetaEnv x
+ ; case mb_val of
+ Nothing -> do { str <- globalVar x
+ ; repVarOrCon x str }
+ Just (Bound y) -> repVarOrCon x (coreVar y)
+ Just (Splice e) -> do { e' <- dsExpr e
+ ; return (MkC e') } }
+repE (HsIPVar x) = panic "DsMeta.repE: Can't represent implicit parameters"
+
+ -- Remember, we're desugaring renamer output here, so
+ -- HsOverlit can definitely occur
+repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
+repE (HsLit l) = do { a <- repLiteral l; repLit a }
+repE (HsLam (MatchGroup [m] _)) = repLambda m
+repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b}
+
+repE (OpApp e1 op fix e2) =
+ do { arg1 <- repLE e1;
+ arg2 <- repLE e2;
+ the_op <- repLE op ;
+ repInfixApp arg1 the_op arg2 }
+repE (NegApp x nm) = do
+ a <- repLE x
+ negateVar <- lookupOcc negateName >>= repVar
+ negateVar `repApp` a
+repE (HsPar x) = repLE x
+repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
+repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
+repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e
+ ; ms2 <- mapM repMatchTup ms
+ ; repCaseE arg (nonEmptyCoreList ms2) }
+repE (HsIf x y z) = do
+ a <- repLE x
+ b <- repLE y
+ c <- repLE z
+ repCond a b c
+repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
+ ; e2 <- addBinds ss (repLE e)
+ ; z <- repLetE ds e2
+ ; wrapGenSyns ss z }
+-- FIXME: I haven't got the types here right yet
+repE (HsDo DoExpr sts body ty)
+ = do { (ss,zs) <- repLSts sts;
+ body' <- addBinds ss $ repLE body;
+ ret <- repNoBindSt body';
+ e <- repDoE (nonEmptyCoreList (zs ++ [ret]));
+ wrapGenSyns ss e }
+repE (HsDo ListComp sts body ty)
+ = do { (ss,zs) <- repLSts sts;
+ body' <- addBinds ss $ repLE body;
+ ret <- repNoBindSt body';
+ e <- repComp (nonEmptyCoreList (zs ++ [ret]));
+ wrapGenSyns ss e }
+repE (HsDo _ _ _ _) = panic "DsMeta.repE: Can't represent mdo and [: :] yet"
+repE (ExplicitList ty es) = do { xs <- repLEs es; repListExp xs }
+repE (ExplicitPArr ty es) =
+ panic "DsMeta.repE: No explicit parallel arrays yet"
+repE (ExplicitTuple es boxed)
+ | isBoxed boxed = do { xs <- repLEs es; repTup xs }
+ | otherwise = panic "DsMeta.repE: Can't represent unboxed tuples"
+repE (RecordCon c _ flds)
+ = do { x <- lookupLOcc c;
+ fs <- repFields flds;
+ repRecCon x fs }
+repE (RecordUpd e flds _ _)
+ = do { x <- repLE e;
+ fs <- repFields flds;
+ repRecUpd x fs }
+
+repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }
+repE (ArithSeq _ aseq) =
+ case aseq of
+ From e -> do { ds1 <- repLE e; repFrom ds1 }
+ FromThen e1 e2 -> do
+ ds1 <- repLE e1
+ ds2 <- repLE e2
+ repFromThen ds1 ds2
+ FromTo e1 e2 -> do
+ ds1 <- repLE e1
+ ds2 <- repLE e2
+ repFromTo ds1 ds2
+ FromThenTo e1 e2 e3 -> do
+ ds1 <- repLE e1
+ ds2 <- repLE e2
+ ds3 <- repLE e3
+ repFromThenTo ds1 ds2 ds3
+repE (PArrSeq _ aseq) = panic "DsMeta.repE: parallel array seq.s missing"
+repE (HsCoreAnn _ _) = panic "DsMeta.repE: Can't represent CoreAnn" -- hdaume: core annotations
+repE (HsSCC _ _) = panic "DsMeta.repE: Can't represent SCC"
+repE (HsBracketOut _ _) = panic "DsMeta.repE: Can't represent Oxford brackets"
+repE (HsSpliceE (HsSplice n _))
+ = do { mb_val <- dsLookupMetaEnv n
+ ; case mb_val of
+ Just (Splice e) -> do { e' <- dsExpr e
+ ; return (MkC e') }
+ other -> pprPanic "HsSplice" (ppr n) }
+
+repE e = pprPanic "DsMeta.repE: Illegal expression form" (ppr e)
+
+-----------------------------------------------------------------------------
+-- Building representations of auxillary structures like Match, Clause, Stmt,
+
+repMatchTup :: LMatch Name -> DsM (Core TH.MatchQ)
+repMatchTup (L _ (Match [p] ty (GRHSs guards wheres))) =
+ do { ss1 <- mkGenSyms (collectPatBinders p)
+ ; addBinds ss1 $ do {
+ ; p1 <- repLP p
+ ; (ss2,ds) <- repBinds wheres
+ ; addBinds ss2 $ do {
+ ; gs <- repGuards guards
+ ; match <- repMatch p1 gs ds
+ ; wrapGenSyns (ss1++ss2) match }}}
+
+repClauseTup :: LMatch Name -> DsM (Core TH.ClauseQ)
+repClauseTup (L _ (Match ps ty (GRHSs guards wheres))) =
+ do { ss1 <- mkGenSyms (collectPatsBinders ps)
+ ; addBinds ss1 $ do {
+ ps1 <- repLPs ps
+ ; (ss2,ds) <- repBinds wheres
+ ; addBinds ss2 $ do {
+ gs <- repGuards guards
+ ; clause <- repClause ps1 gs ds
+ ; wrapGenSyns (ss1++ss2) clause }}}
+
+repGuards :: [LGRHS Name] -> DsM (Core TH.BodyQ)
+repGuards [L _ (GRHS [] e)]
+ = do {a <- repLE e; repNormal a }
+repGuards other
+ = do { zs <- mapM process other;
+ let {(xs, ys) = unzip zs};
+ gd <- repGuarded (nonEmptyCoreList ys);
+ wrapGenSyns (concat xs) gd }
+ where
+ process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
+ process (L _ (GRHS [L _ (ExprStmt e1 _ _)] e2))
+ = do { x <- repLNormalGE e1 e2;
+ return ([], x) }
+ process (L _ (GRHS ss rhs))
+ = do (gs, ss') <- repLSts ss
+ rhs' <- addBinds gs $ repLE rhs
+ g <- repPatGE (nonEmptyCoreList ss') rhs'
+ return (gs, g)
+
+repFields :: [(Located Name, LHsExpr Name)] -> DsM (Core [TH.Q TH.FieldExp])
+repFields flds = do
+ fnames <- mapM lookupLOcc (map fst flds)
+ es <- mapM repLE (map snd flds)
+ fs <- zipWithM repFieldExp fnames es
+ coreList fieldExpQTyConName fs
+
+
+-----------------------------------------------------------------------------
+-- Representing Stmt's is tricky, especially if bound variables
+-- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |]
+-- First gensym new names for every variable in any of the patterns.
+-- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
+-- if variables didn't shaddow, the static gensym wouldn't be necessary
+-- and we could reuse the original names (x and x).
+--
+-- do { x'1 <- gensym "x"
+-- ; x'2 <- gensym "x"
+-- ; doE [ BindSt (pvar x'1) [| f 1 |]
+-- , BindSt (pvar x'2) [| f x |]
+-- , NoBindSt [| g x |]
+-- ]
+-- }
+
+-- The strategy is to translate a whole list of do-bindings by building a
+-- bigger environment, and a bigger set of meta bindings
+-- (like: x'1 <- gensym "x" ) and then combining these with the translations
+-- of the expressions within the Do
+
+-----------------------------------------------------------------------------
+-- The helper function repSts computes the translation of each sub expression
+-- and a bunch of prefix bindings denoting the dynamic renaming.
+
+repLSts :: [LStmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
+repLSts stmts = repSts (map unLoc stmts)
+
+repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
+repSts (BindStmt p e _ _ : ss) =
+ do { e2 <- repLE e
+ ; ss1 <- mkGenSyms (collectPatBinders p)
+ ; addBinds ss1 $ do {
+ ; p1 <- repLP p;
+ ; (ss2,zs) <- repSts ss
+ ; z <- repBindSt p1 e2
+ ; return (ss1++ss2, z : zs) }}
+repSts (LetStmt bs : ss) =
+ do { (ss1,ds) <- repBinds bs
+ ; z <- repLetSt ds
+ ; (ss2,zs) <- addBinds ss1 (repSts ss)
+ ; return (ss1++ss2, z : zs) }
+repSts (ExprStmt e _ _ : ss) =
+ do { e2 <- repLE e
+ ; z <- repNoBindSt e2
+ ; (ss2,zs) <- repSts ss
+ ; return (ss2, z : zs) }
+repSts [] = return ([],[])
+repSts other = panic "Exotic Stmt in meta brackets"
+
+
+-----------------------------------------------------------
+-- Bindings
+-----------------------------------------------------------
+
+repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ])
+repBinds EmptyLocalBinds
+ = do { core_list <- coreList decQTyConName []
+ ; return ([], core_list) }
+
+repBinds (HsIPBinds _)
+ = panic "DsMeta:repBinds: can't do implicit parameters"
+
+repBinds (HsValBinds decs)
+ = do { let { bndrs = map unLoc (collectHsValBinders decs) }
+ -- No need to worrry about detailed scopes within
+ -- the binding group, because we are talking Names
+ -- here, so we can safely treat it as a mutually
+ -- recursive group
+ ; ss <- mkGenSyms bndrs
+ ; prs <- addBinds ss (rep_val_binds decs)
+ ; core_list <- coreList decQTyConName
+ (de_loc (sort_by_loc prs))
+ ; return (ss, core_list) }
+
+rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
+-- Assumes: all the binders of the binding are alrady in the meta-env
+rep_val_binds (ValBindsOut binds sigs)
+ = do { core1 <- rep_binds' (unionManyBags (map snd binds))
+ ; core2 <- rep_sigs' sigs
+ ; return (core1 ++ core2) }
+
+rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]
+rep_binds binds = do { binds_w_locs <- rep_binds' binds
+ ; return (de_loc (sort_by_loc binds_w_locs)) }
+
+rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
+rep_binds' binds = mapM rep_bind (bagToList binds)
+
+rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
+-- Assumes: all the binders of the binding are alrady in the meta-env
+
+-- Note GHC treats declarations of a variable (not a pattern)
+-- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
+-- with an empty list of patterns
+rep_bind (L loc (FunBind { fun_id = fn,
+ fun_matches = MatchGroup [L _ (Match [] ty (GRHSs guards wheres))] _ }))
+ = do { (ss,wherecore) <- repBinds wheres
+ ; guardcore <- addBinds ss (repGuards guards)
+ ; fn' <- lookupLBinder fn
+ ; p <- repPvar fn'
+ ; ans <- repVal p guardcore wherecore
+ ; ans' <- wrapGenSyns ss ans
+ ; return (loc, ans') }
+
+rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MatchGroup ms _ }))
+ = do { ms1 <- mapM repClauseTup ms
+ ; fn' <- lookupLBinder fn
+ ; ans <- repFun fn' (nonEmptyCoreList ms1)
+ ; return (loc, ans) }
+
+rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres }))
+ = do { patcore <- repLP pat
+ ; (ss,wherecore) <- repBinds wheres
+ ; guardcore <- addBinds ss (repGuards guards)
+ ; ans <- repVal patcore guardcore wherecore
+ ; ans' <- wrapGenSyns ss ans
+ ; return (loc, ans') }
+
+rep_bind (L loc (VarBind { var_id = v, var_rhs = e}))
+ = do { v' <- lookupBinder v
+ ; e2 <- repLE e
+ ; x <- repNormal e2
+ ; patcore <- repPvar v'
+ ; empty_decls <- coreList decQTyConName []
+ ; ans <- repVal patcore x empty_decls
+ ; return (srcLocSpan (getSrcLoc v), ans) }
+
+-----------------------------------------------------------------------------
+-- Since everything in a Bind is mutually recursive we need rename all
+-- all the variables simultaneously. For example:
+-- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
+-- do { f'1 <- gensym "f"
+-- ; g'2 <- gensym "g"
+-- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
+-- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
+-- ]}
+-- This requires collecting the bindings (f'1 <- gensym "f"), and the
+-- environment ( f |-> f'1 ) from each binding, and then unioning them
+-- together. As we do this we collect GenSymBinds's which represent the renamed
+-- variables bound by the Bindings. In order not to lose track of these
+-- representations we build a shadow datatype MB with the same structure as
+-- MonoBinds, but which has slots for the representations
+
+
+-----------------------------------------------------------------------------
+-- GHC allows a more general form of lambda abstraction than specified
+-- by Haskell 98. In particular it allows guarded lambda's like :
+-- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
+-- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
+-- (\ p1 .. pn -> exp) by causing an error.
+
+repLambda :: LMatch Name -> DsM (Core TH.ExpQ)
+repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
+ = do { let bndrs = collectPatsBinders ps ;
+ ; ss <- mkGenSyms bndrs
+ ; lam <- addBinds ss (
+ do { xs <- repLPs ps; body <- repLE e; repLam xs body })
+ ; wrapGenSyns ss lam }
+
+repLambda z = panic "Can't represent a guarded lambda in Template Haskell"
+
+
+-----------------------------------------------------------------------------
+-- Patterns
+-- repP deals with patterns. It assumes that we have already
+-- walked over the pattern(s) once to collect the binders, and
+-- have extended the environment. So every pattern-bound
+-- variable should already appear in the environment.
+
+-- Process a list of patterns
+repLPs :: [LPat Name] -> DsM (Core [TH.PatQ])
+repLPs ps = do { ps' <- mapM repLP ps ;
+ coreList patQTyConName ps' }
+
+repLP :: LPat Name -> DsM (Core TH.PatQ)
+repLP (L _ p) = repP p
+
+repP :: Pat Name -> DsM (Core TH.PatQ)
+repP (WildPat _) = repPwild
+repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
+repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' }
+repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 }
+repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
+repP (ParPat p) = repLP p
+repP (ListPat ps _) = do { qs <- repLPs ps; repPlist qs }
+repP (TuplePat ps _ _) = do { qs <- repLPs ps; repPtup qs }
+repP (ConPatIn dc details)
+ = do { con_str <- lookupLOcc dc
+ ; case details of
+ PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
+ RecCon pairs -> do { vs <- sequence $ map lookupLOcc (map fst pairs)
+ ; ps <- sequence $ map repLP (map snd pairs)
+ ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
+ ; fps' <- coreList fieldPatQTyConName fps
+ ; repPrec con_str fps' }
+ InfixCon p1 p2 -> do { p1' <- repLP p1;
+ p2' <- repLP p2;
+ repPinfix p1' con_str p2' }
+ }
+repP (NPat l (Just _) _ _) = panic "Can't cope with negative overloaded patterns yet (repP (NPat _ (Just _)))"
+repP (NPat l Nothing _ _) = do { a <- repOverloadedLiteral l; repPlit a }
+repP (SigPatIn p t) = do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
+repP other = panic "Exotic pattern inside meta brackets"
+
+----------------------------------------------------------
+-- Declaration ordering helpers
+
+sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
+sort_by_loc xs = sortBy comp xs
+ where comp x y = compare (fst x) (fst y)
+
+de_loc :: [(a, b)] -> [b]
+de_loc = map snd
+
+----------------------------------------------------------
+-- The meta-environment
+
+-- A name/identifier association for fresh names of locally bound entities
+type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
+ -- I.e. (x, x_id) means
+ -- let x_id = gensym "x" in ...
+
+-- Generate a fresh name for a locally bound entity
+
+mkGenSyms :: [Name] -> DsM [GenSymBind]
+-- We can use the existing name. For example:
+-- [| \x_77 -> x_77 + x_77 |]
+-- desugars to
+-- do { x_77 <- genSym "x"; .... }
+-- We use the same x_77 in the desugared program, but with the type Bndr
+-- instead of Int
+--
+-- We do make it an Internal name, though (hence localiseName)
+--
+-- Nevertheless, it's monadic because we have to generate nameTy
+mkGenSyms ns = do { var_ty <- lookupType nameTyConName
+ ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }
+
+
+addBinds :: [GenSymBind] -> DsM a -> DsM a
+-- Add a list of fresh names for locally bound entities to the
+-- meta environment (which is part of the state carried around
+-- by the desugarer monad)
+addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
+
+-- Look up a locally bound name
+--
+lookupLBinder :: Located Name -> DsM (Core TH.Name)
+lookupLBinder (L _ n) = lookupBinder n
+
+lookupBinder :: Name -> DsM (Core TH.Name)
+lookupBinder n
+ = do { mb_val <- dsLookupMetaEnv n;
+ case mb_val of
+ Just (Bound x) -> return (coreVar x)
+ other -> pprPanic "DsMeta: failed binder lookup when desugaring a TH bracket:" (ppr n) }
+
+-- Look up a name that is either locally bound or a global name
+--
+-- * If it is a global name, generate the "original name" representation (ie,
+-- the <module>:<name> form) for the associated entity
+--
+lookupLOcc :: Located Name -> DsM (Core TH.Name)
+-- Lookup an occurrence; it can't be a splice.
+-- Use the in-scope bindings if they exist
+lookupLOcc (L _ n) = lookupOcc n
+
+lookupOcc :: Name -> DsM (Core TH.Name)
+lookupOcc n
+ = do { mb_val <- dsLookupMetaEnv n ;
+ case mb_val of
+ Nothing -> globalVar n
+ Just (Bound x) -> return (coreVar x)
+ Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n)
+ }
+
+globalVar :: Name -> DsM (Core TH.Name)
+-- Not bound by the meta-env
+-- Could be top-level; or could be local
+-- f x = $(g [| x |])
+-- Here the x will be local
+globalVar name
+ | isExternalName name
+ = do { MkC mod <- coreStringLit name_mod
+ ; MkC occ <- occNameLit name
+ ; rep2 mk_varg [mod,occ] }
+ | otherwise
+ = do { MkC occ <- occNameLit name
+ ; MkC uni <- coreIntLit (getKey (getUnique name))
+ ; rep2 mkNameLName [occ,uni] }
+ where
+ name_mod = moduleString (nameModule name)
+ name_occ = nameOccName name
+ mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
+ | OccName.isVarOcc name_occ = mkNameG_vName
+ | OccName.isTcOcc name_occ = mkNameG_tcName
+ | otherwise = pprPanic "DsMeta.globalVar" (ppr name)
+
+lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ)
+ -> DsM Type -- The type
+lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
+ return (mkTyConApp tc []) }
+
+wrapGenSyns :: [GenSymBind]
+ -> Core (TH.Q a) -> DsM (Core (TH.Q a))
+-- wrapGenSyns [(nm1,id1), (nm2,id2)] y
+-- --> bindQ (gensym nm1) (\ id1 ->
+-- bindQ (gensym nm2 (\ id2 ->
+-- y))
+
+wrapGenSyns binds body@(MkC b)
+ = do { var_ty <- lookupType nameTyConName
+ ; go var_ty binds }
+ where
+ [elt_ty] = tcTyConAppArgs (exprType b)
+ -- b :: Q a, so we can get the type 'a' by looking at the
+ -- argument type. NB: this relies on Q being a data/newtype,
+ -- not a type synonym
+
+ go var_ty [] = return body
+ go var_ty ((name,id) : binds)
+ = do { MkC body' <- go var_ty binds
+ ; lit_str <- occNameLit name
+ ; gensym_app <- repGensym lit_str
+ ; repBindQ var_ty elt_ty
+ gensym_app (MkC (Lam id body')) }
+
+-- Just like wrapGenSym, but don't actually do the gensym
+-- Instead use the existing name:
+-- let x = "x" in ...
+-- Only used for [Decl], and for the class ops in class
+-- and instance decls
+wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a)
+wrapNongenSyms binds (MkC body)
+ = do { binds' <- mapM do_one binds ;
+ return (MkC (mkLets binds' body)) }
+ where
+ do_one (name,id)
+ = do { MkC lit_str <- occNameLit name
+ ; MkC var <- rep2 mkNameName [lit_str]
+ ; return (NonRec id var) }
+
+occNameLit :: Name -> DsM (Core String)
+occNameLit n = coreStringLit (occNameString (nameOccName n))
+
+
+-- %*********************************************************************
+-- %* *
+-- Constructing code
+-- %* *
+-- %*********************************************************************
+
+-----------------------------------------------------------------------------
+-- PHANTOM TYPES for consistency. In order to make sure we do this correct
+-- we invent a new datatype which uses phantom types.
+
+newtype Core a = MkC CoreExpr
+unC (MkC x) = x
+
+rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
+rep2 n xs = do { id <- dsLookupGlobalId n
+ ; return (MkC (foldl App (Var id) xs)) }
+
+-- Then we make "repConstructors" which use the phantom types for each of the
+-- smart constructors of the Meta.Meta datatypes.
+
+
+-- %*********************************************************************
+-- %* *
+-- The 'smart constructors'
+-- %* *
+-- %*********************************************************************
+
+--------------- Patterns -----------------
+repPlit :: Core TH.Lit -> DsM (Core TH.PatQ)
+repPlit (MkC l) = rep2 litPName [l]
+
+repPvar :: Core TH.Name -> DsM (Core TH.PatQ)
+repPvar (MkC s) = rep2 varPName [s]
+
+repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
+repPtup (MkC ps) = rep2 tupPName [ps]
+
+repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
+repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
+
+repPrec :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)
+repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
+
+repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
+repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
+
+repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
+repPtilde (MkC p) = rep2 tildePName [p]
+
+repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
+repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
+
+repPwild :: DsM (Core TH.PatQ)
+repPwild = rep2 wildPName []
+
+repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
+repPlist (MkC ps) = rep2 listPName [ps]
+
+repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
+repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
+
+--------------- Expressions -----------------
+repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
+repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
+ | otherwise = repVar str
+
+repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
+repVar (MkC s) = rep2 varEName [s]
+
+repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
+repCon (MkC s) = rep2 conEName [s]
+
+repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
+repLit (MkC c) = rep2 litEName [c]
+
+repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repApp (MkC x) (MkC y) = rep2 appEName [x,y]
+
+repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
+
+repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
+repTup (MkC es) = rep2 tupEName [es]
+
+repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
+
+repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
+
+repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
+repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
+
+repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
+repDoE (MkC ss) = rep2 doEName [ss]
+
+repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
+repComp (MkC ss) = rep2 compEName [ss]
+
+repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
+repListExp (MkC es) = rep2 listEName [es]
+
+repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
+repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
+
+repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
+repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
+
+repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)
+repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
+
+repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))
+repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
+
+repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
+
+repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
+
+repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
+
+------------ Right hand sides (guarded expressions) ----
+repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
+repGuarded (MkC pairs) = rep2 guardedBName [pairs]
+
+repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
+repNormal (MkC e) = rep2 normalBName [e]
+
+------------ Guards ----
+repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
+repLNormalGE g e = do g' <- repLE g
+ e' <- repLE e
+ repNormalGE g' e'
+
+repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
+repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
+
+repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
+repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
+
+------------- Stmts -------------------
+repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
+repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
+
+repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
+repLetSt (MkC ds) = rep2 letSName [ds]
+
+repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
+repNoBindSt (MkC e) = rep2 noBindSName [e]
+
+-------------- Range (Arithmetic sequences) -----------
+repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repFrom (MkC x) = rep2 fromEName [x]
+
+repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
+
+repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
+
+repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
+
+------------ Match and Clause Tuples -----------
+repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
+repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
+
+repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
+repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
+
+-------------- Dec -----------------------------
+repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
+repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
+
+repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
+repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
+
+repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ)
+repData (MkC cxt) (MkC nm) (MkC tvs) (MkC cons) (MkC derivs)
+ = rep2 dataDName [cxt, nm, tvs, cons, derivs]
+
+repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ)
+repNewtype (MkC cxt) (MkC nm) (MkC tvs) (MkC con) (MkC derivs)
+ = rep2 newtypeDName [cxt, nm, tvs, con, derivs]
+
+repTySyn :: Core TH.Name -> Core [TH.Name] -> Core TH.TypeQ -> DsM (Core TH.DecQ)
+repTySyn (MkC nm) (MkC tvs) (MkC rhs) = rep2 tySynDName [nm, tvs, rhs]
+
+repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
+repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
+
+repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core [TH.FunDep] -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
+repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) = rep2 classDName [cxt, cls, tvs, fds, ds]
+
+repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
+repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
+
+repProto :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
+repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]
+
+repCtxt :: Core [TH.TypeQ] -> DsM (Core TH.CxtQ)
+repCtxt (MkC tys) = rep2 cxtName [tys]
+
+repConstr :: Core TH.Name -> HsConDetails Name (LBangType Name)
+ -> DsM (Core TH.ConQ)
+repConstr con (PrefixCon ps)
+ = do arg_tys <- mapM repBangTy ps
+ arg_tys1 <- coreList strictTypeQTyConName arg_tys
+ rep2 normalCName [unC con, unC arg_tys1]
+repConstr con (RecCon ips)
+ = do arg_vs <- mapM lookupLOcc (map fst ips)
+ arg_tys <- mapM repBangTy (map snd ips)
+ arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
+ arg_vs arg_tys
+ arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys
+ rep2 recCName [unC con, unC arg_vtys']
+repConstr con (InfixCon st1 st2)
+ = do arg1 <- repBangTy st1
+ arg2 <- repBangTy st2
+ rep2 infixCName [unC arg1, unC con, unC arg2]
+
+------------ Types -------------------
+
+repTForall :: Core [TH.Name] -> Core TH.CxtQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
+repTForall (MkC tvars) (MkC ctxt) (MkC ty)
+ = rep2 forallTName [tvars, ctxt, ty]
+
+repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
+repTvar (MkC s) = rep2 varTName [s]
+
+repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
+repTapp (MkC t1) (MkC t2) = rep2 appTName [t1,t2]
+
+repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
+repTapps f [] = return f
+repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
+
+--------- Type constructors --------------
+
+repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
+repNamedTyCon (MkC s) = rep2 conTName [s]
+
+repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
+-- Note: not Core Int; it's easier to be direct here
+repTupleTyCon i = rep2 tupleTName [mkIntExpr (fromIntegral i)]
+
+repArrowTyCon :: DsM (Core TH.TypeQ)
+repArrowTyCon = rep2 arrowTName []
+
+repListTyCon :: DsM (Core TH.TypeQ)
+repListTyCon = rep2 listTName []
+
+
+----------------------------------------------------------
+-- Literals
+
+repLiteral :: HsLit -> DsM (Core TH.Lit)
+repLiteral lit
+ = do lit' <- case lit of
+ HsIntPrim i -> mk_integer i
+ HsInt i -> mk_integer i
+ HsFloatPrim r -> mk_rational r
+ HsDoublePrim r -> mk_rational r
+ _ -> return lit
+ lit_expr <- dsLit lit'
+ rep2 lit_name [lit_expr]
+ where
+ lit_name = case lit of
+ HsInteger _ _ -> integerLName
+ HsInt _ -> integerLName
+ HsIntPrim _ -> intPrimLName
+ HsFloatPrim _ -> floatPrimLName
+ HsDoublePrim _ -> doublePrimLName
+ HsChar _ -> charLName
+ HsString _ -> stringLName
+ HsRat _ _ -> rationalLName
+ other -> uh_oh
+ uh_oh = pprPanic "DsMeta.repLiteral: trying to represent exotic literal"
+ (ppr lit)
+
+mk_integer i = do integer_ty <- lookupType integerTyConName
+ return $ HsInteger i integer_ty
+mk_rational r = do rat_ty <- lookupType rationalTyConName
+ return $ HsRat r rat_ty
+
+repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
+repOverloadedLiteral (HsIntegral i _) = do { lit <- mk_integer i; repLiteral lit }
+repOverloadedLiteral (HsFractional f _) = do { lit <- mk_rational f; repLiteral lit }
+ -- The type Rational will be in the environment, becuase
+ -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
+ -- and rationalL is sucked in when any TH stuff is used
+
+--------------- Miscellaneous -------------------
+
+repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
+repGensym (MkC lit_str) = rep2 newNameName [lit_str]
+
+repBindQ :: Type -> Type -- a and b
+ -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))
+repBindQ ty_a ty_b (MkC x) (MkC y)
+ = rep2 bindQName [Type ty_a, Type ty_b, x, y]
+
+repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
+repSequenceQ ty_a (MkC list)
+ = rep2 sequenceQName [Type ty_a, list]
+
+------------ Lists and Tuples -------------------
+-- turn a list of patterns into a single pattern matching a list
+
+coreList :: Name -- Of the TyCon of the element type
+ -> [Core a] -> DsM (Core [a])
+coreList tc_name es
+ = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
+
+coreList' :: Type -- The element type
+ -> [Core a] -> Core [a]
+coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
+
+nonEmptyCoreList :: [Core a] -> Core [a]
+ -- The list must be non-empty so we can get the element type
+ -- Otherwise use coreList
+nonEmptyCoreList [] = panic "coreList: empty argument"
+nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
+
+corePair :: (Core a, Core b) -> Core (a,b)
+corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y])
+
+coreStringLit :: String -> DsM (Core String)
+coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
+
+coreIntLit :: Int -> DsM (Core Int)
+coreIntLit i = return (MkC (mkIntExpr (fromIntegral i)))
+
+coreVar :: Id -> Core TH.Name -- The Id has type Name
+coreVar id = MkC (Var id)
+
+
+
+-- %************************************************************************
+-- %* *
+-- The known-key names for Template Haskell
+-- %* *
+-- %************************************************************************
+
+-- To add a name, do three things
+--
+-- 1) Allocate a key
+-- 2) Make a "Name"
+-- 3) Add the name to knownKeyNames
+
+templateHaskellNames :: [Name]
+-- The names that are implicitly mentioned by ``bracket''
+-- Should stay in sync with the import list of DsMeta
+
+templateHaskellNames = [
+ returnQName, bindQName, sequenceQName, newNameName, liftName,
+ mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
+
+ -- Lit
+ charLName, stringLName, integerLName, intPrimLName,
+ floatPrimLName, doublePrimLName, rationalLName,
+ -- Pat
+ litPName, varPName, tupPName, conPName, tildePName, infixPName,
+ asPName, wildPName, recPName, listPName, sigPName,
+ -- FieldPat
+ fieldPatName,
+ -- Match
+ matchName,
+ -- Clause
+ clauseName,
+ -- Exp
+ varEName, conEName, litEName, appEName, infixEName,
+ infixAppName, sectionLName, sectionRName, lamEName, tupEName,
+ condEName, letEName, caseEName, doEName, compEName,
+ fromEName, fromThenEName, fromToEName, fromThenToEName,
+ listEName, sigEName, recConEName, recUpdEName,
+ -- FieldExp
+ fieldExpName,
+ -- Body
+ guardedBName, normalBName,
+ -- Guard
+ normalGEName, patGEName,
+ -- Stmt
+ bindSName, letSName, noBindSName, parSName,
+ -- Dec
+ funDName, valDName, dataDName, newtypeDName, tySynDName,
+ classDName, instanceDName, sigDName, forImpDName,
+ -- Cxt
+ cxtName,
+ -- Strict
+ isStrictName, notStrictName,
+ -- Con
+ normalCName, recCName, infixCName, forallCName,
+ -- StrictType
+ strictTypeName,
+ -- VarStrictType
+ varStrictTypeName,
+ -- Type
+ forallTName, varTName, conTName, appTName,
+ tupleTName, arrowTName, listTName,
+ -- Callconv
+ cCallName, stdCallName,
+ -- Safety
+ unsafeName,
+ safeName,
+ threadsafeName,
+ -- FunDep
+ funDepName,
+
+ -- And the tycons
+ qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
+ clauseQTyConName, expQTyConName, fieldExpTyConName, stmtQTyConName,
+ decQTyConName, conQTyConName, strictTypeQTyConName,
+ varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
+ typeTyConName, matchTyConName, clauseTyConName, patQTyConName,
+ fieldPatQTyConName, fieldExpQTyConName, funDepTyConName]
+
+thSyn :: Module
+thSyn = mkModule "Language.Haskell.TH.Syntax"
+thLib = mkModule "Language.Haskell.TH.Lib"
+
+mk_known_key_name mod space str uniq
+ = mkExternalName uniq mod (mkOccNameFS space str)
+ Nothing noSrcLoc
+
+libFun = mk_known_key_name thLib OccName.varName
+libTc = mk_known_key_name thLib OccName.tcName
+thFun = mk_known_key_name thSyn OccName.varName
+thTc = mk_known_key_name thSyn OccName.tcName
+
+-------------------- TH.Syntax -----------------------
+qTyConName = thTc FSLIT("Q") qTyConKey
+nameTyConName = thTc FSLIT("Name") nameTyConKey
+fieldExpTyConName = thTc FSLIT("FieldExp") fieldExpTyConKey
+patTyConName = thTc FSLIT("Pat") patTyConKey
+fieldPatTyConName = thTc FSLIT("FieldPat") fieldPatTyConKey
+expTyConName = thTc FSLIT("Exp") expTyConKey
+decTyConName = thTc FSLIT("Dec") decTyConKey
+typeTyConName = thTc FSLIT("Type") typeTyConKey
+matchTyConName = thTc FSLIT("Match") matchTyConKey
+clauseTyConName = thTc FSLIT("Clause") clauseTyConKey
+funDepTyConName = thTc FSLIT("FunDep") funDepTyConKey
+
+returnQName = thFun FSLIT("returnQ") returnQIdKey
+bindQName = thFun FSLIT("bindQ") bindQIdKey
+sequenceQName = thFun FSLIT("sequenceQ") sequenceQIdKey
+newNameName = thFun FSLIT("newName") newNameIdKey
+liftName = thFun FSLIT("lift") liftIdKey
+mkNameName = thFun FSLIT("mkName") mkNameIdKey
+mkNameG_vName = thFun FSLIT("mkNameG_v") mkNameG_vIdKey
+mkNameG_dName = thFun FSLIT("mkNameG_d") mkNameG_dIdKey
+mkNameG_tcName = thFun FSLIT("mkNameG_tc") mkNameG_tcIdKey
+mkNameLName = thFun FSLIT("mkNameL") mkNameLIdKey
+
+
+-------------------- TH.Lib -----------------------
+-- data Lit = ...
+charLName = libFun FSLIT("charL") charLIdKey
+stringLName = libFun FSLIT("stringL") stringLIdKey
+integerLName = libFun FSLIT("integerL") integerLIdKey
+intPrimLName = libFun FSLIT("intPrimL") intPrimLIdKey
+floatPrimLName = libFun FSLIT("floatPrimL") floatPrimLIdKey
+doublePrimLName = libFun FSLIT("doublePrimL") doublePrimLIdKey
+rationalLName = libFun FSLIT("rationalL") rationalLIdKey
+
+-- data Pat = ...
+litPName = libFun FSLIT("litP") litPIdKey
+varPName = libFun FSLIT("varP") varPIdKey
+tupPName = libFun FSLIT("tupP") tupPIdKey
+conPName = libFun FSLIT("conP") conPIdKey
+infixPName = libFun FSLIT("infixP") infixPIdKey
+tildePName = libFun FSLIT("tildeP") tildePIdKey
+asPName = libFun FSLIT("asP") asPIdKey
+wildPName = libFun FSLIT("wildP") wildPIdKey
+recPName = libFun FSLIT("recP") recPIdKey
+listPName = libFun FSLIT("listP") listPIdKey
+sigPName = libFun FSLIT("sigP") sigPIdKey
+
+-- type FieldPat = ...
+fieldPatName = libFun FSLIT("fieldPat") fieldPatIdKey
+
+-- data Match = ...
+matchName = libFun FSLIT("match") matchIdKey
+
+-- data Clause = ...
+clauseName = libFun FSLIT("clause") clauseIdKey
+
+-- data Exp = ...
+varEName = libFun FSLIT("varE") varEIdKey
+conEName = libFun FSLIT("conE") conEIdKey
+litEName = libFun FSLIT("litE") litEIdKey
+appEName = libFun FSLIT("appE") appEIdKey
+infixEName = libFun FSLIT("infixE") infixEIdKey
+infixAppName = libFun FSLIT("infixApp") infixAppIdKey
+sectionLName = libFun FSLIT("sectionL") sectionLIdKey
+sectionRName = libFun FSLIT("sectionR") sectionRIdKey
+lamEName = libFun FSLIT("lamE") lamEIdKey
+tupEName = libFun FSLIT("tupE") tupEIdKey
+condEName = libFun FSLIT("condE") condEIdKey
+letEName = libFun FSLIT("letE") letEIdKey
+caseEName = libFun FSLIT("caseE") caseEIdKey
+doEName = libFun FSLIT("doE") doEIdKey
+compEName = libFun FSLIT("compE") compEIdKey
+-- ArithSeq skips a level
+fromEName = libFun FSLIT("fromE") fromEIdKey
+fromThenEName = libFun FSLIT("fromThenE") fromThenEIdKey
+fromToEName = libFun FSLIT("fromToE") fromToEIdKey
+fromThenToEName = libFun FSLIT("fromThenToE") fromThenToEIdKey
+-- end ArithSeq
+listEName = libFun FSLIT("listE") listEIdKey
+sigEName = libFun FSLIT("sigE") sigEIdKey
+recConEName = libFun FSLIT("recConE") recConEIdKey
+recUpdEName = libFun FSLIT("recUpdE") recUpdEIdKey
+
+-- type FieldExp = ...
+fieldExpName = libFun FSLIT("fieldExp") fieldExpIdKey
+
+-- data Body = ...
+guardedBName = libFun FSLIT("guardedB") guardedBIdKey
+normalBName = libFun FSLIT("normalB") normalBIdKey
+
+-- data Guard = ...
+normalGEName = libFun FSLIT("normalGE") normalGEIdKey
+patGEName = libFun FSLIT("patGE") patGEIdKey
+
+-- data Stmt = ...
+bindSName = libFun FSLIT("bindS") bindSIdKey
+letSName = libFun FSLIT("letS") letSIdKey
+noBindSName = libFun FSLIT("noBindS") noBindSIdKey
+parSName = libFun FSLIT("parS") parSIdKey
+
+-- data Dec = ...
+funDName = libFun FSLIT("funD") funDIdKey
+valDName = libFun FSLIT("valD") valDIdKey
+dataDName = libFun FSLIT("dataD") dataDIdKey
+newtypeDName = libFun FSLIT("newtypeD") newtypeDIdKey
+tySynDName = libFun FSLIT("tySynD") tySynDIdKey
+classDName = libFun FSLIT("classD") classDIdKey
+instanceDName = libFun FSLIT("instanceD") instanceDIdKey
+sigDName = libFun FSLIT("sigD") sigDIdKey
+forImpDName = libFun FSLIT("forImpD") forImpDIdKey
+
+-- type Ctxt = ...
+cxtName = libFun FSLIT("cxt") cxtIdKey
+
+-- data Strict = ...
+isStrictName = libFun FSLIT("isStrict") isStrictKey
+notStrictName = libFun FSLIT("notStrict") notStrictKey
+
+-- data Con = ...
+normalCName = libFun FSLIT("normalC") normalCIdKey
+recCName = libFun FSLIT("recC") recCIdKey
+infixCName = libFun FSLIT("infixC") infixCIdKey
+forallCName = libFun FSLIT("forallC") forallCIdKey
+
+-- type StrictType = ...
+strictTypeName = libFun FSLIT("strictType") strictTKey
+
+-- type VarStrictType = ...
+varStrictTypeName = libFun FSLIT("varStrictType") varStrictTKey
+
+-- data Type = ...
+forallTName = libFun FSLIT("forallT") forallTIdKey
+varTName = libFun FSLIT("varT") varTIdKey
+conTName = libFun FSLIT("conT") conTIdKey
+tupleTName = libFun FSLIT("tupleT") tupleTIdKey
+arrowTName = libFun FSLIT("arrowT") arrowTIdKey
+listTName = libFun FSLIT("listT") listTIdKey
+appTName = libFun FSLIT("appT") appTIdKey
+
+-- data Callconv = ...
+cCallName = libFun FSLIT("cCall") cCallIdKey
+stdCallName = libFun FSLIT("stdCall") stdCallIdKey
+
+-- data Safety = ...
+unsafeName = libFun FSLIT("unsafe") unsafeIdKey
+safeName = libFun FSLIT("safe") safeIdKey
+threadsafeName = libFun FSLIT("threadsafe") threadsafeIdKey
+
+-- data FunDep = ...
+funDepName = libFun FSLIT("funDep") funDepIdKey
+
+matchQTyConName = libTc FSLIT("MatchQ") matchQTyConKey
+clauseQTyConName = libTc FSLIT("ClauseQ") clauseQTyConKey
+expQTyConName = libTc FSLIT("ExpQ") expQTyConKey
+stmtQTyConName = libTc FSLIT("StmtQ") stmtQTyConKey
+decQTyConName = libTc FSLIT("DecQ") decQTyConKey
+conQTyConName = libTc FSLIT("ConQ") conQTyConKey
+strictTypeQTyConName = libTc FSLIT("StrictTypeQ") strictTypeQTyConKey
+varStrictTypeQTyConName = libTc FSLIT("VarStrictTypeQ") varStrictTypeQTyConKey
+typeQTyConName = libTc FSLIT("TypeQ") typeQTyConKey
+fieldExpQTyConName = libTc FSLIT("FieldExpQ") fieldExpQTyConKey
+patQTyConName = libTc FSLIT("PatQ") patQTyConKey
+fieldPatQTyConName = libTc FSLIT("FieldPatQ") fieldPatQTyConKey
+
+-- TyConUniques available: 100-129
+-- Check in PrelNames if you want to change this
+
+expTyConKey = mkPreludeTyConUnique 100
+matchTyConKey = mkPreludeTyConUnique 101
+clauseTyConKey = mkPreludeTyConUnique 102
+qTyConKey = mkPreludeTyConUnique 103
+expQTyConKey = mkPreludeTyConUnique 104
+decQTyConKey = mkPreludeTyConUnique 105
+patTyConKey = mkPreludeTyConUnique 106
+matchQTyConKey = mkPreludeTyConUnique 107
+clauseQTyConKey = mkPreludeTyConUnique 108
+stmtQTyConKey = mkPreludeTyConUnique 109
+conQTyConKey = mkPreludeTyConUnique 110
+typeQTyConKey = mkPreludeTyConUnique 111
+typeTyConKey = mkPreludeTyConUnique 112
+decTyConKey = mkPreludeTyConUnique 113
+varStrictTypeQTyConKey = mkPreludeTyConUnique 114
+strictTypeQTyConKey = mkPreludeTyConUnique 115
+fieldExpTyConKey = mkPreludeTyConUnique 116
+fieldPatTyConKey = mkPreludeTyConUnique 117
+nameTyConKey = mkPreludeTyConUnique 118
+patQTyConKey = mkPreludeTyConUnique 119
+fieldPatQTyConKey = mkPreludeTyConUnique 120
+fieldExpQTyConKey = mkPreludeTyConUnique 121
+funDepTyConKey = mkPreludeTyConUnique 122
+
+-- IdUniques available: 200-399
+-- If you want to change this, make sure you check in PrelNames
+
+returnQIdKey = mkPreludeMiscIdUnique 200
+bindQIdKey = mkPreludeMiscIdUnique 201
+sequenceQIdKey = mkPreludeMiscIdUnique 202
+liftIdKey = mkPreludeMiscIdUnique 203
+newNameIdKey = mkPreludeMiscIdUnique 204
+mkNameIdKey = mkPreludeMiscIdUnique 205
+mkNameG_vIdKey = mkPreludeMiscIdUnique 206
+mkNameG_dIdKey = mkPreludeMiscIdUnique 207
+mkNameG_tcIdKey = mkPreludeMiscIdUnique 208
+mkNameLIdKey = mkPreludeMiscIdUnique 209
+
+
+-- data Lit = ...
+charLIdKey = mkPreludeMiscIdUnique 210
+stringLIdKey = mkPreludeMiscIdUnique 211
+integerLIdKey = mkPreludeMiscIdUnique 212
+intPrimLIdKey = mkPreludeMiscIdUnique 213
+floatPrimLIdKey = mkPreludeMiscIdUnique 214
+doublePrimLIdKey = mkPreludeMiscIdUnique 215
+rationalLIdKey = mkPreludeMiscIdUnique 216
+
+-- data Pat = ...
+litPIdKey = mkPreludeMiscIdUnique 220
+varPIdKey = mkPreludeMiscIdUnique 221
+tupPIdKey = mkPreludeMiscIdUnique 222
+conPIdKey = mkPreludeMiscIdUnique 223
+infixPIdKey = mkPreludeMiscIdUnique 312
+tildePIdKey = mkPreludeMiscIdUnique 224
+asPIdKey = mkPreludeMiscIdUnique 225
+wildPIdKey = mkPreludeMiscIdUnique 226
+recPIdKey = mkPreludeMiscIdUnique 227
+listPIdKey = mkPreludeMiscIdUnique 228
+sigPIdKey = mkPreludeMiscIdUnique 229
+
+-- type FieldPat = ...
+fieldPatIdKey = mkPreludeMiscIdUnique 230
+
+-- data Match = ...
+matchIdKey = mkPreludeMiscIdUnique 231
+
+-- data Clause = ...
+clauseIdKey = mkPreludeMiscIdUnique 232
+
+-- data Exp = ...
+varEIdKey = mkPreludeMiscIdUnique 240
+conEIdKey = mkPreludeMiscIdUnique 241
+litEIdKey = mkPreludeMiscIdUnique 242
+appEIdKey = mkPreludeMiscIdUnique 243
+infixEIdKey = mkPreludeMiscIdUnique 244
+infixAppIdKey = mkPreludeMiscIdUnique 245
+sectionLIdKey = mkPreludeMiscIdUnique 246
+sectionRIdKey = mkPreludeMiscIdUnique 247
+lamEIdKey = mkPreludeMiscIdUnique 248
+tupEIdKey = mkPreludeMiscIdUnique 249
+condEIdKey = mkPreludeMiscIdUnique 250
+letEIdKey = mkPreludeMiscIdUnique 251
+caseEIdKey = mkPreludeMiscIdUnique 252
+doEIdKey = mkPreludeMiscIdUnique 253
+compEIdKey = mkPreludeMiscIdUnique 254
+fromEIdKey = mkPreludeMiscIdUnique 255
+fromThenEIdKey = mkPreludeMiscIdUnique 256
+fromToEIdKey = mkPreludeMiscIdUnique 257
+fromThenToEIdKey = mkPreludeMiscIdUnique 258
+listEIdKey = mkPreludeMiscIdUnique 259
+sigEIdKey = mkPreludeMiscIdUnique 260
+recConEIdKey = mkPreludeMiscIdUnique 261
+recUpdEIdKey = mkPreludeMiscIdUnique 262
+
+-- type FieldExp = ...
+fieldExpIdKey = mkPreludeMiscIdUnique 265
+
+-- data Body = ...
+guardedBIdKey = mkPreludeMiscIdUnique 266
+normalBIdKey = mkPreludeMiscIdUnique 267
+
+-- data Guard = ...
+normalGEIdKey = mkPreludeMiscIdUnique 310
+patGEIdKey = mkPreludeMiscIdUnique 311
+
+-- data Stmt = ...
+bindSIdKey = mkPreludeMiscIdUnique 268
+letSIdKey = mkPreludeMiscIdUnique 269
+noBindSIdKey = mkPreludeMiscIdUnique 270
+parSIdKey = mkPreludeMiscIdUnique 271
+
+-- data Dec = ...
+funDIdKey = mkPreludeMiscIdUnique 272
+valDIdKey = mkPreludeMiscIdUnique 273
+dataDIdKey = mkPreludeMiscIdUnique 274
+newtypeDIdKey = mkPreludeMiscIdUnique 275
+tySynDIdKey = mkPreludeMiscIdUnique 276
+classDIdKey = mkPreludeMiscIdUnique 277
+instanceDIdKey = mkPreludeMiscIdUnique 278
+sigDIdKey = mkPreludeMiscIdUnique 279
+forImpDIdKey = mkPreludeMiscIdUnique 297
+
+-- type Cxt = ...
+cxtIdKey = mkPreludeMiscIdUnique 280
+
+-- data Strict = ...
+isStrictKey = mkPreludeMiscIdUnique 281
+notStrictKey = mkPreludeMiscIdUnique 282
+
+-- data Con = ...
+normalCIdKey = mkPreludeMiscIdUnique 283
+recCIdKey = mkPreludeMiscIdUnique 284
+infixCIdKey = mkPreludeMiscIdUnique 285
+forallCIdKey = mkPreludeMiscIdUnique 288
+
+-- type StrictType = ...
+strictTKey = mkPreludeMiscIdUnique 286
+
+-- type VarStrictType = ...
+varStrictTKey = mkPreludeMiscIdUnique 287
+
+-- data Type = ...
+forallTIdKey = mkPreludeMiscIdUnique 290
+varTIdKey = mkPreludeMiscIdUnique 291
+conTIdKey = mkPreludeMiscIdUnique 292
+tupleTIdKey = mkPreludeMiscIdUnique 294
+arrowTIdKey = mkPreludeMiscIdUnique 295
+listTIdKey = mkPreludeMiscIdUnique 296
+appTIdKey = mkPreludeMiscIdUnique 293
+
+-- data Callconv = ...
+cCallIdKey = mkPreludeMiscIdUnique 300
+stdCallIdKey = mkPreludeMiscIdUnique 301
+
+-- data Safety = ...
+unsafeIdKey = mkPreludeMiscIdUnique 305
+safeIdKey = mkPreludeMiscIdUnique 306
+threadsafeIdKey = mkPreludeMiscIdUnique 307
+
+-- data FunDep = ...
+funDepIdKey = mkPreludeMiscIdUnique 320
+
diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs
new file mode 100644
index 0000000000..f24dee4905
--- /dev/null
+++ b/compiler/deSugar/DsMonad.lhs
@@ -0,0 +1,285 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[DsMonad]{@DsMonad@: monadery used in desugaring}
+
+\begin{code}
+module DsMonad (
+ DsM, mappM, mapAndUnzipM,
+ initDs, returnDs, thenDs, listDs, fixDs, mapAndUnzipDs,
+ foldlDs, foldrDs,
+
+ newTyVarsDs, newLocalName,
+ duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
+ newFailLocalDs,
+ getSrcSpanDs, putSrcSpanDs,
+ getModuleDs,
+ newUnique,
+ UniqSupply, newUniqueSupply,
+ getDOptsDs,
+ dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon,
+
+ DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
+
+ -- Warnings
+ DsWarning, dsWarn,
+
+ -- Data types
+ DsMatchContext(..),
+ EquationInfo(..), MatchResult(..), DsWrapper, idWrapper,
+ CanItFail(..), orFail
+ ) where
+
+#include "HsVersions.h"
+
+import TcRnMonad
+import CoreSyn ( CoreExpr )
+import HsSyn ( HsExpr, HsMatchContext, Pat )
+import TcIface ( tcIfaceGlobal )
+import RdrName ( GlobalRdrEnv )
+import HscTypes ( TyThing(..), TypeEnv, HscEnv,
+ tyThingId, tyThingTyCon, tyThingDataCon, unQualInScope )
+import Bag ( emptyBag, snocBag, Bag )
+import DataCon ( DataCon )
+import TyCon ( TyCon )
+import Id ( mkSysLocal, setIdUnique, Id )
+import Module ( Module )
+import Var ( TyVar, setTyVarUnique )
+import Outputable
+import SrcLoc ( noSrcSpan, SrcSpan )
+import Type ( Type )
+import UniqSupply ( UniqSupply, uniqsFromSupply )
+import Name ( Name, nameOccName )
+import NameEnv
+import OccName ( occNameFS )
+import DynFlags ( DynFlags )
+import ErrUtils ( WarnMsg, mkWarnMsg )
+import Bag ( mapBag )
+
+import DATA_IOREF ( newIORef, readIORef )
+
+infixr 9 `thenDs`
+\end{code}
+
+%************************************************************************
+%* *
+ Data types for the desugarer
+%* *
+%************************************************************************
+
+\begin{code}
+data DsMatchContext
+ = DsMatchContext (HsMatchContext Name) SrcSpan
+ | NoMatchContext
+ deriving ()
+
+data EquationInfo
+ = EqnInfo { eqn_wrap :: DsWrapper, -- Bindings
+ eqn_pats :: [Pat Id], -- The patterns for an eqn
+ eqn_rhs :: MatchResult } -- What to do after match
+
+type DsWrapper = CoreExpr -> CoreExpr
+idWrapper e = e
+
+-- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
+-- \fail. wrap (case vs of { pats -> rhs fail })
+-- where vs are not bound by wrap
+
+
+-- A MatchResult is an expression with a hole in it
+data MatchResult
+ = MatchResult
+ CanItFail -- Tells whether the failure expression is used
+ (CoreExpr -> DsM CoreExpr)
+ -- Takes a expression to plug in at the
+ -- failure point(s). The expression should
+ -- be duplicatable!
+
+data CanItFail = CanFail | CantFail
+
+orFail CantFail CantFail = CantFail
+orFail _ _ = CanFail
+\end{code}
+
+
+%************************************************************************
+%* *
+ Monad stuff
+%* *
+%************************************************************************
+
+Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
+a @UniqueSupply@ and some annotations, which
+presumably include source-file location information:
+\begin{code}
+type DsM result = TcRnIf DsGblEnv DsLclEnv result
+
+-- Compatibility functions
+fixDs = fixM
+thenDs = thenM
+returnDs = returnM
+listDs = sequenceM
+foldlDs = foldlM
+foldrDs = foldrM
+mapAndUnzipDs = mapAndUnzipM
+
+
+type DsWarning = (SrcSpan, SDoc)
+ -- Not quite the same as a WarnMsg, we have an SDoc here
+ -- and we'll do the print_unqual stuff later on to turn it
+ -- into a Doc.
+
+data DsGblEnv = DsGblEnv {
+ ds_mod :: Module, -- For SCC profiling
+ ds_warns :: IORef (Bag DsWarning), -- Warning messages
+ ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global,
+ -- possibly-imported things
+ }
+
+data DsLclEnv = DsLclEnv {
+ ds_meta :: DsMetaEnv, -- Template Haskell bindings
+ ds_loc :: SrcSpan -- to put in pattern-matching error msgs
+ }
+
+-- Inside [| |] brackets, the desugarer looks
+-- up variables in the DsMetaEnv
+type DsMetaEnv = NameEnv DsMetaVal
+
+data DsMetaVal
+ = Bound Id -- Bound by a pattern inside the [| |].
+ -- Will be dynamically alpha renamed.
+ -- The Id has type THSyntax.Var
+
+ | Splice (HsExpr Id) -- These bindings are introduced by
+ -- the PendingSplices on a HsBracketOut
+
+-- initDs returns the UniqSupply out the end (not just the result)
+
+initDs :: HscEnv
+ -> Module -> GlobalRdrEnv -> TypeEnv
+ -> DsM a
+ -> IO (a, Bag WarnMsg)
+
+initDs hsc_env mod rdr_env type_env thing_inside
+ = do { warn_var <- newIORef emptyBag
+ ; let { if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
+ ; if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod)
+ ; gbl_env = DsGblEnv { ds_mod = mod,
+ ds_if_env = (if_genv, if_lenv),
+ ds_warns = warn_var }
+ ; lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
+ ds_loc = noSrcSpan } }
+
+ ; res <- initTcRnIf 'd' hsc_env gbl_env lcl_env thing_inside
+
+ ; warns <- readIORef warn_var
+ ; return (res, mapBag mk_warn warns)
+ }
+ where
+ print_unqual = unQualInScope rdr_env
+
+ mk_warn :: (SrcSpan,SDoc) -> WarnMsg
+ mk_warn (loc,sdoc) = mkWarnMsg loc print_unqual sdoc
+\end{code}
+
+%************************************************************************
+%* *
+ Operations in the monad
+%* *
+%************************************************************************
+
+And all this mysterious stuff is so we can occasionally reach out and
+grab one or more names. @newLocalDs@ isn't exported---exported
+functions are defined with it. The difference in name-strings makes
+it easier to read debugging output.
+
+\begin{code}
+-- Make a new Id with the same print name, but different type, and new unique
+newUniqueId :: Name -> Type -> DsM Id
+newUniqueId id ty
+ = newUnique `thenDs` \ uniq ->
+ returnDs (mkSysLocal (occNameFS (nameOccName id)) uniq ty)
+
+duplicateLocalDs :: Id -> DsM Id
+duplicateLocalDs old_local
+ = newUnique `thenDs` \ uniq ->
+ returnDs (setIdUnique old_local uniq)
+
+newSysLocalDs, newFailLocalDs :: Type -> DsM Id
+newSysLocalDs ty
+ = newUnique `thenDs` \ uniq ->
+ returnDs (mkSysLocal FSLIT("ds") uniq ty)
+
+newSysLocalsDs tys = mappM newSysLocalDs tys
+
+newFailLocalDs ty
+ = newUnique `thenDs` \ uniq ->
+ returnDs (mkSysLocal FSLIT("fail") uniq ty)
+ -- The UserLocal bit just helps make the code a little clearer
+\end{code}
+
+\begin{code}
+newTyVarsDs :: [TyVar] -> DsM [TyVar]
+newTyVarsDs tyvar_tmpls
+ = newUniqueSupply `thenDs` \ uniqs ->
+ returnDs (zipWith setTyVarUnique tyvar_tmpls (uniqsFromSupply uniqs))
+\end{code}
+
+We can also reach out and either set/grab location information from
+the @SrcSpan@ being carried around.
+
+\begin{code}
+getDOptsDs :: DsM DynFlags
+getDOptsDs = getDOpts
+
+getModuleDs :: DsM Module
+getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
+
+getSrcSpanDs :: DsM SrcSpan
+getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
+
+putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
+putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
+
+dsWarn :: SDoc -> DsM ()
+dsWarn warn = do { env <- getGblEnv
+ ; loc <- getSrcSpanDs
+ ; updMutVar (ds_warns env) (`snocBag` (loc,msg)) }
+ where
+ msg = ptext SLIT("Warning:") <+> warn
+\end{code}
+
+\begin{code}
+dsLookupGlobal :: Name -> DsM TyThing
+-- Very like TcEnv.tcLookupGlobal
+dsLookupGlobal name
+ = do { env <- getGblEnv
+ ; setEnvs (ds_if_env env)
+ (tcIfaceGlobal name) }
+
+dsLookupGlobalId :: Name -> DsM Id
+dsLookupGlobalId name
+ = dsLookupGlobal name `thenDs` \ thing ->
+ returnDs (tyThingId thing)
+
+dsLookupTyCon :: Name -> DsM TyCon
+dsLookupTyCon name
+ = dsLookupGlobal name `thenDs` \ thing ->
+ returnDs (tyThingTyCon thing)
+
+dsLookupDataCon :: Name -> DsM DataCon
+dsLookupDataCon name
+ = dsLookupGlobal name `thenDs` \ thing ->
+ returnDs (tyThingDataCon thing)
+\end{code}
+
+\begin{code}
+dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
+dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
+
+dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
+dsExtendMetaEnv menv thing_inside
+ = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
+\end{code}
+
+
diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
new file mode 100644
index 0000000000..29e7773bb8
--- /dev/null
+++ b/compiler/deSugar/DsUtils.lhs
@@ -0,0 +1,884 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[DsUtils]{Utilities for desugaring}
+
+This module exports some utility functions of no great interest.
+
+\begin{code}
+module DsUtils (
+ EquationInfo(..),
+ firstPat, shiftEqns,
+
+ mkDsLet, mkDsLets,
+
+ MatchResult(..), CanItFail(..),
+ cantFailMatchResult, alwaysFailMatchResult,
+ extractMatchResult, combineMatchResults,
+ adjustMatchResult, adjustMatchResultDs,
+ mkCoLetMatchResult, mkGuardedMatchResult,
+ matchCanFail,
+ mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
+ wrapBind, wrapBinds,
+
+ mkErrorAppDs, mkNilExpr, mkConsExpr, mkListExpr,
+ mkIntExpr, mkCharExpr,
+ mkStringExpr, mkStringExprFS, mkIntegerExpr,
+
+ mkSelectorBinds, mkTupleExpr, mkTupleSelector,
+ mkTupleType, mkTupleCase, mkBigCoreTup,
+ mkCoreTup, mkCoreTupTy, seqVar,
+
+ dsSyntaxTable, lookupEvidence,
+
+ selectSimpleMatchVarL, selectMatchVars, selectMatchVar
+ ) where
+
+#include "HsVersions.h"
+
+import {-# SOURCE #-} Match ( matchSimply )
+import {-# SOURCE #-} DsExpr( dsExpr )
+
+import HsSyn
+import TcHsSyn ( hsPatType )
+import CoreSyn
+import Constants ( mAX_TUPLE_SIZE )
+import DsMonad
+
+import CoreUtils ( exprType, mkIfThenElse, mkCoerce, bindNonRec )
+import MkId ( iRREFUT_PAT_ERROR_ID, mkReboxingAlt, mkNewTypeBody )
+import Id ( idType, Id, mkWildId, mkTemplateLocals, mkSysLocal )
+import Var ( Var )
+import Name ( Name )
+import Literal ( Literal(..), mkStringLit, inIntRange, tARGET_MAX_INT )
+import TyCon ( isNewTyCon, tyConDataCons )
+import DataCon ( DataCon, dataConSourceArity, dataConTyCon, dataConTag )
+import Type ( mkFunTy, isUnLiftedType, Type, splitTyConApp, mkTyVarTy )
+import TcType ( tcEqType )
+import TysPrim ( intPrimTy )
+import TysWiredIn ( nilDataCon, consDataCon,
+ tupleCon, mkTupleTy,
+ unitDataConId, unitTy,
+ charTy, charDataCon,
+ intTy, intDataCon,
+ isPArrFakeCon )
+import BasicTypes ( Boxity(..) )
+import UniqSet ( mkUniqSet, minusUniqSet, isEmptyUniqSet )
+import UniqSupply ( splitUniqSupply, uniqFromSupply, uniqsFromSupply )
+import PrelNames ( unpackCStringName, unpackCStringUtf8Name,
+ plusIntegerName, timesIntegerName, smallIntegerDataConName,
+ lengthPName, indexPName )
+import Outputable
+import SrcLoc ( Located(..), unLoc )
+import Util ( isSingleton, zipEqual, sortWith )
+import ListSetOps ( assocDefault )
+import FastString
+import Data.Char ( ord )
+
+#ifdef DEBUG
+import Util ( notNull ) -- Used in an assertion
+#endif
+\end{code}
+
+
+
+%************************************************************************
+%* *
+ Rebindable syntax
+%* *
+%************************************************************************
+
+\begin{code}
+dsSyntaxTable :: SyntaxTable Id
+ -> DsM ([CoreBind], -- Auxiliary bindings
+ [(Name,Id)]) -- Maps the standard name to its value
+
+dsSyntaxTable rebound_ids
+ = mapAndUnzipDs mk_bind rebound_ids `thenDs` \ (binds_s, prs) ->
+ return (concat binds_s, prs)
+ where
+ -- The cheapo special case can happen when we
+ -- make an intermediate HsDo when desugaring a RecStmt
+ mk_bind (std_name, HsVar id) = return ([], (std_name, id))
+ mk_bind (std_name, expr)
+ = dsExpr expr `thenDs` \ rhs ->
+ newSysLocalDs (exprType rhs) `thenDs` \ id ->
+ return ([NonRec id rhs], (std_name, id))
+
+lookupEvidence :: [(Name, Id)] -> Name -> Id
+lookupEvidence prs std_name
+ = assocDefault (mk_panic std_name) prs std_name
+ where
+ mk_panic std_name = pprPanic "dsSyntaxTable" (ptext SLIT("Not found:") <+> ppr std_name)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Building lets}
+%* *
+%************************************************************************
+
+Use case, not let for unlifted types. The simplifier will turn some
+back again.
+
+\begin{code}
+mkDsLet :: CoreBind -> CoreExpr -> CoreExpr
+mkDsLet (NonRec bndr rhs) body
+ | isUnLiftedType (idType bndr)
+ = Case rhs bndr (exprType body) [(DEFAULT,[],body)]
+mkDsLet bind body
+ = Let bind body
+
+mkDsLets :: [CoreBind] -> CoreExpr -> CoreExpr
+mkDsLets binds body = foldr mkDsLet body binds
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{ Selecting match variables}
+%* *
+%************************************************************************
+
+We're about to match against some patterns. We want to make some
+@Ids@ to use as match variables. If a pattern has an @Id@ readily at
+hand, which should indeed be bound to the pattern as a whole, then use it;
+otherwise, make one up.
+
+\begin{code}
+selectSimpleMatchVarL :: LPat Id -> DsM Id
+selectSimpleMatchVarL pat = selectMatchVar (unLoc pat) (hsPatType pat)
+
+-- (selectMatchVars ps tys) chooses variables of type tys
+-- to use for matching ps against. If the pattern is a variable,
+-- we try to use that, to save inventing lots of fresh variables.
+-- But even if it is a variable, its type might not match. Consider
+-- data T a where
+-- T1 :: Int -> T Int
+-- T2 :: a -> T a
+--
+-- f :: T a -> a -> Int
+-- f (T1 i) (x::Int) = x
+-- f (T2 i) (y::a) = 0
+-- Then we must not choose (x::Int) as the matching variable!
+
+selectMatchVars :: [Pat Id] -> [Type] -> DsM [Id]
+selectMatchVars [] [] = return []
+selectMatchVars (p:ps) (ty:tys) = do { v <- selectMatchVar p ty
+ ; vs <- selectMatchVars ps tys
+ ; return (v:vs) }
+
+selectMatchVar (BangPat pat) pat_ty = selectMatchVar (unLoc pat) pat_ty
+selectMatchVar (LazyPat pat) pat_ty = selectMatchVar (unLoc pat) pat_ty
+selectMatchVar (VarPat var) pat_ty = try_for var pat_ty
+selectMatchVar (AsPat var pat) pat_ty = try_for (unLoc var) pat_ty
+selectMatchVar other_pat pat_ty = newSysLocalDs pat_ty -- OK, better make up one...
+
+try_for var pat_ty
+ | idType var `tcEqType` pat_ty = returnDs var
+ | otherwise = newSysLocalDs pat_ty
+\end{code}
+
+
+%************************************************************************
+%* *
+%* type synonym EquationInfo and access functions for its pieces *
+%* *
+%************************************************************************
+\subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
+
+The ``equation info'' used by @match@ is relatively complicated and
+worthy of a type synonym and a few handy functions.
+
+\begin{code}
+firstPat :: EquationInfo -> Pat Id
+firstPat eqn = head (eqn_pats eqn)
+
+shiftEqns :: [EquationInfo] -> [EquationInfo]
+-- Drop the first pattern in each equation
+shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ]
+\end{code}
+
+Functions on MatchResults
+
+\begin{code}
+matchCanFail :: MatchResult -> Bool
+matchCanFail (MatchResult CanFail _) = True
+matchCanFail (MatchResult CantFail _) = False
+
+alwaysFailMatchResult :: MatchResult
+alwaysFailMatchResult = MatchResult CanFail (\fail -> returnDs fail)
+
+cantFailMatchResult :: CoreExpr -> MatchResult
+cantFailMatchResult expr = MatchResult CantFail (\ ignore -> returnDs expr)
+
+extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
+extractMatchResult (MatchResult CantFail match_fn) fail_expr
+ = match_fn (error "It can't fail!")
+
+extractMatchResult (MatchResult CanFail match_fn) fail_expr
+ = mkFailurePair fail_expr `thenDs` \ (fail_bind, if_it_fails) ->
+ match_fn if_it_fails `thenDs` \ body ->
+ returnDs (mkDsLet fail_bind body)
+
+
+combineMatchResults :: MatchResult -> MatchResult -> MatchResult
+combineMatchResults (MatchResult CanFail body_fn1)
+ (MatchResult can_it_fail2 body_fn2)
+ = MatchResult can_it_fail2 body_fn
+ where
+ body_fn fail = body_fn2 fail `thenDs` \ body2 ->
+ mkFailurePair body2 `thenDs` \ (fail_bind, duplicatable_expr) ->
+ body_fn1 duplicatable_expr `thenDs` \ body1 ->
+ returnDs (Let fail_bind body1)
+
+combineMatchResults match_result1@(MatchResult CantFail body_fn1) match_result2
+ = match_result1
+
+adjustMatchResult :: (CoreExpr -> CoreExpr) -> MatchResult -> MatchResult
+adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
+ = MatchResult can_it_fail (\fail -> body_fn fail `thenDs` \ body ->
+ returnDs (encl_fn body))
+
+adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
+adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
+ = MatchResult can_it_fail (\fail -> body_fn fail `thenDs` \ body ->
+ encl_fn body)
+
+wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr
+wrapBinds [] e = e
+wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)
+
+wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
+wrapBind new old body
+ | new==old = body
+ | isTyVar new = App (Lam new body) (Type (mkTyVarTy old))
+ | otherwise = Let (NonRec new (Var old)) body
+
+seqVar :: Var -> CoreExpr -> CoreExpr
+seqVar var body = Case (Var var) var (exprType body)
+ [(DEFAULT, [], body)]
+
+mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
+mkCoLetMatchResult bind match_result
+ = adjustMatchResult (mkDsLet bind) match_result
+
+mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
+mkGuardedMatchResult pred_expr (MatchResult can_it_fail body_fn)
+ = MatchResult CanFail (\fail -> body_fn fail `thenDs` \ body ->
+ returnDs (mkIfThenElse pred_expr body fail))
+
+mkCoPrimCaseMatchResult :: Id -- Scrutinee
+ -> Type -- Type of the case
+ -> [(Literal, MatchResult)] -- Alternatives
+ -> MatchResult
+mkCoPrimCaseMatchResult var ty match_alts
+ = MatchResult CanFail mk_case
+ where
+ mk_case fail
+ = mappM (mk_alt fail) sorted_alts `thenDs` \ alts ->
+ returnDs (Case (Var var) var ty ((DEFAULT, [], fail) : alts))
+
+ sorted_alts = sortWith fst match_alts -- Right order for a Case
+ mk_alt fail (lit, MatchResult _ body_fn) = body_fn fail `thenDs` \ body ->
+ returnDs (LitAlt lit, [], body)
+
+
+mkCoAlgCaseMatchResult :: Id -- Scrutinee
+ -> Type -- Type of exp
+ -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives
+ -> MatchResult
+mkCoAlgCaseMatchResult var ty match_alts
+ | isNewTyCon tycon -- Newtype case; use a let
+ = ASSERT( null (tail match_alts) && null (tail arg_ids1) )
+ mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1
+
+ | isPArrFakeAlts match_alts -- Sugared parallel array; use a literal case
+ = MatchResult CanFail mk_parrCase
+
+ | otherwise -- Datatype case; use a case
+ = MatchResult fail_flag mk_case
+ where
+ tycon = dataConTyCon con1
+ -- [Interesting: becuase of GADTs, we can't rely on the type of
+ -- the scrutinised Id to be sufficiently refined to have a TyCon in it]
+
+ -- Stuff for newtype
+ (con1, arg_ids1, match_result1) = head match_alts
+ arg_id1 = head arg_ids1
+ newtype_rhs = mkNewTypeBody tycon (idType arg_id1) (Var var)
+
+ -- Stuff for data types
+ data_cons = tyConDataCons tycon
+ match_results = [match_result | (_,_,match_result) <- match_alts]
+
+ fail_flag | exhaustive_case
+ = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
+ | otherwise
+ = CanFail
+
+ wild_var = mkWildId (idType var)
+ sorted_alts = sortWith get_tag match_alts
+ get_tag (con, _, _) = dataConTag con
+ mk_case fail = mappM (mk_alt fail) sorted_alts `thenDs` \ alts ->
+ returnDs (Case (Var var) wild_var ty (mk_default fail ++ alts))
+
+ mk_alt fail (con, args, MatchResult _ body_fn)
+ = body_fn fail `thenDs` \ body ->
+ newUniqueSupply `thenDs` \ us ->
+ returnDs (mkReboxingAlt (uniqsFromSupply us) con args body)
+
+ mk_default fail | exhaustive_case = []
+ | otherwise = [(DEFAULT, [], fail)]
+
+ un_mentioned_constructors
+ = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
+ exhaustive_case = isEmptyUniqSet un_mentioned_constructors
+
+ -- Stuff for parallel arrays
+ --
+ -- * the following is to desugar cases over fake constructors for
+ -- parallel arrays, which are introduced by `tidy1' in the `PArrPat'
+ -- case
+ --
+ -- Concerning `isPArrFakeAlts':
+ --
+ -- * it is *not* sufficient to just check the type of the type
+ -- constructor, as we have to be careful not to confuse the real
+ -- representation of parallel arrays with the fake constructors;
+ -- moreover, a list of alternatives must not mix fake and real
+ -- constructors (this is checked earlier on)
+ --
+ -- FIXME: We actually go through the whole list and make sure that
+ -- either all or none of the constructors are fake parallel
+ -- array constructors. This is to spot equations that mix fake
+ -- constructors with the real representation defined in
+ -- `PrelPArr'. It would be nicer to spot this situation
+ -- earlier and raise a proper error message, but it can really
+ -- only happen in `PrelPArr' anyway.
+ --
+ isPArrFakeAlts [(dcon, _, _)] = isPArrFakeCon dcon
+ isPArrFakeAlts ((dcon, _, _):alts) =
+ case (isPArrFakeCon dcon, isPArrFakeAlts alts) of
+ (True , True ) -> True
+ (False, False) -> False
+ _ ->
+ panic "DsUtils: You may not mix `[:...:]' with `PArr' patterns"
+ --
+ mk_parrCase fail =
+ dsLookupGlobalId lengthPName `thenDs` \lengthP ->
+ unboxAlt `thenDs` \alt ->
+ returnDs (Case (len lengthP) (mkWildId intTy) ty [alt])
+ where
+ elemTy = case splitTyConApp (idType var) of
+ (_, [elemTy]) -> elemTy
+ _ -> panic panicMsg
+ panicMsg = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?"
+ len lengthP = mkApps (Var lengthP) [Type elemTy, Var var]
+ --
+ unboxAlt =
+ newSysLocalDs intPrimTy `thenDs` \l ->
+ dsLookupGlobalId indexPName `thenDs` \indexP ->
+ mappM (mkAlt indexP) sorted_alts `thenDs` \alts ->
+ returnDs (DataAlt intDataCon, [l], (Case (Var l) wild ty (dft : alts)))
+ where
+ wild = mkWildId intPrimTy
+ dft = (DEFAULT, [], fail)
+ --
+ -- each alternative matches one array length (corresponding to one
+ -- fake array constructor), so the match is on a literal; each
+ -- alternative's body is extended by a local binding for each
+ -- constructor argument, which are bound to array elements starting
+ -- with the first
+ --
+ mkAlt indexP (con, args, MatchResult _ bodyFun) =
+ bodyFun fail `thenDs` \body ->
+ returnDs (LitAlt lit, [], mkDsLets binds body)
+ where
+ lit = MachInt $ toInteger (dataConSourceArity con)
+ binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] args]
+ --
+ indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr i]
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Desugarer's versions of some Core functions}
+%* *
+%************************************************************************
+
+\begin{code}
+mkErrorAppDs :: Id -- The error function
+ -> Type -- Type to which it should be applied
+ -> String -- The error message string to pass
+ -> DsM CoreExpr
+
+mkErrorAppDs err_id ty msg
+ = getSrcSpanDs `thenDs` \ src_loc ->
+ let
+ full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
+ core_msg = Lit (mkStringLit full_msg)
+ -- mkStringLit returns a result of type String#
+ in
+ returnDs (mkApps (Var err_id) [Type ty, core_msg])
+\end{code}
+
+
+*************************************************************
+%* *
+\subsection{Making literals}
+%* *
+%************************************************************************
+
+\begin{code}
+mkCharExpr :: Char -> CoreExpr -- Returns C# c :: Int
+mkIntExpr :: Integer -> CoreExpr -- Returns I# i :: Int
+mkIntegerExpr :: Integer -> DsM CoreExpr -- Result :: Integer
+mkStringExpr :: String -> DsM CoreExpr -- Result :: String
+mkStringExprFS :: FastString -> DsM CoreExpr -- Result :: String
+
+mkIntExpr i = mkConApp intDataCon [mkIntLit i]
+mkCharExpr c = mkConApp charDataCon [mkLit (MachChar c)]
+
+mkIntegerExpr i
+ | inIntRange i -- Small enough, so start from an Int
+ = dsLookupDataCon smallIntegerDataConName `thenDs` \ integer_dc ->
+ returnDs (mkSmallIntegerLit integer_dc i)
+
+-- Special case for integral literals with a large magnitude:
+-- They are transformed into an expression involving only smaller
+-- integral literals. This improves constant folding.
+
+ | otherwise -- Big, so start from a string
+ = dsLookupGlobalId plusIntegerName `thenDs` \ plus_id ->
+ dsLookupGlobalId timesIntegerName `thenDs` \ times_id ->
+ dsLookupDataCon smallIntegerDataConName `thenDs` \ integer_dc ->
+ let
+ lit i = mkSmallIntegerLit integer_dc i
+ plus a b = Var plus_id `App` a `App` b
+ times a b = Var times_id `App` a `App` b
+
+ -- Transform i into (x1 + (x2 + (x3 + (...) * b) * b) * b) with abs xi <= b
+ horner :: Integer -> Integer -> CoreExpr
+ horner b i | abs q <= 1 = if r == 0 || r == i
+ then lit i
+ else lit r `plus` lit (i-r)
+ | r == 0 = horner b q `times` lit b
+ | otherwise = lit r `plus` (horner b q `times` lit b)
+ where
+ (q,r) = i `quotRem` b
+
+ in
+ returnDs (horner tARGET_MAX_INT i)
+
+mkSmallIntegerLit small_integer_data_con i = mkConApp small_integer_data_con [mkIntLit i]
+
+mkStringExpr str = mkStringExprFS (mkFastString str)
+
+mkStringExprFS str
+ | nullFS str
+ = returnDs (mkNilExpr charTy)
+
+ | lengthFS str == 1
+ = let
+ the_char = mkCharExpr (headFS str)
+ in
+ returnDs (mkConsExpr charTy the_char (mkNilExpr charTy))
+
+ | all safeChar chars
+ = dsLookupGlobalId unpackCStringName `thenDs` \ unpack_id ->
+ returnDs (App (Var unpack_id) (Lit (MachStr str)))
+
+ | otherwise
+ = dsLookupGlobalId unpackCStringUtf8Name `thenDs` \ unpack_id ->
+ returnDs (App (Var unpack_id) (Lit (MachStr str)))
+
+ where
+ chars = unpackFS str
+ safeChar c = ord c >= 1 && ord c <= 0x7F
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[mkSelectorBind]{Make a selector bind}
+%* *
+%************************************************************************
+
+This is used in various places to do with lazy patterns.
+For each binder $b$ in the pattern, we create a binding:
+\begin{verbatim}
+ b = case v of pat' -> b'
+\end{verbatim}
+where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
+
+ToDo: making these bindings should really depend on whether there's
+much work to be done per binding. If the pattern is complex, it
+should be de-mangled once, into a tuple (and then selected from).
+Otherwise the demangling can be in-line in the bindings (as here).
+
+Boring! Boring! One error message per binder. The above ToDo is
+even more helpful. Something very similar happens for pattern-bound
+expressions.
+
+\begin{code}
+mkSelectorBinds :: LPat Id -- The pattern
+ -> CoreExpr -- Expression to which the pattern is bound
+ -> DsM [(Id,CoreExpr)]
+
+mkSelectorBinds (L _ (VarPat v)) val_expr
+ = returnDs [(v, val_expr)]
+
+mkSelectorBinds pat val_expr
+ | isSingleton binders || is_simple_lpat pat
+ = -- Given p = e, where p binds x,y
+ -- we are going to make
+ -- v = p (where v is fresh)
+ -- x = case v of p -> x
+ -- y = case v of p -> x
+
+ -- Make up 'v'
+ -- NB: give it the type of *pattern* p, not the type of the *rhs* e.
+ -- This does not matter after desugaring, but there's a subtle
+ -- issue with implicit parameters. Consider
+ -- (x,y) = ?i
+ -- Then, ?i is given type {?i :: Int}, a PredType, which is opaque
+ -- to the desugarer. (Why opaque? Because newtypes have to be. Why
+ -- does it get that type? So that when we abstract over it we get the
+ -- right top-level type (?i::Int) => ...)
+ --
+ -- So to get the type of 'v', use the pattern not the rhs. Often more
+ -- efficient too.
+ newSysLocalDs (hsPatType pat) `thenDs` \ val_var ->
+
+ -- For the error message we make one error-app, to avoid duplication.
+ -- But we need it at different types... so we use coerce for that
+ mkErrorAppDs iRREFUT_PAT_ERROR_ID
+ unitTy (showSDoc (ppr pat)) `thenDs` \ err_expr ->
+ newSysLocalDs unitTy `thenDs` \ err_var ->
+ mappM (mk_bind val_var err_var) binders `thenDs` \ binds ->
+ returnDs ( (val_var, val_expr) :
+ (err_var, err_expr) :
+ binds )
+
+
+ | otherwise
+ = mkErrorAppDs iRREFUT_PAT_ERROR_ID
+ tuple_ty (showSDoc (ppr pat)) `thenDs` \ error_expr ->
+ matchSimply val_expr PatBindRhs pat local_tuple error_expr `thenDs` \ tuple_expr ->
+ newSysLocalDs tuple_ty `thenDs` \ tuple_var ->
+ let
+ mk_tup_bind binder
+ = (binder, mkTupleSelector binders binder tuple_var (Var tuple_var))
+ in
+ returnDs ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
+ where
+ binders = collectPatBinders pat
+ local_tuple = mkTupleExpr binders
+ tuple_ty = exprType local_tuple
+
+ mk_bind scrut_var err_var bndr_var
+ -- (mk_bind sv err_var) generates
+ -- bv = case sv of { pat -> bv; other -> coerce (type-of-bv) err_var }
+ -- Remember, pat binds bv
+ = matchSimply (Var scrut_var) PatBindRhs pat
+ (Var bndr_var) error_expr `thenDs` \ rhs_expr ->
+ returnDs (bndr_var, rhs_expr)
+ where
+ error_expr = mkCoerce (idType bndr_var) (Var err_var)
+
+ is_simple_lpat p = is_simple_pat (unLoc p)
+
+ is_simple_pat (TuplePat ps Boxed _) = all is_triv_lpat ps
+ is_simple_pat (ConPatOut _ _ _ _ ps _) = all is_triv_lpat (hsConArgs ps)
+ is_simple_pat (VarPat _) = True
+ is_simple_pat (ParPat p) = is_simple_lpat p
+ is_simple_pat other = False
+
+ is_triv_lpat p = is_triv_pat (unLoc p)
+
+ is_triv_pat (VarPat v) = True
+ is_triv_pat (WildPat _) = True
+ is_triv_pat (ParPat p) = is_triv_lpat p
+ is_triv_pat other = False
+\end{code}
+
+
+%************************************************************************
+%* *
+ Tuples
+%* *
+%************************************************************************
+
+@mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@.
+
+* If it has only one element, it is the identity function.
+
+* If there are more elements than a big tuple can have, it nests
+ the tuples.
+
+Nesting policy. Better a 2-tuple of 10-tuples (3 objects) than
+a 10-tuple of 2-tuples (11 objects). So we want the leaves to be big.
+
+\begin{code}
+mkTupleExpr :: [Id] -> CoreExpr
+mkTupleExpr ids = mkBigCoreTup (map Var ids)
+
+-- corresponding type
+mkTupleType :: [Id] -> Type
+mkTupleType ids = mkBigTuple mkCoreTupTy (map idType ids)
+
+mkBigCoreTup :: [CoreExpr] -> CoreExpr
+mkBigCoreTup = mkBigTuple mkCoreTup
+
+mkBigTuple :: ([a] -> a) -> [a] -> a
+mkBigTuple small_tuple as = mk_big_tuple (chunkify as)
+ where
+ -- Each sub-list is short enough to fit in a tuple
+ mk_big_tuple [as] = small_tuple as
+ mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s))
+
+chunkify :: [a] -> [[a]]
+-- The sub-lists of the result all have length <= mAX_TUPLE_SIZE
+-- But there may be more than mAX_TUPLE_SIZE sub-lists
+chunkify xs
+ | n_xs <= mAX_TUPLE_SIZE = {- pprTrace "Small" (ppr n_xs) -} [xs]
+ | otherwise = {- pprTrace "Big" (ppr n_xs) -} (split xs)
+ where
+ n_xs = length xs
+ split [] = []
+ split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs)
+\end{code}
+
+
+@mkTupleSelector@ builds a selector which scrutises the given
+expression and extracts the one name from the list given.
+If you want the no-shadowing rule to apply, the caller
+is responsible for making sure that none of these names
+are in scope.
+
+If there is just one id in the ``tuple'', then the selector is
+just the identity.
+
+If it's big, it does nesting
+ mkTupleSelector [a,b,c,d] b v e
+ = case e of v {
+ (p,q) -> case p of p {
+ (a,b) -> b }}
+We use 'tpl' vars for the p,q, since shadowing does not matter.
+
+In fact, it's more convenient to generate it innermost first, getting
+
+ case (case e of v
+ (p,q) -> p) of p
+ (a,b) -> b
+
+\begin{code}
+mkTupleSelector :: [Id] -- The tuple args
+ -> Id -- The selected one
+ -> Id -- A variable of the same type as the scrutinee
+ -> CoreExpr -- Scrutinee
+ -> CoreExpr
+
+mkTupleSelector vars the_var scrut_var scrut
+ = mk_tup_sel (chunkify vars) the_var
+ where
+ mk_tup_sel [vars] the_var = mkCoreSel vars the_var scrut_var scrut
+ mk_tup_sel vars_s the_var = mkCoreSel group the_var tpl_v $
+ mk_tup_sel (chunkify tpl_vs) tpl_v
+ where
+ tpl_tys = [mkCoreTupTy (map idType gp) | gp <- vars_s]
+ tpl_vs = mkTemplateLocals tpl_tys
+ [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s,
+ the_var `elem` gp ]
+\end{code}
+
+A generalization of @mkTupleSelector@, allowing the body
+of the case to be an arbitrary expression.
+
+If the tuple is big, it is nested:
+
+ mkTupleCase uniqs [a,b,c,d] body v e
+ = case e of v { (p,q) ->
+ case p of p { (a,b) ->
+ case q of q { (c,d) ->
+ body }}}
+
+To avoid shadowing, we use uniqs to invent new variables p,q.
+
+ToDo: eliminate cases where none of the variables are needed.
+
+\begin{code}
+mkTupleCase
+ :: UniqSupply -- for inventing names of intermediate variables
+ -> [Id] -- the tuple args
+ -> CoreExpr -- body of the case
+ -> Id -- a variable of the same type as the scrutinee
+ -> CoreExpr -- scrutinee
+ -> CoreExpr
+
+mkTupleCase uniqs vars body scrut_var scrut
+ = mk_tuple_case uniqs (chunkify vars) body
+ where
+ mk_tuple_case us [vars] body
+ = mkSmallTupleCase vars body scrut_var scrut
+ mk_tuple_case us vars_s body
+ = let
+ (us', vars', body') = foldr one_tuple_case (us, [], body) vars_s
+ in
+ mk_tuple_case us' (chunkify vars') body'
+ one_tuple_case chunk_vars (us, vs, body)
+ = let
+ (us1, us2) = splitUniqSupply us
+ scrut_var = mkSysLocal FSLIT("ds") (uniqFromSupply us1)
+ (mkCoreTupTy (map idType chunk_vars))
+ body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var)
+ in (us2, scrut_var:vs, body')
+\end{code}
+
+The same, but with a tuple small enough not to need nesting.
+
+\begin{code}
+mkSmallTupleCase
+ :: [Id] -- the tuple args
+ -> CoreExpr -- body of the case
+ -> Id -- a variable of the same type as the scrutinee
+ -> CoreExpr -- scrutinee
+ -> CoreExpr
+
+mkSmallTupleCase [var] body _scrut_var scrut
+ = bindNonRec var scrut body
+mkSmallTupleCase vars body scrut_var scrut
+-- One branch no refinement?
+ = Case scrut scrut_var (exprType body) [(DataAlt (tupleCon Boxed (length vars)), vars, body)]
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[mkFailurePair]{Code for pattern-matching and other failures}
+%* *
+%************************************************************************
+
+Call the constructor Ids when building explicit lists, so that they
+interact well with rules.
+
+\begin{code}
+mkNilExpr :: Type -> CoreExpr
+mkNilExpr ty = mkConApp nilDataCon [Type ty]
+
+mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
+mkConsExpr ty hd tl = mkConApp consDataCon [Type ty, hd, tl]
+
+mkListExpr :: Type -> [CoreExpr] -> CoreExpr
+mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs
+
+
+-- The next three functions make tuple types, constructors and selectors,
+-- with the rule that a 1-tuple is represented by the thing itselg
+mkCoreTupTy :: [Type] -> Type
+mkCoreTupTy [ty] = ty
+mkCoreTupTy tys = mkTupleTy Boxed (length tys) tys
+
+mkCoreTup :: [CoreExpr] -> CoreExpr
+-- Builds exactly the specified tuple.
+-- No fancy business for big tuples
+mkCoreTup [] = Var unitDataConId
+mkCoreTup [c] = c
+mkCoreTup cs = mkConApp (tupleCon Boxed (length cs))
+ (map (Type . exprType) cs ++ cs)
+
+mkCoreSel :: [Id] -- The tuple args
+ -> Id -- The selected one
+ -> Id -- A variable of the same type as the scrutinee
+ -> CoreExpr -- Scrutinee
+ -> CoreExpr
+-- mkCoreSel [x,y,z] x v e
+-- ===> case e of v { (x,y,z) -> x
+mkCoreSel [var] should_be_the_same_var scrut_var scrut
+ = ASSERT(var == should_be_the_same_var)
+ scrut
+
+mkCoreSel vars the_var scrut_var scrut
+ = ASSERT( notNull vars )
+ Case scrut scrut_var (idType the_var)
+ [(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)]
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[mkFailurePair]{Code for pattern-matching and other failures}
+%* *
+%************************************************************************
+
+Generally, we handle pattern matching failure like this: let-bind a
+fail-variable, and use that variable if the thing fails:
+\begin{verbatim}
+ let fail.33 = error "Help"
+ in
+ case x of
+ p1 -> ...
+ p2 -> fail.33
+ p3 -> fail.33
+ p4 -> ...
+\end{verbatim}
+Then
+\begin{itemize}
+\item
+If the case can't fail, then there'll be no mention of @fail.33@, and the
+simplifier will later discard it.
+
+\item
+If it can fail in only one way, then the simplifier will inline it.
+
+\item
+Only if it is used more than once will the let-binding remain.
+\end{itemize}
+
+There's a problem when the result of the case expression is of
+unboxed type. Then the type of @fail.33@ is unboxed too, and
+there is every chance that someone will change the let into a case:
+\begin{verbatim}
+ case error "Help" of
+ fail.33 -> case ....
+\end{verbatim}
+
+which is of course utterly wrong. Rather than drop the condition that
+only boxed types can be let-bound, we just turn the fail into a function
+for the primitive case:
+\begin{verbatim}
+ let fail.33 :: Void -> Int#
+ fail.33 = \_ -> error "Help"
+ in
+ case x of
+ p1 -> ...
+ p2 -> fail.33 void
+ p3 -> fail.33 void
+ p4 -> ...
+\end{verbatim}
+
+Now @fail.33@ is a function, so it can be let-bound.
+
+\begin{code}
+mkFailurePair :: CoreExpr -- Result type of the whole case expression
+ -> DsM (CoreBind, -- Binds the newly-created fail variable
+ -- to either the expression or \ _ -> expression
+ CoreExpr) -- Either the fail variable, or fail variable
+ -- applied to unit tuple
+mkFailurePair expr
+ | isUnLiftedType ty
+ = newFailLocalDs (unitTy `mkFunTy` ty) `thenDs` \ fail_fun_var ->
+ newSysLocalDs unitTy `thenDs` \ fail_fun_arg ->
+ returnDs (NonRec fail_fun_var (Lam fail_fun_arg expr),
+ App (Var fail_fun_var) (Var unitDataConId))
+
+ | otherwise
+ = newFailLocalDs ty `thenDs` \ fail_var ->
+ returnDs (NonRec fail_var expr, Var fail_var)
+ where
+ ty = exprType expr
+\end{code}
+
+
diff --git a/compiler/deSugar/Match.hi-boot-5 b/compiler/deSugar/Match.hi-boot-5
new file mode 100644
index 0000000000..42c200fbff
--- /dev/null
+++ b/compiler/deSugar/Match.hi-boot-5
@@ -0,0 +1,6 @@
+__interface Match 1 0 where
+__export Match match matchExport matchSimply matchSinglePat;
+1 match :: [Var.Id] -> [DsUtils.EquationInfo] -> DsMonad.DsM DsUtils.MatchResult ;
+1 matchExport :: [Var.Id] -> [DsUtils.EquationInfo] -> DsMonad.DsM DsUtils.MatchResult ;
+1 matchSimply :: CoreSyn.CoreExpr -> HsExpr.HsMatchContext Name.Name -> HsPat.LPat Var.Id -> CoreSyn.CoreExpr -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr ;
+1 matchSinglePat :: CoreSyn.CoreExpr -> DsMonad.DsMatchContext -> HsPat.LPat Var.Id -> DsUtils.MatchResult -> DsMonad.DsM DsUtils.MatchResult ;
diff --git a/compiler/deSugar/Match.hi-boot-6 b/compiler/deSugar/Match.hi-boot-6
new file mode 100644
index 0000000000..df806ec644
--- /dev/null
+++ b/compiler/deSugar/Match.hi-boot-6
@@ -0,0 +1,27 @@
+module Match where
+
+match :: [Var.Id]
+ -> TcType.TcType
+ -> [DsMonad.EquationInfo]
+ -> DsMonad.DsM DsMonad.MatchResult
+
+matchWrapper
+ :: HsExpr.HsMatchContext Name.Name
+ -> HsExpr.MatchGroup Var.Id
+ -> DsMonad.DsM ([Var.Id], CoreSyn.CoreExpr)
+
+matchSimply
+ :: CoreSyn.CoreExpr
+ -> HsExpr.HsMatchContext Name.Name
+ -> HsPat.LPat Var.Id
+ -> CoreSyn.CoreExpr
+ -> CoreSyn.CoreExpr
+ -> DsMonad.DsM CoreSyn.CoreExpr
+
+matchSinglePat
+ :: CoreSyn.CoreExpr
+ -> HsExpr.HsMatchContext Name.Name
+ -> HsPat.LPat Var.Id
+ -> TcType.TcType
+ -> DsMonad.MatchResult
+ -> DsMonad.DsM DsMonad.MatchResult
diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs
new file mode 100644
index 0000000000..d72d6adf17
--- /dev/null
+++ b/compiler/deSugar/Match.lhs
@@ -0,0 +1,740 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[Main_match]{The @match@ function}
+
+\begin{code}
+module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where
+
+#include "HsVersions.h"
+
+import DynFlags ( DynFlag(..), dopt )
+import HsSyn
+import TcHsSyn ( mkVanillaTuplePat )
+import Check ( check, ExhaustivePat )
+import CoreSyn
+import CoreUtils ( bindNonRec, exprType )
+import DsMonad
+import DsBinds ( dsLHsBinds )
+import DsGRHSs ( dsGRHSs )
+import DsUtils
+import Id ( idName, idType, Id )
+import DataCon ( dataConFieldLabels, dataConInstOrigArgTys, isVanillaDataCon )
+import MatchCon ( matchConFamily )
+import MatchLit ( matchLiterals, matchNPlusKPats, matchNPats, tidyLitPat, tidyNPat )
+import PrelInfo ( pAT_ERROR_ID )
+import TcType ( Type, tcTyConAppArgs )
+import Type ( splitFunTysN, mkTyVarTys )
+import TysWiredIn ( consDataCon, mkListTy, unitTy,
+ tupleCon, parrFakeCon, mkPArrTy )
+import BasicTypes ( Boxity(..) )
+import ListSetOps ( runs )
+import SrcLoc ( noLoc, unLoc, Located(..) )
+import Util ( lengthExceeds, notNull )
+import Name ( Name )
+import Outputable
+\end{code}
+
+This function is a wrapper of @match@, it must be called from all the parts where
+it was called match, but only substitutes the firs call, ....
+if the associated flags are declared, warnings will be issued.
+It can not be called matchWrapper because this name already exists :-(
+
+JJCQ 30-Nov-1997
+
+\begin{code}
+matchCheck :: DsMatchContext
+ -> [Id] -- Vars rep'ing the exprs we're matching with
+ -> Type -- Type of the case expression
+ -> [EquationInfo] -- Info about patterns, etc. (type synonym below)
+ -> DsM MatchResult -- Desugared result!
+
+matchCheck ctx vars ty qs
+ = getDOptsDs `thenDs` \ dflags ->
+ matchCheck_really dflags ctx vars ty qs
+
+matchCheck_really dflags ctx vars ty qs
+ | incomplete && shadow =
+ dsShadowWarn ctx eqns_shadow `thenDs` \ () ->
+ dsIncompleteWarn ctx pats `thenDs` \ () ->
+ match vars ty qs
+ | incomplete =
+ dsIncompleteWarn ctx pats `thenDs` \ () ->
+ match vars ty qs
+ | shadow =
+ dsShadowWarn ctx eqns_shadow `thenDs` \ () ->
+ match vars ty qs
+ | otherwise =
+ match vars ty qs
+ where (pats, eqns_shadow) = check qs
+ incomplete = want_incomplete && (notNull pats)
+ want_incomplete = case ctx of
+ DsMatchContext RecUpd _ ->
+ dopt Opt_WarnIncompletePatternsRecUpd dflags
+ _ ->
+ dopt Opt_WarnIncompletePatterns dflags
+ shadow = dopt Opt_WarnOverlappingPatterns dflags
+ && not (null eqns_shadow)
+\end{code}
+
+This variable shows the maximum number of lines of output generated for warnings.
+It will limit the number of patterns/equations displayed to@ maximum_output@.
+
+(ToDo: add command-line option?)
+
+\begin{code}
+maximum_output = 4
+\end{code}
+
+The next two functions create the warning message.
+
+\begin{code}
+dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM ()
+dsShadowWarn ctx@(DsMatchContext kind loc) qs
+ = putSrcSpanDs loc (dsWarn warn)
+ where
+ warn | qs `lengthExceeds` maximum_output
+ = pp_context ctx (ptext SLIT("are overlapped"))
+ (\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$
+ ptext SLIT("..."))
+ | otherwise
+ = pp_context ctx (ptext SLIT("are overlapped"))
+ (\ f -> vcat $ map (ppr_eqn f kind) qs)
+
+
+dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM ()
+dsIncompleteWarn ctx@(DsMatchContext kind loc) pats
+ = putSrcSpanDs loc (dsWarn warn)
+ where
+ warn = pp_context ctx (ptext SLIT("are non-exhaustive"))
+ (\f -> hang (ptext SLIT("Patterns not matched:"))
+ 4 ((vcat $ map (ppr_incomplete_pats kind)
+ (take maximum_output pats))
+ $$ dots))
+
+ dots | pats `lengthExceeds` maximum_output = ptext SLIT("...")
+ | otherwise = empty
+
+pp_context (DsMatchContext kind _loc) msg rest_of_msg_fun
+ = vcat [ptext SLIT("Pattern match(es)") <+> msg,
+ sep [ptext SLIT("In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]]
+ where
+ (ppr_match, pref)
+ = case kind of
+ FunRhs fun -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
+ other -> (pprMatchContext kind, \ pp -> pp)
+
+ppr_pats pats = sep (map ppr pats)
+
+ppr_shadow_pats kind pats
+ = sep [ppr_pats pats, matchSeparator kind, ptext SLIT("...")]
+
+ppr_incomplete_pats kind (pats,[]) = ppr_pats pats
+ppr_incomplete_pats kind (pats,constraints) =
+ sep [ppr_pats pats, ptext SLIT("with"),
+ sep (map ppr_constraint constraints)]
+
+
+ppr_constraint (var,pats) = sep [ppr var, ptext SLIT("`notElem`"), ppr pats]
+
+ppr_eqn prefixF kind eqn = prefixF (ppr_shadow_pats kind (eqn_pats eqn))
+\end{code}
+
+
+The function @match@ is basically the same as in the Wadler chapter,
+except it is monadised, to carry around the name supply, info about
+annotations, etc.
+
+Notes on @match@'s arguments, assuming $m$ equations and $n$ patterns:
+\begin{enumerate}
+\item
+A list of $n$ variable names, those variables presumably bound to the
+$n$ expressions being matched against the $n$ patterns. Using the
+list of $n$ expressions as the first argument showed no benefit and
+some inelegance.
+
+\item
+The second argument, a list giving the ``equation info'' for each of
+the $m$ equations:
+\begin{itemize}
+\item
+the $n$ patterns for that equation, and
+\item
+a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on
+the front'' of the matching code, as in:
+\begin{verbatim}
+let <binds>
+in <matching-code>
+\end{verbatim}
+\item
+and finally: (ToDo: fill in)
+
+The right way to think about the ``after-match function'' is that it
+is an embryonic @CoreExpr@ with a ``hole'' at the end for the
+final ``else expression''.
+\end{itemize}
+
+There is a type synonym, @EquationInfo@, defined in module @DsUtils@.
+
+An experiment with re-ordering this information about equations (in
+particular, having the patterns available in column-major order)
+showed no benefit.
+
+\item
+A default expression---what to evaluate if the overall pattern-match
+fails. This expression will (almost?) always be
+a measly expression @Var@, unless we know it will only be used once
+(as we do in @glue_success_exprs@).
+
+Leaving out this third argument to @match@ (and slamming in lots of
+@Var "fail"@s) is a positively {\em bad} idea, because it makes it
+impossible to share the default expressions. (Also, it stands no
+chance of working in our post-upheaval world of @Locals@.)
+\end{enumerate}
+So, the full type signature:
+\begin{code}
+match :: [Id] -- Variables rep'ing the exprs we're matching with
+ -> Type -- Type of the case expression
+ -> [EquationInfo] -- Info about patterns, etc. (type synonym below)
+ -> DsM MatchResult -- Desugared result!
+\end{code}
+
+Note: @match@ is often called via @matchWrapper@ (end of this module),
+a function that does much of the house-keeping that goes with a call
+to @match@.
+
+It is also worth mentioning the {\em typical} way a block of equations
+is desugared with @match@. At each stage, it is the first column of
+patterns that is examined. The steps carried out are roughly:
+\begin{enumerate}
+\item
+Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add
+bindings to the second component of the equation-info):
+\begin{itemize}
+\item
+Remove the `as' patterns from column~1.
+\item
+Make all constructor patterns in column~1 into @ConPats@, notably
+@ListPats@ and @TuplePats@.
+\item
+Handle any irrefutable (or ``twiddle'') @LazyPats@.
+\end{itemize}
+\item
+Now {\em unmix} the equations into {\em blocks} [w/ local function
+@unmix_eqns@], in which the equations in a block all have variable
+patterns in column~1, or they all have constructor patterns in ...
+(see ``the mixture rule'' in SLPJ).
+\item
+Call @matchEqnBlock@ on each block of equations; it will do the
+appropriate thing for each kind of column-1 pattern, usually ending up
+in a recursive call to @match@.
+\end{enumerate}
+
+%************************************************************************
+%* *
+%* match: empty rule *
+%* *
+%************************************************************************
+\subsection[Match-empty-rule]{The ``empty rule''}
+
+We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87)
+than the Wadler-chapter code for @match@ (p.~93, first @match@ clause).
+And gluing the ``success expressions'' together isn't quite so pretty.
+
+\begin{code}
+match [] ty eqns_info
+ = ASSERT( not (null eqns_info) )
+ returnDs (foldr1 combineMatchResults match_results)
+ where
+ match_results = [ ASSERT( null (eqn_pats eqn) )
+ adjustMatchResult (eqn_wrap eqn) (eqn_rhs eqn)
+ | eqn <- eqns_info ]
+\end{code}
+
+
+%************************************************************************
+%* *
+%* match: non-empty rule *
+%* *
+%************************************************************************
+\subsection[Match-nonempty]{@match@ when non-empty: unmixing}
+
+This (more interesting) clause of @match@ uses @tidy_and_unmix_eqns@
+(a)~to get `as'- and `twiddle'-patterns out of the way (tidying), and
+(b)~to do ``the mixture rule'' (SLPJ, p.~88) [which really {\em
+un}mixes the equations], producing a list of equation-info
+blocks, each block having as its first column of patterns either all
+constructors, or all variables (or similar beasts), etc.
+
+@match_unmixed_eqn_blks@ simply takes the place of the @foldr@ in the
+Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@
+corresponds roughly to @matchVarCon@.
+
+\begin{code}
+match vars@(v:_) ty eqns_info
+ = do { tidy_eqns <- mappM (tidyEqnInfo v) eqns_info
+ ; let eqns_blks = runs same_family tidy_eqns
+ ; match_results <- mappM match_block eqns_blks
+ ; ASSERT( not (null match_results) )
+ return (foldr1 combineMatchResults match_results) }
+ where
+ same_family eqn1 eqn2
+ = samePatFamily (firstPat eqn1) (firstPat eqn2)
+
+ match_block eqns
+ = case firstPat (head eqns) of
+ WildPat {} -> matchVariables vars ty eqns
+ ConPatOut {} -> matchConFamily vars ty eqns
+ NPlusKPat {} -> matchNPlusKPats vars ty eqns
+ NPat {} -> matchNPats vars ty eqns
+ LitPat {} -> matchLiterals vars ty eqns
+
+-- After tidying, there are only five kinds of patterns
+samePatFamily (WildPat {}) (WildPat {}) = True
+samePatFamily (ConPatOut {}) (ConPatOut {}) = True
+samePatFamily (NPlusKPat {}) (NPlusKPat {}) = True
+samePatFamily (NPat {}) (NPat {}) = True
+samePatFamily (LitPat {}) (LitPat {}) = True
+samePatFamily _ _ = False
+
+matchVariables :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
+-- Real true variables, just like in matchVar, SLPJ p 94
+-- No binding to do: they'll all be wildcards by now (done in tidy)
+matchVariables (var:vars) ty eqns = match vars ty (shiftEqns eqns)
+\end{code}
+
+
+\end{code}
+
+Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@
+which will be scrutinised. This means:
+\begin{itemize}
+\item
+Replace variable patterns @x@ (@x /= v@) with the pattern @_@,
+together with the binding @x = v@.
+\item
+Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@.
+\item
+Removing lazy (irrefutable) patterns (you don't want to know...).
+\item
+Converting explicit tuple-, list-, and parallel-array-pats into ordinary
+@ConPats@.
+\item
+Convert the literal pat "" to [].
+\end{itemize}
+
+The result of this tidying is that the column of patterns will include
+{\em only}:
+\begin{description}
+\item[@WildPats@:]
+The @VarPat@ information isn't needed any more after this.
+
+\item[@ConPats@:]
+@ListPats@, @TuplePats@, etc., are all converted into @ConPats@.
+
+\item[@LitPats@ and @NPats@:]
+@LitPats@/@NPats@ of ``known friendly types'' (Int, Char,
+Float, Double, at least) are converted to unboxed form; e.g.,
+\tr{(NPat (HsInt i) _ _)} is converted to:
+\begin{verbatim}
+(ConPat I# _ _ [LitPat (HsIntPrim i)])
+\end{verbatim}
+\end{description}
+
+\begin{code}
+tidyEqnInfo :: Id -> EquationInfo -> DsM EquationInfo
+ -- DsM'd because of internal call to dsLHsBinds
+ -- and mkSelectorBinds.
+ -- "tidy1" does the interesting stuff, looking at
+ -- one pattern and fiddling the list of bindings.
+ --
+ -- POST CONDITION: head pattern in the EqnInfo is
+ -- WildPat
+ -- ConPat
+ -- NPat
+ -- LitPat
+ -- NPlusKPat
+ -- but no other
+
+tidyEqnInfo v eqn@(EqnInfo { eqn_wrap = wrap, eqn_pats = pat : pats })
+ = tidy1 v wrap pat `thenDs` \ (wrap', pat') ->
+ returnDs (eqn { eqn_wrap = wrap', eqn_pats = pat' : pats })
+
+tidy1 :: Id -- The Id being scrutinised
+ -> DsWrapper -- Previous wrapping bindings
+ -> Pat Id -- The pattern against which it is to be matched
+ -> DsM (DsWrapper, -- Extra bindings around what to do afterwards
+ Pat Id) -- Equivalent pattern
+
+-- The extra bindings etc are all wrapped around the RHS of the match
+-- so they are only available when matching is complete. But that's ok
+-- becuase, for example, in the pattern x@(...), the x can only be
+-- used in the RHS, not in the nested pattern, nor subsquent patterns
+--
+-- However this does have an awkward consequence. The bindings in
+-- a VarPatOut get wrapped around the result in right to left order,
+-- rather than left to right. This only matters if one set of
+-- bindings can mention things used in another, and that can happen
+-- if we allow equality dictionary bindings of form d1=d2.
+-- bindIInstsOfLocalFuns is now careful not to do this, but it's a wart.
+-- (Without this care in bindInstsOfLocalFuns, compiling
+-- Data.Generics.Schemes.hs fails in function everywhereBut.)
+
+-------------------------------------------------------
+-- (pat', mr') = tidy1 v pat mr
+-- tidies the *outer level only* of pat, giving pat'
+-- It eliminates many pattern forms (as-patterns, variable patterns,
+-- list patterns, etc) yielding one of:
+-- WildPat
+-- ConPatOut
+-- LitPat
+-- NPat
+-- NPlusKPat
+
+tidy1 v wrap (ParPat pat) = tidy1 v wrap (unLoc pat)
+tidy1 v wrap (SigPatOut pat _) = tidy1 v wrap (unLoc pat)
+tidy1 v wrap (WildPat ty) = returnDs (wrap, WildPat ty)
+
+ -- case v of { x -> mr[] }
+ -- = case v of { _ -> let x=v in mr[] }
+tidy1 v wrap (VarPat var)
+ = returnDs (wrap . wrapBind var v, WildPat (idType var))
+
+tidy1 v wrap (VarPatOut var binds)
+ = do { prs <- dsLHsBinds binds
+ ; return (wrap . wrapBind var v . mkDsLet (Rec prs),
+ WildPat (idType var)) }
+
+ -- case v of { x@p -> mr[] }
+ -- = case v of { p -> let x=v in mr[] }
+tidy1 v wrap (AsPat (L _ var) pat)
+ = tidy1 v (wrap . wrapBind var v) (unLoc pat)
+
+tidy1 v wrap (BangPat pat)
+ = tidy1 v (wrap . seqVar v) (unLoc pat)
+
+{- now, here we handle lazy patterns:
+ tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
+ v2 = case v of p -> v2 : ... : bs )
+
+ where the v_i's are the binders in the pattern.
+
+ ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing?
+
+ The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
+-}
+
+tidy1 v wrap (LazyPat pat)
+ = do { v' <- newSysLocalDs (idType v)
+ ; sel_prs <- mkSelectorBinds pat (Var v)
+ ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs]
+ ; returnDs (wrap . wrapBind v' v . mkDsLets sel_binds,
+ WildPat (idType v)) }
+
+-- re-express <con-something> as (ConPat ...) [directly]
+
+tidy1 v wrap (ConPatOut (L loc con) ex_tvs dicts binds ps pat_ty)
+ = returnDs (wrap, ConPatOut (L loc con) ex_tvs dicts binds tidy_ps pat_ty)
+ where
+ tidy_ps = PrefixCon (tidy_con con ex_tvs pat_ty ps)
+
+tidy1 v wrap (ListPat pats ty)
+ = returnDs (wrap, unLoc list_ConPat)
+ where
+ list_ty = mkListTy ty
+ list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] list_ty)
+ (mkNilPat list_ty)
+ pats
+
+-- Introduce fake parallel array constructors to be able to handle parallel
+-- arrays with the existing machinery for constructor pattern
+tidy1 v wrap (PArrPat pats ty)
+ = returnDs (wrap, unLoc parrConPat)
+ where
+ arity = length pats
+ parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty)
+
+tidy1 v wrap (TuplePat pats boxity ty)
+ = returnDs (wrap, unLoc tuple_ConPat)
+ where
+ arity = length pats
+ tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats ty
+
+tidy1 v wrap (DictPat dicts methods)
+ = case num_of_d_and_ms of
+ 0 -> tidy1 v wrap (TuplePat [] Boxed unitTy)
+ 1 -> tidy1 v wrap (unLoc (head dict_and_method_pats))
+ _ -> tidy1 v wrap (mkVanillaTuplePat dict_and_method_pats Boxed)
+ where
+ num_of_d_and_ms = length dicts + length methods
+ dict_and_method_pats = map nlVarPat (dicts ++ methods)
+
+-- LitPats: we *might* be able to replace these w/ a simpler form
+tidy1 v wrap pat@(LitPat lit)
+ = returnDs (wrap, unLoc (tidyLitPat lit (noLoc pat)))
+
+-- NPats: we *might* be able to replace these w/ a simpler form
+tidy1 v wrap pat@(NPat lit mb_neg _ lit_ty)
+ = returnDs (wrap, unLoc (tidyNPat lit mb_neg lit_ty (noLoc pat)))
+
+-- and everything else goes through unchanged...
+
+tidy1 v wrap non_interesting_pat
+ = returnDs (wrap, non_interesting_pat)
+
+
+tidy_con data_con ex_tvs pat_ty (PrefixCon ps) = ps
+tidy_con data_con ex_tvs pat_ty (InfixCon p1 p2) = [p1,p2]
+tidy_con data_con ex_tvs pat_ty (RecCon rpats)
+ | null rpats
+ = -- Special case for C {}, which can be used for
+ -- a constructor that isn't declared to have
+ -- fields at all
+ map (noLoc . WildPat) con_arg_tys'
+
+ | otherwise
+ = map mk_pat tagged_arg_tys
+ where
+ -- Boring stuff to find the arg-tys of the constructor
+
+ inst_tys | isVanillaDataCon data_con = tcTyConAppArgs pat_ty -- Newtypes must be opaque
+ | otherwise = mkTyVarTys ex_tvs
+
+ con_arg_tys' = dataConInstOrigArgTys data_con inst_tys
+ tagged_arg_tys = con_arg_tys' `zip` dataConFieldLabels data_con
+
+ -- mk_pat picks a WildPat of the appropriate type for absent fields,
+ -- and the specified pattern for present fields
+ mk_pat (arg_ty, lbl) =
+ case [ pat | (sel_id,pat) <- rpats, idName (unLoc sel_id) == lbl] of
+ (pat:pats) -> ASSERT( null pats ) pat
+ [] -> noLoc (WildPat arg_ty)
+\end{code}
+
+\noindent
+{\bf Previous @matchTwiddled@ stuff:}
+
+Now we get to the only interesting part; note: there are choices for
+translation [from Simon's notes]; translation~1:
+\begin{verbatim}
+deTwiddle [s,t] e
+\end{verbatim}
+returns
+\begin{verbatim}
+[ w = e,
+ s = case w of [s,t] -> s
+ t = case w of [s,t] -> t
+]
+\end{verbatim}
+
+Here \tr{w} is a fresh variable, and the \tr{w}-binding prevents multiple
+evaluation of \tr{e}. An alternative translation (No.~2):
+\begin{verbatim}
+[ w = case e of [s,t] -> (s,t)
+ s = case w of (s,t) -> s
+ t = case w of (s,t) -> t
+]
+\end{verbatim}
+
+%************************************************************************
+%* *
+\subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing}
+%* *
+%************************************************************************
+
+We might be able to optimise unmixing when confronted by
+only-one-constructor-possible, of which tuples are the most notable
+examples. Consider:
+\begin{verbatim}
+f (a,b,c) ... = ...
+f d ... (e:f) = ...
+f (g,h,i) ... = ...
+f j ... = ...
+\end{verbatim}
+This definition would normally be unmixed into four equation blocks,
+one per equation. But it could be unmixed into just one equation
+block, because if the one equation matches (on the first column),
+the others certainly will.
+
+You have to be careful, though; the example
+\begin{verbatim}
+f j ... = ...
+-------------------
+f (a,b,c) ... = ...
+f d ... (e:f) = ...
+f (g,h,i) ... = ...
+\end{verbatim}
+{\em must} be broken into two blocks at the line shown; otherwise, you
+are forcing unnecessary evaluation. In any case, the top-left pattern
+always gives the cue. You could then unmix blocks into groups of...
+\begin{description}
+\item[all variables:]
+As it is now.
+\item[constructors or variables (mixed):]
+Need to make sure the right names get bound for the variable patterns.
+\item[literals or variables (mixed):]
+Presumably just a variant on the constructor case (as it is now).
+\end{description}
+
+%************************************************************************
+%* *
+%* matchWrapper: a convenient way to call @match@ *
+%* *
+%************************************************************************
+\subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@}
+
+Calls to @match@ often involve similar (non-trivial) work; that work
+is collected here, in @matchWrapper@. This function takes as
+arguments:
+\begin{itemize}
+\item
+Typchecked @Matches@ (of a function definition, or a case or lambda
+expression)---the main input;
+\item
+An error message to be inserted into any (runtime) pattern-matching
+failure messages.
+\end{itemize}
+
+As results, @matchWrapper@ produces:
+\begin{itemize}
+\item
+A list of variables (@Locals@) that the caller must ``promise'' to
+bind to appropriate values; and
+\item
+a @CoreExpr@, the desugared output (main result).
+\end{itemize}
+
+The main actions of @matchWrapper@ include:
+\begin{enumerate}
+\item
+Flatten the @[TypecheckedMatch]@ into a suitable list of
+@EquationInfo@s.
+\item
+Create as many new variables as there are patterns in a pattern-list
+(in any one of the @EquationInfo@s).
+\item
+Create a suitable ``if it fails'' expression---a call to @error@ using
+the error-string input; the {\em type} of this fail value can be found
+by examining one of the RHS expressions in one of the @EquationInfo@s.
+\item
+Call @match@ with all of this information!
+\end{enumerate}
+
+\begin{code}
+matchWrapper :: HsMatchContext Name -- For shadowing warning messages
+ -> MatchGroup Id -- Matches being desugared
+ -> DsM ([Id], CoreExpr) -- Results
+\end{code}
+
+ There is one small problem with the Lambda Patterns, when somebody
+ writes something similar to:
+\begin{verbatim}
+ (\ (x:xs) -> ...)
+\end{verbatim}
+ he/she don't want a warning about incomplete patterns, that is done with
+ the flag @opt_WarnSimplePatterns@.
+ This problem also appears in the:
+\begin{itemize}
+\item @do@ patterns, but if the @do@ can fail
+ it creates another equation if the match can fail
+ (see @DsExpr.doDo@ function)
+\item @let@ patterns, are treated by @matchSimply@
+ List Comprension Patterns, are treated by @matchSimply@ also
+\end{itemize}
+
+We can't call @matchSimply@ with Lambda patterns,
+due to the fact that lambda patterns can have more than
+one pattern, and match simply only accepts one pattern.
+
+JJQC 30-Nov-1997
+
+\begin{code}
+matchWrapper ctxt (MatchGroup matches match_ty)
+ = do { eqns_info <- mapM mk_eqn_info matches
+ ; new_vars <- selectMatchVars arg_pats pat_tys
+ ; result_expr <- matchEquations ctxt new_vars eqns_info rhs_ty
+ ; return (new_vars, result_expr) }
+ where
+ arg_pats = map unLoc (hsLMatchPats (head matches))
+ n_pats = length arg_pats
+ (pat_tys, rhs_ty) = splitFunTysN n_pats match_ty
+
+ mk_eqn_info (L _ (Match pats _ grhss))
+ = do { let upats = map unLoc pats
+ ; match_result <- dsGRHSs ctxt upats grhss rhs_ty
+ ; return (EqnInfo { eqn_wrap = idWrapper,
+ eqn_pats = upats,
+ eqn_rhs = match_result}) }
+
+
+matchEquations :: HsMatchContext Name
+ -> [Id] -> [EquationInfo] -> Type
+ -> DsM CoreExpr
+matchEquations ctxt vars eqns_info rhs_ty
+ = do { dflags <- getDOptsDs
+ ; locn <- getSrcSpanDs
+ ; let ds_ctxt = DsMatchContext ctxt locn
+ error_string = matchContextErrString ctxt
+
+ ; match_result <- match_fun dflags ds_ctxt vars rhs_ty eqns_info
+
+ ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_string
+ ; extractMatchResult match_result fail_expr }
+ where
+ match_fun dflags ds_ctxt
+ = case ctxt of
+ LambdaExpr | dopt Opt_WarnSimplePatterns dflags -> matchCheck ds_ctxt
+ | otherwise -> match
+ _ -> matchCheck ds_ctxt
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern}
+%* *
+%************************************************************************
+
+@mkSimpleMatch@ is a wrapper for @match@ which deals with the
+situation where we want to match a single expression against a single
+pattern. It returns an expression.
+
+\begin{code}
+matchSimply :: CoreExpr -- Scrutinee
+ -> HsMatchContext Name -- Match kind
+ -> LPat Id -- Pattern it should match
+ -> CoreExpr -- Return this if it matches
+ -> CoreExpr -- Return this if it doesn't
+ -> DsM CoreExpr
+
+matchSimply scrut hs_ctx pat result_expr fail_expr
+ = let
+ match_result = cantFailMatchResult result_expr
+ rhs_ty = exprType fail_expr
+ -- Use exprType of fail_expr, because won't refine in the case of failure!
+ in
+ matchSinglePat scrut hs_ctx pat rhs_ty match_result `thenDs` \ match_result' ->
+ extractMatchResult match_result' fail_expr
+
+
+matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id
+ -> Type -> MatchResult -> DsM MatchResult
+matchSinglePat (Var var) hs_ctx (L _ pat) ty match_result
+ = getDOptsDs `thenDs` \ dflags ->
+ getSrcSpanDs `thenDs` \ locn ->
+ let
+ match_fn dflags
+ | dopt Opt_WarnSimplePatterns dflags = matchCheck ds_ctx
+ | otherwise = match
+ where
+ ds_ctx = DsMatchContext hs_ctx locn
+ in
+ match_fn dflags [var] ty [EqnInfo { eqn_wrap = idWrapper,
+ eqn_pats = [pat],
+ eqn_rhs = match_result }]
+
+matchSinglePat scrut hs_ctx pat ty match_result
+ = selectSimpleMatchVarL pat `thenDs` \ var ->
+ matchSinglePat (Var var) hs_ctx pat ty match_result `thenDs` \ match_result' ->
+ returnDs (adjustMatchResult (bindNonRec var scrut) match_result')
+\end{code}
+
diff --git a/compiler/deSugar/Match.lhs-boot b/compiler/deSugar/Match.lhs-boot
new file mode 100644
index 0000000000..5f99f5cc1a
--- /dev/null
+++ b/compiler/deSugar/Match.lhs-boot
@@ -0,0 +1,35 @@
+\begin{code}
+module Match where
+import Var ( Id )
+import TcType ( TcType )
+import DsMonad ( DsM, EquationInfo, MatchResult )
+import CoreSyn ( CoreExpr )
+import HsSyn ( LPat, HsMatchContext, MatchGroup )
+import Name ( Name )
+
+match :: [Id]
+ -> TcType
+ -> [EquationInfo]
+ -> DsM MatchResult
+
+matchWrapper
+ :: HsMatchContext Name
+ -> MatchGroup Id
+ -> DsM ([Id], CoreExpr)
+
+matchSimply
+ :: CoreExpr
+ -> HsMatchContext Name
+ -> LPat Id
+ -> CoreExpr
+ -> CoreExpr
+ -> DsM CoreExpr
+
+matchSinglePat
+ :: CoreExpr
+ -> HsMatchContext Name
+ -> LPat Id
+ -> TcType
+ -> MatchResult
+ -> DsM MatchResult
+\end{code}
diff --git a/compiler/deSugar/MatchCon.lhs b/compiler/deSugar/MatchCon.lhs
new file mode 100644
index 0000000000..6ff502a8ae
--- /dev/null
+++ b/compiler/deSugar/MatchCon.lhs
@@ -0,0 +1,174 @@
+
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[MatchCon]{Pattern-matching constructors}
+
+\begin{code}
+module MatchCon ( matchConFamily ) where
+
+#include "HsVersions.h"
+
+import Id( idType )
+
+import {-# SOURCE #-} Match ( match )
+
+import HsSyn ( Pat(..), HsConDetails(..) )
+import DsBinds ( dsLHsBinds )
+import DataCon ( isVanillaDataCon, dataConInstOrigArgTys )
+import TcType ( tcTyConAppArgs )
+import Type ( mkTyVarTys )
+import CoreSyn
+import DsMonad
+import DsUtils
+
+import Id ( Id )
+import Type ( Type )
+import ListSetOps ( equivClassesByUniq )
+import SrcLoc ( unLoc, Located(..) )
+import Unique ( Uniquable(..) )
+import Outputable
+\end{code}
+
+We are confronted with the first column of patterns in a set of
+equations, all beginning with constructors from one ``family'' (e.g.,
+@[]@ and @:@ make up the @List@ ``family''). We want to generate the
+alternatives for a @Case@ expression. There are several choices:
+\begin{enumerate}
+\item
+Generate an alternative for every constructor in the family, whether
+they are used in this set of equations or not; this is what the Wadler
+chapter does.
+\begin{description}
+\item[Advantages:]
+(a)~Simple. (b)~It may also be that large sparsely-used constructor
+families are mainly handled by the code for literals.
+\item[Disadvantages:]
+(a)~Not practical for large sparsely-used constructor families, e.g.,
+the ASCII character set. (b)~Have to look up a list of what
+constructors make up the whole family.
+\end{description}
+
+\item
+Generate an alternative for each constructor used, then add a default
+alternative in case some constructors in the family weren't used.
+\begin{description}
+\item[Advantages:]
+(a)~Alternatives aren't generated for unused constructors. (b)~The
+STG is quite happy with defaults. (c)~No lookup in an environment needed.
+\item[Disadvantages:]
+(a)~A spurious default alternative may be generated.
+\end{description}
+
+\item
+``Do it right:'' generate an alternative for each constructor used,
+and add a default alternative if all constructors in the family
+weren't used.
+\begin{description}
+\item[Advantages:]
+(a)~You will get cases with only one alternative (and no default),
+which should be amenable to optimisation. Tuples are a common example.
+\item[Disadvantages:]
+(b)~Have to look up constructor families in TDE (as above).
+\end{description}
+\end{enumerate}
+
+We are implementing the ``do-it-right'' option for now. The arguments
+to @matchConFamily@ are the same as to @match@; the extra @Int@
+returned is the number of constructors in the family.
+
+The function @matchConFamily@ is concerned with this
+have-we-used-all-the-constructors? question; the local function
+@match_cons_used@ does all the real work.
+\begin{code}
+matchConFamily :: [Id]
+ -> Type
+ -> [EquationInfo]
+ -> DsM MatchResult
+matchConFamily (var:vars) ty eqns_info
+ = let
+ -- Sort into equivalence classes by the unique on the constructor
+ -- All the EqnInfos should start with a ConPat
+ groups = equivClassesByUniq get_uniq eqns_info
+ get_uniq (EqnInfo { eqn_pats = ConPatOut (L _ data_con) _ _ _ _ _ : _}) = getUnique data_con
+
+ -- Get the wrapper from the head of each group. We're going to
+ -- use it as the pattern in this case expression, so we need to
+ -- ensure that any type variables it mentions in the pattern are
+ -- in scope. So we put its wrappers outside the case, and
+ -- zap the wrapper for it.
+ wraps :: [CoreExpr -> CoreExpr]
+ wraps = map (eqn_wrap . head) groups
+
+ groups' = [ eqn { eqn_wrap = idWrapper } : eqns | eqn:eqns <- groups ]
+ in
+ -- Now make a case alternative out of each group
+ mappM (match_con vars ty) groups' `thenDs` \ alts ->
+ returnDs (adjustMatchResult (foldr (.) idWrapper wraps) $
+ mkCoAlgCaseMatchResult var ty alts)
+\end{code}
+
+And here is the local function that does all the work. It is
+more-or-less the @matchCon@/@matchClause@ functions on page~94 in
+Wadler's chapter in SLPJ. The function @shift_con_pats@ does what the
+list comprehension in @matchClause@ (SLPJ, p.~94) does, except things
+are trickier in real life. Works for @ConPats@, and we want it to
+fail catastrophically for anything else (which a list comprehension
+wouldn't). Cf.~@shift_lit_pats@ in @MatchLits@.
+
+\begin{code}
+match_con vars ty eqns
+ = do { -- Make new vars for the con arguments; avoid new locals where possible
+ arg_vars <- selectMatchVars (map unLoc arg_pats1) arg_tys
+ ; eqns' <- mapM shift eqns
+ ; match_result <- match (arg_vars ++ vars) ty eqns'
+ ; return (con, tvs1 ++ dicts1 ++ arg_vars, match_result) }
+ where
+ ConPatOut (L _ con) tvs1 dicts1 _ (PrefixCon arg_pats1) pat_ty = firstPat (head eqns)
+
+ shift eqn@(EqnInfo { eqn_wrap = wrap,
+ eqn_pats = ConPatOut _ tvs ds bind (PrefixCon arg_pats) _ : pats })
+ = do { prs <- dsLHsBinds bind
+ ; return (eqn { eqn_wrap = wrap . wrapBinds (tvs `zip` tvs1)
+ . wrapBinds (ds `zip` dicts1)
+ . mkDsLet (Rec prs),
+ eqn_pats = map unLoc arg_pats ++ pats }) }
+
+ -- Get the arg types, which we use to type the new vars
+ -- to match on, from the "outside"; the types of pats1 may
+ -- be more refined, and hence won't do
+ arg_tys = dataConInstOrigArgTys con inst_tys
+ inst_tys | isVanillaDataCon con = tcTyConAppArgs pat_ty -- Newtypes opaque!
+ | otherwise = mkTyVarTys tvs1
+\end{code}
+
+Note [Existentials in shift_con_pat]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ data T = forall a. Ord a => T a (a->Int)
+
+ f (T x f) True = ...expr1...
+ f (T y g) False = ...expr2..
+
+When we put in the tyvars etc we get
+
+ f (T a (d::Ord a) (x::a) (f::a->Int)) True = ...expr1...
+ f (T b (e::Ord b) (y::a) (g::a->Int)) True = ...expr2...
+
+After desugaring etc we'll get a single case:
+
+ f = \t::T b::Bool ->
+ case t of
+ T a (d::Ord a) (x::a) (f::a->Int)) ->
+ case b of
+ True -> ...expr1...
+ False -> ...expr2...
+
+*** We have to substitute [a/b, d/e] in expr2! **
+Hence
+ False -> ....((/\b\(e:Ord b).expr2) a d)....
+
+Originally I tried to use
+ (\b -> let e = d in expr2) a
+to do this substitution. While this is "correct" in a way, it fails
+Lint, because e::Ord b but d::Ord a.
+
diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs
new file mode 100644
index 0000000000..0b7907b22e
--- /dev/null
+++ b/compiler/deSugar/MatchLit.lhs
@@ -0,0 +1,329 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[MatchLit]{Pattern-matching literal patterns}
+
+\begin{code}
+module MatchLit ( dsLit, dsOverLit,
+ tidyLitPat, tidyNPat,
+ matchLiterals, matchNPlusKPats, matchNPats ) where
+
+#include "HsVersions.h"
+
+import {-# SOURCE #-} Match ( match )
+import {-# SOURCE #-} DsExpr ( dsExpr )
+
+import DsMonad
+import DsUtils
+
+import HsSyn
+import Id ( Id, idType )
+import CoreSyn
+import TyCon ( tyConDataCons )
+import TcType ( tcSplitTyConApp, isIntegerTy, isIntTy,
+ isFloatTy, isDoubleTy, isStringTy )
+import Type ( Type )
+import PrelNames ( ratioTyConKey )
+import TysWiredIn ( stringTy, consDataCon, intDataCon, floatDataCon, doubleDataCon )
+import PrelNames ( eqStringName )
+import Unique ( hasKey )
+import Literal ( mkMachInt, Literal(..) )
+import SrcLoc ( noLoc )
+import ListSetOps ( equivClasses, runs )
+import Ratio ( numerator, denominator )
+import SrcLoc ( Located(..) )
+import Outputable
+import FastString ( lengthFS, unpackFS )
+\end{code}
+
+%************************************************************************
+%* *
+ Desugaring literals
+ [used to be in DsExpr, but DsMeta needs it,
+ and it's nice to avoid a loop]
+%* *
+%************************************************************************
+
+We give int/float literals type @Integer@ and @Rational@, respectively.
+The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
+around them.
+
+ToDo: put in range checks for when converting ``@i@''
+(or should that be in the typechecker?)
+
+For numeric literals, we try to detect there use at a standard type
+(@Int@, @Float@, etc.) are directly put in the right constructor.
+[NB: down with the @App@ conversion.]
+
+See also below where we look for @DictApps@ for \tr{plusInt}, etc.
+
+\begin{code}
+dsLit :: HsLit -> DsM CoreExpr
+dsLit (HsChar c) = returnDs (mkCharExpr c)
+dsLit (HsCharPrim c) = returnDs (mkLit (MachChar c))
+dsLit (HsString str) = mkStringExprFS str
+dsLit (HsStringPrim s) = returnDs (mkLit (MachStr s))
+dsLit (HsInteger i _) = mkIntegerExpr i
+dsLit (HsInt i) = returnDs (mkIntExpr i)
+dsLit (HsIntPrim i) = returnDs (mkIntLit i)
+dsLit (HsFloatPrim f) = returnDs (mkLit (MachFloat f))
+dsLit (HsDoublePrim d) = returnDs (mkLit (MachDouble d))
+
+dsLit (HsRat r ty)
+ = mkIntegerExpr (numerator r) `thenDs` \ num ->
+ mkIntegerExpr (denominator r) `thenDs` \ denom ->
+ returnDs (mkConApp ratio_data_con [Type integer_ty, num, denom])
+ where
+ (ratio_data_con, integer_ty)
+ = case tcSplitTyConApp ty of
+ (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
+ (head (tyConDataCons tycon), i_ty)
+
+dsOverLit :: HsOverLit Id -> DsM CoreExpr
+-- Post-typechecker, the SyntaxExpr field of an OverLit contains
+-- (an expression for) the literal value itself
+dsOverLit (HsIntegral _ lit) = dsExpr lit
+dsOverLit (HsFractional _ lit) = dsExpr lit
+\end{code}
+
+%************************************************************************
+%* *
+ Tidying lit pats
+%* *
+%************************************************************************
+
+\begin{code}
+tidyLitPat :: HsLit -> LPat Id -> LPat Id
+-- Result has only the following HsLits:
+-- HsIntPrim, HsCharPrim, HsFloatPrim
+-- HsDoublePrim, HsStringPrim, HsString
+-- * HsInteger, HsRat, HsInt can't show up in LitPats
+-- * We get rid of HsChar right here
+tidyLitPat (HsChar c) pat = mkCharLitPat c
+tidyLitPat (HsString s) pat
+ | lengthFS s <= 1 -- Short string literals only
+ = foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c,pat] stringTy)
+ (mkNilPat stringTy) (unpackFS s)
+ -- The stringTy is the type of the whole pattern, not
+ -- the type to instantiate (:) or [] with!
+tidyLitPat lit pat = pat
+
+----------------
+tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> Type -> LPat Id -> LPat Id
+tidyNPat over_lit mb_neg lit_ty default_pat
+ | isIntTy lit_ty = mk_con_pat intDataCon (HsIntPrim int_val)
+ | isFloatTy lit_ty = mk_con_pat floatDataCon (HsFloatPrim rat_val)
+ | isDoubleTy lit_ty = mk_con_pat doubleDataCon (HsDoublePrim rat_val)
+ | otherwise = default_pat
+ where
+ mk_con_pat con lit = mkPrefixConPat con [noLoc $ LitPat lit] lit_ty
+ neg_lit = case (mb_neg, over_lit) of
+ (Nothing, _) -> over_lit
+ (Just _, HsIntegral i s) -> HsIntegral (-i) s
+ (Just _, HsFractional f s) -> HsFractional (-f) s
+
+ int_val :: Integer
+ int_val = case neg_lit of
+ HsIntegral i _ -> i
+ HsFractional f _ -> panic "tidyNPat"
+
+ rat_val :: Rational
+ rat_val = case neg_lit of
+ HsIntegral i _ -> fromInteger i
+ HsFractional f _ -> f
+\end{code}
+
+
+%************************************************************************
+%* *
+ Pattern matching on LitPat
+%* *
+%************************************************************************
+
+\begin{code}
+matchLiterals :: [Id]
+ -> Type -- Type of the whole case expression
+ -> [EquationInfo]
+ -> DsM MatchResult
+-- All the EquationInfos have LitPats at the front
+
+matchLiterals (var:vars) ty eqns
+ = do { -- Group by literal
+ let groups :: [[(Literal, EquationInfo)]]
+ groups = equivClasses cmpTaggedEqn (tagLitEqns eqns)
+
+ -- Deal with each group
+ ; alts <- mapM match_group groups
+
+ -- Combine results. For everything except String
+ -- we can use a case expression; for String we need
+ -- a chain of if-then-else
+ ; if isStringTy (idType var) then
+ do { mrs <- mapM wrap_str_guard alts
+ ; return (foldr1 combineMatchResults mrs) }
+ else
+ return (mkCoPrimCaseMatchResult var ty alts)
+ }
+ where
+ match_group :: [(Literal, EquationInfo)] -> DsM (Literal, MatchResult)
+ match_group group
+ = do { let (lits, eqns) = unzip group
+ ; match_result <- match vars ty (shiftEqns eqns)
+ ; return (head lits, match_result) }
+
+ wrap_str_guard :: (Literal,MatchResult) -> DsM MatchResult
+ -- Equality check for string literals
+ wrap_str_guard (MachStr s, mr)
+ = do { eq_str <- dsLookupGlobalId eqStringName
+ ; lit <- mkStringExprFS s
+ ; let pred = mkApps (Var eq_str) [Var var, lit]
+ ; return (mkGuardedMatchResult pred mr) }
+\end{code}
+
+%************************************************************************
+%* *
+ Pattern matching on NPat
+%* *
+%************************************************************************
+
+\begin{code}
+matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
+-- All the EquationInfos have NPat at the front
+
+matchNPats (var:vars) ty eqns
+ = do { let groups :: [[(Literal, EquationInfo)]]
+ groups = equivClasses cmpTaggedEqn (tagLitEqns eqns)
+
+ ; match_results <- mapM (match_group . map snd) groups
+
+ ; ASSERT( not (null match_results) )
+ return (foldr1 combineMatchResults match_results) }
+ where
+ match_group :: [EquationInfo] -> DsM MatchResult
+ match_group (eqn1:eqns)
+ = do { lit_expr <- dsOverLit lit
+ ; neg_lit <- case mb_neg of
+ Nothing -> return lit_expr
+ Just neg -> do { neg_expr <- dsExpr neg
+ ; return (App neg_expr lit_expr) }
+ ; eq_expr <- dsExpr eq_chk
+ ; let pred_expr = mkApps eq_expr [Var var, neg_lit]
+ ; match_result <- match vars ty (eqn1' : shiftEqns eqns)
+ ; return (adjustMatchResult (eqn_wrap eqn1) $
+ -- Bring the eqn1 wrapper stuff into scope because
+ -- it may be used in pred_expr
+ mkGuardedMatchResult pred_expr match_result) }
+ where
+ NPat lit mb_neg eq_chk _ : pats1 = eqn_pats eqn1
+ eqn1' = eqn1 { eqn_wrap = idWrapper, eqn_pats = pats1 }
+\end{code}
+
+
+%************************************************************************
+%* *
+ Pattern matching on n+k patterns
+%* *
+%************************************************************************
+
+For an n+k pattern, we use the various magic expressions we've been given.
+We generate:
+\begin{verbatim}
+ if ge var lit then
+ let n = sub var lit
+ in <expr-for-a-successful-match>
+ else
+ <try-next-pattern-or-whatever>
+\end{verbatim}
+
+WATCH OUT! Consider
+
+ f (n+1) = ...
+ f (n+2) = ...
+ f (n+1) = ...
+
+We can't group the first and third together, because the second may match
+the same thing as the first. Contrast
+ f 1 = ...
+ f 2 = ...
+ f 1 = ...
+where we can group the first and third. Hence 'runs' rather than 'equivClasses'
+
+\begin{code}
+matchNPlusKPats all_vars@(var:vars) ty eqns
+ = do { let groups :: [[(Literal, EquationInfo)]]
+ groups = runs eqTaggedEqn (tagLitEqns eqns)
+
+ ; match_results <- mapM (match_group . map snd) groups
+
+ ; ASSERT( not (null match_results) )
+ return (foldr1 combineMatchResults match_results) }
+ where
+ match_group :: [EquationInfo] -> DsM MatchResult
+ match_group (eqn1:eqns)
+ = do { ge_expr <- dsExpr ge
+ ; minus_expr <- dsExpr minus
+ ; lit_expr <- dsOverLit lit
+ ; let pred_expr = mkApps ge_expr [Var var, lit_expr]
+ minusk_expr = mkApps minus_expr [Var var, lit_expr]
+ ; match_result <- match vars ty (eqn1' : map shift eqns)
+ ; return (adjustMatchResult (eqn_wrap eqn1) $
+ -- Bring the eqn1 wrapper stuff into scope because
+ -- it may be used in ge_expr, minusk_expr
+ mkGuardedMatchResult pred_expr $
+ mkCoLetMatchResult (NonRec n1 minusk_expr) $
+ match_result) }
+ where
+ NPlusKPat (L _ n1) lit ge minus : pats1 = eqn_pats eqn1
+ eqn1' = eqn1 { eqn_wrap = idWrapper, eqn_pats = pats1 }
+
+ shift eqn@(EqnInfo { eqn_wrap = wrap,
+ eqn_pats = NPlusKPat (L _ n) _ _ _ : pats })
+ = eqn { eqn_wrap = wrap . wrapBind n n1, eqn_pats = pats }
+\end{code}
+
+
+%************************************************************************
+%* *
+ Grouping functions
+%* *
+%************************************************************************
+
+Given a blob of @LitPat@s/@NPat@s, we want to split them into those
+that are ``same''/different as one we are looking at. We need to know
+whether we're looking at a @LitPat@/@NPat@, and what literal we're after.
+
+\begin{code}
+-- Tag equations by the leading literal
+-- NB: we have ordering on Core Literals, but not on HsLits
+cmpTaggedEqn :: (Literal,EquationInfo) -> (Literal,EquationInfo) -> Ordering
+cmpTaggedEqn (lit1,_) (lit2,_) = lit1 `compare` lit2
+
+eqTaggedEqn :: (Literal,EquationInfo) -> (Literal,EquationInfo) -> Bool
+eqTaggedEqn (lit1,_) (lit2,_) = lit1 == lit2
+
+tagLitEqns :: [EquationInfo] -> [(Literal, EquationInfo)]
+tagLitEqns eqns = [(get_lit (firstPat eqn), eqn) | eqn <- eqns]
+
+get_lit :: Pat Id -> Literal
+-- Get a Core literal to use (only) a grouping key
+-- Hence its type doesn't need to match the type of the original literal
+get_lit (LitPat (HsIntPrim i)) = mkMachInt i
+get_lit (LitPat (HsCharPrim c)) = MachChar c
+get_lit (LitPat (HsStringPrim s)) = MachStr s
+get_lit (LitPat (HsFloatPrim f)) = MachFloat f
+get_lit (LitPat (HsDoublePrim d)) = MachDouble d
+get_lit (LitPat (HsString s)) = MachStr s
+
+get_lit (NPat (HsIntegral i _) Nothing _ _) = MachInt i
+get_lit (NPat (HsIntegral i _) (Just _) _ _) = MachInt (-i)
+get_lit (NPat (HsFractional r _) Nothing _ _) = MachFloat r
+get_lit (NPat (HsFractional r _) (Just _) _ _) = MachFloat (-r)
+
+get_lit (NPlusKPat _ (HsIntegral i _) _ _) = MachInt i
+
+-- These ones can't happen
+-- get_lit (LitPat (HsChar c))
+-- get_lit (LitPat (HsInt i))
+get_lit other = pprPanic "get_lit:bad pattern" (ppr other)
+\end{code}
+
diff --git a/compiler/deSugar/deSugar.tex b/compiler/deSugar/deSugar.tex
new file mode 100644
index 0000000000..02cb285742
--- /dev/null
+++ b/compiler/deSugar/deSugar.tex
@@ -0,0 +1,23 @@
+\documentstyle{report}
+\input{lit-style}
+
+\begin{document}
+\centerline{{\Large{deSugar}}}
+\tableofcontents
+
+\input{Desugar} % {@deSugar@: the main function}
+\input{DsBinds} % {Pattern-matching bindings (HsBinds and MonoBinds)}
+\input{DsGRHSs} % {Matching guarded right-hand-sides (GRHSs)}
+\input{DsExpr} % {Matching expressions (Exprs)}
+\input{DsHsSyn} % {Haskell abstract syntax---added things for desugarer}
+\input{DsListComp} % {Desugaring list comprehensions}
+\input{DsMonad} % {@DsMonad@: monadery used in desugaring}
+\input{DsUtils} % {Utilities for desugaring}
+\input{Check} % {Module @Check@ in @deSugar@}
+\input{Match} % {The @match@ function}
+\input{MatchCon} % {Pattern-matching constructors}
+\input{MatchLit} % {Pattern-matching literal patterns}
+\input{DsForeign} % {Desugaring \tr{foreign} declarations}
+\input{DsCCall} % {Desugaring \tr{_ccall_}s and \tr{_casm_}s}
+
+\end{document}
View Lorry Controller Status