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
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 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.
 
 
 the in-scope-name-set.
 
 
@@ -515,7 +515,6 @@ have any parent.
 
 Note [Parents for record fields]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 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
 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' }) }
 
        ; 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)
                 (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 (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
 
 
 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)
 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
 
 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)
     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
         ; 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
 
 
         ; (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
                             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
 
                     -- 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)
 
   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)
 
       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], [])
 
       (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
 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
   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
     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]
                                         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 []
              resTyVar = case resultSig of
                      TyVarSig bndr -> mkHsQTvs [bndr]
                      _             -> mkHsQTvs []
@@ -389,8 +400,8 @@ repAssocTyFamDefaults = mapM rep_deflt
            ; repTySynInst tc1 eqn1 }
 
 -------------------------
            ; 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]
 -- 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 })
 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
             -- 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)
             --
             -- 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
                ; 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
                ; 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 }))
 
 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
        ; 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 })
 
 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)
        ; 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
                                  , 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
 
 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
                                  , 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)
             ; 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
  = 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
       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 :: 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'] }
   = 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
   = 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)
        ; rep2 typedRuleVarName [n', ty'] }
 
 repAnnD :: LAnnDecl Name -> DsM (SrcSpan, Core TH.DecQ)
@@ -701,15 +710,15 @@ repBangTy ty = do
 --                      Deriving clause
 -------------------------------------------------------
 
 --                      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))
 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
   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)
       = 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)]
                      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 _   (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
 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_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)
            -> 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
   = do { nm1 <- lookupLOcc nm
-       ; ty1 <- rep_ty ty
+       ; ty1 <- repHsSigType sig_ty
        ; sig <- repProto mk_sig nm1 ty1
        ; return (loc, sig) }
        ; 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]
     -- 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
 
 rep_inline :: Located Name
            -> InlinePragma      -- Never defaultInlinePragma
@@ -773,11 +792,11 @@ rep_inline nm ispec loc
        ; return [(loc, pragma)]
        }
 
        ; 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
                -> 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
        ; 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)]
        }
 
        ; 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
 rep_specialiseInst ty loc
-  = do { ty1    <- repLTy ty
+  = do { ty1    <- repHsSigType ty
        ; pragma <- repPragSpecInst ty1
        ; return [(loc, pragma)] }
 
        ; pragma <- repPragSpecInst ty1
        ; return [(loc, pragma)] }
 
@@ -816,7 +835,15 @@ repPhases _                = dataCon allPhasesDataConName
 --                      Types
 -------------------------------------------------------
 
 --                      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;
               -> (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)
 
   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))
 
                   -> (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
 
 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]
 -- 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
 
 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
 
 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 }
 
         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 }
 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 \
        CoreSeq \
        CoreStats \
        CostCentre \
-       Ctype \
        DataCon \
        Demand \
        Digraph \
        DataCon \
        Demand \
        Digraph \
@@ -550,7 +549,6 @@ compiler_stage2_dll0_MODULES = \
        InstEnv \
        Kind \
        Lexeme \
        InstEnv \
        Kind \
        Lexeme \
-       Lexer \
        ListSetOps \
        Literal \
        Maybes \
        ListSetOps \
        Literal \
        Maybes \
index 29dd48c..1fc4f09 100644 (file)
@@ -14,7 +14,6 @@ module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
                 thRdrNameGuesses ) where
 
 import HsSyn as Hs
                 thRdrNameGuesses ) where
 
 import HsSyn as Hs
-import HsTypes  ( mkHsForAllTy )
 import qualified Class
 import RdrName
 import qualified Name
 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
 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)
 
 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.
   -- 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'
         ; 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 ^^
                     , 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
         ; 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 $
         ; 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
 
 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
 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 $
        ; 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
 
 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
 ----------------
 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' } }
 
 ----------------
                              , 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
 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
 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
 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
 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
 
 -------------------------------------------------------------------
 --              Partitioning declarations
@@ -419,13 +423,13 @@ cvtConstr (NormalC c strtys)
   = do  { c'   <- cNameL c
         ; cxt' <- returnL []
         ; tys' <- mapM cvt_arg 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
 
 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)
                                    (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
         ; 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'))
 
 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)
                          , 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}) }
 
                                        , 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
 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') }
 
 
 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
 
 ------------------------------------------
 --      Foreign declarations
@@ -498,7 +502,10 @@ cvtForD (ImportF callconv safety from nm ty)
     mk_imp impspec
       = do { nm' <- vNameL nm
            ; ty' <- cvtType 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
            }
     safety' = case safety of
                      Unsafe     -> PlayRisky
