automatic haskell function memoizing

Memo.hs

{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveFoldable #-}

import Data.Foldable
import qualified Data.Set as Set
import qualified Data.Map as Map

class Memo a where
  memo :: (a -> b) -> (a -> b)

  memoFix :: ((a -> b) -> (a -> b)) -> (a -> b)
  memoFix f = x
    where x = memo (f x)

-- Memoize a function over some type by mapping it into and out of
-- some other already memoizable type.
memoIso :: (Memo a) => (b -> a) -> (a -> b) -> (b -> c) -> (b -> c)
memoIso into out f = memo (f . out) . into

-- lurr
curry3 f = \a b c -> f (a, b, c)
uncurry3 f = \(a, b, c) -> f a b c

-- () memoization - lol?
instance Memo () where
  memo f = let x = f () in \() -> x

-- Positive integer memoization
newtype Pos = Pos Integer
            deriving (Show, Enum, Real, Num, Ord, Eq, Integral)

branchP :: a -> (Pos -> a) -> (Pos -> a) -> Pos -> a
branchP x l r n | n == 1 = x
                | even n = l (n `div` 2)
                | otherwise = r (n `div` 2)

instance Memo Pos where
  memo f = branchP (f 1) (memo (\n -> f (2*n))) (memo (\n -> f (2*n+1)))

-- Integer memoization
intToPos n = Pos $ if n >= 0 then n*2 + 1 else -n*2
posToInt (Pos n) = if even n then -n `div` 2 else n `div` 2

instance Memo Integer where
  memo = memoIso intToPos posToInt

-- Other ints and enums built on top
memoInt :: Integral a => (a -> b) -> (a -> b)
memoInt = memoIso toInteger fromInteger
memoEnum :: Enum a => (a -> b) -> (a -> b)
memoEnum = memoIso fromEnum toEnum

instance Memo Int where memo = memoInt
instance Memo Char where memo = memoEnum

-- curried memoization
memo2 :: (Memo a, Memo b) => (a -> b -> c) -> (a -> b -> c)
memo2 f = memo (\x -> memo (f x))
memo3 :: (Memo a, Memo b, Memo c) => (a -> b -> c -> d) -> (a -> b -> c -> d)
memo3 f = memo (\x -> memo2 (f x))

-- products
instance (Memo a, Memo b) => Memo (a, b) where
  memo = uncurry . memo2 . curry
instance (Memo a, Memo b, Memo c) => Memo (a, b, c) where
  memo = uncurry3 . memo3 . curry3

-- sums
instance (Memo a, Memo b) => Memo (Either a b) where
  memo f = either (memo (f . Left)) (memo (f . Right))

--
-- One way to do [] is by converting it to an algebraic form
-- that falls out automatically and then converting back
newtype BSList a = InBS { outBS :: Either () (a, BSList a) }
                 deriving (Show, Foldable)
toBSList :: Foldable t => t a -> BSList a
toBSList = foldr (curry (InBS . Right)) (InBS $ Left ())

instance Memo a => Memo (BSList a) where
  memo = memoIso outBS InBS

-- There's also a fairly straightforward direct list implementation
instance Memo a => Memo [a] where
  memo f = list (f []) (memo2 (\x xs -> f (x:xs)))

-- is this actually not a function anywhere?
list :: b -> (a -> [a] -> b) -> [a] -> b
list nil cons [] = nil
list nil cons (x:xs) = cons x xs

--

instance (Memo a) => Memo (Set.Set a) where
  memo = memoIso Set.toList Set.fromDistinctAscList
instance (Memo a, Memo k) => Memo (Map.Map k a) where
  memo = memoIso Map.toList Map.fromDistinctAscList

-----
-- Test for Integer memoizing
hyperbinary :: Integer -> Integer
hyperbinary = memo hyperbinary'
hyperbinary' 0 = 1
hyperbinary' n = if odd n then hyperbinary ((n-1) `div` 2)
                 else hyperbinary ((n `div` 2) - 1) + hyperbinary (n `div` 2)

--
main = print $ hyperbinary 1000000000000000000000000000000000000000000000000000000000000000000000000100000000000000000000000000000000000000000000000000000000000000000000000010000000000000000000000000000000000000000000000000000000000000000000000001000000000000000000000000000000000000000000000000000000000000000000000000100000000000000000000000000000000000000000000000000000000000000000000000010000000000000000000000000000000000000000000000000000000000000000000000001