+-- | Given a type @ty@, return the PR dictionary for @PRepr ty@.
+prDictOfPReprInst :: Type -> VM CoreExpr
+prDictOfPReprInst ty
+ = do
+ (prepr_tc, prepr_args) <- preprSynTyCon ty
+ prDictOfPReprInstTyCon ty prepr_tc prepr_args
+
+-- | Given a type @ty@, its PRepr synonym tycon and its type arguments,
+-- return the PR @PRepr ty@. Suppose we have:
+--
+-- > type instance PRepr (T a1 ... an) = t
+--
+-- which is internally translated into
+--
+-- > type :R:PRepr a1 ... an = t
+--
+-- and the corresponding coercion. Then,
+--
+-- > prDictOfPReprInstTyCon (T a1 ... an) :R:PRepr u1 ... un = PR (T u1 ... un)
+--
+-- Note that @ty@ is only used for error messages
+--
+prDictOfPReprInstTyCon :: Type -> TyCon -> [Type] -> VM CoreExpr
+prDictOfPReprInstTyCon ty prepr_tc prepr_args
+ | Just rhs <- coreView (mkTyConApp prepr_tc prepr_args)
+ = do
+ dict <- prDictOfReprType' rhs
+ pr_co <- mkBuiltinCo prTyCon
+ let Just arg_co = tyConFamilyCoercion_maybe prepr_tc
+ let co = mkAppCo pr_co
+ $ mkSymCo
+ $ mkAxInstCo arg_co prepr_args
+ return $ mkCoerce co dict
+
+ | otherwise = cantVectorise "Invalid PRepr type instance" (ppr ty)
+
+-- | Get the PR dictionary for a type. The argument must be a representation
+-- type.
+prDictOfReprType :: Type -> VM CoreExpr
+prDictOfReprType ty
+ | Just (tycon, tyargs) <- splitTyConApp_maybe ty
+ = do
+ prepr <- builtin preprTyCon
+ if tycon == prepr
+ then do
+ let [ty'] = tyargs
+ pa <- paDictOfType ty'
+ sel <- builtin paPRSel
+ return $ Var sel `App` Type ty' `App` pa
+ else do
+ -- a representation tycon must have a PR instance
+ dfun <- maybeV $ lookupTyConPR tycon
+ prDFunApply dfun tyargs
+
+ | otherwise
+ = do
+ -- it is a tyvar or an application of a tyvar
+ -- determine the PR dictionary from its PA dictionary
+ --
+ -- NOTE: This assumes that PRepr t ~ t is for all representation types
+ -- t
+ --
+ -- FIXME: This doesn't work for kinds other than * at the moment. We'd
+ -- have to simply abstract the term over the missing type arguments.
+ pa <- paDictOfType ty
+ prsel <- builtin paPRSel
+ return $ Var prsel `mkApps` [Type ty, pa]
+
+prDictOfReprType' :: Type -> VM CoreExpr
+prDictOfReprType' ty = prDictOfReprType ty `orElseV`
+ cantVectorise "No PR dictionary for representation type"
+ (ppr ty)
+
+-- | Apply a tycon's PR dfun to dictionary arguments (PR or PA) corresponding
+-- to the argument types.
+prDFunApply :: Var -> [Type] -> VM CoreExpr
+prDFunApply dfun tys
+ | Just [] <- ctxs -- PR (a :-> b) doesn't have a context
+ = return $ Var dfun `mkTyApps` tys
+
+ | Just tycons <- ctxs
+ , length tycons == length tys
+ = do
+ pa <- builtin paTyCon
+ pr <- builtin prTyCon
+ args <- zipWithM (dictionary pa pr) tys tycons
+ return $ Var dfun `mkTyApps` tys `mkApps` args
+
+ | otherwise = invalid
+ where
+ -- the dfun's contexts - if its type is (PA a, PR b) => PR (C a b) then
+ -- ctxs is Just [PA, PR]
+ ctxs = fmap (map fst)
+ $ sequence
+ $ map splitTyConApp_maybe
+ $ fst
+ $ splitFunTys
+ $ snd
+ $ splitForAllTys
+ $ varType dfun
+
+ dictionary pa pr ty tycon
+ | tycon == pa = paDictOfType ty
+ | tycon == pr = prDictOfReprType ty
+ | otherwise = invalid
+
+ invalid = cantVectorise "Invalid PR dfun type" (ppr (varType dfun) <+> ppr tys)
+