Refactor treatment of wildcards
authorSimon Peyton Jones <simonpj@microsoft.com>
Tue, 1 Dec 2015 16:38:23 +0000 (17:38 +0100)
committerBen Gamari <ben@smart-cactus.org>
Tue, 1 Dec 2015 17:45:23 +0000 (18:45 +0100)
This patch began as a modest refactoring of HsType and friends, to
clarify and tidy up exactly where quantification takes place in types.
Although initially driven by making the implementation of wildcards more
tidy (and fixing a number of bugs), I gradually got drawn into a pretty
big process, which I've been doing on and off for quite a long time.

There is one compiler performance regression as a result of all
this, in perf/compiler/T3064.  I still need to look into that.

* The principal driving change is described in Note [HsType binders]
  in HsType.  Well worth reading!

* Those data type changes drive almost everything else.  In particular
  we now statically know where

       (a) implicit quantification only (LHsSigType),
           e.g. in instance declaratios and SPECIALISE signatures

       (b) implicit quantification and wildcards (LHsSigWcType)
           can appear, e.g. in function type signatures

* As part of this change, HsForAllTy is (a) simplified (no wildcards)
  and (b) split into HsForAllTy and HsQualTy.  The two contructors
  appear when and only when the correponding user-level construct
  appears.  Again see Note [HsType binders].

  HsExplicitFlag disappears altogether.

* Other simplifications

     - ExprWithTySig no longer needs an ExprWithTySigOut variant

     - TypeSig no longer needs a PostRn name [name] field
       for wildcards

     - PatSynSig records a LHsSigType rather than the decomposed
       pieces

     - The mysterious 'GenericSig' is now 'ClassOpSig'

* Renamed LHsTyVarBndrs to LHsQTyVars

* There are some uninteresting knock-on changes in Haddock,
  because of the HsSyn changes

I also did a bunch of loosely-related changes:

* We already had type synonyms CoercionN/CoercionR for nominal and
  representational coercions.  I've added similar treatment for

      TcCoercionN/TcCoercionR

      mkWpCastN/mkWpCastN

  All just type synonyms but jolly useful.

* I record-ised ForeignImport and ForeignExport

* I improved the (poor) fix to Trac #10896, by making
  TcTyClsDecls.checkValidTyCl recover from errors, but adding a
  harmless, abstract TyCon to the envt if so.

* I did some significant refactoring in RnEnv.lookupSubBndrOcc,
  for reasons that I have (embarrassingly) now totally forgotten.
  It had to do with something to do with import and export

Updates haddock submodule.

319 files changed:
compiler/basicTypes/RdrName.hs
compiler/deSugar/Coverage.hs
compiler/deSugar/DsArrows.hs
compiler/deSugar/DsBinds.hs
compiler/deSugar/DsExpr.hs
compiler/deSugar/DsForeign.hs
compiler/deSugar/DsMeta.hs
compiler/ghc.mk
compiler/hsSyn/Convert.hs
compiler/hsSyn/HsBinds.hs
compiler/hsSyn/HsDecls.hs
compiler/hsSyn/HsExpr.hs
compiler/hsSyn/HsPat.hs
compiler/hsSyn/HsSyn.hs
compiler/hsSyn/HsTypes.hs
compiler/hsSyn/HsUtils.hs
compiler/iface/IfaceSyn.hs
compiler/main/HscStats.hs
compiler/main/HscTypes.hs
compiler/parser/Lexer.x
compiler/parser/Parser.y
compiler/parser/RdrHsSyn.hs
compiler/prelude/PrelNames.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/TcArrows.hs
compiler/typecheck/TcBinds.hs
compiler/typecheck/TcClassDcl.hs
compiler/typecheck/TcDefaults.hs
compiler/typecheck/TcDeriv.hs
compiler/typecheck/TcEnv.hs
compiler/typecheck/TcErrors.hs
compiler/typecheck/TcEvidence.hs
compiler/typecheck/TcExpr.hs
compiler/typecheck/TcForeign.hs
compiler/typecheck/TcGenDeriv.hs
compiler/typecheck/TcHsSyn.hs
compiler/typecheck/TcHsType.hs
compiler/typecheck/TcInstDcls.hs
compiler/typecheck/TcMType.hs
compiler/typecheck/TcMatches.hs
compiler/typecheck/TcPat.hs
compiler/typecheck/TcPatSyn.hs
compiler/typecheck/TcPatSyn.hs-boot
compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcRnMonad.hs
compiler/typecheck/TcRnTypes.hs
compiler/typecheck/TcRules.hs
compiler/typecheck/TcSMonad.hs
compiler/typecheck/TcSimplify.hs
compiler/typecheck/TcSplice.hs
compiler/typecheck/TcTyClsDecls.hs
compiler/typecheck/TcTyDecls.hs
compiler/typecheck/TcType.hs
compiler/typecheck/TcTypeable.hs
compiler/typecheck/TcUnify.hs
compiler/typecheck/TcValidity.hs
compiler/types/Coercion.hs
compiler/types/InstEnv.hs
compiler/utils/Util.hs
ghc/InteractiveUI.hs
libraries/base/Data/Monoid.hs
testsuite/tests/ado/ado005.stderr
testsuite/tests/arrows/should_fail/T5380.stderr
testsuite/tests/deriving/should_fail/T5287.stderr
testsuite/tests/gadt/T3169.stderr
testsuite/tests/gadt/T7558.stderr
testsuite/tests/gadt/rw.stderr
testsuite/tests/ghc-api/annotations/all.T
testsuite/tests/ghc-api/landmines/landmines.stdout
testsuite/tests/ghci/scripts/Defer02.stderr
testsuite/tests/ghci/scripts/T10248.stderr
testsuite/tests/ghci/scripts/T7873.stdout
testsuite/tests/ghci/scripts/ghci050.stderr
testsuite/tests/indexed-types/should_compile/PushedInAsGivens.stderr
testsuite/tests/indexed-types/should_compile/Records.hs
testsuite/tests/indexed-types/should_compile/Simple14.stderr
testsuite/tests/indexed-types/should_compile/T3208b.stderr
testsuite/tests/indexed-types/should_fail/BadSock.hs
testsuite/tests/indexed-types/should_fail/GADTwrong1.stderr
testsuite/tests/indexed-types/should_fail/NoMatchErr.stderr
testsuite/tests/indexed-types/should_fail/Overlap6.stderr
testsuite/tests/indexed-types/should_fail/SimpleFail15.stderr
testsuite/tests/indexed-types/should_fail/SimpleFail16.stderr
testsuite/tests/indexed-types/should_fail/SimpleFail5a.stderr
testsuite/tests/indexed-types/should_fail/T1897b.stderr
testsuite/tests/indexed-types/should_fail/T1900.stderr
testsuite/tests/indexed-types/should_fail/T2693.stderr
testsuite/tests/indexed-types/should_fail/T3330a.stderr
testsuite/tests/indexed-types/should_fail/T3440.stderr
testsuite/tests/indexed-types/should_fail/T4093a.stderr
testsuite/tests/indexed-types/should_fail/T4093b.stderr
testsuite/tests/indexed-types/should_fail/T4174.stderr
testsuite/tests/indexed-types/should_fail/T4272.stderr
testsuite/tests/indexed-types/should_fail/T7194.stderr
testsuite/tests/indexed-types/should_fail/T9036.stderr
testsuite/tests/indexed-types/should_fail/T9171.stderr
testsuite/tests/indexed-types/should_fail/T9433.stderr
testsuite/tests/indexed-types/should_fail/T9662.stderr
testsuite/tests/module/mod98.stderr
testsuite/tests/monadfail/MonadFailErrors.stderr
testsuite/tests/monadfail/MonadFailWarnings.stderr
testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.stderr
testsuite/tests/parser/should_fail/NoPatternSynonyms.stderr
testsuite/tests/parser/should_fail/T3811.stderr
testsuite/tests/parser/should_fail/T7848.stderr
testsuite/tests/parser/should_fail/readFail031.stderr
testsuite/tests/partial-sigs/should_compile/Defaulting2MROn.stderr
testsuite/tests/partial-sigs/should_compile/ExprSigLocal.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/ExprSigLocal.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr
testsuite/tests/partial-sigs/should_compile/SomethingShowable.hs
testsuite/tests/partial-sigs/should_compile/SomethingShowable.stderr
testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr
testsuite/tests/partial-sigs/should_compile/T10403.hs
testsuite/tests/partial-sigs/should_compile/T10403.stderr
testsuite/tests/partial-sigs/should_compile/T10438.stderr
testsuite/tests/partial-sigs/should_compile/T10519.stderr
testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr
testsuite/tests/partial-sigs/should_compile/all.T
testsuite/tests/partial-sigs/should_fail/Defaulting1MROff.hs
testsuite/tests/partial-sigs/should_fail/Defaulting1MROff.stderr
testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInExpressionSignature.stderr
testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSignature.stderr
testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInTypeSplice2.hs
testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInTypeSplice2.stderr
testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInTypeSpliceUsed.stderr
testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotEnabled.stderr
testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotLast.stderr
testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotPresent.stderr
testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardTwice.stderr
testsuite/tests/partial-sigs/should_fail/InstantiatedNamedWildcardsInConstraints.stderr
testsuite/tests/partial-sigs/should_fail/NamedExtraConstraintsWildcard.stderr
testsuite/tests/partial-sigs/should_fail/NamedWildcardInDataFamilyInstanceLHS.stderr
testsuite/tests/partial-sigs/should_fail/NamedWildcardInTypeFamilyInstanceLHS.stderr
testsuite/tests/partial-sigs/should_fail/NamedWildcardInTypeSplice.stderr
testsuite/tests/partial-sigs/should_fail/NamedWildcardsEnabled.stderr
testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotEnabled.stderr
testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotInMonotype.hs
testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotInMonotype.stderr
testsuite/tests/partial-sigs/should_fail/NestedExtraConstraintsWildcard.stderr
testsuite/tests/partial-sigs/should_fail/NestedNamedExtraConstraintsWildcard.stderr
testsuite/tests/partial-sigs/should_fail/PartialClassMethodSignature.stderr
testsuite/tests/partial-sigs/should_fail/PartialClassMethodSignature2.stderr
testsuite/tests/partial-sigs/should_fail/PartialTypeSignaturesDisabled.stderr
testsuite/tests/partial-sigs/should_fail/T10045.stderr
testsuite/tests/partial-sigs/should_fail/T10615.stderr
testsuite/tests/partial-sigs/should_fail/T10999.hs
testsuite/tests/partial-sigs/should_fail/T10999.stderr
testsuite/tests/partial-sigs/should_fail/TidyClash.stderr
testsuite/tests/partial-sigs/should_fail/Trac10045.hs [deleted file]
testsuite/tests/partial-sigs/should_fail/Trac10045.stderr [deleted file]
testsuite/tests/partial-sigs/should_fail/UnnamedConstraintWildcard1.stderr
testsuite/tests/partial-sigs/should_fail/UnnamedConstraintWildcard2.stderr
testsuite/tests/partial-sigs/should_fail/WildcardInADT1.stderr
testsuite/tests/partial-sigs/should_fail/WildcardInADT2.stderr
testsuite/tests/partial-sigs/should_fail/WildcardInADT3.stderr
testsuite/tests/partial-sigs/should_fail/WildcardInADTContext1.stderr
testsuite/tests/partial-sigs/should_fail/WildcardInADTContext2.stderr
testsuite/tests/partial-sigs/should_fail/WildcardInDefault.stderr
testsuite/tests/partial-sigs/should_fail/WildcardInDefaultSignature.stderr
testsuite/tests/partial-sigs/should_fail/WildcardInDeriving.stderr
testsuite/tests/partial-sigs/should_fail/WildcardInForeignExport.stderr
testsuite/tests/partial-sigs/should_fail/WildcardInForeignImport.stderr
testsuite/tests/partial-sigs/should_fail/WildcardInGADT1.stderr
testsuite/tests/partial-sigs/should_fail/WildcardInGADT2.stderr
testsuite/tests/partial-sigs/should_fail/WildcardInInstanceHead.stderr
testsuite/tests/partial-sigs/should_fail/WildcardInInstanceSig.stderr
testsuite/tests/partial-sigs/should_fail/WildcardInNewtype.stderr
testsuite/tests/partial-sigs/should_fail/WildcardInPatSynSig.stderr
testsuite/tests/partial-sigs/should_fail/WildcardInStandaloneDeriving.stderr
testsuite/tests/partial-sigs/should_fail/WildcardInTypeFamilyInstanceRHS.stderr
testsuite/tests/partial-sigs/should_fail/WildcardInTypeSynonymRHS.stderr
testsuite/tests/partial-sigs/should_fail/WildcardInstantiations.stderr
testsuite/tests/partial-sigs/should_fail/all.T
testsuite/tests/patsyn/should_fail/T9161-1.stderr
testsuite/tests/patsyn/should_fail/T9161-2.stderr
testsuite/tests/perf/compiler/T5837.stderr
testsuite/tests/perf/compiler/all.T
testsuite/tests/polykinds/PolyKinds02.stderr
testsuite/tests/polykinds/T10503.stderr
testsuite/tests/polykinds/T10516.stderr
testsuite/tests/polykinds/T6021.stderr
testsuite/tests/polykinds/T6068.hs
testsuite/tests/polykinds/T7224.stderr
testsuite/tests/polykinds/T7230.stderr
testsuite/tests/polykinds/T7278.stderr
testsuite/tests/polykinds/T7328.stderr
testsuite/tests/polykinds/T7438.stderr
testsuite/tests/polykinds/T9222.stderr
testsuite/tests/rename/should_compile/T4426.hs
testsuite/tests/rename/should_compile/T4426.stderr
testsuite/tests/rename/should_compile/T5331.stderr
testsuite/tests/rename/should_compile/all.T
testsuite/tests/rename/should_fail/T2901.stderr
testsuite/tests/rename/should_fail/T5372.hs
testsuite/tests/rename/should_fail/T5372.stderr
testsuite/tests/rename/should_fail/rnfail026.stderr
testsuite/tests/roles/should_fail/RolesIArray.stderr
testsuite/tests/simplCore/should_compile/T8848.stderr
testsuite/tests/simplCore/should_compile/T8848a.stderr
testsuite/tests/simplCore/should_compile/rule2.stderr
testsuite/tests/th/T10267.stderr
testsuite/tests/th/T3177a.stderr
testsuite/tests/th/T8625.stdout
testsuite/tests/th/TH_pragma.stderr
testsuite/tests/typecheck/should_compile/FD1.stderr
testsuite/tests/typecheck/should_compile/FD2.stderr
testsuite/tests/typecheck/should_compile/FD3.stderr
testsuite/tests/typecheck/should_compile/T10632.stderr
testsuite/tests/typecheck/should_compile/T7220a.stderr
testsuite/tests/typecheck/should_compile/T9834.stderr
testsuite/tests/typecheck/should_compile/T9939.stderr
testsuite/tests/typecheck/should_compile/tc141.stderr
testsuite/tests/typecheck/should_compile/tc166.hs
testsuite/tests/typecheck/should_compile/tc168.stderr
testsuite/tests/typecheck/should_compile/tc182.hs
testsuite/tests/typecheck/should_compile/tc244.hs
testsuite/tests/typecheck/should_fail/ContextStack2.stderr
testsuite/tests/typecheck/should_fail/CustomTypeErrors02.stderr
testsuite/tests/typecheck/should_fail/CustomTypeErrors03.stderr
testsuite/tests/typecheck/should_fail/FDsFromGivens.stderr
testsuite/tests/typecheck/should_fail/FailDueToGivenOverlapping.stderr
testsuite/tests/typecheck/should_fail/IPFail.stderr
testsuite/tests/typecheck/should_fail/T10285.stderr
testsuite/tests/typecheck/should_fail/T10351.stderr
testsuite/tests/typecheck/should_fail/T10534.stderr
testsuite/tests/typecheck/should_fail/T10715.stderr
testsuite/tests/typecheck/should_fail/T11112.stderr
testsuite/tests/typecheck/should_fail/T1897a.stderr
testsuite/tests/typecheck/should_fail/T1899.stderr
testsuite/tests/typecheck/should_fail/T2538.stderr
testsuite/tests/typecheck/should_fail/T2714.stderr
testsuite/tests/typecheck/should_fail/T3102.stderr
testsuite/tests/typecheck/should_fail/T3540.stderr
testsuite/tests/typecheck/should_fail/T4875.stderr
testsuite/tests/typecheck/should_fail/T5236.stderr
testsuite/tests/typecheck/should_fail/T5300.stderr
testsuite/tests/typecheck/should_fail/T5957.stderr
testsuite/tests/typecheck/should_fail/T6022.stderr
testsuite/tests/typecheck/should_fail/T7279.stderr
testsuite/tests/typecheck/should_fail/T7410.stderr
testsuite/tests/typecheck/should_fail/T7453.stderr
testsuite/tests/typecheck/should_fail/T7609.stderr
testsuite/tests/typecheck/should_fail/T7645.stderr
testsuite/tests/typecheck/should_fail/T7696.stderr
testsuite/tests/typecheck/should_fail/T7697.stderr
testsuite/tests/typecheck/should_fail/T7748a.stderr
testsuite/tests/typecheck/should_fail/T7778.stderr
testsuite/tests/typecheck/should_fail/T7809.stderr
testsuite/tests/typecheck/should_fail/T7869.stderr
testsuite/tests/typecheck/should_fail/T8030.stderr
testsuite/tests/typecheck/should_fail/T8034.stderr
testsuite/tests/typecheck/should_fail/T8142.stderr
testsuite/tests/typecheck/should_fail/T8392a.stderr
testsuite/tests/typecheck/should_fail/T8450.stderr
testsuite/tests/typecheck/should_fail/T8603.stderr
testsuite/tests/typecheck/should_fail/T8806.stderr
testsuite/tests/typecheck/should_fail/T8883.stderr
testsuite/tests/typecheck/should_fail/T9196.stderr
testsuite/tests/typecheck/should_fail/T9201.stderr
testsuite/tests/typecheck/should_fail/mc19.stderr
testsuite/tests/typecheck/should_fail/mc21.stderr
testsuite/tests/typecheck/should_fail/mc22.stderr
testsuite/tests/typecheck/should_fail/tcfail032.stderr
testsuite/tests/typecheck/should_fail/tcfail034.stderr
testsuite/tests/typecheck/should_fail/tcfail057.stderr
testsuite/tests/typecheck/should_fail/tcfail058.stderr
testsuite/tests/typecheck/should_fail/tcfail063.stderr
testsuite/tests/typecheck/should_fail/tcfail065.stderr
testsuite/tests/typecheck/should_fail/tcfail067.stderr
testsuite/tests/typecheck/should_fail/tcfail068.stderr
testsuite/tests/typecheck/should_fail/tcfail072.stderr
testsuite/tests/typecheck/should_fail/tcfail076.stderr
testsuite/tests/typecheck/should_fail/tcfail078.stderr
testsuite/tests/typecheck/should_fail/tcfail080.stderr
testsuite/tests/typecheck/should_fail/tcfail097.stderr
testsuite/tests/typecheck/should_fail/tcfail098.stderr
testsuite/tests/typecheck/should_fail/tcfail101.stderr
testsuite/tests/typecheck/should_fail/tcfail102.stderr
testsuite/tests/typecheck/should_fail/tcfail103.stderr
testsuite/tests/typecheck/should_fail/tcfail107.stderr
testsuite/tests/typecheck/should_fail/tcfail110.stderr
testsuite/tests/typecheck/should_fail/tcfail113.stderr
testsuite/tests/typecheck/should_fail/tcfail116.stderr
testsuite/tests/typecheck/should_fail/tcfail127.stderr
testsuite/tests/typecheck/should_fail/tcfail131.stderr
testsuite/tests/typecheck/should_fail/tcfail134.stderr
testsuite/tests/typecheck/should_fail/tcfail135.stderr
testsuite/tests/typecheck/should_fail/tcfail142.stderr
testsuite/tests/typecheck/should_fail/tcfail153.stderr
testsuite/tests/typecheck/should_fail/tcfail158.stderr
testsuite/tests/typecheck/should_fail/tcfail160.stderr
testsuite/tests/typecheck/should_fail/tcfail161.stderr
testsuite/tests/typecheck/should_fail/tcfail174.stderr
testsuite/tests/typecheck/should_fail/tcfail175.stderr
testsuite/tests/typecheck/should_fail/tcfail179.stderr
testsuite/tests/typecheck/should_fail/tcfail181.stderr
testsuite/tests/typecheck/should_fail/tcfail191.stderr
testsuite/tests/typecheck/should_fail/tcfail193.stderr
testsuite/tests/typecheck/should_fail/tcfail196.stderr
testsuite/tests/typecheck/should_fail/tcfail197.stderr
testsuite/tests/typecheck/should_fail/tcfail201.stderr
testsuite/tests/typecheck/should_fail/tcfail206.stderr
testsuite/tests/typecheck/should_fail/tcfail208.stderr
testsuite/tests/typecheck/should_fail/tcfail209a.stderr
testsuite/tests/typecheck/should_fail/tcfail212.stderr
testsuite/tests/typecheck/should_fail/tcfail215.stderr
testsuite/tests/typecheck/should_run/Defer01.hs
testsuite/tests/typecheck/should_run/T7861.stderr
testsuite/tests/typecheck/should_run/tcrun008.hs
testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr
utils/haddock

index bfb11e0..f4ca912 100644 (file)
@@ -383,7 +383,7 @@ Note [Local bindings with Exact Names]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 With Template Haskell we can make local bindings that have Exact Names.
 Computing shadowing etc may use elemLocalRdrEnv (at least it certainly
-does so in RnTpes.bindHsTyVars), so for an Exact Name we must consult
+does so in RnTpes.bindHsQTyVars), so for an Exact Name we must consult
 the in-scope-name-set.
 
 
@@ -515,7 +515,6 @@ have any parent.
 
 Note [Parents for record fields]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
 For record fields, in addition to the Name of the type constructor
 (stored in par_is), we use FldParent to store the field label.  This
 extra information is used for identifying overloaded record fields
index ac9438f..85f603f 100644 (file)
@@ -545,8 +545,8 @@ addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds })
        ; flds' <- mapM addTickHsRecField flds
        ; return (expr { rupd_expr = e', rupd_flds = flds' }) }
 
-addTickHsExpr (ExprWithTySigOut e ty) =
-        liftM2 ExprWithTySigOut
+addTickHsExpr (ExprWithTySig e ty) =
+        liftM2 ExprWithTySig
                 (addTickLHsExprNever e) -- No need to tick the inner expression
                                     -- for expressions with signatures
                 (return ty)
@@ -594,11 +594,16 @@ addTickHsExpr (HsProc pat cmdtop) =
 addTickHsExpr (HsWrap w e) =
         liftM2 HsWrap
                 (return w)
-                (addTickHsExpr e)       -- explicitly no tick on inside
+                (addTickHsExpr e)       -- Explicitly no tick on inside
+
+addTickHsExpr (ExprWithTySigOut e ty) =
+        liftM2 ExprWithTySigOut
+               (addTickLHsExprNever e) -- No need to tick the inner expression
+               (return ty)             -- for expressions with signatures
 
 addTickHsExpr e@(HsType _) = return e
 
--- Others dhould never happen in expression content.
+-- Others should never happen in expression content.
 addTickHsExpr e  = pprPanic "addTickHsExpr" (ppr e)
 
 addTickTupArg :: LHsTupArg Id -> TM (LHsTupArg Id)
index 3d592b1..7735aa8 100644 (file)
@@ -616,7 +616,7 @@ dsCmd _ids local_vars _stack_ty _res_ty (HsCmdArrForm op _ args) env_ids = do
 
 dsCmd ids local_vars stack_ty res_ty (HsCmdCast coercion cmd) env_ids = do
     (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids
-    wrapped_cmd <- dsHsWrapper (mkWpCast coercion) core_cmd
+    wrapped_cmd <- dsHsWrapper (mkWpCastN coercion) core_cmd
     return (wrapped_cmd, env_ids')
 
 dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c)
index f29353b..64d5521 100644 (file)
@@ -173,10 +173,10 @@ dsHsBind dflags
         ; let core_bind = Rec bind_prs
         ; ds_binds <- dsTcEvBinds_s ev_binds
         ; rhs <- dsHsWrapper wrap $  -- Usually the identity
-                            mkLams tyvars $ mkLams dicts $
-                            mkCoreLets ds_binds $
-                            Let core_bind $
-                            Var local
+                 mkLams tyvars $ mkLams dicts $
+                 mkCoreLets ds_binds $
+                 Let core_bind $
+                 Var local
 
         ; (spec_binds, rules) <- dsSpecs rhs prags
 
index 7100e0b..cd6b96c 100644 (file)
@@ -653,7 +653,7 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
                             Nothing  -> mkTcReflCo Nominal ty
                         in if null eq_spec
                              then rhs
-                             else mkLHsWrap (mkWpCast (mkTcSubCo wrap_co)) rhs
+                             else mkLHsWrap (mkWpCastN wrap_co) rhs
                     -- eq_spec is always null for a PatSynCon
                     PatSynCon _ -> rhs
 
index acea47c..5893ae8 100644 (file)
@@ -101,14 +101,14 @@ dsForeigns' fos = do
   where
    do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl)
 
-   do_decl (ForeignImport id _ co spec) = do
+   do_decl (ForeignImport { fd_name = id, fd_co = co, fd_fi = spec }) = do
       traceIf (text "fi start" <+> ppr id)
       (bs, h, c) <- dsFImport (unLoc id) co spec
       traceIf (text "fi end" <+> ppr id)
       return (h, c, [], bs)
 
-   do_decl (ForeignExport (L _ id) _ co
-                          (CExport (L _ (CExportStatic _ ext_nm cconv)) _)) = do
+   do_decl (ForeignExport { fd_name = L _ id, fd_co = co
+                          , fd_fe = CExport (L _ (CExportStatic _ ext_nm cconv)) _ }) = do
       (h, c, _, _) <- dsFExport id co ext_nm cconv False
       return (h, c, [id], [])
 
index df452ea..8d701af 100644 (file)
@@ -180,9 +180,19 @@ repTopDs group@(HsGroup { hs_valds   = valds
 hsSigTvBinders :: HsValBinds Name -> [Name]
 -- See Note [Scoped type variables in bindings]
 hsSigTvBinders binds
-  = [hsLTyVarName tv | L _ (TypeSig _ (L _ (HsForAllTy Explicit _ qtvs _ _)) _) <- sigs
-                     , tv <- hsQTvBndrs qtvs]
+  = concatMap get_scoped_tvs sigs
   where
+    get_scoped_tvs :: LSig Name -> [Name]
+    -- Both implicit and explicit quantified variables
+    -- We need the implicit ones for   f :: forall (a::k). blah
+    --    here 'k' scopes too
+    get_scoped_tvs (L _ (TypeSig _ sig))
+       | HsIB { hsib_kvs = implicit_kvs, hsib_tvs = implicit_tvs
+              , hsib_body = sig1 } <- sig
+       , (explicit_tvs, _) <- splitLHsForAllTy (hswc_body sig1)
+       = implicit_kvs ++ implicit_tvs ++ map hsLTyVarName explicit_tvs
+    get_scoped_tvs _ = []
+
     sigs = case binds of
              ValBindsIn  _ sigs -> sigs
              ValBindsOut _ sigs -> sigs
@@ -312,7 +322,8 @@ repFamilyDecl decl@(L loc (FamilyDecl { fdInfo      = info,
                                         fdResultSig = L _ resultSig,
                                         fdInjectivityAnn = injectivity }))
   = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
-       ; let mkHsQTvs tvs = HsQTvs { hsq_kvs = [], hsq_tvs = tvs }
+       ; let mkHsQTvs :: [LHsTyVarBndr Name] -> LHsQTyVars Name
+             mkHsQTvs tvs = HsQTvs { hsq_kvs = [], hsq_tvs = tvs }
              resTyVar = case resultSig of
                      TyVarSig bndr -> mkHsQTvs [bndr]
                      _             -> mkHsQTvs []
@@ -389,8 +400,8 @@ repAssocTyFamDefaults = mapM rep_deflt
            ; repTySynInst tc1 eqn1 }
 
 -------------------------
-mk_extra_tvs :: Located Name -> LHsTyVarBndrs Name
-             -> HsDataDefn Name -> DsM (LHsTyVarBndrs Name)
+mk_extra_tvs :: Located Name -> LHsQTyVars Name
+             -> HsDataDefn Name -> DsM (LHsQTyVars Name)
 -- If there is a kind signature it must be of form
 --    k1 -> .. -> kn -> *
 -- Return type variables [tv1:k1, tv2:k2, .., tvn:kn]
@@ -445,7 +456,7 @@ repClsInstD :: ClsInstDecl Name -> DsM (Core TH.DecQ)
 repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
                          , cid_sigs = prags, cid_tyfam_insts = ats
                          , cid_datafam_insts = adts })
-  = addTyVarBinds tvs $ \_ ->
+  = addSimpleTyVarBinds tvs $
             -- We must bring the type variables into scope, so their
             -- occurrences don't fail, even though the binders don't
             -- appear in the resulting data structure
