{-# LANGUAGE Arrows #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}

module KDL.Decoder.Arrow (
  decodeWith,
  decodeFileWith,
  decodeDocWith,

  -- * Decoder
  Decoder,
  liftDecodeM,
  fail,
  withDecoder,
  debug,

  -- ** DecodeM
  DecodeM,
  runDecodeM,
  decodeThrow,
  failM,

  -- ** Decode errors
  module KDL.Decoder.Internal.Error,

  -- * Document
  DocumentDecoder (..),
  document,
  documentSchema,

  -- * NodeList
  NodeListDecoder,
  NodeListDecodeArrow,
  node,
  remainingNodes,
  argAt,
  argsAt,
  dashChildrenAt,
  dashNodesAt,

  -- ** Explicitly specify decoders
  nodeWith,
  remainingNodesWith,
  argAtWith,
  argsAtWith,
  dashChildrenAtWith,
  dashNodesAtWith,

  -- ** Explicitly specify decoders and type annotations
  nodeWith',
  remainingNodesWith',
  argAtWith',
  argsAtWith',
  dashChildrenAtWith',

  -- * Node
  NodeDecoder,
  NodeDecodeArrow,
  DecodeNode (..),
  arg,
  prop,
  remainingProps,
  children,

  -- ** Explicitly specify decoders
  argWith,
  propWith,
  remainingPropsWith,

  -- ** Explicitly specify decoders and type annotations
  argWith',
  propWith',
  remainingPropsWith',

  -- * Value
  ValueDecoder,
  ValueDecodeArrow,
  DecodeValue (..),
  any,
  string,
  number,
  bool,
  null,

  -- * Combinators
  oneOf,
  many,
  optional,
  option,
  some,
) where

import Control.Applicative (
  Alternative (..),
  optional,
 )
import Control.Monad (unless, when)
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.Bifunctor (first)
import Data.Bits (finiteBitSize)
import Data.Int (Int64)
import Data.List (partition)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (fromMaybe, isNothing)
import Data.Proxy (Proxy (..))
import Data.Scientific (Scientific)
import Data.Scientific qualified as Scientific
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Typeable (Typeable, typeRep)
import Data.Word (Word16, Word32, Word64, Word8)
import GHC.Int (Int16, Int32, Int8)
import KDL.Decoder.Internal.DecodeM
import KDL.Decoder.Internal.Decoder
import KDL.Decoder.Internal.Error
import KDL.Decoder.Schema (
  Schema (..),
  SchemaItem (..),
  SchemaOf,
  TypedNodeSchema (..),
  TypedValueSchema (..),
 )
import KDL.Parser (parse, parseFile)
import KDL.Types (
  Ann (..),
  Document,
  Entry (..),
  Identifier (..),
  Node (..),
  NodeList (..),
  Value (..),
  ValueData (..),
  def,
 )
import Numeric.Natural (Natural)
import Prelude hiding (any, fail, null)
import Prelude qualified

-- | Decode the given KDL configuration with the given decoder.
decodeWith :: DocumentDecoder a -> Text -> Either DecodeError a
decodeWith :: forall a. DocumentDecoder a -> Text -> Either DecodeError a
decodeWith DocumentDecoder a
decoder = DocumentDecoder a
-> Maybe FilePath -> Either Text NodeList -> Either DecodeError a
forall a.
DocumentDecoder a
-> Maybe FilePath -> Either Text NodeList -> Either DecodeError a
decodeFromParseResult DocumentDecoder a
decoder Maybe FilePath
forall a. Maybe a
Nothing (Either Text NodeList -> Either DecodeError a)
-> (Text -> Either Text NodeList) -> Text -> Either DecodeError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text NodeList
parse

-- | Read KDL configuration from the given file path and decode it with the given decoder.
decodeFileWith :: DocumentDecoder a -> FilePath -> IO (Either DecodeError a)
decodeFileWith :: forall a.
DocumentDecoder a -> FilePath -> IO (Either DecodeError a)
decodeFileWith DocumentDecoder a
decoder FilePath
fp = DocumentDecoder a
-> Maybe FilePath -> Either Text NodeList -> Either DecodeError a
forall a.
DocumentDecoder a
-> Maybe FilePath -> Either Text NodeList -> Either DecodeError a
decodeFromParseResult DocumentDecoder a
decoder (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
fp) (Either Text NodeList -> Either DecodeError a)
-> IO (Either Text NodeList) -> IO (Either DecodeError a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Either Text NodeList)
parseFile FilePath
fp

-- | Decode an already-parsed 'Document' with the given decoder.
decodeDocWith :: DocumentDecoder a -> Document -> Either DecodeError a
decodeDocWith :: forall a. DocumentDecoder a -> NodeList -> Either DecodeError a
decodeDocWith (UnsafeDocumentDecoder NodeListDecoder a
decoder) NodeList
doc =
  DecodeM a -> Either DecodeError a
forall a. DecodeM a -> Either DecodeError a
runDecodeM (DecodeM a -> Either DecodeError a)
-> (DecodeStateM NodeList a -> DecodeM a)
-> DecodeStateM NodeList a
-> Either DecodeError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeList
-> DecodeHistory NodeList -> DecodeStateM NodeList a -> DecodeM a
forall o a. o -> DecodeHistory o -> DecodeStateM o a -> DecodeM a
runDecodeStateM NodeList
doc DecodeHistory NodeList
forall {k} (o :: k). HasDecodeHistory o => DecodeHistory o
emptyDecodeHistory (DecodeStateM NodeList a -> Either DecodeError a)
-> DecodeStateM NodeList a -> Either DecodeError a
forall a b. (a -> b) -> a -> b
$
    NodeListDecoder a
decoder.run ()

decodeFromParseResult ::
  DocumentDecoder a ->
  Maybe FilePath ->
  Either Text Document ->
  Either DecodeError a
decodeFromParseResult :: forall a.
DocumentDecoder a
-> Maybe FilePath -> Either Text NodeList -> Either DecodeError a
decodeFromParseResult DocumentDecoder a
decoder Maybe FilePath
mPath =
  (DecodeError -> DecodeError)
-> Either DecodeError a -> Either DecodeError a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (\DecodeError
e -> DecodeError
e{filepath = mPath}) (Either DecodeError a -> Either DecodeError a)
-> (Either Text NodeList -> Either DecodeError a)
-> Either Text NodeList
-> Either DecodeError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
    Left Text
e -> DecodeM a -> Either DecodeError a
forall a. DecodeM a -> Either DecodeError a
runDecodeM (DecodeM a -> Either DecodeError a)
-> (DecodeErrorKind -> DecodeM a)
-> DecodeErrorKind
-> Either DecodeError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecodeErrorKind -> DecodeM a
forall a. DecodeErrorKind -> DecodeM a
decodeThrow (DecodeErrorKind -> Either DecodeError a)
-> DecodeErrorKind -> Either DecodeError a
forall a b. (a -> b) -> a -> b
$ Text -> DecodeErrorKind
DecodeError_ParseError Text
e
    Right NodeList
doc -> DocumentDecoder a -> NodeList -> Either DecodeError a
forall a. DocumentDecoder a -> NodeList -> Either DecodeError a
decodeDocWith DocumentDecoder a
decoder NodeList
doc

{----- Decoder -----}

{----- Decoding Document -----}

newtype DocumentDecoder a = UnsafeDocumentDecoder (NodeListDecoder a)

-- | Finalize a 'NodeListDecoder' as a 'DocumentDecoder' to use with 'decodeWith'.
--
-- Ensures that all nodes have been decoded (e.g. error if the user specified
-- unrecognized nodes, or misspelled a node name). To allow unrecognized nodes,
-- use @remainingNodes \@Node@ and ignore the result.
document :: NodeListDecoder a -> DocumentDecoder a
document :: forall a. NodeListDecoder a -> DocumentDecoder a
document NodeListDecoder a
decoder =
  NodeListDecoder a -> DocumentDecoder a
forall a. NodeListDecoder a -> DocumentDecoder a
UnsafeDocumentDecoder
    NodeListDecoder a
decoder
      { run = \() -> do
          a
a <- NodeListDecoder a
decoder.run ()
          StateT (DecodeState NodeList) DecodeM ()
validateNodeList
          a -> StateT (DecodeState NodeList) DecodeM a
forall a. a -> StateT (DecodeState NodeList) DecodeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
      }

-- | Get the schema of a 'DocumentDecoder'.
--
-- The schema is statically determined without running the decoder.
documentSchema :: DocumentDecoder a -> SchemaOf NodeList
documentSchema :: forall a. DocumentDecoder a -> SchemaOf NodeList
documentSchema (UnsafeDocumentDecoder NodeListDecoder a
decoder) = NodeListDecoder a
decoder.schema

{----- Decoding NodeList -----}

type NodeListDecoder a = NodeListDecodeArrow () a
type NodeListDecodeArrow a b = DecodeArrow NodeList a b

getNodeIndex :: Text -> DecodeState NodeList -> Int
getNodeIndex :: Text -> DecodeState NodeList -> Int
getNodeIndex Text
name = Int -> Text -> Map Text Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Int
0 Text
name (Map Text Int -> Int)
-> (DecodeState NodeList -> Map Text Int)
-> DecodeState NodeList
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.history.nodesSeen)

validateNodeList :: StateT (DecodeState NodeList) DecodeM ()
validateNodeList :: StateT (DecodeState NodeList) DecodeM ()
validateNodeList = do
  NodeList
nodeList <- (DecodeState NodeList -> NodeList)
-> StateT (DecodeState NodeList) DecodeM NodeList
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
StateT.gets (.object)
  case NodeList
nodeList.nodes of
    [] -> () -> StateT (DecodeState NodeList) DecodeM ()
forall a. a -> StateT (DecodeState NodeList) DecodeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Node
node_ : [Node]
_ -> do
      let identifier :: Identifier
identifier = Node
node_.name
      Int
index <- (DecodeState NodeList -> Int)
-> StateT (DecodeState NodeList) DecodeM Int
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
StateT.gets (Text -> DecodeState NodeList -> Int
getNodeIndex Identifier
identifier.value)
      DecodeM () -> StateT (DecodeState NodeList) DecodeM ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (DecodeState NodeList) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (DecodeM () -> StateT (DecodeState NodeList) DecodeM ())
-> (DecodeErrorKind -> DecodeM ())
-> DecodeErrorKind
-> StateT (DecodeState NodeList) DecodeM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecodeErrorKind -> DecodeM ()
forall a. DecodeErrorKind -> DecodeM a
decodeThrow (DecodeErrorKind -> StateT (DecodeState NodeList) DecodeM ())
-> DecodeErrorKind -> StateT (DecodeState NodeList) DecodeM ()
forall a b. (a -> b) -> a -> b
$
        DecodeError_UnexpectedNode
          { identifier :: Identifier
identifier = Identifier
identifier
          , index :: Int
index = Int
index
          }

-- | Decode a node with the given name using a 'DecodeNode' instance.
--
-- Ensures that the node has been fully decoded (e.g. error if the user specified
-- extra args, misspelled a prop name, or provided extraneous children nodes).
-- To allow extra values, use the following functions to parse and ignore them:
--
-- @
-- KDL.many $ KDL.arg \@Value
-- KDL.remainingProps \@Value
-- KDL.children $ KDL.remainingNodes \@Node
-- @
--
-- === __Example__
--
-- @
-- instance KDL.DecodeNode Person where
--   nodeDecoder = proc () -> do
--     name <- KDL.arg -< ()
--     returnA -< Person{..}
--
-- let
--   config =
--     """
--     person \"Alice"
--     person \"Bob"
--     """
--   decoder = KDL.document $ proc () -> do
--     many $ KDL.node "person" -< ()
-- KDL.decodeWith decoder config == Right [\"Alice", \"Bob"]
-- @
node :: (DecodeNode a) => Text -> NodeListDecoder a
node :: forall a. DecodeNode a => Text -> NodeListDecoder a
node Text
name = ([Text] -> NodeDecoder a -> NodeListDecoder a) -> NodeListDecoder a
forall a r. DecodeNode a => ([Text] -> NodeDecoder a -> r) -> r
withDecodeNode (([Text] -> NodeDecoder a -> NodeListDecoder a)
 -> NodeListDecoder a)
-> ([Text] -> NodeDecoder a -> NodeListDecoder a)
-> NodeListDecoder a
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> NodeDecoder a -> NodeListDecoder a
forall a b.
Typeable b =>
Text -> [Text] -> NodeDecodeArrow a b -> NodeListDecodeArrow a b
nodeWith' Text
name

-- | Same as 'node', except explicitly specify the 'NodeDecoder' instead of using 'DecodeNode'.
--
-- === __Example__
--
-- @
-- let
--   config =
--     """
--     person \"Alice"
--     person \"Bob"
--     """
--   decoder = KDL.document $ proc () -> do
--     many . KDL.nodeWith "person" $ KDL.arg -< ()
-- KDL.decodeWith decoder config == Right [\"Alice", \"Bob"]
-- @
nodeWith :: forall a b. (Typeable b) => Text -> NodeDecodeArrow a b -> NodeListDecodeArrow a b
nodeWith :: forall a b.
Typeable b =>
Text -> NodeDecodeArrow a b -> NodeListDecodeArrow a b
nodeWith Text
name = Text -> [Text] -> NodeDecodeArrow a b -> NodeListDecodeArrow a b
forall a b.
Typeable b =>
Text -> [Text] -> NodeDecodeArrow a b -> NodeListDecodeArrow a b
nodeWith' Text
name []

-- | Same as 'nodeWith', except allow specifying type annotations.
nodeWith' :: forall a b. (Typeable b) => Text -> [Text] -> NodeDecodeArrow a b -> NodeListDecodeArrow a b
nodeWith' :: forall a b.
Typeable b =>
Text -> [Text] -> NodeDecodeArrow a b -> NodeListDecodeArrow a b
nodeWith' Text
name =
  (TypedNodeSchema
 -> (a -> Node -> DecodeM b) -> NodeListDecodeArrow a b)
-> [Text] -> NodeDecodeArrow a b -> NodeListDecodeArrow a b
forall a b r.
Typeable b =>
(TypedNodeSchema -> (a -> Node -> DecodeM b) -> r)
-> [Text] -> NodeDecodeArrow a b -> r
withTypedNodeDecoder ((TypedNodeSchema
  -> (a -> Node -> DecodeM b) -> NodeListDecodeArrow a b)
 -> [Text] -> NodeDecodeArrow a b -> NodeListDecodeArrow a b)
