compiler/deSugar/DsBinds.lhs

@@ -95,13 +95,8 @@ ds_lhs_binds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
 ds_lhs_binds binds = do { ds_bs <- mapBagM dsLHsBind binds
                         ; return (foldBag appOL id nilOL ds_bs) }
 
-dsLHsBind :: (Origin, LHsBind Id) -> DsM (OrdList (Id,CoreExpr))
-dsLHsBind (origin, L loc bind)
-  = handleWarnings $ putSrcSpanDs loc $ dsHsBind bind
-  where
-    handleWarnings = if isGenerated origin
-                     then discardWarningsDs
-                     else id
+dsLHsBind :: LHsBind Id -> DsM (OrdList (Id,CoreExpr))
+dsLHsBind (L loc bind) = putSrcSpanDs loc $ dsHsBind bind
 
 dsHsBind :: HsBind Id -> DsM (OrdList (Id,CoreExpr))
 

compiler/deSugar/DsExpr.lhs

@@ -99,7 +99,7 @@ ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
 -- a tuple and doing selections.
 -- Silently ignore INLINE and SPECIALISE pragmas...
 ds_val_bind (NonRecursive, hsbinds) body
-  | [(_, L loc bind)] <- bagToList hsbinds,
+  | [L loc bind] <- bagToList hsbinds,
         -- 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
@@ -130,11 +130,11 @@ dsStrictBind :: HsBind Id -> CoreExpr -> DsM CoreExpr
 dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
                , abs_exports = exports
                , abs_ev_binds = ev_binds
-               , abs_binds = binds }) body
+               , abs_binds = lbinds }) body
   = do { let body1 = foldr bind_export body exports
              bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b
-       ; body2 <- foldlBagM (\body (_, bind) -> dsStrictBind (unLoc bind) body)
-                            body1 binds 
+       ; body2 <- foldlBagM (\body lbind -> dsStrictBind (unLoc lbind) body)
+                            body1 lbinds 
        ; ds_binds <- dsTcEvBinds ev_binds
        ; return (mkCoreLets ds_binds body2) }
 
@@ -163,11 +163,11 @@ dsStrictBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
 
 ----------------------
 strictMatchOnly :: HsBind Id -> Bool
-strictMatchOnly (AbsBinds { abs_binds = binds })
-  = anyBag (strictMatchOnly . unLoc . snd) binds
-strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = ty })
-  =  isUnLiftedType ty 
-  || isBangLPat lpat   
+strictMatchOnly (AbsBinds { abs_binds = lbinds })
+  = anyBag (strictMatchOnly . unLoc) lbinds
+strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = rhs_ty })
+  =  isUnLiftedType rhs_ty
+  || isStrictLPat lpat
   || any (isUnLiftedType . idType) (collectPatBinders lpat)
 strictMatchOnly (FunBind { fun_id = L _ id })
   = isUnLiftedType (idType id)
@@ -488,7 +488,7 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
         -- constructor aguments.
         ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
         ; ([discrim_var], matching_code) 
-                <- matchWrapper RecUpd (MG { mg_alts = alts, mg_arg_tys = [in_ty], mg_res_ty = out_ty })
+                <- matchWrapper RecUpd (MG { mg_alts = alts, mg_arg_tys = [in_ty], mg_res_ty = out_ty, mg_origin = Generated })
 
         ; return (add_field_binds field_binds' $
                   bindNonRec discrim_var record_expr' matching_code) }
@@ -789,7 +789,8 @@ dsDo stmts
         rets         = map noLoc rec_rets
         mfix_app     = nlHsApp (noLoc mfix_op) mfix_arg
         mfix_arg     = noLoc $ HsLam (MG { mg_alts = [mkSimpleMatch [mfix_pat] body]
-                                         , mg_arg_tys = [tup_ty], mg_res_ty = body_ty })
+                                         , mg_arg_tys = [tup_ty], mg_res_ty = body_ty
+                                         , mg_origin = Generated })
         mfix_pat     = noLoc $ LazyPat $ mkBigLHsPatTup rec_tup_pats
         body         = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty
         ret_app      = nlHsApp (noLoc return_op) (mkBigLHsTup rets)

compiler/deSugar/DsMeta.hs

@@ -705,12 +705,14 @@ addTyVarBinds :: LHsTyVarBndrs Name                            -- the binders to
 -- 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 tvs m
-  = do { freshNames <- mkGenSyms (hsLKiTyVarNames tvs)
-       ; term <- addBinds freshNames $
-                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvBndrs tvs `zip` freshNames)
+addTyVarBinds (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs }) m
+  = do { fresh_kv_names <- mkGenSyms kvs
+       ; fresh_tv_names <- mkGenSyms (map hsLTyVarName tvs)
+       ; let fresh_names = fresh_kv_names ++ fresh_tv_names
+       ; term <- addBinds fresh_names $
+                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (tvs `zip` fresh_tv_names)
                     ; m kbs }
-       ; wrapGenSyms freshNames term }
+       ; wrapGenSyms fresh_names term }
   where
     mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
 
@@ -1196,7 +1198,7 @@ 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 . snd) (bagToList binds)
+rep_binds' = mapM rep_bind . bagToList
 
 rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
 -- Assumes: all the binders of the binding are alrady in the meta-env
@@ -1238,7 +1240,7 @@ rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
         ; return (srcLocSpan (getSrcLoc v), ans) }
 
 rep_bind (L _ (AbsBinds {}))  = panic "rep_bind: AbsBinds"
-rep_bind (L _ (PatSynBind {})) = panic "rep_bind: PatSynBind"
+rep_bind (L _ dec@(PatSynBind {})) = notHandled "pattern synonyms" (ppr dec)
 -----------------------------------------------------------------------------
 -- Since everything in a Bind is mutually recursive we need rename all
 -- all the variables simultaneously. For example:

compiler/deSugar/Match.lhs

@@ -40,7 +40,7 @@ import Maybes
 import Util
 import Name
 import Outputable
-import BasicTypes ( boxityNormalTupleSort )
+import BasicTypes ( boxityNormalTupleSort, isGenerated )
 import FastString
 
 import Control.Monad( when )
@@ -586,8 +586,6 @@ tidy1 _ non_interesting_pat
 
 --------------------
 tidy_bang_pat :: Id -> SrcSpan -> Pat Id -> DsM (DsWrapper, Pat Id)
--- BangPatterns: Pattern matching is already strict in constructors,
--- tuples etc, so the last case strips off the bang for those patterns.
 
 -- Discard bang around strict pattern
 tidy_bang_pat v _ p@(ListPat {})   = tidy1 v p
@@ -596,8 +594,7 @@ tidy_bang_pat v _ p@(PArrPat {})   = tidy1 v p
 tidy_bang_pat v _ p@(ConPatOut {}) = tidy1 v p
 tidy_bang_pat v _ p@(LitPat {})    = tidy1 v p
 