@@ -455,10 +466,8 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
             -- For example, the method names should be bound to
             -- the selector Ids, not to fresh names (Trac #5410)
             --
-            do { cxt1 <- repContext cxt
-               ; cls_tcon <- repTy (HsTyVar cls)
-               ; cls_tys <- repLTys tys
-               ; inst_ty1 <- repTapps cls_tcon cls_tys
+            do { cxt1 <- repLContext cxt
+               ; inst_ty1 <- repLTy inst_ty
                ; binds1 <- rep_binds binds
                ; prags1 <- rep_sigs prags
                ; ats1 <- mapM (repTyFamInstD . unLoc) ats
@@ -466,19 +475,17 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
                ; decls <- coreList decQTyConName (ats1 ++ adts1 ++ binds1 ++ prags1)
                ; repInst cxt1 inst_ty1 decls }
  where
-   Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty
+   (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
 
 repStandaloneDerivD :: LDerivDecl Name -> DsM (SrcSpan, Core TH.DecQ)
 repStandaloneDerivD (L loc (DerivDecl { deriv_type = ty }))
-  = do { dec <- addTyVarBinds tvs $ \_ ->
-                do { cxt' <- repContext cxt
-                   ; cls_tcon <- repTy (HsTyVar cls)
-                   ; cls_tys <- repLTys tys
-                   ; inst_ty <- repTapps cls_tcon cls_tys
-                   ; repDeriv cxt' inst_ty }
+  = do { dec <- addSimpleTyVarBinds tvs $
+                do { cxt'     <- repLContext cxt
+                   ; inst_ty' <- repLTy inst_ty
+                   ; repDeriv cxt' inst_ty' }
        ; return (loc, dec) }
   where
-    Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty
+    (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
 
 repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ)
 repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
@@ -488,9 +495,9 @@ repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
        ; repTySynInst tc eqn1 }
 
 repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ)
-repTyFamEqn (L loc (TyFamEqn { tfe_pats = HsWB { hswb_cts = tys
-                                               , hswb_kvs = kv_names
-                                               , hswb_tvs = tv_names }
+repTyFamEqn (L loc (TyFamEqn { tfe_pats = HsIB { hsib_body = tys
+                                               , hsib_kvs = kv_names
+                                               , hsib_tvs = tv_names }
                                  , tfe_rhs = rhs }))
   = do { let hs_tvs = HsQTvs { hsq_kvs = kv_names
                              , hsq_tvs = userHsTyVarBndrs loc tv_names }   -- Yuk
@@ -502,7 +509,7 @@ repTyFamEqn (L loc (TyFamEqn { tfe_pats = HsWB { hswb_cts = tys
 
 repDataFamInstD :: DataFamInstDecl Name -> DsM (Core TH.DecQ)
 repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name
-                                 , dfid_pats = HsWB { hswb_cts = tys, hswb_kvs = kv_names, hswb_tvs = tv_names }
+                                 , dfid_pats = HsIB { hsib_body = tys, hsib_kvs = kv_names, hsib_tvs = tv_names }
                                  , dfid_defn = defn })
   = do { tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
        ; let loc = getLoc tc_name
@@ -512,9 +519,10 @@ repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name
             ; repDataDefn tc bndrs (Just tys1) tv_names defn } }
 
 repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
-repForD (L loc (ForeignImport name typ _ (CImport (L _ cc) (L _ s) mch cis _)))
+repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
+                              , fd_fi = CImport (L _ cc) (L _ s) mch cis _ }))
  = do MkC name' <- lookupLOcc name
-      MkC typ' <- repLTy typ
+      MkC typ' <- repHsSigType typ
       MkC cc' <- repCCallConv cc
       MkC s' <- repSafety s
       cis' <- conv_cimportspec cis
@@ -580,16 +588,17 @@ repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
 
 ruleBndrNames :: LRuleBndr Name -> [Name]
 ruleBndrNames (L _ (RuleBndr n))      = [unLoc n]
-ruleBndrNames (L _ (RuleBndrSig n (HsWB { hswb_kvs = kvs, hswb_tvs = tvs })))
+ruleBndrNames (L _ (RuleBndrSig n sig))
+  | HsIB { hsib_kvs = kvs, hsib_tvs = tvs } <- sig
   = unLoc n : kvs ++ tvs
 
 repRuleBndr :: LRuleBndr Name -> DsM (Core TH.RuleBndrQ)
 repRuleBndr (L _ (RuleBndr n))
   = do { MkC n' <- lookupLBinder n
        ; rep2 ruleVarName [n'] }
-repRuleBndr (L _ (RuleBndrSig n (HsWB { hswb_cts = ty })))
+repRuleBndr (L _ (RuleBndrSig n sig))
   = do { MkC n'  <- lookupLBinder n
-       ; MkC ty' <- repLTy ty
+       ; MkC ty' <- repLTy (hsSigWcType sig)
        ; rep2 typedRuleVarName [n', ty'] }
 
 repAnnD :: LAnnDecl Name -> DsM (SrcSpan, Core TH.DecQ)
@@ -701,15 +710,15 @@ repBangTy ty = do
 --                      Deriving clause
 -------------------------------------------------------
 
-repDerivs :: Maybe (Located [LHsType Name]) -> DsM (Core [TH.Name])
+repDerivs :: HsDeriving Name -> DsM (Core [TH.Name])
 repDerivs Nothing = coreList nameTyConName []
 repDerivs (Just (L _ ctxt))
-  = repList nameTyConName rep_deriv ctxt
+  = repList nameTyConName (rep_deriv . hsSigType) ctxt
   where
     rep_deriv :: LHsType Name -> DsM (Core TH.Name)
         -- Deriving clauses must have the simple H98 form
     rep_deriv ty
-      | Just (cls, []) <- splitHsClassTy_maybe (unLoc ty)
+      | Just (L _ cls, []) <- splitLHsClassTy_maybe ty
       = lookupOcc cls
       | otherwise
       = notHandled "Non-H98 deriving clause" (ppr ty)
@@ -729,9 +738,11 @@ rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
                      return (concat sigs1) }
 
 rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
-rep_sig (L loc (TypeSig nms ty _))    = mapM (rep_ty_sig sigDName loc ty) nms
+rep_sig (L loc (TypeSig nms ty))      = mapM (rep_wc_ty_sig sigDName loc ty) nms
 rep_sig (L _   (PatSynSig {}))        = notHandled "Pattern type signatures" empty
-rep_sig (L loc (GenericSig nms ty))   = mapM (rep_ty_sig defaultSigDName loc ty) nms
+rep_sig (L loc (ClassOpSig is_deflt nms ty))
+  | is_deflt                          = mapM (rep_ty_sig defaultSigDName loc ty) nms
+  | otherwise                         = mapM (rep_ty_sig sigDName loc ty) nms
 rep_sig d@(L _ (IdSig {}))            = pprPanic "rep_sig IdSig" (ppr d)
 rep_sig (L _   (FixSig {}))           = return [] -- fixity sigs at top level
 rep_sig (L loc (InlineSig nm ispec))  = rep_inline nm ispec loc
@@ -740,25 +751,33 @@ rep_sig (L loc (SpecSig nm tys ispec))
 rep_sig (L loc (SpecInstSig _ ty))    = rep_specialiseInst ty loc
 rep_sig (L _   (MinimalSig {}))       = notHandled "MINIMAL pragmas" empty
 
-rep_ty_sig :: Name -> SrcSpan -> LHsType Name -> Located Name
+rep_ty_sig :: Name -> SrcSpan -> LHsSigType Name -> Located Name
            -> DsM (SrcSpan, Core TH.DecQ)
-rep_ty_sig mk_sig loc (L _ ty) nm
+rep_ty_sig mk_sig loc sig_ty nm
   = do { nm1 <- lookupLOcc nm
-       ; ty1 <- rep_ty ty
+       ; ty1 <- repHsSigType sig_ty
        ; sig <- repProto mk_sig nm1 ty1
        ; return (loc, sig) }
-  where
+
+rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType Name -> Located 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_ty (HsForAllTy Explicit _ tvs ctxt ty)
-      = do { let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
-                                         ; repTyVarBndrWithKind tv name }
-           ; bndrs1 <- repList tyVarBndrTyConName rep_in_scope_tv (hsQTvBndrs tvs)
-           ; ctxt1  <- repLContext ctxt
-           ; ty1    <- repLTy ty
-           ; repTForall bndrs1 ctxt1 ty1 }
-
-    rep_ty ty = repTy ty
+rep_wc_ty_sig mk_sig loc sig_ty nm
+  | HsIB { hsib_tvs  = implicit_tvs, hsib_body = sig1 } <- sig_ty
+  , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy (hswc_body sig1)
+  = do { nm1 <- lookupLOcc nm
+       ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
+                                     ; repTyVarBndrWithKind tv name }
+             all_tvs = map (noLoc . UserTyVar . noLoc) implicit_tvs ++ explicit_tvs
+       ; th_tvs  <- repList tyVarBndrTyConName rep_in_scope_tv all_tvs
+       ; th_ctxt <- repLContext ctxt
+       ; th_ty   <- repLTy ty
+       ; ty1 <- if null all_tvs && null (unLoc ctxt)
+                then return th_ty
+                else repTForall th_tvs th_ctxt th_ty
+       ; sig <- repProto mk_sig nm1 ty1
+       ; return (loc, sig) }
 
 rep_inline :: Located Name
            -> InlinePragma      -- Never defaultInlinePragma
@@ -773,11 +792,11 @@ rep_inline nm ispec loc
        ; return [(loc, pragma)]
        }
 
-rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan
+rep_specialise :: Located Name -> LHsSigType Name -> InlinePragma -> SrcSpan
                -> DsM [(SrcSpan, Core TH.DecQ)]
 rep_specialise nm ty ispec loc
   = do { nm1 <- lookupLOcc nm
-       ; ty1 <- repLTy ty
+       ; ty1 <- repHsSigType ty
        ; phases <- repPhases $ inl_act ispec
        ; let inline = inl_inline ispec
        ; pragma <- if isEmptyInlineSpec inline
@@ -789,9 +808,9 @@ rep_specialise nm ty ispec loc
        ; return [(loc, pragma)]
        }
 
-rep_specialiseInst :: LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
+rep_specialiseInst :: LHsSigType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
 rep_specialiseInst ty loc
-  = do { ty1    <- repLTy ty
+  = do { ty1    <- repHsSigType ty
        ; pragma <- repPragSpecInst ty1
        ; return [(loc, pragma)] }
 
@@ -816,7 +835,15 @@ repPhases _                = dataCon allPhasesDataConName
 --                      Types
 -------------------------------------------------------
 
-addTyVarBinds :: LHsTyVarBndrs Name                            -- the binders to be added
+addSimpleTyVarBinds :: [Name]                -- the binders to be added
+                    -> DsM (Core (TH.Q a))   -- action in the ext env
+                    -> DsM (Core (TH.Q a))
+addSimpleTyVarBinds names thing_inside
+  = do { fresh_names <- mkGenSyms names
+       ; term <- addBinds fresh_names thing_inside
+       ; wrapGenSyms fresh_names term }
+
+addTyVarBinds :: LHsQTyVars Name                            -- the binders to be added
               -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))  -- action in the ext env
               -> DsM (Core (TH.Q a))
 -- gensym a list of type variables and enter them into the meta environment;
@@ -834,7 +861,7 @@ addTyVarBinds (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs }) m
   where
     mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
 
-addTyClTyVarBinds :: LHsTyVarBndrs Name
+addTyClTyVarBinds :: LHsQTyVars Name
                   -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))
                   -> DsM (Core (TH.Q a))
 
@@ -885,6 +912,24 @@ repContext :: HsContext Name -> DsM (Core TH.CxtQ)
 repContext ctxt = do preds <- repList typeQTyConName repLTy ctxt
                      repCtxt preds
 
+repHsSigType :: LHsSigType Name -> DsM (Core TH.TypeQ)
+repHsSigType ty = repLTy (hsSigType ty)
+
+repHsSigWcType :: LHsSigWcType Name -> DsM (Core TH.TypeQ)
+repHsSigWcType (HsIB { hsib_kvs  = implicit_kvs
+                     , hsib_tvs  = implicit_tvs
+                     , hsib_body = sig1 })
+  | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy (hswc_body sig1)
+  = addTyVarBinds (HsQTvs { hsq_kvs = implicit_kvs
+                          , hsq_tvs = map (noLoc . UserTyVar . noLoc) implicit_tvs
+                                      ++ explicit_tvs })
+                  $ \ th_tvs ->
+    do { th_ctxt <- repLContext ctxt
+       ; th_ty   <- repLTy ty
+       ; if null implicit_tvs && null explicit_tvs && null (unLoc ctxt)
+         then return th_ty
+         else repTForall th_tvs th_ctxt th_ty }
+
 -- yield the representation of a list of types
 --
 repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
@@ -895,27 +940,18 @@ repLTys tys = mapM repLTy tys
 repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
 repLTy (L _ ty) = repTy ty
 
-repTy :: HsType Name -> DsM (Core TH.TypeQ)
-repTy (HsForAllTy _ extra tvs ctxt ty)  =
-  addTyVarBinds tvs $ \bndrs -> do
-    ctxt1  <- repLContext ctxt'
-    ty1    <- repLTy ty
-    repTForall bndrs ctxt1 ty1
-  where
-    -- If extra is not Nothing, an extra-constraints wild card was removed
-    -- (just) before renaming. It must be put back now, otherwise the
-    -- represented type won't include this extra-constraints wild card.
-    ctxt'
-      | Just loc <- extra
-      = let uniq = panic "addExtraCtsWC"
-             -- This unique will be discarded by repLContext, but is required
-             -- to make a Name
-            name = mkInternalName uniq (mkTyVarOcc "_") loc
-        in  (++ [L loc (HsWildCardTy (AnonWildCard (L loc name)))]) `fmap` ctxt
-      | otherwise
-      = ctxt
-
+repForall :: HsType Name -> DsM (Core TH.TypeQ)
+-- Arg of repForall is always HsForAllTy or HsQualTy
+repForall ty
+ | (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty)
+ = addTyVarBinds (HsQTvs { hsq_kvs = [], hsq_tvs = tvs}) $ \bndrs ->
+   do { ctxt1  <- repLContext ctxt
+      ; ty1    <- repLTy tau
+      ; repTForall bndrs ctxt1 ty1 }
 
+repTy :: HsType Name -> DsM (Core TH.TypeQ)
+repTy ty@(HsForAllTy {}) = repForall ty
+repTy ty@(HsQualTy {})   = repForall ty
 
 repTy (HsTyVar (L _ n))
   | isTvOcc occ   = do tv1 <- lookupOcc n
@@ -1152,7 +1188,11 @@ repE (RecordUpd { rupd_expr = e, rupd_flds = flds })
         fs <- repUpdFields flds;
         repRecUpd x fs }
 
-repE (ExprWithTySig e ty _) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }
+repE (ExprWithTySig e ty)
+  = do { e1 <- repLE e
+       ; t1 <- repHsSigWcType ty
+       ; repSigExp e1 t1 }
+
 repE (ArithSeq _ _ aseq) =
   case aseq of
     From e              -> do { ds1 <- repLE e; repFrom ds1 }
index 74cbd29..eb6292d 100644 (file)
@@ -510,7 +510,6 @@ compiler_stage2_dll0_MODULES = \
        CoreSeq \
        CoreStats \
        CostCentre \
-       Ctype \
        DataCon \
        Demand \
        Digraph \
@@ -550,7 +549,6 @@ compiler_stage2_dll0_MODULES = \
        InstEnv \
        Kind \
        Lexeme \
-       Lexer \
        ListSetOps \
        Literal \
        Maybes \
index 29dd48c..1fc4f09 100644 (file)
@@ -14,7 +14,6 @@ module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
                 thRdrNameGuesses ) where
 
 import HsSyn as Hs
-import HsTypes  ( mkHsForAllTy )
 import qualified Class
 import RdrName
 import qualified Name
@@ -173,10 +172,10 @@ cvtDec (TH.FunD nm cls)
 cvtDec (TH.SigD nm typ)
   = do  { nm' <- vNameL nm
         ; ty' <- cvtType typ
-        ; returnJustL $ Hs.SigD (TypeSig [nm'] ty' PlaceHolder) }
+        ; returnJustL $ Hs.SigD (TypeSig [nm'] (mkLHsSigWcType ty')) }
 
 cvtDec (TH.InfixD fx nm)
-  -- fixity signatures are allowed for variables, constructors, and types
+  -- 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.
@@ -229,7 +228,8 @@ cvtDec (ClassD ctxt cl tvs fds decs)
         ; at_defs <- mapM cvt_at_def ats'
         ; returnJustL $ TyClD $
           ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
-                    , tcdFDs = fds', tcdSigs = sigs', tcdMeths = binds'
+                    , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'
+                    , tcdMeths = binds'
                     , tcdATs = fams', tcdATDefs = at_defs, tcdDocs = []
                     , tcdFVs = placeHolderNames }
                               -- no docs in TH ^^
@@ -247,9 +247,13 @@ cvtDec (InstanceD ctxt ty decs)
         ; unless (null fams') (failWith (mkBadDecMsg doc fams'))
         ; ctxt' <- cvtContext ctxt
         ; L loc ty' <- cvtType ty
-        ; let inst_ty' = L loc $ mkHsForAllTy Implicit [] ctxt' $ L loc ty'
+        ; let inst_ty' = L loc $ HsQualTy { hst_ctxt = ctxt', hst_body = L loc ty' }
         ; returnJustL $ InstD $ ClsInstD $
-          ClsInstDecl inst_ty' binds' sigs' ats' adts' Nothing }
+          ClsInstDecl { cid_poly_ty = mkLHsSigType inst_ty'
+                      , cid_binds = binds'
+                      , cid_sigs = Hs.mkClassOpSigs sigs'
+                      , cid_tyfam_insts = ats', cid_datafam_insts = adts'
+                      , cid_overlap_mode = Nothing } }
 
 cvtDec (ForeignD ford)
   = do { ford' <- cvtForD ford
@@ -319,21 +323,21 @@ cvtDec (TH.RoleAnnotD tc roles)
 cvtDec (TH.StandaloneDerivD cxt ty)
   = do { cxt' <- cvtContext cxt
        ; L loc ty'  <- cvtType ty
-       ; let inst_ty' = L loc $ mkHsForAllTy Implicit [] cxt' $ L loc ty'
+       ; let inst_ty' = L loc $ HsQualTy { hst_ctxt = cxt', hst_body = L loc ty' }
        ; returnJustL $ DerivD $
-         DerivDecl { deriv_type = inst_ty', deriv_overlap_mode = Nothing } }
+         DerivDecl { deriv_type = mkLHsSigType inst_ty', deriv_overlap_mode = Nothing } }
 
 cvtDec (TH.DefaultSigD nm typ)
   = do { nm' <- vNameL nm
        ; ty' <- cvtType typ
-       ; returnJustL $ Hs.SigD $ GenericSig [nm'] ty' }
+       ; returnJustL $ Hs.SigD $ ClassOpSig True [nm'] (mkLHsSigType ty') }
 ----------------
 cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName)
 cvtTySynEqn tc (TySynEqn lhs rhs)
   = do  { lhs' <- mapM cvtType lhs
         ; rhs' <- cvtType rhs
         ; returnL $ TyFamEqn { tfe_tycon = tc
-                             , tfe_pats = mkHsWithBndrs lhs'
+                             , tfe_pats = mkHsImplicitBndrs lhs'
                              , tfe_rhs = rhs' } }
 
 ----------------
@@ -361,7 +365,7 @@ cvt_ci_decs doc decs
 cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
              -> CvtM ( LHsContext RdrName
                      , Located RdrName
-                     , LHsTyVarBndrs RdrName)
+                     , LHsQTyVars RdrName)
 cvt_tycl_hdr cxt tc tvs
   = do { cxt' <- cvtContext cxt
        ; tc'  <- tconNameL tc
@@ -372,12 +376,12 @@ cvt_tycl_hdr cxt tc tvs
 cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
                -> CvtM ( LHsContext RdrName
                        , Located RdrName
-                       , HsWithBndrs RdrName [LHsType RdrName])
+                       , HsImplicitBndrs RdrName [LHsType RdrName])
 cvt_tyinst_hdr cxt tc tys
   = do { cxt' <- cvtContext cxt
        ; tc'  <- tconNameL tc
        ; tys' <- mapM cvtType tys
-       ; return (cxt', tc', mkHsWithBndrs tys') }
+       ; return (cxt', tc', mkHsImplicitBndrs tys') }
 
 -------------------------------------------------------------------
 --              Partitioning declarations
@@ -419,13 +423,13 @@ cvtConstr (NormalC c strtys)
   = do  { c'   <- cNameL c
         ; cxt' <- returnL []
         ; tys' <- mapM cvt_arg strtys
-        ; returnL $ mkSimpleConDecl c' noExistentials cxt' (PrefixCon tys') }
+        ; returnL $ mkSimpleConDecl c' Nothing cxt' (PrefixCon tys') }
 
 cvtConstr (RecC c varstrtys)
   = do  { c'    <- cNameL c
         ; cxt'  <- returnL []
         ; args' <- mapM cvt_id_arg varstrtys
-        ; returnL $ mkSimpleConDecl c' noExistentials cxt'
+        ; returnL $ mkSimpleConDecl c' Nothing cxt'
                                    (RecCon (noLoc args')) }
 
 cvtConstr (InfixC st1 c st2)
@@ -433,13 +437,14 @@ cvtConstr (InfixC st1 c st2)
         ; cxt' <- returnL []
         ; st1' <- cvt_arg st1
         ; st2' <- cvt_arg st2
-        ; returnL $ mkSimpleConDecl c' noExistentials cxt' (InfixCon st1' st2') }
+        ; returnL $ mkSimpleConDecl c' Nothing cxt' (InfixCon st1' st2') }
 
 cvtConstr (ForallC tvs ctxt con)
   = do  { tvs'  <- cvtTvs tvs
         ; L loc ctxt' <- cvtContext ctxt
         ; L _ con' <- cvtConstr con
         ; returnL $ con' { con_qvars = mkHsQTvs (hsQTvBndrs tvs' ++ hsQTvBndrs (con_qvars con'))
+                         , con_explicit = True
                          , con_cxt = L loc (ctxt' ++ (unLoc $ con_cxt con')) } }
 
 cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName)
@@ -459,21 +464,20 @@ cvt_id_arg (i, str, ty)
                                        , cd_fld_type =  ty'
                                        , cd_fld_doc = Nothing}) }
 
-cvtDerivs :: [TH.Name] -> CvtM (Maybe (Located [LHsType RdrName]))
+cvtDerivs :: [TH.Name] -> CvtM (HsDeriving RdrName)
 cvtDerivs [] = return Nothing
 cvtDerivs cs = do { cs' <- mapM cvt_one cs
                   ; return (Just (noLoc cs')) }
         where
           cvt_one c = do { c' <- tconName c
-                         ; returnL $ HsTyVar (noLoc c') }
+                         ; ty <- returnL $ HsTyVar (noLoc c')
+                         ; return (mkLHsSigType ty) }
 
 cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep (Located RdrName)))
 cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs
                                ; ys' <- mapM tName ys
                                ; returnL (map noLoc xs', map noLoc ys') }
 
-noExistentials :: [LHsTyVarBndr RdrName]
-noExistentials = []
 
 ------------------------------------------
 --      Foreign declarations
@@ -498,7 +502,10 @@ cvtForD (ImportF callconv safety from nm ty)
     mk_imp impspec
       = do { nm' <- vNameL nm
            ; ty' <- cvtType ty
-           ; return (ForeignImport nm' ty' noForeignImportCoercionYet impspec)
+           ; return (ForeignImport { fd_name = nm'
+                                   , fd_sig_ty = mkLHsSigType ty'
+                                   , fd_co = noForeignImportCoercionYet
+                                   , fd_fi = impspec })
            }
     safety' = case safety of
                      Unsafe     -> PlayRisky
@@ -512,7 +519,10 @@ cvtForD (ExportF callconv as nm ty)
                                                 (mkFastString as)
                                                 (cvt_conv callconv)))
                                                 (noLoc as)
-        ; return $ ForeignExport nm' ty' noForeignExportCoercionYet e }
+        ; return $ ForeignExport { fd_name = nm'
+                                 , fd_sig_ty = mkLHsSigType ty'
+                                 , fd_co = noForeignExportCoercionYet
+                                 , fd_fe = e } }
 
 cvt_conv :: TH.Callconv -> CCallConv
 cvt_conv TH.CCall      = CCallConv
@@ -547,11 +557,12 @@ cvtPragmaD (SpecialiseP nm ty inline phases)
                                , inl_rule   = Hs.FunLike
                                , inl_act    = cvtPhases phases dflt
                                , inl_sat    = Nothing }
-       ; returnJustL $ Hs.SigD $ SpecSig nm' [ty'] ip }
+       ; returnJustL $ Hs.SigD $ SpecSig nm' [mkLHsSigType ty'] ip }
 
 cvtPragmaD (SpecialiseInstP ty)
   = do { ty' <- cvtType ty
-       ; returnJustL $ Hs.SigD $ SpecInstSig "{-# SPECIALISE" ty' }
+       ; returnJustL $ Hs.SigD $
+         SpecInstSig "{-# SPECIALISE" (mkLHsSigType ty') }
 
 cvtPragmaD (RuleP nm bndrs lhs rhs phases)
   = do { let nm' = mkFastString nm
@@ -608,7 +619,7 @@ cvtRuleBndr (RuleVar n)
 cvtRuleBndr (TypedRuleVar n ty)
   = do { n'  <- vNameL n
        ; ty' <- cvtType ty
-       ; return $ noLoc $ Hs.RuleBndrSig n' $ mkHsWithBndrs ty' }
+       ; return $ noLoc $ Hs.RuleBndrSig n' $ mkLHsSigWcType ty' }
 
 ---------------------------------------------------
 --              Declarations
@@ -709,7 +720,7 @@ cvtl e = wrapL (cvt e)
 
     cvt (ParensE e)      = do { e' <- cvtl e; return $ HsPar e' }
     cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtType t
-                              ; return $ ExprWithTySig e' t' PlaceHolder }
+                              ; return $ ExprWithTySig e' (mkLHsSigWcType t') }
     cvt (RecConE c flds) = do { c' <- cNameL c
                               ; flds' <- mapM (cvtFld mkFieldOcc) flds
                               ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) }
@@ -952,7 +963,7 @@ cvtp (RecP c fs)       = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
 cvtp (ListP ps)        = do { ps' <- cvtPats ps
                             ; return $ ListPat ps' placeHolderType Nothing }
 cvtp (SigP p t)        = do { p' <- cvtPat p; t' <- cvtType t
-                            ; return $ SigPatIn p' (mkHsWithBndrs t') }
+                            ; return $ SigPatIn p' (mkLHsSigWcType t') }
 cvtp (ViewP e p)       = do { e' <- cvtl e; p' <- cvtPat p
                             ; return $ ViewPat e' p' placeHolderType }
 
@@ -980,7 +991,7 @@ cvtOpAppP x op y
 -----------------------------------------------------------
 --      Types and type variables
 
-cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsTyVarBndrs RdrName)
+cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsQTyVars RdrName)
 cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') }
 
 cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
