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] ...@@ -383,7 +383,7 @@ Note [Local bindings with Exact Names]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
With Template Haskell we can make local bindings that have Exact Names. With Template Haskell we can make local bindings that have Exact Names.
Computing shadowing etc may use elemLocalRdrEnv (at least it certainly 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. ...@@ -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 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 (stored in par_is), we use FldParent to store the field label. This
extra information is used for identifying overloaded record fields extra information is used for identifying overloaded record fields
......
...@@ -545,8 +545,8 @@ addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds }) ...@@ -545,8 +545,8 @@ addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds })
; flds' <- mapM addTickHsRecField flds ; flds' <- mapM addTickHsRecField flds
; return (expr { rupd_expr = e', rupd_flds = flds' }) } ; return (expr { rupd_expr = e', rupd_flds = flds' }) }
addTickHsExpr (ExprWithTySigOut e ty) = addTickHsExpr (ExprWithTySig e ty) =
liftM2 ExprWithTySigOut liftM2 ExprWithTySig
(addTickLHsExprNever e) -- No need to tick the inner expression (addTickLHsExprNever e) -- No need to tick the inner expression
-- for expressions with signatures -- for expressions with signatures
(return ty) (return ty)
...@@ -594,11 +594,16 @@ addTickHsExpr (HsProc pat cmdtop) = ...@@ -594,11 +594,16 @@ addTickHsExpr (HsProc pat cmdtop) =
addTickHsExpr (HsWrap w e) = addTickHsExpr (HsWrap w e) =
liftM2 HsWrap liftM2 HsWrap
(return w) (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) addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e)
addTickTupArg :: LHsTupArg Id -> TM (LHsTupArg Id) addTickTupArg :: LHsTupArg Id -> TM (LHsTupArg Id)
......
...@@ -616,7 +616,7 @@ dsCmd _ids local_vars _stack_ty _res_ty (HsCmdArrForm op _ args) env_ids = do ...@@ -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 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 (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') return (wrapped_cmd, env_ids')
dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c) dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c)
......
...@@ -653,7 +653,7 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields ...@@ -653,7 +653,7 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
Nothing -> mkTcReflCo Nominal ty Nothing -> mkTcReflCo Nominal ty
in if null eq_spec in if null eq_spec
then rhs then rhs
else mkLHsWrap (mkWpCast (mkTcSubCo wrap_co)) rhs else mkLHsWrap (mkWpCastN wrap_co) rhs
-- eq_spec is always null for a PatSynCon -- eq_spec is always null for a PatSynCon
PatSynCon _ -> rhs PatSynCon _ -> rhs
......
...@@ -101,14 +101,14 @@ dsForeigns' fos = do ...@@ -101,14 +101,14 @@ dsForeigns' fos = do
where where
do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl) 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) traceIf (text "fi start" <+> ppr id)
(bs, h, c) <- dsFImport (unLoc id) co spec (bs, h, c) <- dsFImport (unLoc id) co spec
traceIf (text "fi end" <+> ppr id) traceIf (text "fi end" <+> ppr id)
return (h, c, [], bs) return (h, c, [], bs)
do_decl (ForeignExport (L _ id) _ co do_decl (ForeignExport { fd_name = L _ id, fd_co = co
(CExport (L _ (CExportStatic _ ext_nm cconv)) _)) = do , fd_fe = CExport (L _ (CExportStatic _ ext_nm cconv)) _ }) = do
(h, c, _, _) <- dsFExport id co ext_nm cconv False (h, c, _, _) <- dsFExport id co ext_nm cconv False
return (h, c, [id], []) return (h, c, [id], [])
......
...@@ -180,9 +180,19 @@ repTopDs group@(HsGroup { hs_valds = valds ...@@ -180,9 +180,19 @@ repTopDs group@(HsGroup { hs_valds = valds
hsSigTvBinders :: HsValBinds Name -> [Name] hsSigTvBinders :: HsValBinds Name -> [Name]
-- See Note [Scoped type variables in bindings] -- See Note [Scoped type variables in bindings]
hsSigTvBinders binds hsSigTvBinders binds
= [hsLTyVarName tv | L _ (TypeSig _ (L _ (HsForAllTy Explicit _ qtvs _ _)) _) <- sigs = concatMap get_scoped_tvs sigs
, tv <- hsQTvBndrs qtvs]
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 sigs = case binds of
ValBindsIn _ sigs -> sigs ValBindsIn _ sigs -> sigs
ValBindsOut _ sigs -> sigs ValBindsOut _ sigs -> sigs
...@@ -312,7 +322,8 @@ repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info, ...@@ -312,7 +322,8 @@ repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info,
fdResultSig = L _ resultSig, fdResultSig = L _ resultSig,
fdInjectivityAnn = injectivity })) fdInjectivityAnn = injectivity }))
= do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] = 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 resTyVar = case resultSig of
TyVarSig bndr -> mkHsQTvs [bndr] TyVarSig bndr -> mkHsQTvs [bndr]
_ -> mkHsQTvs [] _ -> mkHsQTvs []
...@@ -389,8 +400,8 @@ repAssocTyFamDefaults = mapM rep_deflt ...@@ -389,8 +400,8 @@ repAssocTyFamDefaults = mapM rep_deflt
; repTySynInst tc1 eqn1 } ; repTySynInst tc1 eqn1 }
------------------------- -------------------------
mk_extra_tvs :: Located Name -> LHsTyVarBndrs Name mk_extra_tvs :: Located Name -> LHsQTyVars Name
-> HsDataDefn Name -> DsM (LHsTyVarBndrs Name) -> HsDataDefn Name -> DsM (LHsQTyVars Name)
-- If there is a kind signature it must be of form -- If there is a kind signature it must be of form
-- k1 -> .. -> kn -> * -- k1 -> .. -> kn -> *
-- Return type variables [tv1:k1, tv2:k2, .., tvn:kn] -- Return type variables [tv1:k1, tv2:k2, .., tvn:kn]
...@@ -445,7 +456,7 @@ repClsInstD :: ClsInstDecl Name -> DsM (Core TH.DecQ) ...@@ -445,7 +456,7 @@ repClsInstD :: ClsInstDecl Name -> DsM (Core TH.DecQ)
repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
, cid_sigs = prags, cid_tyfam_insts = ats , cid_sigs = prags, cid_tyfam_insts = ats
, cid_datafam_insts = adts }) , cid_datafam_insts = adts })
= addTyVarBinds tvs $ \_ -> = addSimpleTyVarBinds tvs $
-- We must bring the type variables into scope, so their -- We must bring the type variables into scope, so their
-- occurrences don't fail, even though the binders don't -- occurrences don't fail, even though the binders don't
-- appear in the resulting data structure -- appear in the resulting data structure
...@@ -455,10 +466,8 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds ...@@ -455,10 +466,8 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
-- For example, the method names should be bound to -- For example, the method names should be bound to
-- the selector Ids, not to fresh names (Trac #5410) -- the selector Ids, not to fresh names (Trac #5410)
-- --
do { cxt1 <- repContext cxt do { cxt1 <- repLContext cxt
; cls_tcon <- repTy (HsTyVar cls) ; inst_ty1 <- repLTy inst_ty
; cls_tys <- repLTys tys
; inst_ty1 <- repTapps cls_tcon cls_tys
; binds1 <- rep_binds binds ; binds1 <- rep_binds binds
; prags1 <- rep_sigs prags ; prags1 <- rep_sigs prags
; ats1 <- mapM (repTyFamInstD . unLoc) ats ; ats1 <- mapM (repTyFamInstD . unLoc) ats
...@@ -466,19 +475,17 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds ...@@ -466,19 +475,17 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
; decls <- coreList decQTyConName (ats1 ++ adts1 ++ binds1 ++ prags1) ; decls <- coreList decQTyConName (ats1 ++ adts1 ++ binds1 ++ prags1)
; repInst cxt1 inst_ty1 decls } ; repInst cxt1 inst_ty1 decls }
where where
Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
repStandaloneDerivD :: LDerivDecl Name -> DsM (SrcSpan, Core TH.DecQ) repStandaloneDerivD :: LDerivDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repStandaloneDerivD (L loc (DerivDecl { deriv_type = ty })) repStandaloneDerivD (L loc (DerivDecl { deriv_type = ty }))
= do { dec <- addTyVarBinds tvs $ \_ -> = do { dec <- addSimpleTyVarBinds tvs $
do { cxt' <- repContext cxt do { cxt' <- repLContext cxt
; cls_tcon <- repTy (HsTyVar cls) ; inst_ty' <- repLTy inst_ty
; cls_tys <- repLTys tys ; repDeriv cxt' inst_ty' }
; inst_ty <- repTapps cls_tcon cls_tys
; repDeriv cxt' inst_ty }
; return (loc, dec) } ; return (loc, dec) }
where where
Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ) repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ)
repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn }) repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
...@@ -488,9 +495,9 @@ repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn }) ...@@ -488,9 +495,9 @@ repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
; repTySynInst tc eqn1 } ; repTySynInst tc eqn1 }
repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ) repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ)
repTyFamEqn (L loc (TyFamEqn { tfe_pats = HsWB { hswb_cts = tys repTyFamEqn (L loc (TyFamEqn { tfe_pats = HsIB { hsib_body = tys
, hswb_kvs = kv_names , hsib_kvs = kv_names
, hswb_tvs = tv_names } , hsib_tvs = tv_names }
, tfe_rhs = rhs })) , tfe_rhs = rhs }))
= do { let hs_tvs = HsQTvs { hsq_kvs = kv_names = do { let hs_tvs = HsQTvs { hsq_kvs = kv_names
, hsq_tvs = userHsTyVarBndrs loc tv_names } -- Yuk , hsq_tvs = userHsTyVarBndrs loc tv_names } -- Yuk
...@@ -502,7 +509,7 @@ repTyFamEqn (L loc (TyFamEqn { tfe_pats = HsWB { hswb_cts = tys ...@@ -502,7 +509,7 @@ repTyFamEqn (L loc (TyFamEqn { tfe_pats = HsWB { hswb_cts = tys
repDataFamInstD :: DataFamInstDecl Name -> DsM (Core TH.DecQ) repDataFamInstD :: DataFamInstDecl Name -> DsM (Core TH.DecQ)
repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name 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 }) , dfid_defn = defn })
= do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences] = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
; let loc = getLoc tc_name ; let loc = getLoc tc_name
...@@ -512,9 +519,10 @@ repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name ...@@ -512,9 +519,10 @@ repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name
; repDataDefn tc bndrs (Just tys1) tv_names defn } } ; repDataDefn tc bndrs (Just tys1) tv_names defn } }
repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ) 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 cc' <- repCCallConv cc
MkC s' <- repSafety s MkC s' <- repSafety s
cis' <- conv_cimportspec cis cis' <- conv_cimportspec cis
...@@ -580,16 +588,17 @@ repRuleD (L loc (HsRule n act bndrs lhs _ rhs _)) ...@@ -580,16 +588,17 @@ repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
ruleBndrNames :: LRuleBndr Name -> [Name] ruleBndrNames :: LRuleBndr Name -> [Name]
ruleBndrNames (L _ (RuleBndr n)) = [unLoc n] 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 = unLoc n : kvs ++ tvs
repRuleBndr :: LRuleBndr Name -> DsM (Core TH.RuleBndrQ) repRuleBndr :: LRuleBndr Name -> DsM (Core TH.RuleBndrQ)
repRuleBndr (L _ (RuleBndr n)) repRuleBndr (L _ (RuleBndr n))
= do { MkC n' <- lookupLBinder n = do { MkC n' <- lookupLBinder n
; rep2 ruleVarName [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'] } ; rep2 typedRuleVarName [n', ty'] }
repAnnD :: LAnnDecl Name -> DsM (SrcSpan, Core TH.DecQ) repAnnD :: LAnnDecl Name -> DsM (SrcSpan, Core TH.DecQ)
...@@ -701,15 +710,15 @@ repBangTy ty = do ...@@ -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 Nothing = coreList nameTyConName []
repDerivs (Just (L _ ctxt)) repDerivs (Just (L _ ctxt))
= repList nameTyConName rep_deriv ctxt = repList nameTyConName (rep_deriv . hsSigType) ctxt
where where
rep_deriv :: LHsType Name -> DsM (Core TH.Name) rep_deriv :: LHsType Name -> DsM (Core TH.Name)
-- Deriving clauses must have the simple H98 form -- Deriving clauses must have the simple H98 form
rep_deriv ty rep_deriv ty
| Just (cls, []) <- splitHsClassTy_maybe (unLoc ty) | Just (L _ cls, []) <- splitLHsClassTy_maybe ty
= lookupOcc cls = lookupOcc cls
| otherwise | otherwise
= notHandled "Non-H98 deriving clause" (ppr ty) = notHandled "Non-H98 deriving clause" (ppr ty)
...@@ -729,9 +738,11 @@ rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ; ...@@ -729,9 +738,11 @@ rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
return (concat sigs1) } return (concat sigs1) }
rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)] 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 d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d)
rep_sig (L _ (FixSig {})) = return [] -- fixity sigs at top level rep_sig (L _ (FixSig {})) = return [] -- fixity sigs at top level
rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc
...@@ -740,25 +751,33 @@ rep_sig (L loc (SpecSig nm tys ispec)) ...@@ -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 loc (SpecInstSig _ ty)) = rep_specialiseInst ty loc
rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty 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 ; sig <- repProto mk_sig nm1 ty1
; return (loc, sig) } ; 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 -- We must special-case the top-level explicit for-all of a TypeSig
-- See Note [Scoped type variables in bindings] -- See Note [Scoped type variables in bindings]
rep_ty (HsForAllTy Explicit _ tvs ctxt ty) rep_wc_ty_sig mk_sig loc sig_ty nm
= do { let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv) | 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 } ; repTyVarBndrWithKind tv name }
; bndrs1 <- repList tyVarBndrTyConName rep_in_scope_tv (hsQTvBndrs tvs) all_tvs = map (noLoc . UserTyVar . noLoc) implicit_tvs ++ explicit_tvs
; ctxt1 <- repLContext ctxt ; th_tvs <- repList tyVarBndrTyConName rep_in_scope_tv all_tvs
; ty1 <- repLTy ty ; th_ctxt <- repLContext ctxt
; repTForall bndrs1 ctxt1 ty1 } ; th_ty <- repLTy ty
; ty1 <- if null all_tvs && null (unLoc ctxt)
rep_ty ty = repTy ty 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 rep_inline :: Located Name
-> InlinePragma -- Never defaultInlinePragma -> InlinePragma -- Never defaultInlinePragma
...@@ -773,11 +792,11 @@ rep_inline nm ispec loc ...@@ -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)] -> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialise nm ty ispec loc rep_specialise nm ty ispec loc
= do { nm1 <- lookupLOcc nm = do { nm1 <- lookupLOcc nm
; ty1 <- repLTy ty ; ty1 <- repHsSigType ty
; phases <- repPhases $ inl_act ispec ; phases <- repPhases $ inl_act ispec
; let inline = inl_inline ispec ; let inline = inl_inline ispec
; pragma <- if isEmptyInlineSpec inline ; pragma <- if isEmptyInlineSpec inline
...@@ -789,9 +808,9 @@ rep_specialise nm ty ispec loc ...@@ -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 ; pragma <- repPragSpecInst ty1
; return [(loc, pragma)] } ; return [(loc, pragma)] }
...@@ -816,7 +835,15 @@ repPhases _ = dataCon allPhasesDataConName ...@@ -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 -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a))) -- action in the ext env
-> DsM (Core (TH.Q a)) -> DsM (Core (TH.Q a))
-- gensym a list of type variables and enter them into the meta environment; -- 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 ...@@ -834,7 +861,7 @@ addTyVarBinds (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs }) m
where where
mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v) mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
addTyClTyVarBinds :: LHsTyVarBndrs Name addTyClTyVarBinds :: LHsQTyVars Name
-> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a))) -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))
-> DsM (Core (TH.Q a)) -> DsM (Core (TH.Q a))
...@@ -885,6 +912,24 @@ repContext :: HsContext Name -> DsM (Core TH.CxtQ) ...@@ -885,6 +912,24 @@ repContext :: HsContext Name -> DsM (Core TH.CxtQ)
repContext ctxt = do preds <- repList typeQTyConName repLTy ctxt repContext ctxt = do preds <- repList typeQTyConName repLTy ctxt
repCtxt preds 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 -- yield the representation of a list of types
-- --
repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ] repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
...@@ -895,27 +940,18 @@ repLTys tys = mapM repLTy tys ...@@ -895,27 +940,18 @@ repLTys tys = mapM repLTy tys
repLTy :: LHsType Name -> DsM (Core TH.TypeQ) repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
repLTy (L _ ty) = repTy ty repLTy (L _ ty) = repTy ty