diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -191,12 +191,12 @@ submission :: Consumer Value Doc Submission submission = - obj "Submission" - (Submission - <$> key "token" (integer "Submission token; see the API docs") - <*> key "title" (string "Submission title") - <*> key "comment" (string "Submission comment") - <*> key "subreddit" (integer "The ID of the subreddit")) + object "Submission" + (Submission + <$> key "token" (integer "Submission token; see the API docs") + <*> key "title" (string "Submission title") + <*> key "comment" (string "Submission comment") + <*> key "subreddit" (integer "The ID of the subreddit")) sample :: Value sample = diff --git a/descriptive.cabal b/descriptive.cabal --- a/descriptive.cabal +++ b/descriptive.cabal @@ -1,5 +1,5 @@ name: descriptive -version: 0.3.1 +version: 0.4.0 synopsis: Self-describing consumers/parsers; forms, cmd-line args, JSON, etc. description: Self-describing consumers/parsers. See the README.md for more information. It is currently EXPERIMENTAL. stability: Experimental @@ -23,8 +23,15 @@ Descriptive.Formlet Descriptive.Options Descriptive.JSON - build-depends: base >= 4 && <5, - transformers, containers, text, mtl, aeson, bifunctors + build-depends: aeson + , base >= 4 && <5 + , bifunctors + , containers + , mtl + , scientific + , text + , transformers + , vector test-suite test type: exitcode-stdio-1.0 diff --git a/src/Descriptive/JSON.hs b/src/Descriptive/JSON.hs --- a/src/Descriptive/JSON.hs +++ b/src/Descriptive/JSON.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE OverloadedStrings #-} @@ -9,36 +12,55 @@ module Descriptive.JSON (-- * Combinators - obj + object ,key + ,keyMaybe + ,array ,string ,integer + ,double + ,bool + ,null + ,label -- * Description ,Doc(..) ) where -import Data.Bifunctor -import Data.Monoid -import Descriptive +import Data.Scientific +import Descriptive -import Data.Aeson -import Data.Aeson.Types -import Data.Text (Text) +import Data.Function +import Data.Aeson hiding (Value(Object,Null,Array),object) +import Data.Aeson.Types (Value,parseMaybe) +import qualified Data.Aeson.Types as Aeson +import Data.Bifunctor +import Data.Data +import Data.Monoid +import Data.Text (Text) +import Data.Vector ((!)) +import Data.Vector (Vector) +import qualified Data.Vector as V +import Prelude hiding (null) -- | Description of parseable things. data Doc = Integer !Text + | Double !Text | Text !Text - | Struct !Text + | Boolean !Text + | Null !Text + | Object !Text | Key !Text - deriving (Show,Eq) + | Array !Text + | Label !Text + deriving (Eq,Show,Typeable,Data) -- | Consume an object. -obj :: Text -- ^ Description of what the object is. - -> Consumer Object Doc a -- ^ An object consumer. - -> Consumer Value Doc a -obj desc = +object :: Text -- ^ Description of what the object is. + -> Consumer Object Doc a -- ^ An object consumer. + -> Consumer Value Doc a +object desc = wrap (\v d -> (Wrap doc (fst (d mempty)),v)) (\v _ p -> case fromJSON v of @@ -49,7 +71,7 @@ (Continued e,_) -> Failed (Wrap doc e) (Succeeded a,_) -> Succeeded a ,toJSON o)) - where doc = Struct desc + where doc = Object desc -- | Consume from object at the given key. key :: Text -- ^ The key to lookup. @@ -70,6 +92,49 @@ (p v))) where doc = Key k +-- | Optionally consume from object at the given key, only if it +-- exists. +keyMaybe :: Text -- ^ The key to lookup. + -> Consumer Value Doc a -- ^ A value consumer of the object at the key. + -> Consumer Object Doc (Maybe a) +keyMaybe k = + wrap (\o d -> + first (Wrap doc) + (second (const o) + (d (toJSON o)))) + (\o _ p -> + case parseMaybe (const (o .: k)) + () of + Nothing -> (Succeeded Nothing,o) + Just (v :: Value) -> + first (bimap (Wrap doc) Just) + (second (const o) + (p v))) + where doc = Key k + +-- | Consume an array. +array :: Text -> Consumer Value Doc a -> Consumer Value Doc (Vector a) +array desc = + wrap (\v d -> (Wrap doc (fst (d Aeson.Null)),v)) + (\v _ p -> + case fromJSON v of + Error{} -> (Failed (Unit doc),v) + Success (o :: Vector Value) -> + (fix (\loop i acc -> + if i < V.length o - 1 + then case p (o ! i) of + (Failed e,_) -> + Failed (Wrap doc e) + (Continued e,_) -> + Failed (Wrap doc e) + (Succeeded a,_) -> + loop (i + 1) (a : acc) + else Succeeded (V.fromList (reverse acc))) + 0 + [] + ,v)) + where doc = Array desc + -- | Consume a string. string :: Text -- ^ Description of what the string is for. -> Consumer Value Doc Text @@ -87,7 +152,52 @@ integer doc = consumer (d,) (\s -> + case s of + Number a + | Right i <- floatingOrInteger a -> + (Succeeded i,s) + _ -> (Failed d,s)) + where d = Unit (Integer doc) + +-- | Consume an double. +double :: Text -- ^ Description of what the double is for. + -> Consumer Value Doc Double +double doc = + consumer (d,) + (\s -> + case s of + Number a -> + (Succeeded (toRealFloat a),s) + _ -> (Failed d,s)) + where d = Unit (Double doc) + +-- | Parse a boolean. +bool :: Text -- ^ Description of what the bool is for. + -> Consumer Value Doc Bool +bool doc = + consumer (d,) + (\s -> case fromJSON s of Error{} -> (Failed d,s) Success a -> (Succeeded a,s)) - where d = Unit (Integer doc) + where d = Unit (Boolean doc) + +-- | Expect null. +null :: Text -- ^ What the null is for. + -> Consumer Value Doc () +null doc = + consumer (d,) + (\s -> + case fromJSON s of + Success Aeson.Null -> (Succeeded (),s) + _ -> (Failed d,s)) + where d = Unit (Null doc) + +-- | Wrap a consumer with a label containing additional description. +label :: Text -- ^ Some label. + -> Consumer s Doc a -- ^ An object consumer. + -> Consumer s Doc a +label desc = + wrap (\s d -> (Wrap doc (fst (d s)),s)) + (\s _ p -> p s) + where doc = Label desc diff --git a/src/test/Main.hs b/src/test/Main.hs --- a/src/test/Main.hs +++ b/src/test/Main.hs @@ -167,12 +167,12 @@ submission :: Consumer Value JSON.Doc Submission submission = - JSON.obj "Submission" - (Submission - <$> JSON.key "token" (JSON.integer "Submission token; see the API docs") - <*> JSON.key "title" (JSON.string "Submission title") - <*> JSON.key "comment" (JSON.string "Submission comment") - <*> JSON.key "subreddit" (JSON.integer "The ID of the subreddit")) + JSON.object "Submission" + (Submission + <$> JSON.key "token" (JSON.integer "Submission token; see the API docs") + <*> JSON.key "title" (JSON.string "Submission title") + <*> JSON.key "comment" (JSON.string "Submission comment") + <*> JSON.key "subreddit" (JSON.integer "The ID of the subreddit")) sample :: Value sample = @@ -194,7 +194,7 @@ json = do it "describe JSON" (describe submission (toJSON ()) == - Wrap (JSON.Struct "Submission") + Wrap (JSON.Object "Submission") (And (And (And (Wrap (JSON.Key "token") (Unit (JSON.Integer "Submission token; see the API docs"))) (Wrap (JSON.Key "title") @@ -211,6 +211,6 @@ ,submissionSubreddit = 234214})) it "failing json" (consume submission badsample == - Failed (Wrap (JSON.Struct "Submission") + Failed (Wrap (JSON.Object "Submission") (Wrap (JSON.Key "comment") (Unit (JSON.Text "Submission comment")))))