@@ -1045,8 +1056,15 @@ cvtTypeKind ty_str ty
              -> do { tvs' <- cvtTvs tvs
                    ; cxt' <- cvtContext cxt
                    ; ty'  <- cvtType ty
-                   ; returnL $ mkExplicitHsForAllTy (hsQTvBndrs tvs') cxt' ty'
-                   }
+                   ; loc <- getL
+                   ; let hs_ty | null tvs  = rho_ty
+                               | otherwise = L loc (HsForAllTy { hst_bndrs = hsQTvBndrs tvs'
+                                                               , hst_body  = rho_ty })
+                         rho_ty | null cxt  = ty'
+                                | otherwise = L loc (HsQualTy { hst_ctxt = cxt'
+                                                              , hst_body = ty' })
+
+                   ; return hs_ty }
 
            SigT ty ki
              -> do { ty' <- cvtType ty
index 978d363..25ce654 100644 (file)
@@ -447,7 +447,7 @@ plusHsValBinds _ _
 getTypeSigNames :: HsValBinds a -> NameSet
 -- Get the names that have a user type sig
 getTypeSigNames (ValBindsOut _ sigs)
-  = mkNameSet [unLoc n | L _ (TypeSig names _ _) <- sigs, n <- names]
+  = mkNameSet [unLoc n | L _ (TypeSig names _) <- sigs, n <- names]
 getTypeSigNames _
   = panic "HsBinds.getTypeSigNames"
 
@@ -627,9 +627,8 @@ 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
-       (LHsType name)         -- RHS of the signature
-       (PostRn name [Name])   -- Wildcards (both named and anonymous) of the RHS
+       [Located 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
       --
@@ -640,21 +639,20 @@ data Sig name
       --           'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow'
 
       -- For details on above see note [Api annotations] in ApiAnnotation
-  | PatSynSig (Located name)
-              (HsExplicitFlag, LHsTyVarBndrs name)
-              (LHsContext name) -- Required context
-              (LHsContext name) -- Provided context
-              (LHsType name)
-
-        -- | A type signature for a default method inside a class
-        --
-        -- > default eq :: (Representable0 a, GEq (Rep0 a)) => a -> a -> Bool
-        --
-        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault',
-        --           'ApiAnnotation.AnnDcolon'
-
-        -- For details on above see note [Api annotations] in ApiAnnotation
-  | GenericSig [Located name] (LHsType name)
+  | PatSynSig (Located name) (LHsSigType name)
+      -- P :: forall a b. Prov => Req => ty
+
+      -- | A signature for a class method
+      --   False: ordinary class-method signauure
+      --   True:  default class method signature
+      -- e.g.   class C a where
+      --          op :: a -> a                   -- Ordinary
+      --          default op :: Eq a => a -> a   -- Generic default
+      -- No wildcards allowed here
+      --
+      --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault',
+      --           'ApiAnnotation.AnnDcolon'
+  | ClassOpSig Bool [Located name] (LHsSigType name)
 
         -- | A type signature in generated code, notably the code
         -- generated for record selectors.  We simply record
@@ -700,11 +698,11 @@ data Sig name
         --      'ApiAnnotation.AnnDcolon'
 
         -- For details on above see note [Api annotations] in ApiAnnotation
-  | SpecSig     (Located name)  -- Specialise a function or datatype  ...
-                [LHsType name]  -- ... to these types
-                InlinePragma    -- The pragma on SPECIALISE_INLINE form.
-                                -- If it's just defaultInlinePragma, then we said
-                                --    SPECIALISE, not SPECIALISE_INLINE
+  | SpecSig     (Located 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
+                                   --    SPECIALISE, not SPECIALISE_INLINE
 
         -- | A specialisation pragma for instance declarations only
         --
@@ -717,7 +715,7 @@ data Sig name
         --      'ApiAnnotation.AnnInstance','ApiAnnotation.AnnClose'
 
         -- For details on above see note [Api annotations] in ApiAnnotation
-  | SpecInstSig SourceText (LHsType name)
+  | SpecInstSig SourceText (LHsSigType name)
                   -- Note [Pragma source text] in BasicTypes
 
         -- | A minimal complete definition pragma
@@ -782,7 +780,7 @@ isVanillaLSig _                 = False
 
 isTypeLSig :: LSig name -> Bool  -- Type signatures
 isTypeLSig (L _(TypeSig {}))    = True
-isTypeLSig (L _(GenericSig {})) = True
+isTypeLSig (L _(ClassOpSig {})) = True
 isTypeLSig (L _(IdSig {}))      = True
 isTypeLSig _                    = False
 
@@ -812,7 +810,9 @@ isMinimalLSig _                    = False
 hsSigDoc :: Sig name -> SDoc
 hsSigDoc (TypeSig {})           = ptext (sLit "type signature")
 hsSigDoc (PatSynSig {})         = ptext (sLit "pattern synonym signature")
-hsSigDoc (GenericSig {})        = ptext (sLit "default type signature")
+hsSigDoc (ClassOpSig is_deflt _ _)
+ | is_deflt                     = ptext (sLit "default type signature")
+ | otherwise                    = ptext (sLit "class method signature")
 hsSigDoc (IdSig {})             = ptext (sLit "id signature")
 hsSigDoc (SpecSig {})           = ptext (sLit "SPECIALISE pragma")
 hsSigDoc (InlineSig _ prag)     = ppr (inlinePragmaSpec prag) <+> ptext (sLit "pragma")
@@ -830,21 +830,26 @@ instance (OutputableBndr name) => Outputable (Sig name) where
     ppr sig = ppr_sig sig
 
 ppr_sig :: OutputableBndr name => Sig name -> SDoc
-ppr_sig (TypeSig vars ty _wcs)    = pprVarSig (map unLoc vars) (ppr ty)
-ppr_sig (GenericSig vars ty)      = ptext (sLit "default") <+> pprVarSig (map unLoc vars) (ppr ty)
-ppr_sig (IdSig id)                = pprVarSig [id] (ppr (varType id))
-ppr_sig (FixSig fix_sig)          = ppr fix_sig
+ppr_sig (TypeSig vars ty)    = pprVarSig (map unLoc vars) (ppr ty)
+ppr_sig (ClassOpSig is_deflt vars ty)
+  | is_deflt                 = ptext (sLit "default") <+> pprVarSig (map unLoc vars) (ppr ty)
+  | otherwise                = pprVarSig (map unLoc vars) (ppr ty)
+ppr_sig (IdSig id)           = pprVarSig [id] (ppr (varType id))
+ppr_sig (FixSig fix_sig)     = ppr fix_sig
 ppr_sig (SpecSig var ty inl)
   = pragBrackets (pprSpec (unLoc var) (interpp'SP ty) inl)
 ppr_sig (InlineSig var inl)       = pragBrackets (ppr inl <+> pprPrefixOcc (unLoc var))
 ppr_sig (SpecInstSig _ ty)
   = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty)
 ppr_sig (MinimalSig _ bf)         = pragBrackets (pprMinimalSig bf)
-ppr_sig (PatSynSig name (flag, qtvs) (L _ req) (L _ prov) ty)
+ppr_sig (PatSynSig name sig_ty)
   = pprPatSynSig (unLoc name) False -- TODO: is_bindir
-                 (pprHsForAll flag qtvs (noLoc []))
-                 (pprHsContextMaybe req) (pprHsContextMaybe prov)
+                 (pprHsForAllTvs qtvs)
+                 (pprHsContextMaybe (unLoc req))
+                 (pprHsContextMaybe (unLoc prov))
                  (ppr ty)
+  where
+    (qtvs, req, prov, ty) = splitLHsPatSynTy (hsSigType sig_ty)
 
 pprPatSynSig :: (OutputableBndr name)
              => name -> Bool -> SDoc -> Maybe SDoc -> Maybe SDoc -> SDoc -> SDoc
index f75fff1..b8612ed 100644 (file)
@@ -19,7 +19,8 @@
 -- @InstDecl@, @DefaultDecl@ and @ForeignDecl@.
 module HsDecls (
   -- * Toplevel declarations
-  HsDecl(..), LHsDecl, HsDataDefn(..),
+  HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving,
+
   -- ** Class or type declarations
   TyClDecl(..), LTyClDecl,
   TyClGroup(..), tyClGroupConcat, mkTyClGroup,
@@ -481,10 +482,10 @@ data TyClDecl name
     --             'ApiAnnotation.AnnEqual',
 
     -- For details on above see note [Api annotations] in ApiAnnotation
-    SynDecl { tcdLName  :: Located name            -- ^ Type constructor
-            , tcdTyVars :: LHsTyVarBndrs name      -- ^ Type variables; for an associated type
+    SynDecl { tcdLName  :: Located name           -- ^ Type constructor
+            , tcdTyVars :: LHsQTyVars name        -- ^ Type variables; for an associated type
                                                   --   these include outer binders
-            , tcdRhs    :: LHsType name            -- ^ RHS of type declaration
+            , tcdRhs    :: LHsType name           -- ^ RHS of type declaration
             , tcdFVs    :: PostRn name NameSet }
 
   | -- | @data@ declaration
@@ -497,7 +498,7 @@ data TyClDecl name
 
     -- For details on above see note [Api annotations] in ApiAnnotation
     DataDecl { tcdLName    :: Located name        -- ^ Type constructor
-             , tcdTyVars   :: LHsTyVarBndrs name  -- ^ Type variables; for an associated type
+             , tcdTyVars   :: LHsQTyVars name  -- ^ Type variables; for an associated type
                                                   --   these include outer binders
                                                   -- Eg  class T a where
                                                   --       type F a :: *
@@ -509,7 +510,7 @@ data TyClDecl name
 
   | ClassDecl { tcdCtxt    :: LHsContext name,          -- ^ Context...
                 tcdLName   :: Located name,             -- ^ Name of the class
-                tcdTyVars  :: LHsTyVarBndrs name,       -- ^ Class type variables
+                tcdTyVars  :: LHsQTyVars name,          -- ^ Class type variables
                 tcdFDs     :: [Located (FunDep (Located name))],
                                                         -- ^ Functional deps
                 tcdSigs    :: [LSig name],              -- ^ Methods' signatures
@@ -548,7 +549,6 @@ tyClGroupConcat = concatMap group_tyclds
 mkTyClGroup :: [LTyClDecl name] -> TyClGroup name
 mkTyClGroup decls = TyClGroup { group_tyclds = decls, group_roles = [] }
 
-
 -- Simple classifiers for TyClDecl
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
@@ -613,7 +613,7 @@ tyClDeclLName decl = tcdLName decl
 tcdName :: TyClDecl name -> name
 tcdName = unLoc . tyClDeclLName
 
-tyClDeclTyVars :: TyClDecl name -> LHsTyVarBndrs name
+tyClDeclTyVars :: TyClDecl name -> LHsQTyVars name
 tyClDeclTyVars (FamDecl { tcdFam = FamilyDecl { fdTyVars = tvs } }) = tvs
 tyClDeclTyVars d = tcdTyVars d
 
@@ -685,7 +685,7 @@ instance OutputableBndr name => Outputable (TyClGroup name) where
 
 pp_vanilla_decl_head :: OutputableBndr name
    => Located name
-   -> LHsTyVarBndrs name
+   -> LHsQTyVars name
    -> HsContext name
    -> SDoc
 pp_vanilla_decl_head thing tyvars context
@@ -796,7 +796,7 @@ type LFamilyDecl name = Located (FamilyDecl name)
 data FamilyDecl name = FamilyDecl
   { fdInfo           :: FamilyInfo name              -- type/data, closed/open
   , fdLName          :: Located name                 -- type constructor
-  , fdTyVars         :: LHsTyVarBndrs name           -- type variables
+  , fdTyVars         :: LHsQTyVars name              -- type variables
   , fdResultSig      :: LFamilyResultSig name        -- result signature
   , fdInjectivityAnn :: Maybe (LInjectivityAnn name) -- optional injectivity ann
   }
@@ -960,26 +960,31 @@ data HsDataDefn name   -- The payload of a data type defn
                      -- For @data T a where { T1 :: T a }@
                      --   the 'LConDecls' all have 'ResTyGADT'.
 
-                 dd_derivs :: Maybe (Located [LHsType name])
-                     -- ^ Derivings; @Nothing@ => not specified,
-                     --              @Just []@ => derive exactly what is asked
-                     --
-                     -- These "types" must be of form
-                     -- @
-                     --      forall ab. C ty1 ty2
-                     -- @
-                     -- Typically the foralls and ty args are empty, but they
-                     -- are non-empty for the newtype-deriving case
-                     --
-                     --  - 'ApiAnnotation.AnnKeywordId' :
-                     --       'ApiAnnotation.AnnDeriving',
-                     --       'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'
+                 dd_derivs :: HsDeriving name  -- ^ Optional 'deriving' claues
 
              -- For details on above see note [Api annotations] in ApiAnnotation
    }
     deriving( Typeable )
 deriving instance (DataId id) => Data (HsDataDefn id)
 
+type HsDeriving name = Maybe (Located [LHsSigType name])
+  -- ^ The optional 'deriving' clause of a data declaration
+  --
+  --   @Nothing@ => not specified,
+  --   @Just []@ => derive exactly what is asked
+  --
+  -- It's a 'LHsSigType' because, with Generalised Newtype
+  -- Deriving, we can mention type variables that aren't
+  -- bound by the date type.   e.g.
+  --     data T b = ... deriving( C [a] )
+  -- should producd a derived instance for (C [a] (T b))
+  --
+  -- The payload of the Maybe is Located so that we have a
+  -- place to hang the API annotations:
+  --  - 'ApiAnnotation.AnnKeywordId' :
+  --       'ApiAnnotation.AnnDeriving',
+  --       'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'
+
 data NewOrData
   = NewType                     -- ^ @newtype Blah ...@
   | DataType                    -- ^ @data Blah ...@
@@ -1021,17 +1026,28 @@ data ConDecl name
         -- the user-callable wrapper Id.
         -- It is a list to deal with GADT constructors of the form
         --   T1, T2, T3 :: <payload>
-    , con_explicit  :: HsExplicitFlag
-        -- ^ Is there an user-written forall? (cf. 'HsTypes.HsForAllTy')
 
-    , con_qvars     :: LHsTyVarBndrs name
+    , con_explicit  :: Bool
+        -- ^ Is there an user-written forall?
+        -- For ResTyH98, "explicit" means something like:
+        --     data T = forall a. MkT { x :: a -> a }
+        -- For ResTyGADT, "explicit" means something like
+        --     data T where { MkT :: forall a. <blah> }
+
+    , con_qvars     :: LHsQTyVars name
         -- ^ Type variables.  Depending on 'con_res' this describes the
         -- following entities
         --
         --  - ResTyH98:  the constructor's *existential* type variables
+        --               e.g. data T a = forall b. MkT b (b->a)
+        --               con_qvars = {b}
+        --
         --  - ResTyGADT: *all* the constructor's quantified type variables
+        --               e.g.  data T a where
+        --                       MkT :: forall a b. b -> (b->a) -> T a
+        --               con_qvars = {a,b}
         --
-        -- If con_explicit is Implicit, then con_qvars is irrelevant
+        -- If con_explicit is False, then con_qvars is irrelevant
         -- until after renaming.
 
     , con_cxt       :: LHsContext name
@@ -1087,9 +1103,9 @@ pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context
                Nothing   -> empty
                Just kind -> dcolon <+> ppr kind
     pp_derivings = case derivings of
-                     Nothing       -> empty
-                     Just (L _ ds) -> hsep [ptext (sLit "deriving"),
-                                            parens (interpp'SP ds)]
+                     Nothing -> empty
+                     Just (L _ ds) -> hsep [ ptext (sLit "deriving")
+                                           , parens (interpp'SP ds)]
 
 instance OutputableBndr name => Outputable (HsDataDefn name) where
    ppr d = pp_data_defn (\_ -> ptext (sLit "Naked HsDataDefn")) d
@@ -1112,7 +1128,7 @@ pprConDecl (ConDecl { con_names = [L _ con]  -- NB: non-GADT means 1 con
                     , con_explicit = expl, con_qvars = tvs
                     , con_cxt = cxt, con_details = details
                     , con_res = ResTyH98, con_doc = doc })
-  = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details details]
+  = sep [ppr_mbDoc doc, ppr_con_forall expl tvs cxt, ppr_details details]
   where
     ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc con, ppr t2]
     ppr_details (PrefixCon tys)  = hsep (pprPrefixOcc con
@@ -1124,7 +1140,7 @@ pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs
                     , con_cxt = cxt, con_details = PrefixCon arg_tys
                     , con_res = ResTyGADT _ res_ty, con_doc = doc })
   = ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon <+>
-    sep [pprHsForAll expl tvs cxt, ppr (foldr mk_fun_ty res_ty arg_tys)]
+    sep [ppr_con_forall expl tvs cxt, ppr (foldr mk_fun_ty res_ty arg_tys)]
   where
     mk_fun_ty a b = noLoc (HsFunTy a b)
 
@@ -1132,7 +1148,7 @@ pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs
                     , con_cxt = cxt, con_details = RecCon fields
                     , con_res = ResTyGADT _ res_ty, con_doc = doc })
   = sep [ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon
-         <+> pprHsForAll expl tvs cxt,
+         <+> ppr_con_forall expl tvs cxt,
          pprConDeclFields (unLoc fields) <+> arrow <+> ppr res_ty]
 
 pprConDecl decl@(ConDecl { con_details = InfixCon ty1 ty2, con_res = ResTyGADT {} })
@@ -1145,6 +1161,14 @@ pprConDecl decl@(ConDecl { con_details = InfixCon ty1 ty2, con_res = ResTyGADT {
 -- than one constructor, which should indeed be impossible
 pprConDecl (ConDecl { con_names = cons }) = pprPanic "pprConDecl" (ppr cons)
 
+ppr_con_forall :: OutputableBndr name => Bool -> LHsQTyVars name
+                                      -> LHsContext name -> SDoc
+ppr_con_forall explicit_forall qtvs (L _ ctxt)
+  | explicit_forall
+  = pprHsForAllTvs (hsQTvBndrs qtvs) <+> pprHsContext ctxt
+  | otherwise
+  = pprHsContext ctxt
+
 ppr_con_names :: (OutputableBndr name) => [Located name] -> SDoc
 ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc)
 
@@ -1183,12 +1207,12 @@ type LTyFamInstEqn  name = Located (TyFamInstEqn  name)
 
 type LTyFamDefltEqn name = Located (TyFamDefltEqn name)
 
-type HsTyPats name = HsWithBndrs name [LHsType name]
+type HsTyPats name = HsImplicitBndrs name [LHsType name]
             -- ^ Type patterns (with kind and type bndrs)
             -- See Note [Family instance declaration binders]
 
 type TyFamInstEqn  name = TyFamEqn name (HsTyPats name)
-type TyFamDefltEqn name = TyFamEqn name (LHsTyVarBndrs name)
+type TyFamDefltEqn name = TyFamEqn name (LHsQTyVars name)
   -- See Note [Type family instance declarations in HsSyn]
 
 -- | One equation in a type family instance declaration
@@ -1244,9 +1268,9 @@ deriving instance (DataId name) => Data (DataFamInstDecl name)
 type LClsInstDecl name = Located (ClsInstDecl name)
 data ClsInstDecl name
   = ClsInstDecl
-      { cid_poly_ty :: LHsType name    -- Context => Class Instance-type
-                                       -- Using a polytype means that the renamer conveniently
-                                       -- figures out the quantified type variables for us.
+      { cid_poly_ty :: LHsSigType name    -- Context => Class Instance-type
+                                          -- Using a polytype means that the renamer conveniently
+                                          -- figures out the quantified type variables for us.
       , cid_binds         :: LHsBinds name           -- Class methods
       , cid_sigs          :: [LSig name]             -- User-supplied pragmatic info
       , cid_tyfam_insts   :: [LTyFamInstDecl name]   -- Type family instances
@@ -1344,7 +1368,7 @@ pp_fam_inst_lhs :: OutputableBndr name
    -> HsTyPats name
    -> HsContext name
    -> SDoc
-pp_fam_inst_lhs thing (HsWB { hswb_cts = typats }) context -- explicit type patterns
+pp_fam_inst_lhs thing (HsIB { hsib_body = typats }) context -- explicit type patterns
    = hsep [ pprHsContext context, pprPrefixOcc (unLoc thing)
           , hsep (map (pprParendHsType.unLoc) typats)]
 
@@ -1404,7 +1428,7 @@ instDeclDataFamInsts inst_decls
 type LDerivDecl name = Located (DerivDecl name)
 
 data DerivDecl name = DerivDecl
-        { deriv_type :: LHsType name
+        { deriv_type         :: LHsSigType name
         , deriv_overlap_mode :: Maybe (Located OverlapMode)
          -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
          --                                    'ApiAnnotation.AnnClose',
@@ -1466,14 +1490,17 @@ instance (OutputableBndr name)
 type LForeignDecl name = Located (ForeignDecl name)
 
 data ForeignDecl name
-  = ForeignImport (Located name) -- defines this name
-                  (LHsType name) -- sig_ty
-                  (PostTc name Coercion) -- rep_ty ~ sig_ty
-                  ForeignImport
-  | ForeignExport (Located name) -- uses this name
-                  (LHsType name) -- sig_ty
-                  (PostTc name Coercion)  -- sig_ty ~ rep_ty
-                  ForeignExport
+  = ForeignImport
+      { fd_name   :: Located name          -- defines this name
+      , fd_sig_ty :: LHsSigType name       -- sig_ty
+      , fd_co     :: PostTc name Coercion  -- rep_ty ~ sig_ty
+      , fd_fi     :: ForeignImport }
+
+  | ForeignExport
+      { fd_name   :: Located name          -- uses this name
+      , fd_sig_ty :: LHsSigType name       -- sig_ty
+      , fd_co     :: PostTc name Coercion  -- rep_ty ~ sig_ty
+      , fd_fe     :: ForeignExport }
         -- ^
         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForeign',
         --           'ApiAnnotation.AnnImport','ApiAnnotation.AnnExport',
@@ -1481,6 +1508,7 @@ data ForeignDecl name
 
         -- For details on above see note [Api annotations] in ApiAnnotation
   deriving (Typeable)
+
 deriving instance (DataId name) => Data (ForeignDecl name)
 {-
     In both ForeignImport and ForeignExport:
@@ -1543,10 +1571,10 @@ data ForeignExport = CExport  (Located CExportSpec) -- contains the calling
 --
 
 instance OutputableBndr name => Outputable (ForeignDecl name) where
-  ppr (ForeignImport n ty _ fimport) =
-    hang (ptext (sLit "foreign import") <+> ppr fimport <+> ppr n)
-       2 (dcolon <+> ppr ty)
-  ppr (ForeignExport n ty _ fexport) =
+  ppr (ForeignImport { fd_name = n, fd_sig_ty = ty, fd_fi = fimport })
+    hang (ptext (sLit "foreign import") <+> ppr fimport <+> ppr n)
+         2 (dcolon <+> ppr ty)
+  ppr (ForeignExport { fd_name = n, fd_sig_ty = ty, fd_fe = fexport }) =
     hang (ptext (sLit "foreign export") <+> ppr fexport <+> ppr n)
        2 (dcolon <+> ppr ty)
 
@@ -1621,7 +1649,7 @@ flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls
 type LRuleBndr name = Located (RuleBndr name)
 data RuleBndr name
   = RuleBndr (Located name)
-  | RuleBndrSig (Located name) (HsWithBndrs name (LHsType name))
+  | RuleBndrSig (Located name) (LHsSigWcType name)
         -- ^
         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
         --     'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose'
@@ -1630,7 +1658,7 @@ data RuleBndr name
   deriving (Typeable)
 deriving instance (DataId name) => Data (RuleBndr name)
 
-collectRuleBndrSigTys :: [RuleBndr name] -> [HsWithBndrs name (LHsType name)]
+collectRuleBndrSigTys :: [RuleBndr name] -> [LHsSigWcType name]
 collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]
 
 instance OutputableBndr name => Outputable (RuleDecls name) where
@@ -1709,7 +1737,7 @@ data VectDecl name
   | HsVectClassOut              -- post type-checking
       Class
   | HsVectInstIn                -- pre type-checking (always SCALAR)  !!!FIXME: should be superfluous now
-      (LHsType name)
+      (LHsSigType name)
   | HsVectInstOut               -- post type-checking (always SCALAR) !!!FIXME: should be superfluous now
       ClsInst
   deriving (Typeable)
index 7106b06..127d87a 100644 (file)
@@ -321,16 +321,13 @@ data HsExpr id
   -- For details on above see note [Api annotations] in ApiAnnotation
   | ExprWithTySig
                 (LHsExpr id)
-                (LHsType id)
-                (PostRn id [Name])      -- After renaming, the list of Names
-                                        -- contains the named and unnamed
-                                        -- wildcards brought in scope by the
-                                        -- signature
+                (LHsSigWcType id)
 
-  | ExprWithTySigOut                    -- TRANSLATION
+  | ExprWithTySigOut              -- Post typechecking
                 (LHsExpr id)
-                (LHsType Name)          -- Retain the signature for
-                                        -- round-tripping purposes
+                (LHsSigWcType Name)  -- Retain the signature,
+                                     -- as HsSigType Name, for
+                                     -- round-tripping purposes
 
   -- | Arithmetic sequence
   --
@@ -571,28 +568,21 @@ So we use Nothing to mean "use the old built-in typing rule".
 
 Note [Record Update HsWrapper]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-There is a wrapper in RecordUpd which is used for the *required* constraints for
-pattern synonyms. This wrapper is created in the typechecking and is then
-directly used in the desugaring without modification.
+There is a wrapper in RecordUpd which is used for the *required*
+constraints for pattern synonyms. This wrapper is created in the
+typechecking and is then directly used in the desugaring without
+modification.
 
 For example, if we have the record pattern synonym P,
+  pattern P :: (Show a) => a -> Maybe a
+  pattern P{x} = Just x
 
-```
-pattern P :: (Show a) => a -> Maybe a
-pattern P{x} = Just x
-
-foo = (Just True) { x = False }
-```
-
+  foo = (Just True) { x = False }
 then `foo` desugars to something like
-
-```
-P x = P False
-```
-
-hence we need to provide the correct dictionaries to P on the RHS so that we can
-build the expression.
+  foo = case Just True of
+          P x -> P False
+hence we need to provide the correct dictionaries to P's matcher on
+the RHS so that we can build the expression.
 
 Note [Located RdrNames]
 ~~~~~~~~~~~~~~~~~~~~~~~
@@ -604,6 +594,7 @@ in the ParsedSource.
 There are unfortunately enough differences between the ParsedSource and the
 RenamedSource that the API Annotations cannot be used directly with
 RenamedSource, so this allows a simple mapping to be used based on the location.
+>>>>>>> origin/master
 -}
 
 instance OutputableBndr id => Outputable (HsExpr id) where
@@ -751,7 +742,7 @@ ppr_expr (RecordCon { rcon_con_name = con_id, rcon_flds = rbinds })
 ppr_expr (RecordUpd { rupd_expr = aexp, rupd_flds = rbinds })
   = hang (pprLExpr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds))))
 
-ppr_expr (ExprWithTySig expr sig _)
+ppr_expr (ExprWithTySig expr sig)
   = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
          4 (ppr sig)
 ppr_expr (ExprWithTySigOut expr sig)
@@ -979,7 +970,7 @@ data HsCmd id
 
     -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsCmdCast   TcCoercion     -- A simpler version of HsWrap in HsExpr
+  | HsCmdCast   TcCoercionN    -- A simpler version of HsWrap in HsExpr
                 (HsCmd id)     -- If   cmd :: arg1 --> res
                                --       co :: arg1 ~ arg2
                                -- Then (HsCmdCast co cmd) :: arg2 --> res
@@ -1147,6 +1138,7 @@ data Match id body
         m_type :: (Maybe (LHsType id)),
                                  -- A type signature for the result of the match
                                  -- Nothing after typechecking
+                                 -- NB: No longer supported
         m_grhss :: (GRHSs id body)
   } deriving (Typeable)
 deriving instance (Data body,DataId id) => Data (Match id body)
index 3209562..24ef065 100644 (file)
@@ -157,6 +157,8 @@ data Pat id
         pat_binds :: TcEvBinds,         -- Bindings involving those dictionaries
         pat_args  :: HsConPatDetails id,
         pat_wrap  :: HsWrapper          -- Extra wrapper to pass to the matcher
+                                        -- Only relevant for pattern-synonyms;
+                                        --   ignored for data cons
     }
 
         ------------ View patterns ---------------
@@ -199,9 +201,9 @@ data Pat id
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | SigPatIn        (LPat id)                  -- Pattern with a type signature
-                    (HsWithBndrs id (LHsType id)) -- Signature can bind both
-                                                  -- kind and type vars
+  | SigPatIn        (LPat id)                 -- Pattern with a type signature
+                    (LHsSigWcType id)         -- Signature can bind both
+                                              -- kind and type vars
 
   | SigPatOut       (LPat id)           -- Pattern with a type signature
                     Type
index d084dc2..72525b2 100644 (file)
@@ -40,7 +40,7 @@ import HsImpExp
 import HsLit
 import PlaceHolder
 import HsPat
-import HsTypes  hiding  ( mkHsForAllTy )
+import HsTypes
 import BasicTypes       ( Fixity, WarningTxt )
 import HsUtils
 import HsDoc
index eda643c..cd8f203 100644 (file)
@@ -20,9 +20,11 @@ module HsTypes (
         HsType(..), LHsType, HsKind, LHsKind,
         HsTyOp,LHsTyOp,
         HsTyVarBndr(..), LHsTyVarBndr,
-        LHsTyVarBndrs(..),
-        HsWithBndrs(..),
-        HsTupleSort(..), HsExplicitFlag(..),
+        LHsQTyVars(..),
+        HsImplicitBndrs(..),
+        HsWildCardBndrs(..),
+        LHsSigType, LHsSigWcType, LHsWcType,
+        HsTupleSort(..),
         HsContext, LHsContext,
         HsTyWrapper(..),
         HsTyLit(..),
@@ -44,23 +46,23 @@ module HsTypes (
         wildCardName, sameWildCard, sameNamedWildCard,
         isAnonWildCard, isNamedWildCard,
 
+        mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody,
+        mkEmptyImplicitBndrs, mkEmptyWildCardBndrs,
         mkHsQTvs, hsQTvBndrs, isHsKindedTyVar, hsTvbAllKinded,
-        mkExplicitHsForAllTy, mkImplicitHsForAllTy, mkQualifiedHsForAllTy,
-        mkHsForAllTy,
-        flattenTopLevelLHsForAllTy,flattenTopLevelHsForAllTy,
-        flattenHsForAllTyKeepAnns,
-        hsExplicitTvs,
-        hsTyVarName, mkHsWithBndrs, hsLKiTyVarNames,
-        hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
+        hsScopedTvs, hsWcScopedTvs, dropWildCards,
+        hsTyVarName, hsLKiTyVarNames,
+        hsLTyVarName, hsLTyVarNames, hsLTyVarLocName,
+        splitLHsInstDeclTy, getLHsInstDeclClass_maybe,
+        splitLHsPatSynTy,
+        splitLHsForAllTy, splitLHsQualTy, splitLHsSigmaTy,
+        splitLHsClassTy_maybe,
+        splitHsFunType, splitHsAppTys, hsTyGetAppHead_maybe,
+        mkHsAppTys, mkHsOpTy,
+        ignoreParens, hsSigType, hsSigWcType,
         hsLTyVarBndrsToTypes,
-        splitLHsInstDeclTy_maybe,
-        splitHsClassTy_maybe, splitLHsClassTy_maybe,
-        splitHsFunType,
-        splitHsAppTys, hsTyGetAppHead_maybe, mkHsAppTys, mkHsOpTy,
-        ignoreParens,
 
         -- Printing
-        pprParendHsType, pprHsForAll, pprHsForAllExtra,
+        pprParendHsType, pprHsForAll, pprHsForAllTvs, pprHsForAllExtra,
         pprHsContext, pprHsContextNoArrow, pprHsContextMaybe
     ) where
 
@@ -81,15 +83,15 @@ import SrcLoc
 import StaticFlags
 import Outputable
 import FastString
-import Lexer ( AddAnn, mkParensApiAnn )
 import Maybes( isJust )
 
 import Data.Data hiding ( Fixity )
 import Data.Maybe ( fromMaybe )
 #if __GLASGOW_HASKELL__ < 709
-import Data.Monoid hiding ((<>))
+-- SPJ temp
+-- import Data.Monoid hiding((<>))
 #endif
-#if __GLASGOW_HASKELL__ > 710
+#if __GLASGOW_HASKELL > 710
 import Data.Semigroup   ( Semigroup )
 import qualified Data.Semigroup as Semigroup
 #endif
@@ -132,6 +134,52 @@ renamer can decorate it with the variables bound
 by the pattern ('a' in the first example, 'k' in the second),
 assuming that neither of them is in scope already
 See also Note [Kind and type-variable binders] in RnTypes
+
+Note [HsType binders]
+~~~~~~~~~~~~~~~~~~~~~
+The system fr recording type and kind-variable binders in HsTypes
+is a bit complicated.  Here's how it works.
+
+* In a HsType,
+     HsForAllTy   represents an /explicit, user-written/ 'forall'
+                   e.g.   forall a b. ...
+     HsQualTy     reprsents an /explicit, user-written/ context
+                   e.g.   (Eq a, Show a) => ...
+                  The context can be empty if that's what the user wrote
+  These constructors reprsents what the user wrote, no more
+  and no less.
+
+* HsTyVarBndr describes a quantified type variable written by the
+  user.  For example
+     f :: forall a (b :: *).  blah
+  here 'a' and '(b::*)' are each a HsTyVarBndr.  A HsForAllTy has
+  a list of LHsTyVarBndrs.
+
+* HsImplicitBndrs is a wrapper that gives the implicitly-quantified
+  kind and type variables of the wrapped thing.  It is filled in by
+  the renamer.   For example, if the
+  user writes
+     f :: a -> a
+  the HsImplicitBinders binds the 'a' (not a HsForAllTy!).
+  NB: this implicit quantification is purely lexical: we bind any
+      type or kind variables that are not in scope. The type checker
+      may subsequently quantify over further kind variables.
+
+* HsWildCardBndrs is a wrapper that binds the wildcard variables
+  of the wrapped thing.  It is filled in by the renamer
+     f :: _a -> _
+  The enclosing HsWildCardBndrs binds the wildcards _a and _.
+
+* The explicit presence of these wrappers specifies, in the HsSyn,
+  exactly where implicit quantification is allowed, and where
+  wildcards are allowed.
+
+* LHsQTyVars is used in data/class declarations, where the user gives
+  explicit *type* variable bindings, but we need to implicitly bind
+  *kind* variables.  For example
+      class C (a :: k -> *) where ...
+  The 'k' is implicitly bound in the hsq_tvs field of LHsQTyVars
+
 -}
 
 type LHsContext name = Located (HsContext name)
@@ -153,45 +201,42 @@ type LHsKind name = Located (HsKind name)
       -- For details on above see note [Api annotations] in ApiAnnotation
 
 --------------------------------------------------
---             LHsTyVarBndrs
---  The quantified binders in a HsForallTy
+--             LHsQTyVars
+--  The explicitly-quantified binders in a data/type declaration
 
 type LHsTyVarBndr name = Located (HsTyVarBndr name)
+                         -- See Note [HsType binders]
 
-data LHsTyVarBndrs name
-  = HsQTvs { hsq_kvs :: [Name]                  -- Kind variables
+data LHsQTyVars name   -- See Note [HsType binders]
+  = HsQTvs { hsq_kvs :: PostRn name [Name]      -- Kind variables
            , hsq_tvs :: [LHsTyVarBndr name]     -- Type variables
              -- See Note [HsForAllTy tyvar binders]
     }
   deriving( Typeable )
-deriving instance (DataId name) => Data (LHsTyVarBndrs name)
 
-mkHsQTvs :: [LHsTyVarBndr RdrName] -> LHsTyVarBndrs RdrName
--- Just at RdrName because in the Name variant we should know just
--- what the kind-variable binders are; and we don't
--- We put an empty list (rather than a panic) for the kind vars so
--- that the pretty printer works ok on them.
-mkHsQTvs tvs = HsQTvs { hsq_kvs = [], hsq_tvs = tvs }
+deriving instance (DataId name) => Data (LHsQTyVars name)
 
-emptyHsQTvs :: LHsTyVarBndrs name   -- Use only when you know there are no kind binders
-emptyHsQTvs =  HsQTvs { hsq_kvs = [], hsq_tvs = [] }
+mkHsQTvs :: [LHsTyVarBndr RdrName] -> LHsQTyVars RdrName
+mkHsQTvs tvs = HsQTvs { hsq_kvs = PlaceHolder, hsq_tvs = tvs }
 
-hsQTvBndrs :: LHsTyVarBndrs name -> [LHsTyVarBndr name]
+hsQTvBndrs :: LHsQTyVars name -> [LHsTyVarBndr name]
 hsQTvBndrs = hsq_tvs
 
+{-
 #if __GLASGOW_HASKELL__ > 710
 instance Semigroup (LHsTyVarBndrs name) where
   HsQTvs kvs1 tvs1 <> HsQTvs kvs2 tvs2
     = HsQTvs (kvs1 ++ kvs2) (tvs1 ++ tvs2)
 #endif
 
-instance Monoid (LHsTyVarBndrs name) where
-  mempty = emptyHsQTvs
+instance Monoid (LHsQTyVars name) where
+  mempty = mkHsQTvs []
   mappend (HsQTvs kvs1 tvs1) (HsQTvs kvs2 tvs2)
     = HsQTvs (kvs1 ++ kvs2) (tvs1 ++ tvs2)
+-}
 
 ------------------------------------------------
---            HsWithBndrs
+--            HsImplicitBndrs
 -- Used to quantify the binders of a type in cases
 -- when a HsForAll isn't appropriate:
 --    * Patterns in a type/data family instance (HsTyPats)
@@ -199,20 +244,96 @@ instance Monoid (LHsTyVarBndrs name) where
 --    * Pattern type signatures (SigPatIn)
 -- In the last of these, wildcards can happen, so we must accommodate them
 
-data HsWithBndrs name thing
-  = HsWB { hswb_cts :: thing             -- Main payload (type or list of types)
-         , hswb_kvs :: PostRn name [Name] -- Kind vars
-         , hswb_tvs :: PostRn name [Name] -- Type vars
-         , hswb_wcs :: PostRn name [Name] -- Wild cards
+data HsImplicitBndrs name thing   -- See Note [HsType binders]
+  = HsIB { hsib_kvs :: PostRn name [Name] -- Implicitly-bound kind vars
+         , hsib_tvs :: PostRn name [Name] -- Implicitly-bound type vars
+         , hsib_body :: thing              -- Main payload (type or list of types)
     }
   deriving (Typeable)
+
+data HsWildCardBndrs name thing   -- See Note [HsType binders]
+  = HsWC { hswc_wcs :: PostRn name [Name]
+                -- Wild cards, both named and anonymous
+
+         , hswc_ctx :: Maybe SrcSpan
+                -- Indicates whether hswc_body has an
+                -- extra-constraint wildcard, and if so where
+                --    e.g.  (Eq a, _) => a -> a
+                -- NB: the wildcard stays in HsQualTy inside the type!
+                -- So for pretty printing purposes you can ignore
+                -- hswc_ctx
+
+         , hswc_body :: thing  -- Main payload (type or list of types)
+    }
+  deriving( Typeable )
+
 deriving instance (Data name, Data thing, Data (PostRn name [Name]))
-  => Data (HsWithBndrs name thing)
+  => Data (HsImplicitBndrs name thing)
 
-mkHsWithBndrs :: thing -> HsWithBndrs RdrName thing
-mkHsWithBndrs x = HsWB { hswb_cts = x, hswb_kvs = PlaceHolder
-                                     , hswb_tvs = PlaceHolder
-                                     , hswb_wcs = PlaceHolder }
+deriving instance (Data name, Data thing, Data (PostRn name [Name]))
+  => Data (HsWildCardBndrs name thing)
+
+type LHsSigType   name = HsImplicitBndrs name (LHsType name)    -- Implicit only
+type LHsWcType    name = HsWildCardBndrs name (LHsType name)    -- Wildcard only
+type LHsSigWcType name = HsImplicitBndrs name (LHsWcType name)  -- Both
+
+-- See Note [Representing type signatures]
+
+hsImplicitBody :: HsImplicitBndrs name thing -> thing
+hsImplicitBody (HsIB { hsib_body = body }) = body
+
+hsSigType :: LHsSigType name -> LHsType name
+hsSigType = hsImplicitBody
+
+hsSigWcType :: LHsSigWcType name -> LHsType name
+hsSigWcType sig_ty = hswc_body (hsib_body sig_ty)
+
+dropWildCards :: LHsSigWcType name -> LHsSigType name
+-- Drop the wildcard part of a LHsSigWcType
+dropWildCards sig_ty = sig_ty { hsib_body = hsSigWcType sig_ty }
+
+{- Note [Representing type signatures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+HsSigType is used to represent an explicit user type signature
+such as   f :: a -> a
+     or   g (x :: a -> a) = x
+
+A HsSigType is just a HsImplicitBndrs wrapping a LHsType.
+ * The HsImplicitBndrs binds the /implicitly/ quantified tyvars
+ * The LHsType binds the /explictly/ quantified tyvars
+
+E.g. For a signature like
+   f :: forall (a::k). blah
+we get
+   HsIB { hsib_kvs = [k]
+        , hsib_tvs = []
+        , hsib_body = HsForAllTy { hst_bndrs = [(a::*)]
+                                 , hst_body = blah }
+The implicit kind variable 'k' is bound by the HsIB;
+the explictly forall'd tyvar 'a' is bounnd by the HsForAllTy
+-}
+
+mkHsImplicitBndrs :: thing -> HsImplicitBndrs RdrName thing
+mkHsImplicitBndrs x = HsIB { hsib_body = x
+                           , hsib_kvs = PlaceHolder
+                           , hsib_tvs = PlaceHolder }
+
+mkHsWildCardBndrs :: thing -> HsWildCardBndrs RdrName thing
+mkHsWildCardBndrs x = HsWC { hswc_body = x
+                           , hswc_wcs  = PlaceHolder
+                           , hswc_ctx  = Nothing }
+
+-- Add empty binders.  This is a bit suspicious; what if
+-- the wrapped thing had free type variables?
+mkEmptyImplicitBndrs :: thing -> HsImplicitBndrs Name thing
+mkEmptyImplicitBndrs x = HsIB { hsib_body = x
+                              , hsib_kvs = []
+                              , hsib_tvs = [] }
+
+mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs Name thing
+mkEmptyWildCardBndrs x = HsWC { hswc_body = x
+                              , hswc_wcs  = []
+                              , hswc_ctx  = Nothing }
 
 
 --------------------------------------------------
@@ -254,27 +375,22 @@ isHsKindedTyVar (UserTyVar {})   = False
 isHsKindedTyVar (KindedTyVar {}) = True
 
 -- | Do all type variables in this 'LHsTyVarBndr' come with kind annotations?
-hsTvbAllKinded :: LHsTyVarBndrs name -> Bool
+hsTvbAllKinded :: LHsQTyVars name -> Bool
 hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvBndrs
 
 data HsType name
-  = HsForAllTy  HsExplicitFlag          -- Renamer leaves this flag unchanged, to record the way
-                                        -- the user wrote it originally, so that the printer can
-                                        -- print it as the user wrote it
-                (Maybe SrcSpan)         -- Indicates whether extra constraints may be inferred.
-                                        -- When Nothing, no, otherwise the location of the extra-
-                                        -- constraints wildcard is stored. For instance, for the
-                                        -- signature (Eq a, _) => a -> a -> Bool, this field would
-                                        -- be something like (Just 1:8), with 1:8 being line 1,
-                                        -- column 8.
-                (LHsTyVarBndrs name)
-                (LHsContext name)
-                (LHsType name)
+  = HsForAllTy   -- See Note [HsType binders]
+      { hst_bndrs :: [LHsTyVarBndr name]   -- Explicit, user-supplied 'forall a b c'
+      , hst_body  :: LHsType name          -- body type
+      }
       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForall',
       --         'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow'
-
       -- For details on above see note [Api annotations] in ApiAnnotation
 
+  | HsQualTy   -- See Note [HsType binders]
+      { hst_ctxt :: LHsContext name       -- Context C => blah
+      , hst_body :: LHsType name }
+
   | HsTyVar    (Located name)
                   -- Type variable, type constructor, or data constructor
                   -- see Note [Promotions (HsTyVar)]
@@ -439,7 +555,8 @@ mkHsOpTy ty1 op ty2 = HsOpTy ty1 (WpKiApps [], op) ty2
 
 data HsWildCardInfo name
     = AnonWildCard (PostRn name (Located Name))
-      -- A anonymous wild card ('_'). A name is generated during renaming.
+      -- A anonymous wild card ('_'). A fresh Name is generated for
+      -- each individual anonymous wildcard during renaming
     | NamedWildCard (Located name)
       -- A named wild card ('_a').
     deriving (Typeable)
@@ -548,13 +665,6 @@ data HsTupleSort = HsUnboxedTuple
                  | HsBoxedOrConstraintTuple
                  deriving (Data, Typeable)
 
-data HsExplicitFlag
-  = Explicit     -- An explicit forall, eg  f :: forall a. a-> a
-  | Implicit     -- No explicit forall, eg  f :: a -> a, or f :: Eq a => a -> a
-  | Qualified    -- A *nested* occurrences of (ctxt => ty), with no explicit forall
-                 -- e.g.  f :: (Eq a => a -> a) -> Int
- deriving (Data, Typeable)
-
 type LConDeclField name = Located (ConDeclField name)
       -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when
       --   in a list
@@ -655,86 +765,38 @@ gives
 -- A valid type must have a for-all at the top of the type, or of the fn arg
 -- types
 
-mkImplicitHsForAllTy  ::                                                 LHsType RdrName -> HsType RdrName
-mkExplicitHsForAllTy  :: [LHsTyVarBndr RdrName] -> LHsContext RdrName -> LHsType RdrName -> HsType RdrName
-mkQualifiedHsForAllTy ::                           LHsContext RdrName -> LHsType RdrName -> HsType RdrName
-
--- | mkImplicitHsForAllTy is called when we encounter
---    f :: type
--- Wrap around a HsForallTy if one is not there already.
-mkImplicitHsForAllTy (L _ (HsForAllTy exp extra tvs cxt ty))
-  = HsForAllTy exp' extra tvs cxt ty
-  where
-    exp' = case exp of
-             Qualified -> Implicit
-                          -- Qualified is used only for a nested forall,
-                          -- this is now top level
-             _         -> exp
-mkImplicitHsForAllTy ty = mkHsForAllTy Implicit  [] (noLoc []) ty
-
-mkExplicitHsForAllTy  tvs ctxt ty = mkHsForAllTy Explicit  tvs ctxt ty
-mkQualifiedHsForAllTy     ctxt ty = mkHsForAllTy Qualified []  ctxt ty
-
--- |Smart constructor for HsForAllTy, which populates the extra-constraints
--- field if a wildcard is present in the context.
-mkHsForAllTy :: HsExplicitFlag -> [LHsTyVarBndr RdrName] -> LHsContext RdrName -> LHsType RdrName -> HsType RdrName
-mkHsForAllTy exp tvs ctxt ty
-  = HsForAllTy exp Nothing (mkHsQTvs tvs) ctxt ty
-
--- |When a sigtype is parsed, the type found is wrapped in an Implicit
--- HsForAllTy via mkImplicitHsForAllTy, to ensure that a signature always has a
--- forall at the outer level. For Api Annotations this nested structure is
--- important to ensure that all `forall` and `.` locations are retained.  From
--- the renamer onwards this structure is flattened, to ease the renaming and
--- type checking process.
-flattenTopLevelLHsForAllTy :: LHsType name -> LHsType name
-flattenTopLevelLHsForAllTy (L l ty) = L l (flattenTopLevelHsForAllTy ty)
-
-flattenTopLevelHsForAllTy :: HsType name -> HsType name
-flattenTopLevelHsForAllTy (HsForAllTy exp extra tvs (L l []) ty)
-  = snd $ mk_forall_ty [] l exp extra tvs ty
-flattenTopLevelHsForAllTy ty = ty
-
-flattenHsForAllTyKeepAnns :: HsType name -> ([AddAnn],HsType name)
-flattenHsForAllTyKeepAnns (HsForAllTy exp extra tvs (L l []) ty)
-  = mk_forall_ty [] l exp extra tvs ty
-flattenHsForAllTyKeepAnns ty = ([],ty)
-
--- mk_forall_ty makes a pure for-all type (no context)
-mk_forall_ty :: [AddAnn] -> SrcSpan -> HsExplicitFlag -> Maybe SrcSpan
-             -> LHsTyVarBndrs name
-             -> LHsType name -> ([AddAnn],HsType name)
-mk_forall_ty ann _ exp1 extra1 tvs1 (L _ (HsForAllTy exp2 extra qtvs2 ctxt ty))
-  = (ann,HsForAllTy (exp1 `plus` exp2) (mergeExtra extra1 extra)
-                    (tvs1 `mappend` qtvs2) ctxt ty)
-  where
-        -- Bias the merging of extra's to the top level, so that a single
-        -- wildcard context will prevail
-        mergeExtra (Just s) _ = Just s
-        mergeExtra _        e = e
-mk_forall_ty ann l exp  extra tvs  (L lp (HsParTy ty))
-  = mk_forall_ty (ann ++ mkParensApiAnn lp) l exp extra tvs ty
-mk_forall_ty ann l exp extra tvs  ty
-  = (ann,HsForAllTy exp extra tvs (L l []) ty)
-        -- Even if tvs is empty, we still make a HsForAll!
-        -- In the Implicit case, this signals the place to do implicit quantification
-        -- In the Explicit case, it prevents implicit quantification
-        --      (see the sigtype production in Parser.y)
-        --      so that (forall. ty) isn't implicitly quantified
-
-plus :: HsExplicitFlag -> HsExplicitFlag -> HsExplicitFlag
-Qualified `plus` Qualified = Qualified
-Explicit  `plus` _         = Explicit
-_         `plus` Explicit  = Explicit
-_         `plus` _         = Implicit
-  -- NB: Implicit `plus` Qualified = Implicit
-  --     so that  f :: Eq a => a -> a  ends up Implicit
-
 ---------------------
-hsExplicitTvs :: LHsType Name -> [Name]
--- The explicitly-given forall'd type variables of a HsType
-hsExplicitTvs (L _ (HsForAllTy Explicit _ tvs _ _)) = hsLKiTyVarNames tvs
-hsExplicitTvs _                                     = []
+hsWcScopedTvs :: LHsSigWcType Name -> [Name]
+-- Get the lexically-scoped type variables of a HsSigType
+--  - the explicitly-given forall'd type variables
+--  - the implicitly-bound kind variables
+--  - the named wildcars; see Note [Scoping of named wildcards]
+-- because they scope in the same way
+hsWcScopedTvs sig_ty
+  | HsIB { hsib_kvs = kvs,  hsib_body = sig_ty1 } <- sig_ty
+  , HsWC { hswc_wcs = nwcs, hswc_body = sig_ty2 } <- sig_ty1
+  , (tvs, _) <- splitLHsForAllTy sig_ty2
+  = kvs ++ nwcs ++ map hsLTyVarName tvs
+
+hsScopedTvs :: LHsSigType Name -> [Name]
+-- Same as hsWcScopedTvs, but for a LHsSigType
+hsScopedTvs sig_ty
+  | HsIB { hsib_kvs = kvs,  hsib_body = sig_ty2 } <- sig_ty
+  , (tvs, _) <- splitLHsForAllTy sig_ty2
+  = kvs ++ map hsLTyVarName tvs
+
+{- Note [Scoping of named wildcards]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  f :: _a -> _a
+  f x = let g :: _a -> _a
+            g = ...
+        in ...
+
+Currently, for better or worse, the "_a" variables are all the same. So
+although there is no explicit forall, the "_a" scopes over the definition.
+I don't know if this is a good idea, but there it is.
+-}
 
 ---------------------
 hsTyVarName :: HsTyVarBndr name -> name
@@ -744,11 +806,11 @@ hsTyVarName (KindedTyVar (L _ n) _) = n
 hsLTyVarName :: LHsTyVarBndr name -> name
 hsLTyVarName = hsTyVarName . unLoc
 
-hsLTyVarNames :: LHsTyVarBndrs name -> [name]
+hsLTyVarNames :: LHsQTyVars name -> [name]
 -- Type variables only
 hsLTyVarNames qtvs = map hsLTyVarName (hsQTvBndrs qtvs)
 
-hsLKiTyVarNames :: LHsTyVarBndrs Name -> [Name]
+hsLKiTyVarNames :: LHsQTyVars Name -> [Name]
 -- Kind and type variables
 hsLKiTyVarNames (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs })
   = kvs ++ map hsLTyVarName tvs
@@ -756,9 +818,6 @@ hsLKiTyVarNames (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs })
 hsLTyVarLocName :: LHsTyVarBndr name -> Located name
 hsLTyVarLocName = fmap hsTyVarName
 
-hsLTyVarLocNames :: LHsTyVarBndrs name -> [Located name]
-hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvBndrs qtvs)
-
 -- | Convert a LHsTyVarBndr to an equivalent LHsType. Used in Template Haskell
 -- quoting for type family equations.
 hsLTyVarBndrToType :: LHsTyVarBndr name -> LHsType name
@@ -770,7 +829,7 @@ hsLTyVarBndrToType = fmap cvt
 -- | Convert a LHsTyVarBndrs to a list of types. Used in Template Haskell
 -- quoting for type family equations. Works on *type* variable only, no kind
 -- vars.
-hsLTyVarBndrsToTypes :: LHsTyVarBndrs name -> [LHsType name]
+hsLTyVarBndrsToTypes :: LHsQTyVars name -> [LHsType name]
 hsLTyVarBndrsToTypes (HsQTvs { hsq_tvs = tvbs }) = map hsLTyVarBndrToType tvbs
 
 ---------------------
@@ -836,33 +895,62 @@ mkHsAppTys fun_ty (arg_ty:arg_tys)
        -- Add noLocs for inner nodes of the application;
        -- they are never used
 
-splitLHsInstDeclTy_maybe
-    :: LHsType name
-    -> Maybe (LHsTyVarBndrs name, HsContext name, Located name, [LHsType name])
+splitLHsPatSynTy :: LHsType name
+                 -> ( [LHsTyVarBndr name]
+                    , LHsContext name        -- Required
+                    , LHsContext name        -- Provided
+                    , LHsType name)          -- Body
+splitLHsPatSynTy ty
+  | L _ (HsQualTy { hst_ctxt = req, hst_body = ty2 }) <- ty1
+  , L _ (HsQualTy { hst_ctxt = prov,  hst_body = ty3 }) <- ty2
+  = (tvs, req, prov, ty3)
+
+  | L _ (HsQualTy { hst_ctxt = req, hst_body = ty2 }) <- ty1
+  = (tvs, req, noLoc [], ty2)
+
+  | otherwise
+  = (tvs, noLoc [], noLoc [], ty1)
+  where
+    (tvs, ty1) = splitLHsForAllTy ty
+
+splitLHsSigmaTy :: LHsType name -> ([LHsTyVarBndr name], LHsContext name, LHsType name)
+splitLHsSigmaTy ty
+  | (tvs, ty1)  <- splitLHsForAllTy ty
+  , (ctxt, ty2) <- splitLHsQualTy ty1
+  = (tvs, ctxt, ty2)
+
+splitLHsForAllTy :: LHsType name -> ([LHsTyVarBndr name], LHsType name)
+splitLHsForAllTy (L _ (HsForAllTy { hst_bndrs = tvs, hst_body = body })) = (tvs, body)
+splitLHsForAllTy body                                                    = ([], body)
+
+splitLHsQualTy :: LHsType name -> (LHsContext name, LHsType name)
+splitLHsQualTy (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body })) = (ctxt,     body)
+splitLHsQualTy body                                                  = (noLoc [], body)
+
+splitLHsInstDeclTy
+    :: LHsSigType Name
+    -> ([Name], LHsContext Name, LHsType Name)
         -- Split up an instance decl type, returning the pieces
-splitLHsInstDeclTy_maybe inst_ty = do
-    let (tvs, cxt, ty) = splitLHsForAllTy inst_ty
-    (cls, tys) <- splitLHsClassTy_maybe ty
-    return (tvs, cxt, cls, tys)
-
-splitLHsForAllTy
-    :: LHsType name
-    -> (LHsTyVarBndrs name, HsContext name, LHsType name)
-splitLHsForAllTy poly_ty
-  = case unLoc poly_ty of
-        HsParTy ty                -> splitLHsForAllTy ty
-        HsForAllTy _ _ tvs cxt ty -> (tvs, unLoc cxt, ty)
-        _                         -> (emptyHsQTvs, [], poly_ty)
-        -- The type vars should have been computed by now, even if they were implicit
-
-splitHsClassTy_maybe :: HsType name -> Maybe (name, [LHsType name])
-splitHsClassTy_maybe ty = fmap (\(L _ n, tys) -> (n, tys)) $ splitLHsClassTy_maybe (noLoc ty)
+splitLHsInstDeclTy (HsIB { hsib_kvs = ikvs, hsib_tvs = itvs
+                         , hsib_body = inst_ty })
+  = (ikvs ++ itvs, cxt, body_ty)
+         -- Return implicitly bound type and kind vars
+         -- For an instance decl, all of them are in scope
+  where
+    (cxt, body_ty) = splitLHsQualTy inst_ty
 
-splitLHsClassTy_maybe :: LHsType name -> Maybe (Located name, [LHsType name])
---- Watch out.. in ...deriving( Show )... we use this on
---- the list of partially applied predicates in the deriving,
---- so there can be zero args.
+getLHsInstDeclClass_maybe :: LHsSigType name -> Maybe (Located name)
+-- Works on (HsSigType RdrName)
+getLHsInstDeclClass_maybe inst_ty
+  = do { let (_, tau) = splitLHsQualTy (hsSigType inst_ty)
+       ; (cls, _) <- splitLHsClassTy_maybe tau
+       ; return cls }
 
+splitLHsClassTy_maybe :: LHsType name -> Maybe (Located name, [LHsType name])
+-- Watch out.. in ...deriving( Show )... we use this on
+-- the list of partially applied predicates in the deriving,
+-- so there can be zero args.
+--
 -- In TcDeriv we also use this to figure out what data type is being
 -- mentioned in a deriving (Generic (Foo bar baz)) declaration (i.e. "Foo").
 splitLHsClassTy_maybe ty
@@ -921,23 +1009,26 @@ instance (OutputableBndr name) => Outputable (HsType name) where
 instance Outputable HsTyLit where
     ppr = ppr_tylit
 
-instance (OutputableBndr name) => Outputable (LHsTyVarBndrs name) where
-    ppr (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs })
-      = sep [ ifPprDebug $ braces (interppSP kvs), interppSP tvs ]
+instance (OutputableBndr name)
+      => Outputable (LHsQTyVars name) where
+    ppr (HsQTvs { hsq_tvs = tvs }) = interppSP tvs
 
 instance (OutputableBndr name) => Outputable (HsTyVarBndr name) where
     ppr (UserTyVar n)     = ppr n
     ppr (KindedTyVar n k) = parens $ hsep [ppr n, dcolon, ppr k]
 
-instance (Outputable thing) => Outputable (HsWithBndrs name thing) where
-    ppr (HsWB { hswb_cts = ty }) = ppr ty
+instance (Outputable thing) => Outputable (HsImplicitBndrs name thing) where
+    ppr (HsIB { hsib_body = ty }) = ppr ty
+
+instance (Outputable thing) => Outputable (HsWildCardBndrs name thing) where
+    ppr (HsWC { hswc_body = ty }) = ppr ty
 
 instance (Outputable name) => Outputable (HsWildCardInfo name) where
     ppr (AnonWildCard _)  = char '_'
     ppr (NamedWildCard n) = ppr n
 
-pprHsForAll :: OutputableBndr name => HsExplicitFlag -> LHsTyVarBndrs name -> LHsContext name -> SDoc
-pprHsForAll exp = pprHsForAllExtra exp Nothing
+pprHsForAll :: OutputableBndr name => [LHsTyVarBndr name] -> LHsContext name -> SDoc
+pprHsForAll = pprHsForAllExtra Nothing
 
 -- | Version of 'pprHsForAll' that can also print an extra-constraints
 -- wildcard, e.g. @_ => a -> Bool@ or @(Show a, _) => a -> String@. This
@@ -946,16 +1037,18 @@ pprHsForAll exp = pprHsForAllExtra exp Nothing
 -- function for this is needed, as the extra-constraints wildcard is removed
 -- from the actual context and type, and stored in a separate field, thus just
 -- printing the type will not print the extra-constraints wildcard.
-pprHsForAllExtra :: OutputableBndr name => HsExplicitFlag -> Maybe SrcSpan -> LHsTyVarBndrs name -> LHsContext name -> SDoc
-pprHsForAllExtra exp extra qtvs cxt
-  | show_forall = forall_part <+> pprHsContextExtra show_extra (unLoc cxt)
-  | otherwise   = pprHsContextExtra show_extra (unLoc cxt)
+pprHsForAllExtra :: OutputableBndr name => Maybe SrcSpan -> [LHsTyVarBndr name] -> LHsContext name -> SDoc
+pprHsForAllExtra extra qtvs cxt
+  = pprHsForAllTvs qtvs <+> pprHsContextExtra show_extra (unLoc cxt)
   where
-    show_extra  = isJust extra
-    show_forall =  opt_PprStyle_Debug
-                || (not (null (hsQTvBndrs qtvs)) && is_explicit)
-    is_explicit = case exp of {Explicit -> True; Implicit -> False; Qualified -> False}
-    forall_part = forAllLit <+> ppr qtvs <> dot
+    show_extra = isJust extra
+
+pprHsForAllTvs :: OutputableBndr name => [LHsTyVarBndr name] -> SDoc
+pprHsForAllTvs qtvs
+  | show_forall = forAllLit <+> interppSP qtvs <> dot
+  | otherwise   = empty
+  where
+    show_forall = opt_PprStyle_Debug || not (null qtvs)
 
 pprHsContext :: (OutputableBndr name) => HsContext name -> SDoc
 pprHsContext = maybe empty (<+> darrow) . pprHsContextMaybe
@@ -970,12 +1063,15 @@ pprHsContextMaybe cxt        = Just $ parens (interpp'SP cxt)
 
 -- True <=> print an extra-constraints wildcard, e.g. @(Show a, _) =>@
 pprHsContextExtra :: (OutputableBndr name) => Bool -> HsContext name -> SDoc
-pprHsContextExtra False = pprHsContext
-pprHsContextExtra True
-  = \ctxt -> case ctxt of
-               [] -> char '_' <+> darrow
-               _  -> parens (sep (punctuate comma ctxt')) <+> darrow
-                 where ctxt' = map ppr ctxt ++ [char '_']
+pprHsContextExtra show_extra ctxt
+  | not show_extra
+  = pprHsContext ctxt
+  | null ctxt
+  = char '_' <+> darrow
+  | otherwise
+  = parens (sep (punctuate comma ctxt')) <+> darrow
+  where
+    ctxt' = map ppr ctxt ++ [char '_']
 
 pprConDeclFields :: OutputableBndr name => [LConDeclField name] -> SDoc
 pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))
@@ -1018,9 +1114,13 @@ ppr_mono_lty :: (OutputableBndr name) => TyPrec -> LHsType name -> SDoc
 ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)
 
 ppr_mono_ty :: (OutputableBndr name) => TyPrec -> HsType name -> SDoc
-ppr_mono_ty ctxt_prec (HsForAllTy exp extra tvs ctxt ty)
+ppr_mono_ty ctxt_prec (HsForAllTy { hst_bndrs = tvs, hst_body = ty })
+  = maybeParen ctxt_prec FunPrec $
+    sep [pprHsForAllTvs tvs, ppr_mono_lty TopPrec ty]
+
+ppr_mono_ty ctxt_prec (HsQualTy { hst_ctxt = L _ ctxt, hst_body = ty })
   = maybeParen ctxt_prec FunPrec $
-    sep [pprHsForAllExtra exp extra tvs ctxt, ppr_mono_lty TopPrec ty]
+    sep [pprHsContext ctxt, ppr_mono_lty TopPrec ty]
 
 ppr_mono_ty _    (HsBangTy b ty)     = ppr b <> ppr_mono_lty TyConPrec ty
 ppr_mono_ty _    (HsRecTy flds)      = pprConDeclFields flds
index 62aabe3..19996fd 100644 (file)
@@ -23,14 +23,14 @@ module HsUtils(
   mkSimpleMatch, unguardedGRHSs, unguardedRHS,
   mkMatchGroup, mkMatchGroupName, mkMatch, mkHsLam, mkHsIf,
   mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,
-  coToHsWrapper, coToHsWrapperR, mkHsDictLet, mkHsLams,
+  mkHsDictLet, mkHsLams,
   mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
   mkLHsPar, mkHsCmdCast,
 
   nlHsTyApp, nlHsTyApps, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps,
   nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
   mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
-  toHsType, toHsKind,
+  toLHsSigWcType,
 
   -- * Constructing general big tuples
   -- $big_tuples
@@ -52,6 +52,7 @@ module HsUtils(
 
   -- Types
   mkHsAppTy, userHsTyVarBndrs,
+  mkLHsSigType, mkLHsSigWcType, mkClassOpSigs,
   nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp,
 
   -- Stmts
@@ -91,12 +92,13 @@ import HsTypes
 import HsLit
 import PlaceHolder
 
+import TcType( tcSplitForAllTys, tcSplitPhiTy )
 import TcEvidence
 import RdrName
 import Var
+import Type( isPredTy )
+import Kind( isKind )
 import TypeRep
-import TcType
-import Kind
 import DataCon
 import Name
 import NameSet
@@ -516,48 +518,67 @@ chunkify xs
 {-
 ************************************************************************
 *                                                                      *
-        Converting a Type to an HsType RdrName
+        LHsSigType and LHsSigWcType
 *                                                                      *
-************************************************************************
+********************************************************************* -}
 
-This is needed to implement GeneralizedNewtypeDeriving.
--}
+mkLHsSigType :: LHsType RdrName -> LHsSigType RdrName
+mkLHsSigType ty = mkHsImplicitBndrs ty
 
-toHsType :: Type -> LHsType RdrName
-toHsType ty
-  | [] <- tvs_only
-  , [] <- theta
-  = to_hs_type tau
-  | otherwise
-  = noLoc $
-    mkExplicitHsForAllTy (map mk_hs_tvb tvs_only)
-                         (noLoc $ map toHsType theta)
-                         (to_hs_type tau)
+mkLHsSigWcType :: LHsType RdrName -> LHsSigWcType RdrName
+mkLHsSigWcType ty = mkHsImplicitBndrs (mkHsWildCardBndrs ty)
 
+mkClassOpSigs :: [LSig RdrName] -> [LSig RdrName]
+-- Convert TypeSig to ClassOpSig
+-- The former is what is parsed, but the latter is
+-- what we need in class/instance declarations
+mkClassOpSigs sigs
+  = map fiddle sigs
   where
-    (tvs, theta, tau) = tcSplitSigmaTy ty
-    tvs_only = filter isTypeVar tvs
+    fiddle (L loc (TypeSig nms ty)) = L loc (ClassOpSig False nms (dropWildCards ty))
+    fiddle sig                      = sig
 
-    to_hs_type (TyVarTy tv) = nlHsTyVar (getRdrName tv)
-    to_hs_type (AppTy t1 t2) = nlHsAppTy (toHsType t1) (toHsType t2)
-    to_hs_type (TyConApp tc args) = nlHsTyConApp (getRdrName tc) (map toHsType args')
+toLHsSigWcType :: Type -> LHsSigWcType RdrName
+-- ^ Converting a Type to an HsType RdrName
+-- This is needed to implement GeneralizedNewtypeDeriving.
+--
+-- Note that we use 'getRdrName' extensively, which
+-- generates Exact RdrNames rather than strings.
+toLHsSigWcType ty
+  = mkLHsSigWcType (go ty)
+  where
+    go :: Type -> LHsType RdrName
+    go ty@(ForAllTy {})
+      | (tvs, tau) <- tcSplitForAllTys ty
+      = noLoc (HsForAllTy { hst_bndrs = map go_tv tvs
+                          , hst_body = go tau })
+    go ty@(FunTy arg _)
+      | isPredTy arg
+      , (theta, tau) <- tcSplitPhiTy ty
+      = noLoc (HsQualTy { hst_ctxt = noLoc (map go theta)
+                        , hst_body = go tau })
+    go (FunTy arg res)      = nlHsFunTy (go arg) (go res)
+    go (TyVarTy tv)         = nlHsTyVar (getRdrName tv)
+    go (AppTy t1 t2)        = nlHsAppTy (go t1) (go t2)
+    go (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy "" n)
+    go (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy "" s)
+    go (TyConApp tc args)   = nlHsTyConApp (getRdrName tc) (map go args')
        where
          args' = filterOut isKind args
          -- Source-language types have _implicit_ kind arguments,
          -- so we must remove them here (Trac #8563)
-    to_hs_type (FunTy arg res) = ASSERT( not (isConstraintKind (typeKind arg)) )
-                                 nlHsFunTy (toHsType arg) (toHsType res)
-    to_hs_type t@(ForAllTy {}) = pprPanic "toHsType" (ppr t)
-    to_hs_type (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy "" n)
-    to_hs_type (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy "" s)
 
-    mk_hs_tvb tv = noLoc $ KindedTyVar (noLoc (getRdrName tv))
-                                       (toHsKind (tyVarKind tv))
+    go_tv :: TyVar -> LHsTyVarBndr RdrName
+    go_tv tv = noLoc $ KindedTyVar (noLoc (getRdrName tv))
+                                   (go (tyVarKind tv))
 
-toHsKind :: Kind -> LHsKind RdrName
-toHsKind = toHsType
 
---------- HsWrappers: type args, dict args, casts ---------
+{- *********************************************************************
+*                                                                      *
+    --------- HsWrappers: type args, dict args, casts ---------
+*                                                                      *
+********************************************************************* -}
+
 mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id
 mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
 
@@ -567,35 +588,26 @@ mkHsWrap co_fn e | isIdHsWrapper co_fn = e
 
 mkHsWrapCo :: TcCoercionN   -- A Nominal coercion  a ~N b
            -> HsExpr id -> HsExpr id
-mkHsWrapCo co e = mkHsWrap (coToHsWrapper co) e
+mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e
 
 mkHsWrapCoR :: TcCoercionR   -- A Representational coercion  a ~R b
             -> HsExpr id -> HsExpr id
-mkHsWrapCoR co e = mkHsWrap (coToHsWrapperR co) e
+mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e
 
-mkLHsWrapCo :: TcCoercion -> LHsExpr id -> LHsExpr id
+mkLHsWrapCo :: TcCoercionN -> LHsExpr id -> LHsExpr id
 mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e)
 
 mkHsCmdCast :: TcCoercion -> HsCmd id -> HsCmd id
 mkHsCmdCast co cmd | isTcReflCo co = cmd
                    | otherwise     = HsCmdCast co cmd
 
-coToHsWrapper :: TcCoercion -> HsWrapper   -- A Nominal coercion
-coToHsWrapper co | isTcReflCo co = idHsWrapper
-                 | otherwise     = mkWpCast (mkTcSubCo co)
-
-coToHsWrapperR :: TcCoercion -> HsWrapper   -- A Representational coercion
-coToHsWrapperR co | isTcReflCo co = idHsWrapper
-                  | otherwise     = mkWpCast co
-
 mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
 mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
                        | otherwise           = CoPat co_fn p ty
 
--- input coercion is Nominal
-mkHsWrapPatCo :: TcCoercion -> Pat id -> Type -> Pat id
+mkHsWrapPatCo :: TcCoercionN -> Pat id -> Type -> Pat id
 mkHsWrapPatCo co pat ty | isTcReflCo co = pat
-                        | otherwise     = CoPat (mkWpCast (mkTcSubCo co)) pat ty
+                        | otherwise     = CoPat (mkWpCastN co) pat ty
 
 mkHsDictLet :: TcEvBinds -> LHsExpr Id -> LHsExpr Id
 mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr
@@ -869,8 +881,8 @@ hsLTyClDeclBinders (L loc (SynDecl     { tcdLName = L _ name })) = ([L loc 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 (TypeSig ns _ _) <- sigs, L _ mem_name <- ns ]
+     [ 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 ]
     , [])
 hsLTyClDeclBinders (L loc (DataDecl    { tcdLName = L _ name, tcdDataDefn = defn }))
   = (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn
@@ -880,7 +892,7 @@ hsForeignDeclsBinders :: [LForeignDecl name] -> [Located name]
 -- See Note [SrcSpan for binders]
 hsForeignDeclsBinders foreign_decls
   = [ L decl_loc n
-    | L decl_loc (ForeignImport (L _ n) _ _ _) <- foreign_decls]
+    | L decl_loc (ForeignImport { fd_name = L _ n }) <- foreign_decls]
 
 
 
index 463078c..307a448 100644 (file)
@@ -869,9 +869,12 @@ pprIfaceConDecl ss gadt_style mk_user_con_res_ty fls
         (IfCon { ifConOcc = name, ifConInfix = is_infix,
                  ifConExTvs = ex_tvs,
                  ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys,
-                 ifConStricts = stricts, ifConFields = labels })
-  | gadt_style = pp_prefix_con <+> dcolon <+> ppr_ty
-  | otherwise  = ppr_fields tys_w_strs
+                 ifConStricts = stricts, ifConFields = fields })
+  | gadt_style            = pp_prefix_con <+> dcolon <+> ppr_ty
+  | not (null fields)     = pp_prefix_con <+> pp_field_args
+  | is_infix
+  , [ty1, ty2] <- pp_args = sep [ty1, pprInfixIfDeclBndr ss name, ty2]
+  | otherwise             = pp_prefix_con <+> sep pp_args
   where
     tys_w_strs :: [(IfaceBang, IfaceType)]
     tys_w_strs = zip stricts arg_tys
@@ -882,9 +885,12 @@ pprIfaceConDecl ss gadt_style mk_user_con_res_ty fls
 
         -- A bit gruesome this, but we can't form the full con_tau, and ppr it,
         -- because we don't have a Name for the tycon, only an OccName
-    pp_tau = case map pprParendIfaceType arg_tys ++ [pp_res_ty] of
+    pp_tau | null fields
+           = case pp_args ++ [pp_res_ty] of
                 (t:ts) -> fsep (t : map (arrow <+>) ts)
                 []     -> panic "pp_con_taus"
+           | otherwise
+           = sep [pp_field_args, arrow <+> pp_res_ty]
 
     ppr_bang IfNoBang = ppWhen opt_PprStyle_Debug $ char '_'
     ppr_bang IfStrict = char '!'
@@ -895,6 +901,13 @@ pprIfaceConDecl ss gadt_style mk_user_con_res_ty fls
     pprParendBangTy (bang, ty) = ppr_bang bang <> pprParendIfaceType ty
     pprBangTy       (bang, ty) = ppr_bang bang <> ppr ty
 
+    pp_args :: [SDoc]  -- With parens, e.g  (Maybe a)  or  !(Maybe a)
+    pp_args = map pprParendBangTy tys_w_strs
+
+    pp_field_args :: SDoc  -- Braces form:  { x :: !Maybe a, y :: Int }
+    pp_field_args = braces $ sep $ punctuate comma $ ppr_trim $
+                    map maybe_show_label (zip fields tys_w_strs)
+
     maybe_show_label (sel,bty)
       | showSub ss sel = Just (pprPrefixIfDeclBndr ss lbl <+> dcolon <+> pprBangTy bty)
       | otherwise      = Nothing
@@ -904,14 +917,6 @@ pprIfaceConDecl ss gadt_style mk_user_con_res_ty fls
         -- DuplicateRecordFields was used for the definition)
         lbl = maybe sel (mkVarOccFS . flLabel) $ find (\ fl -> flSelector fl == sel) fls
 
-    ppr_fields [ty1, ty2]
-      | is_infix && null labels
-      = sep [pprParendBangTy ty1, pprInfixIfDeclBndr ss name, pprParendBangTy ty2]
-    ppr_fields fields
-      | null labels = pp_prefix_con <+> sep (map pprParendBangTy fields)
-      | otherwise   = pp_prefix_con <+> (braces $ sep $ punctuate comma $ ppr_trim $
-                                    map maybe_show_label (zip labels fields))
-
 instance Outputable IfaceRule where
   ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
                    ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs })
index d32f619..b7f3dd7 100644 (file)
@@ -45,7 +45,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
              ("InstType         ", inst_type_ds),
              ("InstData         ", inst_data_ds),
              ("TypeSigs         ", bind_tys),
-             ("GenericSigs      ", generic_sigs),
+             ("ClassOpSigs      ", generic_sigs),
              ("ValBinds         ", val_bind_ds),
              ("FunBinds         ", fn_bind_ds),
              ("PatSynBinds      ", patsyn_ds),
@@ -105,12 +105,12 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
 
     count_sigs sigs = sum5 (map sig_info sigs)
 
-    sig_info (FixSig _)       = (1,0,0,0,0)
-    sig_info (TypeSig _ _ _)  = (0,1,0,0,0)
-    sig_info (SpecSig _ _ _)  = (0,0,1,0,0)
-    sig_info (InlineSig _ _)  = (0,0,0,1,0)
-    sig_info (GenericSig _ _) = (0,0,0,0,1)
-    sig_info _                = (0,0,0,0,0)
+    sig_info (FixSig {})     = (1,0,0,0,0)
+    sig_info (TypeSig {})    = (0,1,0,0,0)
+    sig_info (SpecSig {})    = (0,0,1,0,0)
+    sig_info (InlineSig {})  = (0,0,0,1,0)
+    sig_info (ClassOpSig {}) = (0,0,0,0,1)
+    sig_info _               = (0,0,0,0,0)
 
     import_info (L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual
                                  , ideclAs = as, ideclHiding = spec }))
@@ -126,7 +126,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
 
     data_info (DataDecl { tcdDataDefn = HsDataDefn { dd_cons = cs
                                                    , dd_derivs = derivs}})
-        = (length cs, case derivs of Nothing       -> 0
+        = (length cs, case derivs of Nothing -> 0
                                      Just (L _ ds) -> length ds)
     data_info _ = (0,0)
 
index 290f27b..b5abdf4 100644 (file)
@@ -1709,10 +1709,12 @@ implicitClassThings :: Class -> [TyThing]
 implicitClassThings cl
   = -- Does not include default methods, because those Ids may have
     --    their own pragmas, unfoldings etc, not derived from the Class object
+
     -- associated types
     --    No recursive call for the classATs, because they
     --    are only the family decls; they have no implicit things
     map ATyCon (classATs cl) ++
+
     -- superclass and operation selectors
     map AnId (classAllSelIds cl)
 
index 32f4254..db96acb 100644 (file)
@@ -2641,11 +2641,15 @@ clean_pragma prag = canon_ws (map toLower (unprefix prag))
 %************************************************************************
 -}
 
--- |Encapsulated call to addAnnotation, requiring only the SrcSpan of
--- the AST element the annotation belongs to
-type AddAnn = (SrcSpan -> P ())
-
-addAnnotation :: SrcSpan -> AnnKeywordId -> SrcSpan -> P ()
+-- | Encapsulated call to addAnnotation, requiring only the SrcSpan of
+--   the AST construct the annotation belongs to; together with the
+--   AnnKeywordId, this is is the key of the annotation map
+type AddAnn = SrcSpan -> P ()
+
+addAnnotation :: SrcSpan          -- SrcSpan of enclosing AST construct
+              -> AnnKeywordId     -- The first two parameters are the key
+              -> SrcSpan          -- The location of the keyword itself
+              -> P ()
 addAnnotation l a v = do
   addAnnotationOnly l a v
   allocateComments l
index dac78df..fb5c8db 100644 (file)
@@ -900,10 +900,11 @@ inst_decl :: { LInstDecl RdrName }
         : 'instance' overlap_pragma inst_type where_inst
        {% do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc $4)
              ; let cid = ClsInstDecl { cid_poly_ty = $3, cid_binds = binds
-                                     , cid_sigs = sigs, cid_tyfam_insts = ats
+                                     , cid_sigs = mkClassOpSigs sigs
+                                     , cid_tyfam_insts = ats
                                      , cid_overlap_mode = $2
                                      , cid_datafam_insts = adts }
-             ; ams (L (comb3 $1 $3 $4) (ClsInstD { cid_inst = cid }))
+             ; ams (L (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_inst = cid }))
                    (mj AnnInstance $1 : (fst $ unLoc $4)) } }
 
            -- type instance declarations
@@ -1122,11 +1123,10 @@ capi_ctype : '{-# CTYPE' STRING STRING '#-}'
 -- Glasgow extension: stand-alone deriving declarations
 stand_alone_deriving :: { LDerivDecl RdrName }
   : 'deriving' 'instance' overlap_pragma inst_type
-                         {% do {
-                                 let err = text "in the stand-alone deriving instance"
-                                            <> colon <+> quotes (ppr $4)
-                               ; ams (sLL $1 $> (DerivDecl $4 $3))
-                                     [mj AnnDeriving $1,mj AnnInstance $2] }}
+                         {% do { let { err = text "in the stand-alone deriving instance"
+                                             <> colon <+> quotes (ppr $4) }
+                               ; ams (sLL $1 (hsSigType $>) (DerivDecl $4 $3))
+                                     [mj AnnDeriving $1, mj AnnInstance $2] } }
 
 -----------------------------------------------------------------------------
 -- Role annotations
@@ -1160,10 +1160,12 @@ pattern_synonym_decl :: { LHsDecl RdrName }
                                                     ImplicitBidirectional)
                (as ++ [mj AnnPattern $1, mj AnnEqual $3])
          }