--- Discard lazy/par/sig under a bang
-tidy_bang_pat v _ (LazyPat (L l p))     = tidy_bang_pat v l p
+-- Discard par/sig under a bang
 tidy_bang_pat v _ (ParPat (L l p))      = tidy_bang_pat v l p
 tidy_bang_pat v _ (SigPatOut (L l p) _) = tidy_bang_pat v l p
 
@@ -607,7 +604,10 @@ tidy_bang_pat v l (AsPat v' p)  = tidy1 v (AsPat v' (L l (BangPat p)))
 tidy_bang_pat v l (CoPat w p t) = tidy1 v (CoPat w (BangPat (L l p)) t)
 
 -- Default case, leave the bang there:
--- VarPat, WildPat, ViewPat, NPat, NPlusKPat
+-- VarPat, LazyPat, WildPat, ViewPat, NPat, NPlusKPat
+-- For LazyPat, remember that it's semantically like a VarPat
+--  i.e.  !(~p) is not like ~p, or p!  (Trac #8952)
+
 tidy_bang_pat _ l p = return (idDsWrapper, BangPat (L l p))
   -- NB: SigPatIn, ConPatIn should not happen
 \end{code}
@@ -752,12 +752,14 @@ JJQC 30-Nov-1997
 \begin{code}
 matchWrapper ctxt (MG { mg_alts = matches
                       , mg_arg_tys = arg_tys
-                      , mg_res_ty = rhs_ty })
+                      , mg_res_ty = rhs_ty
+                      , mg_origin = origin })
   = do  { eqns_info   <- mapM mk_eqn_info matches
         ; new_vars    <- case matches of
                            []    -> mapM newSysLocalDs arg_tys
                            (m:_) -> selectMatchVars (map unLoc (hsLMatchPats m))
-        ; result_expr <- matchEquations ctxt new_vars eqns_info rhs_ty
+        ; result_expr <- handleWarnings $
+                         matchEquations ctxt new_vars eqns_info rhs_ty
         ; return (new_vars, result_expr) }
   where
     mk_eqn_info (L _ (Match pats _ grhss))
@@ -765,6 +767,10 @@ matchWrapper ctxt (MG { mg_alts = matches
            ; match_result <- dsGRHSs ctxt upats grhss rhs_ty
            ; return (EqnInfo { eqn_pats = upats, eqn_rhs  = match_result}) }
 
+    handleWarnings = if isGenerated origin
+                     then discardWarningsDs
+                     else id
+
 
 matchEquations  :: HsMatchContext Name
                 -> [Id] -> [EquationInfo] -> Type

compiler/ghc.mk

@@ -99,8 +99,6 @@ endif
 	@echo 'cGhcEnableTablesNextToCode = "$(GhcEnableTablesNextToCode)"' >> $@
 	@echo 'cLeadingUnderscore    :: String'                             >> $@
 	@echo 'cLeadingUnderscore    = "$(LeadingUnderscore)"'              >> $@
-	@echo 'cRAWCPP_FLAGS         :: String'                             >> $@
-	@echo 'cRAWCPP_FLAGS         = "$(RAWCPP_FLAGS)"'                   >> $@
 	@echo 'cGHC_UNLIT_PGM        :: String'                             >> $@
 	@echo 'cGHC_UNLIT_PGM        = "$(utils/unlit_dist_PROG)"'          >> $@
 	@echo 'cGHC_SPLIT_PGM        :: String'                             >> $@
@@ -353,6 +351,11 @@ else
 compiler_CONFIGURE_OPTS += --ghc-option=-DNO_REGS
 endif
 
+ifneq "$(GhcWithSMP)" "YES"
+compiler_CONFIGURE_OPTS += --ghc-option=-DNOSMP
+compiler_CONFIGURE_OPTS += --ghc-option=-optc-DNOSMP
+endif
+
 # Careful optimisation of the parser: we don't want to throw everything
 # at it, because that takes too long and doesn't buy much, but we do want
 # to inline certain key external functions, so we instruct GHC not to

compiler/ghci/Linker.lhs

@@ -378,7 +378,16 @@ preloadLib dflags lib_paths framework_paths lib_spec
              -> do maybe_errstr <- loadDLL (mkSOName platform dll_unadorned)
                    case maybe_errstr of
                       Nothing -> maybePutStrLn dflags "done"
-                      Just mm -> preloadFailed mm lib_paths lib_spec
+                      Just mm | platformOS platform /= OSDarwin ->
+                        preloadFailed mm lib_paths lib_spec
+                      Just mm | otherwise -> do
+                        -- As a backup, on Darwin, try to also load a .so file
+                        -- since (apparently) some things install that way - see
+                        -- ticket #8770.
+                        err2 <- loadDLL $ ("lib" ++ dll_unadorned) <.> "so"
+                        case err2 of
+                          Nothing -> maybePutStrLn dflags "done"
+                          Just _  -> preloadFailed mm lib_paths lib_spec
 
           DLLPath dll_path
              -> do maybe_errstr <- loadDLL dll_path

compiler/ghci/RtClosureInspect.hs

@@ -939,8 +939,7 @@ findPtrTyss i tys = foldM step (i, []) tys
 -- The types can contain skolem type variables, which need to be treated as normal vars.
 -- In particular, we want them to unify with things.
 improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe TvSubst
-improveRTTIType _ base_ty new_ty
-  = U.tcUnifyTys (const U.BindMe) [base_ty] [new_ty]
+improveRTTIType _ base_ty new_ty = U.tcUnifyTy base_ty new_ty
 
 getDataConArgTys :: DataCon -> Type -> TR [Type]
 -- Given the result type ty of a constructor application (D a b c :: ty)

compiler/hsSyn/Convert.lhs

@@ -300,7 +300,7 @@ cvt_ci_decs doc decs
         ; unless (null bads) (failWith (mkBadDecMsg doc bads))
           --We use FromSource as the origin of the bind
           -- because the TH declaration is user-written
-        ; return (listToBag (map (\bind -> (FromSource, bind)) binds'), sigs', fams', ats', adts') }
+        ; return (listToBag binds', sigs', fams', ats', adts') }
 
 ----------------
 cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
@@ -535,9 +535,7 @@ cvtLocalDecs doc ds
        ; let (binds, prob_sigs) = partitionWith is_bind ds'
        ; let (sigs, bads) = partitionWith is_sig prob_sigs
        ; unless (null bads) (failWith (mkBadDecMsg doc bads))
-       ; return (HsValBinds (ValBindsIn (toBindBag binds) sigs)) }
-  where
-    toBindBag = listToBag . map (\bind -> (FromSource, bind))
+       ; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) }
 
 cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName))
 cvtClause (Clause ps body wheres)
