Add HsEmbellished type to hsSyn wip/embelleshed-rdr
authorAlan Zimmerman <alan.zimm@gmail.com>
Fri, 17 Feb 2017 10:13:14 +0000 (12:13 +0200)
committerAlan Zimmerman <alan.zimm@gmail.com>
Sat, 18 Feb 2017 18:40:09 +0000 (20:40 +0200)
Summary:
A RdrName can be parsed with parens or backquotes if it is used prefix or infix
respectively when it is normally not used that way.

This is not captured in hsSyn, and must be inferred from the occName when pretty
printing, or using the API annotations.

Introduce a wrapper type around the name to capture this

    data Embellished name
      = EName       name
      | EParens     (Located name)
      | EBackquotes (Located name)

So that we now have

    data HsExpr id
      = HsVar     (LEmbellished id)   -- ^ Variable

and in the other relevant points in hsSyn.

Test Plan: ./validate

Reviewers: bgamari, austin, goldfire

Subscribers: goldfire, thomie, mpickering, snowleopard

Differential Revision: https://phabricator.haskell.org/D3145

65 files changed:
compiler/deSugar/Check.hs
compiler/deSugar/Coverage.hs
compiler/deSugar/Desugar.hs
compiler/deSugar/DsArrows.hs
compiler/deSugar/DsExpr.hs
compiler/deSugar/DsGRHSs.hs
compiler/deSugar/DsMeta.hs
compiler/deSugar/DsUtils.hs
compiler/deSugar/Match.hs
compiler/deSugar/PmExpr.hs
compiler/ghc.cabal.in
compiler/ghc.mk
compiler/hsSyn/Convert.hs
compiler/hsSyn/HsBinds.hs
compiler/hsSyn/HsDecls.hs
compiler/hsSyn/HsEmbellished.hs [new file with mode: 0644]
compiler/hsSyn/HsExpr.hs
compiler/hsSyn/HsPat.hs
compiler/hsSyn/HsSyn.hs
compiler/hsSyn/HsTypes.hs
compiler/hsSyn/HsUtils.hs
compiler/main/HscMain.hs
compiler/main/InteractiveEval.hs
compiler/parser/ApiAnnotation.hs
compiler/parser/Parser.y
compiler/parser/RdrHsSyn.hs
compiler/rename/RnBinds.hs
compiler/rename/RnEnv.hs
compiler/rename/RnExpr.hs
compiler/rename/RnNames.hs
compiler/rename/RnPat.hs
compiler/rename/RnSource.hs
compiler/rename/RnSplice.hs
compiler/rename/RnTypes.hs
compiler/typecheck/Inst.hs
compiler/typecheck/TcAnnotations.hs
compiler/typecheck/TcBinds.hs
compiler/typecheck/TcClassDcl.hs
compiler/typecheck/TcEnv.hs
compiler/typecheck/TcErrors.hs
compiler/typecheck/TcExpr.hs
compiler/typecheck/TcGenDeriv.hs
compiler/typecheck/TcHsSyn.hs
compiler/typecheck/TcHsType.hs
compiler/typecheck/TcInstDcls.hs
compiler/typecheck/TcPat.hs
compiler/typecheck/TcPatSyn.hs
compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcRnTypes.hs
compiler/typecheck/TcSigs.hs
compiler/typecheck/TcSplice.hs
compiler/typecheck/TcTyClsDecls.hs
compiler/typecheck/TcTyDecls.hs
ghc/GHCi/UI/Info.hs
testsuite/tests/ghc-api/annotations/T10357.stdout
testsuite/tests/ghc-api/annotations/T11321.stdout
testsuite/tests/ghc-api/annotations/T13163.stdout
testsuite/tests/ghc-api/landmines/landmines.stdout
testsuite/tests/parser/should_compile/DumpParsedAst.hs
testsuite/tests/parser/should_compile/DumpParsedAst.stderr
testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
testsuite/tests/quasiquotation/T7918.hs
utils/ghctags/Main.hs
utils/haddock

index 4a8a18d..57eb020 100644 (file)
@@ -568,7 +568,7 @@ translatePat fam_insts pat = case pat of
      -- Note [Translating As Patterns]
     ps <- translatePat fam_insts (unLoc p)
     let [e] = map vaToPmExpr (coercePatVec ps)
-        g   = PmGrd [PmVar (unLoc lid)] e
+        g   = PmGrd [PmVar (unLocEmb lid)] e
     return (ps ++ [g])
 
   SigPatOut p _ty -> translatePat fam_insts (unLoc p)
@@ -1042,7 +1042,7 @@ mkPmId ty = getUniqueM >>= \unique ->
 mkPmId2Forms :: Type -> DsM (Pattern, LHsExpr Id)
 mkPmId2Forms ty = do
   x <- mkPmId ty
-  return (PmVar x, noLoc (HsVar (noLoc x)))
+  return (PmVar x, noLoc (HsVar (noEmb x)))
 
 -- ----------------------------------------------------------------------------
 -- * Converting between Value Abstractions, Patterns and PmExpr
index d42b6b0..98f64d9 100644 (file)
@@ -508,7 +508,7 @@ addBinTickLHsExpr boxLabel (L pos e0)
 -- in the addTickLHsExpr family of functions.)
 
 addTickHsExpr :: HsExpr Id -> TM (HsExpr Id)
-addTickHsExpr e@(HsVar (L _ id)) = do freeVar id; return e
+addTickHsExpr e@(HsVar (L _ id)) = do freeVar $ unEmb id; return e
 addTickHsExpr (HsUnboundVar {})  = panic "addTickHsExpr.HsUnboundVar"
 addTickHsExpr e@(HsConLikeOut con)
   | Just id <- conLikeWrapId_maybe con = do freeVar id; return e
index d5931d1..c74189a 100644 (file)
@@ -547,10 +547,10 @@ dsVect :: LVectDecl Id -> DsM CoreVect
 dsVect (L loc (HsVect _ (L _ v) rhs))
   = putSrcSpanDs loc $
     do { rhs' <- dsLExpr rhs
-       ; return $ Vect v rhs'
+       ; return $ Vect (unEmb v) rhs'
        }
 dsVect (L _loc (HsNoVect _ (L _ v)))
-  = return $ NoVect v
+  = return $ NoVect $ unEmb v
 dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon))
   = return $ VectType isScalar tycon' rhs_tycon
   where
index f686b68..7a576b5 100644 (file)
@@ -1187,7 +1187,7 @@ collectl (L _ pat) bndrs
     go (WildPat _)                = bndrs
     go (LazyPat pat)              = collectl pat bndrs
     go (BangPat pat)              = collectl pat bndrs
-    go (AsPat (L _ a) pat)        = a : collectl pat bndrs
+    go (AsPat (L _ a) pat)        = unEmb a : collectl pat bndrs
     go (ParPat  pat)              = collectl pat bndrs
 
     go (ListPat pats _ _)         = foldr collectl bndrs pats
index 28254c9..f570b46 100644 (file)
@@ -254,7 +254,7 @@ dsLExprNoLP (L loc e)
 dsExpr :: HsExpr Id -> DsM CoreExpr
 dsExpr (HsPar e)              = dsLExpr e
 dsExpr (ExprWithTySigOut e _) = dsLExpr e
-dsExpr (HsVar (L _ var))      = return (varToCoreExpr var)
+dsExpr (HsVar (L _ var))      = return (varToCoreExpr $ unEmb var)
                                 -- See Note [Desugaring vars]
 dsExpr (HsUnboundVar {})      = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
 dsExpr (HsConLikeOut con)     = return (dsConLike con)
index 0a66bd0..ea4c439 100644 (file)
@@ -134,8 +134,8 @@ isTrueLHsExpr :: LHsExpr Id -> Maybe (CoreExpr -> DsM CoreExpr)
 --        * Trivial wappings of these
 -- The arguments to Just are any HsTicks that we have found,
 -- because we still want to tick then, even it they are always evaluated.
-isTrueLHsExpr (L _ (HsVar (L _ v))) |  v `hasKey` otherwiseIdKey
-                                    || v `hasKey` getUnique trueDataConId
+isTrueLHsExpr (L _ (HsVar (L _ v))) |  unEmb v `hasKey` otherwiseIdKey
+                                    || unEmb v `hasKey` getUnique trueDataConId
                                             = Just return
         -- trueDataConId doesn't have the same unique as trueDataCon
 isTrueLHsExpr (L _ (HsConLikeOut con)) | con `hasKey` getUnique trueDataCon = Just return
index 7880474..a8a1a44 100644 (file)
@@ -74,13 +74,13 @@ dsBracket brack splices
   where
     new_bit = mkNameEnv [(n, DsSplice (unLoc e)) | PendingTcSplice n e <- splices]
 
-    do_brack (VarBr _ n) = do { MkC e1  <- lookupOcc n ; return e1 }
-    do_brack (ExpBr e)   = do { MkC e1  <- repLE e     ; return e1 }
-    do_brack (PatBr p)   = do { MkC p1  <- repTopP p   ; return p1 }
-    do_brack (TypBr t)   = do { MkC t1  <- repLTy t    ; return t1 }
-    do_brack (DecBrG gp) = do { MkC ds1 <- repTopDs gp ; return ds1 }
+    do_brack (VarBr _ n) = do { MkC e1  <- lookupLEOcc n ; return e1 }
+    do_brack (ExpBr e)   = do { MkC e1  <- repLE e       ; return e1 }
+    do_brack (PatBr p)   = do { MkC p1  <- repTopP p     ; return p1 }
+    do_brack (TypBr t)   = do { MkC t1  <- repLTy t      ; return t1 }
+    do_brack (DecBrG gp) = do { MkC ds1 <- repTopDs gp   ; return ds1 }
     do_brack (DecBrL _)  = panic "dsBracket: unexpected DecBrL"
