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)
......
......@@ -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], [])
......
......@@ -180,9 +180,19 @@ repTopDs group@(HsGroup { hs_valds = valds
hsSigTvBinders :: HsValBinds Name -> [Name]
-- See Note [Scoped type variables in bindings]
hsSigTvBinders binds
= [hsLTyVarName tv | L _ (TypeSig _ (L _ (HsForAllTy Explicit _ qtvs _ _)) _) <- sigs
, tv <- hsQTvBndrs qtvs]
= concatMap get_scoped_tvs sigs
where
get_scoped_tvs :: LSig Name -> [Name]
-- Both implicit and explicit quantified variables
-- We need the implicit ones for f :: forall (a::k). blah
-- here 'k' scopes too
get_scoped_tvs (L _ (TypeSig _ sig))
| HsIB { hsib_kvs = implicit_kvs, hsib_tvs = implicit_tvs
, hsib_body = sig1 } <- sig
, (explicit_tvs, _) <- splitLHsForAllTy (hswc_body sig1)
= implicit_kvs ++ implicit_tvs ++ map hsLTyVarName explicit_tvs
get_scoped_tvs _ = []
sigs = case binds of
ValBindsIn _ sigs -> sigs
ValBindsOut _ sigs -> sigs
......@@ -312,7 +322,8 @@ repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info,
fdResultSig = L _ resultSig,
fdInjectivityAnn = injectivity }))
= do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
; let mkHsQTvs tvs = HsQTvs { hsq_kvs = [], hsq_tvs = tvs }
; let mkHsQTvs :: [LHsTyVarBndr Name] -> LHsQTyVars Name
mkHsQTvs tvs = HsQTvs { hsq_kvs = [], hsq_tvs = tvs }
resTyVar = case resultSig of
TyVarSig bndr -> mkHsQTvs [bndr]
_ -> mkHsQTvs []
......@@ -389,8 +400,8 @@ repAssocTyFamDefaults = mapM rep_deflt
; repTySynInst tc1 eqn1 }
-------------------------
mk_extra_tvs :: Located Name -> LHsTyVarBndrs Name
-> HsDataDefn Name -> DsM (LHsTyVarBndrs Name)
mk_extra_tvs :: Located Name -> LHsQTyVars Name
-> HsDataDefn Name -> DsM (LHsQTyVars Name)
-- If there is a kind signature it must be of form
-- k1 -> .. -> kn -> *
-- Return type variables [tv1:k1, tv2:k2, .., tvn:kn]
......@@ -445,7 +456,7 @@ repClsInstD :: ClsInstDecl Name -> DsM (Core TH.DecQ)
repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
, cid_sigs = prags, cid_tyfam_insts = ats
, cid_datafam_insts = adts })
= addTyVarBinds tvs $ \_ ->
= addSimpleTyVarBinds tvs $
-- We must bring the type variables into scope, so their
-- occurrences don't fail, even though the binders don't
-- appear in the resulting data structure
......@@ -455,10 +466,8 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
-- For example, the method names should be bound to
-- the selector Ids, not to fresh names (Trac #5410)
--
do { cxt1 <- repContext cxt
; cls_tcon <- repTy (HsTyVar cls)
; cls_tys <- repLTys tys
; inst_ty1 <- repTapps cls_tcon cls_tys
do { cxt1 <- repLContext cxt
; inst_ty1 <- repLTy inst_ty
; binds1 <- rep_binds binds
; prags1 <- rep_sigs prags
; ats1 <- mapM (repTyFamInstD . unLoc) ats
......@@ -466,19 +475,17 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
; decls <- coreList decQTyConName (ats1 ++ adts1 ++ binds1 ++ prags1)
; repInst cxt1 inst_ty1 decls }
where
Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty
(tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
repStandaloneDerivD :: LDerivDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repStandaloneDerivD (L loc (DerivDecl { deriv_type = ty }))
= do { dec <- addTyVarBinds tvs $ \_ ->
do { cxt' <- repContext cxt
; cls_tcon <- repTy (HsTyVar cls)
; cls_tys <- repLTys tys
; inst_ty <- repTapps cls_tcon cls_tys
; repDeriv cxt' inst_ty }
= do { dec <- addSimpleTyVarBinds tvs $
do { cxt' <- repLContext cxt
; inst_ty' <- repLTy inst_ty
; repDeriv cxt' inst_ty' }
; return (loc, dec) }
where
Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty
(tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ)
repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
......@@ -488,9 +495,9 @@ repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
; repTySynInst tc eqn1 }
repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ)
repTyFamEqn (L loc (TyFamEqn { tfe_pats = HsWB { hswb_cts = tys
, hswb_kvs = kv_names
, hswb_tvs = tv_names }
repTyFamEqn (L loc (TyFamEqn { tfe_pats = HsIB { hsib_body = tys
, hsib_kvs = kv_names
, hsib_tvs = tv_names }
, tfe_rhs = rhs }))
= do { let hs_tvs = HsQTvs { hsq_kvs = kv_names
, hsq_tvs = userHsTyVarBndrs loc tv_names } -- Yuk
......@@ -502,7 +509,7 @@ repTyFamEqn (L loc (TyFamEqn { tfe_pats = HsWB { hswb_cts = tys
repDataFamInstD :: DataFamInstDecl Name -> DsM (Core TH.DecQ)
repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name
, dfid_pats = HsWB { hswb_cts = tys, hswb_kvs = kv_names, hswb_tvs = tv_names }
, dfid_pats = HsIB { hsib_body = tys, hsib_kvs = kv_names, hsib_tvs = tv_names }
, dfid_defn = defn })
= do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
; let loc = getLoc tc_name
......@@ -512,9 +519,10 @@ repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name
; repDataDefn tc bndrs (Just tys1) tv_names defn } }
repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
repForD (L loc (ForeignImport name typ _ (CImport (L _ cc) (L _ s) mch cis _)))
repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
, fd_fi = CImport (L _ cc) (L _ s) mch cis _ }))
= do MkC name' <- lookupLOcc name
MkC typ' <- repLTy typ
MkC typ' <- repHsSigType typ
MkC cc' <- repCCallConv cc
MkC s' <- repSafety s
cis' <- conv_cimportspec cis
......@@ -580,16 +588,17 @@ repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
ruleBndrNames :: LRuleBndr Name -> [Name]
ruleBndrNames (L _ (RuleBndr n)) = [unLoc n]
ruleBndrNames (L _ (RuleBndrSig n (HsWB { hswb_kvs = kvs, hswb_tvs = tvs })))
ruleBndrNames (L _ (RuleBndrSig n sig))
| HsIB { hsib_kvs = kvs, hsib_tvs = tvs } <- sig
= unLoc n : kvs ++ tvs
repRuleBndr :: LRuleBndr Name -> DsM (Core TH.RuleBndrQ)
repRuleBndr (L _ (RuleBndr n))
= do { MkC n' <- lookupLBinder n
; rep2 ruleVarName [n'] }
repRuleBndr (L _ (RuleBndrSig n (HsWB { hswb_cts = ty })))
repRuleBndr (L _ (RuleBndrSig n sig))
= do { MkC n' <- lookupLBinder n
; MkC ty' <- repLTy ty
; MkC ty' <- repLTy (hsSigWcType sig)
; rep2 typedRuleVarName [n', ty'] }
repAnnD :: LAnnDecl Name -> DsM (SrcSpan, Core TH.DecQ)
......@@ -701,15 +710,15 @@ repBangTy ty = do
-- Deriving clause
-------------------------------------------------------
repDerivs :: Maybe (Located [LHsType Name]) -> DsM (Core [TH.Name])
repDerivs :: HsDeriving Name -> DsM (Core [TH.Name])
repDerivs Nothing = coreList nameTyConName []
repDerivs (Just (L _ ctxt))
= repList nameTyConName rep_deriv ctxt
= repList nameTyConName (rep_deriv . hsSigType) ctxt
where
rep_deriv :: LHsType Name -> DsM (Core TH.Name)
-- Deriving clauses must have the simple H98 form
rep_deriv ty
| Just (cls, []) <- splitHsClassTy_maybe (unLoc ty)
| Just (L _ cls, []) <- splitLHsClassTy_maybe ty
= lookupOcc cls
| otherwise
= notHandled "Non-H98 deriving clause" (ppr ty)
......@@ -729,9 +738,11 @@ rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
return (concat sigs1) }
rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
rep_sig (L loc (TypeSig nms ty _)) = mapM (rep_ty_sig sigDName loc ty) nms
rep_sig (L loc (TypeSig nms ty)) = mapM (rep_wc_ty_sig sigDName loc ty) nms
rep_sig (L _ (PatSynSig {})) = notHandled "Pattern type signatures" empty
rep_sig (L loc (GenericSig nms ty)) = mapM (rep_ty_sig defaultSigDName loc ty) nms
rep_sig (L loc (ClassOpSig is_deflt nms ty))
| is_deflt = mapM (rep_ty_sig defaultSigDName loc ty) nms
| otherwise = mapM (rep_ty_sig sigDName loc ty) nms
rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d)
rep_sig (L _ (FixSig {})) = return [] -- fixity sigs at top level
rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc
......@@ -740,25 +751,33 @@ rep_sig (L loc (SpecSig nm tys ispec))
rep_sig (L loc (SpecInstSig _ ty)) = rep_specialiseInst ty loc
rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty
rep_ty_sig :: Name -> SrcSpan -> LHsType Name -> Located Name
rep_ty_sig :: Name -> SrcSpan -> LHsSigType Name -> Located Name
-> DsM (SrcSpan, Core TH.DecQ)
rep_ty_sig mk_sig loc (L _ ty) nm
rep_ty_sig mk_sig loc sig_ty nm
= do { nm1 <- lookupLOcc nm
; ty1 <- rep_ty ty
; ty1 <- repHsSigType sig_ty
; sig <- repProto mk_sig nm1 ty1
; return (loc, sig) }
where
rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType Name -> Located Name
-> DsM (SrcSpan, Core TH.DecQ)
-- We must special-case the top-level explicit for-all of a TypeSig
-- See Note [Scoped type variables in bindings]
rep_ty (HsForAllTy Explicit _ tvs ctxt ty)
= do { let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
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 }
; bndrs1 <- repList tyVarBndrTyConName rep_in_scope_tv (hsQTvBndrs tvs)
; ctxt1 <- repLContext ctxt
; ty1 <- repLTy ty
; repTForall bndrs1 ctxt1 ty1 }
rep_ty ty = repTy ty
all_tvs = map (noLoc . UserTyVar . noLoc) implicit_tvs ++ explicit_tvs
; th_tvs <- repList tyVarBndrTyConName rep_in_scope_tv all_tvs
; th_ctxt <- repLContext ctxt
; th_ty <- repLTy ty
; ty1 <- if null all_tvs && null (unLoc ctxt)
then return th_ty
else repTForall th_tvs th_ctxt th_ty
; sig <- repProto mk_sig nm1 ty1
; return (loc, sig) }
rep_inline :: Located Name
-> InlinePragma -- Never defaultInlinePragma
......@@ -773,11 +792,11 @@ rep_inline nm ispec loc
; return [(loc, pragma)]
}
rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan
rep_specialise :: Located Name -> LHsSigType Name -> InlinePragma -> SrcSpan
-> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialise nm ty ispec loc
= do { nm1 <- lookupLOcc nm
; ty1 <- repLTy ty
; ty1 <- repHsSigType ty
; phases <- repPhases $ inl_act ispec
; let inline = inl_inline ispec
; pragma <- if isEmptyInlineSpec inline
......@@ -789,9 +808,9 @@ rep_specialise nm ty ispec loc
; return [(loc, pragma)]
}
rep_specialiseInst :: LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialiseInst :: LHsSigType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialiseInst ty loc
= do { ty1 <- repLTy ty
= do { ty1 <- repHsSigType ty
; pragma <- repPragSpecInst ty1
; return [(loc, pragma)] }
......@@ -816,7 +835,15 @@ repPhases _ = dataCon allPhasesDataConName
-- Types
-------------------------------------------------------
addTyVarBinds :: LHsTyVarBndrs Name -- the binders to be added
addSimpleTyVarBinds :: [Name] -- the binders to be added
-> DsM (Core (TH.Q a)) -- action in the ext env
-> DsM (Core (TH.Q a))
addSimpleTyVarBinds names thing_inside
= do { fresh_names <- mkGenSyms names
; term <- addBinds fresh_names thing_inside
; wrapGenSyms fresh_names term }
addTyVarBinds :: LHsQTyVars Name -- the binders to be added
-> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a))) -- action in the ext env
-> DsM (Core (TH.Q a))
-- gensym a list of type variables and enter them into the meta environment;
......@@ -834,7 +861,7 @@ addTyVarBinds (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs }) m
where
mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
addTyClTyVarBinds :: LHsTyVarBndrs Name
addTyClTyVarBinds :: LHsQTyVars Name
-> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))
-> DsM (Core (TH.Q a))
......@@ -885,6 +912,24 @@ repContext :: HsContext Name -> DsM (Core TH.CxtQ)
repContext ctxt = do preds <- repList typeQTyConName repLTy ctxt
repCtxt preds
repHsSigType :: LHsSigType Name -> DsM (Core TH.TypeQ)
repHsSigType ty = repLTy (hsSigType ty)
repHsSigWcType :: LHsSigWcType Name -> DsM (Core TH.TypeQ)
repHsSigWcType (HsIB { hsib_kvs = implicit_kvs
, hsib_tvs = implicit_tvs
, hsib_body = sig1 })
| (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy (hswc_body sig1)
= addTyVarBinds (HsQTvs { hsq_kvs = implicit_kvs
, hsq_tvs = map (noLoc . UserTyVar . noLoc) implicit_tvs
++ explicit_tvs })
$ \ th_tvs ->
do { th_ctxt <- repLContext ctxt
; th_ty <- repLTy ty
; if null implicit_tvs && null explicit_tvs && null (unLoc ctxt)
then return th_ty
else repTForall th_tvs th_ctxt th_ty }
-- yield the representation of a list of types
--
repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
......@@ -895,27 +940,18 @@ repLTys tys = mapM repLTy tys
repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
repLTy (L _ ty) = repTy ty
repTy :: HsType Name -> DsM (Core TH.TypeQ)
repTy (HsForAllTy _ extra tvs ctxt ty) =
addTyVarBinds tvs $ \bndrs -> do
ctxt1 <- repLContext ctxt'
ty1 <- repLTy ty
repTForall bndrs ctxt1 ty1
where
-- If extra is not Nothing, an extra-constraints wild card was removed
-- (just) before renaming. It must be put back now, otherwise the
-- represented type won't include this extra-constraints wild card.
ctxt'
| Just loc <- extra
= let uniq = panic "addExtraCtsWC"
-- This unique will be discarded by repLContext, but is required
-- to make a Name
name = mkInternalName uniq (mkTyVarOcc "_") loc
in (++ [L loc (HsWildCardTy (AnonWildCard (L loc name)))]) `fmap` ctxt
| otherwise
= ctxt
repForall :: HsType Name -> DsM (Core TH.TypeQ)
-- Arg of repForall is always HsForAllTy or HsQualTy
repForall ty
| (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty)
= addTyVarBinds (HsQTvs { hsq_kvs = [], hsq_tvs = tvs}) $ \bndrs ->
do { ctxt1 <- repLContext ctxt
; ty1 <- repLTy tau
; repTForall bndrs ctxt1 ty1 }
repTy :: HsType Name -> DsM (Core TH.TypeQ)
repTy ty@(HsForAllTy {}) = repForall ty
repTy ty@(HsQualTy {}) = repForall ty
repTy (HsTyVar (L _ n))
| isTvOcc occ = do tv1 <- lookupOcc n
......@@ -1152,7 +1188,11 @@ repE (RecordUpd { rupd_expr = e, rupd_flds = flds })
fs <- repUpdFields flds;
repRecUpd x fs }
repE (ExprWithTySig e ty _) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }
repE (ExprWithTySig e ty)
= do { e1 <- repLE e
; t1 <- repHsSigWcType ty
; repSigExp e1 t1 }
repE (ArithSeq _ _ aseq) =
case aseq of
From e -> do { ds1 <- repLE e; repFrom ds1 }
......
......@@ -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 \
......
......@@ -14,7 +14,6 @@ module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
thRdrNameGuesses ) where
import HsSyn as Hs
import HsTypes ( mkHsForAllTy )
import qualified Class
import RdrName
import qualified Name
......@@ -173,10 +172,10 @@ cvtDec (TH.FunD nm cls)
cvtDec (TH.SigD nm typ)
= do { nm' <- vNameL nm
; ty' <- cvtType typ
; returnJustL $ Hs.SigD (TypeSig [nm'] ty' PlaceHolder) }
; returnJustL $ Hs.SigD (TypeSig [nm'] (mkLHsSigWcType ty')) }
cvtDec (TH.InfixD fx nm)
-- fixity signatures are allowed for variables, constructors, and types
-- Fixity signatures are allowed for variables, constructors, and types
-- the renamer automatically looks for types during renaming, even when
-- the RdrName says it's a variable or a constructor. So, just assume
-- it's a variable or constructor and proceed.
......@@ -229,7 +228,8 @@ cvtDec (ClassD ctxt cl tvs fds decs)
; at_defs <- mapM cvt_at_def ats'
; returnJustL $ TyClD $
ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
, tcdFDs = fds', tcdSigs = sigs', tcdMeths = binds'
, tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'
, tcdMeths = binds'
, tcdATs = fams', tcdATDefs = at_defs, tcdDocs = []
, tcdFVs = placeHolderNames }
-- no docs in TH ^^
......@@ -247,9 +247,13 @@ cvtDec (InstanceD ctxt ty decs)
; unless (null fams') (failWith (mkBadDecMsg doc fams'))
; ctxt' <- cvtContext ctxt
; L loc ty' <- cvtType ty
; let inst_ty' = L loc $ mkHsForAllTy Implicit [] ctxt' $ L loc ty'
; let inst_ty' = L loc $ HsQualTy { hst_ctxt = ctxt', hst_body = L loc ty' }
; returnJustL $ InstD $ ClsInstD $
ClsInstDecl inst_ty' binds' sigs' ats' adts' Nothing }
ClsInstDecl { cid_poly_ty = mkLHsSigType inst_ty'
, cid_binds = binds'
, cid_sigs = Hs.mkClassOpSigs sigs'
, cid_tyfam_insts = ats', cid_datafam_insts = adts'
, cid_overlap_mode = Nothing } }
cvtDec (ForeignD ford)
= do { ford' <- cvtForD ford
......@@ -319,21 +323,21 @@ cvtDec (TH.RoleAnnotD tc roles)
cvtDec (TH.StandaloneDerivD cxt ty)
= do { cxt' <- cvtContext cxt
; L loc ty' <- cvtType ty
; let inst_ty' = L loc $ mkHsForAllTy Implicit [] cxt' $ L loc ty'
; let inst_ty' = L loc $ HsQualTy { hst_ctxt = cxt', hst_body = L loc ty' }
; returnJustL $ DerivD $
DerivDecl { deriv_type = inst_ty', deriv_overlap_mode = Nothing } }
DerivDecl { deriv_type = mkLHsSigType inst_ty', deriv_overlap_mode = Nothing } }
cvtDec (TH.DefaultSigD nm typ)
= do { nm' <- vNameL nm
; ty' <- cvtType typ
; returnJustL $ Hs.SigD $ GenericSig [nm'] ty' }
; returnJustL $ Hs.SigD $ ClassOpSig True [nm'] (mkLHsSigType ty') }
----------------
cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName)
cvtTySynEqn tc (TySynEqn lhs rhs)
= do { lhs' <- mapM cvtType lhs
; rhs' <- cvtType rhs
; returnL $ TyFamEqn { tfe_tycon = tc
, tfe_pats = mkHsWithBndrs lhs'
, tfe_pats = mkHsImplicitBndrs lhs'
, tfe_rhs = rhs' } }
----------------
......@@ -361,7 +365,7 @@ cvt_ci_decs doc decs
cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
-> CvtM ( LHsContext RdrName
, Located RdrName
, LHsTyVarBndrs RdrName)
, LHsQTyVars RdrName)
cvt_tycl_hdr cxt tc tvs
= do { cxt' <- cvtContext cxt
; tc' <- tconNameL tc
......@@ -372,12 +376,12 @@ cvt_tycl_hdr cxt tc tvs
cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
-> CvtM ( LHsContext RdrName