Get.hs

module Rattletrap.Get where

import qualified Control.Applicative as Applicative
import qualified Control.Exception as Exception
import qualified Data.Bifunctor as Bifunctor
import qualified Rattletrap.Exception.Empty as Empty
import qualified Rattletrap.Exception.Fail as Fail

newtype Get s m a = Get (s -> m (Either ([String], Exception.SomeException) (s, a)))

instance (Functor m) => Functor (Get s m) where
  fmap f g = Get $ fmap (fmap (fmap f)) . run g

instance (Monad m) => Applicative (Get s m) where
  pure x = Get $ \s -> pure $ Right (s, x)

  gf <*> gx = Get $ \s1 -> do
    r <- run gf s1
    case r of
      Left e -> pure $ Left e
      Right (s2, f) -> run (fmap f gx) s2

instance (Monad m) => Monad (Get s m) where
  g >>= f = Get $ \s1 -> do
    r <- run g s1
    case r of
      Left e -> pure $ Left e
      Right (s2, x) -> run (f x) s2

instance (Monad m) => MonadFail (Get s m) where
  fail = throw . Fail.Fail

instance (Monad m) => Applicative.Alternative (Get s m) where
  empty = throw Empty.Empty

  gx <|> gy = Get $ \s -> do
    r <- run gx s
    case r of
      Left _ -> run gy s
      Right x -> pure $ Right x

run :: Get s m a -> s -> m (Either ([String], Exception.SomeException) (s, a))
run (Get f) = f

get :: (Applicative m) => Get s m s
get = Get $ \s -> pure $ Right (s, s)

put :: (Applicative m) => s -> Get s m ()
put s = Get $ \_ -> pure $ Right (s, ())

lift :: (Functor m) => m a -> Get s m a
lift m = Get $ \s -> fmap (\x -> Right (s, x)) m

throw :: (Exception.Exception e, Applicative m) => e -> Get s m a
throw = Get . const . pure . Left . (,) [] . Exception.toException

embed :: (Monad m) => Get s m a -> s -> Get t m a
embed g s = do
  r <- lift $ run g s
  case r of
    Left (ls, e) -> labels ls $ throw e
    Right (_, x) -> pure x

labels :: (Functor m) => [String] -> Get s m a -> Get s m a
labels ls g = Get $ fmap (Bifunctor.first $ Bifunctor.first (ls <>)) . run g

label :: (Functor m) => String -> Get s m a -> Get s m a
label = labels . pure