-    do_brack (TExpBr e)  = do { MkC e1  <- repLE e     ; return e1 }
+    do_brack (TExpBr e)  = do { MkC e1  <- repLE e       ; return e1 }
 
 {- -------------- Examples --------------------
 
@@ -299,7 +299,7 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
 -------------------------
 repRoleD :: LRoleAnnotDecl Name -> DsM (SrcSpan, Core TH.DecQ)
 repRoleD (L loc (RoleAnnotDecl tycon roles))
-  = do { tycon1 <- lookupLOcc tycon
+  = do { tycon1 <- lookupLEOcc tycon
        ; roles1 <- mapM repRole roles
        ; roles2 <- coreList roleTyConName roles1
        ; dec <- repRoleAnnotD tycon1 roles2
@@ -568,7 +568,7 @@ repFixD (L loc (FixitySig names (Fixity _ prec dir)))
                         InfixR -> infixRDName
                         InfixN -> infixNDName
        ; let do_one name
-              = do { MkC name' <- lookupLOcc name
+              = do { MkC name' <- lookupLEOcc name
                    ; dec <- rep2 rep_fn [prec', name']
                    ; return (loc,dec) }
        ; mapM do_one names }
@@ -611,7 +611,7 @@ repAnnD (L loc (HsAnnotation _ ann_prov (L _ exp)))
 
 repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget)
 repAnnProv (ValueAnnProvenance (L _ n))
-  = do { MkC n' <- globalVar n  -- ANNs are allowed only at top-level
+  = do { MkC n' <- globalVar $ unEmb n  -- ANNs are allowed only at top-level
        ; rep2 valueAnnotationName [ n' ] }
 repAnnProv (TypeAnnProvenance (L _ n))
   = do { MkC n' <- globalVar n
@@ -740,32 +740,32 @@ rep_sig (L _   (SCCFunSig {}))        = notHandled "SCC pragmas" empty
 rep_sig (L loc (CompleteMatchSig _st cls mty)) = rep_complete_sig cls mty loc
 
 
-rep_ty_sig :: Name -> SrcSpan -> LHsSigType Name -> Located Name
+rep_ty_sig :: Name -> SrcSpan -> LHsSigType Name -> LEmbellished Name
            -> DsM (SrcSpan, Core TH.DecQ)
 rep_ty_sig mk_sig loc sig_ty nm
-  = do { nm1 <- lookupLOcc nm
+  = do { nm1 <- lookupLEOcc nm
        ; ty1 <- repHsSigType sig_ty
        ; sig <- repProto mk_sig nm1 ty1
        ; return (loc, sig) }
 
-rep_patsyn_ty_sig :: SrcSpan -> LHsSigType Name -> Located Name
+rep_patsyn_ty_sig :: SrcSpan -> LHsSigType Name -> LEmbellished Name
                   -> DsM (SrcSpan, Core TH.DecQ)
 -- represents a pattern synonym type signature;
 -- see Note [Pattern synonym type signatures and Template Haskell] in Convert
 rep_patsyn_ty_sig loc sig_ty nm
-  = do { nm1 <- lookupLOcc nm
+  = do { nm1 <- lookupLEOcc nm
        ; ty1 <- repHsPatSynSigType sig_ty
        ; sig <- repProto patSynSigDName nm1 ty1
        ; return (loc, sig) }
 
-rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType Name -> Located Name
+rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType Name -> LEmbellished Name
               -> DsM (SrcSpan, Core TH.DecQ)
     -- We must special-case the top-level explicit for-all of a TypeSig
     -- See Note [Scoped type variables in bindings]
 rep_wc_ty_sig mk_sig loc sig_ty nm
   | HsIB { hsib_body = hs_ty } <- hswc_body sig_ty
   , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy hs_ty
-  = do { nm1 <- lookupLOcc nm
+  = do { nm1 <- lookupLEOcc nm
        ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
                                      ; repTyVarBndrWithKind tv name }
        ; th_explicit_tvs <- repList tyVarBndrTyConName rep_in_scope_tv
@@ -781,12 +781,12 @@ rep_wc_ty_sig mk_sig loc sig_ty nm
        ; sig <- repProto mk_sig nm1 ty1
        ; return (loc, sig) }
 
-rep_inline :: Located Name
+rep_inline :: LEmbellished Name
            -> InlinePragma      -- Never defaultInlinePragma
            -> SrcSpan
            -> DsM [(SrcSpan, Core TH.DecQ)]
 rep_inline nm ispec loc
-  = do { nm1    <- lookupLOcc nm
+  = do { nm1    <- lookupLEOcc nm
        ; inline <- repInline $ inl_inline ispec
        ; rm     <- repRuleMatch $ inl_rule ispec
        ; phases <- repPhases $ inl_act ispec
@@ -794,10 +794,11 @@ rep_inline nm ispec loc
        ; return [(loc, pragma)]
        }
 
-rep_specialise :: Located Name -> LHsSigType Name -> InlinePragma -> SrcSpan
+rep_specialise
+  :: LEmbellished Name -> LHsSigType Name -> InlinePragma -> SrcSpan
                -> DsM [(SrcSpan, Core TH.DecQ)]
 rep_specialise nm ty ispec loc
-  = do { nm1 <- lookupLOcc nm
+  = do { nm1 <- lookupLEOcc nm
        ; ty1 <- repHsSigType ty
        ; phases <- repPhases $ inl_act ispec
        ; let inline = inl_inline ispec
@@ -833,13 +834,13 @@ repPhases (ActiveAfter _ i)  = do { MkC arg <- coreIntLit i
                                   ; dataCon' fromPhaseDataConName [arg] }
 repPhases _                  = dataCon allPhasesDataConName
 
-rep_complete_sig :: Located [Located Name]
-                 -> Maybe (Located Name)
+rep_complete_sig :: Located [LEmbellished Name]
+                 -> Maybe (LEmbellished Name)
                  -> SrcSpan
                  -> DsM [(SrcSpan, Core TH.DecQ)]
 rep_complete_sig (L _ cls) mty loc
-  = do { mty' <- rep_maybe_name mty
-       ; cls' <- repList nameTyConName lookupLOcc cls
+  = do { mty' <- rep_maybe_name $ fmap unLEmb mty
+       ; cls' <- repList nameTyConName lookupLEOcc cls
        ; sig <- repPragComplete cls' mty'
        ; return [(loc, sig)] }
   where
@@ -992,15 +993,15 @@ repTy ty@(HsForAllTy {}) = repForall ty
 repTy ty@(HsQualTy {})   = repForall ty
 
 repTy (HsTyVar _ (L _ n))
-  | isTvOcc occ   = do tv1 <- lookupOcc n
+  | isTvOcc occ   = do tv1 <- lookupOcc $ unEmb n
                        repTvar tv1
-  | isDataOcc occ = do tc1 <- lookupOcc n
+  | isDataOcc occ = do tc1 <- lookupOcc $ unEmb n
                        repPromotedDataCon tc1
-  | n == eqTyConName = repTequality
-  | otherwise     = do tc1 <- lookupOcc n
+  | unEmb n == eqTyConName = repTequality
+  | otherwise     = do tc1 <- lookupOcc $ unEmb n
                        repNamedTyCon tc1
   where
-    occ = nameOccName n
+    occ = nameOccName $ unEmb n
 
 repTy (HsAppTy f a)         = do
                                 f1 <- repLTy f
@@ -1018,7 +1019,7 @@ repTy (HsListTy t)          = do
 repTy (HsPArrTy t)     = do
                            t1   <- repLTy t
                            tcon <- repTy (HsTyVar NotPromoted
-                                                  (noLoc (tyConName parrTyCon)))
+                                                  (noEmb (tyConName parrTyCon)))
                            repTapp tcon t1
 repTy (HsTupleTy HsUnboxedTuple tys) = do
                                 tys1 <- repLTys tys
@@ -1090,10 +1091,10 @@ repNonArrowLKind (L _ ki) = repNonArrowKind ki
 
 repNonArrowKind :: HsKind Name -> DsM (Core TH.Kind)
 repNonArrowKind (HsTyVar _ (L _ name))
-  | isLiftedTypeKindTyConName name       = repKStar
-  | name `hasKey` constraintKindTyConKey = repKConstraint
-  | isTvOcc (nameOccName name)      = lookupOcc name >>= repKVar
-  | otherwise                       = lookupOcc name >>= repKCon
+  | isLiftedTypeKindTyConName $ unEmb name = repKStar
+  | unEmb name `hasKey` constraintKindTyConKey = repKConstraint
+  | isTvOcc (nameOccName $ unEmb name) = lookupOcc (unEmb name) >>= repKVar
+  | otherwise                          = lookupOcc (unEmb name) >>= repKCon
 repNonArrowKind (HsAppTy f a)       = do  { f' <- repLKind f
                                           ; a' <- repLKind a
                                           ; repKApp f' a'
@@ -1150,18 +1151,18 @@ repLE (L loc e) = putSrcSpanDs loc (repE e)
 
 repE :: HsExpr Name -> DsM (Core TH.ExpQ)
 repE (HsVar (L _ x))            =
-  do { mb_val <- dsLookupMetaEnv x
+  do { mb_val <- dsLookupMetaEnv(unEmb x)
      ; case mb_val of
-        Nothing            -> do { str <- globalVar x
-                                 ; repVarOrCon x str }
-        Just (DsBound y)   -> repVarOrCon x (coreVar y)
+        Nothing            -> do { str <- globalVar (unEmb x)
+                                 ; repVarOrCon (unEmb x) str }
+        Just (DsBound y)   -> repVarOrCon (unEmb x) (coreVar y)
         Just (DsSplice e)  -> do { e' <- dsExpr e
                                  ; return (MkC e') } }
 repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
 repE e@(HsOverLabel{}) = notHandled "Overloaded labels" (ppr e)
 
 repE e@(HsRecFld f) = case f of
-  Unambiguous _ x -> repE (HsVar (noLoc x))
+  Unambiguous _ x -> repE (HsVar (noEmb x))
   Ambiguous{}     -> notHandled "Ambiguous record selectors" (ppr e)
 
         -- Remember, we're desugaring renamer output here, so
@@ -1506,7 +1507,7 @@ rep_bind (L loc (PatSynBind (PSB { psb_id   = syn
                                  , psb_args = args
                                  , psb_def  = pat
                                  , psb_dir  = dir })))
-  = do { syn'      <- lookupLBinder syn
+  = do { syn'      <- lookupLBinder $ unLEmb syn
        ; dir'      <- repPatSynDir dir
        ; ss        <- mkGenArgSyms args
        ; patSynD'  <- addBinds ss (
@@ -1637,7 +1638,8 @@ repP (LitPat l)        = do { l2 <- repLiteral l; repPlit l2 }
 repP (VarPat (L _ x))  = do { x' <- lookupBinder x; repPvar x' }
 repP (LazyPat p)       = do { p1 <- repLP p; repPtilde p1 }
 repP (BangPat p)       = do { p1 <- repLP p; repPbang p1 }
-repP (AsPat x p)       = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
+repP (AsPat x p)       = do { x' <- lookupLEBinder x
+                            ; p1 <- repLP p; repPaspat x' p1 }
 repP (ParPat p)        = repLP p
 repP (ListPat ps _ Nothing)    = do { qs <- repLPs ps; repPlist qs }
 repP (ListPat ps ty1 (Just (_,e))) = do { p <- repP (ListPat ps ty1 Nothing); e' <- repE (syn_expr e); repPview e' p}
@@ -1714,6 +1716,9 @@ addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) <- bs]) m
 
 -- Look up a locally bound name
 --
+lookupLEBinder :: LEmbellished Name -> DsM (Core TH.Name)
+lookupLEBinder (L _ n) = lookupBinder $ unEmb n
+
 lookupLBinder :: Located Name -> DsM (Core TH.Name)
 lookupLBinder (L _ n) = lookupBinder n
 
@@ -1729,6 +1734,9 @@ lookupBinder = lookupOcc
 --  * If it is a global name, generate the "original name" representation (ie,
 --   the <module>:<name> form) for the associated entity
 --
+lookupLEOcc :: LEmbellished Name -> DsM (Core TH.Name)
+lookupLEOcc (L _ n) = lookupOcc $ unEmb n
+
 lookupLOcc :: Located Name -> DsM (Core TH.Name)
 -- Lookup an occurrence; it can't be a splice.
 -- Use the in-scope bindings if they exist
@@ -2170,19 +2178,19 @@ repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty]
 repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)
 repCtxt (MkC tys) = rep2 cxtName [tys]
 
-repDataCon :: Located Name
+repDataCon :: LEmbellished Name
            -> HsConDeclDetails Name
            -> DsM (Core TH.ConQ)
 repDataCon con details
-    = do con' <- lookupLOcc con -- See Note [Binders and occurrences]
+    = do con' <- lookupLEOcc con -- See Note [Binders and occurrences]
          repConstr details Nothing [con']
 
-repGadtDataCons :: [Located Name]
+repGadtDataCons :: [LEmbellished Name]
                 -> HsConDeclDetails Name
                 -> LHsType Name
                 -> DsM (Core TH.ConQ)
 repGadtDataCons cons details res_ty
-    = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
+    = do cons' <- mapM lookupLEOcc cons -- See Note [Binders and occurrences]
          repConstr details (Just res_ty) cons'
 
 -- Invariant:
index 165130a..adfa3c3 100644 (file)
@@ -120,7 +120,7 @@ selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat)
 selectMatchVar (ParPat pat)  = selectMatchVar (unLoc pat)
 selectMatchVar (VarPat var)  = return (localiseId (unLoc var))
                                   -- Note [Localise pattern binders]
-selectMatchVar (AsPat var _) = return (unLoc var)
+selectMatchVar (AsPat var _) = return (unLocEmb var)
 selectMatchVar other_pat     = newSysLocalDsNoLP (hsPatType other_pat)
                                   -- OK, better make up one...
 
index 840a5fe..045c5ee 100644 (file)
@@ -430,7 +430,7 @@ tidy1 v (VarPat (L _ var))
         -- = case v of { p -> let x=v in mr[] }
 tidy1 v (AsPat (L _ var) pat)
   = do  { (wrap, pat') <- tidy1 v (unLoc pat)
-        ; return (wrapBind var v . wrap, pat') }
+        ; return (wrapBind (unEmb var) v . wrap, pat') }
 
 {- now, here we handle lazy patterns:
     tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
index 8c3df96..f9d0c55 100644 (file)
@@ -234,7 +234,7 @@ lhsExprToPmExpr (L _ e) = hsExprToPmExpr e
 
 hsExprToPmExpr :: HsExpr Id -> PmExpr
 
-hsExprToPmExpr (HsVar         x) = PmExprVar (idName (unLoc x))
+hsExprToPmExpr (HsVar         x) = PmExprVar (idName (unEmb $ unLoc x))
 hsExprToPmExpr (HsConLikeOut  c) = PmExprVar (conLikeName c)
 hsExprToPmExpr (HsOverLit  olit) = PmExprLit (PmOLit False olit)
 hsExprToPmExpr (HsLit       lit) = PmExprLit (PmSLit lit)
index f3d6711..c91d0af 100644 (file)
@@ -310,6 +310,7 @@ Library
         HsImpExp
         HsLit
         PlaceHolder
+        HsEmbellished
         HsPat
         HsSyn
         HsTypes
index ce41eca..1018eac 100644 (file)
@@ -481,6 +481,7 @@ compiler_stage2_dll0_MODULES = \
        HsImpExp \
        HsLit \
        PlaceHolder \
+       HsEmbellished \
        PmExpr \
        HsPat \
        HsSyn \
index 7e786bd..1d672b2 100644 (file)
@@ -165,14 +165,14 @@ cvtDec (TH.FunD nm cls)
 cvtDec (TH.SigD nm typ)
   = do  { nm' <- vNameL nm
         ; ty' <- cvtType typ
-        ; returnJustL $ Hs.SigD (TypeSig [nm'] (mkLHsSigWcType ty')) }
+        ; returnJustL $ Hs.SigD (TypeSig [lEmb nm'] (mkLHsSigWcType ty')) }
 
 cvtDec (TH.InfixD fx nm)
   -- Fixity signatures are allowed for variables, constructors, and types
   -- the renamer automatically looks for types during renaming, even when
   -- the RdrName says it's a variable or a constructor. So, just assume
   -- it's a variable or constructor and proceed.
-  = do { nm' <- vcNameL nm
+  = do { nm' <- vcNameLE nm
        ; returnJustL (Hs.SigD (FixSig (FixitySig [nm'] (cvtFixity fx)))) }
 
 cvtDec (PragmaD prag)
@@ -341,7 +341,7 @@ cvtDec (ClosedTypeFamilyD head eqns)
 cvtDec (TH.RoleAnnotD tc roles)
   = do { tc' <- tconNameL tc
        ; let roles' = map (noLoc . cvtRole) roles
-       ; returnJustL $ Hs.RoleAnnotD (RoleAnnotDecl tc' roles') }
+       ; returnJustL $ Hs.RoleAnnotD (RoleAnnotDecl (lEmb tc') roles') }
 
 cvtDec (TH.StandaloneDerivD ds cxt ty)
   = do { cxt' <- cvtContext cxt
@@ -355,7 +355,7 @@ cvtDec (TH.StandaloneDerivD ds cxt ty)
 cvtDec (TH.DefaultSigD nm typ)
   = do { nm' <- vNameL nm
        ; ty' <- cvtType typ
-       ; returnJustL $ Hs.SigD $ ClassOpSig True [nm'] (mkLHsSigType ty') }
+       ; returnJustL $ Hs.SigD $ ClassOpSig True [lEmb nm'] (mkLHsSigType ty') }
 
 cvtDec (TH.PatSynD nm args dir pat)
   = do { nm'   <- cNameL nm
@@ -363,7 +363,7 @@ cvtDec (TH.PatSynD nm args dir pat)
        ; dir'  <- cvtDir nm' dir
        ; pat'  <- cvtPat pat
        ; returnJustL $ Hs.ValD $ PatSynBind $
-           PSB nm' placeHolderType args' pat' dir' }
+           PSB (lEmb nm') placeHolderType args' pat' dir' }
   where
     cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixPatSyn <$> mapM vNameL args
     cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixPatSyn <$> vNameL a1 <*> vNameL a2
@@ -379,7 +379,7 @@ cvtDec (TH.PatSynD nm args dir pat)
          ; return $ ExplicitBidirectional $ mkMatchGroup FromSource ms }
 
 cvtDec (TH.PatSynSigD nm ty)
-  = do { nm' <- cNameL nm
+  = do { nm' <- cNameLE nm
        ; ty' <- cvtPatSynSigTy ty
        ; returnJustL $ Hs.SigD $ PatSynSig [nm'] (mkLHsSigType ty') }
 
@@ -485,20 +485,20 @@ mkBadDecMsg doc bads
 cvtConstr :: TH.Con -> CvtM (LConDecl RdrName)
 
 cvtConstr (NormalC c strtys)
-  = do  { c'   <- cNameL c
+  = do  { c'   <- cNameLE c
         ; cxt' <- returnL []
         ; tys' <- mapM cvt_arg strtys
         ; returnL $ mkConDeclH98 c' Nothing cxt' (PrefixCon tys') }
 
 cvtConstr (RecC c varstrtys)
-  = do  { c'    <- cNameL c
+  = do  { c'    <- cNameLE c
         ; cxt'  <- returnL []
         ; args' <- mapM cvt_id_arg varstrtys
         ; returnL $ mkConDeclH98 c' Nothing cxt'
                                    (RecCon (noLoc args')) }
 
 cvtConstr (InfixC st1 c st2)
-  = do  { c'   <- cNameL c
+  = do  { c'   <- cNameLE c
         ; cxt' <- returnL []
         ; st1' <- cvt_arg st1
         ; st2' <- cvt_arg st2
@@ -527,14 +527,14 @@ cvtConstr (ForallC tvs ctxt con)
                                           (con_cxt con'))) } }
 
 cvtConstr (GadtC c strtys ty)
-  = do  { c'      <- mapM cNameL c
+  = do  { c'      <- mapM cNameLE c
         ; args    <- mapM cvt_arg strtys
         ; L _ ty' <- cvtType ty
         ; c_ty    <- mk_arr_apps args ty'
         ; returnL $ mkGadtDecl c' (mkLHsSigType c_ty)}
 
 cvtConstr (RecGadtC c varstrtys ty)
-  = do  { c'       <- mapM cNameL c
+  = do  { c'       <- mapM cNameLE c
         ; ty'      <- cvtType ty
         ; rec_flds <- mapM cvt_id_arg varstrtys
         ; let rec_ty = noLoc (HsFunTy (noLoc $ HsRecTy rec_flds) ty')
@@ -563,7 +563,7 @@ cvt_id_arg (i, str, ty)
         ; ty' <- cvt_arg (str,ty)
         ; return $ noLoc (ConDeclField
                           { cd_fld_names
-                              = [L li $ FieldOcc (L li i') PlaceHolder]
+                              = [L li $ FieldOcc (L li $ EName i') PlaceHolder]
                           , cd_fld_type =  ty'
                           , cd_fld_doc = Nothing}) }
 
@@ -646,7 +646,7 @@ cvtPragmaD (InlineP nm inline rm phases)
                                  , inl_rule   = cvtRuleMatch rm
                                  , inl_act    = cvtPhases phases dflt
                                  , inl_sat    = Nothing }
-       ; returnJustL $ Hs.SigD $ InlineSig nm' ip }
+       ; returnJustL $ Hs.SigD $ InlineSig (lEmb nm') ip }
 
 cvtPragmaD (SpecialiseP nm ty inline phases)
   = do { nm' <- vNameL nm
@@ -664,7 +664,7 @@ cvtPragmaD (SpecialiseP nm ty inline phases)
                                , inl_rule   = Hs.FunLike
                                , inl_act    = cvtPhases phases dflt
                                , inl_sat    = Nothing }
-       ; returnJustL $ Hs.SigD $ SpecSig nm' [mkLHsSigType ty'] ip }
+       ; returnJustL $ Hs.SigD $ SpecSig (lEmb nm') [mkLHsSigType ty'] ip }
 
 cvtPragmaD (SpecialiseInstP ty)
   = do { ty' <- cvtType ty
@@ -693,7 +693,7 @@ cvtPragmaD (AnnP target exp)
            return (TypeAnnProvenance  (noLoc n'))
          ValueAnnotation n -> do
            n' <- vcName n
-           return (ValueAnnProvenance (noLoc n'))
+           return (ValueAnnProvenance (noEmb n'))
        ; returnJustL $ Hs.AnnD $ HsAnnotation (SourceText "{-# ANN") target'
                                                exp'
        }
@@ -703,8 +703,8 @@ cvtPragmaD (LineP line file)
        ; return Nothing
        }
 cvtPragmaD (CompleteP cls mty)
-  = do { cls' <- noLoc <$> mapM cNameL cls
-       ; mty'  <- traverse tconNameL mty
+  = do { cls' <- noLoc <$> mapM cNameLE cls
+       ; mty'  <- traverse tconNameLE mty
        ; returnJustL $ Hs.SigD
                    $ CompleteMatchSig NoSourceText cls' mty' }
 
@@ -768,8 +768,8 @@ cvtClause ctxt (Clause ps body wheres)
 cvtl :: TH.Exp -> CvtM (LHsExpr RdrName)
 cvtl e = wrapL (cvt e)
   where
-    cvt (VarE s)        = do { s' <- vName s; return $ HsVar (noLoc s') }
-    cvt (ConE s)        = do { s' <- cName s; return $ HsVar (noLoc s') }
+    cvt (VarE s)        = do { s' <- vName s; return $ HsVar (noEmb s') }
+    cvt (ConE s)        = do { s' <- cName s; return $ HsVar (noEmb s') }
     cvt (LitE l)
       | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' }
       | otherwise       = do { l' <- cvtLit l;     return $ HsLit l' }
@@ -848,7 +848,7 @@ cvtl e = wrapL (cvt e)
     cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtType t
                               ; return $ ExprWithTySig e' (mkLHsSigWcType t') }
     cvt (RecConE c flds) = do { c' <- cNameL c
-                              ; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds
+                              ; flds' <- mapM (cvtFld (mkFieldOcc . noEmb)) flds
                               ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) }
     cvt (RecUpdE e flds) = do { e' <- cvtl e
                               ; flds'
@@ -856,7 +856,7 @@ cvtl e = wrapL (cvt e)
                                            flds
                               ; return $ mkRdrRecordUpd e' flds' }
     cvt (StaticE e)      = fmap (HsStatic placeHolderNames) $ cvtl e
-    cvt (UnboundVarE s)  = do { s' <- vName s; return $ HsVar (noLoc s') }
+    cvt (UnboundVarE s)  = do { s' <- vName s; return $ HsVar (noEmb s') }
 
 {- Note [Dropping constructors]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1095,7 +1095,8 @@ cvtp (ParensP p)       = do { p' <- cvtPat p;
                                 _                 -> return $ ParPat p' }
 cvtp (TildeP p)        = do { p' <- cvtPat p; return $ LazyPat p' }
 cvtp (BangP p)         = do { p' <- cvtPat p; return $ BangPat p' }
-cvtp (TH.AsP s p)      = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
+cvtp (TH.AsP s p)      = do { s' <- vNameL s
+                            ; p' <- cvtPat p; return $ AsPat (lEmb s') p' }
 cvtp TH.WildP          = return $ WildPat placeHolderType
 cvtp (RecP c fs)       = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
                             ; return $ ConPatIn c'
@@ -1111,7 +1112,7 @@ cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField RdrName (LPat RdrName))
 cvtPatFld (s,p)
   = do  { L ls s' <- vNameL s; p' <- cvtPat p
         ; return (noLoc $ HsRecField { hsRecFieldLbl
-                                         = L ls $ mkFieldOcc (L ls s')
+                                         = L ls $ mkFieldOcc (L ls $ EName s')
                                      , hsRecFieldArg = p'
                                      , hsRecPun      = False}) }
 
@@ -1190,13 +1191,13 @@ cvtTypeKind ty_str ty
              -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor")))
              | otherwise
              -> mk_apps (HsTyVar NotPromoted
-                               (noLoc (getRdrName (tupleTyCon Boxed n)))) tys'
+                               (noEmb (getRdrName (tupleTyCon Boxed n)))) tys'
            UnboxedTupleT n
              | length tys' == n         -- Saturated
              -> returnL (HsTupleTy HsUnboxedTuple tys')
              | otherwise
              -> mk_apps (HsTyVar NotPromoted
-                             (noLoc (getRdrName (tupleTyCon Unboxed n)))) tys'
+                             (noEmb (getRdrName (tupleTyCon Unboxed n)))) tys'
            UnboxedSumT n
              | n < 2
             -> failWith $
@@ -1206,22 +1207,22 @@ cvtTypeKind ty_str ty
              | length tys' == n -- Saturated
              -> returnL (HsSumTy tys')
              | otherwise
-             -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName (sumTyCon n))))
+             -> mk_apps (HsTyVar NotPromoted (noEmb (getRdrName (sumTyCon n))))
                         tys'
            ArrowT
              | [x',y'] <- tys' -> returnL (HsFunTy x' y')
              | otherwise ->
-                  mk_apps (HsTyVar NotPromoted (noLoc (getRdrName funTyCon)))
+                  mk_apps (HsTyVar NotPromoted (noEmb (getRdrName funTyCon)))
                           tys'
            ListT
              | [x']    <- tys' -> returnL (HsListTy x')
              | otherwise ->
-                  mk_apps (HsTyVar NotPromoted (noLoc (getRdrName listTyCon)))
+                  mk_apps (HsTyVar NotPromoted (noEmb (getRdrName listTyCon)))
                            tys'
            VarT nm -> do { nm' <- tNameL nm
-                         ; mk_apps (HsTyVar NotPromoted nm') tys' }
+                         ; mk_apps (HsTyVar NotPromoted (lEmb nm')) tys' }
            ConT nm -> do { nm' <- tconName nm
-                         ; mk_apps (HsTyVar NotPromoted (noLoc nm')) tys' }
+                         ; mk_apps (HsTyVar NotPromoted (noEmb nm')) tys' }
 
            ForallT tvs cxt ty
              | null tys'
@@ -1250,7 +1251,7 @@ cvtTypeKind ty_str ty
              -> do { s'  <- tconName s
                    ; t1' <- cvtType t1
                    ; t2' <- cvtType t2
-                   ; mk_apps (HsTyVar NotPromoted (noLoc s')) [t1', t2']
+                   ; mk_apps (HsTyVar NotPromoted (noEmb s')) [t1', t2']
                    }
 
            UInfixT t1 s t2
@@ -1266,7 +1267,7 @@ cvtTypeKind ty_str ty
                    }
 
            PromotedT nm -> do { nm' <- cName nm
-                              ; mk_apps (HsTyVar NotPromoted (noLoc nm')) tys' }
+                              ; mk_apps (HsTyVar NotPromoted (noEmb nm')) tys' }
                  -- Promoted data constructor; hence cName
 
            PromotedTupleT n
@@ -1287,22 +1288,22 @@ cvtTypeKind ty_str ty
              | [ty1, L _ (HsExplicitListTy ip _ tys2)] <- tys'
              -> returnL (HsExplicitListTy ip placeHolderKind (ty1:tys2))
              | otherwise
-             -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName consDataCon)))
+             -> mk_apps (HsTyVar NotPromoted (noEmb (getRdrName consDataCon)))
                         tys'
 
            StarT
-             -> returnL (HsTyVar NotPromoted (noLoc
+             -> returnL (HsTyVar NotPromoted (noEmb
                                               (getRdrName liftedTypeKindTyCon)))
 
            ConstraintT
              -> returnL (HsTyVar NotPromoted
-                              (noLoc (getRdrName constraintKindTyCon)))
+                              (noEmb (getRdrName constraintKindTyCon)))
 
            EqualityT
              | [x',y'] <- tys' -> returnL (HsEqTy x' y')
              | otherwise ->
                    mk_apps (HsTyVar NotPromoted
-                            (noLoc (getRdrName eqPrimTyCon))) tys'
+                            (noEmb (getRdrName eqPrimTyCon))) tys'
 
            _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))
     }
@@ -1345,7 +1346,7 @@ cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s)
 cvtOpAppT :: LHsType RdrName -> RdrName -> LHsType RdrName -> LHsType RdrName
 cvtOpAppT t1@(L loc1 _) op t2@(L loc2 _)
   = L (combineSrcSpans loc1 loc2) $
-    HsAppsTy (t1' ++ [noLoc $ HsAppInfix (noLoc op)] ++ t2')
+    HsAppsTy (t1' ++ [noLoc $ HsAppInfix (noEmb op)] ++ t2')
   where
     t1' | L _ (HsAppsTy t1s) <- t1
         = t1s
@@ -1492,7 +1493,8 @@ mkHsQualTy ctxt loc ctxt' ty
 --------------------------------------------------------------------
 
 -- variable names
-vNameL, cNameL, vcNameL, tNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
+cNameLE, vcNameLE, tconNameLE :: TH.Name -> CvtM (LEmbellished RdrName)
+vNameL, cNameL,          tNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
 vName,  cName,  vcName,  tName,  tconName  :: TH.Name -> CvtM RdrName
 
 -- Variable names
@@ -1500,11 +1502,12 @@ vNameL n = wrapL (vName n)
 vName n = cvtName OccName.varName n
 
 -- Constructor function names; this is Haskell source, hence srcDataName
+cNameLE n = wrapL (cName n >>= \nn -> return $ EName nn)
 cNameL n = wrapL (cName n)
 cName n = cvtName OccName.dataName n
 
 -- Variable *or* constructor names; check by looking at the first char
-vcNameL n = wrapL (vcName n)
+vcNameLE n = wrapL (vcName n >>= \nn -> return $ EName nn)
 vcName n = if isVarName n then vName n else cName n
 
 -- Type variable names
@@ -1512,6 +1515,7 @@ tNameL n = wrapL (tName n)
 tName n = cvtName OccName.tvName n
 
 -- Type Constructor names
+tconNameLE n = wrapL (tconName n >>= \nn -> return $ EName nn)
 tconNameL n = wrapL (tconName n)
 tconName n = cvtName OccName.tcClsName n
 
index 1f38c38..60a460a 100644 (file)
@@ -24,6 +24,7 @@ import {-# SOURCE #-} HsPat  ( LPat )
 
 import PlaceHolder ( PostTc,PostRn,DataId,OutputableBndrId )
 import HsTypes
+import HsEmbellished
 import PprCore ()
 import CoreSyn
 import TcEvidence
@@ -292,7 +293,7 @@ data ABExport id
 
 -- | Pattern Synonym binding
 data PatSynBind idL idR
-  = PSB { psb_id   :: Located idL,             -- ^ Name of the pattern synonym
+  = PSB { psb_id   :: LEmbellished idL,        -- ^ Name of the pattern synonym
           psb_fvs  :: PostRn idR NameSet,      -- ^ See Note [Bind free vars]
           psb_args :: HsPatSynDetails (Located idR), -- ^ Formal parameter names
           psb_def  :: LPat idR,                      -- ^ Right-hand side
@@ -739,7 +740,7 @@ data Sig name
 
       -- For details on above see note [Api annotations] in ApiAnnotation
     TypeSig
-       [Located name]        -- LHS of the signature; e.g.  f,g,h :: blah
+       [LEmbellished name]   -- LHS of the signature; e.g.  f,g,h :: blah
        (LHsSigWcType name)   -- RHS of the signature; can have wildcards
 
       -- | A pattern synonym type signature
@@ -751,7 +752,7 @@ data Sig name
       --           'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow'
 
       -- For details on above see note [Api annotations] in ApiAnnotation
-  | PatSynSig [Located name] (LHsSigType name)
+  | PatSynSig [LEmbellished name] (LHsSigType name)
       -- P :: forall a b. Req => Prov => ty
 
       -- | A signature for a class method
@@ -764,7 +765,7 @@ data Sig name
       --
       --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault',
       --           'ApiAnnotation.AnnDcolon'
-  | ClassOpSig Bool [Located name] (LHsSigType name)
+  | ClassOpSig Bool [LEmbellished name] (LHsSigType name)
 
         -- | A type signature in generated code, notably the code
         -- generated for record selectors.  We simply record
@@ -795,7 +796,7 @@ data Sig name
         --       'ApiAnnotation.AnnClose'
 
         -- For details on above see note [Api annotations] in ApiAnnotation
-  | InlineSig   (Located name)  -- Function name
+  | InlineSig   (LEmbellished name)  -- Function name
                 InlinePragma    -- Never defaultInlinePragma
 
         -- | A specialisation pragma
@@ -810,7 +811,7 @@ data Sig name
         --      'ApiAnnotation.AnnDcolon'
 
         -- For details on above see note [Api annotations] in ApiAnnotation
-  | SpecSig     (Located name)     -- Specialise a function or datatype  ...
+  | SpecSig     (LEmbellished name) -- Specialise a function or datatype  ...
                 [LHsSigType name]  -- ... to these types
                 InlinePragma       -- The pragma on SPECIALISE_INLINE form.
                                    -- If it's just defaultInlinePragma, then we said
@@ -839,7 +840,7 @@ data Sig name
         --      'ApiAnnotation.AnnClose'
 
         -- For details on above see note [Api annotations] in ApiAnnotation
-  | MinimalSig SourceText (LBooleanFormula (Located name))
+  | MinimalSig SourceText (LBooleanFormula (LEmbellished name))
                -- Note [Pragma source text] in BasicTypes
 
         -- | A "set cost centre" pragma for declarations
@@ -851,9 +852,11 @@ data Sig name
         -- > {-# SCC funName "cost_centre_name" #-}
 
   | SCCFunSig  SourceText      -- Note [Pragma source text] in BasicTypes
-               (Located name)  -- Function name
+               (LEmbellished name) -- Function name
                (Maybe StringLiteral)
-  | CompleteMatchSig SourceText (Located [Located name]) (Maybe (Located name))
+  | CompleteMatchSig SourceText
+                     (Located [LEmbellished name])
+                     (Maybe (LEmbellished name))
 
 deriving instance (DataId name) => Data (Sig name)
 
@@ -861,7 +864,7 @@ deriving instance (DataId name) => Data (Sig name)
 type LFixitySig name = Located (FixitySig name)
 
 -- | Fixity Signature
-data FixitySig name = FixitySig [Located name] Fixity
+data FixitySig name = FixitySig [LEmbellished name] Fixity
   deriving Data
 
 -- | Type checker Specialisation Pragmas
index e3029a2..4c29f23 100644 (file)
@@ -100,6 +100,7 @@ import Coercion
 import ForeignCall
 import PlaceHolder ( PostTc,PostRn,PlaceHolder(..),DataId, OutputableBndrId )
 import NameSet
+import HsEmbellished
 
 -- others:
 import InstEnv
@@ -1131,7 +1132,7 @@ type LConDecl name = Located (ConDecl name)
 -- | data Constructor Declaration
 data ConDecl name
   = ConDeclGADT
-      { con_names   :: [Located name]
+      { con_names   :: [LEmbellished name]
       , con_type    :: LHsSigType name
         -- ^ The type after the ‘::’
       , con_doc     :: Maybe LHsDocString
@@ -1139,7 +1140,7 @@ data ConDecl name
       }
 
   | ConDeclH98
-      { con_name    :: Located name
+      { con_name    :: LEmbellished name
 
       , con_qvars     :: Maybe (LHsQTyVars name)
         -- User-written forall (if any), and its implicit
@@ -1163,7 +1164,7 @@ deriving instance (DataId name) => Data (ConDecl name)
 type HsConDeclDetails name
    = HsConDetails (LBangType name) (Located [LConDeclField name])
 
-getConNames :: ConDecl name -> [Located name]
+getConNames :: ConDecl name -> [LEmbellished name]
 getConNames ConDeclH98  {con_name  = name}  = [name]
 getConNames ConDeclGADT {con_names = names} = names
 
@@ -1865,7 +1866,7 @@ type LVectDecl name = Located (VectDecl name)
 data VectDecl name
   = HsVect
       SourceText   -- Note [Pragma source text] in BasicTypes
-      (Located name)
+      (LEmbellished name)
       (LHsExpr name)
         -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
         --           'ApiAnnotation.AnnEqual','ApiAnnotation.AnnClose'
@@ -1873,7 +1874,7 @@ data VectDecl name
         -- For details on above see note [Api annotations] in ApiAnnotation
   | HsNoVect
       SourceText   -- Note [Pragma source text] in BasicTypes
-      (Located name)
+      (LEmbellished name)
         -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
         --                                    'ApiAnnotation.AnnClose'
 
@@ -1881,8 +1882,8 @@ data VectDecl name
   | 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
+      (LEmbellished name)
+      (Maybe (LEmbellished name))    -- 'Nothing' => no right-hand side
         -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
         --           'ApiAnnotation.AnnType','ApiAnnotation.AnnClose',
         --           'ApiAnnotation.AnnEqual'
@@ -1894,7 +1895,7 @@ data VectDecl name
       (Maybe TyCon)             -- 'Nothing' => no right-hand side
   | HsVectClassIn               -- pre type-checking
       SourceText                -- Note [Pragma source text] in BasicTypes
-      (Located name)
+      (LEmbellished name)
         -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
         --           'ApiAnnotation.AnnClass','ApiAnnotation.AnnClose',
 
@@ -1908,11 +1909,11 @@ 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 _ (HsVect _       (L _ name) _))    = getName $ unEmb name
+lvectDeclName (L _ (HsNoVect _     (L _ name)))      = getName $ unEmb name
+lvectDeclName (L _ (HsVectTypeIn _  _ (L _ name) _)) = getName $ unEmb name
 lvectDeclName (L _ (HsVectTypeOut  _ tycon _))       = getName tycon
-lvectDeclName (L _ (HsVectClassIn _ (L _ name)))     = getName name
+lvectDeclName (L _ (HsVectClassIn _ (L _ name)))     = getName $ unEmb name
 lvectDeclName (L _ (HsVectClassOut cls))             = getName cls
 lvectDeclName (L _ (HsVectInstIn _))
   = panic "HsDecls.lvectDeclName: HsVectInstIn"
@@ -2009,7 +2010,7 @@ data WarnDecls name = Warnings { wd_src :: SourceText
 type LWarnDecl name = Located (WarnDecl name)
 
 -- | Warning pragma Declaration
-data WarnDecl name = Warning [Located name] WarningTxt
+data WarnDecl name = Warning [LEmbellished name] WarningTxt
   deriving Data
 
 instance OutputableBndr name => Outputable (WarnDecls name) where
@@ -2050,7 +2051,7 @@ instance (OutputableBndrId name) => Outputable (AnnDecl name) where
       = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"]
 
 -- | Annotation Provenance
-data AnnProvenance name = ValueAnnProvenance (Located name)
+data AnnProvenance name = ValueAnnProvenance (LEmbellished name)
                         | TypeAnnProvenance (Located name)
                         | ModuleAnnProvenance
   deriving (Data, Functor)
@@ -2058,7 +2059,7 @@ deriving instance Foldable    AnnProvenance
 deriving instance Traversable AnnProvenance
 
 annProvenanceName_maybe :: AnnProvenance name -> Maybe name
-annProvenanceName_maybe (ValueAnnProvenance (L _ name)) = Just name
+annProvenanceName_maybe (ValueAnnProvenance (L _ name)) = Just $ unEmb name
 annProvenanceName_maybe (TypeAnnProvenance (L _ name))  = Just name
 annProvenanceName_maybe ModuleAnnProvenance       = Nothing
 
@@ -2084,7 +2085,7 @@ type LRoleAnnotDecl name = Located (RoleAnnotDecl name)
 -- top-level declarations
 -- | Role Annotation Declaration
 data RoleAnnotDecl name
-  = RoleAnnotDecl (Located name)         -- type constructor
+  = RoleAnnotDecl (LEmbellished name)         -- type constructor
                   [Located (Maybe Role)] -- optional annotations
       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
       --           'ApiAnnotation.AnnRole'
@@ -2101,4 +2102,4 @@ instance OutputableBndr name => Outputable (RoleAnnotDecl name) where
       pp_role (Just r) = ppr r
 
 roleAnnotDeclName :: RoleAnnotDecl name -> name
-roleAnnotDeclName (RoleAnnotDecl (L _ name) _) = name
+roleAnnotDeclName (RoleAnnotDecl (L _ name) _) = unEmb name
diff --git a/compiler/hsSyn/HsEmbellished.hs b/compiler/hsSyn/HsEmbellished.hs
new file mode 100644 (file)
index 0000000..9f6c8b3
--- /dev/null
@@ -0,0 +1,63 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+module HsEmbellished (
+  Embellished(..),
+  LEmbellished,
+  noEmb,
+  unEmb,
+  unLEmb,
+  unLocEmb,
+  lEmb,
+  reEmb,
+  reLEmb
+  ) where
+
+import SrcLoc
+import Outputable
+
+import Data.Data
+
+-- | An embellished name
+--
+-- The parser can read a RdrName with either parens or backquotes around them.
+-- This type wraps the name and captures whichever embellishment is present.
+data Embellished name
+  = EName       name
+  | EParens     (Located name)
+  | EBackquotes (Located name)
+  deriving (Data, Ord, Eq, Functor, Foldable, Traversable)
+
+type LEmbellished name = Located (Embellished name)
+
+noEmb :: name -> LEmbellished name
+noEmb n = noLoc $ EName n
+
+unEmb :: Embellished name -> name
+unEmb (EName            n)  = n
+unEmb (EParens     (L _ n)) = n
+unEmb (EBackquotes (L _ n)) = n
+
+unLEmb :: LEmbellished name -> Located name
+unLEmb (L l en) = L l (unEmb en)
+
+unLocEmb :: LEmbellished name -> name
+unLocEmb (L _ en) = unEmb en
+
+lEmb :: Located name -> LEmbellished name
+lEmb  (L l n) = L l $ EName n
+
+reEmb :: Embellished name1 -> name2 -> Embellished name2
+reEmb (EName _)             n = EName n
+reEmb (EParens (L l _))     n = EParens (L l n)
+reEmb (EBackquotes (L l _)) n = EBackquotes (L l n)
+
+reLEmb :: LEmbellished name1 -> name2 -> LEmbellished name2
+reLEmb (L l e) n = L l (reEmb e n)
+
+instance (Outputable name) => Outputable (Embellished name) where
+  pprPrec n en = pprPrec n (unEmb en)
+
+instance (OutputableBndr name) => OutputableBndr (Embellished name) where
+  pprPrefixOcc en = pprPrefixOcc (unEmb en)
+  pprInfixOcc  en = pprInfixOcc  (unEmb en)
index 71c4089..0008827 100644 (file)
@@ -41,6 +41,7 @@ import Util
 import Outputable
 import FastString
 import Type
+import HsEmbellished
 
 -- libraries:
 import Data.Data hiding (Fixity(..))
@@ -125,7 +126,7 @@ noSyntaxExpr = SyntaxExpr { syn_expr      = HsLit (HsString NoSourceText
 -- | Make a 'SyntaxExpr Name' (the "rn" is because this is used in the
 -- renamer), missing its HsWrappers.
 mkRnSyntaxExpr :: Name -> SyntaxExpr Name
-mkRnSyntaxExpr name = SyntaxExpr { syn_expr      = HsVar $ noLoc name
+mkRnSyntaxExpr name = SyntaxExpr { syn_expr      = HsVar $ noLoc $ EName name
                                  , syn_arg_wraps = []
                                  , syn_res_wrap  = WpHole }
   -- don't care about filling in syn_arg_wraps because we're clearly
@@ -274,7 +275,7 @@ information to use is the GlobalRdrEnv itself.
 
 -- | A Haskell expression.
 data HsExpr id
-  = HsVar     (Located id)   -- ^ Variable
+  = HsVar     (LEmbellished id)   -- ^ Variable
 
                              -- See Note [Located RdrNames]
 
@@ -667,12 +668,13 @@ data HsExpr id
   -- These constructors only appear temporarily in the parser.
   -- The renamer translates them into the Right Thing.
 
+  -- AZ: TODO: Needs to be embellished too, for backquotes
   | EWildPat                 -- wildcard
 
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt'
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | EAsPat      (Located id) -- as pattern
+  | EAsPat      (LEmbellished id) -- as pattern
                 (LHsExpr id)
 
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'
@@ -2242,7 +2244,7 @@ data HsBracket id = ExpBr (LHsExpr id)   -- [|  expr  |]
                   | DecBrL [LHsDecl id]  -- [d| decls |]; result of parser
                   | DecBrG (HsGroup id)  -- [d| decls |]; result of renamer
                   | TypBr (LHsType id)   -- [t| type  |]
-                  | VarBr Bool id        -- True: 'x, False: ''T
+                  | VarBr Bool (LEmbellished id) -- True: 'x, False: ''T
                                          -- (The Bool flag is used only in pprHsBracket)
                   | TExpBr (LHsExpr id)  -- [||  expr  ||]
 deriving instance (DataId id) => Data (HsBracket id)
@@ -2261,9 +2263,9 @@ pprHsBracket (PatBr p)   = thBrackets (char 'p') (ppr p)
 pprHsBracket (DecBrG gp) = thBrackets (char 'd') (ppr gp)
 pprHsBracket (DecBrL ds) = thBrackets (char 'd') (vcat (map ppr ds))
 pprHsBracket (TypBr t)   = thBrackets (char 't') (ppr t)
-pprHsBracket (VarBr True n)
+pprHsBracket (VarBr True (L _ n))
   = char '\'' <> pprPrefixOcc n
-pprHsBracket (VarBr False n)
+pprHsBracket (VarBr False (L _ n))
   = text "''" <> pprPrefixOcc n
 pprHsBracket (TExpBr e)  = thTyBrackets (ppr e)
 
index 174e837..e3c647a 100644 (file)
@@ -45,6 +45,7 @@ import HsBinds
 import HsLit
 import PlaceHolder
 import HsTypes
+import HsEmbellished
 import TcEvidence
 import BasicTypes
 -- others:
@@ -88,7 +89,7 @@ data Pat id
 
     -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | AsPat       (Located id) (LPat id)  -- ^ As pattern
+  | AsPat       (LEmbellished id) (LPat id)  -- ^ As pattern
     -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt'
 
     -- For details on above see note [Api annotations] in ApiAnnotation
@@ -391,7 +392,7 @@ hsRecFieldSel = fmap selectorFieldOcc . hsRecFieldLbl
 hsRecFieldId :: HsRecField Id arg -> Located Id
 hsRecFieldId = hsRecFieldSel
 
-hsRecUpdFieldRdr :: HsRecUpdField id -> Located RdrName
+hsRecUpdFieldRdr :: HsRecUpdField id -> LEmbellished RdrName
 hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hsRecFieldLbl
 
 hsRecUpdFieldId :: HsRecField' (AmbiguousFieldOcc Id) arg -> Located Id
index e7cae91..4da8cd3 100644 (file)
@@ -27,6 +27,7 @@ module HsSyn (
         module HsUtils,
         module HsDoc,
         module PlaceHolder,
+        module HsEmbellished,
         Fixity,
 
         HsModule(..)
@@ -39,6 +40,7 @@ import HsExpr
 import HsImpExp
 import HsLit
 import PlaceHolder
+import HsEmbellished
 import HsPat
 import HsTypes
 import BasicTypes       ( Fixity, WarningTxt )
index 998f8bd..0df2658 100644 (file)
@@ -86,6 +86,7 @@ import BasicTypes
 import SrcLoc
 import Outputable
 import FastString
+import HsEmbellished
 import Maybes( isJust )
 
 import Data.Data hiding ( Fixity, Prefix, Infix )
@@ -434,7 +435,7 @@ data HsType name
 
   | HsTyVar             Promoted -- whether explicitly promoted, for the pretty
                                  -- printer
-                        (Located name)
+                        (LEmbellished name)
                   -- Type variable, type constructor, or data constructor
                   -- see Note [Promotions (HsTyVar)]
                   -- See Note [Located RdrNames] in HsExpr
@@ -605,7 +606,7 @@ type LHsAppType name = Located (HsAppType name)
 
 -- | Haskell Application Type
 data HsAppType name
-  = HsAppInfix (Located name)       -- either a symbol or an id in backticks
+  = HsAppInfix (LEmbellished name)  -- either a symbol or an id in backticks
   | HsAppPrefix (LHsType name)      -- anything else, including things like (+)
 deriving instance (DataId name) => Data (HsAppType name)
 
@@ -884,9 +885,10 @@ hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs)
 -- | Convert a LHsTyVarBndr to an equivalent LHsType.
 hsLTyVarBndrToType :: LHsTyVarBndr name -> LHsType name
 hsLTyVarBndrToType = fmap cvt
-  where cvt (UserTyVar n) = HsTyVar NotPromoted n
+  where cvt (UserTyVar n) = HsTyVar NotPromoted (lEmb n)
         cvt (KindedTyVar (L name_loc n) kind)
-          = HsKindSig (L name_loc (HsTyVar NotPromoted (L name_loc n))) kind
+          = HsKindSig (L name_loc (HsTyVar NotPromoted (L name_loc $ EName n)))
+                                                        kind
 
 -- | Convert a LHsTyVarBndrs to a list of types.
 -- Works on *type* variable only, no kind vars.
@@ -953,7 +955,7 @@ splitHsFunType (L _ (HsFunTy x y))
 splitHsFunType orig_ty@(L _ (HsAppTy t1 t2))
   = go t1 [t2]
   where  -- Look for (->) t1 t2, possibly with parenthesisation
-    go (L _ (HsTyVar _ (L _ fn))) tys | fn == funTyConName
+    go (L _ (HsTyVar _ (L _ fn))) tys | unEmb fn == funTyConName
                                  , [t1,t2] <- tys
                                  , (args, res) <- splitHsFunType t2
                                  = (t1:args, res)
@@ -983,7 +985,7 @@ getAppsTyHead_maybe tys = case splitHsAppsTy tys of
 -- element of @non_syms@ followed by the first element of @syms@ followed by
 -- the next element of @non_syms@, etc. It is guaranteed that the non_syms list
 -- has one more element than the syms list.
-splitHsAppsTy :: [LHsAppType name] -> ([[LHsType name]], [Located name])
+splitHsAppsTy :: [LHsAppType name] -> ([[LHsType name]], [LEmbellished name])
 splitHsAppsTy = go [] [] []
   where
     go acc acc_non acc_sym [] = (reverse (reverse acc : acc_non), reverse acc_sym)
@@ -999,7 +1001,7 @@ splitHsAppsTy = go [] [] []
 hsTyGetAppHead_maybe :: LHsType name -> Maybe (Located name, [LHsType name])
 hsTyGetAppHead_maybe = go []
   where
-    go tys (L _ (HsTyVar _ ln))          = Just (ln, tys)
+    go tys (L _ (HsTyVar _ ln))          = Just (unLEmb ln, tys)
     go tys (L _ (HsAppsTy apps))
       | Just (head, args, _) <- getAppsTyHead_maybe apps
                                          = go (args ++ tys) head
@@ -1081,7 +1083,7 @@ type LFieldOcc name = Located (FieldOcc name)
 -- Represents an *occurrence* of an unambiguous field.  We store
 -- both the 'RdrName' the user originally wrote, and after the
 -- renamer, the selector function.
-data FieldOcc name = FieldOcc { rdrNameFieldOcc  :: Located RdrName
+data FieldOcc name = FieldOcc { rdrNameFieldOcc  :: LEmbellished RdrName
                                  -- ^ See Note [Located RdrNames] in HsExpr
                               , selectorFieldOcc :: PostRn name name
                               }
@@ -1092,7 +1094,7 @@ deriving instance (Data name, Data (PostRn name name)) => Data (FieldOcc name)
 instance Outputable (FieldOcc name) where
   ppr = ppr . rdrNameFieldOcc
 
-mkFieldOcc :: Located RdrName -> FieldOcc RdrName
+mkFieldOcc :: LEmbellished RdrName -> FieldOcc RdrName
 mkFieldOcc rdr = FieldOcc rdr PlaceHolder
 
 
@@ -1109,8 +1111,8 @@ mkFieldOcc rdr = FieldOcc rdr PlaceHolder
 -- Note [Disambiguating record fields] in TcExpr.
 -- See Note [Located RdrNames] in HsExpr
 data AmbiguousFieldOcc name
-  = Unambiguous (Located RdrName) (PostRn name name)
-  | Ambiguous   (Located RdrName) (PostTc name name)
+  = Unambiguous (LEmbellished RdrName) (PostRn name name)
+  | Ambiguous   (LEmbellished RdrName) (PostTc name name)
 deriving instance ( Data name
                   , Data (PostRn name name)
                   , Data (PostTc name name))
@@ -1124,9 +1126,9 @@ instance OutputableBndr (AmbiguousFieldOcc name) where
   pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc
 
 mkAmbiguousFieldOcc :: Located RdrName -> AmbiguousFieldOcc RdrName
-mkAmbiguousFieldOcc rdr = Unambiguous rdr PlaceHolder
+mkAmbiguousFieldOcc rdr = Unambiguous (lEmb rdr) PlaceHolder
 
-rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc name -> RdrName
+rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc name -> Embellished RdrName
 rdrNameAmbiguousFieldOcc (Unambiguous (L _ rdr) _) = rdr
 rdrNameAmbiguousFieldOcc (Ambiguous   (L _ rdr) _) = rdr
 
index 8001a15..e067d93 100644 (file)
@@ -120,6 +120,7 @@ import Util
 import Bag
 import Outputable
 import Constants
+import HsEmbellished
 
 import Data.Either
 import Data.Function
@@ -196,7 +197,7 @@ mkHsCaseAlt pat expr
   = mkSimpleMatch CaseAlt [pat] expr
 
 nlHsTyApp :: name -> [Type] -> LHsExpr name
-nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar (noLoc fun_id)))
+nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar (noEmb fun_id)))
 
 nlHsTyApps :: name -> [Type] -> [LHsExpr name] -> LHsExpr name
 nlHsTyApps fun_id tys xs = foldl nlHsApp (nlHsTyApp fun_id tys) xs
@@ -315,7 +316,7 @@ mkRecStmt stmts  = emptyRecStmt { recS_stmts = stmts }
 --- A useful function for building @OpApps@.  The operator is always a
 -- variable, and we don't know the fixity yet.
 mkHsOpApp :: LHsExpr id -> id -> LHsExpr id -> HsExpr id
-mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar (noLoc op)))
+mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar (noEmb op)))
                            (error "mkOpApp:fixity") e2
 
 unqualSplice :: RdrName
@@ -368,7 +369,7 @@ userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar (L loc v)) | v <- bndrs ]
 -}
 
 nlHsVar :: id -> LHsExpr id
-nlHsVar n = noLoc (HsVar (noLoc n))
+nlHsVar n = noLoc (HsVar (noEmb n))
 
 -- NB: Only for LHsExpr **Id**
 nlHsDataCon :: DataCon -> LHsExpr Id
@@ -405,7 +406,7 @@ nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
 nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
 
 nlHsVarApps :: id -> [id] -> LHsExpr id
-nlHsVarApps f xs = noLoc (foldl mk (HsVar (noLoc f)) (map (HsVar . noLoc) xs))
+nlHsVarApps f xs = noLoc (foldl mk (HsVar (noEmb f)) (map (HsVar . noEmb) xs))
                  where
                    mk f a = HsApp (noLoc f) (noLoc a)
 
@@ -472,7 +473,7 @@ nlHsFunTy :: LHsType name -> LHsType name -> LHsType name
 nlHsParTy :: LHsType name                 -> LHsType name
 
 nlHsAppTy f t           = noLoc (HsAppTy f t)
-nlHsTyVar x             = noLoc (HsTyVar NotPromoted (noLoc x))
+nlHsTyVar x             = noLoc (HsTyVar NotPromoted (noEmb x))
 nlHsFunTy a b           = noLoc (HsFunTy a b)
 nlHsParTy t             = noLoc (HsParTy t)
 
@@ -722,7 +723,7 @@ mkVarBind :: id -> LHsExpr id -> LHsBind id
 mkVarBind var rhs = L (getLoc rhs) $
                     VarBind { var_id = var, var_rhs = rhs, var_inline = False }
 
-mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName)
+mkPatSynBind :: LEmbellished RdrName -> HsPatSynDetails (Located RdrName)
              -> LPat RdrName -> HsPatSynDir RdrName -> HsBind RdrName
 mkPatSynBind name details lpat dir = PatSynBind psb
   where
@@ -891,7 +892,7 @@ collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++
 collect_bind _ (AbsBindsSig { abs_sig_export = poly }) acc = poly : acc
 collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc
   | omitPatSyn                  = acc
-  | otherwise                   = ps : acc
+  | otherwise                   = unEmb ps : acc
 
 collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName]
 -- Used exclusively for the bindings of an instance decl which are all FunBinds
@@ -940,7 +941,7 @@ collect_lpat (L _ pat) bndrs
     go (WildPat _)                = bndrs
     go (LazyPat pat)              = collect_lpat pat bndrs
     go (BangPat pat)              = collect_lpat pat bndrs
-    go (AsPat (L _ a) pat)        = a : collect_lpat pat bndrs
+    go (AsPat (L _ a) pat)        = unEmb a : collect_lpat pat bndrs
     go (ViewPat _ pat _)          = collect_lpat pat bndrs
     go (ParPat  pat)              = collect_lpat pat bndrs
 
@@ -1007,11 +1008,13 @@ hsTyClForeignBinders tycl_decls foreign_decls
          `mappend`
          foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls)
   where
-    getSelectorNames :: ([Located Name], [LFieldOcc Name]) -> [Name]
-    getSelectorNames (ns, fs) = map unLoc ns ++ map (selectorFieldOcc.unLoc) fs
+    getSelectorNames :: ([LEmbellished Name], [LFieldOcc Name]) -> [Name]
+    getSelectorNames (ns, fs)
+      = map unLocEmb ns ++ map (selectorFieldOcc.unLoc) fs
 
 -------------------
-hsLTyClDeclBinders :: Located (TyClDecl name) -> ([Located name], [LFieldOcc name])
+hsLTyClDeclBinders :: Located (TyClDecl name)
+                   -> ([LEmbellished name], [LFieldOcc name])
 -- ^ Returns all the /binding/ names of the decl.  The first one is
 
 -- guaranteed to be the name of the decl. The first component
@@ -1023,16 +1026,19 @@ hsLTyClDeclBinders :: Located (TyClDecl name) -> ([Located name], [LFieldOcc nam
 -- See Note [SrcSpan for binders]
 
 hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl { fdLName = L _ name } }))
-  = ([L loc name], [])
-hsLTyClDeclBinders (L loc (SynDecl     { tcdLName = L _ name })) = ([L loc name], [])
+  = ([L loc $ EName name], [])
+hsLTyClDeclBinders (L loc (SynDecl     { tcdLName = L _ name }))
+  = ([L loc (EName name)], [])
 hsLTyClDeclBinders (L loc (ClassDecl   { tcdLName = L _ cls_name
                                        , tcdSigs = sigs, tcdATs = ats }))
-  = (L loc cls_name :
-     [ L fam_loc fam_name | L fam_loc (FamilyDecl { fdLName = L _ fam_name }) <- ats ] ++
-     [ L mem_loc mem_name | L mem_loc (ClassOpSig False ns _) <- sigs, L _ mem_name <- ns ]
+  = (L loc (EName cls_name) :
+     [ L fam_loc (EName fam_name) |
+                 L fam_loc (FamilyDecl { fdLName = L _ fam_name }) <- ats ] ++
+     [ L mem_loc (EName mem_name) | L mem_loc (ClassOpSig False ns _) <- sigs
+                          , L _ mem_name <- (map unLEmb ns) ]
     , [])
 hsLTyClDeclBinders (L loc (DataDecl    { tcdLName = L _ name, tcdDataDefn = defn }))
-  = (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn
+  = (\ (xs, ys) -> (L loc (EName name) : xs, ys)) $ hsDataDefnBinders defn
 
 -------------------
 hsForeignDeclsBinders :: [LForeignDecl name] -> [Located name]
@@ -1062,7 +1068,7 @@ getPatSynBinds binds
           , L _ (PatSynBind psb) <- bagToList lbinds ]
 
 -------------------
-hsLInstDeclBinders :: LInstDecl name -> ([Located name], [LFieldOcc name])
+hsLInstDeclBinders :: LInstDecl name -> ([LEmbellished name], [LFieldOcc name])
 hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } }))
   = foldMap (hsDataFamInstBinders . unLoc) dfis
 hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi }))
@@ -1071,26 +1077,27 @@ hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty
 
 -------------------
 -- the SrcLoc returned are for the whole declarations, not just the names
-hsDataFamInstBinders :: DataFamInstDecl name -> ([Located name], [LFieldOcc name])
+hsDataFamInstBinders :: DataFamInstDecl name
+                     -> ([LEmbellished name], [LFieldOcc name])
 hsDataFamInstBinders (DataFamInstDecl { dfid_defn = defn })
   = hsDataDefnBinders defn
   -- There can't be repeated symbols because only data instances have binders
 
 -------------------
 -- the SrcLoc returned are for the whole declarations, not just the names
-hsDataDefnBinders :: HsDataDefn name -> ([Located name], [LFieldOcc name])
+hsDataDefnBinders :: HsDataDefn name -> ([LEmbellished name], [LFieldOcc name])
 hsDataDefnBinders (HsDataDefn { dd_cons = cons })
   = hsConDeclsBinders cons
   -- See Note [Binders in family instances]
 
 -------------------
-hsConDeclsBinders :: [LConDecl name] -> ([Located name], [LFieldOcc name])
+hsConDeclsBinders :: [LConDecl name] -> ([LEmbellished name], [LFieldOcc name])
   -- See hsLTyClDeclBinders for what this does
   -- The function is boringly complicated because of the records
   -- And since we only have equality, we have to be a little careful
 hsConDeclsBinders cons = go id cons
   where go :: ([LFieldOcc name] -> [LFieldOcc name])
-           -> [LConDecl name] -> ([Located name], [LFieldOcc name])
+           -> [LConDecl name] -> ([LEmbellished name], [LFieldOcc name])
         go _ [] = ([], [])
         go remSeen (r:rs) =
           -- don't re-mangle the location of field names, because we don't
@@ -1112,7 +1119,8 @@ hsConDeclsBinders cons = go id cons
                             where (ns, fs) = go remSeen rs
                where
                  (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty
-                 record_gadt flds = (map (L loc . unLoc) names ++ ns, r' ++ fs)
+                 record_gadt flds = (map (L loc . unLoc) names ++ ns
+                                    , r' ++ fs)
                    where r' = remSeen (concatMap (cd_fld_names . unLoc) flds)
                          remSeen' = foldr (.) remSeen
                                         [deleteBy ((==) `on`
index 6e6ac04..0837438 100644 (file)
@@ -1678,7 +1678,7 @@ hscParseStmtWithLocation source linenumber stmt =
 hscParseType :: String -> Hsc (LHsType RdrName)
 hscParseType = hscParseThing parseType
 
-hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName)
+hscParseIdentifier :: HscEnv -> String -> IO (LEmbellished RdrName)
 hscParseIdentifier hsc_env str =
     runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str
 
index 1fa2698..dfab3d4 100644 (file)
@@ -775,7 +775,7 @@ getRdrNamesInScope = withSession $ \hsc_env -> do
 parseName :: GhcMonad m => String -> m [Name]
 parseName str = withSession $ \hsc_env -> liftIO $
    do { lrdr_name <- hscParseIdentifier hsc_env str
-      ; hscTcRnLookupRdrName hsc_env lrdr_name }
+      ; hscTcRnLookupRdrName hsc_env $ unLEmb lrdr_name }
 
 -- | Returns @True@ if passed string is a statement.
 isStmt :: DynFlags -> String -> Bool
@@ -890,7 +890,8 @@ dynCompileExpr expr = do
   parsed_expr <- parseExpr expr
   -- > Data.Dynamic.toDyn expr
   let loc = getLoc parsed_expr
-      to_dyn_expr = mkHsApp (L loc . HsVar . L loc $ getRdrName toDynName)
+      to_dyn_expr = mkHsApp (L loc . HsVar . L loc $ EName
+                                                        $ getRdrName toDynName)
                             parsed_expr
   hval <- compileParsedExpr to_dyn_expr
   return (unsafeCoerce# hval :: Dynamic)
index b20f23f..9d289d0 100644 (file)
@@ -242,7 +242,6 @@ data AnnKeywordId
     | AnnMinus -- ^ '-'
     | AnnModule
     | AnnNewtype
-    | AnnName -- ^ where a name loses its location in the AST, this carries it
     | AnnOf
     | AnnOpen   -- ^ '(\#' or '{-\# LANGUAGE' etc
     | AnnOpenC   -- ^ '{'
index 175cfbb..82c6961 100644 (file)
@@ -552,12 +552,12 @@ TH_QQUASIQUOTE  { L _ (ITqQuasiQuote _) }
 
 -----------------------------------------------------------------------------
 -- Identifiers; one of the entry points
-identifier :: { Located RdrName }
+identifier :: { Located (Embellished RdrName) }
         : qvar                          { $1 }
         | qcon                          { $1 }
         | qvarop                        { $1 }
         | qconop                        { $1 }
-    | '(' '->' ')'      {% ams (sLL $1 $> $ getRdrName funTyCon)
+    | '(' '->' ')'      {% ams (sLL $1 $> $ EName $ getRdrName funTyCon)
                                [mj AnnOpenP $1,mu AnnRarrow $2,mj AnnCloseP $3] }
 
 -----------------------------------------------------------------------------
@@ -793,7 +793,7 @@ export  :: { OrdList (LIE RdrName) }
                                           >>= \ie -> amsu (sLL $1 $> ie) (fst $ unLoc $2) }
         |  'module' modid            {% amsu (sLL $1 $> (IEModuleContents $2))
                                              [mj AnnModule $1] }
-        |  'pattern' qcon            {% amsu (sLL $1 $> (IEVar (sLL $1 $> (IEPattern $2))))
+        |  'pattern' qcon            {% amsu (sLL $1 $> (IEVar (sLL $1 $> (IEPattern $ unLEmb $2))))
                                              [mj AnnPattern $1] }
 
 export_subspec :: { Located ([AddAnn],ImpExpSubSpec) }
@@ -827,12 +827,12 @@ qcname_ext_w_wildcard :: { Located ([AddAnn], Located ImpExpQcSpec) }
         |  '..'                     { sL1 $1 ([mj AnnDotdot $1], sL1 $1 ImpExpQcWildcard)  }
 
 qcname_ext :: { Located ImpExpQcSpec }
-        :  qcname                   { sL1 $1 (ImpExpQcName $1) }
-        |  'type' oqtycon           {% do { n <- mkTypeImpExp $2
+        :  qcname                   { sL1 $1 (ImpExpQcName (unLEmb $1)) }
+        |  'type' oqtycon           {% do { n <- mkTypeImpExp (unLEmb $2)
                                           ; ams (sLL $1 $> (ImpExpQcType n))
                                                 [mj AnnType $1] } }
 
-qcname  :: { Located RdrName }  -- Variable or type constructor
+qcname  :: { Located (Embellished RdrName) }  -- Variable or type constructor
         :  qvar                 { $1 } -- Things which look like functions
                                        -- Note: This includes record selectors but
                                        -- also (-.->), see #11432
@@ -935,7 +935,7 @@ infix   :: { Located FixityDirection }
         | 'infixl'                              { sL1 $1 InfixL  }
         | 'infixr'                              { sL1 $1 InfixR }
 
-ops     :: { Located (OrdList (Located RdrName)) }
+ops     :: { Located (OrdList (Located (Embellished RdrName))) }
         : ops ',' op       {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >>
                               return (sLL $1 $> ((unLoc $1) `appOL` unitOL $3))}
         | op               { sL1 $1 (unitOL $1) }
@@ -1352,7 +1352,7 @@ pattern_synonym_decl :: { LHsDecl RdrName }
                        (as ++ ((mj AnnPattern $1:mu AnnLarrow $3:(fst $ unLoc $5))) )
                    }}
 
-pattern_synonym_lhs :: { (Located RdrName, HsPatSynDetails (Located RdrName), [AddAnn]) }
+pattern_synonym_lhs :: { (Located (Embellished RdrName), HsPatSynDetails (Located RdrName), [AddAnn]) }
         : con vars0 { ($1, PrefixPatSyn $2, []) }
         | varid conop varid { ($2, InfixPatSyn $1 $3, []) }
         | con '{' cvars1 '}' { ($1, RecordPatSyn $3, [moc $2, mcc $4] ) }
@@ -1656,9 +1656,9 @@ fspec :: { Located ([AddAnn]
                     ,(Located StringLiteral, Located RdrName, LHsSigType RdrName)) }
        : STRING var '::' sigtypedoc     { sLL $1 $> ([mu AnnDcolon $3]
                                              ,(L (getLoc $1)
-                                                    (getStringLiteral $1), $2, mkLHsSigType $4)) }
+                                                    (getStringLiteral $1), unLEmb $2, mkLHsSigType $4)) }
        |        var '::' sigtypedoc     { sLL $1 $> ([mu AnnDcolon $2]
-                                             ,(noLoc (StringLiteral NoSourceText nilFS), $1, mkLHsSigType $3)) }
+                                             ,(noLoc (StringLiteral NoSourceText nilFS), unLEmb $1, mkLHsSigType $3)) }
          -- if the entity string is missing, it defaults to the empty string;
          -- the meaning of an empty entity string depends on the calling
          -- convention
@@ -1674,7 +1674,7 @@ opt_asig :: { ([AddAnn],Maybe (LHsType RdrName)) }
         : {- empty -}                   { ([],Nothing) }
         | '::' atype                    { ([mu AnnDcolon $1],Just $2) }
 
-opt_tyconsig :: { ([AddAnn], Maybe (Located RdrName)) }
+opt_tyconsig :: { ([AddAnn], Maybe (Located (Embellished RdrName))) }
              : {- empty -}              { ([], Nothing) }
              | '::' gtycon              { ([mu AnnDcolon $1], Just $2) }
 
@@ -1685,7 +1685,7 @@ sigtypedoc :: { LHsType RdrName }
         : ctypedoc                         { $1 }
 
 
-sig_vars :: { Located [Located RdrName] }    -- Returned in reversed order
+sig_vars :: { Located [Located (Embellished RdrName)] }    -- Returned in reversed order
          : sig_vars ',' var           {% addAnnotation (gl $ head $ unLoc $1)
                                                        AnnComma (gl $2)
                                          >> return (sLL $1 $> ($3 : unLoc $1)) }
@@ -1846,8 +1846,8 @@ tyapp :: { LHsAppType RdrName }
                                                [mj AnnSimpleQuote $1] }
 
 atype :: { LHsType RdrName }
-        : ntgtycon                       { sL1 $1 (HsTyVar NotPromoted $1) }      -- Not including unit tuples
-        | tyvar                          { sL1 $1 (HsTyVar NotPromoted $1) }      -- (See Note [Unit tuples])
+        : ntgtycon                       { sL1 $1 (HsTyVar NotPromoted $1) }        -- Not including unit tuples
+        | tyvar                          { sL1 $1 (HsTyVar NotPromoted (lEmb $1)) } -- (See Note [Unit tuples])
         | strict_mark atype              {% ams (sLL $1 $> (HsBangTy (snd $ unLoc $1) $2))
                                                 (fst $ unLoc $1) }  -- Constructor sigs only
         | '{' fielddecls '}'             {% amms (checkRecordSyntax
@@ -1877,10 +1877,10 @@ atype :: { LHsType RdrName }
         | '$(' exp ')'                {% ams (sLL $1 $> $ mkHsSpliceTy HasParens $2)
                                              [mj AnnOpenPE $1,mj AnnCloseP $3] }
         | TH_ID_SPLICE                {%ams (sLL $1 $> $ mkHsSpliceTy NoParens $ sL1 $1 $ HsVar $
-                                             (sL1 $1 (mkUnqual varName (getTH_ID_SPLICE $1))))
+                                             (sL1 $1 (EName $ mkUnqual varName (getTH_ID_SPLICE $1))))
                                              [mj AnnThIdSplice $1] }
                                       -- see Note [Promotion] for the followings
-        | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar Promoted $2) [mj AnnSimpleQuote $1,mj AnnName $2] }
+        | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar Promoted $2) [mj AnnSimpleQuote $1] }
         | SIMPLEQUOTE  '(' ctype ',' comma_types1 ')'
                              {% addAnnotation (gl $3) AnnComma (gl $4) >>
                                 ams (sLL $1 $> $ HsExplicitTupleTy [] ($3 : $5))
@@ -1889,7 +1889,7 @@ atype :: { LHsType RdrName }
                                                             placeHolderKind $3)
                                                        [mj AnnSimpleQuote $1,mos $2,mcs $4] }
         | SIMPLEQUOTE var                       {% ams (sLL $1 $> $ HsTyVar Promoted $2)
-                                                       [mj AnnSimpleQuote $1,mj AnnName $2] }
+                                                       [mj AnnSimpleQuote $1] }
 
         -- Two or more [ty, ty, ty] must be a promoted list type, just as
         -- if you had written '[ty, ty, ty]
@@ -2089,7 +2089,7 @@ forall :: { Located ([AddAnn], Maybe [LHsTyVarBndr RdrName]) }
         : 'forall' tv_bndrs '.'       { sLL $1 $> ([mu AnnForall $1,mj AnnDot $3], Just $2) }
         | {- empty -}                 { noLoc ([], Nothing) }
 
-constr_stuff :: { Located (Located RdrName, HsConDeclDetails RdrName) }
+constr_stuff :: { Located (LEmbellished RdrName, HsConDeclDetails RdrName) }
     -- See Note [Parsing data constructors is hard] in RdrHsSyn
         : btype_no_ops                         {% do { c <- splitCon $1
                                                      ; return $ sLL $1 $> c } }
@@ -2181,7 +2181,7 @@ docdecld :: { LDocDecl }
 decl_no_th :: { LHsDecl RdrName }
         : sigdecl               { $1 }
 
-        | '!' aexp rhs          {% do { let { e = sLL $1 $2 (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2) };
+        | '!' aexp rhs          {% do { let { e = sLL $1 $2 (SectionR (sL1 $1 (HsVar (sL1 $1 $ EName bang_RDR))) $2) };
                                         pat <- checkPattern empty e;
                                         _ <- ams (sLL $1 $> ())
                                                (fst $ unLoc $3);
@@ -2517,10 +2517,10 @@ aexp2   :: { LHsExpr RdrName }
         -- Template Haskell Extension
         | splice_exp            { $1 }
 
-        | SIMPLEQUOTE  qvar     {% ams (sLL $1 $> $ HsBracket (VarBr True  (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }
-        | SIMPLEQUOTE  qcon     {% ams (sLL $1 $> $ HsBracket (VarBr True  (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }
-        | TH_TY_QUOTE tyvar     {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }
-        | TH_TY_QUOTE gtycon    {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }
+        | SIMPLEQUOTE  qvar     {% ams (sLL $1 $> $ HsBracket (VarBr True  $2)       ) [mj AnnSimpleQuote $1] }
+        | SIMPLEQUOTE  qcon     {% ams (sLL $1 $> $ HsBracket (VarBr True  $2)       ) [mj AnnSimpleQuote $1] }
+        | TH_TY_QUOTE tyvar     {% ams (sLL $1 $> $ HsBracket (VarBr False (lEmb $2))) [mj AnnThTyQuote $1] }
+        | TH_TY_QUOTE gtycon    {% ams (sLL $1 $> $ HsBracket (VarBr False $2)) [mj AnnThTyQuote $1] }
         | '[|' exp '|]'       {% ams (sLL $1 $> $ HsBracket (ExpBr $2))
                                       (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) }
         | '[||' exp '||]'     {% ams (sLL $1 $> $ HsBracket (TExpBr $2))
@@ -2540,13 +2540,13 @@ aexp2   :: { LHsExpr RdrName }
 
 splice_exp :: { LHsExpr RdrName }
         : TH_ID_SPLICE          {% ams (sL1 $1 $ mkHsSpliceE NoParens
-                                        (sL1 $1 $ HsVar (sL1 $1 (mkUnqual varName
+                                        (sL1 $1 $ HsVar (sL1 $1 (EName $ mkUnqual varName
                                                            (getTH_ID_SPLICE $1)))))
                                        [mj AnnThIdSplice $1] }
         | '$(' exp ')'          {% ams (sLL $1 $> $ mkHsSpliceE HasParens $2)
                                        [mj AnnOpenPE $1,mj AnnCloseP $3] }
         | TH_ID_TY_SPLICE       {% ams (sL1 $1 $ mkHsSpliceTE NoParens
-                                        (sL1 $1 $ HsVar (sL1 $1 (mkUnqual varName
+                                        (sL1 $1 $ HsVar (sL1 $1 (EName $ mkUnqual varName
                                                         (getTH_ID_TY_SPLICE $1)))))
                                        [mj AnnThIdTySplice $1] }
         | '$$(' exp ')'         {% ams (sLL $1 $> $ mkHsSpliceTE HasParens $2)
@@ -2821,7 +2821,7 @@ gdpat   :: { LGRHS RdrName (LHsExpr RdrName) }
 pat     :: { LPat RdrName }
 pat     :  exp          {% checkPattern empty $1 }
         | '!' aexp      {% amms (checkPattern empty (sLL $1 $> (SectionR
-                                                     (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2)))
+                                                     (sL1 $1 (HsVar (sL1 $1 $ EName bang_RDR))) $2)))
                                 [mj AnnBang $1] }
 
 bindpat :: { LPat RdrName }
@@ -2829,14 +2829,14 @@ bindpat :  exp            {% checkPattern
                                 (text "Possibly caused by a missing 'do'?") $1 }
         | '!' aexp        {% amms (checkPattern
                                      (text "Possibly caused by a missing 'do'?")
-                                     (sLL $1 $> (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2)))
+                                     (sLL $1 $> (SectionR (sL1 $1 (HsVar (sL1 $1 $ EName bang_RDR))) $2)))
                                   [mj AnnBang $1] }
 
 apat   :: { LPat RdrName }
 apat    : aexp                  {% checkPattern empty $1 }
         | '!' aexp              {% amms (checkPattern empty
                                             (sLL $1 $> (SectionR
-                                                (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2)))
+                                                (sL1 $1 (HsVar (sL1 $1 $ EName bang_RDR))) $2)))
                                         [mj AnnBang $1] }
 
 apats  :: { [LPat RdrName] }
@@ -2948,31 +2948,31 @@ overloaded_label :: { Located FastString }
 -----------------------------------------------------------------------------
 -- Warnings and deprecations
 
-name_boolformula_opt :: { LBooleanFormula (Located RdrName) }
+name_boolformula_opt :: { LBooleanFormula (LEmbellished RdrName) }
         : name_boolformula          { $1 }
         | {- empty -}               { noLoc mkTrue }
 
-name_boolformula :: { LBooleanFormula (Located RdrName) }
+name_boolformula :: { LBooleanFormula (LEmbellished RdrName) }
         : name_boolformula_and                      { $1 }
         | name_boolformula_and '|' name_boolformula
                            {% aa $1 (AnnVbar, $2)
                               >> return (sLL $1 $> (Or [$1,$3])) }
 
-name_boolformula_and :: { LBooleanFormula (Located RdrName) }
+name_boolformula_and :: { LBooleanFormula (LEmbellished RdrName) }
         : name_boolformula_atom                             { $1 }
         | name_boolformula_atom ',' name_boolformula_and
                   {% aa $1 (AnnComma,$2) >> return (sLL $1 $> (And [$1,$3])) }
 
-name_boolformula_atom :: { LBooleanFormula (Located RdrName) }
+name_boolformula_atom :: { LBooleanFormula (LEmbellished RdrName) }
         : '(' name_boolformula ')'  {% ams (sLL $1 $> (Parens $2)) [mop $1,mcp $3] }
         | name_var                  { sL1 $1 (Var $1) }
 
-namelist :: { Located [Located RdrName] }
+namelist :: { Located [Located (Embellished RdrName)] }
 namelist : name_var              { sL1 $1 [$1] }
          | name_var ',' namelist {% addAnnotation (gl $1) AnnComma (gl $2) >>
                                     return (sLL $1 $> ($1 : unLoc $3)) }
 
-name_var :: { Located RdrName }
+name_var :: { Located (Embellished RdrName) }
 name_var : var { $1 }
          | con { $1 }
 
@@ -2981,28 +2981,28 @@ name_var : var { $1 }
 -- There are two different productions here as lifted list constructors
 -- are parsed differently.
 
-qcon_nowiredlist :: { Located RdrName }
+qcon_nowiredlist :: { Located (Embellished RdrName) }
         : gen_qcon                     { $1 }
-        | sysdcon_nolist               { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) }
+        | sysdcon_nolist               { sL1 $1 $ EName $ nameRdrName (dataConName (unLoc $1)) }
 
-qcon :: { Located RdrName }
+qcon :: { Located (Embellished RdrName) }
   : gen_qcon              { $1}
-  | sysdcon               { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) }
+  | sysdcon               { sL1 $1 $ EParens $ sL1 $1 $ nameRdrName (dataConName (unLoc $1)) }
 
-gen_qcon :: { Located RdrName }
-  : qconid                { $1 }
-  | '(' qconsym ')'       {% ams (sLL $1 $> (unLoc $2))
-                                   [mop $1,mj AnnVal $2,mcp $3] }
+gen_qcon :: { Located (Embellished RdrName) }
+  : qconid                { sL1 $1 (EName $ unLoc $1) }
+  | '(' qconsym ')'       {% ams (sLL $1 $> (EParens $2))
+                                   [mop $1,mcp $3] }
 
 -- The case of '[:' ':]' is part of the production `parr'
 
-con     :: { Located RdrName }
-        : conid                 { $1 }
-        | '(' consym ')'        {% ams (sLL $1 $> (unLoc $2))
-                                       [mop $1,mj AnnVal $2,mcp $3] }
-        | sysdcon               { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) }
+con     :: { Located (Embellished RdrName) }
+        : conid                 { sL1 $1 (EName (unLoc $1)) }
+        | '(' consym ')'        {% ams (sLL $1 $> (EParens $2))
+                                       [mop $1,mcp $3] }
+        | sysdcon               { sL1 $1 $ EName $ nameRdrName (dataConName (unLoc $1)) }
 
-con_list :: { Located [Located RdrName] }
+con_list :: { Located [Located (Embellished RdrName)] }
 con_list : con                  { sL1 $1 [$1] }
          | con ',' con_list     {% addAnnotation (gl $1) AnnComma (gl $2) >>
                                    return (sLL $1 $> ($1 : unLoc $3)) }
@@ -3019,16 +3019,16 @@ sysdcon :: { Located DataCon }
         : sysdcon_nolist                 { $1 }
         | '[' ']'               {% ams (sLL $1 $> nilDataCon) [mos $1,mcs $2] }
 
-conop :: { Located RdrName }
-        : consym                { $1 }
-        | '`' conid '`'         {% ams (sLL $1 $> (unLoc $2))
-                                       [mj AnnBackquote $1,mj AnnVal $2
+conop :: { Located (Embellished RdrName) }
+        : consym                { sL1 $1 (EName (unLoc $1)) }
+        | '`' conid '`'         {% ams (sLL $1 $> (EBackquotes $2))
+                                       [mj AnnBackquote $1
                                        ,mj AnnBackquote $3] }
 
-qconop :: { Located RdrName }
-        : qconsym               { $1 }
-        | '`' qconid '`'        {% ams (sLL $1 $> (unLoc $2))
-                                       [mj AnnBackquote $1,mj AnnVal $2
+qconop :: { Located (Embellished RdrName) }
+        : qconsym               { sL1 $1 $ (EName $ unLoc $1) }
+        | '`' qconid '`'        {% ams (sLL $1 $> (EBackquotes $2))
+                                       [mj AnnBackquote $1
                                        ,mj AnnBackquote $3] }
 
 ----------------------------------------------------------------------------
@@ -3037,47 +3037,47 @@ qconop :: { Located RdrName }
 
 -- See Note [Unit tuples] in HsTypes for the distinction
 -- between gtycon and ntgtycon
-gtycon :: { Located RdrName }  -- A "general" qualified tycon, including unit tuples
+gtycon :: { Located (Embellished RdrName) }  -- A "general" qualified tycon, including unit tuples
         : ntgtycon                     { $1 }
-        | '(' ')'                      {% ams (sLL $1 $> $ getRdrName unitTyCon)
+        | '(' ')'                      {% ams (sLL $1 $> $ EName $ getRdrName unitTyCon)
                                               [mop $1,mcp $2] }
-        | '(#' '#)'                    {% ams (sLL $1 $> $ getRdrName unboxedUnitTyCon)
+        | '(#' '#)'                    {% ams (sLL $1 $> $ EName $ getRdrName unboxedUnitTyCon)
                                               [mo $1,mc $2] }
 
-ntgtycon :: { Located RdrName }  -- A "general" qualified tycon, excluding unit tuples
+ntgtycon :: { Located (Embellished RdrName) }  -- A "general" qualified tycon, excluding unit tuples
         : oqtycon               { $1 }
-        | '(' commas ')'        {% ams (sLL $1 $> $ getRdrName (tupleTyCon Boxed
+        | '(' commas ')'        {% ams (sLL $1 $> $ EName $ getRdrName (tupleTyCon Boxed
                                                         (snd $2 + 1)))
                                        (mop $1:mcp $3:(mcommas (fst $2))) }
-        | '(#' commas '#)'      {% ams (sLL $1 $> $ getRdrName (tupleTyCon Unboxed
+        | '(#' commas '#)'      {% ams (sLL $1 $> $ EName $ getRdrName (tupleTyCon Unboxed
                                                         (snd $2 + 1)))
                                        (mo $1:mc $3:(mcommas (fst $2))) }
-        | '(' '->' ')'          {% ams (sLL $1 $> $ getRdrName funTyCon)
+        | '(' '->' ')'          {% ams (sLL $1 $> $ EName $ getRdrName funTyCon)
                                        [mop $1,mu AnnRarrow $2,mcp $3] }
-        | '[' ']'               {% ams (sLL $1 $> $ listTyCon_RDR) [mos $1,mcs $2] }
-        | '[:' ':]'             {% ams (sLL $1 $> $ parrTyCon_RDR) [mo $1,mc $2] }
-        | '(' '~#' ')'          {% ams (sLL $1 $> $ getRdrName eqPrimTyCon)
+        | '[' ']'               {% ams (sLL $1 $> $ EName $ listTyCon_RDR) [mos $1,mcs $2] }
+        | '[:' ':]'             {% ams (sLL $1 $> $ EName $ parrTyCon_RDR) [mo $1,mc $2] }
+        | '(' '~#' ')'          {% ams (sLL $1 $> $ EName $ getRdrName eqPrimTyCon)
                                         [mop $1,mj AnnTildehsh $2,mcp $3] }
 
-oqtycon :: { Located RdrName }  -- An "ordinary" qualified tycon;
+oqtycon :: { Located (Embellished RdrName) }  -- An "ordinary" qualified tycon;
                                 -- These can appear in export lists
-        : qtycon                        { $1 }
-        | '(' qtyconsym ')'             {% ams (sLL $1 $> (unLoc $2))
-                                               [mop $1,mj AnnVal $2,mcp $3] }
-        | '(' '~' ')'                   {% ams (sLL $1 $> $ eqTyCon_RDR)
-                                               [mop $1,mj AnnVal $2,mcp $3] }
+        : qtycon                        { sL1 $1 (EName $ unLoc  $1) }
+        | '(' qtyconsym ')'             {% ams (sLL $1 $> (EParens $2))
+                                               [mop $1,mcp $3] }
+        | '(' '~' ')'                   {% ams (sLL $1 $> $ EParens (sL1 $1 eqTyCon_RDR))
+                                               [mop $1,mcp $3] }
 
-oqtycon_no_varcon :: { Located RdrName }  -- Type constructor which cannot be mistaken
+oqtycon_no_varcon :: { Located (Embellished RdrName) }  -- Type constructor which cannot be mistaken
                                           -- for variable constructor in export lists
                                           -- see Note [Type constructors in export list]
-        :  qtycon            { $1 }
+        :  qtycon            { sL1 $1 (EName $ unLoc $1) }
         | '(' QCONSYM ')'    {% let name = sL1 $2 $! mkQual tcClsName (getQCONSYM $2)
-                                in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] }
+                                in ams (sLL $1 $> (EParens name)) [mop $1,mcp $3] }
         | '(' CONSYM ')'     {% let name = sL1 $2 $! mkUnqual tcClsName (getCONSYM $2)
-                                in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] }
+                                in ams (sLL $1 $> (EParens name)) [mop $1,mcp $3] }
         | '(' ':' ')'        {% let name = sL1 $2 $! consDataCon_RDR
-                                in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] }
-        | '(' '~' ')'        {% ams (sLL $1 $> $ eqTyCon_RDR) [mop $1,mj AnnTilde $2,mcp $3] }
+                                in ams (sLL $1 $> (EParens name)) [mop $1,mcp $3] }
+        | '(' '~' ')'        {% ams (sLL $1 $> $ EParens (sL1 $2 eqTyCon_RDR)) [mop $1,mcp $3] }
 
 {- Note [Type constructors in export list]
 ~~~~~~~~~~~~~~~~~~~~~
@@ -3099,10 +3099,10 @@ until after renaming when we resolve the proper namespace for each exported
 child.
 -}
 
-qtyconop :: { Located RdrName } -- Qualified or unqualified
-        : qtyconsym                     { $1 }
-        | '`' qtycon '`'                {% ams (sLL $1 $> (unLoc $2))
-                                               [mj AnnBackquote $1,mj AnnVal $2
+qtyconop :: { Located (Embellished RdrName) } -- Qualified or unqualified
+        : qtyconsym                     { sL1 $1 $ EName (unLoc $1) }
+        | '`' qtycon '`'                {% ams (sLL $1 $> (EBackquotes $2))
+                                               [mj AnnBackquote $1
                                                ,mj AnnBackquote $3] }
 
 qtycon :: { Located RdrName }   -- Qualified or unqualified
@@ -3110,8 +3110,8 @@ qtycon :: { Located RdrName }   -- Qualified or unqualified
         | tycon             { $1 }
 
 qtycondoc :: { LHsType RdrName } -- Qualified or unqualified
-        : qtycon            { sL1 $1                     (HsTyVar NotPromoted $1)      }
-        | qtycon docprev    { sLL $1 $> (HsDocTy (sL1 $1 (HsTyVar NotPromoted $1)) $2) }
+        : qtycon            { sL1 $1                     (HsTyVar NotPromoted (lEmb $1))      }
+        | qtycon docprev    { sLL $1 $> (HsDocTy (sL1 $1 (HsTyVar NotPromoted (lEmb $1))) $2) }
 
 tycon   :: { Located RdrName }  -- Unqualified
         : CONID                   { sL1 $1 $! mkUnqual tcClsName (getCONID $1) }
@@ -3133,14 +3133,14 @@ tyconsym :: { Located RdrName }
 -----------------------------------------------------------------------------
 -- Operators
 
-op      :: { Located RdrName }   -- used in infix decls
+op      :: { Located (Embellished RdrName) }   -- used in infix decls
         : varop                 { $1 }
         | conop                 { $1 }
 
-varop   :: { Located RdrName }
-        : varsym                { $1 }
-        | '`' varid '`'         {% ams (sLL $1 $> (unLoc $2))
-                                       [mj AnnBackquote $1,mj AnnVal $2
+varop   :: { Located (Embellished RdrName) }
+        : varsym                { sL1 $1 (EName $ unLoc $1) }
+        | '`' varid '`'         {% ams (sLL $1 $> (EBackquotes $2))
+                                       [mj AnnBackquote $1
                                        ,mj AnnBackquote $3] }
 
 qop     :: { LHsExpr RdrName }   -- used in sections
@@ -3154,16 +3154,16 @@ qopm    :: { LHsExpr RdrName }   -- used in sections
         : qvaropm               { sL1 $1 $ HsVar $1 }
         | qconop                { sL1 $1 $ HsVar $1 }
 
-qvarop :: { Located RdrName }
-        : qvarsym               { $1 }
-        | '`' qvarid '`'        {% ams (sLL $1 $> (unLoc $2))
-                                       [mj AnnBackquote $1,mj AnnVal $2
+qvarop :: { Located (Embellished RdrName) }
+        : qvarsym               { sL1 $1 $ EName (unLoc $1) }
+        | '`' qvarid '`'        {% ams (sLL $1 $> (EBackquotes $2))
+                                       [mj AnnBackquote $1
                                        ,mj AnnBackquote $3] }
 
-qvaropm :: { Located RdrName }
-        : qvarsym_no_minus      { $1 }
-        | '`' qvarid '`'        {% ams (sLL $1 $> (unLoc $2))
-                                       [mj AnnBackquote $1,mj AnnVal $2
+qvaropm :: { Located (Embellished RdrName) }
+        : qvarsym_no_minus      { sL1 $1 $ EName (unLoc $1) }
+        | '`' qvarid '`'        {% ams (sLL $1 $> (EBackquotes $2))
+                                       [mj AnnBackquote $1
                                        ,mj AnnBackquote $3] }
 
 -----------------------------------------------------------------------------
@@ -3172,9 +3172,9 @@ qvaropm :: { Located RdrName }
 tyvar   :: { Located RdrName }
 tyvar   : tyvarid               { $1 }
 
-tyvarop :: { Located RdrName }
-tyvarop : '`' tyvarid '`'       {% ams (sLL $1 $> (unLoc $2))
-                                       [mj AnnBackquote $1,mj AnnVal $2
+tyvarop :: { Located (Embellished RdrName) }
+tyvarop : '`' tyvarid '`'       {% ams (sLL $1 $> (EBackquotes $2))
+                                       [mj AnnBackquote $1
                                        ,mj AnnBackquote $3] }
         | '.'                   {% parseErrorSDoc (getLoc $1)
                                       (vcat [text "Illegal symbol '.' in type",
@@ -3192,21 +3192,21 @@ tyvarid :: { Located RdrName }
 -----------------------------------------------------------------------------
 -- Variables
 
-var     :: { Located RdrName }
-        : varid                 { $1 }
-        | '(' varsym ')'        {% ams (sLL $1 $> (unLoc $2))
-                                       [mop $1,mj AnnVal $2,mcp $3] }
+var     :: { Located (Embellished RdrName) }
+        : varid                 { sL1 $1 (EName $ unLoc $1) }
+        | '(' varsym ')'        {% ams (sLL $1 $> (EParens $2))
+                                       [mop $1,mcp $3] }
 
  -- Lexing type applications depends subtly on what characters can possibly
  -- end a qvar. Currently (June 2015), only $idchars and ")" can end a qvar.
  -- If you're changing this, please see Note [Lexing type applications] in
  -- Lexer.x.
-qvar    :: { Located RdrName }
-        : qvarid                { $1 }
-        | '(' varsym ')'        {% ams (sLL $1 $> (unLoc $2))
-                                       [mop $1,mj AnnVal $2,mcp $3] }
-        | '(' qvarsym1 ')'      {% ams (sLL $1 $> (unLoc $2))
-                                       [mop $1,mj AnnVal $2,mcp $3] }
+qvar    :: { Located (Embellished RdrName) }
+        : qvarid                { sL1 $1 (EName (unLoc $1)) }
+        | '(' varsym ')'        {% ams (sLL $1 $> (EParens $2))
+                                       [mop $1,mcp $3] }
+        | '(' qvarsym1 ')'      {% ams (sLL $1 $> (EParens $2))
+                                       [mop $1,mcp $3] }
 -- We've inlined qvarsym here so that the decision about
 -- whether it's a qvar or a var can be postponed until
 -- *after* we see the close paren.
index 2c63c42..4fc18dd 100644 (file)
@@ -293,7 +293,7 @@ mkSpliceDecl lexpr@(L loc expr)
   = SpliceD (SpliceDecl (L loc (mkUntypedSplice NoParens lexpr)) ImplicitSplice)
 
 mkRoleAnnotDecl :: SrcSpan
-                -> Located RdrName                   -- type being annotated
+                -> LEmbellished RdrName              -- type being annotated
                 -> [Located (Maybe FastString)]      -- roles
                 -> P (LRoleAnnotDecl RdrName)
 mkRoleAnnotDecl loc tycon roles
@@ -463,7 +463,7 @@ So the plan is:
 -}
 
 splitCon :: LHsType RdrName
-      -> P (Located RdrName, HsConDeclDetails RdrName)
+      -> P (LEmbellished RdrName, HsConDeclDetails RdrName)
 -- See Note [Parsing data constructors is hard]
 -- This gets given a "type" that should look like
 --      C Int Bool
@@ -474,34 +474,37 @@ splitCon ty
  where
    -- This is used somewhere where HsAppsTy is not used
    split (L _ (HsAppTy t u)) ts       = split t (u : ts)
-   split (L l (HsTyVar _ (L _ tc)))  ts = do data_con <- tyConToDataCon l tc
-                                             return (data_con, mk_rest ts)
+   split (L l (HsTyVar _ (L _ tc)))  ts
+     = do data_con <- tyConToDataCon l tc
+          return (data_con, mk_rest ts)
    split (L l (HsTupleTy HsBoxedOrConstraintTuple ts)) []
-      = return (L l (getRdrName (tupleDataCon Boxed (length ts))), PrefixCon ts)
+      = return (L l (EName $ getRdrName (tupleDataCon Boxed (length ts)))
+               , PrefixCon ts)
    split (L l _) _ = parseErrorSDoc l (text "Cannot parse data constructor in a data/newtype declaration:" <+> ppr ty)
 
    mk_rest [L l (HsRecTy flds)] = RecCon (L l flds)
    mk_rest ts                   = PrefixCon ts
 
-tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
+tyConToDataCon :: SrcSpan -> Embellished RdrName -> P (LEmbellished RdrName)
 -- See Note [Parsing data constructors is hard]
 -- Data constructor RHSs are parsed as types
 tyConToDataCon loc tc
   | isTcOcc occ
   , isLexCon (occNameFS occ)
-  = return (L loc (setRdrNameSpace tc srcDataName))
+  -- = return (L loc (setRdrNameSpace tc srcDataName))
+  = return (L loc $ fmap (\n -> setRdrNameSpace n srcDataName) tc)
 
   | otherwise
   = parseErrorSDoc loc (msg $$ extra)
   where
-    occ = rdrNameOcc tc
+    occ = rdrNameOcc $ unEmb tc
 
     msg = text "Not a data constructor:" <+> quotes (ppr tc)
-    extra | tc == forall_tv_RDR
+    extra | unEmb tc == forall_tv_RDR
           = text "Perhaps you intended to use ExistentialQuantification"
           | otherwise = empty
 
-mkPatSynMatchGroup :: Located RdrName
+mkPatSynMatchGroup :: LEmbellished RdrName
                    -> Located (OrdList (LHsDecl RdrName))
                    -> P (MatchGroup RdrName (LHsExpr RdrName))
 mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
@@ -510,7 +513,7 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
        ; return $ mkMatchGroup FromSource matches }
   where
     fromDecl (L loc decl@(ValD (PatBind pat@(L _ (ConPatIn ln@(L _ name) details)) rhs _ _ _))) =
-        do { unless (name == patsyn_name) $
+        do { unless (name == unEmb patsyn_name) $
                wrongNameBindingErr loc decl
            ; match <- case details of
                PrefixCon pats ->
@@ -542,7 +545,7 @@ recordPatSynErr loc pat =
     text "record syntax not supported for pattern synonym declarations:" $$
     ppr pat
 
-mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr RdrName]
+mkConDeclH98 :: LEmbellished RdrName -> Maybe [LHsTyVarBndr RdrName]
                 -> LHsContext RdrName -> HsConDeclDetails RdrName
                 -> ConDecl RdrName
 
@@ -555,7 +558,7 @@ mkConDeclH98 name mb_forall cxt details
                , con_details  = details
                , con_doc      = Nothing }
 
-mkGadtDecl :: [Located RdrName]
+mkGadtDecl :: [LEmbellished RdrName]
            -> LHsSigType RdrName     -- Always a HsForAllTy
            -> ConDecl RdrName
 mkGadtDecl names ty = ConDeclGADT { con_names = names
@@ -691,9 +694,9 @@ checkTyVars pp_what equals_or_where tc tparms
         -- Check that the name space is correct!
     chk (L l (HsKindSig
             (L _ (HsAppsTy [L _ (HsAppPrefix (L lv (HsTyVar _ (L _ tv))))])) k))
-        | isRdrTyVar tv    = return (L l (KindedTyVar (L lv tv) k))
+        | isRdrTyVar $ unEmb tv = return (L l (KindedTyVar (L lv $ unEmb tv) k))
     chk (L l (HsTyVar _ (L ltv tv)))
-        | isRdrTyVar tv    = return (L l (UserTyVar (L ltv tv)))
+        | isRdrTyVar $ unEmb tv = return (L l (UserTyVar (L ltv $ unEmb tv)))
     chk t@(L loc _)
         = Left (loc,
                 vcat [ text "Unexpected type" <+> quotes (ppr t)
@@ -743,7 +746,7 @@ checkTyClHdr is_cls ty
     goL (L l ty) acc ann fix = go l ty acc ann fix
 
     go l (HsTyVar _ (L _ tc)) acc ann fix
-      | isRdrTc tc               = return (L l tc, acc, fix, ann)
+      | isRdrTc $ unEmb tc       = return (L l $ unEmb tc, acc, fix, ann)
     go _ (HsOpTy t1 ltc@(L _ tc) t2) acc ann _fix
       | isRdrTc tc               = return (ltc, t1:t2:acc, Infix, ann)
     go l (HsParTy ty)    acc ann fix = goL ty acc (ann ++ mkParensApiAnn l) fix
@@ -753,9 +756,9 @@ checkTyClHdr is_cls ty
       = goL head (args ++ acc) ann fixity
 
     go _ (HsAppsTy [L _ (HsAppInfix (L loc star))]) [] ann fix
-      | occNameFS (rdrNameOcc star) == fsLit "*"
+      | occNameFS (rdrNameOcc $ unEmb star) == fsLit "*"
       = return (L loc (nameRdrName starKindTyConName), [], fix, ann)
-      | occNameFS (rdrNameOcc star) == fsLit "★"
+      | occNameFS (rdrNameOcc $ unEmb star) == fsLit "★"
       = return (L loc (nameRdrName unicodeStarKindTyConName), [], fix, ann)
 
     go l (HsTupleTy HsBoxedOrConstraintTuple ts) [] ann fix
@@ -806,7 +809,8 @@ checkLPat msg e@(L l _) = checkPat msg l e []
 checkPat :: SDoc -> SrcSpan -> LHsExpr RdrName -> [LPat RdrName]
          -> P (LPat RdrName)
 checkPat _ loc (L l (HsVar (L _ c))) args
-  | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
+  | isRdrDataCon $ unEmb c
+    = return (L loc (ConPatIn (L l $ unEmb c) (PrefixCon args)))
 checkPat msg loc e args     -- OK to let this happen even if bang-patterns
                         -- are not enabled, because there is no valid
                         -- non-bang-pattern parse of (C ! e)
@@ -827,9 +831,9 @@ checkAPat msg loc e0 = do
  pState <- getPState
  let opts = options pState
  case e0 of
-   EWildPat -> return (WildPat placeHolderType)
-   HsVar x  -> return (VarPat x)
-   HsLit l  -> return (LitPat l)
+   EWildPat       -> return (WildPat placeHolderType)
+   HsVar (L l x)  -> return (VarPat (L l $ unEmb x))
+   HsLit l        -> return (LitPat l)
 
    -- Overloaded numeric patterns (e.g. f 0 x = x)
    -- Negation is recorded separately, so that the literal is zero or +ve
@@ -839,7 +843,7 @@ checkAPat msg loc e0 = do
                         -> return (mkNPat (L l pos_lit) (Just noSyntaxExpr))
 
    SectionR (L lb (HsVar (L _ bang))) e    -- (! x)
-        | bang == bang_RDR
+        | unEmb bang == bang_RDR
         -> do { bang_on <- extension bangPatEnabled
               ; if bang_on then do { e' <- checkLPat msg e
                                    ; addAnnotation loc AnnBang lb
@@ -857,14 +861,17 @@ checkAPat msg loc e0 = do
    -- n+k patterns
    OpApp (L nloc (HsVar (L _ n))) (L _ (HsVar (L _ plus))) _
          (L lloc (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
-                      | extopt LangExt.NPlusKPatterns opts && (plus == plus_RDR)
-                      -> return (mkNPlusKPat (L nloc n) (L lloc lit))
+                      | extopt LangExt.NPlusKPatterns opts &&
+                          (unEmb plus == plus_RDR)
+                      -> return (mkNPlusKPat (L nloc $ unEmb n) (L lloc lit))
 
    OpApp l op _fix r  -> do l <- checkLPat msg l
                             r <- checkLPat msg r
                             case op of
-                               L cl (HsVar (L _ c)) | isDataOcc (rdrNameOcc c)
-                                      -> return (ConPatIn (L cl c) (InfixCon l r))
+                               L cl (HsVar (L _ c))
+                                 | isDataOcc (rdrNameOcc $ unEmb c)
+                                      -> return (ConPatIn (L cl $ unEmb c)
+                                                          (InfixCon l r))
                                _ -> patFail msg loc e0
 
    HsPar e            -> checkLPat msg e >>= (return . ParPat)
@@ -893,7 +900,7 @@ checkAPat msg loc e0 = do
 placeHolderPunRhs :: LHsExpr RdrName
 -- The RHS of a punned record field will be filled in by the renamer
 -- It's better not to make it an error, in case we want to print it when debugging
-placeHolderPunRhs = noLoc (HsVar (noLoc pun_RDR))
+placeHolderPunRhs = noLoc (HsVar (noEmb pun_RDR))
 
 plus_RDR, bang_RDR, pun_RDR :: RdrName
 plus_RDR = mkUnqual varName (fsLit "+") -- Hack
@@ -974,11 +981,11 @@ checkPatBind msg lhs (L _ (_,grhss))
         ; return ([],PatBind lhs grhss placeHolderType placeHolderNames
                     ([],[])) }
 
-checkValSigLhs :: LHsExpr RdrName -> P (Located RdrName)
-checkValSigLhs (L _ (HsVar lrdr@(L _ v)))
-  | isUnqual v
-  , not (isDataOcc (rdrNameOcc v))
-  = return lrdr
+checkValSigLhs :: LHsExpr RdrName -> P (LEmbellished RdrName)
+checkValSigLhs (L _ (HsVar (L l v)))
+  | isUnqual $ unEmb v
+  , not (isDataOcc (rdrNameOcc $ unEmb v))
+  = return (L l v)
 
 checkValSigLhs lhs@(L l _)
   = parseErrorSDoc l ((text "Invalid type signature:" <+>
@@ -997,7 +1004,7 @@ checkValSigLhs lhs@(L l _)
     -- A common error is to forget the ForeignFunctionInterface flag
     -- so check for that, and suggest.  cf Trac #3805
     -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword
-    looks_like s (L _ (HsVar (L _ v))) = v == s
+    looks_like s (L _ (HsVar (L _ v))) = unEmb v == s
     looks_like s (L _ (HsApp lhs _))   = looks_like s lhs
     looks_like _ _                     = False
 
@@ -1033,7 +1040,7 @@ checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
 -- Splits (f ! g a b) into (f, [(! g), a, b])
 splitBang (L _ (OpApp l_arg bang@(L _ (HsVar (L _ op))) _ r_arg))
-  | op == bang_RDR = Just (l_arg, L l' (SectionR bang arg1) : argns)
+  | unEmb op == bang_RDR = Just (l_arg, L l' (SectionR bang arg1) : argns)
   where
     l' = combineLocs bang arg1
     (arg1,argns) = split_bang r_arg []
@@ -1058,7 +1065,8 @@ isFunLhs :: LHsExpr RdrName
 isFunLhs e = go e [] []
  where
    go (L loc (HsVar (L _ f))) es ann
-        | not (isRdrDataCon f)       = return (Just (L loc f, Prefix, es, ann))
+        | not (isRdrDataCon $ unEmb f)
+                    = return (Just (L loc (unEmb f), Prefix, es, ann))
    go (L _ (HsApp f e)) es       ann = go f (e:es) ann
    go (L l (HsPar e))   es@(_:_) ann = go e es (ann ++ mkParensApiAnn l)
 
@@ -1079,10 +1087,10 @@ isFunLhs e = go e [] []
         | Just (e',es') <- splitBang e
         = do { bang_on <- extension bangPatEnabled
              ; if bang_on then go e' (es' ++ es) ann
-               else return (Just (L loc' op, Infix, (l:r:es), ann)) }
+               else return (Just (L loc' (unEmb op), Infix, (l:r:es), ann)) }
                 -- No bangs; behave just like the next case
-        | not (isRdrDataCon op)         -- We have found the function!
-        = return (Just (L loc' op, Infix, (l:r:es), ann))
+        | not (isRdrDataCon $ unEmb op)         -- We have found the function!
+        = return (Just (L loc' (unEmb op), Infix, (l:r:es), ann))
         | otherwise                     -- Infix data con; keep going
         = do { mb_l <- go l es ann
              ; case mb_l of
@@ -1132,7 +1140,7 @@ splitTildeApps (t : rest) = do
                     ty))))
           = addAnnotation l AnnTilde tilde_loc >>
             return
-              [L tilde_loc (HsAppInfix (L tilde_loc eqTyCon_RDR)),
+              [L tilde_loc (HsAppInfix (L tilde_loc $ EName eqTyCon_RDR)),
                L l (HsAppPrefix ty)]
                -- NOTE: no annotation is attached to an HsAppPrefix, so the
                --       surrounding SrcSpan is not critical
@@ -1260,8 +1268,8 @@ mkRecConstrOrUpdate
         -> P (HsExpr RdrName)
 
 mkRecConstrOrUpdate (L l (HsVar (L _ c))) _ (fs,dd)
-  | isRdrDataCon c
-  = return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd))
+  | isRdrDataCon $ unEmb c
+  = return (mkRdrRecordCon (L l $ unEmb c) (mk_rec_fields fs dd))
 mkRecConstrOrUpdate exp@(L l _) _ (fs,dd)
   | dd        = parseErrorSDoc l (text "You cannot use `..' in a record update")
   | otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs))
index f6a22f5..05a7080 100644 (file)
@@ -409,14 +409,15 @@ rnBindLHS name_maker _ bind@(FunBind { fun_id = rdr_name })
 rnBindLHS name_maker _ (PatSynBind psb@PSB{ psb_id = rdrname })
   | isTopRecNameMaker name_maker
   = do { addLocM checkConName rdrname
-       ; name <- lookupLocatedTopBndrRn rdrname   -- Should be in scope already
-       ; return (PatSynBind psb{ psb_id = name }) }
+       ; L _ name <- lookupLocatedTopBndrRn $ unLEmb rdrname
+                    -- Should be in scope already
+       ; return (PatSynBind psb{ psb_id = reLEmb rdrname name }) }
 
   | otherwise  -- Pattern synonym, not at top level
   = do { addErr localPatternSynonymErr  -- Complain, but make up a fake
                                         -- name so that we can carry on
-       ; name <- applyNameMaker name_maker rdrname
-       ; return (PatSynBind psb{ psb_id = name }) }
+       ; L _ name <- applyNameMaker name_maker $ unLEmb rdrname
+       ; return (PatSynBind psb{ psb_id = reLEmb rdrname name }) }
   where
     localPatternSynonymErr :: SDoc
     localPatternSynonymErr
@@ -565,11 +566,11 @@ mkSigTvFn sigs = \n -> lookupNameEnv env n `orElse` []
     get_scoped_tvs :: LSig Name -> Maybe ([Located Name], [Name])
     -- Returns (binders, scoped tvs for those binders)
     get_scoped_tvs (L _ (ClassOpSig _ names sig_ty))
-      = Just (names, hsScopedTvs sig_ty)
+      = Just (map unLEmb names, hsScopedTvs sig_ty)
     get_scoped_tvs (L _ (TypeSig names sig_ty))
-      = Just (names, hsWcScopedTvs sig_ty)
+      = Just (map unLEmb names, hsWcScopedTvs sig_ty)
     get_scoped_tvs (L _ (PatSynSig names sig_ty))
-      = Just (names, hsScopedTvs sig_ty)
+      = Just (map unLEmb names, hsScopedTvs sig_ty)
     get_scoped_tvs _ = Nothing
 
 -- Process the fixity declarations, making a FastString -> (Located Fixity) map
@@ -587,19 +588,19 @@ makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls
      foldlM add_one env [ (loc,name_loc,name,fixity)
                         | L name_loc name <- names ]
 
-   add_one env (loc, name_loc, name,fixity) = do
+   add_one env (loc, name_loc, name, fixity) = do
      { -- this fixity decl is a duplicate iff
        -- the ReaderName's OccName's FastString is already in the env
        -- (we only need to check the local fix_env because
        --  definitions of non-local will be caught elsewhere)
-       let { fs = occNameFS (rdrNameOcc name)
+       let { fs = occNameFS (rdrNameOcc $ unEmb name)
            ; fix_item = L loc fixity };
 
        case lookupFsEnv env fs of
          Nothing -> return $ extendFsEnv env fs fix_item
          Just (L loc' _) -> do
            { setSrcSpan loc $
-             addErrAt name_loc (dupFixityDecl loc' name)
+             addErrAt name_loc (dupFixityDecl loc' (unEmb name))
            ; return env}
      }
 
@@ -625,7 +626,7 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
        -- invariant: no free vars here when it's a FunBind
   = do  { pattern_synonym_ok <- xoptM LangExt.PatternSynonyms
         ; unless pattern_synonym_ok (addErr patternSynonymErr)
-        ; let sig_tvs = sig_fn name
+        ; let sig_tvs = sig_fn $ unEmb name
 
         ; ((pat', details'), fvs1) <- bindSigTyVarsFV sig_tvs $
                                       rnPat PatSyn pat $ \pat' ->
@@ -662,10 +663,10 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
             Unidirectional -> return (Unidirectional, emptyFVs)
             ImplicitBidirectional -> return (ImplicitBidirectional, emptyFVs)
             ExplicitBidirectional mg ->
-                do { (mg', fvs) <- bindSigTyVarsFV sig_tvs $
-                                   rnMatchGroup (FunRhs (L l name) Prefix)
-                                                rnLExpr mg
-                   ; return (ExplicitBidirectional mg', fvs) }
+              do { (mg', fvs) <- bindSigTyVarsFV sig_tvs $
+                                 rnMatchGroup (FunRhs (L l $ unEmb name) Prefix)
+                                              rnLExpr mg
+                 ; return (ExplicitBidirectional mg', fvs) }
 
         ; mod <- getModule
         ; let fvs = fvs1 `plusFV` fvs2
@@ -684,7 +685,7 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
                                  _ -> []
 
         ; fvs' `seq` -- See Note [Free-variable space leak]
-          return (bind', name : selector_names , fvs1)
+          return (bind', unEmb name : selector_names , fvs1)
           -- Why fvs1?  See Note [Pattern synonym builders don't yield dependencies]
       }
   where
@@ -888,7 +889,7 @@ renameSig _ (IdSig x)
   = return (IdSig x, emptyFVs)    -- Actually this never occurs
 
 renameSig ctxt sig@(TypeSig vs ty)
-  = do  { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
+  = do  { new_vs <- mapM (lookupLESigOccRn ctxt sig) vs
         ; let doc = TypeSigCtx (ppr_sig_bndrs vs)
         ; (new_ty, fvs) <- rnHsSigWcType doc ty
         ; return (TypeSig new_vs new_ty, fvs) }
@@ -897,7 +898,7 @@ renameSig ctxt sig@(ClassOpSig is_deflt vs ty)
   = do  { defaultSigs_on <- xoptM LangExt.DefaultSignatures
         ; when (is_deflt && not defaultSigs_on) $
           addErr (defaultSigErr sig)
-        ; new_v <- mapM (lookupSigOccRn ctxt sig) vs
+        ; new_v <- mapM (lookupLESigOccRn ctxt sig) vs
         ; (new_ty, fvs) <- rnHsSigType ty_ctxt ty
         ; return (ClassOpSig is_deflt new_v new_ty, fvs) }
   where
@@ -915,8 +916,8 @@ renameSig _ (SpecInstSig src ty)
 -- then the SPECIALISE pragma is ambiguous, unlike all other signatures
 renameSig ctxt sig@(SpecSig v tys inl)
   = do  { new_v <- case ctxt of
-                     TopSigCtxt {} -> lookupLocatedOccRn v
-                     _             -> lookupSigOccRn ctxt sig v
+                     TopSigCtxt {} -> lookupLEmbellishedOccRn v
+                     _             -> lookupLESigOccRn ctxt sig v
         ; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys
         ; return (SpecSig new_v new_ty inl, fvs) }
   where
@@ -927,19 +928,19 @@ renameSig ctxt sig@(SpecSig v tys inl)
            ; return ( new_ty:tys, fvs_ty `plusFV` fvs) }
 
 renameSig ctxt sig@(InlineSig v s)
-  = do  { new_v <- lookupSigOccRn ctxt sig v
+  = do  { new_v <- lookupLESigOccRn ctxt sig v
         ; return (InlineSig new_v s, emptyFVs) }
 
 renameSig ctxt sig@(FixSig (FixitySig vs f))
-  = do  { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
+  = do  { new_vs <- mapM (lookupLESigOccRn ctxt sig) vs
         ; return (FixSig (FixitySig new_vs f), emptyFVs) }
 
 renameSig ctxt sig@(MinimalSig s (L l bf))
-  = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf
+  = do new_bf <- traverse (lookupLESigOccRn ctxt sig) bf
        return (MinimalSig s (L l new_bf), emptyFVs)
 
 renameSig ctxt sig@(PatSynSig vs ty)
-  = do  { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
+  = do  { new_vs <- mapM (lookupLESigOccRn ctxt sig) vs
         ; (ty', fvs) <- rnHsSigType ty_ctxt ty
         ; return (PatSynSig new_vs ty', fvs) }
   where
@@ -947,17 +948,17 @@ renameSig ctxt sig@(PatSynSig vs ty)
                           <+> ppr_sig_bndrs vs)
 
 renameSig ctxt sig@(SCCFunSig st v s)
-  = do  { new_v <- lookupSigOccRn ctxt sig v
+  = do  { new_v <- lookupLESigOccRn ctxt sig v
         ; return (SCCFunSig st new_v s, emptyFVs) }
 
 -- COMPLETE Sigs can refer to imported IDs which is why we use
 -- lookupLocatedOccRn rather than lookupSigOccRn
 renameSig _ctxt (CompleteMatchSig s (L l bf) mty)
-  = do new_bf <- traverse lookupLocatedOccRn bf
-       new_mty  <- traverse lookupLocatedOccRn mty
+  = do new_bf  <- traverse lookupLEmbellishedOccRn bf
+       new_mty <- traverse lookupLEmbellishedOccRn mty
        return (CompleteMatchSig s (L l new_bf) new_mty, emptyFVs)
 
-ppr_sig_bndrs :: [Located RdrName] -> SDoc
+ppr_sig_bndrs :: [LEmbellished RdrName] -> SDoc
 ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs)
 
 okHsSig :: HsSigCtxt -> LSig a -> Bool
@@ -1014,12 +1015,12 @@ findDupSigs :: [LSig RdrName] -> [[(Located RdrName, Sig RdrName)]]
 findDupSigs sigs
   = findDupsEq matching_sig (concatMap (expand_sig . unLoc) sigs)
   where
-    expand_sig sig@(FixSig (FixitySig ns _)) = zip ns (repeat sig)
-    expand_sig sig@(InlineSig n _)           = [(n,sig)]
-    expand_sig sig@(TypeSig ns _)            = [(n,sig) | n <- ns]
-    expand_sig sig@(ClassOpSig _ ns _)       = [(n,sig) | n <- ns]
-    expand_sig sig@(PatSynSig ns  _ )        = [(n,sig) | n <- ns]
-    expand_sig sig@(SCCFunSig _ n _)         = [(n,sig)]
+    expand_sig sig@(FixSig (FixitySig ns _)) = zip (map unLEmb ns) (repeat sig)
+    expand_sig sig@(InlineSig n _)           = [(unLEmb n,sig)]
+    expand_sig sig@(TypeSig ns _)            = [(unLEmb n,sig) | n <- ns]
+    expand_sig sig@(ClassOpSig _ ns _)       = [(unLEmb n,sig) | n <- ns]
+    expand_sig sig@(PatSynSig ns  _ )        = [(unLEmb n,sig) | n <- ns]
+    expand_sig sig@(SCCFunSig _ n _)         = [(unLEmb n,sig)]
     expand_sig _ = []
 
     matching_sig (L _ n1,sig1) (L _ n2,sig2)       = n1 == n2 && mtch sig1 sig2
index 7c05994..3ed1bf8 100644 (file)
@@ -9,7 +9,9 @@
 module RnEnv (
         newTopSrcBinder,
         lookupLocatedTopBndrRn, lookupTopBndrRn,
+        lookupLEmbellishedTopBndrRn,
         lookupLocatedOccRn, lookupOccRn, lookupOccRn_maybe,
+        lookupLEmbellishedOccRn,
         lookupLocalOccRn_maybe, lookupInfoOccRn,
         lookupLocalOccThLvl_maybe,
         lookupTypeOccRn, lookupKindOccRn,
@@ -19,6 +21,7 @@ module RnEnv (
         addNameClashErrRn,
 
         HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn,
+        lookupLESigOccRn,
         lookupSigCtxtOccRn,
 
         lookupFixityRn, lookupFixityRn_help,
@@ -249,6 +252,13 @@ lookupTopBndrRn n = do nopt <- lookupTopBndrRn_maybe n
                          Nothing -> do traceRn "lookupTopBndrRn fail" (ppr n)
                                        unboundName WL_LocalTop n
 
+lookupLEmbellishedTopBndrRn :: LEmbellished RdrName -> RnM (LEmbellished Name)
+lookupLEmbellishedTopBndrRn = wrapLocM lookup
+  where
+    lookup en = do
+      n <- lookupTopBndrRn (unEmb en)
+      return (reEmb en n)
+
 lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name)
 lookupLocatedTopBndrRn = wrapLocM lookupTopBndrRn
 
@@ -668,6 +678,13 @@ getLookupOccRn
 mkUnboundNameRdr :: RdrName -> Name
 mkUnboundNameRdr rdr = mkUnboundName (rdrNameOcc rdr)
 
+lookupLEmbellishedOccRn :: LEmbellished RdrName -> RnM (LEmbellished Name)
+lookupLEmbellishedOccRn = wrapLocM lookup
+  where
+    lookup emb = do
+      n <- lookupOccRn (unEmb emb)
+      return (reEmb emb n)
+
 lookupLocatedOccRn :: Located RdrName -> RnM (Located Name)
 lookupLocatedOccRn = wrapLocM lookupOccRn
 
@@ -921,7 +938,7 @@ lookupGlobalOccRn_overloaded overload_ok rdr_name
                                ; let
                                    fld_occ :: FieldOcc Name
                                    fld_occ
-                                     = FieldOcc (noLoc rdr_name) (gre_name gre)
+                                     = FieldOcc (noEmb rdr_name) (gre_name gre)
                                ; return (Just (Right [fld_occ])) }
                       | otherwise
                          -> do { addUsedGRE True gre
@@ -931,7 +948,7 @@ lookupGlobalOccRn_overloaded overload_ok rdr_name
                             -- until we know which is meant
                          -> return
                              (Just (Right
-                                     (map (FieldOcc (noLoc rdr_name) . gre_name)
+                                     (map (FieldOcc (noEmb rdr_name) . gre_name)
                                            gres)))
                 gres     -> do { addNameClashErrRn rdr_name gres
                                ; return (Just (Left (gre_name (head gres)))) } }
@@ -1224,6 +1241,13 @@ instance Outputable HsSigCtxt where
     ppr (HsBootCtxt ns) = text "HsBootCtxt" <+> ppr ns
     ppr (RoleAnnotCtxt ns) = text "RoleAnnotCtxt" <+> ppr ns
 
+lookupLESigOccRn :: HsSigCtxt
+                 -> Sig RdrName
+                 -> LEmbellished RdrName -> RnM (LEmbellished Name)
+lookupLESigOccRn ctxt sig le = do
+  L _ n <- lookupSigOccRn ctxt sig (unLEmb le)
+  return (reLEmb le n )
+
 lookupSigOccRn :: HsSigCtxt
                -> Sig RdrName
                -> Located RdrName -> RnM (Located Name)
@@ -1496,8 +1520,8 @@ lookupTyFixityRn (L _ n) = lookupFixityRn n
 -- multiple possible selectors with different fixities, generate an error.
 lookupFieldFixityRn :: AmbiguousFieldOcc Name -> RnM Fixity
 lookupFieldFixityRn (Unambiguous (L _ rdr) n)
-  = lookupFixityRn' n (rdrNameOcc rdr)
-lookupFieldFixityRn (Ambiguous   (L _ rdr) _) = get_ambiguous_fixity rdr
+  = lookupFixityRn' n (rdrNameOcc $ unEmb rdr)
+lookupFieldFixityRn (Ambiguous   (L _ rdr) _) = get_ambiguous_fixity $ unEmb rdr
   where
     get_ambiguous_fixity :: RdrName -> RnM Fixity
     get_ambiguous_fixity rdr_name = do
@@ -1636,10 +1660,10 @@ lookupSyntaxNames :: [Name]                          -- Standard names
 lookupSyntaxNames std_names
   = do { rebindable_on <- xoptM LangExt.RebindableSyntax
        ; if not rebindable_on then
-             return (map (HsVar . noLoc) std_names, emptyFVs)
+             return (map (HsVar . noEmb) std_names, emptyFVs)
         else
           do { usr_names <- mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names
-             ; return (map (HsVar . noLoc) usr_names, mkFVs usr_names) } }
+             ; return (map (HsVar . noEmb) usr_names, mkFVs usr_names) } }
 
 {-
 *********************************************************
index 4e9192c..ddbd762 100644 (file)
@@ -78,14 +78,14 @@ rnLExpr = wrapLocFstM rnExpr
 
 rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
 
-finishHsVar :: Located Name -> RnM (HsExpr Name, FreeVars)
+finishHsVar :: LEmbellished Name -> RnM (HsExpr Name, FreeVars)
 -- Separated from rnExpr because it's also used
 -- when renaming infix expressions
 finishHsVar (L l name)
  = do { this_mod <- getModule
-      ; when (nameIsLocalOrFrom this_mod name) $
-        checkThLocalName name
-      ; return (HsVar (L l name), unitFV name) }
+      ; when (nameIsLocalOrFrom this_mod $ unEmb name) $
+        checkThLocalName $ unEmb name
+      ; return (HsVar (L l name), unitFV $ unEmb name) }
 
 rnUnboundVar :: RdrName -> RnM (HsExpr Name, FreeVars)
 rnUnboundVar v
@@ -101,20 +101,20 @@ rnUnboundVar v
 
         else -- Fail immediately (qualified name)
              do { n <- reportUnboundName v
-                ; return (HsVar (noLoc n), emptyFVs) } }
+                ; return (HsVar (noEmb n), emptyFVs) } }
 
 rnExpr (HsVar (L l v))
   = do { opt_DuplicateRecordFields <- xoptM LangExt.DuplicateRecordFields
-       ; mb_name <- lookupOccRn_overloaded opt_DuplicateRecordFields v
+       ; mb_name <- lookupOccRn_overloaded opt_DuplicateRecordFields $ unEmb v
        ; case mb_name of {
-           Nothing -> rnUnboundVar v ;
+           Nothing -> rnUnboundVar $ unEmb v ;
            Just (Left name)
               | name == nilDataConName -- Treat [] as an ExplicitList, so that
                                        -- OverloadedLists works correctly
               -> rnExpr (ExplicitList placeHolderType Nothing [])
 
               | otherwise
-              -> finishHsVar (L l name) ;
+              -> finishHsVar (L l (reEmb v name)) ;
             Just (Right [f@(FieldOcc (L _ fn) s)]) ->
                       return (HsRecFld (ambiguousFieldOcc (FieldOcc (L l fn) s))
                              , unitFV (selectorFieldOcc f)) ;
@@ -170,7 +170,7 @@ rnExpr (OpApp e1 op  _ e2)
         -- more, so I've removed the test.  Adding HsPars in TcGenDeriv
         -- should prevent bad things happening.
         ; fixity <- case op' of
-              L _ (HsVar (L _ n)) -> lookupFixityRn n
+              L _ (HsVar (L _ n)) -> lookupFixityRn $ unEmb n
               L _ (HsRecFld f)    -> lookupFieldFixityRn f
               _ -> return (Fixity NoSourceText minPrecedence InfixL)
                    -- c.f. lookupFixity for unbound
@@ -289,7 +289,7 @@ rnExpr (RecordCon { rcon_con_name = con_id
                            , rcon_con_expr = noPostTcExpr, rcon_con_like = PlaceHolder }
                 , fvs `plusFV` plusFVs fvss `addOneFV` con_name) }
   where
-    mk_hs_var l n = HsVar (L l n)
+    mk_hs_var l n = HsVar (L l $ EName n)
     rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
                             ; return (L l (fld { hsRecFieldArg = arg' }), fvs) }
 
@@ -481,7 +481,7 @@ rnCmd (HsCmdArrForm op _ (Just _) [arg1, arg2])
        ; (arg1',fv_arg1) <- rnCmdTop arg1
        ; (arg2',fv_arg2) <- rnCmdTop arg2
         -- Deal with fixity
-       ; fixity <- lookupFixityRn op_name
+       ; fixity <- lookupFixityRn $ unEmb op_name
        ; final_e <- mkOpFormRn arg1' op' fixity arg2'
        ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) }
 
@@ -972,12 +972,12 @@ lookupStmtNamePoly ctxt name
   = do { rebindable_on <- xoptM LangExt.RebindableSyntax
        ; if rebindable_on
          then do { fm <- lookupOccRn (nameRdrName name)
-                 ; return (HsVar (noLoc fm), unitFV fm) }
+                 ; return (HsVar (noEmb fm), unitFV fm) }
          else not_rebindable }
   | otherwise
   = not_rebindable
   where
-    not_rebindable = return (HsVar (noLoc name), emptyFVs)
+    not_rebindable = return (HsVar (noEmb name), emptyFVs)
 
 -- | Is this a context where we respect RebindableSyntax?
 -- but ListComp/PArrComp are never rebindable
@@ -1820,7 +1820,7 @@ isReturnApp monad_names (L _ e) = case e of
  where
   is_var f (L _ (HsPar e)) = is_var f e
   is_var f (L _ (HsAppType e _)) = is_var f e
-  is_var f (L _ (HsVar (L _ r))) = f r
+  is_var f (L _ (HsVar (L _ r))) = f $ unEmb r
        -- TODO: I don't know how to get this right for rebindable syntax
   is_var _ _ = False
 
index dc9cdd9..15e6133 100644 (file)
@@ -577,7 +577,7 @@ getLocalNonValBinders fixity_env
           --    type sigs in case of a hs-boot file only
         ; is_boot <- tcIsHsBootOrSig
         ; let val_bndrs | is_boot   = hs_boot_sig_bndrs
-                        | otherwise = for_hs_bndrs
+                        | otherwise = map lEmb for_hs_bndrs
         ; val_avails <- mapM new_simple val_bndrs
 
         ; let avails    = concat nti_availss ++ val_avails
@@ -607,15 +607,16 @@ getLocalNonValBinders fixity_env
 
       -- the SrcSpan attached to the input should be the span of the
       -- declaration, not just the name
-    new_simple :: Located RdrName -> RnM AvailInfo
-    new_simple rdr_name = do{ nm <- newTopSrcBinder rdr_name
+    new_simple :: LEmbellished RdrName -> RnM AvailInfo
+    new_simple rdr_name = do{ nm <- newTopSrcBinder $ unLEmb rdr_name
                             ; return (avail nm) }
 
     new_tc :: Bool -> LTyClDecl RdrName
            -> RnM (AvailInfo, [(Name, [FieldLabel])])
     new_tc overload_ok tc_decl -- NOT for type/data instances
         = do { let (bndrs, flds) = hsLTyClDeclBinders tc_decl
-             ; names@(main_name : sub_names) <- mapM newTopSrcBinder bndrs
+             ; names@(main_name : sub_names)
+                                     <- mapM (newTopSrcBinder . unLEmb) bndrs
              ; flds' <- mapM (newRecordSelector overload_ok sub_names) flds
              ; let fld_env = case unLoc tc_decl of
                      DataDecl { tcdDataDefn = d } -> mk_fld_env d names flds'
@@ -631,12 +632,12 @@ getLocalNonValBinders fixity_env
       where
         find_con_flds (L _ (ConDeclH98 { con_name    = L _ rdr
                                        , con_details = RecCon cdflds }))
-            = [( find_con_name rdr
+            = [( find_con_name $ unEmb rdr
                , concatMap find_con_decl_flds (unLoc cdflds) )]
         find_con_flds (L _ (ConDeclGADT
                               { con_names = rdrs
                               , con_type = (HsIB { hsib_body = res_ty})}))
-            = map (\ (L _ rdr) -> ( find_con_name rdr
+            = map (\ (L _ rdr) -> ( find_con_name $ unEmb rdr
                                   , concatMap find_con_decl_flds cdflds))
                   rdrs
             where
@@ -657,7 +658,7 @@ getLocalNonValBinders fixity_env
         find_con_decl_fld  (L _ (FieldOcc (L _ rdr) _))
           = expectJust "getLocalNonValBinders/find_con_decl_fld" $
               find (\ fl -> flLabel fl == lbl) flds
-          where lbl = occNameFS (rdrNameOcc rdr)
+          where lbl = occNameFS (rdrNameOcc $ unEmb rdr)
 
     new_assoc :: Bool -> LInstDecl RdrName
               -> RnM ([AvailInfo], [(Name, [FieldLabel])])
@@ -683,7 +684,7 @@ getLocalNonValBinders fixity_env
     new_di overload_ok mb_cls ti_decl
         = do { main_name <- lookupFamInstName mb_cls (dfid_tycon ti_decl)
              ; let (bndrs, flds) = hsDataFamInstBinders ti_decl
-             ; sub_names <- mapM newTopSrcBinder bndrs
+             ; sub_names <- mapM (newTopSrcBinder . unLEmb) bndrs
              ; flds' <- mapM (newRecordSelector overload_ok sub_names) flds
              ; let avail    = AvailTC (unLoc main_name) sub_names flds'
                                   -- main_name is not bound here!
@@ -697,19 +698,19 @@ getLocalNonValBinders fixity_env
 newRecordSelector :: Bool -> [Name] -> LFieldOcc RdrName -> RnM FieldLabel
 newRecordSelector _ [] _ = error "newRecordSelector: datatype has no constructors!"
 newRecordSelector overload_ok (dc:_) (L loc (FieldOcc (L _ fld) _))
-  = do { selName <- newTopSrcBinder $ L loc $ field
+  = do { selName <- newTopSrcBinder $ L loc $ unEmb field
        ; return $ qualFieldLbl { flSelector = selName } }
   where
-    fieldOccName = occNameFS $ rdrNameOcc fld
+    fieldOccName = occNameFS $ rdrNameOcc $ unEmb fld
     qualFieldLbl = mkFieldLabelOccs fieldOccName (nameOccName dc) overload_ok
-    field | isExact fld = fld
+    field | isExact $ unEmb fld = fld
               -- use an Exact RdrName as is to preserve the bindings
               -- of an already renamer-resolved field and its use
               -- sites. This is needed to correctly support record
               -- selectors in Template Haskell. See Note [Binders in
               -- Template Haskell] in Convert.hs and Note [Looking up
               -- Exact RdrNames] in RnEnv.hs.
-          | otherwise   = mkRdrUnqual (flSelector qualFieldLbl)
+          | otherwise   = EName $ mkRdrUnqual (flSelector qualFieldLbl)
 
 {-
 Note [Looking up family names in family instances]
@@ -1618,8 +1619,9 @@ packageImportErr
 --      data T = :% Int Int
 -- from interface files, which always print in prefix form
 
-checkConName :: RdrName -> TcRn ()
-checkConName name = checkErr (isRdrDataCon name) (badDataCon name)
+checkConName :: Embellished RdrName -> TcRn ()
+checkConName name
+  = checkErr (isRdrDataCon $ unEmb name) (badDataCon $ unEmb name)
 
 badDataCon :: RdrName -> SDoc
 badDataCon name
index 3417494..fcaf891 100644 (file)
@@ -426,9 +426,9 @@ rnPatAndThen mk (NPlusKPat rdr (L l lit) _ _ _ _)
                 -- The Report says that n+k patterns must be in Integral
 
 rnPatAndThen mk (AsPat rdr pat)
-  = do { new_name <- newPatLName mk rdr
+  = do { new_name <- newPatLName mk $ unLEmb rdr
        ; pat' <- rnLPatAndThen mk pat
-       ; return (AsPat new_name pat') }
+       ; return (AsPat (reLEmb rdr (unLoc new_name)) pat') }
 
 rnPatAndThen mk p@(ViewPat expr pat _ty)
   = do { liftCps $ do { vp_flag <- xoptM LangExt.ViewPatterns
@@ -589,13 +589,13 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
                                               = L loc (FieldOcc (L ll lbl) _)
                                           , hsRecFieldArg = arg
                                           , hsRecPun      = pun }))
-      = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent doc lbl
+      = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent doc (unEmb lbl)
            ; arg' <- if pun
-                     then do { checkErr pun_ok (badPun (L loc lbl))
-                               -- Discard any module qualifier (#11662)
-                             ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)
-                             ; return (L loc (mk_arg loc arg_rdr)) }
-                     else return arg
+                   then do { checkErr pun_ok (badPun (L loc $ unEmb lbl))
+                             -- Discard any module qualifier (#11662)
+                           ; let arg_rdr = mkRdrUnqual (rdrNameOcc $ unEmb lbl)
+                           ; return (L loc (mk_arg loc arg_rdr)) }
+                   else return arg
            ; return (L l (HsRecField { hsRecFieldLbl
                                          = L loc (FieldOcc (L ll lbl) sel)
                                      , hsRecFieldArg = arg'
@@ -640,7 +640,8 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
 
            ; addUsedGREs dot_dot_gres
            ; return [ L loc (HsRecField
-                        { hsRecFieldLbl = L loc (FieldOcc (L loc arg_rdr) sel)
+                        { hsRecFieldLbl
+                                 = L loc (FieldOcc (L loc $ EName arg_rdr) sel)
                         , hsRecFieldArg = L loc (mk_arg loc arg_rdr)
                         , hsRecPun      = False })
                     | fl <- dot_dot_fields
@@ -724,17 +725,20 @@ rnHsRecUpdFields flds
                       -- Defer renaming of overloaded fields to the typechecker
                       -- See Note [Disambiguating record fields] in TcExpr
                       if overload_ok
-                          then do { mb <- lookupGlobalOccRn_overloaded overload_ok lbl
+                          then do { mb <- lookupGlobalOccRn_overloaded
+                                                    overload_ok (unEmb lbl)
                                   ; case mb of
-                                      Nothing -> do { addErr (unknownSubordinateErr doc lbl)
-                                                    ; return (Right []) }
+                                      Nothing -> do
+                                        { addErr (unknownSubordinateErr doc
+                                                  (unEmb lbl))
+                                        ; return (Right []) }
                                       Just r  -> return r }
-                          else fmap Left $ lookupGlobalOccRn lbl
+                          else fmap Left $ lookupGlobalOccRn $ unEmb lbl
            ; arg' <- if pun
-                     then do { checkErr pun_ok (badPun (L loc lbl))
-                               -- Discard any module qualifier (#11662)
-                             ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)
-                             ; return (L loc (HsVar (L loc arg_rdr))) }
+                 then do { checkErr pun_ok (badPun (L loc $ unEmb lbl))
+                           -- Discard any module qualifier (#11662)
+                         ; let arg_rdr = mkRdrUnqual (rdrNameOcc $ unEmb lbl)
+                         ; return (L loc (HsVar (L loc (reEmb lbl arg_rdr)))) }
                      else return arg
            ; (arg'', fvs) <- rnLExpr arg'
 
@@ -766,10 +770,11 @@ getFieldIds flds = map (unLoc . hsRecFieldSel . unLoc) flds
 
 getFieldLbls :: [LHsRecField id arg] -> [RdrName]
 getFieldLbls flds
-  = map (unLoc . rdrNameFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds
+  = map (unLocEmb . rdrNameFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds
 
 getFieldUpdLbls :: [LHsRecUpdField id] -> [RdrName]
-getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds
+getFieldUpdLbls flds
+  = map (unEmb . rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds
 
 needFlagDotDot :: HsRecFieldContext -> SDoc
 needFlagDotDot ctxt = vcat [text "Illegal `..' in record" <+> pprRFC ctxt,
@@ -832,7 +837,7 @@ rnOverLit origLit
         ; (SyntaxExpr { syn_expr = from_thing_name }, fvs)
             <- lookupSyntaxName std_name
         ; let rebindable = case from_thing_name of
-                                HsVar (L _ v) -> v /= std_name
+                                HsVar (L _ v) -> unEmb v /= std_name
                                 _             -> panic "rnOverLit"
         ; return (lit { ol_witness = from_thing_name
                       , ol_rebindable = rebindable
index 3e46274..5234308 100644 (file)
@@ -284,12 +284,12 @@ rnSrcFixityDecls bndr_set fix_decls
            return [ L loc (FixitySig name fixity)
                   | name <- names ]
 
-    lookup_one :: Located RdrName -> RnM [Located Name]
+    lookup_one :: LEmbellished RdrName -> RnM [LEmbellished Name]
     lookup_one (L name_loc rdr_name)
       = setSrcSpan name_loc $
                     -- this lookup will fail if the definition isn't local
-        do names <- lookupLocalTcNames sig_ctxt what rdr_name
-           return [ L name_loc name | (_, name) <- names ]
+        do names <- lookupLocalTcNames sig_ctxt what $ unEmb rdr_name
+           return [ L name_loc (reEmb rdr_name name) | (_, name) <- names ]
     what = text "fixity signature"
 
 {-
@@ -325,14 +325,14 @@ rnSrcWarnDecls bndr_set decls'
 
    rn_deprec (Warning rdr_names txt)
        -- ensures that the names are defined locally
-     = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc)
+     = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLocEmb)
                                 rdr_names
           ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] }
 
    what = text "deprecation"
 
-   warn_rdr_dups = findDupRdrNames $ concatMap (\(L _ (Warning ns _)) -> ns)
-                                               decls
+   warn_rdr_dups = findDupRdrNames
+                      $ concatMap (\(L _ (Warning ns _)) -> map unLEmb ns) decls
 
 findDupRdrNames :: [Located RdrName] -> [[Located RdrName]]
 findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
@@ -607,7 +607,7 @@ checkCanonicalInstances cls poly_ty mbinds = do
     isAliasMG MG {mg_alts = L _ [L _ (Match { m_pats = [], m_grhss = grhss })]}
         | GRHSs [L _ (GRHS [] body)] lbinds <- grhss
         , L _ EmptyLocalBinds <- lbinds
-        , L _ (HsVar (L _ rhsName)) <- body  = Just rhsName
+        , L _ (HsVar (L _ rhsName)) <- body  = Just $ unEmb rhsName
     isAliasMG _ = Nothing
 
     -- got "lhs = rhs" but expected something different
@@ -1051,7 +1051,7 @@ validRuleLhs foralls lhs
     check (OpApp e1 op _ e2)              = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2
     check (HsApp e1 e2)                   = checkl e1 `mplus` checkl_e e2
     check (HsAppType e _)                 = checkl e
-    check (HsVar (L _ v)) | v `notElem` foralls = Nothing
+    check (HsVar (L _ v)) | unEmb v `notElem` foralls = Nothing
     check other                           = Just other  -- Failure
 
         -- Check an argument
@@ -1102,9 +1102,9 @@ rnHsVectDecl :: VectDecl RdrName -> RnM (VectDecl Name, FreeVars)
 -- FIXME: For the moment, the right-hand side is restricted to be a variable as we cannot properly
 --        typecheck a complex right-hand side without invoking 'vectType' from the vectoriser.
 rnHsVectDecl (HsVect s var rhs@(L _ (HsVar _)))
-  = do { var' <- lookupLocatedOccRn var
+  = do { var' <- lookupLEmbellishedOccRn var
        ; (rhs', fv_rhs) <- rnLExpr rhs
-       ; return (HsVect s var' rhs', fv_rhs `addOneFV` unLoc var')
+       ; return (HsVect s var' rhs', fv_rhs `addOneFV` unLocEmb var')
        }
 rnHsVectDecl (HsVect _ _var _rhs)
   = failWith $ vcat
@@ -1112,24 +1112,26 @@ rnHsVectDecl (HsVect _ _var _rhs)
                , text "must be an identifier"
                ]
 rnHsVectDecl (HsNoVect s var)
-  = do { var' <- lookupLocatedTopBndrRn var           -- only applies to local (not imported) names
-       ; return (HsNoVect s var', unitFV (unLoc var'))
+  = do { var' <- lookupLEmbellishedTopBndrRn var
+                 -- only applies to local (not imported) names
+       ; return (HsNoVect s var', unitFV (unLocEmb var'))
        }
 rnHsVectDecl (HsVectTypeIn s isScalar tycon Nothing)
-  = do { tycon' <- lookupLocatedOccRn tycon
-       ; return (HsVectTypeIn s isScalar tycon' Nothing, unitFV (unLoc tycon'))
+  = do { tycon' <- lookupLEmbellishedOccRn tycon
+       ; return (HsVectTypeIn s isScalar tycon' Nothing
+                , unitFV (unLocEmb tycon'))
        }
 rnHsVectDecl (HsVectTypeIn s isScalar tycon (Just rhs_tycon))
-  = do { tycon'     <- lookupLocatedOccRn tycon
-       ; rhs_tycon' <- lookupLocatedOccRn rhs_tycon
+  = do { tycon'     <- lookupLEmbellishedOccRn tycon
+       ; rhs_tycon' <- lookupLEmbellishedOccRn rhs_tycon
        ; return ( HsVectTypeIn s isScalar tycon' (Just rhs_tycon')
-                , mkFVs [unLoc tycon', unLoc rhs_tycon'])
+                , mkFVs [unLocEmb tycon', unLocEmb rhs_tycon'])
        }
 rnHsVectDecl (HsVectTypeOut _ _ _)
   = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectTypeOut'"
 rnHsVectDecl (HsVectClassIn s cls)
-  = do { cls' <- lookupLocatedOccRn cls
-       ; return (HsVectClassIn s cls', unitFV (unLoc cls'))
+  = do { cls' <- lookupLEmbellishedOccRn cls
+       ; return (HsVectClassIn s cls', unitFV (unLocEmb cls'))
        }
 rnHsVectDecl (HsVectClassOut _)
   = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'"
@@ -1514,8 +1516,8 @@ rnRoleAnnots tc_names role_annots
               -- decls defined in this group (see #10263)
              tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt tc_names)
                                           (text "role annotation")
-                                          tycon
-           ; return $ RoleAnnotDecl tycon' roles }
+                                          (unLEmb tycon)
+           ; return $ RoleAnnotDecl (reLEmb tycon (unLoc tycon')) roles }
 
 dupRoleAnnotErr :: [LRoleAnnotDecl RdrName] -> RnM ()
 dupRoleAnnotErr [] = panic "dupRoleAnnotErr"
@@ -1701,7 +1703,8 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
 
         -- Check the signatures
         -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
-        ; let sig_rdr_names_w_locs = [op | L _ (ClassOpSig False ops _) <- sigs
+        ; let sig_rdr_names_w_locs = [unLEmb op
+                                         | L _ (ClassOpSig False ops _) <- sigs
                                          , op <- ops]
         ; checkDupRdrNames sig_rdr_names_w_locs
                 -- Typechecker is responsible for checking that we only
@@ -2014,8 +2017,8 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs
                            , con_cxt = mcxt, con_details = details
                            , con_doc = mb_doc })
   = do  { _ <- addLocM checkConName name
-        ; new_name     <- lookupLocatedTopBndrRn name
-        ; let doc = ConDeclCtx [new_name]
+        ; new_name     <- lookupLEmbellishedTopBndrRn name
+        ; let doc = ConDeclCtx [unLEmb new_name]
         ; mb_doc'      <- rnMbLHsDoc mb_doc
         ; (kvs, qtvs') <- get_con_qtvs (hsConDeclArgTys details)
 
@@ -2025,7 +2028,8 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs
                              Nothing   -> return (Nothing,emptyFVs)
                              Just lcxt -> do { (lctx',fvs) <- rnContext doc lcxt
                                              ; return (Just lctx',fvs) }
-        ; (new_details, fvs2) <- rnConDeclDetails (unLoc new_name) doc details
+        ; (new_details, fvs2)
+                            <- rnConDeclDetails (unLocEmb new_name) doc details
         ; let (new_details',fvs3) = (new_details,emptyFVs)
         ; traceRn "rnConDecl" (ppr name <+> vcat
              [ text "free_kvs:" <+> ppr kvs
@@ -2055,8 +2059,8 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs
 rnConDecl decl@(ConDeclGADT { con_names = names, con_type = ty
                             , con_doc = mb_doc })
   = do  { mapM_ (addLocM checkConName) names
-        ; new_names    <- mapM lookupLocatedTopBndrRn names
-        ; let doc = ConDeclCtx new_names
+        ; new_names    <- mapM lookupLEmbellishedTopBndrRn names
+        ; let doc = ConDeclCtx $ map unLEmb new_names
         ; mb_doc'      <- rnMbLHsDoc mb_doc
 
         ; (ty', fvs) <- rnHsSigType doc ty
@@ -2115,16 +2119,16 @@ extendPatSynEnv val_decls local_fix_env thing = do {
       | L bind_loc (PatSynBind (PSB { psb_id = L _ n
                                     , psb_args = RecordPatSyn as })) <- bind
       = do
-          bnd_name <- newTopSrcBinder (L bind_loc n)
-          let rnames = map recordPatSynSelectorId as
-              mkFieldOcc :: Located RdrName -> LFieldOcc RdrName
+          bnd_name <- newTopSrcBinder (L bind_loc $ unEmb n)
+          let rnames = map (lEmb . recordPatSynSelectorId) as
+              mkFieldOcc :: LEmbellished RdrName -> LFieldOcc RdrName
               mkFieldOcc (L l name) = L l (FieldOcc (L l name) PlaceHolder)
               field_occs =  map mkFieldOcc rnames
           flds     <- mapM (newRecordSelector False [bnd_name]) field_occs
           return ((bnd_name, flds): names)
       | L bind_loc (PatSynBind (PSB { psb_id = L _ n})) <- bind
       = do
-        bnd_name <- newTopSrcBinder (L bind_loc n)
+        bnd_name <- newTopSrcBinder (L bind_loc $ unEmb n)
         return ((bnd_name, []): names)
       | otherwise
       = return names
index b927a89..7e068c4 100644 (file)
@@ -112,7 +112,7 @@ rnBracket e br_body
 
 rn_bracket :: ThStage -> HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
 rn_bracket outer_stage br@(VarBr flg rdr_name)
-  = do { name <- lookupOccRn rdr_name
+  = do { name <- lookupOccRn $ unLocEmb rdr_name
        ; this_mod <- getModule
 
        ; when (flg && nameIsLocalOrFrom this_mod name) $
@@ -133,7 +133,7 @@ rn_bracket outer_stage br@(VarBr flg rdr_name)
                                              (quotedNameStageErr br) }
                         }
                     }
-       ; return (VarBr flg name, unitFV name) }
+       ; return (VarBr flg (reLEmb rdr_name name), unitFV name) }
 
 rn_bracket _ (ExpBr e) = do { (e', fvs) <- rnLExpr e
                             ; return (ExpBr e', fvs) }
@@ -344,11 +344,11 @@ mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString -> LHs
 -- which is what we must run in a quasi-quote
 mkQuasiQuoteExpr flavour quoter q_span quote
   = L q_span $ HsApp (L q_span $
-                      HsApp (L q_span (HsVar (L q_span quote_selector)))
+                      HsApp (L q_span (HsVar (L q_span $ EName quote_selector)))
                             quoterExpr)
                      quoteExpr
   where
-    quoterExpr = L q_span $! HsVar $! (L q_span quoter)
+    quoterExpr = L q_span $! HsVar $! (L q_span $ EName quoter)
     quoteExpr  = L q_span $! HsLit $! HsString NoSourceText quote
     quote_selector = case flavour of
                        UntypedExpSplice  -> quoteExpName
index b740647..8fe4abd 100644 (file)
@@ -465,8 +465,8 @@ rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau })
                 , fvs1 `plusFV` fvs2) }
 
 rnHsTyKi env (HsTyVar ip (L loc rdr_name))
-  = do { name <- rnTyVar env rdr_name
-       ; return (HsTyVar ip (L loc name), unitFV name) }
+  = do { name <- rnTyVar env $ unEmb rdr_name
+       ; return (HsTyVar ip (L loc (reEmb rdr_name name)), unitFV name) }
 
 rnHsTyKi env ty@(HsOpTy ty1 l_op ty2)
   = setSrcSpan (getLoc l_op) $
@@ -563,7 +563,7 @@ rnHsTyKi env overall_ty@(HsAppsTy tys)
          let (non_syms, syms) = splitHsAppsTy tys
 
              -- Step 2: rename the pieces
-       ; (syms1, fvs1)      <- mapFvRn (rnHsTyOp env overall_ty) syms
+       ; (syms1, fvs1)      <- mapFvRn (rnHsTyOp env overall_ty . unLEmb) syms
        ; (non_syms1, fvs2)  <- (mapFvRn . mapFvRn) (rnLHsTyKi env) non_syms
 
              -- Step 3: deal with *. See Note [Dealing with *]
@@ -586,7 +586,8 @@ rnHsTyKi env overall_ty@(HsAppsTy tys)
                    (non_syms1 : non_syms2 : non_syms) (L loc star : ops)
       | star `hasKey` starKindTyConKey || star `hasKey` unicodeStarKindTyConKey
       = deal_with_star acc1 acc2
-                       ((non_syms1 ++ L loc (HsTyVar NotPromoted (L loc star))
+                       ((non_syms1
+                            ++ L loc (HsTyVar NotPromoted (L loc $ EName star))
                             : non_syms2) : non_syms)
                        ops
     deal_with_star acc1 acc2 (non_syms1 : non_syms) (op1 : ops)
@@ -1104,7 +1105,7 @@ rnField fl_env env (L l (ConDeclField names ty haddock_doc))
     lookupField :: FieldOcc RdrName -> FieldOcc Name
     lookupField (FieldOcc (L lr rdr) _) = FieldOcc (L lr rdr) (flSelector fl)
       where
-        lbl = occNameFS $ rdrNameOcc rdr
+        lbl = occNameFS $ rdrNameOcc $ unEmb rdr
         fl  = expectJust "rnField" $ lookupFsEnv fl_env lbl
 
 {-
@@ -1239,7 +1240,7 @@ instance Outputable OpName where
 get_op :: LHsExpr Name -> OpName
 -- An unbound name could be either HsVar or HsUnboundVar
 -- See RnExpr.rnUnboundVar
-get_op (L _ (HsVar (L _ n)))   = NormalOp n
+get_op (L _ (HsVar (L _ n)))   = NormalOp $ unEmb n
 get_op (L _ (HsUnboundVar uv)) = UnboundOp uv
 get_op (L _ (HsRecFld fld))    = RecFldOp fld
 get_op other                   = pprPanic "get_op" (ppr other)
@@ -1643,7 +1644,7 @@ extract_lkind = extract_lty KindLevel
 extract_lty :: TypeOrKind -> LHsType RdrName -> FreeKiTyVars -> RnM FreeKiTyVars
 extract_lty t_or_k (L _ ty) acc
   = case ty of
-      HsTyVar _  ltv            -> extract_tv t_or_k ltv acc
+      HsTyVar _  ltv            -> extract_tv t_or_k (unLEmb ltv) acc
       HsBangTy _ ty             -> extract_lty t_or_k ty acc
       HsRecTy flds              -> foldrM (extract_lty t_or_k
                                            . cd_fld_type . unLoc) acc
@@ -1687,7 +1688,7 @@ extract_apps t_or_k tys acc = foldrM (extract_app t_or_k) acc tys
 
 extract_app :: TypeOrKind -> LHsAppType RdrName -> FreeKiTyVars
             -> RnM FreeKiTyVars
-extract_app t_or_k (L _ (HsAppInfix tv))  acc = extract_tv t_or_k tv acc
+extract_app t_or_k (L _ (HsAppInfix tv)) acc = extract_tv t_or_k (unLEmb tv) acc
 extract_app t_or_k (L _ (HsAppPrefix ty)) acc = extract_lty t_or_k ty acc
 
 extract_hs_tv_bndrs :: [LHsTyVarBndr RdrName] -> FreeKiTyVars
index 75b17ef..57b2f46 100644 (file)
@@ -94,7 +94,7 @@ newMethodFromName origin name inst_ty
        ; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta )
                  instCall origin [inst_ty] theta
 
-       ; return (mkHsWrap wrap (HsVar (noLoc id))) }
+       ; return (mkHsWrap wrap (HsVar (noEmb id))) }
 
 {-
 ************************************************************************
@@ -530,7 +530,7 @@ newNonTrivialOverloadedLit orig
                , ol_rebindable = rebindable }) res_ty
   = do  { hs_lit <- mkOverLit val
         ; let lit_ty = hsLitType hs_lit
-        ; (_, fi') <- tcSyntaxOp orig (mkRnSyntaxExpr meth_name)
+        ; (_, fi') <- tcSyntaxOp orig (mkRnSyntaxExpr $ unEmb meth_name)
                                       [synKnownType lit_ty] res_ty $
                       \_ -> return ()
         ; let L _ witness = nlHsSyntaxApps fi' [nlHsLit hs_lit]
@@ -593,7 +593,7 @@ tcSyntaxName :: CtOrigin
 -- See Note [CmdSyntaxTable] in HsExpr
 
 tcSyntaxName orig ty (std_nm, HsVar (L _ user_nm))
-  | std_nm == user_nm
+  | std_nm == unEmb user_nm
   = do rhs <- newMethodFromName orig std_nm ty
        return (std_nm, rhs)
 
index 7b3cc65..5d1f5a1 100644 (file)
@@ -42,7 +42,8 @@ tcAnnotation (L loc ann@(HsAnnotation _ provenance expr)) = do
                   , text "See https://ghc.haskell.org/trac/ghc/ticket/10826" ]
 
 annProvenanceToTarget :: Module -> AnnProvenance Name -> AnnTarget Name
-annProvenanceToTarget _   (ValueAnnProvenance (L _ name)) = NamedTarget name
+annProvenanceToTarget _   (ValueAnnProvenance (L _ name))
+  = NamedTarget $ unEmb name
 annProvenanceToTarget _   (TypeAnnProvenance (L _ name))  = NamedTarget name
 annProvenanceToTarget mod ModuleAnnProvenance             = ModuleTarget mod
 
index 25c4061..b451984 100644 (file)
@@ -235,7 +235,7 @@ tcCompleteSigs sigs =
            addErrCtxt (text "In" <+> ppr c) $
             case mtc of
               Nothing -> infer_complete_match
-              Just tc -> check_complete_match tc
+              Just tc -> check_complete_match $ unLEmb tc
         where
 
           checkCLTypes acc = foldM checkCLType (acc, []) (unLoc lns)
@@ -259,10 +259,10 @@ tcCompleteSigs sigs =
 
 
       -- See note [Typechecking Complete Matches]
-      checkCLType :: (CompleteSigType, [ConLike]) -> Located Name
+      checkCLType :: (CompleteSigType, [ConLike]) -> LEmbellished Name
                   -> TcM (CompleteSigType, [ConLike])
       checkCLType (cst, cs) n = do
-        cl <- addLocM tcLookupConLike n
+        cl <- addLocM tcLookupConLike $ unLEmb n
         let   (_,_,_,_,_,_, res_ty) = conLikeFullSig cl
               res_ty_con = fst <$> splitTyConApp_maybe res_ty
         case (cst, res_ty_con) of
@@ -315,8 +315,8 @@ tcHsBootSigs binds sigs
       where
         f (L _ name)
           = do { sigma_ty <- solveEqualities $
-                             tcHsSigWcType (FunSigCtxt name False) hs_ty
-               ; return (mkVanillaGlobal name sigma_ty) }
+                             tcHsSigWcType (FunSigCtxt (unEmb name) False) hs_ty
+               ; return (mkVanillaGlobal (unEmb name) sigma_ty) }
         -- Notice that we make GlobalIds, not LocalIds
     tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s)
 
@@ -527,7 +527,7 @@ tc_single _top_lvl sig_fn _prag_fn
        }
   where
     tc_pat_syn_decl :: TcM (LHsBinds TcId, TcGblEnv)
-    tc_pat_syn_decl = case sig_fn name of
+    tc_pat_syn_decl = case sig_fn $ unEmb name of
         Nothing                 -> tcInferPatSynDecl psb
         Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi
         Just                 _  -> panic "tc_single"
@@ -1139,34 +1139,35 @@ tcVect :: VectDecl Name -> TcM (VectDecl TcId)
 --   from the vectoriser here.
 tcVect (HsVect s name rhs)
   = addErrCtxt (vectCtxt name) $
-    do { var <- wrapLocM tcLookupId name
+    do { var <- wrapLocM tcLookupId $ unLEmb name
        ; let L rhs_loc (HsVar (L lv rhs_var_name)) = rhs
-       ; rhs_id <- tcLookupId rhs_var_name
-       ; return $ HsVect s var (L rhs_loc (HsVar (L lv rhs_id)))
+       ; rhs_id <- tcLookupId $ unEmb rhs_var_name
+       ; return $ HsVect s (reLEmb name (unLoc var))
+                          (L rhs_loc (HsVar (L lv (reEmb rhs_var_name rhs_id))))
        }
 
 tcVect (HsNoVect s name)
-  = addErrCtxt (vectCtxt name) $
-    do { var <- wrapLocM tcLookupId name
-       ; return $ HsNoVect s var
+  = addErrCtxt (vectCtxt $ unLEmb name) $
+    do { var <- wrapLocM tcLookupId $ unLEmb name
+       ; return $ HsNoVect s (reLEmb name (unLoc var))
        }
 tcVect (HsVectTypeIn _ isScalar lname rhs_name)
   = addErrCtxt (vectCtxt lname) $
-    do { tycon <- tcLookupLocatedTyCon lname
+    do { tycon <- tcLookupLocatedTyCon $ unLEmb lname
        ; checkTc (   not isScalar             -- either    we have a non-SCALAR declaration
                  || isJust rhs_name           -- or        we explicitly provide a vectorised type
                  || tyConArity tycon == 0     -- otherwise the type constructor must be nullary
                  )
                  scalarTyConMustBeNullary
 
-       ; rhs_tycon <- fmapMaybeM (tcLookupTyCon . unLoc) rhs_name
+       ; rhs_tycon <- fmapMaybeM (tcLookupTyCon . unLocEmb) rhs_name
        ; return $ HsVectTypeOut isScalar tycon rhs_tycon
        }
 tcVect (HsVectTypeOut _ _ _)
   = panic "TcBinds.tcVect: Unexpected 'HsVectTypeOut'"
 tcVect (HsVectClassIn _ lname)
   = addErrCtxt (vectCtxt lname) $
-    do { cls <- tcLookupLocatedClass lname
+    do { cls <- tcLookupLocatedClass $ unLEmb lname
        ; return $ HsVectClassOut cls
        }
 tcVect (HsVectClassOut _)
index 3b9e6ac..ee49f7f 100644 (file)
@@ -135,8 +135,10 @@ tcClassSigs clas sigs def_methods
        ; traceTc "tcClassSigs 2" (ppr clas)
        ; return op_info }
   where
-    vanilla_sigs = [L loc (nm,ty) | L loc (ClassOpSig False nm ty) <- sigs]
-    gen_sigs     = [L loc (nm,ty) | L loc (ClassOpSig True  nm ty) <- sigs]
+    vanilla_sigs = [L loc (map unLEmb nm,ty)
+                      | L loc (ClassOpSig False nm ty) <- sigs]
+    gen_sigs     = [L loc (map unLEmb nm,ty)
+                      | L loc (ClassOpSig True  nm ty) <- sigs]
     dm_bind_names :: [Name]     -- These ones have a value binding in the class decl
     dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]
 
@@ -346,7 +348,7 @@ mkHsSigFun sigs = lookupNameEnv env
     env = mkHsSigEnv get_classop_sig sigs
 
     get_classop_sig :: LSig Name -> Maybe ([Located Name], LHsSigType Name)
-    get_classop_sig  (L _ (ClassOpSig _ ns hs_ty)) = Just (ns, hs_ty)
+    get_classop_sig  (L _ (ClassOpSig _ ns hs_ty)) = Just (map unLEmb ns,hs_ty)
     get_classop_sig  _                             = Nothing
 
 ---------------------------
@@ -372,7 +374,7 @@ findMinimalDef :: [LSig Name] -> Maybe ClassMinimalDef
 findMinimalDef = firstJusts . map toMinimalDef
   where
     toMinimalDef :: LSig Name -> Maybe ClassMinimalDef
-    toMinimalDef (L _ (MinimalSig _ (L _ bf))) = Just (fmap unLoc bf)
+    toMinimalDef (L _ (MinimalSig _ (L _ bf))) = Just (fmap unLocEmb bf)
     toMinimalDef _                             = Nothing
 
 {-
index 7b19cd0..715da1f 100644 (file)
@@ -575,13 +575,13 @@ tcAddDataFamConPlaceholders inst_decls thing_inside
 
     get_fi_cons :: DataFamInstDecl Name -> [Name]
     get_fi_cons (DataFamInstDecl { dfid_defn = HsDataDefn { dd_cons = cons } })
-      = map unLoc $ concatMap (getConNames . unLoc) cons
+      = map unLocEmb $ concatMap (getConNames . unLoc) cons
 
 
 tcAddPatSynPlaceholders :: [PatSynBind Name Name] -> TcM a -> TcM a
 -- See Note [Don't promote pattern synonyms]
 tcAddPatSynPlaceholders pat_syns thing_inside
-  = tcExtendKindEnv2 [ (name, APromotionErr PatSynPE)
+  = tcExtendKindEnv2 [ (unEmb name, APromotionErr PatSynPE)
                      | PSB{ psb_id = L _ name } <- pat_syns ]
        thing_inside
 
@@ -593,8 +593,8 @@ getTypeSigNames sigs
     get_type_sig :: LSig Name -> NameSet -> NameSet
     get_type_sig sig ns =
       case sig of
-        L _ (TypeSig names _) -> extendNameSetList ns (map unLoc names)
-        L _ (PatSynSig names _) -> extendNameSetList ns (map unLoc names)
+        L _ (TypeSig names _) -> extendNameSetList ns (map unLocEmb names)
+        L _ (PatSynSig names _) -> extendNameSetList ns (map unLocEmb names)
         _ -> ns
 
 
index 6d4e3de..1f9d253 100644 (file)
@@ -30,6 +30,7 @@ import DataCon
 import TcEvidence
 import HsExpr  ( UnboundVar(..) )
 import HsBinds ( PatSynBind(..) )
+import HsEmbellished
 import Name
 import RdrName ( lookupGlobalRdrEnv, lookupGRE_Name, GlobalRdrEnv
                , mkRdrUnqual, isLocalGRE, greSrcSpan )
@@ -2347,7 +2348,7 @@ ctxtFixes has_ambig_tvs pred implics
 discardProvCtxtGivens :: CtOrigin -> [UserGiven] -> [UserGiven]
 discardProvCtxtGivens orig givens  -- See Note [discardProvCtxtGivens]
   | ProvCtxtOrigin (PSB {psb_id = L _ name}) <- orig
-  = filterOut (discard name) givens
+  = filterOut (discard $ unEmb name) givens
   | otherwise
   = givens
   where
index fe2bbab..645fa7b 100644 (file)
@@ -163,7 +163,7 @@ NB: The res_ty is always deeply skolemised.
 -}
 
 tcExpr :: HsExpr Name -> ExpRhoType -> TcM (HsExpr TcId)
-tcExpr (HsVar (L _ name)) res_ty = tcCheckId name res_ty
+tcExpr (HsVar (L _ name)) res_ty = tcCheckId (unEmb name) res_ty
 tcExpr (HsUnboundVar uv)  res_ty = tcUnboundId uv res_ty
 
 tcExpr e@(HsApp {})     res_ty = tcApp1 e res_ty
@@ -207,7 +207,7 @@ tcExpr e@(HsIPVar x) res_ty
        ; let ip_name = mkStrLitTy (hsIPNameFS x)
        ; ipClass <- tcLookupClass ipClassName
        ; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty])
-       ; tcWrapResult e (fromDict ipClass ip_name ip_ty (HsVar (noLoc ip_var)))
+       ; tcWrapResult e (fromDict ipClass ip_name ip_ty (HsVar (noEmb ip_var)))
                       ip_ty res_ty }
   where
   -- Coerces a dictionary for `IP "x" t` into `t`.
@@ -225,7 +225,8 @@ tcExpr e@(HsOverLabel mb_fromLabel l) res_ty
                          ; let pred = mkClassPred isLabelClass [lbl, alpha]
                          ; loc <- getSrcSpanM
                          ; var <- emitWantedEvVar origin pred
-                         ; tcWrapResult e (fromDict pred (HsVar (L loc var)))
+                         ; tcWrapResult e (fromDict pred
+                                           (HsVar (L loc $ EName var)))
                                         alpha res_ty } }
   where
   -- Coerces a dictionary for `IsLabel "x" t` into `t`,
@@ -235,7 +236,7 @@ tcExpr e@(HsOverLabel mb_fromLabel l) res_ty
   lbl = mkStrLitTy l
 
   applyFromLabel loc fromLabel =
-    L loc (HsVar (L loc fromLabel)) `HsAppType`
+    L loc (HsVar (L loc $ EName fromLabel)) `HsAppType`
       mkEmptyWildCardBndrs (L loc (HsTyLit (HsStrTy NoSourceText l)))
 
 tcExpr (HsLam match) res_ty
@@ -346,20 +347,20 @@ See also Note [seqId magic] in MkId
 
 tcExpr expr@(OpApp arg1 op fix arg2) res_ty
   | (L loc (HsVar (L lv op_name))) <- op
-  , op_name `hasKey` seqIdKey           -- Note [Typing rule for seq]
+  , unEmb op_name `hasKey` seqIdKey           -- Note [Typing rule for seq]
   = do { arg1_ty <- newFlexiTyVarTy liftedTypeKind
        ; let arg2_exp_ty = res_ty
        ; arg1' <- tcArg op arg1 arg1_ty 1
        ; arg2' <- addErrCtxt (funAppCtxt op arg2 2) $
                   tc_poly_expr_nc arg2 arg2_exp_ty
        ; arg2_ty <- readExpType arg2_exp_ty
-       ; op_id <- tcLookupId op_name
+       ; op_id <- tcLookupId $ unEmb op_name
        ; let op' = L loc (HsWrap (mkWpTyApps [arg1_ty, arg2_ty])
-                                 (HsVar (L lv op_id)))
+                                 (HsVar (L lv $ reEmb op_name op_id)))
        ; return $ OpApp arg1' op' fix arg2' }
 
   | (L loc (HsVar (L lv op_name))) <- op
-  , op_name `hasKey` dollarIdKey        -- Note [Typing rule for ($)]
+  , unEmb op_name `hasKey` dollarIdKey        -- Note [Typing rule for ($)]
   = do { traceTc "Application rule" (ppr op)
        ; (arg1', arg1_ty) <- tcInferSigma arg1
 
@@ -390,12 +391,12 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty
        ; wrap_res <- tcSubTypeHR orig1 (Just expr) op_res_ty res_ty
                        -- op_res -> res
 
-       ; op_id  <- tcLookupId op_name
+       ; op_id  <- tcLookupId $ unEmb op_name
        ; res_ty <- readExpType res_ty
        ; let op' = L loc (HsWrap (mkWpTyApps [ getRuntimeRep "tcExpr ($)" res_ty
                                              , arg2_sigma
                                              , res_ty])
-                                 (HsVar (L lv op_id)))
+                                 (HsVar (L lv $ reEmb op_name op_id)))
              -- arg1' :: arg1_ty
              -- wrap_arg1 :: arg1_ty "->" (arg2_sigma -> op_res_ty)
              -- wrap_res :: op_res_ty "->" res_ty
@@ -819,7 +820,8 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty
         -- After this we know that rbinds is unambiguous
         ; rbinds <- disambiguateRecordBinds record_expr record_rho rbnds res_ty
         ; let upd_flds = map (unLoc . hsRecFieldLbl . unLoc) rbinds
-              upd_fld_occs = map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds
+              upd_fld_occs = map (occNameFS . rdrNameOcc
+                                  . unEmb . rdrNameAmbiguousFieldOcc) upd_flds
               sel_ids      = map selectorAmbiguousFieldOcc upd_flds
         -- STEP 0
         -- Check that the field names are really field names
@@ -1143,14 +1145,14 @@ tcApp m_herald orig_fun orig_args res_ty
     go (L _ (HsAppType e t)) args = go e  (Right t:args)
 
     go (L loc (HsVar (L _ fun))) args
-      | fun `hasKey` tagToEnumKey
+      | unEmb fun `hasKey` tagToEnumKey
       , count isLeft args == 1
-      = do { (wrap, expr, args) <- tcTagToEnum loc fun args res_ty
+      = do { (wrap, expr, args) <- tcTagToEnum loc (unEmb fun) args res_ty
            ; return (wrap, expr, args) }
 
-      | fun `hasKey` seqIdKey
+      | unEmb fun `hasKey` seqIdKey
       , count isLeft args == 2
-      = do { (wrap, expr, args) <- tcSeq loc fun args res_ty
+      = do { (wrap, expr, args) <- tcSeq loc (unEmb fun) args res_ty
            ; return (wrap, expr, args) }
 
     go (L loc (HsRecFld (Ambiguous lbl _))) args@(Left (L _ arg) : _)
@@ -1191,7 +1193,7 @@ mk_op_msg op = text "The operator" <+> quotes (ppr op) <+> text "takes"
 tcInferFun :: LHsExpr Name -> TcM (LHsExpr TcId, TcSigmaType)
 -- Infer type of a function
 tcInferFun (L loc (HsVar (L _ name)))
-  = do { (fun, ty) <- setSrcSpan loc (tcInferId name)
+  = do { (fun, ty) <- setSrcSpan loc (tcInferId $ unEmb name)
                -- Don't wrap a context around a plain Id
        ; return (L loc fun, ty) }
 
@@ -1309,7 +1311,7 @@ tcSyntaxOpGen :: CtOrigin
               -> TcM (a, SyntaxExpr TcId)
 tcSyntaxOpGen orig (SyntaxExpr { syn_expr = HsVar (L _ op) })
               arg_tys res_ty thing_inside
-  = do { (expr, sigma) <- tcInferId op
+  = do { (expr, sigma) <- tcInferId $ unEmb op
        ; (result, expr_wrap, arg_wraps, res_wrap)
            <- tcSynArgA orig sigma arg_tys res_ty $
               thing_inside
@@ -1580,14 +1582,15 @@ tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr TcId)
 tcCheckId name res_ty
   = do { (expr, actual_res_ty) <- tcInferId name
        ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty])
-       ; addFunResCtxt False (HsVar (noLoc name)) actual_res_ty res_ty $
+       ; addFunResCtxt False (HsVar (noEmb name)) actual_res_ty res_ty $
          tcWrapResultO (OccurrenceOf name)  expr actual_res_ty res_ty }
 
 tcCheckRecSelId :: AmbiguousFieldOcc Name -> ExpRhoType -> TcM (HsExpr TcId)
 tcCheckRecSelId f@(Unambiguous (L _ lbl) _) res_ty
   = do { (expr, actual_res_ty) <- tcInferRecSelId f
        ; addFunResCtxt False (HsRecFld f) actual_res_ty res_ty $
-         tcWrapResultO (OccurrenceOfRecSel lbl) expr actual_res_ty res_ty }
+         tcWrapResultO (OccurrenceOfRecSel $ unEmb lbl) expr
+                       actual_res_ty res_ty }
 tcCheckRecSelId (Ambiguous lbl _) res_ty
   = case tcSplitFunTy_maybe =<< checkingExpType_maybe res_ty of
       Nothing       -> ambiguousSelector lbl
@@ -1597,7 +1600,7 @@ tcCheckRecSelId (Ambiguous lbl _) res_ty
 ------------------------
 tcInferRecSelId :: AmbiguousFieldOcc Name -> TcM (HsExpr TcId, TcRhoType)
 tcInferRecSelId (Unambiguous (L _ lbl) sel)
-  = do { (expr', ty) <- tc_infer_id lbl sel
+  = do { (expr', ty) <- tc_infer_id (unEmb lbl) sel
        ; return (expr', ty) }
 tcInferRecSelId (Ambiguous lbl _)
   = ambiguousSelector lbl
@@ -1629,7 +1632,7 @@ tc_infer_assert assert_name
   = do { assert_error_id <- tcLookupId assertErrorName
        ; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name)
                                           (idType assert_error_id)
-       ; return (mkHsWrap wrap (HsVar (noLoc assert_error_id)), id_rho)
+       ; return (mkHsWrap wrap (HsVar (noEmb assert_error_id)), id_rho)
        }
 
 tc_infer_id :: RdrName -> Name -> TcM (HsExpr TcId, TcSigmaType)
@@ -1655,7 +1658,7 @@ tc_infer_id lbl id_name
              _ -> failWithTc $
                   ppr thing <+> text "used where a value identifier was expected" }
   where
-    return_id id = return (HsVar (noLoc id), idType id)
+    return_id id = return (HsVar (noEmb id), idType id)
 
     return_data_con con
        -- For data constructors, must perform the stupid-theta check
@@ -1703,7 +1706,7 @@ tcUnboundId unbound res_ty
                                               , ctev_loc  = loc}
                            , cc_hole = ExprHole unbound }
       ; emitInsoluble can
-      ; tcWrapResultO (UnboundOccurrenceOf occ) (HsVar (noLoc ev)) ty res_ty }
+      ; tcWrapResultO (UnboundOccurrenceOf occ) (HsVar (noEmb ev)) ty res_ty }
 
 
 {-
@@ -1785,7 +1788,7 @@ tcSeq loc fun_name args res_ty
         ; arg1' <- tcMonoExpr arg1 (mkCheckExpType arg1_ty)
         ; arg2' <- tcMonoExpr arg2 arg2_exp_ty
         ; res_ty <- readExpType res_ty  -- by now, it's surely filled in
-        ; let fun'    = L loc (HsWrap ty_args (HsVar (L loc fun)))
+        ; let fun'    = L loc (HsWrap ty_args (HsVar (L loc $ EName fun)))
               ty_args = WpTyApp res_ty <.> WpTyApp arg1_ty
         ; return (idHsWrapper, fun', [Left arg1', Left arg2']) }
 
@@ -1827,7 +1830,7 @@ tcTagToEnum loc fun_name args res_ty
                  (mk_error ty' doc2)
 
        ; arg' <- tcMonoExpr arg (mkCheckExpType intPrimTy)
-       ; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar (L loc fun)))
+       ; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar (L loc $ EName fun)))
              rep_ty = mkTyConApp rep_tc rep_args
 
        ; return (mkWpCastR (mkTcSymCo coi), fun', [Left arg']) }
@@ -1905,7 +1908,7 @@ checkCrossStageLifting id (Brack _ (TcPending ps_var lie_var))
         ; lift <- if isStringTy id_ty then
                      do { sid <- tcLookupId THNames.liftStringName
                                      -- See Note [Lifting strings]
-                        ; return (HsVar (noLoc sid)) }
+                        ; return (HsVar (noEmb sid)) }
                   else
                      setConstraintVar lie_var   $
                           -- Put the 'lift' constraint into the right LIE
@@ -2069,26 +2072,26 @@ See also Note [HsRecField and HsRecUpdField] in HsPat.
 -- Given a RdrName that refers to multiple record fields, and the type
 -- of its argument, try to determine the name of the selector that is
 -- meant.
-disambiguateSelector :: Located RdrName -> Type -> TcM Name
+disambiguateSelector :: LEmbellished RdrName -> Type -> TcM Name
 disambiguateSelector lr@(L _ rdr) parent_type
  = do { fam_inst_envs <- tcGetFamInstEnvs
       ; case tyConOf fam_inst_envs parent_type of
           Nothing -> ambiguousSelector lr
           Just p  ->
-            do { xs <- lookupParents rdr
+            do { xs <- lookupParents $ unEmb rdr
                ; let parent = RecSelData p
                ; case lookup parent xs of
                    Just gre -> do { addUsedGRE True gre
                                   ; return (gre_name gre) }
-                   Nothing  -> failWithTc (fieldNotInType parent rdr) } }
+                   Nothing  -> failWithTc (fieldNotInType parent $ unEmb rdr) }}
 
 -- This field name really is ambiguous, so add a suitable "ambiguous
 -- occurrence" error, then give up.
-ambiguousSelector :: Located RdrName -> TcM a
+ambiguousSelector :: LEmbellished RdrName -> TcM a
 ambiguousSelector (L _ rdr)
   = do { env <- getGlobalRdrEnv
-       ; let gres = lookupGRE_RdrName rdr env
-       ; setErrCtxt [] $ addNameClashErrRn rdr gres
+       ; let gres = lookupGRE_RdrName (unEmb rdr) env
+       ; setErrCtxt [] $ addNameClashErrRn (unEmb rdr) gres
        ; failM }
 
 -- Disambiguate the fields in a record update.
@@ -2123,7 +2126,7 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty
                                 , [(RecSelParent, GlobalRdrElt)])]
     getUpdFieldsParents
       = fmap (zip rbnds) $ mapM
-          (lookupParents . unLoc . hsRecUpdFieldRdr . unLoc)
+          (lookupParents . unLocEmb . hsRecUpdFieldRdr . unLoc)
           rbnds
 
     -- Given a the lists of possible parents for each field,
@@ -2172,7 +2175,7 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty
                       -- The field doesn't belong to this parent, so report
                       -- an error but keep going through all the fields
           Nothing  -> do { addErrTc (fieldNotInType p
-                                      (unLoc (hsRecUpdFieldRdr (unLoc upd))))
+                                      (unLocEmb (hsRecUpdFieldRdr (unLoc upd))))
                          ; lookupSelector (upd, gre_name (snd (head xs))) }
 
     -- Given a (field update, selector name) pair, look up the
@@ -2311,7 +2314,7 @@ tcRecordField con_like flds_w_tys (L loc (FieldOcc lbl sel_name)) rhs
       = do { addErrTc (badFieldCon con_like field_lbl)
            ; return Nothing }
   where
-        field_lbl = occNameFS $ rdrNameOcc (unLoc lbl)
+        field_lbl = occNameFS $ rdrNameOcc (unLocEmb lbl)
 
 
 checkMissingFields ::  ConLike -> HsRecordBinds Name -> TcM ()
@@ -2469,7 +2472,8 @@ badFieldsUpd rbinds data_cons
     membership :: [(FieldLabelString, [Bool])]
     membership = sortMembership $
         map (\fld -> (fld, map (Set.member fld) fieldLabelSets)) $
-          map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) rbinds
+          map (occNameFS . rdrNameOcc . unEmb . rdrNameAmbiguousFieldOcc
+               . unLoc . hsRecFieldLbl . unLoc) rbinds
 
     fieldLabelSets :: [Set.Set FieldLabelString]
     fieldLabelSets = map (Set.fromList . map flLabel . conLikeFieldLabels) data_cons
index 533664e..f0fe864 100644 (file)
@@ -773,7 +773,7 @@ gen_Ix_binds loc tycon = do
 
     enum_index dflags
       = mk_easy_FunBind loc unsafeIndex_RDR
-                [noLoc (AsPat (noLoc c_RDR)
+                [noLoc (AsPat (noEmb c_RDR)
                            (nlTuplePat [a_Pat, nlWildPat] Boxed)),
                                 d_Pat] (
            untag_Expr dflags tycon [(a_RDR, ah_RDR)] (
@@ -1314,7 +1314,7 @@ gen_data dflags data_type_name constr_names loc rep_tc
     genDataTyCon :: DerivStuff
     genDataTyCon        --  $dT
       = DerivHsBind (mkHsVarBind loc data_type_name rhs,
-                     L loc (TypeSig [L loc data_type_name] sig_ty))
+                     L loc (TypeSig [L loc (EName data_type_name)] sig_ty))
 
     sig_ty = mkLHsSigWcType (nlHsTyVar dataType_RDR)
     rhs    = nlHsVar mkDataType_RDR
@@ -1324,7 +1324,7 @@ gen_data dflags data_type_name constr_names loc rep_tc
     genDataDataCon :: DataCon -> RdrName -> DerivStuff
     genDataDataCon dc constr_name       --  $cT1 etc
       = DerivHsBind (mkHsVarBind loc constr_name rhs,
-                     L loc (TypeSig [L loc constr_name] sig_ty))
+                     L loc (TypeSig [L loc (EName constr_name)] sig_ty))
       where
         sig_ty   = mkLHsSigWcType (nlHsTyVar constr_RDR)
         rhs      = nlHsApps mkConstr_RDR constr_args
@@ -1753,7 +1753,7 @@ genAuxBindSpec :: DynFlags -> SrcSpan -> AuxBindSpec
                   -> (LHsBind RdrName, LSig RdrName)
 genAuxBindSpec dflags loc (DerivCon2Tag tycon)
   = (mk_FunBind loc rdr_name eqns,
-     L loc (TypeSig [L loc rdr_name] sig_ty))
+     L loc (TypeSig [L loc (EName rdr_name)] sig_ty))
   where
     rdr_name = con2tag_RDR dflags tycon
 
@@ -1779,7 +1779,7 @@ genAuxBindSpec dflags loc (DerivTag2Con tycon)
   = (mk_FunBind loc rdr_name
         [([nlConVarPat intDataCon_RDR [a_RDR]],
            nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
-     L loc (TypeSig [L loc rdr_name] sig_ty))
+     L loc (TypeSig [L loc (EName rdr_name)] sig_ty))
   where
     sig_ty = mkLHsSigWcType $ L loc $
              HsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $
@@ -1789,7 +1789,7 @@ genAuxBindSpec dflags loc (DerivTag2Con tycon)
 
 genAuxBindSpec dflags loc (DerivMaxTag tycon)
   = (mkHsVarBind loc rdr_name rhs,
-     L loc (TypeSig [L loc rdr_name] sig_ty))
+     L loc (TypeSig [L loc (EName rdr_name)] sig_ty))
   where
     rdr_name = maxtag_RDR dflags tycon
     sig_ty = mkLHsSigWcType (L loc (HsCoreTy intTy))
index 6ad2b28..113cc24 100644 (file)
@@ -92,7 +92,7 @@ hsPatType (VarPat (L _ var))          = idType var
 hsPatType (BangPat pat)               = hsLPatType pat
 hsPatType (LazyPat pat)               = hsLPatType pat
 hsPatType (LitPat lit)                = hsLitType lit
-hsPatType (AsPat var _)               = idType (unLoc var)
+hsPatType (AsPat var _)               = idType (unLocEmb var)
 hsPatType (ViewPat _ _ ty)            = ty
 hsPatType (ListPat _ ty Nothing)      = mkListTy ty
 hsPatType (ListPat _ _ (Just (ty,_))) = ty
@@ -522,12 +522,12 @@ zonk_bind env (PatSynBind bind@(PSB { psb_id = L loc id
                                     , psb_args = details
                                     , psb_def = lpat
                                     , psb_dir = dir }))
-  = do { id' <- zonkIdBndr env id
+  = do { id' <- zonkIdBndr env $ unEmb id
        ; details' <- zonkPatSynDetails env details
        ; (env1, lpat') <- zonkPat env lpat
        ; (_env2, dir') <- zonkPatSynDir env1 dir
        ; return $ PatSynBind $
-                  bind { psb_id = L loc id'
+                  bind { psb_id = L loc (reEmb id id')
                        , psb_args = details'
                        , psb_def = lpat'
                        , psb_dir = dir' } }
@@ -615,8 +615,8 @@ zonkLExprs env exprs = mapM (zonkLExpr env) exprs
 zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr
 
 zonkExpr env (HsVar (L l id))
-  = ASSERT2( isNothing (isDataConId_maybe id), ppr id )
-    return (HsVar (L l (zonkIdOcc env id)))
+  = ASSERT2( isNothing (isDataConId_maybe $ unEmb id), ppr id )
+    return (HsVar (L l (reEmb id (zonkIdOcc env $ unEmb id))))
 
 zonkExpr _ e@(HsConLikeOut {}) = return e
 
@@ -1204,9 +1204,9 @@ zonk_pat env (BangPat pat)
         ; return (env',  BangPat pat') }
 
 zonk_pat env (AsPat (L loc v) pat)
-  = do  { v' <- zonkIdBndr env v
+  = do  { v' <- zonkIdBndr env (unEmb v)
         ; (env', pat') <- zonkPat (extendIdZonkEnv1 env v') pat
-        ; return (env', AsPat (L loc v') pat') }
+        ; return (env', AsPat (L loc (reEmb v v')) pat') }
 
 zonk_pat env (ViewPat expr pat ty)
   = do  { expr' <- zonkLExpr env expr
@@ -1389,13 +1389,13 @@ zonkVects env = mapM (wrapLocM (zonkVect env))
 
 zonkVect :: ZonkEnv -> VectDecl TcId -> TcM (VectDecl Id)
 zonkVect env (HsVect s v e)
-  = do { v' <- wrapLocM (zonkIdBndr env) v
+  = do { v' <- wrapLocM (zonkIdBndr env) (unLEmb v)
        ; e' <- zonkLExpr env e
-       ; return $ HsVect s v' e'
+       ; return $ HsVect s (reLEmb v (unLoc v')) e'
        }
 zonkVect env (HsNoVect s v)
-  = do { v' <- wrapLocM (zonkIdBndr env) v
-       ; return $ HsNoVect s v'
+  = do { v' <- wrapLocM (zonkIdBndr env) (unLEmb v)
+       ; return $ HsNoVect s (reLEmb v (unLoc v'))
        }
 zonkVect _env (HsVectTypeOut s t rt)
   = return $ HsVectTypeOut s t rt
index ef8d84c..e2489e6 100644 (file)
@@ -429,7 +429,7 @@ tc_infer_lhs_type mode (L span ty)
 -- | Infer the kind of a type and desugar. This is the "up" type-checker,
 -- as described in Note [Bidirectional type checking]
 tc_infer_hs_type :: TcTyMode -> HsType Name -> TcM (TcType, TcKind)
-tc_infer_hs_type mode (HsTyVar _ (L _ tv)) = tcTyVar mode tv
+tc_infer_hs_type mode (HsTyVar _ (L _ tv)) = tcTyVar mode $ unEmb tv
 tc_infer_hs_type mode (HsAppTy ty1 ty2)
   = do { let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2]
        ; (fun_ty', fun_kind) <- tc_infer_lhs_type mode fun_ty
index 95d33dd..3601196 100644 (file)
@@ -907,7 +907,7 @@ addDFunPrags dfun_id sc_meth_ids
    is_newtype  = isNewTyCon clas_tc
 
 wrapId :: HsWrapper -> id -> HsExpr id
-wrapId wrapper id = mkHsWrap wrapper (HsVar (noLoc id))
+wrapId wrapper id = mkHsWrap wrapper (HsVar (noEmb id))
 
 {- Note [Typechecking plan for instance declarations]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1547,7 +1547,7 @@ mkDefMethBind clas inst_tys sel_id dm_name
         ; dm_id <- tcLookupId dm_name
         ; let inline_prag = idInlinePragma dm_id
               inline_prags | isAnyInlinePragma inline_prag
-                           = [noLoc (InlineSig fn inline_prag)]
+                           = [noLoc (InlineSig (lEmb fn) inline_prag)]
                            | otherwise
                            = []
                  -- Copy the inline pragma (if any) from the default method
index ebf10cb..bc3935e 100644 (file)
@@ -357,8 +357,9 @@ tc_pat _ (WildPat _) pat_ty thing_inside
         ; return (WildPat pat_ty, res) }
 
 tc_pat penv (AsPat (L nm_loc name) pat) pat_ty thing_inside
-  = do  { (wrap, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty)
-        ; (pat', res) <- tcExtendIdEnv1 name bndr_id $
+  = do  { (wrap, bndr_id)
+                      <- setSrcSpan nm_loc (tcPatBndr penv (unEmb name) pat_ty)
+        ; (pat', res) <- tcExtendIdEnv1 (unEmb name) bndr_id $
                          tc_lpat pat (mkCheckExpType $ idType bndr_id)
                                  penv thing_inside
             -- NB: if we do inference on:
@@ -369,7 +370,8 @@ tc_pat penv (AsPat (L nm_loc name) pat) pat_ty thing_inside
             --
             -- If you fix it, don't forget the bindInstsOfPatIds!
         ; pat_ty <- readExpType pat_ty
-        ; return (mkHsWrapPat wrap (AsPat (L nm_loc bndr_id) pat') pat_ty, res) }
+        ; return (mkHsWrapPat wrap (AsPat (L nm_loc (reEmb name bndr_id)) pat')
+                                                                 pat_ty, res) }
 
 tc_pat penv (ViewPat expr pat _) overall_pat_ty thing_inside
   = do  {
@@ -977,7 +979,8 @@ tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside
     tc_field (L l (HsRecField (L loc (FieldOcc (L lr rdr) sel)) pat pun)) penv
                                                                     thing_inside
       = do { sel'   <- tcLookupId sel
-           ; pat_ty <- setSrcSpan loc $ find_field_ty (occNameFS $ rdrNameOcc rdr)
+           ; pat_ty <- setSrcSpan loc
+                           $ find_field_ty (occNameFS $ rdrNameOcc $ unEmb rdr)
            ; (pat', res) <- tcConArg (pat, pat_ty) penv thing_inside
            ; return (L l (HsRecField (L loc (FieldOcc (L lr rdr) sel')) pat'
                                                                     pun), res) }
index 587e2b8..198f4fc 100644 (file)
@@ -78,7 +78,8 @@ tcInferPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details,
                tcPat PatSyn lpat exp_ty $
                mapM tcLookupId arg_names
 
-       ; let named_taus = (name, pat_ty) : map (\arg -> (getName arg, varType arg)) args
+       ; let named_taus = (unEmb name, pat_ty)
+                             : map (\arg -> (getName arg, varType arg)) args
 
        ; (qtvs, req_dicts, ev_binds) <- simplifyInfer tclvl NoRestrictions []
                                                       named_taus wanted
@@ -119,8 +120,9 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
        ; tcCheckPatSynPat lpat
 
        ; (arg_tys, pat_ty) <- case tcSplitFunTysN decl_arity sig_body_ty of
-                                 Right stuff  -> return stuff
-                                 Left missing -> wrongNumberOfParmsErr name decl_arity missing
+                                Right stuff  -> return stuff
+                                Left missing -> wrongNumberOfParmsErr
+                                                 (unEmb name) decl_arity missing
 
        -- Complain about:  pattern P :: () => forall x. x -> P x
        -- The existential 'x' should not appear in the result type
@@ -168,7 +170,8 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
               ; args'      <- zipWithM (tc_arg subst) arg_names arg_tys
               ; return (ex_tvs', prov_dicts, args') }
 
-       ; let skol_info = SigSkol (PatSynCtxt name) (mkPhiTy req_theta pat_ty)
+       ; let skol_info = SigSkol (PatSynCtxt $ unEmb name)
+                                 (mkPhiTy req_theta pat_ty)
                          -- The type here is a bit bogus, but we do not print
                          -- the type for PatSynCtxt, so it doesn't matter
                          -- See TcRnTypes Note [Skolem info for pattern synonyms]
@@ -266,7 +269,7 @@ collectPatSynArgInfo details =
                                          , recordPatSynSelectorId = L _ selId })
       = (patVar, selId)
 
-addPatSynCtxt :: Located Name -> TcM a -> TcM a
+addPatSynCtxt :: LEmbellished Name -> TcM a -> TcM a
 addPatSynCtxt (L loc name) thing_inside
   = setSrcSpan loc $
     addErrCtxt (text "In the declaration for pattern synonym"
@@ -282,7 +285,7 @@ wrongNumberOfParmsErr name decl_arity missing
 
 -------------------------
 -- Shared by both tcInferPatSyn and tcCheckPatSyn
-tc_patsyn_finish :: Located Name  -- ^ PatSyn Name
+tc_patsyn_finish :: LEmbellished Name -- ^ PatSyn Name
                  -> HsPatSynDir Name  -- ^ PatSyn type (Uni/Bidir/ExplicitBidir)
                  -> Bool              -- ^ Whether infix
                  -> LPat Id           -- ^ Pattern of the PatSyn
@@ -324,14 +327,14 @@ tc_patsyn_finish lname dir is_infix lpat'
            ppr pat_ty
 
        -- Make the 'matcher'
-       ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat'
+       ; (matcher_id, matcher_bind) <- tcPatSynMatcher (unLEmb lname) lpat'
                                          (binderVars univ_tvs, req_theta, req_ev_binds, req_dicts)
                                          (binderVars ex_tvs, ex_tys, prov_theta, prov_dicts)
                                          (args, arg_tys)
                                          pat_ty
 
        -- Make the 'builder'
-       ; builder_id <- mkPatSynBuilderId dir lname
+       ; builder_id <- mkPatSynBuilderId dir (unLEmb lname)
                                          univ_tvs req_theta
                                          ex_tvs   prov_theta
                                          arg_tys pat_ty
@@ -344,7 +347,7 @@ tc_patsyn_finish lname dir is_infix lpat'
 
 
        -- Make the PatSyn itself
-       ; let patSyn = mkPatSyn (unLoc lname) is_infix
+       ; let patSyn = mkPatSyn (unLocEmb lname) is_infix
                         (univ_tvs, req_theta)
                         (ex_tvs, prov_theta)
                         arg_tys
@@ -521,7 +524,7 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat
          , text "RHS pattern:" <+> ppr lpat ]
 
   | Right match_group <- mb_match_group  -- Bidirectional
-  = do { patsyn <- tcLookupPatSyn name
+  = do { patsyn <- tcLookupPatSyn $ unEmb name
        ; traceTc "tcPatSynBuilderBind {" $ ppr patsyn
        ; let Just (builder_id, need_dummy_arg) = patSynBuilder patsyn
                    -- Bidirectional, so patSynBuilder returns Just
@@ -535,7 +538,7 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat
                             , bind_fvs    = placeHolderNamesTc
                             , fun_tick    = [] }
 
-             sig = completeSigFromId (PatSynCtxt name) builder_id
+             sig = completeSigFromId (PatSynCtxt $ unEmb name) builder_id
 
        ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLoc bind)
        ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds
@@ -553,7 +556,7 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat
     mk_mg body = mkMatchGroup Generated [builder_match]
              where
                builder_args  = [L loc (VarPat (L loc n)) | L loc n <- args]
-               builder_match = mkMatch (FunRhs (L loc name) Prefix)
+               builder_match = mkMatch (FunRhs (L loc $ unEmb name) Prefix)
                                        builder_args body
                                        (noLoc EmptyLocalBinds)
 
@@ -608,10 +611,10 @@ tcPatToExpr args pat = go pat
 
     -- Make a prefix con for prefix and infix patterns for simplicity
     mkPrefixConExpr :: Located Name -> [LPat Name] -> Either MsgDoc (HsExpr Name)
-    mkPrefixConExpr lcon@(L loc _) pats
+    mkPrefixConExpr (L loc n) pats
       = do { exprs <- mapM go pats
            ; return (foldl (\x y -> HsApp (L loc x) y)
-                           (HsVar lcon) exprs) }
+                           (HsVar (L loc (EName n))) exprs) }
 
     mkRecordConExpr :: Located Name -> HsRecFields Name (LPat Name)
                     -> Either MsgDoc (HsExpr Name)
@@ -634,7 +637,7 @@ tcPatToExpr args pat = go pat
 
     go1 (VarPat (L l var))
         | var `elemNameSet` lhsVars
-        = return $ HsVar (L l var)
+        = return $ HsVar (L l $ EName var)
         | otherwise
         = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym")
     go1 (ParPat pat)                = fmap HsPar $ go pat
index 082b2fd..6cd3a35 100644 (file)
@@ -1609,7 +1609,7 @@ check_main dflags tcg_env explicit_mod_hdr
         ; res_ty <- newFlexiTyVarTy liftedTypeKind
         ; main_expr
                 <- addErrCtxt mainCtxt    $
-                   tcMonoExpr (L loc (HsVar (L loc main_name)))
+                   tcMonoExpr (L loc (HsVar (L loc $ EName main_name)))
                                             (mkCheckExpType $
                                              mkTyConApp ioTyCon [res_ty])
 
index f0ca574..eb2ff37 100644 (file)
@@ -3105,10 +3105,11 @@ lexprCtOrigin :: LHsExpr Name -> CtOrigin
 lexprCtOrigin (L _ e) = exprCtOrigin e
 
 exprCtOrigin :: HsExpr Name -> CtOrigin
-exprCtOrigin (HsVar (L _ name)) = OccurrenceOf name
+exprCtOrigin (HsVar (L _ name)) = OccurrenceOf (unEmb name)
 exprCtOrigin (HsUnboundVar uv)  = UnboundOccurrenceOf (unboundVarOcc uv)
 exprCtOrigin (HsConLikeOut {})  = panic "exprCtOrigin HsConLikeOut"
-exprCtOrigin (HsRecFld f)       = OccurrenceOfRecSel (rdrNameAmbiguousFieldOcc f)
+exprCtOrigin (HsRecFld f)       = OccurrenceOfRecSel
+                                           (unEmb $ rdrNameAmbiguousFieldOcc f)
 exprCtOrigin (HsOverLabel _ l)  = OverLabelOrigin l
 exprCtOrigin (HsIPVar ip)       = IPOccOrigin ip
 exprCtOrigin (HsOverLit lit)    = LiteralOrigin lit
index e26133e..7da6df8 100644 (file)
@@ -206,7 +206,8 @@ tcTySig (L loc (PatSynSig names sig_ty))
 tcTySig _ = return []
 
 
-tcUserTypeSig :: SrcSpan -> LHsSigWcType Name -> Maybe Name -> TcM TcIdSigInfo
+tcUserTypeSig :: SrcSpan -> LHsSigWcType Name -> Maybe (Embellished Name)
+              -> TcM TcIdSigInfo
 -- A function or expression type signature
 -- Returns a fully quantified type signature; even the wildcards
 -- are quantified with ordinary skolems that should be instantiated
@@ -222,24 +223,24 @@ tcUserTypeSig loc hs_sig_ty mb_name
   | isCompleteHsSig hs_sig_ty
   = do { sigma_ty <- tcHsSigWcType ctxt_F hs_sig_ty
        ; return $
-         CompleteSig { sig_bndr  = mkLocalId name sigma_ty
+         CompleteSig { sig_bndr  = mkLocalId (unEmb name) sigma_ty
                      , sig_ctxt  = ctxt_T
                      , sig_loc   = loc } }
                        -- Location of the <type> in   f :: <type>
 
   -- Partial sig with wildcards
   | otherwise
-  = return (PartialSig { psig_name = name, psig_hs_ty = hs_sig_ty
+  = return (PartialSig { psig_name = unEmb name, psig_hs_ty = hs_sig_ty
                        , sig_ctxt = ctxt_F, sig_loc = loc })
   where
     name   = case mb_name of
                Just n  -> n
-               Nothing -> mkUnboundName (mkVarOcc "<expression>")
+               Nothing -> EName $ mkUnboundName (mkVarOcc "<expression>")
     ctxt_F = case mb_name of
-               Just n  -> FunSigCtxt n False
+               Just n  -> FunSigCtxt (unEmb n) False
                Nothing -> ExprSigCtxt
     ctxt_T = case mb_name of
-               Just n  -> FunSigCtxt n True
+               Just n  -> FunSigCtxt (unEmb n) True
                Nothing -> ExprSigCtxt
 
 
@@ -342,7 +343,7 @@ for example, in hs-boot file, we may need to think what to do...
 (eg don't have any implicitly-bound variables).
 -}
 
-tcPatSynSig :: Name -> LHsSigType Name -> TcM TcPatSynInfo
+tcPatSynSig :: Embellished Name -> LHsSigType Name -> TcM TcPatSynInfo
 tcPatSynSig name sig_ty
   | HsIB { hsib_vars = implicit_hs_tvs
          , hsib_body = hs_ty }  <- sig_ty
@@ -399,7 +400,7 @@ tcPatSynSig name sig_ty
               , text "ex_tvs" <+> ppr_tvs ex_tvs
               , text "prov" <+> ppr prov
               , text "body_ty" <+> ppr body_ty ]
-       ; return (TPSI { patsig_name = name
+       ; return (TPSI { patsig_name = unEmb name
                       , patsig_implicit_bndrs = mkTyVarBinders Inferred kvs ++
                                                 mkTyVarBinders Specified implicit_tvs
                       , patsig_univ_bndrs     = univ_tvs
@@ -408,7 +409,7 @@ tcPatSynSig name sig_ty
                       , patsig_prov           = prov
                       , patsig_body_ty        = body_ty }) }
   where
-    ctxt = PatSynCtxt name
+    ctxt = PatSynCtxt $ unEmb name
 
     build_patsyn_type kvs imp univ req ex prov body
       = mkInvForAllTys kvs $
@@ -503,15 +504,18 @@ mkPragEnv sigs binds
     prs = mapMaybe get_sig sigs
 
     get_sig :: LSig Name -> Maybe (Name, LSig Name)
-    get_sig (L l (SpecSig lnm@(L _ nm) ty inl)) = Just (nm, L l $ SpecSig   lnm ty (add_arity nm inl))
-    get_sig (L l (InlineSig lnm@(L _ nm) inl))  = Just (nm, L l $ InlineSig lnm    (add_arity nm inl))
-    get_sig (L l (SCCFunSig st lnm@(L _ nm) str))  = Just (nm, L l $ SCCFunSig st lnm str)
+    get_sig (L l (SpecSig lnm@(L _ nm) ty inl))
+                  = Just (unEmb nm, L l $ SpecSig   lnm ty (add_arity nm inl))
+    get_sig (L l (InlineSig lnm@(L _ nm) inl))
+                  = Just (unEmb nm, L l $ InlineSig lnm    (add_arity nm inl))
+    get_sig (L l (SCCFunSig st lnm@(L _ nm) str))
+                  = Just (unEmb nm, L l $ SCCFunSig st lnm str)
     get_sig _                                   = Nothing
 
     add_arity n inl_prag   -- Adjust inl_sat field to match visible arity of function
       | Inline <- inl_inline inl_prag
         -- add arity only for real INLINE pragmas, not INLINABLE
-      = case lookupNameEnv ar_env n of
+      = case lookupNameEnv ar_env (unEmb n) of
           Just ar -> inl_prag { inl_sat = Just ar }
           Nothing -> WARN( True, text "mkPragEnv no arity" <+> ppr n )
                      -- There really should be a binding for every INLINE pragma
@@ -746,9 +750,9 @@ tcImpPrags prags
             return []
          else do
             { pss <- mapAndRecoverM (wrapLocM tcImpSpec)
-                     [L loc (name,prag)
+                     [L loc (unEmb name,prag)
                                | (L loc prag@(SpecSig (L _ name) _ _)) <- prags
-                               , not (nameIsLocalOrFrom this_mod name) ]
+                               , not (nameIsLocalOrFrom this_mod $ unEmb name)]
             ; return $ concatMap (\(L l ps) -> map (L l) ps) pss } }
   where
     -- Ignore SPECIALISE pragmas for imported things
index e590494..a7942c1 100644 (file)
@@ -573,7 +573,7 @@ runAnnotation target expr = do
               ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]]
               ; let specialised_to_annotation_wrapper_expr
                       = L loc (HsWrap wrapper
-                                      (HsVar (L loc to_annotation_wrapper_id)))
+                               (HsVar (L loc $ EName to_annotation_wrapper_id)))
               ; return (L loc (HsApp specialised_to_annotation_wrapper_expr expr')) }
 
     -- Run the appropriately wrapped expression to get the value of
index a66f401..a0c76e9 100644 (file)
@@ -475,7 +475,7 @@ getInitialKind decl@(DataDecl { tcdLName = L _ name
                            Just ksig -> tcLHsKind ksig
                            Nothing   -> return liftedTypeKind
               ; return (res_k, ()) }
-        ; let inner_prs = [ (unLoc con, APromotionErr RecDataConPE)
+        ; let inner_prs = [ (unLocEmb con, APromotionErr RecDataConPE)
                           | L _ con' <- cons, con <- getConNames con' ]
         ; return (mkTcTyConPair tycon : inner_prs) }
 
@@ -573,7 +573,7 @@ kcTyClDecl (ClassDecl { tcdLName = L _ name
     do  { _ <- tcHsContext ctxt
         ; mapM_ (wrapLocM kc_sig)     sigs }
   where
-    kc_sig (ClassOpSig _ nms op_ty) = kcHsSigType nms op_ty
+    kc_sig (ClassOpSig _ nms op_ty) = kcHsSigType (map unLEmb nms) op_ty
     kc_sig _                        = return ()
 
 kcTyClDecl (FamDecl (FamilyDecl { fdLName  = L _ fam_tc_name
@@ -594,7 +594,7 @@ kcConDecl (ConDeclH98 { con_name = name, con_qvars = ex_tvs
          -- the 'False' says that the existentials don't have a CUSK, as the
          -- concept doesn't really apply here. We just need to bring the variables
          -- into scope.
-    do { _ <- kcHsTyVarBndrs (unLoc name) False False False False
+    do { _ <- kcHsTyVarBndrs (unLocEmb name) False False False False
                              ((fromMaybe emptyLHsQTvs ex_tvs)) $
               do { _ <- tcHsContext (fromMaybe (noLoc []) ex_ctxt)
                  ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys details)
@@ -606,7 +606,7 @@ kcConDecl (ConDeclH98 { con_name = name, con_qvars = ex_tvs
 kcConDecl (ConDeclGADT { con_names = names
                        , con_type = ty })
   = addErrCtxt (dataConCtxtName names) $
-      do { _ <- tcGadtSigType (ppr names) (unLoc $ head names) ty
+      do { _ <- tcGadtSigType (ppr names) (unLocEmb $ head names) ty
          ; return () }
 
 
@@ -1161,7 +1161,7 @@ kcDataDefn fam_name (HsIB { hsib_body = pats })
             Just k  -> do { k' <- tcLHsKind k
                           ; unifyKind (Just hs_ty_pats) res_k k' } }
   where
-    hs_ty_pats = mkHsAppTys (noLoc $ HsTyVar NotPromoted (noLoc fam_name)) pats
+    hs_ty_pats = mkHsAppTys (noLoc $ HsTyVar NotPromoted (noEmb fam_name)) pats
 
 {-
 Kind check type patterns and kind annotate the embedded type variables.
@@ -1469,7 +1469,7 @@ tcConDecl rep_tycon tmpl_bndrs res_tmpl
               do { traceTc "tcConDecl" (ppr name <+> text "tvs:" <+> ppr hs_tvs)
                  ; ctxt <- tcHsContext (fromMaybe (noLoc []) hs_ctxt)
                  ; btys <- tcConArgs hs_details
-                 ; field_lbls <- lookupConstructorFields (unLoc name)
+                 ; field_lbls <- lookupConstructorFields (unLocEmb name)
                  ; let (arg_tys, stricts) = unzip btys
                        bound_vars  = allBoundVariabless ctxt `unionVarSet`
                                      allBoundVariabless arg_tys
@@ -1509,10 +1509,10 @@ tcConDecl rep_tycon tmpl_bndrs res_tmpl
            ex_tvs = mkTyVarBinders Inferred qkvs ++
                     mkTyVarBinders Specified user_qtvs
            buildOneDataCon (L _ name) = do
-             { is_infix <- tcConIsInfixH98 name hs_details
-             ; rep_nm   <- newTyConRepName name
+             { is_infix <- tcConIsInfixH98 (unEmb name) hs_details
+             ; rep_nm   <- newTyConRepName $ unEmb name
 
-             ; buildDataCon fam_envs name is_infix rep_nm
+             ; buildDataCon fam_envs (unEmb name) is_infix rep_nm
                             stricts Nothing field_lbls
                             (mkDataConUnivTyVarBinders tmpl_bndrs)
                             ex_tvs
@@ -1531,7 +1531,7 @@ tcConDecl rep_tycon tmpl_bndrs res_tmpl
   = addErrCtxt (dataConCtxtName names) $
     do { traceTc "tcConDecl 1" (ppr names)
        ; (user_tvs, ctxt, stricts, field_lbls, arg_tys, res_ty,hs_details)
-           <- tcGadtSigType (ppr names) (unLoc $ head names) ty
+           <- tcGadtSigType (ppr names) (unLocEmb $ head names) ty
 
        ; vars <- zonkTcTypeAndSplitDepVars (mkSpecForAllTys user_tvs $
                                             mkFunTys ctxt $
@@ -1561,10 +1561,10 @@ tcConDecl rep_tycon tmpl_bndrs res_tmpl
        ; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls)
        ; let
            buildOneDataCon (L _ name) = do
-             { is_infix <- tcConIsInfixGADT name hs_details
-             ; rep_nm   <- newTyConRepName name
+             { is_infix <- tcConIsInfixGADT (unEmb name) hs_details
+             ; rep_nm   <- newTyConRepName $ unEmb name
 
-             ; buildDataCon fam_envs name is_infix
+             ; buildDataCon fam_envs (unEmb name) is_infix
                             rep_nm
                             stricts Nothing field_lbls
                             univ_bndrs ex_bndrs eq_preds
@@ -2910,7 +2910,7 @@ fieldTypeMisMatch field_name con1 con2
   = sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2,
          text "give different types for field", quotes (ppr field_name)]
 
-dataConCtxtName :: [Located Name] -> SDoc
+dataConCtxtName :: [LEmbellished Name] -> SDoc
 dataConCtxtName [con]
    = text "In the definition of data constructor" <+> quotes (ppr con)
 dataConCtxtName con
index 96154cc..89cd83e 100644 (file)
@@ -840,12 +840,13 @@ mkOneRecordSelector all_cons idDetails fl
              | otherwise =  map mk_match cons_w_field ++ deflt
     mk_match con = mkSimpleMatch (FunRhs sel_lname Prefix)
                                  [L loc (mk_sel_pat con)]
-                                 (L loc (HsVar (L loc field_var)))
+                                 (L loc (HsVar (L loc $ EName field_var)))
     mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields)
     rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing }
     rec_field  = noLoc (HsRecField
                         { hsRecFieldLbl
-                           = L loc (FieldOcc (L loc $ mkVarUnqual lbl) sel_name)
+                           = L loc (FieldOcc (L loc $ EName $ mkVarUnqual lbl)
+                                             sel_name)
                         , hsRecFieldArg = L loc (VarPat (L loc field_var))
                         , hsRecPun = False })
     sel_lname = L loc sel_name
@@ -855,11 +856,12 @@ mkOneRecordSelector all_cons idDetails fl
     -- We do this explicitly so that we get a nice error message that
     -- mentions this particular record selector
     deflt | all dealt_with all_cons = []
-          | otherwise = [mkSimpleMatch CaseAlt
-                            [L loc (WildPat placeHolderType)]
-                            (mkHsApp (L loc (HsVar
-                                            (L loc (getName rEC_SEL_ERROR_ID))))
-                                     (L loc (HsLit msg_lit)))]
+          | otherwise
+            = [mkSimpleMatch CaseAlt
+                [L loc (WildPat placeHolderType)]
+                (mkHsApp (L loc (HsVar
+                                (L loc (EName $ getName rEC_SEL_ERROR_ID))))
+                         (L loc (HsLit msg_lit)))]
 
         -- Do not add a default case unless there are unmatched
         -- constructors.  We must take account of GADTs, else we
index ef5e9ef..2d01503 100644 (file)
@@ -321,7 +321,7 @@ processAllTypeCheckedModule tcm = do
         return $ fmap (\expr -> (mid, getLoc e, CoreUtils.exprType expr)) mbe
       where
         mid :: Maybe Id
-        mid | HsVar (L _ i) <- unwrapVar (unLoc e) = Just i
+        mid | HsVar (L _ i) <- unwrapVar (unLoc e) = Just $ unEmb i
             | otherwise                            = Nothing
 
         unwrapVar (HsWrap _ var) = var
index 15d5139..d826e50 100644 (file)
@@ -32,7 +32,6 @@
 ((Test10357.hs:7:31-36,AnnVal), [Test10357.hs:7:33]),
 ((Test10357.hs:7:31-40,AnnVal), [Test10357.hs:7:38]),
 ((Test10357.hs:7:43-52,AnnBackquote), [Test10357.hs:7:43, Test10357.hs:7:52]),
-((Test10357.hs:7:43-52,AnnVal), [Test10357.hs:7:44-51]),
 ((Test10357.hs:8:18-59,AnnCloseP), [Test10357.hs:8:59]),
 ((Test10357.hs:8:18-59,AnnOpenP), [Test10357.hs:8:18]),
 ((Test10357.hs:8:19-58,AnnVal), [Test10357.hs:8:43-52]),
@@ -40,7 +39,6 @@
 ((Test10357.hs:8:37-41,AnnOpenS), [Test10357.hs:8:37]),
 ((Test10357.hs:8:38-40,AnnMinus), [Test10357.hs:8:38]),
 ((Test10357.hs:8:43-52,AnnBackquote), [Test10357.hs:8:43, Test10357.hs:8:52]),
-((Test10357.hs:8:43-52,AnnVal), [Test10357.hs:8:44-51]),
 ((Test10357.hs:10:7-20,AnnComma), [Test10357.hs:10:21]),
 ((Test10357.hs:10:7-20,AnnLarrow), [Test10357.hs:10:13-14]),
 ((Test10357.hs:10:16-20,AnnCloseS), [Test10357.hs:10:20]),
index d4df67d..8165425 100644 (file)
@@ -35,7 +35,6 @@
 ((Test11321.hs:16:24-34,AnnTilde), [Test11321.hs:16:26]),
 ((Test11321.hs:16:28-30,AnnCloseP), [Test11321.hs:16:30]),
 ((Test11321.hs:16:28-30,AnnOpenP), [Test11321.hs:16:28]),
-((Test11321.hs:16:28-30,AnnVal), [Test11321.hs:16:29]),
 ((Test11321.hs:17:11-18,AnnCloseP), [Test11321.hs:17:18]),
 ((Test11321.hs:17:11-18,AnnOpenP), [Test11321.hs:17:11]),
 ((Test11321.hs:17:20-27,AnnCloseP), [Test11321.hs:17:27]),
index f216acd..d5f1777 100644 (file)
 ((Test13163.hs:6:5-16,AnnOpenP), [Test13163.hs:6:13]),
 ((Test13163.hs:6:10-12,AnnCloseP), [Test13163.hs:6:12]),
 ((Test13163.hs:6:10-12,AnnOpenP), [Test13163.hs:6:10]),
-((Test13163.hs:6:10-12,AnnVal), [Test13163.hs:6:11]),
 ((Test13163.hs:7:5,AnnComma), [Test13163.hs:7:6]),
 ((Test13163.hs:7:8-15,AnnComma), [Test13163.hs:7:16]),
 ((Test13163.hs:7:8-15,AnnType), [Test13163.hs:7:8-11]),
 ((Test13163.hs:7:13-15,AnnCloseP), [Test13163.hs:7:15]),
 ((Test13163.hs:7:13-15,AnnOpenP), [Test13163.hs:7:13]),
-((Test13163.hs:7:13-15,AnnVal), [Test13163.hs:7:14]),
 ((Test13163.hs:7:18-31,AnnPattern), [Test13163.hs:7:18-24]),
 ((Test13163.hs:10:1-78,AnnImport), [Test13163.hs:10:1-6]),
 ((Test13163.hs:10:1-78,AnnSemi), [Test13163.hs:11:1]),
 ((Test13163.hs:10:32-41,AnnType), [Test13163.hs:10:32-35]),
 ((Test13163.hs:10:37-41,AnnCloseP), [Test13163.hs:10:41]),
 ((Test13163.hs:10:37-41,AnnOpenP), [Test13163.hs:10:37]),
-((Test13163.hs:10:37-41,AnnVal), [Test13163.hs:10:38-40]),
 ((Test13163.hs:10:44-53,AnnComma), [Test13163.hs:10:54]),
 ((Test13163.hs:10:44-53,AnnType), [Test13163.hs:10:44-47]),
 ((Test13163.hs:10:49-53,AnnCloseP), [Test13163.hs:10:53]),
 ((Test13163.hs:10:49-53,AnnOpenP), [Test13163.hs:10:49]),
-((Test13163.hs:10:49-53,AnnVal), [Test13163.hs:10:50-52]),
 ((Test13163.hs:10:56-65,AnnComma), [Test13163.hs:10:66]),
 ((Test13163.hs:10:56-65,AnnType), [Test13163.hs:10:56-59]),
 ((Test13163.hs:10:61-65,AnnCloseP), [Test13163.hs:10:65]),
 ((Test13163.hs:10:61-65,AnnOpenP), [Test13163.hs:10:61]),
-((Test13163.hs:10:61-65,AnnVal), [Test13163.hs:10:62-64]),
 ((Test13163.hs:10:68-77,AnnType), [Test13163.hs:10:68-71]),
 ((Test13163.hs:10:73-77,AnnCloseP), [Test13163.hs:10:77]),
 ((Test13163.hs:10:73-77,AnnOpenP), [Test13163.hs:10:73]),
-((Test13163.hs:10:73-77,AnnVal), [Test13163.hs:10:74-76]),
 ((Test13163.hs:11:1-61,AnnImport), [Test13163.hs:11:1-6]),
 ((Test13163.hs:11:1-61,AnnSemi), [Test13163.hs:12:1]),
 ((Test13163.hs:11:24-61,AnnCloseP), [Test13163.hs:11:61]),
@@ -62,7 +56,6 @@
 ((Test13163.hs:11:47-60,AnnOpenP), [Test13163.hs:11:57]),
 ((Test13163.hs:11:52-56,AnnCloseP), [Test13163.hs:11:56]),
 ((Test13163.hs:11:52-56,AnnOpenP), [Test13163.hs:11:52]),
-((Test13163.hs:11:52-56,AnnVal), [Test13163.hs:11:53-55]),
 ((Test13163.hs:12:1-19,AnnImport), [Test13163.hs:12:1-6]),
 ((Test13163.hs:12:1-19,AnnSemi), [Test13163.hs:14:1]),
 ((Test13163.hs:14:1-22,AnnEqual), [Test13163.hs:14:18]),
index 0f83b12..c957066 100644 (file)
@@ -9,3 +9,7 @@ type family Length (as :: [k]) :: Peano where
   Length '[]      = Zero
 
 main = putStrLn "hello"
+
+foo = 5 `mod` 2
+
+bar = (+) 3 4
index 9f6b869..b1c9718 100644 (file)
@@ -28,7 +28,8 @@
         ({ DumpParsedAst.hs:5:14-17 }
          (ConDeclH98 
           ({ DumpParsedAst.hs:5:14-17 }
-           (Unqual {OccName: Zero})) 
+           (EName 
+            (Unqual {OccName: Zero}))) 
           (Nothing) 
           (Just 
            ({ <no location info> }
@@ -39,7 +40,8 @@
         ({ DumpParsedAst.hs:5:21-30 }
          (ConDeclH98 
           ({ DumpParsedAst.hs:5:21-24 }
-           (Unqual {OccName: Succ})) 
+           (EName 
+            (Unqual {OccName: Succ}))) 
           (Nothing) 
           (Just 
            ({ <no location info> }
@@ -50,7 +52,8 @@
              (HsTyVar 
               (NotPromoted) 
               ({ DumpParsedAst.hs:5:26-30 }
-               (Unqual {OccName: Peano}))))]) 
+               (EName 
+                (Unqual {OccName: Peano})))))]) 
           (Nothing)))] 
        ({ <no location info> }
         [])) 
                       (HsTyVar 
                        (NotPromoted) 
                        ({ DumpParsedAst.hs:8:11 }
-                        (Unqual {OccName: a})))))),
+                        (EName 
+                         (Unqual {OccName: a}))))))),
                    ({ DumpParsedAst.hs:8:13 }
                     (HsAppInfix 
                      ({ DumpParsedAst.hs:8:13 }
-                      (Exact {Name: ghc-prim:GHC.Types.:{(w) d}})))),
+                      (EName 
+                       (Exact {Name: ghc-prim:GHC.Types.:{(w) d}}))))),
                    ({ DumpParsedAst.hs:8:15-16 }
                     (HsAppPrefix 
                      ({ DumpParsedAst.hs:8:15-16 }
                       (HsTyVar 
                        (NotPromoted) 
                        ({ DumpParsedAst.hs:8:15-16 }
-                        (Unqual {OccName: as}))))))]))))]) 
+                        (EName 
+                         (Unqual {OccName: as})))))))]))))]) 
             (Prefix) 
             ({ DumpParsedAst.hs:8:21-36 }
              (HsAppsTy 
                   (HsTyVar 
                    (NotPromoted) 
                    ({ DumpParsedAst.hs:8:21-24 }
-                    (Unqual {OccName: Succ})))))),
+                    (EName 
+                     (Unqual {OccName: Succ}))))))),
                ({ DumpParsedAst.hs:8:26-36 }
                 (HsAppPrefix 
                  ({ DumpParsedAst.hs:8:26-36 }
                          (HsTyVar 
                           (NotPromoted) 
                           ({ DumpParsedAst.hs:8:27-32 }
-                           (Unqual {OccName: Length})))))),
+                           (EName 
+                            (Unqual {OccName: Length}))))))),
                       ({ DumpParsedAst.hs:8:34-35 }
                        (HsAppPrefix 
                         ({ DumpParsedAst.hs:8:34-35 }
                          (HsTyVar 
                           (NotPromoted) 
                           ({ DumpParsedAst.hs:8:34-35 }
-                           (Unqual {OccName: as}))))))]))))))])))),
+                           (EName 
+                            (Unqual {OccName: as})))))))]))))))])))),
           ({ DumpParsedAst.hs:9:3-24 }
            (TyFamEqn 
             ({ DumpParsedAst.hs:9:3-8 }
                   (HsTyVar 
                    (NotPromoted) 
                    ({ DumpParsedAst.hs:9:21-24 }
-                    (Unqual {OccName: Zero}))))))]))))])) 
+                    (EName 
+                     (Unqual {OccName: Zero})))))))]))))])) 
        ({ DumpParsedAst.hs:7:13-18 }
         (Unqual {OccName: Length})) 
        (HsQTvs 
                         (HsTyVar 
                          (NotPromoted) 
                          ({ DumpParsedAst.hs:7:28 }
-                          (Unqual {OccName: k}))))))]))))))]))))] 
+                          (EName 
+                           (Unqual {OccName: k})))))))]))))))]))))] 
         (PlaceHolder)) 
        (Prefix) 
        ({ DumpParsedAst.hs:7:32-39 }
                (HsTyVar 
                 (NotPromoted) 
                 ({ DumpParsedAst.hs:7:35-39 }
-                 (Unqual {OccName: Peano}))))))])))) 
+                 (EName 
+                  (Unqual {OccName: Peano})))))))])))) 
        (Nothing))))),
    ({ DumpParsedAst.hs:11:1-23 }
     (ValD 
                  ({ DumpParsedAst.hs:11:8-15 }
                   (HsVar 
                    ({ DumpParsedAst.hs:11:8-15 }
-                    (Unqual {OccName: putStrLn})))) 
+                    (EName 
+                     (Unqual {OccName: putStrLn}))))) 
                  ({ DumpParsedAst.hs:11:17-23 }
                   (HsLit 
                    (HsString 
        (FromSource)) 
       (WpHole) 
       (PlaceHolder) 
+      []))),
+   ({ DumpParsedAst.hs:13:1-15 }
+    (ValD 
+     (FunBind 
+      ({ DumpParsedAst.hs:13:1-3 }
+       (Unqual {OccName: foo})) 
+      (MG 
+       ({ DumpParsedAst.hs:13:1-15 }
+        [
+         ({ DumpParsedAst.hs:13:1-15 }
+          (Match 
+           (FunRhs 
+            ({ DumpParsedAst.hs:13:1-3 }
+             (Unqual {OccName: foo})) 
+            (Prefix)) 
+           [] 
+           (Nothing) 
+           (GRHSs 
+            [
+             ({ DumpParsedAst.hs:13:5-15 }
+              (GRHS 
+               [] 
+               ({ DumpParsedAst.hs:13:7-15 }
+                (OpApp 
+                 ({ DumpParsedAst.hs:13:7 }
+                  (HsOverLit 
+                   (OverLit 
+                    (HsIntegral 
+                     (SourceText "5") 
+                     (5)) 
+                    (PlaceHolder) 
+                    (HsLit 
+                     (HsString 
+                      (SourceText "noExpr") {FastString: "noExpr"})) 
+                    (PlaceHolder)))) 
+                 ({ DumpParsedAst.hs:13:9-13 }
+                  (HsVar 
+                   ({ DumpParsedAst.hs:13:9-13 }
+                    (EBackquotes 
+                     ({ DumpParsedAst.hs:13:10-12 }
+                      (Unqual {OccName: mod})))))) 
+                 (PlaceHolder) 
+                 ({ DumpParsedAst.hs:13:15 }
+                  (HsOverLit 
+                   (OverLit 
+                    (HsIntegral 
+                     (SourceText "2") 
+                     (2)) 
+                    (PlaceHolder) 
+                    (HsLit 
+                     (HsString 
+                      (SourceText "noExpr") {FastString: "noExpr"})) 
+                    (PlaceHolder))))))))] 
+            ({ <no location info> }
+             (EmptyLocalBinds)))))]) 
+       [] 
+       (PlaceHolder) 
+       (FromSource)) 
+      (WpHole) 
+      (PlaceHolder) 
+      []))),
+   ({ DumpParsedAst.hs:15:1-13 }
+    (ValD 
+     (FunBind 
+      ({ DumpParsedAst.hs:15:1-3 }
+       (Unqual {OccName: bar})) 
+      (MG 
+       ({ DumpParsedAst.hs:15:1-13 }
+        [
+         ({ DumpParsedAst.hs:15:1-13 }
+          (Match 
+           (FunRhs 
+            ({ DumpParsedAst.hs:15:1-3 }
+             (Unqual {OccName: bar})) 
+            (Prefix)) 
+           [] 
+           (Nothing) 
+           (GRHSs 
+            [
+             ({ DumpParsedAst.hs:15:5-13 }
+              (GRHS 
+               [] 
+               ({ DumpParsedAst.hs:15:7-13 }
+                (HsApp 
+                 ({ DumpParsedAst.hs:15:7-11 }
+                  (HsApp 
+                   ({ DumpParsedAst.hs:15:7-9 }
+                    (HsVar 
+                     ({ DumpParsedAst.hs:15:7-9 }
+                      (EParens 
+                       ({ DumpParsedAst.hs:15:8 }
+                        (Unqual {OccName: +})))))) 
+                   ({ DumpParsedAst.hs:15:11 }
+                    (HsOverLit 
+                     (OverLit 
+                      (HsIntegral 
+                       (SourceText "3") 
+                       (3)) 
+                      (PlaceHolder) 
+                      (HsLit 
+                       (HsString 
+                        (SourceText "noExpr") {FastString: "noExpr"})) 
+                      (PlaceHolder)))))) 
+                 ({ DumpParsedAst.hs:15:13 }
+                  (HsOverLit 
+                   (OverLit 
+                    (HsIntegral 
+                     (SourceText "4") 
+                     (4)) 
+                    (PlaceHolder) 
+                    (HsLit 
+                     (HsString 
+                      (SourceText "noExpr") {FastString: "noExpr"})) 
+                    (PlaceHolder))))))))] 
+            ({ <no location info> }
+             (EmptyLocalBinds)))))]) 
+       [] 
+       (PlaceHolder) 
+       (FromSource)) 
+      (WpHole) 
+      (PlaceHolder) 
       [])))] 
   (Nothing) 
   (Nothing)))
