{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}

module OptEnvConf.NonDet
  ( runNonDet,
    runNonDetT,
    runNonDetTLazy,
    liftNonDetTList,
    NonDetT,
  )
where

import Control.Applicative
import Control.Monad
import Control.Monad.State
import Data.Functor.Identity

type NonDet = NonDetT Identity

runNonDet :: NonDet a -> [a]
runNonDet :: forall a. NonDet a -> [a]
runNonDet = Identity [a] -> [a]
forall a. Identity a -> a
runIdentity (Identity [a] -> [a])
-> (NonDet a -> Identity [a]) -> NonDet a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonDet a -> Identity [a]
forall (m :: * -> *) a. Monad m => NonDetT m a -> m [a]
runNonDetT

type NonDetT = ListT

runNonDetT :: (Monad m) => NonDetT m a -> m [a]
runNonDetT :: forall (m :: * -> *) a. Monad m => NonDetT m a -> m [a]
runNonDetT = ListT m a -> m [a]
forall (m :: * -> *) a. Monad m => NonDetT m a -> m [a]
runListTComplete

runNonDetTLazy :: (Monad m) => NonDetT m a -> m (Maybe (a, NonDetT m a))
runNonDetTLazy :: forall (m :: * -> *) a.
Monad m =>
NonDetT m a -> m (Maybe (a, NonDetT m a))
runNonDetTLazy = ListT m a -> m (Maybe (a, ListT m a))
forall (m :: * -> *) a.
Functor m =>
ListT m a -> m (Maybe (a, ListT m a))
runListTLazy

liftNonDetTList :: (Applicative m) => [a] -> NonDetT m a
liftNonDetTList :: forall (m :: * -> *) a. Applicative m => [a] -> NonDetT m a
liftNonDetTList = [a] -> ListT m a
forall (m :: * -> *) a. Applicative m => [a] -> NonDetT m a
liftListT

-- The monadic list type
data MList m a
  = MNil
  | MCons a (m (MList m a))

instance (Functor f) => Functor (MList f) where
  fmap :: forall a b. (a -> b) -> MList f a -> MList f b
fmap a -> b
f = \case
    MList f a
MNil -> MList f b
forall (m :: * -> *) a. MList m a
MNil
    MCons a
a f (MList f a)
r -> b -> f (MList f b) -> MList f b
forall (m :: * -> *) a. a -> m (MList m a) -> MList m a
MCons (a -> b
f a
a) ((MList f a -> MList f b) -> f (MList f a) -> f (MList f b)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> MList f a -> MList f b
forall a b. (a -> b) -> MList f a -> MList f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) f (MList f a)
r)

liftMList :: (Applicative m) => [a] -> MList m a
liftMList :: forall (m :: * -> *) a. Applicative m => [a] -> MList m a
liftMList = \case
  [] -> MList m a
forall (m :: * -> *) a. MList m a
MNil
  (a
a : [a]
as) -> a -> m (MList m a) -> MList m a
forall (m :: * -> *) a. a -> m (MList m a) -> MList m a
MCons a
a (m (MList m a) -> MList m a) -> m (MList m a) -> MList m a
forall a b. (a -> b) -> a -> b
$ MList m a -> m (MList m a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MList m a -> m (MList m a)) -> MList m a -> m (MList m a)
forall a b. (a -> b) -> a -> b
$ [a] -> MList m a
forall (m :: * -> *) a. Applicative m => [a] -> MList m a
liftMList [a]
as

joinMMList :: (Monad m) => MList m (m (MList m a)) -> m (MList m a)
joinMMList :: forall (m :: * -> *) a.
Monad m =>
MList m (m (MList m a)) -> m (MList m a)
joinMMList = \case
  MList m (m (MList m a))