@@ -512,7 +519,10 @@ cvtForD (ExportF callconv as nm ty)
                                                 (mkFastString as)
                                                 (cvt_conv callconv)))
                                                 (noLoc as)
                                                 (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
 
 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 }
                                , 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
 
 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
 
 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
 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
 
 ---------------------------------------------------
 --              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
 
     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) }
     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
 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 }
 
 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
 
 -----------------------------------------------------------
 --      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)
 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
              -> 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
 
            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)
 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"
 
 getTypeSigNames _
   = panic "HsBinds.getTypeSigNames"
 
@@ -627,9 +627,8 @@ data Sig name
 
       -- For details on above see note [Api annotations] in ApiAnnotation
     TypeSig
 
       -- 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
       --
 
       -- | 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
       --           '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
 
         -- | 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
         --      '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
         --
 
         -- | 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
         --      '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
                   -- 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 :: LSig name -> Bool  -- Type signatures
 isTypeLSig (L _(TypeSig {}))    = True
-isTypeLSig (L _(GenericSig {})) = True
+isTypeLSig (L _(ClassOpSig {})) = True
 isTypeLSig (L _(IdSig {}))      = True
 isTypeLSig _                    = False
 
 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 :: 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")
 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 = 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 (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
   = 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)
                  (ppr ty)
+  where
+    (qtvs, req, prov, ty) = splitLHsPatSynTy (hsSigType sig_ty)
 
 pprPatSynSig :: (OutputableBndr name)
              => name -> Bool -> SDoc -> Maybe SDoc -> Maybe SDoc -> SDoc -> SDoc
 
 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
 -- @InstDecl@, @DefaultDecl@ and @ForeignDecl@.
 module HsDecls (
   -- * Toplevel declarations
-  HsDecl(..), LHsDecl, HsDataDefn(..),
+  HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving,
+
   -- ** Class or type declarations
   TyClDecl(..), LTyClDecl,
   TyClGroup(..), tyClGroupConcat, mkTyClGroup,
   -- ** 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
     --             '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
                                                   --   these include outer binders
-            , tcdRhs    :: LHsType name            -- ^ RHS of type declaration
+            , tcdRhs    :: LHsType name           -- ^ RHS of type declaration
             , tcdFVs    :: PostRn name NameSet }
 
   | -- | @data@ 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
 
     -- 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 :: *
                                                   --   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
 
   | 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
                 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 = [] }
 
 mkTyClGroup :: [LTyClDecl name] -> TyClGroup name
 mkTyClGroup decls = TyClGroup { group_tyclds = decls, group_roles = [] }
 
-
 -- Simple classifiers for TyClDecl
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 -- Simple classifiers for TyClDecl
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
@@ -613,7 +613,7 @@ tyClDeclLName decl = tcdLName decl
 tcdName :: TyClDecl name -> name
 tcdName = unLoc . tyClDeclLName
 
 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
 
 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
 
 pp_vanilla_decl_head :: OutputableBndr name
    => Located name
-   -> LHsTyVarBndrs name
+   -> LHsQTyVars name
    -> HsContext name
    -> SDoc
 pp_vanilla_decl_head thing tyvars context
    -> 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
 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
   }
   , 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'.
 
                      -- 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)
 
 
              -- 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 ...@
 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>
         -- 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
         -- ^ 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
         --  - 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
         -- 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 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
 
 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 })
                     , 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
   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 <+>
                     , 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)
 
   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
                     , 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 {} })
          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)
 
 -- 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)
 
 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 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 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
   -- 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
 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
       , 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
    -> 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)]
 
    = 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
 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',
         , 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
 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',
         -- ^
         --  - '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)
 
         -- For details on above see note [Api annotations] in ApiAnnotation
   deriving (Typeable)
+
 deriving instance (DataId name) => Data (ForeignDecl name)
 {-
     In both ForeignImport and ForeignExport:
 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
 --
 
 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)
 
     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)
 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'
         -- ^
         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
         --     'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose'
@@ -1630,7 +1658,7 @@ data RuleBndr name
   deriving (Typeable)
 deriving instance (DataId name) => 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
 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
   | 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)
   | 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)
   -- 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)
                 (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
   --
 
   -- | Arithmetic sequence
   --
@@ -571,28 +568,21 @@ So we use Nothing to mean "use the old built-in typing rule".
 
 Note [Record Update HsWrapper]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 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,
 
 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
 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]
 ~~~~~~~~~~~~~~~~~~~~~~~
 
 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.
 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
 -}
 
 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 (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)
   = 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
 
 
     -- 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
                 (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
         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)
         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
         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 ---------------
     }
 
         ------------ View patterns ---------------
