{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DerivingVia #-}
module Trek
(
TrekT(..)
, Trek
, select
, selectEach
, iter
, collect
, mount
, mountEach
, with
, withEach
, evalTrek
, evalTrekT
, execTrek
, execTrekT
, runTrek
, runTrekT
, get
, gets
, put
, modify
, ask
, asks
) where
import Control.Applicative
import Control.Monad.Fail
import Control.Monad.Identity
import Control.Monad.Logic
import Control.Monad.Reader
import Control.Monad.State
import Data.Foldable
import Data.Functor.Identity
import Data.Monoid
type Trek s a = TrekT s Identity a
newtype TrekT s m a = TrekT (LogicT (StateT s m) a)
deriving newtype (Functor, Applicative, Monad, MonadState s, Alternative, MonadFail)
deriving (Semigroup, Monoid) via Ap (LogicT (StateT s m)) a
instance MonadTrans (TrekT s) where
lift m = TrekT (lift . lift $ m)
instance (Monad m) => MonadReader s (TrekT s m) where
ask = get
local f m = do
s <- get
modify f
a <- m
put s
pure a
select :: Monad m => (s -> a) -> TrekT s m a
select getter = gets getter
selectEach :: (Monad m, Foldable f) => (s -> f a) -> TrekT s m a
selectEach getter = select getter >>= iter
iter :: Foldable f => f a -> TrekT s m a
iter = asum . fmap pure . toList
collect :: Monad m => TrekT s m a -> TrekT s m [a]
collect trek = do
s <- get
lift . fmap fst $ runTrekT trek s
mount :: Monad m => (t -> s) -> TrekT s m a -> TrekT t m a
mount f trek = do
s <- select f
with s trek
mountEach :: (Monad m, Foldable f) => (t -> f s) -> TrekT s m a -> TrekT t m a
mountEach f trek = do
s <- selectEach f
with s trek
with :: Monad m => s -> TrekT s m a -> TrekT t m a
with s = mount (const s)
withEach :: (Monad m, Foldable f) => f s -> TrekT s m a -> TrekT t m a
withEach xs trek =
iter xs >>= flip with trek
evalTrek :: Trek s a -> s -> [a]
evalTrek t s = runIdentity $ evalTrekT t s
evalTrekT :: Monad m => TrekT s m a -> s -> m [a]
evalTrekT t s = fst <$> runTrekT t s
execTrek :: Trek s a -> s -> s
execTrek t s = runIdentity $ execTrekT t s
execTrekT :: Monad m => TrekT s m a -> s -> m s
execTrekT t s = snd <$> runTrekT t s
runTrek :: Trek s a -> s -> ([a], s)
runTrek t s = runIdentity $ runTrekT t s
runTrekT :: Monad m => TrekT s m a -> s -> m ([a], s)
runTrekT (TrekT m) s = flip runStateT s $ observeAllT m