{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DeriveFunctor       #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-|
Module      : HsLua.Marshalling.Peek
Copyright   : © 2020-2021 Albert Krewinkel
License     : MIT
Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>
Stability   : beta
Portability : Portable

Types for unmarshalling of values from Lua.
-}
module HsLua.Marshalling.Peek
  ( Peeker
  , runPeeker
  , Result (..)
  , isFailure
  , failure
  , force
  , retrieving
  , resultToEither
  , toPeeker
  -- * Lua peek monad
  , Peek (..)
  , forcePeek
  , failPeek
  , liftLua
  , withContext
  , lastly
  , cleanup
  ) where

import Control.Applicative (Alternative (..))
import Control.Monad ((<$!>), (<=<))
import Data.ByteString (ByteString)
import Data.List (intercalate)
import HsLua.Core as Lua
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail (MonadFail (..))
#endif
import qualified HsLua.Core.Utf8 as Utf8

-- | Record to keep track of failure contexts while retrieving objects
-- from the Lua stack.
data Result a
  = Success a
  | Failure ByteString [Name]       -- ^ Error message and stack of contexts
  deriving (Int -> Result a -> ShowS
[Result a] -> ShowS
Result a -> String
(Int -> Result a -> ShowS)
-> (Result a -> String) -> ([Result a] -> ShowS) -> Show (Result a)
forall a. Show a => Int -> Result a -> ShowS
forall a. Show a => [Result a] -> ShowS
forall a. Show a => Result a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Result a] -> ShowS
$cshowList :: forall a. Show a => [Result a] -> ShowS
show :: Result a -> String
$cshow :: forall a. Show a => Result a -> String
showsPrec :: Int -> Result a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Result a -> ShowS
Show, Result a -> Result a -> Bool
(Result a -> Result a -> Bool)
-> (Result a -> Result a -> Bool) -> Eq (Result a)
forall a. Eq a => Result a -> Result a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Result a -> Result a -> Bool
$c/= :: forall a. Eq a => Result a -> Result a -> Bool
== :: Result a -> Result a -> Bool
$c== :: forall a. Eq a => Result a -> Result a -> Bool
Eq, a -> Result b -> Result a
(a -> b) -> Result a -> Result b
(forall a b. (a -> b) -> Result a -> Result b)
-> (forall a b. a -> Result b -> Result a) -> Functor Result
forall a b. a -> Result b -> Result a
forall a b. (a -> b) -> Result a -> Result b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Result b -> Result a
$c<$ :: forall a b. a -> Result b -> Result a
fmap :: (a -> b) -> Result a -> Result b
$cfmap :: forall a b. (a -> b) -> Result a -> Result b
Functor)

instance Applicative Result where
  pure :: a -> Result a