MNil -> MList m a -> m (MList m a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MList m a
forall (m :: * -> *) a. MList m a
MNil
  MCons m (MList m a)
a m (MList m (m (MList m a)))
m -> m (MList m a) -> m (MList m a) -> m (MList m a)
forall (m :: * -> *) a.
Applicative m =>
m (MList m a) -> m (MList m a) -> m (MList m a)
appendMMMList m (MList m a)
a (m (MList m (m (MList m a)))
m m (MList m (m (MList m a)))
-> (MList m (m (MList m a)) -> m (MList m a)) -> m (MList m a)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MList m (m (MList m a)) -> m (MList m a)
forall (m :: * -> *) a.
Monad m =>
MList m (m (MList m a)) -> m (MList m a)
joinMMList)

joinMMMList :: (Monad m) => m (MList m (m (MList m a))) -> m (MList m a)
joinMMMList :: forall (m :: * -> *) a.
Monad m =>
m (MList m (m (MList m a))) -> m (MList m a)
joinMMMList = (m (MList m (m (MList m a)))
-> (MList m (m (MList m a)) -> m (MList m a)) -> m (MList m a)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MList m (m (MList m a)) -> m (MList m a)
forall (m :: * -> *) a.
Monad m =>
MList m (m (MList m a)) -> m (MList m a)
joinMMList)

appendMList :: (Functor m) => MList m a -> MList m a -> MList m a
appendMList :: forall (m :: * -> *) a.
Functor m =>
MList m a -> MList m a -> MList m a
appendMList MList m a
MNil MList m a
ml = MList m a
ml
appendMList (MCons a
a m (MList m a)
ml1) MList m a
ml2 = a -> m (MList m a) -> MList m a
forall (m :: * -> *) a. a -> m (MList m a) -> MList m a
MCons a
a (m (MList m a) -> MList m a) -> m (MList m a) -> MList m a
forall a b. (a -> b) -> a -> b
$ (MList m a -> MList m a -> MList m a
forall (m :: * -> *) a.
Functor m =>
MList m a -> MList m a -> MList m a
`appendMList` MList m a
ml2) (MList m a -> MList m a) -> m (MList m a) -> m (MList m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (MList m a)
ml1

appendMMMList :: (Applicative m) => m (MList m a) -> m (MList m a) -> m (MList m a)
appendMMMList :: forall (m :: * -> *) a.
Applicative m =>
m (MList m a) -> m (MList m a) -> m (MList m a)
appendMMMList m (MList m a)
ml1 m (MList m a)
ml2 = MList m a -> MList m a -> MList m a
forall (m :: * -> *) a.
Functor m =>
MList m a -> MList m a -> MList m a
appendMList (MList m a -> MList m a -> MList m a)
-> m (MList m a) -> m (MList m a -> MList m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (MList m a)
ml1 m (MList m a -> MList m a) -> m (MList m a) -> m (MList m a)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m (MList m a)
ml2

-- This can be directly used as a monad transformer
newtype ListT m a = ListT {forall (m :: * -> *) a. ListT m a -> m (MList m a)
unListT :: m (MList m a)}

-- A "lazy" run function, which only calculates the first solution.
runListTLazy :: (Functor m) => ListT m a -> m (Maybe (a, ListT m a))
runListTLazy :: forall (m :: * -> *) a.
Functor m =>
ListT m a -> m (Maybe (a, ListT m a))
runListTLazy = (MList m a -> Maybe (a, ListT m a))
-> m (MList m a) -> m (Maybe (a, ListT m a))
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MList m a -> Maybe (a, ListT m a)
forall {m :: * -> *} {a}. MList m a -> Maybe (a, ListT m a)
g (m (MList m a) -> m (Maybe (a, ListT m a)))
-> (ListT m a -> m (MList m a))
-> ListT m a
-> m (Maybe (a, ListT m a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ListT m a -> m (MList m a)
forall (m :: * -> *) a. ListT m a -> m (MList m a)
unListT
  where
    g :: MList m a -> Maybe (a, ListT m a)
g MList m a
MNil = Maybe (a, ListT m a)
forall a. Maybe a
Nothing
    g (a
x `MCons` m (MList m a)
xs) = (a, ListT m a) -> Maybe (a, ListT m a)
forall a. a -> Maybe a
Just (a
x, m (MList m a) -> ListT m a
forall (m :: * -> *) a. m (MList m a) -> ListT m a
ListT m (MList m a)
xs)

runListTComplete :: (Monad m) => ListT m a -> m [a]
runListTComplete :: forall (m :: * -> *) a. Monad m => NonDetT m a -> m [a]
runListTComplete = ListT m a -> m (MList m a)
forall (m :: * -> *) a. ListT m a -> m (MList m a)
unListT (ListT m a -> m (MList m a))
-> (MList m a -> m [a]) -> ListT m a -> m [a]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> MList m a -> m [a]
forall {a}. MList m a -> m [a]
go
  where
    goML :: m (MList m a) -> m [a]
goML m (MList m a)
f = m (MList m a)
f m (MList m a) -> (MList m a -> m [a]) -> m [a]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MList m a -> m [a]
go
    go :: MList m a -> m [a]
go = \case
      MList m a
MNil -> [a] -> m [a]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      MCons a
a m (MList m a)
f -> (a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> m [a] -> m [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (MList m a) -> m [a]
goML m (MList m a)
f

liftListT :: (Applicative m) => [a] -> ListT m a
liftListT :: forall (m :: * -> *) a. Applicative m => [a] -> NonDetT m a
liftListT = m (MList m a) -> ListT m a
forall (m :: * -> *) a. m (MList m a) -> ListT m a
ListT (m (MList m a) -> ListT m a)
-> ([a] -> m (MList m a)) -> [a] -> ListT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MList m a -> m (MList m a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MList m a -> m (MList m a))
-> ([a] -> MList m a) -> [a] -> m (MList m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> MList m a
forall (m :: * -> *) a. Applicative m => [a] -> MList m a
liftMList

instance (Functor f) => Functor (ListT f) where
  fmap :: forall a b. (a -> b) -> ListT f a -> ListT f b
fmap a -> b
f = f (MList f b) -> ListT f b
forall (m :: * -> *) a. m (MList m a) -> ListT m a
ListT (f (MList f b) -> ListT f b)
-> (ListT f a -> f (MList f b)) -> ListT f a -> ListT f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MList f a -> MList f b) -> f (MList f a) -> f (MList f b)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> MList f a -> MList f b
forall a b. (a -> b) -> MList f a -> MList f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) (f (MList f a) -> f (MList f b))
-> (ListT f a -> f (MList f a)) -> ListT f a -> f (MList f b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ListT f a -> f (MList f a)
forall (m :: * -> *) a. ListT m a -> m (MList m a)
unListT

instance (Monad f) => Applicative (ListT f) where
  pure :: forall a. a -> ListT f a
pure a
a = f (MList f a) -> ListT f a
forall (m :: * -> *) a. m (MList m a) -> ListT m a
ListT (MList f a -> f (MList f a)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> f (MList f a) -> MList f a
forall (m :: * -> *) a. a -> m (MList m a) -> MList m a
MCons a
a (MList f a -> f (MList f a)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MList f a
forall (m :: * -> *) a. MList m a
MNil)))
  <*> :: forall a b. ListT f (a -> b) -> ListT f a -> ListT f b
(<*>) ListT f (a -> b)
ff ListT f a
fa = do
    a -> b
f <- ListT f (a -> b)
ff
    a
a <- ListT f a
fa
    b -> ListT f b
forall a. a -> ListT f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> b
f a
a)

instance (MonadIO m) => MonadIO (ListT m) where
  liftIO :: forall a. IO a -> ListT m a
liftIO = m a -> ListT m a
forall (m :: * -> *) a. Monad m => m a -> ListT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ListT m a) -> (IO a -> m a) -> IO a -> ListT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

instance MonadTrans ListT where
  lift :: forall (m :: * -> *) a. Monad m => m a -> ListT m a
lift = m (MList m a) -> ListT m a
forall (m :: * -> *) a. m (MList m a) -> ListT m a
ListT (m (MList m a) -> ListT m a)
-> (m a -> m (MList m a)) -> m a -> ListT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> MList m a) -> m a -> m (MList m a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> m (MList m a) -> MList m a
forall (m :: * -> *) a. a -> m (MList m a) -> MList m a
`MCons` MList m a -> m (MList m a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MList m a
forall (m :: * -> *) a. MList m a
MNil)

-- Note: This alternative instance only "alternates" on the nondeterminism, not the
-- underlying effect.
instance (Monad f) => Alternative (ListT f) where
  empty :: forall a. ListT f a
empty = f (MList f a) -> ListT f a
forall (m :: * -> *) a. m (MList m a) -> ListT m a
ListT (f (MList f a) -> ListT f a) -> f (MList f a) -> ListT f a
forall a b. (a -> b) -> a -> b
$ MList f a -> f (MList f a)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MList f a
forall (m :: * -> *) a. MList m a
MNil
  <|> :: forall a. ListT f a -> ListT f a -> ListT f a
(<|>) (ListT f (MList f a)
l1) (ListT f (MList f a)
l2) = f (MList f a) -> ListT f a
forall (m :: * -> *) a. m (MList m a) -> ListT m a
ListT (f (MList f a) -> ListT f a) -> f (MList f a) -> ListT f a
forall a b. (a -> b) -> a -> b
$ f (MList f a) -> f (MList f a) -> f (MList f a)
forall (m :: * -> *) a.
Applicative m =>
m (MList m a) -> m (MList m a) -> m (MList m a)
appendMMMList f (MList f a)
l1 f (MList f a)
l2

instance (Monad f) => Monad (ListT f) where
  >>= :: forall a b. ListT f a -> (a -> ListT f b) -> ListT f b
(>>=) ListT f a
m a -> ListT f b
f = ListT f (ListT f b) -> ListT f b
forall (m :: * -> *) a. Monad m => ListT m (ListT m a) -> ListT m a
joinListT (ListT f (ListT f b) -> ListT f b)
-> ListT f (ListT f b) -> ListT f b
forall a b. (a -> b) -> a -> b
$ (a -> ListT f b) -> ListT f a -> ListT f (ListT f b)
forall a b. (a -> b) -> ListT f a -> ListT f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> ListT f b
f ListT f a
m

joinListT :: (Monad m) => ListT m (ListT m a) -> ListT m a
joinListT :: forall (m :: * -> *) a. Monad m => ListT m (ListT m a) -> ListT m a
joinListT (ListT m (MList m (ListT m a))
xss) = m (MList m a) -> ListT m a
forall (m :: * -> *) a. m (MList m a) -> ListT m a
ListT (m (MList m a) -> ListT m a)
-> (m (MList m (m (MList m a))) -> m (MList m a))
-> m (MList m (m (MList m a)))
-> ListT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (MList m (m (MList m a))) -> m (MList m a)
forall (m :: * -> *) a.
Monad m =>
m (MList m (m (MList m a))) -> m (MList m a)
joinMMMList (m (MList m (m (MList m a))) -> ListT m a)
-> m (MList m (m (MList m a))) -> ListT m a
forall a b. (a -> b) -> a -> b
$ (MList m (ListT m a) -> MList m (m (MList m a)))
-> m (MList m (ListT m a)) -> m (MList m (m (MList m a)))
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ListT m a -> m (MList m a))
-> MList m (ListT m a) -> MList m (m (MList m a))
forall a b. (a -> b) -> MList m a -> MList m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ListT m a -> m (MList m a)
forall (m :: * -> *) a. ListT m a -> m (MList m a)
unListT) m (MList m (ListT m a))
xss