Skip to content

Instantly share code, notes, and snippets.

@paf31

paf31/ListT.purs

Created August 27, 2015 04:03
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save paf31/eac16f0795165a285820 to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save paf31/eac16f0795165a285820 to your computer and use it in GitHub Desktop.
Download ZIP

Revisions

  1. paf31 created this gist Aug 27, 2015.
    83 changes: 83 additions & 0 deletions ListT.purs
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,83 @@
    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