From a011a71c2de871a7843138a9c35f74952baf7350 Mon Sep 17 00:00:00 2001 From: igloo Date: Wed, 21 May 2003 02:58:40 +0000 Subject: [PATCH] [project @ 2003-05-21 02:58:39 by igloo] Added support for newtypes to TH and altered a test for them. --- ghc/compiler/deSugar/DsMeta.hs | 20 ++++++++++++++++- ghc/compiler/hsSyn/Convert.lhs | 46 +++++++++++++++++++++++----------------- 2 files changed, 45 insertions(+), 21 deletions(-) diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index 048660f..c1b49d9 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -219,6 +219,18 @@ repTyClD' (TyData { tcdND = DataType, tcdCtxt = cxt, repData cxt1 tc1 (coreList' stringTy bndrs) cons2 derivs1 } ; return $ Just (loc, dec) } +repTyClD' (TyData { tcdND = NewType, tcdCtxt = cxt, + tcdName = tc, tcdTyVars = tvs, + tcdCons = DataCons [con], tcdDerivs = mb_derivs, + tcdLoc = loc}) + = do { tc1 <- lookupOcc tc ; -- See note [Binders and occurrences] + dec <- addTyVarBinds tvs $ \bndrs -> do { + cxt1 <- repContext cxt ; + con1 <- repC con ; + derivs1 <- repDerivs mb_derivs ; + repNewtype cxt1 tc1 (coreList' stringTy bndrs) con1 derivs1 } ; + return $ Just (loc, dec) } + repTyClD' (TySynonym { tcdName = tc, tcdTyVars = tvs, tcdSynRhs = ty, tcdLoc = loc}) = do { tc1 <- lookupOcc tc ; -- See note [Binders and occurrences] @@ -1049,6 +1061,9 @@ repFun (MkC nm) (MkC b) = rep2 funName [nm, b] repData :: Core M.CxtQ -> Core String -> Core [String] -> Core [M.ConQ] -> Core [String] -> DsM (Core M.DecQ) repData (MkC cxt) (MkC nm) (MkC tvs) (MkC cons) (MkC derivs) = rep2 dataDName [cxt, nm, tvs, cons, derivs] +repNewtype :: Core M.CxtQ -> Core String -> Core [String] -> Core M.ConQ -> Core [String] -> DsM (Core M.DecQ) +repNewtype (MkC cxt) (MkC nm) (MkC tvs) (MkC con) (MkC derivs) = rep2 newtypeDName [cxt, nm, tvs, con, derivs] + repTySyn :: Core String -> Core [String] -> Core M.TypQ -> DsM (Core M.DecQ) repTySyn (MkC nm) (MkC tvs) (MkC rhs) = rep2 tySynDName [nm, tvs, rhs] @@ -1225,7 +1240,7 @@ templateHaskellNames fromName, fromThenName, fromToName, fromThenToName, funName, valName, liftName, gensymName, returnQName, bindQName, sequenceQName, - matchName, clauseName, funName, valName, tySynDName, dataDName, classDName, + matchName, clauseName, funName, valName, tySynDName, dataDName, newtypeDName, classDName, instName, protoName, tforallName, tvarName, tconName, tappName, arrowTyConName, tupleTyConName, listTyConName, namedTyConName, ctxtName, constrName, recConstrName, infixConstrName, @@ -1309,6 +1324,7 @@ clauseName = varQual FSLIT("clause") clauseIdKey funName = varQual FSLIT("fun") funIdKey valName = varQual FSLIT("val") valIdKey dataDName = varQual FSLIT("dataD") dataDIdKey +newtypeDName = varQual FSLIT("newtypeD") newtypeDIdKey tySynDName = varQual FSLIT("tySynD") tySynDIdKey classDName = varQual FSLIT("classD") classDIdKey instName = varQual FSLIT("inst") instIdKey @@ -1480,6 +1496,8 @@ intPrimLIdKey = mkPreludeMiscIdUnique 275 floatPrimLIdKey = mkPreludeMiscIdUnique 276 doublePrimLIdKey = mkPreludeMiscIdUnique 277 +newtypeDIdKey = mkPreludeMiscIdUnique 278 + -- %************************************************************************ -- %* * -- Other utilities diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs index 0dffc23..3c71e52 100644 --- a/ghc/compiler/hsSyn/Convert.lhs +++ b/ghc/compiler/hsSyn/Convert.lhs @@ -46,6 +46,27 @@ import Outputable convertToHsDecls :: [Meta.Dec] -> [Either (HsDecl RdrName) Message] convertToHsDecls ds = map cvt_top ds +mk_con con = case con of + Constr c strtys + -> ConDecl (cName c) noExistentials noContext + (PrefixCon (map mk_arg strtys)) loc0 + RecConstr c varstrtys + -> ConDecl (cName c) noExistentials noContext + (Hs.RecCon (map mk_id_arg varstrtys)) loc0 + InfixConstr st1 c st2 + -> ConDecl (cName c) noExistentials noContext + (InfixCon (mk_arg st1) (mk_arg st2)) loc0 + where + mk_arg (Strict, ty) = BangType MarkedUserStrict (cvtType ty) + mk_arg (NonStrict, ty) = BangType NotMarkedStrict (cvtType ty) + + mk_id_arg (i, Strict, ty) + = (vName i, BangType MarkedUserStrict (cvtType ty)) + mk_id_arg (i, NonStrict, ty) + = (vName i, BangType NotMarkedStrict (cvtType ty)) + +mk_derivs [] = Nothing +mk_derivs cs = Just [HsClassP (tconName c) [] | c <- cs] cvt_top :: Meta.Dec -> Either (HsDecl RdrName) Message cvt_top d@(Val _ _ _) = Left $ ValD (cvtd d) @@ -59,27 +80,12 @@ cvt_top (Data ctxt tc tvs constrs derivs) (cvt_context ctxt, tconName tc, cvt_tvs tvs) (DataCons (map mk_con constrs)) (mk_derivs derivs) loc0) - where - mk_con (Constr c strtys) - = ConDecl (cName c) noExistentials noContext - (PrefixCon (map mk_arg strtys)) loc0 - mk_con (RecConstr c varstrtys) - = ConDecl (cName c) noExistentials noContext - (Hs.RecCon (map mk_id_arg varstrtys)) loc0 - mk_con (InfixConstr st1 c st2) - = ConDecl (cName c) noExistentials noContext - (InfixCon (mk_arg st1) (mk_arg st2)) loc0 - mk_arg (Strict, ty) = BangType MarkedUserStrict (cvtType ty) - mk_arg (NonStrict, ty) = BangType NotMarkedStrict (cvtType ty) - - mk_id_arg (i, Strict, ty) - = (vName i, BangType MarkedUserStrict (cvtType ty)) - mk_id_arg (i, NonStrict, ty) - = (vName i, BangType NotMarkedStrict (cvtType ty)) - - mk_derivs [] = Nothing - mk_derivs cs = Just [HsClassP (tconName c) [] | c <- cs] +cvt_top (Newtype ctxt tc tvs constr derivs) + = Left $ TyClD (mkTyData NewType + (cvt_context ctxt, tconName tc, cvt_tvs tvs) + (DataCons [mk_con constr]) + (mk_derivs derivs) loc0) cvt_top (Class ctxt cl tvs decs) = Left $ TyClD (mkClassDecl (cvt_context ctxt, tconName cl, cvt_tvs tvs) -- 1.7.10.4