Commit 1e041b73 authored by Simon Peyton Jones's avatar Simon Peyton Jones Committed by Ben Gamari

Refactor treatment of wildcards

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.
parent b432e2f3
......@@ -383,7 +383,7 @@ Note [Local bindings with Exact Names]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
With Template Haskell we can make local bindings that have Exact Names.
Computing shadowing etc may use elemLocalRdrEnv (at least it certainly
does so in RnTpes.bindHsTyVars), so for an Exact Name we must consult
does so in RnTpes.bindHsQTyVars), so for an Exact Name we must consult
the in-scope-name-set.
......@@ -515,7 +515,6 @@ have any parent.
Note [Parents for record fields]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For record fields, in addition to the Name of the type constructor
(stored in par_is), we use FldParent to store the field label. This
extra information is used for identifying overloaded record fields
......
......@@ -545,8 +545,8 @@ addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds })
; flds' <- mapM addTickHsRecField flds
; return (expr { rupd_expr = e', rupd_flds = flds' }) }
addTickHsExpr (ExprWithTySigOut e ty) =
liftM2 ExprWithTySigOut
addTickHsExpr (ExprWithTySig e ty) =
liftM2 ExprWithTySig
(addTickLHsExprNever e) -- No need to tick the inner expression
-- for expressions with signatures
(return ty)
......@@ -594,11 +594,16 @@ addTickHsExpr (HsProc pat cmdtop) =
addTickHsExpr (HsWrap w e) =
liftM2 HsWrap
(return w)
(addTickHsExpr e) -- explicitly no tick on inside
(addTickHsExpr e) -- Explicitly no tick on inside
addTickHsExpr (ExprWithTySigOut e ty) =
liftM2 ExprWithTySigOut
(addTickLHsExprNever e) -- No need to tick the inner expression
(return ty) -- for expressions with signatures
addTickHsExpr e@(HsType _) = return e
-- Others dhould never happen in expression content.
-- Others should never happen in expression content.
addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e)
addTickTupArg :: LHsTupArg Id -> TM (LHsTupArg Id)
......
......@@ -616,7 +616,7 @@ dsCmd _ids local_vars _stack_ty _res_ty (HsCmdArrForm op _ args) env_ids = do
dsCmd ids local_vars stack_ty res_ty (HsCmdCast coercion cmd) env_ids = do
(core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids
wrapped_cmd <- dsHsWrapper (mkWpCast coercion) core_cmd
wrapped_cmd <- dsHsWrapper (mkWpCastN coercion) core_cmd
return (wrapped_cmd, env_ids')
dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c)
......
......@@ -173,10 +173,10 @@ dsHsBind dflags
; let core_bind = Rec bind_prs
; ds_binds <- dsTcEvBinds_s ev_binds
; rhs <- dsHsWrapper wrap $ -- Usually the identity
mkLams tyvars $ mkLams dicts $
mkCoreLets ds_binds $
Let core_bind $
Var local
mkLams tyvars $ mkLams dicts $
mkCoreLets ds_binds $
Let core_bind $
Var local
; (spec_binds, rules) <- dsSpecs rhs prags
......
......@@ -653,7 +653,7 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
Nothing -> mkTcReflCo Nominal ty
in if null eq_spec
then rhs
else mkLHsWrap (mkWpCast (mkTcSubCo wrap_co)) rhs
else mkLHsWrap (mkWpCastN wrap_co) rhs
-- eq_spec is always null for a PatSynCon
PatSynCon _ -> rhs
......
......@@ -101,14 +101,14 @@ dsForeigns' fos = do
where
do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl)
do_decl (ForeignImport id _ co spec) = do
do_decl (ForeignImport { fd_name = id, fd_co = co, fd_fi = spec }) = do
traceIf (text "fi start" <+> ppr id)
(bs, h, c) <- dsFImport (unLoc id) co spec
traceIf (text "fi end" <+> ppr id)
return (h, c, [], bs)
do_decl (ForeignExport (L _ id) _ co
(CExport (L _ (CExportStatic _ ext_nm cconv)) _)) = do
do_decl (ForeignExport { fd_name = L _ id, fd_co = co
, fd_fe = CExport (L _ (CExportStatic _ ext_nm cconv)) _ }) = do
(h, c, _, _) <- dsFExport id co ext_nm cconv False
return (h, c, [id], [])
......
This diff is collapsed.
......@@ -510,7 +510,6 @@ compiler_stage2_dll0_MODULES = \
CoreSeq \
CoreStats \
CostCentre \
Ctype \
DataCon \
Demand \
Digraph \
......@@ -550,7 +549,6 @@ compiler_stage2_dll0_MODULES = \
InstEnv \
Kind \
Lexeme \
Lexer \
ListSetOps \
Literal \
Maybes \
......
This diff is collapsed.
......@@ -447,7 +447,7 @@ plusHsValBinds _ _
getTypeSigNames :: HsValBinds a -> NameSet
-- Get the names that have a user type sig
getTypeSigNames (ValBindsOut _ sigs)
= mkNameSet [unLoc n | L _ (TypeSig names _ _) <- sigs, n <- names]
= mkNameSet [unLoc n | L _ (TypeSig names _) <- sigs, n <- names]
getTypeSigNames _
= panic "HsBinds.getTypeSigNames"
......@@ -627,9 +627,8 @@ data Sig name
-- For details on above see note [Api annotations] in ApiAnnotation
TypeSig
[Located name] -- LHS of the signature; e.g. f,g,h :: blah
(LHsType name) -- RHS of the signature
(PostRn name [Name]) -- Wildcards (both named and anonymous) of the RHS
[Located name] -- LHS of the signature; e.g. f,g,h :: blah
(LHsSigWcType name) -- RHS of the signature; can have wildcards
-- | A pattern synonym type signature
--
......@@ -640,21 +639,20 @@ data Sig name
-- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow'
-- For details on above see note [Api annotations] in ApiAnnotation
| PatSynSig (Located name)
(HsExplicitFlag, LHsTyVarBndrs name)
(LHsContext name) -- Required context
(LHsContext name) -- Provided context
(LHsType name)
-- | A type signature for a default method inside a class
--
-- > default eq :: (Representable0 a, GEq (Rep0 a)) => a -> a -> Bool
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault',
-- 'ApiAnnotation.AnnDcolon'
-- For details on above see note [Api annotations] in ApiAnnotation
| GenericSig [Located name] (LHsType name)
| PatSynSig (Located name) (LHsSigType name)
-- P :: forall a b. Prov => Req => ty
-- | A signature for a class method
-- False: ordinary class-method signauure
-- True: default class method signature
-- e.g. class C a where
-- op :: a -> a -- Ordinary
-- default op :: Eq a => a -> a -- Generic default
-- No wildcards allowed here
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault',
-- 'ApiAnnotation.AnnDcolon'
| ClassOpSig Bool [Located name] (LHsSigType name)
-- | A type signature in generated code, notably the code
-- generated for record selectors. We simply record
......@@ -700,11 +698,11 @@ data Sig name
-- 'ApiAnnotation.AnnDcolon'
-- For details on above see note [Api annotations] in ApiAnnotation
| SpecSig (Located name) -- Specialise a function or datatype ...
[LHsType name] -- ... to these types
InlinePragma -- The pragma on SPECIALISE_INLINE form.
-- If it's just defaultInlinePragma, then we said
-- SPECIALISE, not SPECIALISE_INLINE
| SpecSig (Located name) -- Specialise a function or datatype ...
[LHsSigType name] -- ... to these types
InlinePragma -- The pragma on SPECIALISE_INLINE form.
-- If it's just defaultInlinePragma, then we said
-- SPECIALISE, not SPECIALISE_INLINE
-- | A specialisation pragma for instance declarations only
--
......@@ -717,7 +715,7 @@ data Sig name
-- 'ApiAnnotation.AnnInstance','ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation
| SpecInstSig SourceText (LHsType name)
| SpecInstSig SourceText (LHsSigType name)
-- Note [Pragma source text] in BasicTypes
-- | A minimal complete definition pragma
......@@ -782,7 +780,7 @@ isVanillaLSig _ = False
isTypeLSig :: LSig name -> Bool -- Type signatures
isTypeLSig (L _(TypeSig {})) = True
isTypeLSig (L _(GenericSig {})) = True
isTypeLSig (L _(ClassOpSig {})) = True
isTypeLSig (L _(IdSig {})) = True
isTypeLSig _ = False
......@@ -812,7 +810,9 @@ isMinimalLSig _ = False
hsSigDoc :: Sig name -> SDoc
hsSigDoc (TypeSig {}) = ptext (sLit "type signature")
hsSigDoc (PatSynSig {}) = ptext (sLit "pattern synonym signature")
hsSigDoc (GenericSig {}) = ptext (sLit "default type signature")
hsSigDoc (ClassOpSig is_deflt _ _)
| is_deflt = ptext (sLit "default type signature")
| otherwise = ptext (sLit "class method signature")
hsSigDoc (IdSig {}) = ptext (sLit "id signature")
hsSigDoc (SpecSig {}) = ptext (sLit "SPECIALISE pragma")
hsSigDoc (InlineSig _ prag) = ppr (inlinePragmaSpec prag) <+> ptext (sLit "pragma")
......@@ -830,21 +830,26 @@ instance (OutputableBndr name) => Outputable (Sig name) where
ppr sig = ppr_sig sig
ppr_sig :: OutputableBndr name => Sig name -> SDoc
ppr_sig (TypeSig vars ty _wcs) = pprVarSig (map unLoc vars) (ppr ty)
ppr_sig (GenericSig vars ty) = ptext (sLit "default") <+> pprVarSig (map unLoc vars) (ppr ty)
ppr_sig (IdSig id) = pprVarSig [id] (ppr (varType id))
ppr_sig (FixSig fix_sig) = ppr fix_sig
ppr_sig (TypeSig vars ty) = pprVarSig (map unLoc vars) (ppr ty)
ppr_sig (ClassOpSig is_deflt vars ty)
| is_deflt = ptext (sLit "default") <+> pprVarSig (map unLoc vars) (ppr ty)
| otherwise = pprVarSig (map unLoc vars) (ppr ty)
ppr_sig (IdSig id) = pprVarSig [id] (ppr (varType id))
ppr_sig (FixSig fix_sig) = ppr fix_sig
ppr_sig (SpecSig var ty inl)
= pragBrackets (pprSpec (unLoc var) (interpp'SP ty) inl)
ppr_sig (InlineSig var inl) = pragBrackets (ppr inl <+> pprPrefixOcc (unLoc var))
ppr_sig (SpecInstSig _ ty)
= pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty)
ppr_sig (MinimalSig _ bf) = pragBrackets (pprMinimalSig bf)
ppr_sig (PatSynSig name (flag, qtvs) (L _ req) (L _ prov) ty)
ppr_sig (PatSynSig name sig_ty)
= pprPatSynSig (unLoc name) False -- TODO: is_bindir
(pprHsForAll flag qtvs (noLoc []))
(pprHsContextMaybe req) (pprHsContextMaybe prov)
(pprHsForAllTvs qtvs)
(pprHsContextMaybe (unLoc req))
(pprHsContextMaybe (unLoc prov))
(ppr ty)
where
(qtvs, req, prov, ty) = splitLHsPatSynTy (hsSigType sig_ty)
pprPatSynSig :: (OutputableBndr name)
=> name -> Bool -> SDoc -> Maybe SDoc -> Maybe SDoc -> SDoc -> SDoc
......
This diff is collapsed.
......@@ -321,16 +321,13 @@ data HsExpr id
-- For details on above see note [Api annotations] in ApiAnnotation
| ExprWithTySig
(LHsExpr id)
(LHsType id)
(PostRn id [Name]) -- After renaming, the list of Names
-- contains the named and unnamed
-- wildcards brought in scope by the
-- signature
(LHsSigWcType id)
| ExprWithTySigOut -- TRANSLATION
| ExprWithTySigOut -- Post typechecking
(LHsExpr id)
(LHsType Name) -- Retain the signature for
-- round-tripping purposes
(LHsSigWcType Name) -- Retain the signature,
-- as HsSigType Name, for
-- round-tripping purposes
-- | Arithmetic sequence
--
......@@ -571,28 +568,21 @@ So we use Nothing to mean "use the old built-in typing rule".
Note [Record Update HsWrapper]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
There is a wrapper in RecordUpd which is used for the *required* constraints for
pattern synonyms. This wrapper is created in the typechecking and is then
directly used in the desugaring without modification.
There is a wrapper in RecordUpd which is used for the *required*
constraints for pattern synonyms. This wrapper is created in the
typechecking and is then directly used in the desugaring without
modification.
For example, if we have the record pattern synonym P,
pattern P :: (Show a) => a -> Maybe a
pattern P{x} = Just x
```
pattern P :: (Show a) => a -> Maybe a
pattern P{x} = Just x
foo = (Just True) { x = False }
```
foo = (Just True) { x = False }
then `foo` desugars to something like
```
P x = P False
```
hence we need to provide the correct dictionaries to P on the RHS so that we can
build the expression.
foo = case Just True of
P x -> P False
hence we need to provide the correct dictionaries to P's matcher on
the RHS so that we can build the expression.
Note [Located RdrNames]
~~~~~~~~~~~~~~~~~~~~~~~
......@@ -604,6 +594,7 @@ in the ParsedSource.
There are unfortunately enough differences between the ParsedSource and the
RenamedSource that the API Annotations cannot be used directly with
RenamedSource, so this allows a simple mapping to be used based on the location.
>>>>>>> origin/master
-}
instance OutputableBndr id => Outputable (HsExpr id) where
......@@ -751,7 +742,7 @@ ppr_expr (RecordCon { rcon_con_name = con_id, rcon_flds = rbinds })
ppr_expr (RecordUpd { rupd_expr = aexp, rupd_flds = rbinds })
= hang (pprLExpr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds))))
ppr_expr (ExprWithTySig expr sig _)
ppr_expr (ExprWithTySig expr sig)
= hang (nest 2 (ppr_lexpr expr) <+> dcolon)
4 (ppr sig)
ppr_expr (ExprWithTySigOut expr sig)
......@@ -979,7 +970,7 @@ data HsCmd id
-- For details on above see note [Api annotations] in ApiAnnotation
| HsCmdCast TcCoercion -- A simpler version of HsWrap in HsExpr
| HsCmdCast TcCoercionN -- A simpler version of HsWrap in HsExpr
(HsCmd id) -- If cmd :: arg1 --> res
-- co :: arg1 ~ arg2
-- Then (HsCmdCast co cmd) :: arg2 --> res
......@@ -1147,6 +1138,7 @@ data Match id body
m_type :: (Maybe (LHsType id)),
-- A type signature for the result of the match
-- Nothing after typechecking
-- NB: No longer supported
m_grhss :: (GRHSs id body)
} deriving (Typeable)
deriving instance (Data body,DataId id) => Data (Match id body)
......
......@@ -157,6 +157,8 @@ data Pat id
pat_binds :: TcEvBinds, -- Bindings involving those dictionaries
pat_args :: HsConPatDetails id,
pat_wrap :: HsWrapper -- Extra wrapper to pass to the matcher
-- Only relevant for pattern-synonyms;
-- ignored for data cons
}
------------ View patterns ---------------
......@@ -199,9 +201,9 @@ data Pat id
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
-- For details on above see note [Api annotations] in ApiAnnotation
| SigPatIn (LPat id) -- Pattern with a type signature
(HsWithBndrs id (LHsType id)) -- Signature can bind both
-- kind and type vars
| SigPatIn (LPat id) -- Pattern with a type signature
(LHsSigWcType id) -- Signature can bind both
-- kind and type vars
| SigPatOut (LPat id) -- Pattern with a type signature
Type
......
......@@ -40,7 +40,7 @@ import HsImpExp
import HsLit
import PlaceHolder
import HsPat
import HsTypes hiding ( mkHsForAllTy )
import HsTypes
import BasicTypes ( Fixity, WarningTxt )
import HsUtils
import HsDoc
......
This diff is collapsed.
......@@ -23,14 +23,14 @@ module HsUtils(
mkSimpleMatch, unguardedGRHSs, unguardedRHS,
mkMatchGroup, mkMatchGroupName, mkMatch, mkHsLam, mkHsIf,
mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,
coToHsWrapper, coToHsWrapperR, mkHsDictLet, mkHsLams,
mkHsDictLet, mkHsLams,
mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
mkLHsPar, mkHsCmdCast,
nlHsTyApp, nlHsTyApps, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps,
nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
toHsType, toHsKind,
toLHsSigWcType,
-- * Constructing general big tuples
-- $big_tuples
......@@ -52,6 +52,7 @@ module HsUtils(
-- Types
mkHsAppTy, userHsTyVarBndrs,
mkLHsSigType, mkLHsSigWcType, mkClassOpSigs,
nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp,
-- Stmts
......@@ -91,12 +92,13 @@ import HsTypes
import HsLit
import PlaceHolder
import TcType( tcSplitForAllTys, tcSplitPhiTy )
import TcEvidence
import RdrName
import Var
import Type( isPredTy )
import Kind( isKind )
import TypeRep
import TcType
import Kind
import DataCon
import Name
import NameSet
......@@ -516,48 +518,67 @@ chunkify xs
{-
************************************************************************
* *
Converting a Type to an HsType RdrName
LHsSigType and LHsSigWcType
* *
************************************************************************
********************************************************************* -}
This is needed to implement GeneralizedNewtypeDeriving.
-}
mkLHsSigType :: LHsType RdrName -> LHsSigType RdrName
mkLHsSigType ty = mkHsImplicitBndrs ty
toHsType :: Type -> LHsType RdrName
toHsType ty
| [] <- tvs_only
, [] <- theta
= to_hs_type tau
| otherwise
= noLoc $
mkExplicitHsForAllTy (map mk_hs_tvb tvs_only)
(noLoc $ map toHsType theta)
(to_hs_type tau)
mkLHsSigWcType :: LHsType RdrName -> LHsSigWcType RdrName
mkLHsSigWcType ty = mkHsImplicitBndrs (mkHsWildCardBndrs ty)
mkClassOpSigs :: [LSig RdrName] -> [LSig RdrName]
-- Convert TypeSig to ClassOpSig
-- The former is what is parsed, but the latter is
-- what we need in class/instance declarations
mkClassOpSigs sigs
= map fiddle sigs
where
(tvs, theta, tau) = tcSplitSigmaTy ty
tvs_only = filter isTypeVar tvs
fiddle (L loc (TypeSig nms ty)) = L loc (ClassOpSig False nms (dropWildCards ty))
fiddle sig = sig
to_hs_type (TyVarTy tv) = nlHsTyVar (getRdrName tv)
to_hs_type (AppTy t1 t2) = nlHsAppTy (toHsType t1) (toHsType t2)
to_hs_type (TyConApp tc args) = nlHsTyConApp (getRdrName tc) (map toHsType args')
toLHsSigWcType :: Type -> LHsSigWcType RdrName
-- ^ Converting a Type to an HsType RdrName
-- This is needed to implement GeneralizedNewtypeDeriving.
--
-- Note that we use 'getRdrName' extensively, which
-- generates Exact RdrNames rather than strings.
toLHsSigWcType ty
= mkLHsSigWcType (go ty)
where
go :: Type -> LHsType RdrName
go ty@(ForAllTy {})
| (tvs, tau) <- tcSplitForAllTys ty
= noLoc (HsForAllTy { hst_bndrs = map go_tv tvs
, hst_body = go tau })
go ty@(FunTy arg _)
| isPredTy arg
, (theta, tau) <- tcSplitPhiTy ty
= noLoc (HsQualTy { hst_ctxt = noLoc (map go theta)
, hst_body = go tau })
go (FunTy arg res) = nlHsFunTy (go arg) (go res)
go (TyVarTy tv) = nlHsTyVar (getRdrName tv)
go (AppTy t1 t2) = nlHsAppTy (go t1) (go t2)
go (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy "" n)
go (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy "" s)
go (TyConApp tc args) = nlHsTyConApp (getRdrName tc) (map go args')
where
args' = filterOut isKind args
-- Source-language types have _implicit_ kind arguments,
-- so we must remove them here (Trac #8563)
to_hs_type (FunTy arg res) = ASSERT( not (isConstraintKind (typeKind arg)) )
nlHsFunTy (toHsType arg) (toHsType res)
to_hs_type t@(ForAllTy {}) = pprPanic "toHsType" (ppr t)
to_hs_type (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy "" n)
to_hs_type (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy "" s)
mk_hs_tvb tv = noLoc $ KindedTyVar (noLoc (getRdrName tv))
(toHsKind (tyVarKind tv))
go_tv :: TyVar -> LHsTyVarBndr RdrName
go_tv tv = noLoc $ KindedTyVar (noLoc (getRdrName tv))
(go (tyVarKind tv))
toHsKind :: Kind -> LHsKind RdrName
toHsKind = toHsType
--------- HsWrappers: type args, dict args, casts ---------
{- *********************************************************************
* *
--------- HsWrappers: type args, dict args, casts ---------
* *
********************************************************************* -}
mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id
mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
......@@ -567,35 +588,26 @@ mkHsWrap co_fn e | isIdHsWrapper co_fn = e
mkHsWrapCo :: TcCoercionN -- A Nominal coercion a ~N b
-> HsExpr id -> HsExpr id
mkHsWrapCo co e = mkHsWrap (coToHsWrapper co) e
mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e
mkHsWrapCoR :: TcCoercionR -- A Representational coercion a ~R b
-> HsExpr id -> HsExpr id
mkHsWrapCoR co e = mkHsWrap (coToHsWrapperR co) e
mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e
mkLHsWrapCo :: TcCoercion -> LHsExpr id -> LHsExpr id
mkLHsWrapCo :: TcCoercionN -> LHsExpr id -> LHsExpr id
mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e)
mkHsCmdCast :: TcCoercion -> HsCmd id -> HsCmd id
mkHsCmdCast co cmd | isTcReflCo co = cmd
| otherwise = HsCmdCast co cmd
coToHsWrapper :: TcCoercion -> HsWrapper -- A Nominal coercion
coToHsWrapper co | isTcReflCo co = idHsWrapper
| otherwise = mkWpCast (mkTcSubCo co)
coToHsWrapperR :: TcCoercion -> HsWrapper -- A Representational coercion
coToHsWrapperR co | isTcReflCo co = idHsWrapper
| otherwise = mkWpCast co
mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
mkHsWrapPat co_fn p ty | isIdHsWrapper