+
         | 'pattern' pattern_synonym_lhs '<-' pat
          {%    let (name, args, as) = $2 in
                ams (sLL $1 $> . ValD $ mkPatSynBind name args $4 Unidirectional)
                (as ++ [mj AnnPattern $1,mu AnnLarrow $3]) }
+
         | 'pattern' pattern_synonym_lhs '<-' pat where_decls
             {% do { let (name, args, as) = $2
                   ; mg <- mkPatSynMatchGroup name (snd $ unLoc $5)
@@ -1192,29 +1194,30 @@ where_decls :: { Located ([AddAnn]
                                            :mcc $4:(fst $ unLoc $3)),sL1 $3 (snd $ unLoc $3)) }
         | 'where' vocurly decls close { L (comb2 $1 $3) ((mj AnnWhere $1:(fst $ unLoc $3))
                                           ,sL1 $3 (snd $ unLoc $3)) }
+
 pattern_synonym_sig :: { LSig RdrName }
         : 'pattern' con '::' ptype
-            {% do { let (flag, qtvs, req, prov, ty) = snd $ unLoc $4
-                  ; let sig = PatSynSig $2 (flag, mkHsQTvs qtvs) req prov ty
-                  ; ams (sLL $1 $> $ sig)
-                        (mj AnnPattern $1:mu AnnDcolon $3:(fst $ unLoc $4)) } }
-
-ptype :: { Located ([AddAnn]
-                  ,( HsExplicitFlag, [LHsTyVarBndr RdrName], LHsContext RdrName
-                   , LHsContext RdrName, LHsType RdrName)) }
+                   {% ams (sLL $1 $> $ PatSynSig $2 (mkLHsSigType $4))
+                          [mj AnnPattern $1, mu AnnDcolon $3] }
+
+ptype   :: { LHsType RdrName }
         : 'forall' tv_bndrs '.' ptype
-            {% do { hintExplicitForall (getLoc $1)
-                  ; let (_, qtvs', prov, req, ty) = snd $ unLoc $4
-                  ; return $ sLL $1 $>
-                                ((mu AnnForall $1:mj AnnDot $3:(fst $ unLoc $4))
-                                ,(Explicit, $2 ++ qtvs', prov, req ,ty)) }}
+                   {% hintExplicitForall (getLoc $1) >>
+                      ams (sLL $1 $> $
+                           HsForAllTy { hst_bndrs = $2
+                                      , hst_body = $4 })
+                          [mu AnnForall $1, mj AnnDot $3] }
+
         | context '=>' context '=>' type
-            { sLL $1 $> ([mu AnnDarrow $2,mu AnnDarrow $4]
-                        ,(Implicit, [], $1, $3, $5)) }
+                   {% ams (sLL $1 $> $
+                           HsQualTy { hst_ctxt = $1, hst_body = sLL $3 $> $
+                           HsQualTy { hst_ctxt = $3, hst_body = $5 } })
+                           [mu AnnDarrow $2, mu AnnDarrow $4] }
         | context '=>' type
-            { sLL $1 $> ([mu AnnDarrow $2],(Implicit, [], $1, noLoc [], $3)) }
-        | type
-            { sL1 $1 ([],(Implicit, [], noLoc [], noLoc [], $1)) }
+                   {% ams (sLL $1 $> $
+                           HsQualTy { hst_ctxt = $1, hst_body = $3 })
+                           [mu AnnDarrow $2] }
+        | type     { $1 }
 
 -----------------------------------------------------------------------------
 -- Nested declarations
@@ -1227,10 +1230,10 @@ decl_cls  : at_decl_cls                 { $1 }
 
           -- A 'default' signature used with the generic-programming extension
           | 'default' infixexp '::' sigtypedoc
-                    {% do { (TypeSig l ty _) <- checkValSig $2 $4
+                    {% do { v <- checkValSigLhs $2
                           ; let err = text "in default signature" <> colon <+>
-                                      quotes (ppr ty)
-                          ; ams (sLL $1 $> $ SigD (GenericSig l ty))
+                                      quotes (ppr $2)
+                          ; ams (sLL $1 $> $ SigD $ ClassOpSig True [v] $ mkLHsSigType $4)
                                 [mj AnnDefault $1,mu AnnDcolon $3] } }
 
 decls_cls :: { Located ([AddAnn],OrdList (LHsDecl RdrName)) }  -- Reversed
@@ -1399,7 +1402,7 @@ rule_var_list :: { [LRuleBndr RdrName] }
 rule_var :: { LRuleBndr RdrName }
         : varid                         { sLL $1 $> (RuleBndr $1) }
         | '(' varid '::' ctype ')'      {% ams (sLL $1 $> (RuleBndrSig $2
-                                                       (mkHsWithBndrs $4)))
+                                                       (mkLHsSigWcType $4)))
                                                [mop $1,mu AnnDcolon $3,mcp $5] }
 
 -----------------------------------------------------------------------------
@@ -1491,12 +1494,12 @@ safety :: { Located Safety }
         | 'interruptible'               { sLL $1 $> PlayInterruptible }
 
 fspec :: { Located ([AddAnn]
-                    ,(Located StringLiteral, Located RdrName, LHsType RdrName)) }
+                    ,(Located StringLiteral, Located RdrName, LHsSigType RdrName)) }
        : STRING var '::' sigtypedoc     { sLL $1 $> ([mu AnnDcolon $3]
                                              ,(L (getLoc $1)
-                                                    (getStringLiteral $1), $2, $4)) }
+                                                    (getStringLiteral $1), $2, mkLHsSigType $4)) }
        |        var '::' sigtypedoc     { sLL $1 $> ([mu AnnDcolon $2]
-                                             ,(noLoc (StringLiteral "" nilFS), $1, $3)) }
+                                             ,(noLoc (StringLiteral "" nilFS), $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
@@ -1504,7 +1507,7 @@ fspec :: { Located ([AddAnn]
 -----------------------------------------------------------------------------
 -- Type signatures
 
-opt_sig :: { ([AddAnn],Maybe (LHsType RdrName)) }
+opt_sig :: { ([AddAnn], Maybe (LHsType RdrName)) }
         : {- empty -}                   { ([],Nothing) }
         | '::' sigtype                  { ([mu AnnDcolon $1],Just $2) }
 
@@ -1512,14 +1515,12 @@ opt_asig :: { ([AddAnn],Maybe (LHsType RdrName)) }
         : {- empty -}                   { ([],Nothing) }
         | '::' atype                    { ([mu AnnDcolon $1],Just $2) }
 
-sigtype :: { LHsType RdrName }          -- Always a HsForAllTy,
-                                        -- to tell the renamer where to generalise
-        : ctype                         { sL1 $1 (mkImplicitHsForAllTy $1) }
-        -- Wrap an Implicit forall if there isn't one there already
+sigtype :: { LHsType RdrName }
+        : ctype                            { $1 }
+
+sigtypedoc :: { LHsType RdrName }
+        : ctypedoc                         { $1 }
 
-sigtypedoc :: { LHsType RdrName }       -- Always a HsForAllTy
-        : ctypedoc                      { sL1 $1 (mkImplicitHsForAllTy $1) }
-        -- Wrap an Implicit forall if there isn't one there already
 
 sig_vars :: { Located [Located RdrName] }    -- Returned in reversed order
          : sig_vars ',' var           {% addAnnotation (gl $ head $ unLoc $1)
@@ -1527,10 +1528,10 @@ sig_vars :: { Located [Located RdrName] }    -- Returned in reversed order
                                          >> return (sLL $1 $> ($3 : unLoc $1)) }
          | var                        { sL1 $1 [$1] }
 
-sigtypes1 :: { (OrdList (LHsType RdrName)) }      -- Always HsForAllTys
-        : sigtype                      { unitOL $1 }
-        | sigtype ',' sigtypes1        {% addAnnotation (gl $1) AnnComma (gl $2)
-                                          >> return ((unitOL $1) `appOL` $3) }
+sigtypes1 :: { (OrdList (LHsSigType RdrName)) }
+   : sigtype                 { unitOL (mkLHsSigType $1) }
+   | sigtype ',' sigtypes1   {% addAnnotation (gl $1) AnnComma (gl $2)
+                                >> return (unitOL (mkLHsSigType $1) `appOL` $3) }
 
 -----------------------------------------------------------------------------
 -- Types
@@ -1555,12 +1556,14 @@ unpackedness :: { Located ([AddAnn], Maybe SourceText, SrcUnpackedness) }
 -- A ctype is a for-all type
 ctype   :: { LHsType RdrName }
         : 'forall' tv_bndrs '.' ctype   {% hintExplicitForall (getLoc $1) >>
-                                           ams (sLL $1 $> $ mkExplicitHsForAllTy $2
-                                                                 (noLoc []) $4)
-                                               [mu AnnForall $1,mj AnnDot $3] }
+                                           ams (sLL $1 $> $
+                                                HsForAllTy { hst_bndrs = $2
+                                                           , hst_body = $4 })
+                                               [mu AnnForall $1, mj AnnDot $3] }
         | context '=>' ctype          {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)
                                          >> return (sLL $1 $> $
-                                               mkQualifiedHsForAllTy $1 $3) }
+                                            HsQualTy { hst_ctxt = $1
+                                                     , hst_body = $3 }) }
         | ipvar '::' type             {% ams (sLL $1 $> (HsIParamTy (unLoc $1) $3))
                                              [mj AnnVal $1,mu AnnDcolon $2] }
         | type                        { $1 }