@@ -199,9 +201,9 @@ data Pat id
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   -- | - '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
 
   | 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 HsLit
 import PlaceHolder
 import HsPat
-import HsTypes  hiding  ( mkHsForAllTy )
+import HsTypes
 import BasicTypes       ( Fixity, WarningTxt )
 import HsUtils
 import HsDoc
 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,
         HsType(..), LHsType, HsKind, LHsKind,
         HsTyOp,LHsTyOp,
         HsTyVarBndr(..), LHsTyVarBndr,
-        LHsTyVarBndrs(..),
-        HsWithBndrs(..),
-        HsTupleSort(..), HsExplicitFlag(..),
+        LHsQTyVars(..),
+        HsImplicitBndrs(..),
+        HsWildCardBndrs(..),
+        LHsSigType, LHsSigWcType, LHsWcType,
+        HsTupleSort(..),
         HsContext, LHsContext,
         HsTyWrapper(..),
         HsTyLit(..),
         HsContext, LHsContext,
         HsTyWrapper(..),
         HsTyLit(..),
@@ -44,23 +46,23 @@ module HsTypes (
         wildCardName, sameWildCard, sameNamedWildCard,
         isAnonWildCard, isNamedWildCard,
 
         wildCardName, sameWildCard, sameNamedWildCard,
         isAnonWildCard, isNamedWildCard,
 
+        mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody,
+        mkEmptyImplicitBndrs, mkEmptyWildCardBndrs,
         mkHsQTvs, hsQTvBndrs, isHsKindedTyVar, hsTvbAllKinded,
         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,
         hsLTyVarBndrsToTypes,
-        splitLHsInstDeclTy_maybe,
-        splitHsClassTy_maybe, splitLHsClassTy_maybe,
-        splitHsFunType,
-        splitHsAppTys, hsTyGetAppHead_maybe, mkHsAppTys, mkHsOpTy,
-        ignoreParens,
 
         -- Printing
 
         -- Printing
-        pprParendHsType, pprHsForAll, pprHsForAllExtra,
+        pprParendHsType, pprHsForAll, pprHsForAllTvs, pprHsForAllExtra,
         pprHsContext, pprHsContextNoArrow, pprHsContextMaybe
     ) where
 
         pprHsContext, pprHsContextNoArrow, pprHsContextMaybe
     ) where
 
@@ -81,15 +83,15 @@ import SrcLoc
 import StaticFlags
 import Outputable
 import FastString
 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 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
 #endif
-#if __GLASGOW_HASKELL__ > 710
+#if __GLASGOW_HASKELL > 710
 import Data.Semigroup   ( Semigroup )
 import qualified Data.Semigroup as Semigroup
 #endif
 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
 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)
 -}
 
 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
 
 --------------------------------------------------
       -- 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)
 
 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 )
            , 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
 
 hsQTvBndrs = hsq_tvs
 
+{-
 #if __GLASGOW_HASKELL__ > 710
 instance Semigroup (LHsTyVarBndrs name) where
   HsQTvs kvs1 tvs1 <> HsQTvs kvs2 tvs2
     = HsQTvs (kvs1 ++ kvs2) (tvs1 ++ tvs2)
 #endif
 
 #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)
   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)
 -- 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
 
 --    * 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)
     }
   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]))
 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?
 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
 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'
       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForall',
       --         'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow'
-
       -- For details on above see note [Api annotations] in ApiAnnotation
 
       -- 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)]
   | 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))
 
 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)
     | NamedWildCard (Located name)
       -- A named wild card ('_a').
     deriving (Typeable)
@@ -548,13 +665,6 @@ data HsTupleSort = HsUnboxedTuple
                  | HsBoxedOrConstraintTuple
                  deriving (Data, Typeable)
 
                  | 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
 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
 
 -- 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
 
 ---------------------
 hsTyVarName :: HsTyVarBndr name -> name
@@ -744,11 +806,11 @@ hsTyVarName (KindedTyVar (L _ n) _) = n
 hsLTyVarName :: LHsTyVarBndr name -> name
 hsLTyVarName = hsTyVarName . unLoc
 
 hsLTyVarName :: LHsTyVarBndr name -> name
 hsLTyVarName = hsTyVarName . unLoc
 
