NewtypePhases.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE DeriveFunctor #-}

import Control.Applicative

data Free f a where
  Pure :: a -> Free f a
  App  :: f (a -> b) -> Free f a -> Free f b
  
instance Functor f =>  Functor (Free f) where
  fmap f (Pure x) = Pure (f x)
  fmap f (App fs xs) = App (fmap (f.) fs) xs
  
instance Functor f => Applicative (Free f) where
  pure = Pure
  liftA2 f (Pure x)   xs = fmap (f x) xs
  liftA2 f (App x xs) ys = App (fmap (\k -> uncurry (f . k)) x) (liftA2 (,) xs ys)
  
lift :: Functor f => f a -> Free f a
lift x = App (fmap const x) (Pure ())

lower :: Applicative f => Free f a -> f a
lower (Pure x) = pure x
lower (App f xs) = f <*> lower xs
  
newtype Phases f a = Phases { runPhases :: Free f a } deriving Functor

instance Applicative f => Applicative (Phases f) where
  pure = Phases . Pure
  liftA2 f (Phases (Pure x)) xs = fmap (f x) xs
  liftA2 f xs (Phases (Pure y)) = fmap (flip f y) xs
  liftA2 f (Phases (App x xs)) (Phases (App y ys)) = 
    Phases (App (liftA2 (\k1 k2 (x,y) -> f (k1 x) (k2 y)) x y) (runPhases (liftA2 (,) (Phases xs) (Phases ys))))
    
now :: Functor f => f a -> Phases f a
now = Phases . lift

later :: Applicative f => Phases f a -> Phases f a
later = Phases . App (pure id) . runPhases