diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,6 @@ +0.9.0: + * Move 'validate' to .JSON as 'parse'. + 0.5.0: * Changed the parser/doc type to use StateT m. So now you can use monads as part of your consumers. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -205,7 +205,6 @@ anyString "SERVER_NAME" <*> switch "dev" "Enable dev mode?" <*> arg "port" "Port to listen on") - ((,,,) <$> ``` ``` haskell @@ -267,15 +266,15 @@ ``` haskell λ> describe submission (toJSON ()) -Wrap (Struct "Submission") - (And (And (And (Wrap (Key "token") - (Unit (Integer "Submission token; see the API docs"))) - (Wrap (Key "title") - (Unit (Text "Submission title")))) - (Wrap (Key "comment") - (Unit (Text "Submission comment")))) - (Wrap (Key "subreddit") - (Unit (Integer "The ID of the subreddit")))) +Wrap (Object "Submission") + (And (And (And (Wrap (Key "token") + (Unit (Integer "Submission token; see the API docs"))) + (Wrap (Key "title") + (Unit (Text "Submission title")))) + (Wrap (Key "comment") + (Unit (Text "Submission comment")))) + (Wrap (Key "subreddit") + (Unit (Integer "The ID of the subreddit")))) λ> consume submission sample @@ -284,9 +283,9 @@ ,submissionComment = "This is good" ,submissionSubreddit = 234214}) λ> consume submission badsample -Failed (Wrap (Struct "Submission") - (Wrap (Key "comment") - (Unit (Text "Submission comment")))) +Failed (Wrap (Object "Submission") + (Wrap (Key "comment") + (Unit (Text "Submission comment")))) ``` The bad sample yields an informative message that: diff --git a/descriptive.cabal b/descriptive.cabal --- a/descriptive.cabal +++ b/descriptive.cabal @@ -1,5 +1,5 @@ name: descriptive -version: 0.8.0 +version: 0.9.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 diff --git a/src/Descriptive.hs b/src/Descriptive.hs --- a/src/Descriptive.hs +++ b/src/Descriptive.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -21,13 +23,12 @@ ,Result(..) -- * Combinators ,consumer - ,wrap - ,validate) + ,wrap) where import Control.Applicative -import Control.Monad.State.Strict import Control.Monad.Identity +import Control.Monad.State.Strict import Data.Bifunctor import Data.Monoid @@ -71,11 +72,13 @@ | Sequence ![Description a] | Wrap a !(Description a) | None - deriving (Show,Eq) + deriving (Show,Eq,Functor) instance Monoid (Description d) where mempty = None - mappend = And + mappend None x = x + mappend x None = x + mappend x y = And x y -- | The bounds of a many-consumable thing. data Bound @@ -158,7 +161,7 @@ Consumer d p <|> Consumer d' p' = consumer (do d1 <- d d2 <- d' - return (Or d1 d2)) + return (disjunct d1 d2)) (do s <- get r <- p case r of @@ -168,7 +171,7 @@ Failed e2 -> return (Failed e2) Continued e2 -> - return (Continued (e1 <> e2)) + return (Continued (disjunct e1 e2)) Succeeded a' -> return (Succeeded a') Failed e1 -> @@ -176,12 +179,15 @@ r' <- p' case r' of Failed e2 -> - return (Failed (Or e1 e2)) + return (Failed (disjunct e1 e2)) Continued e2 -> return (Continued e2) Succeeded a2 -> return (Succeeded a2) Succeeded a1 -> return (Succeeded a1)) + where disjunct None x = x + disjunct x None = x + disjunct x y = Or x y many = sequenceHelper 0 some = sequenceHelper 1 @@ -243,7 +249,7 @@ mempty = consumer (return mempty) (return mempty) - mappend x y = (<>) <$> x <*> y + mappend = liftA2 (<>) -------------------------------------------------------------------------------- -- Combinators @@ -269,27 +275,3 @@ wrap redescribe reparse (Consumer d p) = Consumer (redescribe d) (reparse d p) - --- | Add validation to a consumer. -validate :: Monad m - => d -- ^ Description of what it expects. - -> (a -> StateT s m (Maybe b)) -- ^ Attempt to parse the value. - -> Consumer s d m a -- ^ Consumer to add validation to. - -> Consumer s d m b -- ^ A new validating consumer. -validate d' check = - wrap (liftM wrapper) - (\d p -> - do s <- get - r <- p - case r of - (Failed e) -> return (Failed e) - (Continued e) -> - return (Continued (wrapper e)) - (Succeeded a) -> - do r' <- check a - case r' of - Nothing -> - do doc <- withStateT (const s) d - return (Continued (wrapper doc)) - Just a' -> return (Succeeded a')) - where wrapper = Wrap d' diff --git a/src/Descriptive/JSON.hs b/src/Descriptive/JSON.hs --- a/src/Descriptive/JSON.hs +++ b/src/Descriptive/JSON.hs @@ -12,7 +12,8 @@ module Descriptive.JSON (-- * Consumers - object + parse + ,object ,key ,keyMaybe ,array @@ -155,7 +156,7 @@ return (Continued (Unit doc)) Success (o :: Vector Value) -> fix (\loop i acc -> - if i < V.length o - 1 + if i < V.length o then do r <- runSubStateT (const (o ! i)) (const s) @@ -250,6 +251,32 @@ do r <- p case r of Failed e -> + return (Failed (Wrap doc e)) + Continued e -> return (Continued (Wrap doc e)) k -> return k) where doc = Label desc + +-- | Parse from a consumer. +parse :: Monad m + => d -- ^ Description of what it expects. + -> (a -> StateT s m (Maybe b)) -- ^ Attempt to parse the value. + -> Consumer s d m a -- ^ Consumer to add validation to. + -> Consumer s d m b -- ^ A new validating consumer. +parse d' check = + wrap (liftM wrapper) + (\d p -> + do s <- get + r <- p + case r of + (Failed e) -> return (Failed e) + (Continued e) -> + return (Continued (wrapper e)) + (Succeeded a) -> + do r' <- check a + case r' of + Nothing -> + do doc <- withStateT (const s) d + return (Continued (wrapper doc)) + Just a' -> return (Succeeded a')) + where wrapper = Wrap d'