-> (TypedNodeSchema
    -> (a -> Node -> DecodeM b) -> NodeListDecodeArrow a b)
-> [Text]
-> NodeDecodeArrow a b
-> NodeListDecodeArrow a b
forall a b. (a -> b) -> a -> b
$ \TypedNodeSchema
schema a -> Node -> DecodeM b
decodeNode ->
    SchemaOf NodeList
-> (a -> DecodeStateM NodeList b) -> NodeListDecodeArrow a b
forall o a b.
SchemaOf o -> (a -> DecodeStateM o b) -> DecodeArrow o a b
DecodeArrow (SchemaItem NodeList -> SchemaOf NodeList
forall a. a -> Schema a
SchemaOne (SchemaItem NodeList -> SchemaOf NodeList)
-> SchemaItem NodeList -> SchemaOf NodeList
forall a b. (a -> b) -> a -> b
$ Text -> TypedNodeSchema -> SchemaItem NodeList
NodeNamed Text
name TypedNodeSchema
schema) ((a -> DecodeStateM NodeList b) -> NodeListDecodeArrow a b)
-> (a -> DecodeStateM NodeList b) -> NodeListDecodeArrow a b
forall a b. (a -> b) -> a -> b
$ \a
a -> do
      (Node -> Bool)
-> (Node -> DecodeM b)
-> StateT (DecodeState NodeList) DecodeM (Maybe (Node, b))
forall a.
(Node -> Bool)
-> (Node -> DecodeM a)
-> StateT (DecodeState NodeList) DecodeM (Maybe (Node, a))
decodeFirstNodeWhere ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name) (Text -> Bool) -> (Node -> Text) -> Node -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.name.value)) (a -> Node -> DecodeM b
decodeNode a
a) StateT (DecodeState NodeList) DecodeM (Maybe (Node, b))
-> (Maybe (Node, b) -> DecodeStateM NodeList b)
-> DecodeStateM NodeList b
forall a b.
StateT (DecodeState NodeList) DecodeM a
-> (a -> StateT (DecodeState NodeList) DecodeM b)
-> StateT (DecodeState NodeList) DecodeM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just (Node
_, b
b) -> b -> DecodeStateM NodeList b
forall a. a -> StateT (DecodeState NodeList) DecodeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b
        Maybe (Node, b)
Nothing -> do
          Int
index <- (DecodeState NodeList -> Int)
-> StateT (DecodeState NodeList) DecodeM Int
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
StateT.gets (Text -> DecodeState NodeList -> Int
getNodeIndex Text
name)
          DecodeM b -> DecodeStateM NodeList b
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (DecodeState NodeList) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (DecodeM b -> DecodeStateM NodeList b)
-> DecodeM b -> DecodeStateM NodeList b
forall a b. (a -> b) -> a -> b
$ DecodeErrorKind -> DecodeM b
forall a. DecodeErrorKind -> DecodeM a
decodeThrow DecodeError_ExpectedNode{name :: Text
name = Text
name, index :: Int
index = Int
index}

decodeFirstNodeWhere ::
  (Node -> Bool) ->
  (Node -> DecodeM a) ->
  StateT (DecodeState NodeList) DecodeM (Maybe (Node, a))
decodeFirstNodeWhere :: forall a.
(Node -> Bool)
-> (Node -> DecodeM a)
-> StateT (DecodeState NodeList) DecodeM (Maybe (Node, a))
decodeFirstNodeWhere Node -> Bool
matcher Node -> DecodeM a
decodeNode = do
  [Node]
nodes <- (DecodeState NodeList -> [Node])
-> StateT (DecodeState NodeList) DecodeM [Node]
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
StateT.gets (.object.nodes)
  case (Node -> Bool) -> [Node] -> Maybe (Node, [Node])
forall a. (a -> Bool) -> [a] -> Maybe (a, [a])
extractFirst Node -> Bool
matcher [Node]
nodes of
    Maybe (Node, [Node])
Nothing -> do
      Maybe (Node, a)
-> StateT (DecodeState NodeList) DecodeM (Maybe (Node, a))
forall a. a -> StateT (DecodeState NodeList) DecodeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Node, a)
forall a. Maybe a
Nothing
    Just (Node
node_, [Node]
nodes') -> do
      let name :: Identifier
name = Node
node_.name
      Int
index <- (DecodeState NodeList -> Int)
-> StateT (DecodeState NodeList) DecodeM Int
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
StateT.gets (Text -> DecodeState NodeList -> Int
getNodeIndex Identifier
name.value)
      (DecodeState NodeList -> DecodeState NodeList)
-> StateT (DecodeState NodeList) DecodeM ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
StateT.modify ((DecodeState NodeList -> DecodeState NodeList)
 -> StateT (DecodeState NodeList) DecodeM ())
-> (DecodeState NodeList -> DecodeState NodeList)
-> StateT (DecodeState NodeList) DecodeM ()
forall a b. (a -> b) -> a -> b
$ \DecodeState NodeList
s -> DecodeState NodeList
s{object = s.object{nodes = nodes'}}
      a
b <-
        DecodeM a -> StateT (DecodeState NodeList) DecodeM a
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (DecodeState NodeList) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (DecodeM a -> StateT (DecodeState NodeList) DecodeM a)
-> (DecodeM a -> DecodeM a)
-> DecodeM a
-> StateT (DecodeState NodeList) DecodeM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContextItem -> DecodeM a -> DecodeM a
forall a. ContextItem -> DecodeM a -> DecodeM a
addContext ContextNode{name :: Identifier
name = Identifier
name, index :: Int
index = Int
index} (DecodeM a -> StateT (DecodeState NodeList) DecodeM a)
-> DecodeM a -> StateT (DecodeState NodeList) DecodeM a
forall a b. (a -> b) -> a -> b
$
          Node -> DecodeM a
decodeNode Node
node_
      (DecodeState NodeList -> DecodeState NodeList)
-> StateT (DecodeState NodeList) DecodeM ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
StateT.modify ((DecodeState NodeList -> DecodeState NodeList)
 -> StateT (DecodeState NodeList) DecodeM ())
-> (DecodeState NodeList -> DecodeState NodeList)
-> StateT (DecodeState NodeList) DecodeM ()
forall a b. (a -> b) -> a -> b
$ \DecodeState NodeList
s -> DecodeState NodeList
s{history = s.history{nodesSeen = inc name.value s.history.nodesSeen}}
      Maybe (Node, a)
-> StateT (DecodeState NodeList) DecodeM (Maybe (Node, a))
forall a. a -> StateT (DecodeState NodeList) DecodeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Node, a)
 -> StateT (DecodeState NodeList) DecodeM (Maybe (Node, a)))
-> Maybe (Node, a)
-> StateT (DecodeState NodeList) DecodeM (Maybe (Node, a))
forall a b. (a -> b) -> a -> b
$ (Node, a) -> Maybe (Node, a)
forall a. a -> Maybe a
Just (Node
node_, a
b)
 where
  inc :: k -> Map k a -> Map k a
inc k
k = (a -> a -> a) -> k -> a -> Map k a -> Map k a
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith a -> a -> a
forall a. Num a => a -> a -> a
(+) k
k a
1

-- | Decode all remaining nodes.
--
-- === __Example__
--
-- @
-- instance KDL.DecodeNode MyArg where
--   nodeDecoder = proc () -> do
--     name <- KDL.arg -< ()
--     returnA -< MyArg{..}
--
-- let
--   config =
--     """
--     build "pkg1"
--     build "pkg2"
--     lint "pkg1"
--     """
--   decoder = KDL.document $ proc () -> do
--     KDL.remainingNodes -< ()
-- KDL.decodeWith decoder config == (Right . Map.fromList) [("build", [MyArg "pkg1", MyArg "pkg2"]), ("lint", [MyArg "pkg1"])]
-- @
remainingNodes :: (DecodeNode a) => NodeListDecoder (Map Text [a])
remainingNodes :: forall a. DecodeNode a => NodeListDecoder (Map Text [a])
remainingNodes = ([Text] -> NodeDecoder a -> NodeListDecoder (Map Text [a]))
-> NodeListDecoder (Map Text [a])
forall a r. DecodeNode a => ([Text] -> NodeDecoder a -> r) -> r
withDecodeNode [Text] -> NodeDecoder a -> NodeListDecoder (Map Text [a])
forall a b.
Typeable b =>
[Text]
-> NodeDecodeArrow a b -> NodeListDecodeArrow a (Map Text [b])
remainingNodesWith'

-- | Same as 'remainingNodes', except explicitly specify the 'NodeDecoder' instead of using 'DecodeNode'
--
-- === __Example__
--
-- @
-- let
--   config =
--     """
--     build "pkg1"
--     build "pkg2"
--     lint "pkg1"
--     """
--   decoder = KDL.document $ proc () -> do
--     KDL.remainingNodesWith $ KDL.arg -< ()
-- KDL.decodeWith decoder config == (Right . Map.fromList) [("build", ["pkg1", "pkg2"]), ("lint", ["pkg1"])]
-- @
remainingNodesWith :: forall a b. (Typeable b) => NodeDecodeArrow a b -> NodeListDecodeArrow a (Map Text [b])
-- TODO: Detect duplicate `remainingNodes` calls and fail to build a decoder
remainingNodesWith :: forall a b.
Typeable b =>
NodeDecodeArrow a b -> NodeListDecodeArrow a (Map Text [b])
remainingNodesWith = [Text]
-> NodeDecodeArrow a b -> NodeListDecodeArrow a (Map Text [b])
forall a b.
Typeable b =>
[Text]
-> NodeDecodeArrow a b -> NodeListDecodeArrow a (Map Text [b])
remainingNodesWith' []

-- | Same as 'remainingNodesWith', except allow specifying type annotations.
remainingNodesWith' :: forall a b. (Typeable b) => [Text] -> NodeDecodeArrow a b -> NodeListDecodeArrow a (Map Text [b])
-- TODO: Detect duplicate `remainingNodes` calls and fail to build a decoder
remainingNodesWith' :: forall a b.
Typeable b =>
[Text]
-> NodeDecodeArrow a b -> NodeListDecodeArrow a (Map Text [b])
remainingNodesWith' =
  (TypedNodeSchema
 -> (a -> Node -> DecodeM b)
 -> NodeListDecodeArrow a (Map Text [b]))
-> [Text]
-> NodeDecodeArrow a b
-> NodeListDecodeArrow a (Map Text [b])
forall a b r.
Typeable b =>
(TypedNodeSchema -> (a -> Node -> DecodeM b) -> r)
-> [Text] -> NodeDecodeArrow a b -> r
withTypedNodeDecoder ((TypedNodeSchema
  -> (a -> Node -> DecodeM b)
  -> NodeListDecodeArrow a (Map Text [b]))
 -> [Text]
 -> NodeDecodeArrow a b
 -> NodeListDecodeArrow a (Map Text [b]))
-> (TypedNodeSchema
    -> (a -> Node -> DecodeM b)
    -> NodeListDecodeArrow a (Map Text [b]))
-> [Text]
-> NodeDecodeArrow a b
-> NodeListDecodeArrow a (Map Text [b])
forall a b. (a -> b) -> a -> b
$ \TypedNodeSchema
schema a -> Node -> DecodeM b
decodeNode ->
    SchemaOf NodeList
-> (a -> DecodeStateM NodeList (Map Text [b]))
-> NodeListDecodeArrow a (Map Text [b])
forall o a b.
SchemaOf o -> (a -> DecodeStateM o b) -> DecodeArrow o a b
DecodeArrow (SchemaItem NodeList -> SchemaOf NodeList
forall a. a -> Schema a
SchemaOne (SchemaItem NodeList -> SchemaOf NodeList)
-> SchemaItem NodeList -> SchemaOf NodeList
forall a b. (a -> b) -> a -> b
$ TypedNodeSchema -> SchemaItem NodeList
RemainingNodes TypedNodeSchema
schema) ((a -> DecodeStateM NodeList (Map Text [b]))
 -> NodeListDecodeArrow a (Map Text [b]))
-> (a -> DecodeStateM NodeList (Map Text [b]))
-> NodeListDecodeArrow a (Map Text [b])
forall a b. (a -> b) -> a -> b
$ \a
a -> do
      ([b] -> [b] -> [b]) -> [(Text, [b])] -> Map Text [b]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [b] -> [b] -> [b]
forall a. Semigroup a => a -> a -> a
(<>) ([(Text, [b])] -> Map Text [b])
-> StateT (DecodeState NodeList) DecodeM [(Text, [b])]
-> DecodeStateM NodeList (Map Text [b])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Node -> DecodeM b)
-> StateT (DecodeState NodeList) DecodeM [(Text, [b])]
forall {a}.
(Node -> DecodeM a)
-> StateT (DecodeState NodeList) DecodeM [(Text, [a])]
go (a -> Node -> DecodeM b
decodeNode a
a)
 where
  go :: (Node -> DecodeM a)
-> StateT (DecodeState NodeList) DecodeM [(Text, [a])]
go Node -> DecodeM a
decodeNode = do
    (Node -> Bool)
-> (Node -> DecodeM a)
-> StateT (DecodeState NodeList) DecodeM (Maybe (Node, a))
forall a.
(Node -> Bool)
-> (Node -> DecodeM a)
-> StateT (DecodeState NodeList) DecodeM (Maybe (Node, a))
decodeFirstNodeWhere (Bool -> Node -> Bool
forall a b. a -> b -> a
const Bool
True) Node -> DecodeM a
decodeNode StateT (DecodeState NodeList) DecodeM (Maybe (Node, a))
-> (Maybe (Node, a)
    -> StateT (DecodeState NodeList) DecodeM [(Text, [a])])
-> StateT (DecodeState NodeList) DecodeM [(Text, [a])]
forall a b.
StateT (DecodeState NodeList) DecodeM a
-> (a -> StateT (DecodeState NodeList) DecodeM b)
-> StateT (DecodeState NodeList) DecodeM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (Node, a)
Nothing -> [(Text, [a])]
-> StateT (DecodeState NodeList) DecodeM [(Text, [a])]
forall a. a -> StateT (DecodeState NodeList) DecodeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      Just (Node
node_, a
b) -> do
        [(Text, [a])]
nodeMap <- (Node -> DecodeM a)
-> StateT (DecodeState NodeList) DecodeM [(Text, [a])]
go Node -> DecodeM a
decodeNode
        [(Text, [a])]