@@ -562,10 +560,10 @@ cvtl e = wrapL (cvt e)
 
     cvt (AppE x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' }
     cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e
-                            ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) }
+                            ; return $ HsLam (mkMatchGroup FromSource [mkSimpleMatch ps' e']) }
     cvt (LamCaseE ms)  = do { ms' <- mapM cvtMatch ms
                             ; return $ HsLamCase placeHolderType
-                                                 (mkMatchGroup ms')
+                                                 (mkMatchGroup FromSource ms')
                             }
     cvt (TupE [e])     = do { e' <- cvtl e; return $ HsPar e' }
                                  -- Note [Dropping constructors]
@@ -581,7 +579,7 @@ cvtl e = wrapL (cvt e)
     cvt (LetE ds e)    = do { ds' <- cvtLocalDecs (ptext (sLit "a let expression")) ds
                             ; e' <- cvtl e; return $ HsLet ds' e' }
     cvt (CaseE e ms)   = do { e' <- cvtl e; ms' <- mapM cvtMatch ms
-                            ; return $ HsCase e' (mkMatchGroup ms') }
+                            ; return $ HsCase e' (mkMatchGroup FromSource ms') }
     cvt (DoE ss)       = cvtHsDo DoExpr ss
     cvt (CompE ss)     = cvtHsDo ListComp ss
     cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr Nothing dd' }
@@ -1112,8 +1110,10 @@ thRdrName loc ctxt_ns th_occ th_name
      TH.NameQ mod  -> (mkRdrQual  $! mk_mod mod) $! occ
      TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq uniq) $! occ) loc)
      TH.NameU uniq -> nameRdrName $! (((Name.mkSystemNameAt $! mk_uniq uniq) $! occ) loc)
-     TH.NameS | Just name <- isBuiltInOcc ctxt_ns th_occ -> nameRdrName $! name
-              | otherwise                                -> mkRdrUnqual $! occ
+     TH.NameS | Just name <- isBuiltInOcc_maybe occ -> nameRdrName $! name
+              | otherwise                           -> mkRdrUnqual $! occ
+              -- We check for built-in syntax here, because the TH
+              -- user might have written a (NameS "(,,)"), for example
   where
     occ :: OccName.OccName
     occ = mk_occ ctxt_ns th_occ
@@ -1133,25 +1133,6 @@ thRdrNameGuesses (TH.Name occ flavour)
                 | otherwise                       = [OccName.varName, OccName.tvName]
     occ_str = TH.occString occ
 
-isBuiltInOcc :: OccName.NameSpace -> String -> Maybe Name.Name
--- Built in syntax isn't "in scope" so an Unqual RdrName won't do
--- We must generate an Exact name, just as the parser does
-isBuiltInOcc ctxt_ns occ
-  = case occ of
-        ":"              -> Just (Name.getName consDataCon)
-        "[]"             -> Just (Name.getName nilDataCon)
-        "()"             -> Just (tup_name 0)
-        '(' : ',' : rest -> go_tuple 2 rest
-        _                -> Nothing
-  where
-    go_tuple n ")"          = Just (tup_name n)
-    go_tuple n (',' : rest) = go_tuple (n+1) rest
-    go_tuple _ _            = Nothing
-
-    tup_name n
-        | OccName.isTcClsNameSpace ctxt_ns = Name.getName (tupleTyCon BoxedTuple n)
-        | otherwise                        = Name.getName (tupleCon BoxedTuple n)
-
 -- The packing and unpacking is rather turgid :-(
 mk_occ :: OccName.NameSpace -> String -> OccName.OccName
 mk_occ ns occ = OccName.mkOccName ns occ

compiler/hsSyn/HsBinds.lhs

@@ -89,7 +89,7 @@ type LHsBind  id = LHsBindLR  id id
 type LHsBinds id = LHsBindsLR id id
 type HsBind   id = HsBindLR   id id
 
-type LHsBindsLR idL idR = Bag (Origin, LHsBindLR idL idR)
+type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)
 type LHsBindLR  idL idR = Located (HsBindLR idL idR)
 
 data HsBindLR idL idR
@@ -322,7 +322,7 @@ instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsValBindsLR id
 pprLHsBinds :: (OutputableBndr idL, OutputableBndr idR) => LHsBindsLR idL idR -> SDoc
 pprLHsBinds binds
   | isEmptyLHsBinds binds = empty
-  | otherwise = pprDeclList (map (ppr . snd) (bagToList binds))
+  | otherwise = pprDeclList (map ppr (bagToList binds))
 
 pprLHsBindsForUser :: (OutputableBndr idL, OutputableBndr idR, OutputableBndr id2)
                    => LHsBindsLR idL idR -> [LSig id2] -> [SDoc]
@@ -338,7 +338,7 @@ pprLHsBindsForUser binds sigs
 
     decls :: [(SrcSpan, SDoc)]
     decls = [(loc, ppr sig)  | L loc sig <- sigs] ++
-            [(loc, ppr bind) | (_, L loc bind) <- bagToList binds]
+            [(loc, ppr bind) | L loc bind <- bagToList binds]
 
     sort_by_loc decls = sortBy (comparing fst) decls
 

compiler/hsSyn/HsExpr.lhs

@@ -909,7 +909,8 @@ patterns in each equation.
 data MatchGroup id body
   = MG { mg_alts    :: [LMatch id body]  -- The alternatives
        , mg_arg_tys :: [PostTcType]      -- Types of the arguments, t1..tn
-       , mg_res_ty  :: PostTcType  }     -- Type of the result, tr 
+       , mg_res_ty  :: PostTcType        -- Type of the result, tr 
+       , mg_origin  :: Origin }
      -- The type is the type of the entire group
      --      t1 -> ... -> tn -> tr
      -- where there are n patterns

compiler/hsSyn/HsPat.lhs