pure = a -> Result a
forall a. a -> Result a
Success
  {-# INLINE pure #-}
  Success a -> b
f         <*> :: Result (a -> b) -> Result a -> Result b
<*> Result a
s = (a -> b) -> Result a -> Result b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Result a
s
  Failure ByteString
msg [Name]
stack <*> Result a
_         = ByteString -> [Name] -> Result b
forall a. ByteString -> [Name] -> Result a
Failure ByteString
msg [Name]
stack
  {-# INLINE (<*>) #-}

instance Monad Result where
  Failure ByteString
msg [Name]
stack >>= :: Result a -> (a -> Result b) -> Result b
>>= a -> Result b
_ = ByteString -> [Name] -> Result b
forall a. ByteString -> [Name] -> Result a
Failure ByteString
msg [Name]
stack
  Success a
x         >>= a -> Result b
f = a -> Result b
f a
x

instance Alternative Result where
  empty :: Result a
empty = ByteString -> [Name] -> Result a
forall a. ByteString -> [Name] -> Result a
Failure ByteString
"empty" []
  {-# INLINE empty #-}
  Result a
x <|> :: Result a -> Result a -> Result a
<|> Result a
y = case Result a
x of
    Failure {} -> Result a
y
    Result a
_          -> Result a
x
  {-# INLINE (<|>) #-}

--
-- Peek
--

-- | Lua operation with an additional failure mode that can stack errors
-- from different contexts; errors are not based on exceptions).
newtype Peek e a = Peek { Peek e a -> LuaE e (Result a)
runPeek :: LuaE e (Result a) }
  deriving (a -> Peek e b -> Peek e a
(a -> b) -> Peek e a -> Peek e b
(forall a b. (a -> b) -> Peek e a -> Peek e b)
-> (forall a b. a -> Peek e b -> Peek e a) -> Functor (Peek e)
forall a b. a -> Peek e b -> Peek e a
forall a b. (a -> b) -> Peek e a -> Peek e b
forall e a b. a -> Peek e b -> Peek e a
forall e a b. (a -> b) -> Peek e a -> Peek e b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Peek e b -> Peek e a
$c<$ :: forall e a b. a -> Peek e b -> Peek e a
fmap :: (a -> b) -> Peek e a -> Peek e b
$cfmap :: forall e a b. (a -> b) -> Peek e a -> Peek e b
Functor)

-- | Converts a Peek action into a LuaE action, throwing an exception in
-- case of a peek failure.
forcePeek :: LuaError e => Peek e a -> LuaE e a
forcePeek :: Peek e a -> LuaE e a
forcePeek = Result a -> LuaE e a
forall e a. LuaError e => Result a -> LuaE e a
force (Result a -> LuaE e a)
-> (Peek e a -> LuaE e (Result a)) -> Peek e a -> LuaE e a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Peek e a -> LuaE e (Result a)
forall e a. Peek e a -> LuaE e (Result a)
runPeek
{-# INLINE forcePeek #-}

-- | Fails the peek operation.
failPeek :: forall a e. ByteString -> Peek e a
failPeek :: ByteString -> Peek e a
failPeek = LuaE e (Result a) -> Peek e a
forall e a. LuaE e (Result a) -> Peek e a
Peek (LuaE e (Result a) -> Peek e a)
-> (ByteString -> LuaE e (Result a)) -> ByteString -> Peek e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result a -> LuaE e (Result a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result a -> LuaE e (Result a))
-> (ByteString -> Result a) -> ByteString -> LuaE e (Result a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Result a
forall a. ByteString -> Result a
failure
{-# INLINE failPeek #-}

-- | Lifts a Lua operation into the Peek monad.
liftLua :: LuaE e a -> Peek e a
liftLua :: LuaE e a -> Peek e a
liftLua = LuaE e (Result a) -> Peek e a
forall e a. LuaE e (Result a) -> Peek e a
Peek (LuaE e (Result a) -> Peek e a)
-> (LuaE e a -> LuaE e (Result a)) -> LuaE e a -> Peek e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Result a) -> LuaE e a -> LuaE e (Result a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Result a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE liftLua #-}

instance Applicative (Peek e) where
  pure :: a -> Peek e a
pure = LuaE e (Result a) -> Peek e a
forall e a. LuaE e (Result a) -> Peek e a
Peek (LuaE e (Result a) -> Peek e a)
-> (a -> LuaE e (Result a)) -> a -> Peek e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result a -> LuaE e (Result a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result a -> LuaE e (Result a))
-> (a -> Result a) -> a -> LuaE e (Result a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Result a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE pure #-}

  Peek LuaE e (Result (a -> b))
f <*> :: Peek e (a -> b) -> Peek e a -> Peek e b
<*> Peek e a
x = LuaE e (Result b) -> Peek e b
forall e a. LuaE e (Result a) -> Peek e a
Peek (LuaE e (Result b) -> Peek e b) -> LuaE e (Result b) -> Peek e b
forall a b. (a -> b) -> a -> b
$! LuaE e (Result (a -> b))
f LuaE e (Result (a -> b))
-> (Result (a -> b) -> LuaE e (Result b)) -> LuaE e (Result b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Failure ByteString
msg [Name]
stack -> Result b -> LuaE e (Result b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result b -> LuaE e (Result b)) -> Result b -> LuaE e (Result b)
forall a b. (a -> b) -> a -> b
$ ByteString -> [Name] -> Result b
forall a. ByteString -> [Name] -> Result a
Failure ByteString
msg [Name]
stack
    Success a -> b
f'        -> (a -> b) -> Result a -> Result b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f' (Result a -> Result b) -> LuaE e (Result a) -> LuaE e (Result b)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Peek e a -> LuaE e (Result a)
forall e a. Peek e a -> LuaE e (Result a)
runPeek Peek e a
x
  {-# INLINEABLE (<*>) #-}

  Peek e a
m *> :: Peek e a -> Peek e b -> Peek e b
*> Peek e b
k = Peek e a
m Peek e a -> (a -> Peek e b) -> Peek e b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Peek e b -> a -> Peek e b
forall a b. a -> b -> a
const Peek e b
k
  {-# INLINE (*>) #-}

instance Monad (Peek e) where
  Peek LuaE e (Result a)
m >>= :: Peek e a -> (a -> Peek e b) -> Peek e b
>>= a -> Peek e b
k = LuaE e (Result b) -> Peek e b
forall e a. LuaE e (Result a) -> Peek e a
Peek (LuaE e (Result b) -> Peek e b) -> LuaE e (Result b) -> Peek e b
forall a b. (a -> b) -> a -> b
$
    LuaE e (Result a)
m LuaE e (Result a)
-> (Result a -> LuaE e (Result b)) -> LuaE e (Result b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Failure ByteString
msg [Name]
stack -> Result b -> LuaE e (Result b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result b -> LuaE e (Result b)) -> Result b -> LuaE e (Result b)
forall a b. (a -> b) -> a -> b
$ ByteString -> [Name] -> Result b
forall a. ByteString -> [Name] -> Result a
Failure ByteString
msg [Name]
stack
      Success a
x         -> Peek e b -> LuaE e (Result b)
forall e a. Peek e a -> LuaE e (Result a)
runPeek (a -> Peek e b
k a
x)
  {-# INLINE (>>=) #-}

instance Alternative (Peek e) where
  empty :: Peek e a
empty = LuaE e (Result a) -> Peek e a
forall e a. LuaE e (Result a) -> Peek e a
Peek (LuaE e (Result a) -> Peek e a)
-> (Result a -> LuaE e (Result a)) -> Result a -> Peek e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result a -> LuaE e (Result a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result a -> Peek e a) -> Result a -> Peek e a
forall a b. (a -> b) -> a -> b
$ ByteString -> Result a
forall a. ByteString -> Result a
failure ByteString
"empty"
  {-# INLINE empty #-}

  Peek e a
a <|> :: Peek e a -> Peek e a -> Peek e a
<|> Peek e a
b = LuaE e (Result a) -> Peek e a
forall e a. LuaE e (Result a) -> Peek e a
Peek (LuaE e (Result a) -> Peek e a) -> LuaE e (Result a) -> Peek e a
forall a b. (a -> b) -> a -> b
$ Peek e a -> LuaE e (Result a)
forall e a. Peek e a -> LuaE e (Result a)
runPeek Peek e a
a LuaE e (Result a)
-> (Result a -> LuaE e (Result a)) -> LuaE e (Result a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Success a
ra -> Result a -> LuaE e (Result a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Result a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
ra)
    Result a
_          -> Peek e a -> LuaE e (Result a)
forall e a. Peek e a -> LuaE e (Result a)
runPeek Peek e a
b
  {-# INLINE (<|>) #-}

instance MonadFail (Peek e) where
  fail :: String -> Peek e a
fail = LuaE e (Result a) -> Peek e a
forall e a. LuaE e (Result a) -> Peek e a
Peek (LuaE e (Result a) -> Peek e a)
-> (String -> LuaE e (Result a)) -> String -> Peek e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result a -> LuaE e (Result a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result a -> LuaE e (Result a))
-> (String -> Result a) -> String -> LuaE e (Result a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Result a
forall a. ByteString -> Result a
failure (ByteString -> Result a)
-> (String -> ByteString) -> String -> Result a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
Utf8.fromString
  {-# INLINABLE fail #-}

-- | Transform the result using the given function.
withContext :: Name -> Peek e a -> Peek e a
withContext :: Name -> Peek e a -> Peek e a
withContext Name
ctx = LuaE e (Result a) -> Peek e a
forall e a. LuaE e (Result a) -> Peek e a
Peek (LuaE e (Result a) -> Peek e a)
-> (Peek e a -> LuaE e (Result a)) -> Peek e a -> Peek e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Result a -> Result a) -> LuaE e (Result a) -> LuaE e (Result a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> Result a -> Result a
forall a. Name -> Result a -> Result a
addFailureContext Name
ctx) (LuaE e (Result a) -> LuaE e (Result a))
-> (Peek e a -> LuaE e (Result a)) -> Peek e a -> LuaE e (Result a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Peek e a -> LuaE e (Result a)
forall e a. Peek e a -> LuaE e (Result a)
runPeek
{-# INLINABLE withContext #-}

-- | Runs the peek action and Lua action in sequence, even if the peek
-- action fails.
lastly :: Peek e a -> LuaE e b -> Peek e a
lastly :: Peek e a -> LuaE e b -> Peek e a
lastly Peek e a
p LuaE e b
after = LuaE e (Result a) -> Peek e a
forall e a. LuaE e (Result a) -> Peek e a
Peek (LuaE e (Result a) -> Peek e a) -> LuaE e (Result a) -> Peek e a
forall a b. (a -> b) -> a -> b
$ Peek e a -> LuaE e (Result a)
forall e a. Peek e a -> LuaE e (Result a)
runPeek Peek e a
p LuaE e (Result a) -> LuaE e b -> LuaE e (Result a)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* LuaE e b
after
{-# INLINABLE lastly #-}

-- | Runs the peek action, resetting the stack top afterwards. This can
-- be used with peek actions that might otherwise leave elements on the
-- stack in case of a failure.
cleanup :: Peek e a -> Peek e a
cleanup :: Peek e a -> Peek e a
cleanup Peek e a
p = LuaE e (Result a) -> Peek e a
forall e a. LuaE e (Result a) -> Peek e a
Peek (LuaE e (Result a) -> Peek e a) -> LuaE e (Result a) -> Peek e a
forall a b. (a -> b) -> a -> b
$ do
  StackIndex
oldtop <- LuaE e StackIndex
forall e. LuaE e StackIndex
gettop
  Result a
result <- Peek e a -> LuaE e (Result a)
forall e a. Peek e a -> LuaE e (Result a)
runPeek Peek e a
p
  StackIndex -> LuaE e ()
forall e. StackIndex -> LuaE e ()
settop StackIndex
oldtop
  Result a -> LuaE e (Result a)
forall (m :: * -> *) a. Monad m => a -> m a
return Result a
result
{-# INLINABLE cleanup #-}

-- | Returns 'True' iff the peek result is a Failure.
isFailure :: Result a -> Bool
isFailure :: Result a -> Bool
isFailure Failure {} = Bool
True
isFailure Result a
_          = Bool
False

-- | Combines the peek failure components into a reportable string.
formatPeekFailure :: ByteString -> [Name] -> String
formatPeekFailure :: ByteString -> [Name] -> String
formatPeekFailure ByteString
msg [Name]
stack =
  String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n\twhile retrieving " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
  (ByteString -> String) -> [ByteString] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> String
Utf8.toString (ByteString
msg ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: (Name -> ByteString) -> [Name] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ByteString
fromName ([Name] -> [Name]
forall a. [a] -> [a]
reverse [Name]
stack))

-- | Function to retrieve a value from Lua's stack.
type Peeker e a = StackIndex -> Peek e a

-- | Runs the peeker function.
runPeeker :: Peeker e a -> StackIndex -> LuaE e (Result a)
runPeeker :: Peeker e a -> StackIndex -> LuaE e (Result a)
runPeeker Peeker e a
p = Peek e a -> LuaE e (Result a)
forall e a. Peek e a -> LuaE e (Result a)
runPeek (Peek e a -> LuaE e (Result a))
-> Peeker e a -> StackIndex -> LuaE e (Result a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Peeker e a
p

-- | Create a peek failure record from an error message.
failure :: ByteString -> Result a
failure :: ByteString -> Result a
failure ByteString
msg = ByteString -> [Name] -> Result a
forall a. ByteString -> [Name] -> Result a
Failure ByteString
msg []

-- | Add a message to the peek traceback stack.
addFailureContext :: Name -> Result a -> Result a
addFailureContext :: Name -> Result a -> Result a
addFailureContext Name
name = \case
  Failure ByteString
msg [Name]
stack -> ByteString -> [Name] -> Result a
forall a. ByteString -> [Name] -> Result a
Failure ByteString
msg (Name
name Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
stack)
  Result a
x -> Result a
x
{-# INLINABLE addFailureContext #-}

-- | Add context information to the peek traceback stack.
retrieving :: Name
           -> Peek e a
           -> Peek e a
retrieving :: Name -> Peek e a -> Peek e a
retrieving = Name -> Peek e a -> Peek e a
forall e a. Name -> Peek e a -> Peek e a
withContext
{-# INLINE retrieving #-}

-- | Force creation of an unwrapped result, throwing an exception if
-- that's not possible.
force :: LuaError e => Result a -> LuaE e a
force :: Result a -> LuaE e a
force = \case
  Success a
x -> a -> LuaE e a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
  Failure ByteString
msg [Name]
stack -> String -> LuaE e a
forall e a. LuaError e => String -> LuaE e a
failLua (String -> LuaE e a) -> String -> LuaE e a
forall a b. (a -> b) -> a -> b
$ ByteString -> [Name] -> String
formatPeekFailure ByteString
msg [Name]
stack
{-# INLINABLE force #-}

-- | Converts a Result into an Either, where @Left@ holds the reportable
-- string in case of an failure.
resultToEither :: Result a -> Either String a
resultToEither :: Result a -> Either String a
resultToEither = \case
  Failure ByteString
msg [Name]
stack -> String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a) -> String -> Either String a
forall a b. (a -> b) -> a -> b
$ ByteString -> [Name] -> String
formatPeekFailure ByteString
msg [Name]
stack
  Success a
x         -> a -> Either String a
forall a b. b -> Either a b
Right a
x

-- | Converts an old peek funtion to a 'Peeker'.
toPeeker :: LuaError e
         => (StackIndex -> LuaE e a)
         -> Peeker e a
toPeeker :: (StackIndex -> LuaE e a) -> Peeker e a
toPeeker StackIndex -> LuaE e a
op StackIndex
idx = LuaE e (Result a) -> Peek e a
forall e a. LuaE e (Result a) -> Peek e a
Peek (LuaE e (Result a) -> Peek e a) -> LuaE e (Result a) -> Peek e a
forall a b. (a -> b) -> a -> b
$ LuaE e a -> LuaE e (Either e a)
forall e a. Exception e => LuaE e a -> LuaE e (Either e a)
try (StackIndex -> LuaE e a
op StackIndex
idx) LuaE e (Either e a)
-> (Either e a -> LuaE e (Result a)) -> LuaE e (Result a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Left e
err  -> Result a -> LuaE e (Result a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result a -> LuaE e (Result a)) -> Result a -> LuaE e (Result a)
forall a b. (a -> b) -> a -> b
$! ByteString -> Result a
forall a. ByteString -> Result a
failure (ByteString -> Result a) -> ByteString -> Result a
forall a b. (a -> b) -> a -> b
$ String -> ByteString
Utf8.fromString (e -> String
forall a. Show a => a -> String
show e
err)
  Right a
res -> Result a -> LuaE e (Result a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result a -> LuaE e (Result a)) -> Result a -> LuaE e (Result a)
forall a b. (a -> b) -> a -> b
$! a -> Result a
forall a. a -> Result a
Success a
res