-> StateT (DecodeState NodeList) DecodeM [(Text, [a])]
forall a. a -> StateT (DecodeState NodeList) DecodeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Text, [a])]
 -> StateT (DecodeState NodeList) DecodeM [(Text, [a])])
-> [(Text, [a])]
-> StateT (DecodeState NodeList) DecodeM [(Text, [a])]
forall a b. (a -> b) -> a -> b
$ (Node
node_.name.value, [a
b]) (Text, [a]) -> [(Text, [a])] -> [(Text, [a])]
forall a. a -> [a] -> [a]
: [(Text, [a])]
nodeMap

-- | A helper to decode the first argument of the first node with the given name.
-- A utility for nodes that are acting like a key-value store.
--
-- > KDL.argAt "my-node" === KDL.node "my-node" KDL.arg
--
-- === __Example__
--
-- @
-- let
--   config =
--     """
--     verbose #true
--     """
--   decoder = KDL.document $ proc () -> do
--     KDL.argAt "verbose" -< ()
-- KDL.decodeWith decoder config == Right True
-- @
argAt :: (DecodeValue a) => Text -> NodeListDecoder a
argAt :: forall a. DecodeValue a => Text -> NodeListDecoder a
argAt Text
name = ([Text] -> ValueDecoder a -> NodeListDecoder a)
-> NodeListDecoder a
forall a r. DecodeValue a => ([Text] -> ValueDecoder a -> r) -> r
withDecodeValue (([Text] -> ValueDecoder a -> NodeListDecoder a)
 -> NodeListDecoder a)
-> ([Text] -> ValueDecoder a -> NodeListDecoder a)
-> NodeListDecoder a
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> ValueDecoder a -> NodeListDecoder a
forall a b.
Typeable b =>
Text -> [Text] -> ValueDecodeArrow a b -> NodeListDecodeArrow a b
argAtWith' Text
name

-- | Same as 'argAt', except explicitly specify the 'ValueDecoder' instead of using 'DecodeValue'
--
-- === __Example__
--
-- @
-- let
--   config =
--     """
--     verbose #true
--     """
--   decoder = KDL.document $ proc () -> do
--     KDL.argAtWith "verbose" KDL.bool -< ()
-- KDL.decodeWith decoder config == Right True
-- @
argAtWith :: forall a b. (Typeable b) => Text -> ValueDecodeArrow a b -> NodeListDecodeArrow a b
argAtWith :: forall a b.
Typeable b =>
Text -> ValueDecodeArrow a b -> NodeListDecodeArrow a b
argAtWith Text
name = Text -> [Text] -> ValueDecodeArrow a b -> NodeListDecodeArrow a b
forall a b.
Typeable b =>
Text -> [Text] -> ValueDecodeArrow a b -> NodeListDecodeArrow a b
argAtWith' Text
name []

-- | Same as 'argAtWith', except allow specifying type annotations.
argAtWith' :: forall a b. (Typeable b) => Text -> [Text] -> ValueDecodeArrow a b -> NodeListDecodeArrow a b
argAtWith' :: forall a b.
Typeable b =>
Text -> [Text] -> ValueDecodeArrow a b -> NodeListDecodeArrow a b
argAtWith' Text
name [Text]
typeAnns ValueDecodeArrow a b
decoder = Text -> NodeDecodeArrow a b -> NodeListDecodeArrow a b
forall a b.
Typeable b =>
Text -> NodeDecodeArrow a b -> NodeListDecodeArrow a b
nodeWith Text
name (NodeDecodeArrow a b -> NodeListDecodeArrow a b)
-> NodeDecodeArrow a b -> NodeListDecodeArrow a b
forall a b. (a -> b) -> a -> b
$ [Text] -> ValueDecodeArrow a b -> NodeDecodeArrow a b
forall a b.
Typeable b =>
[Text] -> ValueDecodeArrow a b -> NodeDecodeArrow a b
argWith' [Text]
typeAnns ValueDecodeArrow a b
decoder

-- | A helper to decode all the arguments of the first node with the given name.
-- A utility for nodes that are acting like a key-value store with a list of values.
--
-- > KDL.argsAt "my-node" === KDL.node "my-node" $ KDL.many KDL.arg
--
-- This is different from @many (argAt "foo")@, as that would find multiple nodes
-- named @"foo"@ and get the first arg from each.
--
-- === __Example__
--
-- @
-- let
--   config =
--     """
--     email "a@example.com" "b@example.com"
--     """
--   decoder = KDL.document $ proc () -> do
--     KDL.argsAt "email" -< ()
-- KDL.decodeWith decoder config == Right ["a@example.com", "b@example.com"]
-- @
argsAt :: (DecodeValue a) => Text -> NodeListDecoder [a]
argsAt :: forall a. DecodeValue a => Text -> NodeListDecoder [a]
argsAt Text
name = ([Text] -> ValueDecoder a -> NodeListDecoder [a])
-> NodeListDecoder [a]
forall a r. DecodeValue a => ([Text] -> ValueDecoder a -> r) -> r
withDecodeValue (([Text] -> ValueDecoder a -> NodeListDecoder [a])
 -> NodeListDecoder [a])
-> ([Text] -> ValueDecoder a -> NodeListDecoder [a])
-> NodeListDecoder [a]
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> ValueDecoder a -> NodeListDecoder [a]
forall a b.
Typeable b =>
Text -> [Text] -> ValueDecodeArrow a b -> NodeListDecodeArrow a [b]
argsAtWith' Text
name

-- | Same as 'argsAt', except explicitly specify the 'ValueDecoder' instead of using 'DecodeValue'
--
-- === __Example__
--
-- @
-- let
--   config =
--     """
--     email "a@example.com" "b@example.com"
--     """
--   decoder = KDL.document $ proc () -> do
--     KDL.argsAtWith "email" KDL.string -< ()
-- KDL.decodeWith decoder config == Right ["a@example.com", "b@example.com"]
-- @
argsAtWith :: forall a b. (Typeable b) => Text -> ValueDecodeArrow a b -> NodeListDecodeArrow a [b]
argsAtWith :: forall a b.
Typeable b =>
Text -> ValueDecodeArrow a b -> NodeListDecodeArrow a [b]
argsAtWith Text
name = Text -> [Text] -> ValueDecodeArrow a b -> NodeListDecodeArrow a [b]
forall a b.
Typeable b =>
Text -> [Text] -> ValueDecodeArrow a b -> NodeListDecodeArrow a [b]
argsAtWith' Text
name []

