Commit 4f8369bf authored by cactus's avatar cactus Committed by Austin Seipp

Implement pattern synonyms

This patch implements Pattern Synonyms (enabled by -XPatternSynonyms),
allowing y ou to assign names to a pattern and abstract over it.

The rundown is this:

  * Named patterns are introduced by the new 'pattern' keyword, and can
    be either *unidirectional* or *bidirectional*. A unidirectional
    pattern is, in the simplest sense, simply an 'alias' for a pattern,
    where the LHS may mention variables to occur in the RHS. A
    bidirectional pattern synonym occurs when a pattern may also be used
    in expression context.

  * Unidirectional patterns are declared like thus:

        pattern P x <- x:_

    The synonym 'P' may only occur in a pattern context:

        foo :: [Int] -> Maybe Int
        foo (P x) = Just x
        foo _     = Nothing

  * Bidirectional patterns are declared like thus:

        pattern P x y = [x, y]

    Here, P may not only occur as a pattern, but also as an expression
    when given values for 'x' and 'y', i.e.

        bar :: Int -> [Int]
        bar x = P x 10

  * Patterns can't yet have their own type signatures; signatures are inferred.

  * Pattern synonyms may not be recursive, c.f. type synonyms.

  * Pattern synonyms are also exported/imported using the 'pattern'
    keyword in an import/export decl, i.e.

        module Foo (pattern Bar) where ...

    Note that pattern synonyms share the namespace of constructors, so
    this disambiguation is required as a there may also be a 'Bar'
    type in scope as well as the 'Bar' pattern.

  * The semantics of a pattern synonym differ slightly from a typical
    pattern: when using a synonym, the pattern itself is matched,
    followed by all the arguments. This means that the strictness
    differs slightly:

        pattern P x y <- [x, y]

        f (P True True) = True
        f _             = False

        g [True, True] = True
        g _            = False

    In the example, while `g (False:undefined)` evaluates to False,
    `f (False:undefined)` results in undefined as both `x` and `y`
    arguments are matched to `True`.

For more information, see the wiki:

    https://ghc.haskell.org/trac/ghc/wiki/PatternSynonyms
    https://ghc.haskell.org/trac/ghc/wiki/PatternSynonyms/ImplementationReviewed-by: Simon Peyton Jones's avatarSimon Peyton Jones <simonpj@microsoft.com>
