+mkPAInstance :: TyCon -> TyCon -> VM PAInstance
+mkPAInstance vect_tc arr_tc
+ = do
+ pa <- builtin paClass
+ let inst_ty = mkForAllTys tvs
+ . (mkFunTys $ mkPredTys [ClassP pa [ty] | ty <- arg_tys])
+ $ mkPredTy (ClassP pa [mkTyConApp vect_tc arg_tys])
+
+ dfun <- newExportedVar (mkPADFunOcc $ getOccName vect_tc) inst_ty
+
+ return $ PAInstance {
+ painstInstance = mkLocalInstance dfun NoOverlap
+ , painstVectTyCon = vect_tc
+ , painstArrTyCon = arr_tc
+ }
+ where
+ tvs = tyConTyVars arr_tc
+ arg_tys = mkTyVarTys tvs
+
+buildPADict :: PAInstance -> VM [(Var, CoreExpr)]
+buildPADict (PAInstance {
+ painstInstance = inst
+ , painstVectTyCon = vect_tc
+ , painstArrTyCon = arr_tc })
+ = localV . abstractOverTyVars (tyConTyVars arr_tc) $ \abstract ->
+ do
+ meth_binds <- mapM (mk_method abstract) paMethods
+ let meth_vars = map (Var . fst) meth_binds
+ meth_exprs <- mapM (`applyToTypes` arg_tys) meth_vars
+
+ pa_dc <- builtin paDictDataCon
+ let dict = mkConApp pa_dc (Type (mkTyConApp vect_tc arg_tys) : meth_exprs)
+ return $ (instanceDFunId inst, dict) : meth_binds
+ where
+ tvs = tyConTyVars arr_tc
+ arg_tys = mkTyVarTys tvs
+
+ mk_method abstract (name, build)
+ = localV
+ $ do
+ body <- liftM abstract $ build vect_tc arr_tc
+ var <- newLocalVar name (exprType body)
+ return (var, mkInlineMe body)
+
+paMethods = [(FSLIT("lengthPA"), buildLengthPA),
+ (FSLIT("replicatePA"), buildReplicatePA)]
+
+buildLengthPA :: TyCon -> TyCon -> VM CoreExpr
+buildLengthPA _ arr_tc