-hsLTyVarNames :: LHsTyVarBndrs name -> [name]
+hsLTyVarNames :: LHsQTyVars name -> [name]
 -- Type variables only
 hsLTyVarNames qtvs = map hsLTyVarName (hsQTvBndrs qtvs)
 
 -- 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
 -- 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
 
 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
 -- | 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.
 -- | 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
 
 ---------------------
 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
 
        -- 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
         -- 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
 -- 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 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 (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
 
 
 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
 
 -- | 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.
 -- 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
   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
 
 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
 
 -- 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)))
 
 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_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 $
   = 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
 
 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,
   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,
   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
 
   -- * Constructing general big tuples
   -- $big_tuples
@@ -52,6 +52,7 @@ module HsUtils(
 
   -- Types
   mkHsAppTy, userHsTyVarBndrs,
 
   -- Types
   mkHsAppTy, userHsTyVarBndrs,
+  mkLHsSigType, mkLHsSigWcType, mkClassOpSigs,
   nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp,
 
   -- Stmts
   nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp,
 
   -- Stmts
@@ -91,12 +92,13 @@ import HsTypes
 import HsLit
 import PlaceHolder
 
 import HsLit
 import PlaceHolder
 
+import TcType( tcSplitForAllTys, tcSplitPhiTy )
 import TcEvidence
 import RdrName
 import Var
 import TcEvidence
 import RdrName
 import Var
+import Type( isPredTy )
+import Kind( isKind )
 import TypeRep
 import TypeRep
-import TcType
-import Kind
 import DataCon
 import Name
 import NameSet
 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
   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)
        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)
 
 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 :: 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 :: 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
 
 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
 
 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
 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
 
 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 :
 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
     , [])
 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
 -- 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,
         (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
   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
 
         -- 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"
                 (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 '!'
 
     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
 
     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
     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
 
         -- 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 })
 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),
              ("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),
              ("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)
 
 
     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 }))
 
     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}})
 
     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)
 
                                      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
 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) ++
     -- 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)
 
     -- 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
 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
         : '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 }
                                      , 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
                    (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
 -- 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
 
 -----------------------------------------------------------------------------
 -- Role annotations
@@ -1160,10 +1160,12 @@ pattern_synonym_decl :: { LHsDecl RdrName }
                                                     ImplicitBidirectional)
                (as ++ [mj AnnPattern $1, mj AnnEqual $3])
          }
                                                     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
          {%    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)
         | '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)) }
                                            :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
 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
         : '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
         | 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
         | 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
 
 -----------------------------------------------------------------------------
 -- Nested declarations
@@ -1227,10 +1230,10 @@ decl_cls  : at_decl_cls                 { $1 }
 
           -- A 'default' signature used with the generic-programming extension
           | 'default' infixexp '::' sigtypedoc
 
           -- 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 <+>
                           ; 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
                                 [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
 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] }
 
 -----------------------------------------------------------------------------
                                                [mop $1,mu AnnDcolon $3,mcp $5] }
 
 -----------------------------------------------------------------------------
@@ -1491,12 +1494,12 @@ safety :: { Located Safety }
         | 'interruptible'               { sLL $1 $> PlayInterruptible }
 
 fspec :: { Located ([AddAnn]
         | '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)
        : 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]
        |        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
          -- 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
 
 -----------------------------------------------------------------------------
 -- Type signatures
 
-opt_sig :: { ([AddAnn],Maybe (LHsType RdrName)) }
+opt_sig :: { ([AddAnn], Maybe (LHsType RdrName)) }
         : {- empty -}                   { ([],Nothing) }
         | '::' sigtype                  { ([mu AnnDcolon $1],Just $2) }
 
         : {- 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) }
 
         : {- 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)
 
 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] }
 
                                          >> 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
 
 -----------------------------------------------------------------------------
 -- 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) >>
 -- 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 $> $
         | 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 }
         | 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) >>
 
 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 $> $
                                                 [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 }
         | 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
 
 -- 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 }
 
 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
 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) } }
 
                       ; ams (sLL $1 $> gadtDecl)
                             (mu AnnDcolon $2:anns) } }
 
@@ -1932,9 +1936,9 @@ constr :: { LConDecl RdrName }
                             ($1 `mplus` $4))
                        (fst $ unLoc $2) }
 
                             ($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]
 
 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] }
 
                       (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 }
         : {- 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
 
              -- 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
         :
         -- 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]
                         ; _ <- ams (sLL $1 $> ()) [mu AnnDcolon $2]
