compiler/deSugar/Check.hs

@@ -452,11 +452,11 @@ get_lit :: Pat id -> Maybe HsLit
 -- 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 (OverLit { ol_val = HsIntegral src i})    mb _)
+get_lit (NPat (L _ (OverLit { ol_val = HsIntegral src i}))    mb _)
                         = Just (HsIntPrim src (mb_neg negate              mb i))
-get_lit (NPat (OverLit { ol_val = HsFractional f }) mb _)
+get_lit (NPat (L _ (OverLit { ol_val = HsFractional f })) mb _)
                         = Just (HsFloatPrim (mb_neg negateFractionalLit mb f))
-get_lit (NPat (OverLit { ol_val = HsIsString src s })   _  _)
+get_lit (NPat (L _ (OverLit { ol_val = HsIsString src s }))   _  _)
                         = Just (HsStringPrim src (fastStringToByteString s))
 get_lit _                                                 = Nothing
 
@@ -727,7 +727,7 @@ tidy_pat (TuplePat ps boxity tys)
   where
     arity = length ps
 
-tidy_pat (NPat lit mb_neg eq) = tidyNPat tidy_lit_pat lit mb_neg eq
+tidy_pat (NPat (L _ lit) mb_neg eq) = tidyNPat tidy_lit_pat lit mb_neg eq
 tidy_pat (LitPat lit)         = tidy_lit_pat lit
 
 tidy_pat (ConPatIn {})        = panic "Check.tidy_pat: ConPatIn"

compiler/deSugar/Coverage.hs

@@ -567,7 +567,7 @@ addTickHsExpr (HsTick t e) =
 addTickHsExpr (HsBinTick t0 t1 e) =
         liftM (HsBinTick t0 t1) (addTickLHsExprNever e)
 
-addTickHsExpr (HsTickPragma _ (L pos e0)) = do
+addTickHsExpr (HsTickPragma _ _ (L pos e0)) = do
     e2 <- allocTickBox (ExpBox False) False False pos $
                 addTickHsExpr e0
     return $ unLoc e2
@@ -575,12 +575,14 @@ addTickHsExpr (PArrSeq   ty arith_seq) =
         liftM2 PArrSeq
                 (return ty)
                 (addTickArithSeqInfo arith_seq)
-addTickHsExpr (HsSCC nm e) =
-        liftM2 HsSCC
+addTickHsExpr (HsSCC src nm e) =
+        liftM3 HsSCC
+                (return src)
                 (return nm)
                 (addTickLHsExpr e)
-addTickHsExpr (HsCoreAnn nm e) =
-        liftM2 HsCoreAnn
+addTickHsExpr (HsCoreAnn src nm e) =
+        liftM3 HsCoreAnn
+                (return src)
                 (return nm)
                 (addTickLHsExpr e)
 addTickHsExpr e@(HsBracket     {})   = return e
@@ -614,10 +616,10 @@ addTickMatchGroup is_lam mg@(MG { mg_alts = matches }) = do
   return $ mg { mg_alts = matches' }
 
 addTickMatch :: Bool -> Bool -> Match Id (LHsExpr Id) -> TM (Match Id (LHsExpr Id))
-addTickMatch isOneOfMany isLambda (Match pats opSig gRHSs) =
+addTickMatch isOneOfMany isLambda (Match mf pats opSig gRHSs) =
   bindLocals (collectPatsBinders pats) $ do
     gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs
-    return $ Match pats opSig gRHSs'
+    return $ Match mf pats opSig gRHSs'
 
 addTickGRHSs :: Bool -> Bool -> GRHSs Id (LHsExpr Id) -> TM (GRHSs Id (LHsExpr Id))
 addTickGRHSs isOneOfMany isLambda (GRHSs guarded local_binds) = do
@@ -829,10 +831,10 @@ addTickCmdMatchGroup mg@(MG { mg_alts = matches }) = do
   return $ mg { mg_alts = matches' }
 
 addTickCmdMatch :: Match Id (LHsCmd Id) -> TM (Match Id (LHsCmd Id))
-addTickCmdMatch (Match pats opSig gRHSs) =
+addTickCmdMatch (Match mf pats opSig gRHSs) =
   bindLocals (collectPatsBinders pats) $ do
     gRHSs' <- addTickCmdGRHSs gRHSs
-    return $ Match pats opSig gRHSs'
+    return $ Match mf pats opSig gRHSs'
 
 addTickCmdGRHSs :: GRHSs Id (LHsCmd Id) -> TM (GRHSs Id (LHsCmd Id))
 addTickCmdGRHSs (GRHSs guarded local_binds) = do
@@ -1204,7 +1206,7 @@ hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
 matchesOneOfMany :: [LMatch Id body] -> Bool
 matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
   where
-        matchCount (L _ (Match _pats _ty (GRHSs grhss _binds))) = length grhss
+        matchCount (L _ (Match _ _pats _ty (GRHSs grhss _binds))) = length grhss
 
 type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)
 

compiler/deSugar/Desugar.hs

@@ -24,7 +24,6 @@ import Coercion
 import InstEnv
 import Class
 import Avail
-import PatSyn
 import CoreSyn
 import CoreSubst
 import PprCore
@@ -184,7 +183,7 @@ deSugar hsc_env
                 mg_fam_insts    = fam_insts,
                 mg_inst_env     = inst_env,
                 mg_fam_inst_env = fam_inst_env,
-                mg_patsyns      = filter ((`elemNameSet` export_set) . patSynName) patsyns,
+                mg_patsyns      = patsyns,
                 mg_rules        = ds_rules_for_imps,
                 mg_binds        = ds_binds,
                 mg_foreign      = ds_fords,
@@ -462,12 +461,12 @@ by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS).
 -}
 
 dsVect :: LVectDecl Id -> DsM CoreVect
-dsVect (L loc (HsVect (L _ v) rhs))
+dsVect (L loc (HsVect _ (L _ v) rhs))
   = putSrcSpanDs loc $
     do { rhs' <- dsLExpr rhs
        ; return $ Vect v rhs'
        }
-dsVect (L _loc (HsNoVect (L _ v)))
+dsVect (L _loc (HsNoVect _ (L _ v)))
   = return $ NoVect v
 dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon))
   = return $ VectType isScalar tycon' rhs_tycon
