Skip to content

GitLab

GHC
GHC
Commit b857c8ad authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files
Options

Refactor HsDecls.TyClDecl to extract the type HsTyDefn, which is the 

RHS of a data type or type synonym declaration.  This can be shared
between type declarations and type *instance* declarations.
parent ca7c3a0e
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 807 additions and 836 deletions
compiler/deSugar/DsMeta.hs
View file @ b857c8ad
......@@ -134,7 +134,7 @@ repTopDs group
-- more needed
return (de_loc $ sort_by_loc $
val_ds ++ catMaybes tycl_ds ++ fix_ds
++ catMaybes inst_ds ++ for_ds) }) ;
++ inst_ds ++ for_ds) }) ;
decl_ty <- lookupType decQTyConName ;
let { core_list = coreList' decl_ty decls } ;
......@@ -194,53 +194,12 @@ repTyClD (L loc (TyFamily { tcdFlavour = flavour,
; return $ Just (loc, dec)
}
repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt, tcdKindSig = mb_kind,
tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys,
tcdCons = cons, tcdDerivs = mb_derivs }))
= do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
; tc_tvs <- mk_extra_tvs tvs mb_kind
; dec <- addTyClTyVarBinds tc_tvs $ \bndrs ->
do { cxt1 <- repLContext cxt
; opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts
; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
; cons1 <- mapM (repC (hsLTyVarNames tc_tvs)) cons
; cons2 <- coreList conQTyConName cons1
; derivs1 <- repDerivs mb_derivs
; bndrs1 <- coreList tyVarBndrTyConName bndrs
; repData cxt1 tc1 bndrs1 opt_tys2 cons2 derivs1
}
; return $ Just (loc, dec)
}
repTyClD (L loc (TyData { tcdND = NewType, tcdCtxt = cxt, tcdKindSig = mb_kind,
tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys,
tcdCons = [con], tcdDerivs = mb_derivs }))
= do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
; tc_tvs <- mk_extra_tvs tvs mb_kind
repTyClD (L loc (TyDecl { tcdLName = tc, tcdTyVars = tvs, tcdTyDefn = defn }))
= do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
; tc_tvs <- mk_extra_tvs tc tvs defn
; dec <- addTyClTyVarBinds tc_tvs $ \bndrs ->
do { cxt1 <- repLContext cxt
; opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts
; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
; con1 <- repC (hsLTyVarNames tc_tvs) con
; derivs1 <- repDerivs mb_derivs
; bndrs1 <- coreList tyVarBndrTyConName bndrs
; repNewtype cxt1 tc1 bndrs1 opt_tys2 con1 derivs1
}
; return $ Just (loc, dec)
}
repTyClD (L loc (TySynonym { tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys,
tcdSynRhs = ty }))
= do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
; dec <- addTyClTyVarBinds tvs $ \bndrs ->
do { opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts
; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
; ty1 <- repLTy ty
; bndrs1 <- coreList tyVarBndrTyConName bndrs
; repTySyn tc1 bndrs1 opt_tys2 ty1
}
; return (Just (loc, dec))
}
repTyDefn tc1 bndrs Nothing (hsLTyVarNames tc_tvs) defn
; return (Just (loc, dec)) }
repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
tcdTyVars = tvs, tcdFDs = fds,
......@@ -254,8 +213,7 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
; fds1 <- repLFunDeps fds
; ats1 <- repTyClDs ats
; decls1 <- coreList decQTyConName (ats1 ++ sigs1 ++ binds1)
; bndrs1 <- coreList tyVarBndrTyConName bndrs
; repClass cxt1 cls1 bndrs1 fds1 decls1
; repClass cxt1 cls1 bndrs fds1 decls1
}
; return $ Just (loc, dec)
}
......@@ -266,22 +224,45 @@ repTyClD (L loc d) = putSrcSpanDs loc $
; return Nothing }
-------------------------
mk_extra_tvs :: [LHsTyVarBndr Name] -> Maybe (HsBndrSig (LHsKind Name)) -> DsM [LHsTyVarBndr Name]
repTyDefn :: Core TH.Name -> Core [TH.TyVarBndr]
-> Maybe (Core [TH.TypeQ])
-> [Name] -> HsTyDefn Name
-> DsM (Core TH.DecQ)
repTyDefn tc bndrs opt_tys tv_names
(TyData { td_ND = new_or_data, td_ctxt = cxt
, td_cons = cons, td_derivs = mb_derivs })
= do { cxt1 <- repLContext cxt
; derivs1 <- repDerivs mb_derivs
; case new_or_data of
NewType -> do { con1 <- repC tv_names (head cons)
; repNewtype cxt1 tc bndrs opt_tys con1 derivs1 }
DataType -> do { cons1 <- mapM (repC tv_names) cons
; cons2 <- coreList conQTyConName cons1
; repData cxt1 tc bndrs opt_tys cons2 derivs1 } }
repTyDefn tc bndrs opt_tys _ (TySynonym { td_synRhs = ty })
= do { ty1 <- repLTy ty
; repTySyn tc bndrs opt_tys ty1 }
-------------------------
mk_extra_tvs :: Located Name -> [LHsTyVarBndr Name]
-> HsTyDefn Name -> DsM [LHsTyVarBndr Name]
-- If there is a kind signature it must be of form
-- k1 -> .. -> kn -> *
-- Return type variables [tv1:k1, tv2:k2, .., tvn:kn]
mk_extra_tvs tvs Nothing
= return tvs
mk_extra_tvs tvs (Just (HsBSig hs_kind _))
mk_extra_tvs tc tvs defn
| TyData { td_kindSig = Just (HsBSig hs_kind _) } <- defn
= do { extra_tvs <- go hs_kind
; return (tvs ++ extra_tvs) }
| otherwise
= return tvs
where
go :: LHsKind Name -> DsM [LHsTyVarBndr Name]
go (L loc (HsFunTy kind rest))
= do { uniq <- newUnique
; let { occ = mkTyVarOccFS (fsLit "t")
; nm = mkInternalName uniq occ loc
; hs_tv = L loc (KindedTyVar nm (HsBSig kind placeHolderBndrs)) }
; hs_tv = L loc (KindedTyVar nm (mkHsBSig kind)) }
; hs_tvs <- go rest
; return (hs_tv : hs_tvs) }
......@@ -289,9 +270,7 @@ mk_extra_tvs tvs (Just (HsBSig hs_kind _))
| n == liftedTypeKindTyConName
= return []
go _ = failWithDs (hang (ptext (sLit "Malformed kind signature"))
2 (ppr hs_kind))
go _ = failWithDs (ptext (sLit "Malformed kind signature for") <+> ppr tc)
-------------------------
-- represent fundeps
......@@ -314,14 +293,27 @@ repFamilyFlavour :: FamilyFlavour -> DsM (Core TH.FamFlavour)
repFamilyFlavour TypeFamily = rep2 typeFamName []
repFamilyFlavour DataFamily = rep2 dataFamName []
-- represent instance declarations
-- represent associated family declarations
--
repInstD :: LInstDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
repInstD (L loc (FamInstDecl fi_decl))
= repTyClD (L loc fi_decl)
repLAssocFamilys :: [LTyClDecl Name] -> DsM [Core TH.DecQ]
repLAssocFamilys = mapM repLAssocFamily
where
repLAssocFamily tydecl@(L _ (TyFamily {}))
= liftM (snd . fromJust) $ repTyFamily tydecl lookupTyVarBinds
repLAssocFamily tydecl
= failWithDs msg
where
msg = ptext (sLit "Illegal associated declaration in class:") <+>
ppr tydecl
-- Represent instance declarations
--
repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repInstD (L loc (FamInstD fi_decl))
= do { dec <- repFamInstD fi_decl
; return (loc, dec) }
repInstD (L loc (ClsInstDecl ty binds prags ats))
repInstD (L loc (ClsInstD ty binds prags ats))
= do { dec <- addTyVarBinds tvs $ \_ ->
-- We must bring the type variables into scope, so their
-- occurrences don't fail, even though the binders don't
......@@ -338,13 +330,23 @@ repInstD (L loc (ClsInstDecl ty binds prags ats))
; inst_ty1 <- repTapps cls_tcon cls_tys
; binds1 <- rep_binds binds
; prags1 <- rep_sigs prags
; ats1 <- repTyClDs ats
; ats1 <- mapM (repFamInstD . unLoc) ats
; decls <- coreList decQTyConName (ats1 ++ binds1 ++ prags1)
; repInst cxt1 inst_ty1 decls }
; return (Just (loc, dec)) }
; return (loc, dec) }
where
Just (tvs, cxt, cls, tys) = splitHsInstDeclTy_maybe (unLoc ty)
repFamInstD :: FamInstDecl Name -> DsM (Core TH.DecQ)
repFamInstD (FamInstDecl { fid_tycon = tc_name, fid_pats = HsBSig tys tv_names, fid_defn = defn })
= do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
; let loc = getLoc tc_name
hs_tvs = [ L loc (UserTyVar n) | n <- tv_names] -- Yuk
; addTyVarBinds hs_tvs $ \ bndrs ->
do { tys1 <- repLTys tys
; tys2 <- coreList typeQTyConName tys1
; repTyDefn tc bndrs (Just tys2) tv_names defn } }
repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
repForD (L loc (ForeignImport name typ _ (CImport cc s mch cis)))
= do MkC name' <- lookupLOcc name
......@@ -414,8 +416,7 @@ repC tvs (L _ (ConDecl { con_name = con
do { con1 <- lookupLOcc con -- See note [Binders and occurrences]
; c' <- repConstr con1 details
; ctxt' <- repContext (eq_ctxt ++ ctxt)
; ex_bndrs' <- coreList tyVarBndrTyConName ex_bndrs
; rep2 forallCName [unC ex_bndrs', unC ctxt', unC c'] } }
; rep2 forallCName [unC ex_bndrs, unC ctxt', unC c'] } }
in_subst :: Name -> [(Name,Name)] -> Bool
in_subst _ [] = False
......@@ -591,7 +592,7 @@ rep_InlinePrag (InlinePragma { inl_act = activation, inl_rule = match, inl_inlin
--
type ProcessTyVarBinds a =
[LHsTyVarBndr 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))
-- gensym a list of type variables and enter them into the meta environment;
......@@ -602,13 +603,13 @@ addTyVarBinds :: ProcessTyVarBinds a
addTyVarBinds tvs m
= do { freshNames <- mkGenSyms (hsLTyVarNames tvs)
; term <- addBinds freshNames $
do { kindedBndrs <- mapM mk_tv_bndr (tvs `zip` freshNames)
; m kindedBndrs }
do { kbs1 <- mapM mk_tv_bndr (tvs `zip` freshNames)
; kbs2 <- coreList tyVarBndrTyConName kbs1
; m kbs2 }
; wrapGenSyms freshNames term }
where
mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
addTyClTyVarBinds :: ProcessTyVarBinds a
-- Used for data/newtype declarations, and family instances,
-- so that the nested type variables work right
......@@ -686,8 +687,7 @@ repTy (HsForAllTy _ tvs ctxt ty) =
addTyVarBinds tvs $ \bndrs -> do
ctxt1 <- repLContext ctxt
ty1 <- repLTy ty
bndrs1 <- coreList tyVarBndrTyConName bndrs
repTForall bndrs1 ctxt1 ty1
repTForall bndrs ctxt1 ty1
repTy (HsTyVar n)
| isTvOcc (nameOccName n) = do
......
compiler/hsSyn/Convert.lhs
View file @ b857c8ad
......@@ -31,7 +31,6 @@ import TysWiredIn
import BasicTypes as Hs
import ForeignCall
import Unique
import MonadUtils
import ErrUtils
import Bag
import Util
......@@ -42,7 +41,6 @@ import Control.Monad( unless )
import Language.Haskell.TH as TH hiding (sigP)
import Language.Haskell.TH.Syntax as TH
import GHC.Exts
-------------------------------------------------------------------
......@@ -165,45 +163,52 @@ cvtDec (PragmaD prag)
cvtDec (TySynD tc tvs rhs)
= do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
; rhs' <- cvtType rhs
; returnL $ TyClD (TySynonym { tcdLName = tc'
, tcdTyVars = tvs', tcdTyPats = Nothing
, tcdSynRhs = rhs', tcdFVs = placeHolderNames }) }
; returnL $ TyClD (TyDecl { tcdLName = tc'
, tcdTyVars = tvs'
, tcdTyDefn = TySynonym rhs'
, tcdFVs = placeHolderNames }) }
cvtDec (DataD ctxt tc tvs constrs derivs)
= do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
; cons' <- mapM cvtConstr constrs
; derivs' <- cvtDerivs derivs
; returnL $ TyClD (TyData { tcdND = DataType, tcdCType = Nothing
, tcdLName = tc', tcdCtxt = ctxt'
, tcdTyVars = tvs', tcdTyPats = Nothing, tcdKindSig = Nothing
, tcdCons = cons', tcdDerivs = derivs' }) }
; let defn = TyData { td_ND = DataType, td_cType = Nothing
, td_ctxt = ctxt'
, td_kindSig = Nothing
, td_cons = cons', td_derivs = derivs' }
; returnL $ TyClD (TyDecl { tcdLName = tc', tcdTyVars = tvs'
, tcdTyDefn = defn, tcdFVs = placeHolderNames }) }
cvtDec (NewtypeD ctxt tc tvs constr derivs)
= do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
; con' <- cvtConstr constr
; derivs' <- cvtDerivs derivs
; returnL $ TyClD (TyData { tcdND = NewType, tcdCType = Nothing
, tcdLName = tc', tcdCtxt = ctxt'
, tcdTyVars = tvs', tcdTyPats = Nothing, tcdKindSig = Nothing
, tcdCons = [con'], tcdDerivs = derivs'}) }
; let defn = TyData { td_ND = DataType, td_cType = Nothing
, td_ctxt = ctxt'
, td_kindSig = Nothing
, td_cons = [con'], td_derivs = derivs' }
; returnL $ TyClD (TyDecl { tcdLName = tc', tcdTyVars = tvs'
, tcdTyDefn = defn, tcdFVs = placeHolderNames }) }
cvtDec (ClassD ctxt cl tvs fds decs)
= do { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs
; fds' <- mapM cvt_fundep fds
; (binds', sigs', ats') <- cvt_ci_decs (ptext (sLit "a class declaration")) decs
; returnL $
TyClD $ ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
, tcdFDs = fds', tcdSigs = sigs', tcdMeths = binds'
, tcdATs = ats', tcdATDefs = [], tcdDocs = [] }
-- no docs in TH ^^
; (binds', sigs', fams', ats') <- cvt_ci_decs (ptext (sLit "a class declaration")) decs
; returnL $ TyClD $
ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
, tcdFDs = fds', tcdSigs = sigs', tcdMeths = binds'
, tcdATs = fams', tcdATDefs = ats', tcdDocs = [] }
-- no docs in TH ^^
}
cvtDec (InstanceD ctxt ty decs)
= do { (binds', sigs', ats') <- cvt_ci_decs (ptext (sLit "an instance declaration")) decs
= do { let doc = ptext (sLit "an instance declaration")
; (binds', sigs', fams', ats') <- cvt_ci_decs doc decs
; unless (null fams') (failWith (mkBadDecMsg doc fams'))
; ctxt' <- cvtContext ctxt
; L loc ty' <- cvtType ty
; let inst_ty' = L loc $ mkImplicitHsForAllTy ctxt' $ L loc ty'
; returnL $ InstD (ClsInstDecl inst_ty' binds' sigs' ats') }
; returnL $ InstD (ClsInstD inst_ty' binds' sigs' ats') }
cvtDec (ForeignD ford)
= do { ford' <- cvtForD ford
......@@ -218,47 +223,50 @@ cvtDec (FamilyD flav tc tvs kind)
cvtFamFlavour DataFam = DataFamily
cvtDec (DataInstD ctxt tc tys constrs derivs)
= do { (ctxt', tc', tvs', typats') <- cvt_tyinst_hdr ctxt tc tys
= do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
; cons' <- mapM cvtConstr constrs
; derivs' <- cvtDerivs derivs
; returnL $ InstD $ FamInstDecl $
TyData { tcdND = DataType, tcdCType = Nothing
, tcdLName = tc', tcdCtxt = ctxt'
, tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing
, tcdCons = cons', tcdDerivs = derivs' } }
; let defn = TyData { td_ND = DataType, td_cType = Nothing
, td_ctxt = ctxt'
, td_kindSig = Nothing
, td_cons = cons', td_derivs = derivs' }
; returnL $ InstD $ FamInstD $
FamInstDecl { fid_tycon = tc', fid_pats = typats', fid_defn = defn } }
cvtDec (NewtypeInstD ctxt tc tys constr derivs)
= do { (ctxt', tc', tvs', typats') <- cvt_tyinst_hdr ctxt tc tys
= do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
; con' <- cvtConstr constr
; derivs' <- cvtDerivs derivs
; returnL $ InstD $ FamInstDecl $
TyData { tcdND = NewType, tcdCType = Nothing
, tcdLName = tc', tcdCtxt = ctxt'
, tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing
, tcdCons = [con'], tcdDerivs = derivs' } }
; let defn = TyData { td_ND = NewType, td_cType = Nothing
, td_ctxt = ctxt'
, td_kindSig = Nothing
, td_cons = [con'], td_derivs = derivs' }
; returnL $ InstD $ FamInstD $
FamInstDecl { fid_tycon = tc', fid_pats = typats', fid_defn = defn } }
cvtDec (TySynInstD tc tys rhs)
= do { (_, tc', tvs', tys') <- cvt_tyinst_hdr [] tc tys
= do { (_, tc', tys') <- cvt_tyinst_hdr [] tc tys
; rhs' <- cvtType rhs
; returnL $ InstD $ FamInstDecl $
TySynonym { tcdLName = tc'
, tcdTyVars = tvs', tcdTyPats = tys'
, tcdSynRhs = rhs', tcdFVs = placeHolderNames } }
; returnL $ InstD $ FamInstD $
FamInstDecl { fid_tycon = tc', fid_pats = tys', fid_defn = TySynonym rhs' } }
----------------
cvt_ci_decs :: MsgDoc -> [TH.Dec]
-> CvtM (LHsBinds RdrName,
[LSig RdrName],
[LTyClDecl RdrName])
[LTyClDecl RdrName], -- Family decls
[LFamInstDecl RdrName])
-- Convert the declarations inside a class or instance decl
-- ie signatures, bindings, and associated types
cvt_ci_decs doc decs
= do { decs' <- mapM cvtDec decs
; let (ats', bind_sig_decs') = partitionWith is_fam_inst decs'
; let (sigs', prob_binds') = partitionWith is_sig bind_sig_decs'
; let (binds', bads) = partitionWith is_bind prob_binds'
; let (sigs', prob_binds') = partitionWith is_sig bind_sig_decs'
; let (binds', prob_fams') = partitionWith is_bind prob_binds'
; let (fams', bads) = partitionWith is_fam_decl prob_fams'
; unless (null bads) (failWith (mkBadDecMsg doc bads))
; return (listToBag binds', sigs', ats') }
; return (listToBag binds', sigs', fams', ats') }
----------------
cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
......@@ -275,40 +283,25 @@ cvt_tycl_hdr cxt tc tvs
cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
-> CvtM ( LHsContext RdrName
, Located RdrName
, [LHsTyVarBndr RdrName]
, Maybe [LHsType RdrName])
, HsBndrSig [LHsType RdrName])
cvt_tyinst_hdr cxt tc tys
= do { cxt' <- cvtContext cxt
; tc' <- tconNameL tc
; tvs <- concatMapM collect tys
; tvs' <- cvtTvs tvs
; tys' <- mapM cvtType tys
; return (cxt', tc', tvs', Just tys')
}
where
collect (ForallT _ _ _)
= failWith $ text "Forall type not allowed as type parameter"
collect (VarT tv) = return [PlainTV tv]
collect (ConT _) = return []
collect (TupleT _) = return []
collect (UnboxedTupleT _) = return []
collect ArrowT = return []
collect ListT = return []
collect (AppT t1 t2)
= do { tvs1 <- collect t1
; tvs2 <- collect t2
; return $ tvs1 ++ tvs2
}
collect (SigT (VarT tv) ki) = return [KindedTV tv ki]
collect (SigT ty _) = collect ty
; return (cxt', tc', mkHsBSig tys') }
-------------------------------------------------------------------
-- Partitioning declarations
-------------------------------------------------------------------
is_fam_inst :: LHsDecl RdrName -> Either (LTyClDecl RdrName) (LHsDecl RdrName)
is_fam_inst (L loc (Hs.InstD (FamInstDecl d))) = Left (L loc d)
is_fam_inst decl = Right decl
is_fam_decl :: LHsDecl RdrName -> Either (LTyClDecl RdrName) (LHsDecl RdrName)
is_fam_decl (L loc (TyClD d@(TyFamily {}))) = Left (L loc d)
is_fam_decl decl = Right decl
is_fam_inst :: LHsDecl RdrName -> Either (LFamInstDecl RdrName) (LHsDecl RdrName)
is_fam_inst (L loc (Hs.InstD (FamInstD d))) = Left (L loc d)
is_fam_inst decl = Right decl
is_sig :: LHsDecl RdrName -> Either (LSig RdrName) (LHsDecl RdrName)
is_sig (L loc (Hs.SigD sig)) = Left (L loc sig)
......@@ -318,7 +311,7 @@ is_bind :: LHsDecl RdrName -> Either (LHsBind RdrName) (LHsDecl RdrName)
is_bind (L loc (Hs.ValD bind)) = Left (L loc bind)
is_bind decl = Right decl
mkBadDecMsg :: MsgDoc -> [LHsDecl RdrName] -> MsgDoc
mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc
mkBadDecMsg doc bads
= sep [ ptext (sLit "Illegal declaration(s) in") <+> doc <> colon
, nest 2 (vcat (map Outputable.ppr bads)) ]
......@@ -764,7 +757,7 @@ cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) }
cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void }
cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t
; return $ SigPatIn p' (HsBSig t' placeHolderBndrs) }
; return $ SigPatIn p' (mkHsBSig t') }
cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p; return $ ViewPat e' p' void }
cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
......@@ -799,7 +792,7 @@ cvt_tv (TH.PlainTV nm)
cvt_tv (TH.KindedTV nm ki)
= do { nm' <- tName nm
; ki' <- cvtKind ki
; returnL $ KindedTyVar nm' (HsBSig ki' placeHolderBndrs) }
; returnL $ KindedTyVar nm' (mkHsBSig ki') }
cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
......@@ -883,7 +876,7 @@ cvtKind (ArrowK k1 k2) = do
cvtMaybeKind :: Maybe TH.Kind -> CvtM (Maybe (HsBndrSig (LHsKind RdrName)))
cvtMaybeKind Nothing = return Nothing
cvtMaybeKind (Just ki) = do { ki' <- cvtKind ki
; return (Just (HsBSig ki' placeHolderBndrs)) }
; return (Just (mkHsBSig ki')) }
-----------------------------------------------------------
cvtFixity :: TH.Fixity -> Hs.Fixity
......
compiler/hsSyn/HsDecls.lhs
View file @ b857c8ad
This diff is collapsed.
compiler/hsSyn/HsUtils.lhs
View file @ b857c8ad
......@@ -33,7 +33,7 @@ module HsUtils(
nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps,
nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, mkHsBSig,
-- Bindings
mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind,
......@@ -69,7 +69,7 @@ module HsUtils(
collectSigTysFromPats, collectSigTysFromPat,
hsLTyClDeclBinders, hsTyClDeclBinders, hsTyClDeclsBinders,
hsForeignDeclsBinders, hsGroupBinders,
hsForeignDeclsBinders, hsGroupBinders, hsFamInstBinders,
-- Collecting implicit binders
lStmtsImplicits, hsValBindsImplicits, lPatImplicits
......@@ -96,7 +96,6 @@ import Util
import Bag
import Data.Either
import Data.Maybe
\end{code}
......@@ -266,6 +265,9 @@ unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
mkHsString :: String -> HsLit
mkHsString s = HsString (mkFastString s)
mkHsBSig :: a -> HsBndrSig a
mkHsBSig x = HsBSig x placeHolderBndrs
-------------
userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)]
userHsTyVarBndrs bndrs = [ L loc (UserTyVar v) | L loc v <- bndrs ]
......@@ -622,9 +624,10 @@ hsTyClDeclsBinders :: [[LTyClDecl Name]] -> [Located (InstDecl Name)] -> [Name]
-- We need to look at instance declarations too,
-- because their associated types may bind data constructors
hsTyClDeclsBinders tycl_decls inst_decls
= [n | d <- instDeclFamInsts inst_decls ++ concat tycl_decls
, L _ n <- hsLTyClDeclBinders d]
= map unLoc (concatMap (concatMap hsLTyClDeclBinders) tycl_decls ++
concatMap (hsInstDeclBinders . unLoc) inst_decls)
-------------------
hsLTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name]
-- ^ Returns all the /binding/ names of the decl, along with their SrcLocs.
-- The first one is guaranteed to be the name of the decl. For record fields
......@@ -632,24 +635,37 @@ hsLTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name]
-- occurence. We use the equality to filter out duplicate field names
hsLTyClDeclBinders (L _ d) = hsTyClDeclBinders d
-------------------
hsTyClDeclBinders :: Eq name => TyClDecl name -> [Located name]
hsTyClDeclBinders (TyFamily {tcdLName = name}) = [name]
hsTyClDeclBinders (ForeignType {tcdLName = name}) = [name]
hsTyClDeclBinders (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats})
hsTyClDeclBinders (ClassDecl { tcdLName = cls_name, tcdSigs = sigs
, tcdATs = ats, tcdATDefs = fam_insts })
= cls_name :
concatMap hsLTyClDeclBinders ats ++ [n | L _ (TypeSig ns _) <- sigs, n <- ns]
hsTyClDeclBinders (TySynonym {tcdLName = name, tcdTyPats = mb_pats })
| isJust mb_pats = []
| otherwise = [name]
-- See Note [Binders in family instances]
hsTyClDeclBinders (TyData {tcdLName = tc_name, tcdCons = cons, tcdTyPats = mb_pats })
| isJust mb_pats = hsConDeclsBinders cons
| otherwise = tc_name : hsConDeclsBinders cons
concatMap hsLTyClDeclBinders ats ++
concatMap (hsFamInstBinders . unLoc) fam_insts ++
[n | L _ (TypeSig ns _) <- sigs, n <- ns]
hsTyClDeclBinders (TyDecl { tcdLName = name, tcdTyDefn = defn })
= name : hsTyDefnBinders defn
-------------------
hsInstDeclBinders :: Eq name => InstDecl name -> [Located name]
hsInstDeclBinders (ClsInstD { cid_fam_insts = fis }) = concatMap (hsFamInstBinders . unLoc) fis
hsInstDeclBinders (FamInstD fi) = hsFamInstBinders fi
-------------------
hsFamInstBinders :: Eq name => FamInstDecl name -> [Located name]
hsFamInstBinders (FamInstDecl { fid_defn = defn }) = hsTyDefnBinders defn
-------------------
hsTyDefnBinders :: Eq name => HsTyDefn name -> [Located name]
hsTyDefnBinders (TySynonym {}) = []
hsTyDefnBinders (TyData { td_cons = cons }) = hsConDeclsBinders cons
-- See Note [Binders in family instances]
-------------------
hsConDeclsBinders :: (Eq name) => [LConDecl name] -> [Located name]
-- See hsTyClDeclBinders for what this does
-- The function is boringly complicated because of the records
......
compiler/main/HscStats.lhs
View file @ b857c8ad
......@@ -141,7 +141,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
spec_info (Just (False, _)) = (0,0,0,0,0,1,0)
spec_info (Just (True, _)) = (0,0,0,0,0,0,1)
data_info (TyData {tcdCons = cs, tcdDerivs = derivs})
data_info (TyDecl { tcdTyDefn = TyData {td_cons = cs, td_derivs = derivs}})
= (length cs, case derivs of Nothing -> 0
Just ds -> length ds)
data_info _ = (0,0)
......@@ -152,9 +152,9 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
(classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl)))))
class_info _ = (0,0)
inst_info (FamInstDecl d) = case countATDecl d of
inst_info (FamInstD d) = case countATDecl d of
(tyd, dtd) -> (0,0,0,tyd,dtd)
inst_info (ClsInstDecl _ inst_meths inst_sigs ats)
inst_info (ClsInstD _ inst_meths inst_sigs ats)
= case count_sigs (map unLoc inst_sigs) of
(_,_,ss,is,_) ->
case foldr add2 (0, 0) (map (countATDecl . unLoc) ats) of
......@@ -163,10 +163,8 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
(map (count_bind.unLoc) (bagToList inst_meths))),
ss, is, tyDecl, dtDecl)
where
countATDecl (TyData {}) = (0, 1)
countATDecl (TySynonym {}) = (1, 0)
countATDecl d = pprPanic "countATDecl: Unhandled decl"
(ppr d)
countATDecl (FamInstDecl { fid_defn = TyData {} }) = (0, 1)
countATDecl (FamInstDecl { fid_defn = TySynonym {} }) = (1, 0)
addpr :: (Int,Int) -> Int
add2 :: (Int,Int) -> (Int,Int) -> (Int, Int)
......
compiler/parser/Parser.y.pp
View file @ b857c8ad
......@@ -617,7 +617,7 @@ ty_decl :: { LTyClDecl RdrName }
--
-- Note the use of type for the head; this allows
-- infix type constructors to be declared
{% mkTySynonym (comb2 $1 $4) False $2 $4 }
{% mkTySynonym (comb2 $1 $4) $2 $4 }
-- type family declarations
| 'type' 'family' type opt_kind_sig
......@@ -627,7 +627,7 @@ ty_decl :: { LTyClDecl RdrName }
-- ordinary data type or newtype declaration
| data_or_newtype capi_ctype tycl_hdr constrs deriving
{% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) False $2 $3
{% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) $2 $3
Nothing (reverse (unLoc $4)) (unLoc $5) }
-- We need the location on tycl_hdr in case
-- constrs and deriving are both empty
......@@ -636,7 +636,7 @@ ty_decl :: { LTyClDecl RdrName }
| data_or_newtype capi_ctype tycl_hdr opt_kind_sig
gadt_constrlist
deriving
{% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) False $2 $3
{% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) $2 $3
(unLoc $4) (unLoc $5) (unLoc $6) }
-- We need the location on tycl_hdr in case
-- constrs and deriving are both empty
......@@ -647,29 +647,29 @@ ty_decl :: { LTyClDecl RdrName }
inst_decl :: { LInstDecl RdrName }
: 'instance' inst_type where_inst
{ let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3)
in L (comb3 $1 $2 $3) (ClsInstDecl $2 binds sigs ats) }
{ let (binds, sigs, _, ats, _) = cvBindsAndSigs (unLoc $3)
in L (comb3 $1 $2 $3) (ClsInstD $2 binds sigs ats) }