-- | Same as 'argsAtWith', except allow specifying type annotations.
argsAtWith' :: forall a b. (Typeable b) => Text -> [Text] -> ValueDecodeArrow a b -> NodeListDecodeArrow a [b]
argsAtWith' :: forall a b.
Typeable b =>
Text -> [Text] -> ValueDecodeArrow a b -> NodeListDecodeArrow a [b]
argsAtWith' Text
name [Text]
typeAnns ValueDecodeArrow a b
decoder = [b] -> DecodeArrow NodeList a [b] -> DecodeArrow NodeList a [b]
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option [] (DecodeArrow NodeList a [b] -> DecodeArrow NodeList a [b])
-> DecodeArrow NodeList a [b] -> DecodeArrow NodeList a [b]
forall a b. (a -> b) -> a -> b
$ Text -> NodeDecodeArrow a [b] -> DecodeArrow NodeList a [b]
forall a b.
Typeable b =>
Text -> NodeDecodeArrow a b -> NodeListDecodeArrow a b
nodeWith Text
name (NodeDecodeArrow a [b] -> DecodeArrow NodeList a [b])
-> NodeDecodeArrow a [b] -> DecodeArrow NodeList a [b]
forall a b. (a -> b) -> a -> b
$ DecodeArrow Node a b -> NodeDecodeArrow a [b]
forall a. DecodeArrow Node a a -> DecodeArrow Node a [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (DecodeArrow Node a b -> NodeDecodeArrow a [b])
-> DecodeArrow Node a b -> NodeDecodeArrow a [b]
forall a b. (a -> b) -> a -> b
$ [Text] -> ValueDecodeArrow a b -> DecodeArrow Node a b
forall a b.
Typeable b =>
[Text] -> ValueDecodeArrow a b -> NodeDecodeArrow a b
argWith' [Text]
typeAnns ValueDecodeArrow a b
decoder

-- | A helper for decoding child values in a list following the KDL convention of being named @"-"@.
--
-- > KDL.dashChildrenAt "my-node" === KDL.nodeWith "my-node" $ KDL.children $ KDL.many $ KDL.argAt "-"
--
-- === __Example__
--
-- @
-- let
--   config =
--     """
--     attendees {
--       - \"Alice"
--       - \"Bob"
--     }
--     """
--   decoder = KDL.document $ proc () -> do
--     KDL.dashChildrenAt "attendees" -< ()
-- KDL.decodeWith decoder config == Right [\"Alice", \"Bob"]
-- @
dashChildrenAt :: (DecodeValue a) => Text -> NodeListDecoder [a]
dashChildrenAt :: forall a. DecodeValue a => Text -> NodeListDecoder [a]
dashChildrenAt Text
name = ([Text] -> ValueDecoder a -> NodeListDecoder [a])
-> NodeListDecoder [a]
forall a r. DecodeValue a => ([Text] -> ValueDecoder a -> r) -> r
withDecodeValue (([Text] -> ValueDecoder a -> NodeListDecoder [a])
 -> NodeListDecoder [a])
-> ([Text] -> ValueDecoder a -> NodeListDecoder [a])
-> NodeListDecoder [a]
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> ValueDecoder a -> NodeListDecoder [a]
forall a b.
Typeable b =>
Text -> [Text] -> ValueDecodeArrow a b -> NodeListDecodeArrow a [b]
dashChildrenAtWith' Text
name

-- | Same as 'dashChildrenAt', except explicitly specify the 'ValueDecoder' instead of using 'DecodeValue'
--
-- === __Example__
--
-- @
-- let
--   config =
--     """
--     attendees {
--       - \"Alice"
--       - \"Bob"
--     }
--     """
--   decoder = KDL.document $ proc () -> do
--     KDL.dashChildrenAtWith "attendees" $ KDL.string -< ()
-- KDL.decodeWith decoder config == Right [\"Alice", \"Bob"]
-- @
dashChildrenAtWith :: forall a b. (Typeable b) => Text -> ValueDecodeArrow a b -> NodeListDecodeArrow a [b]
dashChildrenAtWith :: forall a b.
Typeable b =>
Text -> ValueDecodeArrow a b -> NodeListDecodeArrow a [b]
dashChildrenAtWith Text
name = Text -> [Text] -> ValueDecodeArrow a b -> NodeListDecodeArrow a [b]
forall a b.
Typeable b =>
Text -> [Text] -> ValueDecodeArrow a b -> NodeListDecodeArrow a [b]
dashChildrenAtWith' Text
name []

-- | Same as 'dashChildrenAtWith', except allow specifying type annotations.
dashChildrenAtWith' :: forall a b. (Typeable b) => Text -> [Text] -> ValueDecodeArrow a b -> NodeListDecodeArrow a [b]
dashChildrenAtWith' :: forall a b.
Typeable b =>
Text -> [Text] -> ValueDecodeArrow a b -> NodeListDecodeArrow a [b]
dashChildrenAtWith' Text
name [Text]
typeAnns ValueDecodeArrow a b
decoder = Text -> NodeDecodeArrow a b -> NodeListDecodeArrow a [b]
forall a b.
Typeable b =>
Text -> NodeDecodeArrow a b -> NodeListDecodeArrow a [b]
dashNodesAtWith Text
name (NodeDecodeArrow a b -> NodeListDecodeArrow a [b])
-> NodeDecodeArrow a b -> NodeListDecodeArrow a [b]
forall a b. (a -> b) -> a -> b
$ [Text] -> ValueDecodeArrow a b -> NodeDecodeArrow a b
forall a b.
Typeable b =>
[Text] -> ValueDecodeArrow a b -> NodeDecodeArrow a b
argWith' [Text]
typeAnns ValueDecodeArrow a b
decoder

-- | A helper for decoding child nodes in a list following the KDL convention of being named @"-"@.
--
-- > KDL.dashNodesAt "my-node" === KDL.nodeWith "my-node" $ KDL.children $ KDL.many $ KDL.node "-"
--
-- === __Example__
--
-- @
-- instance KDL.DecodeNode Attendee where
--   nodeDecoder = proc () -> do
--     name <- KDL.arg -< ()
--     returnA -< Attendee{..}
--
-- let
--   config =
--     """
--     attendees {
--       - \"Alice"
--       - \"Bob"
--     }
--     """
--   decoder = KDL.document $ proc () -> do
--     KDL.dashNodesAt "attendees" -< ()
-- KDL.decodeWith decoder config == Right [Attendee \"Alice", Attendee \"Bob"]
-- @
dashNodesAt :: (DecodeNode a) => Text -> NodeListDecoder [a]
dashNodesAt :: forall a. DecodeNode a => Text -> NodeListDecoder [a]
dashNodesAt Text
name = ([Text] -> NodeDecoder a -> NodeListDecoder [a])
-> NodeListDecoder [a]
forall a r. DecodeNode a => ([Text] -> NodeDecoder a -> r) -> r
withDecodeNode (([Text] -> NodeDecoder a -> NodeListDecoder [a])
 -> NodeListDecoder [a])
-> ([Text] -> NodeDecoder a -> NodeListDecoder [a])
-> NodeListDecoder [a]
forall a b. (a -> b) -> a -> b
$ \[Text]
_ NodeDecoder a
decoder -> Text -> NodeDecoder a -> NodeListDecoder [a]
forall a b.
Typeable b =>
Text -> NodeDecodeArrow a b -> NodeListDecodeArrow a [b]
dashNodesAtWith Text
name NodeDecoder a
decoder

-- | Same as 'dashChildrenAt', except explicitly specify the 'NodeDecoder' instead of using 'DecodeNode'
--
-- === __Example__
--
-- @
-- let
--   config =
--     """
--     attendees {
--       - \"Alice"
--       - \"Bob"
--     }
--     """
--   decoder = KDL.document $ proc () -> do
--     KDL.dashNodesAtWith "attendees" KDL.arg -< ()
-- KDL.decodeWith decoder config == Right ["Alice", "Bob"]
-- @
dashNodesAtWith :: forall a b. (Typeable b) => Text -> NodeDecodeArrow a b -> NodeListDecodeArrow a [b]
dashNodesAtWith :: forall a b.
Typeable b =>
Text -> NodeDecodeArrow a b -> NodeListDecodeArrow a [b]
dashNodesAtWith Text
name NodeDecodeArrow a b
decoder =
  [b] -> DecodeArrow NodeList a [b] -> DecodeArrow NodeList a [b]
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option [] (DecodeArrow NodeList a [b] -> DecodeArrow NodeList a [b])
-> (NodeDecodeArrow a [b] -> DecodeArrow NodeList a [b])
-> NodeDecodeArrow a [b]
-> DecodeArrow NodeList a [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> NodeDecodeArrow a [b] -> DecodeArrow NodeList a [b]
forall a b.
Typeable b =>
Text -> NodeDecodeArrow a b -> NodeListDecodeArrow a b
nodeWith Text
name (NodeDecodeArrow a [b] -> DecodeArrow NodeList a [b])
-> NodeDecodeArrow a [b] -> DecodeArrow NodeList a [b]
forall a b. (a -> b) -> a -> b
$
    DecodeArrow NodeList a [b] -> NodeDecodeArrow a [b]
forall a b. NodeListDecodeArrow a b -> NodeDecodeArrow a b
children (DecodeArrow NodeList a [b] -> NodeDecodeArrow a [b])
-> DecodeArrow NodeList a [b] -> NodeDecodeArrow a [b]
forall a b. (a -> b) -> a -> b
$
      DecodeArrow NodeList a b -> DecodeArrow NodeList a [b]
forall a. DecodeArrow NodeList a a -> DecodeArrow NodeList a [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Text -> NodeDecodeArrow a b -> DecodeArrow NodeList a b
forall a b.
Typeable b =>
Text -> NodeDecodeArrow a b -> NodeListDecodeArrow a b
nodeWith Text
"-" NodeDecodeArrow a b
decoder)

{----- Decoding Ann -----}

validateAnn :: [Text] -> Maybe Ann -> DecodeM ()
validateAnn :: [Text] -> Maybe Ann -> DecodeM ()
validateAnn [Text]
typeAnns Maybe Ann
mGivenAnn =
  case Maybe Ann
mGivenAnn of
    Maybe Ann
Nothing -> () -> DecodeM ()
forall a. a -> DecodeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just Ann
givenAnn -> do
      let isValidAnn :: Bool
isValidAnn = [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
Prelude.null [Text]
typeAnns Bool -> Bool -> Bool
|| Ann
givenAnn.identifier.value Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
typeAnns
      Bool -> DecodeM () -> DecodeM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isValidAnn (DecodeM () -> DecodeM ()) -> DecodeM () -> DecodeM ()
forall a b. (a -> b) -> a -> b
$ do
        DecodeErrorKind -> DecodeM ()
forall a. DecodeErrorKind -> DecodeM a
decodeThrow DecodeError_MismatchedAnn{givenAnn :: Identifier
givenAnn = Ann
givenAnn.identifier, validAnns :: [Text]
validAnns = [Text]
typeAnns}

{----- Decoding Node -----}

withDecodeNode :: forall a r. (DecodeNode a) => ([Text] -> NodeDecoder a -> r) -> r
withDecodeNode :: forall a r. DecodeNode a => ([Text] -> NodeDecoder a -> r) -> r
withDecodeNode [Text] -> NodeDecoder a -> r
k = [Text] -> NodeDecoder a -> r
k (Proxy a -> [Text]
forall a. DecodeNode a => Proxy a -> [Text]
validNodeTypeAnns (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)) NodeDecoder a
forall a. DecodeNode a => NodeDecoder a
nodeDecoder

withTypedNodeDecoder ::
  forall a b r.
  (Typeable b) =>
  (TypedNodeSchema -> (a -> Node -> DecodeM b) -> r) ->
  ([Text] -> NodeDecodeArrow a b -> r)
withTypedNodeDecoder :: forall a b r.
Typeable b =>
(TypedNodeSchema -> (a -> Node -> DecodeM b) -> r)
-> [Text] -> NodeDecodeArrow a b -> r
withTypedNodeDecoder TypedNodeSchema -> (a -> Node -> DecodeM b) -> r
k [Text]
typeAnns NodeDecodeArrow a b
decoder = TypedNodeSchema -> (a -> Node -> DecodeM b) -> r
k TypedNodeSchema
schema a -> Node -> DecodeM b
decodeNode
 where
  schema :: TypedNodeSchema
schema =
    TypedNodeSchema
      { typeHint :: TypeRep
typeHint = Proxy b -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b)
      , validTypeAnns :: [Text]
validTypeAnns = [Text]
typeAnns
      , nodeSchema :: SchemaOf Node
nodeSchema = NodeDecodeArrow a b
decoder.schema
      }
  decodeNode :: a -> Node -> DecodeM b
decodeNode a
a Node
node_ = do
    [Text] -> Maybe Ann -> DecodeM ()
validateAnn [Text]
typeAnns Node
node_.ann
    Node
-> DecodeHistory Node
-> StateT (DecodeState Node) DecodeM b
-> DecodeM b
forall o a. o -> DecodeHistory o -> DecodeStateM o a -> DecodeM a
runDecodeStateM Node
node_ DecodeHistory Node
forall {k} (o :: k). HasDecodeHistory o => DecodeHistory o
emptyDecodeHistory (StateT (DecodeState Node) DecodeM b -> DecodeM b)
-> StateT (DecodeState Node) DecodeM b -> DecodeM b
forall a b. (a -> b) -> a -> b
$ do
      -- TODO: add typeHint to Context
      NodeDecodeArrow a b
decoder.run a
a StateT (DecodeState Node) DecodeM b
-> StateT (DecodeState Node) DecodeM ()
-> StateT (DecodeState Node) DecodeM b
forall a b.
StateT (DecodeState Node) DecodeM a
-> StateT (DecodeState Node) DecodeM b
-> StateT (DecodeState Node) DecodeM a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* StateT (DecodeState Node) DecodeM ()
validateNode

validateNode :: StateT (DecodeState Node) DecodeM ()
validateNode :: StateT (DecodeState Node) DecodeM ()
validateNode = do
  Node
node_ <- (DecodeState Node -> Node)
-> StateT (DecodeState Node) DecodeM Node
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
StateT.gets (.object)
  case Node
node_.entries of
    [] -> () -> StateT (DecodeState Node) DecodeM ()
forall a. a -> StateT (DecodeState Node) DecodeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Entry{name :: Entry -> Maybe Identifier
name = Maybe Identifier
Nothing, Value
value :: Value
value :: Entry -> Value
value} : [Entry]
_ -> do
      Int
index <- (DecodeState Node -> Int) -> StateT (DecodeState Node) DecodeM Int
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
StateT.gets DecodeState Node -> Int
getArgIndex
      DecodeM () -> StateT (DecodeState Node) DecodeM ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (DecodeState Node) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (DecodeM () -> StateT (DecodeState Node) DecodeM ())
-> (DecodeErrorKind -> DecodeM ())
-> DecodeErrorKind
-> StateT (DecodeState Node) DecodeM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecodeErrorKind -> DecodeM ()
forall a. DecodeErrorKind -> DecodeM a
decodeThrow (DecodeErrorKind -> StateT (DecodeState Node) DecodeM ())
-> DecodeErrorKind -> StateT (DecodeState Node) DecodeM ()
forall a b. (a -> b) -> a -> b
$
        DecodeError_UnexpectedArg
          { index :: Int
index = Int
index
          , value :: Value
value = Value
value
          }
    Entry{name :: Entry -> Maybe Identifier
name = Just Identifier
identifier, Value
value :: Entry -> Value
value :: Value
value} : [Entry]
_ -> do
      DecodeM () -> StateT (DecodeState Node) DecodeM ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (DecodeState Node) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (DecodeM () -> StateT (DecodeState Node) DecodeM ())
-> (DecodeErrorKind -> DecodeM ())
-> DecodeErrorKind
-> StateT (DecodeState Node) DecodeM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecodeErrorKind -> DecodeM ()
forall a. DecodeErrorKind -> DecodeM a
decodeThrow (DecodeErrorKind -> StateT (DecodeState Node) DecodeM ())
-> DecodeErrorKind -> StateT (DecodeState Node) DecodeM ()
forall a b. (a -> b) -> a -> b
$
        DecodeError_UnexpectedProp
          { identifier :: Identifier
identifier = Identifier
identifier
          , value :: Value
value = Value
value
          }
  case Node
node_.children of
    Maybe NodeList
Nothing -> () -> StateT (DecodeState Node) DecodeM ()
forall a. a -> StateT (DecodeState Node) DecodeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just NodeList
children_ -> do
      DecodeHistory NodeList
childrenHistory <- (DecodeState Node -> DecodeHistory NodeList)
-> StateT (DecodeState Node) DecodeM (DecodeHistory NodeList)
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
StateT.gets (.history.childrenHistory)
      DecodeM () -> StateT (DecodeState Node) DecodeM ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (DecodeState Node) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (DecodeM () -> StateT (DecodeState Node) DecodeM ())
-> (StateT (DecodeState NodeList) DecodeM () -> DecodeM ())
-> StateT (DecodeState NodeList) DecodeM ()
-> StateT (DecodeState Node) DecodeM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeList
-> DecodeHistory NodeList
-> StateT (DecodeState NodeList) DecodeM ()
-> DecodeM ()
forall o a. o -> DecodeHistory o -> DecodeStateM o a -> DecodeM a
runDecodeStateM NodeList
children_ DecodeHistory NodeList
childrenHistory (StateT (DecodeState NodeList) DecodeM ()
 -> StateT (DecodeState Node) DecodeM ())
-> StateT (DecodeState NodeList) DecodeM ()
-> StateT (DecodeState Node) DecodeM ()
forall a b. (a -> b) -> a -> b
$ StateT (DecodeState NodeList) DecodeM ()
validateNodeList

type NodeDecoder a = NodeDecodeArrow () a
type NodeDecodeArrow a b = DecodeArrow Node a b

getArgIndex :: DecodeState Node -> Int
getArgIndex :: DecodeState Node -> Int
getArgIndex = (.history.argsSeen)

-- | The type class for specifying how a type should be decoded from a KDL node.
class (Typeable a) => DecodeNode a where
  -- | Allowed type annotations for a node of this type.
  --
  -- If specified, nodes with an explicit type annotation MUST match one of the
  -- annotations in this list. Nodes with no type annotations are not checked.
  -- Defaults to @[]@, which means type annotations are ignored.
  --
  -- === __Example__
  --
  -- @
  -- instance DecodeNode Person where
  --   validNodeTypeAnns _ = ["person"]
  -- @
  validNodeTypeAnns :: Proxy a -> [Text]
  validNodeTypeAnns Proxy a
_ = []

  -- | Decode a t'Node' to a value of type @a@
  nodeDecoder :: NodeDecoder a

instance DecodeNode Node where
  nodeDecoder :: NodeDecoder Node
nodeDecoder =
    SchemaOf Node
-> (() -> StateT (DecodeState Node) DecodeM Node)
-> NodeDecoder Node
forall o a b.
SchemaOf o -> (a -> DecodeStateM o b) -> DecodeArrow o a b
DecodeArrow SchemaOf Node
forall a. Schema a
SchemaUnknown ((() -> StateT (DecodeState Node) DecodeM Node)
 -> NodeDecoder Node)
-> (() -> StateT (DecodeState Node) DecodeM Node)
-> NodeDecoder Node
forall a b. (a -> b) -> a -> b
$ \() -> do
      Node
node_ <- (DecodeState Node -> Node)
-> StateT (DecodeState Node) DecodeM Node
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
StateT.gets (.object)
      (DecodeState Node -> DecodeState Node)
-> StateT (DecodeState Node) DecodeM ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
StateT.modify ((DecodeState Node -> DecodeState Node)
 -> StateT (DecodeState Node) DecodeM ())
-> (DecodeState Node -> DecodeState Node)
-> StateT (DecodeState Node) DecodeM ()
forall a b. (a -> b) -> a -> b
$ \DecodeState Node
s -> DecodeState Node
s{object = emptyNode node_.name}
      Node -> StateT (DecodeState Node) DecodeM Node
forall a. a -> StateT (DecodeState Node) DecodeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Node
node_
   where
    emptyNode :: Identifier -> Node
emptyNode Identifier
name =
      Node
        { ann :: Maybe Ann
ann = Maybe Ann
forall a. Maybe a
Nothing
        , name :: Identifier
name = Identifier
name
        , entries :: [Entry]
entries = []
        , children :: Maybe NodeList
children = Maybe NodeList
forall a. Maybe a
Nothing
        , ext :: NodeExtension
ext = NodeExtension
forall a. Default a => a
def
        }

-- | Decode an argument in the node.
--
-- === __Example__
--
-- @
-- let
--   config =
--     """
--     person \"Alice" 1 2 3
--     """
--   decoder = KDL.document $ proc () -> do
--     KDL.nodeWith "person" $ decodePerson -< ()
--   decodePerson = proc () -> do
--     name <- KDL.arg -< ()
--     vals <- KDL.many KDL.arg -< ()
--     returnA -< (name, vals)
-- KDL.decodeWith decoder config == Right (\"Alice", [1, 2, 3])
-- @
arg :: (DecodeValue a) => NodeDecoder a
arg :: forall a. DecodeValue a => NodeDecoder a
arg = ([Text] -> ValueDecoder a -> NodeDecoder a) -> NodeDecoder a
forall a r. DecodeValue a => ([Text] -> ValueDecoder a -> r) -> r
withDecodeValue [Text] -> ValueDecoder a -> NodeDecoder a
forall a b.
Typeable b =>
[Text] -> ValueDecodeArrow a b -> NodeDecodeArrow a b
argWith'

-- | Same as 'arg', except explicitly specify the 'ValueDecoder' instead of using 'DecodeValue'
--
-- === __Example__
--
-- @
-- let
--   config =
--     """
--     person \"Alice" 1 2 3
--     """
--   decoder = KDL.document $ proc () -> do
--     KDL.nodeWith "person" $ decodePerson -< ()
--   decodePerson = proc () -> do
--     name \<- KDL.argWith $ Text.toUpper \<$> KDL.string -< ()
--     vals \<- KDL.many $ KDL.argWith $ show \<$> KDL.valueDecoder @Int -< ()
--     returnA -< (name, vals)
-- KDL.decodeWith decoder config == Right (\"ALICE", ["1", "2", "3"])
-- @
argWith :: forall a b. (Typeable b) => ValueDecodeArrow a b -> NodeDecodeArrow a b
argWith :: forall a b.
Typeable b =>
ValueDecodeArrow a b -> NodeDecodeArrow a b
argWith = [Text] -> ValueDecodeArrow a b -> NodeDecodeArrow a b
forall a b.
Typeable b =>
[Text] -> ValueDecodeArrow a b -> NodeDecodeArrow a b
argWith' []

-- | Same as 'argWith', except allow specifying type annotations.
argWith' :: forall a b. (Typeable b) => [Text] -> ValueDecodeArrow a b -> NodeDecodeArrow a b
argWith' :: forall a b.
Typeable b =>
[Text] -> ValueDecodeArrow a b -> NodeDecodeArrow a b
argWith' =
  (TypedValueSchema
 -> (a -> Value -> DecodeM b) -> NodeDecodeArrow a b)
-> [Text] -> ValueDecodeArrow a b -> NodeDecodeArrow a b
forall a b r.
Typeable b =>
(TypedValueSchema -> (a -> Value -> DecodeM b) -> r)
-> [Text] -> ValueDecodeArrow a b -> r
withTypedValueDecoder ((TypedValueSchema
  -> (a -> Value -> DecodeM b) -> NodeDecodeArrow a b)
 -> [Text] -> ValueDecodeArrow a b -> NodeDecodeArrow a b)
-> (TypedValueSchema
    -> (a -> Value -> DecodeM b) -> NodeDecodeArrow a b)
-> [Text]
-> ValueDecodeArrow a b
-> NodeDecodeArrow a b
forall a b. (a -> b) -> a -> b
$ \TypedValueSchema
schema a -> Value -> DecodeM b
decodeValue ->
    SchemaOf Node -> (a -> DecodeStateM Node b) -> NodeDecodeArrow a b
forall o a b.
SchemaOf o -> (a -> DecodeStateM o b) -> DecodeArrow o a b
DecodeArrow (SchemaItem Node -> SchemaOf Node
forall a. a -> Schema a
SchemaOne (SchemaItem Node -> SchemaOf Node)
-> SchemaItem Node -> SchemaOf Node
forall a b. (a -> b) -> a -> b
$ TypedValueSchema -> SchemaItem Node
NodeArg TypedValueSchema
schema) ((a -> DecodeStateM Node b) -> NodeDecodeArrow a b)
-> (a -> DecodeStateM Node b) -> NodeDecodeArrow a b
forall a b. (a -> b) -> a -> b
$ \a
a -> do
      Int
index <- (DecodeState Node -> Int) -> StateT (DecodeState Node) DecodeM Int
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
StateT.gets DecodeState Node -> Int
getArgIndex

      [Entry]
entries <- (DecodeState Node -> [Entry])
-> StateT (DecodeState Node) DecodeM [Entry]
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
StateT.gets (.object.entries)
      (Entry
entry, [Entry]
entries') <-
        StateT (DecodeState Node) DecodeM (Entry, [Entry])
-> ((Entry, [Entry])
    -> StateT (DecodeState Node) DecodeM (Entry, [Entry]))
-> Maybe (Entry, [Entry])
-> StateT (DecodeState Node) DecodeM (Entry, [Entry])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (DecodeM (Entry, [Entry])
-> StateT (DecodeState Node) DecodeM (Entry, [Entry])
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (DecodeState Node) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (DecodeM (Entry, [Entry])
 -> StateT (DecodeState Node) DecodeM (Entry, [Entry]))
-> DecodeM (Entry, [Entry])
-> StateT (DecodeState Node) DecodeM (Entry, [Entry])
forall a b. (a -> b) -> a -> b
$ DecodeErrorKind -> DecodeM (Entry, [Entry])
forall a. DecodeErrorKind -> DecodeM a
decodeThrow DecodeError_ExpectedArg{index :: Int
index = Int
index}) (Entry, [Entry])
-> StateT (DecodeState Node) DecodeM (Entry, [Entry])
forall a. a -> StateT (DecodeState Node) DecodeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Entry, [Entry])
 -> StateT (DecodeState Node) DecodeM (Entry, [Entry]))
-> Maybe (Entry, [Entry])
-> StateT (DecodeState Node) DecodeM (Entry, [Entry])
forall a b. (a -> b) -> a -> b
$
          (Entry -> Bool) -> [Entry] -> Maybe (Entry, [Entry])
forall a. (a -> Bool) -> [a] -> Maybe (a, [a])
extractFirst (Maybe Identifier -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Identifier -> Bool)
-> (Entry -> Maybe Identifier) -> Entry -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.name)) [Entry]
entries
      (DecodeState Node -> DecodeState Node)
