Commit a011a71c authored by igloo's avatar igloo

[project @ 2003-05-21 02:58:39 by igloo]

Added support for newtypes to TH and altered a test for them.
parent a77e522a
......@@ -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
......
......@@ -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)
......
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