{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE TypeFamilies #-}

module KDL.Decoder.Internal.Decoder (
  -- * Decoder
  Decoder,

  -- * DecodeArrow
  DecodeArrow (..),
  liftDecodeM,
  withDecoder,
  fail,
  debug,

  -- * DecodeStateM
  DecodeStateM,
  runDecodeStateM,

  -- * DecodeState
  HasDecodeHistory (..),
  DecodeHistory (..),
  DecodeState (..),
) where

import Control.Applicative (
  Alternative (..),
 )
import Control.Arrow (Arrow (..), ArrowChoice (..), (>>>))
import Control.Category (Category)
import Control.Category qualified
import Control.Monad ((>=>))
import Control.Monad.Trans.Class qualified as Trans
import Control.Monad.Trans.State.Strict (StateT)
import Control.Monad.Trans.State.Strict qualified as StateT
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (Text)
import Debug.Trace (traceM)
import KDL.Decoder.Internal.DecodeM
import KDL.Decoder.Schema (
  Schema (..),
  SchemaOf,
  schemaAlt,
  schemaJoin,
 )
import KDL.Types (Identifier, Node, NodeList, Value)
import Prelude hiding (any, fail, null)

class HasDecodeHistory o where
  data DecodeHistory o
  emptyDecodeHistory :: DecodeHistory o

instance HasDecodeHistory NodeList where
  data DecodeHistory NodeList = DecodeHistory_NodeList
    { DecodeHistory NodeList -> Map Text Int
nodesSeen :: Map Text Int
    }
  emptyDecodeHistory :: DecodeHistory NodeList
emptyDecodeHistory = DecodeHistory_NodeList{nodesSeen :: Map Text Int
nodesSeen = Map Text Int
forall k a. Map k a
Map.empty}

instance HasDecodeHistory Node where
  data DecodeHistory Node = DecodeHistory_Node
    { DecodeHistory Node -> Int
argsSeen :: Int
    , DecodeHistory Node -> Set Identifier
propsSeen :: Set Identifier
    , DecodeHistory Node -> DecodeHistory NodeList
childrenHistory :: DecodeHistory NodeList
    }
  emptyDecodeHistory :: DecodeHistory Node
emptyDecodeHistory =
    DecodeHistory_Node
      { argsSeen :: Int
argsSeen = Int
0
      , propsSeen :: Set Identifier
propsSeen = Set Identifier
forall a. Set a
Set.empty
      , childrenHistory :: DecodeHistory NodeList
childrenHistory = DecodeHistory NodeList
forall {k} (o :: k). HasDecodeHistory o => DecodeHistory o
emptyDecodeHistory
      }

instance HasDecodeHistory Value where
  data DecodeHistory Value = DecodeHistory_Value
  emptyDecodeHistory :: DecodeHistory Value
emptyDecodeHistory = DecodeHistory Value
DecodeHistory_Value

-- | The state to track when decoding an object of type @o@.
--
-- At each decode step, some value within @o@ is consumed and
-- the action is recorded in the history.
data DecodeState o = DecodeState
  { forall o. DecodeState o -> o
object :: !o
  , forall o. DecodeState o -> DecodeHistory o
history :: DecodeHistory o
  -- ^ Not strict, since this only matters for reporting errors
  }

type DecodeStateM o a = StateT (DecodeState o) DecodeM a

runDecodeStateM :: o -> DecodeHistory o -> DecodeStateM o a -> DecodeM a
runDecodeStateM :: forall o a. o -> DecodeHistory o -> DecodeStateM o a -> DecodeM a
runDecodeStateM o
o DecodeHistory o
hist DecodeStateM o a
m =
  DecodeStateM o a -> DecodeState o -> DecodeM a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
StateT.evalStateT DecodeStateM o a
m (DecodeState o -> DecodeM a) -> DecodeState o -> DecodeM a
forall a b. (a -> b) -> a -> b
$
    DecodeState
      { object :: o
object = o
o
      , history :: DecodeHistory o
history = DecodeHistory o
hist
      }

-- | @DecodeArrow o a b@ represents an arrow with input @a@ and output @b@, within
-- the context of decoding a KDL object of type @o@. It also knows the expected
-- schema of @o@. Most of the time, @a@ is @()@; it would only be different if
-- you're using Arrows notation.
--
-- We're using arrows here so that we can:
--
--   1. Get the schema without running the decoder, and also
--   2. Use previously decoded values to inform decoding other values
--
-- Using monads alone would lose (1), but applicatives can't do (2).
data DecodeArrow o a b = DecodeArrow
  { forall o a b. DecodeArrow o a b -> SchemaOf o
schema :: SchemaOf o
  , forall o a b. DecodeArrow o a b -> a -> DecodeStateM o b
run :: a -> DecodeStateM o b
  }

instance Category (DecodeArrow o) where
  id :: forall a. DecodeArrow o a a
id = (a -> DecodeM a) -> DecodeArrow o a a
forall a b o. (a -> DecodeM b) -> DecodeArrow o a b
liftDecodeM a -> DecodeM a
forall a. a -> DecodeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  DecodeArrow SchemaOf o
sch2 b -> DecodeStateM o c
bc . :: forall b c a.
DecodeArrow o b c -> DecodeArrow o a b -> DecodeArrow o a c
. DecodeArrow SchemaOf o
sch1 a -> DecodeStateM o b
ab = SchemaOf o -> (a -> DecodeStateM o c) -> DecodeArrow o a c
forall o a b.
SchemaOf o -> (a -> DecodeStateM o b) -> DecodeArrow o a b
DecodeArrow (SchemaOf o
sch1 SchemaOf o -> SchemaOf o -> SchemaOf o
forall a. Schema a -> Schema a -> Schema a
`schemaJoin` SchemaOf o
sch2) ((a -> DecodeStateM o c) -> DecodeArrow o a c)
-> (a -> DecodeStateM o c) -> DecodeArrow o a c
forall a b. (a -> b) -> a -> b
$ a -> DecodeStateM o b
ab (a -> DecodeStateM o b)
-> (b -> DecodeStateM o c) -> a -> DecodeStateM o c
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> b -> DecodeStateM o c
bc
instance Arrow (DecodeArrow o) where
  arr :: forall b c. (b -> c) -> DecodeArrow o b c
arr b -> c
f = (b -> DecodeM c) -> DecodeArrow o b c
forall a b o. (a -> DecodeM b) -> DecodeArrow o a b
liftDecodeM (c -> DecodeM c
forall a. a -> DecodeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (c -> DecodeM c) -> (b -> c) -> b -> DecodeM c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> c
f)
  DecodeArrow SchemaOf o
sch1 b -> DecodeStateM o c
bc *** :: forall b c b' c'.
DecodeArrow o b c
-> DecodeArrow o b' c' -> DecodeArrow o (b, b') (c, c')
*** DecodeArrow SchemaOf o
sch2 b' -> DecodeStateM o c'
bc' =
    SchemaOf o
-> ((b, b') -> DecodeStateM o (c, c'))
-> DecodeArrow o (b, b') (c, c')
forall o a b.
SchemaOf o -> (a -> DecodeStateM o b) -> DecodeArrow o a b
DecodeArrow (SchemaOf o
sch1 SchemaOf o -> SchemaOf o -> SchemaOf o
forall a. Schema a -> Schema a -> Schema a
`schemaJoin` SchemaOf o
sch2) (((b, b') -> DecodeStateM o (c, c'))
 -> DecodeArrow o (b, b') (c, c'))
-> ((b, b') -> DecodeStateM o (c, c'))
-> DecodeArrow o (b, b') (c, c')
forall a b. (a -> b) -> a -> b
$ \(b
b, b'
b') -> (,) (c -> c' -> (c, c'))
-> DecodeStateM o c
-> StateT (DecodeState o) DecodeM (c' -> (c, c'))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> DecodeStateM o c
bc b
b StateT (DecodeState o) DecodeM (c' -> (c, c'))
-> DecodeStateM o c' -> DecodeStateM o (c, c')
forall a b.
StateT (DecodeState o) DecodeM (a -> b)
-> StateT (DecodeState o) DecodeM a
-> StateT (DecodeState o) DecodeM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> b' -> DecodeStateM o c'
bc' b'
b'
instance ArrowChoice (DecodeArrow o) where
  DecodeArrow SchemaOf o
