Stack-safe ListT in PureScript using FreeT

ListT.purs

module Control.Monad.List.Trans where

import Prelude

import Data.List
import Data.Either

import Control.Apply
import Control.Bind
import Control.Monad.Eff
import Control.Monad.Eff.Console
import Control.Monad.Trans
import Control.Monad.Free.Trans
import Control.Monad.Rec.Class
import Control.Monad.Writer.Trans

data ListF a b = One a b | Zero b

instance functorListF :: Functor (ListF a) where
  map f (One a b) = One a (f b)
  map f (Zero b) = Zero (f b)

newtype ListT m a = ListT (FreeT (ListF a) m Unit)

runListT :: forall m a. (MonadRec m) => ListT m a -> m (List a)
runListT (ListT free) = execWriterT $ runFreeT go $ hoistFreeT lift free
  where
  go (One a b) = do
    tell (singleton a)
    return b
  go (Zero b) = return b

instance functorListT :: (Functor m) => Functor (ListT m) where
  map = mapListT
  
mapListT :: forall m a b. (Functor m) => (a -> b) -> ListT m a -> ListT m b
mapListT f (ListT free) = ListT (interpret go free)
  where
  go :: forall r. ListF a r -> ListF b r
  go (One a b) = One (f a) b
  go (Zero b) = Zero b

instance applyListT :: (Monad m) => Apply (ListT m) where
  apply = ap

instance applicativeListT :: (Monad m) => Applicative (ListT m) where
  pure a = ListT (liftFreeT (One a unit))

instance bindLT :: (Monad m) => Bind (ListT m) where
  bind = bindListT

bindListT :: forall m a b. (Monad m) => ListT m a -> (a -> ListT m b) -> ListT m b
bindListT (ListT free) f = ListT $ runFreeT go $ hoistFreeT lift free
  where
  go :: ListF a (FreeT (ListF a) (FreeT (ListF b) m) Unit) -> FreeT (ListF b) m (FreeT (ListF a) (FreeT (ListF b) m) Unit)
  go (One a b) = do
    case f a of ListT l -> l
    return b
  go (Zero b) = return b

instance monadListT :: (Monad m) => Monad (ListT m)

instance monadTransListT :: MonadTrans ListT where
  lift ma = ListT $ freeT \_ -> map (Right <<< (`One` (pure unit))) ma

oneOf :: forall m a. (Monad m) => List a -> ListT m a
oneOf l = ListT $ tailRecM go l
  where
  go :: List a -> FreeT (ListF a) m (Either (List a) Unit)
  go Nil = return (Right unit)
  go (Cons a l1) = liftFreeT (One a (Left l1))

none :: forall m a. (Monad m) => ListT m a
none = ListT (return unit)

main = print =<< runListT do
  x <- oneOf (1 .. 1000)
  y <- oneOf (1 .. x)
  z <- oneOf (1 .. y)
  if (x * x == y * y + z * z)
    then do lift $ print [x, y, z]
            return [x, y, z]
    else none