Alternative instances about free HOT 4 OPEN

#!/usr/bin/env stack
{- stack
  script
  --resolver nightly-2017-09-07
  --package free
-}
{-# LANGUAGE DeriveFunctor #-}
module Main where

import Control.Monad.Free as FreeM
import Control.Alternative.Free as FreeA
import Control.Applicative


data ActF f
  = GetLine (String -> f)
  | PutLine String f
  deriving (Functor)

type Action a = Free (Alt ActF) a

getLn :: Action String
getLn = liftF $ liftAlt $ GetLine id

putLn :: String -> Action ()
putLn s = liftF $ liftAlt $ PutLine s ()


run p = foldFree foldAlts p

foldAlts as = runAlt interpret as

interpret (PutLine s f) = putStrLn s >> (pure f)
interpret (GetLine f) = ioError $ userError "getline failed"

(<||>) :: (Alternative f) => Free f a ->  Free f a -> Free f a
(<||>) (FreeM.Pure alt1) _              = pure alt1
(<||>) (Free alt1) a2@(FreeM.Pure alt2) = FreeM.Free (alt1 <|> pure a2)
(<||>) (Free alt1) (Free alt2)          = FreeM.Free (alt1 <|> alt2)
infixl 3 <||>

actualCase = ((getLn *> pure ()) <|> putLn "Actual: This should get printed")  
expectedCase = ((getLn *> pure ()) <||> putLn "Expected: This should get printed")


main = do
  run expectedCase
  run actualCase

import Control.Alternative.Free (Alt, liftAlt, runAlt)
import Control.Concurrent.Async (Concurrently(..))
import Control.Monad.Free.Ap -- Not quite, need the alternative Alternative instance

newtype Conc a
  = Conc { unConc :: Free (Alt Concurrently) a }
  deriving (Functor, Applicative, Alternative, Monad)

instance MonadIO Conc where
  liftIO = Conc . liftF . liftAlt . Concurrently

await :: Conc a -> IO a
await = foldFree (runConcurrently . runAlt id) . unConc

foo :: IO Int
foo = 
  await $ do
    i <- f1
    (j, k) <- liftA2 (,) (f2 <|> f3) f4
    pure (i + j + k)

type f ~> g = forall x. f x -> g x

newtype FF f m a = FF
  { runFF :: forall n. Monad n
      => (f ~> n) -- Any natural transformation
      -> (m ~> n) -- A monad morphism
      -> n a }