@@ -16,8 +16,8 @@ module HsPat (
 
         mkPrefixConPat, mkCharLitPat, mkNilPat,
 
-        isBangHsBind, isLiftedPatBind,
-        isBangLPat, hsPatNeedsParens,
+        isStrictHsBind, looksLazyPatBind,
+        isStrictLPat, hsPatNeedsParens,
         isIrrefutableHsPat,
 
         pprParendLPat
@@ -358,34 +358,34 @@ patterns are treated specially, of course.
 
 The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
 \begin{code}
-isBangLPat :: LPat id -> Bool
-isBangLPat (L _ (BangPat {})) = True
-isBangLPat (L _ (ParPat p))   = isBangLPat p
-isBangLPat _                  = False
-
-isBangHsBind :: HsBind id -> Bool
--- A pattern binding with an outermost bang
+isStrictLPat :: LPat id -> Bool
+isStrictLPat (L _ (ParPat p))             = isStrictLPat p
+isStrictLPat (L _ (BangPat {}))           = True
+isStrictLPat (L _ (TuplePat _ Unboxed _)) = True
+isStrictLPat _                            = False
+
+isStrictHsBind :: HsBind id -> Bool
+-- A pattern binding with an outermost bang or unboxed tuple must be matched strictly
 -- Defined in this module because HsPat is above HsBinds in the import graph
-isBangHsBind (PatBind { pat_lhs = p }) = isBangLPat p
-isBangHsBind _                         = False
-
-isLiftedPatBind :: HsBind id -> Bool
--- A pattern binding with a compound pattern, not just a variable
---    (I# x)       yes
---    (# a, b #)   no, even if a::Int#
---    x            no, even if x::Int#
--- We want to warn about a missing bang-pattern on the yes's
-isLiftedPatBind (PatBind { pat_lhs = p }) = isLiftedLPat p
-isLiftedPatBind _                         = False
-
-isLiftedLPat :: LPat id -> Bool
-isLiftedLPat (L _ (ParPat p))   = isLiftedLPat p
-isLiftedLPat (L _ (BangPat p))  = isLiftedLPat p
-isLiftedLPat (L _ (AsPat _ p))  = isLiftedLPat p
-isLiftedLPat (L _ (TuplePat _ Unboxed _)) = False
-isLiftedLPat (L _ (VarPat {}))            = False
-isLiftedLPat (L _ (WildPat {}))           = False
-isLiftedLPat _                            = True
+isStrictHsBind (PatBind { pat_lhs = p }) = isStrictLPat p
+isStrictHsBind _                         = False
+
+looksLazyPatBind :: HsBind id -> Bool
+-- Returns True of anything *except*
+--     a StrictHsBind (as above) or 
+--     a VarPat
+-- In particular, returns True of a pattern binding with a compound pattern, like (I# x)
+looksLazyPatBind (PatBind { pat_lhs = p }) = looksLazyLPat p
+looksLazyPatBind _                         = False
+
+looksLazyLPat :: LPat id -> Bool
+looksLazyLPat (L _ (ParPat p))             = looksLazyLPat p
+looksLazyLPat (L _ (AsPat _ p))            = looksLazyLPat p
+looksLazyLPat (L _ (BangPat {}))           = False
+looksLazyLPat (L _ (TuplePat _ Unboxed _)) = False
+looksLazyLPat (L _ (VarPat {}))            = False
+looksLazyLPat (L _ (WildPat {}))           = False
+looksLazyLPat _                            = True
 
 isIrrefutableHsPat :: OutputableBndr id => LPat id -> Bool
 -- (isIrrefutableHsPat p) is true if matching against p cannot fail,

compiler/hsSyn/HsTypes.lhs

@@ -45,6 +45,7 @@ import HsLit
 import Name( Name )
 import RdrName( RdrName )
 import DataCon( HsBang(..) )
+import TysPrim( funTyConName )
 import Type
 import HsDoc
 import BasicTypes
@@ -506,15 +507,31 @@ splitLHsClassTy_maybe ty
         HsKindSig ty _     -> checkl ty args
         _                  -> Nothing
 
--- Splits HsType into the (init, last) parts
+-- splitHsFunType decomposes a type (t1 -> t2 ... -> tn)
 -- Breaks up any parens in the result type: 
 --      splitHsFunType (a -> (b -> c)) = ([a,b], c)
-splitHsFunType :: LHsType name -> ([LHsType name], LHsType name)
-splitHsFunType (L _ (HsFunTy x y)) = (x:args, res)
-  where
-  (args, res) = splitHsFunType y
-splitHsFunType (L _ (HsParTy ty))  = splitHsFunType ty
-splitHsFunType other               = ([], other)
+-- Also deals with (->) t1 t2; that is why it only works on LHsType Name
+--   (see Trac #9096)
+splitHsFunType :: LHsType Name -> ([LHsType Name], LHsType Name)
+splitHsFunType (L _ (HsParTy ty)) 
+  = splitHsFunType ty
+
+splitHsFunType (L _ (HsFunTy x y))
+  | (args, res) <- splitHsFunType y
+  = (x:args, res)
+
+splitHsFunType orig_ty@(L _ (HsAppTy t1 t2)) 
+  = go t1 [t2]
+  where  -- Look for (->) t1 t2, possibly with parenthesisation
+    go (L _ (HsTyVar fn))    tys | fn == funTyConName
+                                 , [t1,t2] <- tys
+                                 , (args, res) <- splitHsFunType t2
+                                 = (t1:args, res)
+    go (L _ (HsAppTy t1 t2)) tys = go t1 (t2:tys)
+    go (L _ (HsParTy ty))    tys = go ty tys
+    go _                     _   = ([], orig_ty)  -- Failure to match
+
+splitHsFunType other = ([], other)
 \end{code}
 
 

compiler/hsSyn/HsUtils.lhs

@@ -132,8 +132,8 @@ unguardedGRHSs rhs = GRHSs (unguardedRHS rhs) emptyLocalBinds
 unguardedRHS :: Located (body id) -> [LGRHS id (Located (body id))]
 unguardedRHS rhs@(L loc _) = [L loc (GRHS [] rhs)]
 
-mkMatchGroup :: [LMatch id (Located (body id))] -> MatchGroup id (Located (body id))
-mkMatchGroup matches = MG { mg_alts = matches, mg_arg_tys = [], mg_res_ty = placeHolderType }
+mkMatchGroup :: Origin -> [LMatch id (Located (body id))] -> MatchGroup id (Located (body id))
+mkMatchGroup origin matches = MG { mg_alts = matches, mg_arg_tys = [], mg_res_ty = placeHolderType, mg_origin = origin }
 
 mkHsAppTy :: LHsType name -> LHsType name -> LHsType name
 mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
@@ -144,7 +144,7 @@ mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
 	where
-          matches = mkMatchGroup [mkSimpleMatch pats body]
+          matches = mkMatchGroup Generated [mkSimpleMatch pats body]
 
 mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr Id -> LHsExpr Id
 mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars <.> mkWpLams dicts) expr
@@ -351,11 +351,11 @@ nlHsIf   :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
 nlHsCase :: LHsExpr id -> [LMatch id (LHsExpr id)] -> LHsExpr id
 nlList   :: [LHsExpr id] -> LHsExpr id
 
-nlHsLam	match		= noLoc (HsLam (mkMatchGroup [match]))
-nlHsPar e		= noLoc (HsPar e)
-nlHsIf cond true false	= noLoc (mkHsIf cond true false)
-nlHsCase expr matches	= noLoc (HsCase expr (mkMatchGroup matches))
-nlList exprs		= noLoc (ExplicitList placeHolderType Nothing exprs)
+nlHsLam	match          = noLoc (HsLam (mkMatchGroup Generated [match]))
+nlHsPar e              = noLoc (HsPar e)
+nlHsIf cond true false = noLoc (mkHsIf cond true false)
+nlHsCase expr matches  = noLoc (HsCase expr (mkMatchGroup Generated matches))
+nlList exprs           = noLoc (ExplicitList placeHolderType Nothing exprs)
 
 nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
 nlHsTyVar :: name                         -> LHsType name
@@ -478,20 +478,20 @@ l
 mkFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> HsBind RdrName
 -- Not infix, with place holders for coercion and free vars
 mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False
-                          , fun_matches = mkMatchGroup ms
-			  , fun_co_fn = idHsWrapper
+                          , fun_matches = mkMatchGroup Generated ms
+                          , fun_co_fn = idHsWrapper
                           , bind_fvs = placeHolderNames
-			  , fun_tick = Nothing }
+                          , fun_tick = Nothing }
 
-mkTopFunBind :: Located Name -> [LMatch Name (LHsExpr Name)] -> HsBind Name
+mkTopFunBind :: Origin -> Located Name -> [LMatch Name (LHsExpr Name)] -> HsBind Name
 -- In Name-land, with empty bind_fvs
-mkTopFunBind fn ms = FunBind { fun_id = fn, fun_infix = False
-                             , fun_matches = mkMatchGroup ms
-			     , fun_co_fn = idHsWrapper
-                             , bind_fvs = emptyNameSet	-- NB: closed binding
-			     , fun_tick = Nothing }
+mkTopFunBind origin fn ms = FunBind { fun_id = fn, fun_infix = False
+                                    , fun_matches = mkMatchGroup origin ms
+                                    , fun_co_fn = idHsWrapper
+                                    , bind_fvs = emptyNameSet	-- NB: closed binding
+                                    , fun_tick = Nothing }
 
-mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> (Origin, LHsBind RdrName)
+mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
 mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
 
 mkVarBind :: id -> LHsExpr id -> LHsBind id
@@ -507,9 +507,9 @@ mkPatSynBind name details lpat dir = PatSynBind{ patsyn_id = name
 
 ------------
 mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
-		-> LHsExpr RdrName -> (Origin, LHsBind RdrName)
+		-> LHsExpr RdrName -> LHsBind RdrName
 mk_easy_FunBind loc fun pats expr
-  = (Generated, L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds])
+  = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds]
 
 ------------
 mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id (LHsExpr id)
@@ -580,11 +580,11 @@ collectHsBindListBinders :: [LHsBindLR idL idR] -> [idL]
 collectHsBindListBinders = foldr (collect_bind . unLoc) []
 
 collect_binds :: LHsBindsLR idL idR -> [idL] -> [idL]
-collect_binds binds acc = foldrBag (collect_bind . unLoc . snd) acc binds
+collect_binds binds acc = foldrBag (collect_bind . unLoc) acc binds
 
 collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName]
 -- Used exclusively for the bindings of an instance decl which are all FunBinds