Signed-off-by: default avatarAustin Seipp <austin@well-typed.com>
parent 59cb44a3
......@@ -35,6 +35,7 @@ module BasicTypes(
compareFixity,
RecFlag(..), isRec, isNonRec, boolToRecFlag,
Origin(..), isGenerated,
RuleName,
......@@ -417,6 +418,25 @@ instance Outputable RecFlag where
ppr NonRecursive = ptext (sLit "NonRecursive")
\end{code}
%************************************************************************
%* *
Code origin
%* *
%************************************************************************
\begin{code}
data Origin = FromSource
| Generated
deriving( Eq, Data, Typeable )
isGenerated :: Origin -> Bool
isGenerated Generated = True
isGenerated FromSource = False
instance Outputable Origin where
ppr FromSource = ptext (sLit "FromSource")
ppr Generated = ptext (sLit "Generated")
\end{code}
%************************************************************************
%* *
Instance overlap flag
......
%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1998
%
\section[ConLike]{@ConLike@: Constructor-like things}
\begin{code}
module ConLike (
ConLike(..)
) where
#include "HsVersions.h"
import {-# SOURCE #-} DataCon (DataCon)
import {-# SOURCE #-} PatSyn (PatSyn)
import Outputable
import Unique
import Util
import Name
import Data.Function (on)
import qualified Data.Data as Data
import qualified Data.Typeable
\end{code}
%************************************************************************
%* *
\subsection{Constructor-like things}
%* *
%************************************************************************
\begin{code}
-- | A constructor-like thing
data ConLike = RealDataCon DataCon
| PatSynCon PatSyn
deriving Data.Typeable.Typeable
\end{code}
%************************************************************************
%* *
\subsection{Instances}
%* *
%************************************************************************
\begin{code}
instance Eq ConLike where
(==) = (==) `on` getUnique
(/=) = (/=) `on` getUnique
instance Ord ConLike where
(<=) = (<=) `on` getUnique
(<) = (<) `on` getUnique
(>=) = (>=) `on` getUnique
(>) = (>) `on` getUnique
compare = compare `on` getUnique
instance Uniquable ConLike where
getUnique (RealDataCon dc) = getUnique dc
getUnique (PatSynCon ps) = getUnique ps
instance NamedThing ConLike where
getName (RealDataCon dc) = getName dc
getName (PatSynCon ps) = getName ps
instance Outputable ConLike where
ppr (RealDataCon dc) = ppr dc
ppr (PatSynCon ps) = ppr ps
instance OutputableBndr ConLike where
pprInfixOcc (RealDataCon dc) = pprInfixOcc dc
pprInfixOcc (PatSynCon ps) = pprInfixOcc ps
pprPrefixOcc (RealDataCon dc) = pprPrefixOcc dc
pprPrefixOcc (PatSynCon ps) = pprPrefixOcc ps
instance Data.Data ConLike where
-- don't traverse?
toConstr _ = abstractConstr "ConLike"
gunfold _ _ = error "gunfold"
dataTypeOf _ = mkNoRepType "ConLike"
\end{code}
\begin{code}
module DataCon where
import Name( Name )
import Name( Name, NamedThing )
import {-# SOURCE #-} TyCon( TyCon )
import Unique ( Uniquable )
import Outputable ( Outputable, OutputableBndr )
data DataCon
data DataConRep
dataConName :: DataCon -> Name
dataConTyCon :: DataCon -> TyCon
isVanillaDataCon :: DataCon -> Bool
instance Eq DataCon
instance Ord DataCon
instance Uniquable DataCon
instance NamedThing DataCon
instance Outputable DataCon
instance OutputableBndr DataCon
\end{code}
......@@ -58,7 +58,7 @@ module OccName (
-- ** Derived 'OccName's
isDerivedOccName,
mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc,
mkDataConWrapperOcc, mkWorkerOcc, mkMatcherOcc, mkDefaultMethodOcc,
mkGenDefMethodOcc,
mkDerivedTyConOcc, mkNewTyCoOcc, mkClassOpAuxOcc,
mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
......@@ -570,7 +570,7 @@ isDerivedOccName occ =
\end{code}
\begin{code}
mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc,
mkDataConWrapperOcc, mkWorkerOcc, mkMatcherOcc, mkDefaultMethodOcc,
mkGenDefMethodOcc, mkDerivedTyConOcc, mkClassDataConOcc, mkDictOcc,
mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
mkGenD, mkGenR, mkGen1R, mkGenRCo,
......@@ -582,6 +582,7 @@ mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc,
-- These derived variables have a prefix that no Haskell value could have
mkDataConWrapperOcc = mk_simple_deriv varName "$W"
mkWorkerOcc = mk_simple_deriv varName "$w"
mkMatcherOcc = mk_simple_deriv varName "$m"
mkDefaultMethodOcc = mk_simple_deriv varName "$dm"
mkGenDefMethodOcc = mk_simple_deriv varName "$gdm"
mkClassOpAuxOcc = mk_simple_deriv varName "$c"
......
%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1998
%
\section[PatSyn]{@PatSyn@: Pattern synonyms}
\begin{code}
module PatSyn (
-- * Main data types
PatSyn, mkPatSyn,
-- ** Type deconstruction
patSynId, patSynType, patSynArity, patSynIsInfix,
patSynArgs, patSynArgTys, patSynTyDetails,
patSynWrapper, patSynMatcher,
patSynExTyVars, patSynSig, patSynInstArgTys
) where
#include "HsVersions.h"
import Type
import Name
import Outputable
import Unique
import Util
import BasicTypes
import FastString
import Var
import Id
import TcType
import HsBinds( HsPatSynDetails(..) )
import qualified Data.Data as Data
import qualified Data.Typeable
import Data.Function
\end{code}
Pattern synonym representation
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider the following pattern synonym declaration
pattern P x = MkT [x] (Just 42)
where
data T a where
MkT :: (Show a, Ord b) => [b] -> a -> T a
so pattern P has type
b -> T (Maybe t)
with the following typeclass constraints:
provides: (Show (Maybe t), Ord b)
requires: (Eq t, Num t)
In this case, the fields of MkPatSyn will be set as follows:
psArgs = [x :: b]
psArity = 1
psInfix = False
psUnivTyVars = [t]
psExTyVars = [b]
psTheta = ((Show (Maybe t), Ord b), (Eq t, Num t))
psOrigResTy = T (Maybe t)
%************************************************************************
%* *
\subsection{Pattern synonyms}
%* *
%************************************************************************
\begin{code}
-- | A pattern synonym
data PatSyn
= MkPatSyn {
psId :: Id,
psUnique :: Unique, -- Cached from Name
psMatcher :: Id,
psWrapper :: Maybe Id,
psArgs :: [Var],
psArity :: Arity, -- == length psArgs
psInfix :: Bool, -- True <=> declared infix
psUnivTyVars :: [TyVar], -- Universially-quantified type variables
psExTyVars :: [TyVar], -- Existentially-quantified type vars
psTheta :: (ThetaType, ThetaType), -- Provided and required dictionaries
psOrigResTy :: Type
}
deriving Data.Typeable.Typeable
\end{code}
%************************************************************************
%* *
\subsection{Instances}
%* *
%************************************************************************
\begin{code}
instance Eq PatSyn where
(==) = (==) `on` getUnique
(/=) = (/=) `on` getUnique
instance Ord PatSyn where
(<=) = (<=) `on` getUnique
(<) = (<) `on` getUnique
(>=) = (>=) `on` getUnique
(>) = (>) `on` getUnique
compare = compare `on` getUnique
instance Uniquable PatSyn where
getUnique = psUnique
instance NamedThing PatSyn where
getName = getName . psId
instance Outputable PatSyn where
ppr = ppr . getName
instance OutputableBndr PatSyn where
pprInfixOcc = pprInfixName . getName
pprPrefixOcc = pprPrefixName . getName
instance Data.Data PatSyn where
-- don't traverse?
toConstr _ = abstractConstr "PatSyn"
gunfold _ _ = error "gunfold"
dataTypeOf _ = mkNoRepType "PatSyn"
\end{code}
%************************************************************************
%* *
\subsection{Construction}
%* *
%************************************************************************
\begin{code}
-- | Build a new pattern synonym
mkPatSyn :: Name
-> Bool -- ^ Is the pattern synonym declared infix?
-> [Var] -- ^ Original arguments
-> [TyVar] -- ^ Universially-quantified type variables
-> [TyVar] -- ^ Existentially-quantified type variables
-> ThetaType -- ^ Wanted dicts
-> ThetaType -- ^ Given dicts
-> Type -- ^ Original result type
-> Id -- ^ Name of matcher
-> Maybe Id -- ^ Name of wrapper
-> PatSyn
mkPatSyn name declared_infix orig_args
univ_tvs ex_tvs
prov_theta req_theta
orig_res_ty
matcher wrapper
= MkPatSyn {psId = id, psUnique = getUnique name,
psUnivTyVars = univ_tvs, psExTyVars = ex_tvs,
psTheta = (prov_theta, req_theta),
psInfix = declared_infix,
psArgs = orig_args,
psArity = length orig_args,
psOrigResTy = orig_res_ty,
psMatcher = matcher,
psWrapper = wrapper }
where
pat_ty = mkSigmaTy univ_tvs req_theta $
mkSigmaTy ex_tvs prov_theta $
mkFunTys (map varType orig_args) orig_res_ty
id = mkLocalId name pat_ty
\end{code}
\begin{code}
-- | The 'Name' of the 'PatSyn', giving it a unique, rooted identification
patSynId :: PatSyn -> Id
patSynId = psId
patSynType :: PatSyn -> Type
patSynType = psOrigResTy
-- | Should the 'PatSyn' be presented infix?
patSynIsInfix :: PatSyn -> Bool
patSynIsInfix = psInfix
-- | Arity of the pattern synonym
patSynArity :: PatSyn -> Arity
patSynArity = psArity
patSynArgs :: PatSyn -> [Var]
patSynArgs = psArgs
patSynArgTys :: PatSyn -> [Type]
patSynArgTys = map varType . patSynArgs
patSynTyDetails :: PatSyn -> HsPatSynDetails Type
patSynTyDetails ps = case (patSynIsInfix ps, patSynArgTys ps) of
(True, [left, right]) -> InfixPatSyn left right
(_, tys) -> PrefixPatSyn tys
patSynExTyVars :: PatSyn -> [TyVar]
patSynExTyVars = psExTyVars
patSynSig :: PatSyn -> ([TyVar], [TyVar], (ThetaType, ThetaType))
patSynSig ps = (psUnivTyVars ps, psExTyVars ps, psTheta ps)
patSynWrapper :: PatSyn -> Maybe Id
patSynWrapper = psWrapper
patSynMatcher :: PatSyn -> Id
patSynMatcher = psMatcher
patSynInstArgTys :: PatSyn -> [Type] -> [Type]
patSynInstArgTys ps inst_tys
= ASSERT2( length tyvars == length inst_tys
, ptext (sLit "patSynInstArgTys") <+> ppr ps $$ ppr tyvars $$ ppr inst_tys )
map (substTyWith tyvars inst_tys) arg_tys
where
(univ_tvs, ex_tvs, _) = patSynSig ps
arg_tys = map varType (psArgs ps)
tyvars = univ_tvs ++ ex_tvs
\end{code}
\begin{code}
module PatSyn where
import Name( NamedThing )
import Data.Typeable ( Typeable )
import Data.Data ( Data )
import Outputable ( Outputable, OutputableBndr )
import Unique ( Uniquable )
data PatSyn
instance Eq PatSyn
instance Ord PatSyn
instance NamedThing PatSyn
instance Outputable PatSyn
instance OutputableBndr PatSyn
instance Uniquable PatSyn
instance Typeable PatSyn
instance Data PatSyn
\end{code}
......@@ -14,7 +14,9 @@ import TcHsSyn
import DsUtils
import MatchLit
import Id
import ConLike
import DataCon
import PatSyn
import Name
import TysWiredIn
import PrelNames
......@@ -310,6 +312,7 @@ same constructor.
\begin{code}
split_by_constructor :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet)
split_by_constructor qs
| null used_cons = ([], mkUniqSet $ map fst qs)
| notNull unused_cons = need_default_case used_cons unused_cons qs
| otherwise = no_need_default_case used_cons qs
where
......@@ -410,8 +413,11 @@ make_row_vars_for_constructor (_, EqnInfo { eqn_pats = pats})
= takeList (tail pats) (repeat nlWildPat)
compare_cons :: Pat Id -> Pat Id -> Bool
compare_cons (ConPatOut{ pat_con = L _ id1 }) (ConPatOut { pat_con = L _ id2 }) = id1 == id2
compare_cons _ _ = panic "Check.compare_cons: Not ConPatOut"
compare_cons (ConPatOut{ pat_con = L _ con1 }) (ConPatOut{ pat_con = L _ con2 })
= case (con1, con2) of
(RealDataCon id1, RealDataCon id2) -> id1 == id2
_ -> False
compare_cons _ _ = panic "Check.compare_cons: Not ConPatOut with RealDataCon"
remove_dups :: [Pat Id] -> [Pat Id]
remove_dups [] = []
......@@ -423,8 +429,8 @@ get_used_cons qs = remove_dups [pat | q <- qs, let pat = firstPatN q,
isConPatOut pat]
isConPatOut :: Pat Id -> Bool
isConPatOut (ConPatOut {}) = True
isConPatOut _ = False
isConPatOut ConPatOut{ pat_con = L _ RealDataCon{} } = True
isConPatOut _ = False
remove_dups' :: [HsLit] -> [HsLit]
remove_dups' [] = []
......@@ -461,7 +467,7 @@ get_unused_cons :: [Pat Id] -> [DataCon]
get_unused_cons used_cons = ASSERT( not (null used_cons) ) unused_cons
where
used_set :: UniqSet DataCon
used_set = mkUniqSet [d | ConPatOut{ pat_con = L _ d} <- used_cons]
used_set = mkUniqSet [d | ConPatOut{ pat_con = L _ (RealDataCon d) } <- used_cons]
(ConPatOut { pat_ty = ty }) = head used_cons
Just (ty_con, inst_tys) = splitTyConApp_maybe ty
unused_cons = filterOut is_used (tyConDataCons ty_con)
......@@ -512,10 +518,10 @@ is_var :: Pat Id -> Bool
is_var (WildPat _) = True
is_var _ = False
is_var_con :: DataCon -> Pat Id -> Bool
is_var_con _ (WildPat _) = True
is_var_con con (ConPatOut{ pat_con = L _ id }) | id == con = True
is_var_con _ _ = False
is_var_con :: ConLike -> Pat Id -> Bool
is_var_con _ (WildPat _) = True
is_var_con con (ConPatOut{ pat_con = L _ id }) = id == con
is_var_con _ _ = False
is_var_lit :: HsLit -> Pat Id -> Bool
is_var_lit _ (WildPat _) = True
......@@ -582,12 +588,12 @@ make_list p (ListPat ps ty Nothing) = ListPat (p:ps) ty Nothing
make_list _ _ = panic "Check.make_list: Invalid argument"
make_con :: Pat Id -> ExhaustivePat -> ExhaustivePat
make_con (ConPatOut{ pat_con = L _ id }) (lp:lq:ps, constraints)
make_con (ConPatOut{ pat_con = L _ (RealDataCon 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{ pat_con = L _ id, pat_args = PrefixCon pats, pat_ty = ty }) (ps, constraints)
make_con (ConPatOut{ pat_con = L _ (RealDataCon id), pat_args = PrefixCon pats, pat_ty = 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)
......@@ -640,6 +646,7 @@ might_fail_pat :: Pat Id -> Bool
-- that is not covered by the checking algorithm. Specifically:
-- NPlusKPat
-- ViewPat (if refutable)
-- ConPatOut of a PatSynCon
-- First the two special cases
might_fail_pat (NPlusKPat {}) = True
......@@ -654,7 +661,10 @@ might_fail_pat (ListPat _ _ (Just _)) = True
might_fail_pat (TuplePat ps _ _) = any might_fail_lpat ps
might_fail_pat (PArrPat ps _) = any might_fail_lpat ps
might_fail_pat (BangPat p) = might_fail_lpat p
might_fail_pat (ConPatOut { pat_args = ps }) = any might_fail_lpat (hsConPatArgs ps)
might_fail_pat (ConPatOut { pat_con = con, pat_args = ps })
= case unLoc con of
RealDataCon _dcon -> any might_fail_lpat (hsConPatArgs ps)
PatSynCon _psyn -> True
-- Finally the ones that are sure to succeed, or which are covered by the checking algorithm
might_fail_pat (LazyPat _) = False -- Always succeeds
......@@ -686,9 +696,11 @@ tidy_pat (CoPat _ pat _) = tidy_pat pat
tidy_pat (NPlusKPat id _ _ _) = WildPat (idType (unLoc id))
tidy_pat (ViewPat _ _ ty) = WildPat ty
tidy_pat (ListPat _ _ (Just (ty,_))) = WildPat ty
tidy_pat (ConPatOut { pat_con = L _ PatSynCon{}, pat_ty = ty })
= WildPat ty
tidy_pat pat@(ConPatOut { pat_con = L _ id, pat_args = ps })
= pat { pat_args = tidy_con id ps }
tidy_pat pat@(ConPatOut { pat_con = L _ con, pat_args = ps })
= pat { pat_args = tidy_con con ps }
tidy_pat (ListPat ps ty Nothing)
= unLoc $ foldr (\ x y -> mkPrefixConPat consDataCon [x,y] list_ty)
......@@ -729,16 +741,22 @@ tidy_lit_pat lit
= tidyLitPat lit
-----------------
tidy_con :: DataCon -> HsConPatDetails Id -> HsConPatDetails Id
tidy_con :: ConLike -> HsConPatDetails Id -> HsConPatDetails Id
tidy_con _ (PrefixCon ps) = PrefixCon (map tidy_lpat ps)
tidy_con _ (InfixCon p1 p2) = PrefixCon [tidy_lpat p1, tidy_lpat p2]
tidy_con con (RecCon (HsRecFields fs _))
| null fs = PrefixCon [nlWildPat | _ <- dataConOrigArgTys con]
| null fs = PrefixCon (replicate arity nlWildPat)
-- Special case for null patterns; maybe not a record at all
| otherwise = PrefixCon (map (tidy_lpat.snd) all_pats)
where
arity = case con of
RealDataCon dcon -> dataConSourceArity dcon
PatSynCon psyn -> patSynArity psyn
-- pad out all the missing fields with WildPats.
field_pats = map (\ f -> (f, nlWildPat)) (dataConFieldLabels con)
field_pats = case con of
RealDataCon dc -> map (\ f -> (f, nlWildPat)) (dataConFieldLabels dc)
PatSynCon{} -> panic "Check.tidy_con: pattern synonym with record syntax"
all_pats = foldr (\(HsRecField id p _) acc -> insertNm (getName (unLoc id)) p acc)
field_pats fs
......
......@@ -117,7 +117,7 @@ guessSourceFile :: LHsBinds Id -> FilePath -> FilePath
guessSourceFile binds orig_file =
-- Try look for a file generated from a .hsc file to a
-- .hs file, by peeking ahead.
let top_pos = catMaybes $ foldrBag (\ (L pos _) rest ->
let top_pos = catMaybes $ foldrBag (\ (_, (L pos _)) rest ->
srcSpanFileName_maybe pos : rest) [] binds
in
case top_pos of
......@@ -229,7 +229,11 @@ shouldTickPatBind density top_lev
-- Adding ticks to bindings
addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id)
addTickLHsBinds binds = mapBagM addTickLHsBind binds
addTickLHsBinds binds = mapBagM addTick binds
where
addTick (origin, bind) = do
bind' <- addTickLHsBind bind
return (origin, bind')
addTickLHsBind :: LHsBind Id -> TM (LHsBind Id)
addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds,
......@@ -325,6 +329,7 @@ addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs, pat_rhs = rhs }))) = do
-- Only internal stuff, not from source, uses VarBind, so we ignore it.
addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind
bindTick :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id))
......
......@@ -21,6 +21,7 @@ import FamInstEnv
import InstEnv
import Class
import Avail
import PatSyn
import CoreSyn
import CoreSubst
import PprCore
......@@ -45,6 +46,8 @@ import OrdList
import Data.List
import Data.IORef
import Control.Monad( when )
import Data.Maybe ( mapMaybe )
import UniqFM
\end{code}
%************************************************************************
......@@ -80,6 +83,7 @@ deSugar hsc_env
tcg_fords = fords,
tcg_rules = rules,
tcg_vects = vects,
tcg_patsyns = patsyns,
tcg_tcs = tcs,
tcg_insts = insts,
tcg_fam_insts = fam_insts,
......@@ -115,21 +119,27 @@ deSugar hsc_env
; let hpc_init
| gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info
| otherwise = empty
; let patsyn_defs = [(patSynId ps, ps) | ps <- patsyns]
; return ( ds_ev_binds
, foreign_prs `appOL` core_prs `appOL` spec_prs
, spec_rules ++ ds_rules, ds_vects
, ds_fords `appendStubC` hpc_init ) }
, ds_fords `appendStubC` hpc_init
, patsyn_defs) }
; case mb_res of {
Nothing -> return (msgs, Nothing) ;
Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords) ->
Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords, patsyn_defs) -> do
do { -- Add export flags to bindings
keep_alive <- readIORef keep_var
; let (rules_for_locals, rules_for_imps)
= partition isLocalRule all_rules
final_patsyns = addExportFlagsAndRules target export_set keep_alive [] patsyn_defs
exp_patsyn_wrappers = mapMaybe (patSynWrapper . snd) final_patsyns
exp_patsyn_matchers = map (patSynMatcher . snd) final_patsyns
keep_alive' = addListToUFM keep_alive (map (\x -> (x, getName x)) (exp_patsyn_wrappers ++ exp_patsyn_matchers))
final_prs = addExportFlagsAndRules target
export_set keep_alive rules_for_locals (fromOL all_prs)
export_set keep_alive' rules_for_locals (fromOL all_prs)
final_pgm = combineEvBinds ds_ev_binds final_prs
-- Notice that we put the whole lot in a big Rec, even the foreign binds
......@@ -173,6 +183,7 @@ deSugar hsc_env
mg_fam_insts = fam_insts,