From 7583384214ed6aa4a90d77c5975728a9b06149f2 Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Thu, 19 Mar 2009 13:23:47 +0000 Subject: [PATCH] Template Haskell support for equality constraints --- compiler/deSugar/DsMeta.hs | 77 +++++++++++++++++++++++++++++---------- compiler/hsSyn/Convert.lhs | 35 ++++++++++++++---- compiler/typecheck/TcSplice.lhs | 18 ++++++--- 3 files changed, 98 insertions(+), 32 deletions(-) diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 5fb13df..82dffd7 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -314,7 +314,7 @@ repInstD' (L loc (InstDecl ty binds _ ats)) -- Ignore user pragmas for now -- occurrences don't fail, even though the binders don't -- appear in the resulting data structure do { cxt1 <- repContext cxt - ; inst_ty1 <- repPred (HsClassP cls tys) + ; inst_ty1 <- repPredTy (HsClassP cls tys) ; ss <- mkGenSyms (collectHsBindBinders binds) ; binds1 <- addBinds ss (rep_binds binds) ; ats1 <- repLAssocFamInst ats @@ -481,22 +481,36 @@ repLContext (L _ ctxt) = repContext ctxt repContext :: HsContext Name -> DsM (Core TH.CxtQ) repContext ctxt = do preds <- mapM repLPred ctxt - predList <- coreList typeQTyConName preds + predList <- coreList predQTyConName preds repCtxt predList -- represent a type predicate -- -repLPred :: LHsPred Name -> DsM (Core TH.TypeQ) +repLPred :: LHsPred Name -> DsM (Core TH.PredQ) repLPred (L _ p) = repPred p -repPred :: HsPred Name -> DsM (Core TH.TypeQ) -repPred (HsClassP cls tys) = do - tcon <- repTy (HsTyVar cls) - tys1 <- repLTys tys - repTapps tcon tys1 -repPred p@(HsEqualP _ _) = notHandled "Equational constraint" (ppr p) +repPred :: HsPred Name -> DsM (Core TH.PredQ) +repPred (HsClassP cls tys) + = do + cls1 <- lookupOcc cls + tys1 <- repLTys tys + tys2 <- coreList typeQTyConName tys1 + repClassP cls1 tys2 +repPred (HsEqualP tyleft tyright) + = do + tyleft1 <- repLTy tyleft + tyright1 <- repLTy tyright + repEqualP tyleft1 tyright1 repPred p@(HsIParam _ _) = notHandled "Implicit parameter constraint" (ppr p) +repPredTy :: HsPred Name -> DsM (Core TH.TypeQ) +repPredTy (HsClassP cls tys) + = do + tcon <- repTy (HsTyVar cls) + tys1 <- repLTys tys + repTapps tcon tys1 +repPredTy _ = panic "DsMeta.repPredTy: unexpected equality: internal error" + -- yield the representation of a list of types -- repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ] @@ -546,7 +560,7 @@ repTy (HsTupleTy _ tys) = do repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) `nlHsAppTy` ty2) repTy (HsParTy t) = repLTy t -repTy (HsPredTy pred) = repPred pred +repTy (HsPredTy pred) = repPredTy pred repTy ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty) repTy ty = notHandled "Exotic form of type" (ppr ty) @@ -1313,9 +1327,15 @@ repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys] repProto :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ) repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty] -repCtxt :: Core [TH.TypeQ] -> DsM (Core TH.CxtQ) +repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ) repCtxt (MkC tys) = rep2 cxtName [tys] +repClassP :: Core TH.Name -> Core [TH.TypeQ] -> DsM (Core TH.PredQ) +repClassP (MkC cla) (MkC tys) = rep2 classPName [cla, tys] + +repEqualP :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.PredQ) +repEqualP (MkC ty1) (MkC ty2) = rep2 equalPName [ty1, ty2] + repConstr :: Core TH.Name -> HsConDeclDetails Name -> DsM (Core TH.ConQ) repConstr con (PrefixCon ps) @@ -1517,6 +1537,8 @@ templateHaskellNames = [ newtypeInstDName, tySynInstDName, -- Cxt cxtName, + -- Pred + classPName, equalPName, -- Strict isStrictName, notStrictName, -- Con @@ -1541,11 +1563,11 @@ templateHaskellNames = [ -- And the tycons qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName, - clauseQTyConName, expQTyConName, fieldExpTyConName, stmtQTyConName, - decQTyConName, conQTyConName, strictTypeQTyConName, + clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName, + stmtQTyConName, decQTyConName, conQTyConName, strictTypeQTyConName, varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName, typeTyConName, matchTyConName, clauseTyConName, patQTyConName, - fieldPatQTyConName, fieldExpQTyConName, funDepTyConName, + fieldPatQTyConName, fieldExpQTyConName, funDepTyConName, predQTyConName, -- Quasiquoting quoteExpName, quotePatName] @@ -1568,7 +1590,7 @@ qqFun = mk_known_key_name OccName.varName qqLib -------------------- TH.Syntax ----------------------- qTyConName, nameTyConName, fieldExpTyConName, patTyConName, fieldPatTyConName, expTyConName, decTyConName, typeTyConName, - matchTyConName, clauseTyConName, funDepTyConName :: Name + matchTyConName, clauseTyConName, funDepTyConName, predTyConName :: Name qTyConName = thTc (fsLit "Q") qTyConKey nameTyConName = thTc (fsLit "Name") nameTyConKey fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey @@ -1580,6 +1602,7 @@ typeTyConName = thTc (fsLit "Type") typeTyConKey matchTyConName = thTc (fsLit "Match") matchTyConKey clauseTyConName = thTc (fsLit "Clause") clauseTyConKey funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey +predTyConName = thTc (fsLit "Pred") predTyConKey returnQName, bindQName, sequenceQName, newNameName, liftName, mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, @@ -1711,6 +1734,11 @@ tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey cxtName :: Name cxtName = libFun (fsLit "cxt") cxtIdKey +-- data Pred = ... +classPName, equalPName :: Name +classPName = libFun (fsLit "classP") classPIdKey +equalPName = libFun (fsLit "equalP") equalPIdKey + -- data Strict = ... isStrictName, notStrictName :: Name isStrictName = libFun (fsLit "isStrict") isStrictKey @@ -1765,7 +1793,7 @@ dataFamName = libFun (fsLit "dataFam") dataFamIdKey matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName, decQTyConName, conQTyConName, strictTypeQTyConName, varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName, - patQTyConName, fieldPatQTyConName :: Name + patQTyConName, fieldPatQTyConName, predQTyConName :: Name matchQTyConName = libTc (fsLit "MatchQ") matchQTyConKey clauseQTyConName = libTc (fsLit "ClauseQ") clauseQTyConKey expQTyConName = libTc (fsLit "ExpQ") expQTyConKey @@ -1778,6 +1806,7 @@ typeQTyConName = libTc (fsLit "TypeQ") typeQTyConKey fieldExpQTyConName = libTc (fsLit "FieldExpQ") fieldExpQTyConKey patQTyConName = libTc (fsLit "PatQ") patQTyConKey fieldPatQTyConName = libTc (fsLit "FieldPatQ") fieldPatQTyConKey +predQTyConName = libTc (fsLit "PredQ") predQTyConKey -- quasiquoting quoteExpName, quotePatName :: Name @@ -1792,7 +1821,8 @@ expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey, stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey, decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey, fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey, - fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey :: Unique + fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey, + predQTyConKey :: Unique expTyConKey = mkPreludeTyConUnique 100 matchTyConKey = mkPreludeTyConUnique 101 clauseTyConKey = mkPreludeTyConUnique 102 @@ -1816,6 +1846,8 @@ patQTyConKey = mkPreludeTyConUnique 119 fieldPatQTyConKey = mkPreludeTyConUnique 120 fieldExpQTyConKey = mkPreludeTyConUnique 121 funDepTyConKey = mkPreludeTyConUnique 122 +predTyConKey = mkPreludeTyConUnique 123 +predQTyConKey = mkPreludeTyConUnique 124 -- IdUniques available: 200-399 -- If you want to change this, make sure you check in PrelNames @@ -1885,9 +1917,9 @@ conEIdKey = mkPreludeMiscIdUnique 241 litEIdKey = mkPreludeMiscIdUnique 242 appEIdKey = mkPreludeMiscIdUnique 243 infixEIdKey = mkPreludeMiscIdUnique 244 -infixAppIdKey = mkPreludeMiscIdUnique 245 -sectionLIdKey = mkPreludeMiscIdUnique 246 -sectionRIdKey = mkPreludeMiscIdUnique 247 +infixAppIdKey = mkPreludeMiscIdUnique 245 +sectionLIdKey = mkPreludeMiscIdUnique 246 +sectionRIdKey = mkPreludeMiscIdUnique 247 lamEIdKey = mkPreludeMiscIdUnique 248 tupEIdKey = mkPreludeMiscIdUnique 249 condEIdKey = mkPreludeMiscIdUnique 250 @@ -1947,6 +1979,11 @@ tySynInstDIdKey = mkPreludeMiscIdUnique 343 cxtIdKey :: Unique cxtIdKey = mkPreludeMiscIdUnique 280 +-- data Pred = ... +classPIdKey, equalPIdKey :: Unique +classPIdKey = mkPreludeMiscIdUnique 346 +equalPIdKey = mkPreludeMiscIdUnique 347 + -- data Strict = ... isStrictKey, notStrictKey :: Unique isStrictKey = mkPreludeMiscIdUnique 281 diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index b48d361..a6b24b6 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -146,13 +146,13 @@ cvtTop (ClassD ctxt cl tvs fds decs) isFamilyD (FamilyD _ _ _) = True isFamilyD _ = False -cvtTop (InstanceD tys ty decs) +cvtTop (InstanceD ctxt ty decs) = do { let (ats, bind_sig_decs) = partition isFamInstD decs ; (binds', sigs') <- cvtBindsAndSigs bind_sig_decs ; ats' <- mapM cvtTop ats ; let ats'' = map unTyClD ats' - ; ctxt' <- cvtContext tys - ; L loc pred' <- cvtPred ty + ; ctxt' <- cvtContext ctxt + ; L loc pred' <- cvtPredTy ty ; inst_ty' <- returnL $ mkImplicitHsForAllTy ctxt' (L loc (HsPredTy pred')) ; returnL $ InstD (InstDecl inst_ty' binds' sigs' ats'') @@ -603,16 +603,29 @@ cvtTvs tvs = mapM cvt_tv tvs cvt_tv :: TH.Name -> CvtM (LHsTyVarBndr RdrName) cvt_tv tv = do { tv' <- tName tv; returnL $ UserTyVar tv' } -cvtContext :: Cxt -> CvtM (LHsContext RdrName) +cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName) cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' } -cvtPred :: TH.Type -> CvtM (LHsPred RdrName) -cvtPred ty +cvtPred :: TH.Pred -> CvtM (LHsPred RdrName) +cvtPred (TH.ClassP cla tys) + = do { cla' <- if isVarName cla then tName cla else tconName cla + ; tys' <- mapM cvtType tys + ; returnL $ HsClassP cla' tys' + } +cvtPred (TH.EqualP ty1 ty2) + = do { ty1' <- cvtType ty1 + ; ty2' <- cvtType ty2 + ; returnL $ HsEqualP ty1' ty2' + } + +cvtPredTy :: TH.Type -> CvtM (LHsPred RdrName) +cvtPredTy ty = do { (head, tys') <- split_ty_app ty ; case head of ConT tc -> do { tc' <- tconName tc; returnL $ HsClassP tc' tys' } VarT tv -> do { tv' <- tName tv; returnL $ HsClassP tv' tys' } - _ -> failWith (ptext (sLit "Malformed predicate") <+> text (TH.pprint ty)) } + _ -> failWith (ptext (sLit "Malformed predicate") <+> + text (TH.pprint ty)) } cvtType :: TH.Type -> CvtM (LHsType RdrName) cvtType ty = do { (head_ty, tys') <- split_ty_app ty @@ -697,6 +710,14 @@ okOcc ns str@(c:_) | OccName.isVarNameSpace ns = startsVarId c || startsVarSym c | otherwise = startsConId c || startsConSym c || str == "[]" +-- Determine the name space of a name in a type +-- +isVarName :: TH.Name -> Bool +isVarName (TH.Name occ _) + = case TH.occString occ of + "" -> False + (c:_) -> startsVarId c || startsVarSym c + badOcc :: OccName.NameSpace -> String -> SDoc badOcc ctxt_ns occ = ptext (sLit "Illegal") <+> pprNameSpace ctxt_ns diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 309874b..0bdcbbd 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -918,7 +918,7 @@ reifyTyCon tc r_tvs = reifyTyVars tvs deriv = [] -- Don't know about deriving decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv - | otherwise = TH.DataD cxt name r_tvs cons deriv + | otherwise = TH.DataD cxt name r_tvs cons deriv ; return (TH.TyConI decl) } reifyDataCon :: [Type] -> DataCon -> TcM TH.Con @@ -970,7 +970,8 @@ reifyType (PredTy {}) = panic "reifyType PredTy" reifyTypes :: [Type] -> TcM [TH.Type] reifyTypes = mapM reifyType -reifyCxt :: [PredType] -> TcM [TH.Type] + +reifyCxt :: [PredType] -> TcM [TH.Pred] reifyCxt = mapM reifyPred reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep @@ -983,10 +984,17 @@ reify_tc_app :: TH.Name -> [TypeRep.Type] -> TcM TH.Type reify_tc_app tc tys = do { tys' <- reifyTypes tys ; return (foldl TH.AppT (TH.ConT tc) tys') } -reifyPred :: TypeRep.PredType -> TcM TH.Type -reifyPred (ClassP cls tys) = reify_tc_app (reifyName cls) tys +reifyPred :: TypeRep.PredType -> TcM TH.Pred +reifyPred (ClassP cls tys) + = do { tys' <- reifyTypes tys + ; return $ TH.ClassP (reifyName cls) tys' + } reifyPred p@(IParam _ _) = noTH (sLit "implicit parameters") (ppr p) -reifyPred (EqPred {}) = panic "reifyPred EqPred" +reifyPred (EqPred ty1 ty2) + = do { ty1' <- reifyType ty1 + ; ty2' <- reifyType ty2 + ; return $ TH.EqualP ty1' ty2' + } ------------------------------ -- 1.7.10.4