@@ -1578,12 +1581,14 @@ ctype   :: { LHsType RdrName }
 
 ctypedoc :: { LHsType RdrName }
         : 'forall' tv_bndrs '.' ctypedoc {% hintExplicitForall (getLoc $1) >>
-                                            ams (sLL $1 $> $ mkExplicitHsForAllTy $2
-                                                                  (noLoc []) $4)
+                                            ams (sLL $1 $> $
+                                                 HsForAllTy { hst_bndrs = $2
+                                                            , hst_body = $4 })
                                                 [mu AnnForall $1,mj AnnDot $3] }
         | context '=>' ctypedoc       {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)
                                          >> return (sLL $1 $> $
-                                                  mkQualifiedHsForAllTy $1 $3) }
+                                            HsQualTy { hst_ctxt = $1
+                                                     , hst_body = $3 }) }
         | ipvar '::' type             {% ams (sLL $1 $> (HsIParamTy (unLoc $1) $3))
                                              [mj AnnVal $1,mu AnnDcolon $2] }
         | typedoc                     { $1 }
@@ -1723,16 +1728,15 @@ atype :: { LHsType RdrName }
 
 -- An inst_type is what occurs in the head of an instance decl
 --      e.g.  (Foo a, Gaz b) => Wibble a b
--- It's kept as a single type, with a MonoDictTy at the right
--- hand corner, for convenience.
-inst_type :: { LHsType RdrName }
-        : sigtype                       { $1 }
+-- It's kept as a single type for convenience.
+inst_type :: { LHsSigType RdrName }
+        : sigtype                       { mkLHsSigType $1 }
 
-inst_types1 :: { [LHsType RdrName] }
-        : inst_type                     { [$1] }
+deriv_types :: { [LHsSigType RdrName] }
+        : type                          { [mkLHsSigType $1] }
 
-        | inst_type ',' inst_types1    {% addAnnotation (gl $1) AnnComma (gl $2)
-                                          >> return ($1 : $3) }
+        | type ',' deriv_types          {% addAnnotation (gl $1) AnnComma (gl $2)
+                                           >> return (mkLHsSigType $1 : $3) }
 
 comma_types0  :: { [LHsType RdrName] }  -- Zero or more:  ty,ty,ty
         : comma_types1                  { $1 }
@@ -1891,8 +1895,8 @@ gadt_constr_with_doc
 gadt_constr :: { LConDecl RdrName }
     -- see Note [Difference in parsing GADT and data constructors]
     -- Returns a list because of:   C,D :: ty
-        : con_list '::' sigtype
-                {% do { let { (anns, gadtDecl) = mkGadtDecl (unLoc $1) $3 }
+        : con_list '::' ctype
+                {% do { let { (anns,gadtDecl) = mkGadtDecl (unLoc $1) $3 }
                       ; ams (sLL $1 $> gadtDecl)
                             (mu AnnDcolon $2:anns) } }
 
@@ -1932,9 +1936,9 @@ constr :: { LConDecl RdrName }
                             ($1 `mplus` $4))
                        (fst $ unLoc $2) }
 
-forall :: { Located ([AddAnn],[LHsTyVarBndr RdrName]) }
-        : 'forall' tv_bndrs '.'       { sLL $1 $> ([mu AnnForall $1,mj AnnDot $3],$2) }
-        | {- empty -}                 { noLoc ([],[]) }
+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) }
     -- see Note [Parsing data constructors is hard]
@@ -1969,21 +1973,23 @@ fielddecl :: { LConDeclField RdrName }
                       (ConDeclField (reverse (map (fmap (flip FieldOcc PlaceHolder)) (unLoc $2))) $4 ($1 `mplus` $5)))
                    [mu AnnDcolon $3] }
 
--- We allow the odd-looking 'inst_type' in a deriving clause, so that
--- we can do deriving( forall a. C [a] ) in a newtype (GHC extension).
--- The 'C [a]' part is converted to an HsPredTy by checkInstType
--- We don't allow a context, but that's sorted out by the type checker.
-deriving :: { Located (Maybe (Located [LHsType RdrName])) }
+-- The outer Located is just to allow the caller to
+-- know the rightmost extremity of the 'deriving' clause
+deriving :: { Located (HsDeriving RdrName) }
         : {- empty -}             { noLoc Nothing }
-        | 'deriving' qtycon       {% aljs ( let { L loc tv = $2 }
-                                            in (sLL $1 $> (Just (sLL $1 $>
-                                                       [L loc (HsTyVar $2)]))))
-                                          [mj AnnDeriving $1] }
-        | 'deriving' '(' ')'      {% aljs (sLL $1 $> (Just (sLL $1 $> [])))
-                                          [mj AnnDeriving $1,mop $2,mcp $3] }
-
-        | 'deriving' '(' inst_types1 ')'  {% aljs (sLL $1 $> (Just (sLL $1 $> $3)))
-                                                 [mj AnnDeriving $1,mop $2,mcp $4] }
+        | 'deriving' qtycon       {% let { L tv_loc tv = $2
+                                         ; full_loc = comb2 $1 $> }
+                                      in ams (L full_loc $ Just $ L full_loc $
+                                                 [mkLHsSigType (L tv_loc (HsTyVar $2))])
+                                             [mj AnnDeriving $1] }
+
+        | 'deriving' '(' ')'      {% let { full_loc = comb2 $1 $> }
+                                     in ams (L full_loc $ Just $ L full_loc [])
+                                            [mj AnnDeriving $1,mop $2,mcp $3] }
+
+        | 'deriving' '(' deriv_types ')'  {% let { full_loc = comb2 $1 $> }
+                                             in ams (L full_loc $ Just $ L full_loc $3)
+                                                    [mj AnnDeriving $1,mop $2,mcp $4] }
              -- Glasgow extension: allow partial
              -- applications in derivings
 
@@ -2077,12 +2083,14 @@ sigdecl :: { LHsDecl RdrName }
         :
         -- See Note [Declaration/signature overlap] for why we need infixexp here
           infixexp '::' sigtypedoc
-                        {% do s <- checkValSig $1 $3
+                        {% do v <- checkValSigLhs $1
                         ; _ <- ams (sLL $1 $> ()) [mu AnnDcolon $2]
-                        ; return (sLL $1 $> $ SigD s) }
+                        ; return (sLL $1 $> $ SigD $
+                                  TypeSig [v] (mkLHsSigWcType $3)) }
 
         | var ',' sig_vars '::' sigtypedoc
-           {% do { let sig = TypeSig ($1 : reverse (unLoc $3)) $5 PlaceHolder
+           {% do { let sig = TypeSig ($1 : reverse (unLoc $3))
+                                     (mkLHsSigWcType $5)
                  ; addAnnotation (gl $1) AnnComma (gl $2)
                  ; ams ( sLL $1 $> $ SigD sig )
                        [mu AnnDcolon $4] } }
@@ -2149,7 +2157,7 @@ quasiquote :: { Located (HsSplice RdrName) }
                             in sL (getLoc $1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) }
 
 exp   :: { LHsExpr RdrName }
-        : infixexp '::' sigtype {% ams (sLL $1 $> $ ExprWithTySig $1 $3 PlaceHolder)
+        : infixexp '::' sigtype {% ams (sLL $1 $> $ ExprWithTySig $1 (mkLHsSigWcType $3))
                                        [mu AnnDcolon $2] }
         | infixexp '-<' exp     {% ams (sLL $1 $> $ HsArrApp $1 $3 placeHolderType
                                                         HsFirstOrderApp True)
@@ -2176,8 +2184,12 @@ infixexp :: { LHsExpr RdrName }
 exp10 :: { LHsExpr RdrName }
         : '\\' apat apats opt_asig '->' exp
                    {% ams (sLL $1 $> $ HsLam (mkMatchGroup FromSource
-                            [sLL $1 $> $ Match NonFunBindMatch ($2:$3) (snd $4) (unguardedGRHSs $6)]))
+                            [sLL $1 $> $ Match { m_fixity = NonFunBindMatch
+                                               , m_pats = $2:$3
+                                               , m_type = snd $4
+                                               , m_grhss = unguardedGRHSs $6 }]))
                           (mj AnnLam $1:mu AnnRarrow $5:(fst $4)) }
+
         | 'let' binds 'in' exp          {% ams (sLL $1 $> $ HsLet (snd $ unLoc $2) $4)
                                                (mj AnnLet $1:mj AnnIn $3
                                                  :(fst $ unLoc $2)) }
@@ -2577,9 +2589,11 @@ alts1   :: { Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)]) }
         | alt                   { sL1 $1 ([],[$1]) }
 
 alt     :: { LMatch RdrName (LHsExpr RdrName) }
-        : pat opt_sig alt_rhs      {%ams (sLL $1 $> (Match NonFunBindMatch [$1] (snd $2)
-                                                              (snd $ unLoc $3)))
-                                         ((fst $2) ++ (fst $ unLoc $3))}
+        : pat opt_asig alt_rhs  {%ams (sLL $1 $> (Match { m_fixity = NonFunBindMatch
+                                                        , m_pats = [$1]
+                                                        , m_type = snd $2
+                                                        , m_grhss = snd $ unLoc $3 }))
+                                      (fst $2 ++ (fst $ unLoc $3))}
 
 alt_rhs :: { Located ([AddAnn],GRHSs RdrName (LHsExpr RdrName)) }
         : ralt wherebinds           { sLL $1 $> (fst $ unLoc $2,
@@ -3367,10 +3381,13 @@ in ApiAnnotation.hs
 
 -}
 
+addAnnsAt :: SrcSpan -> [AddAnn] -> P ()
+addAnnsAt loc anns = mapM_ (\a -> a loc) anns
+
 -- |Construct an AddAnn from the annotation keyword and the location
--- of the keyword
+-- of the keyword itself
 mj :: AnnKeywordId -> Located e -> AddAnn
-mj a l = (\s -> addAnnotation s a (gl l))
+mj a l s = addAnnotation s a (gl l)
 
 -- |Construct an AddAnn from the annotation keyword and the Located Token. If
 -- the token has a unicode equivalent and this has been used, provide the
@@ -3399,35 +3416,41 @@ am a (b,s) = do
 
 -- |Add a list of AddAnns to the given AST element
 ams :: Located a -> [AddAnn] -> P (Located a)
-ams a@(L l _) bs = mapM_ (\a -> a l) bs >> return a
+ams a@(L l _) bs = addAnnsAt l bs >> return a
 
+-- |Add all [AddAnn] to an AST element wrapped in a Just
+aljs :: Located (Maybe a) -> [AddAnn] -> P (Located (Maybe a))
+aljs a@(L l _) bs = addAnnsAt l bs >> return a
+
+-- |Add all [AddAnn] to an AST element wrapped in a Just
+ajs a@(Just (L l _)) bs = addAnnsAt l bs >> return a
 
 -- |Add a list of AddAnns to the given AST element, where the AST element is the
 --  result of a monadic action
 amms :: P (Located a) -> [AddAnn] -> P (Located a)
-amms a bs = do
-  av@(L l _) <- a
-  (mapM_ (\a -> a l) bs) >> return av
+amms a bs = do { av@(L l _) <- a
+               ; addAnnsAt l bs
+               ; return av }
 
 -- |Add a list of AddAnns to the AST element, and return the element as a
 --  OrdList
 amsu :: Located a -> [AddAnn] -> P (OrdList (Located a))
-amsu a@(L l _) bs = (mapM_ (\a -> a l) bs) >> return (unitOL a)
+amsu a@(L l _) bs = addAnnsAt l bs >> return (unitOL a)
 
 -- |Synonyms for AddAnn versions of AnnOpen and AnnClose
-mo,mc :: Located Token -> SrcSpan -> P ()
+mo,mc :: Located Token -> AddAnn
 mo ll = mj AnnOpen ll
 mc ll = mj AnnClose ll
 
-moc,mcc :: Located Token -> SrcSpan -> P ()
+moc,mcc :: Located Token -> AddAnn
 moc ll = mj AnnOpenC ll
 mcc ll = mj AnnCloseC ll
 
-mop,mcp :: Located Token -> SrcSpan -> P ()
+mop,mcp :: Located Token -> AddAnn
 mop ll = mj AnnOpenP ll
 mcp ll = mj AnnCloseP ll
 
-mos,mcs :: Located Token -> SrcSpan -> P ()
+mos,mcs :: Located Token -> AddAnn
 mos ll = mj AnnOpenS ll
 mcs ll = mj AnnCloseS ll
 
@@ -3436,19 +3459,6 @@ mcs ll = mj AnnCloseS ll
 mcommas :: [SrcSpan] -> [AddAnn]
 mcommas ss = map (\s -> mj AnnCommaTuple (L s ())) ss
 
--- |Add the annotation to an AST element wrapped in a Just
-ajl :: Located (Maybe (Located a)) -> AnnKeywordId -> SrcSpan
- -> P (Located (Maybe (Located a)))
-ajl a@(L _ (Just (L l _))) b s = addAnnotation l b s >> return a
-
--- |Add all [AddAnn] to an AST element wrapped in a Just
-aljs :: Located (Maybe (Located a)) -> [AddAnn]
-  -> P (Located (Maybe (Located a)))
-aljs a@(L _ (Just (L l _))) bs = (mapM_ (\a -> a l) bs) >> return a
-
--- |Add all [AddAnn] to an AST element wrapped in a Just
-ajs a@(Just (L l _)) bs = (mapM_ (\a -> a l) bs) >> return a
-
 -- |Get the location of the last element of a OrdList, or noSrcSpan
 oll :: OrdList (Located a) -> SrcSpan
 oll l =
index 7d14f65..4b744fe 100644 (file)
@@ -16,7 +16,7 @@ module RdrHsSyn (
         mkTyData, mkDataFamInst,
         mkTySynonym, mkTyFamInstEqn,
         mkTyFamInst,
-        mkFamDecl,
+        mkFamDecl, mkLHsSigType,
         splitCon, mkInlinePragma,
         mkPatSynMatchGroup,
         mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
@@ -48,7 +48,7 @@ module RdrHsSyn (
         checkMonadComp,       -- P (HsStmtContext RdrName)
         checkCommand,         -- LHsExpr RdrName -> P (LHsCmd RdrName)
         checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
-        checkValSig,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
+        checkValSigLhs,
         checkDoAndIfThenElse,
         checkRecordSyntax,
         parseErrorSDoc,
@@ -140,11 +140,12 @@ mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
        ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
        ; tyvars <- checkTyVarsP (ptext (sLit "class")) whereDots cls tparams
        ; at_defs <- mapM (eitherToP . mkATDefault) at_insts
-       ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars,
-                                    tcdFDs = snd (unLoc fds), tcdSigs = sigs,
-                                    tcdMeths = binds,
-                                    tcdATs = ats, tcdATDefs = at_defs, tcdDocs  = docs,
-                                    tcdFVs = placeHolderNames })) }
+       ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars
+                                  , tcdFDs = snd (unLoc fds)
+                                  , tcdSigs = mkClassOpSigs sigs
+                                  , tcdMeths = binds
+                                  , tcdATs = ats, tcdATDefs = at_defs, tcdDocs  = docs
+                                  , tcdFVs = placeHolderNames })) }
 
 mkATDefault :: LTyFamInstDecl RdrName
             -> Either (SrcSpan, SDoc) (LTyFamDefltEqn RdrName)
@@ -156,7 +157,7 @@ mkATDefault :: LTyFamInstDecl RdrName
 -- from Convert.hs
 mkATDefault (L loc (TyFamInstDecl { tfid_eqn = L _ e }))
       | TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs = rhs } <- e
