- unwindApp env (op@(Var(qv@(_,p)))) as | isPrimVar qv =
- k $ etaExpand (snd (unzip extraTbs)) (drop n atys) (k1 (rewindApp env op as))
- where -- TODO: avoid copying code. these two cases are the same
-
- -- etaExpand needs to add the type arguments too! Bah!
- primEnv = case elookup globalEnv primMname of
- Just es -> venv_ es
- _ -> error "eek"
- (_, _, resTy') = (maybe (error "unwindApp") splitTy (elookup primEnv p))
- (tbs, atys0, _resTy) = (maybe (error "unwindApp") (splitTy . (substNewtys ntEnv)) (elookup primEnv p))
- -- The magic here is so we know to eta-expand applications of
- -- primops whose return types are newtypes.
- -- There are no actual GHC primops that have this property, but
- -- a back-end tool writer (for example: me) might want to add
- -- such a primop.
- -- If this code wasn't here, and we had a primop
- -- foo# :: Int -> IO (),
- -- we would see (foo# 5) and think it was fully applied, when
- -- actually we need to rewrite it as:
- -- (\ (s::State# RealWorld#) -> foo# 5 s)
- -- (This code may be a very good case against introducing such
- -- primops.)
- (k,k1) = case newtypeCoercion_maybe ntEnv resTy' of
- Just co -> case splitTyConApp_maybe resTy' of
- Just (_, args) -> ((\ e -> Cast e (SymCoercion (mkTapp co args))), (\ e1 -> Cast e1 (mkTapp co args)))
- _ -> ((\ e -> Cast e (SymCoercion co)), (\ e1 -> Cast e1 co))
- _ -> (id,id)
- n_args = length ts
- (appliedTbs, extraTbs) = (take n_args tbs, drop n_args tbs)
- atys = map (substl (map fst appliedTbs) ts) atys0
- ts = [t | Right t <- as]
- n = length [e | Left e <- as]
- unwindApp env (op@(External _ t)) as =
- etaExpand [] (drop n atys) (rewindApp env op as)