-> StateT (DecodeState Node) DecodeM ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
StateT.modify ((DecodeState Node -> DecodeState Node)
 -> StateT (DecodeState Node) DecodeM ())
-> (DecodeState Node -> DecodeState Node)
-> StateT (DecodeState Node) DecodeM ()
forall a b. (a -> b) -> a -> b
$ \DecodeState Node
s -> DecodeState Node
s{object = s.object{entries = entries'}}

      b
b <-
        DecodeM b -> DecodeStateM Node b
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (DecodeState Node) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (DecodeM b -> DecodeStateM Node b)
-> (DecodeM b -> DecodeM b) -> DecodeM b -> DecodeStateM Node b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContextItem -> DecodeM b -> DecodeM b
forall a. ContextItem -> DecodeM a -> DecodeM a
addContext ContextArg{index :: Int
index = Int
index} (DecodeM b -> DecodeStateM Node b)
-> DecodeM b -> DecodeStateM Node b
forall a b. (a -> b) -> a -> b
$
          a -> Value -> DecodeM b
decodeValue a
a Entry
entry.value
      (DecodeState Node -> DecodeState Node)
-> StateT (DecodeState Node) DecodeM ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
StateT.modify ((DecodeState Node -> DecodeState Node)
 -> StateT (DecodeState Node) DecodeM ())
-> (DecodeState Node -> DecodeState Node)
-> StateT (DecodeState Node) DecodeM ()
forall a b. (a -> b) -> a -> b
$ \DecodeState Node
s -> DecodeState Node
s{history = s.history{argsSeen = s.history.argsSeen + 1}}
      b -> DecodeStateM Node b
forall a. a -> StateT (DecodeState Node) DecodeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b

-- | Decode the property with the given name in the node.
--
-- If the property appears multiple times, the last value is returned, as
-- defined in the spec.
--
-- === __Example__
--
-- @
-- let
--   config =
--     """
--     my-node a=1 b=2 a=3
--     """
--   decoder = KDL.document $ proc () -> do
--     KDL.nodeWith "my-node" $ KDL.prop @Int "a" -< ()
-- KDL.decodeWith decoder config == Right 3
-- @
prop :: (DecodeValue a) => Text -> NodeDecoder a
prop :: forall a. DecodeValue a => Text -> NodeDecoder a
prop Text
name = ([Text] -> ValueDecoder a -> NodeDecoder a) -> NodeDecoder a
forall a r. DecodeValue a => ([Text] -> ValueDecoder a -> r) -> r
withDecodeValue (([Text] -> ValueDecoder a -> NodeDecoder a) -> NodeDecoder a)
-> ([Text] -> ValueDecoder a -> NodeDecoder a) -> NodeDecoder a
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> ValueDecoder a -> NodeDecoder a
forall a b.
Typeable b =>
Text -> [Text] -> ValueDecodeArrow a b -> NodeDecodeArrow a b
propWith' Text
name

-- | Same as 'prop', except explicitly specify the 'ValueDecoder' instead of using 'DecodeValue'
--
-- === __Example__
--
-- @
-- let
--   config =
--     """
--     my-node a=1 b=2 a=3
--     """
--   decoder = KDL.document $ proc () -> do
--     KDL.nodeWith "my-node" $ KDL.propWith "a" $ show \<$> KDL.number -< ()
-- KDL.decodeWith decoder config == Right "3.0"
-- @
propWith :: forall a b. (Typeable b) => Text -> ValueDecodeArrow a b -> NodeDecodeArrow a b
propWith :: forall a b.
Typeable b =>
Text -> ValueDecodeArrow a b -> NodeDecodeArrow a b
propWith Text
name = Text -> [Text] -> ValueDecodeArrow a b -> NodeDecodeArrow a b
forall a b.
Typeable b =>
Text -> [Text] -> ValueDecodeArrow a b -> NodeDecodeArrow a b
propWith' Text
name []

-- | Same as 'propWith', except allow specifying type annotations.
propWith' :: forall a b. (Typeable b) => Text -> [Text] -> ValueDecodeArrow a b -> NodeDecodeArrow a b
propWith' :: forall a b.
Typeable b =>
Text -> [Text] -> ValueDecodeArrow a b -> NodeDecodeArrow a b
propWith' Text
name =
  (TypedValueSchema
 -> (a -> Value -> DecodeM b) -> NodeDecodeArrow a b)
-> [Text] -> ValueDecodeArrow a b -> NodeDecodeArrow a b
forall a b r.
Typeable b =>
(TypedValueSchema -> (a -> Value -> DecodeM b) -> r)
-> [Text] -> ValueDecodeArrow a b -> r
withTypedValueDecoder ((TypedValueSchema
  -> (a -> Value -> DecodeM b) -> NodeDecodeArrow a b)
 -> [Text] -> ValueDecodeArrow a b -> NodeDecodeArrow a b)
-> (TypedValueSchema
    -> (a -> Value -> DecodeM b) -> NodeDecodeArrow a b)
-> [Text]
-> ValueDecodeArrow a b
-> NodeDecodeArrow a b
forall a b. (a -> b) -> a -> b
$ \TypedValueSchema
schema a -> Value -> DecodeM b
decodeValue ->
    SchemaOf Node -> (a -> DecodeStateM Node b) -> NodeDecodeArrow a b
forall o a b.
SchemaOf o -> (a -> DecodeStateM o b) -> DecodeArrow o a b
DecodeArrow (SchemaItem Node -> SchemaOf Node
forall a. a -> Schema a
SchemaOne (SchemaItem Node -> SchemaOf Node)
-> SchemaItem Node -> SchemaOf Node
forall a b. (a -> b) -> a -> b
$ Text -> TypedValueSchema -> SchemaItem Node
NodeProp Text
name TypedValueSchema
schema) ((a -> DecodeStateM Node b) -> NodeDecodeArrow a b)
-> (a -> DecodeStateM Node b) -> NodeDecodeArrow a b
forall a b. (a -> b) -> a -> b
$ \a
a -> do
      (Text -> Bool)
-> (Value -> DecodeM b)
-> StateT (DecodeState Node) DecodeM (Maybe (Identifier, b))
forall a.
(Text -> Bool)
-> (Value -> DecodeM a)
-> StateT (DecodeState Node) DecodeM (Maybe (Identifier, a))
decodeOnePropWhere (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name) (a -> Value -> DecodeM b
decodeValue a
a)
        StateT (DecodeState Node) DecodeM (Maybe (Identifier, b))
-> (Maybe (Identifier, b) -> DecodeStateM Node b)
-> DecodeStateM Node b
forall a b.
StateT (DecodeState Node) DecodeM a
-> (a -> StateT (DecodeState Node) DecodeM b)
-> StateT (DecodeState Node) DecodeM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DecodeStateM Node b
-> ((Identifier, b) -> DecodeStateM Node b)
-> Maybe (Identifier, b)
-> DecodeStateM Node b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (DecodeM b -> DecodeStateM Node b
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (DecodeState Node) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (DecodeM b -> DecodeStateM Node b)
-> DecodeM b -> DecodeStateM Node b
forall a b. (a -> b) -> a -> b
$ DecodeErrorKind -> DecodeM b
forall a. DecodeErrorKind -> DecodeM a
decodeThrow DecodeError_ExpectedProp{name :: Text
name = Text
name}) (b -> DecodeStateM Node b
forall a. a -> StateT (DecodeState Node) DecodeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> DecodeStateM Node b)
-> ((Identifier, b) -> b) -> (Identifier, b) -> DecodeStateM Node b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Identifier, b) -> b
forall a b. (a, b) -> b
snd)

decodeOnePropWhere ::
  (Text -> Bool) ->
  (Value -> DecodeM a) ->
  StateT (DecodeState Node) DecodeM (Maybe (Identifier, a))
decodeOnePropWhere :: forall a.
(Text -> Bool)
-> (Value -> DecodeM a)
-> StateT (DecodeState Node) DecodeM (Maybe (Identifier, a))
decodeOnePropWhere Text -> Bool
matcher Value -> DecodeM a
decodeValue = do
  [Entry]
entries <- (DecodeState Node -> [Entry])
-> StateT (DecodeState Node) DecodeM [Entry]
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
StateT.gets (.object.entries)
  case [Entry] -> Maybe (Identifier, Entry, [Entry])
findProp [Entry]
entries of
    Maybe (Identifier, Entry, [Entry])