-      = do { tvs <- checkTyVars (ptext (sLit "default")) equalsDots tc (hswb_cts pats)
+      = do { tvs <- checkTyVars (ptext (sLit "default")) equalsDots tc (hsib_body pats)
            ; return (L loc (TyFamEqn { tfe_tycon = tc
                                      , tfe_pats = tvs
                                      , tfe_rhs = rhs })) }
@@ -167,7 +168,7 @@ mkTyData :: SrcSpan
          -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
          -> Maybe (LHsKind RdrName)
          -> [LConDecl RdrName]
-         -> Maybe (Located [LHsType RdrName])
+         -> HsDeriving RdrName
          -> P (LTyClDecl RdrName)
 mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
   = do { (tc, tparams,ann) <- checkTyClHdr False tycl_hdr
@@ -183,7 +184,7 @@ mkDataDefn :: NewOrData
            -> Maybe (LHsContext RdrName)
            -> Maybe (LHsKind RdrName)
            -> [LConDecl RdrName]
-           -> Maybe (Located [LHsType RdrName])
+           -> HsDeriving RdrName
            -> P (HsDataDefn RdrName)
 mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
   = do { checkDatatypeContext mcxt
@@ -212,7 +213,7 @@ mkTyFamInstEqn :: LHsType RdrName
 mkTyFamInstEqn lhs rhs
   = do { (tc, tparams, ann) <- checkTyClHdr False lhs
        ; return (TyFamEqn { tfe_tycon = tc
-                          , tfe_pats  = mkHsWithBndrs tparams
+                          , tfe_pats  = mkHsImplicitBndrs tparams
                           , tfe_rhs   = rhs },
                  ann) }
 
@@ -222,7 +223,7 @@ mkDataFamInst :: SrcSpan
               -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
               -> Maybe (LHsKind RdrName)
               -> [LConDecl RdrName]
-              -> Maybe (Located [LHsType RdrName])
+              -> HsDeriving RdrName
               -> P (LInstDecl RdrName)
 mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
   = do { (tc, tparams,ann) <- checkTyClHdr False tycl_hdr
@@ -230,7 +231,7 @@ mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_
        ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
        ; return (L loc (DataFamInstD (
                   DataFamInstDecl { dfid_tycon = tc
-                                  , dfid_pats = mkHsWithBndrs tparams
+                                  , dfid_pats = mkHsImplicitBndrs tparams
                                   , dfid_defn = defn, dfid_fvs = placeHolderNames }))) }
 
 mkTyFamInst :: SrcSpan
@@ -486,52 +487,58 @@ mkPatSynMatchGroup (L _ patsyn_name) (L _ decls) =
         text "pattern synonym 'where' clause must bind the pattern synonym's name" <+>
         quotes (ppr patsyn_name) $$ ppr decl
 
-mkSimpleConDecl :: Located RdrName -> [LHsTyVarBndr RdrName]
+mkSimpleConDecl :: Located RdrName -> Maybe [LHsTyVarBndr RdrName]
                 -> LHsContext RdrName -> HsConDeclDetails RdrName
                 -> ConDecl RdrName
 
-mkSimpleConDecl name qvars cxt details
+mkSimpleConDecl name mb_forall cxt details
   = ConDecl { con_names    = [name]
-            , con_explicit = Explicit
-            , con_qvars    = mkHsQTvs qvars
+            , con_explicit = explicit
+            , con_qvars    = qvars
             , con_cxt      = cxt
             , con_details  = details
             , con_res      = ResTyH98
             , con_doc      = Nothing }
+  where
+    (explicit, qvars) = case mb_forall of
+                          Nothing  -> (False, mkHsQTvs [])
+                          Just tvs -> (True,  mkHsQTvs tvs)
 
 mkGadtDecl :: [Located RdrName]
            -> LHsType RdrName     -- Always a HsForAllTy
            -> ([AddAnn], ConDecl RdrName)
-mkGadtDecl names (L l ty) =
-  let (anns, ty') = flattenHsForAllTyKeepAnns ty
-      gadt        = mkGadtDecl' names (L l ty')
-  in (anns, gadt)
+mkGadtDecl names ty = ([], mkGadtDecl' names ty)
 
 mkGadtDecl' :: [Located RdrName]
-            ->  LHsType RdrName     -- Always a HsForAllTy
-            -> (ConDecl RdrName)
+            -> LHsType RdrName
+            -> ConDecl RdrName
 -- We allow C,D :: ty
 -- and expand it as if it had been
 --    C :: ty; D :: ty
 -- (Just like type signatures in general.)
-mkGadtDecl' names (L ls (HsForAllTy imp _ qvars cxt tau))
+
+mkGadtDecl' names lbody_ty@(L loc body_ty)
   = mk_gadt_con names
   where
+    (tvs, cxt, tau) = splitLHsSigmaTy lbody_ty
     (details, res_ty)           -- See Note [Sorting out the result type]
       = case tau of
           L _ (HsFunTy (L l (HsRecTy flds)) res_ty)
-                                            -> (RecCon (L l flds), res_ty)
-          _other                            -> (PrefixCon [], tau)
+                  -> (RecCon (L l flds), res_ty)
+          _other  -> (PrefixCon [], tau)
+
+    explicit = case body_ty of
+                 HsForAllTy {} -> True
+                 _             -> False
 
     mk_gadt_con names
        = ConDecl { con_names    = names
-                 , con_explicit = imp
-                 , con_qvars    = qvars
+                 , con_explicit = explicit
+                 , con_qvars    = mkHsQTvs tvs
                  , con_cxt      = cxt
                  , con_details  = details
-                 , con_res      = ResTyGADT ls res_ty
+                 , con_res      = ResTyGADT loc res_ty
                  , con_doc      = Nothing }
-mkGadtDecl' _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty)
 
 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
 tyConToDataCon loc tc
@@ -647,7 +654,7 @@ really doesn't matter!
 --    * For PrefixCon we keep all the args in the ResTyGADT
 --    * For RecCon we do not
 
-checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] -> P (LHsTyVarBndrs RdrName)
+checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] -> P (LHsQTyVars RdrName)
 -- Same as checkTyVars, but in the P monad
 checkTyVarsP pp_what equals_or_where tc tparms
   = eitherToP $ checkTyVars pp_what equals_or_where tc tparms
@@ -657,7 +664,7 @@ eitherToP :: Either (SrcSpan, SDoc) a -> P a
 eitherToP (Left (loc, doc)) = parseErrorSDoc loc doc
 eitherToP (Right thing)     = return thing
 checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName]
-            -> Either (SrcSpan, SDoc) (LHsTyVarBndrs RdrName)
+            -> Either (SrcSpan, SDoc) (LHsQTyVars RdrName)
 -- Check whether the given list of type parameters are all type variables
 -- (possibly with a kind signature)
 -- We use the Either monad because it's also called (via mkATDefault) from
@@ -815,15 +822,8 @@ checkAPat msg loc e0 = do
    -- view pattern is well-formed if the pattern is
    EViewPat expr patE  -> checkLPat msg patE >>=
                             (return . (\p -> ViewPat expr p placeHolderType))
-   ExprWithTySig e t _ -> do e <- checkLPat msg e
-                             -- Pattern signatures are parsed as sigtypes,
-                             -- but they aren't explicit forall points.  Hence
-                             -- we have to remove the implicit forall here.
-                             let t' = case t of
-                                        L _ (HsForAllTy Implicit _ _
-                                             (L _ []) ty) -> ty
-                                        other -> other
-                             return (SigPatIn e (mkHsWithBndrs t'))
+   ExprWithTySig e t   -> do e <- checkLPat msg e
+                             return (SigPatIn e t)
 
    -- n+k patterns
    OpApp (L nloc (HsVar (L _ n))) (L _ (HsVar (L _ plus))) _
@@ -890,14 +890,14 @@ checkValDef :: SDoc
 checkValDef msg lhs (Just sig) grhss
         -- x :: ty = rhs  parses as a *pattern* binding
   = checkPatBind msg (L (combineLocs lhs sig)
-                        (ExprWithTySig lhs sig PlaceHolder)) grhss
+                        (ExprWithTySig lhs (mkLHsSigWcType sig))) grhss
 
 checkValDef msg lhs opt_sig g@(L l (_,grhss))
   = do  { mb_fun <- isFunLhs lhs
         ; case mb_fun of
             Just (fun, is_infix, pats, ann) ->
               checkFunBind msg ann (getLoc lhs)
-                                           fun is_infix pats opt_sig (L l grhss)
+                           fun is_infix pats opt_sig (L l grhss)
             Nothing -> checkPatBind msg lhs g }
 
 checkFunBind :: SDoc
@@ -914,9 +914,11 @@ checkFunBind msg ann lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
         let match_span = combineSrcSpans lhs_loc rhs_span
         -- Add back the annotations stripped from any HsPar values in the lhs
         -- mapM_ (\a -> a match_span) ann
-        return (ann,makeFunBind fun
-                  [L match_span (Match (FunBindMatch fun is_infix)
-                                 ps opt_sig grhss)])
+        return (ann, makeFunBind fun
+                  [L match_span (Match { m_fixity = FunBindMatch fun is_infix
+                                       , m_pats = ps
+                                       , m_type = opt_sig
+                                       , m_grhss = grhss })])
         -- The span of the match covers the entire equation.
         -- That isn't quite right, but it'll do for now.
 
@@ -939,26 +941,26 @@ checkPatBind msg lhs (L _ (_,grhss))
         ; return ([],PatBind lhs grhss placeHolderType placeHolderNames
                     ([],[])) }
 
-checkValSig
-        :: LHsExpr RdrName
-        -> LHsType RdrName
-        -> P (Sig RdrName)
-checkValSig (L l (HsVar (L _ v))) ty
-  | isUnqual v && not (isDataOcc (rdrNameOcc v))
-  = return (TypeSig [L l v] ty PlaceHolder)
-checkValSig lhs@(L l _) ty
+checkValSigLhs :: LHsExpr RdrName -> P (Located RdrName)
+checkValSigLhs (L _ (HsVar lrdr@(L _ v)))
+  | isUnqual v
+  , not (isDataOcc (rdrNameOcc v))
+  = return lrdr
+
+checkValSigLhs lhs@(L l _)
   = parseErrorSDoc l ((text "Invalid type signature:" <+>
-                       ppr lhs <+> text "::" <+> ppr ty)
-                   $$ text hint)
+                       ppr lhs <+> text ":: ...")
+                      $$ text hint)
   where
-    hint | foreign_RDR `looks_like` lhs =
-           "Perhaps you meant to use ForeignFunctionInterface?"
-         | default_RDR `looks_like` lhs =
-           "Perhaps you meant to use DefaultSignatures?"
-         | pattern_RDR `looks_like` lhs =
-           "Perhaps you meant to use PatternSynonyms?"
-         | otherwise =
-           "Should be of form <variable> :: <type>"
+    hint | foreign_RDR `looks_like` lhs
+         = "Perhaps you meant to use ForeignFunctionInterface?"
+         | default_RDR `looks_like` lhs
+         = "Perhaps you meant to use DefaultSignatures?"
+         | pattern_RDR `looks_like` lhs
+         = "Perhaps you meant to use PatternSynonyms?"
+         | otherwise
+         = "Should be of form <variable> :: <type>"
+
     -- 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
@@ -1242,24 +1244,30 @@ mkInlinePragma src (inl, match_info) mb_act
 --
 mkImport :: Located CCallConv
          -> Located Safety
-         -> (Located StringLiteral, Located RdrName, LHsType RdrName)
+         -> (Located StringLiteral, Located RdrName, LHsSigType RdrName)
          -> P (HsDecl RdrName)
 mkImport (L lc cconv) (L ls safety) (L loc (StringLiteral esrc entity), v, ty)
   | cconv == PrimCallConv                      = do
   let funcTarget = CFunction (StaticTarget esrc entity Nothing True)
       importSpec = CImport (L lc PrimCallConv) (L ls safety) Nothing funcTarget
                            (L loc (unpackFS entity))
-  return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec))
+  return (ForD (ForeignImport { fd_name = v, fd_sig_ty = ty
+                              , fd_co = noForeignImportCoercionYet
+                              , fd_fi = importSpec }))
   | cconv == JavaScriptCallConv = do
   let funcTarget = CFunction (StaticTarget esrc entity Nothing True)
       importSpec = CImport (L lc JavaScriptCallConv) (L ls safety) Nothing
                            funcTarget (L loc (unpackFS entity))
-  return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec))
+  return (ForD (ForeignImport { fd_name = v, fd_sig_ty = ty
+                              , fd_co = noForeignImportCoercionYet
+                              , fd_fi = importSpec }))
   | otherwise = do
     case parseCImport (L lc cconv) (L ls safety) (mkExtName (unLoc v))
                       (unpackFS entity) (L loc (unpackFS entity)) of
       Nothing         -> parseErrorSDoc loc (text "Malformed entity string")
-      Just importSpec -> return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec))
+      Just importSpec -> return (ForD (ForeignImport { fd_name = v, fd_sig_ty = ty
+                                                     , fd_co = noForeignImportCoercionYet
+                                                     , fd_fi = importSpec }))
 
 -- the string "foo" is ambigous: either a header or a C identifier.  The
 -- C identifier case comes first in the alternatives below, so we pick
@@ -1321,12 +1329,14 @@ parseCImport cconv safety nm str sourceText =
 -- construct a foreign export declaration
 --
 mkExport :: Located CCallConv
-         -> (Located StringLiteral, Located RdrName, LHsType RdrName)
+         -> (Located StringLiteral, Located RdrName, LHsSigType RdrName)
          -> P (HsDecl RdrName)
-mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty) = do
-  return $ ForD (ForeignExport v ty noForeignExportCoercionYet
-                 (CExport (L lc (CExportStatic esrc entity' cconv))
-                          (L le (unpackFS entity))))
+mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty)
+ = return $ ForD $
+   ForeignExport { fd_name = v, fd_sig_ty = ty
+                 , fd_co = noForeignExportCoercionYet
+                 , fd_fe = CExport (L lc (CExportStatic esrc entity' cconv))
+                                   (L le (unpackFS entity)) }
   where
     entity' | nullFS entity = mkExtName (unLoc v)
             | otherwise     = entity
index 27194a2..11d7d19 100644 (file)
@@ -154,8 +154,8 @@ itName uniq loc = mkInternalName uniq (mkOccNameFS varName (fsLit "it")) loc
 
 -- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly
 -- during compiler debugging.
-mkUnboundName :: RdrName -> Name
-mkUnboundName rdr_name = mkInternalName unboundKey (rdrNameOcc rdr_name) noSrcSpan
+mkUnboundName :: OccName -> Name
+mkUnboundName occ = mkInternalName unboundKey occ noSrcSpan
 
 isUnboundName :: Name -> Bool
 isUnboundName name = name `hasKey` unboundKey
index 9ec71df..c2a45b0 100644 (file)
@@ -19,7 +19,7 @@ module RnBinds (
    rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
 
    -- Other bindings
-   rnMethodBinds, renameSigs, mkSigTvFn,
+   rnMethodBinds, renameSigs,
    rnMatchGroup, rnGRHSs, rnGRHS,
    makeMiniFixityEnv, MiniFixityEnv,
    HsSigCtxt(..)
@@ -554,35 +554,23 @@ depAnalBinds binds_w_dus
 
 mkSigTvFn :: [LSig Name] -> (Name -> [Name])
 -- Return a lookup function that maps an Id Name to the names
--- of the type variables that should scope over its body..
+-- of the type variables that should scope over its body.
 mkSigTvFn sigs
   = \n -> lookupNameEnv env n `orElse` []
   where
-    extractScopedTyVars :: LHsType Name -> [Name]
-    extractScopedTyVars (L _ (HsForAllTy Explicit _ ltvs _ _)) = hsLKiTyVarNames ltvs
-    extractScopedTyVars _ = []
-
     env :: NameEnv [Name]
-    env = mkNameEnv [ (name, nwcs ++ extractScopedTyVars ty)  -- Kind variables and type variables
-                      -- nwcs: see Note [Scoping of named wildcards]
-                    | L _ (TypeSig names ty nwcs) <- sigs
-                    , L _ name <- names]
-        -- Note the pattern-match on "Explicit"; we only bind
-        -- type variables from signatures with an explicit top-level for-all
-
-
-{- Note [Scoping of named wildcards]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-  f :: _a -> _a
-  f x = let g :: _a -> _a
-            g = ...
-        in ...
-
-Currently, for better or worse, the "_a" variables are all the same. So
-although there is no explicit forall, the "_a" scopes over the definition.
-I don't know if this is a good idea, but there it is.
--}
+    env = foldr add_scoped_sig emptyNameEnv sigs
+
+    add_scoped_sig :: LSig Name -> NameEnv [Name] -> NameEnv [Name]
+    add_scoped_sig (L _ (ClassOpSig _ names sig_ty)) env
+      = add_scoped_tvs names (hsScopedTvs sig_ty) env
+    add_scoped_sig (L _ (TypeSig names sig_ty)) env
+      = add_scoped_tvs names (hsWcScopedTvs sig_ty) env
+    add_scoped_sig _ env = env
+
+    add_scoped_tvs :: [Located Name] -> [Name] -> NameEnv [Name] -> NameEnv [Name]
+    add_scoped_tvs id_names tv_names env
+      = foldr (\(L _ id_n) env -> extendNameEnv env id_n tv_names) env id_names
 
 -- Process the fixity declarations, making a FastString -> (Located Fixity) map
 -- (We keep the location around for reporting duplicate fixity declarations.)
@@ -886,29 +874,26 @@ renameSig :: HsSigCtxt -> Sig RdrName -> RnM (Sig Name, FreeVars)
 renameSig _ (IdSig x)
   = return (IdSig x, emptyFVs)    -- Actually this never occurs
 
-renameSig ctxt sig@(TypeSig vs ty _)
+renameSig ctxt sig@(TypeSig vs ty)
   = do  { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
-        ; let doc = ppr_sig_bndrs vs
-              wildCardsAllowed = case ctxt of
-                TopSigCtxt _    -> True
-                LocalBindCtxt _ -> True
-                _               -> False
-        ; (new_ty, fvs, wcs)
-            <- if wildCardsAllowed
-               then rnHsSigTypeWithWildCards doc ty
-               else do { (new_ty, fvs) <- rnHsSigType doc ty
-                       ; return (new_ty, fvs, []) }
-        ; return (TypeSig new_vs new_ty wcs, fvs) }
-
-renameSig ctxt sig@(GenericSig vs ty)
+        ; let doc = TypeSigCtx (ppr_sig_bndrs vs)
+        ; (new_ty, fvs) <- rnHsSigWcType doc ty
+        ; return (TypeSig new_vs new_ty, fvs) }
+
+renameSig ctxt sig@(ClassOpSig is_deflt vs ty)
   = do  { defaultSigs_on <- xoptM Opt_DefaultSignatures
-        ; unless defaultSigs_on (addErr (defaultSigErr sig))
+        ; when (is_deflt && not defaultSigs_on) $
+          addErr (defaultSigErr sig)
         ; new_v <- mapM (lookupSigOccRn ctxt sig) vs
-        ; (new_ty, fvs) <- rnHsSigType (ppr_sig_bndrs vs) ty
-        ; return (GenericSig new_v new_ty, fvs) }
+        ; (new_ty, fvs) <- rnHsSigType ty_ctxt ty
+        ; return (ClassOpSig is_deflt new_v new_ty, fvs) }
+  where
+    (v1:_) = vs
+    ty_ctxt = GenericCtx (ptext (sLit "a class method signature for")
+                          <+> quotes (ppr v1))
 
 renameSig _ (SpecInstSig src ty)
-  = do  { (new_ty, fvs) <- rnLHsType SpecInstSigCtx ty
+  = do  { (new_ty, fvs) <- rnHsSigType SpecInstSigCtx ty
         ; return (SpecInstSig src new_ty,fvs) }
 
 -- {-# SPECIALISE #-} pragmas can refer to imported Ids
@@ -919,12 +904,13 @@ renameSig ctxt sig@(SpecSig v tys inl)
   = do  { new_v <- case ctxt of
                      TopSigCtxt {} -> lookupLocatedOccRn v
                      _             -> lookupSigOccRn ctxt sig v
-        -- ; (new_ty, fvs) <- rnHsSigType (quotes (ppr v)) ty
         ; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys
         ; return (SpecSig new_v new_ty inl, fvs) }
   where
+    ty_ctxt = GenericCtx (ptext (sLit "a SPECIALISE signature for")
+                          <+> quotes (ppr v))
     do_one (tys,fvs) ty
-      = do { (new_ty, fvs_ty) <- rnHsSigType (quotes (ppr v)) ty
+      = do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt ty
            ; return ( new_ty:tys, fvs_ty `plusFV` fvs) }
 
 renameSig ctxt sig@(InlineSig v s)
@@ -939,29 +925,13 @@ renameSig ctxt sig@(MinimalSig s (L l bf))
   = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf
        return (MinimalSig s (L l new_bf), emptyFVs)
 
-renameSig ctxt sig@(PatSynSig v (flag, qtvs) req prov ty)
+renameSig ctxt sig@(PatSynSig v ty)
   = do  { v' <- lookupSigOccRn ctxt sig v
-        ; let doc = TypeSigCtx $ quotes (ppr v)
-        ; loc <- getSrcSpanM
-
-        ; let (tv_kvs, mentioned) = extractHsTysRdrTyVars (ty:unLoc prov ++ unLoc req)
-        ; tv_bndrs <- case flag of
-            Implicit ->
-                return $ mkHsQTvs . userHsTyVarBndrs loc $ mentioned
-            Explicit ->
-                do { let heading = ptext (sLit "In the pattern synonym type signature")
-                                   <+> quotes (ppr sig)
-                   ; warnUnusedForAlls (heading $$ docOfHsDocContext doc) qtvs mentioned
-                   ; return qtvs }
-            Qualified -> panic "renameSig: Qualified"
-
-        ; bindHsTyVars doc Nothing tv_kvs tv_bndrs $ \ tyvars -> do
-        { (req', fvs2) <- rnContext doc req
-        ; (prov', fvs1) <- rnContext doc prov
-        ; (ty', fvs3) <- rnLHsType doc ty
-
-        ; let fvs = plusFVs [fvs1, fvs2, fvs3]
-        ; return (PatSynSig v' (flag, tyvars) req' prov' ty', fvs) }}
+        ; (ty', fvs) <- rnHsSigType ty_ctxt ty
+        ; return (PatSynSig v' ty', fvs) }
+  where
+    ty_ctxt = GenericCtx (ptext (sLit "a pattern synonym signature for")
+                          <+> quotes (ppr v))
 
 ppr_sig_bndrs :: [Located RdrName] -> SDoc
 ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs)
@@ -969,10 +939,13 @@ ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs)
 okHsSig :: HsSigCtxt -> LSig a -> Bool
 okHsSig ctxt (L _ sig)
   = case (sig, ctxt) of
-     (GenericSig {}, ClsDeclCtxt {}) -> True
-     (GenericSig {}, _)              -> False
+     (ClassOpSig {}, ClsDeclCtxt {})  -> True
+     (ClassOpSig {}, InstDeclCtxt {}) -> True
+     (ClassOpSig {}, _)               -> False
 
-     (TypeSig {}, _)              -> True
+     (TypeSig {}, ClsDeclCtxt {})  -> False
+     (TypeSig {}, InstDeclCtxt {}) -> False
+     (TypeSig {}, _)               -> True
 
      (PatSynSig {}, TopSigCtxt{}) -> True
      (PatSynSig {}, _)            -> False
@@ -1012,16 +985,16 @@ 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@(GenericSig ns _)        = [(n,sig) | n <- ns]
+    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 _ = []
 
-    matching_sig (L _ n1,sig1) (L _ n2,sig2) = n1 == n2 && mtch sig1 sig2
-    mtch (FixSig {})     (FixSig {})     = True
-    mtch (InlineSig {})  (InlineSig {})  = True
-    mtch (TypeSig {})    (TypeSig {})    = True
-    mtch (GenericSig {}) (GenericSig {}) = True
+    matching_sig (L _ n1,sig1) (L _ n2,sig2)       = n1 == n2 && mtch sig1 sig2
+    mtch (FixSig {})           (FixSig {})         = True
+    mtch (InlineSig {})        (InlineSig {})      = True
+    mtch (TypeSig {})          (TypeSig {})        = True
+    mtch (ClassOpSig d1 _ _)   (ClassOpSig d2 _ _) = d1 == d2
     mtch _ _ = False
 
 -- Warn about multiple MINIMAL signatures
index 0ce8e41..57b427b 100644 (file)
@@ -22,11 +22,11 @@ module RnEnv (
         lookupSigCtxtOccRn,
 
         lookupFixityRn, lookupTyFixityRn,
-        lookupInstDeclBndr, lookupSubBndrOcc, lookupFamInstName,
-        lookupSubBndrGREs, lookupConstructorFields,
+        lookupInstDeclBndr, lookupRecFieldOcc, lookupFamInstName,
+        lookupConstructorFields,
         lookupSyntaxName, lookupSyntaxNames, lookupIfThenElse,
         lookupGreAvailRn,
-        getLookupOccRn,
+        getLookupOccRn,mkUnboundName, mkUnboundNameRdr, isUnboundName,
         addUsedGRE, addUsedGREs, addUsedDataCons,
 
         newLocalBndrRn, newLocalBndrsRn,
@@ -43,7 +43,8 @@ module RnEnv (
         warnUnusedTopBinds, warnUnusedLocalBinds,
         mkFieldEnv,
         dataTcOccs, kindSigErr, perhapsForallMsg, unknownSubordinateErr,
-        HsDocContext(..), docOfHsDocContext
+        HsDocContext(..), pprHsDocContext,
+        inHsDocContext, withHsDocContext
     ) where
 
 #include "HsVersions.h"
@@ -224,7 +225,7 @@ newTopSrcBinder (L loc rdr_name)
                         -- ToDo: more helpful error messages
                       ; addErr (unknownNameErr (pprNonVarNameSpace
                             (occNameSpace (rdrNameOcc rdr_name))) rdr_name)
-                      ; return (mkUnboundName rdr_name)
+                      ; return (mkUnboundNameRdr rdr_name)
                       }
                 }
             Nothing ->
@@ -412,11 +413,15 @@ lookupInstDeclBndr cls what rdr
                 -- In an instance decl you aren't allowed
                 -- to use a qualified name for the method
                 -- (Although it'd make perfect sense.)
-       ; lookupSubBndrOcc False -- False => we don't give deprecated
+       ; mb_name <- lookupSubBndrOcc
+                          False -- False => we don't give deprecated
                                 -- warnings when a deprecated class
                                 -- method is defined. We only warn
                                 -- when it's used
-                          (Just cls) doc rdr }
+                          cls doc rdr
+       ; case mb_name of
+           Left err -> do { addErr err; return (mkUnboundNameRdr rdr) }
+           Right nm -> return nm }
   where
     doc = what <+> ptext (sLit "of class") <+> quotes (ppr cls)
 
@@ -445,9 +450,11 @@ lookupConstructorFields con_name
   = do  { this_mod <- getModule
         ; if nameIsLocalOrFrom this_mod con_name then
           do { field_env <- getRecFieldEnv
+             ; traceTc "lookupCF" (ppr con_name $$ ppr (lookupNameEnv field_env con_name) $$ ppr field_env)
              ; return (lookupNameEnv field_env con_name `orElse` []) }
           else
           do { con <- tcLookupDataCon con_name
+             ; traceTc "lookupCF 2" (ppr con)
              ; return (dataConFieldLabels con) } }
 
 -----------------------------------------------
@@ -462,58 +469,77 @@ lookupConstructorFields con_name
 -- Arguably this should work, because the reference to 'fld' is
 -- unambiguous because there is only one field id 'fld' in scope.
 -- But currently it's rejected.
+
+lookupRecFieldOcc :: Maybe Name  -- Nothing    => just look it up as usual
+                                 -- Just tycon => use tycon to disambiguate
+                  -> SDoc -> RdrName
+                  -> RnM Name
+lookupRecFieldOcc parent doc rdr_name
+  | Just tc_name <- parent
+  = do { mb_name <- lookupSubBndrOcc True tc_name doc rdr_name
+       ; case mb_name of
+           Left err -> do { addErr err; return (mkUnboundNameRdr rdr_name) }
+           Right n  -> return n }
+
+  | otherwise
+  = lookupGlobalOccRn rdr_name
+
 lookupSubBndrOcc :: Bool
-                 -> Maybe Name  -- Nothing => just look it up as usual
-                                -- Just p  => use parent p to disambiguate
-                 -> SDoc -> RdrName
-                 -> RnM Name
-lookupSubBndrOcc warnIfDeprec parent doc rdr_name
+                 -> Name     -- Parent
+                 -> SDoc
+                 -> RdrName
+                 -> RnM (Either MsgDoc Name)
+-- Find all the things the rdr-name maps to
+-- and pick the one with the right parent namep
+lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name
   | Just n <- isExact_maybe rdr_name   -- This happens in derived code
-  = lookupExactOcc n
+  = do { n <- lookupExactOcc n
+       ; return (Right n) }
 
   | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
-  = lookupOrig rdr_mod rdr_occ
+  = do { n <- lookupOrig rdr_mod rdr_occ
+       ; return (Right n) }
+
+  | isUnboundName the_parent
+        -- Avoid an error cascade from malformed decls:
+        --   instance Int where { foo = e }
+        -- We have already generated an error in rnLHsInstDecl
+  = return (Right (mkUnboundNameRdr rdr_name))
 
-  | otherwise   -- Find all the things the rdr-name maps to
-  = do  {       -- and pick the one with the right parent namep
-          env <- getGlobalRdrEnv
-        ; case lookupSubBndrGREs env parent rdr_name of
+  | otherwise
+  = do { env <- getGlobalRdrEnv
+       ; let gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)
                 -- NB: lookupGlobalRdrEnv, not lookupGRE_RdrName!
                 --     The latter does pickGREs, but we want to allow 'x'
                 --     even if only 'M.x' is in scope
-            [gre] -> do { addUsedGRE warnIfDeprec gre
-                          -- Add a usage; this is an *occurrence* site
-                          -- Note [Usage for sub-bndrs]
-                        ; return (gre_name gre) }
-            []    -> do { ns <- lookupQualifiedNameGHCi rdr_name
-                        ; case ns of {
-                                (n:_) -> return n ;
-                                -- Unlikely to be more than one...?
-                                [] -> do
-                        { addErr (unknownSubordinateErr doc rdr_name)
-                        ; return (mkUnboundName rdr_name) } } }
-            gres  -> do { addNameClashErrRn rdr_name gres
-                        ; return (gre_name (head gres)) } }
-
-lookupSubBndrGREs :: GlobalRdrEnv -> Maybe Name -> RdrName -> [GlobalRdrElt]
--- If parent = Nothing, just do a normal lookup
--- If parent = Just p then find all GREs that
---   (a) have parent p
---   (b) for Unqual, are in scope qualified or unqualified
---       for Qual, are in scope with that qualification
-lookupSubBndrGREs env parent rdr_name
-  = case parent of
-      Nothing               -> pickGREs rdr_name gres
-      Just p
-        | isUnqual rdr_name -> filter (parent_is p) gres
-        | otherwise         -> filter (parent_is p) (pickGREs rdr_name gres)
-
+       ; traceRn (text "lookupSubBndrOcc" <+> vcat [ppr the_parent, ppr rdr_name, ppr gres, ppr (pick_gres rdr_name gres)])
+       ; case pick_gres rdr_name gres of
+            (gre:_) -> do { addUsedGRE warn_if_deprec gre
+                            -- Add a usage; this is an *occurrence* site
+                            -- Note [Usage for sub-bndrs]
+                          ; return (Right (gre_name gre)) }
+                 -- If there is more than one local GRE for the
+                 -- same OccName 'f', that will be reported separately
+                 -- as a duplicate top-level binding for 'f'
+            [] -> do { ns <- lookupQualifiedNameGHCi rdr_name
+                     ; case ns of
+                         (n:_) -> return (Right n)  -- Unlikely to be more than one...?
+                         [] -> return (Left (unknownSubordinateErr doc rdr_name))
+    } }
   where
-    gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)
-
-    parent_is p (GRE { gre_par = ParentIs p' })             = p == p'
-    parent_is p (GRE { gre_par = FldParent { par_is = p'}}) = p == p'
-    parent_is _ _                                           = False
+    -- If Parent = NoParent, just do a normal lookup
+    -- If Parent = Parent p then find all GREs that
+    --   (a) have parent p
+    --   (b) for Unqual, are in scope qualified or unqualified
+    --       for Qual, are in scope with that qualification
+    pick_gres rdr_name gres
+      | isUnqual rdr_name = filter right_parent gres
+      | otherwise         = filter right_parent (pickGREs rdr_name gres)
+
+    right_parent (GRE { gre_par = p })
+      | ParentIs parent <- p               = parent == the_parent
+      | FldParent { par_is = parent } <- p = parent == the_parent
+      | otherwise                          = False
 
 {-
 Note [Family instance binders]
@@ -655,6 +681,9 @@ getLookupOccRn
   = do local_env <- getLocalRdrEnv
        return (lookupLocalRdrOcc local_env . nameOccName)
 
+mkUnboundNameRdr :: RdrName -> Name
+mkUnboundNameRdr rdr = mkUnboundName (rdrNameOcc rdr)
+
 lookupLocatedOccRn :: Located RdrName -> RnM (Located Name)
 lookupLocatedOccRn = wrapLocM lookupOccRn
 
@@ -764,16 +793,33 @@ lookupOccRn_maybe rdr_name
        ; case lookupLocalRdrEnv local_env rdr_name of {
           Just name -> return (Just name) ;
           Nothing   -> do
-       { mb_name <- lookupGlobalOccRn_maybe rdr_name
-       ; case mb_name of {
-                Just name  -> return (Just name) ;
-                Nothing -> do
-       { ns <- lookupQualifiedNameGHCi rdr_name
+       ; lookupGlobalOccRn_maybe rdr_name } }
+
+lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name)
+-- Looks up a RdrName occurrence in the top-level
+--   environment, including using lookupQualifiedNameGHCi
+--   for the GHCi case
+-- No filter function; does not report an error on failure
+-- Uses addUsedRdrName to record use and deprecations
+lookupGlobalOccRn_maybe rdr_name
+  | Just n <- isExact_maybe rdr_name   -- This happens in derived code
+  = do { n' <- lookupExactOcc n; return (Just n') }
+
+  | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
+  = do { n <- lookupOrig rdr_mod rdr_occ
+       ; return (Just n) }
+
+  | otherwise
+  = do  { mb_gre <- lookupGreRn_maybe rdr_name
+        ; case mb_gre of {
+            Just gre -> return (Just (gre_name gre)) ;
+            Nothing  ->
+     do { ns <- lookupQualifiedNameGHCi rdr_name
                       -- This test is not expensive,
                       -- and only happens for failed lookups
        ; case ns of
            (n:_) -> return (Just n)  -- Unlikely to be more than one...?
-           []    -> return Nothing } } } } }
+           []    -> return Nothing } } }
 
 lookupGlobalOccRn :: RdrName -> RnM Name
 -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global
@@ -804,24 +850,6 @@ lookupInfoOccRn rdr_name
        ; qual_ns <- lookupQualifiedNameGHCi rdr_name
        ; return (ns ++ (qual_ns `minusList` ns)) }
 
-lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name)
--- No filter function; does not report an error on failure
-
-lookupGlobalOccRn_maybe rdr_name
-  | Just n <- isExact_maybe rdr_name   -- This happens in derived code
-  = do { n' <- lookupExactOcc n; return (Just n') }
-
-  | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
-  = do { n <- lookupOrig rdr_mod rdr_occ
-       ; return (Just n) }
-
-  | otherwise
-  = do  { mb_gre <- lookupGreRn_maybe rdr_name
-        ; case mb_gre of
-                Nothing  -> return Nothing
-                Just gre -> return (Just (gre_name gre)) }
-
-
 -- | Like 'lookupOccRn_maybe', but with a more informative result if
 -- the 'RdrName' happens to be a record selector:
 --
