+mk_fam_inst :: TyCon -> TyCon -> (TyCon, [Type])
+mk_fam_inst fam_tc arg_tc
+ = (fam_tc, [mkTyConApp arg_tc . mkTyVarTys $ tyConTyVars arg_tc])
+
+buildPReprTyCon :: TyCon -> TyCon -> VM TyCon
+buildPReprTyCon orig_tc vect_tc
+ = do
+ name <- cloneName mkPReprTyConOcc (tyConName orig_tc)
+ rhs_ty <- buildPReprType vect_tc
+ prepr_tc <- builtin preprTyCon
+ liftDs $ buildSynTyCon name
+ tyvars
+ (SynonymTyCon rhs_ty)
+ (Just $ mk_fam_inst prepr_tc vect_tc)
+ where
+ tyvars = tyConTyVars vect_tc
+
+buildPReprType :: TyCon -> VM Type
+buildPReprType = mkPRepr . map dataConRepArgTys . tyConDataCons
+
+buildToPRepr :: Shape -> TyCon -> TyCon -> TyCon -> VM CoreExpr
+buildToPRepr _ vect_tc prepr_tc _
+ = do
+ arg <- newLocalVar FSLIT("x") arg_ty
+ bndrss <- mapM (mapM (newLocalVar FSLIT("x"))) rep_tys
+ (alt_bodies, res_ty) <- mkToPRepr $ map (map Var) bndrss
+
+ return . Lam arg
+ . wrapFamInstBody prepr_tc var_tys
+ . Case (Var arg) (mkWildId arg_ty) res_ty
+ $ zipWith3 mk_alt data_cons bndrss alt_bodies
+ where
+ var_tys = mkTyVarTys $ tyConTyVars vect_tc
+ arg_ty = mkTyConApp vect_tc var_tys
+ data_cons = tyConDataCons vect_tc
+ rep_tys = map dataConRepArgTys data_cons
+
+ mk_alt data_con bndrs body = (DataAlt data_con, bndrs, body)
+
+buildFromPRepr :: Shape -> TyCon -> TyCon -> TyCon -> VM CoreExpr
+buildFromPRepr _ vect_tc prepr_tc _
+ = do
+ arg_ty <- mkPReprType res_ty
+ arg <- newLocalVar FSLIT("x") arg_ty
+ alts <- mapM mk_alt data_cons
+ body <- mkFromPRepr (unwrapFamInstScrut prepr_tc var_tys (Var arg))
+ res_ty alts
+ return $ Lam arg body
+ where
+ var_tys = mkTyVarTys $ tyConTyVars vect_tc
+ res_ty = mkTyConApp vect_tc var_tys
+ data_cons = tyConDataCons vect_tc
+
+ mk_alt dc = do
+ bndrs <- mapM (newLocalVar FSLIT("x")) $ dataConRepArgTys dc
+ return (bndrs, mkConApp dc (map Type var_tys ++ map Var bndrs))
+
+buildPRDict :: Shape -> TyCon -> TyCon -> TyCon -> VM CoreExpr
+buildPRDict _ vect_tc prepr_tc _
+ = prCoerce prepr_tc var_tys
+ =<< prDictOfType (mkTyConApp prepr_tc var_tys)
+ where
+ var_tys = mkTyVarTys $ tyConTyVars vect_tc
+