Streams, Lists, and Tries with Fix and Compose

FunctorFun.hs

{-# LANGUAGE FlexibleContexts     #-} -- {{{
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE PackageImports       #-}
{-# LANGUAGE PolyKinds            #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-} -- }}}
module FunctorFun where
-- {{{ 
import        Control.Applicative (Const(..))
import        Control.Arrow ((***), (+++), first, second, right, left)
import        Control.Monad ((<=<))
import "mtl"  Control.Monad.Identity (Identity(..))
import        Data.Function (fix)
import        Data.Functor.Compose (Compose(..))
import        Data.Maybe (fromMaybe)
-- }}}
newtype Product1 f g a = Product1 { getProduct1 :: (f a, g a) }
instance (Functor f, Functor g) => Functor (Product1 f g) where
  fmap f = Product1 . (fmap f *** fmap f) . getProduct1

newtype Sum1 f g a = Sum1 { getSum1 :: Either (f a) (g a) }
instance (Functor f, Functor g) => Functor (Sum1 f g) where
  fmap f = Sum1 . (fmap f +++ fmap f) . getSum1

newtype Fix1 f a = Fix1 { getFix1 :: f (Fix1 f) a }
instance Functor (f (Fix1 f)) => Functor (Fix1 f) where
  fmap f = Fix1 . fmap f . getFix1

newtype Compose1 f g a b = Compose1 { getCompose1 :: f (g a) b }
instance (Functor (f (g a))) => Functor (Compose1 f g a) where
  fmap f = Compose1 . fmap f . getCompose1
 
newtype Double1 f g a = Double1 { getDouble1 :: f g g a }
instance Functor (f g g) => Functor (Double1 f g) where
  fmap f = Double1 . fmap f . getDouble1

type Free1 f = Fix1 (Sum1 Identity `Compose1` f)                    -- Free1 f a ~ Either a (f (Free1 f) a)
-- {{{
getFree1 :: Free1 f a -> Either a (f (Free1 f) a)
getFree1 = left runIdentity . getSum1 .  getCompose1 .  getFix1

mkFree1 :: Either a (f (Free1 f) a) -> Free1 f a
mkFree1 = Fix1 . Compose1 . Sum1 . left Identity

class Functor1 f where
  fmap1 :: (g a -> g b) -> f g a -> f g b
instance Functor f => Functor1 (Compose f) where
  fmap1 f = Compose . fmap f . getCompose

instance Functor1 f => Monad (Free1 f) where
  return = mkFree1 . Left
  r >>= f = either f (mkFree1 . Right . fmap1 (>>=f)) $ getFree1 r
-- }}}
type Link = Product1 Identity                                       -- Link a ~ (a, f a)
-- {{{
getLink :: Link f a -> (a, f a)
getLink = first runIdentity . getProduct1

mkLink :: (a, f a) -> Link f a
mkLink = Product1 . first Identity

mapLink :: Functor f => (a -> b) -> Link f a -> Link f b
mapLink = fmap
-- }}}
type Stream = Fix1 Link                                             -- Stream a ~ (a, Stream a)
-- {{{
getStream :: Stream a -> (a, Stream a)
getStream = getLink . getFix1

mkStream :: (a, Stream a) -> Stream a
mkStream = Fix1 . mkLink

unfoldStream :: (a -> (b,a)) -> a -> Stream b
unfoldStream f = fix $ \unfoldStream_f -> mkStream . second unfoldStream_f . f

mapStream :: (a -> b) -> Stream a -> Stream b
mapStream = fmap
-- }}}
type List = Fix1 (Compose Maybe `Compose1` Link)                    -- List a ~ Maybe (a, List a)
-- {{{
getList :: List a -> Maybe (a, List a)
getList = fmap getLink . getCompose . getCompose1 . getFix1

mkList :: Maybe (a, List a) -> List a
mkList = Fix1 . Compose1 . Compose . fmap mkLink
 
tailsList :: List a -> NonEmptyList (List a)
tailsList as = consList as . toList . fmap (tailsList . snd) $ getList as
 
emptyList :: List a
emptyList = mkList Nothing
 
mapList :: (a -> b) -> List a -> List b
mapList = fmap
-- }}}
type NonEmptyList = Fix1 (Link `Compose1` Compose Maybe)            -- NonEmptyList a ~ (a, Maybe (NonEmptyList a))
-- {{{
getNonEmptyList :: NonEmptyList a -> (a, Maybe (NonEmptyList a))
getNonEmptyList = second getCompose . getLink . getCompose1 . getFix1

mkNonEmptyList :: (a, Maybe (NonEmptyList a)) -> NonEmptyList a
mkNonEmptyList = Fix1 . Compose1 . mkLink . second Compose

consList :: a -> List a -> NonEmptyList a
consList = curry $ mkNonEmptyList . second ofList

getconsNonEmptyList :: NonEmptyList a -> (a, List a)
getconsNonEmptyList = second (mkList . fmap getconsNonEmptyList) . getNonEmptyList

ofList :: List a -> Maybe (NonEmptyList a)
ofList = fmap ( mkNonEmptyList . second ofList ) . getList

toList :: Maybe (NonEmptyList a) -> List a
toList = mkList . fmap (second toList . getNonEmptyList)

headNonEmptyList :: NonEmptyList a -> a
headNonEmptyList = fst . getNonEmptyList

tailNonEmptyList :: NonEmptyList a -> Maybe (NonEmptyList a)
tailNonEmptyList = snd . getNonEmptyList

mapNonEmptyList :: (a -> b) -> NonEmptyList a -> NonEmptyList b
mapNonEmptyList = fmap
-- }}}
type Trie f = Fix1 (Product1 Maybe `Compose1` Compose f)            -- Trie f a ~ (Maybe a, f (Trie f a))
-- {{{
getTrie :: Trie f a -> (Maybe a, f (Trie f a))
getTrie = second getCompose . getProduct1 . getCompose1 . getFix1

mkTrie :: (Maybe a, f (Trie f a)) -> Trie f a
mkTrie = Fix1 . Compose1 . Product1 . second Compose

mapTrie :: Functor f => (a -> b) -> Trie f a -> Trie f b
mapTrie = fmap

class MapLike f where
  type Key f :: *
  emptyMapLike  :: f a
  insertMapLike :: Key f -> a -> f a -> f a
  lookupMapLike :: Key f -> f a -> Maybe a
 
emptyTrie :: MapLike f => Trie f a
emptyTrie = mkTrie (Nothing, emptyMapLike)
 
insertTrie :: MapLike f => [Key f] -> a -> Trie f a -> Trie f a
insertTrie [] a = mkTrie . first (const $ Just a) . getTrie
insertTrie (k:ks) a = mkTrie . second (insertMapLike k =<< insertTrie ks a . fromMaybe emptyTrie . lookupMapLike k) . getTrie
 
lookupTrie :: MapLike f => [Key f] -> Trie f a -> Maybe a
lookupTrie [] = fst . getTrie
lookupTrie (k:ks) = lookupTrie ks <=< lookupMapLike k . snd . getTrie

instance MapLike f => MapLike (Trie f) where
  type Key (Trie f) = [Key f]
  emptyMapLike = emptyTrie
  insertMapLike = insertTrie
  lookupMapLike = lookupTrie
-- }}}
type TrieForest f = Fix1 (Compose f `Compose1` Product1 Maybe)      -- TrieForest f a ~ f (Maybe a, TrieForest f a)
-- {{{
getTrieForest :: Functor f => TrieForest f a -> f (Maybe a, TrieForest f a)
getTrieForest = fmap getProduct1 . getCompose . getCompose1 . getFix1

mkTrieForest :: Functor f => f (Maybe a, TrieForest f a) -> TrieForest f a
mkTrieForest = Fix1 . Compose1 . Compose . fmap Product1

mapTrieForest :: Functor f => (a -> b) -> TrieForest f a -> TrieForest f b
mapTrieForest = fmap
-- }}}
type BinaryTree = Free1 (Double1 Product1)                          -- BinaryTree a ~ Either a (BinaryTree a, BinaryTree a)
-- {{{
getBinaryTree :: BinaryTree a -> Either a (BinaryTree a, BinaryTree a)
getBinaryTree = right (getProduct1 . getDouble1) . getFree1

mkBinaryTree :: Either a (BinaryTree a, BinaryTree a) -> BinaryTree a
mkBinaryTree = mkFree1 . right (Double1 . Product1)

mapBinaryTree :: (a -> b) -> BinaryTree a -> BinaryTree b
mapBinaryTree = fmap
-- }}}
type BST i = Free1 (Product1 (Const i) `Compose1` Double1 Product1) -- BST i a ~ Either a (BST i a, i, BST i a)
-- {{{
getBST :: BST i a -> Either a (i, (BST i a, BST i a))
getBST = right ((getConst *** getProduct1 . getDouble1) . getProduct1 . getCompose1) . getFree1

mkBST :: Either a (i, (BST i a, BST i a)) -> BST i a
mkBST = mkFree1 . right (Compose1 . Product1 . (Const *** Double1 . Product1))

mapBST :: (a -> b) -> BST i a -> BST i b
mapBST = fmap

-- BST is a bifunctor, but needs a newtype wrapper to do so properly
-- (or we need more tricks to make the BST alias pointfree)
bimapBST :: (i -> j) -> (a -> b) -> BST i a -> BST j b
bimapBST f g = mkBST . (g +++ (f *** (bimapBST f g *** bimapBST f g))) . getBST
-- }}}
-- vim: foldmethod=marker