-collectMethodBinders binds = foldrBag (get . unLoc . snd) [] binds
+collectMethodBinders binds = foldrBag (get . unLoc) [] binds
   where
     get (FunBind { fun_id = f }) fs = f : fs
     get _                        fs = fs	
@@ -808,7 +808,7 @@ hsValBindsImplicits (ValBindsIn binds _)
   = lhsBindsImplicits binds
 
 lhsBindsImplicits :: LHsBindsLR Name idR -> NameSet
-lhsBindsImplicits = foldBag unionNameSets (lhs_bind . unLoc . snd) emptyNameSet
+lhsBindsImplicits = foldBag unionNameSets (lhs_bind . unLoc) emptyNameSet
   where
     lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat
     lhs_bind _ = emptyNameSet

compiler/iface/BuildTyCl.lhs

@@ -15,7 +15,7 @@ module BuildTyCl (
         buildSynTyCon,
         buildAlgTyCon, 
         buildDataCon,
-        buildPatSyn, mkPatSynMatcherId, mkPatSynWrapperId,
+        buildPatSyn,
         TcMethInfo, buildClass,
         distinctAbstractTyConRhs, totallyAbstractTyConRhs,
         mkNewTyConRhs, mkDataTyConRhs, 
@@ -36,10 +36,9 @@ import MkId
 import Class
 import TyCon
 import Type
-import TypeRep
-import TcType
 import Id
 import Coercion
+import TcType
 
 import DynFlags
 import TcRnMonad
@@ -184,66 +183,28 @@ mkDataConStupidTheta tycon arg_tys univ_tvs
 
 
 ------------------------------------------------------
-buildPatSyn :: Name -> Bool -> Bool
-            -> [Var]
+buildPatSyn :: Name -> Bool
+            -> Id -> Maybe Id
+            -> [Type]
             -> [TyVar] -> [TyVar]     -- Univ and ext
             -> ThetaType -> ThetaType -- Prov and req
             -> Type                  -- Result type
-            -> TyVar
-            -> TcRnIf m n PatSyn
-buildPatSyn src_name declared_infix has_wrapper args univ_tvs ex_tvs prov_theta req_theta pat_ty tv
-  = do	{ (matcher, _, _) <- mkPatSynMatcherId src_name args
-                                              univ_tvs ex_tvs
-                                              prov_theta req_theta
-                                              pat_ty tv
-        ; wrapper <- case has_wrapper of
-            False -> return Nothing
-            True -> fmap Just $
-                    mkPatSynWrapperId src_name args
-                                      (univ_tvs ++ ex_tvs) (prov_theta ++ req_theta)
-                                      pat_ty
-        ; return $ mkPatSyn src_name declared_infix
-                            args
-                            univ_tvs ex_tvs
-                            prov_theta req_theta
-                            pat_ty
-                            matcher
-                            wrapper }
-
-mkPatSynMatcherId :: Name
-                  -> [Var]
-                  -> [TyVar]
-                  -> [TyVar]
-                  -> ThetaType -> ThetaType
-                  -> Type
-                  -> TyVar
-                  -> TcRnIf n m (Id, Type, Type)
-mkPatSynMatcherId name args univ_tvs ex_tvs prov_theta req_theta pat_ty res_tv
-  = do { matcher_name <- newImplicitBinder name mkMatcherOcc
-
-       ; let res_ty = TyVarTy res_tv
-             cont_ty = mkSigmaTy ex_tvs prov_theta $
-                       mkFunTys (map varType args) res_ty
-
-       ; let matcher_tau = mkFunTys [pat_ty, cont_ty, res_ty] res_ty
-             matcher_sigma = mkSigmaTy (res_tv:univ_tvs) req_theta matcher_tau
-             matcher_id = mkVanillaGlobal matcher_name matcher_sigma
-       ; return (matcher_id, res_ty, cont_ty) }
-
-mkPatSynWrapperId :: Name
-                  -> [Var]
-                  -> [TyVar]
-                  -> ThetaType
-                  -> Type
-                  -> TcRnIf n m Id
-mkPatSynWrapperId name args qtvs theta pat_ty
-  = do { wrapper_name <- newImplicitBinder name mkDataConWrapperOcc
-
-       ; let wrapper_tau = mkFunTys (map varType args) pat_ty
-             wrapper_sigma = mkSigmaTy qtvs theta wrapper_tau
-
-       ; let wrapper_id = mkVanillaGlobal wrapper_name wrapper_sigma
-       ; return wrapper_id }
+            -> PatSyn
+buildPatSyn src_name declared_infix matcher wrapper
+            args univ_tvs ex_tvs prov_theta req_theta pat_ty
+  = mkPatSyn src_name declared_infix
+             args
+             univ_tvs ex_tvs
+             prov_theta req_theta
+             pat_ty
+             matcher
+             wrapper
+  where
+    -- TODO: assert that these match the ones in the parameters
+    ((_:_univ_tvs'), _req_theta', tau) = tcSplitSigmaTy $ idType matcher
+    ([_pat_ty', cont_sigma, _], _) = tcSplitFunTys tau
+    (_ex_tvs', _prov_theta', cont_tau) = tcSplitSigmaTy cont_sigma
+    (_args', _) = tcSplitFunTys cont_tau
 
 \end{code}
 

compiler/iface/IfaceEnv.lhs

@@ -28,13 +28,10 @@ module IfaceEnv (
 import TcRnMonad
 import TysWiredIn
 import HscTypes
-import TyCon
 import Type
-import DataCon
 import Var
 import Name
 import Avail
-import PrelNames
 import Module
 import UniqFM
 import FastString
@@ -183,23 +180,34 @@ lookupOrig mod occ
 
 See Note [The Name Cache] above.
 
+Note [Built-in syntax and the OrigNameCache]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+You might think that usin isBuiltInOcc_maybe in lookupOrigNameCache is
+unnecessary because tuple TyCon/DataCons are parsed as Exact RdrNames
+and *don't* appear as original names in interface files (because
+serialization gives them special treatment), so we will never look
+them up in the original name cache.
+
+However, there are two reasons why we might look up an Orig RdrName:
+
+  * If you use setRdrNameSpace on an Exact RdrName it may be
+    turned into an Orig RdrName. 
+
+  * Template Haskell turns a BuiltInSyntax Name into a TH.NameG
+    (DsMeta.globalVar), and parses a NameG into an Orig RdrName
+    (Convert.thRdrName).  So, eg $(do { reify '(,); ... }) will
+    go this route (Trac #8954).
+
 \begin{code}
 lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name
-lookupOrigNameCache _ mod occ
-  -- Don't need to mention gHC_UNIT here because it is explicitly
-  -- included in TysWiredIn.wiredInTyCons
-  | mod == gHC_TUPLE || mod == gHC_PRIM,		-- Boxed tuples from one, 
-    Just tup_info <- isTupleOcc_maybe occ	-- unboxed from the other
-  = 	-- Special case for tuples; there are too many
+lookupOrigNameCache nc mod occ
+  | Just name <- isBuiltInOcc_maybe occ
+  = 	-- See Note [Known-key names], 3(c) in PrelNames
+        -- Special case for tuples; there are too many
 	-- of them to pre-populate the original-name cache
-    Just (mk_tup_name tup_info)
-  where
-    mk_tup_name (ns, sort, arity)
-	| ns == tcName   = tyConName (tupleTyCon sort arity)
-	| ns == dataName = dataConName (tupleCon sort arity)
-	| otherwise      = Var.varName (dataConWorkId (tupleCon sort arity))
+    Just name
 
-lookupOrigNameCache nc mod occ	-- The normal case
+  | otherwise
   = case lookupModuleEnv nc mod of
 	Nothing      -> Nothing
 	Just occ_env -> lookupOccEnv occ_env occ

compiler/iface/IfaceSyn.lhs

@@ -55,9 +55,11 @@ import TysWiredIn ( eqTyConName )
 import Fingerprint
 import Binary
 import BooleanFormula ( BooleanFormula )
+import HsBinds
 
 import Control.Monad
 import System.IO.Unsafe
+import Data.Maybe (isJust)
 
 infixl 3 &&&
 \end{code}
@@ -119,13 +121,16 @@ data IfaceDecl
                    ifExtName :: Maybe FastString }
 
   | IfacePatSyn { ifName          :: OccName,           -- Name of the pattern synonym
-                  ifPatHasWrapper :: Bool,
                   ifPatIsInfix    :: Bool,
+                  ifPatMatcher    :: IfExtName,
+                  ifPatWrapper    :: Maybe IfExtName,
+                  -- Everything below is redundant,
+                  -- but needed to implement pprIfaceDecl
                   ifPatUnivTvs    :: [IfaceTvBndr],
                   ifPatExTvs      :: [IfaceTvBndr],
                   ifPatProvCtxt   :: IfaceContext,
                   ifPatReqCtxt    :: IfaceContext,
-                  ifPatArgs       :: [IfaceIdBndr],
+                  ifPatArgs       :: [IfaceType],
                   ifPatTy         :: IfaceType }
 
 -- A bit of magic going on here: there's no need to store the OccName
@@ -185,7 +190,7 @@ instance Binary IfaceDecl where
         put_ bh a3
         put_ bh a4
 
-    put_ bh (IfacePatSyn name a2 a3 a4 a5 a6 a7 a8 a9) = do
+    put_ bh (IfacePatSyn name a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
         putByte bh 6
         put_ bh (occNameFS name)
         put_ bh a2
@@ -196,6 +201,7 @@ instance Binary IfaceDecl where
         put_ bh a7
         put_ bh a8
         put_ bh a9
+        put_ bh a10
 
     get bh = do
         h <- getByte bh
@@ -252,8 +258,9 @@ instance Binary IfaceDecl where
                     a7 <- get bh
                     a8 <- get bh
                     a9 <- get bh
+                    a10 <- get bh
                     occ <- return $! mkOccNameFS dataName a1
-                    return (IfacePatSyn occ a2 a3 a4 a5 a6 a7 a8 a9)
+                    return (IfacePatSyn occ a2 a3 a4 a5 a6 a7 a8 a9 a10)
             _ -> panic (unwords ["Unknown IfaceDecl tag:", show h])
 
 data IfaceSynTyConRhs
@@ -1014,11 +1021,6 @@ ifaceDeclImplicitBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ,
     dc_occ = mkClassDataConOcc cls_tc_occ
     is_newtype = n_sigs + n_ctxt == 1 -- Sigh
 
-ifaceDeclImplicitBndrs (IfacePatSyn{ ifName = ps_occ, ifPatHasWrapper = has_wrapper })
-  = [wrap_occ | has_wrapper]
-  where
-    wrap_occ = mkDataConWrapperOcc ps_occ  -- Id namespace
-
 ifaceDeclImplicitBndrs _ = []
 
 -- -----------------------------------------------------------------------------
@@ -1046,7 +1048,7 @@ instance Outputable IfaceDecl where
 pprIfaceDecl :: IfaceDecl -> SDoc
 pprIfaceDecl (IfaceId {ifName = var, ifType = ty,
                        ifIdDetails = details, ifIdInfo = info})
-  = sep [ ppr var <+> dcolon <+> ppr ty,
+  = sep [ pprPrefixOcc var <+> dcolon <+> ppr ty,
           nest 2 (ppr details),
           nest 2 (ppr info) ]
 
@@ -1099,32 +1101,28 @@ pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
                 sep (map ppr sigs)])
 
 pprIfaceDecl (IfaceAxiom {ifName = name, ifTyCon = tycon, ifAxBranches = branches })
-  = hang (ptext (sLit "axiom") <+> ppr name <> colon)
+  = hang (ptext (sLit "axiom") <+> ppr name <> dcolon)
        2 (vcat $ map (pprAxBranch $ Just tycon) branches)
 
-pprIfaceDecl (IfacePatSyn { ifName = name, ifPatHasWrapper = has_wrap,
+pprIfaceDecl (IfacePatSyn { ifName = name, ifPatWrapper = wrapper,
                             ifPatIsInfix = is_infix,
-                            ifPatUnivTvs = univ_tvs, ifPatExTvs = ex_tvs,
+                            ifPatUnivTvs = _univ_tvs, ifPatExTvs = _ex_tvs,
                             ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt,
                             ifPatArgs = args,
                             ifPatTy = ty })
-  = hang (text "pattern" <+> header)
-       4 details
+  = pprPatSynSig name has_wrap args' ty' (pprCtxt prov_ctxt) (pprCtxt req_ctxt)
   where
-    header = ppr name <+> dcolon <+>
-             (pprIfaceForAllPart univ_tvs req_ctxt $
-              pprIfaceForAllPart ex_tvs prov_ctxt $
-              pp_tau)
-
-    details = sep [ if is_infix then text "Infix" else empty
-                  , if has_wrap then text "HasWrapper" else empty
-                  ]
+    has_wrap = isJust wrapper
+    args' = case (is_infix, args) of
+        (True, [left_ty, right_ty]) ->
+            InfixPatSyn (pprParendIfaceType left_ty) (pprParendIfaceType right_ty)
+        (_, tys) ->
+            PrefixPatSyn (map pprParendIfaceType tys)
 
-    pp_tau = case map pprParendIfaceType (arg_tys ++ [ty]) of
-        (t:ts) -> fsep (t : map (arrow <+>) ts)
-        []     -> panic "pp_tau"
+    ty' = pprParendIfaceType ty
 
-    arg_tys = map snd args
+    pprCtxt [] = Nothing
+    pprCtxt ctxt = Just $ pprIfaceContext ctxt
 
 pprCType :: Maybe CType -> SDoc
 pprCType Nothing = ptext (sLit "No C type associated")
@@ -1152,7 +1150,7 @@ instance Outputable IfaceAT where
 
 pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc
 pprIfaceDeclHead context thing tyvars
-  = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing),
+  = hsep [pprIfaceContextArr context, parenSymOcc thing (ppr thing),
           pprIfaceTvBndrs tyvars]
 
 pp_condecls :: OccName -> IfaceConDecls -> SDoc
@@ -1396,11 +1394,13 @@ freeNamesIfDecl d@IfaceAxiom{} =
   freeNamesIfTc (ifTyCon d) &&&
   fnList freeNamesIfAxBranch (ifAxBranches d)
 freeNamesIfDecl d@IfacePatSyn{} =
+  unitNameSet (ifPatMatcher d) &&&
+  maybe emptyNameSet unitNameSet (ifPatWrapper d) &&&
   freeNamesIfTvBndrs (ifPatUnivTvs d) &&&
   freeNamesIfTvBndrs (ifPatExTvs d) &&&
   freeNamesIfContext (ifPatProvCtxt d) &&&
   freeNamesIfContext (ifPatReqCtxt d) &&&
-  fnList freeNamesIfType (map snd (ifPatArgs d)) &&&
+  fnList freeNamesIfType (ifPatArgs d) &&&
   freeNamesIfType (ifPatTy d)
 
 freeNamesIfAxBranch :: IfaceAxBranch -> NameSet

compiler/iface/IfaceType.lhs

@@ -22,7 +22,7 @@ module IfaceType (
         toIfaceCoercion,
 
         -- Printing
-        pprIfaceType, pprParendIfaceType, pprIfaceContext,
+        pprIfaceType, pprParendIfaceType, pprIfaceContext, pprIfaceContextArr,
         pprIfaceIdBndr, pprIfaceTvBndr, pprIfaceTvBndrs,
         pprIfaceBndrs,
         tOP_PREC, tYCON_PREC, noParens, maybeParen, pprIfaceForAllPart,
@@ -31,6 +31,8 @@ module IfaceType (
     ) where
 
 import Coercion
+import TcType
+import DynFlags
 import TypeRep hiding( maybeParen )
 import Unique( hasKey )
 import TyCon
@@ -248,15 +250,18 @@ ppr_ty ctxt_prec ty@(IfaceForAllTy _ _)
  where
     (tvs, theta, tau) = splitIfaceSigmaTy ty
 
- -------------------
+-------------------
 -- needs to handle type contexts and coercion contexts, hence the
 -- generality
 pprIfaceForAllPart :: Outputable a => [IfaceTvBndr] -> [a] -> SDoc -> SDoc
 pprIfaceForAllPart tvs ctxt doc
-  = sep [ppr_tvs, pprIfaceContext ctxt, doc]
+  = sep [ppr_tvs, pprIfaceContextArr ctxt, doc]
   where
     ppr_tvs | null tvs  = empty
-            | otherwise = ptext (sLit "forall") <+> pprIfaceTvBndrs tvs <> dot
+            | otherwise = sdocWithDynFlags $ \ dflags ->
+            if gopt Opt_PrintExplicitForalls dflags
+            then ptext (sLit "forall") <+> pprIfaceTvBndrs tvs <> dot
+            else empty
 
 -------------------
 ppr_tc_app :: (Int -> a -> SDoc) -> Int -> IfaceTyCon -> [a] -> SDoc
@@ -386,14 +391,14 @@ instance Binary IfaceTyLit where
          _ -> panic ("get IfaceTyLit " ++ show tag)
 
 -------------------
-pprIfaceContext :: Outputable a => [a] -> SDoc
+pprIfaceContextArr :: Outputable a => [a] -> SDoc
 -- Prints "(C a, D b) =>", including the arrow
-pprIfaceContext []    = empty
-pprIfaceContext theta = ppr_preds theta <+> darrow
+pprIfaceContextArr []    = empty
+pprIfaceContextArr theta = pprIfaceContext theta <+> darrow
 
-ppr_preds :: Outputable a => [a] -> SDoc
-ppr_preds [pred] = ppr pred    -- No parens
-ppr_preds preds  = parens (sep (punctuate comma (map ppr preds)))
+pprIfaceContext :: Outputable a => [a] -> SDoc
+pprIfaceContext [pred] = ppr pred    -- No parens
+pprIfaceContext preds  = parens (sep (punctuate comma (map ppr preds)))
 
 instance Binary IfaceType where
     put_ bh (IfaceForAllTy aa ab) = do

compiler/iface/LoadIface.lhs

@@ -416,7 +416,6 @@ loadDecl ignore_prags mod (_version, decl)
   = do  {       -- Populate the name cache with final versions of all 
                 -- the names associated with the decl
           main_name      <- lookupOrig mod (ifName decl)
---        ; traceIf (text "Loading decl for " <> ppr main_name)
 
         -- Typecheck the thing, lazily
         -- NB. Firstly, the laziness is there in case we never need the
@@ -490,6 +489,8 @@ loadDecl ignore_prags mod (_version, decl)
                              pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (decl))
 
         ; implicit_names <- mapM (lookupOrig mod) (ifaceDeclImplicitBndrs decl)
+
+--         ; traceIf (text "Loading decl for " <> ppr main_name $$ ppr implicit_names)
         ; return $ (main_name, thing) :
                       -- uses the invariant that implicit_names and
                       -- implictTyThings are bijective

compiler/iface/MkIface.lhs

@@ -1461,7 +1461,7 @@ tyThingToIfaceDecl (AnId id)      = idToIfaceDecl id
 tyThingToIfaceDecl (ATyCon tycon) = tyConToIfaceDecl emptyTidyEnv tycon
 tyThingToIfaceDecl (ACoAxiom ax)  = coAxiomToIfaceDecl ax
 tyThingToIfaceDecl (AConLike cl)  = case cl of
-    RealDataCon dc -> pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier
+    RealDataCon dc -> dataConToIfaceDecl dc -- for ppr purposes only
     PatSynCon ps   -> patSynToIfaceDecl ps
 
 --------------------------
@@ -1476,29 +1476,38 @@ idToIfaceDecl id
               ifIdDetails = toIfaceIdDetails (idDetails id),
               ifIdInfo    = toIfaceIdInfo (idInfo id) }
 
+--------------------------
+dataConToIfaceDecl :: DataCon -> IfaceDecl
+dataConToIfaceDecl dataCon
+  = IfaceId { ifName      = getOccName dataCon,
+              ifType      = toIfaceType (dataConUserType dataCon),
+              ifIdDetails = IfVanillaId,
+              ifIdInfo    = NoInfo }
+
 --------------------------
 patSynToIfaceDecl :: PatSyn -> IfaceDecl
 patSynToIfaceDecl ps
   = IfacePatSyn { ifName          = getOccName . getName $ ps
-                , ifPatHasWrapper = isJust $ patSynWrapper ps
+                , ifPatMatcher    = matcher
+                , ifPatWrapper    = wrapper
                 , ifPatIsInfix    = patSynIsInfix ps
                 , ifPatUnivTvs    = toIfaceTvBndrs univ_tvs'
                 , ifPatExTvs      = toIfaceTvBndrs ex_tvs'
                 , ifPatProvCtxt   = tidyToIfaceContext env2 prov_theta
                 , ifPatReqCtxt    = tidyToIfaceContext env2 req_theta
-                , ifPatArgs       = map toIfaceArg args
+                , ifPatArgs       = map (tidyToIfaceType env2) args
                 , ifPatTy         = tidyToIfaceType env2 rhs_ty
                 }
   where
-    toIfaceArg var = (occNameFS (getOccName var),
-                      tidyToIfaceType env2 (varType var))
-
-    (univ_tvs, ex_tvs, (prov_theta, req_theta)) = patSynSig ps
+    (univ_tvs, ex_tvs, prov_theta, req_theta) = patSynSig ps
     args = patSynArgs ps
     rhs_ty = patSynType ps
     (env1, univ_tvs') = tidyTyVarBndrs emptyTidyEnv univ_tvs
     (env2, ex_tvs')   = tidyTyVarBndrs env1 ex_tvs
 
+    matcher = idName (patSynMatcher ps)
+    wrapper = fmap idName (patSynWrapper ps)
+
 
 --------------------------
 coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl

compiler/iface/TcIface.lhs

@@ -584,7 +584,8 @@ tc_iface_decl _ _ (IfaceAxiom { ifName = ax_occ, ifTyCon = tc
        ; return (ACoAxiom axiom) }
 
 tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name
-                              , ifPatHasWrapper = has_wrapper
+                              , ifPatMatcher = matcher_name
+                              , ifPatWrapper = wrapper_name
                               , ifPatIsInfix = is_infix
                               , ifPatUnivTvs = univ_tvs
                               , ifPatExTvs = ex_tvs
@@ -594,20 +595,24 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name
                               , ifPatTy = pat_ty })
   = do { name <- lookupIfaceTop occ_name
        ; traceIf (ptext (sLit "tc_iface_decl") <+> ppr name)
+       ; matcher <- tcExt "Matcher" matcher_name
+       ; wrapper <- case wrapper_name of
+                        Nothing -> return Nothing
+                        Just wn -> do { wid <- tcExt "Wrapper" wn
+                                      ; return (Just wid) }
        ; bindIfaceTyVars univ_tvs $ \univ_tvs -> do
        { bindIfaceTyVars ex_tvs $ \ex_tvs -> do
-       { bindIfaceIdVars args $ \args -> do
-       { ~(prov_theta, req_theta, pat_ty) <- forkM (mk_doc name) $
+       { patsyn <- forkM (mk_doc name) $
              do { prov_theta <- tcIfaceCtxt prov_ctxt
                 ; req_theta  <- tcIfaceCtxt req_ctxt
                 ; pat_ty     <- tcIfaceType pat_ty
-                ; return (prov_theta, req_theta, pat_ty) }
-       ; bindIfaceTyVar (fsLit "r", toIfaceKind liftedTypeKind) $ \tv -> do
-       { patsyn <- buildPatSyn name is_infix has_wrapper args univ_tvs ex_tvs prov_theta req_theta pat_ty tv
-       ; return (AConLike (PatSynCon patsyn)) }}}}}
+                ; arg_tys    <- mapM tcIfaceType args
+                ; return $ buildPatSyn name is_infix matcher wrapper
+                                       arg_tys univ_tvs ex_tvs prov_theta req_theta pat_ty }
+       ; return $ AConLike . PatSynCon $ patsyn }}}
   where
      mk_doc n = ptext (sLit "Pattern synonym") <+> ppr n
-
+     tcExt s name = forkM (ptext (sLit s) <+> ppr name) $ tcIfaceExtId name
 
 tc_ax_branches :: TyCon -> [IfaceAxBranch] -> IfL [CoAxBranch]
 tc_ax_branches tc if_branches = foldlM (tc_ax_branch (tyConKind tc)) [] if_branches
@@ -1548,20 +1553,6 @@ bindIfaceTyVars bndrs thing_inside
   where
     (occs,kinds) = unzip bndrs
 
-bindIfaceIdVar :: IfaceIdBndr -> (Id -> IfL a) -> IfL a
-bindIfaceIdVar (occ, ty) thing_inside
-  = do  { name <- newIfaceName (mkVarOccFS occ)
-        ; ty' <- tcIfaceType ty
-        ; let id = mkLocalId name ty'
-        ; extendIfaceIdEnv [id] (thing_inside id) }
-
-bindIfaceIdVars :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a
-bindIfaceIdVars []     thing_inside = thing_inside []
-bindIfaceIdVars (v:vs) thing_inside
-  = bindIfaceIdVar v     $ \ v' ->
-    bindIfaceIdVars vs   $ \ vs' ->
-    thing_inside (v':vs')
-
 isSuperIfaceKind :: IfaceKind -> Bool
 isSuperIfaceKind (IfaceTyConApp (IfaceTc n) []) = n == superKindTyConName
 isSuperIfaceKind _ = False