index 437390c..aa69781 100644 (file)
@@ -29,7 +29,8 @@
                  (HsApp 
                   ({ DumpRenamedAst.hs:11:8-15 }
                    (HsVar 
-                    ({ DumpRenamedAst.hs:11:8-15 }{Name: base:System.IO.putStrLn{v}}))) 
+                    ({ DumpRenamedAst.hs:11:8-15 }
+                     (EName {Name: base:System.IO.putStrLn{v}})))) 
                   ({ DumpRenamedAst.hs:11:17-23 }
                    (HsLit 
                     (HsString 
@@ -64,7 +65,8 @@
        [
         ({ DumpRenamedAst.hs:5:14-17 }
          (ConDeclH98 
-          ({ DumpRenamedAst.hs:5:14-17 }{Name: main:DumpRenamedAst.Zero{d}}) 
+          ({ DumpRenamedAst.hs:5:14-17 }
+           (EName {Name: main:DumpRenamedAst.Zero{d}})) 
           (Nothing) 
           (Just 
            ({ <no location info> }
@@ -74,7 +76,8 @@
           (Nothing))),
         ({ DumpRenamedAst.hs:5:21-30 }
          (ConDeclH98 
-          ({ DumpRenamedAst.hs:5:21-24 }{Name: main:DumpRenamedAst.Succ{d}}) 
+          ({ DumpRenamedAst.hs:5:21-24 }
+           (EName {Name: main:DumpRenamedAst.Succ{d}})) 
           (Nothing) 
           (Just 
            ({ <no location info> }
@@ -84,7 +87,8 @@
             ({ DumpRenamedAst.hs:5:26-30 }
              (HsTyVar 
               (NotPromoted) 
-              ({ DumpRenamedAst.hs:5:26-30 }{Name: main:DumpRenamedAst.Peano{tc}})))]) 
+              ({ DumpRenamedAst.hs:5:26-30 }
+               (EName {Name: main:DumpRenamedAst.Peano{tc}}))))]) 
           (Nothing)))] 
        ({ <no location info> }
         [])) 
                   ({ DumpRenamedAst.hs:8:11 }
                    (HsTyVar 
                     (NotPromoted) 
-                    ({ DumpRenamedAst.hs:8:11 }{Name: a{tv}}))) 
+                    ({ DumpRenamedAst.hs:8:11 }
+                     (EName {Name: a{tv}})))) 
                   ({ DumpRenamedAst.hs:8:13 }{Name: ghc-prim:GHC.Types.:{(w) d}}) 
                   ({ DumpRenamedAst.hs:8:15-16 }
                    (HsTyVar 
                     (NotPromoted) 
-                    ({ DumpRenamedAst.hs:8:15-16 }{Name: as{tv}})))))))]) 
+                    ({ DumpRenamedAst.hs:8:15-16 }
+                     (EName {Name: as{tv}}))))))))]) 
             (Prefix) 
             ({ DumpRenamedAst.hs:8:21-36 }
              (HsAppTy 
               ({ DumpRenamedAst.hs:8:21-24 }
                (HsTyVar 
                 (NotPromoted) 
-                ({ DumpRenamedAst.hs:8:21-24 }{Name: main:DumpRenamedAst.Succ{d}}))) 
+                ({ DumpRenamedAst.hs:8:21-24 }
+                 (EName {Name: main:DumpRenamedAst.Succ{d}})))) 
               ({ DumpRenamedAst.hs:8:26-36 }
                (HsParTy 
                 ({ DumpRenamedAst.hs:8:27-35 }
                   ({ DumpRenamedAst.hs:8:27-32 }
                    (HsTyVar 
                     (NotPromoted) 
-                    ({ DumpRenamedAst.hs:8:27-32 }{Name: main:DumpRenamedAst.Length{tc}}))) 
+                    ({ DumpRenamedAst.hs:8:27-32 }
+                     (EName {Name: main:DumpRenamedAst.Length{tc}})))) 
                   ({ DumpRenamedAst.hs:8:34-35 }
                    (HsTyVar 
                     (NotPromoted) 
-                    ({ DumpRenamedAst.hs:8:34-35 }{Name: as{tv}}))))))))))),
+                    ({ DumpRenamedAst.hs:8:34-35 }
+                     (EName {Name: as{tv}})))))))))))),
           ({ DumpRenamedAst.hs:9:3-24 }
            (TyFamEqn 
             ({ DumpRenamedAst.hs:9:3-8 }{Name: main:DumpRenamedAst.Length{tc}}) 
             ({ DumpRenamedAst.hs:9:21-24 }
              (HsTyVar 
               (NotPromoted) 
-              ({ DumpRenamedAst.hs:9:21-24 }{Name: main:DumpRenamedAst.Zero{d}})))))])) 
+              ({ DumpRenamedAst.hs:9:21-24 }
+               (EName {Name: main:DumpRenamedAst.Zero{d}}))))))])) 
        ({ DumpRenamedAst.hs:7:13-18 }{Name: main:DumpRenamedAst.Length{tc}}) 
        (HsQTvs 
         [{Name: k{tv}}] 
              ({ DumpRenamedAst.hs:7:28 }
               (HsTyVar 
                (NotPromoted) 
-               ({ DumpRenamedAst.hs:7:28 }{Name: k{tv}})))))))] {NameSet: 
+               ({ DumpRenamedAst.hs:7:28 }
+                (EName {Name: k{tv}}))))))))] {NameSet: 
         []}) 
        (Prefix) 
        ({ DumpRenamedAst.hs:7:32-39 }
          ({ DumpRenamedAst.hs:7:35-39 }
           (HsTyVar 
            (NotPromoted) 
-           ({ DumpRenamedAst.hs:7:35-39 }{Name: main:DumpRenamedAst.Peano{tc}}))))) 
+           ({ DumpRenamedAst.hs:7:35-39 }
+            (EName {Name: main:DumpRenamedAst.Peano{tc}})))))) 
        (Nothing))))] 
    [] 
    [])] 