sch1 b -> DecodeStateM o c
bc +++ :: forall b c b' c'.
DecodeArrow o b c
-> DecodeArrow o b' c' -> DecodeArrow o (Either b b') (Either c c')
+++ DecodeArrow SchemaOf o
sch2 b' -> DecodeStateM o c'
bc' =
    SchemaOf o
-> (Either b b' -> DecodeStateM o (Either c c'))
-> DecodeArrow o (Either b b') (Either c c')
forall o a b.
SchemaOf o -> (a -> DecodeStateM o b) -> DecodeArrow o a b
DecodeArrow (SchemaOf o
sch1 SchemaOf o -> SchemaOf o -> SchemaOf o
forall a. Schema a -> Schema a -> Schema a
`schemaAlt` SchemaOf o
sch2) ((Either b b' -> DecodeStateM o (Either c c'))
 -> DecodeArrow o (Either b b') (Either c c'))
-> (Either b b' -> DecodeStateM o (Either c c'))
-> DecodeArrow o (Either b b') (Either c c')
forall a b. (a -> b) -> a -> b
$ (b -> DecodeStateM o (Either c c'))
-> (b' -> DecodeStateM o (Either c c'))
-> Either b b'
-> DecodeStateM o (Either c c')
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((c -> Either c c')
-> DecodeStateM o c -> DecodeStateM o (Either c c')
forall a b.
(a -> b)
-> StateT (DecodeState o) DecodeM a
-> StateT (DecodeState o) DecodeM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> Either c c'
forall a b. a -> Either a b
Left (DecodeStateM o c -> DecodeStateM o (Either c c'))
-> (b -> DecodeStateM o c) -> b -> DecodeStateM o (Either c c')
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> DecodeStateM o c
bc) ((c' -> Either c c')
-> DecodeStateM o c' -> DecodeStateM o (Either c c')
forall a b.
(a -> b)
-> StateT (DecodeState o) DecodeM a
-> StateT (DecodeState o) DecodeM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c' -> Either c c'
forall a b. b -> Either a b
Right (DecodeStateM o c' -> DecodeStateM o (Either c c'))
-> (b' -> DecodeStateM o c') -> b' -> DecodeStateM o (Either c c')
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b' -> DecodeStateM o c'
bc')

instance Functor (DecodeArrow o a) where
  fmap :: forall a b. (a -> b) -> DecodeArrow o a a -> DecodeArrow o a b
fmap a -> b
f (DecodeArrow SchemaOf o
schema a -> DecodeStateM o a
run) = SchemaOf o -> (a -> DecodeStateM o b) -> DecodeArrow o a b
forall o a b.
SchemaOf o -> (a -> DecodeStateM o b) -> DecodeArrow o a b
DecodeArrow SchemaOf o
schema ((a -> DecodeStateM o b) -> DecodeArrow o a b)
-> (a -> DecodeStateM o b) -> DecodeArrow o a b
forall a b. (a -> b) -> a -> b
$ ((a -> b) -> DecodeStateM o a -> DecodeStateM o b
forall a b.
(a -> b)
-> StateT (DecodeState o) DecodeM a
-> StateT (DecodeState o) DecodeM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (DecodeStateM o a -> DecodeStateM o b)
-> (a -> DecodeStateM o a) -> a -> DecodeStateM o b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> DecodeStateM o a
run)
instance Applicative (DecodeArrow o a) where
  pure :: forall a. a -> DecodeArrow o a a
pure = (a -> a) -> DecodeArrow o a a
forall b c. (b -> c) -> DecodeArrow o b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((a -> a) -> DecodeArrow o a a)
-> (a -> a -> a) -> a -> DecodeArrow o a a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a -> a
forall a b. a -> b -> a
const
  DecodeArrow SchemaOf o
sch1 a -> DecodeStateM o (a -> b)
kf <*> :: forall a b.
DecodeArrow o a (a -> b) -> DecodeArrow o a a -> DecodeArrow o a b
<*> DecodeArrow SchemaOf o
sch2 a -> DecodeStateM o a
kx =
    SchemaOf o -> (a -> DecodeStateM o b) -> DecodeArrow o a b
forall o a b.
SchemaOf o -> (a -> DecodeStateM o b) -> DecodeArrow o a b
DecodeArrow (SchemaOf o
sch1 SchemaOf o -> SchemaOf o -> SchemaOf o
forall a. Schema a -> Schema a -> Schema a
`schemaJoin` SchemaOf o
sch2) ((a -> DecodeStateM o b) -> DecodeArrow o a b)
-> (a -> DecodeStateM o b) -> DecodeArrow o a b
forall a b. (a -> b) -> a -> b
$ \a
a -> a -> DecodeStateM o (a -> b)
kf a
a DecodeStateM o (a -> b) -> DecodeStateM o a -> DecodeStateM o b
forall a b.
StateT (DecodeState o) DecodeM (a -> b)
-> StateT (DecodeState o) DecodeM a
-> StateT (DecodeState o) DecodeM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> DecodeStateM o a
kx a
a
instance Alternative (DecodeArrow o a) where
  -- Can't use StateT's Alternative instance: https://hub.darcs.net/ross/transformers/issue/78
  empty :: forall a. DecodeArrow o a a
empty = SchemaOf o -> (a -> DecodeStateM o a) -> DecodeArrow o a a
forall o a b.
SchemaOf o -> (a -> DecodeStateM o b) -> DecodeArrow o a b
DecodeArrow ([SchemaOf o] -> SchemaOf o
forall a. [Schema a] -> Schema a
SchemaOr []) ((a -> DecodeStateM o a) -> DecodeArrow o a a)
-> (a -> DecodeStateM o a) -> DecodeArrow o a a
forall a b. (a -> b) -> a -> b
$ \a
_ -> DecodeM a -> DecodeStateM o a
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (DecodeState o) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift DecodeM a
forall a. DecodeM a
forall (f :: * -> *) a. Alternative f => f a
empty
  DecodeArrow SchemaOf o
sch1 a -> DecodeStateM o a
run1 <|> :: forall a.
DecodeArrow o a a -> DecodeArrow o a a -> DecodeArrow o a a
<|> DecodeArrow SchemaOf o
sch2 a -> DecodeStateM o a
run2 =
    SchemaOf o -> (a -> DecodeStateM o a) -> DecodeArrow o a a
forall o a b.
SchemaOf o -> (a -> DecodeStateM o b) -> DecodeArrow o a b
DecodeArrow (SchemaOf o
sch1 SchemaOf o -> SchemaOf o -> SchemaOf o
forall a. Schema a -> Schema a -> Schema a
`schemaAlt` SchemaOf o
sch2) ((a -> DecodeStateM o a) -> DecodeArrow o a a)
-> (a -> DecodeStateM o a) -> DecodeArrow o a a
forall a b. (a -> b) -> a -> b
$ \a
a -> (DecodeState o -> DecodeM (a, DecodeState o)) -> DecodeStateM o a
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT.StateT ((DecodeState o -> DecodeM (a, DecodeState o)) -> DecodeStateM o a)
-> (DecodeState o -> DecodeM (a, DecodeState o))
-> DecodeStateM o a
forall a b. (a -> b) -> a -> b
$ \DecodeState o
s -> do
      DecodeStateM o a -> DecodeState o -> DecodeM (a, DecodeState o)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
StateT.runStateT (a -> DecodeStateM o a
run1 a
a) DecodeState o
s DecodeM (a, DecodeState o)
-> DecodeM (a, DecodeState o) -> DecodeM (a, DecodeState o)
forall a. DecodeM a -> DecodeM a -> DecodeM a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> DecodeStateM o a -> DecodeState o -> DecodeM (a, DecodeState o)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
StateT.runStateT (a -> DecodeStateM o a
run2 a
a) DecodeState o
s
  some :: forall a. DecodeArrow o a a -> DecodeArrow o a [a]
some (DecodeArrow SchemaOf o
sch a -> DecodeStateM o a
run) =
    SchemaOf o -> (a -> DecodeStateM o [a]) -> DecodeArrow o a [a]
forall o a b.
SchemaOf o -> (a -> DecodeStateM o b) -> DecodeArrow o a b
DecodeArrow (SchemaOf o -> SchemaOf o
forall a. Schema a -> Schema a
SchemaSome SchemaOf o
sch) ((a -> DecodeStateM o [a]) -> DecodeArrow o a [a])
-> (a -> DecodeStateM o [a]) -> DecodeArrow o a [a]
forall a b. (a -> b) -> a -> b
$ \a
a ->
      (DecodeState o -> DecodeM ([a], DecodeState o))
-> DecodeStateM o [a]
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT.StateT ((DecodeState o -> DecodeM ([a], DecodeState o))
 -> DecodeStateM o [a])
-> (DecodeState o -> DecodeM ([a], DecodeState o))
-> DecodeStateM o [a]
forall a b. (a -> b) -> a -> b
$
        let go :: DecodeState o -> DecodeM ([a], DecodeState o)
go DecodeState o
s0 = do
              (a
x, DecodeState o
s1) <- DecodeStateM o a -> DecodeState o -> DecodeM (a, DecodeState o)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
StateT.runStateT (a -> DecodeStateM o a
run a
a) DecodeState o
s0
              ([a]
xs, DecodeState o
s2) <- DecodeState o -> DecodeM ([a], DecodeState o)
go DecodeState o
s1 DecodeM ([a], DecodeState o)
-> DecodeM ([a], DecodeState o) -> DecodeM ([a], DecodeState o)
forall a. DecodeM a -> DecodeM a -> DecodeM a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ([a], DecodeState o) -> DecodeM ([a], DecodeState o)
forall a. a -> DecodeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], DecodeState o
s1)
              ([a], DecodeState o) -> DecodeM ([a], DecodeState o)
forall a. a -> DecodeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs, DecodeState o
s2)
         in DecodeState o -> DecodeM ([a], DecodeState o)
go
  many :: forall a. DecodeArrow o a a -> DecodeArrow o a [a]
many (DecodeArrow SchemaOf o
sch a -> DecodeStateM o a
run) = DecodeArrow o a a -> DecodeArrow o a [a]
forall a. DecodeArrow o a a -> DecodeArrow o a [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (SchemaOf o -> (a -> DecodeStateM o a) -> DecodeArrow o a a
forall o a b.
SchemaOf o -> (a -> DecodeStateM o b) -> DecodeArrow o a b
DecodeArrow SchemaOf o
sch a -> DecodeStateM o a
run) DecodeArrow o a [a] -> DecodeArrow o a [a] -> DecodeArrow o a [a]
forall a.
DecodeArrow o a a -> DecodeArrow o a a -> DecodeArrow o a a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [a] -> DecodeArrow o a [a]
forall a. a -> DecodeArrow o a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

-- | Eliminates all schema information; avoid whenever possible.
instance Monad (DecodeArrow o a) where
  return :: forall a. a -> DecodeArrow o a a
return = a -> DecodeArrow o a a
forall a. a -> DecodeArrow o a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  DecodeArrow SchemaOf o
_ a -> DecodeStateM o a
run1 >>= :: forall a b.
DecodeArrow o a a -> (a -> DecodeArrow o a b) -> DecodeArrow o a b
>>= a -> DecodeArrow o a b
k =
    SchemaOf o -> (a -> DecodeStateM o b) -> DecodeArrow o a b
forall o a b.
SchemaOf o -> (a -> DecodeStateM o b) -> DecodeArrow o a b
DecodeArrow SchemaOf o
forall a. Schema a
SchemaUnknown ((a -> DecodeStateM o b) -> DecodeArrow o a b)
-> (a -> DecodeStateM o b) -> DecodeArrow o a b
forall a b. (a -> b) -> a -> b
$ \a
a -> do
      a
x <- a -> DecodeStateM o a
run1 a
a
      let DecodeArrow SchemaOf o
_ a -> DecodeStateM o b
run2 = a -> DecodeArrow o a b
k a
x
      a -> DecodeStateM o b
run2 a
a

type Decoder o a = DecodeArrow o () a

liftDecodeM :: (a -> DecodeM b) -> DecodeArrow o a b
liftDecodeM :: forall a b o. (a -> DecodeM b) -> DecodeArrow o a b
liftDecodeM a -> DecodeM b
f = SchemaOf o -> (a -> DecodeStateM o b) -> DecodeArrow o a b
forall o a b.
SchemaOf o -> (a -> DecodeStateM o b) -> DecodeArrow o a b
DecodeArrow ([SchemaOf o] -> SchemaOf o
forall a. [Schema a] -> Schema a
SchemaAnd []) (DecodeM b -> DecodeStateM o b
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (DecodeState o) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (DecodeM b -> DecodeStateM o b)
-> (a -> DecodeM b) -> a -> DecodeStateM o b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> DecodeM b
f)

-- | Run actions within a t'DecodeArrow'. Useful for adding post-processing logic.
--
-- === __Example__
--
-- @
-- decoder = KDL.withDecoder KDL.number $ \\x -> do
--   when (x > 100)
--     KDL.failM $ "argument is too large: " <> (Text.pack . show) x
--   pure $ MyVal x
-- @
withDecoder :: forall o a b c. DecodeArrow o a b -> (b -> DecodeM c) -> DecodeArrow o a c
withDecoder :: forall o a b c.
DecodeArrow o a b -> (b -> DecodeM c) -> DecodeArrow o a c
withDecoder DecodeArrow o a b
decoder b -> DecodeM c
f = DecodeArrow o a b
decoder DecodeArrow o a b -> DecodeArrow o b c -> DecodeArrow o a c
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (b -> DecodeM c) -> DecodeArrow o b c
forall a b o. (a -> DecodeM b) -> DecodeArrow o a b
liftDecodeM b -> DecodeM c
f

-- | Unconditionally fail the decoder.
--
-- === __Example__
--
-- @
-- decoder = proc () -> do
--   x <- KDL.arg -< ()
--   if x > 100
--     then KDL.fail -\< "argument is too large: " <> (Text.pack . show) x
--     else returnA -< ()
--   returnA -< x
-- @
fail :: forall b o. DecodeArrow o Text b
fail :: forall b o. DecodeArrow o Text b
fail = SchemaOf o -> (Text -> DecodeStateM o b) -> DecodeArrow o Text b
forall o a b.
SchemaOf o -> (a -> DecodeStateM o b) -> DecodeArrow o a b
DecodeArrow ([SchemaOf o] -> SchemaOf o
forall a. [Schema a] -> Schema a
SchemaOr []) (DecodeM b -> DecodeStateM o b
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (DecodeState o) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (DecodeM b -> DecodeStateM o b)
-> (Text -> DecodeM b) -> Text -> DecodeStateM o b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> DecodeM b
forall a. Text -> DecodeM a
failM)

-- | Debug the current state of the object being decoded.
--
-- === __Example__
--
-- @
-- decoder = proc () -> do
--   KDL.debug -< ()    -- Node{entries = [Entry{}, Entry{}]}
--   x <- KDL.arg -< ()
--   KDL.debug -< ()    -- Node{entries = [Entry{}]}
--   y <- KDL.arg -< ()
--   KDL.debug -< ()    -- Node{entries = []}
--   returnA -< (x, y)
-- @
debug :: forall o a. (Show o) => DecodeArrow o a ()
debug :: forall o a. Show o => DecodeArrow o a ()
debug =
  SchemaOf o -> (a -> DecodeStateM o ()) -> DecodeArrow o a ()
forall o a b.
SchemaOf o -> (a -> DecodeStateM o b) -> DecodeArrow o a b
DecodeArrow ([SchemaOf o] -> SchemaOf o
forall a. [Schema a] -> Schema a
SchemaAnd []) ((a -> DecodeStateM o ()) -> DecodeArrow o a ())
-> (a -> DecodeStateM o ()) -> DecodeArrow o a ()
forall a b. (a -> b) -> a -> b
$ \a
_ -> do
    o
o <- (DecodeState o -> o) -> StateT (DecodeState o) DecodeM o
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
StateT.gets (.object)
    String -> DecodeStateM o ()
forall (f :: * -> *). Applicative f => String -> f ()
traceM (String -> DecodeStateM o ()) -> String -> DecodeStateM o ()
forall a b. (a -> b) -> a -> b
$ String
"[kdl-hs] DEBUG: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ o -> String
forall a. Show a => a -> String
show o
o