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]
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]
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,
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
floatPrimLIdKey = mkPreludeMiscIdUnique 276
doublePrimLIdKey = mkPreludeMiscIdUnique 277
+newtypeDIdKey = mkPreludeMiscIdUnique 278
+
-- %************************************************************************
-- %* *
-- Other utilities
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)
(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)