@@ -475,11 +474,11 @@ dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon))
     tycon' | Just ty <- coreView $ mkTyConTy tycon
            , (tycon', []) <- splitTyConApp ty      = tycon'
            | otherwise                             = tycon
-dsVect vd@(L _ (HsVectTypeIn _ _ _))
+dsVect vd@(L _ (HsVectTypeIn _ _ _ _))
   = pprPanic "Desugar.dsVect: unexpected 'HsVectTypeIn'" (ppr vd)
 dsVect (L _loc (HsVectClassOut cls))
   = return $ VectClass (classTyCon cls)
-dsVect vc@(L _ (HsVectClassIn _))
+dsVect vc@(L _ (HsVectClassIn _ _))
   = pprPanic "Desugar.dsVect: unexpected 'HsVectClassIn'" (ppr vc)
 dsVect (L _loc (HsVectInstOut inst))
   = return $ VectInst (instanceDFunId inst)

compiler/deSugar/DsArrows.hs

@@ -399,7 +399,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do
 --              ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd
 
 dsCmd ids local_vars stack_ty res_ty
-        (HsCmdLam (MG { mg_alts = [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] }))
+        (HsCmdLam (MG { mg_alts = [L _ (Match _ pats _
+                                       (GRHSs [L _ (GRHS [] body)] _ ))] }))
         env_ids = do
     let
         pat_vars = mkVarSet (collectPatsBinders pats)
@@ -1046,7 +1047,7 @@ matchSimplys _ _ _ _ _ = panic "matchSimplys"
 -- List of leaf expressions, with set of variables bound in each
 
 leavesMatch :: LMatch Id (Located (body Id)) -> [(Located (body Id), IdSet)]
-leavesMatch (L _ (Match pats _ (GRHSs grhss binds)))
+leavesMatch (L _ (Match _ pats _ (GRHSs grhss binds)))
   = let
         defined_vars = mkVarSet (collectPatsBinders pats)
                         `unionVarSet`
@@ -1065,11 +1066,11 @@ replaceLeavesMatch
         -> LMatch Id (Located (body Id))        -- the matches of a case command
         -> ([Located (body' Id)],               -- remaining leaf expressions
             LMatch Id (Located (body' Id)))     -- updated match
-replaceLeavesMatch _res_ty leaves (L loc (Match pat mt (GRHSs grhss binds)))
+replaceLeavesMatch _res_ty leaves (L loc (Match mf pat mt (GRHSs grhss binds)))
   = let
         (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
     in
-    (leaves', L loc (Match pat mt (GRHSs grhss' binds)))
+    (leaves', L loc (Match mf pat mt (GRHSs grhss' binds)))
 
 replaceLeavesGRHS
         :: [Located (body' Id)]                 -- replacement leaf expressions of that type

compiler/deSugar/DsBinds.hs

@@ -36,27 +36,30 @@ import CoreArity ( etaExpand )
 import CoreUnfold
 import CoreFVs
 import UniqSupply
-import Unique( Unique )
 import Digraph
-
-
-import TyCon      ( isTupleTyCon, tyConDataCons_maybe )
+import PrelNames
+import TysPrim ( mkProxyPrimTy )
+import TyCon      ( isTupleTyCon, tyConDataCons_maybe
+                  , tyConName, isPromotedTyCon, isPromotedDataCon, tyConKind )
 import TcEvidence
 import TcType
 import Type
+import Kind (returnsConstraintKind)
 import Coercion hiding (substCo)
-import TysWiredIn ( eqBoxDataCon, coercibleDataCon, tupleCon )
+import TysWiredIn ( eqBoxDataCon, coercibleDataCon, tupleCon, mkListTy
+                  , mkBoxedTupleTy, stringTy )
 import Id
+import MkId(proxyHashId)
 import Class
-import DataCon  ( dataConWorkId )
+import DataCon  ( dataConTyCon, dataConWorkId )
 import Name
-import MkId     ( seqId )
 import IdInfo   ( IdDetails(..) )
 import Var
 import VarSet
 import Rules
 import VarEnv
 import Outputable
+import Module
 import SrcLoc
 import Maybes
 import OrdList
@@ -70,6 +73,7 @@ import Util
 import Control.Monad( when )
 import MonadUtils
 import Control.Monad(liftM)
+import Fingerprint(Fingerprint(..), fingerprintString)
 
 {-
 ************************************************************************
@@ -600,37 +604,41 @@ decomposeRuleLhs orig_bndrs orig_lhs
                           -- See Note [Unused spec binders]
   = Left (vcat (map dead_msg unbound))
 
-  | Var fn_var <- fun
-  , not (fn_var `elemVarSet` orig_bndr_set)
+  | Just (fn_id, args) <- decompose fun2 args2
+  , let extra_dict_bndrs = mk_extra_dict_bndrs fn_id args
   = -- pprTrace "decmposeRuleLhs" (vcat [ ptext (sLit "orig_bndrs:") <+> ppr orig_bndrs
     --                                  , ptext (sLit "orig_lhs:") <+> ppr orig_lhs
     --                                  , ptext (sLit "lhs1:")     <+> ppr lhs1
-    --                                  , ptext (sLit "bndrs1:") <+> ppr bndrs1
-    --                                  , ptext (sLit "fn_var:") <+> ppr fn_var
+    --                                  , ptext (sLit "extra_dict_bndrs:") <+> ppr extra_dict_bndrs
+    --                                  , ptext (sLit "fn_id:") <+> ppr fn_id
     --                                  , ptext (sLit "args:")   <+> ppr args]) $
-    Right (bndrs1, fn_var, args)
-
-  | Case scrut bndr ty [(DEFAULT, _, body)] <- fun
-  , isDeadBinder bndr   -- Note [Matching seqId]
-  , let args' = [Type (idType bndr), Type ty, scrut, body]
-  = Right (bndrs1, seqId, args' ++ args)
+    Right (orig_bndrs ++ extra_dict_bndrs, fn_id, args)
 
   | otherwise
   = Left bad_shape_msg
  where
-   lhs1       = drop_dicts orig_lhs
-   lhs2       = simpleOptExpr lhs1  -- See Note [Simplify rule LHS]
-   (fun,args) = collectArgs lhs2
+   lhs1         = drop_dicts orig_lhs
+   lhs2         = simpleOptExpr lhs1  -- See Note [Simplify rule LHS]
+   (fun2,args2) = collectArgs lhs2
+
    lhs_fvs    = exprFreeVars lhs2
    unbound    = filterOut (`elemVarSet` lhs_fvs) orig_bndrs
-   bndrs1     = orig_bndrs ++ extra_dict_bndrs
 
    orig_bndr_set = mkVarSet orig_bndrs
 
         -- Add extra dict binders: Note [Free dictionaries]
-   extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d)
-                      | d <- varSetElems (lhs_fvs `delVarSetList` orig_bndrs)
-                      , isDictId d ]
+   mk_extra_dict_bndrs fn_id args
+     = [ mkLocalId (localiseName (idName d)) (idType d)
+       | d <- varSetElems (exprsFreeVars args `delVarSetList` (fn_id : orig_bndrs))
+              -- fn_id: do not quantify over the function itself, which may
+              -- itself be a dictionary (in pathological cases, Trac #10251)
+       , isDictId d ]
+
+   decompose (Var fn_id) args
+      | not (fn_id `elemVarSet` orig_bndr_set)
+      = Just (fn_id, args)
+
+   decompose _ _ = Nothing
 
    bad_shape_msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar"))
                       2 (vcat [ text "Optimised lhs:" <+> ppr lhs2
@@ -870,16 +878,16 @@ dsEvTerm (EvDFunApp df tys tms) = do { tms' <- mapM dsEvTerm tms
 dsEvTerm (EvCoercion (TcCoVarCo v)) = return (Var v)  -- See Note [Simple coercions]
 dsEvTerm (EvCoercion co)            = dsTcCoercion co mkEqBox
 
-dsEvTerm (EvTupleSel v n)
-   = do { tm' <- dsEvTerm v
-        ; let scrut_ty = exprType tm'
+dsEvTerm (EvTupleSel tm n)
+   = do { tup <- dsEvTerm tm
+        ; let scrut_ty  = exprType tup
               (tc, tys) = splitTyConApp scrut_ty
               Just [dc] = tyConDataCons_maybe tc
               xs = mkTemplateLocals tys
               the_x = getNth xs n
         ; ASSERT( isTupleTyCon tc )
           return $
-          Case tm' (mkWildValBinder scrut_ty) (idType the_x) [(DataAlt dc, xs, Var the_x)] }
+          Case tup (mkWildValBinder scrut_ty) (idType the_x) [(DataAlt dc, xs, Var the_x)] }
 
 dsEvTerm (EvTupleMk tms)
   = do { tms' <- mapM dsEvTerm tms
@@ -905,6 +913,181 @@ dsEvTerm (EvLit l) =
     EvNum n -> mkIntegerExpr n
     EvStr s -> mkStringExprFS s
 
+dsEvTerm (EvTypeable ev) = dsEvTypeable ev
+
+dsEvTerm (EvCallStack cs) = dsEvCallStack cs
+
+dsEvTypeable :: EvTypeable -> DsM CoreExpr
+dsEvTypeable ev =
+  do tyCl      <- dsLookupTyCon typeableClassName
+     typeRepTc <- dsLookupTyCon typeRepTyConName
+     let tyRepType = mkTyConApp typeRepTc []
+
+     (ty, rep) <-
+        case ev of
+
+          EvTypeableTyCon tc ks ->
+            do ctr       <- dsLookupGlobalId mkPolyTyConAppName
+               mkTyCon   <- dsLookupGlobalId mkTyConName
+               dflags    <- getDynFlags
+               let mkRep cRep kReps tReps =
+                     mkApps (Var ctr) [ cRep, mkListExpr tyRepType kReps
+                                            , mkListExpr tyRepType tReps ]
+
+               let kindRep k =
+                     case splitTyConApp_maybe k of
+                       Nothing -> panic "dsEvTypeable: not a kind constructor"
+                       Just (kc,ks) ->
+                         do kcRep <- tyConRep dflags mkTyCon kc
+                            reps  <- mapM kindRep ks
+                            return (mkRep kcRep [] reps)
+
+               tcRep     <- tyConRep dflags mkTyCon tc
+
+               kReps     <- mapM kindRep ks
+
+               return ( mkTyConApp tc ks
+                      , mkRep tcRep kReps []
+                      )
+
+          EvTypeableTyApp t1 t2 ->
+            do e1  <- getRep tyCl t1
+               e2  <- getRep tyCl t2
+               ctr <- dsLookupGlobalId mkAppTyName
+
+               return ( mkAppTy (snd t1) (snd t2)
+                      , mkApps (Var ctr) [ e1, e2 ]
+                      )
+
+          EvTypeableTyLit ty ->
+            do str <- case (isNumLitTy ty, isStrLitTy ty) of
+                        (Just n, _) -> return (show n)
+                        (_, Just n) -> return (show n)
+                        _ -> panic "dsEvTypeable: malformed TyLit evidence"
+               ctr <- dsLookupGlobalId typeLitTypeRepName
+               tag <- mkStringExpr str
+               return (ty, mkApps (Var ctr) [ tag ])
+
+     -- TyRep -> Typeable t
+     -- see also: Note [Memoising typeOf]
+     repName <- newSysLocalDs tyRepType
+     let proxyT = mkProxyPrimTy (typeKind ty) ty
+         method = bindNonRec repName rep
+                $ mkLams [mkWildValBinder proxyT] (Var repName)
+
+     -- package up the method as `Typeable` dictionary
+     return $ mkCast method $ mkSymCo $ getTypeableCo tyCl ty
+
+  where
+  -- co: method -> Typeable k t
+  getTypeableCo tc t =
+    case instNewTyCon_maybe tc [typeKind t, t] of
+      Just (_,co) -> co
+      _           -> panic "Class `Typeable` is not a `newtype`."
+
+  -- Typeable t -> TyRep
+  getRep tc (ev,t) =
+    do typeableExpr <- dsEvTerm ev
+       let co     = getTypeableCo tc t
+           method = mkCast typeableExpr co
+           proxy  = mkTyApps (Var proxyHashId) [typeKind t, t]
+       return (mkApps method [proxy])
+
+  -- This part could be cached
+  tyConRep dflags mkTyCon tc =
+    do pkgStr  <- mkStringExprFS pkg_fs
+       modStr  <- mkStringExprFS modl_fs
+       nameStr <- mkStringExprFS name_fs
+       return (mkApps (Var mkTyCon) [ int64 high, int64 low
+                                    , pkgStr, modStr, nameStr
+                                    ])
+    where
+    tycon_name                = tyConName tc
+    modl                      = nameModule tycon_name
+    pkg                       = modulePackageKey modl
+
+    modl_fs                   = moduleNameFS (moduleName modl)
+    pkg_fs                    = packageKeyFS pkg
+    name_fs                   = occNameFS (nameOccName tycon_name)
+    hash_name_fs
+      | isPromotedTyCon tc    = appendFS (mkFastString "$k") name_fs
+      | isPromotedDataCon tc  = appendFS (mkFastString "$c") name_fs
+      | isTupleTyCon tc &&
+        returnsConstraintKind (tyConKind tc)
+                              = appendFS (mkFastString "$p") name_fs
+      | otherwise             = name_fs
+
+    hashThis = unwords $ map unpackFS [pkg_fs, modl_fs, hash_name_fs]
+    Fingerprint high low = fingerprintString hashThis
+
+    int64
+      | wORD_SIZE dflags == 4 = mkWord64LitWord64
+      | otherwise             = mkWordLit dflags . fromIntegral
+
+
+
+{- Note [Memoising typeOf]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+See #3245, #9203
+
+IMPORTANT: we don't want to recalculate the TypeRep once per call with
+the proxy argument.  This is what went wrong in #3245 and #9203. So we
+help GHC by manually keeping the 'rep' *outside* the lambda.
+-}
+
+dsEvCallStack :: EvCallStack -> DsM CoreExpr
+-- See Note [Overview of implicit CallStacks] in TcEvidence.hs
+dsEvCallStack cs = do
+  df              <- getDynFlags
+  m               <- getModule
+  srcLocDataCon   <- dsLookupDataCon srcLocDataConName
+  let srcLocTyCon  = dataConTyCon srcLocDataCon
+  let srcLocTy     = mkTyConTy srcLocTyCon
+  let mkSrcLoc l =
+        liftM (mkCoreConApps srcLocDataCon)
+              (sequence [ mkStringExprFS (packageKeyFS $ modulePackageKey m)
+                        , mkStringExprFS (moduleNameFS $ moduleName m)
+                        , mkStringExprFS (srcSpanFile l)
+                        , return $ mkIntExprInt df (srcSpanStartLine l)
+                        , return $ mkIntExprInt df (srcSpanStartCol l)
+                        , return $ mkIntExprInt df (srcSpanEndLine l)
+                        , return $ mkIntExprInt df (srcSpanEndCol l)
+                        ])
+
+  let callSiteTy = mkBoxedTupleTy [stringTy, srcLocTy]
+
+  matchId         <- newSysLocalDs $ mkListTy callSiteTy
+
+  callStackDataCon <- dsLookupDataCon callStackDataConName
+  let callStackTyCon = dataConTyCon callStackDataCon
+  let callStackTy    = mkTyConTy callStackTyCon
+  let emptyCS        = mkCoreConApps callStackDataCon [mkNilExpr callSiteTy]
+  let pushCS name loc rest =
+        mkWildCase rest callStackTy callStackTy
+                   [( DataAlt callStackDataCon
+                    , [matchId]
+                    , mkCoreConApps callStackDataCon
+                       [mkConsExpr callSiteTy
+                                   (mkCoreTup [name, loc])
+                                   (Var matchId)]
+                    )]
+  let mkPush name loc tm = do
+        nameExpr <- mkStringExprFS name
+        locExpr <- mkSrcLoc loc
+        case tm of
+          EvCallStack EvCsEmpty -> return (pushCS nameExpr locExpr emptyCS)
+          _ -> do tmExpr  <- dsEvTerm tm
+                  -- at this point tmExpr :: IP sym CallStack
+                  -- but we need the actual CallStack to pass to pushCS,
+                  -- so we use unwrapIP to strip the dictionary wrapper
+                  -- See Note [Overview of implicit CallStacks]
+                  let ip_co = unwrapIP (exprType tmExpr)
+                  return (pushCS nameExpr locExpr (mkCast tmExpr ip_co))
+  case cs of
+    EvCsTop name loc tm -> mkPush name loc tm
+    EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm
+    EvCsEmpty -> panic "Cannot have an empty CallStack"
+
 ---------------------------------------
 dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> DsM CoreExpr
 -- This is the crucial function that moves

compiler/deSugar/DsExpr.hs

@@ -300,13 +300,18 @@ dsExpr (ExplicitTuple tup_args boxity)
                   mkCoreConApps (tupleCon (boxityNormalTupleSort boxity) (length tup_args))
                                 (map (Type . exprType) args ++ args) }
 
-dsExpr (HsSCC cc expr@(L loc _)) = do
-    mod_name <- getModule
-    count <- goptM Opt_ProfCountEntries
-    uniq <- newUnique
-    Tick (ProfNote (mkUserCC cc mod_name loc uniq) count True) <$> dsLExpr expr
-
-dsExpr (HsCoreAnn _ expr)
+dsExpr (HsSCC _ cc expr@(L loc _)) = do
+    dflags <- getDynFlags
+    if gopt Opt_SccProfilingOn dflags
+      then do
+        mod_name <- getModule
+        count <- goptM Opt_ProfCountEntries
+        uniq <- newUnique
+        Tick (ProfNote (mkUserCC cc mod_name loc uniq) count True)
+               <$> dsLExpr expr
+      else dsLExpr expr
+
+dsExpr (HsCoreAnn _ _ expr)
   = dsLExpr expr
 
 dsExpr (HsCase discrim matches)
@@ -403,8 +408,8 @@ dsExpr (PArrSeq _ _)
     g = ... static f ...
 ==>
     sptEntry:N = StaticPtr
-        (fingerprintString "pkgId:module.sptEntry:N")
-        (StaticPtrInfo "current pkg id" "current module" "sptEntry:0")
+        (fingerprintString "pkgKey:module.sptEntry:N")
+        (StaticPtrInfo "current pkg key" "current module" "sptEntry:0")
         f
     g = ... sptEntry:N
 \end{verbatim}
@@ -669,13 +674,18 @@ dsExpr (HsBinTick ixT ixF e) = do
        mkBinaryTickBox ixT ixF e2
      }
 
+dsExpr (HsTickPragma _ _ expr) = do
+  dflags <- getDynFlags
+  if gopt Opt_Hpc dflags
+    then panic "dsExpr:HsTickPragma"
+    else dsLExpr expr
+
 -- HsSyn constructs that just shouldn't be here:
 dsExpr (ExprWithTySig {})  = panic "dsExpr:ExprWithTySig"
 dsExpr (HsBracket     {})  = panic "dsExpr:HsBracket"
 dsExpr (HsQuasiQuoteE {})  = panic "dsExpr:HsQuasiQuoteE"
 dsExpr (HsArrApp      {})  = panic "dsExpr:HsArrApp"
 dsExpr (HsArrForm     {})  = panic "dsExpr:HsArrForm"
-dsExpr (HsTickPragma  {})  = panic "dsExpr:HsTickPragma"
 dsExpr (EWildPat      {})  = panic "dsExpr:EWildPat"
 dsExpr (EAsPat        {})  = panic "dsExpr:EAsPat"
 dsExpr (EViewPat      {})  = panic "dsExpr:EViewPat"
@@ -684,6 +694,7 @@ dsExpr (HsType        {})  = panic "dsExpr:HsType"
 dsExpr (HsDo          {})  = panic "dsExpr:HsDo"
 
 
+
 findField :: [LHsRecField Id arg] -> Name -> [arg]
 findField rbinds lbl
   = [rhs | L _ (HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs }) <- rbinds

compiler/deSugar/DsForeign.hs

@@ -713,7 +713,7 @@ toCType = f False
            -- Note that we aren't looking through type synonyms or
            -- anything, as it may be the synonym that is annotated.
            | TyConApp tycon _ <- t
-           , Just (CType mHeader cType) <- tyConCType_maybe tycon
+           , Just (CType _ mHeader cType) <- tyConCType_maybe tycon
               = (mHeader, ftext cType)
            -- If we don't know a C type for this type, then try looking
            -- through one layer of type synonym etc.

compiler/deSugar/DsMeta.hs

@@ -147,9 +147,11 @@ repTopDs group@(HsGroup { hs_valds   = valds
                      ; fix_ds   <- mapM repFixD fixds
                      ; _        <- mapM no_default_decl defds
                      ; for_ds   <- mapM repForD fords
-                     ; _        <- mapM no_warn warnds
+                     ; _        <- mapM no_warn (concatMap (wd_warnings . unLoc)
+                                                           warnds)
                      ; ann_ds   <- mapM repAnnD annds
-                     ; rule_ds  <- mapM repRuleD ruleds
+                     ; rule_ds  <- mapM repRuleD (concatMap (rds_rules . unLoc)
+                                                            ruleds)
                      ; _        <- mapM no_vect vects
                      ; _        <- mapM no_doc docs
 
@@ -361,7 +363,7 @@ mk_extra_tvs tc tvs defn
       = do { uniq <- newUnique
            ; let { occ = mkTyVarOccFS (fsLit "t")
                  ; nm = mkInternalName uniq occ loc
-                 ; hs_tv = L loc (KindedTyVar nm kind) }
+                 ; hs_tv = L loc (KindedTyVar (noLoc nm) kind) }
            ; hs_tvs <- go rest
            ; return (hs_tv : hs_tvs) }
 
@@ -374,13 +376,14 @@ mk_extra_tvs tc tvs defn
 -------------------------
 -- represent fundeps
 --
-repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])
+repLFunDeps :: [Located (FunDep (Located Name))] -> DsM (Core [TH.FunDep])
 repLFunDeps fds = repList funDepTyConName repLFunDep fds
 
-repLFunDep :: Located (FunDep Name) -> DsM (Core TH.FunDep)
-repLFunDep (L _ (xs, ys)) = do xs' <- repList nameTyConName lookupBinder xs
-                               ys' <- repList nameTyConName lookupBinder ys
-                               repFunDep xs' ys'
+repLFunDep :: Located (FunDep (Located Name)) -> DsM (Core TH.FunDep)
+repLFunDep (L _ (xs, ys))
+   = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs
+        ys' <- repList nameTyConName (lookupBinder . unLoc) ys
+        repFunDep xs' ys'
 
 -- represent family declaration flavours
 --
@@ -488,12 +491,14 @@ repForD (L loc (ForeignImport name typ _ (CImport (L _ cc) (L _ s) mch cis _)))
     conv_cimportspec (CFunction (StaticTarget fs _ True)) = return (unpackFS fs)
     conv_cimportspec (CFunction (StaticTarget _  _ False)) = panic "conv_cimportspec: values not supported yet"
     conv_cimportspec CWrapper = return "wrapper"
+    -- these calling conventions do not support headers and the static keyword
+    raw_cconv = cc == PrimCallConv || cc == JavaScriptCallConv
     static = case cis of
-                 CFunction (StaticTarget _ _ _) -> "static "
+                 CFunction (StaticTarget _ _ _) | not raw_cconv -> "static "
                  _ -> ""
     chStr = case mch of
-            Nothing -> ""
-            Just (Header h) -> unpackFS h ++ " "
+            Just (Header h) | not raw_cconv -> unpackFS h ++ " "
+            _ -> ""
 repForD decl = notHandled "Foreign declaration" (ppr decl)
 
 repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
@@ -550,17 +555,17 @@ repRuleBndr (L _ (RuleBndrSig n (HsWB { hswb_cts = ty })))
        ; rep2 typedRuleVarName [n', ty'] }
 
 repAnnD :: LAnnDecl Name -> DsM (SrcSpan, Core TH.DecQ)
-repAnnD (L loc (HsAnnotation ann_prov (L _ exp)))
+repAnnD (L loc (HsAnnotation _ ann_prov (L _ exp)))
   = do { target <- repAnnProv ann_prov
        ; exp'   <- repE exp
        ; dec    <- repPragAnn target exp'
        ; return (loc, dec) }
 
 repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget)
-repAnnProv (ValueAnnProvenance n)
+repAnnProv (ValueAnnProvenance (L _ n))
   = do { MkC n' <- globalVar n  -- ANNs are allowed only at top-level
        ; rep2 valueAnnotationName [ n' ] }
-repAnnProv (TypeAnnProvenance n)
+repAnnProv (TypeAnnProvenance (L _ n))
   = do { MkC n' <- globalVar n
        ; rep2 typeAnnotationName [ n' ] }
 repAnnProv ModuleAnnProvenance
@@ -619,7 +624,7 @@ mkGadtCtxt :: [Name]            -- Tyvars of the data type
 -- This function is fiddly, but not really hard
 mkGadtCtxt _ ResTyH98
   = return ([], [])
-mkGadtCtxt data_tvs (ResTyGADT res_ty)
+mkGadtCtxt data_tvs (ResTyGADT _ res_ty)
   | Just (_, tys) <- hsTyGetAppHead_maybe res_ty
   , data_tvs `equalLength` tys
   = return (go [] [] (data_tvs `zip` tys))
@@ -651,9 +656,9 @@ repBangTy ty= do
   rep2 strictTypeName [s, t]
   where
     (str, ty') = case ty of
-                   L _ (HsBangTy (HsUserBang (Just True) True) ty) -> (unpackedName,  ty)
-                   L _ (HsBangTy (HsUserBang _     True) ty)       -> (isStrictName,  ty)
-                   _                               -> (notStrictName, ty)
+         L _ (HsBangTy (HsSrcBang _ (Just True) True) ty) -> (unpackedName,  ty)
+         L _ (HsBangTy (HsSrcBang _ _     True) ty)       -> (isStrictName,  ty)
+         _                                                -> (notStrictName, ty)
 
 -------------------------------------------------------
 --                      Deriving clause
@@ -695,7 +700,7 @@ rep_sig (L _   (FixSig {}))           = return [] -- fixity sigs at top level
 rep_sig (L loc (InlineSig nm ispec))  = rep_inline nm ispec loc
 rep_sig (L loc (SpecSig nm tys ispec))
    = concatMapM (\t -> rep_specialise nm t ispec loc) tys
-rep_sig (L loc (SpecInstSig ty))      = rep_specialiseInst ty loc
+rep_sig (L loc (SpecInstSig _ ty))    = rep_specialiseInst ty loc
 rep_sig (L _   (MinimalSig {}))       = notHandled "MINIMAL pragmas" empty
 
 rep_ty_sig :: Name -> SrcSpan -> LHsType Name -> Located Name
@@ -913,11 +918,11 @@ repTy (HsTyLit lit) = do
 repTy ty                      = notHandled "Exotic form of type" (ppr ty)
 
 repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)
-repTyLit (HsNumTy i) = do iExpr <- mkIntegerExpr i
-                          rep2 numTyLitName [iExpr]
-repTyLit (HsStrTy s) = do { s' <- mkStringExprFS s
-                         ; rep2 strTyLitName [s']
-                         }
+repTyLit (HsNumTy _ i) = do iExpr <- mkIntegerExpr i
+                            rep2 numTyLitName [iExpr]
+repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s
+                            ; rep2 strTyLitName [s']
+                            }
 
 -- represent a kind
 --
@@ -1104,7 +1109,7 @@ repE e                     = notHandled "Expression form" (ppr e)
 -- Building representations of auxillary structures like Match, Clause, Stmt,
 
 repMatchTup ::  LMatch Name (LHsExpr Name) -> DsM (Core TH.MatchQ)
-repMatchTup (L _ (Match [p] _ (GRHSs guards wheres))) =
+repMatchTup (L _ (Match _ [p] _ (GRHSs guards wheres))) =
   do { ss1 <- mkGenSyms (collectPatBinders p)
      ; addBinds ss1 $ do {
      ; p1 <- repLP p
@@ -1116,7 +1121,7 @@ repMatchTup (L _ (Match [p] _ (GRHSs guards wheres))) =
 repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
 
 repClauseTup ::  LMatch Name (LHsExpr Name) -> DsM (Core TH.ClauseQ)
-repClauseTup (L _ (Match ps _ (GRHSs guards wheres))) =
+repClauseTup (L _ (Match _ ps _ (GRHSs guards wheres))) =
   do { ss1 <- mkGenSyms (collectPatsBinders ps)
      ; addBinds ss1 $ do {
        ps1 <- repLPs ps
@@ -1268,8 +1273,10 @@ rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
 -- 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 = MG { mg_alts = [L _ (Match [] _ (GRHSs guards wheres))] } }))
+rep_bind (L loc (FunBind
+                 { fun_id = fn,
+                   fun_matches = MG { mg_alts = [L _ (Match _ [] _
+                                                   (GRHSs guards wheres))] } }))
  = do { (ss,wherecore) <- repBinds wheres
         ; guardcore <- addBinds ss (repGuards guards)
         ; fn'  <- lookupLBinder fn
@@ -1328,7 +1335,7 @@ rep_bind (L _ dec@(PatSynBind {})) = notHandled "pattern synonyms" (ppr dec)
 -- (\ p1 .. pn -> exp) by causing an error.
 
 repLambda :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ExpQ)
-repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
+repLambda (L _ (Match _ ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
  = do { let bndrs = collectPatsBinders ps ;
       ; ss  <- mkGenSyms bndrs
       ; lam <- addBinds ss (
@@ -1380,7 +1387,7 @@ repP (ConPatIn dc details)
                           ; MkC p <- repLP (hsRecFieldArg fld)
                           ; rep2 fieldPatName [v,p] }
 
-repP (NPat l Nothing _)  = do { a <- repOverloadedLiteral l; repPlit a }
+repP (NPat (L _ l) Nothing _)  = do { a <- repOverloadedLiteral l; repPlit a }
 repP (ViewPat e p _) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
 repP p@(NPat _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
 repP p@(SigPatIn {})  = notHandled "Type signatures in patterns" (ppr p)
@@ -1848,7 +1855,7 @@ repConstr con (PrefixCon ps)
     = do arg_tys  <- repList strictTypeQTyConName repBangTy ps
          rep2 normalCName [unC con, unC arg_tys]
 
-repConstr con (RecCon ips)
+repConstr con (RecCon (L _ ips))
     = do { args <- concatMapM rep_ip ips
          ; arg_vtys <- coreList varStrictTypeQTyConName args
          ; rep2 recCName [unC con, unC arg_vtys] }

compiler/deSugar/Match.hs

@@ -575,7 +575,7 @@ tidy1 _ (LitPat lit)
   = return (idDsWrapper, tidyLitPat lit)
 
 -- NPats: we *might* be able to replace these w/ a simpler form
-tidy1 _ (NPat lit mb_neg eq)
+tidy1 _ (NPat (L _ lit) mb_neg eq)
   = return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq)
 
 -- Everything else goes through unchanged...
@@ -803,7 +803,7 @@ matchWrapper ctxt (MG { mg_alts = matches
                          matchEquations ctxt new_vars eqns_info rhs_ty
         ; return (new_vars, result_expr) }
   where
-    mk_eqn_info (L _ (Match pats _ grhss))
+    mk_eqn_info (L _ (Match _ pats _ grhss))
       = do { let upats = map unLoc pats
            ; match_result <- dsGRHSs ctxt upats grhss rhs_ty
            ; return (EqnInfo { eqn_pats = upats, eqn_rhs  = match_result}) }
@@ -1062,8 +1062,9 @@ patGroup _      (ConPatOut { pat_con = con }) = case unLoc con of
     RealDataCon dcon -> PgCon dcon
     PatSynCon psyn -> PgSyn psyn
 patGroup dflags (LitPat lit)                  = PgLit (hsLitKey dflags lit)
-patGroup _      (NPat olit mb_neg _)          = PgN   (hsOverLitKey olit (isJust mb_neg))
-patGroup _      (NPlusKPat _ olit _ _)        = PgNpK (hsOverLitKey olit False)
+patGroup _      (NPat (L _ olit) mb_neg _)
+                                     = PgN   (hsOverLitKey olit (isJust mb_neg))
+patGroup _      (NPlusKPat _ (L _ olit) _ _)  = PgNpK (hsOverLitKey olit False)
 patGroup _      (CoPat _ p _)                 = PgCo  (hsPatType p) -- Type of innelexp pattern
 patGroup _      (ViewPat expr p _)            = PgView expr (hsPatType (unLoc p))
 patGroup _      (ListPat _ _ (Just _))        = PgOverloadedList

compiler/deSugar/MatchLit.hs

@@ -295,10 +295,12 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _
                             = mk_con_pat intDataCon    (HsIntPrim    "" int_lit)
   | isWordTy ty,   Just int_lit <- mb_int_lit
                             = mk_con_pat wordDataCon   (HsWordPrim   "" int_lit)
-  | isFloatTy ty,  Just rat_lit <- mb_rat_lit = mk_con_pat floatDataCon  (HsFloatPrim  rat_lit)
-  | isDoubleTy ty, Just rat_lit <- mb_rat_lit = mk_con_pat doubleDataCon (HsDoublePrim rat_lit)
   | isStringTy ty, Just str_lit <- mb_str_lit
                             = tidy_lit_pat (HsString "" str_lit)
+     -- NB: do /not/ convert Float or Double literals to F# 3.8 or D# 5.3
+     -- If we do convert to the constructor form, we'll generate a case
+     -- expression on a Float# or Double# and that's not allowed in Core; see
+     -- Trac #9238 and Note [Rules for floating-point comparisons] in PrelRules
   where
     mk_con_pat :: DataCon -> HsLit -> Pat Id
     mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] [])
@@ -309,22 +311,13 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _
                    (Just _,  HsIntegral _ i) -> Just (-i)
                    _ -> Nothing
 
-    mb_rat_lit :: Maybe FractionalLit
-    mb_rat_lit = case (mb_neg, val) of
-       (Nothing, HsIntegral _ i) -> Just (integralFractionalLit (fromInteger i))
-       (Just _,  HsIntegral _ i) -> Just (integralFractionalLit
-                                                             (fromInteger (-i)))
-       (Nothing, HsFractional f) -> Just f
-       (Just _, HsFractional f)  -> Just (negateFractionalLit f)
-       _ -> Nothing
-
     mb_str_lit :: Maybe FastString
     mb_str_lit = case (mb_neg, val) of
                    (Nothing, HsIsString _ s) -> Just s
                    _ -> Nothing
 
 tidyNPat _ over_lit mb_neg eq
-  = NPat over_lit mb_neg eq
+  = NPat (noLoc over_lit) mb_neg eq
 
 {-
 ************************************************************************
@@ -417,7 +410,7 @@ litValKey (HsIsString _ s) neg   = ASSERT( not neg) MachStr
 
 matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 matchNPats (var:vars) ty (eqn1:eqns)    -- All for the same literal
-  = do  { let NPat lit mb_neg eq_chk = firstPat eqn1
+  = do  { let NPat (L _ lit) mb_neg eq_chk = firstPat eqn1
         ; lit_expr <- dsOverLit lit
         ; neg_lit <- case mb_neg of
                             Nothing -> return lit_expr
@@ -450,7 +443,7 @@ We generate:
 matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 -- All NPlusKPats, for the *same* literal k
 matchNPlusKPats (var:vars) ty (eqn1:eqns)
-  = do  { let NPlusKPat (L _ n1) lit ge minus = firstPat eqn1
+  = do  { let NPlusKPat (L _ n1) (L _ lit) ge minus = firstPat eqn1
         ; ge_expr     <- dsExpr ge
         ; minus_expr  <- dsExpr minus
         ; lit_expr    <- dsOverLit lit

compiler/deSugar/StaticPtrTable.hs

@@ -24,8 +24,21 @@
 -- >
 -- > }
 --
--- where constants are values of a fingerprint of the string
--- "<package_id>:<module_name>.sptEntry:<N>"
+-- where the constants are fingerprints produced from the static forms.
+--
+-- There is also a finalization function for the time when the module is
+-- unloaded.
+--
+-- > static void hs_hpc_fini_Main(void) __attribute__((destructor));
+-- > static void hs_hpc_fini_Main(void) {
+-- >
+-- >   static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL};
+-- >   hs_spt_remove(k0);
+-- >
+-- >   static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL};
+-- >   hs_spt_remove(k1);
+-- >
+-- > }
 --
 module StaticPtrTable (sptInitCode) where
 
@@ -38,7 +51,7 @@ import GHC.Fingerprint
 
 
 -- | @sptInitCode module statics@ is a C stub to insert the static entries
--- @statics@ of @module@ into the static pointer table
+-- @statics@ of @module@ into the static pointer table.
 --
 -- Each entry contains the fingerprint used to locate the entry and the
 -- top-level binding for the entry.
@@ -63,6 +76,15 @@ sptInitCode this_mod entries = vcat
         <> semi
         |  (i, (fp, (n, _))) <- zip [0..] entries
         ]
+    , text "static void hs_spt_fini_" <> ppr this_mod
+           <> text "(void) __attribute__((destructor));"
+    , text "static void hs_spt_fini_" <> ppr this_mod <> text "(void)"
+    , braces $ vcat $
+        [  text "StgWord64 k" <> int i <> text "[2] = "
+           <> pprFingerprint fp <> semi
+        $$ text "hs_spt_remove" <> parens (char 'k' <> int i) <> semi
+        | (i, (fp, _)) <- zip [0..] entries
+        ]
     ]
 
   where

compiler/ghc.cabal.in

@@ -51,7 +51,7 @@ Library
                    time                 < 1.6,
                    containers >= 0.5 && < 0.6,
                    array      >= 0.1 && < 0.6,
-                   filepath   >= 1   && < 1.4,
+                   filepath   >= 1   && < 1.5,
                    hpc,
                    transformers,
                    bin-package-db,

compiler/ghc.mk

@@ -445,6 +445,7 @@ compiler_stage1_MUNGED_VERSION = $(subst .$(ProjectPatchLevel),,$(ProjectVersion
 define compiler_PACKAGE_MAGIC
 compiler_stage1_VERSION = $(compiler_stage1_MUNGED_VERSION)
 compiler_stage1_PACKAGE_KEY = $(subst .$(ProjectPatchLevel),,$(compiler_stage1_PACKAGE_KEY))
+compiler_stage1_LIB_NAME = $(subst .$(ProjectPatchLevel),,$(compiler_stage1_LIB_NAME))
 endef
 
 # NB: the PACKAGE_KEY munging has no effect for new-style package keys

compiler/ghci/ByteCodeItbls.hs

@@ -30,7 +30,7 @@ import Foreign
 import Foreign.C
 
 import GHC.Exts         ( Int(I#), addr2Int# )
-import GHC.Ptr          ( Ptr(..) )
+import GHC.Ptr          ( FunPtr(..) )
 
 {-
   Manufacturing of info tables for DataCons
@@ -87,7 +87,7 @@ make_constr_itbls dflags cons
         mk_dirret_itbl (dcon, conNo)
            = mk_itbl dcon conNo stg_interp_constr_entry
 
-        mk_itbl :: DataCon -> Int -> Ptr () -> IO (Name,ItblPtr)
+        mk_itbl :: DataCon -> Int -> EntryFunPtr -> IO (Name,ItblPtr)
         mk_itbl dcon conNo entry_addr = do
            let rep_args = [ (typePrimRep rep_arg,rep_arg) | arg <- dataConRepArgTys dcon, rep_arg <- flattenRepType (repType arg) ]
                (tot_wds, ptr_wds, _) = mkVirtHeapOffsets dflags False{-not a THUNK-} rep_args
@@ -128,10 +128,10 @@ make_constr_itbls dflags cons
 
 type ItblCodes = Either [Word8] [Word32]
 
-ptrToInt :: Ptr a -> Int
-ptrToInt (Ptr a#) = I# (addr2Int# a#)
+funPtrToInt :: FunPtr a -> Int
+funPtrToInt (FunPtr a#) = I# (addr2Int# a#)
 
-mkJumpToAddr :: DynFlags -> Ptr () -> ItblCodes
+mkJumpToAddr :: DynFlags -> EntryFunPtr -> ItblCodes
 mkJumpToAddr dflags a = case platformArch (targetPlatform dflags) of
     ArchSPARC ->
         -- After some consideration, we'll try this, where
@@ -144,7 +144,7 @@ mkJumpToAddr dflags a = case platformArch (targetPlatform dflags) of
         --   0008 81C0C000              jmp     %g3
         --   000c 01000000              nop
 
-        let w32 = fromIntegral (ptrToInt a)
+        let w32 = fromIntegral (funPtrToInt a)
 
             hi22, lo10 :: Word32 -> Word32
             lo10 x = x .&. 0x3FF
@@ -163,7 +163,7 @@ mkJumpToAddr dflags a = case platformArch (targetPlatform dflags) of
         -- 7D8903A6 mtctr r12
         -- 4E800420 bctr
 
-        let w32 = fromIntegral (ptrToInt a)
+        let w32 = fromIntegral (funPtrToInt a)
             hi16 x = (x `shiftR` 16) .&. 0xFFFF
             lo16 x = x .&. 0xFFFF
         in Right [ 0x3D800000 .|. hi16 w32,
@@ -176,7 +176,7 @@ mkJumpToAddr dflags a = case platformArch (targetPlatform dflags) of
         -- which is
         -- B8 ZZ YY XX WW FF E0
 
-        let w32 = fromIntegral (ptrToInt a) :: Word32
+        let w32 = fromIntegral (funPtrToInt a) :: Word32
             insnBytes :: [Word8]
             insnBytes
                = [0xB8, byte0 w32, byte1 w32,
@@ -200,7 +200,7 @@ mkJumpToAddr dflags a = case platformArch (targetPlatform dflags) of
         -- allocated in low memory).  Assuming the info pointer is aligned to
         -- an 8-byte boundary, the addr will also be aligned.
 
-        let w64 = fromIntegral (ptrToInt a) :: Word64
+        let w64 = fromIntegral (funPtrToInt a) :: Word64
             insnBytes :: [Word8]
             insnBytes
                = [0xff, 0x25, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00,
@@ -210,7 +210,7 @@ mkJumpToAddr dflags a = case platformArch (targetPlatform dflags) of
             Left insnBytes
 
     ArchAlpha ->
-        let w64 = fromIntegral (ptrToInt a) :: Word64
+        let w64 = fromIntegral (funPtrToInt a) :: Word64
         in Right [ 0xc3800000      -- br   at, .+4
                  , 0xa79c000c      -- ldq  at, 12(at)
                  , 0x6bfc0000      -- jmp  (at)    # with zero hint -- oh well
@@ -219,17 +219,17 @@ mkJumpToAddr dflags a = case platformArch (targetPlatform dflags) of
                  , fromIntegral ((w64 `shiftR` 32) .&. 0x0000FFFF) ]
 
     ArchARM { } ->
-        -- Generates Thumb sequence,
+        -- Generates Arm sequence,
         --      ldr r1, [pc, #0]
         --      bx r1
         --
         -- which looks like:
         --     00000000 <.addr-0x8>:
-        --     0:       4900        ldr    r1, [pc]      ; 8 <.addr>
-        --     4:       4708        bx     r1
-        let w32 = fromIntegral (ptrToInt a) :: Word32
-        in Left [ 0x49, 0x00
-                , 0x47, 0x08
+        --     0:       00109fe5    ldr    r1, [pc]      ; 8 <.addr>
+        --     4:       11ff2fe1    bx     r1
+        let w32 = fromIntegral (funPtrToInt a) :: Word32
+        in Left [ 0x00, 0x10, 0x9f, 0xe5
+                , 0x11, 0xff, 0x2f, 0xe1
                 , byte0 w32, byte1 w32, byte2 w32, byte3 w32]
 
     arch ->
@@ -247,7 +247,8 @@ byte6 w = fromIntegral (w `shiftR` 48)
 byte7 w = fromIntegral (w `shiftR` 56)
 
 -- entry point for direct returns for created constr itbls
-foreign import ccall "&stg_interp_constr_entry" stg_interp_constr_entry :: Ptr ()
+foreign import ccall "&stg_interp_constr_entry"
+    stg_interp_constr_entry :: EntryFunPtr
 
 
 
@@ -283,8 +284,10 @@ pokeConItbl dflags wr_ptr ex_ptr itbl
            store' (sizeOfItbl dflags) (pokeItbl dflags) (infoTable itbl)
            unless ghciTablesNextToCode $ store (conDesc itbl)
 
+type EntryFunPtr = FunPtr (Ptr () -> IO (Ptr ()))
+
 data StgInfoTable = StgInfoTable {
-   entry  :: Maybe (Ptr ()), -- Just <=> not ghciTablesNextToCode
+   entry  :: Maybe EntryFunPtr, -- Just <=> not ghciTablesNextToCode
    ptrs   :: HalfWord,
    nptrs  :: HalfWord,
    tipe   :: HalfWord,

compiler/ghci/Linker.hs

@@ -118,9 +118,9 @@ data PersistentLinkerState
         -- that is really important
         pkgs_loaded :: ![PackageKey],
 
-        -- we need to remember the name of the last temporary DLL/.so
-        -- so we can link it
-        last_temp_so :: !(Maybe FilePath) }
+        -- we need to remember the name of previous temporary DLL/.so
+        -- libraries so we can link them (see #10322)
+        temp_sos :: ![(FilePath, String)] }
 
 
 emptyPLS :: DynFlags -> PersistentLinkerState
@@ -130,7 +130,7 @@ emptyPLS _ = PersistentLinkerState {
                         pkgs_loaded = init_pkgs,
                         bcos_loaded = [],
                         objs_loaded = [],
-                        last_temp_so = Nothing }
+                        temp_sos = [] }
 
   -- Packages that don't need loading, because the compiler
   -- shares them with the interpreted program.
@@ -818,7 +818,7 @@ dynLoadObjs :: DynFlags -> PersistentLinkerState -> [FilePath]
 dynLoadObjs _      pls []   = return pls
 dynLoadObjs dflags pls objs = do
     let platform = targetPlatform dflags
-    soFile <- newTempName dflags (soExt platform)
+    (soFile, libPath , libName) <- newTempLibName dflags (soExt platform)
     let -- When running TH for a non-dynamic way, we still need to make
         -- -l flags to link against the dynamic libraries, so we turn
         -- Opt_Static off
@@ -826,20 +826,19 @@ dynLoadObjs dflags pls objs = do
         dflags2 = dflags1 {
                       -- We don't want the original ldInputs in
                       -- (they're already linked in), but we do want
-                      -- to link against the previous dynLoadObjs
-                      -- library if there was one, so that the linker
+                      -- to link against previous dynLoadObjs
+                      -- libraries if there were any, so that the linker
                       -- can resolve dependencies when it loads this
                       -- library.
                       ldInputs =
-                        case last_temp_so pls of
-                          Nothing -> []
-                          Just so  ->
-                                 let (lp, l) = splitFileName so in
+                        concatMap
+                            (\(lp, l) ->
                                  [ Option ("-L" ++ lp)
                                  , Option ("-Wl,-rpath")
                                  , Option ("-Wl," ++ lp)
-                                 , Option ("-l:" ++ l)
-                                 ],
+                                 , Option ("-l" ++  l)
+                                 ])
+                            (temp_sos pls),
                       -- Even if we're e.g. profiling, we still want
                       -- the vanilla dynamic libraries, so we set the
                       -- ways / build tag to be just WayDyn.
@@ -847,11 +846,14 @@ dynLoadObjs dflags pls objs = do
                       buildTag = mkBuildTag [WayDyn],
                       outputFile = Just soFile
                   }
-    linkDynLib dflags2 objs []
+    -- link all "loaded packages" so symbols in those can be resolved
+    -- Note: We are loading packages with local scope, so to see the
+    -- symbols in this link we must link all loaded packages again.
+    linkDynLib dflags2 objs (pkgs_loaded pls)
     consIORef (filesToNotIntermediateClean dflags) soFile
     m <- loadDLL soFile
     case m of
-        Nothing -> return pls { last_temp_so = Just soFile }
+        Nothing -> return pls { temp_sos = (libPath, libName) : temp_sos pls }
         Just err -> panic ("Loading temp shared object failed: " ++ err)
 
 rmDupLinkables :: [Linkable]    -- Already loaded
@@ -1199,7 +1201,7 @@ locateLib dflags is_hs dirs lib
     --       for a dynamic library (#5289)
     --   otherwise, assume loadDLL can find it
     --
-  = findDll `orElse` findArchive `orElse` tryGcc `orElse` assumeDll
+  = findDll `orElse` findArchive `orElse` tryGcc `orElse` tryGccPrefixed `orElse` assumeDll
 
   | not dynamicGhc
     -- When the GHC package was not compiled as dynamic library
@@ -1220,6 +1222,7 @@ locateLib dflags is_hs dirs lib
      mk_hs_dyn_lib_path dir = dir </> mkHsSOName platform hs_dyn_lib_name
 
      so_name = mkSOName platform lib
+     lib_so_name = "lib" ++ so_name
      mk_dyn_lib_path dir = case (arch, os) of
                              (ArchX86_64, OSSolaris2) -> dir </> ("64/" ++ so_name)
                              _ -> dir </> so_name
@@ -1230,6 +1233,7 @@ locateLib dflags is_hs dirs lib
      findHSDll      = liftM (fmap DLLPath) $ findFile mk_hs_dyn_lib_path dirs
      findDll        = liftM (fmap DLLPath) $ findFile mk_dyn_lib_path    dirs
      tryGcc         = liftM (fmap DLLPath) $ searchForLibUsingGcc dflags so_name dirs
+     tryGccPrefixed = liftM (fmap DLLPath) $ searchForLibUsingGcc dflags lib_so_name dirs
 
      assumeDll   = return (DLL lib)
      infixr `orElse`
@@ -1244,7 +1248,9 @@ locateLib dflags is_hs dirs lib
 
 searchForLibUsingGcc :: DynFlags -> String -> [FilePath] -> IO (Maybe FilePath)
 searchForLibUsingGcc dflags so dirs = do
-   str <- askCc dflags (map (FileOption "-L") dirs
+   -- GCC does not seem to extend the library search path (using -L) when using
+   -- --print-file-name. So instead pass it a new base location.
+   str <- askCc dflags (map (FileOption "-B") dirs
                           ++ [Option "--print-file-name", Option so])
    let file = case lines str of
                 []  -> ""

compiler/ghci/RtClosureInspect.hs

@@ -572,9 +572,7 @@ runTR hsc_env thing = do
 
 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
 runTR_maybe hsc_env thing_inside
-  = do { (_errs, res) <- initTc hsc_env HsSrcFile False
-                                (icInteractiveModule (hsc_IC hsc_env))
-                                thing_inside
+  = do { (_errs, res) <- initTcInteractive hsc_env thing_inside
        ; return res }
 
 -- | Term Reconstruction trace

compiler/hsSyn/Convert.hs

@@ -13,6 +13,7 @@ module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
                 thRdrNameGuesses ) where
 
 import HsSyn as Hs
+import HsTypes  ( mkHsForAllTy )
 import qualified Class
 import RdrName
 import qualified Name
@@ -41,6 +42,8 @@ import Control.Monad( unless, liftM, ap )
 import Control.Applicative (Applicative(..))
 #endif
 
+import Data.Char ( chr )
+import Data.Word ( Word8 )
 import Data.Maybe( catMaybes )
 import Language.Haskell.TH as TH hiding (sigP)
 import Language.Haskell.TH.Syntax as TH
@@ -242,7 +245,7 @@ cvtDec (InstanceD ctxt ty decs)
         ; unless (null fams') (failWith (mkBadDecMsg doc fams'))
         ; ctxt' <- cvtContext ctxt
         ; L loc ty' <- cvtType ty
-        ; let inst_ty' = L loc $ mkImplicitHsForAllTy ctxt' $ L loc ty'
+        ; let inst_ty' = L loc $ mkHsForAllTy Implicit [] ctxt' $ L loc ty'
         ; returnJustL $ InstD $ ClsInstD $
           ClsInstDecl inst_ty' binds' sigs' ats' adts' Nothing }
 
@@ -311,7 +314,7 @@ cvtDec (TH.RoleAnnotD tc roles)
 cvtDec (TH.StandaloneDerivD cxt ty)
   = do { cxt' <- cvtContext cxt
        ; L loc ty'  <- cvtType ty
-       ; let inst_ty' = L loc $ mkImplicitHsForAllTy cxt' $ L loc ty'
+       ; let inst_ty' = L loc $ mkHsForAllTy Implicit [] cxt' $ L loc ty'
        ; returnJustL $ DerivD $
          DerivDecl { deriv_type = inst_ty', deriv_overlap_mode = Nothing } }
 
@@ -418,7 +421,7 @@ cvtConstr (RecC c varstrtys)
         ; cxt'  <- returnL []
         ; args' <- mapM cvt_id_arg varstrtys
         ; returnL $ mkSimpleConDecl c' noExistentials cxt'
-                                   (RecCon args') }
+                                   (RecCon (noLoc args')) }
 
 cvtConstr (InfixC st1 c st2)
   = do  { c' <- cNameL c
@@ -436,8 +439,12 @@ cvtConstr (ForallC tvs ctxt con)
 
 cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName)
 cvt_arg (NotStrict, ty) = cvtType ty
-cvt_arg (IsStrict,  ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsUserBang Nothing     True) ty' }
-cvt_arg (Unpacked,  ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsUserBang (Just True) True) ty' }
+cvt_arg (IsStrict,  ty)
+  = do { ty' <- cvtType ty
+       ; returnL $ HsBangTy (HsSrcBang Nothing Nothing     True) ty' }
+cvt_arg (Unpacked,  ty)
+  = do { ty' <- cvtType ty
+       ; returnL $ HsBangTy (HsSrcBang Nothing (Just True) True) ty' }
 
 cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (LConDeclField RdrName)
 cvt_id_arg (i, str, ty)
@@ -455,8 +462,10 @@ cvtDerivs cs = do { cs' <- mapM cvt_one cs
           cvt_one c = do { c' <- tconName c
                          ; returnL $ HsTyVar c' }
 
-cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep RdrName))
-cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs; ys' <- mapM tName ys; returnL (xs', ys') }
+cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep (Located RdrName)))
+cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs
+                               ; ys' <- mapM tName ys
+                               ; returnL (map noLoc xs', map noLoc ys') }
 
 noExistentials :: [LHsTyVarBndr RdrName]
 noExistentials = []
@@ -467,16 +476,22 @@ noExistentials = []
 
 cvtForD :: Foreign -> CvtM (ForeignDecl RdrName)
 cvtForD (ImportF callconv safety from nm ty)
+  | callconv == TH.Prim || callconv == TH.JavaScript
+  = mk_imp (CImport (noLoc (cvt_conv callconv)) (noLoc safety') Nothing
+                    (CFunction (StaticTarget (mkFastString from) Nothing True))
+                    (noLoc from))
   | Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety')
                                  (mkFastString (TH.nameBase nm))
-                                 from (noLoc (mkFastString from))
-  = do { nm' <- vNameL nm
-       ; ty' <- cvtType ty
-       ; return (ForeignImport nm' ty' noForeignImportCoercionYet impspec)
-       }
+                                 from (noLoc from)
+  = mk_imp impspec
   | otherwise
   = failWith $ text (show from) <+> ptext (sLit "is not a valid ccall impent")
   where
+    mk_imp impspec
+      = do { nm' <- vNameL nm
+           ; ty' <- cvtType ty
+           ; return (ForeignImport nm' ty' noForeignImportCoercionYet impspec)
+           }
     safety' = case safety of
                      Unsafe     -> PlayRisky
                      Safe       -> PlaySafe
@@ -487,7 +502,7 @@ cvtForD (ExportF callconv as nm ty)
         ; ty' <- cvtType ty
         ; let e = CExport (noLoc (CExportStatic (mkFastString as)
                                                 (cvt_conv callconv)))
-                                                (noLoc (mkFastString as))
+                                                (noLoc as)
         ; return $ ForeignExport nm' ty' noForeignExportCoercionYet e }
 
 cvt_conv :: TH.Callconv -> CCallConv
@@ -505,7 +520,8 @@ cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl RdrName))
 cvtPragmaD (InlineP nm inline rm phases)
   = do { nm' <- vNameL nm
        ; let dflt = dfltActivation inline
-       ; let ip   = InlinePragma { inl_inline = cvtInline inline
+       ; let ip   = InlinePragma { inl_src    = "{-# INLINE"
+                                 , inl_inline = cvtInline inline
                                  , inl_rule   = cvtRuleMatch rm
                                  , inl_act    = cvtPhases phases dflt
                                  , inl_sat    = Nothing }
@@ -517,7 +533,8 @@ cvtPragmaD (SpecialiseP nm ty inline phases)
        ; let (inline', dflt) = case inline of
                Just inline1 -> (cvtInline inline1, dfltActivation inline1)
                Nothing      -> (EmptyInlineSpec,   AlwaysActive)
-       ; let ip = InlinePragma { inl_inline = inline'
+       ; let ip = InlinePragma { inl_src    = "{-# INLINE"
+                               , inl_inline = inline'
                                , inl_rule   = Hs.FunLike
                                , inl_act    = cvtPhases phases dflt
                                , inl_sat    = Nothing }
@@ -525,7 +542,7 @@ cvtPragmaD (SpecialiseP nm ty inline phases)
 
 cvtPragmaD (SpecialiseInstP ty)
   = do { ty' <- cvtType ty
-       ; returnJustL $ Hs.SigD $ SpecInstSig ty' }
+       ; returnJustL $ Hs.SigD $ SpecInstSig "{-# SPECIALISE" ty' }
 
 cvtPragmaD (RuleP nm bndrs lhs rhs phases)
   = do { let nm' = mkFastString nm
@@ -533,9 +550,10 @@ cvtPragmaD (RuleP nm bndrs lhs rhs phases)
        ; bndrs' <- mapM cvtRuleBndr bndrs
        ; lhs'   <- cvtl lhs
        ; rhs'   <- cvtl rhs
-       ; returnJustL $ Hs.RuleD $ HsRule (noLoc nm') act bndrs'
-                                     lhs' placeHolderNames
-                                     rhs' placeHolderNames
+       ; returnJustL $ Hs.RuleD
+            $ HsRules "{-# RULES" [noLoc $ HsRule (noLoc nm') act bndrs'
+                                                  lhs' placeHolderNames
+                                                  rhs' placeHolderNames]
        }
 
 cvtPragmaD (AnnP target exp)
@@ -544,11 +562,11 @@ cvtPragmaD (AnnP target exp)
          ModuleAnnotation  -> return ModuleAnnProvenance
          TypeAnnotation n  -> do
            n' <- tconName n
-           return (TypeAnnProvenance  n')
+           return (TypeAnnProvenance  (noLoc n'))
          ValueAnnotation n -> do
            n' <- vcName n
-           return (ValueAnnProvenance n')
-       ; returnJustL $ Hs.AnnD $ HsAnnotation target' exp'
+           return (ValueAnnProvenance (noLoc n'))
+       ; returnJustL $ Hs.AnnD $ HsAnnotation "{-# ANN" target' exp'
        }
 
 cvtPragmaD (LineP line file)
@@ -603,7 +621,7 @@ cvtClause (Clause ps body wheres)
   = do  { ps' <- cvtPats ps
         ; g'  <- cvtGuard body
         ; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) wheres
-        ; returnL $ Hs.Match ps' Nothing (GRHSs g' ds') }
+        ; returnL $ Hs.Match Nothing ps' Nothing (GRHSs g' ds') }
 
 
 -------------------------------------------------------------------
@@ -816,7 +834,7 @@ cvtMatch (TH.Match p body decs)
   = do  { p' <- cvtPat p
         ; g' <- cvtGuard body
         ; decs' <- cvtLocalDecs (ptext (sLit "a where clause")) decs
-        ; returnL $ Hs.Match [p'] Nothing (GRHSs g' decs') }
+        ; returnL $ Hs.Match Nothing [p'] Nothing (GRHSs g' decs') }
 
 cvtGuard :: TH.Body -> CvtM [LGRHS RdrName (LHsExpr RdrName)]
 cvtGuard (GuardedB pairs) = mapM cvtpair pairs
@@ -831,13 +849,13 @@ cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
 
 cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
 cvtOverLit (IntegerL i)
-  = do { force i; return $ mkHsIntegral "" i placeHolderType}
+  = do { force i; return $ mkHsIntegral (show i) i placeHolderType}
 cvtOverLit (RationalL r)
   = do { force r; return $ mkHsFractional (cvtFractionalLit r) placeHolderType}
 cvtOverLit (StringL s)
   = do { let { s' = mkFastString s }
        ; force s'
-       ; return $ mkHsIsString "" s' placeHolderType
+       ; return $ mkHsIsString s s' placeHolderType
        }
 cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
 -- An Integer is like an (overloaded) '3' in a Haskell source program
@@ -865,22 +883,25 @@ allCharLs xs
     go _  _                     = Nothing
 
 cvtLit :: Lit -> CvtM HsLit
-cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim "" i }
-cvtLit (WordPrimL w)   = do { force w; return $ HsWordPrim "" w }
+cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim (show i) i }
+cvtLit (WordPrimL w)   = do { force w; return $ HsWordPrim (show w) w }
 cvtLit (FloatPrimL f)  = do { force f; return $ HsFloatPrim (cvtFractionalLit f) }
 cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim (cvtFractionalLit f) }
-cvtLit (CharL c)       = do { force c; return $ HsChar "" c }
+cvtLit (CharL c)       = do { force c; return $ HsChar (show c) c }
 cvtLit (StringL s)     = do { let { s' = mkFastString s }
                             ; force s'
                             ; return $ HsString s s' }
 cvtLit (StringPrimL s) = do { let { s' = BS.pack s }
                             ; force s'
-                            ; return $ HsStringPrim "" s' }
+                            ; return $ HsStringPrim (w8ToString s) s' }
 cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
         -- cvtLit should not be called on IntegerL, RationalL
         -- That precondition is established right here in
         -- Convert.lhs, hence panic
 
+w8ToString :: [Word8] -> String
+w8ToString ws = map (\w -> chr (fromIntegral w)) ws
+
 cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName]
 cvtPats pats = mapM cvtPat pats
 
@@ -890,7 +911,7 @@ cvtPat pat = wrapL (cvtp pat)
 cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName)
 cvtp (TH.LitP l)
   | overloadedLit l    = do { l' <- cvtOverLit l
-                            ; return (mkNPat l' Nothing) }
+                            ; return (mkNPat (noLoc l') Nothing) }
                                   -- Not right for negative patterns;
                                   -- need to think about that!
   | otherwise          = do { l' <- cvtLit l; return $ Hs.LitPat l' }
@@ -953,7 +974,7 @@ cvt_tv (TH.PlainTV nm)
 cvt_tv (TH.KindedTV nm ki)
   = do { nm' <- tName nm
        ; ki' <- cvtKind ki
-       ; returnL $ KindedTyVar nm' ki' }
+       ; returnL $ KindedTyVar (noLoc nm') ki' }
 
 cvtRole :: TH.Role -> Maybe Coercion.Role
 cvtRole TH.NominalR          = Just Coercion.Nominal
@@ -1064,8 +1085,8 @@ split_ty_app ty = go ty []
     go f as           = return (f,as)
 
 cvtTyLit :: TH.TyLit -> HsTyLit
-cvtTyLit (NumTyLit i) = HsNumTy i
-cvtTyLit (StrTyLit s) = HsStrTy (fsLit s)
+cvtTyLit (NumTyLit i) = HsNumTy (show i) i
+cvtTyLit (StrTyLit s) = HsStrTy s        (fsLit s)
 
 cvtKind :: TH.Kind -> CvtM (LHsKind RdrName)
 cvtKind = cvtTypeKind "kind"

compiler/hsSyn/HsBinds.hs

@@ -47,8 +47,6 @@ import Data.Foldable ( Foldable(..) )
 import Data.Traversable ( Traversable(..) )
 import Data.Monoid ( mappend )
 import Control.Applicative hiding (empty)
-#else
-import Control.Applicative ((<$>))
 #endif
 
 {-
@@ -73,15 +71,24 @@ type HsLocalBinds id = HsLocalBindsLR id id
 -- or a 'where' clause
 data HsLocalBindsLR idL idR
   = HsValBinds (HsValBindsLR idL idR)
+         -- There should be no pattern synonyms in the HsValBindsLR
+         -- These are *local* (not top level) bindings
+         -- The parser accepts them, however, leaving the the
+         -- renamer to report them
+
   | HsIPBinds  (HsIPBinds idR)
+
   | EmptyLocalBinds
   deriving (Typeable)
+
 deriving instance (DataId idL, DataId idR)
   => Data (HsLocalBindsLR idL idR)
 
 type HsValBinds id = HsValBindsLR id id
 
 -- | Value bindings (not implicit parameters)
+-- Used for both top level and nested bindings
+-- May contain pattern synonym bindings
 data HsValBindsLR idL idR
   = -- | Before renaming RHS; idR is always RdrName
     -- Not dependency analysed
@@ -97,6 +104,7 @@ data HsValBindsLR idL idR
         [(RecFlag, LHsBinds idL)]
         [LSig Name]
   deriving (Typeable)
+
 deriving instance (DataId idL, DataId idR)
   => Data (HsValBindsLR idL idR)
 
@@ -126,9 +134,11 @@ data HsBindLR idL idR
     --
     --  - 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere',
     --    'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
+
+    -- For details on above see note [Api annotations] in ApiAnnotation
     FunBind {
 
-        fun_id :: Located idL,
+        fun_id :: Located idL, -- Note [fun_id in Match] in HsExpr
 
         fun_infix :: Bool,      -- ^ True => infix declaration
 
@@ -163,6 +173,8 @@ data HsBindLR idL idR
   --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang',
   --       'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere',
   --       'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
   | PatBind {
         pat_lhs    :: LPat idL,
         pat_rhs    :: GRHSs idR (LHsExpr idR),
@@ -197,8 +209,11 @@ data HsBindLR idL idR
 
   | PatSynBind (PatSynBind idL idR)
         -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',
-        --           'ApiAnnotation.AnnLarrow','ApiAnnotation.AnnWhere'
-        --           'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'
+        --          'ApiAnnotation.AnnLarrow','ApiAnnotation.AnnEqual',
+        --          'ApiAnnotation.AnnWhere'
+        --          'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@
+
+        -- For details on above see note [Api annotations] in ApiAnnotation
 
   deriving (Typeable)
 deriving instance (DataId idL, DataId idR)
@@ -224,6 +239,12 @@ data ABExport id
         , abe_prags :: TcSpecPrags  -- ^ SPECIALISE pragmas
   } deriving (Data, Typeable)
 
+-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',
+--             'ApiAnnotation.AnnEqual','ApiAnnotation.AnnLarrow'
+--             'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen' @'{'@,
+--             'ApiAnnotation.AnnClose' @'}'@,
+
+-- For details on above see note [Api annotations] in ApiAnnotation
 data PatSynBind idL idR
   = PSB { psb_id   :: Located idL,             -- ^ Name of the pattern synonym
           psb_fvs  :: PostRn idR NameSet,      -- ^ See Note [Bind free vars]
@@ -539,15 +560,20 @@ type LIPBind id = Located (IPBind id)
 -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a
 --   list
 
+-- For details on above see note [Api annotations] in ApiAnnotation
+
 -- | Implicit parameter bindings.
 --
+-- These bindings start off as (Left "x") in the parser and stay
+-- that way until after type-checking when they are replaced with
+-- (Right d), where "d" is the name of the dictionary holding the
+-- evidence for the implicit parameter.
+--
 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual'
-{- These bindings start off as (Left "x") in the parser and stay
-that way until after type-checking when they are replaced with
-(Right d), where "d" is the name of the dictionary holding the
-evidence for the implicit parameter. -}
+
+-- For details on above see note [Api annotations] in ApiAnnotation
 data IPBind id
-  = IPBind (Either HsIPName id) (LHsExpr id)
+  = IPBind (Either (Located HsIPName) id) (LHsExpr id)
   deriving (Typeable)
 deriving instance (DataId name) => Data (IPBind name)
 
@@ -558,8 +584,8 @@ instance (OutputableBndr id) => Outputable (HsIPBinds id) where
 instance (OutputableBndr id) => Outputable (IPBind id) where
   ppr (IPBind lr rhs) = name <+> equals <+> pprExpr (unLoc rhs)
     where name = case lr of
-                   Left ip  -> pprBndr LetBind ip
-                   Right id -> pprBndr LetBind id
+                   Left (L _ ip) -> pprBndr LetBind ip
+                   Right     id  -> pprBndr LetBind id
 
 {-
 ************************************************************************
@@ -592,6 +618,8 @@ data Sig name
       --
       --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon',
       --          'ApiAnnotation.AnnComma'
+
+      -- For details on above see note [Api annotations] in ApiAnnotation
     TypeSig [Located name] (LHsType name) (PostRn name [Name])
 
       -- | A pattern synonym type signature
@@ -601,6 +629,8 @@ data Sig name
       --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',
       --           'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnForall'
       --           'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow'
+
+      -- For details on above see note [Api annotations] in ApiAnnotation
   | PatSynSig (Located name)
               (HsExplicitFlag, LHsTyVarBndrs name)
               (LHsContext name) -- Provided context
@@ -613,6 +643,8 @@ data Sig name
         --
         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault',
         --           'ApiAnnotation.AnnDcolon'
+
+        -- For details on above see note [Api annotations] in ApiAnnotation
   | GenericSig [Located name] (LHsType name)
 
         -- | A type signature in generated code, notably the code
@@ -629,16 +661,21 @@ data Sig name
         --
         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnInfix',
         --           'ApiAnnotation.AnnVal'
+
+        -- For details on above see note [Api annotations] in ApiAnnotation
   | FixSig (FixitySig name)
 
         -- | An inline pragma
         --
         -- > {#- INLINE f #-}
         --
-        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+        --  - 'ApiAnnotation.AnnKeywordId' :
+        --       'ApiAnnotation.AnnOpen' @'{-\# INLINE'@ and @'['@,
         --       'ApiAnnotation.AnnClose','ApiAnnotation.AnnOpen',
         --       'ApiAnnotation.AnnVal','ApiAnnotation.AnnTilde',
         --       'ApiAnnotation.AnnClose'
+
+        -- For details on above see note [Api annotations] in ApiAnnotation
   | InlineSig   (Located name)  -- Function name
                 InlinePragma    -- Never defaultInlinePragma
 
@@ -647,9 +684,13 @@ data Sig name
         -- > {-# SPECIALISE f :: Int -> Int #-}
         --
         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
-        --      'ApiAnnotation.AnnOpen','ApiAnnotation.AnnTilde',
-        --      'ApiAnnotation.AnnVal','ApiAnnotation.AnnClose',
-        --      'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose',
+        --      'ApiAnnotation.AnnOpen' @'{-\# SPECIALISE'@ and @'['@,
+        --      'ApiAnnotation.AnnTilde',
+        --      'ApiAnnotation.AnnVal',
+        --      'ApiAnnotation.AnnClose' @']'@ and @'\#-}'@,
+        --      'ApiAnnotation.AnnDcolon'
+
+        -- For details on above see note [Api annotations] in ApiAnnotation
   | SpecSig     (Located name)  -- Specialise a function or datatype  ...
                 [LHsType name]  -- ... to these types
                 InlinePragma    -- The pragma on SPECIALISE_INLINE form.
@@ -665,7 +706,10 @@ data Sig name
         --
         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
         --      'ApiAnnotation.AnnInstance','ApiAnnotation.AnnClose'
-  | SpecInstSig (LHsType name)
+
+        -- For details on above see note [Api annotations] in ApiAnnotation
+  | SpecInstSig SourceText (LHsType name)
+                  -- Note [Pragma source text] in BasicTypes
 
         -- | A minimal complete definition pragma
         --
@@ -674,7 +718,10 @@ data Sig name
         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
         --      'ApiAnnotation.AnnVbar','ApiAnnotation.AnnComma',
         --      'ApiAnnotation.AnnClose'
-  | MinimalSig (BooleanFormula (Located name))
+
+        -- For details on above see note [Api annotations] in ApiAnnotation
+  | MinimalSig SourceText (BooleanFormula (Located name))
+               -- Note [Pragma source text] in BasicTypes
 
   deriving (Typeable)
 deriving instance (DataId name) => Data (Sig name)
@@ -781,8 +828,9 @@ ppr_sig (FixSig fix_sig)          = ppr fix_sig
 ppr_sig (SpecSig var ty inl)
   = pragBrackets (pprSpec (unLoc var) (interpp'SP ty) inl)
 ppr_sig (InlineSig var inl)       = pragBrackets (ppr inl <+> pprPrefixOcc (unLoc var))
-ppr_sig (SpecInstSig ty)          = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty)
-ppr_sig (MinimalSig bf)           = pragBrackets (pprMinimalSig bf)
+ppr_sig (SpecInstSig _ ty)
+  = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty)
+ppr_sig (MinimalSig _ bf)         = pragBrackets (pprMinimalSig bf)
 ppr_sig (PatSynSig name (flag, qtvs) (L _ prov) (L _ req) ty)
   = pprPatSynSig (unLoc name) False -- TODO: is_bindir
                  (pprHsForAll flag qtvs (noLoc []))

compiler/hsSyn/HsDecls.hs

@@ -12,7 +12,6 @@
                                       -- in module PlaceHolder
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 -- | Abstract syntax of global declarations.
 --
@@ -38,13 +37,15 @@ module HsDecls (
   TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts,
   DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour,
   TyFamEqn(..), TyFamInstEqn, LTyFamInstEqn, TyFamDefltEqn, LTyFamDefltEqn,
+  HsTyPats,
   LClsInstDecl, ClsInstDecl(..),
 
   -- ** Standalone deriving declarations
   DerivDecl(..), LDerivDecl,
   -- ** @RULE@ declarations
-  RuleDecl(..), LRuleDecl, RuleBndr(..),LRuleBndr,
+  LRuleDecls,RuleDecls(..),RuleDecl(..), LRuleDecl, RuleBndr(..),LRuleBndr,
   collectRuleBndrSigTys,
+  flattenRuleDecls,
   -- ** @VECTORISE@ declarations
   VectDecl(..), LVectDecl,
   lvectDeclName, lvectInstDecl,
@@ -64,6 +65,7 @@ module HsDecls (
   DocDecl(..), LDocDecl, docDeclDoc,
   -- ** Deprecations
   WarnDecl(..),  LWarnDecl,
+  WarnDecls(..), LWarnDecls,
   -- ** Annotations
   AnnDecl(..), LAnnDecl,
   AnnProvenance(..), annProvenanceName_maybe,
@@ -121,6 +123,8 @@ type LHsDecl id = Located (HsDecl id)
         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi'
         --
 
+-- For details on above see note [Api annotations] in ApiAnnotation
+
 -- | A Haskell Declaration
 data HsDecl id
   = TyClD       (TyClDecl id)     -- ^ A type or class declaration.
@@ -130,9 +134,9 @@ data HsDecl id
   | SigD        (Sig id)
   | DefD        (DefaultDecl id)
   | ForD        (ForeignDecl id)
-  | WarningD    (WarnDecl id)
+  | WarningD    (WarnDecls id)
   | AnnD        (AnnDecl id)
-  | RuleD       (RuleDecl id)
+  | RuleD       (RuleDecls id)
   | VectD       (VectDecl id)
   | SpliceD     (SpliceDecl id)
   | DocD        (DocDecl)
@@ -179,9 +183,9 @@ data HsGroup id
 
         hs_defds  :: [LDefaultDecl id],
         hs_fords  :: [LForeignDecl id],
-        hs_warnds :: [LWarnDecl id],
+        hs_warnds :: [LWarnDecls id],
         hs_annds  :: [LAnnDecl id],
-        hs_ruleds :: [LRuleDecl id],
+        hs_ruleds :: [LRuleDecls id],
         hs_vects  :: [LVectDecl id],
 
         hs_docs   :: [LDocDecl]
@@ -461,16 +465,20 @@ data TyClDecl name
     --
     --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
     --             'ApiAnnotation.AnnData',
-    --             'ApiAnnotation.AnnFamily','ApiAnnotation.AnnWhere',
+    --             'ApiAnnotation.AnnFamily','ApiAnnotation.AnnDcolon',
+    --             'ApiAnnotation.AnnWhere',
     --             'ApiAnnotation.AnnOpen','ApiAnnotation.AnnDcolon',
     --             'ApiAnnotation.AnnClose'
 
+    -- For details on above see note [Api annotations] in ApiAnnotation
     FamDecl { tcdFam :: FamilyDecl name }
 
   | -- | @type@ declaration
     --
     --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
     --             'ApiAnnotation.AnnEqual',
+
+    -- For details on above see note [Api annotations] in ApiAnnotation
     SynDecl { tcdLName  :: Located name            -- ^ Type constructor
             , tcdTyVars :: LHsTyVarBndrs name      -- ^ Type variables; for an associated type
                                                   --   these include outer binders
@@ -482,7 +490,10 @@ data TyClDecl name
     --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData',
     --              'ApiAnnotation.AnnFamily',
     --              'ApiAnnotation.AnnNewType',
-    --              'ApiAnnotation.AnnNewType','ApiAnnotation.AnnWhere'
+    --              'ApiAnnotation.AnnNewType','ApiAnnotation.AnnDcolon'
+    --              'ApiAnnotation.AnnWhere',
+
+    -- For details on above see note [Api annotations] in ApiAnnotation
     DataDecl { tcdLName    :: Located name        -- ^ Type constructor
              , tcdTyVars   :: LHsTyVarBndrs name  -- ^ Type variables; for an assoicated type
                                                   --   these include outer binders
@@ -497,10 +508,11 @@ data TyClDecl name
   | ClassDecl { tcdCtxt    :: LHsContext name,          -- ^ Context...
                 tcdLName   :: Located name,             -- ^ Name of the class
                 tcdTyVars  :: LHsTyVarBndrs name,       -- ^ Class type variables
-                tcdFDs     :: [Located (FunDep name)],  -- ^ Functional deps
+                tcdFDs     :: [Located (FunDep (Located name))],
+                                                        -- ^ Functional deps
                 tcdSigs    :: [LSig name],              -- ^ Methods' signatures
                 tcdMeths   :: LHsBinds name,            -- ^ Default methods
-                tcdATs     :: [LFamilyDecl name],       -- ^ Associated types; ie
+                tcdATs     :: [LFamilyDecl name],       -- ^ Associated types;
                 tcdATDefs  :: [LTyFamDefltEqn name],    -- ^ Associated type defaults
                 tcdDocs    :: [LDocDecl],               -- ^ Haddock docs
                 tcdFVs     :: PostRn name NameSet
@@ -512,6 +524,8 @@ data TyClDecl name
         --                          'ApiAnnotation.AnnComma'
         --                          'ApiAnnotation.AnnRarrow'
 
+        -- For details on above see note [Api annotations] in ApiAnnotation
+
   deriving (Typeable)
 deriving instance (DataId id) => Data (TyClDecl id)
 
@@ -816,6 +830,8 @@ data HsDataDefn name   -- The payload of a data type defn
                      --  - 'ApiAnnotation.AnnKeywordId' :
                      --       'ApiAnnotation.AnnDeriving',
                      --       'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'
+
+             -- For details on above see note [Api annotations] in ApiAnnotation
    }
     deriving( Typeable )
 deriving instance (DataId id) => Data (HsDataDefn id)
@@ -829,6 +845,8 @@ type LConDecl name = Located (ConDecl name)
       -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when
       --   in a GADT constructor list
 
+  -- For details on above see note [Api annotations] in ApiAnnotation
+
 -- |
 --
 -- @
@@ -850,6 +868,8 @@ type LConDecl name = Located (ConDecl name)
 --            'ApiAnnotation.AnnEqual','ApiAnnotation.AnnVbar',
 --            'ApiAnnotation.AnnDarrow','ApiAnnotation.AnnDarrow',
 --            'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot'
+
+-- For details on above see note [Api annotations] in ApiAnnotation
 data ConDecl name
   = ConDecl
     { con_names     :: [Located name]
@@ -891,23 +911,25 @@ data ConDecl name
     } deriving (Typeable)
 deriving instance (DataId name) => Data (ConDecl name)
 
-type HsConDeclDetails name = HsConDetails (LBangType name) [LConDeclField name]
+type HsConDeclDetails name
+   = HsConDetails (LBangType name) (Located [LConDeclField name])
 
 hsConDeclArgTys :: HsConDeclDetails name -> [LBangType name]
 hsConDeclArgTys (PrefixCon tys)    = tys
 hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]
-hsConDeclArgTys (RecCon flds)      = map (cd_fld_type . unLoc) flds
+hsConDeclArgTys (RecCon flds)      = map (cd_fld_type . unLoc) (unLoc flds)
 
 data ResType ty
-   = ResTyH98           -- Constructor was declared using Haskell 98 syntax
-   | ResTyGADT ty       -- Constructor was declared using GADT-style syntax,
-                        --      and here is its result type
+   = ResTyH98             -- Constructor was declared using Haskell 98 syntax
+   | ResTyGADT SrcSpan ty -- Constructor was declared using GADT-style syntax,
+                          --      and here is its result type, and the SrcSpan
+                          --      of the original sigtype, for API Annotations
    deriving (Data, Typeable)
 
 instance Outputable ty => Outputable (ResType ty) where
          -- Debugging only
-   ppr ResTyH98       = ptext (sLit "ResTyH98")
-   ppr (ResTyGADT ty) = ptext (sLit "ResTyGADT") <+> ppr ty
+   ppr ResTyH98         = ptext (sLit "ResTyH98")
+   ppr (ResTyGADT _ ty) = ptext (sLit "ResTyGADT") <+> ppr ty
 
 pp_data_defn :: OutputableBndr name
                   => (HsContext name -> SDoc)   -- Printing the header
@@ -939,7 +961,7 @@ instance Outputable NewOrData where
   ppr DataType = ptext (sLit "data")
 
 pp_condecls :: OutputableBndr name => [LConDecl name] -> SDoc
-pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ } : _) -- In GADT syntax
+pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ _ } : _) -- In GADT syntax
   = hang (ptext (sLit "where")) 2 (vcat (map ppr cs))
 pp_condecls cs                    -- In H98 syntax
   = equals <+> sep (punctuate (ptext (sLit " |")) (map ppr cs))
@@ -948,29 +970,31 @@ instance (OutputableBndr name) => Outputable (ConDecl name) where
     ppr = pprConDecl
 
 pprConDecl :: OutputableBndr name => ConDecl name -> SDoc
-pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs
+pprConDecl (ConDecl { con_names = [L _ con]  -- NB: non-GADT means 1 con
+                    , con_explicit = expl, con_qvars = tvs
                     , con_cxt = cxt, con_details = details
                     , con_res = ResTyH98, con_doc = doc })
   = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details details]
   where
-    ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc cons, ppr t2]
-    ppr_details (PrefixCon tys)  = hsep (pprPrefixOcc cons
+    ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc con, ppr t2]
+    ppr_details (PrefixCon tys)  = hsep (pprPrefixOcc con
                                    : map (pprParendHsType . unLoc) tys)
-    ppr_details (RecCon fields)  = ppr_con_names cons
-                                 <+> pprConDeclFields fields
+    ppr_details (RecCon fields)  = pprPrefixOcc con
+                                 <+> pprConDeclFields (unLoc fields)
 
 pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs
                     , con_cxt = cxt, con_details = PrefixCon arg_tys
-                    , con_res = ResTyGADT res_ty })
+                    , con_res = ResTyGADT _ res_ty })
   = ppr_con_names cons <+> dcolon <+>
     sep [pprHsForAll expl tvs cxt, ppr (foldr mk_fun_ty res_ty arg_tys)]
   where
     mk_fun_ty a b = noLoc (HsFunTy a b)
 
 pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs
-                    , con_cxt = cxt, con_details = RecCon fields, con_res = ResTyGADT res_ty })
+                    , con_cxt = cxt, con_details = RecCon fields
+                    , con_res = ResTyGADT _ res_ty })
   = sep [ppr_con_names cons <+> dcolon <+> pprHsForAll expl tvs cxt,
-         pprConDeclFields fields <+> arrow <+> ppr res_ty]
+         pprConDeclFields (unLoc fields) <+> arrow <+> ppr res_ty]
 
 pprConDecl decl@(ConDecl { con_details = InfixCon ty1 ty2, con_res = ResTyGADT {} })
   = pprConDecl (decl { con_details = PrefixCon [ty1,ty2] })
@@ -978,18 +1002,12 @@ pprConDecl decl@(ConDecl { con_details = InfixCon ty1 ty2, con_res = ResTyGADT {
         -- so if we ever trip over one (albeit I can't see how that
         -- can happen) print it like a prefix one
 
-ppr_con_names :: (OutputableBndr name) => [Located name] -> SDoc
-ppr_con_names [x] = ppr x
-ppr_con_names xs  = interpp'SP xs
-
-instance (Outputable name) => OutputableBndr [Located name] where
-  pprBndr _bs xs = cat $ punctuate comma (map ppr xs)
-
-  pprPrefixOcc [x] = ppr x
-  pprPrefixOcc xs  = cat $ punctuate comma (map ppr xs)
+-- this fallthrough would happen with a non-GADT-syntax ConDecl with more
+-- than one constructor, which should indeed be impossible
+pprConDecl (ConDecl { con_names = cons }) = pprPanic "pprConDecl" (ppr cons)
 
-  pprInfixOcc [x] = ppr x
-  pprInfixOcc xs  = cat $ punctuate comma (map ppr xs)
+ppr_con_names :: (OutputableBndr name) => [Located name] -> SDoc
+ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc)
 
 {-
 ************************************************************************
@@ -1020,6 +1038,9 @@ It is parameterised over its tfe_pats field:
 type LTyFamInstEqn  name = Located (TyFamInstEqn  name)
   -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi'
   --   when in a list
+
+-- For details on above see note [Api annotations] in ApiAnnotation
+
 type LTyFamDefltEqn name = Located (TyFamDefltEqn name)
 
 type HsTyPats name = HsWithBndrs name [LHsType name]
@@ -1039,6 +1060,8 @@ data TyFamEqn name pats
        , tfe_rhs   :: LHsType name }
     -- ^
     --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual'
+
+    -- For details on above see note [Api annotations] in ApiAnnotation
   deriving( Typeable )
 deriving instance (DataId name, Data pats) => Data (TyFamEqn name pats)
 
@@ -1050,6 +1073,8 @@ data TyFamInstDecl name
     -- ^
     --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
     --           'ApiAnnotation.AnnInstance',
+
+    -- For details on above see note [Api annotations] in ApiAnnotation
   deriving( Typeable )
 deriving instance (DataId name) => Data (TyFamInstDecl name)
 
@@ -1066,8 +1091,11 @@ data DataFamInstDecl name
     -- ^
     --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData',
     --           'ApiAnnotation.AnnNewType','ApiAnnotation.AnnInstance',
+    --           'ApiAnnotation.AnnDcolon'
     --           'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen',
     --           'ApiAnnotation.AnnClose'
+
+    -- For details on above see note [Api annotations] in ApiAnnotation
   deriving( Typeable )
 deriving instance (DataId name) => Data (DataFamInstDecl name)
 
@@ -1088,12 +1116,14 @@ data ClsInstDecl name
          -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
          --                                    'ApiAnnotation.AnnClose',
 
+        -- For details on above see note [Api annotations] in ApiAnnotation
       }
     -- ^
     --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnInstance',
     --           'ApiAnnotation.AnnWhere',
     --           'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
-    --
+
+    -- For details on above see note [Api annotations] in ApiAnnotation
   deriving (Typeable)
 deriving instance (DataId id) => Data (ClsInstDecl id)
 
@@ -1192,11 +1222,11 @@ ppOverlapPragma :: Maybe (Located OverlapMode) -> SDoc
 ppOverlapPragma mb =
   case mb of
     Nothing           -> empty
-    Just (L _ NoOverlap)    -> ptext (sLit "{-# NO_OVERLAP #-}")
-    Just (L _ Overlappable) -> ptext (sLit "{-# OVERLAPPABLE #-}")
-    Just (L _ Overlapping)  -> ptext (sLit "{-# OVERLAPPING #-}")
-    Just (L _ Overlaps)     -> ptext (sLit "{-# OVERLAPS #-}")
-    Just (L _ Incoherent)   -> ptext (sLit "{-# INCOHERENT #-}")
+    Just (L _ (NoOverlap _))    -> ptext (sLit "{-# NO_OVERLAP #-}")
+    Just (L _ (Overlappable _)) -> ptext (sLit "{-# OVERLAPPABLE #-}")
+    Just (L _ (Overlapping _))  -> ptext (sLit "{-# OVERLAPPING #-}")
+    Just (L _ (Overlaps _))     -> ptext (sLit "{-# OVERLAPS #-}")
+    Just (L _ (Incoherent _))   -> ptext (sLit "{-# INCOHERENT #-}")
 
 
 
@@ -1233,7 +1263,9 @@ data DerivDecl name = DerivDecl
          -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
          --                                    'ApiAnnotation.AnnClose',
          --                                    'ApiAnnotation.AnnDeriving',
-         --                                    'ApiAnnotation.AnnInstance',
+         --                                    'ApiAnnotation.AnnInstance'
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
         }
   deriving (Typeable)
 deriving instance (DataId name) => Data (DerivDecl name)
@@ -1261,6 +1293,7 @@ data DefaultDecl name
         -- ^ - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnDefault',
         --          'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'
 
+        -- For details on above see note [Api annotations] in ApiAnnotation
   deriving (Typeable)
 deriving instance (DataId name) => Data (DefaultDecl name)
 
@@ -1299,6 +1332,8 @@ data ForeignDecl name
         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForeign',
         --           'ApiAnnotation.AnnImport','ApiAnnotation.AnnExport',
         --           'ApiAnnotation.AnnDcolon'
+
+        -- For details on above see note [Api annotations] in ApiAnnotation
   deriving (Typeable)
 deriving instance (DataId name) => Data (ForeignDecl name)
 {-
@@ -1335,9 +1370,9 @@ data ForeignImport = -- import of a C entity
                      --
                      CImport  (Located CCallConv) -- ccall or stdcall
                               (Located Safety)  -- interruptible, safe or unsafe
-                              (Maybe Header)  -- name of C header
-                              CImportSpec     -- details of the C entity
-                              (Located FastString) -- original source text for
+                              (Maybe Header)       -- name of C header
+                              CImportSpec          -- details of the C entity
+                              (Located SourceText) -- original source text for
                                                    -- the C entity
   deriving (Data, Typeable)
 
@@ -1354,7 +1389,7 @@ data CImportSpec = CLabel    CLabelString     -- import address of a C label
 --
 data ForeignExport = CExport  (Located CExportSpec) -- contains the calling
                                                     -- convention
-                              (Located FastString)  -- original source text for
+                              (Located SourceText)  -- original source text for
                                                     -- the C entity
   deriving (Data, Typeable)
 
@@ -1401,6 +1436,14 @@ instance Outputable ForeignExport where
 ************************************************************************
 -}
 
+type LRuleDecls name = Located (RuleDecls name)
+
+  -- Note [Pragma source text] in BasicTypes
+data RuleDecls name = HsRules { rds_src   :: SourceText
+                              , rds_rules :: [LRuleDecl name] }
+  deriving (Typeable)
+deriving instance (DataId name) => Data (RuleDecls name)
+
 type LRuleDecl name = Located (RuleDecl name)
 
 data RuleDecl name
@@ -1414,13 +1457,20 @@ data RuleDecl name
         (Located (HsExpr name)) -- RHS
         (PostRn name NameSet)   -- Free-vars from the RHS
         -- ^
-        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual',
-        --           'ApiAnnotation.AnnOpen','ApiAnnotation.AnnVal',
-        --           'ApiAnnotation.AnnClose','ApiAnnotation.AnnTilde',
+        --  - 'ApiAnnotation.AnnKeywordId' :
+        --           'ApiAnnotation.AnnOpen','ApiAnnotation.AnnTilde',
+        --           'ApiAnnotation.AnnVal',
+        --           'ApiAnnotation.AnnClose',
         --           'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot',
+        --           'ApiAnnotation.AnnEqual',
+
+        -- For details on above see note [Api annotations] in ApiAnnotation
   deriving (Typeable)
 deriving instance (DataId name) => Data (RuleDecl name)
 
+flattenRuleDecls :: [LRuleDecls name] -> [LRuleDecl name]
+flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls
+
 type LRuleBndr name = Located (RuleBndr name)
 data RuleBndr name
   = RuleBndr (Located name)
@@ -1428,12 +1478,17 @@ data RuleBndr name
         -- ^
         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
         --     'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose'
+
+        -- For details on above see note [Api annotations] in ApiAnnotation
   deriving (Typeable)
 deriving instance (DataId name) => Data (RuleBndr name)
 
 collectRuleBndrSigTys :: [RuleBndr name] -> [HsWithBndrs name (LHsType name)]
 collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]
 
+instance OutputableBndr name => Outputable (RuleDecls name) where
+  ppr (HsRules _ rules) = ppr rules
+
 instance OutputableBndr name => Outputable (RuleDecl name) where
   ppr (HsRule name act ns lhs _fv_lhs rhs _fv_rhs)
         = sep [text "{-# RULES" <+> doubleQuotes (ftext $ unLoc name)
@@ -1469,29 +1524,41 @@ type LVectDecl name = Located (VectDecl name)
 
 data VectDecl name
   = HsVect
+      SourceText   -- Note [Pragma source text] in BasicTypes
       (Located name)
       (LHsExpr name)
         -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
         --           'ApiAnnotation.AnnEqual','ApiAnnotation.AnnClose'
+
+        -- For details on above see note [Api annotations] in ApiAnnotation
   | HsNoVect
+      SourceText   -- Note [Pragma source text] in BasicTypes
       (Located name)
         -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
         --                                    'ApiAnnotation.AnnClose'
+
+        -- For details on above see note [Api annotations] in ApiAnnotation
   | HsVectTypeIn                -- pre type-checking
+      SourceText                -- Note [Pragma source text] in BasicTypes
       Bool                      -- 'TRUE' => SCALAR declaration
       (Located name)
       (Maybe (Located name))    -- 'Nothing' => no right-hand side
         -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
         --           'ApiAnnotation.AnnType','ApiAnnotation.AnnClose',
         --           'ApiAnnotation.AnnEqual'
+
+        -- For details on above see note [Api annotations] in ApiAnnotation
   | HsVectTypeOut               -- post type-checking
       Bool                      -- 'TRUE' => SCALAR declaration
       TyCon
       (Maybe TyCon)             -- 'Nothing' => no right-hand side
   | HsVectClassIn               -- pre type-checking
+      SourceText                -- Note [Pragma source text] in BasicTypes
       (Located name)
         -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
         --           'ApiAnnotation.AnnClass','ApiAnnotation.AnnClose',
+
+       -- For details on above see note [Api annotations] in ApiAnnotation
   | HsVectClassOut              -- post type-checking
       Class
   | HsVectInstIn                -- pre type-checking (always SCALAR)  !!!FIXME: should be superfluous now
@@ -1502,14 +1569,16 @@ data VectDecl name
 deriving instance (DataId name) => Data (VectDecl name)
 
 lvectDeclName :: NamedThing name => LVectDecl name -> Name
-lvectDeclName (L _ (HsVect         (L _ name) _))   = getName name
-lvectDeclName (L _ (HsNoVect       (L _ name)))     = getName name
-lvectDeclName (L _ (HsVectTypeIn   _ (L _ name) _)) = getName name
-lvectDeclName (L _ (HsVectTypeOut  _ tycon _))      = getName tycon
-lvectDeclName (L _ (HsVectClassIn  (L _ name)))     = getName name
-lvectDeclName (L _ (HsVectClassOut cls))            = getName cls
-lvectDeclName (L _ (HsVectInstIn   _))              = panic "HsDecls.lvectDeclName: HsVectInstIn"
-lvectDeclName (L _ (HsVectInstOut  _))              = panic "HsDecls.lvectDeclName: HsVectInstOut"
+lvectDeclName (L _ (HsVect _       (L _ name) _))    = getName name
+lvectDeclName (L _ (HsNoVect _     (L _ name)))      = getName name
+lvectDeclName (L _ (HsVectTypeIn _  _ (L _ name) _)) = getName name
+lvectDeclName (L _ (HsVectTypeOut  _ tycon _))       = getName tycon
+lvectDeclName (L _ (HsVectClassIn _ (L _ name)))     = getName name
+lvectDeclName (L _ (HsVectClassOut cls))             = getName cls
+lvectDeclName (L _ (HsVectInstIn _))
+  = panic "HsDecls.lvectDeclName: HsVectInstIn"
+lvectDeclName (L _ (HsVectInstOut  _))
+  = panic "HsDecls.lvectDeclName: HsVectInstOut"
 
 lvectInstDecl :: LVectDecl name -> Bool
 lvectInstDecl (L _ (HsVectInstIn _))  = True
@@ -1517,19 +1586,19 @@ lvectInstDecl (L _ (HsVectInstOut _)) = True
 lvectInstDecl _                       = False
 
 instance OutputableBndr name => Outputable (VectDecl name) where
-  ppr (HsVect v rhs)
+  ppr (HsVect _ v rhs)
     = sep [text "{-# VECTORISE" <+> ppr v,
            nest 4 $
              pprExpr (unLoc rhs) <+> text "#-}" ]
-  ppr (HsNoVect v)
+  ppr (HsNoVect _ v)
     = sep [text "{-# NOVECTORISE" <+> ppr v <+> text "#-}" ]
-  ppr (HsVectTypeIn False t Nothing)
+  ppr (HsVectTypeIn _ False t Nothing)
     = sep [text "{-# VECTORISE type" <+> ppr t <+> text "#-}" ]
-  ppr (HsVectTypeIn False t (Just t'))
+  ppr (HsVectTypeIn _ False t (Just t'))
     = sep [text "{-# VECTORISE type" <+> ppr t, text "=", ppr t', text "#-}" ]
-  ppr (HsVectTypeIn True t Nothing)
+  ppr (HsVectTypeIn _ True t Nothing)
     = sep [text "{-# VECTORISE SCALAR type" <+> ppr t <+> text "#-}" ]
-  ppr (HsVectTypeIn True t (Just t'))
+  ppr (HsVectTypeIn _ True t (Just t'))
     = sep [text "{-# VECTORISE SCALAR type" <+> ppr t, text "=", ppr t', text "#-}" ]
   ppr (HsVectTypeOut False t Nothing)
     = sep [text "{-# VECTORISE type" <+> ppr t <+> text "#-}" ]
@@ -1539,7 +1608,7 @@ instance OutputableBndr name => Outputable (VectDecl name) where
     = sep [text "{-# VECTORISE SCALAR type" <+> ppr t <+> text "#-}" ]
   ppr (HsVectTypeOut True t (Just t'))
     = sep [text "{-# VECTORISE SCALAR type" <+> ppr t, text "=", ppr t', text "#-}" ]
-  ppr (HsVectClassIn c)
+  ppr (HsVectClassIn _ c)
     = sep [text "{-# VECTORISE class" <+> ppr c <+> text "#-}" ]
   ppr (HsVectClassOut c)
     = sep [text "{-# VECTORISE class" <+> ppr c <+> text "#-}" ]
@@ -1585,11 +1654,24 @@ docDeclDoc (DocGroup _ d) = d
 We use exported entities for things to deprecate.
 -}
 
+
+type LWarnDecls name = Located (WarnDecls name)
+
+ -- Note [Pragma source text] in BasicTypes
+data WarnDecls name = Warnings { wd_src :: SourceText
+                               , wd_warnings :: [LWarnDecl name]
+                               }
+  deriving (Data, Typeable)
+
+
 type LWarnDecl name = Located (WarnDecl name)
 
-data WarnDecl name = Warning name WarningTxt
+data WarnDecl name = Warning [Located name] WarningTxt
   deriving (Data, Typeable)
 
+instance OutputableBndr name => Outputable (WarnDecls name) where
+    ppr (Warnings _ decls) = ppr decls
+
 instance OutputableBndr name => Outputable (WarnDecl name) where
     ppr (Warning thing txt)
       = hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"]
@@ -1604,33 +1686,40 @@ instance OutputableBndr name => Outputable (WarnDecl name) where
 
 type LAnnDecl name = Located (AnnDecl name)
 
-data AnnDecl name = HsAnnotation (AnnProvenance name) (Located (HsExpr name))
+data AnnDecl name = HsAnnotation
+                      SourceText -- Note [Pragma source text] in BasicTypes
+                      (AnnProvenance name) (Located (HsExpr name))
       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
       --           'ApiAnnotation.AnnType'
       --           'ApiAnnotation.AnnModule'
       --           'ApiAnnotation.AnnClose'
+
+      -- For details on above see note [Api annotations] in ApiAnnotation
   deriving (Typeable)
 deriving instance (DataId name) => Data (AnnDecl name)
 
 instance (OutputableBndr name) => Outputable (AnnDecl name) where
-    ppr (HsAnnotation provenance expr)
+    ppr (HsAnnotation _ provenance expr)
       = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"]
 
-
-data AnnProvenance name = ValueAnnProvenance name
-                        | TypeAnnProvenance name
+data AnnProvenance name = ValueAnnProvenance (Located name)
+                        | TypeAnnProvenance (Located name)
                         | ModuleAnnProvenance
-  deriving (Data, Typeable, Functor, Foldable, Traversable)
+  deriving (Data, Typeable, Functor)
+deriving instance Foldable    AnnProvenance
+deriving instance Traversable AnnProvenance
 
 annProvenanceName_maybe :: AnnProvenance name -> Maybe name
-annProvenanceName_maybe (ValueAnnProvenance name) = Just name
-annProvenanceName_maybe (TypeAnnProvenance name)  = Just name
+annProvenanceName_maybe (ValueAnnProvenance (L _ name)) = Just name
+annProvenanceName_maybe (TypeAnnProvenance (L _ name))  = Just name
 annProvenanceName_maybe ModuleAnnProvenance       = Nothing
 
 pprAnnProvenance :: OutputableBndr name => AnnProvenance name -> SDoc
 pprAnnProvenance ModuleAnnProvenance       = ptext (sLit "ANN module")
-pprAnnProvenance (ValueAnnProvenance name) = ptext (sLit "ANN") <+> ppr name
-pprAnnProvenance (TypeAnnProvenance name)  = ptext (sLit "ANN type") <+> ppr name
+pprAnnProvenance (ValueAnnProvenance (L _ name))
+  = ptext (sLit "ANN") <+> ppr name
+pprAnnProvenance (TypeAnnProvenance (L _ name))
+  = ptext (sLit "ANN type") <+> ppr name
 
 {-
 ************************************************************************
@@ -1649,6 +1738,8 @@ data RoleAnnotDecl name
                   [Located (Maybe Role)] -- optional annotations
       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
       --           'ApiAnnotation.AnnRole'
+
+      -- For details on above see note [Api annotations] in ApiAnnotation
   deriving (Data, Typeable)
 
 instance OutputableBndr name => Outputable (RoleAnnotDecl name) where

compiler/hsSyn/HsExpr.hs

@@ -55,6 +55,8 @@ type LHsExpr id = Located (HsExpr id)
   -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when
   --   in a list
 
+  -- For details on above see note [Api annotations] in ApiAnnotation
+
 -------------------------
 -- | PostTcExpr is an evidence expression attached to the syntax tree by the
 -- type checker (c.f. postTcType).
@@ -136,11 +138,16 @@ data HsExpr id
        -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam',
        --       'ApiAnnotation.AnnRarrow',
 
+       -- For details on above see note [Api annotations] in ApiAnnotation
+
   | HsLamCase (PostTc id Type) (MatchGroup id (LHsExpr id)) -- ^ Lambda-case
        --
        -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam',
        --           'ApiAnnotation.AnnCase','ApiAnnotation.AnnOpen',
        --           'ApiAnnotation.AnnClose'
+
+       -- For details on above see note [Api annotations] in ApiAnnotation
+
   | HsApp     (LHsExpr id) (LHsExpr id) -- ^ Application
 
   -- | Operator applications:
@@ -158,15 +165,15 @@ data HsExpr id
   -- of 'negate'
   --
   --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnMinus'
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
   | NegApp      (LHsExpr id)
                 (SyntaxExpr id)
 
-  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
-  --             'ApiAnnotation.AnnClose'
-  --   - Note: if 'ApiAnnotation.AnnVal' is present this is actually an
-  --           inactive 'HsSCC'
-  --   - Note: if multiple 'ApiAnnotation.AnnVal' are
-  --            present this is actually an inactive 'HsTickPragma'
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
+  --             'ApiAnnotation.AnnClose' @')'@
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
   | HsPar       (LHsExpr id)    -- ^ Parenthesised expr; see Note [Parens in HsSyn]
 
   | SectionL    (LHsExpr id)    -- operand; see Note [Sections in HsSyn]
@@ -178,20 +185,26 @@ data HsExpr id
   --
   --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
   --         'ApiAnnotation.AnnClose'
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
   | ExplicitTuple
         [LHsTupArg id]
         Boxity
 
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase',
-  --       'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen',
-  --       'ApiAnnotation.AnnClose'
+  --       'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@,
+  --       'ApiAnnotation.AnnClose' @'}'@
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
   | HsCase      (LHsExpr id)
                 (MatchGroup id (LHsExpr id))
 
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf',
   --       'ApiAnnotation.AnnSemi',
-  --       'ApiAnnotation.AnnThen','ApiAnnotation.AnnSemi2',
+  --       'ApiAnnotation.AnnThen','ApiAnnotation.AnnSemi',
   --       'ApiAnnotation.AnnElse',
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
   | HsIf        (Maybe (SyntaxExpr id)) -- cond function
                                         -- Nothing => use the built-in 'if'
                                         -- See Note [Rebindable if]
@@ -203,13 +216,17 @@ data HsExpr id
   --
   -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf'
   --       'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
   | HsMultiIf   (PostTc id Type) [LGRHS id (LHsExpr id)]
 
   -- | let(rec)
   --
   -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet',
-  --       'ApiAnnotation.AnnIn','ApiAnnotation.AnnOpen',
-  --       'ApiAnnotation.AnnClose'
+  --       'ApiAnnotation.AnnOpen' @'{'@,
+  --       'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn'
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
   | HsLet       (HsLocalBinds id)
                 (LHsExpr  id)
 
@@ -217,6 +234,8 @@ data HsExpr id
   --             'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnSemi',
   --             'ApiAnnotation.AnnVbar',
   --             'ApiAnnotation.AnnClose'
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
   | HsDo        (HsStmtContext Name) -- The parameterisation is unimportant
                                      -- because in this context we never use
                                      -- the PatGuard or ParStmt variant
@@ -225,8 +244,10 @@ data HsExpr id
 
   -- | Syntactic list: [a,b,c,...]
   --
-  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
-  --              'ApiAnnotation.AnnClose'
+  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@,
+  --              'ApiAnnotation.AnnClose' @']'@
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
   | ExplicitList
                 (PostTc id Type)        -- Gives type of components of list
                 (Maybe (SyntaxExpr id)) -- For OverloadedLists, the fromListN witness
@@ -234,18 +255,22 @@ data HsExpr id
 
   -- | Syntactic parallel array: [:e1, ..., en:]
   --
-  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@,
   --              'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnComma',
   --              'ApiAnnotation.AnnVbar'
-  --              'ApiAnnotation.AnnClose'
+  --              'ApiAnnotation.AnnClose' @':]'@
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
   | ExplicitPArr
                 (PostTc id Type)   -- type of elements of the parallel array
                 [LHsExpr id]
 
   -- | Record construction
   --
-  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
-  --         'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose'
+  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@,
+  --         'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose' @'}'@
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
   | RecordCon   (Located id)       -- The constructor.  After type checking
                                    -- it's the dataConWrapId of the constructor
                 PostTcExpr         -- Data con Id applied to type args
@@ -253,8 +278,10 @@ data HsExpr id
 
   -- | Record update
   --
-  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
-  --         'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose'
+  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@,
+  --         'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose' @'}'@
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
   | RecordUpd   (LHsExpr id)
                 (HsRecordBinds id)
 --              (HsMatchGroup Id)  -- Filled in by the type checker to be
@@ -270,6 +297,8 @@ data HsExpr id
   -- | Expression with an explicit type signature. @e :: type@
   --
   --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
   | ExprWithTySig
                 (LHsExpr id)
                 (LHsType id)
@@ -285,27 +314,45 @@ data HsExpr id
 
   -- | Arithmetic sequence
   --
-  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
-  --              'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnComma',
-  --              'ApiAnnotation.AnnClose'
+  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@,
+  --              'ApiAnnotation.AnnComma','ApiAnnotation.AnnDotdot',
+  --              'ApiAnnotation.AnnClose' @']'@
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
   | ArithSeq
                 PostTcExpr
                 (Maybe (SyntaxExpr id))   -- For OverloadedLists, the fromList witness
                 (ArithSeqInfo id)
 
   -- | Arithmetic sequence for parallel array
+  --
+  -- > [:e1..e2:] or [:e1, e2..e3:]
+  --
+  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@,
+  --              'ApiAnnotation.AnnComma','ApiAnnotation.AnnDotdot',
+  --              'ApiAnnotation.AnnVbar',
+  --              'ApiAnnotation.AnnClose' @':]'@
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
   | PArrSeq
-                PostTcExpr              -- [:e1..e2:] or [:e1, e2..e3:]
+                PostTcExpr
                 (ArithSeqInfo id)
 
-  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
-  --             'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose'
-  | HsSCC       FastString              -- "set cost centre" SCC pragma
-                (LHsExpr id)            -- expr whose cost is to be measured
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# SCC'@,
+  --             'ApiAnnotation.AnnVal' or 'ApiAnnotation.AnnValStr',
+  --              'ApiAnnotation.AnnClose' @'\#-}'@
 
-  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
-  --             'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose'
-  | HsCoreAnn   FastString              -- hdaume: core annotation
+  -- For details on above see note [Api annotations] in ApiAnnotation
+  | HsSCC       SourceText            -- Note [Pragma source text] in BasicTypes
+                FastString            -- "set cost centre" SCC pragma
+                (LHsExpr id)          -- expr whose cost is to be measured
+
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CORE'@,
+  --             'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose' @'\#-}'@
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
+  | HsCoreAnn   SourceText            -- Note [Pragma source text] in BasicTypes
+                FastString            -- hdaume: core annotation
                 (LHsExpr id)
 
   -----------------------------------------------------------
@@ -314,6 +361,8 @@ data HsExpr id
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
   --         'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
   --         'ApiAnnotation.AnnClose'
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
   | HsBracket    (HsBracket id)
 
     -- See Note [Pending Splices]
@@ -330,6 +379,8 @@ data HsExpr id
 
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
   --         'ApiAnnotation.AnnClose'
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
   | HsSpliceE    Bool                   -- True <=> typed splice
                  (HsSplice id)          -- False <=> untyped
 
@@ -343,12 +394,17 @@ data HsExpr id
   --
   --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnProc',
   --          'ApiAnnotation.AnnRarrow'
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
   | HsProc      (LPat id)               -- arrow abstraction, proc
                 (LHsCmdTop id)          -- body of the abstraction
                                         -- always has an empty stack
 
   ---------------------------------------
   -- static pointers extension
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnStatic',
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
   | HsStatic    (LHsExpr id)
 
   ---------------------------------------
@@ -359,6 +415,8 @@ data HsExpr id
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.Annlarrowtail',
   --          'ApiAnnotation.Annrarrowtail','ApiAnnotation.AnnLarrowtail',
   --          'ApiAnnotation.AnnRarrowtail'
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
   | HsArrApp             -- Arrow tail, or arrow application (f -< arg)
         (LHsExpr id)     -- arrow expression, f
         (LHsExpr id)     -- input expression, arg
@@ -368,8 +426,10 @@ data HsExpr id
         Bool             -- True => right-to-left (f -< arg)
                          -- False => left-to-right (arg >- f)
 
-  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
-  --         'ApiAnnotation.AnnClose'
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(|'@,
+  --         'ApiAnnotation.AnnClose' @'|)'@
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
   | HsArrForm            -- Command formation,  (| e cmd1 .. cmdn |)
         (LHsExpr id)     -- the operator
                          -- after type-checking, a type abstraction to be
@@ -391,15 +451,18 @@ data HsExpr id
      (LHsExpr id)                       -- sub-expression
 
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
-  --       'ApiAnnotation.AnnOpen',
-  --       'ApiAnnotation.AnnVal','ApiAnnotation.AnnVal2',
-  --       'ApiAnnotation.AnnColon','ApiAnnotation.AnnVal3',
+  --       'ApiAnnotation.AnnOpen' @'{-\# GENERATED'@,
+  --       'ApiAnnotation.AnnVal','ApiAnnotation.AnnVal',
+  --       'ApiAnnotation.AnnColon','ApiAnnotation.AnnVal',
   --       'ApiAnnotation.AnnMinus',
-  --       'ApiAnnotation.AnnVal4','ApiAnnotation.AnnColon2',
-  --       'ApiAnnotation.AnnVal5',
-  --       'ApiAnnotation.AnnClose'
-  | HsTickPragma                        -- A pragma introduced tick
-     (FastString,(Int,Int),(Int,Int))   -- external span for this tick
+  --       'ApiAnnotation.AnnVal','ApiAnnotation.AnnColon',
+  --       'ApiAnnotation.AnnVal',
+  --       'ApiAnnotation.AnnClose' @'\#-}'@
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
+  | HsTickPragma                      -- A pragma introduced tick
+     SourceText                       -- Note [Pragma source text] in BasicTypes
+     (FastString,(Int,Int),(Int,Int)) -- external span for this tick
      (LHsExpr id)
 
   ---------------------------------------
@@ -409,14 +472,20 @@ data HsExpr id
   | EWildPat                 -- wildcard
 
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt'
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
   | EAsPat      (Located id) -- as pattern
                 (LHsExpr id)
 
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
   | EViewPat    (LHsExpr id) -- view pattern
                 (LHsExpr id)
 
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde'
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
   | ELazyPat    (LHsExpr id) -- ~ pattern
 
   | HsType      (LHsType id) -- Explicit type argument; e.g  f {| Int |} x y
@@ -435,6 +504,8 @@ deriving instance (DataId id) => Data (HsExpr id)
 --  Which in turn stands for (\x:ty1 \y:ty2. (x,a,y))
 type LHsTupArg id = Located (HsTupArg id)
 -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma'
+
+-- For details on above see note [Api annotations] in ApiAnnotation
 data HsTupArg id
   = Present (LHsExpr id)     -- ^ The argument
   | Missing (PostTc id Type) -- ^ The argument is missing, but this is its type
@@ -520,7 +591,7 @@ ppr_expr (HsLit lit)     = ppr lit
 ppr_expr (HsOverLit lit) = ppr lit
 ppr_expr (HsPar e)       = parens (ppr_lexpr e)
 
-ppr_expr (HsCoreAnn s e)
+ppr_expr (HsCoreAnn _ s e)
   = vcat [ptext (sLit "HsCoreAnn") <+> ftext s, ppr_lexpr e]
 
 ppr_expr (HsApp e1 e2)
@@ -642,7 +713,7 @@ ppr_expr (ELazyPat e)   = char '~' <> pprParendExpr e
 ppr_expr (EAsPat v e)   = ppr v <> char '@' <> pprParendExpr e
 ppr_expr (EViewPat p e) = ppr p <+> ptext (sLit "->") <+> ppr e
 
-ppr_expr (HsSCC lbl expr)
+ppr_expr (HsSCC _ lbl expr)
   = sep [ ptext (sLit "{-# SCC") <+> doubleQuotes (ftext lbl) <+> ptext (sLit "#-}"),
           pprParendExpr expr ]
 
@@ -665,7 +736,7 @@ ppr_expr (HsStatic e)
 
 ppr_expr (HsTick tickish exp)
   = pprTicks (ppr exp) $
-    ppr tickish <+> ppr exp
+    ppr tickish <+> ppr_lexpr exp
 ppr_expr (HsBinTick tickIdTrue tickIdFalse exp)
   = pprTicks (ppr exp) $
     hcat [ptext (sLit "bintick<"),
@@ -674,7 +745,7 @@ ppr_expr (HsBinTick tickIdTrue tickIdFalse exp)
           ppr tickIdFalse,
           ptext (sLit ">("),
           ppr exp,ptext (sLit ")")]
-ppr_expr (HsTickPragma externalSrcLoc exp)
+ppr_expr (HsTickPragma _ externalSrcLoc exp)
   = pprTicks (ppr exp) $
     hcat [ptext (sLit "tickpragma<"),
           ppr externalSrcLoc,
@@ -770,6 +841,11 @@ We re-use HsExpr to represent these.
 type LHsCmd id = Located (HsCmd id)
 
 data HsCmd id
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.Annlarrowtail',
+  --          'ApiAnnotation.Annrarrowtail','ApiAnnotation.AnnLarrowtail',
+  --          'ApiAnnotation.AnnRarrowtail'
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
   = HsCmdArrApp          -- Arrow tail, or arrow application (f -< arg)
         (LHsExpr id)     -- arrow expression, f
         (LHsExpr id)     -- input expression, arg
@@ -779,6 +855,10 @@ data HsCmd id
         Bool             -- True => right-to-left (f -< arg)
                          -- False => left-to-right (arg >- f)
 
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(|'@,
+  --         'ApiAnnotation.AnnClose' @'|)'@
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
   | HsCmdArrForm         -- Command formation,  (| e cmd1 .. cmdn |)
         (LHsExpr id)     -- the operator
                          -- after type-checking, a type abstraction to be
@@ -791,22 +871,52 @@ data HsCmd id
                 (LHsExpr id)
 
   | HsCmdLam    (MatchGroup id (LHsCmd id))     -- kappa
+       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam',
+       --       'ApiAnnotation.AnnRarrow',
+
+       -- For details on above see note [Api annotations] in ApiAnnotation
 
   | HsCmdPar    (LHsCmd id)                     -- parenthesised command
+    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
+    --             'ApiAnnotation.AnnClose' @')'@
+
+    -- For details on above see note [Api annotations] in ApiAnnotation
 
   | HsCmdCase   (LHsExpr id)
                 (MatchGroup id (LHsCmd id))     -- bodies are HsCmd's
+    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase',
+    --       'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@,
+    --       'ApiAnnotation.AnnClose' @'}'@
+
+    -- For details on above see note [Api annotations] in ApiAnnotation
 
   | HsCmdIf     (Maybe (SyntaxExpr id))         -- cond function
                 (LHsExpr id)                    -- predicate
                 (LHsCmd id)                     -- then part
                 (LHsCmd id)                     -- else part
+    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf',
+    --       'ApiAnnotation.AnnSemi',
+    --       'ApiAnnotation.AnnThen','ApiAnnotation.AnnSemi',
+    --       'ApiAnnotation.AnnElse',
+
+    -- For details on above see note [Api annotations] in ApiAnnotation
 
   | HsCmdLet    (HsLocalBinds id)               -- let(rec)
                 (LHsCmd  id)
+    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet',
+    --       'ApiAnnotation.AnnOpen' @'{'@,
+    --       'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn'
+
+    -- For details on above see note [Api annotations] in ApiAnnotation
 
   | HsCmdDo     [CmdLStmt id]
                 (PostTc id Type)                -- Type of the whole expression
+    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo',
+    --             'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnSemi',
+    --             'ApiAnnotation.AnnVbar',
+    --             'ApiAnnotation.AnnClose'
+
+    -- For details on above see note [Api annotations] in ApiAnnotation
 
   | HsCmdCast   TcCoercion     -- A simpler version of HsWrap in HsExpr
                 (HsCmd id)     -- If   cmd :: arg1 --> res
@@ -818,8 +928,8 @@ deriving instance (DataId id) => Data (HsCmd id)
 data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp
   deriving (Data, Typeable)
 
-{-
-Top-level command, introducing a new arrow.
+
+{- | Top-level command, introducing a new arrow.
 This may occur inside a proc (where the stack is empty) or as an
 argument of a command-forming operator.
 -}
@@ -967,15 +1077,47 @@ deriving instance (Data body,DataId id) => Data (MatchGroup id body)
 type LMatch id body = Located (Match id body)
 -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a
 --   list
+
+-- For details on above see note [Api annotations] in ApiAnnotation
 data Match id body
-  = Match
-        [LPat id]               -- The patterns
-        (Maybe (LHsType id))    -- A type signature for the result of the match
-                                -- Nothing after typechecking
-        (GRHSs id body)
-  deriving (Typeable)
+  = Match {
+        m_fun_id_infix :: (Maybe (Located id,Bool)),
+          -- fun_id and fun_infix for functions with multiple equations
+          -- only present for a RdrName. See note [fun_id in Match]
+        m_pats :: [LPat id], -- The patterns
+        m_type :: (Maybe (LHsType id)),
+                                 -- A type signature for the result of the match
+                                 -- Nothing after typechecking
+        m_grhss :: (GRHSs id body)
+  } deriving (Typeable)
 deriving instance (Data body,DataId id) => Data (Match id body)
 
+{-
+Note [fun_id in Match]
+~~~~~~~~~~~~~~~~~~~~~~
+
+The parser initially creates a FunBind with a single Match in it for
+every function definition it sees.
+
+These are then grouped together by getMonoBind into a single FunBind,
+where all the Matches are combined.
+
+In the process, all the original FunBind fun_id's bar one are
+discarded, including the locations.
+
+This causes a problem for source to source conversions via API
+Annotations, so the original fun_ids and infix flags are preserved in
+the Match, when it originates from a FunBind.
+
+Example infix function definition requiring individual API Annotations
+
+    (&&&  ) [] [] =  []
+    xs    &&&   [] =  xs
+    (  &&&  ) [] ys =  ys
+
+
+-}
+
 isEmptyMatchGroup :: MatchGroup id body -> Bool
 isEmptyMatchGroup (MG { mg_alts = ms }) = null ms
 
@@ -987,7 +1129,7 @@ matchGroupArity (MG { mg_alts = alts })
   | otherwise        = panic "matchGroupArity"
 
 hsLMatchPats :: LMatch id body -> [LPat id]
-hsLMatchPats (L _ (Match pats _ _)) = pats
+hsLMatchPats (L _ (Match _ pats _ _)) = pats
 
 -- | GRHSs are used both for pattern bindings and for Matches
 --
@@ -995,6 +1137,8 @@ hsLMatchPats (L _ (Match pats _ _)) = pats
 --        'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere',
 --        'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'
 --        'ApiAnnotation.AnnRarrow','ApiAnnotation.AnnSemi'
+
+-- For details on above see note [Api annotations] in ApiAnnotation
 data GRHSs id body
   = GRHSs {
       grhssGRHSs :: [LGRHS id body],       -- ^ Guarded RHSs
@@ -1031,7 +1175,7 @@ pprPatBind pat (grhss)
 
 pprMatch :: (OutputableBndr idL, OutputableBndr idR, Outputable body)
          => HsMatchContext idL -> Match idR body -> SDoc
-pprMatch ctxt (Match pats maybe_ty grhss)
+pprMatch ctxt (Match _ pats maybe_ty grhss)
   = sep [ sep (herald : map (nest 2 . pprParendLPat) other_pats)
         , nest 2 ppr_maybe_ty
         , nest 2 (pprGRHSs ctxt grhss) ]
@@ -1112,6 +1256,8 @@ type GhciStmt   id = Stmt  id (LHsExpr id)
 --         'ApiAnnotation.AnnComma','ApiAnnotation.AnnThen',
 --         'ApiAnnotation.AnnBy','ApiAnnotation.AnnBy',
 --         'ApiAnnotation.AnnGroup','ApiAnnotation.AnnUsing'
+
+-- For details on above see note [Api annotations] in ApiAnnotation
 data StmtLR idL idR body -- body should always be (LHs**** idR)
   = LastStmt  -- Always the last Stmt in ListComp, MonadComp, PArrComp,
               -- and (after the renamer) DoExpr, MDoExpr
@@ -1122,6 +1268,8 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
                                   -- For DoExpr, MDoExpr, we don't appply a 'return' at all
                                   -- See Note [Monad Comprehensions]
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLarrow'
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
   | BindStmt (LPat idL)
              body
              (SyntaxExpr idR) -- The (>>=) operator; see Note [The type of bind]
@@ -1136,6 +1284,9 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
              (PostTc idR Type) -- Element type of the RHS (used for arrows)
 
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet'
+  --          'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@,
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
   | LetStmt  (HsLocalBindsLR idL idR)
 
   -- ParStmts only occur in a list/monad comprehension
@@ -1166,6 +1317,8 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
 
   -- Recursive statement (see Note [How RecStmt works] below)
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRec'
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
   | RecStmt
      { recS_stmts :: [LStmtLR idL idR body]