Nothing -> Maybe (Identifier, a)
-> StateT (DecodeState Node) DecodeM (Maybe (Identifier, a))
forall a. a -> StateT (DecodeState Node) DecodeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Identifier, a)
forall a. Maybe a
Nothing
    Just (Identifier
name, Entry
prop_, [Entry]
entries') -> do
      (DecodeState Node -> DecodeState Node)
-> StateT (DecodeState Node) DecodeM ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
StateT.modify ((DecodeState Node -> DecodeState Node)
 -> StateT (DecodeState Node) DecodeM ())
-> (DecodeState Node -> DecodeState Node)
-> StateT (DecodeState Node) DecodeM ()
forall a b. (a -> b) -> a -> b
$ \DecodeState Node
s -> DecodeState Node
s{object = s.object{entries = entries'}}
      a
b <-
        DecodeM a -> StateT (DecodeState Node) DecodeM a
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (DecodeState Node) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (DecodeM a -> StateT (DecodeState Node) DecodeM a)
-> (DecodeM a -> DecodeM a)
-> DecodeM a
-> StateT (DecodeState Node) DecodeM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContextItem -> DecodeM a -> DecodeM a
forall a. ContextItem -> DecodeM a -> DecodeM a
addContext ContextProp{name :: Identifier
name = Identifier
name} (DecodeM a -> StateT (DecodeState Node) DecodeM a)
-> DecodeM a -> StateT (DecodeState Node) DecodeM a
forall a b. (a -> b) -> a -> b
$
          Value -> DecodeM a
decodeValue Entry
prop_.value
      (DecodeState Node -> DecodeState Node)
-> StateT (DecodeState Node) DecodeM ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
StateT.modify ((DecodeState Node -> DecodeState Node)
 -> StateT (DecodeState Node) DecodeM ())
-> (DecodeState Node -> DecodeState Node)
-> StateT (DecodeState Node) DecodeM ()
forall a b. (a -> b) -> a -> b
$ \DecodeState Node
s -> DecodeState Node
s{history = s.history{propsSeen = Set.insert name s.history.propsSeen}}
      Maybe (Identifier, a)
-> StateT (DecodeState Node) DecodeM (Maybe (Identifier, a))
forall a. a -> StateT (DecodeState Node) DecodeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Identifier, a)
 -> StateT (DecodeState Node) DecodeM (Maybe (Identifier, a)))
-> Maybe (Identifier, a)
-> StateT (DecodeState Node) DecodeM (Maybe (Identifier, a))
forall a b. (a -> b) -> a -> b
$ (Identifier, a) -> Maybe (Identifier, a)
forall a. a -> Maybe a
Just (Identifier
name, a
b)
 where
  isPropWhere :: (b -> Bool) -> r -> Bool
isPropWhere b -> Bool
f r
entry = (b -> Bool
f (b -> Bool) -> (a -> b) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.value) (a -> Bool) -> Maybe a -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> r
entry.name) Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
  findProp :: [Entry] -> Maybe (Identifier, Entry, [Entry])
findProp [Entry]
entries =
    case (Entry -> Bool) -> [Entry] -> ([Entry], [Entry])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((Text -> Bool) -> Entry -> Bool
forall {a} {b} {r}.
(HasField "value" a b, HasField "name" r (Maybe a)) =>
(b -> Bool) -> r -> Bool
isPropWhere Text -> Bool
matcher) [Entry]
entries of
      ([Entry]
entries1, prop0 :: Entry
prop0@Entry{name :: Entry -> Maybe Identifier
name = Just Identifier
name} : [Entry]
remainingEntries) ->
        -- Collect remaining props with the same name, latter props override earlier props
        let ([Entry]
props, [Entry]
entries2) = (Entry -> Bool) -> [Entry] -> ([Entry], [Entry])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((Text -> Bool) -> Entry -> Bool
forall {a} {b} {r}.
(HasField "value" a b, HasField "name" r (Maybe a)) =>
(b -> Bool) -> r -> Bool
isPropWhere (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Identifier
name.value)) [Entry]
remainingEntries
         in (Identifier, Entry, [Entry]) -> Maybe (Identifier, Entry, [Entry])
forall a. a -> Maybe a
Just (Identifier
name, NonEmpty Entry -> Entry
forall a. NonEmpty a -> a
NonEmpty.last (NonEmpty Entry -> Entry) -> NonEmpty Entry -> Entry
forall a b. (a -> b) -> a -> b
$ Entry
prop0 Entry -> [Entry] -> NonEmpty Entry
forall a. a -> [a] -> NonEmpty a
NonEmpty.:| [Entry]
props, [Entry]
entries1 [Entry] -> [Entry] -> [Entry]
forall a. Semigroup a => a -> a -> a
<> [Entry]
entries2)
      ([Entry], [Entry])
_ ->
        Maybe (Identifier, Entry, [Entry])
forall a. Maybe a
Nothing

-- | Decode all remaining props.
--
-- === __Example__
--
-- @
-- let
--   config =
--     """
--     my-node a=1 b=2 a=3
--     """
--   decoder = KDL.document $ proc () -> do
--     KDL.nodeWith "my-node" $ KDL.remainingProps @Int -< ()
-- KDL.decodeWith decoder config == (Right . Map.fromList) [("a", 3), ("b", 2)]
-- @
remainingProps :: (DecodeValue a) => NodeDecoder (Map Text a)
remainingProps :: forall a. DecodeValue a => NodeDecoder (Map Text a)
remainingProps = ([Text] -> ValueDecoder a -> NodeDecoder (Map Text a))
-> NodeDecoder (Map Text a)
forall a r. DecodeValue a => ([Text] -> ValueDecoder a -> r) -> r
withDecodeValue [Text] -> ValueDecoder a -> NodeDecoder (Map Text a)
forall a b.
Typeable b =>
[Text] -> ValueDecodeArrow a b -> NodeDecodeArrow a (Map Text b)
remainingPropsWith'

-- | Same as 'remainingProps', except explicitly specify the 'ValueDecoder' instead of using 'DecodeValue'
--
-- === __Example__
--
-- @
-- let
--   config =
--     """
--     my-node a=1 b=2 a=3
--     """
--   decoder = KDL.document $ proc () -> do
--     KDL.nodeWith "my-node" $ KDL.remainingPropsWith $ show \<$> KDL.number -< ()
-- KDL.decodeWith decoder config == (Right . Map.fromList) [("a", "3.0"), ("b", "2.0")]
-- @
remainingPropsWith :: forall a b. (Typeable b) => ValueDecodeArrow a b -> NodeDecodeArrow a (Map Text b)
remainingPropsWith :: forall a b.
Typeable b =>
ValueDecodeArrow a b -> NodeDecodeArrow a (Map Text b)
remainingPropsWith = [Text] -> ValueDecodeArrow a b -> NodeDecodeArrow a (Map Text b)
forall a b.
Typeable b =>
[Text] -> ValueDecodeArrow a b -> NodeDecodeArrow a (Map Text b)
remainingPropsWith' []

-- | Same as 'remainingPropsWith', except allow specifying type annotations.
remainingPropsWith' :: forall a b. (Typeable b) => [Text] -> ValueDecodeArrow a b -> NodeDecodeArrow a (Map Text b)
remainingPropsWith' :: forall a b.
Typeable b =>
[Text] -> ValueDecodeArrow a b -> NodeDecodeArrow a (Map Text b)
remainingPropsWith' =
  (TypedValueSchema
 -> (a -> Value -> DecodeM b) -> NodeDecodeArrow a (Map Text b))
-> [Text] -> ValueDecodeArrow a b -> NodeDecodeArrow a (Map Text b)
forall a b r.
Typeable b =>
(TypedValueSchema -> (a -> Value -> DecodeM b) -> r)
-> [Text] -> ValueDecodeArrow a b -> r
withTypedValueDecoder ((TypedValueSchema
  -> (a -> Value -> DecodeM b) -> NodeDecodeArrow a (Map Text b))
 -> [Text]
 -> ValueDecodeArrow a b
 -> NodeDecodeArrow a (Map Text b))
-> (TypedValueSchema
    -> (a -> Value -> DecodeM b) -> NodeDecodeArrow a (Map Text b))
-> [Text]
-> ValueDecodeArrow a b
-> NodeDecodeArrow a (Map Text b)
forall a b. (a -> b) -> a -> b
$ \TypedValueSchema
schema a -> Value -> DecodeM b
decodeValue ->
    SchemaOf Node
-> (a -> DecodeStateM Node (Map Text b))
-> NodeDecodeArrow a (Map Text b)
forall o a b.
SchemaOf o -> (a -> DecodeStateM o b) -> DecodeArrow o a b
DecodeArrow (SchemaItem Node -> SchemaOf Node
forall a. a -> Schema a
SchemaOne (SchemaItem Node -> SchemaOf Node)
-> SchemaItem Node -> SchemaOf Node
forall a b. (a -> b) -> a -> b
$ TypedValueSchema -> SchemaItem Node
NodeRemainingProps TypedValueSchema
schema) ((a -> DecodeStateM Node (Map Text b))
 -> NodeDecodeArrow a (Map Text b))
-> (a -> DecodeStateM Node (Map Text b))
-> NodeDecodeArrow a (Map Text b)
forall a b. (a -> b) -> a -> b
$ \a
a -> do
      [(Text, b)] -> Map Text b
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, b)] -> Map Text b)
-> StateT (DecodeState Node) DecodeM [(Text, b)]
-> DecodeStateM Node (Map Text b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> DecodeM b)
-> StateT (DecodeState Node) DecodeM [(Text, b)]
forall {b}.
(Value -> DecodeM b)
-> StateT (DecodeState Node) DecodeM [(Text, b)]
go (a -> Value -> DecodeM b
decodeValue a
a)
 where
  go :: (Value -> DecodeM b)
-> StateT (DecodeState Node) DecodeM [(Text, b)]
go Value -> DecodeM b
decodeValue =
    (Text -> Bool)
-> (Value -> DecodeM b)
-> StateT (DecodeState Node) DecodeM (Maybe (Identifier, b))
forall a.
(Text -> Bool)
-> (Value -> DecodeM a)
-> StateT (DecodeState Node) DecodeM (Maybe (Identifier, a))
decodeOnePropWhere (Bool -> Text -> Bool
forall a b. a -> b -> a
const Bool
True) Value -> DecodeM b
decodeValue StateT (DecodeState Node) DecodeM (Maybe (Identifier, b))
-> (Maybe (Identifier, b)
    -> StateT (DecodeState Node) DecodeM [(Text, b)])
-> StateT (DecodeState Node) DecodeM [(Text, b)]
forall a b.
StateT (DecodeState Node) DecodeM a
-> (a -> StateT (DecodeState Node) DecodeM b)
-> StateT (DecodeState Node) DecodeM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (Identifier, b)
Nothing -> [(Text, b)] -> StateT (DecodeState Node) DecodeM [(Text, b)]
forall a. a -> StateT (DecodeState Node) DecodeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      Just (Identifier
name, b
b) -> do
        [(Text, b)]
propMap <- (Value -> DecodeM b)
-> StateT (DecodeState Node) DecodeM [(Text, b)]
go Value -> DecodeM b
decodeValue
        [(Text, b)] -> StateT (DecodeState Node) DecodeM [(Text, b)]
forall a. a -> StateT (DecodeState Node) DecodeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Text, b)] -> StateT (DecodeState Node) DecodeM [(Text, b)])
-> [(Text, b)] -> StateT (DecodeState Node) DecodeM [(Text, b)]
forall a b. (a -> b) -> a -> b
$ (Identifier
name.value, b
b) (Text, b) -> [(Text, b)] -> [(Text, b)]
forall a. a -> [a] -> [a]
: [(Text, b)]
propMap

-- | Decode the children of the node.
--
-- === __Example__
--
-- @
-- let
--   config =
--     """
--     person \"Alice" {
--       email "alice@example.com"
--     }
--     """
--   decoder = KDL.document $ proc () -> do
--     KDL.nodeWith "person" decodePerson -< ()
--   decodePerson = proc () -> do
--     name <- KDL.arg -< ()
--     email <- KDL.children $ KDL.argAt "email" -< ()
--     returnA -< Person{..}
-- KDL.decodeWith decoder config == Right Person{name = \"Alice", email = "alice\@example.com"}
-- @
children :: forall a b. NodeListDecodeArrow a b -> NodeDecodeArrow a b
children :: forall a b. NodeListDecodeArrow a b -> NodeDecodeArrow a b
children NodeListDecodeArrow a b
decoder =
  SchemaOf Node -> (a -> DecodeStateM Node b) -> DecodeArrow Node a b
forall o a b.
SchemaOf o -> (a -> DecodeStateM o b) -> DecodeArrow o a b
DecodeArrow (SchemaItem Node -> SchemaOf Node
forall a. a -> Schema a
SchemaOne (SchemaItem Node -> SchemaOf Node)
-> SchemaItem Node -> SchemaOf Node
forall a b. (a -> b) -> a -> b
$ SchemaOf NodeList -> SchemaItem Node
NodeChildren NodeListDecodeArrow a b
decoder.schema) ((a -> DecodeStateM Node b) -> DecodeArrow Node a b)
-> (a -> DecodeStateM Node b) -> DecodeArrow Node a b
forall a b. (a -> b) -> a -> b
$ \a
a -> do
    Maybe NodeList
mChildren <- (DecodeState Node -> Maybe NodeList)
-> StateT (DecodeState Node) DecodeM (Maybe NodeList)
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
StateT.gets (.object.children)
    DecodeHistory NodeList
childrenHistory <- (DecodeState Node -> DecodeHistory NodeList)
-> StateT (DecodeState Node) DecodeM (DecodeHistory NodeList)
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
StateT.gets (.history.childrenHistory)
    (b
b, DecodeState NodeList
decodeState) <-
      DecodeM (b, DecodeState NodeList)
-> StateT (DecodeState Node) DecodeM (b, DecodeState NodeList)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (DecodeState Node) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (DecodeM (b, DecodeState NodeList)
 -> StateT (DecodeState Node) DecodeM (b, DecodeState NodeList))
-> DecodeM (b, DecodeState NodeList)
-> StateT (DecodeState Node) DecodeM (b, DecodeState NodeList)
forall a b. (a -> b) -> a -> b
$
        StateT (DecodeState NodeList) DecodeM b
-> DecodeState NodeList -> DecodeM (b, DecodeState NodeList)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
StateT.runStateT (NodeListDecodeArrow a b
decoder.run a
a) (DecodeState NodeList -> DecodeM (b, DecodeState NodeList))
-> DecodeState NodeList -> DecodeM (b, DecodeState NodeList)
forall a b. (a -> b) -> a -> b
$
          DecodeState
            { object :: NodeList
object = NodeList -> Maybe NodeList -> NodeList
forall a. a -> Maybe a -> a
fromMaybe NodeList
emptyNodeList Maybe NodeList
mChildren
            , history :: DecodeHistory NodeList
history = DecodeHistory NodeList
childrenHistory
            }
    (DecodeState Node -> DecodeState Node)
-> StateT (DecodeState Node) DecodeM ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
StateT.modify ((DecodeState Node -> DecodeState Node)
 -> StateT (DecodeState Node) DecodeM ())
-> (DecodeState Node -> DecodeState Node)
-> StateT (DecodeState Node) DecodeM ()
forall a b. (a -> b) -> a -> b
$ \DecodeState Node
s ->
      DecodeState Node
s
        { object = s.object{children = decodeState.object <$ mChildren}
        , history = s.history{childrenHistory = decodeState.history}
        }
    b -> DecodeStateM Node b
forall a. a -> StateT (DecodeState Node) DecodeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b
 where
  emptyNodeList :: NodeList
emptyNodeList = NodeList{nodes :: [Node]
nodes = [], ext :: NodeListExtension
ext = NodeListExtension
forall a. Default a => a
def}

