Commit b24f59e7 authored by igloo's avatar igloo

[project @ 2004-11-03 01:10:53 by igloo]

Implement TH ForallC constructor.
parent 70c643c9
......@@ -275,7 +275,14 @@ repC :: LConDecl Name -> DsM (Core TH.ConQ)
repC (L loc (ConDecl con [] (L _ []) details))
= do { con1 <- lookupLOcc con ; -- See note [Binders and occurrences]
repConstr con1 details }
repC (L loc (ConDecl con tvs (L cloc ctxt) details))
= do { addTyVarBinds tvs $ \bndrs -> do {
c' <- repC (L loc (ConDecl con [] (L cloc []) details));
ctxt' <- repContext ctxt;
bndrs' <- coreList nameTyConName bndrs;
rep2 forallCName [unC bndrs', unC ctxt', unC c']
}
}
repC (L loc con_decl)
= do { dsWarn (loc, hang ds_msg 4 (ppr con_decl))
; return (panic "DsMeta:repC") }
......@@ -1338,7 +1345,7 @@ templateHaskellNames = [
-- Strict
isStrictName, notStrictName,
-- Con
normalCName, recCName, infixCName,
normalCName, recCName, infixCName, forallCName,
-- StrictType
strictTypeName,
-- VarStrictType
......@@ -1500,6 +1507,7 @@ notStrictName = libFun FSLIT("notStrict") notStrictKey
normalCName = libFun FSLIT("normalC") normalCIdKey
recCName = libFun FSLIT("recC") recCIdKey
infixCName = libFun FSLIT("infixC") infixCIdKey
forallCName = libFun FSLIT("forallC") forallCIdKey
-- type StrictType = ...
strictTypeName = libFun FSLIT("strictType") strictTKey
......@@ -1674,6 +1682,7 @@ notStrictKey = mkPreludeMiscIdUnique 282
normalCIdKey = mkPreludeMiscIdUnique 283
recCIdKey = mkPreludeMiscIdUnique 284
infixCIdKey = mkPreludeMiscIdUnique 285
forallCIdKey = mkPreludeMiscIdUnique 288
-- type StrictType = ...
strictTKey = mkPreludeMiscIdUnique 286
......
......@@ -42,7 +42,9 @@ import Outputable
convertToHsDecls :: [TH.Dec] -> [Either (LHsDecl RdrName) Message]
convertToHsDecls ds = map cvt_ltop ds
mk_con con = L loc0 $ case con of
mk_con con = L loc0 $ mk_nlcon con
where
mk_nlcon con = case con of
NormalC c strtys
-> ConDecl (noLoc (cName c)) noExistentials noContext
(PrefixCon (map mk_arg strtys))
......@@ -52,7 +54,12 @@ mk_con con = L loc0 $ case con of
InfixC st1 c st2
-> ConDecl (noLoc (cName c)) noExistentials noContext
(InfixCon (mk_arg st1) (mk_arg st2))
where
ForallC tvs ctxt (ForallC tvs' ctxt' con')
-> mk_nlcon (ForallC (tvs ++ tvs') (ctxt ++ ctxt') con')
ForallC tvs ctxt con' -> case mk_nlcon con' of
ConDecl l [] (L _ []) x ->
ConDecl l (cvt_tvs tvs) (cvt_context ctxt) x
c -> panic "ForallC: Can't happen"
mk_arg (IsStrict, ty) = noLoc $ HsBangTy HsStrict (cvtType ty)
mk_arg (NotStrict, ty) = cvtType ty
......
Markdown is supported
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