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