@@ -863,7 +891,8 @@ lookupGlobalOccRn_overloaded overload_ok rdr_name
                 []    -> return Nothing
                 [gre] | isRecFldGRE gre
                          -> do { addUsedGRE True gre
-                               ; let fld_occ = FieldOcc rdr_name (gre_name gre)
+                               ; let fld_occ :: FieldOcc Name
+                                     fld_occ = FieldOcc rdr_name (gre_name gre)
                                ; return (Just (Right [fld_occ])) }
                       | otherwise
                          -> do { addUsedGRE True gre
@@ -887,6 +916,7 @@ lookupGreRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt)
 --   Many bindings:       report "ambiguous", return an arbitrary (Just gre)
 -- (This API is a bit strange; lookupGRERn2_maybe is simpler.
 --  But it works and I don't want to fiddle too much.)
+-- Uses addUsedRdrName to record use and deprecations
 lookupGreRn_maybe rdr_name
   = do  { env <- getGlobalRdrEnv
         ; case lookupGRE_RdrName rdr_name env of
@@ -902,6 +932,7 @@ lookupGreRn2_maybe :: RdrName -> RnM (Maybe GlobalRdrElt)
 --   Exactly one binding: record it as "used",   return (Just gre)
 --   No bindings:         report "not in scope", return Nothing
 --   Many bindings:       report "ambiguous",    return Nothing
+-- Uses addUsedRdrName to record use and deprecations
 lookupGreRn2_maybe rdr_name
   = do  { env <- getGlobalRdrEnv
         ; case lookupGRE_RdrName rdr_name env of
@@ -916,13 +947,14 @@ lookupGreRn2_maybe rdr_name
 lookupGreAvailRn :: RdrName -> RnM (Name, AvailInfo)
 -- Used in export lists
 -- If not found or ambiguous, add error message, and fake with UnboundName
+-- Uses addUsedRdrName to record use and deprecations
 lookupGreAvailRn rdr_name
   = do  { mb_gre <- lookupGreRn2_maybe rdr_name
         ; case mb_gre of {
             Just gre -> return (gre_name gre, availFromGRE gre) ;
             Nothing  ->
     do  { traceRn (text "lookupGreRn" <+> ppr rdr_name)
-        ; let name = mkUnboundName rdr_name
+        ; let name = mkUnboundNameRdr rdr_name
         ; return (name, avail name) } } }
 
 {-
@@ -1089,7 +1121,8 @@ lookupQualifiedNameGHCi rdr_name
                         ; return [] } }
 
       | otherwise
-      = return []
+      = do { traceRn (text "lookupQualifedNameGHCi: off" <+> ppr rdr_name)
+           ; return [] }
 
     doc = ptext (sLit "Need to find") <+> ppr rdr_name
 
@@ -1163,7 +1196,7 @@ lookupSigCtxtOccRn ctxt what
   = wrapLocM $ \ rdr_name ->
     do { mb_name <- lookupBindGroupOcc ctxt what rdr_name
        ; case mb_name of
-           Left err   -> do { addErr err; return (mkUnboundName rdr_name) }
+           Left err   -> do { addErr err; return (mkUnboundNameRdr rdr_name) }
            Right name -> return name }
 
 lookupBindGroupOcc :: HsSigCtxt
@@ -1195,14 +1228,7 @@ lookupBindGroupOcc ctxt what rdr_name
       InstDeclCtxt ns  -> lookup_top (`elemNameSet` ns)
   where
     lookup_cls_op cls
-      = do { env <- getGlobalRdrEnv
-           ; let gres = lookupSubBndrGREs env (Just cls) rdr_name
-           ; case gres of
-               []      -> return (Left (unknownSubordinateErr doc rdr_name))
-               (gre:_) -> return (Right (gre_name gre)) }
-                        -- If there is more than one local GRE for the
-                        -- same OccName 'f', that will be reported separately
-                        -- as a duplicate top-level binding for 'f'
+      = lookupSubBndrOcc True cls doc rdr_name
       where
         doc = ptext (sLit "method of class") <+> quotes (ppr cls)
 
@@ -1640,7 +1666,7 @@ unboundNameX where_look rdr_name extra
                   ; let suggestions = unknownNameSuggestions_ where_look
                                         dflags global_env local_env impInfo rdr_name
                   ; addErr (err $$ suggestions) }
-        ; return (mkUnboundName rdr_name) }
+        ; return (mkUnboundNameRdr rdr_name) }
 
 unknownNameErr :: SDoc -> RdrName -> SDoc
 unknownNameErr what rdr_name
@@ -2108,6 +2134,7 @@ data HsDocContext
   | TyDataCtx (Located RdrName)
   | TySynCtx (Located RdrName)
   | TyFamilyCtx (Located RdrName)
+  | FamPatCtx (Located RdrName)    -- The patterns of a type/data family instance
   | ConDeclCtx [Located RdrName]
   | ClassDeclCtx (Located RdrName)
   | ExprWithTySigCtx
@@ -2119,29 +2146,37 @@ data HsDocContext
   | VectDeclCtx (Located RdrName)
   | GenericCtx SDoc   -- Maybe we want to use this more!
 
-docOfHsDocContext :: HsDocContext -> SDoc
-docOfHsDocContext (GenericCtx doc) = doc
-docOfHsDocContext (TypeSigCtx doc) = text "In the type signature for" <+> doc
-docOfHsDocContext PatCtx = text "In a pattern type-signature"
-docOfHsDocContext SpecInstSigCtx = text "In a SPECIALISE instance pragma"
-docOfHsDocContext DefaultDeclCtx = text "In a `default' declaration"
-docOfHsDocContext (ForeignDeclCtx name) = ptext (sLit "In the foreign declaration for") <+> ppr name
-docOfHsDocContext DerivDeclCtx = text "In a deriving declaration"
-docOfHsDocContext (RuleCtx name) = text "In the transformation rule" <+> ftext name
-docOfHsDocContext (TyDataCtx tycon) = text "In the data type declaration for" <+> quotes (ppr tycon)
-docOfHsDocContext (TySynCtx name) = text "In the declaration for type synonym" <+> quotes (ppr name)
-docOfHsDocContext (TyFamilyCtx name) = text "In the declaration for type family" <+> quotes (ppr name)
-
-docOfHsDocContext (ConDeclCtx [name])
-   = text "In the definition of data constructor" <+> quotes (ppr name)
-docOfHsDocContext (ConDeclCtx names)
-   = text "In the definition of data constructors" <+> interpp'SP names
-
-docOfHsDocContext (ClassDeclCtx name) = text "In the declaration for class"     <+> ppr name
-docOfHsDocContext ExprWithTySigCtx = text "In an expression type signature"
-docOfHsDocContext TypBrCtx = ptext (sLit "In a Template-Haskell quoted type")
-docOfHsDocContext HsTypeCtx = text "In a type argument"
-docOfHsDocContext GHCiCtx = ptext (sLit "In GHCi input")
-docOfHsDocContext (SpliceTypeCtx hs_ty) = ptext (sLit "In the spliced type") <+> ppr hs_ty
-docOfHsDocContext ClassInstanceCtx = ptext (sLit "TcSplice.reifyInstances")
-docOfHsDocContext (VectDeclCtx tycon) = ptext (sLit "In the VECTORISE pragma for type constructor") <+> quotes (ppr tycon)
+withHsDocContext :: HsDocContext -> SDoc -> SDoc
+withHsDocContext ctxt doc = doc $$ inHsDocContext ctxt
+
+inHsDocContext :: HsDocContext -> SDoc
+inHsDocContext ctxt = ptext (sLit "In") <+> pprHsDocContext ctxt
+
+pprHsDocContext :: HsDocContext -> SDoc
+pprHsDocContext (GenericCtx doc)      = doc
+pprHsDocContext (TypeSigCtx doc)      = text "the type signature for" <+> doc
+pprHsDocContext PatCtx                = text "a pattern type-signature"
+pprHsDocContext SpecInstSigCtx        = text "a SPECIALISE instance pragma"
+pprHsDocContext DefaultDeclCtx        = text "a `default' declaration"
+pprHsDocContext DerivDeclCtx          = text "a deriving declaration"
+pprHsDocContext (RuleCtx name)        = text "the transformation rule" <+> ftext name
+pprHsDocContext (TyDataCtx tycon)     = text "the data type declaration for" <+> quotes (ppr tycon)
+pprHsDocContext (FamPatCtx tycon)     = text "a type pattern of family instance for" <+> quotes (ppr tycon)
+pprHsDocContext (TySynCtx name)       = text "the declaration for type synonym" <+> quotes (ppr name)
+pprHsDocContext (TyFamilyCtx name)    = text "the declaration for type family" <+> quotes (ppr name)
+pprHsDocContext (ClassDeclCtx name)   = text "the declaration for class" <+> quotes (ppr name)
+pprHsDocContext ExprWithTySigCtx      = text "an expression type signature"
+pprHsDocContext TypBrCtx              = text "a Template-Haskell quoted type"
+pprHsDocContext HsTypeCtx             = text "a type argument"
+pprHsDocContext GHCiCtx               = text "GHCi input"
+pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr hs_ty)
+pprHsDocContext ClassInstanceCtx      = text "TcSplice.reifyInstances"
+
+pprHsDocContext (ForeignDeclCtx name)
+   = ptext (sLit "the foreign declaration for") <+> quotes (ppr name)
+pprHsDocContext (ConDeclCtx [name])
+   = text "the definition of data constructor" <+> quotes (ppr name)
+pprHsDocContext (ConDeclCtx names)
+   = text "the definition of data constructors" <+> interpp'SP names
+pprHsDocContext (VectDeclCtx tycon)
+   = ptext (sLit "the VECTORISE pragma for type constructor") <+> quotes (ppr tycon)
index 31ef55c..035b4db 100644 (file)
@@ -255,12 +255,19 @@ rnExpr (ExplicitTuple tup_args boxity)
     rnTupArg (L l (Missing _)) = return (L l (Missing placeHolderType)
                                         , emptyFVs)
 
-rnExpr (RecordCon { rcon_con_name = con_id, rcon_flds = rbinds })
-  = do  { conname <- lookupLocatedOccRn con_id
-        ; (rbinds', fvRbinds) <- rnHsRecBinds (HsRecFieldCon (unLoc conname)) rbinds
-        ; return (RecordCon { rcon_con_name = conname, rcon_flds = rbinds'
-                            , rcon_con_expr = noPostTcExpr, rcon_con_like = PlaceHolder },
-                  fvRbinds `addOneFV` unLoc conname ) }
+rnExpr (RecordCon { rcon_con_name = con_id
+                  , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) })
+  = do { con_lname@(L _ con_name) <- lookupLocatedOccRn con_id
+       ; (flds, fvs)   <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds
+       ; (flds', fvss) <- mapAndUnzipM rn_field flds
+       ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd }
+       ; return (RecordCon { rcon_con_name = con_lname, rcon_flds = rec_binds'
+                           , 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)
+    rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
+                            ; return (L l (fld { hsRecFieldArg = arg' }), fvs) }
 
 rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds })
   = do  { (expr', fvExpr) <- rnLExpr expr
@@ -270,11 +277,11 @@ rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds })
                             , rupd_out_tys = PlaceHolder, rupd_wrap   = PlaceHolder }
                  , fvExpr `plusFV` fvRbinds) }
 
