diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +## v0.2.1 + +* Add `KDL.Applicative` +* Re-export `Control.Arrow` and `Control.Category` from `KDL.Arrow`, for convenience + ## v0.2.0 * Remove monad `Decoder` newtype, just give the `Monad` instance to the canonical `Decoder` type and use the same `Decoder` type everywhere diff --git a/kdl-hs.cabal b/kdl-hs.cabal --- a/kdl-hs.cabal +++ b/kdl-hs.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: kdl-hs -version: 0.2.0 +version: 0.2.1 synopsis: KDL language parser and API description: KDL language parser and API. homepage: https://github.com/brandonchinn178/kdl-hs#readme @@ -24,6 +24,7 @@ hs-source-dirs: src exposed-modules: KDL + KDL.Applicative KDL.Arrow KDL.Decoder KDL.Decoder.Arrow @@ -59,6 +60,7 @@ hs-source-dirs: test main-is: Main.hs other-modules: + KDL.ApplicativeSpec KDL.ParserSpec KDL.Decoder.ArrowSpec KDL.Decoder.MonadSpec diff --git a/src/KDL.hs b/src/KDL.hs --- a/src/KDL.hs +++ b/src/KDL.hs @@ -4,8 +4,8 @@ > import KDL qualified This provides a Monad interface for decoding KDL files, which is sufficient for -most cases. You may wish to use "KDL.Arrow" if you would like to -statically analyze a decoder's schema, e.g. to generate documentation. +most cases. You may wish to use "KDL.Applicative" or "KDL.Arrow" if you would +like to statically analyze a decoder's schema, e.g. to generate documentation. = Quickstart @@ -65,6 +65,7 @@ @ -} module KDL ( + -- * Re-exports module X, ) where diff --git a/src/KDL/Applicative.hs b/src/KDL/Applicative.hs new file mode 100644 --- /dev/null +++ b/src/KDL/Applicative.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE DataKinds #-} + +{-| +This module is intended to be imported qualified as: + +> import KDL.Applicative qualified as KDL + +This module is equivalent to "KDL", except when @ApplicativeDo@ and +@QualifiedDo@ are enabled, @KDL.do@ will ensure you don't accidentally use +monadic operations. + +The Applicative decoder can do most of the things the Arrow decoder can do, +except run different decoders based on a previously decoded result. If you +need to do that, either use "KDL.Arrow", or follow this example: + +@ +# Example KDL config + +rules { + - a + - b { + foo 123 # only allowed in b, not a + } +} +@ + +@ +{\-# LANGUAGE ApplicativeDo #-\} +{\-# LANGUAGE QualifiedDo #-\} + +import KDL.Arrow ((>>>), (|||)) +import KDL.Arrow qualified + +decoder = KDL.do + rules <- + KDL.dashNodesWith "rules" $ + (toEither \<$> KDL.arg) >>> fromEither + pure rules + where + toEither = \case + "a" -> Left $ () + "b" -> Right . Left $ () + name -> Right . Right $ "Invalid rule: " <> name + fromEither = + -- "a" + pure RuleA ||| + -- "b" + (RuleB \<$> KDL.children (KDL.argAt "foo")) ||| + -- else + KDL.Arrow.fail +@ +-} +module KDL.Applicative ( + -- * QualifiedDo + Prelude.fmap, + Prelude.pure, + Prelude.return, + (Prelude.<*>), + (Prelude.>>), + (>>=), + + -- * Re-exports + module X, +) where + +import GHC.TypeError qualified as GHC +import KDL.Decoder as X +import KDL.Parser as X +import KDL.Render as X +import KDL.Types as X +import Prelude hiding ((>>=)) + +class NoBind a where + -- | Gives a compile-time error if used. + -- + -- It seems like QualifiedDo still needs a definition for this, even with + -- ApplicativeDo enabled. + -- + -- https://discourse.haskell.org/t/qualifieddo-applicativedo-still-requires/13491 + (>>=) :: a +instance (GHC.Unsatisfiable (GHC.Text ">>= is not allowed in a KDL.do block")) => NoBind a where + (>>=) = GHC.unsatisfiable diff --git a/src/KDL/Arrow.hs b/src/KDL/Arrow.hs --- a/src/KDL/Arrow.hs +++ b/src/KDL/Arrow.hs @@ -68,9 +68,16 @@ @ -} module KDL.Arrow ( + -- * KDL re-exports module X, + + -- * base re-reexports + module Control.Arrow, + module Control.Category, ) where +import Control.Arrow +import Control.Category import KDL.Decoder.Arrow as X import KDL.Decoder.Schema as X import KDL.Parser as X diff --git a/src/KDL/Decoder/Internal/Decoder.hs b/src/KDL/Decoder/Internal/Decoder.hs --- a/src/KDL/Decoder/Internal/Decoder.hs +++ b/src/KDL/Decoder/Internal/Decoder.hs @@ -144,15 +144,16 @@ in go many (DecodeArrow sch run) = some (DecodeArrow sch run) <|> pure [] -type Decoder o a = DecodeArrow o () a - -- | Eliminates all schema information; avoid whenever possible. instance Monad (DecodeArrow o a) where + return = pure DecodeArrow _ run1 >>= k = DecodeArrow SchemaUnknown $ \a -> do x <- run1 a let DecodeArrow _ run2 = k x run2 a + +type Decoder o a = DecodeArrow o () a liftDecodeM :: (a -> DecodeM b) -> DecodeArrow o a b liftDecodeM f = DecodeArrow (SchemaAnd []) (Trans.lift . f) diff --git a/test/KDL/ApplicativeSpec.hs b/test/KDL/ApplicativeSpec.hs new file mode 100644 --- /dev/null +++ b/test/KDL/ApplicativeSpec.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QualifiedDo #-} + +module KDL.ApplicativeSpec (spec) where + +import Data.Int (Int64) +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import Data.Typeable (typeRep) +import KDL.Applicative qualified as KDL +import KDL.Arrow ((>>>), (|||)) +import KDL.Arrow qualified +import Skeletest + +spec :: Spec +spec = do + describe "documentSchema" $ do + it "gets the schema of a decoder" $ do + let decoder = KDL.document $ KDL.do + x <- + KDL.nodeWith "foo" $ + fmap show . KDL.argWith $ + KDL.oneOf + [ Left <$> KDL.valueDecoder @Bool + , Right <$> KDL.valueDecoder @Text + ] + + ys <- KDL.many $ KDL.nodeWith "bar" $ KDL.arg @String + + z <- (parseBazType <$> KDL.argAt @Text "baz_type") >>> KDL.argAtWith "baz" decodeBaz + + pure (x, ys, z) + parseBazType = \case + "int" -> Left $ () + "bool" -> Right . Left $ () + ty -> Right . Right $ "Invalid type: " <> ty + decodeBaz = + -- "int" + KDL.valueDecoder @Int64 + -- "bool" + ||| ((\b -> if b then 1 else 0) <$> KDL.valueDecoder @Bool) + -- else + ||| KDL.Arrow.fail + 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.SchemaOne . KDL.NodeNamed "baz_type" $ + KDL.TypedNodeSchema + { typeHint = typeRep $ Proxy @Text + , validTypeAnns = [] + , nodeSchema = + KDL.SchemaOne . KDL.NodeArg $ + KDL.TypedValueSchema + { typeHint = typeRep $ Proxy @Text + , validTypeAnns = ["text"] + , dataSchema = KDL.SchemaOne KDL.TextSchema + } + } + , KDL.SchemaOne . KDL.NodeNamed "baz" $ + KDL.TypedNodeSchema + { typeHint = typeRep $ Proxy @Int64 + , validTypeAnns = [] + , nodeSchema = + KDL.SchemaOne . KDL.NodeArg $ + KDL.TypedValueSchema + { typeHint = typeRep $ Proxy @Int64 + , validTypeAnns = [] + , dataSchema = + KDL.SchemaOr + [ KDL.SchemaOne KDL.NumberSchema + , KDL.SchemaOne KDL.BoolSchema + ] + } + } + ] + KDL.documentSchema decoder `shouldBe` expected