Skip to content

GitLab

Commit 75833842 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files

Template Haskell support for equality constraints

parent 7a253ca4
Hide whitespace changes
Inline Side-by-side
compiler/deSugar/DsMeta.hs
View file @ 75833842
......@@ -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
......
compiler/hsSyn/Convert.lhs
View file @ 75833842
......@@ -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
......
compiler/typecheck/TcSplice.lhs
View file @ 75833842
......@@ -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'
}
------------------------------
......
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