kdl-hs 0.1.0 → 0.2.0

raw patch · 40 files changed

+5391/−5922 lines, 40 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• README.md +2/−2
• kdl-hs.cabal +21/−18
• src/Data/KDL.hs +0/−70
• src/Data/KDL/Decoder/Arrow.hs +0/−1278
• src/Data/KDL/Decoder/DecodeM.hs +0/−94
• src/Data/KDL/Decoder/Error.hs +0/−96
• src/Data/KDL/Decoder/Monad.hs +0/−687
• src/Data/KDL/Decoder/Schema.hs +0/−80
• src/Data/KDL/Parser.hs +0/−91
• src/Data/KDL/Parser/Hustle.hs +0/−28
• src/Data/KDL/Parser/Hustle/Formatter.hs +0/−83
• src/Data/KDL/Parser/Hustle/Internal.hs +0/−96
• src/Data/KDL/Parser/Hustle/Parser.hs +0/−310
• src/Data/KDL/Parser/Hustle/Types.hs +0/−73
• src/Data/KDL/Render.hs +0/−132
• src/Data/KDL/Types.hs +0/−367
• src/KDL.hs +74/−0
• src/KDL/Arrow.hs +78/−0
• src/KDL/Decoder.hs +10/−0
• src/KDL/Decoder/Arrow.hs +1060/−0
• src/KDL/Decoder/Internal/DecodeM.hs +94/−0
• src/KDL/Decoder/Internal/Decoder.hs +205/−0
• src/KDL/Decoder/Internal/Error.hs +96/−0
• src/KDL/Decoder/Monad.hs +25/−0
• src/KDL/Decoder/Schema.hs +84/−0
• src/KDL/Parser.hs +91/−0
• src/KDL/Parser/Hustle.hs +28/−0
• src/KDL/Parser/Hustle/Formatter.hs +83/−0
• src/KDL/Parser/Hustle/Internal.hs +96/−0
• src/KDL/Parser/Hustle/Parser.hs +310/−0
• src/KDL/Parser/Hustle/Types.hs +73/−0
• src/KDL/Render.hs +132/−0
• src/KDL/Types.hs +367/−0
• test/Data/KDL/Decoder/ArrowSpec.hs +0/−1182
• test/Data/KDL/Decoder/MonadSpec.hs +0/−1122
• test/Data/KDL/ParserSpec.hs +0/−113
• test/KDL/Decoder/ArrowSpec.hs +1219/−0
• test/KDL/Decoder/MonadSpec.hs +1122/−0
• test/KDL/ParserSpec.hs +113/−0

@@ -1,3 +1,11 @@+## v0.2.0++* Remove monad `Decoder` newtype, just give the `Monad` instance to the canonical `Decoder` type and use the same `Decoder` type everywhere+* Reorganize module structure+* Schema improvements+* Rename `Decoder` => `DecodeArrow`, set `Decoder o a` as alias for `DecodeArrow o () a`+* Use v2 syntax for `#true`/`#false`/`#null`+ ## v0.1.0  Initial release, with:

@@ -24,14 +24,14 @@ Parse it with `kdl-hs`:  ```hs-import Data.KDL qualified as KDL+import KDL qualified  main :: IO () main = do   config <- KDL.decodeFileWith decoder "config.kdl"   print config -decoder :: KDL.Decoder Config+decoder :: KDL.DocumentDecoder Config decoder = KDL.document $ do   KDL.node "package" 

@@ -1,7 +1,7 @@ cabal-version: 3.0  name: kdl-hs-version: 0.1.0+version: 0.2.0 synopsis: KDL language parser and API description: KDL language parser and API. homepage: https://github.com/brandonchinn178/kdl-hs#readme@@ -23,21 +23,24 @@ library   hs-source-dirs: src   exposed-modules:-    Data.KDL-    Data.KDL.Decoder.Arrow-    Data.KDL.Decoder.DecodeM-    Data.KDL.Decoder.Error-    Data.KDL.Decoder.Monad-    Data.KDL.Decoder.Schema-    Data.KDL.Parser-    Data.KDL.Render-    Data.KDL.Types+    KDL+    KDL.Arrow+    KDL.Decoder+    KDL.Decoder.Arrow+    KDL.Decoder.Internal.DecodeM+    KDL.Decoder.Internal.Decoder+    KDL.Decoder.Internal.Error+    KDL.Decoder.Monad+    KDL.Decoder.Schema+    KDL.Parser+    KDL.Render+    KDL.Types   other-modules:-    Data.KDL.Parser.Hustle-    Data.KDL.Parser.Hustle.Formatter-    Data.KDL.Parser.Hustle.Internal-    Data.KDL.Parser.Hustle.Parser-    Data.KDL.Parser.Hustle.Types+    KDL.Parser.Hustle+    KDL.Parser.Hustle.Formatter+    KDL.Parser.Hustle.Internal+    KDL.Parser.Hustle.Parser+    KDL.Parser.Hustle.Types   build-depends:       base < 5     , containers@@ -56,9 +59,9 @@   hs-source-dirs: test   main-is: Main.hs   other-modules:-    Data.KDL.ParserSpec-    Data.KDL.Decoder.ArrowSpec-    Data.KDL.Decoder.MonadSpec+    KDL.ParserSpec+    KDL.Decoder.ArrowSpec+    KDL.Decoder.MonadSpec   build-depends:       base     , containers

@@ -1,70 +0,0 @@-{-|-This module is intended to be imported qualified as:--> import Data.KDL qualified as KDL--= Quickstart--Given a file @config.kdl@:--@-package {-  name my-pkg-  version "1.2.3"--  dependencies {-    aeson ">= 2.2.3.0" optional=#true-    text ">= 2"-  }-}-@--Parse it with @kdl-hs@:--@-import Data.KDL qualified as KDL--main :: IO ()-main = do-  config <- KDL.decodeFileWith decoder "config.kdl"-  print config--decoder :: KDL.Decoder Config-decoder = KDL.document $ do-  KDL.node "package"--data Config = Config-  { name :: Text-  , version :: Text-  , dependencies :: Map Text Dep-  }-  deriving (Show)--data Dep = Dep-  { version :: Text-  , optional :: Bool-  }-  deriving (Show)--instance KDL.DecodeNode Config where-  nodeDecoder = KDL.noSchema $ do-    name <- KDL.argAt "name"-    version <- KDL.argAt "version"-    dependencies <- KDL.nodeWith "dependencies" . KDL.children $ KDL.remainingNodes-    pure Config{..}--instance KDL.DecodeNode Dep where-  nodeDecoder = KDL.noSchema $ do-    version <- KDL.arg-    optional <- KDL.option False $ KDL.prop "optional"-    pure Dep{..}-@--}-module Data.KDL (-  module X,-) where--import Data.KDL.Decoder.Monad as X-import Data.KDL.Parser as X-import Data.KDL.Render as X-import Data.KDL.Types as X

@@ -1,1278 +0,0 @@-{-# LANGUAGE Arrows #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedRecordDot #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}--{-|-This module defines the Arrow interface for decoding a KDL document. Intended to-be imported qualified as:--> import Data.KDL.Decoder.Arrow qualified as KDL--For most use-cases, the Monad interface exported by "Data.KDL" is sufficient. You-may wish to use the Arrow interface if you would like to statically analyze a-decoder's schema, e.g. to generate documentation.--= Quickstart--Given a file @config.kdl@:--@-package {-  name my-pkg-  version "1.2.3"--  dependencies {-    aeson ">= 2.2.3.0" optional=#true-    text ">= 2"-  }-}-@--Parse it with:--@-{\-# LANGUAGE Arrows #-\}--import Data.KDL.Decoder.Arrow qualified as KDL--main :: IO ()-main = do-  config <- KDL.decodeFileWith decoder "config.kdl"-  print config--decoder :: KDL.Decoder Config-decoder = KDL.document $ proc () -> do-  KDL.node "package" -< ()--data Config = Config-  { name :: Text-  , version :: Text-  , dependencies :: Map Text Dep-  }-  deriving (Show)--data Dep = Dep-  { version :: Text-  , optional :: Bool-  }-  deriving (Show)--instance KDL.DecodeNode Config where-  nodeDecoder = proc () -> do-    name <- KDL.argAt "name" -< ()-    version <- KDL.argAt "version" -< ()-    dependencies <- KDL.nodeWith "dependencies" . KDL.children $ KDL.remainingNodes -< ()-    returnA -< Config{..}--instance KDL.DecodeNode Dep where-  nodeDecoder = proc () -> do-    version <- KDL.arg -< ()-    optional <- KDL.option False $ KDL.prop "optional" -< ()-    returnA -< Dep{..}-@--}-module Data.KDL.Decoder.Arrow (-  decodeWith,-  decodeFileWith,-  decodeDocWith,--  -- * Decoder-  Decoder (..),-  module Data.KDL.Decoder.DecodeM,-  fail,-  withDecoder,-  debug,--  -- * Document-  DocumentDecoder (..),-  document,-  documentSchema,--  -- * NodeList-  NodeListDecoder,-  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,-  DecodeNode (..),-  arg,-  prop,-  remainingProps,-  children,--  -- ** Explicitly specify decoders-  argWith,-  propWith,-  remainingPropsWith,--  -- ** Explicitly specify decoders and type annotations-  argWith',-  propWith',-  remainingPropsWith',--  -- * Value-  ValueDecoder,-  DecodeValue (..),-  any,-  text,-  number,-  bool,-  null,--  -- * Combinators-  oneOf,-  many,-  optional,-  option,-  some,--  -- * Internal API-  DecodeStateM,-  runDecodeStateM,-  HasDecodeHistory (..),-  DecodeState (..),-) where--import Control.Applicative (-  Alternative (..),-  optional,- )-import Control.Arrow (Arrow (..), ArrowChoice (..), (>>>))-import Control.Category (Category)-import Control.Category qualified-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.Bits (finiteBitSize)-import Data.Int (Int64)-import Data.KDL.Decoder.DecodeM-import Data.KDL.Decoder.Schema (-  Schema (..),-  SchemaItem (..),-  SchemaOf,-  TypedNodeSchema (..),-  TypedValueSchema (..),-  schemaAlt,-  schemaJoin,- )-import Data.KDL.Parser (parse, parseFile)-import Data.KDL.Types (-  Ann (..),-  Document,-  Entry (..),-  Identifier (..),-  Node (..),-  NodeList (..),-  Value (..),-  ValueData (..),- )-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 (Set)-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 Debug.Trace (traceM)-import GHC.Int (Int16, Int32, Int8)-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 decoder = decodeFromParseResult decoder . 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 decoder = fmap (decodeFromParseResult decoder) . parseFile---- | Decode an already-parsed 'Document' with the given decoder.-decodeDocWith :: DocumentDecoder a -> Document -> Either DecodeError a-decodeDocWith (UnsafeDocumentDecoder decoder) doc =-  runDecodeM . runDecodeStateM doc emptyDecodeHistory $-    decoder.run ()--decodeFromParseResult :: DocumentDecoder a -> Either Text Document -> Either DecodeError a-decodeFromParseResult decoder = \case-  Left e -> runDecodeM . decodeThrow $ DecodeError_ParseError e-  Right doc -> decodeDocWith decoder doc--{----- Decoder -----}--class HasDecodeHistory o where-  data DecodeHistory o-  emptyDecodeHistory :: DecodeHistory o---- | The state to track when decoding an object of type @o@.------ At each decode step, some value within @o@ is consumed and--- the action is recorded in the history.-data DecodeState o = DecodeState-  { object :: !o-  , history :: DecodeHistory o-  -- ^ Not strict, since this only matters for reporting errors-  }--type DecodeStateM o a = StateT (DecodeState o) DecodeM a---- | @Decoder o a b@ represents an arrow with input @a@ and output @b@, within--- the context of decoding a KDL object of type @o@. It also knows the expected--- schema of @o@.------ We're using arrows here so that we can:------   1. Get the schema without running the decoder, and also---   2. Use previously decoded values to inform decoding other values------ Using monads alone would lose (1), but applicatives can't do (2).-data Decoder o a b = Decoder-  { schema :: SchemaOf o-  , run :: a -> DecodeStateM o b-  }--instance Category (Decoder o) where-  id = liftDecodeM pure-  Decoder sch2 bc . Decoder sch1 ab = Decoder (sch1 `schemaJoin` sch2) $ ab >=> bc-instance Arrow (Decoder o) where-  arr f = liftDecodeM (pure . f)-  Decoder sch1 bc *** Decoder sch2 bc' =-    Decoder (sch1 `schemaJoin` sch2) $ \(b, b') -> (,) <$> bc b <*> bc' b'-instance ArrowChoice (Decoder o) where-  Decoder sch1 bc +++ Decoder sch2 bc' =-    Decoder (sch1 `schemaAlt` sch2) $ either (fmap Left . bc) (fmap Right . bc')--instance Functor (Decoder o a) where-  fmap f (Decoder schema run) = Decoder schema $ (fmap f . run)-instance Applicative (Decoder o a) where-  pure = arr . const-  Decoder sch1 kf <*> Decoder sch2 kx =-    Decoder (sch1 `schemaJoin` sch2) $ \a -> kf a <*> kx a-instance Alternative (Decoder o a) where-  -- Can't use StateT's Alternative instance: https://hub.darcs.net/ross/transformers/issue/78-  empty = Decoder (SchemaOr []) $ \_ -> Trans.lift empty-  Decoder sch1 run1 <|> Decoder sch2 run2 =-    Decoder (sch1 `schemaAlt` sch2) $ \a -> StateT.StateT $ \s -> do-      StateT.runStateT (run1 a) s <|> StateT.runStateT (run2 a) s-  some (Decoder sch run) =-    Decoder (SchemaSome sch) $ \a ->-      StateT.StateT $-        let go s0 = do-              (x, s1) <- StateT.runStateT (run a) s0-              (xs, s2) <- go s1 <|> pure ([], s1)-              pure (x : xs, s2)-         in go-  many (Decoder sch run) = some (Decoder sch run) <|> pure []--liftDecodeM :: (a -> DecodeM b) -> Decoder o a b-liftDecodeM f = Decoder (SchemaAnd []) (Trans.lift . f)---- | Run actions within a t'Decoder'. Useful for adding post-processing logic.------ === __Example__------ @--- decoder = KDL.withDecoder KDL.number $ \\x -> do---   when (x > 100)---     KDL.failM $ "argument is too large: " <> (Text.pack . show) x---   pure $ MyVal x--- @-withDecoder :: forall o a b c. Decoder o a b -> (b -> DecodeM c) -> Decoder o a c-withDecoder decoder f = decoder >>> liftDecodeM f--runDecodeStateM :: o -> DecodeHistory o -> DecodeStateM o a -> DecodeM a-runDecodeStateM o hist m =-  StateT.evalStateT m $-    DecodeState-      { object = o-      , history = hist-      }---- | Unconditionally fail the decoder.------ === __Example__------ @--- decoder = proc () -> do---   x <- KDL.arg -< ()---   if x > 100---     then KDL.fail -\< "argument is too large: " <> (Text.pack . show) x---     else returnA -< ()---   returnA -< x--- @-fail :: forall b o. Decoder o Text b-fail = liftDecodeM failM---- | Debug the current state of the object being decoded.------ === __Example__------ @--- decoder = proc () -> do---   KDL.debug -< ()    -- Node{entries = [Entry{}, Entry{}]}---   x <- KDL.arg -< ()---   KDL.debug -< ()    -- Node{entries = [Entry{}]}---   y <- KDL.arg -< ()---   KDL.debug -< ()    -- Node{entries = []}---   returnA -< (x, y)--- @-debug :: forall o a. (Show o) => Decoder o a ()-debug =-  Decoder (SchemaAnd []) $ \_ -> do-    o <- StateT.gets (.object)-    traceM $ "[kdl-hs] DEBUG: " ++ show o--{----- 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 decoder =-  UnsafeDocumentDecoder-    decoder-      { run = \() -> do-          a <- decoder.run ()-          validateNodeList-          pure a-      }---- | Get the schema of a 'DocumentDecoder'.------ The schema is statically determined without running the decoder.-documentSchema :: DocumentDecoder a -> SchemaOf NodeList-documentSchema (UnsafeDocumentDecoder decoder) = decoder.schema--{----- Decoding NodeList -----}--type NodeListDecoder = Decoder NodeList-instance HasDecodeHistory NodeList where-  data DecodeHistory NodeList = DecodeHistory_NodeList-    { nodesSeen :: Map Text Int-    }-  emptyDecodeHistory = DecodeHistory_NodeList{nodesSeen = Map.empty}--getNodeIndex :: Text -> DecodeState NodeList -> Int-getNodeIndex name = Map.findWithDefault 0 name . (.history.nodesSeen)--validateNodeList :: StateT (DecodeState NodeList) DecodeM ()-validateNodeList = do-  nodeList <- StateT.gets (.object)-  case nodeList.nodes of-    [] -> pure ()-    node_ : _ -> do-      let identifier = node_.name-      index <- StateT.gets (getNodeIndex identifier.value)-      Trans.lift . decodeThrow $-        DecodeError_UnexpectedNode-          { identifier = identifier-          , index = 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 name = withDecodeNode $ nodeWith' 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 -> NodeDecoder a b -> NodeListDecoder a b-nodeWith name = nodeWith' name []---- | Same as 'nodeWith', except allow specifying type annotations.-nodeWith' :: forall a b. (Typeable b) => Text -> [Text] -> NodeDecoder a b -> NodeListDecoder a b-nodeWith' name =-  withTypedNodeDecoder $ \schema decodeNode ->-    Decoder (SchemaOne $ NodeNamed name schema) $ \a -> do-      decodeFirstNodeWhere ((== name) . (.name.value)) (decodeNode a) >>= \case-        Just (_, b) -> pure b-        Nothing -> do-          index <- StateT.gets (getNodeIndex name)-          Trans.lift $ decodeThrow DecodeError_ExpectedNode{name = name, index = index}--decodeFirstNodeWhere ::-  (Node -> Bool) ->-  (Node -> DecodeM a) ->-  StateT (DecodeState NodeList) DecodeM (Maybe (Node, a))-decodeFirstNodeWhere matcher decodeNode = do-  nodes <- StateT.gets (.object.nodes)-  case extractFirst matcher nodes of-    Nothing -> do-      pure Nothing-    Just (node_, nodes') -> do-      let name = node_.name-      index <- StateT.gets (getNodeIndex name.value)-      StateT.modify $ \s -> s{object = s.object{nodes = nodes'}}-      b <--        Trans.lift . makeFatal . addContext ContextNode{name = name, index = index} $-          decodeNode node_-      StateT.modify $ \s -> s{history = s.history{nodesSeen = inc name.value s.history.nodesSeen}}-      pure $ Just (node_, b)- where-  inc k = Map.insertWith (+) k 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 = withDecodeNode 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) => NodeDecoder a b -> NodeListDecoder a (Map Text [b])--- TODO: Detect duplicate `remainingNodes` calls and fail to build a decoder-remainingNodesWith = remainingNodesWith' []---- | Same as 'remainingNodesWith', except allow specifying type annotations.-remainingNodesWith' :: forall a b. (Typeable b) => [Text] -> NodeDecoder a b -> NodeListDecoder a (Map Text [b])--- TODO: Detect duplicate `remainingNodes` calls and fail to build a decoder-remainingNodesWith' =-  withTypedNodeDecoder $ \schema decodeNode ->-    Decoder (SchemaOne $ RemainingNodes schema) $ \a -> do-      Map.fromListWith (<>) <$> go (decodeNode a)- where-  go decodeNode = do-    decodeFirstNodeWhere (const True) decodeNode >>= \case-      Nothing -> pure []-      Just (node_, b) -> do-        nodeMap <- go decodeNode-        pure $ (node_.name.value, [b]) : 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 name = withDecodeValue $ argAtWith' 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 -> ValueDecoder a b -> NodeListDecoder a b-argAtWith name = argAtWith' name []---- | Same as 'argAtWith', except allow specifying type annotations.-argAtWith' :: forall a b. (Typeable b) => Text -> [Text] -> ValueDecoder a b -> NodeListDecoder a b-argAtWith' name typeAnns decoder = nodeWith name $ argWith' typeAnns 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 name = withDecodeValue $ argsAtWith' 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.text -< ()--- KDL.decodeWith decoder config == Right ["a@example.com", "b@example.com"]--- @-argsAtWith :: forall a b. (Typeable b) => Text -> ValueDecoder a b -> NodeListDecoder a [b]-argsAtWith name = argsAtWith' name []---- | Same as 'argsAtWith', except allow specifying type annotations.-argsAtWith' :: forall a b. (Typeable b) => Text -> [Text] -> ValueDecoder a b -> NodeListDecoder a [b]-argsAtWith' name typeAnns decoder = option [] $ nodeWith name $ many $ argWith' typeAnns 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 name = withDecodeValue $ dashChildrenAtWith' 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.text -< ()--- KDL.decodeWith decoder config == Right [\"Alice", \"Bob"]--- @-dashChildrenAtWith :: forall a b. (Typeable b) => Text -> ValueDecoder a b -> NodeListDecoder a [b]-dashChildrenAtWith name = dashChildrenAtWith' name []---- | Same as 'dashChildrenAtWith', except allow specifying type annotations.-dashChildrenAtWith' :: forall a b. (Typeable b) => Text -> [Text] -> ValueDecoder a b -> NodeListDecoder a [b]-dashChildrenAtWith' name typeAnns decoder = dashNodesAtWith name $ argWith' typeAnns 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 name = withDecodeNode $ \_ decoder -> dashNodesAtWith name 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 -> NodeDecoder a b -> NodeListDecoder a [b]-dashNodesAtWith name decoder =-  option [] . nodeWith name $-    children $-      many (nodeWith "-" decoder)--{----- Decoding Ann -----}--validateAnn :: [Text] -> Maybe Ann -> DecodeM ()-validateAnn typeAnns mGivenAnn =-  case mGivenAnn of-    Nothing -> pure ()-    Just givenAnn -> do-      let isValidAnn = Prelude.null typeAnns || givenAnn.identifier.value `elem` typeAnns-      unless isValidAnn $ do-        decodeThrow DecodeError_MismatchedAnn{givenAnn = givenAnn.identifier, validAnns = typeAnns}--{----- Decoding Node -----}--withDecodeNode :: forall a r. (DecodeNode a) => ([Text] -> NodeDecoder () a -> r) -> r-withDecodeNode k = k (validNodeTypeAnns (Proxy @a)) nodeDecoder--withTypedNodeDecoder ::-  forall a b r.-  (Typeable b) =>-  (TypedNodeSchema -> (a -> Node -> DecodeM b) -> r) ->-  ([Text] -> NodeDecoder a b -> r)-withTypedNodeDecoder k typeAnns decoder = k schema decodeNode- where-  schema =-    TypedNodeSchema-      { typeHint = typeRep (Proxy @b)-      , validTypeAnns = typeAnns-      , nodeSchema = decoder.schema-      }-  decodeNode a node_ = do-    validateAnn typeAnns node_.ann-    runDecodeStateM node_ emptyDecodeHistory $ do-      -- TODO: add typeHint to Context-      decoder.run a <* validateNode--validateNode :: StateT (DecodeState Node) DecodeM ()-validateNode = do-  node_ <- StateT.gets (.object)-  case node_.entries of-    [] -> pure ()-    Entry{name = Nothing, value} : _ -> do-      index <- StateT.gets getArgIndex-      Trans.lift . decodeThrow $-        DecodeError_UnexpectedArg-          { index = index-          , value = value-          }-    Entry{name = Just identifier, value} : _ -> do-      Trans.lift . decodeThrow $-        DecodeError_UnexpectedProp-          { identifier = identifier-          , value = value-          }-  case node_.children of-    Nothing -> pure ()-    Just children_ -> do-      childrenHistory <- StateT.gets (.history.childrenHistory)-      Trans.lift . runDecodeStateM children_ childrenHistory $ validateNodeList--type NodeDecoder = Decoder Node-instance HasDecodeHistory Node where-  data DecodeHistory Node = DecodeHistory_Node-    { argsSeen :: Int-    , propsSeen :: Set Identifier-    , childrenHistory :: DecodeHistory NodeList-    }-  emptyDecodeHistory =-    DecodeHistory_Node-      { argsSeen = 0-      , propsSeen = Set.empty-      , childrenHistory = emptyDecodeHistory-      }--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 _ = []--  -- | Decode a t'Node' to a value of type @a@-  nodeDecoder :: NodeDecoder () a--instance DecodeNode Node where-  nodeDecoder =-    Decoder SchemaUnknown $ \() -> do-      node_ <- StateT.gets (.object)-      StateT.modify $ \s -> s{object = emptyNode node_.name}-      pure node_-   where-    emptyNode name =-      Node-        { ann = Nothing-        , name = name-        , entries = []-        , children = Nothing-        , format = Nothing-        }---- | 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 = withDecodeValue 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.text -< ()---     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) => ValueDecoder a b -> NodeDecoder a b-argWith = argWith' []---- | Same as 'argWith', except allow specifying type annotations.-argWith' :: forall a b. (Typeable b) => [Text] -> ValueDecoder a b -> NodeDecoder a b-argWith' =-  withTypedValueDecoder $ \schema decodeValue ->-    Decoder (SchemaOne $ NodeArg schema) $ \a -> do-      index <- StateT.gets getArgIndex--      entries <- StateT.gets (.object.entries)-      (entry, entries') <--        maybe (Trans.lift $ decodeThrow DecodeError_ExpectedArg{index = index}) pure $-          extractFirst (isNothing . (.name)) entries-      StateT.modify $ \s -> s{object = s.object{entries = entries'}}--      b <--        Trans.lift . makeFatal . addContext ContextArg{index = index} $-          decodeValue a entry.value-      StateT.modify $ \s -> s{history = s.history{argsSeen = s.history.argsSeen + 1}}-      pure 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 name = withDecodeValue $ propWith' 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 -> ValueDecoder a b -> NodeDecoder a b-propWith name = propWith' name []---- | Same as 'propWith', except allow specifying type annotations.-propWith' :: forall a b. (Typeable b) => Text -> [Text] -> ValueDecoder a b -> NodeDecoder a b-propWith' name =-  withTypedValueDecoder $ \schema decodeValue ->-    Decoder (SchemaOne $ NodeProp name schema) $ \a -> do-      decodeOnePropWhere (== name) (decodeValue a)-        >>= maybe (Trans.lift $ decodeThrow DecodeError_ExpectedProp{name = name}) (pure . snd)--decodeOnePropWhere ::-  (Text -> Bool) ->-  (Value -> DecodeM a) ->-  StateT (DecodeState Node) DecodeM (Maybe (Identifier, a))-decodeOnePropWhere matcher decodeValue = do-  entries <- StateT.gets (.object.entries)-  case findProp entries of-    Nothing -> pure Nothing-    Just (name, prop_, entries') -> do-      StateT.modify $ \s -> s{object = s.object{entries = entries'}}-      b <--        Trans.lift . makeFatal . addContext ContextProp{name = name} $-          decodeValue prop_.value-      StateT.modify $ \s -> s{history = s.history{propsSeen = Set.insert name s.history.propsSeen}}-      pure $ Just (name, b)- where-  isPropWhere f entry = (f . (.value) <$> entry.name) == Just True-  findProp entries =-    case break (isPropWhere matcher) entries of-      (entries1, prop0@Entry{name = Just name} : remainingEntries) ->-        -- Collect remaining props with the same name, latter props override earlier props-        let (props, entries2) = partition (isPropWhere (== name.value)) remainingEntries-         in Just (name, NonEmpty.last $ prop0 NonEmpty.:| props, entries1 <> entries2)-      _ ->-        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 = withDecodeValue 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) => ValueDecoder a b -> NodeDecoder a (Map Text b)-remainingPropsWith = remainingPropsWith' []---- | Same as 'remainingPropsWith', except allow specifying type annotations.-remainingPropsWith' :: forall a b. (Typeable b) => [Text] -> ValueDecoder a b -> NodeDecoder a (Map Text b)-remainingPropsWith' =-  withTypedValueDecoder $ \schema decodeValue ->-    Decoder (SchemaOne $ NodeRemainingProps schema) $ \a -> do-      Map.fromList <$> go (decodeValue a)- where-  go decodeValue =-    decodeOnePropWhere (const True) decodeValue >>= \case-      Nothing -> pure []-      Just (name, b) -> do-        propMap <- go decodeValue-        pure $ (name.value, 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. NodeListDecoder a b -> NodeDecoder a b-children decoder =-  Decoder (SchemaOne $ NodeChildren decoder.schema) $ \a -> do-    mChildren <- StateT.gets (.object.children)-    childrenHistory <- StateT.gets (.history.childrenHistory)-    (b, decodeState) <--      Trans.lift $-        StateT.runStateT (decoder.run a) $-          DecodeState-            { object = fromMaybe emptyNodeList mChildren-            , history = childrenHistory-            }-    StateT.modify $ \s ->-      s-        { object = s.object{children = decodeState.object <$ mChildren}-        , history = s.history{childrenHistory = decodeState.history}-        }-    pure b- where-  emptyNodeList = NodeList{nodes = [], format = Nothing}--{----- Decoding ValueData -----}--withDecodeValue :: forall a r. (DecodeValue a) => ([Text] -> ValueDecoder () a -> r) -> r-withDecodeValue k = k (validValueTypeAnns (Proxy @a)) valueDecoder--withTypedValueDecoder ::-  forall a b r.-  (Typeable b) =>-  (TypedValueSchema -> (a -> Value -> DecodeM b) -> r) ->-  ([Text] -> ValueDecoder a b -> r)-withTypedValueDecoder k typeAnns decoder = k schema decodeValue- where-  schema =-    TypedValueSchema-      { typeHint = typeRep (Proxy @b)-      , validTypeAnns = typeAnns-      , dataSchema = decoder.schema-      }-  decodeValue a value = do-    validateAnn typeAnns value.ann-    runDecodeStateM value emptyDecodeHistory $ do-      -- TODO: add typeHint to Context-      decoder.run a--type ValueDecoder = Decoder Value--instance HasDecodeHistory Value where-  data DecodeHistory Value = DecodeHistory_Value-  emptyDecodeHistory = DecodeHistory_Value---- | 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 _ = []--  -- | 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 = any-instance DecodeValue ValueData where-  valueDecoder = (.data_) <$> any-instance DecodeValue Text where-  validValueTypeAnns _ = ["text"]-  valueDecoder = text-instance DecodeValue String where-  validValueTypeAnns _ = ["string"]-  valueDecoder = Text.unpack <$> text-instance DecodeValue Bool where-  validValueTypeAnns _ = ["bool", "boolean"]-  valueDecoder = bool-instance (DecodeValue a) => DecodeValue (Maybe a) where-  validValueTypeAnns _ = validValueTypeAnns (Proxy @a)-  valueDecoder = oneOf [Nothing <$ null, Just <$> valueDecoder]-instance (DecodeValue a, DecodeValue b) => DecodeValue (Either a b) where-  validValueTypeAnns _ = validValueTypeAnns (Proxy @a) <> validValueTypeAnns (Proxy @b)-  valueDecoder = oneOf [Left <$> valueDecoder, Right <$> valueDecoder]--decodeInt :: (Integral b, Bounded b) => ValueDecoder a b-decodeInt = withDecoder number $ \x -> do-  unless (Scientific.isInteger x) $ do-    failM $ "Expected integer, got: " <> (Text.pack . show) x-  maybe (failM $ "Number doesn't fit bounds: " <> (Text.pack . show) x) pure $-    Scientific.toBoundedInteger x-instance DecodeValue Integer where-  validValueTypeAnns _ =-    concat-      [ ["i8", "i16", "i32", "i64", "i128", "isize"]-      , ["u8", "u16", "u32", "u64", "u128", "usize"]-      ]-  valueDecoder = toInteger <$> decodeInt @Int64-instance DecodeValue Int where-  validValueTypeAnns _ =-    concat-      [ ["i8", "i16", "isize"]-      , if bits >= 32 then ["i32"] else []-      , if bits >= 64 then ["i64"] else []-      ]-   where-    bits = finiteBitSize (0 :: Int)-  valueDecoder = decodeInt-instance DecodeValue Int8 where-  validValueTypeAnns _ = ["i8"]-  valueDecoder = decodeInt-instance DecodeValue Int16 where-  validValueTypeAnns _ = ["i16"]-  valueDecoder = decodeInt-instance DecodeValue Int32 where-  validValueTypeAnns _ = ["i32"]-  valueDecoder = decodeInt-instance DecodeValue Int64 where-  validValueTypeAnns _ = ["i64"]-  valueDecoder = decodeInt-instance DecodeValue Word where-  validValueTypeAnns _ =-    concat-      [ ["u8", "u16", "usize"]-      , if bits >= 32 then ["u32"] else []-      , if bits >= 64 then ["u64"] else []-      ]-   where-    bits = finiteBitSize (0 :: Word)-  valueDecoder = decodeInt-instance DecodeValue Word8 where-  validValueTypeAnns _ = ["u8"]-  valueDecoder = decodeInt-instance DecodeValue Word16 where-  validValueTypeAnns _ = ["u16"]-  valueDecoder = decodeInt-instance DecodeValue Word32 where-  validValueTypeAnns _ = ["u32"]-  valueDecoder = decodeInt-instance DecodeValue Word64 where-  validValueTypeAnns _ = ["u64"]-  valueDecoder = decodeInt-instance DecodeValue Natural where-  validValueTypeAnns _ = ["u8", "u16", "u32", "u64", "usize"]-  valueDecoder = withDecoder (valueDecoder @Integer) $ \x -> do-    when (x < 0) $ do-      failM $ "Expected a non-negative number, got: " <> (Text.pack . show) x-    pure $ fromIntegral x--decodeRealFloat :: (RealFloat b) => ValueDecoder a b-decodeRealFloat = withDecoder number $ \x -> do-  either (\_ -> failM $ "Number is too small or too large: " <> (Text.pack . show) x) pure $-    Scientific.toBoundedRealFloat x-instance DecodeValue Scientific where-  validValueTypeAnns _ = ["f32", "f64", "decimal64", "decimal128"]-  valueDecoder = number-instance DecodeValue Float where-  validValueTypeAnns _ = ["f32"]-  valueDecoder = decodeRealFloat-instance DecodeValue Double where-  validValueTypeAnns _ = ["f64"]-  valueDecoder = decodeRealFloat-instance DecodeValue Rational where-  validValueTypeAnns _ = ["decimal64", "decimal128"]-  valueDecoder = withDecoder number $ \x -> do-    -- Use toBoundedRealFloat to guard against large values, but use-    -- toRational after checking to maintain precision-    case Scientific.toBoundedRealFloat @Double x of-      Right _ -> pure $ toRational x-      Left _ -> failM $ "Number is too small or too large: " <> (Text.pack . show) x--valueDataDecoderPrim :: SchemaOf Value -> (Value -> DecodeM b) -> ValueDecoder a b-valueDataDecoderPrim schema f = Decoder schema $ \_ -> Trans.lift . f =<< StateT.gets (.object)---- | Decode any value, without any possibility of failure.-any :: ValueDecoder a Value-any = valueDataDecoderPrim (SchemaOr $ map SchemaOne [minBound .. maxBound]) pure---- | Decode a KDL text value.-text :: ValueDecoder a Text-text = valueDataDecoderPrim (SchemaOne TextSchema) $ \case-  Value{data_ = Text s} -> pure s-  v -> decodeThrow DecodeError_ValueDecodeFail{expectedType = "text", value = v}---- | Decode a KDL number value.-number :: ValueDecoder a Scientific-number = valueDataDecoderPrim (SchemaOne NumberSchema) $ \case-  Value{data_ = Number x} -> pure x-  v -> decodeThrow DecodeError_ValueDecodeFail{expectedType = "number", value = v}---- | Decode a KDL bool value.-bool :: ValueDecoder a Bool-bool = valueDataDecoderPrim (SchemaOne BoolSchema) $ \case-  Value{data_ = Bool x} -> pure x-  v -> decodeThrow DecodeError_ValueDecodeFail{expectedType = "bool", value = v}---- | Decode a KDL null value.-null :: ValueDecoder a ()-null = valueDataDecoderPrim (SchemaOne NullSchema) $ \case-  Value{data_ = Null} -> pure ()-  v -> decodeThrow DecodeError_ValueDecodeFail{expectedType = "null", value = v}--{----- Utilities -----}---- | Return the first result that succeeds.------ > oneOf [a, b, c] === a <|> b <|> c <|> empty-oneOf :: (Alternative f) => [f a] -> f a-oneOf = foldr (<|>) 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 a f = f <|> pure a--extractFirst :: (a -> Bool) -> [a] -> Maybe (a, [a])-extractFirst f = go- where-  go = \case-    [] -> Nothing-    x : xs ->-      if f x-        then Just (x, xs)-        else fmap (x :) <$> go xs

@@ -1,94 +0,0 @@-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE NoFieldSelectors #-}--module Data.KDL.Decoder.DecodeM (-  -- * Decoding errors-  module Data.KDL.Decoder.Error,--  -- * DecodeM monad-  DecodeM (..),-  runDecodeM,-  decodeThrow,-  failM,-  makeFatal,-  makeNonFatal,-  addContext,-) where--import Control.Applicative (Alternative (..))-import Data.KDL.Decoder.Error-import Data.Text (Text)---- | The monad that returns either a 'DecodeError' or a result of type @a@.------ To a first approximation, this monad is equivalent to the @Either DecodeError@--- monad, with the following changes:------   * Uses continuation-passing style for performance---   * Has two error channels, one for fatal errors and one for non-fatal errors (see 'makeFatal')---   * Collects as many errors as possible, within an Applicative context-data DecodeM a-  = DecodeM-      ( forall r.-        (DecodeError -> r) -> -- fatal error, not handled by <|>-        (DecodeError -> r) -> -- non-fatal error, handled by <|>-        (a -> r) ->-        r-      )--instance Functor DecodeM where-  fmap f (DecodeM k) = DecodeM $ \onFatal onFail onSuccess -> k onFatal onFail (onSuccess . f)-instance Applicative DecodeM where-  pure x = DecodeM $ \_ _ onSuccess -> onSuccess x-  DecodeM kf <*> DecodeM ka = DecodeM $ \onFatal onFail onSuccess ->-    -- Collect all errors-    kf-      (\e1 -> ka (\e2 -> onFatal $ e1 <> e2) (\e2 -> onFatal $ e1 <> e2) (\_ -> onFatal e1))-      (\e1 -> ka (\e2 -> onFatal $ e1 <> e2) (\e2 -> onFail $ e1 <> e2) (\_ -> onFail e1))-      (\f -> ka onFatal onFail (onSuccess . f))-instance Monad DecodeM where-  (>>) = (*>)-  DecodeM ka >>= k = DecodeM $ \onFatal onFail onSuccess ->-    ka onFatal onFail $ \a -> let DecodeM kb = k a in kb onFatal onFail onSuccess-instance Alternative DecodeM where-  empty = DecodeM $ \_ onFail _ -> onFail mempty-  DecodeM k1 <|> DecodeM k2 = DecodeM $ \onFatal onFail onSuccess ->-    k1-      onFatal-      (\e1 -> k2 onFatal (\e2 -> onFail $ e1 <> e2) onSuccess)-      onSuccess---- | Run a 'DecodeM' action and return the result or the error.-runDecodeM :: DecodeM a -> Either DecodeError a-runDecodeM (DecodeM f) = f Left Left Right---- | Throw an error.------ This error is non-fatal and can be handled by '<|>'. See 'makeFatal'--- for more information.-decodeThrow :: BaseDecodeError -> DecodeM a-decodeThrow e = DecodeM $ \_ onFail _ -> onFail $ DecodeError [([], e)]---- | Throw a 'DecodeError_Custom' error.-failM :: Text -> DecodeM a-failM = decodeThrow . DecodeError_Custom---- | Make all errors in the given action fatal errors.------ A la standard parsing libraries like megaparsec, errors should be--- considered fatal when decoding has started consuming something.-makeFatal :: DecodeM a -> DecodeM a-makeFatal (DecodeM f) = DecodeM $ \onFatal _ onSuccess -> f onFatal onFatal onSuccess---- | Make all errors non-fatal errors.-makeNonFatal :: DecodeM a -> DecodeM a-makeNonFatal (DecodeM f) = DecodeM $ \_ onFail onSuccess -> f onFail onFail onSuccess---- | Add context to all errors that occur in the given action.-addContext :: ContextItem -> DecodeM a -> DecodeM a-addContext ctxItem (DecodeM f) = DecodeM $ \onFatal onFail onSuccess -> f (onFatal . addCtx) (onFail . addCtx) onSuccess- where-  addCtx (DecodeError es) = DecodeError [(ctxItem : ctx, msg) | (ctx, msg) <- es]

@@ -1,96 +0,0 @@-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE NoFieldSelectors #-}--module Data.KDL.Decoder.Error (-  DecodeError (..),-  BaseDecodeError (..),-  Context,-  ContextItem (..),-  renderDecodeError,-) where--import Data.KDL.Render (-  renderIdentifier,-  renderValue,- )-import Data.KDL.Types (-  Identifier,-  Value,- )-import Data.Map qualified as Map-import Data.Text (Text)-import Data.Text qualified as Text--data DecodeError = DecodeError [(Context, BaseDecodeError)]-  deriving (Show, Eq)-instance Semigroup DecodeError where-  DecodeError e1 <> DecodeError e2 = DecodeError (e1 <> e2)-instance Monoid DecodeError where-  mempty = DecodeError []--type Context = [ContextItem]--data ContextItem-  = ContextNode-      { name :: Identifier-      , index :: Int-      }-  | ContextArg-      { index :: Int-      }-  | ContextProp-      { name :: Identifier-      }-  deriving (Show, Eq, Ord)--data BaseDecodeError-  = DecodeError_Custom Text-  | DecodeError_ParseError Text-  | DecodeError_ExpectedNode {name :: Text, index :: Int}-  | DecodeError_ExpectedArg {index :: Int}-  | DecodeError_ExpectedProp {name :: Text}-  | DecodeError_MismatchedAnn {givenAnn :: Identifier, validAnns :: [Text]}-  | DecodeError_ValueDecodeFail {expectedType :: Text, value :: Value}-  | DecodeError_UnexpectedNode {identifier :: Identifier, index :: Int}-  | DecodeError_UnexpectedArg {index :: Int, value :: Value}-  | DecodeError_UnexpectedProp {identifier :: Identifier, value :: Value}-  deriving (Show, Eq)--renderDecodeError :: DecodeError -> Text-renderDecodeError = Text.intercalate "\n" . map renderCtxErrors . groupCtxErrors- where-  -- Group errors with the same contexts together-  groupCtxErrors (DecodeError es) = Map.toAscList $ Map.fromListWith (<>) [(ctx, [e]) | (ctx, e) <- es]--  renderCtxErrors (ctx, errs) =-    Text.intercalate "\n" $ ("At: " <> renderCtxItems ctx) : renderErrors errs--  renderCtxItems items-    | null items = "<root>"-    | otherwise = Text.intercalate " > " . map renderCtxItem $ items-  renderCtxItem = \case-    ContextNode{..} -> renderIdentifier name <> " #" <> showT index-    ContextArg{..} -> "arg #" <> showT index-    ContextProp{..} -> "prop " <> renderIdentifier name--  renderErrors = map ("  " <>) . concatMap (Text.lines . renderError)-  renderError = \case-    DecodeError_Custom msg -> msg-    DecodeError_ParseError msg -> msg-    DecodeError_ExpectedNode{..}-      | index == 0 -> "Expected node: " <> name-      | otherwise -> "Expected another node: " <> name-    DecodeError_ExpectedArg{..} -> "Expected arg #" <> showT index-    DecodeError_ExpectedProp{..} -> "Expected prop: " <> name-    DecodeError_MismatchedAnn{..} -> "Expected annotation to be one of " <> showT validAnns <> ", got: " <> renderIdentifier givenAnn-    DecodeError_ValueDecodeFail{..} -> "Expected " <> expectedType <> ", got: " <> renderValue value-    DecodeError_UnexpectedNode{..} -> "Unexpected node: " <> renderIdentifier identifier <> " #" <> showT index-    DecodeError_UnexpectedArg{..} -> "Unexpected arg #" <> showT index <> ": " <> renderValue value-    DecodeError_UnexpectedProp{..} -> "Unexpected prop: " <> renderIdentifier identifier <> "=" <> renderValue value--  -- Replace with Text.show after requiring at least text-2.1.2-  showT :: (Show a) => a -> Text-  showT = Text.pack . show

@@ -1,687 +0,0 @@-{-# LANGUAGE LambdaCase #-}--{-|-This module defines the Monad interface for decoding a KDL document. Intended to-be imported from "Data.KDL" as:--> import Data.KDL qualified as KDL--For most use-cases, this Monad interface is sufficient. You may wish to use-"Data.KDL.Decoder.Arrow" if you would like to statically analyze a decoder's-schema, e.g. to generate documentation.--= Quickstart--See "Data.KDL"--}-module Data.KDL.Decoder.Monad (-  -- * Decoding entrypoint-  decodeWith,-  decodeFileWith,-  decodeDocWith,--  -- * Decoder-  Decoder,-  module Data.KDL.Decoder.DecodeM,-  fail,-  withDecoder,-  debug,--  -- * Decode type classes-  -- $decodeTypeClassesDoc-  noSchema,-  Arrow.DecodeNode (..),-  Arrow.DecodeValue (..),--  -- * Document-  DocumentDecoder,-  document,--  -- * NodeList-  NodeListDecoder,-  node,-  remainingNodes,-  argAt,-  argsAt,-  dashChildrenAt,-  dashNodesAt,--  -- ** Explicitly specify decoders-  nodeWith,-  remainingNodesWith,-  dashChildrenAtWith,-  dashNodesAtWith,-  argAtWith,-  argsAtWith,--  -- ** Explicitly specify decoders and type annotations-  nodeWith',-  remainingNodesWith',-  dashChildrenAtWith',-  argAtWith',-  argsAtWith',--  -- * Node-  NodeDecoder,-  arg,-  prop,-  remainingProps,-  children,--  -- ** Explicitly specify decoders-  argWith,-  propWith,-  remainingPropsWith,--  -- ** Explicitly specify decoders and type annotations-  argWith',-  propWith',-  remainingPropsWith',--  -- * Value-  ValueDecoder,-  any,-  text,-  number,-  bool,-  null,--  -- * Combinators-  Arrow.oneOf,-  Arrow.many,-  Arrow.optional,-  Arrow.option,-  Arrow.some,-) where--import Control.Applicative (Alternative)-import Control.Arrow qualified as Arrow-import Data.Coerce (coerce)-import Data.KDL.Decoder.Arrow qualified as Arrow-import Data.KDL.Decoder.DecodeM-import Data.KDL.Decoder.Schema (-  Schema (..),- )-import Data.KDL.Types (-  Document,-  Node,-  NodeList,-  Value,- )-import Data.Map (Map)-import Data.Scientific (Scientific)-import Data.Text (Text)-import Data.Typeable (Typeable)-import Prelude hiding (any, fail, null)---- | Decode the given KDL configuration with the given decoder.-decodeWith :: forall a. DocumentDecoder a -> Text -> Either DecodeError a-decodeWith = coerce (Arrow.decodeWith @a)---- | Read KDL configuration from the given file path and decode it with the given decoder.-decodeFileWith :: forall a. DocumentDecoder a -> FilePath -> IO (Either DecodeError a)-decodeFileWith = coerce (Arrow.decodeFileWith @a)---- | Decode an already-parsed 'Document' with the given decoder.-decodeDocWith :: forall a. DocumentDecoder a -> Document -> Either DecodeError a-decodeDocWith = coerce (Arrow.decodeDocWith @a)--{----- Decoder -----}---- | @Decoder o a@ represents an action that decodes a KDL object of type @o@--- and returns a value of type @a@.------ Exactly the same as the Arrow 'Data.KDL.Decoder.Arrow.Decoder', except--- provides a Monad instance that's useful for do-notation. The only downside of--- using this over the Arrow 'Data.KDL.Decoder.Arrow.Decoder' is you don't get a--- statically derived schema of the entire document. If you want that, you must--- use either arrows notation with the Arrow 'Data.KDL.Decoder.Arrow.Decoder' or--- use do-notation with @-XApplicativeDo@.-newtype Decoder o a = Decoder (Arrow.Decoder o () a)-  deriving-    ( Functor-    , Applicative-    , Alternative-    )--instance Monad (Decoder o) where-  Decoder (Arrow.Decoder _ run1) >>= k =-    Decoder . Arrow.Decoder SchemaUnknown $ \a -> do-      x <- run1 a-      let Decoder (Arrow.Decoder _ run2) = k x-      run2 a---- $decodeTypeClassesDoc--- To avoid code duplication, the same 'DecodeNode' and 'DecodeValue' type classes--- are used for both the Arrow and Monad decoders. However, the type classes are--- implemented with the Arrow decoder, as the Monad decoder is lossy regarding the--- schema. If you're implementing instances that may be used with the Arrow--- decoder, you should probably implement the decoder with--- the "Data.KDL.Decoder.Arrow" API.------ Otherwise, use the normal Monad decoder API and use 'noSchema' at the very end,--- which indicates that this instance doesn't provide any schema information.------ @--- instance KDL.DecodeNode Person where---   nodeDecoder = KDL.noSchema $ do---     name <- KDL.arg---     age <- KDL.prop "age"---     pure Person{..}------ instance KDL.DecodeValue MyVal where---   valueDecoder =---     KDL.noSchema . KDL.oneOf $---       [ MyText \<$> KDL.text---       , KDL.withDecoder KDL.number $ \x -> do---           if x == 0---             then pure MyZero---             else KDL.failM "integer value must be zero"---       ]--- @---- | Drop the Monad Decoder back down to an Arrow Decoder.-noSchema :: Decoder o a -> Arrow.Decoder o () a-noSchema (Decoder decoder) = decoder---- | Unconditionally fail the decoder.------ === __Example__------ @--- decoder = do---   x <- KDL.arg---   when (x > 100) $ do---     KDL.fail $ "argument is too large: " <> (Text.pack . show) x---   pure x--- @-fail :: forall a o. Text -> Decoder o a-fail msg = coerce (Arrow.arr (\() -> msg) Arrow.>>> Arrow.fail @a)---- | Run actions within a t'Decoder'. Useful for adding post-processing logic.------ === __Example__------ @--- decoder = KDL.withDecoder KDL.number $ \\x -> do---   when (x > 100)---     KDL.failM $ "argument is too large: " <> (Text.pack . show) x---   pure $ MyVal x--- @-withDecoder :: forall o a b. Decoder o a -> (a -> DecodeM b) -> Decoder o b-withDecoder = coerce (Arrow.withDecoder @o @() @a @b)---- | Debug the current state of the object being decoded.------ === __Example__------ @--- decoder = do---   KDL.debug    -- Node{entries = [Entry{}, Entry{}]}---   x <- KDL.arg---   KDL.debug    -- Node{entries = [Entry{}]}---   y <- KDL.arg---   KDL.debug    -- Node{entries = []}---   pure (x, y)--- @-debug :: forall o. (Show o) => Decoder o ()-debug = coerce (Arrow.debug @o @())--{----- Decoding Document -----}--newtype DocumentDecoder a = DocumentDecoder (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 :: forall a. NodeListDecoder a -> DocumentDecoder a-document = coerce (Arrow.document @a)--{----- Decoding NodeList -----}--type NodeListDecoder = Decoder NodeList---- | Decode a node with the given name and decoder.------ == __Example__------ @--- instance KDL.DecodeNode Person where---   nodeTypeAnns _ = ["Person"]---   nodeDecoder = KDL.noSchema $ do---     name <- KDL.arg---     pure Person{..}------ let---   config =---     """---     person "Alice"---     person "Bob"---     person "Charlie"---     (Person)person "Danielle"---     (Dog)person "Fido"---     """---   decoder = KDL.document $ do---     many $ KDL.node "person"--- KDL.decodeWith decoder config == Right ["Alice", "Bob", "Charlie", "Danielle"]--- @-node :: forall a. (Arrow.DecodeNode a) => Text -> NodeListDecoder a-node = coerce (Arrow.node @a)---- | Same as 'node', except explicitly specify the 'NodeDecoder' instead of using 'Arrow.DecodeNode'.------ == __Example__------ @--- let---   config =---     """---     person "Alice"---     person "Bob"---     person "Charlie"---     (Person)person "Danielle"---     (Dog)person "Fido"---     """---   decoder = KDL.document $ do---     many . KDL.nodeWith "person" ["Person"] $ KDL.arg--- KDL.decodeWith decoder config == Right ["Alice", "Bob", "Charlie", "Danielle"]--- @-nodeWith :: forall a. (Typeable a) => Text -> NodeDecoder a -> NodeListDecoder a-nodeWith = coerce (Arrow.nodeWith @() @a)---- | Same as 'nodeWith', except allow specifying type annotations.-nodeWith' :: forall a. (Typeable a) => Text -> [Text] -> NodeDecoder a -> NodeListDecoder a-nodeWith' = coerce (Arrow.nodeWith' @() @a)---- | Decode all remaining nodes with the given decoder.------ == __Example__------ @--- instance KDL.DecodeNode MyArg where---   nodeDecoder = KDL.noSchema $ do---     name <- KDL.arg---     pure MyArg{..}------ let---   config =---     """---     build "pkg1"---     build "pkg2"---     lint "pkg1"---     """---   decoder = KDL.document $ do---     KDL.remainingNodes--- KDL.decodeWith decoder config == Right (Map.fromList [("build", [MyArg "pkg1", MyArg "pkg2"]), ("lint", [MyArg "pkg1"])])--- @-remainingNodes :: forall a. (Arrow.DecodeNode a) => NodeListDecoder (Map Text [a])-remainingNodes = coerce (Arrow.remainingNodes @a)---- | Same as 'remainingNodes', except explicitly specify the 'NodeDecoder' instead of using 'Arrow.DecodeNode'------ == __Example__------ @--- let---   config =---     """---     build "pkg1"---     build "pkg2"---     lint "pkg1"---     """---   decoder = KDL.document $ do---     KDL.remainingNodesWith [] KDL.arg--- KDL.decodeWith decoder config == Right (Map.fromList [("build", ["pkg1", "pkg2"]), ("lint", ["pkg1"])])--- @-remainingNodesWith :: forall a. (Typeable a) => NodeDecoder a -> NodeListDecoder (Map Text [a])-remainingNodesWith = coerce (Arrow.remainingNodesWith @() @a)---- | Same as 'remainingNodesWith', except allow specifying type annotations.-remainingNodesWith' :: forall a. (Typeable a) => [Text] -> NodeDecoder a -> NodeListDecoder (Map Text [a])-remainingNodesWith' = coerce (Arrow.remainingNodesWith' @() @a)---- | 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.------ == __Example__------ @--- let---   config =---     """---     verbose #true---     """---   decoder = KDL.document $ do---     KDL.argAt "verbose"--- KDL.decodeWith decoder config == Right True--- @-argAt :: forall a. (Arrow.DecodeValue a) => Text -> NodeListDecoder a-argAt = coerce (Arrow.argAt @a)---- | Same as 'argAt', except explicitly specify the 'ValueDecoder' instead of using 'Arrow.DecodeValue'------ == __Example__------ @--- let---   config =---     """---     verbose #true---     """---   decoder = KDL.document $ do---     KDL.argAtWith "verbose" [] KDL.bool--- KDL.decodeWith decoder config == Right True--- @-argAtWith :: forall a. (Typeable a) => Text -> ValueDecoder a -> NodeListDecoder a-argAtWith = coerce (Arrow.argAtWith @() @a)---- | Same as 'argAtWith', except allow specifying type annotations.-argAtWith' :: forall a. (Typeable a) => Text -> [Text] -> ValueDecoder a -> NodeListDecoder a-argAtWith' = coerce (Arrow.argAtWith' @() @a)---- | 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.------ == __Example__------ @--- let---   config =---     """---     email "a@example.com" "b@example.com"---     """---   decoder = KDL.document $ do---     KDL.argsAt "email"--- KDL.decodeWith decoder config == Right ["a@example.com", "b@example.com"]--- @-argsAt :: forall a. (Arrow.DecodeValue a) => Text -> NodeListDecoder [a]-argsAt = coerce (Arrow.argsAt @a)---- | Same as 'argsAt', except explicitly specify the 'ValueDecoder' instead of using 'Arrow.DecodeValue'------ == __Example__------ @--- let---   config =---     """---     email "a@example.com" "b@example.com"---     """---   decoder = KDL.document $ do---     KDL.argsAtWith "email" [] KDL.text--- KDL.decodeWith decoder config == Right ["a@example.com", "b@example.com"]--- @-argsAtWith :: forall a. (Typeable a) => Text -> ValueDecoder a -> NodeListDecoder [a]-argsAtWith = coerce (Arrow.argsAtWith @() @a)---- | Same as 'argsAtWith', except allow specifying type annotations.-argsAtWith' :: forall a. (Typeable a) => Text -> [Text] -> ValueDecoder a -> NodeListDecoder [a]-argsAtWith' = coerce (Arrow.argsAtWith' @() @a)---- | A helper for decoding child values in a list following the KDL convention of being named "-".------ == __Example__------ @--- let---   config =---     """---     attendees {---       - "Alice"---       - "Bob"---     }---     """---   decoder = KDL.document $ do---     KDL.dashChildrenAt "attendees"--- KDL.decodeWith decoder config == Right ["Alice", "Bob"]--- @-dashChildrenAt :: forall a. (Arrow.DecodeValue a) => Text -> NodeListDecoder [a]-dashChildrenAt = coerce (Arrow.dashChildrenAt @a)---- | Same as 'dashChildrenAt', except explicitly specify the 'ValueDecoder' instead of using 'Arrow.DecodeValue'------ == __Example__------ @--- let---   config =---     """---     attendees {---       - "Alice"---       - "Bob"---     }---     """---   decoder = KDL.document $ do---     KDL.dashChildrenAtWith "attendees" [] KDL.text--- KDL.decodeWith decoder config == Right ["Alice", "Bob"]--- @-dashChildrenAtWith :: forall a. (Typeable a) => Text -> ValueDecoder a -> NodeListDecoder [a]-dashChildrenAtWith = coerce (Arrow.dashChildrenAtWith @() @a)---- | Same as 'dashChildrenAtWith', except allow specifying type annotations.-dashChildrenAtWith' :: forall a. (Typeable a) => Text -> [Text] -> ValueDecoder a -> NodeListDecoder [a]-dashChildrenAtWith' = coerce (Arrow.dashChildrenAtWith' @() @a)---- | A helper for decoding child values in a list following the KDL convention of being named "-".------ == __Example__------ @--- instance KDL.DecodeNode Attendee where---   nodeDecoder = KDL.noSchema $ do---     name <- KDL.arg---     pure Attendee{..}------ let---   config =---     """---     attendees {---       - "Alice"---       - "Bob"---     }---     """---   decoder = KDL.document $ do---     KDL.dashNodesAt "attendees"--- KDL.decodeWith decoder config == Right [Attendee "Alice", Attendee "Bob"]--- @-dashNodesAt :: forall a. (Arrow.DecodeNode a) => Text -> NodeListDecoder [a]-dashNodesAt = coerce (Arrow.dashNodesAt @a)---- | Same as 'dashChildrenAt', except explicitly specify the 'NodeDecoder' instead of using 'Arrow.DecodeNode'------ == __Example__------ @--- let---   config =---     """---     attendees {---       - "Alice"---       - "Bob"---     }---     """---   decoder = KDL.document $ do---     KDL.dashNodesAtWith "attendees" [] KDL.arg--- KDL.decodeWith decoder config == Right ["Alice", "Bob"]--- @-dashNodesAtWith :: forall a. (Typeable a) => Text -> NodeDecoder a -> NodeListDecoder [a]-dashNodesAtWith = coerce (Arrow.dashNodesAtWith @() @a)--{----- Decoding Node -----}--type NodeDecoder a = Decoder Node a---- | Decode an argument in the node.------ === __Example__------ @--- let---   config =---     """---     person \"Alice" 1 2 3---     """---   decoder = KDL.document $ do---     KDL.nodeWith "person" decodePerson---   decodePerson = do---     name <- KDL.arg---     vals <- KDL.many KDL.arg---     pure (name, vals)--- KDL.decodeWith decoder config == Right (\"Alice", [1, 2, 3])--- @-arg :: forall a. (Arrow.DecodeValue a) => NodeDecoder a-arg = coerce (Arrow.arg @a)---- | Same as 'arg', except explicitly specify the 'ValueDecoder' instead of using 'DecodeValue'------ === __Example__------ @--- let---   config =---     """---     person \"Alice" 1 2 3---     """---   decoder = KDL.document $ do---     KDL.nodeWith "person" $ decodePerson---   decodePerson = do---     name \<- KDL.argWith $ Text.toUpper \<$> KDL.text---     vals \<- KDL.many $ KDL.argWith $ show \<$> KDL.valueDecoder @Int---     pure (name, vals)--- KDL.decodeWith decoder config == Right (\"ALICE", ["1", "2", "3"])--- @-argWith :: forall a. (Typeable a) => ValueDecoder a -> NodeDecoder a-argWith = coerce (Arrow.argWith @() @a)---- | Same as 'argWith', except allow specifying type annotations.-argWith' :: forall a. (Typeable a) => [Text] -> ValueDecoder a -> NodeDecoder a-argWith' = coerce (Arrow.argWith' @() @a)---- | 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 $ do---     KDL.nodeWith "my-node" $ KDL.prop @Int "a"--- KDL.decodeWith decoder config == Right 3--- @-prop :: forall a. (Arrow.DecodeValue a) => Text -> NodeDecoder a-prop = coerce (Arrow.prop @a)---- | 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 $ do---     KDL.nodeWith "my-node" $ do---       KDL.propWith "a" $ show \<$> KDL.number--- KDL.decodeWith decoder config == Right "3.0"--- @-propWith :: forall a. (Typeable a) => Text -> ValueDecoder a -> NodeDecoder a-propWith = coerce (Arrow.propWith @() @a)---- | Same as 'propWith', except allow specifying type annotations.-propWith' :: forall a. (Typeable a) => Text -> [Text] -> ValueDecoder a -> NodeDecoder a-propWith' = coerce (Arrow.propWith' @() @a)---- | Decode all remaining props------ === __Example__------ @--- let---   config =---     """---     my-node a=1 b=2 a=3---     """---   decoder = KDL.document $ do---     KDL.nodeWith "my-node" $ KDL.remainingProps @Int--- KDL.decodeWith decoder config == (Right . Map.fromList) [("a", 3), ("b", 2)]--- @-remainingProps :: forall a. (Arrow.DecodeValue a) => NodeDecoder (Map Text a)-remainingProps = coerce (Arrow.remainingProps @a)---- | 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 $ do---     KDL.nodeWith "my-node" $ do---       KDL.remainingPropsWith $ show \<$> KDL.number--- KDL.decodeWith decoder config == (Right . Map.fromList) [("a", "3.0"), ("b", "2.0")]--- @-remainingPropsWith :: forall a. (Typeable a) => ValueDecoder a -> NodeDecoder (Map Text a)-remainingPropsWith = coerce (Arrow.remainingPropsWith @() @a)---- | Same as 'remainingPropsWith', except allow specifying type annotations.-remainingPropsWith' :: forall a. (Typeable a) => [Text] -> ValueDecoder a -> NodeDecoder (Map Text a)-remainingPropsWith' = coerce (Arrow.remainingPropsWith' @() @a)---- | Decode the children of the node.------ === __Example__------ @--- let---   config =---     """---     person \"Alice" {---       email "alice@example.com"---     }---     """---   decoder = KDL.document $ do---     KDL.nodeWith "person" $ do---       name <- KDL.arg---       email <- KDL.children $ KDL.argAt "email"---       pure Person{..}--- KDL.decodeWith decoder config == Right Person{name = \"Alice", email = "alice\@example.com"}--- @-children :: forall a. NodeListDecoder a -> NodeDecoder a-children = coerce (Arrow.children @() @a)--{----- Decoding Value -----}--type ValueDecoder a = Decoder Value a---- | Decode any value, without any possibility of failure.-any :: ValueDecoder Value-any = coerce (Arrow.any @())---- | Decode a KDL text value.-text :: ValueDecoder Text-text = coerce (Arrow.text @())---- | Decode a KDL number value.-number :: ValueDecoder Scientific-number = coerce (Arrow.number @())---- | Decode a KDL bool value.-bool :: ValueDecoder Bool-bool = coerce (Arrow.bool @())---- | Decode a KDL null value.-null :: ValueDecoder ()-null = coerce (Arrow.null @())

@@ -1,80 +0,0 @@-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE TypeFamilies #-}--module Data.KDL.Decoder.Schema (-  SchemaOf,-  Schema (..),-  SchemaItem (..),-  TypedNodeSchema (..),-  TypedValueSchema (..),-  schemaJoin,-  schemaAlt,-) where--import Data.KDL.Types (-  Node,-  NodeList,-  Value,- )-import Data.Text (Text)-import Data.Typeable (TypeRep)--type SchemaOf o = Schema (SchemaItem o)--data Schema a-  = SchemaOne a-  | SchemaSome (Schema a)-  | SchemaAnd [Schema a]-  | SchemaOr [Schema a]-  | SchemaUnknown-  deriving (Show, Eq)--data family SchemaItem a--data instance SchemaItem NodeList-  = NodeNamed Text TypedNodeSchema-  | RemainingNodes TypedNodeSchema-  deriving (Show, Eq)--data TypedNodeSchema = TypedNodeSchema-  { typeHint :: TypeRep-  , validTypeAnns :: [Text]-  , nodeSchema :: SchemaOf Node-  }-  deriving (Show, Eq)--data instance SchemaItem Node-  = NodeArg TypedValueSchema-  | NodeProp Text TypedValueSchema-  | NodeRemainingProps TypedValueSchema-  | NodeChildren (SchemaOf NodeList)-  deriving (Show, Eq)--data TypedValueSchema = TypedValueSchema-  { typeHint :: TypeRep-  , validTypeAnns :: [Text]-  , dataSchema :: SchemaOf Value-  }-  deriving (Show, Eq)--data instance SchemaItem Value-  = TextSchema-  | NumberSchema-  | BoolSchema-  | NullSchema-  deriving (Show, Eq, Ord, Enum, Bounded)--schemaJoin :: Schema a -> Schema a -> Schema a-schemaJoin = curry $ \case-  (SchemaAnd l, SchemaAnd r) -> SchemaAnd (l <> r)-  (l, SchemaAnd r) -> SchemaAnd (l : r)-  (SchemaAnd l, r) -> SchemaAnd (l <> [r])-  (l, r) -> SchemaAnd [l, r]--schemaAlt :: Schema a -> Schema a -> Schema a-schemaAlt = curry $ \case-  (SchemaOr l, SchemaOr r) -> SchemaOr (l <> r)-  (l, SchemaOr r) -> SchemaOr (l : r)-  (SchemaOr l, r) -> SchemaOr (r : l)-  (l, r) -> SchemaOr [l, r]

@@ -1,91 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}--module Data.KDL.Parser (-  parse,-  parseFile,-) where--import Data.KDL.Parser.Hustle qualified as Hustle-import Data.KDL.Types (-  Ann (..),-  Document,-  Entry (..),-  Identifier (..),-  Node (..),-  NodeList (..),-  Value (..),-  ValueData (..),-  ValueFormat (..),- )-import Data.Map qualified as Map-import Data.Text (Text)-import Data.Text qualified as Text-import Data.Text.IO qualified as Text---- TODO: Implement our own parser that implements the v2.0.0 spec + preserves formatting and comments-parse :: Text -> Either Text Document-parse input =-  case Hustle.parse Hustle.document "" input of-    Left e -> Left . Text.strip . Text.pack . Hustle.errorBundlePretty $ e-    Right (Hustle.Document nodes) -> Right $ fromNodes nodes- where-  fromNodes nodes =-    NodeList-      { nodes = map fromNode nodes-      , format = Nothing-      }--  fromAnn identifier =-    Ann-      { identifier = fromIdentifier identifier-      , format = Nothing-      }--  fromNode Hustle.Node{..} =-    Node-      { ann = fromAnn <$> nodeAnn-      , name = fromIdentifier nodeName-      , entries = map fromArgEntry nodeArgs <> map fromPropEntry (Map.toList nodeProps)-      , children = Just $ fromNodes nodeChildren-      , format = Nothing-      }--  fromArgEntry v =-    Entry-      { name = Nothing-      , value = fromValue v-      , format = Nothing-      }--  fromPropEntry (name, v) =-    Entry-      { name = Just $ fromIdentifier name-      , value = fromValue v-      , format = Nothing-      }--  fromValue Hustle.Value{..} =-    Value-      { ann = fromAnn <$> valueAnn-      , data_ =-          case valueExp of-            Hustle.StringValue s -> Text s-            Hustle.IntegerValue x -> Number (fromInteger x)-            Hustle.SciValue x -> Number x-            Hustle.BooleanValue x -> Bool x-            Hustle.NullValue -> Null-      , format =-          case valueExp of-            Hustle.IntegerValue x -> Just ValueFormat{repr = Text.pack $ show x}-            _ -> Nothing-      }--  fromIdentifier (Hustle.Identifier s) =-    Identifier-      { value = s-      , format = Nothing-      }--parseFile :: FilePath -> IO (Either Text Document)-parseFile = fmap parse . Text.readFile

@@ -1,28 +0,0 @@-{- FOURMOLU_DISABLE -}--{- | Vendered from https://github.com/fuzzypixelz/hustle -}-module Data.KDL.Parser.Hustle-  ( Parser-  , Document(..)-  , Node(..)-  , Value(..)-  , ValueType(..)-  , Identifier(..)-  , pretty-  , document-  , parse-  , errorBundlePretty-  ) where--import           Data.KDL.Parser.Hustle.Formatter ( Pretty(pretty) )-import           Data.KDL.Parser.Hustle.Parser  ( document )-import           Data.KDL.Parser.Hustle.Types   ( Document(..)-                                                , Identifier(..)-                                                , Node(..)-                                                , Parser-                                                , Value(..)-                                                , ValueType(..)-                                                )-import           Text.Megaparsec                ( errorBundlePretty-                                                , parse-                                                )

@@ -1,83 +0,0 @@-{- FOURMOLU_DISABLE -}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleInstances #-}-{-# OPTIONS_GHC -Wno-orphans #-}--{- | Vendered from https://github.com/fuzzypixelz/hustle -}-module Data.KDL.Parser.Hustle.Formatter-  ( Pretty(pretty)-  ) where--import           Data.Map                       ( Map )-import qualified Data.Map.Strict               as Map-import           Data.Maybe                     ( catMaybes )-import           Data.Scientific                ( Scientific )-import qualified Data.Text                     as T-import           Data.KDL.Parser.Hustle.Internal ( escChar-                                                , match-                                                )-import           Data.KDL.Parser.Hustle.Parser  ( identifier )-import           Data.KDL.Parser.Hustle.Types-import           Prettyprinter                  ( Pretty(pretty)-                                                , braces-                                                , dquotes-                                                , enclose-                                                , hsep-                                                , nest-                                                , parens-                                                , viaShow-                                                , vsep-                                                )--instance Pretty Scientific where-  pretty = viaShow--instance Pretty Identifier where-  pretty (Identifier i) =-    if match identifier i then pretty i else dquotes (pretty i)--instance Pretty Value where-  pretty v = vann <> vexp-   where-    vann = case valueAnn v of-      Nothing -> ""-      Just a  -> parens (pretty a)-    vexp = case valueExp v of-      StringValue  s -> dquotes . pretty $ T.concatMap escChar s-      IntegerValue i -> pretty i-      SciValue     s -> pretty s-      BooleanValue b -> if b then "true" else "false"-      NullValue      -> "null"--instance Pretty (Map Identifier Value) where-  pretty ps = hsep . Map.elems $ Map.mapWithKey prop ps-    where prop i v = pretty i <> "=" <> pretty v--instance Pretty Node where-  pretty n = hsep . catMaybes $ [nname, nargs, nprops, nchildren]-   where-    nann = case nodeAnn n of-      Nothing -> ""-      Just a  -> parens (pretty a)-    nname = Just $ nann <> pretty (nodeName n)-    nargs = case nodeArgs n of-      []  -> Nothing-      nas -> Just . hsep . map pretty $ nas-    nprops | nodeProps n == Map.empty = Nothing-           | otherwise                = Just (pretty (nodeProps n))-    nchildren = case nodeChildren n of-      [] -> Nothing-      ncs ->-        Just-          . nest 4-          . braces-          . enclose "\n" (nest (-4) "\n")-          . vsep-          . map pretty-          $ ncs--instance Pretty Document where-  pretty d = vsep (map pretty (docNodes d)) <> "\n"--instance Show Document where-  show d = show (pretty d)

@@ -1,96 +0,0 @@-{- FOURMOLU_DISABLE -}-{-# LANGUAGE OverloadedStrings #-}--{- | Vendered from https://github.com/fuzzypixelz/hustle -}-module Data.KDL.Parser.Hustle.Internal where--import           Control.Monad                  ( void )-import           Data.Char                      ( digitToInt-                                                , isDigit-                                                )-import           Data.Either                    ( isRight )-import           Data.Scientific                ( Scientific )-import qualified Data.Scientific               as Sci-import           Data.Text                      ( Text )-import qualified Data.Text                     as T-import           Data.KDL.Parser.Hustle.Types   ( Parser )-import           Text.Megaparsec                ( (<|>)-                                                , MonadParsec-                                                  ( eof-                                                  , takeWhileP-                                                  , try-                                                  )-                                                , option-                                                , runParser-                                                , satisfy-                                                )-import           Text.Megaparsec.Char           ( char-                                                , char'-                                                , digitChar-                                                , newline-                                                )-import qualified Text.Megaparsec.Char.Lexer    as L--signed :: Num a => Parser a -> Parser a-signed p = option id sign <*> p-  where sign = (id <$ char '+') <|> (negate <$ char '-')--lineComment :: Parser ()-lineComment = L.skipLineComment "//" >> (void newline <|> eof)--blockComment :: Parser ()-blockComment = L.skipBlockCommentNested "/*" "*/"--isBinDigit :: Char -> Bool-isBinDigit c = c `elem` ['0', '1']--data SP = SP Integer Int--number :: Integer -> (Char -> Bool) -> Parser Integer-number b isNumDigit = mkNum . T.filter (/= '_') <$> digits- where-  mkNum = T.foldl' step 0-  step a c = a * b + fromIntegral (digitToInt c)-  digits = T.cons <$> satisfy isNumDigit <*> takeWhileP-    (Just "digit")-    (\c -> isNumDigit c || c == '_')--decimal_ :: Parser Integer-decimal_ = number 10 isDigit--scientific_ :: Parser Scientific-scientific_ = do-  c'      <- decimal_-  SP c e' <- dotDecimal_ c'-  e       <- option e' (try $ exponent_ e')-  return (Sci.scientific c e)--dotDecimal_ :: Integer -> Parser SP-dotDecimal_ c' = do-  void (char '.')-  let digits = T.cons <$> digitChar <*> takeWhileP-        (Just "digit")-        (\c -> isDigit c || c == '_')-  let mkNum = T.foldl' step (SP c' 0)-      step (SP a e') c = SP (a * 10 + fromIntegral (digitToInt c)) (e' - 1)-  mkNum . T.filter (/= '_') <$> digits--exponent_ :: Int -> Parser Int-exponent_ e' = do-  void (char' 'e')-  (+ e') <$> L.signed (return ()) (fromIntegral <$> decimal_)--match :: Parser a -> Text -> Bool-match p t = isRight $ runParser (p >> eof) "" t--escChar :: Char -> Text-escChar c = case c of-  '\x08' -> "\\b"-  '\x09' -> "\\t"-  '\x0A' -> "\\n"-  '\x0C' -> "\\f"-  '\x0D' -> "\\r"-  '\x22' -> "\\\""-  '\x2F' -> "\\/"-  '\x5C' -> "\\\\"-  _      -> T.singleton c

@@ -1,310 +0,0 @@-{- FOURMOLU_DISABLE -}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}--{- | Vendered from https://github.com/fuzzypixelz/hustle -}-module Data.KDL.Parser.Hustle.Parser where--import           Data.KDL.Parser.Hustle.Internal-import           Data.KDL.Parser.Hustle.Types--import           Control.Monad                  ( void )-import           Data.Char                      ( chr-                                                , isHexDigit-                                                , isOctDigit-                                                , isDigit-                                                , isSpace-                                                )-import qualified Data.Map.Strict               as Map-import           Data.Maybe                     ( catMaybes-                                                , fromMaybe-                                                , mapMaybe-                                                , maybeToList-                                                )-import           Data.Scientific                ( Scientific )-import           Data.Text                      ( Text )-import qualified Data.Text                     as T-import           Text.Megaparsec                ( (<?>)-                                                , (<|>)-                                                , MonadParsec(eof, label, try)-                                                , anySingle-                                                , between-                                                , choice-                                                , many-                                                , manyTill-                                                , noneOf-                                                , optional-                                                , satisfy-                                                , some-                                                )-import           Text.Megaparsec.Char           ( char-                                                , char'-                                                , crlf-                                                , newline-                                                , string-                                                )---- WHITESPACE--escline :: Parser ()-escline =-  char '\\' >> many ws >> (try linebreak <|> lineComment) <?> "Escape Line"--linespace :: Parser ()-linespace = try linebreak <|> try ws <|> try lineComment <?> "Line Space"--linebreak :: Parser ()-linebreak = label "Newline" $ do-  choice $ void crlf : map-    void-    [ char '\r' <?> "carriage return"-    , char '\n' <?> "newline"-    , char '\x85' <?> "next line"-    , char '\f' <?> "form feed"-    , char '\x2028' <?> "line seperator"-    , char '\x2029' <?> "paragraph seperator"-    ]--ws :: Parser ()-ws = bom <|> hspacechar <|> blockComment <?> "Whitespace"--bom :: Parser ()-bom = void (char '\xFEFF') <?> "BOM"--hspacechar :: Parser ()-hspacechar = label "Unicode Space" $ do-  choice $ map-    void-    [ char '\x0009' <?> "character tabulation"-    , char '\x0020' <?> "space"-    , char '\x00A0' <?> "bo-break space"-    , char '\x1680' <?> "ogham space mark"-    , char '\x2000' <?> "en quad"-    , char '\x2001' <?> "em quad"-    , char '\x2002' <?> "en space"-    , char '\x2003' <?> "em space"-    , char '\x2004' <?> "three-per-em space"-    , char '\x2005' <?> "four-per-em space"-    , char '\x2006' <?> "six-per-em space"-    , char '\x2007' <?> "figure space"-    , char '\x2008' <?> "punctuation space"-    , char '\x2009' <?> "thin space"-    , char '\x200A' <?> "hair space"-    , char '\x202F' <?> "narrow no-break space"-    , char '\x205F' <?> "medium mathmatical space"-    , char '\x3000' <?> "ideographic space"-    ]---- STRINGS--anystring :: Parser Text-anystring = try unquotedstring <|> try rawstring <|> quotedstring--unquotedstring :: Parser Text-unquotedstring = label "Unquoted String" $ do-  c0 <- satisfy $ \c -> isValidChar c && not (isDigit c) && c /= '"'-  rest <- many $ satisfy isValidChar-  -- TODO: Forbid true, false, null, inf, -inf, nan, or "looks like a number"-  pure $ T.pack (c0 : rest)-  where-    isValidChar c = not (isSpace c) && c `notElem` ("[]{}()\\/#\";=" :: [Char])--quotedstring :: Parser Text-quotedstring = label "Quoted String" $ do-  T.concat <$> (char '"' *> manyTill character (char '"'))--rawstring :: Parser Text-rawstring = label "Raw String" $ do-  void (char 'r')-  hs <- T.pack <$> many (char '#')-  void (char '"')-  s <- manyTill anySingle (string (T.cons '"' hs))-  return (T.pack s)--character :: Parser Text-character = void (char '\\') *> escape <|> nonescape--{--  As per the Haskell 2010 Language Report,-  (https://www.haskell.org/onlinereport/haskell2010/haskellch2.html#x7-200002.6)-  The '\/' Solidus escape isn't defined, so if we try to parse it directly the-  compiler throws a lexical error. Hence this terribleness.--}-escape :: Parser Text-escape =-  do-    e <- choice-      [ '\x08' <$ char 'b'-      , '\x09' <$ char 't'-      , '\x0A' <$ char 'n'-      , '\x0C' <$ char 'f'-      , '\x0D' <$ char 'r'-      , '\x22' <$ char '\"'-      , '\x2F' <$ char '/'-      , '\x5C' <$ char '\\'-      ]-    return (T.singleton e)-  <|> uescape--uescape :: Parser Text-uescape = do-  void (string "u{")-  u <- fromInteger <$> number 16 isHexDigit-  if u >= 0x10ffff-    then fail "Exceeded Unicode code point limit."-    else do-      void (char '}')-      let c = chr u-      return (T.singleton c)--nonescape :: Parser Text-nonescape = do-  c <- noneOf ("\\\"" :: [Char])-  return (T.singleton c)---- NUMBERS--binary :: Parser Integer-binary = signed $ char '0' >> char' 'b' >> number 2 isBinDigit--octal :: Parser Integer-octal = signed $ char '0' >> char 'o' >> number 8 isOctDigit--hexadecimal :: Parser Integer-hexadecimal = signed $ char '0' >> char 'x' >> number 16 isHexDigit--integer :: Parser Integer-integer = signed decimal_--scientific :: Parser Scientific-scientific = signed scientific_---- CONTENT--name :: Parser Identifier-name = Identifier <$> (try anystring <|> identifier)--identifier :: Parser Text-identifier = label "Identifier" $ do-  i  <- satisfy iichar-  is <- many (satisfy ichar)-  let result = T.pack (i : is)-  case result of-    "true"  -> fail "keyword true in identifier"-    "false" -> fail "keyword false in identifier"-    "null"  -> fail "keyword null in identifier"-    _       -> return result- where-  ichar c =-    (c > '\x20')-      && (c <= '\x10FFFF')-      && (c `notElem` ("\\/(){}<>;[]=,\"" :: [Char]))-      && not (match linespace (T.singleton c))-  iichar c = ichar c && c `notElem` ['0' .. '9']--nullvalue :: Parser Text-nullvalue = string "null"--bool :: Parser Bool-bool = True <$ string "true" <|> False <$ string "false"--property :: Parser (Identifier, Value)-property = label "Property" $ do-  propKey <- name-  void (char '=')-  propValue <- value-  return (propKey, propValue)--value :: Parser Value-value = label "Value" $ do-  valueAnn <- optional typeAnnotation-  valueExp <- choice-    [ IntegerValue <$> try binary <?> "Binary"-    , IntegerValue <$> try octal <?> "Octal"-    , IntegerValue <$> try hexadecimal <?> "Hexadecimal"-    , SciValue <$> try scientific <?> "Decimal"-    , IntegerValue <$> try integer <?> "Integer"-    , BooleanValue <$> try bool <?> "Boolean"-    , NullValue <$ try nullvalue <?> "Null"-    , StringValue <$> anystring <?> "String"-    ]-  return Value { .. }--typeAnnotation :: Parser Identifier-typeAnnotation = label "Type Annotation" $ do-  void (char '(')-  i <- name-  void (char ')')-  return i---- NODES--nodes :: Parser [Node]-nodes = between (many linespace) (many linespace) (fromMaybe [] <$> body)- where-  body = optional $ do-    n  <- maybeToList <$> node-    ns <- fromMaybe [] <$> optional nodes-    return (n ++ ns)--node :: Parser (Maybe Node)-node = label "Node" $ do-  discard      <- optional comment-  nodeAnn      <- optional typeAnnotation-  nodeName     <- name-  nodeContent  <- catMaybes <$> content-  nodeChildren <- fromMaybe [] <$> optional children-  _            <- many nodespace-  _            <- terminator-  let nodeArgs  = mapMaybe isArg nodeContent-      nodeProps = Map.fromList $ mapMaybe isProp nodeContent-  case discard of-    Just _  -> return Nothing-    Nothing -> return $ Just Node { .. }- where-  isArg c = case c of-    NodeValue v -> Just v-    _           -> Nothing-  isProp c = case c of-    NodeProperty p -> Just p-    _              -> Nothing--content :: Parser [Maybe Content]-content = many . try $ do-  void (some nodespace)-  discard <- optional $ comment <* many nodespace-  c       <- choice [NodeProperty <$> try property, NodeValue <$> try value]-  case discard of-    Just _  -> return Nothing-    Nothing -> return $ Just c--children :: Parser [Node]-children = label "Node Child" . try $ do-  void (many nodespace)-  discard <- optional comment-  void (char '{')-  ns <- nodes-  void (char '}')-  void (many ws)-  case discard of-    Just _  -> return []-    Nothing -> return ns--comment :: Parser ()-comment = label "/-Comment" . try $ do-  void (string "/-")-  void $ many nodespace--nodespace :: Parser ()-nodespace = label "Node Space" $ do-  try (many ws *> escline <* many ws) <|> try (void $ some ws)--terminator :: Parser ()-terminator = label "Node Terminator" $ do-  choice [try (void (char ';')), try (void newline), try lineComment, eof]--document :: Parser Document-document = do-  docNodes <- nodes-  void eof-  return Document { .. }

@@ -1,73 +0,0 @@-{- FOURMOLU_DISABLE -}-{- | Vendered from https://github.com/fuzzypixelz/hustle -}-module Data.KDL.Parser.Hustle.Types-  ( Parser-  , Document(..)-  , Content(..)-  , Node(..)-  , Value(..)-  , ValueType(..)-  , Identifier(..)-  ) where--import           Data.Map                       ( Map )-import           Data.Scientific                ( Scientific )-import           Data.Text                      ( Text )-import           Data.Void                      ( Void )-import           Text.Megaparsec                ( Parsec )--{--  String has exactly one use, -  and that’s showing Hello World in tutorials.-                  -- Albert Einstein--}-type Parser = Parsec Void Text--newtype Document = Document-  { docNodes :: [Node]-  }-  deriving (Eq)--{- -  This data type serves as an abstraction over Values-  and Properties of a Node, in order simplify the the node-  Parser, i.e group the two types together to-  consume any number of them in any order. --}-data Content-  = NodeValue    { getValue :: Value }-  | NodeProperty { getProp :: (Identifier, Value) }-  deriving (Eq)--data Node = Node-  { nodeAnn      :: Maybe Identifier-  , nodeName     :: Identifier-  , nodeArgs     :: [Value]-  , nodeProps    :: Map Identifier Value-  , nodeChildren :: [Node]-  }-  deriving (Show, Eq)--newtype Identifier = Identifier Text-  deriving (Show, Eq)--data Value = Value-  { valueAnn :: Maybe Identifier-  , valueExp :: ValueType-  }-  deriving (Show, Eq)--data ValueType-  = StringValue Text-  | IntegerValue Integer-  | SciValue Scientific-  | BooleanValue Bool-  | NullValue-  deriving (Show, Eq)--{- -  This allows for querying properties in alphabetical order-  upon printing out, the rest is handled automatically by Map.--}-instance Ord Identifier where-  Identifier t1 `compare` Identifier t2 = t1 `compare` t2

@@ -1,132 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedRecordDot #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}--module Data.KDL.Render (-  render,--  -- * Rendering components-  renderAnn,-  renderValue,-  renderValueData,-  renderIdentifier,-) where--import Data.Char (isDigit)-import Data.KDL.Types (-  Ann (..),-  AnnFormat (..),-  Document,-  Identifier (..),-  IdentifierFormat (..),-  Value (..),-  ValueData (..),-  ValueFormat (..),- )-import Data.Text (Text)-import Data.Text qualified as Text---- TODO: Implement render after parsing Document with formatting information-render :: Document -> Text-render = error "render is not implemented yet"--renderAnn :: Ann -> Text-renderAnn Ann{..} =-  Text.concat-    [ maybe "" (.leading) format-    , "("-    , maybe "" (.before_id) format-    , renderIdentifier identifier-    , maybe "" (.after_id) format-    , ")"-    , maybe "" (.trailing) format-    ]--renderValue :: Value -> Text-renderValue Value{..} =-  Text.concat-    [ maybe "" renderAnn ann-    , maybe (renderValueData data_) (.repr) format-    ]--renderValueData :: ValueData -> Text-renderValueData = \case-  Text s -> renderString s-  Number x -> (Text.pack . show) x-  Bool b -> if b then "#true" else "#false"-  Null -> "#null"- where-  renderString s = if isPlainIdent s then s else "\"" <> Text.concatMap escapeChar s <> "\""-  isPlainIdent s =-    and . map not $-      [ Text.any isDisallowedChar s-      , case fmap Text.uncons <$> Text.uncons s of-          Just (c, _) | isDigit c -> True-          Just (c0, Just (c1, _))-            | c0 `elem` ['.', '-', '+']-            , isDigit c1 ->-                True-          _ -> False-      , s `elem` ["inf", "-inf", "nan", "true", "false", "null"]-      ]-  isDisallowedChar c =-    or-      [ c `elem` disallowedIdentChars-      , any (c `Text.elem`) newlines-      , c `elem` unicodeSpaces-      , isDisallowedUnicode c-      , c == '='-      ]-  disallowedIdentChars = ['\\', '/', '(', ')', '{', '}', '[', ']', ';', '"', '#']-  newlines =-    [ "\x000D\x000A"-    , "\x000D"-    , "\x000A"-    , "\x0085"-    , "\x000B"-    , "\x000C"-    , "\x2028"-    , "\x2029"-    ]-  unicodeSpaces =-    [ '\x0009'-    , '\x0020'-    , '\x00A0'-    , '\x1680'-    , '\x2000'-    , '\x2001'-    , '\x2002'-    , '\x2003'-    , '\x2004'-    , '\x2005'-    , '\x2006'-    , '\x2007'-    , '\x2008'-    , '\x2009'-    , '\x200A'-    , '\x202F'-    , '\x205F'-    , '\x3000'-    ]-  isDisallowedUnicode c =-    or-      [ '\x0000' < c && c <= '\x0008'-      , '\x000E' < c && c <= '\x001F'-      , '\x200E' < c && c <= '\x200F'-      , '\x202A' < c && c <= '\x202E'-      , '\x2066' < c && c <= '\x2069'-      , c == '\xFEFF'-      ]-  escapeChar = \case-    '\\' -> "\\\\"-    '"' -> "\\\""-    '\n' -> "\\n"-    '\r' -> "\\r"-    '\t' -> "\\t"-    '\x08' -> "\\b"-    '\x0C' -> "\\f"-    c -> Text.singleton c--renderIdentifier :: Identifier -> Text-renderIdentifier ident = maybe ident.value (.repr) ident.format

@@ -1,367 +0,0 @@-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedRecordDot #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE NoFieldSelectors #-}--{-|-Defines the types that make up a KDL document.--This module enables @-XNoFieldSelectors@, so none of the fields create implicit-selector functions. Instead, use @-XOverloadedRecordDot@, or the functions-provided by this module.--}-module Data.KDL.Types (-  -- * Document-  Document,-  docNodes,--  -- * NodeList-  NodeList (..),-  NodeListFormat (..),-  fromNodeList,-  nodeListFormat,--  -- ** Helpers-  filterNodes,-  lookupNode,-  getArgAt,-  getArgsAt,-  getDashChildrenAt,-  getDashNodesAt,--  -- * Node-  Node (..),-  NodeFormat (..),-  nodeAnn,-  nodeName,-  nodeEntries,-  nodeChildren,-  nodeFormat,--  -- ** Helpers-  getArgs,-  getArg,-  getProps,-  getProp,--  -- * Entry-  Entry (..),-  EntryFormat (..),-  entryName,-  entryValue,-  entryFormat,--  -- * Value-  Value (..),-  ValueFormat (..),-  valueAnn,-  valueData,-  valueFormat,-  ValueData (..),--  -- * Ann-  Ann (..),-  AnnFormat (..),-  annIdentifier,-  annFormat,--  -- * Identifier-  Identifier (..),-  IdentifierFormat (..),-  fromIdentifier,-  identifierFormat,-  toIdentifier,-) where--import Control.Monad ((<=<))-import Data.Map (Map)-import Data.Map qualified as Map-import Data.Maybe (listToMaybe, mapMaybe)-import Data.Scientific (Scientific)-import Data.Text (Text)--{----- Document -----}--type Document = NodeList--docNodes :: Document -> [Node]-docNodes = fromNodeList--{----- NodeList -----}--data NodeList = NodeList-  { nodes :: [Node]-  , format :: Maybe NodeListFormat-  }-  deriving (Show, Eq)--data NodeListFormat = NodeListFormat-  { leading :: Text-  -- ^ Whitespace and comments preceding the document's first node.-  , trailing :: Text-  -- ^ Whitespace and comments following the document's last node.-  }-  deriving (Show, Eq)--fromNodeList :: NodeList -> [Node]-fromNodeList = (.nodes)--nodeListFormat :: NodeList -> Maybe NodeListFormat-nodeListFormat = (.format)---- | A helper to get all nodes with the given name-filterNodes :: Text -> NodeList -> [Node]-filterNodes name = filter ((== name) . (.name.value)) . (.nodes)---- | A helper to get the first node with the given name-lookupNode :: Text -> NodeList -> Maybe Node-lookupNode name = listToMaybe . filterNodes name---- | A helper to get the first argument of the first node with the given name.--- A utility for nodes that are acting like a key-value store.------ == __Example__------ @--- let---   config =---     """---     foo 1---     """--- Right doc <- pure $ parse config--- getArgAt "foo" doc == Just (Number 1)--- @-getArgAt :: Text -> NodeList -> Maybe Value-getArgAt name = listToMaybe . getArgsAt name---- | A helper to get 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.------ == __Example__------ @--- let---   config =---     """---     foo 1 2 "test"---     """--- Right doc <- pure $ parse config--- getArgsAt "foo" doc == [Number 1, Number 2, Text "test"]--- @-getArgsAt :: Text -> NodeList -> [Value]-getArgsAt name = maybe [] getArgs . lookupNode name---- | A helper for getting child values following the KDL convention of being named "-".------ == __Example__------ @--- let---   config =---     """---     foo {---       - 1---       - 2---       - "test"---     }---     """--- Right doc <- pure $ parse config--- getDashChildrenAt "foo" doc == [Number 1, Number 2, Text "test"]--- @-getDashChildrenAt :: Text -> NodeList -> [Value]-getDashChildrenAt name = mapMaybe getArg . getDashNodesAt name---- | A helper for getting child nodes following the KDL convention of being named "-".------ == __Example__------ @--- let---   config =---     """---     foo {---       - 1---       - 2---       - "test"---     }---     """--- Right doc <- pure $ parse config--- mapM getArg (getDashNodesAt "foo" doc) == Just [Number 1, Number 2, Text "test"]--- @-getDashNodesAt :: Text -> NodeList -> [Node]-getDashNodesAt name = maybe [] (filterNodes "-") . (nodeChildren <=< lookupNode name)--{----- Ann -----}--data Ann = Ann-  { identifier :: Identifier-  , format :: Maybe AnnFormat-  }-  deriving (Show, Eq)--data AnnFormat = AnnFormat-  { leading :: Text-  -- ^ Whitespace and comments preceding the annotation itself.-  , before_id :: Text-  -- ^ Whitespace and comments between the opening `(` and the identifier.-  , after_id :: Text-  -- ^ Whitespace and comments between the identifier and the closing `)`.-  , trailing :: Text-  -- ^ Whitespace and comments following the annotation itself.-  }-  deriving (Show, Eq)--annIdentifier :: Ann -> Identifier-annIdentifier = (.identifier)--annFormat :: Ann -> Maybe AnnFormat-annFormat = (.format)--{----- Node -----}--data Node = Node-  { ann :: Maybe Ann-  , name :: Identifier-  , entries :: [Entry]-  , children :: Maybe NodeList-  , format :: Maybe NodeFormat-  }-  deriving (Show, Eq)--data NodeFormat = NodeFormat-  { leading :: Text-  -- ^ Whitespace and comments preceding the node itself.-  , before_children :: Text-  -- ^ Whitespace and comments preceding the node's children block.-  , before_terminator :: Text-  -- ^ Whitespace and comments right before the node's terminator.-  , terminator :: Text-  -- ^ The terminator for the node.-  , trailing :: Text-  -- ^ Whitespace and comments following the node, after the terminator.-  }-  deriving (Show, Eq)--nodeAnn :: Node -> Maybe Ann-nodeAnn = (.ann)--nodeName :: Node -> Identifier-nodeName = (.name)--nodeEntries :: Node -> [Entry]-nodeEntries = (.entries)--nodeChildren :: Node -> Maybe NodeList-nodeChildren = (.children)--nodeFormat :: Node -> Maybe NodeFormat-nodeFormat = (.format)---- | Get all the positional arguments of the node.-getArgs :: Node -> [Value]-getArgs node =-  [ value-  | Entry{name = Nothing, value} <- node.entries-  ]---- | Get the first argument of the node.-getArg :: Node -> Maybe Value-getArg = listToMaybe . getArgs---- | Get the properties of the node.-getProps :: Node -> Map Text Value-getProps node =-  Map.fromList-    [ (name.value, value)-    | Entry{name = Just name, value} <- node.entries-    ]---- | Get the property with the given name in the node.-getProp :: Text -> Node -> Maybe Value-getProp name = Map.lookup name . getProps--{----- Entry -----}--data Entry = Entry-  { name :: Maybe Identifier-  -- ^ The name of the entry, if it's a property, Nothing if it's a positional arg-  , value :: Value-  , format :: Maybe EntryFormat-  }-  deriving (Show, Eq)--data EntryFormat = EntryFormat-  { leading :: Text-  -- ^ Whitespace and comments preceding the entry itself.-  , after_key :: Text-  -- ^ Whitespace and comments between an entry's key name and its equals sign.-  , after_eq :: Text-  -- ^ Whitespace and comments between an entry's equals sign and its value.-  , trailing :: Text-  -- ^ Whitespace and comments following the entry itself.-  }-  deriving (Show, Eq)--entryName :: Entry -> Maybe Identifier-entryName = (.name)--entryValue :: Entry -> Value-entryValue = (.value)--entryFormat :: Entry -> Maybe EntryFormat-entryFormat = (.format)--{----- Value -----}--data Value = Value-  { ann :: Maybe Ann-  , data_ :: ValueData-  , format :: Maybe ValueFormat-  }-  deriving (Show, Eq)--data ValueFormat = ValueFormat-  { repr :: Text-  -- ^ The actual text representation of the value.-  }-  deriving (Show, Eq)--valueAnn :: Value -> Maybe Ann-valueAnn = (.ann)--valueData :: Value -> ValueData-valueData = (.data_)--valueFormat :: Value -> Maybe ValueFormat-valueFormat = (.format)--data ValueData-  = Text Text-  | Number Scientific-  | Bool Bool-  | Null-  deriving (Show, Eq)--{----- Identifier -----}--data Identifier = Identifier-  { value :: Text-  , format :: Maybe IdentifierFormat-  }-  deriving (Show, Eq, Ord)--data IdentifierFormat = IdentifierFormat-  { repr :: Text-  }-  deriving (Show, Eq, Ord)--fromIdentifier :: Identifier -> Text-fromIdentifier = (.value)--identifierFormat :: Identifier -> Maybe IdentifierFormat-identifierFormat = (.format)--toIdentifier :: Text -> Identifier-toIdentifier value = Identifier{value = value, format = Nothing}

@@ -0,0 +1,74 @@+{-|+This module is intended to be imported qualified as:++> import KDL qualified++This provides a Monad interface for decoding KDL files, which is sufficient for+most cases. You may wish to use "KDL.Arrow" if you would like to+statically analyze a decoder's schema, e.g. to generate documentation.++= Quickstart++Given a file @config.kdl@:++@+package {+  name my-pkg+  version "1.2.3"++  dependencies {+    aeson ">= 2.2.3.0" optional=#true+    text ">= 2"+  }+}+@++Parse it with @kdl-hs@:++@+import KDL qualified++main :: IO ()+main = do+  config <- KDL.decodeFileWith decoder "config.kdl"+  print config++decoder :: KDL.DocumentDecoder Config+decoder = KDL.document $ do+  KDL.node "package"++data Config = Config+  { name :: Text+  , version :: Text+  , dependencies :: Map Text Dep+  }+  deriving (Show)++data Dep = Dep+  { version :: Text+  , optional :: Bool+  }+  deriving (Show)++instance KDL.DecodeNode Config where+  nodeDecoder = do+    name <- KDL.argAt "name"+    version <- KDL.argAt "version"+    dependencies <- KDL.nodeWith "dependencies" . KDL.children $ KDL.remainingNodes+    pure Config{..}++instance KDL.DecodeNode Dep where+  nodeDecoder = do+    version <- KDL.arg+    optional <- KDL.option False $ KDL.prop "optional"+    pure Dep{..}+@+-}+module KDL (+  module X,+) where++import KDL.Decoder as X+import KDL.Parser as X+import KDL.Render as X+import KDL.Types as X

@@ -0,0 +1,78 @@+{-|+This module defines the Arrow interface for decoding a KDL document. Intended to+be imported qualified as:++> import KDL.Arrow qualified as KDL++For most use-cases, the Monad interface exported by "KDL" is sufficient. You+may wish to use the Arrow interface if you would like to statically analyze a+decoder's schema, e.g. to generate documentation.++= Quickstart++Given a file @config.kdl@:++@+package {+  name my-pkg+  version "1.2.3"++  dependencies {+    aeson ">= 2.2.3.0" optional=#true+    text ">= 2"+  }+}+@++Parse it with:++@+{\-# LANGUAGE Arrows #-\}++import KDL.Arrow qualified as KDL++main :: IO ()+main = do+  config <- KDL.decodeFileWith decoder "config.kdl"+  print config++decoder :: KDL.DocumentDecoder Config+decoder = KDL.document $ proc () -> do+  KDL.node "package" -< ()++data Config = Config+  { name :: Text+  , version :: Text+  , dependencies :: Map Text Dep+  }+  deriving (Show)++data Dep = Dep+  { version :: Text+  , optional :: Bool+  }+  deriving (Show)++instance KDL.DecodeNode Config where+  nodeDecoder = proc () -> do+    name <- KDL.argAt "name" -< ()+    version <- KDL.argAt "version" -< ()+    dependencies <- KDL.nodeWith "dependencies" . KDL.children $ KDL.remainingNodes -< ()+    returnA -< Config{..}++instance KDL.DecodeNode Dep where+  nodeDecoder = proc () -> do+    version <- KDL.arg -< ()+    optional <- KDL.option False $ KDL.prop "optional" -< ()+    returnA -< Dep{..}+@+-}+module KDL.Arrow (+  module X,+) where++import KDL.Decoder.Arrow as X+import KDL.Decoder.Schema as X+import KDL.Parser as X+import KDL.Render as X+import KDL.Types as X

@@ -0,0 +1,10 @@+module KDL.Decoder (+  -- * Decoder monad+  module KDL.Decoder.Monad,++  -- * Schema+  module KDL.Decoder.Schema,+) where++import KDL.Decoder.Monad+import KDL.Decoder.Schema

@@ -0,0 +1,1060 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module KDL.Decoder.Arrow (+  decodeWith,+  decodeFileWith,+  decodeDocWith,++  -- * Decoder+  Decoder,+  module KDL.Decoder.Internal.DecodeM,+  fail,+  withDecoder,+  debug,++  -- * 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,+  text,+  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.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.Schema (+  Schema (..),+  SchemaItem (..),+  SchemaOf,+  TypedNodeSchema (..),+  TypedValueSchema (..),+ )+import KDL.Parser (parse, parseFile)+import KDL.Types (+  Ann (..),+  Document,+  Entry (..),+  Identifier (..),+  Node (..),+  NodeList (..),+  Value (..),+  ValueData (..),+ )+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 decoder = decodeFromParseResult decoder . 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 decoder = fmap (decodeFromParseResult decoder) . parseFile++-- | Decode an already-parsed 'Document' with the given decoder.+decodeDocWith :: DocumentDecoder a -> Document -> Either DecodeError a+decodeDocWith (UnsafeDocumentDecoder decoder) doc =+  runDecodeM . runDecodeStateM doc emptyDecodeHistory $+    decoder.run ()++decodeFromParseResult :: DocumentDecoder a -> Either Text Document -> Either DecodeError a+decodeFromParseResult decoder = \case+  Left e -> runDecodeM . decodeThrow $ DecodeError_ParseError e+  Right doc -> decodeDocWith decoder 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 decoder =+  UnsafeDocumentDecoder+    decoder+      { run = \() -> do+          a <- decoder.run ()+          validateNodeList+          pure a+      }++-- | Get the schema of a 'DocumentDecoder'.+--+-- The schema is statically determined without running the decoder.+documentSchema :: DocumentDecoder a -> SchemaOf NodeList+documentSchema (UnsafeDocumentDecoder decoder) = decoder.schema++{----- Decoding NodeList -----}++type NodeListDecoder a = NodeListDecodeArrow () a+type NodeListDecodeArrow a b = DecodeArrow NodeList a b++getNodeIndex :: Text -> DecodeState NodeList -> Int+getNodeIndex name = Map.findWithDefault 0 name . (.history.nodesSeen)++validateNodeList :: StateT (DecodeState NodeList) DecodeM ()+validateNodeList = do+  nodeList <- StateT.gets (.object)+  case nodeList.nodes of+    [] -> pure ()+    node_ : _ -> do+      let identifier = node_.name+      index <- StateT.gets (getNodeIndex identifier.value)+      Trans.lift . decodeThrow $+        DecodeError_UnexpectedNode+          { identifier = identifier+          , index = 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 name = withDecodeNode $ nodeWith' 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 name = nodeWith' name []++-- | Same as 'nodeWith', except allow specifying type annotations.+nodeWith' :: forall a b. (Typeable b) => Text -> [Text] -> NodeDecodeArrow a b -> NodeListDecodeArrow a b+nodeWith' name =+  withTypedNodeDecoder $ \schema decodeNode ->+    DecodeArrow (SchemaOne $ NodeNamed name schema) $ \a -> do+      decodeFirstNodeWhere ((== name) . (.name.value)) (decodeNode a) >>= \case+        Just (_, b) -> pure b+        Nothing -> do+          index <- StateT.gets (getNodeIndex name)+          Trans.lift $ decodeThrow DecodeError_ExpectedNode{name = name, index = index}++decodeFirstNodeWhere ::+  (Node -> Bool) ->+  (Node -> DecodeM a) ->+  StateT (DecodeState NodeList) DecodeM (Maybe (Node, a))+decodeFirstNodeWhere matcher decodeNode = do+  nodes <- StateT.gets (.object.nodes)+  case extractFirst matcher nodes of+    Nothing -> do+      pure Nothing+    Just (node_, nodes') -> do+      let name = node_.name+      index <- StateT.gets (getNodeIndex name.value)+      StateT.modify $ \s -> s{object = s.object{nodes = nodes'}}+      b <-+        Trans.lift . makeFatal . addContext ContextNode{name = name, index = index} $+          decodeNode node_+      StateT.modify $ \s -> s{history = s.history{nodesSeen = inc name.value s.history.nodesSeen}}+      pure $ Just (node_, b)+ where+  inc k = Map.insertWith (+) k 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 = withDecodeNode 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 = 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' =+  withTypedNodeDecoder $ \schema decodeNode ->+    DecodeArrow (SchemaOne $ RemainingNodes schema) $ \a -> do+      Map.fromListWith (<>) <$> go (decodeNode a)+ where+  go decodeNode = do+    decodeFirstNodeWhere (const True) decodeNode >>= \case+      Nothing -> pure []+      Just (node_, b) -> do+        nodeMap <- go decodeNode+        pure $ (node_.name.value, [b]) : 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 name = withDecodeValue $ argAtWith' 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 name = argAtWith' name []++-- | Same as 'argAtWith', except allow specifying type annotations.+argAtWith' :: forall a b. (Typeable b) => Text -> [Text] -> ValueDecodeArrow a b -> NodeListDecodeArrow a b+argAtWith' name typeAnns decoder = nodeWith name $ argWith' typeAnns 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 name = withDecodeValue $ argsAtWith' 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.text -< ()+-- 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 name = argsAtWith' name []++-- | Same as 'argsAtWith', except allow specifying type annotations.+argsAtWith' :: forall a b. (Typeable b) => Text -> [Text] -> ValueDecodeArrow a b -> NodeListDecodeArrow a [b]+argsAtWith' name typeAnns decoder = option [] $ nodeWith name $ many $ argWith' typeAnns 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 name = withDecodeValue $ dashChildrenAtWith' 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.text -< ()+-- KDL.decodeWith decoder config == Right [\"Alice", \"Bob"]+-- @+dashChildrenAtWith :: forall a b. (Typeable b) => Text -> ValueDecodeArrow a b -> NodeListDecodeArrow a [b]+dashChildrenAtWith name = dashChildrenAtWith' name []++-- | Same as 'dashChildrenAtWith', except allow specifying type annotations.+dashChildrenAtWith' :: forall a b. (Typeable b) => Text -> [Text] -> ValueDecodeArrow a b -> NodeListDecodeArrow a [b]+dashChildrenAtWith' name typeAnns decoder = dashNodesAtWith name $ argWith' typeAnns 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 name = withDecodeNode $ \_ decoder -> dashNodesAtWith name 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 name decoder =+  option [] . nodeWith name $+    children $+      many (nodeWith "-" decoder)++{----- Decoding Ann -----}++validateAnn :: [Text] -> Maybe Ann -> DecodeM ()+validateAnn typeAnns mGivenAnn =+  case mGivenAnn of+    Nothing -> pure ()+    Just givenAnn -> do+      let isValidAnn = Prelude.null typeAnns || givenAnn.identifier.value `elem` typeAnns+      unless isValidAnn $ do+        decodeThrow DecodeError_MismatchedAnn{givenAnn = givenAnn.identifier, validAnns = typeAnns}++{----- Decoding Node -----}++withDecodeNode :: forall a r. (DecodeNode a) => ([Text] -> NodeDecoder a -> r) -> r+withDecodeNode k = k (validNodeTypeAnns (Proxy @a)) nodeDecoder++withTypedNodeDecoder ::+  forall a b r.+  (Typeable b) =>+  (TypedNodeSchema -> (a -> Node -> DecodeM b) -> r) ->+  ([Text] -> NodeDecodeArrow a b -> r)+withTypedNodeDecoder k typeAnns decoder = k schema decodeNode+ where+  schema =+    TypedNodeSchema+      { typeHint = typeRep (Proxy @b)+      , validTypeAnns = typeAnns+      , nodeSchema = decoder.schema+      }+  decodeNode a node_ = do+    validateAnn typeAnns node_.ann+    runDecodeStateM node_ emptyDecodeHistory $ do+      -- TODO: add typeHint to Context+      decoder.run a <* validateNode++validateNode :: StateT (DecodeState Node) DecodeM ()+validateNode = do+  node_ <- StateT.gets (.object)+  case node_.entries of+    [] -> pure ()+    Entry{name = Nothing, value} : _ -> do+      index <- StateT.gets getArgIndex+      Trans.lift . decodeThrow $+        DecodeError_UnexpectedArg+          { index = index+          , value = value+          }+    Entry{name = Just identifier, value} : _ -> do+      Trans.lift . decodeThrow $+        DecodeError_UnexpectedProp+          { identifier = identifier+          , value = value+          }+  case node_.children of+    Nothing -> pure ()+    Just children_ -> do+      childrenHistory <- StateT.gets (.history.childrenHistory)+      Trans.lift . runDecodeStateM children_ childrenHistory $ validateNodeList++type NodeDecoder a = NodeDecodeArrow () a+type NodeDecodeArrow a b = DecodeArrow Node a b++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 _ = []++  -- | Decode a t'Node' to a value of type @a@+  nodeDecoder :: NodeDecoder a++instance DecodeNode Node where+  nodeDecoder =+    DecodeArrow SchemaUnknown $ \() -> do+      node_ <- StateT.gets (.object)+      StateT.modify $ \s -> s{object = emptyNode node_.name}+      pure node_+   where+    emptyNode name =+      Node+        { ann = Nothing+        , name = name+        , entries = []+        , children = Nothing+        , format = Nothing+        }++-- | 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 = withDecodeValue 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.text -< ()+--     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 = argWith' []++-- | Same as 'argWith', except allow specifying type annotations.+argWith' :: forall a b. (Typeable b) => [Text] -> ValueDecodeArrow a b -> NodeDecodeArrow a b+argWith' =+  withTypedValueDecoder $ \schema decodeValue ->+    DecodeArrow (SchemaOne $ NodeArg schema) $ \a -> do+      index <- StateT.gets getArgIndex++      entries <- StateT.gets (.object.entries)+      (entry, entries') <-+        maybe (Trans.lift $ decodeThrow DecodeError_ExpectedArg{index = index}) pure $+          extractFirst (isNothing . (.name)) entries+      StateT.modify $ \s -> s{object = s.object{entries = entries'}}++      b <-+        Trans.lift . makeFatal . addContext ContextArg{index = index} $+          decodeValue a entry.value+      StateT.modify $ \s -> s{history = s.history{argsSeen = s.history.argsSeen + 1}}+      pure 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 name = withDecodeValue $ propWith' 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 name = propWith' name []++-- | Same as 'propWith', except allow specifying type annotations.+propWith' :: forall a b. (Typeable b) => Text -> [Text] -> ValueDecodeArrow a b -> NodeDecodeArrow a b+propWith' name =+  withTypedValueDecoder $ \schema decodeValue ->+    DecodeArrow (SchemaOne $ NodeProp name schema) $ \a -> do+      decodeOnePropWhere (== name) (decodeValue a)+        >>= maybe (Trans.lift $ decodeThrow DecodeError_ExpectedProp{name = name}) (pure . snd)++decodeOnePropWhere ::+  (Text -> Bool) ->+  (Value -> DecodeM a) ->+  StateT (DecodeState Node) DecodeM (Maybe (Identifier, a))+decodeOnePropWhere matcher decodeValue = do+  entries <- StateT.gets (.object.entries)+  case findProp entries of+    Nothing -> pure Nothing+    Just (name, prop_, entries') -> do+      StateT.modify $ \s -> s{object = s.object{entries = entries'}}+      b <-+        Trans.lift . makeFatal . addContext ContextProp{name = name} $+          decodeValue prop_.value+      StateT.modify $ \s -> s{history = s.history{propsSeen = Set.insert name s.history.propsSeen}}+      pure $ Just (name, b)+ where+  isPropWhere f entry = (f . (.value) <$> entry.name) == Just True+  findProp entries =+    case break (isPropWhere matcher) entries of+      (entries1, prop0@Entry{name = Just name} : remainingEntries) ->+        -- Collect remaining props with the same name, latter props override earlier props+        let (props, entries2) = partition (isPropWhere (== name.value)) remainingEntries+         in Just (name, NonEmpty.last $ prop0 NonEmpty.:| props, entries1 <> entries2)+      _ ->+        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 = withDecodeValue 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 = 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' =+  withTypedValueDecoder $ \schema decodeValue ->+    DecodeArrow (SchemaOne $ NodeRemainingProps schema) $ \a -> do+      Map.fromList <$> go (decodeValue a)+ where+  go decodeValue =+    decodeOnePropWhere (const True) decodeValue >>= \case+      Nothing -> pure []+      Just (name, b) -> do+        propMap <- go decodeValue+        pure $ (name.value, 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 decoder =+  DecodeArrow (SchemaOne $ NodeChildren decoder.schema) $ \a -> do+    mChildren <- StateT.gets (.object.children)+    childrenHistory <- StateT.gets (.history.childrenHistory)+    (b, decodeState) <-+      Trans.lift $+        StateT.runStateT (decoder.run a) $+          DecodeState+            { object = fromMaybe emptyNodeList mChildren+            , history = childrenHistory+            }+    StateT.modify $ \s ->+      s+        { object = s.object{children = decodeState.object <$ mChildren}+        , history = s.history{childrenHistory = decodeState.history}+        }+    pure b+ where+  emptyNodeList = NodeList{nodes = [], format = Nothing}++{----- Decoding ValueData -----}++withDecodeValue :: forall a r. (DecodeValue a) => ([Text] -> ValueDecoder a -> r) -> r+withDecodeValue k = k (validValueTypeAnns (Proxy @a)) valueDecoder++withTypedValueDecoder ::+  forall a b r.+  (Typeable b) =>+  (TypedValueSchema -> (a -> Value -> DecodeM b) -> r) ->+  ([Text] -> ValueDecodeArrow a b -> r)+withTypedValueDecoder k typeAnns decoder = k schema decodeValue+ where+  schema =+    TypedValueSchema+      { typeHint = typeRep (Proxy @b)+      , validTypeAnns = typeAnns+      , dataSchema = decoder.schema+      }+  decodeValue a value = do+    validateAnn typeAnns value.ann+    runDecodeStateM value emptyDecodeHistory $ do+      -- TODO: add typeHint to Context+      decoder.run 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 _ = []++  -- | 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 = any+instance DecodeValue ValueData where+  valueDecoder = (.data_) <$> any+instance DecodeValue Text where+  validValueTypeAnns _ = ["text"]+  valueDecoder = text+instance DecodeValue String where+  validValueTypeAnns _ = ["string"]+  valueDecoder = Text.unpack <$> text+instance DecodeValue Bool where+  validValueTypeAnns _ = ["bool", "boolean"]+  valueDecoder = bool+instance (DecodeValue a) => DecodeValue (Maybe a) where+  validValueTypeAnns _ = validValueTypeAnns (Proxy @a)+  valueDecoder = oneOf [Nothing <$ null, Just <$> valueDecoder]+instance (DecodeValue a, DecodeValue b) => DecodeValue (Either a b) where+  validValueTypeAnns _ = validValueTypeAnns (Proxy @a) <> validValueTypeAnns (Proxy @b)+  valueDecoder = oneOf [Left <$> valueDecoder, Right <$> valueDecoder]++decodeInt :: (Integral b, Bounded b) => DecodeArrow Value a b+decodeInt = withDecoder number $ \x -> do+  unless (Scientific.isInteger x) $ do+    failM $ "Expected integer, got: " <> (Text.pack . show) x+  maybe (failM $ "Number doesn't fit bounds: " <> (Text.pack . show) x) pure $+    Scientific.toBoundedInteger x+instance DecodeValue Integer where+  validValueTypeAnns _ =+    concat+      [ ["i8", "i16", "i32", "i64", "i128", "isize"]+      , ["u8", "u16", "u32", "u64", "u128", "usize"]+      ]+  valueDecoder = toInteger <$> decodeInt @Int64+instance DecodeValue Int where+  validValueTypeAnns _ =+    concat+      [ ["i8", "i16", "isize"]+      , if bits >= 32 then ["i32"] else []+      , if bits >= 64 then ["i64"] else []+      ]+   where+    bits = finiteBitSize (0 :: Int)+  valueDecoder = decodeInt+instance DecodeValue Int8 where+  validValueTypeAnns _ = ["i8"]+  valueDecoder = decodeInt+instance DecodeValue Int16 where+  validValueTypeAnns _ = ["i16"]+  valueDecoder = decodeInt+instance DecodeValue Int32 where+  validValueTypeAnns _ = ["i32"]+  valueDecoder = decodeInt+instance DecodeValue Int64 where+  validValueTypeAnns _ = ["i64"]+  valueDecoder = decodeInt+instance DecodeValue Word where+  validValueTypeAnns _ =+    concat+      [ ["u8", "u16", "usize"]+      , if bits >= 32 then ["u32"] else []+      , if bits >= 64 then ["u64"] else []+      ]+   where+    bits = finiteBitSize (0 :: Word)+  valueDecoder = decodeInt+instance DecodeValue Word8 where+  validValueTypeAnns _ = ["u8"]+  valueDecoder = decodeInt+instance DecodeValue Word16 where+  validValueTypeAnns _ = ["u16"]+  valueDecoder = decodeInt+instance DecodeValue Word32 where+  validValueTypeAnns _ = ["u32"]+  valueDecoder = decodeInt+instance DecodeValue Word64 where+  validValueTypeAnns _ = ["u64"]+  valueDecoder = decodeInt+instance DecodeValue Natural where+  validValueTypeAnns _ = ["u8", "u16", "u32", "u64", "usize"]+  valueDecoder = withDecoder (valueDecoder @Integer) $ \x -> do+    when (x < 0) $ do+      failM $ "Expected a non-negative number, got: " <> (Text.pack . show) x+    pure $ fromIntegral x++decodeRealFloat :: (RealFloat b) => DecodeArrow Value a b+decodeRealFloat = withDecoder number $ \x -> do+  either (\_ -> failM $ "Number is too small or too large: " <> (Text.pack . show) x) pure $+    Scientific.toBoundedRealFloat x+instance DecodeValue Scientific where+  validValueTypeAnns _ = ["f32", "f64", "decimal64", "decimal128"]+  valueDecoder = number+instance DecodeValue Float where+  validValueTypeAnns _ = ["f32"]+  valueDecoder = decodeRealFloat+instance DecodeValue Double where+  validValueTypeAnns _ = ["f64"]+  valueDecoder = decodeRealFloat+instance DecodeValue Rational where+  validValueTypeAnns _ = ["decimal64", "decimal128"]+  valueDecoder = withDecoder number $ \x -> do+    -- Use toBoundedRealFloat to guard against large values, but use+    -- toRational after checking to maintain precision+    case Scientific.toBoundedRealFloat @Double x of+      Right _ -> pure $ toRational x+      Left _ -> failM $ "Number is too small or too large: " <> (Text.pack . show) x++valueDataDecoderPrim :: SchemaOf Value -> (Value -> DecodeM b) -> DecodeArrow Value a b+valueDataDecoderPrim schema f = DecodeArrow schema $ \_ -> Trans.lift . f =<< StateT.gets (.object)++-- | Decode any value, without any possibility of failure.+any :: DecodeArrow Value a Value+any = valueDataDecoderPrim (SchemaOr $ map SchemaOne [minBound .. maxBound]) pure++-- | Decode a KDL text value.+text :: DecodeArrow Value a Text+text = valueDataDecoderPrim (SchemaOne TextSchema) $ \case+  Value{data_ = Text s} -> pure s+  v -> decodeThrow DecodeError_ValueDecodeFail{expectedType = "text", value = v}++-- | Decode a KDL number value.+number :: DecodeArrow Value a Scientific+number = valueDataDecoderPrim (SchemaOne NumberSchema) $ \case+  Value{data_ = Number x} -> pure x+  v -> decodeThrow DecodeError_ValueDecodeFail{expectedType = "number", value = v}++-- | Decode a KDL bool value.+bool :: DecodeArrow Value a Bool+bool = valueDataDecoderPrim (SchemaOne BoolSchema) $ \case+  Value{data_ = Bool x} -> pure x+  v -> decodeThrow DecodeError_ValueDecodeFail{expectedType = "bool", value = v}++-- | Decode a KDL null value.+null :: DecodeArrow Value a ()+null = valueDataDecoderPrim (SchemaOne NullSchema) $ \case+  Value{data_ = Null} -> pure ()+  v -> decodeThrow DecodeError_ValueDecodeFail{expectedType = "null", value = v}++{----- Utilities -----}++-- | Return the first result that succeeds.+--+-- > oneOf [a, b, c] === a <|> b <|> c <|> empty+oneOf :: (Alternative f) => [f a] -> f a+oneOf = foldr (<|>) 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 a f = f <|> pure a++extractFirst :: (a -> Bool) -> [a] -> Maybe (a, [a])+extractFirst f = go+ where+  go = \case+    [] -> Nothing+    x : xs ->+      if f x+        then Just (x, xs)+        else fmap (x :) <$> go xs

@@ -0,0 +1,94 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoFieldSelectors #-}++module KDL.Decoder.Internal.DecodeM (+  -- * Decoding errors+  module KDL.Decoder.Internal.Error,++  -- * DecodeM monad+  DecodeM (..),+  runDecodeM,+  decodeThrow,+  failM,+  makeFatal,+  makeNonFatal,+  addContext,+) where++import Control.Applicative (Alternative (..))+import Data.Text (Text)+import KDL.Decoder.Internal.Error++-- | The monad that returns either a 'DecodeError' or a result of type @a@.+--+-- To a first approximation, this monad is equivalent to the @Either DecodeError@+-- monad, with the following changes:+--+--   * Uses continuation-passing style for performance+--   * Has two error channels, one for fatal errors and one for non-fatal errors (see 'makeFatal')+--   * Collects as many errors as possible, within an Applicative context+data DecodeM a+  = DecodeM+      ( forall r.+        (DecodeError -> r) -> -- fatal error, not handled by <|>+        (DecodeError -> r) -> -- non-fatal error, handled by <|>+        (a -> r) ->+        r+      )++instance Functor DecodeM where+  fmap f (DecodeM k) = DecodeM $ \onFatal onFail onSuccess -> k onFatal onFail (onSuccess . f)+instance Applicative DecodeM where+  pure x = DecodeM $ \_ _ onSuccess -> onSuccess x+  DecodeM kf <*> DecodeM ka = DecodeM $ \onFatal onFail onSuccess ->+    -- Collect all errors+    kf+      (\e1 -> ka (\e2 -> onFatal $ e1 <> e2) (\e2 -> onFatal $ e1 <> e2) (\_ -> onFatal e1))+      (\e1 -> ka (\e2 -> onFatal $ e1 <> e2) (\e2 -> onFail $ e1 <> e2) (\_ -> onFail e1))+      (\f -> ka onFatal onFail (onSuccess . f))+instance Monad DecodeM where+  (>>) = (*>)+  DecodeM ka >>= k = DecodeM $ \onFatal onFail onSuccess ->+    ka onFatal onFail $ \a -> let DecodeM kb = k a in kb onFatal onFail onSuccess+instance Alternative DecodeM where+  empty = DecodeM $ \_ onFail _ -> onFail mempty+  DecodeM k1 <|> DecodeM k2 = DecodeM $ \onFatal onFail onSuccess ->+    k1+      onFatal+      (\e1 -> k2 onFatal (\e2 -> onFail $ e1 <> e2) onSuccess)+      onSuccess++-- | Run a 'DecodeM' action and return the result or the error.+runDecodeM :: DecodeM a -> Either DecodeError a+runDecodeM (DecodeM f) = f Left Left Right++-- | Throw an error.+--+-- This error is non-fatal and can be handled by '<|>'. See 'makeFatal'+-- for more information.+decodeThrow :: BaseDecodeError -> DecodeM a+decodeThrow e = DecodeM $ \_ onFail _ -> onFail $ DecodeError [([], e)]++-- | Throw a 'DecodeError_Custom' error.+failM :: Text -> DecodeM a+failM = decodeThrow . DecodeError_Custom++-- | Make all errors in the given action fatal errors.+--+-- A la standard parsing libraries like megaparsec, errors should be+-- considered fatal when decoding has started consuming something.+makeFatal :: DecodeM a -> DecodeM a+makeFatal (DecodeM f) = DecodeM $ \onFatal _ onSuccess -> f onFatal onFatal onSuccess++-- | Make all errors non-fatal errors.+makeNonFatal :: DecodeM a -> DecodeM a+makeNonFatal (DecodeM f) = DecodeM $ \_ onFail onSuccess -> f onFail onFail onSuccess++-- | Add context to all errors that occur in the given action.+addContext :: ContextItem -> DecodeM a -> DecodeM a+addContext ctxItem (DecodeM f) = DecodeM $ \onFatal onFail onSuccess -> f (onFatal . addCtx) (onFail . addCtx) onSuccess+ where+  addCtx (DecodeError es) = DecodeError [(ctxItem : ctx, msg) | (ctx, msg) <- es]

@@ -0,0 +1,205 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TypeFamilies #-}++module KDL.Decoder.Internal.Decoder (+  -- * Decoder+  Decoder,++  -- * DecodeArrow+  DecodeArrow (..),+  liftDecodeM,+  withDecoder,+  fail,+  debug,++  -- * DecodeStateM+  DecodeStateM,+  runDecodeStateM,++  -- * DecodeState+  HasDecodeHistory (..),+  DecodeHistory (..),+  DecodeState (..),+) where++import Control.Applicative (+  Alternative (..),+ )+import Control.Arrow (Arrow (..), ArrowChoice (..), (>>>))+import Control.Category (Category)+import Control.Category qualified+import Control.Monad ((>=>))+import Control.Monad.Trans.Class qualified as Trans+import Control.Monad.Trans.State.Strict (StateT)+import Control.Monad.Trans.State.Strict qualified as StateT+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)+import Debug.Trace (traceM)+import KDL.Decoder.Internal.DecodeM+import KDL.Decoder.Schema (+  Schema (..),+  SchemaOf,+  schemaAlt,+  schemaJoin,+ )+import KDL.Types (Identifier, Node, NodeList, Value)+import Prelude hiding (any, fail, null)++class HasDecodeHistory o where+  data DecodeHistory o+  emptyDecodeHistory :: DecodeHistory o++instance HasDecodeHistory NodeList where+  data DecodeHistory NodeList = DecodeHistory_NodeList+    { nodesSeen :: Map Text Int+    }+  emptyDecodeHistory = DecodeHistory_NodeList{nodesSeen = Map.empty}++instance HasDecodeHistory Node where+  data DecodeHistory Node = DecodeHistory_Node+    { argsSeen :: Int+    , propsSeen :: Set Identifier+    , childrenHistory :: DecodeHistory NodeList+    }+  emptyDecodeHistory =+    DecodeHistory_Node+      { argsSeen = 0+      , propsSeen = Set.empty+      , childrenHistory = emptyDecodeHistory+      }++instance HasDecodeHistory Value where+  data DecodeHistory Value = DecodeHistory_Value+  emptyDecodeHistory = DecodeHistory_Value++-- | The state to track when decoding an object of type @o@.+--+-- At each decode step, some value within @o@ is consumed and+-- the action is recorded in the history.+data DecodeState o = DecodeState+  { object :: !o+  , history :: DecodeHistory o+  -- ^ Not strict, since this only matters for reporting errors+  }++type DecodeStateM o a = StateT (DecodeState o) DecodeM a++runDecodeStateM :: o -> DecodeHistory o -> DecodeStateM o a -> DecodeM a+runDecodeStateM o hist m =+  StateT.evalStateT m $+    DecodeState+      { object = o+      , history = hist+      }++-- | @DecodeArrow o a b@ represents an arrow with input @a@ and output @b@, within+-- the context of decoding a KDL object of type @o@. It also knows the expected+-- schema of @o@. Most of the time, @a@ is @()@; it would only be different if+-- you're using Arrows notation.+--+-- We're using arrows here so that we can:+--+--   1. Get the schema without running the decoder, and also+--   2. Use previously decoded values to inform decoding other values+--+-- Using monads alone would lose (1), but applicatives can't do (2).+data DecodeArrow o a b = DecodeArrow+  { schema :: SchemaOf o+  , run :: a -> DecodeStateM o b+  }++instance Category (DecodeArrow o) where+  id = liftDecodeM pure+  DecodeArrow sch2 bc . DecodeArrow sch1 ab = DecodeArrow (sch1 `schemaJoin` sch2) $ ab >=> bc+instance Arrow (DecodeArrow o) where+  arr f = liftDecodeM (pure . f)+  DecodeArrow sch1 bc *** DecodeArrow sch2 bc' =+    DecodeArrow (sch1 `schemaJoin` sch2) $ \(b, b') -> (,) <$> bc b <*> bc' b'+instance ArrowChoice (DecodeArrow o) where+  DecodeArrow sch1 bc +++ DecodeArrow sch2 bc' =+    DecodeArrow (sch1 `schemaAlt` sch2) $ either (fmap Left . bc) (fmap Right . bc')++instance Functor (DecodeArrow o a) where+  fmap f (DecodeArrow schema run) = DecodeArrow schema $ (fmap f . run)+instance Applicative (DecodeArrow o a) where+  pure = arr . const+  DecodeArrow sch1 kf <*> DecodeArrow sch2 kx =+    DecodeArrow (sch1 `schemaJoin` sch2) $ \a -> kf a <*> kx a+instance Alternative (DecodeArrow o a) where+  -- Can't use StateT's Alternative instance: https://hub.darcs.net/ross/transformers/issue/78+  empty = DecodeArrow (SchemaOr []) $ \_ -> Trans.lift empty+  DecodeArrow sch1 run1 <|> DecodeArrow sch2 run2 =+    DecodeArrow (sch1 `schemaAlt` sch2) $ \a -> StateT.StateT $ \s -> do+      StateT.runStateT (run1 a) s <|> StateT.runStateT (run2 a) s+  some (DecodeArrow sch run) =+    DecodeArrow (SchemaSome sch) $ \a ->+      StateT.StateT $+        let go s0 = do+              (x, s1) <- StateT.runStateT (run a) s0+              (xs, s2) <- go s1 <|> pure ([], s1)+              pure (x : xs, s2)+         in go+  many (DecodeArrow sch run) = some (DecodeArrow sch run) <|> pure []++type Decoder o a = DecodeArrow o () a++-- | Eliminates all schema information; avoid whenever possible.+instance Monad (DecodeArrow o a) where+  DecodeArrow _ run1 >>= k =+    DecodeArrow SchemaUnknown $ \a -> do+      x <- run1 a+      let DecodeArrow _ run2 = k x+      run2 a++liftDecodeM :: (a -> DecodeM b) -> DecodeArrow o a b+liftDecodeM f = DecodeArrow (SchemaAnd []) (Trans.lift . f)++-- | Run actions within a t'DecodeArrow'. Useful for adding post-processing logic.+--+-- === __Example__+--+-- @+-- decoder = KDL.withDecoder KDL.number $ \\x -> do+--   when (x > 100)+--     KDL.failM $ "argument is too large: " <> (Text.pack . show) x+--   pure $ MyVal x+-- @+withDecoder :: forall o a b c. DecodeArrow o a b -> (b -> DecodeM c) -> DecodeArrow o a c+withDecoder decoder f = decoder >>> liftDecodeM f++-- | Unconditionally fail the decoder.+--+-- === __Example__+--+-- @+-- decoder = proc () -> do+--   x <- KDL.arg -< ()+--   if x > 100+--     then KDL.fail -\< "argument is too large: " <> (Text.pack . show) x+--     else returnA -< ()+--   returnA -< x+-- @+fail :: forall b o. DecodeArrow o Text b+fail = DecodeArrow (SchemaOr []) (Trans.lift . failM)++-- | Debug the current state of the object being decoded.+--+-- === __Example__+--+-- @+-- decoder = proc () -> do+--   KDL.debug -< ()    -- Node{entries = [Entry{}, Entry{}]}+--   x <- KDL.arg -< ()+--   KDL.debug -< ()    -- Node{entries = [Entry{}]}+--   y <- KDL.arg -< ()+--   KDL.debug -< ()    -- Node{entries = []}+--   returnA -< (x, y)+-- @+debug :: forall o a. (Show o) => DecodeArrow o a ()+debug =+  DecodeArrow (SchemaAnd []) $ \_ -> do+    o <- StateT.gets (.object)+    traceM $ "[kdl-hs] DEBUG: " ++ show o

@@ -0,0 +1,96 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoFieldSelectors #-}++module KDL.Decoder.Internal.Error (+  DecodeError (..),+  BaseDecodeError (..),+  Context,+  ContextItem (..),+  renderDecodeError,+) where++import Data.Map qualified as Map+import Data.Text (Text)+import Data.Text qualified as Text+import KDL.Render (+  renderIdentifier,+  renderValue,+ )+import KDL.Types (+  Identifier,+  Value,+ )++data DecodeError = DecodeError [(Context, BaseDecodeError)]+  deriving (Show, Eq)+instance Semigroup DecodeError where+  DecodeError e1 <> DecodeError e2 = DecodeError (e1 <> e2)+instance Monoid DecodeError where+  mempty = DecodeError []++type Context = [ContextItem]++data ContextItem+  = ContextNode+      { name :: Identifier+      , index :: Int+      }+  | ContextArg+      { index :: Int+      }+  | ContextProp+      { name :: Identifier+      }+  deriving (Show, Eq, Ord)++data BaseDecodeError+  = DecodeError_Custom Text+  | DecodeError_ParseError Text+  | DecodeError_ExpectedNode {name :: Text, index :: Int}+  | DecodeError_ExpectedArg {index :: Int}+  | DecodeError_ExpectedProp {name :: Text}+  | DecodeError_MismatchedAnn {givenAnn :: Identifier, validAnns :: [Text]}+  | DecodeError_ValueDecodeFail {expectedType :: Text, value :: Value}+  | DecodeError_UnexpectedNode {identifier :: Identifier, index :: Int}+  | DecodeError_UnexpectedArg {index :: Int, value :: Value}+  | DecodeError_UnexpectedProp {identifier :: Identifier, value :: Value}+  deriving (Show, Eq)++renderDecodeError :: DecodeError -> Text+renderDecodeError = Text.intercalate "\n" . map renderCtxErrors . groupCtxErrors+ where+  -- Group errors with the same contexts together+  groupCtxErrors (DecodeError es) = Map.toAscList $ Map.fromListWith (<>) [(ctx, [e]) | (ctx, e) <- es]++  renderCtxErrors (ctx, errs) =+    Text.intercalate "\n" $ ("At: " <> renderCtxItems ctx) : renderErrors errs++  renderCtxItems items+    | null items = "<root>"+    | otherwise = Text.intercalate " > " . map renderCtxItem $ items+  renderCtxItem = \case+    ContextNode{..} -> renderIdentifier name <> " #" <> showT index+    ContextArg{..} -> "arg #" <> showT index+    ContextProp{..} -> "prop " <> renderIdentifier name++  renderErrors = map ("  " <>) . concatMap (Text.lines . renderError)+  renderError = \case+    DecodeError_Custom msg -> msg+    DecodeError_ParseError msg -> msg+    DecodeError_ExpectedNode{..}+      | index == 0 -> "Expected node: " <> name+      | otherwise -> "Expected another node: " <> name+    DecodeError_ExpectedArg{..} -> "Expected arg #" <> showT index+    DecodeError_ExpectedProp{..} -> "Expected prop: " <> name+    DecodeError_MismatchedAnn{..} -> "Expected annotation to be one of " <> showT validAnns <> ", got: " <> renderIdentifier givenAnn+    DecodeError_ValueDecodeFail{..} -> "Expected " <> expectedType <> ", got: " <> renderValue value+    DecodeError_UnexpectedNode{..} -> "Unexpected node: " <> renderIdentifier identifier <> " #" <> showT index+    DecodeError_UnexpectedArg{..} -> "Unexpected arg #" <> showT index <> ": " <> renderValue value+    DecodeError_UnexpectedProp{..} -> "Unexpected prop: " <> renderIdentifier identifier <> "=" <> renderValue value++  -- Replace with Text.show after requiring at least text-2.1.2+  showT :: (Show a) => a -> Text+  showT = Text.pack . show

@@ -0,0 +1,25 @@+{-# LANGUAGE LambdaCase #-}++{-|+See "KDL" for more information.+-}+module KDL.Decoder.Monad (+  -- * Monad-specific definitions+  fail,++  -- * Re-exports from "KDL.Decoder.Arrow"+  module KDL.Decoder.Arrow,+) where++import Control.Arrow (arr, (>>>))+import Data.Text (Text)+import KDL.Decoder.Arrow hiding (+  fail,+ )+import KDL.Decoder.Arrow qualified as Arrow+import Prelude hiding (any, fail, null)++-- | Same as 'KDL.Decoder.Arrow.fail', except a more ergonomic signature+-- for use in do-notation.+fail :: forall a o. Text -> Decoder o a+fail msg = arr (\() -> msg) >>> Arrow.fail

@@ -0,0 +1,84 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeFamilies #-}++module KDL.Decoder.Schema (+  SchemaOf,+  Schema (..),+  SchemaItem (..),+  TypedNodeSchema (..),+  TypedValueSchema (..),+  schemaJoin,+  schemaAlt,+) where++import Data.Text (Text)+import Data.Typeable (TypeRep)+import KDL.Types (+  Node,+  NodeList,+  Value,+ )++type SchemaOf o = Schema (SchemaItem o)++data Schema a+  = SchemaOne a+  | SchemaSome (Schema a)+  | SchemaAnd [Schema a]+  | SchemaOr [Schema a]+  | SchemaUnknown+  deriving (Show, Eq)++data family SchemaItem a++data instance SchemaItem NodeList+  = NodeNamed Text TypedNodeSchema+  | RemainingNodes TypedNodeSchema+  deriving (Show, Eq)++data TypedNodeSchema = TypedNodeSchema+  { typeHint :: TypeRep+  , validTypeAnns :: [Text]+  , nodeSchema :: SchemaOf Node+  }+  deriving (Show, Eq)++data instance SchemaItem Node+  = NodeArg TypedValueSchema+  | NodeProp Text TypedValueSchema+  | NodeRemainingProps TypedValueSchema+  | NodeChildren (SchemaOf NodeList)+  deriving (Show, Eq)++data TypedValueSchema = TypedValueSchema+  { typeHint :: TypeRep+  , validTypeAnns :: [Text]+  , dataSchema :: SchemaOf Value+  }+  deriving (Show, Eq)++data instance SchemaItem Value+  = TextSchema+  | NumberSchema+  | BoolSchema+  | NullSchema+  deriving (Show, Eq, Ord, Enum, Bounded)++schemaJoin :: Schema a -> Schema a -> Schema a+schemaJoin = curry $ \case+  (SchemaAnd l, SchemaAnd r) -> SchemaAnd (l <> r)+  (l, SchemaAnd []) -> l+  (l, SchemaAnd r) -> SchemaAnd (l : r)+  (SchemaAnd [], r) -> r+  (SchemaAnd l, r) -> SchemaAnd (l <> [r])+  (l, r) -> SchemaAnd [l, r]++schemaAlt :: Schema a -> Schema a -> Schema a+schemaAlt = curry $ \case+  (SchemaOr l, SchemaOr r) -> SchemaOr (l <> r)+  (l, SchemaOr []) -> l+  (l, SchemaOr r) -> SchemaOr (l : r)+  (SchemaOr [], r) -> r+  (SchemaOr l, r) -> SchemaOr (l <> [r])+  (l, r) -> SchemaOr [l, r]

@@ -0,0 +1,91 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module KDL.Parser (+  parse,+  parseFile,+) where++import Data.Map qualified as Map+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.IO qualified as Text+import KDL.Parser.Hustle qualified as Hustle+import KDL.Types (+  Ann (..),+  Document,+  Entry (..),+  Identifier (..),+  Node (..),+  NodeList (..),+  Value (..),+  ValueData (..),+  ValueFormat (..),+ )++-- TODO: Implement our own parser that implements the v2.0.0 spec + preserves formatting and comments+parse :: Text -> Either Text Document+parse input =+  case Hustle.parse Hustle.document "" input of+    Left e -> Left . Text.strip . Text.pack . Hustle.errorBundlePretty $ e+    Right (Hustle.Document nodes) -> Right $ fromNodes nodes+ where+  fromNodes nodes =+    NodeList+      { nodes = map fromNode nodes+      , format = Nothing+      }++  fromAnn identifier =+    Ann+      { identifier = fromIdentifier identifier+      , format = Nothing+      }++  fromNode Hustle.Node{..} =+    Node+      { ann = fromAnn <$> nodeAnn+      , name = fromIdentifier nodeName+      , entries = map fromArgEntry nodeArgs <> map fromPropEntry (Map.toList nodeProps)+      , children = Just $ fromNodes nodeChildren+      , format = Nothing+      }++  fromArgEntry v =+    Entry+      { name = Nothing+      , value = fromValue v+      , format = Nothing+      }++  fromPropEntry (name, v) =+    Entry+      { name = Just $ fromIdentifier name+      , value = fromValue v+      , format = Nothing+      }++  fromValue Hustle.Value{..} =+    Value+      { ann = fromAnn <$> valueAnn+      , data_ =+          case valueExp of+            Hustle.StringValue s -> Text s+            Hustle.IntegerValue x -> Number (fromInteger x)+            Hustle.SciValue x -> Number x+            Hustle.BooleanValue x -> Bool x+            Hustle.NullValue -> Null+      , format =+          case valueExp of+            Hustle.IntegerValue x -> Just ValueFormat{repr = Text.pack $ show x}+            _ -> Nothing+      }++  fromIdentifier (Hustle.Identifier s) =+    Identifier+      { value = s+      , format = Nothing+      }++parseFile :: FilePath -> IO (Either Text Document)+parseFile = fmap parse . Text.readFile

@@ -0,0 +1,28 @@+{- FOURMOLU_DISABLE -}++{- | Vendered from https://github.com/fuzzypixelz/hustle -}+module KDL.Parser.Hustle+  ( Parser+  , Document(..)+  , Node(..)+  , Value(..)+  , ValueType(..)+  , Identifier(..)+  , pretty+  , document+  , parse+  , errorBundlePretty+  ) where++import           KDL.Parser.Hustle.Formatter ( Pretty(pretty) )+import           KDL.Parser.Hustle.Parser  ( document )+import           KDL.Parser.Hustle.Types   ( Document(..)+                                                , Identifier(..)+                                                , Node(..)+                                                , Parser+                                                , Value(..)+                                                , ValueType(..)+                                                )+import           Text.Megaparsec                ( errorBundlePretty+                                                , parse+                                                )

@@ -0,0 +1,83 @@+{- FOURMOLU_DISABLE -}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-}++{- | Vendered from https://github.com/fuzzypixelz/hustle -}+module KDL.Parser.Hustle.Formatter+  ( Pretty(pretty)+  ) where++import           Data.Map                       ( Map )+import qualified Data.Map.Strict               as Map+import           Data.Maybe                     ( catMaybes )+import           Data.Scientific                ( Scientific )+import qualified Data.Text                     as T+import           KDL.Parser.Hustle.Internal ( escChar+                                                , match+                                                )+import           KDL.Parser.Hustle.Parser  ( identifier )+import           KDL.Parser.Hustle.Types+import           Prettyprinter                  ( Pretty(pretty)+                                                , braces+                                                , dquotes+                                                , enclose+                                                , hsep+                                                , nest+                                                , parens+                                                , viaShow+                                                , vsep+                                                )++instance Pretty Scientific where+  pretty = viaShow++instance Pretty Identifier where+  pretty (Identifier i) =+    if match identifier i then pretty i else dquotes (pretty i)++instance Pretty Value where+  pretty v = vann <> vexp+   where+    vann = case valueAnn v of+      Nothing -> ""+      Just a  -> parens (pretty a)+    vexp = case valueExp v of+      StringValue  s -> dquotes . pretty $ T.concatMap escChar s+      IntegerValue i -> pretty i+      SciValue     s -> pretty s+      BooleanValue b -> if b then "true" else "false"+      NullValue      -> "null"++instance Pretty (Map Identifier Value) where+  pretty ps = hsep . Map.elems $ Map.mapWithKey prop ps+    where prop i v = pretty i <> "=" <> pretty v++instance Pretty Node where+  pretty n = hsep . catMaybes $ [nname, nargs, nprops, nchildren]+   where+    nann = case nodeAnn n of+      Nothing -> ""+      Just a  -> parens (pretty a)+    nname = Just $ nann <> pretty (nodeName n)+    nargs = case nodeArgs n of+      []  -> Nothing+      nas -> Just . hsep . map pretty $ nas+    nprops | nodeProps n == Map.empty = Nothing+           | otherwise                = Just (pretty (nodeProps n))+    nchildren = case nodeChildren n of+      [] -> Nothing+      ncs ->+        Just+          . nest 4+          . braces+          . enclose "\n" (nest (-4) "\n")+          . vsep+          . map pretty+          $ ncs++instance Pretty Document where+  pretty d = vsep (map pretty (docNodes d)) <> "\n"++instance Show Document where+  show d = show (pretty d)

@@ -0,0 +1,96 @@+{- FOURMOLU_DISABLE -}+{-# LANGUAGE OverloadedStrings #-}++{- | Vendered from https://github.com/fuzzypixelz/hustle -}+module KDL.Parser.Hustle.Internal where++import           Control.Monad                  ( void )+import           Data.Char                      ( digitToInt+                                                , isDigit+                                                )+import           Data.Either                    ( isRight )+import           Data.Scientific                ( Scientific )+import qualified Data.Scientific               as Sci+import           Data.Text                      ( Text )+import qualified Data.Text                     as T+import           KDL.Parser.Hustle.Types   ( Parser )+import           Text.Megaparsec                ( (<|>)+                                                , MonadParsec+                                                  ( eof+                                                  , takeWhileP+                                                  , try+                                                  )+                                                , option+                                                , runParser+                                                , satisfy+                                                )+import           Text.Megaparsec.Char           ( char+                                                , char'+                                                , digitChar+                                                , newline+                                                )+import qualified Text.Megaparsec.Char.Lexer    as L++signed :: Num a => Parser a -> Parser a+signed p = option id sign <*> p+  where sign = (id <$ char '+') <|> (negate <$ char '-')++lineComment :: Parser ()+lineComment = L.skipLineComment "//" >> (void newline <|> eof)++blockComment :: Parser ()+blockComment = L.skipBlockCommentNested "/*" "*/"++isBinDigit :: Char -> Bool+isBinDigit c = c `elem` ['0', '1']++data SP = SP Integer Int++number :: Integer -> (Char -> Bool) -> Parser Integer+number b isNumDigit = mkNum . T.filter (/= '_') <$> digits+ where+  mkNum = T.foldl' step 0+  step a c = a * b + fromIntegral (digitToInt c)+  digits = T.cons <$> satisfy isNumDigit <*> takeWhileP+    (Just "digit")+    (\c -> isNumDigit c || c == '_')++decimal_ :: Parser Integer+decimal_ = number 10 isDigit++scientific_ :: Parser Scientific+scientific_ = do+  c'      <- decimal_+  SP c e' <- dotDecimal_ c'+  e       <- option e' (try $ exponent_ e')+  return (Sci.scientific c e)++dotDecimal_ :: Integer -> Parser SP+dotDecimal_ c' = do+  void (char '.')+  let digits = T.cons <$> digitChar <*> takeWhileP+        (Just "digit")+        (\c -> isDigit c || c == '_')+  let mkNum = T.foldl' step (SP c' 0)+      step (SP a e') c = SP (a * 10 + fromIntegral (digitToInt c)) (e' - 1)+  mkNum . T.filter (/= '_') <$> digits++exponent_ :: Int -> Parser Int+exponent_ e' = do+  void (char' 'e')+  (+ e') <$> L.signed (return ()) (fromIntegral <$> decimal_)++match :: Parser a -> Text -> Bool+match p t = isRight $ runParser (p >> eof) "" t++escChar :: Char -> Text+escChar c = case c of+  '\x08' -> "\\b"+  '\x09' -> "\\t"+  '\x0A' -> "\\n"+  '\x0C' -> "\\f"+  '\x0D' -> "\\r"+  '\x22' -> "\\\""+  '\x2F' -> "\\/"+  '\x5C' -> "\\\\"+  _      -> T.singleton c

@@ -0,0 +1,310 @@+{- FOURMOLU_DISABLE -}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++{- | Vendered from https://github.com/fuzzypixelz/hustle -}+module KDL.Parser.Hustle.Parser where++import           KDL.Parser.Hustle.Internal+import           KDL.Parser.Hustle.Types++import           Control.Monad                  ( void )+import           Data.Char                      ( chr+                                                , isHexDigit+                                                , isOctDigit+                                                , isDigit+                                                , isSpace+                                                )+import qualified Data.Map.Strict               as Map+import           Data.Maybe                     ( catMaybes+                                                , fromMaybe+                                                , mapMaybe+                                                , maybeToList+                                                )+import           Data.Scientific                ( Scientific )+import           Data.Text                      ( Text )+import qualified Data.Text                     as T+import           Text.Megaparsec                ( (<?>)+                                                , (<|>)+                                                , MonadParsec(eof, label, try)+                                                , anySingle+                                                , between+                                                , choice+                                                , many+                                                , manyTill+                                                , noneOf+                                                , optional+                                                , satisfy+                                                , some+                                                )+import           Text.Megaparsec.Char           ( char+                                                , char'+                                                , crlf+                                                , newline+                                                , string+                                                )++-- WHITESPACE++escline :: Parser ()+escline =+  char '\\' >> many ws >> (try linebreak <|> lineComment) <?> "Escape Line"++linespace :: Parser ()+linespace = try linebreak <|> try ws <|> try lineComment <?> "Line Space"++linebreak :: Parser ()+linebreak = label "Newline" $ do+  choice $ void crlf : map+    void+    [ char '\r' <?> "carriage return"+    , char '\n' <?> "newline"+    , char '\x85' <?> "next line"+    , char '\f' <?> "form feed"+    , char '\x2028' <?> "line seperator"+    , char '\x2029' <?> "paragraph seperator"+    ]++ws :: Parser ()+ws = bom <|> hspacechar <|> blockComment <?> "Whitespace"++bom :: Parser ()+bom = void (char '\xFEFF') <?> "BOM"++hspacechar :: Parser ()+hspacechar = label "Unicode Space" $ do+  choice $ map+    void+    [ char '\x0009' <?> "character tabulation"+    , char '\x0020' <?> "space"+    , char '\x00A0' <?> "bo-break space"+    , char '\x1680' <?> "ogham space mark"+    , char '\x2000' <?> "en quad"+    , char '\x2001' <?> "em quad"+    , char '\x2002' <?> "en space"+    , char '\x2003' <?> "em space"+    , char '\x2004' <?> "three-per-em space"+    , char '\x2005' <?> "four-per-em space"+    , char '\x2006' <?> "six-per-em space"+    , char '\x2007' <?> "figure space"+    , char '\x2008' <?> "punctuation space"+    , char '\x2009' <?> "thin space"+    , char '\x200A' <?> "hair space"+    , char '\x202F' <?> "narrow no-break space"+    , char '\x205F' <?> "medium mathmatical space"+    , char '\x3000' <?> "ideographic space"+    ]++-- STRINGS++anystring :: Parser Text+anystring = try unquotedstring <|> try rawstring <|> quotedstring++unquotedstring :: Parser Text+unquotedstring = label "Unquoted String" $ do+  c0 <- satisfy $ \c -> isValidChar c && not (isDigit c) && c /= '"'+  rest <- many $ satisfy isValidChar+  -- TODO: Forbid true, false, null, inf, -inf, nan, or "looks like a number"+  pure $ T.pack (c0 : rest)+  where+    isValidChar c = not (isSpace c) && c `notElem` ("[]{}()\\/#\";=" :: [Char])++quotedstring :: Parser Text+quotedstring = label "Quoted String" $ do+  T.concat <$> (char '"' *> manyTill character (char '"'))++rawstring :: Parser Text+rawstring = label "Raw String" $ do+  void (char 'r')+  hs <- T.pack <$> many (char '#')+  void (char '"')+  s <- manyTill anySingle (string (T.cons '"' hs))+  return (T.pack s)++character :: Parser Text+character = void (char '\\') *> escape <|> nonescape++{-+  As per the Haskell 2010 Language Report,+  (https://www.haskell.org/onlinereport/haskell2010/haskellch2.html#x7-200002.6)+  The '\/' Solidus escape isn't defined, so if we try to parse it directly the+  compiler throws a lexical error. Hence this terribleness.+-}+escape :: Parser Text+escape =+  do+    e <- choice+      [ '\x08' <$ char 'b'+      , '\x09' <$ char 't'+      , '\x0A' <$ char 'n'+      , '\x0C' <$ char 'f'+      , '\x0D' <$ char 'r'+      , '\x22' <$ char '\"'+      , '\x2F' <$ char '/'+      , '\x5C' <$ char '\\'+      ]+    return (T.singleton e)+  <|> uescape++uescape :: Parser Text+uescape = do+  void (string "u{")+  u <- fromInteger <$> number 16 isHexDigit+  if u >= 0x10ffff+    then fail "Exceeded Unicode code point limit."+    else do+      void (char '}')+      let c = chr u+      return (T.singleton c)++nonescape :: Parser Text+nonescape = do+  c <- noneOf ("\\\"" :: [Char])+  return (T.singleton c)++-- NUMBERS++binary :: Parser Integer+binary = signed $ char '0' >> char' 'b' >> number 2 isBinDigit++octal :: Parser Integer+octal = signed $ char '0' >> char 'o' >> number 8 isOctDigit++hexadecimal :: Parser Integer+hexadecimal = signed $ char '0' >> char 'x' >> number 16 isHexDigit++integer :: Parser Integer+integer = signed decimal_++scientific :: Parser Scientific+scientific = signed scientific_++-- CONTENT++name :: Parser Identifier+name = Identifier <$> (try anystring <|> identifier)++identifier :: Parser Text+identifier = label "Identifier" $ do+  i  <- satisfy iichar+  is <- many (satisfy ichar)+  let result = T.pack (i : is)+  case result of+    "true"  -> fail "keyword true in identifier"+    "false" -> fail "keyword false in identifier"+    "null"  -> fail "keyword null in identifier"+    _       -> return result+ where+  ichar c =+    (c > '\x20')+      && (c <= '\x10FFFF')+      && (c `notElem` ("\\/(){}<>;[]=,\"" :: [Char]))+      && not (match linespace (T.singleton c))+  iichar c = ichar c && c `notElem` ['0' .. '9']++nullvalue :: Parser Text+nullvalue = string "#null"++bool :: Parser Bool+bool = True <$ string "#true" <|> False <$ string "#false"++property :: Parser (Identifier, Value)+property = label "Property" $ do+  propKey <- name+  void (char '=')+  propValue <- value+  return (propKey, propValue)++value :: Parser Value+value = label "Value" $ do+  valueAnn <- optional typeAnnotation+  valueExp <- choice+    [ IntegerValue <$> try binary <?> "Binary"+    , IntegerValue <$> try octal <?> "Octal"+    , IntegerValue <$> try hexadecimal <?> "Hexadecimal"+    , SciValue <$> try scientific <?> "Decimal"+    , IntegerValue <$> try integer <?> "Integer"+    , BooleanValue <$> try bool <?> "Boolean"+    , NullValue <$ try nullvalue <?> "Null"+    , StringValue <$> anystring <?> "String"+    ]+  return Value { .. }++typeAnnotation :: Parser Identifier+typeAnnotation = label "Type Annotation" $ do+  void (char '(')+  i <- name+  void (char ')')+  return i++-- NODES++nodes :: Parser [Node]+nodes = between (many linespace) (many linespace) (fromMaybe [] <$> body)+ where+  body = optional $ do+    n  <- maybeToList <$> node+    ns <- fromMaybe [] <$> optional nodes+    return (n ++ ns)++node :: Parser (Maybe Node)+node = label "Node" $ do+  discard      <- optional comment+  nodeAnn      <- optional typeAnnotation+  nodeName     <- name+  nodeContent  <- catMaybes <$> content+  nodeChildren <- fromMaybe [] <$> optional children+  _            <- many nodespace+  _            <- terminator+  let nodeArgs  = mapMaybe isArg nodeContent+      nodeProps = Map.fromList $ mapMaybe isProp nodeContent+  case discard of+    Just _  -> return Nothing+    Nothing -> return $ Just Node { .. }+ where+  isArg c = case c of+    NodeValue v -> Just v+    _           -> Nothing+  isProp c = case c of+    NodeProperty p -> Just p+    _              -> Nothing++content :: Parser [Maybe Content]+content = many . try $ do+  void (some nodespace)+  discard <- optional $ comment <* many nodespace+  c       <- choice [NodeProperty <$> try property, NodeValue <$> try value]+  case discard of+    Just _  -> return Nothing+    Nothing -> return $ Just c++children :: Parser [Node]+children = label "Node Child" . try $ do+  void (many nodespace)+  discard <- optional comment+  void (char '{')+  ns <- nodes+  void (char '}')+  void (many ws)+  case discard of+    Just _  -> return []+    Nothing -> return ns++comment :: Parser ()+comment = label "/-Comment" . try $ do+  void (string "/-")+  void $ many nodespace++nodespace :: Parser ()+nodespace = label "Node Space" $ do+  try (many ws *> escline <* many ws) <|> try (void $ some ws)++terminator :: Parser ()+terminator = label "Node Terminator" $ do+  choice [try (void (char ';')), try (void newline), try lineComment, eof]++document :: Parser Document+document = do+  docNodes <- nodes+  void eof+  return Document { .. }

@@ -0,0 +1,73 @@+{- FOURMOLU_DISABLE -}+{- | Vendered from https://github.com/fuzzypixelz/hustle -}+module KDL.Parser.Hustle.Types+  ( Parser+  , Document(..)+  , Content(..)+  , Node(..)+  , Value(..)+  , ValueType(..)+  , Identifier(..)+  ) where++import           Data.Map                       ( Map )+import           Data.Scientific                ( Scientific )+import           Data.Text                      ( Text )+import           Data.Void                      ( Void )+import           Text.Megaparsec                ( Parsec )++{-+  String has exactly one use, +  and that’s showing Hello World in tutorials.+                  -- Albert Einstein+-}+type Parser = Parsec Void Text++newtype Document = Document+  { docNodes :: [Node]+  }+  deriving (Eq)++{- +  This data type serves as an abstraction over Values+  and Properties of a Node, in order simplify the the node+  Parser, i.e group the two types together to+  consume any number of them in any order. +-}+data Content+  = NodeValue    { getValue :: Value }+  | NodeProperty { getProp :: (Identifier, Value) }+  deriving (Eq)++data Node = Node+  { nodeAnn      :: Maybe Identifier+  , nodeName     :: Identifier+  , nodeArgs     :: [Value]+  , nodeProps    :: Map Identifier Value+  , nodeChildren :: [Node]+  }+  deriving (Show, Eq)++newtype Identifier = Identifier Text+  deriving (Show, Eq)++data Value = Value+  { valueAnn :: Maybe Identifier+  , valueExp :: ValueType+  }+  deriving (Show, Eq)++data ValueType+  = StringValue Text+  | IntegerValue Integer+  | SciValue Scientific+  | BooleanValue Bool+  | NullValue+  deriving (Show, Eq)++{- +  This allows for querying properties in alphabetical order+  upon printing out, the rest is handled automatically by Map.+-}+instance Ord Identifier where+  Identifier t1 `compare` Identifier t2 = t1 `compare` t2

@@ -0,0 +1,132 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module KDL.Render (+  render,++  -- * Rendering components+  renderAnn,+  renderValue,+  renderValueData,+  renderIdentifier,+) where++import Data.Char (isDigit)+import Data.Text (Text)+import Data.Text qualified as Text+import KDL.Types (+  Ann (..),+  AnnFormat (..),+  Document,+  Identifier (..),+  IdentifierFormat (..),+  Value (..),+  ValueData (..),+  ValueFormat (..),+ )++-- TODO: Implement render after parsing Document with formatting information+render :: Document -> Text+render = error "render is not implemented yet"++renderAnn :: Ann -> Text+renderAnn Ann{..} =+  Text.concat+    [ maybe "" (.leading) format+    , "("+    , maybe "" (.before_id) format+    , renderIdentifier identifier+    , maybe "" (.after_id) format+    , ")"+    , maybe "" (.trailing) format+    ]++renderValue :: Value -> Text+renderValue Value{..} =+  Text.concat+    [ maybe "" renderAnn ann+    , maybe (renderValueData data_) (.repr) format+    ]++renderValueData :: ValueData -> Text+renderValueData = \case+  Text s -> renderString s+  Number x -> (Text.pack . show) x+  Bool b -> if b then "#true" else "#false"+  Null -> "#null"+ where+  renderString s = if isPlainIdent s then s else "\"" <> Text.concatMap escapeChar s <> "\""+  isPlainIdent s =+    and . map not $+      [ Text.any isDisallowedChar s+      , case fmap Text.uncons <$> Text.uncons s of+          Just (c, _) | isDigit c -> True+          Just (c0, Just (c1, _))+            | c0 `elem` ['.', '-', '+']+            , isDigit c1 ->+                True+          _ -> False+      , s `elem` ["inf", "-inf", "nan", "true", "false", "null"]+      ]+  isDisallowedChar c =+    or+      [ c `elem` disallowedIdentChars+      , any (c `Text.elem`) newlines+      , c `elem` unicodeSpaces+      , isDisallowedUnicode c+      , c == '='+      ]+  disallowedIdentChars = ['\\', '/', '(', ')', '{', '}', '[', ']', ';', '"', '#']+  newlines =+    [ "\x000D\x000A"+    , "\x000D"+    , "\x000A"+    , "\x0085"+    , "\x000B"+    , "\x000C"+    , "\x2028"+    , "\x2029"+    ]+  unicodeSpaces =+    [ '\x0009'+    , '\x0020'+    , '\x00A0'+    , '\x1680'+    , '\x2000'+    , '\x2001'+    , '\x2002'+    , '\x2003'+    , '\x2004'+    , '\x2005'+    , '\x2006'+    , '\x2007'+    , '\x2008'+    , '\x2009'+    , '\x200A'+    , '\x202F'+    , '\x205F'+    , '\x3000'+    ]+  isDisallowedUnicode c =+    or+      [ '\x0000' < c && c <= '\x0008'+      , '\x000E' < c && c <= '\x001F'+      , '\x200E' < c && c <= '\x200F'+      , '\x202A' < c && c <= '\x202E'+      , '\x2066' < c && c <= '\x2069'+      , c == '\xFEFF'+      ]+  escapeChar = \case+    '\\' -> "\\\\"+    '"' -> "\\\""+    '\n' -> "\\n"+    '\r' -> "\\r"+    '\t' -> "\\t"+    '\x08' -> "\\b"+    '\x0C' -> "\\f"+    c -> Text.singleton c++renderIdentifier :: Identifier -> Text+renderIdentifier ident = maybe ident.value (.repr) ident.format

@@ -0,0 +1,367 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoFieldSelectors #-}++{-|+Defines the types that make up a KDL document.++This module enables @-XNoFieldSelectors@, so none of the fields create implicit+selector functions. Instead, use @-XOverloadedRecordDot@, or the functions+provided by this module.+-}+module KDL.Types (+  -- * Document+  Document,+  docNodes,++  -- * NodeList+  NodeList (..),+  NodeListFormat (..),+  fromNodeList,+  nodeListFormat,++  -- ** Helpers+  filterNodes,+  lookupNode,+  getArgAt,+  getArgsAt,+  getDashChildrenAt,+  getDashNodesAt,++  -- * Node+  Node (..),+  NodeFormat (..),+  nodeAnn,+  nodeName,+  nodeEntries,+  nodeChildren,+  nodeFormat,++  -- ** Helpers+  getArgs,+  getArg,+  getProps,+  getProp,++  -- * Entry+  Entry (..),+  EntryFormat (..),+  entryName,+  entryValue,+  entryFormat,++  -- * Value+  Value (..),+  ValueFormat (..),+  valueAnn,+  valueData,+  valueFormat,+  ValueData (..),++  -- * Ann+  Ann (..),+  AnnFormat (..),+  annIdentifier,+  annFormat,++  -- * Identifier+  Identifier (..),+  IdentifierFormat (..),+  fromIdentifier,+  identifierFormat,+  toIdentifier,+) where++import Control.Monad ((<=<))+import Data.Map (Map)+import Data.Map qualified as Map+import Data.Maybe (listToMaybe, mapMaybe)+import Data.Scientific (Scientific)+import Data.Text (Text)++{----- Document -----}++type Document = NodeList++docNodes :: Document -> [Node]+docNodes = fromNodeList++{----- NodeList -----}++data NodeList = NodeList+  { nodes :: [Node]+  , format :: Maybe NodeListFormat+  }+  deriving (Show, Eq)++data NodeListFormat = NodeListFormat+  { leading :: Text+  -- ^ Whitespace and comments preceding the document's first node.+  , trailing :: Text+  -- ^ Whitespace and comments following the document's last node.+  }+  deriving (Show, Eq)++fromNodeList :: NodeList -> [Node]+fromNodeList = (.nodes)++nodeListFormat :: NodeList -> Maybe NodeListFormat+nodeListFormat = (.format)++-- | A helper to get all nodes with the given name+filterNodes :: Text -> NodeList -> [Node]+filterNodes name = filter ((== name) . (.name.value)) . (.nodes)++-- | A helper to get the first node with the given name+lookupNode :: Text -> NodeList -> Maybe Node+lookupNode name = listToMaybe . filterNodes name++-- | A helper to get the first argument of the first node with the given name.+-- A utility for nodes that are acting like a key-value store.+--+-- == __Example__+--+-- @+-- let+--   config =+--     """+--     foo 1+--     """+-- Right doc <- pure $ parse config+-- getArgAt "foo" doc == Just (Number 1)+-- @+getArgAt :: Text -> NodeList -> Maybe Value+getArgAt name = listToMaybe . getArgsAt name++-- | A helper to get 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.+--+-- == __Example__+--+-- @+-- let+--   config =+--     """+--     foo 1 2 "test"+--     """+-- Right doc <- pure $ parse config+-- getArgsAt "foo" doc == [Number 1, Number 2, Text "test"]+-- @+getArgsAt :: Text -> NodeList -> [Value]+getArgsAt name = maybe [] getArgs . lookupNode name++-- | A helper for getting child values following the KDL convention of being named "-".+--+-- == __Example__+--+-- @+-- let+--   config =+--     """+--     foo {+--       - 1+--       - 2+--       - "test"+--     }+--     """+-- Right doc <- pure $ parse config+-- getDashChildrenAt "foo" doc == [Number 1, Number 2, Text "test"]+-- @+getDashChildrenAt :: Text -> NodeList -> [Value]+getDashChildrenAt name = mapMaybe getArg . getDashNodesAt name++-- | A helper for getting child nodes following the KDL convention of being named "-".+--+-- == __Example__+--+-- @+-- let+--   config =+--     """+--     foo {+--       - 1+--       - 2+--       - "test"+--     }+--     """+-- Right doc <- pure $ parse config+-- mapM getArg (getDashNodesAt "foo" doc) == Just [Number 1, Number 2, Text "test"]+-- @+getDashNodesAt :: Text -> NodeList -> [Node]+getDashNodesAt name = maybe [] (filterNodes "-") . (nodeChildren <=< lookupNode name)++{----- Ann -----}++data Ann = Ann+  { identifier :: Identifier+  , format :: Maybe AnnFormat+  }+  deriving (Show, Eq)++data AnnFormat = AnnFormat+  { leading :: Text+  -- ^ Whitespace and comments preceding the annotation itself.+  , before_id :: Text+  -- ^ Whitespace and comments between the opening `(` and the identifier.+  , after_id :: Text+  -- ^ Whitespace and comments between the identifier and the closing `)`.+  , trailing :: Text+  -- ^ Whitespace and comments following the annotation itself.+  }+  deriving (Show, Eq)++annIdentifier :: Ann -> Identifier+annIdentifier = (.identifier)++annFormat :: Ann -> Maybe AnnFormat+annFormat = (.format)++{----- Node -----}++data Node = Node+  { ann :: Maybe Ann+  , name :: Identifier+  , entries :: [Entry]+  , children :: Maybe NodeList+  , format :: Maybe NodeFormat+  }+  deriving (Show, Eq)++data NodeFormat = NodeFormat+  { leading :: Text+  -- ^ Whitespace and comments preceding the node itself.+  , before_children :: Text+  -- ^ Whitespace and comments preceding the node's children block.+  , before_terminator :: Text+  -- ^ Whitespace and comments right before the node's terminator.+  , terminator :: Text+  -- ^ The terminator for the node.+  , trailing :: Text+  -- ^ Whitespace and comments following the node, after the terminator.+  }+  deriving (Show, Eq)++nodeAnn :: Node -> Maybe Ann+nodeAnn = (.ann)++nodeName :: Node -> Identifier+nodeName = (.name)++nodeEntries :: Node -> [Entry]+nodeEntries = (.entries)++nodeChildren :: Node -> Maybe NodeList+nodeChildren = (.children)++nodeFormat :: Node -> Maybe NodeFormat+nodeFormat = (.format)++-- | Get all the positional arguments of the node.+getArgs :: Node -> [Value]+getArgs node =+  [ value+  | Entry{name = Nothing, value} <- node.entries+  ]++-- | Get the first argument of the node.+getArg :: Node -> Maybe Value+getArg = listToMaybe . getArgs++-- | Get the properties of the node.+getProps :: Node -> Map Text Value+getProps node =+  Map.fromList+    [ (name.value, value)+    | Entry{name = Just name, value} <- node.entries+    ]++-- | Get the property with the given name in the node.+getProp :: Text -> Node -> Maybe Value+getProp name = Map.lookup name . getProps++{----- Entry -----}++data Entry = Entry+  { name :: Maybe Identifier+  -- ^ The name of the entry, if it's a property, Nothing if it's a positional arg+  , value :: Value+  , format :: Maybe EntryFormat+  }+  deriving (Show, Eq)++data EntryFormat = EntryFormat+  { leading :: Text+  -- ^ Whitespace and comments preceding the entry itself.+  , after_key :: Text+  -- ^ Whitespace and comments between an entry's key name and its equals sign.+  , after_eq :: Text+  -- ^ Whitespace and comments between an entry's equals sign and its value.+  , trailing :: Text+  -- ^ Whitespace and comments following the entry itself.+  }+  deriving (Show, Eq)++entryName :: Entry -> Maybe Identifier+entryName = (.name)++entryValue :: Entry -> Value+entryValue = (.value)++entryFormat :: Entry -> Maybe EntryFormat+entryFormat = (.format)++{----- Value -----}++data Value = Value+  { ann :: Maybe Ann+  , data_ :: ValueData+  , format :: Maybe ValueFormat+  }+  deriving (Show, Eq)++data ValueFormat = ValueFormat+  { repr :: Text+  -- ^ The actual text representation of the value.+  }+  deriving (Show, Eq)++valueAnn :: Value -> Maybe Ann+valueAnn = (.ann)++valueData :: Value -> ValueData+valueData = (.data_)++valueFormat :: Value -> Maybe ValueFormat+valueFormat = (.format)++data ValueData+  = Text Text+  | Number Scientific+  | Bool Bool+  | Null+  deriving (Show, Eq)++{----- Identifier -----}++data Identifier = Identifier+  { value :: Text+  , format :: Maybe IdentifierFormat+  }+  deriving (Show, Eq, Ord)++data IdentifierFormat = IdentifierFormat+  { repr :: Text+  }+  deriving (Show, Eq, Ord)++fromIdentifier :: Identifier -> Text+fromIdentifier = (.value)++identifierFormat :: Identifier -> Maybe IdentifierFormat+identifierFormat = (.format)++toIdentifier :: Text -> Identifier+toIdentifier value = Identifier{value = value, format = Nothing}

@@ -1,1182 +0,0 @@-{-# LANGUAGE Arrows #-}-{-# LANGUAGE DisambiguateRecordFields #-}-{-# LANGUAGE OverloadedStrings #-}--module Data.KDL.Decoder.ArrowSpec (spec) where--import Control.Arrow (returnA)-import Control.Monad (forM_, unless, when)-import Data.KDL.Decoder.Arrow qualified as KDL-import Data.KDL.Decoder.Schema qualified as KDL-import Data.KDL.Types (-  Entry (..),-  Identifier (..),-  Node (..),-  NodeList (..),-  Value (..),-  ValueData (..),- )-import Data.Map qualified as Map-import Data.Proxy (Proxy (..))-import Data.Text (Text)-import Data.Text qualified as Text-import Data.Typeable (typeRep)-import Skeletest-import Skeletest.Predicate qualified as P--decodeErrorMsg :: [Text] -> Predicate IO (Either KDL.DecodeError a)-decodeErrorMsg msgs = P.left (KDL.renderDecodeError P.>>> P.eq msg)- where-  msg = Text.intercalate "\n" msgs--spec :: Spec-spec = do-  apiSpec-  schemaSpec-  decodeNodeSpec-  decodeValueSpec--apiSpec :: Spec-apiSpec = do-  describe "decodeWith" $ do-    it "fails with helpful error if parsing fails" $ do-      let config = "foo hello= 123"-          decoder = KDL.document $ KDL.node @Node "foo"-      KDL.decodeWith decoder config-        `shouldSatisfy` decodeErrorMsg-          [ "At: <root>"-          , "  1:10:"-          , "    |"-          , "  1 | foo hello= 123"-          , "    |          ^^"-          , "  unexpected \"= \""-          , "  expecting Node Child, Node Space, or Node Terminator"-          ]--    it "fails with user-defined error" $ do-      let config = "foo -1"-          decoder =-            KDL.document . KDL.argAtWith "foo" $-              KDL.withDecoder KDL.number $ \x -> do-                when (x < 0) $ do-                  KDL.failM $ "Got negative number: " <> (Text.pack . show) x-                pure x-      KDL.decodeWith decoder config-        `shouldSatisfy` decodeErrorMsg-          [ "At: foo #0 > arg #0"-          , "  Got negative number: -1.0"-          ]--    it "shows context in deeply nested error" $ do-      let config = "foo; foo { bar { baz; baz; baz; baz a=1; }; }"-          decoder =-            KDL.document-              . (KDL.many . KDL.nodeWith "foo" . KDL.children)-              . (KDL.many . KDL.nodeWith "bar" . KDL.children)-              . (KDL.many . KDL.nodeWith "baz")-              $ KDL.optional (KDL.prop @Text "a")-      KDL.decodeWith decoder config-        `shouldSatisfy` decodeErrorMsg-          [ "At: foo #1 > bar #0 > baz #3 > prop a"-          , "  Expected text, got: 1"-          ]--  describe "NodeListDecoder" $ do-    describe "node" $ do-      it "decodes a node" $ do-        let config = "foo 1.0"-            decoder = KDL.document $ proc () -> do-              KDL.node "foo" -< ()-            expected =-              Node-                { ann = Nothing-                , name = Identifier{value = "foo", format = Nothing}-                , entries =-                    [ Entry-                        { name = Nothing-                        , value = Value{ann = Nothing, data_ = Number 1.0, format = Nothing}-                        , format = Nothing-                        }-                    ]-                , children = Just NodeList{nodes = [], format = Nothing}-                , format = Nothing-                }-        KDL.decodeWith decoder config `shouldBe` Right expected--      it "decodes multiple nodes" $ do-        let config = "foo; foo"-            decoder = KDL.document $ proc () -> do-              KDL.many $ KDL.node "foo" -< ()-            expected = [fooNode, fooNode]-            fooNode =-              Node-                { ann = Nothing-                , name = Identifier{value = "foo", format = Nothing}-                , entries = []-                , children = Just NodeList{nodes = [], format = Nothing}-                , format = Nothing-                }-        KDL.decodeWith decoder config `shouldBe` Right expected--      it "decodes nodes in any order" $ do-        let config = "foo; bar"-            decoder = KDL.document $ proc () -> do-              bar <- KDL.node "bar" -< ()-              foo <- KDL.node "foo" -< ()-              returnA -< (bar, foo)-            expected = (node "bar", node "foo")-            node name =-              Node-                { ann = Nothing-                , name = Identifier{value = name, format = Nothing}-                , entries = []-                , children = Just NodeList{nodes = [], format = Nothing}-                , format = Nothing-                }-        KDL.decodeWith decoder config `shouldBe` Right expected--      it "fails when not enough nodes" $ do-        let config = "foo"-            decoder = KDL.document $ proc () -> do-              foo1 <- KDL.node @Node "foo" -< ()-              foo2 <- KDL.node @Node "foo" -< ()-              returnA -< (foo1, foo2)-        KDL.decodeWith decoder config-          `shouldSatisfy` decodeErrorMsg-            [ "At: <root>"-            , "  Expected another node: foo"-            ]--    -- Most behaviors tested with `node`-    describe "nodeWith" $ do-      it "decodes a node" $ do-        let config = "foo 1.0 { hello \"world\"; }"-            decodeFoo = proc () -> do-              arg <- KDL.arg @Int -< ()-              child <- KDL.children $ KDL.argAt @Text "hello" -< ()-              returnA -< (arg, child)-            decoder = KDL.document $ proc () -> do-              KDL.nodeWith "foo" decodeFoo -< ()-        KDL.decodeWith decoder config `shouldBe` Right (1, "world")--      it "fails when node fails to parse" $ do-        let config = "foo 1.0"-            decodeFoo = proc () -> do-              KDL.arg @Text -< ()-            decoder = KDL.document $ proc () -> do-              KDL.nodeWith "foo" decodeFoo -< ()-        KDL.decodeWith decoder config-          `shouldSatisfy` decodeErrorMsg-            [ "At: foo #0 > arg #0"-            , "  Expected text, got: 1.0"-            ]--    -- Most behaviors tested with `nodeWith`-    describe "nodeWith'" $ do-      it "decodes a node with an annotation" $ do-        let testCases =-              [ []-              , ["test"]-              , ["test", "other"]-              ]-        forM_ testCases $ \anns -> do-          let config = "(test)foo 1"-              decoder = KDL.document $ proc () -> do-                KDL.nodeWith' "foo" anns $ KDL.arg @Int -< ()-          KDL.decodeWith decoder config `shouldBe` Right 1--      it "decodes a node without an annotation" $ do-        let testCases =-              [ []-              , ["test"]-              , ["test", "other"]-              ]-        forM_ testCases $ \anns -> do-          let config = "foo 1"-              decoder = KDL.document $ proc () -> do-                KDL.nodeWith' "foo" anns $ KDL.arg @Int -< ()-          KDL.decodeWith decoder config `shouldBe` Right 1--      it "fails when node has unexpected annotation" $ do-        let config = "(test)foo 2"-            decoder = KDL.document $ proc () -> do-              KDL.nodeWith' "foo" ["FOO"] $ KDL.arg @Int -< ()-        KDL.decodeWith decoder config-          `shouldSatisfy` decodeErrorMsg-            [ "At: foo #0"-            , "  Expected annotation to be one of [\"FOO\"], got: test"-            ]--    describe "remainingNodes" $ do-      it "returns all remaining nodes" $ do-        let config = "foo 1.0; foo 2.0; bar"-            decoder = KDL.document $ proc () -> do-              _ <- KDL.node @Node "foo" -< ()-              KDL.remainingNodes -< ()-            expected =-              Map.fromList-                [ ("foo", [fooNode2])-                , ("bar", [barNode])-                ]-            fooNode2 =-              Node-                { ann = Nothing-                , name = Identifier{value = "foo", format = Nothing}-                , entries =-                    [ Entry-                        { name = Nothing-                        , value = Value{ann = Nothing, data_ = Number 2.0, format = Nothing}-                        , format = Nothing-                        }-                    ]-                , children = Just NodeList{nodes = [], format = Nothing}-                , format = Nothing-                }-            barNode =-              Node-                { ann = Nothing-                , name = Identifier{value = "bar", format = Nothing}-                , entries = []-                , children = Just NodeList{nodes = [], format = Nothing}-                , format = Nothing-                }-        KDL.decodeWith decoder config `shouldBe` Right expected--    -- Most behaviors tested with `remainingNodes`-    describe "remainingNodesWith" $ do-      it "returns all remaining nodes" $ do-        let config = "foo 1.0; foo 2.0; bar"-            decodeNode = proc () -> do-              KDL.optional $ KDL.arg @Int -< ()-            decoder = KDL.document $ proc () -> do-              _ <- KDL.node @Node "foo" -< ()-              KDL.remainingNodesWith decodeNode -< ()-            expected =-              Map.fromList-                [ ("foo", [Just 2])-                , ("bar", [Nothing])-                ]-        KDL.decodeWith decoder config `shouldBe` Right expected--      it "fails when node fails to parse" $ do-        let config = "foo 1; bar 1; bar \"hello\""-            decodeNode = proc () -> do-              KDL.arg @Int -< ()-            decoder = KDL.document $ proc () -> do-              KDL.remainingNodesWith decodeNode -< ()-        KDL.decodeWith decoder config-          `shouldSatisfy` decodeErrorMsg-            [ "At: bar #1 > arg #0"-            , "  Expected number, got: hello"-            ]--    -- Most behaviors tested with `remainingNodesWith`-    describe "remainingNodesWith'" $ do-      it "decodes a node with an annotation" $ do-        let testCases =-              [ []-              , ["test"]-              , ["test", "other"]-              ]-        forM_ testCases $ \anns -> do-          let config = "(test)foo 1"-              decoder = KDL.document $ proc () -> do-                KDL.remainingNodesWith' anns $ KDL.arg @Int -< ()-          KDL.decodeWith decoder config-            `shouldBe` (Right . Map.fromList) [("foo", [1])]--      it "decodes a node without an annotation" $ do-        let testCases =-              [ []-              , ["test"]-              , ["test", "other"]-              ]-        forM_ testCases $ \anns -> do-          let config = "foo 1"-              decoder = KDL.document $ proc () -> do-                KDL.remainingNodesWith' anns $ KDL.arg @Int -< ()-          KDL.decodeWith decoder config-            `shouldBe` (Right . Map.fromList) [("foo", [1])]--      it "fails when node has unexpected annotation" $ do-        let config = "(FOO)foo 1; (test)foo 2"-            decoder = KDL.document $ proc () -> do-              KDL.remainingNodesWith' ["FOO"] $ KDL.arg @Int -< ()-        KDL.decodeWith decoder config-          `shouldSatisfy` decodeErrorMsg-            [ "At: foo #1"-            , "  Expected annotation to be one of [\"FOO\"], got: test"-            ]--    describe "argAt" $ do-      it "gets argument at a node" $ do-        let config = "foo \"bar\"; hello \"world\""-            decoder = KDL.document $ proc () -> do-              hello <- KDL.argAt @Text "hello" -< ()-              foo <- KDL.argAt @Text "foo" -< ()-              returnA -< (hello, foo)-        KDL.decodeWith decoder config `shouldBe` Right ("world", "bar")--      it "fails if no node" $ do-        let config = "other_node"-            decoder = KDL.document $ proc () -> do-              KDL.argAt @Int "foo" -< ()-        KDL.decodeWith decoder config-          `shouldSatisfy` decodeErrorMsg-            [ "At: <root>"-            , "  Expected node: foo"-            ]--      it "fails if node has no args" $ do-        let config = "foo"-            decoder = KDL.document $ proc () -> do-              KDL.argAt @Int "foo" -< ()-        KDL.decodeWith decoder config-          `shouldSatisfy` decodeErrorMsg-            [ "At: foo #0"-            , "  Expected arg #0"-            ]--      it "fails if arg fails to parse" $ do-        let config = "foo 1"-            decoder = KDL.document $ proc () -> do-              KDL.argAt @Text "foo" -< ()-        KDL.decodeWith decoder config-          `shouldSatisfy` decodeErrorMsg-            [ "At: foo #0 > arg #0"-            , "  Expected text, got: 1"-            ]--    -- Most behaviors tested with `argAt`-    describe "argAtWith" $ do-      it "gets argument at a node" $ do-        let config = "foo 1"-            decoder = KDL.document $ proc () -> do-              KDL.argAtWith "foo" $ show . (* 10) <$> KDL.number -< ()-        KDL.decodeWith decoder config `shouldBe` Right "10.0"--    -- Most behaviors tested with `argAtWith`-    describe "argAtWith'" $ do-      it "decodes argument with an annotation" $ do-        let testCases =-              [ []-              , ["test"]-              , ["test", "other"]-              ]-        forM_ testCases $ \anns -> do-          let config = "foo (test)a"-              decoder = KDL.document $ proc () -> do-                KDL.argAtWith' "foo" anns KDL.text -< ()-          KDL.decodeWith decoder config `shouldBe` Right "a"--      it "decodes argument without an annotation" $ do-        let testCases =-              [ []-              , ["test"]-              , ["test", "other"]-              ]-        forM_ testCases $ \anns -> do-          let config = "foo a"-              decoder = KDL.document $ proc () -> do-                KDL.argAtWith' "foo" anns KDL.text -< ()-          KDL.decodeWith decoder config `shouldBe` Right "a"--      it "fails when argument has unexpected annotation" $ do-        let config = "foo (test)a"-            decoder = KDL.document $ proc () -> do-              KDL.argAtWith' "foo" ["VAL"] KDL.text -< ()-        KDL.decodeWith decoder config-          `shouldSatisfy` decodeErrorMsg-            [ "At: foo #0 > arg #0"-            , "  Expected annotation to be one of [\"VAL\"], got: test"-            ]--    describe "argsAt" $ do-      it "gets arguments at a node" $ do-        let config = "foo 1 2 3"-            decoder = KDL.document $ proc () -> do-              KDL.argsAt @Int "foo" -< ()-        KDL.decodeWith decoder config `shouldBe` Right [1, 2, 3]--      it "returns empty list if no node" $ do-        let config = ""-            decoder = KDL.document $ proc () -> do-              KDL.argsAt @Int "foo" -< ()-        KDL.decodeWith decoder config `shouldBe` Right []--      it "returns empty list if node has no args" $ do-        let config = "foo"-            decoder = KDL.document $ proc () -> do-              KDL.argsAt @Int "foo" -< ()-        KDL.decodeWith decoder config `shouldBe` Right []--      it "fails if any arg fails to parse" $ do-        let config = "foo 1 \"asdf\""-            decoder = KDL.document $ proc () -> do-              KDL.argsAt @Int "foo" -< ()-        KDL.decodeWith decoder config-          `shouldSatisfy` decodeErrorMsg-            [ "At: foo #0 > arg #1"-            , "  Expected number, got: asdf"-            ]--    -- Most behaviors tested with `argsAt`-    describe "argsAtWith" $ do-      it "gets arguments at a node" $ do-        let config = "foo 1 2"-            decoder = KDL.document $ proc () -> do-              KDL.argsAtWith "foo" $ show . (* 10) <$> KDL.number -< ()-        KDL.decodeWith decoder config `shouldBe` Right ["10.0", "20.0"]--    -- Most behaviors tested with `argsAtWith`-    describe "argsAtWith'" $ do-      it "decodes arguments with an annotation" $ do-        let testCases =-              [ []-              , ["test"]-              , ["test", "other"]-              ]-        forM_ testCases $ \anns -> do-          let config = "foo (test)a (test)b"-              decoder = KDL.document $ proc () -> do-                KDL.argsAtWith' "foo" anns KDL.text -< ()-          KDL.decodeWith decoder config `shouldBe` Right ["a", "b"]--      it "decodes arguments without an annotation" $ do-        let testCases =-              [ []-              , ["test"]-              , ["test", "other"]-              ]-        forM_ testCases $ \anns -> do-          let config = "foo a b"-              decoder = KDL.document $ proc () -> do-                KDL.argsAtWith' "foo" anns KDL.text -< ()-          KDL.decodeWith decoder config `shouldBe` Right ["a", "b"]--      it "fails when argument has unexpected annotation" $ do-        let config = "foo (VAL)a (test)b"-            decoder = KDL.document $ proc () -> do-              KDL.argsAtWith' "foo" ["VAL"] KDL.text -< ()-        KDL.decodeWith decoder config-          `shouldSatisfy` decodeErrorMsg-            [ "At: foo #0 > arg #1"-            , "  Expected annotation to be one of [\"VAL\"], got: test"-            ]--    describe "dashChildrenAt" $ do-      it "gets dash children at a node" $ do-        let config = "foo { - 1; - 2; - 3; }"-            decoder = KDL.document $ proc () -> do-              KDL.dashChildrenAt @Int "foo" -< ()-        KDL.decodeWith decoder config `shouldBe` Right [1, 2, 3]--      it "returns empty list if no node" $ do-        let config = ""-            decoder = KDL.document $ proc () -> do-              KDL.dashChildrenAt @Int "foo" -< ()-        KDL.decodeWith decoder config `shouldBe` Right []--      it "returns empty list if node has no dash children" $ do-        forM_ ["foo", "foo {}"] $ \config -> do-          let decoder = KDL.document $ proc () -> do-                KDL.dashChildrenAt @Int "foo" -< ()-          KDL.decodeWith decoder config `shouldBe` Right []--      it "fails if dash children have multiple args" $ do-        let config = "foo { - 1 2; - 3 4; }"-            decoder = KDL.document $ proc () -> do-              KDL.dashChildrenAt @Int "foo" -< ()-        KDL.decodeWith decoder config-          `shouldSatisfy` decodeErrorMsg-            [ "At: foo #0 > - #0"-            , "  Unexpected arg #1: 2"-            ]--      it "fails if node has non-dash children" $ do-        let config = "foo { - 1; bar 1 2 3; }"-            decoder = KDL.document $ proc () -> do-              KDL.dashChildrenAt @Int "foo" -< ()-        KDL.decodeWith decoder config-          `shouldSatisfy` decodeErrorMsg-            [ "At: foo #0"-            , "  Unexpected node: bar #0"-            ]--      it "fails if any child fails to parse" $ do-        let config = "foo { - 1; - \"asdf\"; }"-            decoder = KDL.document $ proc () -> do-              KDL.dashChildrenAt @Int "foo" -< ()-        KDL.decodeWith decoder config-          `shouldSatisfy` decodeErrorMsg-            [ "At: foo #0 > - #1 > arg #0"-            , "  Expected number, got: asdf"-            ]--    -- Most behaviors tested with `dashChildrenAt`-    describe "dashChildrenAtWith" $ do-      it "gets dash children at a node" $ do-        let config = "foo { - 1; - 2; }"-            decoder = KDL.document $ proc () -> do-              KDL.dashChildrenAtWith "foo" $ show . (* 10) <$> KDL.number -< ()-        KDL.decodeWith decoder config `shouldBe` Right ["10.0", "20.0"]--    -- Most behaviors tested with `dashChildrenAtWith`-    describe "dashChildrenAtWith'" $ do-      it "decodes dash children with an annotation" $ do-        let testCases =-              [ []-              , ["test"]-              , ["test", "other"]-              ]-        forM_ testCases $ \anns -> do-          let config = "foo { - (test)a; - (test)b; }"-              decoder = KDL.document $ proc () -> do-                KDL.dashChildrenAtWith' "foo" anns KDL.text -< ()-          KDL.decodeWith decoder config `shouldBe` Right ["a", "b"]--      it "decodes dash children without an annotation" $ do-        let testCases =-              [ []-              , ["test"]-              , ["test", "other"]-              ]-        forM_ testCases $ \anns -> do-          let config = "foo { - a; - b; }"-              decoder = KDL.document $ proc () -> do-                KDL.dashChildrenAtWith' "foo" anns KDL.text -< ()-          KDL.decodeWith decoder config `shouldBe` Right ["a", "b"]--      it "fails when child has unexpected annotation" $ do-        let config = "foo { - (test)a; }"-            decoder = KDL.document $ proc () -> do-              KDL.dashChildrenAtWith' "foo" ["VAL"] KDL.text -< ()-        KDL.decodeWith decoder config-          `shouldSatisfy` decodeErrorMsg-            [ "At: foo #0 > - #0 > arg #0"-            , "  Expected annotation to be one of [\"VAL\"], got: test"-            ]--    describe "dashNodesAt" $ do-      it "gets dash nodes at a node" $ do-        let config = "foo { - { bar; }; - { baz; }; }"-            decoder = KDL.document $ proc () -> do-              KDL.dashNodesAt "foo" -< ()-            expected = [node "-" [node "bar" []], node "-" [node "baz" []]]-            node name children =-              Node-                { ann = Nothing-                , name = Identifier{value = name, format = Nothing}-                , entries = []-                , children = Just NodeList{nodes = children, format = Nothing}-                , format = Nothing-                }-        KDL.decodeWith decoder config `shouldBe` Right expected--      it "returns empty list if no node" $ do-        let config = ""-            decoder = KDL.document $ proc () -> do-              KDL.dashNodesAt @Node "foo" -< ()-        KDL.decodeWith decoder config `shouldBe` Right []--      it "returns empty list if node has no dash nodes" $ do-        forM_ ["foo", "foo {}"] $ \config -> do-          let decoder = KDL.document $ proc () -> do-                KDL.dashNodesAt @Node "foo" -< ()-          KDL.decodeWith decoder config `shouldBe` Right []--      it "fails if node has non-dash nodes" $ do-        let config = "foo { - 1; bar 1 2 3; }"-            decoder = KDL.document $ proc () -> do-              KDL.dashNodesAt @Node "foo" -< ()-        KDL.decodeWith decoder config-          `shouldSatisfy` decodeErrorMsg-            [ "At: foo #0"-            , "  Unexpected node: bar #0"-            ]--    -- Most behaviors tested with `dashNodesAt`-    describe "dashNodesAtWith" $ do-      it "gets dash nodes at a node" $ do-        let config = "foo { - 1 { bar \"hello\"; }; - 2 { bar \"world\"; }; }"-            decodeChild = proc () -> do-              arg <- KDL.arg @Int -< ()-              child <- KDL.children $ KDL.nodeWith "bar" $ KDL.arg @Text -< ()-              returnA -< (arg, child)-            decoder = KDL.document $ proc () -> do-              KDL.dashNodesAtWith "foo" decodeChild -< ()-        KDL.decodeWith decoder config `shouldBe` Right [(1, "hello"), (2, "world")]--      it "fails if any child fails to parse" $ do-        let config = "foo { - { bar 1; }; - { bar \"test\"; }; }"-            decoder = KDL.document $ proc () -> do-              KDL.dashNodesAtWith "foo" $ KDL.children $ KDL.argAt @Int "bar" -< ()-        KDL.decodeWith decoder config-          `shouldSatisfy` decodeErrorMsg-            [ "At: foo #0 > - #1 > bar #0 > arg #0"-            , "  Expected number, got: test"-            ]--  describe "NodeDecoder" $ do-    let decodeNode name decoder config =-          KDL.decodeWith-            ( KDL.document $ proc () -> do-                KDL.nodeWith name decoder -< ()-            )-            config--    describe "arg" $ do-      it "decodes an argument" $ do-        let config = "foo 1 \"bar\""-            decoder = proc () -> do-              arg1 <- KDL.arg @Int -< ()-              arg2 <- KDL.arg @Text -< ()-              returnA -< (arg1, arg2)-        decodeNode "foo" decoder config `shouldBe` Right (1, "bar")--      it "decodes multiple arguments" $ do-        let config = "foo 1 2 3"-            decoder = proc () -> do-              KDL.many $ KDL.arg @Int -< ()-        decodeNode "foo" decoder config `shouldBe` Right [1, 2, 3]--      it "fails if argument doesn't exist" $ do-        let config = "foo"-            decoder = proc () -> do-              KDL.arg @Int -< ()-        decodeNode "foo" decoder config-          `shouldSatisfy` decodeErrorMsg-            [ "At: foo #0"-            , "  Expected arg #0"-            ]--      it "fails if argument fails to parse" $ do-        let config = "foo \"test\""-            decoder = proc () -> do-              KDL.arg @Int -< ()-        decodeNode "foo" decoder config-          `shouldSatisfy` decodeErrorMsg-            [ "At: foo #0 > arg #0"-            , "  Expected number, got: test"-            ]--      it "fails if not all arguments are decoded" $ do-        let config = "foo 1 2 3"-            decoder = proc () -> do-              KDL.arg @Int -< ()-        decodeNode "foo" decoder config-          `shouldSatisfy` decodeErrorMsg-            [ "At: foo #0"-            , "  Unexpected arg #1: 2"-            ]--    -- Most behaviors tested with `arg`-    describe "argWith" $ do-      it "decodes an argument" $ do-        let config = "foo \"bar\""-            decoder = proc () -> do-              KDL.argWith KDL.text -< ()-        decodeNode "foo" decoder config `shouldBe` Right "bar"--    -- Most behaviors tested with `argWith`-    describe "argWith'" $ do-      it "decodes argument with an annotation" $ do-        let testCases =-              [ []-              , ["test"]-              , ["test", "other"]-              ]-        forM_ testCases $ \anns -> do-          let config = "foo (test)a"-              decoder = proc () -> do-                KDL.argWith' anns KDL.text -< ()-          decodeNode "foo" decoder config `shouldBe` Right "a"--      it "decodes argument without an annotation" $ do-        let testCases =-              [ []-              , ["test"]-              , ["test", "other"]-              ]-        forM_ testCases $ \anns -> do-          let config = "foo a"-              decoder = proc () -> do-                KDL.argWith' anns KDL.text -< ()-          decodeNode "foo" decoder config `shouldBe` Right "a"--      it "fails when argument has unexpected annotation" $ do-        let config = "foo (test)a"-            decoder = proc () -> do-              KDL.argWith' ["VAL"] KDL.text -< ()-        decodeNode "foo" decoder config-          `shouldSatisfy` decodeErrorMsg-            [ "At: foo #0 > arg #0"-            , "  Expected annotation to be one of [\"VAL\"], got: test"-            ]--    describe "prop" $ do-      it "decodes a prop" $ do-        let config = "foo test1=1 test2=\"hello\""-            decoder = proc () -> do-              prop1 <- KDL.prop @Text "test2" -< ()-              prop2 <- KDL.prop @Int "test1" -< ()-              returnA -< (prop1, prop2)-        decodeNode "foo" decoder config `shouldBe` Right ("hello", 1)--      it "can optionally decode a prop" $ do-        let config = "foo a=1"-            decoder = proc () -> do-              a <- KDL.optional $ KDL.prop @Int "a" -< ()-              b <- KDL.optional $ KDL.prop @Int "b" -< ()-              returnA -< (a, b)-        decodeNode "foo" decoder config `shouldBe` Right (Just 1, Nothing)--      it "decodes last prop" $ do-        let config = "foo test=1 test=2"-            decoder = proc () -> do-              KDL.prop @Int "test" -< ()-        decodeNode "foo" decoder config `shouldBe` Right 2--      it "fails if prop doesn't exist" $ do-        let config = "foo 123"-            decoder = proc () -> do-              KDL.prop @Int "test" -< ()-        decodeNode "foo" decoder config-          `shouldSatisfy` decodeErrorMsg-            [ "At: foo #0"-            , "  Expected prop: test"-            ]--      it "fails if prop fails to parse" $ do-        let config = "foo hello=world"-            decoder = proc () -> do-              KDL.prop @Int "hello" -< ()-        decodeNode "foo" decoder config-          `shouldSatisfy` decodeErrorMsg-            [ "At: foo #0 > prop hello"-            , "  Expected number, got: world"-            ]--      it "fails if not all props are decoded" $ do-        let config = "foo a=1 b=2"-            decoder = proc () -> do-              KDL.prop @Int "a" -< ()-        decodeNode "foo" decoder config-          `shouldSatisfy` decodeErrorMsg-            [ "At: foo #0"-            , "  Unexpected prop: b=2"-            ]--    -- Most behaviors tested with `prop`-    describe "propWith" $ do-      it "decodes a prop" $ do-        let config = "foo a=1"-            decoder = proc () -> do-              KDL.propWith "a" KDL.number -< ()-        decodeNode "foo" decoder config `shouldBe` Right 1--    -- Most behaviors tested with `propWith`-    describe "propWith'" $ do-      it "decodes prop with an annotation" $ do-        let testCases =-              [ []-              , ["test"]-              , ["test", "other"]-              ]-        forM_ testCases $ \anns -> do-          let config = "foo a=(test)1"-              decoder = proc () -> do-                KDL.propWith' "a" anns KDL.number -< ()-          decodeNode "foo" decoder config `shouldBe` Right 1--      it "decodes prop without an annotation" $ do-        let testCases =-              [ []-              , ["test"]-              , ["test", "other"]-              ]-        forM_ testCases $ \anns -> do-          let config = "foo a=1"-              decoder = proc () -> do-                KDL.propWith' "a" anns KDL.number -< ()-          decodeNode "foo" decoder config `shouldBe` Right 1--      it "fails when prop has unexpected annotation" $ do-        let config = "foo a=(test)1"-            decoder = proc () -> do-              KDL.propWith' "a" ["VAL"] KDL.number -< ()-        decodeNode "foo" decoder config-          `shouldSatisfy` decodeErrorMsg-            [ "At: foo #0 > prop a"-            , "  Expected annotation to be one of [\"VAL\"], got: test"-            ]--    describe "remainingProps" $ do-      it "decodes remaining props" $ do-        let config = "foo a=1 b=2 c=3 b=4"-            decoder = proc () -> do-              _ <- KDL.prop @Int "a" -< ()-              KDL.remainingProps @Int -< ()-        decodeNode "foo" decoder config-          `shouldBe` (Right . Map.fromList) [("b", 4), ("c", 3)]--      it "returns empty map if no props left" $ do-        let config = "foo a=1"-            decoder = proc () -> do-              _ <- KDL.prop @Int "a" -< ()-              KDL.remainingProps @Int -< ()-        decodeNode "foo" decoder config `shouldBe` Right Map.empty--      it "fails if prop fails to parse" $ do-        let config = "foo a=1 b=1 c=2 c=test"-            decoder = proc () -> do-              _ <- KDL.prop @Int "a" -< ()-              KDL.remainingProps @Int -< ()-        decodeNode "foo" decoder config-          `shouldSatisfy` decodeErrorMsg-            [ "At: foo #0 > prop c"-            , "  Expected number, got: test"-            ]--    -- Most behaviors tested with `remainingProps`-    describe "remainingPropsWith" $ do-      it "decodes remaining props" $ do-        let config = "foo a=1 b=2 c=3 b=4"-            decoder = proc () -> do-              _ <- KDL.prop @Int "a" -< ()-              KDL.remainingPropsWith KDL.number -< ()-        decodeNode "foo" decoder config-          `shouldBe` (Right . Map.fromList) [("b", 4), ("c", 3)]--    -- Most behaviors tested with `remainingPropsWith`-    describe "remainingPropsWith'" $ do-      it "decodes props with an annotation" $ do-        let testCases =-              [ []-              , ["test"]-              , ["test", "other"]-              ]-        forM_ testCases $ \anns -> do-          let config = "foo a=(test)1 b=(test)2"-              decoder = proc () -> do-                KDL.remainingPropsWith' anns KDL.number -< ()-          decodeNode "foo" decoder config-            `shouldBe` (Right . Map.fromList) [("a", 1), ("b", 2)]--      it "decodes props without an annotation" $ do-        let testCases =-              [ []-              , ["test"]-              , ["test", "other"]-              ]-        forM_ testCases $ \anns -> do-          let config = "foo a=1 b=2"-              decoder = proc () -> do-                KDL.remainingPropsWith' anns KDL.number -< ()-          decodeNode "foo" decoder config-            `shouldBe` (Right . Map.fromList) [("a", 1), ("b", 2)]--      it "fails when prop has unexpected annotation" $ do-        let config = "foo a=(VAL)1 b=(test)2"-            decoder = proc () -> do-              KDL.remainingPropsWith' ["VAL"] KDL.number -< ()-        decodeNode "foo" decoder config-          `shouldSatisfy` decodeErrorMsg-            [ "At: foo #0 > prop b"-            , "  Expected annotation to be one of [\"VAL\"], got: test"-            ]--    describe "children" $ do-      it "decodes children" $ do-        let config = "foo { bar test; }"-            decoder = proc () -> do-              KDL.children $ KDL.node @Node "bar" -< ()-            expected =-              Node-                { ann = Nothing-                , name = Identifier{value = "bar", format = Nothing}-                , entries =-                    [ Entry-                        { name = Nothing-                        , value = Value{ann = Nothing, data_ = Text "test", format = Nothing}-                        , format = Nothing-                        }-                    ]-                , children = Just NodeList{nodes = [], format = Nothing}-                , format = Nothing-                }-        decodeNode "foo" decoder config `shouldBe` Right expected--      it "can be re-entered" $ do-        let config = "foo { bar a; baz b; }"-            decoder = proc () -> do-              arg1 <- KDL.children $ KDL.argAt @Text "bar" -< ()-              arg2 <- KDL.children $ KDL.argAt @Text "baz" -< ()-              returnA -< (arg1, arg2)-        decodeNode "foo" decoder config `shouldBe` Right ("a", "b")--      it "fails if not all children are decoded" $ do-        let config = "foo { asdf; bar; }"-            decoder = proc () -> do-              KDL.children $ KDL.node @Node "bar" -< ()-        decodeNode "foo" decoder config-          `shouldSatisfy` decodeErrorMsg-            [ "At: foo #0"-            , "  Unexpected node: asdf #0"-            ]--  describe "ValueDecoder" $ do-    describe "any" $ do-      it "decodes any value" $ do-        let config = "foo 1.0 asdf true"-            decoder = KDL.document $ proc () -> do-              KDL.argsAtWith "foo" KDL.any -< ()-            val data_ =-              Value-                { ann = Nothing-                , data_ = data_-                , format = Nothing-                }-        KDL.decodeWith decoder config-          `shouldBe` Right [val $ Number 1, val $ Text "asdf", val $ Bool True]--    describe "text" $ do-      it "decodes text value" $ do-        let config = "foo asdf"-            decoder = KDL.document $ proc () -> do-              KDL.argAtWith "foo" KDL.text -< ()-        KDL.decodeWith decoder config `shouldBe` Right "asdf"--      it "fails when value is not text" $ do-        let config = "foo 1"-            decoder = KDL.document $ proc () -> do-              KDL.argAtWith "foo" KDL.text -< ()-        KDL.decodeWith decoder config-          `shouldSatisfy` decodeErrorMsg-            [ "At: foo #0 > arg #0"-            , "  Expected text, got: 1"-            ]--    describe "number" $ do-      it "decodes number value" $ do-        let config = "foo 1"-            decoder = KDL.document $ proc () -> do-              KDL.argAtWith "foo" KDL.number -< ()-        KDL.decodeWith decoder config `shouldBe` Right 1--      it "fails when value is not number" $ do-        let config = "foo asdf"-            decoder = KDL.document $ proc () -> do-              KDL.argAtWith "foo" KDL.number -< ()-        KDL.decodeWith decoder config-          `shouldSatisfy` decodeErrorMsg-            [ "At: foo #0 > arg #0"-            , "  Expected number, got: asdf"-            ]--    describe "bool" $ do-      it "decodes bool value" $ do-        let config = "foo true"-            decoder = KDL.document $ proc () -> do-              KDL.argAtWith "foo" KDL.bool -< ()-        KDL.decodeWith decoder config `shouldBe` Right True--      it "fails when value is not bool" $ do-        let config = "foo 1"-            decoder = KDL.document $ proc () -> do-              KDL.argAtWith "foo" KDL.bool -< ()-        KDL.decodeWith decoder config-          `shouldSatisfy` decodeErrorMsg-            [ "At: foo #0 > arg #0"-            , "  Expected bool, got: 1"-            ]--    describe "null" $ do-      it "decodes null value" $ do-        let config = "foo null"-            decoder = KDL.document $ proc () -> do-              KDL.argAtWith "foo" KDL.null -< ()-        KDL.decodeWith decoder config `shouldBe` Right ()--      it "fails when value is not null" $ do-        let config = "foo 1"-            decoder = KDL.document $ proc () -> do-              KDL.argAtWith "foo" KDL.null -< ()-        KDL.decodeWith decoder config-          `shouldSatisfy` decodeErrorMsg-            [ "At: foo #0 > arg #0"-            , "  Expected null, got: 1"-            ]--  describe "Combinators" $ do-    describe "oneOf" $ do-      it "decodes one of the options" $ do-        let config = "foo 123 hello"-            decoder = KDL.document $ proc () -> do-              KDL.nodeWith "foo" . KDL.many . KDL.argWith $-                KDL.oneOf [Left <$> KDL.number, Right <$> KDL.text]-                -<-                  ()-        KDL.decodeWith decoder config `shouldBe` Right [Left 123, Right "hello"]--      it "fails if none can be decoded" $ do-        let config = "foo 123 hello"-            decoder = KDL.document $ proc () -> do-              KDL.nodeWith "foo" . KDL.many . KDL.argWith $-                KDL.oneOf [Left <$> KDL.number, Right <$> KDL.bool]-                -<-                  ()-        KDL.decodeWith decoder config-          `shouldSatisfy` decodeErrorMsg-            [ "At: foo #0 > arg #1"-            , "  Expected bool, got: hello"-            , "  Expected number, got: hello"-            ]--    describe "option" $ do-      it "defaults to the given value" $ do-        let config = "foo"-            decoder = KDL.document $ proc () -> do-              KDL.nodeWith "foo" $ KDL.option 123 $ KDL.arg @Int -< ()-        KDL.decodeWith decoder config `shouldBe` Right 123--schemaSpec :: Spec-schemaSpec = do-  describe "documentSchema" $ do-    it "gets the schema of a decoder" $ do-      let decoder = KDL.document $ proc () -> do-            x <- KDL.nodeWith "foo" $ show <$> KDL.argWith decodeFoo -< ()-            ys <- KDL.many $ KDL.nodeWith "bar" $ KDL.arg @String -< ()-            returnA -< (x, ys)-          decodeFoo =-            KDL.oneOf-              [ Left <$> KDL.valueDecoder @Bool-              , Right <$> KDL.valueDecoder @Text-              ]-          expected =-            KDL.SchemaAnd-              [ KDL.SchemaOne . KDL.NodeNamed "foo" $-                  KDL.TypedNodeSchema-                    { typeHint = typeRep $ Proxy @String-                    , validTypeAnns = []-                    , nodeSchema =-                        KDL.SchemaOne . KDL.NodeArg $-                          KDL.TypedValueSchema-                            { typeHint = typeRep $ Proxy @(Either Bool Text)-                            , validTypeAnns = []-                            , dataSchema =-                                KDL.SchemaOr-                                  [ KDL.SchemaOne KDL.BoolSchema-                                  , KDL.SchemaOne KDL.TextSchema-                                  ]-                            }-                    }-              , KDL.SchemaOr-                  [ KDL.SchemaSome . KDL.SchemaOne . KDL.NodeNamed "bar" $-                      KDL.TypedNodeSchema-                        { typeHint = typeRep $ Proxy @String-                        , validTypeAnns = []-                        , nodeSchema =-                            KDL.SchemaOne . KDL.NodeArg $-                              KDL.TypedValueSchema-                                { typeHint = typeRep $ Proxy @String-                                , validTypeAnns = ["string"]-                                , dataSchema = KDL.SchemaOne KDL.TextSchema-                                }-                        }-                  , KDL.SchemaAnd []-                  ]-              ]-      KDL.documentSchema decoder `shouldBe` expected--newtype MyNode = MyNode Int-  deriving (Eq)--instance KDL.DecodeNode MyNode where-  validNodeTypeAnns _ = ["MyNode"]-  nodeDecoder = proc () -> do-    x <- KDL.arg -< ()-    if not (0 < x && x < 10)-      then KDL.fail -< "Invalid argument: " <> (Text.pack . show) x-      else returnA -< ()-    returnA -< MyNode x--decodeNodeSpec :: Spec-decodeNodeSpec = do-  describe "DecodeNode" $ do-    it "decodes a custom node" $ do-      let config = "foo 1"-          decoder = KDL.document $ proc () -> do-            KDL.node "foo" -< ()-      KDL.decodeWith decoder config `shouldBe` Right (MyNode 1)--    it "throws user-specified error" $ do-      let config = "foo 100"-          decoder = KDL.document $ proc () -> do-            KDL.node @MyNode "foo" -< ()-      KDL.decodeWith decoder config-        `shouldSatisfy` decodeErrorMsg-          [ "At: foo #0"-          , "  Invalid argument: 100"-          ]--    it "decodes valid type ann" $ do-      let config = "(MyNode)foo 1"-          decoder = KDL.document $ proc () -> do-            KDL.node "foo" -< ()-      KDL.decodeWith decoder config `shouldBe` Right (MyNode 1)--    it "fails on invalid type ann" $ do-      let config = "(bad)foo 1"-          decoder = KDL.document $ proc () -> do-            KDL.node @MyNode "foo" -< ()-      KDL.decodeWith decoder config-        `shouldSatisfy` decodeErrorMsg-          [ "At: foo #0"-          , "  Expected annotation to be one of [\"MyNode\"], got: bad"-          ]--newtype MyVal = MyVal Double-  deriving (Eq)--instance KDL.DecodeValue MyVal where-  validValueTypeAnns _ = ["MyVal"]-  valueDecoder = KDL.withDecoder KDL.number $ \x -> do-    unless (0 < x && x < 10) $ do-      KDL.failM $ "Invalid value: " <> (Text.pack . show) x-    pure $ MyVal (realToFrac x)--decodeValueSpec :: Spec-decodeValueSpec = do-  describe "DecodeValue" $ do-    it "decodes a custom value" $ do-      let config = "foo 1"-          decoder = KDL.document $ proc () -> do-            KDL.argAt "foo" -< ()-      KDL.decodeWith decoder config `shouldBe` Right (MyVal 1)--    it "throws user-specified error" $ do-      let config = "foo 100.0"-          decoder = KDL.document $ proc () -> do-            KDL.argAt @MyVal "foo" -< ()-      KDL.decodeWith decoder config-        `shouldSatisfy` decodeErrorMsg-          [ "At: foo #0 > arg #0"-          , "  Invalid value: 100.0"-          ]--    it "decodes valid type ann" $ do-      let config = "foo (MyVal)1"-          decoder = KDL.document $ proc () -> do-            KDL.argAt "foo" -< ()-      KDL.decodeWith decoder config `shouldBe` Right (MyVal 1)--    it "fails on invalid type ann" $ do-      let config = "foo (bad)1"-          decoder = KDL.document $ proc () -> do-            KDL.argAt @MyVal "foo" -< ()-      KDL.decodeWith decoder config-        `shouldSatisfy` decodeErrorMsg-          [ "At: foo #0 > arg #0"-          , "  Expected annotation to be one of [\"MyVal\"], got: bad"-          ]