Skip to content
GitLab
Commit ef2491a3 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Add fixity declarations to Template Haskell (Trac #1541) 

There is an accompanying patch to the template-haskell library
parent 431c05b3
Hide whitespace changes
Inline Side-by-side
compiler/deSugar/DsMeta.hs
View file @ ef2491a3
......@@ -124,16 +124,16 @@ repTopDs group
-- return (Data t [] ...more t's... }
-- The other important reason is that the output must mention
-- only "T", not "Foo:T" where Foo is the current module
decls <- addBinds ss (do {
fix_ds <- mapM repFixD (hs_fixds group) ;
val_ds <- rep_val_binds (hs_valds group) ;
tycl_ds <- mapM repTyClD (concat (hs_tyclds group)) ;
inst_ds <- mapM repInstD (hs_instds group) ;
for_ds <- mapM repForD (hs_fords group) ;
-- more needed
return (de_loc $ sort_by_loc $
val_ds ++ catMaybes tycl_ds
val_ds ++ catMaybes tycl_ds ++ fix_ds
++ catMaybes inst_ds ++ for_ds) }) ;
decl_ty <- lookupType decQTyConName ;
......@@ -175,11 +175,12 @@ repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
repTyClD tydecl@(L _ (TyFamily {}))
= repTyFamily tydecl addTyVarBinds
repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt,
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]
; dec <- addTyVarBinds tvs $ \bndrs ->
; more_tvs <- mk_extra_tvs mb_kind
; dec <- addTyVarBinds (tvs ++ more_tvs) $ \bndrs ->
do { cxt1 <- repLContext cxt
; opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts
; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
......@@ -244,6 +245,34 @@ repTyClD (L loc d) = putSrcSpanDs loc $
do { warnDs (hang ds_msg 4 (ppr d))
; return Nothing }
-------------------------
mk_extra_tvs :: Maybe (HsBndrSig (LHsKind 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 Nothing
= return []
mk_extra_tvs (Just (HsBSig hs_kind _))
= go hs_kind
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_tvs <- go rest
; return (hs_tv : hs_tvs) }
go (L _ (HsTyVar n))
| n == liftedTypeKindTyConName
= return []
go _ = failWithDs (hang (ptext (sLit "Malformed kind signature"))
2 (ppr hs_kind))
-------------------------
-- The type variables in the head of families are treated differently when the
-- family declaration is associated. In that case, they are usage, not binding
-- occurences.
......@@ -261,9 +290,9 @@ repTyFamily (L loc (TyFamily { tcdFlavour = flavour,
; bndrs1 <- coreList tyVarBndrTyConName bndrs
; case opt_kind of
Nothing -> repFamilyNoKind flav tc1 bndrs1
Just ki -> do { ki1 <- repKind ki
; repFamilyKind flav tc1 bndrs1 ki1
}
Just (HsBSig ki _)
-> do { ki1 <- repKind ki
; repFamilyKind flav tc1 bndrs1 ki1 }
}
; return $ Just (loc, dec)
}
......@@ -314,7 +343,7 @@ repInstD (L loc (FamInstDecl fi_decl))
= repTyClD (L loc fi_decl)
repInstD (L loc (ClsInstDecl ty binds _ ats)) -- Ignore user pragmas for now
repInstD (L loc (ClsInstDecl 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
......@@ -330,8 +359,9 @@ repInstD (L loc (ClsInstDecl ty binds _ ats)) -- Ignore user pragmas for now
; cls_tys <- repLTys tys
; inst_ty1 <- repTapps cls_tcon cls_tys
; binds1 <- rep_binds binds
; prags1 <- rep_sigs prags
; ats1 <- repLAssocFamInst ats
; decls <- coreList decQTyConName (ats1 ++ binds1)
; decls <- coreList decQTyConName (ats1 ++ binds1 ++ prags1)
; repInst cxt1 inst_ty1 decls }
; return (Just (loc, dec)) }
where
......@@ -371,6 +401,17 @@ repSafety PlayRisky = rep2 unsafeName []
repSafety PlayInterruptible = rep2 interruptibleName []
repSafety PlaySafe = rep2 safeName []
repFixD :: LFixitySig Name -> DsM (SrcSpan, Core TH.DecQ)
repFixD (L loc (FixitySig name (Fixity prec dir)))
= do { MkC name' <- lookupLOcc name
; MkC prec' <- coreIntLit prec
; let rep_fn = case dir of
InfixL -> infixLDName
InfixR -> infixRDName
InfixN -> infixNDName
; dec <- rep2 rep_fn [prec', name']
; return (loc, dec) }
ds_msg :: SDoc
ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
......@@ -426,7 +467,7 @@ mkGadtCtxt data_tvs (ResTyGADT res_ty)
= return (go [] [] (data_tvs `zip` tys))
| otherwise
= failWithDs (ptext (sLit "Malformed constructor result type") <+> ppr res_ty)
= failWithDs (ptext (sLit "Malformed constructor result type:") <+> ppr res_ty)
where
go cxt subst [] = (cxt, subst)
go cxt subst ((data_tv, ty) : rest)
......@@ -607,7 +648,7 @@ repTyVarBndrWithKind :: LHsTyVarBndr Name
-> Core TH.Name -> DsM (Core TH.TyVarBndr)
repTyVarBndrWithKind (L _ (UserTyVar {})) nm
= repPlainTV nm
repTyVarBndrWithKind (L _ (KindedTyVar _ (HsBSig ki _) _)) nm
repTyVarBndrWithKind (L _ (KindedTyVar _ (HsBSig ki _))) nm
= repKind ki >>= repKindedTV nm
-- represent a type context
......@@ -1963,7 +2004,8 @@ parSName = libFun (fsLit "parS") parSIdKey
funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName,
pragSpecInlDName, familyNoKindDName, familyKindDName, dataInstDName,
newtypeInstDName, tySynInstDName :: Name
newtypeInstDName, tySynInstDName,
infixLDName, infixRDName, infixNDName :: Name
funDName = libFun (fsLit "funD") funDIdKey
valDName = libFun (fsLit "valD") valDIdKey
dataDName = libFun (fsLit "dataD") dataDIdKey
......@@ -1981,6 +2023,9 @@ familyKindDName = libFun (fsLit "familyKindD") familyKindDIdKey
dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey
newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey
tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey
infixLDName = libFun (fsLit "infixLD") infixLDIdKey
infixRDName = libFun (fsLit "infixRD") infixRDIdKey
infixNDName = libFun (fsLit "infixND") infixNDIdKey
-- type Ctxt = ...
cxtName :: Name
......@@ -2245,7 +2290,8 @@ parSIdKey = mkPreludeMiscIdUnique 323
funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,
classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey,
pragSpecDIdKey, pragSpecInlDIdKey, familyNoKindDIdKey, familyKindDIdKey,
dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey :: Unique
dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey,
infixLDIdKey, infixRDIdKey, infixNDIdKey :: Unique
funDIdKey = mkPreludeMiscIdUnique 330
valDIdKey = mkPreludeMiscIdUnique 331
dataDIdKey = mkPreludeMiscIdUnique 332
......@@ -2263,6 +2309,9 @@ familyKindDIdKey = mkPreludeMiscIdUnique 343
dataInstDIdKey = mkPreludeMiscIdUnique 344
newtypeInstDIdKey = mkPreludeMiscIdUnique 345
tySynInstDIdKey = mkPreludeMiscIdUnique 346
infixLDIdKey = mkPreludeMiscIdUnique 347
infixRDIdKey = mkPreludeMiscIdUnique 348
infixNDIdKey = mkPreludeMiscIdUnique 349
-- type Cxt = ...
cxtIdKey :: Unique
......
compiler/hsSyn/Convert.lhs
View file @ ef2491a3
......@@ -154,6 +154,10 @@ cvtDec (TH.SigD nm typ)
; ty' <- cvtType typ
; returnL $ Hs.SigD (TypeSig [nm'] ty') }
cvtDec (TH.InfixD fx nm)
= do { nm' <- vNameL nm
; returnL (Hs.SigD (FixSig (FixitySig nm' (cvtFixity fx)))) }
cvtDec (PragmaD prag)
= do { prag' <- cvtPragmaD prag
; returnL $ Hs.SigD prag' }
......@@ -250,7 +254,7 @@ cvt_ci_decs :: MsgDoc -> [TH.Dec]
-- ie signatures, bindings, and associated types
cvt_ci_decs doc decs
= do { decs' <- mapM cvtDec decs
; let (ats', bind_sig_decs') = partitionWith is_tycl 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'
; unless (null bads) (failWith (mkBadDecMsg doc bads))
......@@ -302,9 +306,9 @@ cvt_tyinst_hdr cxt tc tys
-- Partitioning declarations
-------------------------------------------------------------------
is_tycl :: LHsDecl RdrName -> Either (LTyClDecl RdrName) (LHsDecl RdrName)
is_tycl (L loc (Hs.TyClD tcd)) = Left (L loc tcd)
is_tycl decl = Right decl
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_sig :: LHsDecl RdrName -> Either (LSig RdrName) (LHsDecl RdrName)
is_sig (L loc (Hs.SigD sig)) = Left (L loc sig)
......@@ -791,12 +795,11 @@ cvtTvs tvs = mapM cvt_tv tvs
cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
cvt_tv (TH.PlainTV nm)
= do { nm' <- tName nm
; returnL $ UserTyVar nm' placeHolderKind
}
; returnL $ UserTyVar nm' }
cvt_tv (TH.KindedTV nm ki)
= do { nm' <- tName nm
; ki' <- cvtKind ki
; returnL $ KindedTyVar nm' (HsBSig ki' placeHolderBndrs) placeHolderKind }
; returnL $ KindedTyVar nm' (HsBSig ki' placeHolderBndrs) }
cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
......@@ -877,9 +880,18 @@ cvtKind (ArrowK k1 k2) = do
k2' <- cvtKind k2
returnL (HsFunTy k1' k2')
cvtMaybeKind :: Maybe TH.Kind -> CvtM (Maybe (LHsKind RdrName))
cvtMaybeKind :: Maybe TH.Kind -> CvtM (Maybe (HsBndrSig (LHsKind RdrName)))
cvtMaybeKind Nothing = return Nothing
cvtMaybeKind (Just ki) = cvtKind ki >>= return . Just
cvtMaybeKind (Just ki) = do { ki' <- cvtKind ki
; return (Just (HsBSig ki' placeHolderBndrs)) }
-----------------------------------------------------------
cvtFixity :: TH.Fixity -> Hs.Fixity
cvtFixity (TH.Fixity prec dir) = Hs.Fixity prec (cvt_dir dir)
where
cvt_dir TH.InfixL = Hs.InfixL
cvt_dir TH.InfixR = Hs.InfixR
cvt_dir TH.InfixN = Hs.InfixN
-----------------------------------------------------------
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment