recursion-schemes-ext-1.0.0.4: test/Examples.hs

-- {-# LANGUAGE AllowAmbiguousTypes   #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DeriveFoldable        #-}
{-# LANGUAGE DeriveFunctor         #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE DeriveTraversable     #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeFamilies          #-}

-- | This module contains an example used by the test suite.
module Examples ( -- * Data Types
         Bert (..)
       , Ernie (..)
       , BertF (..)
       , ErnieF (..)
       -- * Catamorphisms
       , collapseErnieSyntaxTree
       , collapseErnieSyntaxTree'
       , collapseBertSyntaxTree
       , collapseBertSyntaxTree'
       ) where

import           Control.DeepSeq              (NFData)
import           Data.Functor.Foldable
import           Data.Functor.Foldable.Exotic
import           Data.Functor.Foldable.TH
import           GHC.Generics                 (Generic)

-- | We call our co-dependent data types 'Ernie' and 'Bert'.
data Bert = Bert Ernie
          | Num Integer
          | String String
          | Add Bert Bert
           deriving (Show, Eq, Generic, NFData)

data Ernie = Ernie Bert
           | Multiply Ernie Ernie
           deriving (Show, Eq, Generic, NFData)

makeBaseFunctor ''Ernie
makeBaseFunctor ''Bert

ernieHelper :: (BertF Bert -> Bert) -> Trans Ernie Ernie
ernieHelper alg = (mapErnie g .)
    where g (Ernie b) = Ernie $ dendro bertHelper ernieAlgebra alg b
          g x         = x
          mapErnie f (Ernie (Bert e)) = mapErnie f e
          mapErnie f e                = f e

bertHelper :: (ErnieF Ernie -> Ernie) -> Trans Bert Bert
bertHelper alg = (mapBert g .)
    where g (Bert e) = Bert $ dendro ernieHelper bertAlgebra alg e
          g x        = x
          mapBert f (Bert (Ernie b)) = mapBert f b
          mapBert f x                = f x

-- | BertF-algebra
bertAlgebra :: BertF Bert -> Bert
bertAlgebra (AddF (Num i) (Num j)) = Num $ i + j
bertAlgebra x                      = embed x

-- | ErnieF-algebra
ernieAlgebra :: ErnieF Ernie -> Ernie
ernieAlgebra (MultiplyF (Ernie (Num i)) (Ernie (Num j))) = Ernie . Num $ i * j
ernieAlgebra x                                           = embed x

-- | Dendromorphism collapsing the tree. Note that we can use the same
-- F-algebras here as we would in a normal catamorphism.
collapseErnieSyntaxTree :: (Recursive Ernie, Recursive Bert) => Ernie -> Ernie
collapseErnieSyntaxTree = finish $ dendro ernieHelper bertAlgebra ernieAlgebra

-- | We can generate two functions by swapping the F-algebras and the dummy
-- type.
collapseBertSyntaxTree :: (Recursive Bert, Recursive Ernie) => Bert -> Bert
collapseBertSyntaxTree = finish $ dendro bertHelper ernieAlgebra bertAlgebra

-- | Catamorphism, which collapses the tree the usual way.
collapseErnieSyntaxTree' :: (Recursive Ernie) => Ernie -> Ernie
collapseErnieSyntaxTree' = cata algebra
    where algebra (ErnieF e)                                  = Ernie $ collapseBertSyntaxTree' e
          algebra (MultiplyF (Ernie (Num i)) (Ernie (Num j))) = Ernie . Num $ i * j
          algebra x                                           = embed x

collapseBertSyntaxTree' :: (Recursive Bert) => Bert -> Bert
collapseBertSyntaxTree' = cata algebra
    where algebra (BertF e)              = Bert $ collapseErnieSyntaxTree' e
          algebra (AddF (Num i) (Num j)) = Num $ i + j
          algebra x                      = embed x