index c7db52a..2fd0e22 100644 (file)
@@ -31,7 +31,8 @@
                 (2739668351064589274)))))) 
            ({ <no location info> }
             (HsVar 
-             ({ <no location info> }{Var: (main:DumpTypecheckedAst.$trModule{v} [lidx] :: ghc-prim:GHC.Types.Module{tc})}))))) 
+             ({ <no location info> }
+              (EName {Var: (main:DumpTypecheckedAst.$trModule{v} [lidx] :: ghc-prim:GHC.Types.Module{tc})})))))) 
          ({ <no location info> }
           (HsPar 
            ({ <no location info> }
@@ -50,7 +51,8 @@
           (0)))))) 
      ({ <no location info> }
       (HsVar 
-       ({ <no location info> }{Var: (krep{v} [lid] :: ghc-prim:GHC.Types.KindRep{tc})}))))) 
+       ({ <no location info> }
+        (EName {Var: (krep{v} [lid] :: ghc-prim:GHC.Types.KindRep{tc})})))))) 
    (False))),
  ({ <no location info> }
   (VarBind {Var: (krep{v} [lid] :: ghc-prim:GHC.Types.KindRep{tc})} 
@@ -92,7 +94,8 @@
                 (12314848029315386153)))))) 
            ({ <no location info> }
             (HsVar 
-             ({ <no location info> }{Var: (main:DumpTypecheckedAst.$trModule{v} [lidx] :: ghc-prim:GHC.Types.Module{tc})}))))) 
+             ({ <no location info> }
+              (EName {Var: (main:DumpTypecheckedAst.$trModule{v} [lidx] :: ghc-prim:GHC.Types.Module{tc})})))))) 
          ({ <no location info> }
           (HsPar 
            ({ <no location info> }
           (0)))))) 
      ({ <no location info> }
       (HsVar 
-       ({ <no location info> }{Var: (krep{v} [lid] :: ghc-prim:GHC.Types.KindRep{tc})}))))) 
+       ({ <no location info> }
+        (EName {Var: (krep{v} [lid] :: ghc-prim:GHC.Types.KindRep{tc})})))))) 
    (False))),
  ({ <no location info> }
   (VarBind {Var: (krep{v} [lid] :: ghc-prim:GHC.Types.KindRep{tc})} 
          ({abstract:ConLike}))) 
        ({ <no location info> }
         (HsVar 
-         ({ <no location info> }{Var: (main:DumpTypecheckedAst.$tcPeano{v} [lidx] :: ghc-prim:GHC.Types.TyCon{tc})}))))) 
+         ({ <no location info> }
+          (EName {Var: (main:DumpTypecheckedAst.$tcPeano{v} [lidx] :: ghc-prim:GHC.Types.TyCon{tc})})))))) 
      ({ <no location info> }
       (HsWrap 
        (WpTyApp 
                 (14802086722010293686)))))) 
            ({ <no location info> }
             (HsVar 
-             ({ <no location info> }{Var: (main:DumpTypecheckedAst.$trModule{v} [lidx] :: ghc-prim:GHC.Types.Module{tc})}))))) 
+             ({ <no location info> }
+              (EName {Var: (main:DumpTypecheckedAst.$trModule{v} [lidx] :: ghc-prim:GHC.Types.Module{tc})})))))) 
          ({ <no location info> }
           (HsPar 
            ({ <no location info> }
           (0)))))) 
      ({ <no location info> }
       (HsVar 
-       ({ <no location info> }{Var: (krep{v} [lid] :: ghc-prim:GHC.Types.KindRep{tc})}))))) 
+       ({ <no location info> }
+        (EName {Var: (krep{v} [lid] :: ghc-prim:GHC.Types.KindRep{tc})})))))) 
    (False))),
  ({ <no location info> }
   (VarBind {Var: (krep{v} [lid] :: ghc-prim:GHC.Types.KindRep{tc})} 
                ({abstract:ConLike}))) 
              ({ <no location info> }
               (HsVar 
-               ({ <no location info> }{Var: (main:DumpTypecheckedAst.$tcPeano{v} [lidx] :: ghc-prim:GHC.Types.TyCon{tc})}))))) 
+               ({ <no location info> }
+                (EName {Var: (main:DumpTypecheckedAst.$tcPeano{v} [lidx] :: ghc-prim:GHC.Types.TyCon{tc})})))))) 
            ({ <no location info> }
             (HsWrap 
              (WpTyApp 
              ({abstract:ConLike}))) 
            ({ <no location info> }
             (HsVar 
-             ({ <no location info> }{Var: (main:DumpTypecheckedAst.$tcPeano{v} [lidx] :: ghc-prim:GHC.Types.TyCon{tc})}))))) 
+             ({ <no location info> }
+              (EName {Var: (main:DumpTypecheckedAst.$tcPeano{v} [lidx] :: ghc-prim:GHC.Types.TyCon{tc})})))))) 
          ({ <no location info> }
           (HsWrap 
            (WpTyApp 
                 (HsApp 
                  ({ DumpTypecheckedAst.hs:11:8-15 }
                   (HsVar 
-                   ({ <no location info> }{Var: (base:System.IO.putStrLn{v} [gid] :: base:GHC.Base.String{tc}
-                                     -> ghc-prim:GHC.Types.IO{tc} ())}))) 
+                   ({ <no location info> }
+                    (EName {Var: (base:System.IO.putStrLn{v} [gid] :: base:GHC.Base.String{tc}
+                                     -> ghc-prim:GHC.Types.IO{tc} ())})))) 
                  ({ DumpTypecheckedAst.hs:11:17-23 }
                   (HsLit 
                    (HsString 
index 0f32699..f27c982 100644 (file)
@@ -30,13 +30,13 @@ traverse a =
   where
     showVar :: Maybe (HsExpr Id) -> Traverse ()
     showVar (Just (HsVar (L _ v))) =
-      modify $ \(loc, ids) -> (loc, (varName v, loc) : ids)
+      modify $ \(loc, ids) -> (loc, (varName $ unEmb v, loc) : ids)
     showVar _ =
       return ()
 
     showTyVar :: Maybe (HsType Name) -> Traverse ()
     showTyVar (Just (HsTyVar _ (L _ v))) =
-      modify $ \(loc, ids) -> (loc, (v, loc) : ids)
+      modify $ \(loc, ids) -> (loc, (unEmb v, loc) : ids)
     showTyVar _ =
       return ()
 
index 138687e..18ff53e 100644 (file)
@@ -259,7 +259,7 @@ boundValues mod group =
                _other -> error "boundValues"
       tys = [ n | ns <- map (fst . hsLTyClDeclBinders)
                             (hs_tyclds group >>= group_tyclds)
-                , n <- map found ns ]
+                , n <- map (found . unLEmb) ns ]
       fors = concat $ map forBound (hs_fords group)
              where forBound lford = case unLoc lford of
                                       ForeignImport n _ _ _ -> [found n]
@@ -283,7 +283,7 @@ boundThings modname lbinding =
     VarBind { var_id = id } -> [FoundThing modname (getOccString id) (startOfLocated lbinding)]
     AbsBinds { }    -> [] -- nothing interesting in a type abstraction
     AbsBindsSig { } -> []
-    PatSynBind PSB{ psb_id = id } -> [thing id]
+    PatSynBind PSB{ psb_id = id } -> [thing $ unLEmb id]
   where thing = foundOfLName modname
         patThings lpat tl =
           let loc = startOfLocated lpat
@@ -292,7 +292,7 @@ boundThings modname lbinding =
                WildPat _ -> tl
                VarPat (L _ name) -> lid name : tl
                LazyPat p -> patThings p tl
-               AsPat id p -> patThings p (thing id : tl)
+               AsPat id p -> patThings p (thing (unLEmb id) : tl)
                ParPat p -> patThings p tl
                BangPat p -> patThings p tl
                ListPat ps _ _ -> foldr patThings tl ps
index dbbdabf..fdaaa11 160000 (submodule)
@@ -1 +1 @@
-Subproject commit dbbdabfd3842f70c78d4c64e10f75f47fe5c0f5d
+Subproject commit fdaaa11fd38d03f09ef4d26ef411f37b8922e6c3