Commit b857c8ad authored by Simon Peyton Jones's avatar Simon Peyton Jones

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
......@@ -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
......
......@@ -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
......
This diff is collapsed.
......@@ -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
......
......@@ -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)
......
......@@ -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 }