Free functors

free.hs

{-# LANGUAGE 
    ConstraintKinds
  , RankNTypes
  , TypeOperators
  , FlexibleInstances
  , GADTs
  , MultiParamTypeClasses
  , UndecidableInstances
  , ScopedTypeVariables
  #-}

import Data.Constraint
import Data.Constraint.Forall

import Control.Monad
import Control.Comonad

import Data.Monoid hiding ((<>))
import Data.Default
import Data.Semigroup

import Control.Applicative
import Control.Monad.Trans.Class
import Data.Functor.Identity
import Data.Functor.Compose
import Data.Foldable hiding (foldr1)
import Data.Traversable



newtype Free c a = Free { runFree :: forall b. c b => (a -> b) -> b }

leftAdjunct :: (Free c a -> b) -> a -> b
leftAdjunct f a = f (Free ($ a))

rightAdjunct :: c b => (a -> b) -> Free c a -> b
rightAdjunct f g = runFree g f

rightAdjunct' :: ForallF c f => (a -> f b) -> Free c a -> f b
rightAdjunct' = h instF rightAdjunct
  where
    h :: ForallF c f 
      => (ForallF c f :- c (f b))
      -> (c (f b) => (a -> f b) -> Free c a -> f b) 
      -> (a -> f b) -> Free c a -> f b
    h (Sub Dict) f = f

rightAdjunct'' :: ForallT c t => (a -> t f b) -> Free c a -> t f b
rightAdjunct'' = h instT rightAdjunct
  where
    h :: ForallT c t
      => (ForallT c t :- c (t f b))
      -> (c (t f b) => (a -> t f b) -> Free c a -> t f b)
      -> (a -> t f b) -> Free c a -> t f b
    h (Sub Dict) f = f

instance Functor (Free c) where
  fmap f (Free g) = Free (g . (. f))

instance Applicative (Free c) where
  pure = leftAdjunct id
  fs <*> as = Free $ \k -> runFree fs (\f -> runFree as (k . f))

instance ForallF c (Free c) => Monad (Free c) where
  return = pure
  (>>=) = flip rightAdjunct'
  
instance (ForallF c Identity, ForallF c (Free c), ForallF c (Compose (Free c) (Free c))) 
  => Comonad (Free c) where
  extract = runIdentity . rightAdjunct' Identity
  extend g = fmap g . getCompose . rightAdjunct' (Compose . return . return)

newtype LiftAFree c f a = LiftAFree { getLiftAFree :: f (Free c a) }

instance ForallT c (LiftAFree c) => Foldable (Free c) where
  foldMap = foldMapDefault

instance ForallT c (LiftAFree c) => Traversable (Free c) where
  traverse f = getLiftAFree . rightAdjunct'' (LiftAFree . fmap pure . f)

convert :: (c (f a), Applicative f) => Free c a -> f a
convert = rightAdjunct pure



type List = Free Monoid

instance Monoid (List a) where
  mempty = Free $ pure mempty
  Free fa `mappend` Free fb = Free $ liftA2 mappend fa fb

instance Applicative f => Monoid (LiftAFree Monoid f a) where
  mempty = LiftAFree $ pure mempty
  LiftAFree fa `mappend` LiftAFree fb = LiftAFree $ liftA2 mappend fa fb

toList :: List a -> [a]
toList = convert

  
type Opt = Free Default

instance Default (Opt a) where
  def = Free def 
  
toMaybe :: Opt a -> Maybe a
toMaybe = convert


type NonEmpty = Free Semigroup

instance Semigroup (NonEmpty a) where
  Free fa <> Free fb = Free $ liftA2 (<>) fa fb

instance Semigroup (Identity a) where
  a <> _ = a

instance Semigroup (Compose NonEmpty NonEmpty a) where
  Compose l <> Compose r = Compose $ ((<> extract r) <$> l) <> r
  
toNonEmpty :: [a] -> NonEmpty a
toNonEmpty = foldr1 (<>) . map return

fromNonEmpty :: NonEmpty a -> [a]
fromNonEmpty = convert

test :: [Int]
test = fromNonEmpty $ extend (Prelude.sum . fromNonEmpty) $ (pure 1 <> pure 2) <> (pure 3 <> pure 4)


type f :~> g = forall b. f b -> g b

newtype HFree c f a = HFree { runHFree :: forall g. (c g, Functor g) => (f :~> g) -> g a }

hleftAdjunct :: (HFree c f :~> g) -> f :~> g
hleftAdjunct f fa = f (HFree $ \k -> k fa)

hrightAdjunct :: (c g, Functor g) => (f :~> g) -> HFree c f :~> g
hrightAdjunct f h = runHFree h f

instance Functor (HFree c f) where
  fmap f (HFree g) = HFree (fmap f . g)
  
hfmap :: (f :~> g) -> HFree c f :~> HFree c g
hfmap f (HFree g) = HFree $ \k -> g (k . f)

liftFree :: f a -> HFree c f a
liftFree = hleftAdjunct id

lowerFree :: (c f, Functor f) => HFree c f a -> f a
lowerFree = hrightAdjunct id

hconvert :: (c (t f), Functor (t f), Monad f, MonadTrans t) => HFree c f a -> t f a
hconvert = hrightAdjunct lift


instance Monad (HFree Monad f) where
  return a = HFree $ const (return a)
  HFree f >>= g = HFree $ \k -> f k >>= (\a -> runHFree (g a) k)

instance Applicative (HFree Applicative f) where
  pure a = HFree $ const (pure a)
  HFree f <*> HFree g = HFree $ \k -> f k <*> g k

instance Applicative (HFree Alternative f) where
  pure a = HFree $ const (pure a)
  HFree f <*> HFree g = HFree $ \k -> f k <*> g k
instance Alternative (HFree Alternative f) where
  empty = HFree $ const empty
  HFree f <|> HFree g = HFree $ \k -> f k <|> g k
  
  

data Cofree c b where
  Cofree :: c a => (a -> b) -> a -> Cofree c b

leftAdjunctCF :: c a => (a -> b) -> a -> Cofree c b
leftAdjunctCF f a = Cofree f a

rightAdjunctCF :: (a -> Cofree c b) -> a -> b
rightAdjunctCF f a = case f a of Cofree k a' -> k a'

leftAdjunctCF' :: ForallF c f => (f a -> b) -> f a -> Cofree c b
leftAdjunctCF' = h instF leftAdjunctCF
  where
    h :: ForallF c f
      => (ForallF c f :- c (f a))
      -> (c (f a) => (f a -> b) -> f a -> Cofree c b) 
      -> (f a -> b) -> f a -> Cofree c b
    h (Sub Dict) f = f
    
instance Functor (Cofree c) where
  fmap f (Cofree k a) = Cofree (f . k) a

instance ForallF c (Cofree c) => Comonad (Cofree c) where
  extract = rightAdjunctCF id
  extend = leftAdjunctCF'

instance (ForallF c Identity, ForallF c (Cofree c), ForallF c (Compose (Cofree c) (Cofree c))) 
  => Applicative (Cofree c) where
  pure = leftAdjunctCF' runIdentity . Identity
  (<*>) = ap
  
instance (ForallF c Identity, ForallF c (Cofree c), ForallF c (Compose (Cofree c) (Cofree c))) 
  => Monad (Cofree c) where
  return = pure
  m >>= g = leftAdjunctCF' (extract . extract . getCompose) (Compose $ fmap g m)

convertCF :: (c (w a), Comonad w) => w a -> Cofree c a
convertCF wa = Cofree extract wa



class Action i s where
  act :: i -> s -> s

type Automaton i = Cofree (Action i)

instance Action i (Automaton i o) where
  act i (Cofree k s) = Cofree k (act i s)

instance Action i (Identity a) where
  act _ = id

instance Action i (Compose (Automaton i) (Automaton i) o) where
  act i = Compose . fmap (act i) . act i . getCompose

data ActionD i s = ActionD (i -> s -> s) s
instance Action i (ActionD i s) where
  act i (ActionD f s) = ActionD f (f i s)

unfoldAutomaton :: (i -> s -> s) -> (s -> o) -> s -> Automaton i o
unfoldAutomaton fi fo = Cofree (\(ActionD _ s) -> fo s) . ActionD fi
  

type Stream = Automaton ()

unfoldStream :: (s -> (a, s)) -> s -> Stream a
unfoldStream f = unfoldAutomaton (const (snd . f)) (fst . f)

headS :: Stream a -> a
headS = extract

tailS :: Stream a -> Stream a
tailS = act ()

fromStream :: Stream a -> [a]
fromStream = map headS . iterate tailS



class Project a p where
  project :: p -> a

type Prod a = Cofree (Project a)

instance Project a (Prod a b) where
  project (Cofree _ p) = project p

instance Monoid m => Project m (Identity a) where
  project _ = mempty
  
instance Monoid m => Project m (Compose (Prod m) (Prod m) a) where
  project (Compose p) = project p `mappend` project (extract p)


class Inject b s where
  inject :: b -> s

type Coprod b = Free (Inject b)

instance Inject b (Coprod b a) where
  inject b = Free $ \_ -> inject b