-rnExpr (ExprWithTySig expr pty PlaceHolder)
-  = do  { (pty', fvTy, wcs) <- rnLHsTypeWithWildCards ExprWithTySigCtx pty
-        ; (expr', fvExpr)   <- bindSigTyVarsFV (hsExplicitTvs pty') $
-                               rnLExpr expr
-        ; return (ExprWithTySig expr' pty' wcs, fvExpr `plusFV` fvTy) }
+rnExpr (ExprWithTySig expr pty)
+  = do  { (pty', fvTy)    <- rnHsSigWcType ExprWithTySigCtx pty
+        ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $
+                             rnLExpr expr
+        ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
 
 rnExpr (HsIf _ p b1 b2)
   = do { (p', fvP) <- rnLExpr p
@@ -417,26 +424,6 @@ rnSection other = pprPanic "rnSection" (ppr other)
 {-
 ************************************************************************
 *                                                                      *
-        Records
-*                                                                      *
-************************************************************************
--}
-
-rnHsRecBinds :: HsRecFieldContext -> HsRecordBinds RdrName
-             -> RnM (HsRecordBinds Name, FreeVars)
-rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd })
-  = do { (flds, fvs) <- rnHsRecFields ctxt mkHsVar rec_binds
-       ; (flds', fvss) <- mapAndUnzipM rn_field flds
-       ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd },
-                 fvs `plusFV` plusFVs fvss) }
-  where
-    mkHsVar l n = HsVar (L l n)
-    rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
-                            ; return (L l (fld { hsRecFieldArg = arg' }), fvs) }
-
-{-
-************************************************************************
-*                                                                      *
         Arrow commands
 *                                                                      *
 ************************************************************************
index 32f0f94..b0b79f5 100644 (file)
@@ -541,7 +541,7 @@ getLocalNonValBinders fixity_env
   = do  { -- Process all type/class decls *except* family instances
         ; overload_ok <- xoptM Opt_DuplicateRecordFields
         ; (tc_avails, tc_fldss) <- fmap unzip $ mapM (new_tc overload_ok)
-                                                    (tyClGroupConcat tycl_decls)
+                                                     (tyClGroupConcat tycl_decls)
         ; traceRn (text "getLocalNonValBinders 1" <+> ppr tc_avails)
         ; envs <- extendGlobalRdrEnvRn tc_avails fixity_env
         ; setEnvs envs $ do {
@@ -573,6 +573,7 @@ getLocalNonValBinders fixity_env
         ; let field_env = extendNameEnvList (tcg_field_env tcg_env) flds
               envs      = (tcg_env { tcg_field_env = field_env }, tcl_env)
 
+        ; traceRn (text "getLocalNonValBinders 3" <+> vcat [ppr flds, ppr field_env])
         ; return (envs, new_bndrs) } }
   where
     ValBindsIn _val_binds val_sigs = binds
@@ -583,7 +584,7 @@ getLocalNonValBinders fixity_env
     -- In a hs-boot file, the value binders come from the
     --  *signatures*, and there should be no foreign binders
     hs_boot_sig_bndrs = [ L decl_loc (unLoc n)
-                        | L decl_loc (TypeSig ns _ _) <- val_sigs, n <- ns]
+                        | L decl_loc (TypeSig ns _) <- val_sigs, n <- ns]
 
       -- the SrcSpan attached to the input should be the span of the
       -- declaration, not just the name
@@ -636,8 +637,7 @@ getLocalNonValBinders fixity_env
            ; return ([avail], flds) }
     new_assoc overload_ok (L _ (ClsInstD (ClsInstDecl { cid_poly_ty = inst_ty
                                                       , cid_datafam_insts = adts })))
-      | Just (_, _, L loc cls_rdr, _) <-
-                   splitLHsInstDeclTy_maybe (flattenTopLevelLHsForAllTy inst_ty)
+      | Just (L loc cls_rdr) <- getLHsInstDeclClass_maybe inst_ty
       = do { cls_nm <- setSrcSpan loc $ lookupGlobalOccRn cls_rdr
            ; (avails, fldss)
                     <- mapAndUnzipM (new_loc_di overload_ok (Just cls_nm)) adts
index 9aee561..77f08f4 100644 (file)
@@ -206,10 +206,8 @@ matchNameMaker ctxt = LamMk report_unused
                       ThPatQuote            -> False
                       _                     -> True
 
-rnHsSigCps :: HsWithBndrs RdrName (LHsType RdrName)
-           -> CpsRn (HsWithBndrs Name (LHsType Name))
-rnHsSigCps sig
-  = CpsRn (rnHsBndrSig PatCtx sig)
+rnHsSigCps :: LHsSigWcType RdrName -> CpsRn (LHsSigWcType Name)
+rnHsSigCps sig = CpsRn (rnHsSigWcTypeScoped PatCtx sig)
 
 newPatLName :: NameMaker -> Located RdrName -> CpsRn (Located Name)
 newPatLName name_maker rdr_name@(L loc _)
@@ -560,7 +558,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
     rn_fld pun_ok parent (L l (HsRecField { hsRecFieldLbl = L loc (FieldOcc lbl _)
                                           , hsRecFieldArg = arg
                                           , hsRecPun      = pun }))
-      = do { sel <- setSrcSpan loc $ lookupSubBndrOcc True parent doc lbl
+      = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent doc lbl
            ; arg' <- if pun
                      then do { checkErr pun_ok (badPun (L loc lbl))
                              ; return (L loc (mk_arg loc lbl)) }
@@ -683,7 +681,7 @@ rnHsRecUpdFields flds
                                       Nothing -> do { addErr (unknownSubordinateErr doc lbl)
                                                     ; return (Right []) }
                                       Just r  -> return r }
-                          else fmap Left $ lookupSubBndrOcc True Nothing doc lbl
+                          else fmap Left $ lookupGlobalOccRn lbl
            ; arg' <- if pun
                      then do { checkErr pun_ok (badPun (L loc lbl))
                              ; return (L loc (HsVar (L loc lbl))) }
index 1b234bd..2fbbea4 100644 (file)
@@ -31,8 +31,7 @@ import Module
 import HscTypes         ( Warnings(..), plusWarns )
 import Class            ( FunDep )
 import PrelNames        ( applicativeClassName, pureAName, thenAName
-                        , monadClassName, returnMName, thenMName
-                        , isUnboundName )
+                        , monadClassName, returnMName, thenMName )
 import Name
 import NameSet
 import NameEnv
@@ -389,21 +388,26 @@ rnDefaultDecl (DefaultDecl tys)
 -}
 
 rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars)
-rnHsForeignDecl (ForeignImport name ty _ spec)
+rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec })
   = do { topEnv :: HscEnv <- getTopEnv
        ; name' <- lookupLocatedTopBndrRn name
-       ; (ty', fvs) <- rnLHsType (ForeignDeclCtx name) ty
+       ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty
 
         -- Mark any PackageTarget style imports as coming from the current package
        ; let unitId = thisPackage $ hsc_dflags topEnv
              spec'      = patchForeignImport unitId spec
 
-       ; return (ForeignImport name' ty' noForeignImportCoercionYet spec', fvs) }
+       ; return (ForeignImport { fd_name = name', fd_sig_ty = ty'
+                               , fd_co = noForeignImportCoercionYet
+                               , fd_fi = spec' }, fvs) }
 
-rnHsForeignDecl (ForeignExport name ty _ spec)
+rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec })
   = do { name' <- lookupLocatedOccRn name
-       ; (ty', fvs) <- rnLHsType (ForeignDeclCtx name) ty
-       ; return (ForeignExport name' ty' noForeignExportCoercionYet spec, fvs `addOneFV` unLoc name') }
+       ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty
+       ; return (ForeignExport { fd_name = name', fd_sig_ty = ty'
+                               , fd_co = noForeignExportCoercionYet
+                               , fd_fe = spec }
+                , fvs `addOneFV` unLoc name') }
         -- NB: a foreign export is an *occurrence site* for name, so
         --     we add it to the free-variable list.  It might, for example,
         --     be imported from another module
@@ -464,7 +468,7 @@ rnSrcInstDecl (ClsInstD { cid_inst = cid })
 --  * Warn if 'pure' is defined backwards (i.e. @pure = return@).
 --  * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@).
 --
-checkCanonicalMonadInstances :: Name -> LHsType Name -> LHsBinds Name -> RnM ()
+checkCanonicalMonadInstances :: Name -> LHsSigType Name -> LHsBinds Name -> RnM ()
 checkCanonicalMonadInstances cls poly_ty mbinds
   | cls == applicativeClassName  = do
       forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
@@ -524,11 +528,10 @@ checkCanonicalMonadInstances cls poly_ty mbinds
                        ]
 
     -- stolen from TcInstDcls
-    instDeclCtxt1 :: LHsType Name -> SDoc
+    instDeclCtxt1 :: LHsSigType Name -> SDoc
     instDeclCtxt1 hs_inst_ty
-      = inst_decl_ctxt (case unLoc hs_inst_ty of
-                        HsForAllTy _ _ _ _ (L _ ty') -> ppr ty'
-                        _                            -> ppr hs_inst_ty)
+      | (_, _, head_ty) <- splitLHsInstDeclTy hs_inst_ty
+      = inst_decl_ctxt (ppr head_ty)
 
     inst_decl_ctxt :: SDoc -> SDoc
     inst_decl_ctxt doc = hang (ptext (sLit "in the instance declaration for"))
@@ -540,23 +543,19 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
                            , cid_sigs = uprags, cid_tyfam_insts = ats
                            , cid_overlap_mode = oflag
                            , cid_datafam_insts = adts })
-        -- Used for both source and interface file decls
-  = do { (inst_ty', inst_fvs) <- rnLHsInstType (text "In an instance declaration") inst_ty
-       ; case splitLHsInstDeclTy_maybe inst_ty' of {
-           Nothing -> return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = emptyLHsBinds
-                                          , cid_sigs = [], cid_tyfam_insts = []
-                                          , cid_overlap_mode = oflag
-                                          , cid_datafam_insts = [] }
-                             , inst_fvs) ;
-           Just (inst_tyvars, _, L _ cls,_) ->
-
-    do { let ktv_names = hsLKiTyVarNames inst_tyvars
-
-        -- Rename the bindings
-        -- The typechecker (not the renamer) checks that all
-        -- the bindings are for the right class
-        -- (Slightly strangely) when scoped type variables are on, the
-        -- forall-d tyvars scope over the method bindings too
+  = do { (inst_ty', inst_fvs) <- rnLHsInstType (text "an instance declaration") inst_ty
+       ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty'
+       ; let cls = case splitLHsClassTy_maybe head_ty' of
+                     Nothing -> mkUnboundName (mkTcOccFS (fsLit "<class>"))
+                     Just (L _ cls, _) -> cls
+                     -- rnLHsInstType has added an error message
+                     -- if splitLHsClassTy_maybe fails
+
+          -- Rename the bindings
+          -- The typechecker (not the renamer) checks that all
+          -- the bindings are for the right class
+          -- (Slightly strangely) when scoped type variables are on, the
+          -- forall-d tyvars scope over the method bindings too
        ; (mbinds', uprags', meth_fvs) <- rnMethodBinds False cls ktv_names mbinds uprags
 
        ; whenWOptM Opt_WarnNonCanonicalMonadInstances $
@@ -564,11 +563,11 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
 
        -- Rename the associated types, and type signatures
        -- Both need to have the instance type variables in scope
-       ; traceRn (text "rnSrcInstDecl"  <+> ppr inst_ty' $$ ppr inst_tyvars $$ ppr ktv_names)
+       ; traceRn (text "rnSrcInstDecl"  <+> ppr inst_ty' $$ ppr ktv_names)
        ; ((ats', adts'), more_fvs)
              <- extendTyVarEnvFVRn ktv_names $
-                do { (ats',  at_fvs)  <- rnATInstDecls rnTyFamInstDecl cls inst_tyvars ats
-                   ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls inst_tyvars adts
+                do { (ats',  at_fvs)  <- rnATInstDecls rnTyFamInstDecl cls ktv_names ats
+                   ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls ktv_names adts
                    ; return ( (ats', adts'), at_fvs `plusFV` adt_fvs) }
 
        ; let all_fvs = meth_fvs `plusFV` more_fvs
@@ -577,7 +576,7 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
                              , cid_sigs = uprags', cid_tyfam_insts = ats'
                              , cid_overlap_mode = oflag
                              , cid_datafam_insts = adts' },
-                 all_fvs) } } }
+                 all_fvs) }
              -- We return the renamed associated data type declarations so
              -- that they can be entered into the list of type declarations
              -- for the binding group, but we also keep a copy in the instance.
@@ -592,12 +591,11 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
 rnFamInstDecl :: HsDocContext
               -> Maybe (Name, [Name])
               -> Located RdrName
-              -> [LHsType RdrName]
+              -> HsTyPats RdrName
               -> rhs
               -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
-              -> RnM (Located Name, HsWithBndrs Name [LHsType Name], rhs',
-                      FreeVars)
-rnFamInstDecl doc mb_cls tycon pats payload rnPayload
+              -> RnM (Located Name, HsTyPats Name, rhs', FreeVars)
+rnFamInstDecl doc mb_cls tycon (HsIB { hsib_body = pats }) payload rnPayload
   = do { tycon'   <- lookupFamInstName (fmap fst mb_cls) tycon
        ; let loc = case pats of
                      []             -> pprPanic "rnFamInstDecl" (ppr tycon)
@@ -605,7 +603,6 @@ rnFamInstDecl doc mb_cls tycon pats payload rnPayload
                      (L loc _ : ps) -> combineSrcSpans loc (getLoc (last ps))
              (kv_rdr_names, tv_rdr_names) = extractHsTysRdrTyVars pats
 
-
        ; rdr_env  <- getLocalRdrEnv
        ; kv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) kv_rdr_names
        ; tv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) tv_rdr_names
@@ -614,7 +611,7 @@ rnFamInstDecl doc mb_cls tycon pats payload rnPayload
        ; ((pats', payload'), fvs)
               <- bindLocalNamesFV kv_names $
                  bindLocalNamesFV tv_names $
-                 do { (pats', pat_fvs) <- rnLHsTypes doc pats
+                 do { (pats', pat_fvs)    <- rnLHsTypes (FamPatCtx tycon) pats
                     ; (payload', rhs_fvs) <- rnPayload doc payload
 
                          -- See Note [Renaming associated types]
@@ -631,19 +628,12 @@ rnFamInstDecl doc mb_cls tycon pats payload rnPayload
 
 
        ; let all_fvs = fvs `addOneFV` unLoc tycon'
-             awcs = concatMap collectAnonymousWildCardNames pats'
        ; return (tycon',
-                 HsWB { hswb_cts = pats', hswb_kvs = kv_names,
-                        hswb_tvs = tv_names, hswb_wcs = awcs },
+                 HsIB { hsib_body = pats'
+                      , hsib_kvs = kv_names, hsib_tvs = tv_names },
                  payload',
                  all_fvs) }
              -- type instance => use, hence addOneFV
-  where
-    collectAnonymousWildCardNames ty
-      = [ wildCardName wc
-        | L _ wc <- snd (collectWildCards ty)
-        , isAnonWildCard wc ]
-
 
 rnTyFamInstDecl :: Maybe (Name, [Name])
                 -> TyFamInstDecl RdrName
@@ -657,7 +647,7 @@ rnTyFamInstEqn :: Maybe (Name, [Name])
                -> TyFamInstEqn RdrName
                -> RnM (TyFamInstEqn Name, FreeVars)
 rnTyFamInstEqn mb_cls (TyFamEqn { tfe_tycon = tycon
-                                , tfe_pats  = HsWB { hswb_cts = pats }
+                                , tfe_pats  = pats
                                 , tfe_rhs   = rhs })
   = do { (tycon', pats', rhs', fvs) <-
            rnFamInstDecl (TySynCtx tycon) mb_cls tycon pats rhs rnTySyn
@@ -671,7 +661,7 @@ rnTyFamDefltEqn :: Name
 rnTyFamDefltEqn cls (TyFamEqn { tfe_tycon = tycon
                               , tfe_pats  = tyvars
                               , tfe_rhs   = rhs })
-  = bindHsTyVars ctx (Just cls) [] tyvars $ \ tyvars' ->
+  = bindHsQTyVars ctx (Just cls) [] tyvars $ \ tyvars' ->
     do { tycon'      <- lookupFamInstName (Just cls) tycon
        ; (rhs', fvs) <- rnLHsType ctx rhs
        ; return (TyFamEqn { tfe_tycon = tycon'
@@ -684,7 +674,7 @@ rnDataFamInstDecl :: Maybe (Name, [Name])
                   -> DataFamInstDecl RdrName
                   -> RnM (DataFamInstDecl Name, FreeVars)
 rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_tycon = tycon
-                                          , dfid_pats  = HsWB { hswb_cts = pats }
+                                          , dfid_pats  = pats
                                           , dfid_defn  = defn })
   = do { (tycon', pats', defn', fvs) <-
            rnFamInstDecl (TyDataCtx tycon) mb_cls tycon pats defn rnDataDefn
@@ -706,7 +696,7 @@ rnATInstDecls :: (Maybe (Name, [Name]) ->    -- The function that renames
                   decl RdrName ->            -- an instance. rnTyFamInstDecl
                   RnM (decl Name, FreeVars)) -- or rnDataFamInstDecl
               -> Name      -- Class
-              -> LHsTyVarBndrs Name
+              -> [Name]
               -> [Located (decl RdrName)]
               -> RnM ([Located (decl Name)], FreeVars)
 -- Used for data and type family defaults in a class decl
@@ -714,10 +704,8 @@ rnATInstDecls :: (Maybe (Name, [Name]) ->    -- The function that renames
 --
 -- NB: We allow duplicate associated-type decls;
 --     See Note [Associated type instances] in TcInstDcls
-rnATInstDecls rnFun cls hs_tvs at_insts
+rnATInstDecls rnFun cls tv_ns at_insts
   = rnList (rnFun (Just (cls, tv_ns))) at_insts
-  where
-    tv_ns = hsLKiTyVarNames hs_tvs
     -- See Note [Renaming associated types]
 
 {-
@@ -813,7 +801,7 @@ bindHsRuleVars rule_name vars names thing_inside
         thing_inside (L l (RuleBndr (L loc n)) : vars')
 
     go (L l (RuleBndrSig (L loc _) bsig) : vars) (n : ns) thing_inside
-      = rnHsBndrSig doc bsig $ \ bsig' ->
+      = rnHsSigWcTypeScoped doc bsig $ \ bsig' ->
         go vars ns $ \ vars' ->
         thing_inside (L l (RuleBndrSig (L loc n) bsig') : vars')
 
@@ -940,7 +928,7 @@ rnHsVectDecl (HsVectClassIn s cls)
 rnHsVectDecl (HsVectClassOut _)
   = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'"
 rnHsVectDecl (HsVectInstIn instTy)
-  = do { (instTy', fvs) <- rnLHsInstType (text "In a VECTORISE pragma") instTy
+  = do { (instTy', fvs) <- rnLHsInstType (text "a VECTORISE pragma") instTy
        ; return (HsVectInstIn instTy', fvs)
        }
 rnHsVectDecl (HsVectInstOut _)
@@ -1082,7 +1070,7 @@ rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdRhs = rhs })
        ; let kvs = fst (extractHsTyRdrTyVars rhs)
              doc = TySynCtx tycon
        ; traceRn (text "rntycl-ty" <+> ppr tycon <+> ppr kvs)
-       ; ((tyvars', rhs'), fvs) <- bindHsTyVars doc Nothing kvs tyvars $
+       ; ((tyvars', rhs'), fvs) <- bindHsQTyVars doc Nothing kvs tyvars $
                                     \ tyvars' ->
                                     do { (rhs', fvs) <- rnTySyn doc rhs
                                        ; return ((tyvars', rhs'), fvs) }
@@ -1096,17 +1084,16 @@ rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdDataDefn = defn
        ; let kvs = extractDataDefnKindVars defn
              doc = TyDataCtx tycon
        ; traceRn (text "rntycl-data" <+> ppr tycon <+> ppr kvs)
-       ; ((tyvars', defn'), fvs) <-
-                      bindHsTyVars doc Nothing kvs tyvars $ \ tyvars' ->
+       ; ((tyvars', defn'), fvs) <- bindHsQTyVars doc Nothing kvs tyvars $ \ tyvars' ->
                                     do { (defn', fvs) <- rnDataDefn doc defn
                                        ; return ((tyvars', defn'), fvs) }
        ; return (DataDecl { tcdLName = tycon', tcdTyVars = tyvars'
                           , tcdDataDefn = defn', tcdFVs = fvs }, fvs) }
 
-rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = lcls,
-                              tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
-                              tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,
-                              tcdDocs = docs})
+rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
+                        tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
+                        tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,
+                        tcdDocs = docs})
   = do  { lcls' <- lookupLocatedTopBndrRn lcls
         ; let cls' = unLoc lcls'
               kvs = []  -- No scoped kind vars except those in
@@ -1114,7 +1101,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = lcls,
 
         -- Tyvars scope over superclass context and method signatures
         ; ((tyvars', context', fds', ats'), stuff_fvs)
-            <- bindHsTyVars cls_doc Nothing kvs tyvars $ \ tyvars' -> do
+            <- bindHsQTyVars cls_doc Nothing kvs tyvars $ \ tyvars' -> do
                   -- Checks for distinct tyvars
              { (context', cxt_fvs) <- rnContext cls_doc context
              ; fds'  <- rnFds fds
@@ -1131,7 +1118,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 _ (TypeSig ops _ _) <- sigs, op <- ops]
+        ; let sig_rdr_names_w_locs = [op | L _ (ClassOpSig False ops _) <- sigs
+                                         , op <- ops]
         ; checkDupRdrNames sig_rdr_names_w_locs
                 -- Typechecker is responsible for checking that we only
                 -- give default-method bindings for things in this class.
@@ -1257,9 +1245,11 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
                      L _ (ConDecl { con_res = ResTyGADT {} }) : _  -> False
                      _                                             -> True
 
-    rn_derivs Nothing   = return (Nothing, emptyFVs)
-    rn_derivs (Just (L ld ds)) = do { (ds', fvs) <- rnLHsTypes doc ds
-                                    ; return (Just (L ld ds'), fvs) }
+    rn_derivs Nothing
+      = return (Nothing, emptyFVs)
+    rn_derivs (Just (L loc ds))
+      = do { (ds', fvs) <- mapFvRn (rnHsSigType doc) ds
+           ; return (Just (L loc ds'), fvs) }
 
 badGadtStupidTheta :: HsDocContext -> SDoc
 badGadtStupidTheta _
@@ -1276,7 +1266,7 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
                              , fdInjectivityAnn = injectivity })
   = do { tycon' <- lookupLocatedTopBndrRn tycon
        ; ((tyvars', res_sig', injectivity'), fv1) <-
-            bindHsTyVars doc mb_cls kvs tyvars $ \ tyvars' ->
+            bindHsQTyVars doc mb_cls kvs tyvars $ \ tyvars' ->
             do { (res_sig', fv_kind) <- wrapLocFstM (rnFamResultSig doc) res_sig
                ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig')
                                           injectivity
@@ -1369,7 +1359,7 @@ rnFamResultSig doc (TyVarSig tvbndr)
 -- | Rename injectivity annotation. Note that injectivity annotation is just the
 -- part after the "|".  Everything that appears before it is renamed in
 -- rnFamDecl.
-rnInjectivityAnn :: LHsTyVarBndrs Name         -- ^ Type variables declared in
+rnInjectivityAnn :: LHsQTyVars Name            -- ^ Type variables declared in
                                                --   type family head
                  -> LFamilyResultSig Name      -- ^ Result signature
                  -> LInjectivityAnn RdrName    -- ^ Injectivity annotation
@@ -1382,8 +1372,8 @@ rnInjectivityAnn tvBndrs (L _ (TyVarSig resTv))
              bindLocalNames [hsLTyVarName resTv] $
              -- The return type variable scopes over the injectivity annotation
              -- e.g.   type family F a = (r::*) | r -> a
-             do { injFrom' <- rnLTyVar True injFrom
-                ; injTo'   <- mapM (rnLTyVar True) injTo
+             do { injFrom' <- rnLTyVar injFrom
+                ; injTo'   <- mapM rnLTyVar injTo
                 ; return $ L srcSpan (InjectivityAnn injFrom' injTo') }
 
    ; let tvNames  = Set.fromList $ hsLKiTyVarNames tvBndrs
@@ -1423,8 +1413,8 @@ rnInjectivityAnn tvBndrs (L _ (TyVarSig resTv))
 rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn injFrom injTo)) =
    setSrcSpan srcSpan $ do
    (injDecl', _) <- askNoErrs $ do
-     injFrom' <- rnLTyVar True injFrom
-     injTo'   <- mapM (rnLTyVar True) injTo
+     injFrom' <- rnLTyVar injFrom
+     injTo'   <- mapM rnLTyVar injTo
      return $ L srcSpan (InjectivityAnn injFrom' injTo')
    return $ injDecl'
 
@@ -1516,6 +1506,29 @@ modules), we get better error messages, too.
 \subsection{Support code for type/data declarations}
 *                                                      *
 *********************************************************
+
+Note [Quantification in data constructor declarations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Four cases, afer renaming
+  * ResTyH98
+     - data T a = forall b. MkT { x :: b -> a }
+       The 'b' is explicitly declared;
+       con_qvars = [b]
+
+     - data T a = MkT { x :: a -> b }
+       Do *not* implicitly quantify over 'b'; it is
+       simply out of scope.  con_qvars = []
+
+  * ResTyGADT
+     - data T a where { MkT :: forall b. (b -> a) -> T a }
+       con_qvars = [a,b]
+
+     - data T a where { MkT :: (b -> a) -> T a }
+       con_qvars = [a,b], by implicit quantification
+                          of the type signature
+       It is uncomfortable that we add implicitly-bound
+       type variables to the HsQTyVars, which usually
+       only has explicitly-bound type variables
 -}
 
 ---------------
@@ -1530,49 +1543,53 @@ rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars)
 rnConDecls = mapFvRn (wrapLocFstM rnConDecl)
 
 rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name, FreeVars)
-rnConDecl decl@(ConDecl { con_names = names, con_qvars = tvs
+rnConDecl decl@(ConDecl { con_names = names, con_qvars = qtvs
                         , con_cxt = lcxt@(L loc cxt), con_details = details
                         , con_res = res_ty, con_doc = mb_doc
-                        , con_explicit = expl })
+                        , con_explicit = explicit })
   = do  { mapM_ (addLocM checkConName) names
-        ; new_names <- mapM lookupLocatedTopBndrRn names
-
-           -- For H98 syntax, the tvs are the existential ones
-           -- For GADT syntax, the tvs are all the quantified tyvars
-           -- Hence the 'filter' in the ResTyH98 case only
-        ; rdr_env <- getLocalRdrEnv
-        ; let arg_tys    = hsConDeclArgTys details
-              (free_kvs, free_tvs) = case res_ty of
-                ResTyH98 -> filterInScope rdr_env (get_rdr_tvs arg_tys)
-                ResTyGADT _ ty -> get_rdr_tvs (ty : arg_tys)
-
-         -- With an Explicit forall, check for unused binders
-         -- With Implicit, find the mentioned ones, and use them as binders
-         -- With Qualified, do the same as with Implicit, but give a warning
-         --   See Note [Context quantification]
-        ; new_tvs <- case expl of
-                       Implicit -> return (mkHsQTvs (userHsTyVarBndrs loc free_tvs))
-                       Qualified -> do { warnContextQuantification (docOfHsDocContext doc)
-                                                                   (userHsTyVarBndrs loc free_tvs)
-                                       ; return (mkHsQTvs (userHsTyVarBndrs loc free_tvs)) }
-                       Explicit -> do { warnUnusedForAlls (docOfHsDocContext doc) tvs free_tvs
-                                      ; return tvs }
-
-        ; mb_doc' <- rnMbLHsDoc mb_doc
-
-        ; bindHsTyVars doc Nothing free_kvs new_tvs $ \new_tyvars -> do
+        ; new_names    <- mapM lookupLocatedTopBndrRn names
+        ; mb_doc'      <- rnMbLHsDoc mb_doc
+        ; let (kvs, qtvs') = get_con_qtvs qtvs (hsConDeclArgTys details) res_ty
+
+        ; bindHsQTyVars doc Nothing kvs qtvs' $ \new_tyvars -> do
         { (new_context, fvs1) <- rnContext doc lcxt
         ; (new_details, fvs2) <- rnConDeclDetails (unLoc $ head new_names) doc details
         ; (new_details', new_res_ty, fvs3)
                      <- rnConResult doc (map unLoc new_names) new_details res_ty
+        ; traceRn (text "rnConDecl" <+> ppr names <+> vcat
+             [ text "free_kvs:" <+> ppr kvs
+             , text "qtvs:" <+> ppr qtvs
+             , text "qtvs':" <+> ppr qtvs' ])
+        ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
+        ; warnUnusedForAlls (inHsDocContext doc) (hsQTvBndrs new_tyvars) all_fvs
         ; return (decl { con_names = new_names, con_qvars = new_tyvars
                        , con_cxt = new_context, con_details = new_details'
                        , con_res = new_res_ty, con_doc = mb_doc' },
-                  fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
+                  all_fvs) }}
  where
     doc = ConDeclCtx names
     get_rdr_tvs tys = extractHsTysRdrTyVars (cxt ++ tys)
 
+    get_con_qtvs :: LHsQTyVars RdrName -> [LHsType RdrName]
+                 -> ResType (LHsType RdrName)
+                 -> ([RdrName], LHsQTyVars RdrName)
+    get_con_qtvs qtvs arg_tys ResTyH98
+      | explicit   -- data T = forall a. MkT (a -> a)
+      = (free_kvs, qtvs)
+      | otherwise  -- data T = MkT (a -> a)
+      = ([], mkHsQTvs [])
+      where
+        (free_kvs, _) = get_rdr_tvs arg_tys
+
+    get_con_qtvs qtvs arg_tys (ResTyGADT _ ty)
+      | explicit  -- data T x where { MkT :: forall a. a -> T a }
+      = (free_kvs, qtvs)
+      | otherwise -- data T x where { MkT :: a -> T a }
+      = (free_kvs, mkHsQTvs (userHsTyVarBndrs loc free_tvs))
+      where
+        (free_kvs, free_tvs) = get_rdr_tvs (ty : arg_tys)
+
 rnConResult :: HsDocContext -> [Name]
             -> HsConDetails (LHsType Name) (Located [LConDeclField Name])
             -> ResType (LHsType RdrName)
@@ -1591,7 +1608,7 @@ rnConResult doc _con details (ResTyGADT ls ty)
            -- See Note [Sorting out the result type] in RdrHsSyn
 
            RecCon {}    -> do { unless (null arg_tys)
-                                       (addErr (badRecResTy (docOfHsDocContext doc)))
+                                       (addErr (badRecResTy doc))
                               ; return (details, ResTyGADT ls res_ty, fvs) }
 
            PrefixCon {} -> return (PrefixCon arg_tys, ResTyGADT ls res_ty, fvs)}
@@ -1618,8 +1635,9 @@ rnConDeclDetails con doc (RecCon (L l fields))
         ; return (RecCon (L l new_fields), fvs) }
 
 -------------------------------------------------
-badRecResTy :: SDoc -> SDoc
-badRecResTy doc = ptext (sLit "Malformed constructor signature") $$ doc
+badRecResTy :: HsDocContext -> SDoc
+badRecResTy ctxt = withHsDocContext ctxt $
+                   ptext (sLit "Malformed constructor signature")
 
 -- | Brings pattern synonym names and also pattern synonym selectors
 -- from record pattern synonyms into scope.
index 2093312..3c7695b 100644 (file)
@@ -33,7 +33,6 @@ import Control.Monad    ( unless, when )
 
 import {-# SOURCE #-} RnExpr   ( rnLExpr )
 
-import PrelNames        ( isUnboundName )
 import TcEnv            ( checkWellStaged )
 import THNames          ( liftName )
 
@@ -45,7 +44,6 @@ import Hooks
 import Var              ( Id )
 import THNames          ( quoteExpName, quotePatName, quoteDecName, quoteTypeName
                         , decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, )
-import RnTypes          ( collectWildCards )
 
 import {-# SOURCE #-} TcExpr   ( tcMonoExpr )
 import {-# SOURCE #-} TcSplice ( runMetaD, runMetaE, runMetaP, runMetaT, tcTopSpliceExpr )
@@ -421,20 +419,19 @@ rnSpliceType splice k
       = do { traceRn (text "rnSpliceType: untyped type splice")
            ; hs_ty2 <- runRnSplice UntypedTypeSplice runMetaT ppr rn_splice
            ; (hs_ty3, fvs) <- do { let doc = SpliceTypeCtx hs_ty2
-                                 ; checkValidPartialTypeSplice doc hs_ty2
-                                    -- See Note [Partial Type Splices]
                                  ; checkNoErrs $ rnLHsType doc hs_ty2 }
                                     -- checkNoErrs: see Note [Renamer errors]
            ; return (HsParTy hs_ty3, fvs) }
               -- Wrap the result of the splice in parens so that we don't
               -- lose the outermost location set by runQuasiQuote (#7918)
-{-
-Note [Partial Type Splices]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
+{- Note [Partial Type Splices]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Partial Type Signatures are partially supported in TH type splices: only
 anonymous wild cards are allowed.
 
+  -- ToDo: SLPJ says: I don't understand all this
+
 Normally, named wild cards are collected before renaming a (partial) type
 signature. However, TH type splices are run during renaming, i.e. after the
 initial traversal, leading to out of scope errors for named wild cards. We
@@ -454,7 +451,7 @@ are given names during renaming. These names are collected right after
 renaming. The names generated for anonymous wild cards in TH type splices will
 thus be collected as well.
 
-For more details about renaming wild cards, see rnLHsTypeWithWildCards.
+For more details about renaming wild cards, see RnTypes.rnHsSigWcType
 
 Note that partial type signatures are fully supported in TH declaration
 splices, e.g.:
@@ -463,28 +460,10 @@ splices, e.g.:
          foo x y = x == y |]
 
 This is because in this case, the partial type signature can be treated as a
-whole signature, instead of as an arbitray type.
+whole signature, instead of as an arbitrary type.
 
 -}
 
--- | Check that the type splice doesn't contain an extra-constraint wild card.
--- See Note [Partial Type Splices]. Named wild cards aren't supported in type
--- splices either, but they will be caught during renaming, as they won't be
--- in scope.
---
--- Note that without this check, an error would still be reported, but it
--- would tell the user an unexpected wild card was encountered. This message
--- is confusing, as it doesn't mention the wild card was unexpected because it
--- was an extra-constraints wild card. To avoid confusing, this function
--- provides a specific error message for this case.
-checkValidPartialTypeSplice :: HsDocContext -> LHsType RdrName -> RnM ()
-checkValidPartialTypeSplice doc ty
-  | (L loc _extraWc : _, _) <- collectWildCards ty
-  = failAt loc $ hang (text "Invalid partial type:") 2 (ppr ty) $$
-    text "An extra-constraints wild card is not allowed in a type splice" $$
-    docOfHsDocContext doc
-  | otherwise
-  = return ()
 
 ----------------------
 -- | Rename a splice pattern. See Note [rnSplicePat]
index 27c9fc8..49b707c 100644 (file)
@@ -11,20 +11,22 @@ module RnTypes (
         -- Type related stuff
         rnHsType, rnLHsType, rnLHsTypes, rnContext,
         rnHsKind, rnLHsKind, rnLHsMaybeKind,
-        rnHsSigType, rnLHsInstType, rnConDeclFields,
-        newTyVarNameRn, rnLHsTypeWithWildCards,
-        rnHsSigTypeWithWildCards, rnLTyVar, collectWildCards,
+        rnHsSigType, rnHsWcType,
+        rnHsSigWcType, rnHsSigWcTypeScoped,
+        rnLHsInstType,
+        newTyVarNameRn, collectAnonWildCards,
+        rnConDeclFields,
+        rnLTyVar, rnLHsTyVarBndr,
 
         -- Precence related stuff
         mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
         checkPrecMatch, checkSectionPrec,
 
         -- Binding related stuff
-        warnContextQuantification, warnUnusedForAlls,
-        bindSigTyVarsFV, bindHsTyVars, rnHsBndrSig, rnLHsTyVarBndr,
+        warnUnusedForAlls,
+        bindSigTyVarsFV, bindHsQTyVars,
         extractHsTyRdrTyVars, extractHsTysRdrTyVars,
-        extractRdrKindSigVars, extractDataDefnKindVars,
-        filterInScope
+        extractRdrKindSigVars, extractDataDefnKindVars
   ) where
 
 import {-# SOURCE #-} RnSplice( rnSpliceType )
@@ -35,7 +37,7 @@ import RnHsDoc          ( rnLHsDoc, rnMbLHsDoc )
 import RnEnv
 import TcRnMonad
 import RdrName
-import PrelNames
+import PrelNames        ( negateName, dot_tv_RDR, forall_tv_RDR )
 import TysPrim          ( funTyConName )
 import Name
 import SrcLoc
@@ -48,7 +50,7 @@ import BasicTypes       ( compareFixity, funTyFixity, negateFixity,
 import Outputable
 import FastString
 import Maybes
-import Data.List        ( nub, nubBy, deleteFirstsBy )
+import Data.List        ( nub, nubBy )
 import Control.Monad    ( unless, when )
 
 #if __GLASGOW_HASKELL__ < 709
@@ -62,32 +64,184 @@ These type renamers are in a separate module, rather than in (say) RnSource,
 to break several loop.
 
 *********************************************************
-*                                                      *
-\subsection{Renaming types}
-*                                                      *
+*                                                       *
+           HsSigWcType (i.e with wildcards)
+*                                                       *
 *********************************************************
 -}
 
-rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
-        -- rnHsSigType is used for source-language type signatures,
-        -- which use *implicit* universal quantification.
-rnHsSigType doc_str ty = rnLHsType (TypeSigCtx doc_str) ty
+rnHsSigWcType :: HsDocContext -> LHsSigWcType RdrName
+            -> RnM (LHsSigWcType Name, FreeVars)
+rnHsSigWcType doc sig_ty
+  = rn_hs_sig_wc_type True doc sig_ty $ \sig_ty' ->
+    return (sig_ty', emptyFVs)
+
+rnHsSigWcTypeScoped :: HsDocContext -> LHsSigWcType RdrName
+                    -> (LHsSigWcType Name -> RnM (a, FreeVars))
+                    -> RnM (a, FreeVars)
+-- Used for
+--   - Signatures on binders in a RULE
+--   - Pattern type signatures
+-- Wildcards are allowed
+rnHsSigWcTypeScoped ctx sig_ty thing_inside
+  = rn_hs_sig_wc_type False ctx sig_ty thing_inside
+    -- False: for pattern type sigs and rules we /do/ want
+    --        to bring those type varibles into scope
+    -- e.g  \ (x :: forall a. a-> b) -> e
+    -- Here we do bring 'b' into scope
+
+rn_hs_sig_wc_type :: Bool   -- see rnImplicitBndrs
+                  -> HsDocContext
+                  -> LHsSigWcType RdrName
+                  -> (LHsSigWcType Name -> RnM (a, FreeVars))
+                  -> RnM (a, FreeVars)
+-- rn_hs_sig_wc_type is used for source-language type signatures
+rn_hs_sig_wc_type no_implicit_if_forall ctxt
+                  (HsIB { hsib_body = wc_ty }) thing_inside
+  = rnImplicitBndrs no_implicit_if_forall (hswc_body wc_ty) $ \ kvs tvs ->
+    rn_hs_wc_type ctxt wc_ty $ \ wc_ty' ->
+    thing_inside (HsIB { hsib_kvs  = kvs
+                       , hsib_tvs  = tvs
+                       , hsib_body = wc_ty' })
+
+rnHsWcType :: HsDocContext -> LHsWcType RdrName -> RnM (LHsWcType Name, FreeVars)
+rnHsWcType ctxt wc_ty
+  = rn_hs_wc_type ctxt wc_ty $ \ wc_ty' ->
+    return (wc_ty', emptyFVs)
+
+rn_hs_wc_type :: HsDocContext -> LHsWcType RdrName
+              -> (LHsWcType Name -> RnM (a, FreeVars))
+              -> RnM (a, FreeVars)
+rn_hs_wc_type ctxt (HsWC { hswc_body = hs_ty }) thing_inside
+  = do { let nwc_rdrs = collectNamedWildCards hs_ty
+       ; rdr_env <- getLocalRdrEnv
+       ; nwcs <- sequence [ newLocalBndrRn lrdr
+                          | lrdr@(L _ rdr) <- nwc_rdrs
+                          , not (inScope rdr_env rdr) ]
+                 -- nwcs :: [Name]   Named wildcards
+       ; bindLocalNamesFV nwcs $
+    do { (wc_ty, fvs1) <- rnWcSigTy ctxt hs_ty
+       ; let wc_ty' :: HsWildCardBndrs Name (LHsType Name)
+             wc_ty' = wc_ty { hswc_wcs = nwcs ++ hswc_wcs wc_ty }
+       ; (res, fvs2) <- thing_inside wc_ty'
+       ; return (res, fvs1 `plusFV` fvs2) } }
 
-rnLHsInstType :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
--- Rename the type in an instance or standalone deriving decl
-rnLHsInstType doc_str ty
-  = do { (ty', fvs) <- rnLHsType (GenericCtx doc_str) ty
-       ; unless good_inst_ty (addErrAt (getLoc ty) (badInstTy ty))
-       ; return (ty', fvs) }
-  where
-    good_inst_ty
-      | Just (_, _, L _ cls, _) <-
-                        splitLHsInstDeclTy_maybe (flattenTopLevelLHsForAllTy ty)
-      , isTcOcc (rdrNameOcc cls) = True
-      | otherwise                = False
+rnWcSigTy :: HsDocContext -> LHsType RdrName
+          -> RnM (LHsWcType Name, FreeVars)
+-- Renames just the top level of a type signature
+-- It's exactly like rnHsTyKi, except that it uses rnWcSigContext
+-- on a qualified type, and return info on any extra-constraints
+-- wildcard.  Some code duplication, but no big deal.
+rnWcSigTy ctxt (L loc hs_ty@(HsForAllTy { hst_bndrs = tvs, hst_body = hs_tau }))
+  = bindLHsTyVarBndrs ctxt Nothing tvs $ \ tvs' ->
+    do { (hs_tau', fvs) <- rnWcSigTy ctxt hs_tau
+       ; warnUnusedForAlls (inTypeDoc hs_ty) tvs' fvs
+       ; let hs_ty' = HsForAllTy { hst_bndrs = tvs', hst_body = hswc_body hs_tau' }
+       ; return ( hs_tau' { hswc_body = L loc hs_ty' }, fvs) }
+
+rnWcSigTy ctxt (L loc (HsQualTy { hst_ctxt = hs_ctxt, hst_body = tau }))
+  = do { (hs_ctxt', fvs1) <- rnWcSigContext ctxt hs_ctxt
+       ; (tau',     fvs2) <- rnLHsType ctxt tau
+       ; let awcs_tau = collectAnonWildCards tau'
+             hs_ty'   = HsQualTy { hst_ctxt = hswc_body hs_ctxt'
+                                 , hst_body = tau' }
+       ; return ( HsWC { hswc_wcs = hswc_wcs hs_ctxt' ++ awcs_tau
+                       , hswc_ctx = hswc_ctx hs_ctxt'
+                       , hswc_body = L loc hs_ty' }
+                , fvs1 `plusFV` fvs2) }
+
+rnWcSigTy ctxt hs_ty
+  = do { (hs_ty', fvs) <- rnLHsType ctxt hs_ty
+       ; return (HsWC { hswc_wcs = collectAnonWildCards hs_ty'
+                      , hswc_ctx = Nothing
+                      , hswc_body = hs_ty' }
+                , fvs) }
+
+rnWcSigContext :: HsDocContext -> LHsContext RdrName
+               -> RnM (HsWildCardBndrs Name (LHsContext Name), FreeVars)
+rnWcSigContext ctxt (L loc hs_ctxt)
+  | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt
+  , L lx (HsWildCardTy wc) <- ignoreParens hs_ctxt_last
+  = do { (hs_ctxt1', fvs) <- mapFvRn (rnLHsTyKi RnTopConstraint ctxt) hs_ctxt1
+       ; wc'              <- setSrcSpan lx $
+                             rnExtraConstraintWildCard ctxt wc
+       ; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy wc')]
+             awcs     = concatMap collectAnonWildCards hs_ctxt1'
+             -- NB: *not* including the extra-constraint wildcard
+       ; return ( HsWC { hswc_wcs = awcs
+                       , hswc_ctx = Just lx
+                       , hswc_body = L loc hs_ctxt' }
+                , fvs ) }
+  | otherwise
+  = do { (hs_ctxt', fvs) <- mapFvRn (rnLHsTyKi RnTopConstraint ctxt) hs_ctxt
+       ; return (HsWC { hswc_wcs = concatMap collectAnonWildCards hs_ctxt'
+                      , hswc_ctx = Nothing
+                      , hswc_body = L loc hs_ctxt' }, fvs) }
 
-badInstTy :: LHsType RdrName -> SDoc
-badInstTy ty = ptext (sLit "Malformed instance:") <+> ppr ty
+
+{- ******************************************************
+*                                                       *
+           HsSigtype (i.e. no wildcards)
+*                                                       *
+****************************************************** -}
+
+rnHsSigType :: HsDocContext -> LHsSigType RdrName
+            -> RnM (LHsSigType Name, FreeVars)
+-- Used for source-language type signatures
+-- that cannot have wildcards
+rnHsSigType ctx (HsIB { hsib_body = hs_ty })
+  = rnImplicitBndrs True hs_ty $ \ kvs tvs ->
+    do { (body', fvs) <- rnLHsType ctx hs_ty
+       ; return (HsIB { hsib_kvs  = kvs
+                      , hsib_tvs  = tvs
+                      , hsib_body = body' }, fvs) }
+
+rnImplicitBndrs :: Bool    -- True <=> no implicit quantification
+                           --          if type is headed by a forall
+                           -- E.g.  f :: forall a. a->b
+                           -- Do not quantify over 'b' too.
+                -> LHsType RdrName
+                -> ([Name] -> [Name] -> RnM (a, FreeVars))
+                -> RnM (a, FreeVars)
+rnImplicitBndrs no_implicit_if_forall hs_ty@(L loc _) thing_inside
+  = do { rdr_env <- getLocalRdrEnv
+       ; let (kv_rdrs, tv_rdrs) = filterInScope rdr_env $
+                                  extractHsTyRdrTyVars hs_ty
+             real_tv_rdrs  -- Implicit quantification only if
+                           -- there is no explicit forall
+               | no_implicit_if_forall
+               , L _ (HsForAllTy {}) <- hs_ty = []
+               | otherwise                    = tv_rdrs
+       ; traceRn (text "rnSigType" <+> (ppr hs_ty $$ ppr kv_rdrs $$ ppr tv_rdrs))
+       ; kvs <- mapM (newLocalBndrRn . L loc) kv_rdrs
+       ; tvs <- mapM (newLocalBndrRn . L loc) real_tv_rdrs
+       ; bindLocalNamesFV (kvs ++ tvs) $
+         thing_inside kvs tvs }
+
+rnLHsInstType :: SDoc -> LHsSigType RdrName -> RnM (LHsSigType Name, FreeVars)
+-- Rename the type in an instance or standalone deriving decl
+-- The 'doc_str' is "an instance declaration" or "a VECTORISE pragma"
+rnLHsInstType doc_str inst_ty
+  | Just cls <- getLHsInstDeclClass_maybe inst_ty
+  , isTcOcc (rdrNameOcc (unLoc cls))
+         -- The guards check that the instance type looks like
+         --   blah => C ty1 .. tyn
+  = do { let full_doc = doc_str <+> ptext (sLit "for") <+> quotes (ppr cls)
+       ; rnHsSigType (GenericCtx full_doc) inst_ty }
+
+  | otherwise  -- The instance is malformed, but we'd still like
+               -- to make progress rather than failing outright, so
+               -- we report more errors.  So we rename it anyway.
+  = do { addErrAt (getLoc (hsSigType inst_ty)) $
+         ptext (sLit "Malformed instance:") <+> ppr inst_ty
+       ; rnHsSigType (GenericCtx doc_str) inst_ty }
+
+
+{- ******************************************************
+*                                                       *
+           LHsType and HsType
+*                                                       *
+****************************************************** -}
 
 {-
 rnHsType is here because we call it from loadInstDecl, and I didn't
@@ -113,18 +267,22 @@ The -fwarn-context-quantification flag warns about
 this situation. See rnHsTyKi for case HsForAllTy Qualified.
 -}
 
-rnLHsTyKi  :: Bool --  True <=> renaming a type, False <=> a kind
+rnLHsTyKi  :: RnTyKiWhat
            -> HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
-rnLHsTyKi isType doc (L loc ty)
+rnLHsTyKi what doc (L loc ty)
   = setSrcSpan loc $
-    do { (ty', fvs) <- rnHsTyKi isType doc ty
+    do { (ty', fvs) <- rnHsTyKi what doc ty
        ; return (L loc ty', fvs) }
 
 rnLHsType  :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
-rnLHsType = rnLHsTyKi True
+rnLHsType cxt ty = -- pprTrace "rnHsType" (pprHsDocContext cxt $$ ppr ty) $
+                   rnLHsTyKi RnType cxt ty
+
+rnLHsPred  :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
+rnLHsPred = rnLHsTyKi RnConstraint
 
 rnLHsKind  :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name, FreeVars)
-rnLHsKind = rnLHsTyKi False
+rnLHsKind = rnLHsTyKi RnKind
 
 rnLHsMaybeKind  :: HsDocContext -> Maybe (LHsKind RdrName)
                 -> RnM (Maybe (LHsKind Name), FreeVars)
@@ -135,44 +293,74 @@ rnLHsMaybeKind doc (Just kind)
        ; return (Just kind', fvs) }
 
 rnHsType  :: HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars)
-rnHsType = rnHsTyKi True
-rnHsKind  :: HsDocContext -> HsKind RdrName -> RnM (HsKind Name, FreeVars)
-rnHsKind = rnHsTyKi False
-
-rnHsTyKi :: Bool -> HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars)
-
-rnHsTyKi isType doc ty@HsForAllTy{}
-  = rnHsTyKiForAll isType doc (flattenTopLevelHsForAllTy ty)
+rnHsType cxt ty = rnHsTyKi RnType cxt ty
 
-rnHsTyKi isType _ (HsTyVar (L l rdr_name))
-  = do { name <- rnTyVar isType rdr_name
-       ; return (HsTyVar (L l name), unitFV name) }
+rnHsKind  :: HsDocContext -> HsKind RdrName -> RnM (HsKind Name, FreeVars)
+rnHsKind = rnHsTyKi RnKind
+
+data RnTyKiWhat = RnType
+                | RnKind
+                | RnTopConstraint  -- Top-level context of HsSigWcTypes
+                | RnConstraint     -- All other constraints
+
+instance Outputable RnTyKiWhat where
+  ppr RnType          = ptext (sLit "RnType")
+  ppr RnKind          = ptext (sLit "RnKind")
+  ppr RnTopConstraint = ptext (sLit "RnTopConstraint")
+  ppr RnConstraint    = ptext (sLit "RnConstraint")
+
+isRnType :: RnTyKiWhat -> Bool
+isRnType RnType = True
+isRnType _      = False
+
+isRnKind :: RnTyKiWhat -> Bool
+isRnKind RnKind = True
+isRnKind _      = False
+
+rnHsTyKi :: RnTyKiWhat -> HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars)
+
+rnHsTyKi _ doc ty@(HsForAllTy { hst_bndrs = tyvars, hst_body  = tau })
+  = bindLHsTyVarBndrs doc Nothing tyvars $ \ tyvars' ->
+    do { (tau',  fvs) <- rnLHsType doc tau
+       ; warnUnusedForAlls (inTypeDoc ty) tyvars' fvs
+       ; return ( HsForAllTy { hst_bndrs = tyvars', hst_body =  tau' }
+                , fvs) }
+
+rnHsTyKi _ doc (HsQualTy { hst_ctxt = lctxt
+                              , hst_body = tau })
+  = do { (ctxt', fvs1) <- rnContext doc lctxt
+       ; (tau',  fvs2) <- rnLHsType doc tau
+       ; return (HsQualTy { hst_ctxt = ctxt', hst_body =  tau' }
+                , f