gistfile1.hs

{-# LANGUAGE 
  FlexibleInstances, 
  FlexibleContexts, 
  UndecidableInstances,
  StandaloneDeriving,
  TypeOperators,
  UnicodeSyntax,
  Rank2Types,
  MultiParamTypeClasses,
  DeriveTraversable, DeriveFunctor, DeriveFoldable,
  TypeFamilies
 #-}
{- Inspired by: 
Visser and Loh. Generic Storage in Haskell. 2010.
http://www.andres-loeh.de/GenericStorage/wgp10-genstorage.pdf
-}

import Control.Applicative
import Control.Monad hiding (mapM)
import Control.Monad.Identity (Identity)
import Control.Monad.State.Lazy hiding (mapM)
import Data.Monoid
import Data.Traversable
import Data.Foldable
import Data.Hashable
import System.IO.Unsafe
import Prelude hiding (foldr, mapM, lookup)

-- Fixpoint
newtype Mu f = In (f (Mu f))
deriving instance (Show (f (Mu f))) => Show (Mu f)
unIn (In f) = f

-- Signature functor
data Tree a x = Tip | Bin x a x deriving (Show, Read, Functor)

deriving instance Foldable (Tree a)
deriving instance Traversable (Tree a)

tip :: Mu (Tree a)
tip = In Tip

bin :: Mu (Tree a) -> a -> Mu (Tree a) -> Mu (Tree a)
bin l a r = In $ Bin l a r

leaf :: a -> Mu (Tree a)
leaf a = bin tip a tip

t0 :: Mu (Tree Int)
t0 = bin (leaf 1) 2 (bin (leaf 3) 4 (In Tip))

-- Ordinary catamorphisms
             
type Algebra f a = f a -> a
type CoAlg f a = a -> f a

cata :: Functor f => Algebra f a -> Mu f -> a
cata f = c where c = f . fmap c . unIn
                 
ana :: Functor f => CoAlg f a -> a -> Mu f
ana f = c where c = In . fmap c . f

hylo :: Functor f => Algebra g b -> CoAlg f a -> a -> b
hylo f . e . fmap (hylo f e g). g

lookupAlg :: Ord a => a -> Algebra (Tree a) Bool
lookupAlg a Tip = False
lookupAlg a (Bin l a' r) = case compare a a' of
  EQ -> True
  LT -> l
  GT -> r

myTreeT :: TreeA Trace Int
myTreeT = evalState (myTree0 :: State [String] (TreeA Trace Int)) []

my_result :: Bool
my_result = ($) (evalState ((cataM (lookupAlg' 2) $ myTreeT) :: State [String] (() -> Bool)) []) ()
-- my_result == True                                                                                                                                                                                                              

my_trace :: [String]
my_tracet = execState ((cataM (lookupAlg' 2) $ myTreeT) :: State [String] (() -> Bool)) []

lookup :: Ord a => a -> Mu (Tree a) -> Bool 
lookup a = cata (lookupAlg a)