-- 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
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]
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)
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)
newtypeInstDName, tySynInstDName,
-- Cxt
cxtName,
+ -- Pred
+ classPName, equalPName,
-- Strict
isStrictName, notStrictName,
-- Con
-- 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]
-------------------- 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
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,
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
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
fieldExpQTyConName = libTc (fsLit "FieldExpQ") fieldExpQTyConKey
patQTyConName = libTc (fsLit "PatQ") patQTyConKey
fieldPatQTyConName = libTc (fsLit "FieldPatQ") fieldPatQTyConKey
+predQTyConName = libTc (fsLit "PredQ") predQTyConKey
-- quasiquoting
quoteExpName, quotePatName :: Name
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
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
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
cxtIdKey :: Unique
cxtIdKey = mkPreludeMiscIdUnique 280
+-- data Pred = ...
+classPIdKey, equalPIdKey :: Unique
+classPIdKey = mkPreludeMiscIdUnique 346
+equalPIdKey = mkPreludeMiscIdUnique 347
+
-- data Strict = ...
isStrictKey, notStrictKey :: Unique
isStrictKey = mkPreludeMiscIdUnique 281
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'')
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
| 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