Reflection.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Reflection where

import Capability.Error
import Capability.Reader
import Capability.Reflection
import Capability.Sink
import Capability.Source
import Capability.State
import Capability.Writer
import Control.Monad (forM_, replicateM)
import qualified Control.Monad.Except as MTL
import qualified Control.Monad.State as MTL
import Data.DList (DList)
import qualified Data.DList as DList
import Data.Monoid (Product (..))
import Test.Hspec

----------------------------------------------------------------------
-- Instances

newtype Logger s a = Logger (MTL.State (DList String, s) a)
  deriving (Functor, Applicative, Monad)
  deriving
    (HasSink "log" String)
    via SinkDList (SinkLog (Rename 1 (Pos 1 () (MonadState (MTL.State (DList String, s))))))
  deriving
    (HasState "test" s, HasSource "test" s, HasSink "test" s)
    via Rename 2 (Pos 2 () (MonadState (MTL.State (DList String, s))))

runLogger :: s -> Logger s a -> (a, s, [String])
runLogger s0 (Logger m) =
  case MTL.runState m (mempty, s0) of
    (a, (log', s)) -> (a, s, DList.toList log')

----------------------------------------------------------------------
-- Test Cases

spec :: Spec
spec = do
  describe "interpret_" $ do
    it "evaluates HasSource" $ do
      runLogger
        [1, 2, 3 :: Int]
        ( interpret_ @"source"
            ReifiedSource
              { _await = do
                  yield @"log" "await"
                  state @"test" $ \case
                    (x : xs) -> (x, xs)
                    [] -> error "empty stream"
              }
            (replicateM 3 $ await @"source")
        )
        `shouldBe` ([1, 2, 3], [], ["await", "await", "await"])
    it "evaluates HasSink" $ do
      runLogger
        []
        ( interpret_ @"sink"
            ReifiedSink
              { _yield = \x -> do
                  yield @"log" "yield"
                  modify @"test" (x :)
              }
            (forM_ [1, 2, 3 :: Int] $ yield @"sink")
        )
        `shouldBe` ((), [3, 2, 1], ["yield", "yield", "yield"])
    it "evaluates HasReader" $ do
      runLogger
        (42 :: Int)
        ( interpret_ @"reader"
            ReifiedReader
              { _readerSource =
                  ReifiedSource
                    { _await = do
                        yield @"log" "ask"
                        get @"test"
                    },
                _local = \f m -> do
                  yield @"log" "local"
                  r <- state @"test" $ \r -> (r, f r)
                  a <- m
                  put @"test" r
                  pure a,
                _reader = \f -> do
                  yield @"log" "reader"
                  f <$> get @"test"
              }
            ( sequence
                [ ask @"reader",
                  local @"reader" succ $ do
                    asks @"reader" succ,
                  reader @"reader" pred
                ]
            )
        )
        `shouldBe` ([42, 44, 41], 42, ["ask", "local", "ask", "reader"])
    it "evaluates HasState" $ do
      runLogger
        (42 :: Int)
        ( interpret_ @"state"
            ReifiedState
              { _stateSource =
                  ReifiedSource
                    { _await = do
                        yield @"log" "get"
                        get @"test"
                    },
                _stateSink =
                  ReifiedSink
                    { _yield = \x -> do
                        yield @"log" "put"
                        put @"test" x
                    },
                _state = \f -> do
                  yield @"log" "state"
                  state @"test" f
              }
            ( do
                old <- get @"state"
                put @"state" 0
                state @"state" (\new -> (old, succ new))
            )
        )
        `shouldBe` (42, 1, ["get", "put", "state"])
    it "evaluates HasWriter" $ do
      runLogger
        (mempty :: Product Int)
        ( interpret_ @"writer"
            ReifiedWriter
              { _writerSink =
                  ReifiedSink
                    { _yield = \w -> do
                        yield @"log" "tell"
                        modify @"test" (<> w)
                    },
                _writer = \(a, w) -> do
                  yield @"log" "writer"
                  modify @"test" (<> w)
                  pure a,
                _listen = \m -> do
                  yield @"log" "listen"
                  w0 <- state @"test" $ \s -> (s, mempty)
                  a <- m
                  w <- state @"test" $ \s -> (s, w0 <> s)
                  pure (a, w),
                _pass = \m -> do
                  yield @"log" "pass"
                  w0 <- state @"test" $ \s -> (s, mempty)
                  (a, f) <- m
                  modify' @"test" $ \s -> w0 <> f s
                  pure a
              }
            ( do
                tell @"writer" 2
                writer @"writer" ((), 3)
                ((), w) <- listen @"writer" $ do
                  tell @"writer" 5
                pass @"writer" $ do
                  tell @"writer" 6
                  pure ((), (+ 1))
                pure w
            )
        )
        `shouldBe` (5, 2 * 3 * 5 * 7, ["tell", "writer", "listen", "tell", "pass", "tell"])
    it "evaluates HasThrow" $ do
      runLogger
        ()
        ( MTL.runExceptT $
            interpret_ @"throw"
              ReifiedThrow
                { _throw = \e -> do
                    MTL.lift $ yield @"log" "throw"
                    MTL.throwError e
                }
              ( do
                  _ <- throw @"throw" "some error"
                  pure $! tail ""
              )
        )
        `shouldBe` (Left "some error", (), ["throw"])
    it "evaluates HasCatch" $ do
      runLogger
        ()
        ( MTL.runExceptT $
            interpret_ @"catch"
              ReifiedCatch
                { _catchThrow =
                    ReifiedThrow
                      { _throw = \e -> do
                          MTL.lift $ yield @"log" "throw"
                          MTL.throwError e
                      },
                  _catch = \m h -> do
                    MTL.lift $ yield @"log" "catch"
                    MTL.catchError m h,
                  _catchJust = \f m h -> do
                    MTL.lift $ yield @"log" "catchJust"
                    MTL.catchError m $ \e ->
                      case f e of
                        Just b -> h b
                        Nothing -> MTL.throwError e
                }
              ( do
                  e1 <-
                    catch @"catch"
                      ( do
                          _ <- throw @"catch" "some error"
                          pure $! tail ""
                      )
                      pure
                  catchJust @"catch"
                    (const Nothing)
                    ( do
                        _ <- throw @"catch" ("again " ++ e1)
                        pure $! tail ""
                    )
                    pure
              )
        )
        `shouldBe` (Left "again some error", (), ["catch", "throw", "catchJust", "throw"])
  describe "interpret" $ do
    it "can be nested" $ do
      runLogger
        ()
        ( interpret @"source" @'[HasSink "log" String]
            ReifiedSource
              { _await = do
                  yield @"log" "await"
                  pure ()
              }
            ( interpret @"sink" @'[HasSink "log" String, HasSource "source" ()]
                ReifiedSink
                  { _yield = \() -> do
                      yield @"log" "yield"
                      pure ()
                  }
                ( do
                    yield @"log" "begin"
                    await @"source"
                    yield @"sink" ()
                    yield @"log" "end"
                )
            )
        )
        `shouldBe` ((), (), ["begin", "await", "yield", "end"])