{----- Decoding ValueData -----}

withDecodeValue :: forall a r. (DecodeValue a) => ([Text] -> ValueDecoder a -> r) -> r
withDecodeValue :: forall a r. DecodeValue a => ([Text] -> ValueDecoder a -> r) -> r
withDecodeValue [Text] -> ValueDecoder a -> r
k = [Text] -> ValueDecoder a -> r
k (Proxy a -> [Text]
forall a. DecodeValue a => Proxy a -> [Text]
validValueTypeAnns (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)) ValueDecoder a
forall a. DecodeValue a => ValueDecoder a
valueDecoder

withTypedValueDecoder ::
  forall a b r.
  (Typeable b) =>
  (TypedValueSchema -> (a -> Value -> DecodeM b) -> r) ->
  ([Text] -> ValueDecodeArrow a b -> r)
withTypedValueDecoder :: forall a b r.
Typeable b =>
(TypedValueSchema -> (a -> Value -> DecodeM b) -> r)
-> [Text] -> ValueDecodeArrow a b -> r
withTypedValueDecoder TypedValueSchema -> (a -> Value -> DecodeM b) -> r
k [Text]
typeAnns ValueDecodeArrow a b
decoder = TypedValueSchema -> (a -> Value -> DecodeM b) -> r
k TypedValueSchema
schema a -> Value -> DecodeM b
decodeValue
 where
  schema :: TypedValueSchema
schema =
    TypedValueSchema
      { typeHint :: TypeRep
typeHint = Proxy b -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b)
      , validTypeAnns :: [Text]
validTypeAnns = [Text]
typeAnns
      , dataSchema :: SchemaOf Value
dataSchema = ValueDecodeArrow a b
decoder.schema
      }
  decodeValue :: a -> Value -> DecodeM b
decodeValue a
a Value
value = do
    [Text] -> Maybe Ann -> DecodeM ()
validateAnn [Text]
typeAnns Value
value.ann
    Value -> DecodeHistory Value -> DecodeStateM Value b -> DecodeM b
forall o a. o -> DecodeHistory o -> DecodeStateM o a -> DecodeM a
runDecodeStateM Value
value DecodeHistory Value
forall {k} (o :: k). HasDecodeHistory o => DecodeHistory o
emptyDecodeHistory (DecodeStateM Value b -> DecodeM b)
-> DecodeStateM Value b -> DecodeM b
forall a b. (a -> b) -> a -> b
$ do
      -- TODO: add typeHint to Context
      ValueDecodeArrow a b
decoder.run a
a

type ValueDecoder a = ValueDecodeArrow () a
type ValueDecodeArrow a b = DecodeArrow Value a b

-- | The type class for specifying how a type should be decoded from a KDL value.
class (Typeable a) => DecodeValue a where
  -- | Allowed type annotations for a value of this type.
  --
  -- If specified, values with an explicit type annotation MUST match one of the
  -- annotations in this list. Nodes with no type annotations are not checked.
  -- Defaults to @[]@, which means type annotations are ignored.
  --
  -- === __Example__
  --
  -- @
  -- instance DecodeValue Age where
  --   validValueTypeAnns _ = ["age"]
  -- @
  validValueTypeAnns :: Proxy a -> [Text]
  validValueTypeAnns Proxy a
_ = []

  -- | Decode a t'Value' to a value of type @a@
  --
  -- Helpers that may be useful:
  --
  --   * 'oneOf'
  --   * 'withDecoder'
  --   * 'failM'
  valueDecoder :: ValueDecoder a

instance DecodeValue Value where
  valueDecoder :: ValueDecoder Value
valueDecoder = ValueDecoder Value
forall a. DecodeArrow Value a Value
any
instance DecodeValue ValueData where
  valueDecoder :: ValueDecoder ValueData
valueDecoder = (.data_) (Value -> ValueData)
-> ValueDecoder Value -> ValueDecoder ValueData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ValueDecoder Value
forall a. DecodeArrow Value a Value
any
instance DecodeValue Text where
  validValueTypeAnns :: Proxy Text -> [Text]
validValueTypeAnns Proxy Text
_ = [Text
"string"]
  valueDecoder :: ValueDecoder Text
valueDecoder = ValueDecoder Text
forall a. DecodeArrow Value a Text
string
instance DecodeValue String where
  validValueTypeAnns :: Proxy FilePath -> [Text]
validValueTypeAnns Proxy FilePath
_ = [Text
"string"]
  valueDecoder :: ValueDecoder FilePath
valueDecoder = Text -> FilePath
Text.unpack (Text -> FilePath) -> ValueDecoder Text -> ValueDecoder FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ValueDecoder Text
forall a. DecodeArrow Value a Text
string
instance DecodeValue Bool where
  validValueTypeAnns :: Proxy Bool -> [Text]
validValueTypeAnns Proxy Bool
_ = [Text
"bool", Text
"boolean"]
  valueDecoder :: ValueDecoder Bool
valueDecoder = ValueDecoder Bool
forall a. DecodeArrow Value a Bool
bool
instance (DecodeValue a) => DecodeValue (Maybe a) where
  validValueTypeAnns :: Proxy (Maybe a) -> [Text]
validValueTypeAnns Proxy (Maybe a)
_ = Proxy a -> [Text]
forall a. DecodeValue a => Proxy a -> [Text]
validValueTypeAnns (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)
  valueDecoder :: ValueDecoder (Maybe a)
valueDecoder = [ValueDecoder (Maybe a)] -> ValueDecoder (Maybe a)
forall (f :: * -> *) a. Alternative f => [f a] -> f a
oneOf [Maybe a
forall a. Maybe a
Nothing Maybe a -> DecodeArrow Value () () -> ValueDecoder (Maybe a)
forall a b. a -> DecodeArrow Value () b -> DecodeArrow Value () a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ DecodeArrow Value () ()
forall a. DecodeArrow Value a ()
null, a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> DecodeArrow Value () a -> ValueDecoder (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DecodeArrow Value () a
forall a. DecodeValue a => ValueDecoder a
valueDecoder]
instance (DecodeValue a, DecodeValue b) => DecodeValue (Either a b) where
  validValueTypeAnns :: Proxy (Either a b) -> [Text]
validValueTypeAnns Proxy (Either a b)
_ = Proxy a -> [Text]
forall a. DecodeValue a => Proxy a -> [Text]
validValueTypeAnns (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a) [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> Proxy b -> [Text]
forall a. DecodeValue a => Proxy a -> [Text]
validValueTypeAnns (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b)
  valueDecoder :: ValueDecoder (Either a b)
valueDecoder = [ValueDecoder (Either a b)] -> ValueDecoder (Either a b)
forall (f :: * -> *) a. Alternative f => [f a] -> f a
oneOf [a -> Either a b
forall a b. a -> Either a b
Left (a -> Either a b)
-> DecodeArrow Value () a -> ValueDecoder (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DecodeArrow Value () a
forall a. DecodeValue a => ValueDecoder a
valueDecoder, b -> Either a b
forall a b. b -> Either a b
Right (b -> Either a b)
-> DecodeArrow Value () b -> ValueDecoder (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DecodeArrow Value () b
forall a. DecodeValue a => ValueDecoder a
valueDecoder]

decodeInt :: (Integral b, Bounded b) => DecodeArrow Value a b
decodeInt :: forall b a. (Integral b, Bounded b) => DecodeArrow Value a b
decodeInt = DecodeArrow Value a Scientific
-> (Scientific -> DecodeM b) -> DecodeArrow Value a b
forall o a b c.
DecodeArrow o a b -> (b -> DecodeM c) -> DecodeArrow o a c
withDecoder DecodeArrow Value a Scientific
forall a. DecodeArrow Value a Scientific
number ((Scientific -> DecodeM b) -> DecodeArrow Value a b)
-> (Scientific -> DecodeM b) -> DecodeArrow Value a b
forall a b. (a -> b) -> a -> b
$ \Scientific
x -> do
  Bool -> DecodeM () -> DecodeM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Scientific -> Bool
Scientific.isInteger Scientific
x) (DecodeM () -> DecodeM ()) -> DecodeM () -> DecodeM ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> DecodeM ()
forall a. Text -> DecodeM a
failM (Text -> DecodeM ()) -> Text -> DecodeM ()
forall a b. (a -> b) -> a -> b
$ Text
"Expected integer, got: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (FilePath -> Text
Text.pack (FilePath -> Text)
-> (Scientific -> FilePath) -> Scientific -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> FilePath
forall a. Show a => a -> FilePath
show) Scientific
x
  DecodeM b -> (b -> DecodeM b) -> Maybe b -> DecodeM b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> DecodeM b
forall a. Text -> DecodeM a
failM (Text -> DecodeM b) -> Text -> DecodeM b
forall a b. (a -> b) -> a -> b
$ Text
"Number doesn't fit bounds: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (FilePath -> Text
Text.pack (FilePath -> Text)
-> (Scientific -> FilePath) -> Scientific -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> FilePath
forall a. Show a => a -> FilePath
show) Scientific
x) b -> DecodeM b
forall a. a -> DecodeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe b -> DecodeM b) -> Maybe b -> DecodeM b
forall a b. (a -> b) -> a -> b
$
    Scientific -> Maybe b
forall i. (Integral i, Bounded i) => Scientific -> Maybe i
Scientific.toBoundedInteger Scientific
x
instance DecodeValue Integer where
  validValueTypeAnns :: Proxy Integer -> [Text]
validValueTypeAnns Proxy Integer
_ =
    [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [Text
"i8", Text
"i16", Text
"i32", Text
"i64", Text
"i128", Text
"isize"]
      , [Text
"u8", Text
"u16", Text
"u32", Text
"u64", Text
"u128", Text
"usize"]
      ]
  valueDecoder :: ValueDecoder Integer
valueDecoder = Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Int64 -> Integer)
-> DecodeArrow Value () Int64 -> ValueDecoder Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall b a. (Integral b, Bounded b) => DecodeArrow Value a b
decodeInt @Int64
instance DecodeValue Int where
  validValueTypeAnns :: Proxy Int -> [Text]
validValueTypeAnns Proxy Int
_ =
    [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [Text
"i8", Text
"i16", Text
"isize"]
      , if Int
bits Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
32 then [Text
"i32"] else []
      , if Int
bits Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
64 then [Text
"i64"] else []
      ]
   where
    bits :: Int
bits = Int -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize (Int
0 :: Int)
  valueDecoder :: ValueDecoder Int
valueDecoder = ValueDecoder Int
forall b a. (Integral b, Bounded b) => DecodeArrow Value a b
decodeInt
instance DecodeValue Int8 where
  validValueTypeAnns :: Proxy Int8 -> [Text]
validValueTypeAnns Proxy Int8
_ = [Text
"i8"]
  valueDecoder :: ValueDecoder Int8
valueDecoder = ValueDecoder Int8
forall b a. (Integral b, Bounded b) => DecodeArrow Value a b
decodeInt
instance DecodeValue Int16 where
  validValueTypeAnns :: Proxy Int16 -> [Text]
validValueTypeAnns Proxy Int16
_ = [Text
"i16"]
  valueDecoder :: ValueDecoder Int16
valueDecoder = ValueDecoder Int16
forall b a. (Integral b, Bounded b) => DecodeArrow Value a b
decodeInt
instance DecodeValue Int32 where
  validValueTypeAnns :: Proxy Int32 -> [Text]
validValueTypeAnns Proxy Int32
_ = [Text
"i32"]
  valueDecoder :: ValueDecoder Int32
valueDecoder = ValueDecoder Int32
forall b a. (Integral b, Bounded b) => DecodeArrow Value a b
decodeInt
instance DecodeValue Int64 where
  validValueTypeAnns :: Proxy Int64 -> [Text]
validValueTypeAnns Proxy Int64
_ = [Text
"i64"]
  valueDecoder :: DecodeArrow Value () Int64
valueDecoder = DecodeArrow Value () Int64
forall b a. (Integral b, Bounded b) => DecodeArrow Value a b
decodeInt
instance DecodeValue Word where
  validValueTypeAnns :: Proxy Word -> [Text]
validValueTypeAnns Proxy Word
_ =
    [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [Text
"u8", Text
"u16", Text
"usize"]
      , if Int
bits Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
32 then [Text
"u32"] else []
      , if Int
bits Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
64 then [Text
"u64"] else []
      ]
   where
    bits :: Int
bits = Word -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize (Word
0 :: Word)
  valueDecoder :: ValueDecoder Word
valueDecoder = ValueDecoder Word
forall b a. (Integral b, Bounded b) => DecodeArrow Value a b
decodeInt
instance DecodeValue Word8 where
  validValueTypeAnns :: Proxy Word8 -> [Text]
validValueTypeAnns Proxy Word8
_ = [Text
"u8"]
  valueDecoder :: ValueDecoder Word8
valueDecoder = ValueDecoder Word8
forall b a. (Integral b, Bounded b) => DecodeArrow Value a b
decodeInt
instance DecodeValue Word16 where
  validValueTypeAnns :: Proxy Word16 -> [Text]
validValueTypeAnns Proxy Word16
_ = [Text
"u16"]
  valueDecoder :: ValueDecoder Word16
valueDecoder = ValueDecoder Word16
forall b a. (Integral b, Bounded b) => DecodeArrow Value a b
decodeInt
instance DecodeValue Word32 where
  validValueTypeAnns :: Proxy Word32 -> [Text]
validValueTypeAnns Proxy Word32
_ = [Text
"u32"]
  valueDecoder :: ValueDecoder Word32
valueDecoder = ValueDecoder Word32
forall b a. (Integral b, Bounded b) => DecodeArrow Value a b
decodeInt
instance DecodeValue Word64 where
  validValueTypeAnns :: Proxy Word64 -> [Text]
validValueTypeAnns Proxy Word64
_ = [Text
"u64"]
  valueDecoder :: ValueDecoder Word64
valueDecoder = ValueDecoder Word64
forall b a. (Integral b, Bounded b) => DecodeArrow Value a b
decodeInt
instance DecodeValue Natural where
  validValueTypeAnns :: Proxy Natural -> [Text]
validValueTypeAnns Proxy Natural
_ = [Text
"u8", Text
"u16", Text
"u32", Text
"u64", Text
"usize"]
  valueDecoder :: ValueDecoder Natural
