kdl-hs (empty) → 0.1.0
raw patch · 22 files changed
+6060/−0 lines, 22 filesdep +basedep +containersdep +kdl-hs
Dependencies added: base, containers, kdl-hs, megaparsec, prettyprinter, scientific, skeletest, temporary, text, transformers
Files
- CHANGELOG.md +7/−0
- LICENSE.md +11/−0
- README.md +69/−0
- kdl-hs.cabal +70/−0
- src/Data/KDL.hs +70/−0
- src/Data/KDL/Decoder/Arrow.hs +1278/−0
- src/Data/KDL/Decoder/DecodeM.hs +94/−0
- src/Data/KDL/Decoder/Error.hs +96/−0
- src/Data/KDL/Decoder/Monad.hs +687/−0
- src/Data/KDL/Decoder/Schema.hs +80/−0
- src/Data/KDL/Parser.hs +91/−0
- src/Data/KDL/Parser/Hustle.hs +28/−0
- src/Data/KDL/Parser/Hustle/Formatter.hs +83/−0
- src/Data/KDL/Parser/Hustle/Internal.hs +96/−0
- src/Data/KDL/Parser/Hustle/Parser.hs +310/−0
- src/Data/KDL/Parser/Hustle/Types.hs +73/−0
- src/Data/KDL/Render.hs +132/−0
- src/Data/KDL/Types.hs +367/−0
- test/Data/KDL/Decoder/ArrowSpec.hs +1182/−0
- test/Data/KDL/Decoder/MonadSpec.hs +1122/−0
- test/Data/KDL/ParserSpec.hs +113/−0
- test/Main.hs +1/−0
+ CHANGELOG.md view
@@ -0,0 +1,7 @@+## v0.1.0++Initial release, with:++* Support for decoding v1 KDL syntax (and a subset of v2 KDL syntax)+* Decoding via Arrows or Monads+* Statically determine decoder schema
+ LICENSE.md view
@@ -0,0 +1,11 @@+Copyright © 2024-present Brandon Chinn++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,69 @@+# kdl-hs++[](https://github.com/brandonchinn178/kdl-hs/actions?query=branch%3Amain)+[](https://hackage.haskell.org/package/kdl-hs)++`kdl-hs` can parse and manage [KDL configuration files](https://kdl.dev).++## Quickstart++Given a file `config.kdl`:++```kdl+package {+ name my-pkg+ version "1.2.3"++ dependencies {+ aeson ">= 2.2.3.0" optional=#true+ text ">= 2"+ }+}+```++Parse it with `kdl-hs`:++```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 = 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{..}+```++## Acknowledgements++* The KDL spec authors for devising a super cool configuration language+* [kdl-rs](https://github.com/kdl-org/kdl-rs) for providing a guide for implementation+* [hustle](https://github.com/fuzzypixelz/hustle) for the initial parser implementation that got me started.
+ kdl-hs.cabal view
@@ -0,0 +1,70 @@+cabal-version: 3.0++name: kdl-hs+version: 0.1.0+synopsis: KDL language parser and API+description: KDL language parser and API.+homepage: https://github.com/brandonchinn178/kdl-hs#readme+bug-reports: https://github.com/brandonchinn178/kdl-hs/issues+author: Brandon Chinn <brandonchinn178@gmail.com>+maintainer: Brandon Chinn <brandonchinn178@gmail.com>+license: BSD-3-Clause+license-file: LICENSE.md+category: Text+build-type: Simple+extra-source-files:+ README.md+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/brandonchinn178/kdl-hs++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+ 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+ build-depends:+ base < 5+ , containers+ , megaparsec+ , prettyprinter >= 1.7.0+ , scientific+ , text+ , transformers+ default-language: GHC2021+ ghc-options: -Wall -Wcompat++test-suite kdl-tests+ type: exitcode-stdio-1.0+ ghc-options: -F -pgmF=skeletest-preprocessor+ build-tool-depends: skeletest:skeletest-preprocessor+ hs-source-dirs: test+ main-is: Main.hs+ other-modules:+ Data.KDL.ParserSpec+ Data.KDL.Decoder.ArrowSpec+ Data.KDL.Decoder.MonadSpec+ build-depends:+ base+ , containers+ , kdl-hs+ , skeletest+ , temporary+ , text+ default-language: GHC2021+ ghc-options: -Wall -Wcompat
+ src/Data/KDL.hs view
@@ -0,0 +1,70 @@+{-|+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
+ src/Data/KDL/Decoder/Arrow.hs view
@@ -0,0 +1,1278 @@+{-# 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
+ src/Data/KDL/Decoder/DecodeM.hs view
@@ -0,0 +1,94 @@+{-# 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]
+ src/Data/KDL/Decoder/Error.hs view
@@ -0,0 +1,96 @@+{-# 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
+ src/Data/KDL/Decoder/Monad.hs view
@@ -0,0 +1,687 @@+{-# 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 @())
+ src/Data/KDL/Decoder/Schema.hs view
@@ -0,0 +1,80 @@+{-# 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]
+ src/Data/KDL/Parser.hs view
@@ -0,0 +1,91 @@+{-# 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
+ src/Data/KDL/Parser/Hustle.hs view
@@ -0,0 +1,28 @@+{- 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+ )
+ src/Data/KDL/Parser/Hustle/Formatter.hs view
@@ -0,0 +1,83 @@+{- 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)
+ src/Data/KDL/Parser/Hustle/Internal.hs view
@@ -0,0 +1,96 @@+{- 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
+ src/Data/KDL/Parser/Hustle/Parser.hs view
@@ -0,0 +1,310 @@+{- 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 { .. }
+ src/Data/KDL/Parser/Hustle/Types.hs view
@@ -0,0 +1,73 @@+{- 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
+ src/Data/KDL/Render.hs view
@@ -0,0 +1,132 @@+{-# 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
+ src/Data/KDL/Types.hs view
@@ -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 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}
+ test/Data/KDL/Decoder/ArrowSpec.hs view
@@ -0,0 +1,1182 @@+{-# 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"+ ]
+ test/Data/KDL/Decoder/MonadSpec.hs view
@@ -0,0 +1,1122 @@+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.KDL.Decoder.MonadSpec (spec) where++import Control.Monad (forM_, unless, when)+import Data.KDL qualified as KDL+import Data.KDL.Types (+ Entry (..),+ Identifier (..),+ Node (..),+ NodeList (..),+ Value (..),+ ValueData (..),+ )+import Data.Map qualified as Map+import Data.Text (Text)+import Data.Text qualified as Text+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+ 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 $ 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 $ 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 $ do+ bar <- KDL.node "bar"+ foo <- KDL.node "foo"+ pure (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 $ do+ foo1 <- KDL.node @Node "foo"+ foo2 <- KDL.node @Node "foo"+ pure (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 = do+ arg <- KDL.arg @Int+ child <- KDL.children $ KDL.argAt @Text "hello"+ pure (arg, child)+ decoder = KDL.document $ 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 = do+ KDL.arg @Text+ decoder = KDL.document $ 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 $ 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 $ 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 $ 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 $ 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 = do+ KDL.optional $ KDL.arg @Int+ decoder = KDL.document $ 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 = do+ KDL.arg @Int+ decoder = KDL.document $ 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 $ 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 $ 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 $ 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 $ do+ hello <- KDL.argAt @Text "hello"+ foo <- KDL.argAt @Text "foo"+ pure (hello, foo)+ KDL.decodeWith decoder config `shouldBe` Right ("world", "bar")++ it "fails if no node" $ do+ let config = "other_node"+ decoder = KDL.document $ 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 $ 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 $ 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 $ 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 $ 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 $ 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 $ 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 $ 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 $ 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 $ 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 $ 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 $ 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 $ 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 $ 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 $ 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 $ 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 $ 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 $ 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 $ 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 $ 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 $ 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 $ 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 $ 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 $ 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 $ 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 $ 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 $ 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 $ 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 $ 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 = do+ arg <- KDL.arg @Int+ child <- KDL.children $ KDL.nodeWith "bar" $ KDL.arg @Text+ pure (arg, child)+ decoder = KDL.document $ 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 $ 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 $ do+ KDL.nodeWith name decoder+ )+ config++ describe "arg" $ do+ it "decodes an argument" $ do+ let config = "foo 1 \"bar\""+ decoder = do+ arg1 <- KDL.arg @Int+ arg2 <- KDL.arg @Text+ pure (arg1, arg2)+ decodeNode "foo" decoder config `shouldBe` Right (1, "bar")++ it "decodes multiple arguments" $ do+ let config = "foo 1 2 3"+ decoder = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = do+ prop1 <- KDL.prop @Text "test2"+ prop2 <- KDL.prop @Int "test1"+ pure (prop1, prop2)+ decodeNode "foo" decoder config `shouldBe` Right ("hello", 1)++ it "can optionally decode a prop" $ do+ let config = "foo a=1"+ decoder = do+ a <- KDL.optional $ KDL.prop @Int "a"+ b <- KDL.optional $ KDL.prop @Int "b"+ pure (a, b)+ decodeNode "foo" decoder config `shouldBe` Right (Just 1, Nothing)++ it "decodes last prop" $ do+ let config = "foo test=1 test=2"+ decoder = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = do+ arg1 <- KDL.children $ KDL.argAt @Text "bar"+ arg2 <- KDL.children $ KDL.argAt @Text "baz"+ pure (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 = 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 $ 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 $ 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 $ 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 $ 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 $ 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 $ 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 $ 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 $ 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 $ 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 $ 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 $ 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 $ do+ KDL.nodeWith "foo" $ KDL.option 123 $ KDL.arg @Int+ KDL.decodeWith decoder config `shouldBe` Right 123++newtype MyNode = MyNode Int+ deriving (Eq)++instance KDL.DecodeNode MyNode where+ validNodeTypeAnns _ = ["MyNode"]+ nodeDecoder = KDL.noSchema $ do+ x <- KDL.arg+ unless (0 < x && x < 10) $ do+ KDL.fail $ "Invalid argument: " <> (Text.pack . show) x+ pure $ MyNode x++decodeNodeSpec :: Spec+decodeNodeSpec = do+ describe "DecodeNode" $ do+ it "decodes a custom node" $ do+ let config = "foo 1"+ decoder = KDL.document $ 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 $ 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 $ 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 $ 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.noSchema . 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 $ 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 $ 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 $ 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 $ 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"+ ]
+ test/Data/KDL/ParserSpec.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.KDL.ParserSpec (spec) where++import Data.KDL.Parser+import Data.KDL.Types (+ Entry (..),+ Identifier (..),+ Node (..),+ NodeList (..),+ Value (..),+ ValueData (..),+ )+import Data.Text (Text)+import Data.Text qualified as Text+import Skeletest+import Skeletest.Predicate qualified as P+import System.IO.Temp (withSystemTempDirectory)++spec :: Spec+spec = do+ describe "parse" $ do+ it "parses a KDL document" $ do+ let expected =+ newNodeList+ [ newNode+ "foo"+ [ newArg $ Number 1.0+ , newProp "hello" $ Text "world"+ ]+ ( Just+ [ newNode "bar" [] (Just [])+ ]+ )+ ]+ parse "foo hello=world 1.0 { bar; }" `shouldBe` Right expected++ it "returns a textual error on parse failure" $ do+ let msg =+ Text.intercalate "\n" $+ [ "1:10:"+ , " |"+ , "1 | foo hello= 123"+ , " | ^^"+ , "unexpected \"= \""+ , "expecting Node Child, Node Space, or Node Terminator"+ ]+ parse "foo hello= 123" `shouldBe` Left msg++ describe "parseFile" $ do+ it "parses a KDL document from a filepath" $ do+ withSystemTempDirectory "" $ \tmpdir -> do+ let file = tmpdir ++ "/test.kdl"+ writeFile file "foo hello=world 1.0 { bar; }"+ let expected =+ newNodeList+ [ newNode+ "foo"+ [ newArg $ Number 1.0+ , newProp "hello" $ Text "world"+ ]+ ( Just+ [ newNode "bar" [] (Just [])+ ]+ )+ ]+ parseFile file `shouldSatisfy` P.returns (P.right (P.eq expected))++{----- Helpers -----}++newNodeList :: [Node] -> NodeList+newNodeList nodes =+ NodeList+ { nodes = nodes+ , format = Nothing+ }++newNode :: Text -> [Entry] -> Maybe [Node] -> Node+newNode name entries children =+ Node+ { ann = Nothing+ , name = newIdentifier name+ , entries = entries+ , children = newNodeList <$> children+ , format = Nothing+ }++newArg :: ValueData -> Entry+newArg = newEntry Nothing++newProp :: Text -> ValueData -> Entry+newProp = newEntry . Just++newEntry :: Maybe Text -> ValueData -> Entry+newEntry mName data_ =+ Entry+ { name = newIdentifier <$> mName+ , value =+ Value+ { ann = Nothing+ , data_ = data_+ , format = Nothing+ }+ , format = Nothing+ }++newIdentifier :: Text -> Identifier+newIdentifier value =+ Identifier+ { value = value+ , format = Nothing+ }
+ test/Main.hs view
@@ -0,0 +1,1 @@+import Skeletest.Main