Tramampoline!

trampoline.purs

module Main where

import Debug.Trace

data Trampoline a = Done a | More ({} -> Trampoline a)

instance functorTrampoline :: Functor Trampoline where
  (<$>) f (Done a) = Done (f a)
  (<$>) f (More k) = More $ \_ -> f <$> k {}
  
instance applyTrampoline :: Apply Trampoline where
  (<*>) = ap
  
instance applicativeTrampoline :: Applicative Trampoline where
  pure = Done
  
instance bindTrampoline :: Bind Trampoline where
  (>>=) (Done a) f = f a
  (>>=) (More k) f = More $ \_ -> k {} >>= f
  
instance monadTrampoline :: Monad Trampoline

runTrampoline :: forall a. Trampoline a -> a
runTrampoline (Done a) = a
runTrampoline (More k) = runTrampoline (k {})

class (Monad m) <= MonadBounce m where
  bounce :: m {}

instance monadBounceTrampoline :: MonadBounce Trampoline where
  bounce = More Done

data Tuple a b = Tuple a b

instance showTuple :: (Show a, Show b) => Show (Tuple a b) where
  show (Tuple a b) = show a ++ "," ++ show b

data StateT s m a = StateT (s -> m (Tuple a s))

runStateT :: forall s m a. StateT s m a -> s -> m (Tuple a s)
runStateT (StateT s) = s

evalStateT :: forall s m a. (Monad m) => StateT s m a -> s -> m a
evalStateT m s = runStateT m s >>= \(Tuple x _) -> return x

execStateT :: forall s m a. (Monad m) => StateT s m a -> s -> m s
execStateT m s = runStateT m s >>= \(Tuple _ s) -> return s

mapStateT :: forall s m1 m2 a b. (m1 (Tuple a s) -> m2 (Tuple b s)) -> StateT s m1 a -> StateT s m2 b
mapStateT f m = StateT $ f <<< runStateT m

withStateT :: forall s m a. (s -> s) -> StateT s m a -> StateT s m a
withStateT f s = StateT $ runStateT s <<< f

instance functorStateT :: (Monad m) => Functor (StateT s m) where
  (<$>) = liftM1
  
instance applyStateT :: (Monad m) => Apply (StateT s m) where
  (<*>) = ap

instance applicativeStateT :: (Monad m) => Applicative (StateT s m) where
  pure a = StateT $ \s -> return $ Tuple a s
  
instance alternativeStateT :: (Alternative m) => Alternative (StateT s m) where
  empty = StateT $ \_ -> empty
  (<|>) x y = StateT $ \s -> runStateT x s <|> runStateT y s

instance bindStateT :: (Monad m) => Bind (StateT s m) where
  (>>=) (StateT x) f = StateT \s -> do
    Tuple v s' <- x s
    runStateT (f v) s'
    
instance monadStateT :: (Monad m) => Monad (StateT s m)

instance monadBounceStateT :: (MonadBounce m) => MonadBounce (StateT s m) where
  bounce = StateT $ \s -> do
    bounce
    return $ Tuple {} s

get :: forall m s. (Monad m) => StateT s m s
get = StateT $ \s -> return (Tuple s s)

put :: forall m s. (Monad m) => s -> StateT s m {}
put s = StateT $ \_ -> return (Tuple {} s)

fib :: Number -> Tuple Number Number
fib n = runTrampoline (runStateT (go n) 0)
  where
  go :: Number -> StateT Number Trampoline Number
  go 1 = pure 1
  go 2 = pure 1
  go n = do
    bounce
    count <- get
    put (count + 1)
    a <- go (n - 1)
    bounce
    b <- go (n - 2)
    return $ a + b
    

main = print (fib 20)