descriptive 0.3.1 → 0.4.0

raw patch · 4 files changed

+149/−32 lines, 4 filesdep +scientificdep +vectordep ~aesonPVP ok

version bump matches the API change (PVP)

Dependencies added: scientific, vector

Dependency ranges changed: aeson

API changes (from Hackage documentation)

Files

• README.md +6/−6
• descriptive.cabal +10/−3
• src/Descriptive/JSON.hs +125/−15
• src/test/Main.hs +8/−8

@@ -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 =

@@ -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

@@ -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

@@ -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")))))