descriptive-0.9.4/0000755000000000000000000000000012543735526012247 5ustar0000000000000000descriptive-0.9.4/Setup.hs0000644000000000000000000000005612543735526013704 0ustar0000000000000000import Distribution.Simple main = defaultMain descriptive-0.9.4/README.md0000644000000000000000000002477012543735526013540 0ustar0000000000000000descriptive ===== Self-describing consumers/parsers [Documentation](http://chrisdone.github.io/descriptive/) There are a variety of Haskell libraries which are implementable through a common interface: self-describing parsers: * A formlet is a self-describing parser. * A regular old text parser can be self-describing. * A command-line options parser is a self-describing parser. * A MUD command set is a self-describing parser. * A JSON API can be a self-describing parser. Consumption is done in this data type: ``` haskell data Consumer s d m a ``` ### Making descriptive consumers To make a consumer, this combinator is used: ``` haskell consumer :: (StateT s m (Description d)) -- ^ Produce description based on the state. -> (StateT s m (Result (Description d) a)) -- ^ Parse the state and maybe transform it if desired. -> Consumer s d m a ``` The first argument generates a description based on some state. The state is determined by whatever use-case you have. The second argument parses from the state, which could be a stream of bytes, a list of strings, a Map, a Vector, etc. You may or may not decide to modify the state during generation of the description and during parsing. ### Running descriptive consumers To use a consumer or describe what it does, these are used: ``` haskell consume :: Consumer s d Identity a -- ^ The consumer to run. -> s -- ^ Initial state. -> Result (Description d) a describe :: Consumer s d Identity a -- ^ The consumer to run. -> s -- ^ Initial state. Can be \"empty\" if you don't use it for -- generating descriptions. -> Description d -- ^ A description and resultant state. ``` Alternatively the parser/printer can be run in a monad of your choice: ``` haskell runConsumer :: Monad m => Consumer s d m a -- ^ The consumer to run. -> StateT s m (Result (Description d) a) runDescription :: Monad m => Consumer s d m a -- ^ The consumer to run. -> StateT s m (Description d) -- ^ A description and resultant state. ``` ### Descriptions A description is like this: ``` haskell data Description a = Unit !a | Bounded !Integer !Bound !(Description a) | And !(Description a) !(Description a) | Or !(Description a) !(Description a) | Sequence ![Description a] | Wrap a !(Description a) | None ``` You configure the `a` for your use-case, but the rest is generatable by the library. Afterwards, you can make your own pretty printing function, which may be to generate an HTML form, to generate a commandline `--help` screen, a man page, API docs for your JSON parser, a text parsing grammar, etc. For example: ``` haskell describeParser :: Description Text -> Text describeForm :: Description (Html ()) -> Html () describeArgs :: Description CmdArgs -> Text ``` ### Wrapping One can wrap up a consumer to alter either the description or the parser or both, this can be used for wrapping labels, or adding validation, things of that nature: ``` haskell wrap :: (StateT t m (Description d) -> StateT s m (Description d)) -- ^ Transform the description. -> (StateT t m (Description d) -> StateT t m (Result (Description d) a) -> StateT s m (Result (Description d) b)) -- ^ Transform the parser. Can re-run the parser as many times as desired. -> Consumer t d m a -> Consumer s d m b ``` There is also a handy function written in terms of `wrap` which will validate a consumer. ``` haskell 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. ``` See below for some examples of this library. ## Parsing characters See `Descriptive.Char`. ``` haskell λ> describe (many (char 'k') <> string "abc") mempty And (Bounded 0 UnlimitedBound (Unit "k")) (Sequence [Unit "a",Unit "b",Unit "c",None]) λ> consume (many (char 'k') <> string "abc") "kkkabc" (Succeeded "kkkabc") λ> consume (many (char 'k') <> string "abc") "kkkab" (Failed (Unit "a character")) λ> consume (many (char 'k') <> string "abc") "kkkabj" (Failed (Unit "c")) ``` ## Validating forms with named inputs See `Descriptive.Form`. ``` haskell λ> describe ((,) <$> input "username" <*> input "password") mempty And (Unit (Input "username")) (Unit (Input "password")) λ> consume ((,) <$> input "username" <*> input "password") (M.fromList [("username","chrisdone"),("password","god")]) Succeeded ("chrisdone","god") ``` Conditions on two inputs: ``` haskell login = validate "confirmed password (entered the same twice)" (\(x,y) -> if x == y then Just y else Nothing) ((,) <$> input "password" <*> input "password2") <|> input "token" ``` ``` haskell λ> consume login (M.fromList [("password2","gob"),("password","gob")]) Succeeded "gob" λ> consume login (M.fromList [("password2","gob"),("password","go")]) Continued (And (Wrap (Constraint "confirmed password (entered the same twice)") (And (Unit (Input "password")) (Unit (Input "password2")))) (Unit (Input "token"))) λ> consume login (M.fromList [("password2","gob"),("password","go"),("token","woot")]) Succeeded "woot" ``` ## Validating forms with auto-generated input indexes See `Descriptive.Formlet`. ``` haskell λ> describe ((,) <$> indexed <*> indexed) (FormletState mempty 0) And (Unit (Index 0)) (Unit (Index 1)) λ> consume ((,) <$> indexed <*> indexed) (FormletState (M.fromList [(0,"chrisdone"),(1,"god")]) 0) Succeeded ("chrisdone","god") λ> consume ((,) <$> indexed <*> indexed) (FormletState (M.fromList [(0,"chrisdone")]) 0) Failed (Unit (Index 1)) ``` ## Parsing command-line options See `Descriptive.Options`. ``` haskell server = ((,,,) <$> constant "start" "cmd" () <*> anyString "SERVER_NAME" <*> switch "dev" "Enable dev mode?" <*> arg "port" "Port to listen on") ``` ``` haskell λ> describe server [] And (And (And (Unit (Constant "start")) (Unit (AnyString "SERVER_NAME"))) (Unit (Flag "dev" "Enable dev mode?"))) (Unit (Arg "port" "Port to listen on")) λ> consume server ["start","any","--port","1234","--dev"] Succeeded ((),"any",True,"1234") λ> consume server ["start","any","--port","1234"] Succeeded ((),"any",False,"1234") λ> ``` ``` haskell λ> textDescription (describe server []) "start SERVER_NAME [--dev] --port <...>" ``` ## Self-documenting JSON parser See `Descriptive.JSON`. ``` haskell -- | Submit a URL to reddit. data Submission = Submission {submissionToken :: !Integer ,submissionTitle :: !Text ,submissionComment :: !Text ,submissionSubreddit :: !Integer} deriving (Show) submission :: Monad m => Consumer Value Doc m Submission submission = 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 = toJSON (object ["token" .= 123 ,"title" .= "Some title" ,"comment" .= "This is good" ,"subreddit" .= 234214]) badsample :: Value badsample = toJSON (object ["token" .= 123 ,"title" .= "Some title" ,"comment" .= 123 ,"subreddit" .= 234214]) ``` ``` haskell λ> describe submission (toJSON ()) 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 Succeeded (Submission {submissionToken = 123 ,submissionTitle = "Some title" ,submissionComment = "This is good" ,submissionSubreddit = 234214}) λ> consume submission badsample Failed (Wrap (Object "Submission") (Wrap (Key "comment") (Unit (Text "Submission comment")))) ``` The bad sample yields an informative message that: * The error is in the Submission object. * The key "comment". * The type of that key should be a String and it should be a Submission comment (or whatever invariants you'd like to mention). ## Parsing Attempto Controlled English for MUD commands TBA. Will use [this package](http://chrisdone.com/posts/attempto-controlled-english). With ACE you can parse into: ``` haskell parsed complV " a a " == Succeeded (ComplVDisV (DistransitiveV "") (ComplNP (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing))) (ComplPP (PP (Preposition "") (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing))))) ``` Which I can then further parse with `descriptive` to yield descriptions like: [ ..] Or similar. Which would be handy for a MUD so that a user can write: > Put the sword on the table. ## Producing questions and consuming the answers in Haskell TBA. Will be a generalization of [this type](https://github.com/chrisdone/exercise/blob/master/src/Exercise/Types.hs#L20). It is a library which I am working on in parallel which will ask the user questions and then validate the answers. Current output is like this: ``` haskell λ> describe (greaterThan 4 (integerExpr (parse id expr exercise))) an integer greater than 4 λ> eval (greaterThan 4 (integerExpr (parse id expr exercise))) $(someHaskell "x = 1") Left expected an expression, but got a declaration λ> eval (greaterThan 4 (integerExpr (parse id expr exercise))) $(someHaskell "x") Left expected an integer, but got an expression λ> eval (greaterThan 4 (integerExpr (parse id expr exercise))) $(someHaskell "3") Left expected an integer greater than 4 λ> eval (greaterThan 4 (integerExpr (parse id expr exercise))) $(someHaskell "5") Right 5 ``` This is also couples description with validation, but I will probably rewrite it with this `descriptive` library. descriptive-0.9.4/descriptive.cabal0000644000000000000000000000303112543735526015551 0ustar0000000000000000name: descriptive version: 0.9.4 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 homepage: https://github.com/chrisdone/descriptive license: BSD3 license-file: LICENSE author: Chris Done maintainer: chrisdone@gmail.com copyright: 2015 Chris Done category: Parsing build-type: Simple cabal-version: >=1.8 extra-source-files: README.md, CHANGELOG library hs-source-dirs: src/ ghc-options: -Wall -O2 exposed-modules: Descriptive Descriptive.Char Descriptive.Form Descriptive.Formlet Descriptive.Options Descriptive.JSON other-modules: Descriptive.Internal build-depends: aeson >= 0.7.0.5 , base >= 4.4 && <5 , bifunctors , containers >= 0.5 , mtl , scientific >= 0.3.2 , text , transformers , vector test-suite test type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: src/test build-depends: base, descriptive, transformers, containers, text, mtl, aeson, bifunctors, HUnit, hspec descriptive-0.9.4/CHANGELOG0000644000000000000000000000061512543735526013463 0ustar00000000000000000.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. 0.2.0: * Change the type of flag. * Add the switch combinator (used to be “flag”). * Add the “stop” combinator. 0.1.1: * Printer fix for options consumer. 0.1.0: * Change to Result type which supports Continued constructor. descriptive-0.9.4/LICENSE0000644000000000000000000000272312543735526013260 0ustar0000000000000000Copyright (c) 2015, descriptive All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * 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. * Neither the name of descriptive 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 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. descriptive-0.9.4/src/0000755000000000000000000000000012543735526013036 5ustar0000000000000000descriptive-0.9.4/src/Descriptive.hs0000644000000000000000000002161712543735526015662 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | Descriptive parsers. module Descriptive (-- * Consuming and describing consume ,describe -- * Lower-level runners ,runConsumer ,runDescription -- * Types ,Description(..) ,Bound(..) ,Consumer(..) ,Result(..) -- * Combinators ,consumer ,wrap) where import Control.Applicative import Control.Monad.Identity import Control.Monad.State.Strict import Data.Bifunctor import Data.Monoid -------------------------------------------------------------------------------- -- Running -- | Run a consumer. consume :: Consumer s d Identity a -- ^ The consumer to run. -> s -- ^ Initial state. -> Result (Description d) a consume c s = evalState (runConsumer c) s -- | Describe a consumer. describe :: Consumer s d Identity a -- ^ The consumer to run. -> s -- ^ Initial state. Can be \"empty\" if you don't use it for -- generating descriptions. -> Description d -- ^ A description and resultant state. describe c s = evalState (runDescription c) s -- | Run a consumer. runConsumer :: Monad m => Consumer s d m a -- ^ The consumer to run. -> StateT s m (Result (Description d) a) runConsumer (Consumer _ m) = m -- | Describe a consumer. runDescription :: Monad m => Consumer s d m a -- ^ The consumer to run. -> StateT s m (Description d) -- ^ A description and resultant state. runDescription (Consumer desc _) = desc -------------------------------------------------------------------------------- -- Types -- | Description of a consumable thing. data Description a = Unit !a | Bounded !Integer !Bound !(Description a) | And !(Description a) !(Description a) | Or !(Description a) !(Description a) | Sequence ![Description a] | Wrap a !(Description a) | None deriving (Show,Eq,Functor) instance Monoid (Description d) where mempty = None mappend None x = x mappend x None = x mappend x y = And x y -- | The bounds of a many-consumable thing. data Bound = NaturalBound !Integer | UnlimitedBound deriving (Show,Eq) -- | A consumer. data Consumer s d m a = Consumer {consumerDesc :: StateT s m (Description d) ,consumerParse :: StateT s m (Result (Description d) a)} -- | Some result. data Result e a = Failed e -- ^ The whole process failed. | Succeeded a -- ^ The whole process succeeded. | Continued e -- ^ There were errors but we continued to collect all the errors. deriving (Show,Eq,Ord) instance Bifunctor Result where second f r = case r of Succeeded a -> Succeeded (f a) Failed e -> Failed e Continued e -> Continued e first f r = case r of Succeeded a -> Succeeded a Failed e -> Failed (f e) Continued e -> Continued (f e) instance Monad m => Functor (Consumer s d m) where fmap f (Consumer d p) = Consumer d (do r <- p case r of (Failed e) -> return (Failed e) (Continued e) -> return (Continued e) (Succeeded a) -> return (Succeeded (f a))) instance Monad m => Applicative (Consumer s d m) where pure a = consumer (return mempty) (return (Succeeded a)) Consumer d pf <*> Consumer d' p' = consumer (do e <- d e' <- d' return (e <> e')) (do mf <- pf s <- get ma <- p' case mf of Failed e -> do put s return (Failed e) Continued e -> case ma of Failed e' -> return (Failed e') Continued e' -> return (Continued (e <> e')) Succeeded{} -> return (Continued e) Succeeded f -> case ma of Continued e -> return (Continued e) Failed e -> return (Failed e) Succeeded a -> return (Succeeded (f a))) instance Monad m => Alternative (Consumer s d m) where empty = consumer (return mempty) (return (Failed mempty)) Consumer d p <|> Consumer d' p' = consumer (do d1 <- d d2 <- d' return (disjunct d1 d2)) (do s <- get r <- p case r of Continued e1 -> do r' <- p' case r' of Failed e2 -> return (Failed e2) Continued e2 -> return (Continued (disjunct e1 e2)) Succeeded a' -> return (Succeeded a') Failed e1 -> do put s r' <- p' case r' of Failed 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 -- | An internal sequence maker which describes itself better than -- regular Alternative, and is strict, not lazy. sequenceHelper :: Monad m => Integer -> Consumer t d m a -> Consumer t d m [a] sequenceHelper minb = wrap (liftM redescribe) (\_ p -> fix (\go !i as -> do s <- get r <- p case r of Succeeded a -> go (i + 1) (a : as) Continued e -> fix (\continue e' -> do s' <- get r' <- p case r' of Continued e'' -> continue (e' <> e'') Succeeded{} -> continue e' Failed e'' | i >= minb -> do put s' return (Continued e') | otherwise -> return (Failed (redescribe e''))) e Failed e | i >= minb -> do put s return (Succeeded (reverse as)) | otherwise -> return (Failed (redescribe e))) 0 []) where redescribe = Bounded minb UnlimitedBound instance (Monoid a) => Monoid (Result (Description d) a) where mempty = Succeeded mempty mappend x y = case x of Failed e -> Failed e Continued e -> case y of Failed e' -> Failed e' Continued e' -> Continued (e <> e') Succeeded _ -> Continued e Succeeded a -> case y of Failed e -> Failed e Continued e -> Continued e Succeeded b -> Succeeded (a <> b) instance (Monoid a, Monad m) => Monoid (Consumer s d m a) where mempty = consumer (return mempty) (return mempty) mappend = liftA2 (<>) -------------------------------------------------------------------------------- -- Combinators -- | Make a self-describing consumer. consumer :: (StateT s m (Description d)) -- ^ Produce description based on the state. -> (StateT s m (Result (Description d) a)) -- ^ Parse the state and maybe transform it if desired. -> Consumer s d m a consumer d p = Consumer d p -- | Wrap a consumer with another consumer. The type looks more -- intimidating than it actually is. The source code is trivial. It -- simply allows for a way to transform the type of the state. wrap :: (StateT t m (Description d) -> StateT s m (Description d)) -- ^ Transform the description. -> (StateT t m (Description d) -> StateT t m (Result (Description d) a) -> StateT s m (Result (Description d) b)) -- ^ Transform the parser. Can re-run the parser as many times as desired. -> Consumer t d m a -> Consumer s d m b wrap redescribe reparse (Consumer d p) = Consumer (redescribe d) (reparse d p) descriptive-0.9.4/src/Descriptive/0000755000000000000000000000000012543735526015317 5ustar0000000000000000descriptive-0.9.4/src/Descriptive/Formlet.hs0000644000000000000000000000247012543735526017266 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} -- | Validating indexed formlet with auto-generated input names. module Descriptive.Formlet (-- * Combinators indexed ,FormletState(..) -- * Description ,Formlet(..)) where import Descriptive import Control.Monad.State.Strict import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Text (Text) -- | Description of a formlet. data Formlet = Index !Integer | Constrained !Text deriving (Show,Eq) -- | State used when running a formlet. data FormletState = FormletState {formletMap :: (Map Integer Text) ,formletIndex :: !Integer} deriving (Show,Eq) -- | Consume any character. indexed :: Monad m => Consumer FormletState Formlet m Text indexed = consumer (do i <- nextIndex return (d i)) (do i <- nextIndex s <- get return (case M.lookup i (formletMap s) of Nothing -> Failed (d i) Just a -> Succeeded a)) where d = Unit . Index nextIndex :: MonadState FormletState m => m Integer nextIndex = do i <- gets formletIndex modify (\s -> s {formletIndex = formletIndex s + 1}) return i descriptive-0.9.4/src/Descriptive/Char.hs0000644000000000000000000000264012543735526016532 0ustar0000000000000000{-# LANGUAGE TupleSections #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} -- | Consuming form a list of characters. module Descriptive.Char where import Data.Traversable import Descriptive import Control.Monad.State.Strict import Data.Text (Text) import qualified Data.Text as T -- | Consume any character. anyChar :: Monad m => Consumer [Char] Text m Char anyChar = consumer (return d) (do s <- get case s of (c':cs') -> do put cs' return (Succeeded c') [] -> return (Failed d)) where d = Unit "a character" -- | A character consumer. char :: Monad m => Char -> Consumer [Char] Text m Char char c = wrap (liftM (const d)) (\_ p -> do r <- p return (case r of (Failed e) -> Failed e (Continued e) -> Continued e (Succeeded c') | c' == c -> Succeeded c | otherwise -> Failed d)) anyChar where d = Unit (T.singleton c) -- | A string consumer. string :: Monad m => [Char] -> Consumer [Char] Text m [Char] string = wrap (liftM (Sequence . flattenAnds)) (\_ p -> p) . sequenceA . map char where flattenAnds (And x y) = flattenAnds x ++ flattenAnds y flattenAnds x = [x] descriptive-0.9.4/src/Descriptive/Internal.hs0000644000000000000000000000061112543735526017425 0ustar0000000000000000-- | Internal functions not necessary to be exported. module Descriptive.Internal where import Control.Monad.State.Strict -- | Run a different state in this state monad. runSubStateT :: Monad m => (s -> s') -> (s' -> s) -> StateT s' m a -> StateT s m a runSubStateT to from m = StateT (\s -> liftM (\(a,s') -> (a,from s')) (runStateT m (to s))) descriptive-0.9.4/src/Descriptive/Form.hs0000644000000000000000000000344712543735526016566 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleContexts #-} -- | Validating form with named inputs. module Descriptive.Form (-- * Combinators input ,validate -- * Description ,Form (..) ) where import Descriptive import Control.Monad.State.Strict import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Text (Text) -- | Form descriptor. data Form d = Input !Text | Constraint !d deriving (Show,Eq) -- | Consume any input value. input :: Monad m => Text -> Consumer (Map Text Text) (Form d) m Text input name = consumer (return d) (do s <- get return (case M.lookup name s of Nothing -> Continued d Just a -> Succeeded a)) where d = Unit (Input name) -- | Validate a form input with a description of what's required. validate :: Monad m => d -- ^ Description of what it expects. -> (a -> StateT s m (Maybe b)) -- ^ Attempt to parse the value. -> Consumer s (Form d) m a -- ^ Consumer to add validation to. -> Consumer s (Form 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 (Constraint d') descriptive-0.9.4/src/Descriptive/JSON.hs0000644000000000000000000002126712543735526016434 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} -- | A JSON API which describes itself. module Descriptive.JSON (-- * Consumers parse ,object ,key ,keyMaybe ,array ,string ,integer ,double ,bool ,null -- * Annotations ,label -- * Description ,Doc(..) ) where import Descriptive import Descriptive.Internal import Control.Monad.State.Strict import Data.Scientific 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 a = Integer !Text | Double !Text | Text !Text | Boolean !Text | Null !Text | Object !Text | Key !Text | Array !Text | Label !a deriving (Eq,Show,Typeable,Data) -- | Consume an object. object :: Monad m => Text -- ^ Description of what the object is. -> Consumer Object (Doc d) m a -- ^ An object consumer. -> Consumer Value (Doc d) m a object desc = wrap (\d -> do s <- get runSubStateT (const mempty) (const s) (liftM (Wrap doc) d)) (\_ p -> do v <- get case fromJSON v of Error{} -> return (Continued (Unit doc)) Success (o :: Object) -> do s <- get runSubStateT (const o) (const s) (do r <- p case r of Failed e -> return (Continued (Wrap doc e)) Continued e -> return (Continued (Wrap doc e)) Succeeded a -> return (Succeeded a))) where doc = Object desc -- | Consume from object at the given key. key :: Monad m => Text -- ^ The key to lookup. -> Consumer Value (Doc d) m a -- ^ A value consumer of the object at the key. -> Consumer Object (Doc d) m a key k = wrap (\d -> do s <- get runSubStateT toJSON (const s) (liftM (Wrap doc) d)) (\_ p -> do s <- get case parseMaybe (const (s .: k)) () of Nothing -> return (Continued (Unit doc)) Just (v :: Value) -> do r <- runSubStateT (const v) (const s) p return (bimap (Wrap doc) id r)) where doc = Key k -- | Optionally consume from object at the given key, only if it -- exists. keyMaybe :: Monad m => Text -- ^ The key to lookup. -> Consumer Value (Doc d) m a -- ^ A value consumer of the object at the key. -> Consumer Object (Doc d) m (Maybe a) keyMaybe k = wrap (\d -> do s <- get runSubStateT toJSON (const s) (liftM (Wrap doc) d)) (\_ p -> do s <- get case parseMaybe (const (s .: k)) () of Nothing -> return (Succeeded Nothing) Just (v :: Value) -> do r <- runSubStateT (const v) (const s) p return (bimap (Wrap doc) Just r)) where doc = Key k -- | Consume an array. array :: Monad m => Text -- ^ Description of this array. -> Consumer Value (Doc d) m a -- ^ Consumer for each element in the array. -> Consumer Value (Doc d) m (Vector a) array desc = wrap (\d -> liftM (Wrap doc) d) (\_ p -> do s <- get case fromJSON s of Error{} -> return (Continued (Unit doc)) Success (o :: Vector Value) -> fix (\loop i acc -> if i < V.length o then do r <- runSubStateT (const (o ! i)) (const s) p case r of Failed e -> return (Continued (Wrap doc e)) Continued e -> return (Continued (Wrap doc e)) Succeeded a -> loop (i + 1) (a : acc) else return (Succeeded (V.fromList (reverse acc)))) 0 []) where doc = Array desc -- | Consume a string. string :: Monad m => Text -- ^ Description of what the string is for. -> Consumer Value (Doc d) m Text string doc = consumer (return d) (do s <- get case fromJSON s of Error{} -> return (Continued d) Success a -> return (Succeeded a)) where d = Unit (Text doc) -- | Consume an integer. integer :: Monad m => Text -- ^ Description of what the integer is for. -> Consumer Value (Doc d) m Integer integer doc = consumer (return d) (do s <- get case s of Number a | Right i <- floatingOrInteger a -> return (Succeeded i) _ -> return (Continued d)) where d = Unit (Integer doc) -- | Consume an double. double :: Monad m => Text -- ^ Description of what the double is for. -> Consumer Value (Doc d) m Double double doc = consumer (return d) (do s <- get case s of Number a -> return (Succeeded (toRealFloat a)) _ -> return (Continued d)) where d = Unit (Double doc) -- | Parse a boolean. bool :: Monad m => Text -- ^ Description of what the bool is for. -> Consumer Value (Doc d) m Bool bool doc = consumer (return d) (do s <- get case fromJSON s of Error{} -> return (Continued d) Success a -> return (Succeeded a)) where d = Unit (Boolean doc) -- | Expect null. null :: Monad m => Text -- ^ What the null is for. -> Consumer Value (Doc d) m () null doc = consumer (return d) (do s <- get case fromJSON s of Success Aeson.Null -> return (Succeeded ()) _ -> return (Continued d)) where d = Unit (Null doc) -- | Wrap a consumer with a label e.g. a type tag. label :: Monad m => d -- ^ Some label. -> Consumer s (Doc d) m a -- ^ A value consumer. -> Consumer s (Doc d) m a label desc = wrap (liftM (Wrap doc)) (\_ p -> 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 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' descriptive-0.9.4/src/Descriptive/Options.hs0000644000000000000000000001524112543735526017311 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} -- | Command-line options parser. module Descriptive.Options (-- * Existence flags flag ,switch -- * Text input arguments ,prefix ,arg -- * Token consumers -- $tokens ,anyString ,constant -- * Special control ,stop -- * Description ,Option(..) ,textDescription ,textOpt) where import Descriptive import Control.Applicative import Control.Monad.State.Strict import Data.Char import Data.List import Data.Monoid import Data.Text (Text) import qualified Data.Text as T -- | Description of a commandline option. data Option a = AnyString !Text | Constant !Text !Text | Flag !Text !Text | Arg !Text !Text | Prefix !Text !Text | Stops | Stopped !a deriving (Show,Eq) -- | If the consumer succeeds, stops the whole parser and returns -- 'Stopped' immediately. stop :: Monad m => Consumer [Text] (Option a) m a -- ^ A parser which, when it succeeds, causes the whole parser to stop. -> Consumer [Text] (Option a) m () stop = wrap (liftM (Wrap Stops)) (\d p -> do r <- p s <- get case r of (Failed _) -> return (Succeeded ()) (Continued e) -> return (Continued e) (Succeeded a) -> do doc <- withStateT (const s) d return (Failed (Wrap (Stopped a) doc))) -- | Consume one argument from the argument list and pops it from the -- start of the list. anyString :: Monad m => Text -- Help for the string. -> Consumer [Text] (Option a) m Text anyString help = consumer (return d) (do s <- get case s of [] -> return (Failed d) (x:s') -> do put s' return (Succeeded x)) where d = Unit (AnyString help) -- | Consume one argument from the argument list which must match the -- given string, and also pops it off the argument list. constant :: Monad m => Text -- ^ String. -> Text -- ^ Description. -> v -> Consumer [Text] (Option a) m v constant x' desc v = consumer (return d) (do s <- get case s of (x:s') | x == x' -> do put s' return (Succeeded v) _ -> return (Failed d)) where d = Unit (Constant x' desc) -- | Find a value flag which must succeed. Removes it from the -- argument list if it succeeds. flag :: Monad m => Text -- ^ Name. -> Text -- ^ Description. -> v -- ^ Value returned when present. -> Consumer [Text] (Option a) m v flag name help v = consumer (return d) (do s <- get if elem ("--" <> name) s then do put (filter (/= "--" <> name) s) return (Succeeded v) else return (Failed d)) where d = Unit (Flag name help) -- | Find a boolean flag. Always succeeds. Omission counts as -- 'False'. Removes it from the argument list if it returns True. switch :: Monad m => Text -- ^ Name. -> Text -- ^ Description. -> Consumer [Text] (Option a) m Bool switch name help = flag name help True <|> pure False -- | Find an argument prefixed by -X. Removes it from the argument -- list when it succeeds. prefix :: Monad m => Text -- ^ Prefix string. -> Text -- ^ Description. -> Consumer [Text] (Option a) m Text prefix pref help = consumer (return d) (do s <- get case find (T.isPrefixOf ("-" <> pref)) s of Nothing -> return (Failed d) Just a -> do put (delete a s) return (Succeeded (T.drop (T.length pref + 1) a))) where d = Unit (Prefix pref help) -- | Find a named argument e.g. @--name value@. Removes it from the -- argument list when it succeeds. arg :: Monad m => Text -- ^ Name. -> Text -- ^ Description. -> Consumer [Text] (Option a) m Text arg name help = consumer (return d) (do s <- get let indexedArgs = zip [0 :: Integer ..] s case find ((== "--" <> name) . snd) indexedArgs of Nothing -> return (Failed d) Just (i,_) -> case lookup (i + 1) indexedArgs of Nothing -> return (Failed d) Just text -> do put (map snd (filter (\(j,_) -> j /= i && j /= i + 1) indexedArgs)) return (Succeeded text)) where d = Unit (Arg name help) -- | Make a text description of the command line options. textDescription :: Description (Option a) -> Text textDescription = go False . clean where go inor d = case d of Or None a -> "[" <> go inor a <> "]" Or a None -> "[" <> go inor a <> "]" Unit o -> textOpt o Bounded min' _ d' -> "[" <> go inor d' <> "]" <> if min' == 0 then "*" else "+" And a b -> go inor a <> " " <> go inor b Or a b -> (if inor then "" else "(") <> go True a <> "|" <> go True b <> (if inor then "" else ")") Sequence xs -> T.intercalate " " (map (go inor) xs) Wrap o d' -> textOpt o <> (if T.null (textOpt o) then "" else " ") <> go inor d' None -> "" -- | Clean up the condition tree for single-line presentation. clean :: Description a -> Description a clean (And None a) = clean a clean (And a None) = clean a clean (Or a (Or b None)) = Or (clean a) (clean b) clean (Or a (Or None b)) = Or (clean a) (clean b) clean (Or None (Or a b)) = Or (clean a) (clean b) clean (Or (Or a b) None) = Or (clean a) (clean b) clean (Or a None) = Or (clean a) None clean (Or None b) = Or None (clean b) clean (And a b) = And (clean a) (clean b) clean (Or a b) = Or (clean a) (clean b) clean a = a -- | Make a text description of an option. textOpt :: (Option a) -> Text textOpt (AnyString t) = T.map toUpper t textOpt (Constant t _) = t textOpt (Flag t _) = "--" <> t textOpt (Arg t _) = "--" <> t <> " <...>" textOpt (Prefix t _) = "-" <> t <> "<...>" textOpt Stops = "" textOpt (Stopped _) = "" descriptive-0.9.4/src/test/0000755000000000000000000000000012543735526014015 5ustar0000000000000000descriptive-0.9.4/src/test/Main.hs0000644000000000000000000001757112543735526015250 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} -- | Test suite for ACE. module Main where import Control.Applicative import Data.Aeson (Value(..),toJSON,object,(.=)) import qualified Data.Map.Strict as M import Data.Monoid import Data.Text (Text) import Descriptive import qualified Descriptive.Char as Char import qualified Descriptive.Form as Form import qualified Descriptive.Formlet as Formlet import qualified Descriptive.JSON as JSON import qualified Descriptive.Options as Options import Test.Hspec (Spec,it,hspec) import qualified Test.Hspec as Hspec -- | Test suite entry point, returns exit failure if any test fails. main :: IO () main = return () {-hspec spec-} -- | Test suite. spec :: Spec spec = do Hspec.describe "Descriptive.Char" characters Hspec.describe "Descriptive.Form" form Hspec.describe "Descriptive.Formlet" formlet Hspec.describe "Descriptive.JSON" json Hspec.describe "Descriptive.Options" options -------------------------------------------------------------------------------- -- Character parsing tests characters :: Spec characters = do it "describe" (describe (many (Char.char 'k') <> Char.string "abc") mempty == And (Bounded 0 UnlimitedBound (Unit "k")) (Sequence [Unit "a",Unit "b",Unit "c",None])) it "consume" (consume (many (Char.char 'k') <> Char.string "abc") "kkkabc" == (Succeeded "kkkabc")) it "fail generic" (consume (many (Char.char 'k') <> Char.string "abc") "kkkab" == (Failed (Unit "a character"))) it "fail specific" (consume (many (Char.char 'k') <> Char.string "abc") "kkkabj" == (Failed (Unit "c"))) -------------------------------------------------------------------------------- -- Form tests form :: Spec form = do it "basic describe login" (describe ((,) <$> Form.input "username" <*> Form.input "password") mempty == (And (Unit (Form.Input "username")) (Unit (Form.Input "password")))) it "basic describe login" (consume ((,) <$> Form.input "username" <*> Form.input "password") (M.fromList [("username","chrisdone"),("password","god")]) == Succeeded ("chrisdone","god")) it "succeeding login" (consume login (M.fromList [("password2","gob"),("password","gob")]) == Succeeded "gob") it "continuing login" (consume login (M.fromList [("password2","gob"),("password","go")]) == Continued (And (Wrap (Form.Constraint "confirmed password (entered the same twice)") (And (Unit (Form.Input "password")) (Unit (Form.Input "password2")))) (Unit (Form.Input "token")))) it "succeeding disjunction" (consume login (M.fromList [("password2","gob"),("password","go"),("token","woot")]) == Succeeded "woot") where login = Form.validate "confirmed password (entered the same twice)" (\(x,y) -> return (if x == y then Just y else Nothing)) ((,) <$> Form.input "password" <*> Form.input "password2") <|> Form.input "token" -------------------------------------------------------------------------------- -- Formlet tests formlet :: Spec formlet = do it "basic formlet" (describe ((,) <$> Formlet.indexed <*> Formlet.indexed) (Formlet.FormletState mempty 0) == And (Unit (Formlet.Index 0)) (Unit (Formlet.Index 1))) it "succeeding formlet" (consume ((,) <$> Formlet.indexed <*> Formlet.indexed) (Formlet.FormletState (M.fromList [(0,"chrisdone"),(1,"god")]) 0) == Succeeded ("chrisdone","god")) it "succeeding formlet" (consume ((,) <$> Formlet.indexed <*> Formlet.indexed) (Formlet.FormletState (M.fromList [(0,"chrisdone")]) 0) == Failed (Unit (Formlet.Index 1))) -------------------------------------------------------------------------------- -- Options tests options :: Spec options = do it "describe options" (describe server [] == And (And (And (Unit (Options.Constant "start" "cmd")) (Unit (Options.AnyString "SERVER_NAME"))) (Or (Unit (Options.Flag "dev" "Enable dev mode?")) None)) (Unit (Options.Arg "port" "Port to listen on"))) it "succeeding options" (consume server ["start","any","--port","1234","--dev"] == Succeeded ((),"any",True,"1234")) it "succeeding omitting port options" (consume server ["start","any","--port","1234"] == Succeeded ((),"any",False,"1234")) it "failing options" (consume server ["start","any"] == Failed (Unit (Options.Arg "port" "Port to listen on"))) where server = ((,,,) <$> Options.constant "start" "cmd" () <*> Options.anyString "SERVER_NAME" <*> Options.switch "dev" "Enable dev mode?" <*> Options.arg "port" "Port to listen on") -------------------------------------------------------------------------------- -- JSON tests -- | Submit a URL to reddit. data Submission = Submission {submissionToken :: !Integer ,submissionTitle :: !Text ,submissionComment :: !Text ,submissionSubreddit :: !Integer} deriving (Show,Eq) submission :: Monad m => Consumer Value (JSON.Doc Text) m Submission submission = 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 = toJSON (object ["token" .= 123 ,"title" .= "Some title" ,"comment" .= "This is good" ,"subreddit" .= 234214]) badsample :: Value badsample = toJSON (object ["token" .= 123 ,"title" .= "Some title" ,"comment" .= 123 ,"subreddit" .= 234214]) json :: Spec json = do it "describe JSON" (describe submission (toJSON ()) == Wrap (JSON.Object "Submission") (And (And (And (Wrap (JSON.Key "token") (Unit (JSON.Integer "Submission token; see the API docs"))) (Wrap (JSON.Key "title") (Unit (JSON.Text "Submission title")))) (Wrap (JSON.Key "comment") (Unit (JSON.Text "Submission comment")))) (Wrap (JSON.Key "subreddit") (Unit (JSON.Integer "The ID of the subreddit"))))) it "succeeding json" (consume submission sample == Succeeded (Submission {submissionToken = 123 ,submissionTitle = "Some title" ,submissionComment = "This is good" ,submissionSubreddit = 234214})) it "failing json" (consume submission badsample == Continued (Wrap (JSON.Object "Submission") (Wrap (JSON.Key "comment") (Unit (JSON.Text "Submission comment")))))