valueDecoder = ValueDecoder Integer
-> (Integer -> DecodeM Natural) -> ValueDecoder Natural
forall o a b c.
DecodeArrow o a b -> (b -> DecodeM c) -> DecodeArrow o a c
withDecoder (forall a. DecodeValue a => ValueDecoder a
valueDecoder @Integer) ((Integer -> DecodeM Natural) -> ValueDecoder Natural)
-> (Integer -> DecodeM Natural) -> ValueDecoder Natural
forall a b. (a -> b) -> a -> b
$ \Integer
x -> do
    Bool -> DecodeM () -> DecodeM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0) (DecodeM () -> DecodeM ()) -> DecodeM () -> DecodeM ()
forall a b. (a -> b) -> a -> b
$ do
      Text -> DecodeM ()
forall a. Text -> DecodeM a
failM (Text -> DecodeM ()) -> Text -> DecodeM ()
forall a b. (a -> b) -> a -> b
$ Text
"Expected a non-negative number, got: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (FilePath -> Text
Text.pack (FilePath -> Text) -> (Integer -> FilePath) -> Integer -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> FilePath
forall a. Show a => a -> FilePath
show) Integer
x
    Natural -> DecodeM Natural
forall a. a -> DecodeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Natural -> DecodeM Natural) -> Natural -> DecodeM Natural
forall a b. (a -> b) -> a -> b
$ Integer -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
x

decodeRealFloat :: (RealFloat b) => DecodeArrow Value a b
decodeRealFloat :: forall b a. RealFloat b => DecodeArrow Value a b
decodeRealFloat = DecodeArrow Value a Scientific
-> (Scientific -> DecodeM b) -> DecodeArrow Value a b
forall o a b c.
DecodeArrow o a b -> (b -> DecodeM c) -> DecodeArrow o a c
withDecoder DecodeArrow Value a Scientific
forall a. DecodeArrow Value a Scientific
number ((Scientific -> DecodeM b) -> DecodeArrow Value a b)
-> (Scientific -> DecodeM b) -> DecodeArrow Value a b
forall a b. (a -> b) -> a -> b
$ \Scientific
x -> do
  (b -> DecodeM b) -> (b -> DecodeM b) -> Either b b -> DecodeM b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\b
_ -> Text -> DecodeM b
forall a. Text -> DecodeM a
failM (Text -> DecodeM b) -> Text -> DecodeM b
forall a b. (a -> b) -> a -> b
$ Text
"Number is too small or too large: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (FilePath -> Text
Text.pack (FilePath -> Text)
-> (Scientific -> FilePath) -> Scientific -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> FilePath
forall a. Show a => a -> FilePath
show) Scientific
x) b -> DecodeM b
forall a. a -> DecodeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either b b -> DecodeM b) -> Either b b -> DecodeM b
forall a b. (a -> b) -> a -> b
$
    Scientific -> Either b b
forall a. RealFloat a => Scientific -> Either a a
Scientific.toBoundedRealFloat Scientific
x
instance DecodeValue Scientific where
  validValueTypeAnns :: Proxy Scientific -> [Text]
validValueTypeAnns Proxy Scientific
_ = [Text
"f32", Text
"f64", Text
"decimal64", Text
"decimal128"]
  valueDecoder :: ValueDecoder Scientific
valueDecoder = ValueDecoder Scientific
forall a. DecodeArrow Value a Scientific
number
instance DecodeValue Float where
  validValueTypeAnns :: Proxy Float -> [Text]
validValueTypeAnns Proxy Float
_ = [Text
"f32"]
  valueDecoder :: ValueDecoder Float
valueDecoder = ValueDecoder Float
forall b a. RealFloat b => DecodeArrow Value a b
decodeRealFloat
instance DecodeValue Double where
  validValueTypeAnns :: Proxy Double -> [Text]
validValueTypeAnns Proxy Double
_ = [Text
"f64"]
  valueDecoder :: ValueDecoder Double
valueDecoder = ValueDecoder Double
forall b a. RealFloat b => DecodeArrow Value a b
decodeRealFloat
instance DecodeValue Rational where
  validValueTypeAnns :: Proxy Rational -> [Text]
validValueTypeAnns Proxy Rational
_ = [Text
"decimal64", Text
"decimal128"]
  valueDecoder :: ValueDecoder Rational
valueDecoder = ValueDecoder Scientific
-> (Scientific -> DecodeM Rational) -> ValueDecoder Rational
forall o a b c.
DecodeArrow o a b -> (b -> DecodeM c) -> DecodeArrow o a c
withDecoder ValueDecoder Scientific
forall a. DecodeArrow Value a Scientific
number ((Scientific -> DecodeM Rational) -> ValueDecoder Rational)
-> (Scientific -> DecodeM Rational) -> ValueDecoder Rational
forall a b. (a -> b) -> a -> b
$ \Scientific
x -> do
    -- Use toBoundedRealFloat to guard against large values, but use
    -- toRational after checking to maintain precision
    case forall a. RealFloat a => Scientific -> Either a a
Scientific.toBoundedRealFloat @Double Scientific
x of
      Right Double
_ -> Rational -> DecodeM Rational
forall a. a -> DecodeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rational -> DecodeM Rational) -> Rational -> DecodeM Rational
forall a b. (a -> b) -> a -> b
$ Scientific -> Rational
forall a. Real a => a -> Rational
toRational Scientific
x
      Left Double
_ -> Text -> DecodeM Rational
forall a. Text -> DecodeM a
failM (Text -> DecodeM Rational) -> Text -> DecodeM Rational
forall a b. (a -> b) -> a -> b
$ Text
"Number is too small or too large: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (FilePath -> Text
Text.pack (FilePath -> Text)
-> (Scientific -> FilePath) -> Scientific -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> FilePath
forall a. Show a => a -> FilePath
show) Scientific
x

valueDataDecoderPrim :: SchemaOf Value -> (Value -> DecodeM b) -> DecodeArrow Value a b
valueDataDecoderPrim :: forall b a.
SchemaOf Value -> (Value -> DecodeM b) -> DecodeArrow Value a b
valueDataDecoderPrim SchemaOf Value
schema Value -> DecodeM b
f = SchemaOf Value
-> (a -> DecodeStateM Value b) -> DecodeArrow Value a b
forall o a b.
SchemaOf o -> (a -> DecodeStateM o b) -> DecodeArrow o a b
DecodeArrow SchemaOf Value
schema ((a -> DecodeStateM Value b) -> DecodeArrow Value a b)
-> (a -> DecodeStateM Value b) -> DecodeArrow Value a b
forall a b. (a -> b) -> a -> b
$ \a
_ -> DecodeM b -> DecodeStateM Value b
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (DecodeState Value) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (DecodeM b -> DecodeStateM Value b)
-> (Value -> DecodeM b) -> Value -> DecodeStateM Value b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> DecodeM b
f (Value -> DecodeStateM Value b)
-> StateT (DecodeState Value) DecodeM Value -> DecodeStateM Value b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (DecodeState Value -> Value)
-> StateT (DecodeState Value) DecodeM Value
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
StateT.gets (.object)

-- | Decode any value, without any possibility of failure.
any :: DecodeArrow Value a Value
any :: forall a. DecodeArrow Value a Value
any = SchemaOf Value
-> (Value -> DecodeM Value) -> DecodeArrow Value a Value
forall b a.
SchemaOf Value -> (Value -> DecodeM b) -> DecodeArrow Value a b
valueDataDecoderPrim ([SchemaOf Value] -> SchemaOf Value
forall a. [Schema a] -> Schema a
SchemaOr ([SchemaOf Value] -> SchemaOf Value)
-> [SchemaOf Value] -> SchemaOf Value
forall a b. (a -> b) -> a -> b
$ (SchemaItem Value -> SchemaOf Value)
-> [SchemaItem Value] -> [SchemaOf Value]
forall a b. (a -> b) -> [a] -> [b]
map SchemaItem Value -> SchemaOf Value
forall a. a -> Schema a
SchemaOne [SchemaItem Value
forall a. Bounded a => a
minBound .. SchemaItem Value
forall a. Bounded a => a
maxBound]) Value -> DecodeM Value
forall a. a -> DecodeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Decode a KDL string value.
string :: DecodeArrow Value a Text
string :: forall a. DecodeArrow Value a Text
string = SchemaOf Value
-> (Value -> DecodeM Text) -> DecodeArrow Value a Text
forall b a.
SchemaOf Value -> (Value -> DecodeM b) -> DecodeArrow Value a b
valueDataDecoderPrim (SchemaItem Value -> SchemaOf Value
forall a. a -> Schema a
SchemaOne SchemaItem Value
TextSchema) ((Value -> DecodeM Text) -> DecodeArrow Value a Text)
-> (Value -> DecodeM Text) -> DecodeArrow Value a Text
forall a b. (a -> b) -> a -> b
$ \case
  Value{data_ :: Value -> ValueData
data_ = String Text
s} -> Text -> DecodeM Text
forall a. a -> DecodeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
s
  Value
v -> DecodeErrorKind -> DecodeM Text
forall a. DecodeErrorKind -> DecodeM a
decodeThrow DecodeError_ValueDecodeFail{expectedType :: Text
expectedType = Text
"string", value :: Value
value = Value
v}

-- | Decode a KDL number value.
number :: DecodeArrow Value a Scientific
number :: forall a. DecodeArrow Value a Scientific
number = SchemaOf Value
-> (Value -> DecodeM Scientific) -> DecodeArrow Value a Scientific
forall b a.
SchemaOf Value -> (Value -> DecodeM b) -> DecodeArrow Value a b
valueDataDecoderPrim (SchemaItem Value -> SchemaOf Value
forall a. a -> Schema a
SchemaOne SchemaItem Value
NumberSchema) ((Value -> DecodeM Scientific) -> DecodeArrow Value a Scientific)
-> (Value -> DecodeM Scientific) -> DecodeArrow Value a Scientific
forall a b. (a -> b) -> a -> b
$ \case
  Value{data_ :: Value -> ValueData
data_ = Number Scientific
x} -> Scientific -> DecodeM Scientific
forall a. a -> DecodeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Scientific
x
  Value
v -> DecodeErrorKind -> DecodeM Scientific
forall a. DecodeErrorKind -> DecodeM a
decodeThrow DecodeError_ValueDecodeFail{expectedType :: Text
expectedType = Text
"number", value :: Value
value = Value
v}

-- | Decode a KDL bool value.
bool :: DecodeArrow Value a Bool
bool :: forall a. DecodeArrow Value a Bool
bool = SchemaOf Value
-> (Value -> DecodeM Bool) -> DecodeArrow Value a Bool
forall b a.
SchemaOf Value -> (Value -> DecodeM b) -> DecodeArrow Value a b
valueDataDecoderPrim (SchemaItem Value -> SchemaOf Value
forall a. a -> Schema a
SchemaOne SchemaItem Value
BoolSchema) ((Value -> DecodeM Bool) -> DecodeArrow Value a Bool)
-> (Value -> DecodeM Bool) -> DecodeArrow Value a Bool
forall a b. (a -> b) -> a -> b
$ \case
  Value{data_ :: Value -> ValueData
data_ = Bool Bool
x} -> Bool -> DecodeM Bool
forall a. a -> DecodeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
x
  Value
v -> DecodeErrorKind -> DecodeM Bool
forall a. DecodeErrorKind -> DecodeM a
decodeThrow DecodeError_ValueDecodeFail{expectedType :: Text
expectedType = Text
"bool", value :: Value
value = Value
v}

-- | Decode a KDL null value.
null :: DecodeArrow Value a ()
null :: forall a. DecodeArrow Value a ()
null = SchemaOf Value -> (Value -> DecodeM ()) -> DecodeArrow Value a ()
forall b a.
SchemaOf Value -> (Value -> DecodeM b) -> DecodeArrow Value a b
valueDataDecoderPrim (SchemaItem Value -> SchemaOf Value
forall a. a -> Schema a
SchemaOne SchemaItem Value
NullSchema) ((Value -> DecodeM ()) -> DecodeArrow Value a ())
-> (Value -> DecodeM ()) -> DecodeArrow Value a ()
forall a b. (a -> b) -> a -> b
$ \case
  Value{data_ :: Value -> ValueData
data_ = ValueData
Null} -> () -> DecodeM ()
forall a. a -> DecodeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  Value
v -> DecodeErrorKind -> DecodeM ()
forall a. DecodeErrorKind -> DecodeM a
decodeThrow DecodeError_ValueDecodeFail{expectedType :: Text
expectedType = Text
"null", value :: Value
value = Value
v}

{----- Utilities -----}

-- | Return the first result that succeeds.
--
-- > oneOf [a, b, c] === a <|> b <|> c
oneOf :: (Alternative f) => [f a] -> f a
oneOf :: forall (f :: * -> *) a. Alternative f => [f a] -> f a
oneOf [f a]
ms =
  -- Avoid 'empty' if possible
  case [f a] -> Maybe (NonEmpty (f a))
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty [f a]
ms of
    Just NonEmpty (f a)
ms' -> (f a -> f a -> f a) -> NonEmpty (f a) -> f a
forall a. (a -> a -> a) -> NonEmpty a -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 f a -> f a -> f a
forall a. f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) NonEmpty (f a)
ms'
    Maybe (NonEmpty (f a))
Nothing -> f a
forall a. f a
forall (f :: * -> *) a. Alternative f => f a
empty

-- | Return the given default value if the given action fails.
--
-- > option a f === f <|> pure a
option :: (Alternative f) => a -> f a -> f a
option :: forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option a
a f a
f = f a
f f a -> f a -> f a
forall a. f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> a -> f a
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

extractFirst :: (a -> Bool) -> [a] -> Maybe (a, [a])
extractFirst :: forall a. (a -> Bool) -> [a] -> Maybe (a, [a])
extractFirst a -> Bool
f = [a] -> Maybe (a, [a])
go
 where
  go :: [a] -> Maybe (a, [a])
go = \case
    [] -> Maybe (a, [a])
forall a. Maybe a
Nothing
    a
x : [a]
xs ->
      if a -> Bool
f a
x
        then (a, [a]) -> Maybe (a, [a])
forall a. a -> Maybe a
Just (a
x, [a]
xs)
        else ([a] -> [a]) -> (a, [a]) -> (a, [a])
forall a b. (a -> b) -> (a, a) -> (a, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a
x :) ((a, [a]) -> (a, [a])) -> Maybe (a, [a]) -> Maybe (a, [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> Maybe (a, [a])
go [a]
xs