-                        ; return (sLL $1 $> $ SigD s) }
+                        ; return (sLL $1 $> $ SigD $
+                                  TypeSig [v] (mkLHsSigWcType $3)) }
 
         | var ',' sig_vars '::' sigtypedoc
 
         | 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] } }
                  ; 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 }
                             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)
                                        [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
 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)) }
                           (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)) }
         | '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) }
         | 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,
 
 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
 -- |Construct an AddAnn from the annotation keyword and the location
--- of the keyword
+-- of the keyword itself
 mj :: AnnKeywordId -> Located e -> AddAnn
 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
 
 -- |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)
 
 -- |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)
 
 -- |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))
 
 -- |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
 
 -- |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
 
 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
 
 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
 
 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
 
 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
 
 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 =
 -- |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,
         mkTyData, mkDataFamInst,
         mkTySynonym, mkTyFamInstEqn,
         mkTyFamInst,
-        mkFamDecl,
+        mkFamDecl, mkLHsSigType,
         splitCon, mkInlinePragma,
         mkPatSynMatchGroup,
         mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
         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
         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,
         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
        ; 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)
 
 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
 -- 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 })) }
            ; 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]
          -> 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
          -> 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 (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
            -> 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
 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) }
 
                           , tfe_rhs   = rhs },
                  ann) }
 
@@ -222,7 +223,7 @@ mkDataFamInst :: SrcSpan
               -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
               -> Maybe (LHsKind RdrName)
               -> [LConDecl RdrName]
               -> 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
               -> 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
        ; 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
                                   , 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
 
         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
 
                 -> LHsContext RdrName -> HsConDeclDetails RdrName
                 -> ConDecl RdrName
 
-mkSimpleConDecl name qvars cxt details
+mkSimpleConDecl name mb_forall cxt details
   = ConDecl { con_names    = [name]
   = 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 }
             , 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 :: [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]
 
 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.)
 -- 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
   = 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)
     (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
 
     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_cxt      = cxt
                  , con_details  = details
-                 , con_res      = ResTyGADT ls res_ty
+                 , con_res      = ResTyGADT loc res_ty
                  , con_doc      = Nothing }
                  , con_doc      = Nothing }
-mkGadtDecl' _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty)
 
 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
 tyConToDataCon loc tc
 
 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
 
 --    * 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
 -- 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]
 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
 -- 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))
    -- 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))) _
 
    -- 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)
 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)
 
 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
             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
         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.
 
         -- 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
                     ([],[])) }
 
         ; 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:" <+>
   = parseErrorSDoc l ((text "Invalid type signature:" <+>
-                       ppr lhs <+> text "::" <+> ppr ty)
-                   $$ text hint)
+                       ppr lhs <+> text ":: ...")
+                      $$ text hint)
   where
   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
     -- 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
 --
 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))
          -> 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))
   | 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")
   | 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
 
 -- 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
 -- construct a foreign export declaration
 --
 mkExport :: Located CCallConv
-         -> (Located StringLiteral, Located RdrName, LHsType RdrName)
+         -> (Located StringLiteral, Located RdrName, LHsSigType RdrName)
          -> P (HsDecl 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
   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 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
 
 isUnboundName :: Name -> Bool
 isUnboundName name = name `hasKey` unboundKey
index 9ec71df..c2a45b0 100644 (file)
@@ -19,7 +19,7 @@ module RnBinds (
    rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
 
    -- Other bindings
    rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
 
    -- Other bindings
-   rnMethodBinds, renameSigs, mkSigTvFn,
+   rnMethodBinds, renameSigs,
    rnMatchGroup, rnGRHSs, rnGRHS,
    makeMiniFixityEnv, MiniFixityEnv,
    HsSigCtxt(..)
    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
 
 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
 mkSigTvFn sigs
   = \n -> lookupNameEnv env n `orElse` []
   where
-    extractScopedTyVars :: LHsType Name -> [Name]
-    extractScopedTyVars (L _ (HsForAllTy Explicit _ ltvs _ _)) = hsLKiTyVarNames ltvs
-    extractScopedTyVars _ = []
-
     env :: NameEnv [Name]
     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.)
 
 -- 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 _ (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
   = 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
   = 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_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)
 
 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
         ; 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
   = 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
         ; (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_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)
            ; 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)
 
   = 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
   = 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)
 
 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
 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
 
      (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)
   = findDupsEq matching_sig (concatMap (expand_sig . unLoc) sigs)
   where
     expand_sig sig@(FixSig (FixitySig ns _)) = zip ns (repeat sig)
-    expand_sig sig@(InlineSig n _)         &nbs