├── .gitignore
├── CHANGELOG
├── LICENSE
├── README.md
├── Setup.hs
├── descriptive.cabal
├── src
    ├── Descriptive.hs
    ├── Descriptive
    │   ├── Char.hs
    │   ├── Form.hs
    │   ├── Formlet.hs
    │   ├── Internal.hs
    │   ├── JSON.hs
    │   └── Options.hs
    ├── Main.hs
    └── test
    │   └── Main.hs
└── stack.yaml


/.gitignore:
--------------------------------------------------------------------------------
 1 | *.o
 2 | *.hi
 3 | *~
 4 | dist/
 5 | cabal-dev/
 6 | .hsenv
 7 | TAGS
 8 | tags
 9 | *.tag
10 | .stack-work
11 | 


--------------------------------------------------------------------------------
/CHANGELOG:
--------------------------------------------------------------------------------
 1 | 0.9.0:
 2 | 	* Move 'validate' to .JSON as 'parse'.
 3 | 
 4 | 0.5.0:
 5 | 	* Changed the parser/doc type to use StateT m. So now you can use
 6 | 	monads as part of your consumers.
 7 | 
 8 | 0.2.0:
 9 | 	* Change the type of flag.
10 | 	* Add the switch combinator (used to be “flag”).
11 | 	* Add the “stop” combinator.
12 | 
13 | 0.1.1:
14 | 	* Printer fix for options consumer.
15 | 
16 | 0.1.0:
17 | 	* Change to Result type which supports Continued constructor.
18 | 


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
 1 | Copyright (c) 2015, descriptive
 2 | All rights reserved.
 3 | 
 4 | Redistribution and use in source and binary forms, with or without
 5 | modification, are permitted provided that the following conditions are met:
 6 |     * Redistributions of source code must retain the above copyright
 7 |       notice, this list of conditions and the following disclaimer.
 8 |     * Redistributions in binary form must reproduce the above copyright
 9 |       notice, this list of conditions and the following disclaimer in the
10 |       documentation and/or other materials provided with the distribution.
11 |     * Neither the name of descriptive nor the
12 |       names of its contributors may be used to endorse or promote products
13 |       derived from this software without specific prior written permission.
14 | 
15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
16 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
18 | DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> BE LIABLE FOR ANY
19 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
22 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
25 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
  1 | descriptive
  2 | =====
  3 | 
  4 | Self-describing consumers/parsers
  5 | 
  6 | [Documentation](http://chrisdone.github.io/descriptive/)
  7 | 
  8 | There are a variety of Haskell libraries which are implementable
  9 | through a common interface: self-describing parsers:
 10 | 
 11 | * A formlet is a self-describing parser.
 12 | * A regular old text parser can be self-describing.
 13 | * A command-line options parser is a self-describing parser.
 14 | * A MUD command set is a self-describing parser.
 15 | * A JSON API can be a self-describing parser.
 16 | 
 17 | Consumption is done in this data type:
 18 | 
 19 | ``` haskell
 20 | data Consumer s d m a
 21 | ```
 22 | 
 23 | ### Making descriptive consumers
 24 | 
 25 | To make a consumer, this combinator is used:
 26 | 
 27 | ``` haskell
 28 | consumer :: (StateT s m (Description d))
 29 |          -- ^ Produce description based on the state.
 30 |          -> (StateT s m (Result (Description d) a))
 31 |          -- ^ Parse the state and maybe transform it if desired.
 32 |          -> Consumer s d m a
 33 | ```
 34 | 
 35 | The first argument generates a description based on some state. The
 36 | state is determined by whatever use-case you have. The second argument
 37 | parses from the state, which could be a stream of bytes, a list of
 38 | strings, a Map, a Vector, etc. You may or may not decide to modify the
 39 | state during generation of the description and during parsing.
 40 | 
 41 | ### Running descriptive consumers
 42 | 
 43 | To use a consumer or describe what it does, these are used:
 44 | 
 45 | ``` haskell
 46 | consume :: Consumer s d Identity a -- ^ The consumer to run.
 47 |         -> s -- ^ Initial state.
 48 |         -> Result (Description d) a
 49 | 
 50 | describe :: Consumer s d Identity a -- ^ The consumer to run.
 51 |          -> s -- ^ Initial state. Can be \"empty\" if you don't use it for
 52 |               -- generating descriptions.
 53 |          -> Description d -- ^ A description and resultant state.
 54 | ```
 55 | 
 56 | Alternatively the parser/printer can be run in a monad of your choice:
 57 | 
 58 | ``` haskell
 59 | runConsumer :: Monad m
 60 |             => Consumer s d m a -- ^ The consumer to run.
 61 |             -> StateT s m (Result (Description d) a)
 62 | 
 63 | runDescription :: Monad m
 64 |                => Consumer s d m a -- ^ The consumer to run.
 65 |                -> StateT s m (Description d) -- ^ A description and resultant state.
 66 | ```
 67 | 
 68 | ### Descriptions
 69 | 
 70 | A description is like this:
 71 | 
 72 | ``` haskell
 73 | data Description a
 74 |   = Unit !a
 75 |   | Bounded !Integer !Bound !(Description a)
 76 |   | And !(Description a) !(Description a)
 77 |   | Or !(Description a) !(Description a)
 78 |   | Sequence ![Description a]
 79 |   | Wrap a !(Description a)
 80 |   | None
 81 | ```
 82 | 
 83 | You configure the `a` for your use-case, but the rest is generatable
 84 | by the library. Afterwards, you can make your own pretty printing
 85 | function, which may be to generate an HTML form, to generate a
 86 | commandline `--help` screen, a man page, API docs for your JSON
 87 | parser, a text parsing grammar, etc. For example:
 88 | 
 89 | ``` haskell
 90 | describeParser :: Description Text -> Text
 91 | describeForm :: Description (Html ()) -> Html ()
 92 | describeArgs :: Description CmdArgs -> Text
 93 | ```
 94 | 
 95 | ### Wrapping
 96 | 
 97 | One can wrap up a consumer to alter either the description or the
 98 | parser or both, this can be used for wrapping labels, or adding
 99 | validation, things of that nature:
100 | 
101 | ``` haskell
102 | wrap :: (StateT t m (Description d) -> StateT s m (Description d))
103 |      -- ^ Transform the description.
104 |      -> (StateT t m (Description d) -> StateT t m (Result (Description d) a) -> StateT s m (Result (Description d) b))
105 |      -- ^ Transform the parser. Can re-run the parser as many times as desired.
106 |      -> Consumer t d m a
107 |      -> Consumer s d m b
108 | ```
109 | 
110 | There is also a handy function written in terms of `wrap` which will
111 | validate a consumer.
112 | 
113 | ``` haskell
114 | validate :: Monad m
115 |          => d                           -- ^ Description of what it expects.
116 |          -> (a -> StateT s m (Maybe b)) -- ^ Attempt to parse the value.
117 |          -> Consumer s d m a            -- ^ Consumer to add validation to.
118 |          -> Consumer s d m b            -- ^ A new validating consumer.
119 | ```
120 | 
121 | See below for some examples of this library.
122 | 
123 | ## Parsing characters
124 | 
125 | See `Descriptive.Char`.
126 | 
127 | ``` haskell
128 | λ> describe (many (char 'k') <> string "abc") mempty
129 | And (Bounded 0 UnlimitedBound (Unit "k"))
130 |     (Sequence [Unit "a",Unit "b",Unit "c",None])
131 | λ> consume (many (char 'k') <> string "abc") "kkkabc"
132 | (Succeeded "kkkabc")
133 | λ> consume (many (char 'k') <> string "abc") "kkkab"
134 | (Failed (Unit "a character"))
135 | λ> consume (many (char 'k') <> string "abc") "kkkabj"
136 | (Failed (Unit "c"))
137 | ```
138 | 
139 | ## Validating forms with named inputs
140 | 
141 | See `Descriptive.Form`.
142 | 
143 | ``` haskell
144 | λ> describe ((,) <$> input "username" <*> input "password") mempty
145 | And (Unit (Input "username")) (Unit (Input "password"))
146 | 
147 | λ> consume ((,) <$>
148 |             input "username" <*>
149 |             input "password")
150 |            (M.fromList [("username","chrisdone"),("password","god")])
151 | Succeeded ("chrisdone","god")
152 | ```
153 | 
154 | Conditions on two inputs:
155 | 
156 | ``` haskell
157 | login =
158 |   validate "confirmed password (entered the same twice)"
159 |            (\(x,y) ->
160 |               if x == y
161 |                  then Just y
162 |                  else Nothing)
163 |            ((,) <$>
164 |             input "password" <*>
165 |             input "password2") <|>
166 |   input "token"
167 | ```
168 | 
169 | ``` haskell
170 | λ> consume login (M.fromList [("password2","gob"),("password","gob")])
171 | Succeeded "gob"
172 | λ> consume login (M.fromList [("password2","gob"),("password","go")])
173 | Continued (And (Wrap (Constraint "confirmed password (entered the same twice)")
174 |                      (And (Unit (Input "password"))
175 |                           (Unit (Input "password2"))))
176 |                (Unit (Input "token")))
177 | λ> consume login (M.fromList [("password2","gob"),("password","go"),("token","woot")])
178 | Succeeded "woot"
179 | ```
180 | 
181 | ## Validating forms with auto-generated input indexes
182 | 
183 | See `Descriptive.Formlet`.
184 | 
185 | ``` haskell
186 | λ> describe ((,) <$> indexed <*> indexed)
187 |             (FormletState mempty 0)
188 | And (Unit (Index 0)) (Unit (Index 1))
189 | λ> consume ((,) <$> indexed <*> indexed)
190 |            (FormletState (M.fromList [(0,"chrisdone"),(1,"god")]) 0)
191 | Succeeded ("chrisdone","god")
192 | λ> consume ((,) <$> indexed <*> indexed)
193 |            (FormletState (M.fromList [(0,"chrisdone")]) 0)
194 | Failed (Unit (Index 1))
195 | ```
196 | 
197 | ## Parsing command-line options
198 | 
199 | See `Descriptive.Options`.
200 | 
201 | ``` haskell
202 | server =
203 |   ((,,,) <$>
204 |    constant "start" "cmd" () <*>
205 |    anyString "SERVER_NAME" <*>
206 |    switch "dev" "Enable dev mode?" <*>
207 |    arg "port" "Port to listen on")
208 | ```
209 | 
210 | ``` haskell
211 | λ> describe server []
212 | And (And (And (Unit (Constant "start"))
213 |                (Unit (AnyString "SERVER_NAME")))
214 |           (Unit (Flag "dev" "Enable dev mode?")))
215 |      (Unit (Arg "port" "Port to listen on"))
216 | λ> consume server ["start","any","--port","1234","--dev"]
217 | Succeeded ((),"any",True,"1234")
218 | λ> consume server ["start","any","--port","1234"]
219 | Succeeded ((),"any",False,"1234")
220 | λ>
221 | ```
222 | 
223 | ``` haskell
224 | λ> textDescription (describe server [])
225 | "start SERVER_NAME [--dev] --port <...>"
226 | ```
227 | 
228 | ## Self-documenting JSON parser
229 | 
230 | See `Descriptive.JSON`.
231 | 
232 | ``` haskell
233 | -- | Submit a URL to reddit.
234 | data Submission =
235 |   Submission {submissionToken :: !Integer
236 |              ,submissionTitle :: !Text
237 |              ,submissionComment :: !Text
238 |              ,submissionSubreddit :: !Integer}
239 |   deriving (Show)
240 | 
241 | submission :: Monad m => Consumer Value Doc m Submission
242 | submission =
243 |   object "Submission"
244 |          (Submission
245 |            <$> key "token" (integer "Submission token; see the API docs")
246 |            <*> key "title" (string "Submission title")
247 |            <*> key "comment" (string "Submission comment")
248 |            <*> key "subreddit" (integer "The ID of the subreddit"))
249 | 
250 | sample :: Value
251 | sample =
252 |   toJSON (object
253 |             ["token" .= 123
254 |             ,"title" .= "Some title"
255 |             ,"comment" .= "This is good"
256 |             ,"subreddit" .= 234214])
257 | 
258 | badsample :: Value
259 | badsample =
260 |   toJSON (object
261 |             ["token" .= 123
262 |             ,"title" .= "Some title"
263 |             ,"comment" .= 123
264 |             ,"subreddit" .= 234214])
265 | ```
266 | 
267 | ``` haskell
268 | λ> describe submission (toJSON ())
269 | Wrap (Object "Submission")
270 |      (And (And (And (Wrap (Key "token")
271 |                           (Unit (Integer "Submission token; see the API docs")))
272 |                     (Wrap (Key "title")
273 |                           (Unit (Text "Submission title"))))
274 |                (Wrap (Key "comment")
275 |                      (Unit (Text "Submission comment"))))
276 |           (Wrap (Key "subreddit")
277 |                 (Unit (Integer "The ID of the subreddit"))))
278 | 
279 | 
280 | λ> consume submission sample
281 | Succeeded (Submission {submissionToken = 123
282 |                    ,submissionTitle = "Some title"
283 |                    ,submissionComment = "This is good"
284 |                    ,submissionSubreddit = 234214})
285 | λ> consume submission badsample
286 | Failed (Wrap (Object "Submission")
287 |              (Wrap (Key "comment")
288 |                    (Unit (Text "Submission comment"))))
289 | ```
290 | 
291 | The bad sample yields an informative message that:
292 | 
293 | * The error is in the Submission object.
294 | * The key "comment".
295 | * The type of that key should be a String and it should be a
296 |   Submission comment (or whatever invariants you'd like to mention).
297 | 
298 | ## Parsing Attempto Controlled English for MUD commands
299 | 
300 | TBA. Will use
301 | [this package](http://chrisdone.com/posts/attempto-controlled-english).
302 | 
303 | With ACE you can parse into:
304 | 
305 | ``` haskell
306 | parsed complV "<distrans-verb> a <noun> <prep> a <noun>" ==
307 | Succeeded (ComplVDisV (DistransitiveV "<distrans-verb>")
308 |                   (ComplNP (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing)))
309 |                   (ComplPP (PP (Preposition "<prep>")
310 |                                (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing)))))
311 | ```
312 | 
313 | Which I can then further parse with `descriptive` to yield
314 | descriptions like:
315 | 
316 |     <verb-phrase> [<noun-phrase> ..]
317 | 
318 | Or similar. Which would be handy for a MUD so that a user can write:
319 | 
320 | > Put the sword on the table.
321 | 
322 | ## Producing questions and consuming the answers in Haskell
323 | 
324 | TBA. Will be a generalization of
325 | [this type](https://github.com/chrisdone/exercise/blob/master/src/Exercise/Types.hs#L20).
326 | 
327 | It is a library which I am working on in parallel which will ask the
328 | user questions and then validate the answers. Current output is like
329 | this:
330 | 
331 | ``` haskell
332 | λ> describe (greaterThan 4 (integerExpr (parse id expr exercise)))
333 | an integer greater than 4
334 | λ> eval (greaterThan 4 (integerExpr (parse id expr exercise))) $(someHaskell "x = 1")
335 | Left expected an expression, but got a declaration
336 | λ> eval (greaterThan 4 (integerExpr (parse id expr exercise))) $(someHaskell "x")
337 | Left expected an integer, but got an expression
338 | λ> eval (greaterThan 4 (integerExpr (parse id expr exercise))) $(someHaskell "3")
339 | Left expected an integer greater than 4
340 | λ> eval (greaterThan 4 (integerExpr (parse id expr exercise))) $(someHaskell "5")
341 | Right 5
342 | ```
343 | 
344 | This is also couples description with validation, but I will probably
345 | rewrite it with this `descriptive` library.
346 | 


--------------------------------------------------------------------------------
/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 | 


--------------------------------------------------------------------------------
/descriptive.cabal:
--------------------------------------------------------------------------------
 1 | name:                descriptive
 2 | version:             0.9.5
 3 | synopsis:            Self-describing consumers/parsers; forms, cmd-line args, JSON, etc.
 4 | description:         Self-describing consumers/parsers. See the README.md for more information. It is currently EXPERIMENTAL.
 5 | stability:           Experimental
 6 | homepage:            https://github.com/chrisdone/descriptive
 7 | license:             BSD3
 8 | license-file:        LICENSE
 9 | author:              Chris Done
10 | maintainer:          chrisdone@gmail.com
11 | copyright:           2015 Chris Done
12 | category:            Parsing
13 | build-type:          Simple
14 | cabal-version:       >=1.8
15 | extra-source-files:  README.md, CHANGELOG
16 | 
17 | library
18 |   hs-source-dirs:    src/
19 |   ghc-options:       -Wall -O2
20 |   exposed-modules:   Descriptive
21 |                      Descriptive.Char
22 |                      Descriptive.Form
23 |                      Descriptive.Formlet
24 |                      Descriptive.Options
25 |                      Descriptive.JSON
26 |   other-modules:     Descriptive.Internal
27 |   build-depends:     aeson >= 0.7.0.5
28 |                    , base >= 4.4 && <5
29 |                    , bifunctors
30 |                    , containers >= 0.5
31 |                    , mtl
32 |                    , scientific >= 0.3.2
33 |                    , text
34 |                    , transformers
35 |                    , vector
36 |   if impl(ghc < 8.0.1)
37 |     build-depends: semigroups
38 | 
39 | test-suite test
40 |     type: exitcode-stdio-1.0
41 |     main-is: Main.hs
42 |     hs-source-dirs: src/test
43 |     build-depends: base,
44 |                    descriptive, transformers, containers, text, mtl, aeson, bifunctors,
45 |                    HUnit,
46 |                    hspec
47 | 


--------------------------------------------------------------------------------
/src/Descriptive.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE DeriveFunctor #-}
  2 | {-# LANGUAGE RankNTypes #-}
  3 | {-# LANGUAGE BangPatterns #-}
  4 | {-# LANGUAGE KindSignatures #-}
  5 | {-# LANGUAGE QuasiQuotes #-}
  6 | {-# LANGUAGE FlexibleContexts #-}
  7 | {-# LANGUAGE FlexibleInstances #-}
  8 | {-# LANGUAGE MultiParamTypeClasses #-}
  9 | {-# LANGUAGE CPP #-}
 10 | 
 11 | -- | Descriptive parsers.
 12 | 
 13 | module Descriptive
 14 |   (-- * Consuming and describing
 15 |    consume
 16 |   ,describe
 17 |    -- * Lower-level runners
 18 |   ,runConsumer
 19 |   ,runDescription
 20 |   -- * Types
 21 |   ,Description(..)
 22 |   ,Bound(..)
 23 |   ,Consumer(..)
 24 |   ,Result(..)
 25 |   -- * Combinators
 26 |   ,consumer
 27 |   ,wrap)
 28 |   where
 29 | 
 30 | import Control.Applicative
 31 | import Control.Monad.Identity
 32 | import Control.Monad.State.Strict
 33 | import Data.Bifunctor
 34 | #if __GLASGOW_HASKELL__ < 804
 35 | import Data.Semigroup
 36 | #endif
 37 | 
 38 | --------------------------------------------------------------------------------
 39 | -- Running
 40 | 
 41 | -- | Run a consumer.
 42 | consume :: Consumer s d Identity a -- ^ The consumer to run.
 43 |         -> s -- ^ Initial state.
 44 |         -> Result (Description d) a
 45 | consume c s = evalState (runConsumer c) s
 46 | 
 47 | -- | Describe a consumer.
 48 | describe :: Consumer s d Identity a -- ^ The consumer to run.
 49 |          -> s -- ^ Initial state. Can be \"empty\" if you don't use it for
 50 |               -- generating descriptions.
 51 |          -> Description d -- ^ A description and resultant state.
 52 | describe c s = evalState (runDescription c) s
 53 | 
 54 | -- | Run a consumer.
 55 | runConsumer :: Monad m
 56 |             => Consumer s d m a -- ^ The consumer to run.
 57 |             -> StateT s m (Result (Description d) a)
 58 | runConsumer (Consumer _ m) = m
 59 | 
 60 | -- | Describe a consumer.
 61 | runDescription :: Monad m
 62 |                => Consumer s d m a -- ^ The consumer to run.
 63 |                -> StateT s m (Description d) -- ^ A description and resultant state.
 64 | runDescription (Consumer desc _) = desc
 65 | 
 66 | --------------------------------------------------------------------------------
 67 | -- Types
 68 | 
 69 | -- | Description of a consumable thing.
 70 | data Description a
 71 |   = Unit !a
 72 |   | Bounded !Integer !Bound !(Description a)
 73 |   | And !(Description a) !(Description a)
 74 |   | Or !(Description a) !(Description a)
 75 |   | Sequence ![Description a]
 76 |   | Wrap a !(Description a)
 77 |   | None
 78 |   deriving (Show,Eq,Functor)
 79 | 
 80 | instance Semigroup (Description d) where
 81 |   (<>) None x = x
 82 |   (<>) x None = x
 83 |   (<>) x y = And x y
 84 | 
 85 | instance Monoid (Description d) where
 86 |   mempty = None
 87 |   mappend = (<>)
 88 | 
 89 | -- | The bounds of a many-consumable thing.
 90 | data Bound
 91 |   = NaturalBound !Integer
 92 |   | UnlimitedBound
 93 |   deriving (Show,Eq)
 94 | 
 95 | -- | A consumer.
 96 | data Consumer s d m a =
 97 |   Consumer {consumerDesc :: StateT s m (Description d)
 98 |            ,consumerParse :: StateT s m (Result (Description d) a)}
 99 | 
100 | -- | Some result.
101 | data Result e a
102 |   = Failed e    -- ^ The whole process failed.
103 |   | Succeeded a -- ^ The whole process succeeded.
104 |   | Continued e -- ^ There were errors but we continued to collect all the errors.
105 |   deriving (Show,Eq,Ord)
106 | 
107 | instance Bifunctor Result where
108 |   second f r =
109 |     case r of
110 |       Succeeded a -> Succeeded (f a)
111 |       Failed e -> Failed e
112 |       Continued e -> Continued e
113 |   first f r =
114 |     case r of
115 |       Succeeded a -> Succeeded a
116 |       Failed e -> Failed (f e)
117 |       Continued e -> Continued (f e)
118 | 
119 | instance Monad m => Functor (Consumer s d m) where
120 |   fmap f (Consumer d p) =
121 |     Consumer d
122 |              (do r <- p
123 |                  case r of
124 |                    (Failed e) ->
125 |                      return (Failed e)
126 |                    (Continued e) ->
127 |                      return (Continued e)
128 |                    (Succeeded a) ->
129 |                      return (Succeeded (f a)))
130 | 
131 | instance Monad m => Applicative (Consumer s d m) where
132 |   pure a =
133 |     consumer (return mempty)
134 |              (return (Succeeded a))
135 |   Consumer d pf <*> Consumer d' p' =
136 |     consumer (do e <- d
137 |                  e' <- d'
138 |                  return (e <> e'))
139 |              (do mf <- pf
140 |                  s <- get
141 |                  ma <- p'
142 |                  case mf of
143 |                    Failed e ->
144 |                      do put s
145 |                         return (Failed e)
146 |                    Continued e ->
147 |                      case ma of
148 |                        Failed e' ->
149 |                          return (Failed e')
150 |                        Continued e' ->
151 |                          return (Continued (e <> e'))
152 |                        Succeeded{} ->
153 |                          return (Continued e)
154 |                    Succeeded f ->
155 |                      case ma of
156 |                        Continued e ->
157 |                          return (Continued e)
158 |                        Failed e ->
159 |                          return (Failed e)
160 |                        Succeeded a ->
161 |                          return (Succeeded (f a)))
162 | 
163 | instance Monad m => Alternative (Consumer s d m) where
164 |   empty =
165 |     consumer (return mempty)
166 |              (return (Failed mempty))
167 |   Consumer d p <|> Consumer d' p' =
168 |     consumer (do d1 <- d
169 |                  d2 <- d'
170 |                  return (disjunct d1 d2))
171 |              (do s <- get
172 |                  r <- p
173 |                  case r of
174 |                    Continued e1 ->
175 |                      do r' <- p'
176 |                         case r' of
177 |                           Failed e2 ->
178 |                             return (Failed e2)
179 |                           Continued e2 ->
180 |                             return (Continued (disjunct e1 e2))
181 |                           Succeeded a' ->
182 |                             return (Succeeded a')
183 |                    Failed e1 ->
184 |                      do put s
185 |                         r' <- p'
186 |                         case r' of
187 |                           Failed e2 ->
188 |                             return (Failed (disjunct e1 e2))
189 |                           Continued e2 ->
190 |                             return (Continued e2)
191 |                           Succeeded a2 ->
192 |                             return (Succeeded a2)
193 |                    Succeeded a1 -> return (Succeeded a1))
194 |     where disjunct None x = x
195 |           disjunct x None = x
196 |           disjunct x y = Or x y
197 |   many = sequenceHelper 0
198 |   some = sequenceHelper 1
199 | 
200 | -- | An internal sequence maker which describes itself better than
201 | -- regular Alternative, and is strict, not lazy.
202 | sequenceHelper :: Monad m => Integer -> Consumer t d m a -> Consumer t d m [a]
203 | sequenceHelper minb =
204 |   wrap (liftM redescribe)
205 |        (\_ p ->
206 |           fix (\go !i as ->
207 |                  do s <- get
208 |                     r <- p
209 |                     case r of
210 |                       Succeeded a ->
211 |                         go (i + 1)
212 |                            (a : as)
213 |                       Continued e ->
214 |                         fix (\continue e' ->
215 |                                do s' <- get
216 |                                   r' <- p
217 |                                   case r' of
218 |                                     Continued e'' ->
219 |                                       continue (e' <> e'')
220 |                                     Succeeded{} -> continue e'
221 |                                     Failed e''
222 |                                       | i >= minb ->
223 |                                         do put s'
224 |                                            return (Continued e')
225 |                                       | otherwise ->
226 |                                         return (Failed (redescribe e'')))
227 |                             e
228 |                       Failed e
229 |                         | i >= minb ->
230 |                           do put s
231 |                              return (Succeeded (reverse as))
232 |                         | otherwise ->
233 |                           return (Failed (redescribe e)))
234 |               0
235 |               [])
236 |   where redescribe = Bounded minb UnlimitedBound
237 | 
238 | instance (Semigroup a) => Semigroup (Result (Description d) a) where
239 |   x <> y =
240 |     case x of
241 |       Failed e -> Failed e
242 |       Continued e ->
243 |         case y of
244 |           Failed e' -> Failed e'
245 |           Continued e' -> Continued (e <> e')
246 |           Succeeded _ -> Continued e
247 |       Succeeded a ->
248 |         case y of
249 |           Failed e -> Failed e
250 |           Continued e -> Continued e
251 |           Succeeded b -> Succeeded (a <> b)
252 | 
253 | instance (Semigroup a, Monoid a) => Monoid (Result (Description d) a) where
254 |   mempty = Succeeded mempty
255 |   mappend = (<>)
256 | 
257 | instance (Semigroup a, Monad m) => Semigroup (Consumer s d m a) where
258 |   (<>) = liftA2 (<>)
259 | 
260 | instance (Semigroup a, Monoid a, Monad m) => Monoid (Consumer s d m a) where
261 |   mempty =
262 |     consumer (return mempty)
263 |              (return mempty)
264 |   mappend = (<>)
265 | 
266 | --------------------------------------------------------------------------------
267 | -- Combinators
268 | 
269 | -- | Make a self-describing consumer.
270 | consumer :: (StateT s m (Description d))
271 |          -- ^ Produce description based on the state.
272 |          -> (StateT s m (Result (Description d) a))
273 |          -- ^ Parse the state and maybe transform it if desired.
274 |          -> Consumer s d m a
275 | consumer d p =
276 |   Consumer d p
277 | 
278 | -- | Wrap a consumer with another consumer. The type looks more
279 | -- intimidating than it actually is. The source code is trivial. It
280 | -- simply allows for a way to transform the type of the state.
281 | wrap :: (StateT t m (Description d) -> StateT s m (Description d))
282 |      -- ^ Transform the description.
283 |      -> (StateT t m (Description d) -> StateT t m (Result (Description d) a) -> StateT s m (Result (Description d) b))
284 |      -- ^ Transform the parser. Can re-run the parser as many times as desired.
285 |      -> Consumer t d m a
286 |      -> Consumer s d m b
287 | wrap redescribe reparse (Consumer d p) =
288 |   Consumer (redescribe d)
289 |            (reparse d p)
290 | 


--------------------------------------------------------------------------------
/src/Descriptive/Char.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE TupleSections #-}
 2 | {-# LANGUAGE OverloadedStrings #-}
 3 | {-# LANGUAGE FlexibleContexts #-}
 4 | {-# LANGUAGE CPP #-}
 5 | 
 6 | -- | Consuming form a list of characters.
 7 | 
 8 | module Descriptive.Char where
 9 | 
10 | #if __GLASGOW_HASKELL__ < 802
11 | import           Data.Traversable
12 | #endif
13 | import           Descriptive
14 | 
15 | import           Control.Monad.State.Strict
16 | import           Data.Text (Text)
17 | import qualified Data.Text as T
18 | 
19 | -- | Consume any character.
20 | anyChar :: Monad m => Consumer [Char] Text m Char
21 | anyChar =
22 |   consumer (return d)
23 |            (do s <- get
24 |                case s of
25 |                  (c':cs') -> do put cs'
26 |                                 return (Succeeded c')
27 |                  [] -> return (Failed d))
28 |   where d = Unit "a character"
29 | 
30 | -- | A character consumer.
31 | char :: Monad m => Char -> Consumer [Char] Text m Char
32 | char c =
33 |   wrap (liftM (const d))
34 |        (\_ p ->
35 |           do r <- p
36 |              return (case r of
37 |                        (Failed e) -> Failed e
38 |                        (Continued e) ->
39 |                          Continued e
40 |                        (Succeeded c')
41 |                          | c' == c -> Succeeded c
42 |                          | otherwise -> Failed d))
43 |        anyChar
44 |   where d = Unit (T.singleton c)
45 | 
46 | -- | A string consumer.
47 | string :: Monad m => [Char] -> Consumer [Char] Text m [Char]
48 | string =
49 |   wrap (liftM (Sequence . flattenAnds))
50 |        (\_ p -> p) .
51 |   sequenceA . map char
52 |   where flattenAnds (And x y) = flattenAnds x ++ flattenAnds y
53 |         flattenAnds x = [x]
54 | 


--------------------------------------------------------------------------------
/src/Descriptive/Form.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE RankNTypes #-}
 2 | {-# LANGUAGE TupleSections #-}
 3 | {-# LANGUAGE FlexibleContexts #-}
 4 | 
 5 | -- | Validating form with named inputs.
 6 | 
 7 | module Descriptive.Form
 8 |   (-- * Combinators
 9 |    input
10 |   ,validate
11 |   -- * Description
12 |   ,Form (..)
13 |   )
14 |   where
15 | 
16 | import           Descriptive
17 | 
18 | import           Control.Monad.State.Strict
19 | import           Data.Map.Strict (Map)
20 | import qualified Data.Map.Strict as M
21 | import           Data.Text (Text)
22 | 
23 | -- | Form descriptor.
24 | data Form d
25 |   = Input !Text
26 |   | Constraint !d
27 |   deriving (Show,Eq)
28 | 
29 | -- | Consume any input value.
30 | input :: Monad m => Text -> Consumer (Map Text Text) (Form d) m Text
31 | input name =
32 |   consumer (return d)
33 |            (do s <- get
34 |                return (case M.lookup name s of
35 |                          Nothing -> Continued d
36 |                          Just a -> Succeeded a))
37 |   where d = Unit (Input name)
38 | 
39 | -- | Validate a form input with a description of what's required.
40 | validate :: Monad m
41 |          => d                           -- ^ Description of what it expects.
42 |          -> (a -> StateT s m (Maybe b)) -- ^ Attempt to parse the value.
43 |          -> Consumer s (Form d) m a     -- ^ Consumer to add validation to.
44 |          -> Consumer s (Form d) m b     -- ^ A new validating consumer.
45 | validate d' check =
46 |   wrap (liftM wrapper)
47 |        (\d p ->
48 |           do s <- get
49 |              r <- p
50 |              case r of
51 |                (Failed e) -> return (Failed e)
52 |                (Continued e) ->
53 |                  return (Continued (wrapper e))
54 |                (Succeeded a) ->
55 |                  do r' <- check a
56 |                     case r' of
57 |                       Nothing ->
58 |                         do doc <- withStateT (const s) d
59 |                            return (Continued (wrapper doc))
60 |                       Just a' -> return (Succeeded a'))
61 |   where wrapper = Wrap (Constraint d')
62 | 


--------------------------------------------------------------------------------
/src/Descriptive/Formlet.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE FlexibleContexts #-}
 2 | {-# LANGUAGE ViewPatterns #-}
 3 | 
 4 | -- | Validating indexed formlet with auto-generated input names.
 5 | 
 6 | module Descriptive.Formlet
 7 |   (-- * Combinators
 8 |    indexed
 9 |   ,FormletState(..)
10 |   -- * Description
11 |   ,Formlet(..))
12 |   where
13 | 
14 | import           Descriptive
15 | 
16 | import           Control.Monad.State.Strict
17 | import           Data.Map.Strict (Map)
18 | import qualified Data.Map.Strict as M
19 | import           Data.Text (Text)
20 | 
21 | -- | Description of a formlet.
22 | data Formlet
23 |   = Index !Integer
24 |   | Constrained !Text
25 |   deriving (Show,Eq)
26 | 
27 | -- | State used when running a formlet.
28 | data FormletState =
29 |   FormletState {formletMap :: (Map Integer Text)
30 |                ,formletIndex :: !Integer}
31 |   deriving (Show,Eq)
32 | 
33 | -- | Consume any character.
34 | indexed :: Monad m => Consumer FormletState Formlet m Text
35 | indexed =
36 |   consumer (do i <- nextIndex
37 |                return (d i))
38 |            (do i <- nextIndex
39 |                s <- get
40 |                return (case M.lookup i (formletMap s) of
41 |                          Nothing -> Failed (d i)
42 |                          Just a -> Succeeded a))
43 |   where d = Unit . Index
44 |         nextIndex :: MonadState FormletState m => m Integer
45 |         nextIndex =
46 |           do i <- gets formletIndex
47 |              modify (\s ->
48 |                        s {formletIndex = formletIndex s + 1})
49 |              return i
50 | 


--------------------------------------------------------------------------------
/src/Descriptive/Internal.hs:
--------------------------------------------------------------------------------
 1 | -- | Internal functions not necessary to be exported.
 2 | 
 3 | module Descriptive.Internal where
 4 | 
 5 | import Control.Monad.State.Strict
 6 | 
 7 | -- | Run a different state in this state monad.
 8 | runSubStateT :: Monad m
 9 |              => (s -> s') -> (s' -> s) -> StateT s' m a -> StateT s m a
10 | runSubStateT to from m =
11 |   StateT (\s ->
12 |             liftM (\(a,s') -> (a,from s'))
13 |                   (runStateT m (to s)))
14 | 


--------------------------------------------------------------------------------
/src/Descriptive/JSON.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE MultiParamTypeClasses #-}
  2 | {-# LANGUAGE PatternGuards #-}
  3 | {-# LANGUAGE DeriveDataTypeable #-}
  4 | {-# LANGUAGE ScopedTypeVariables #-}
  5 | {-# LANGUAGE TupleSections #-}
  6 | {-# LANGUAGE OverloadedStrings #-}
  7 | {-# LANGUAGE ExtendedDefaultRules #-}
  8 | {-# LANGUAGE FlexibleContexts #-}
  9 | {-# OPTIONS_GHC -fno-warn-type-defaults #-}
 10 | 
 11 | -- | A JSON API which describes itself.
 12 | 
 13 | module Descriptive.JSON
 14 |   (-- * Consumers
 15 |    parse
 16 |   ,object
 17 |   ,key
 18 |   ,keyMaybe
 19 |   ,array
 20 |   ,string
 21 |   ,integer
 22 |   ,double
 23 |   ,bool
 24 |   ,null
 25 |   -- * Annotations
 26 |   ,label
 27 |   -- * Description
 28 |   ,Doc(..)
 29 |   )
 30 |   where
 31 | 
 32 | import           Descriptive
 33 | import           Descriptive.Internal
 34 | 
 35 | import           Control.Monad.State.Strict
 36 | import           Data.Scientific
 37 | import           Data.Function
 38 | import           Data.Aeson hiding (Value(Object,Null,Array),object)
 39 | import           Data.Aeson.Types (Value,parseMaybe)
 40 | import qualified Data.Aeson.Types as Aeson
 41 | import           Data.Bifunctor
 42 | import           Data.Data
 43 | import           Data.Monoid
 44 | import           Data.Text (Text)
 45 | import           Data.Vector ((!))
 46 | import           Data.Vector (Vector)
 47 | import qualified Data.Vector as V
 48 | import           Prelude hiding (null)
 49 | 
 50 | -- | Description of parseable things.
 51 | data Doc a
 52 |   = Integer !Text
 53 |   | Double !Text
 54 |   | Text !Text
 55 |   | Boolean !Text
 56 |   | Null !Text
 57 |   | Object !Text
 58 |   | Key !Text
 59 |   | Array !Text
 60 |   | Label !a
 61 |   deriving (Eq,Show,Typeable,Data)
 62 | 
 63 | -- | Consume an object.
 64 | object :: Monad m
 65 |        => Text -- ^ Description of what the object is.
 66 |        -> Consumer Object (Doc d) m a -- ^ An object consumer.
 67 |        -> Consumer Value (Doc d) m a
 68 | object desc =
 69 |   wrap (\d ->
 70 |           do s <- get
 71 |              runSubStateT (const mempty)
 72 |                           (const s)
 73 |                           (liftM (Wrap doc) d))
 74 |        (\_ p ->
 75 |           do v <- get
 76 |              case fromJSON v of
 77 |                Error{} ->
 78 |                  return (Continued (Unit doc))
 79 |                Success (o :: Object) ->
 80 |                  do s <- get
 81 |                     runSubStateT
 82 |                       (const o)
 83 |                       (const s)
 84 |                       (do r <- p
 85 |                           case r of
 86 |                             Failed e ->
 87 |                               return (Continued (Wrap doc e))
 88 |                             Continued e ->
 89 |                               return (Continued (Wrap doc e))
 90 |                             Succeeded a ->
 91 |                               return (Succeeded a)))
 92 |   where doc = Object desc
 93 | 
 94 | -- | Consume from object at the given key.
 95 | key :: Monad m
 96 |     => Text -- ^ The key to lookup.
 97 |     -> Consumer Value (Doc d) m a -- ^ A value consumer of the object at the key.
 98 |     -> Consumer Object (Doc d) m a
 99 | key k =
100 |   wrap (\d ->
101 |           do s <- get
102 |              runSubStateT toJSON
103 |                           (const s)
104 |                           (liftM (Wrap doc) d))
105 |        (\_ p ->
106 |           do s <- get
107 |              case parseMaybe (const (s .: k))
108 |                              () of
109 |                Nothing ->
110 |                  return (Continued (Unit doc))
111 |                Just (v :: Value) ->
112 |                  do r <-
113 |                       runSubStateT (const v)
114 |                                    (const s)
115 |                                    p
116 |                     return (bimap (Wrap doc) id r))
117 |   where doc = Key k
118 | 
119 | -- | Optionally consume from object at the given key, only if it
120 | -- exists.
121 | keyMaybe :: Monad m
122 |          => Text -- ^ The key to lookup.
123 |          -> Consumer Value (Doc d) m a -- ^ A value consumer of the object at the key.
124 |          -> Consumer Object (Doc d) m (Maybe a)
125 | keyMaybe k =
126 |   wrap (\d ->
127 |           do s <- get
128 |              runSubStateT toJSON
129 |                           (const s)
130 |                           (liftM (Wrap doc) d))
131 |        (\_ p ->
132 |           do s <- get
133 |              case parseMaybe (const (s .: k))
134 |                              () of
135 |                Nothing ->
136 |                  return (Succeeded Nothing)
137 |                Just (v :: Value) ->
138 |                  do r <-
139 |                       runSubStateT (const v)
140 |                                    (const s)
141 |                                    p
142 |                     return (bimap (Wrap doc) Just r))
143 |   where doc = Key k
144 | 
145 | -- | Consume an array.
146 | array :: Monad m
147 |       => Text -- ^ Description of this array.
148 |       -> Consumer Value (Doc d) m a -- ^ Consumer for each element in the array.
149 |       -> Consumer Value (Doc d) m (Vector a)
150 | array desc =
151 |   wrap (\d -> liftM (Wrap doc) d)
152 |        (\_ p ->
153 |           do s <- get
154 |              case fromJSON s of
155 |                Error{} ->
156 |                  return (Continued (Unit doc))
157 |                Success (o :: Vector Value) ->
158 |                  fix (\loop i acc ->
159 |                         if i < V.length o
160 |                            then do r <-
161 |                                      runSubStateT (const (o ! i))
162 |                                                   (const s)
163 |                                                   p
164 |                                    case r of
165 |                                      Failed e ->
166 |                                        return (Continued (Wrap doc e))
167 |                                      Continued e ->
168 |                                        return (Continued (Wrap doc e))
169 |                                      Succeeded a ->
170 |                                        loop (i + 1)
171 |                                             (a : acc)
172 |                            else return (Succeeded (V.fromList (reverse acc))))
173 |                      0
174 |                      [])
175 |   where doc = Array desc
176 | 
177 | -- | Consume a string.
178 | string :: Monad m
179 |        => Text -- ^ Description of what the string is for.
180 |        -> Consumer Value (Doc d) m Text
181 | string doc =
182 |   consumer (return d)
183 |            (do s <- get
184 |                case fromJSON s of
185 |                  Error{} -> return (Continued d)
186 |                  Success a ->
187 |                    return (Succeeded a))
188 |   where d = Unit (Text doc)
189 | 
190 | -- | Consume an integer.
191 | integer :: Monad m
192 |         => Text -- ^ Description of what the integer is for.
193 |         -> Consumer Value (Doc d) m Integer
194 | integer doc =
195 |   consumer (return d)
196 |            (do s <- get
197 |                case s of
198 |                  Number a
199 |                    | Right i <- floatingOrInteger a ->
200 |                      return (Succeeded i)
201 |                  _ -> return (Continued d))
202 |   where d = Unit (Integer doc)
203 | 
204 | -- | Consume an double.
205 | double :: Monad m
206 |        => Text -- ^ Description of what the double is for.
207 |        -> Consumer Value (Doc d) m Double
208 | double doc =
209 |   consumer (return d)
210 |            (do s <- get
211 |                case s of
212 |                  Number a ->
213 |                    return (Succeeded (toRealFloat a))
214 |                  _ -> return (Continued d))
215 |   where d = Unit (Double doc)
216 | 
217 | -- | Parse a boolean.
218 | bool :: Monad m
219 |      => Text -- ^ Description of what the bool is for.
220 |      -> Consumer Value (Doc d) m Bool
221 | bool doc =
222 |   consumer (return d)
223 |            (do s <- get
224 |                case fromJSON s of
225 |                  Error{} -> return (Continued d)
226 |                  Success a ->
227 |                    return (Succeeded a))
228 |   where d = Unit (Boolean doc)
229 | 
230 | -- | Expect null.
231 | null :: Monad m
232 |      => Text -- ^ What the null is for.
233 |      -> Consumer Value (Doc d) m ()
234 | null doc =
235 |   consumer (return d)
236 |            (do s <- get
237 |                case fromJSON s of
238 |                  Success Aeson.Null ->
239 |                    return (Succeeded ())
240 |                  _ -> return (Continued d))
241 |   where d = Unit (Null doc)
242 | 
243 | -- | Wrap a consumer with a label e.g. a type tag.
244 | label :: Monad m
245 |       => d                      -- ^ Some label.
246 |       -> Consumer s (Doc d) m a -- ^ A value consumer.
247 |       -> Consumer s (Doc d) m a
248 | label desc =
249 |   wrap (liftM (Wrap doc))
250 |        (\_ p ->
251 |           do r <- p
252 |              case r of
253 |                Failed e ->
254 |                  return (Failed (Wrap doc e))
255 |                Continued e ->
256 |                  return (Continued (Wrap doc e))
257 |                k -> return k)
258 |   where doc = Label desc
259 | 
260 | -- | Parse from a consumer.
261 | parse :: Monad m
262 |       => d                           -- ^ Description of what it expects.
263 |       -> (a -> StateT s m (Maybe b)) -- ^ Attempt to parse the value.
264 |       -> Consumer s d m a            -- ^ Consumer to add validation to.
265 |       -> Consumer s d m b            -- ^ A new validating consumer.
266 | parse d' check =
267 |   wrap (liftM wrapper)
268 |        (\d p ->
269 |           do s <- get
270 |              r <- p
271 |              case r of
272 |                (Failed e) -> return (Failed e)
273 |                (Continued e) ->
274 |                  return (Continued e)
275 |                (Succeeded a) ->
276 |                  do r' <- check a
277 |                     case r' of
278 |                       Nothing ->
279 |                         do doc <- withStateT (const s) d
280 |                            return (Continued (wrapper doc))
281 |                       Just a' -> return (Succeeded a'))
282 |   where wrapper = Wrap d'
283 | 


--------------------------------------------------------------------------------
/src/Descriptive/Options.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE BangPatterns #-}
  2 | {-# LANGUAGE OverloadedStrings #-}
  3 | {-# LANGUAGE FlexibleContexts #-}
  4 | {-# LANGUAGE CPP #-}
  5 | 
  6 | -- | Command-line options parser.
  7 | 
  8 | module Descriptive.Options
  9 |   (-- * Existence flags
 10 |    flag
 11 |   ,switch
 12 |   -- * Text input arguments
 13 |   ,prefix
 14 |   ,arg
 15 |    -- * Token consumers
 16 |    -- $tokens
 17 |   ,anyString
 18 |   ,constant
 19 |   -- * Special control
 20 |   ,stop
 21 |   -- * Description
 22 |   ,Option(..)
 23 |   ,textDescription
 24 |   ,textOpt)
 25 |   where
 26 | 
 27 | import           Descriptive
 28 | 
 29 | import           Control.Applicative
 30 | import           Control.Monad.State.Strict
 31 | import           Data.Char
 32 | import           Data.List
 33 | #if __GLASGOW_HASKELL__ < 804
 34 | import           Data.Monoid
 35 | #endif
 36 | import           Data.Text (Text)
 37 | import qualified Data.Text as T
 38 | 
 39 | -- | Description of a commandline option.
 40 | data Option a
 41 |   = AnyString !Text
 42 |   | Constant !Text !Text
 43 |   | Flag !Text !Text
 44 |   | Arg !Text !Text
 45 |   | Prefix !Text !Text
 46 |   | Stops
 47 |   | Stopped !a
 48 |   deriving (Show,Eq)
 49 | 
 50 | -- | If the consumer succeeds, stops the whole parser and returns
 51 | -- 'Stopped' immediately.
 52 | stop :: Monad m
 53 |      => Consumer [Text] (Option a) m a
 54 |      -- ^ A parser which, when it succeeds, causes the whole parser to stop.
 55 |      -> Consumer [Text] (Option a) m ()
 56 | stop =
 57 |   wrap (liftM (Wrap Stops))
 58 |        (\d p ->
 59 |           do r <- p
 60 |              s <- get
 61 |              case r of
 62 |                (Failed _) ->
 63 |                  return (Succeeded ())
 64 |                (Continued e) ->
 65 |                  return (Continued e)
 66 |                (Succeeded a) ->
 67 |                  do doc <- withStateT (const s) d
 68 |                     return (Failed (Wrap (Stopped a)
 69 |                                          doc)))
 70 | 
 71 | -- | Consume one argument from the argument list and pops it from the
 72 | -- start of the list.
 73 | anyString :: Monad m
 74 |           => Text -- Help for the string.
 75 |           -> Consumer [Text] (Option a) m Text
 76 | anyString help =
 77 |   consumer (return d)
 78 |            (do s <- get
 79 |                case s of
 80 |                  [] -> return (Failed d)
 81 |                  (x:s') -> do put s'
 82 |                               return (Succeeded x))
 83 |   where d = Unit (AnyString help)
 84 | 
 85 | -- | Consume one argument from the argument list which must match the
 86 | -- given string, and also pops it off the argument list.
 87 | constant :: Monad m
 88 |          => Text -- ^ String.
 89 |          -> Text -- ^ Description.
 90 |          -> v
 91 |          -> Consumer [Text] (Option a) m v
 92 | constant x' desc v =
 93 |   consumer (return d)
 94 |            (do s <- get
 95 |                case s of
 96 |                  (x:s') | x == x' ->
 97 |                    do put s'
 98 |                       return (Succeeded v)
 99 |                  _ -> return (Failed d))
100 |   where d = Unit (Constant x' desc)
101 | 
102 | -- | Find a value flag which must succeed. Removes it from the
103 | -- argument list if it succeeds.
104 | flag :: Monad m
105 |      => Text -- ^ Name.
106 |      -> Text -- ^ Description.
107 |      -> v    -- ^ Value returned when present.
108 |      -> Consumer [Text] (Option a) m v
109 | flag name help v =
110 |   consumer (return d)
111 |            (do s <- get
112 |                if elem ("--" <> name) s
113 |                   then do put (filter (/= "--" <> name) s)
114 |                           return (Succeeded v)
115 |                   else return (Failed d))
116 |   where d = Unit (Flag name help)
117 | 
118 | -- | Find a boolean flag. Always succeeds. Omission counts as
119 | -- 'False'. Removes it from the argument list if it returns True.
120 | switch :: Monad m
121 |        => Text -- ^ Name.
122 |        -> Text -- ^ Description.
123 |        -> Consumer [Text] (Option a) m Bool
124 | switch name help =
125 |   flag name help True <|>
126 |   pure False
127 | 
128 | -- | Find an argument prefixed by -X. Removes it from the argument
129 | -- list when it succeeds.
130 | prefix :: Monad m
131 |        => Text -- ^ Prefix string.
132 |        -> Text -- ^ Description.
133 |        -> Consumer [Text] (Option a) m Text
134 | prefix pref help =
135 |   consumer (return d)
136 |            (do s <- get
137 |                case find (T.isPrefixOf ("-" <> pref)) s of
138 |                  Nothing -> return (Failed d)
139 |                  Just a -> do put (delete a s)
140 |                               return (Succeeded (T.drop (T.length pref + 1) a)))
141 |   where d = Unit (Prefix pref help)
142 | 
143 | -- | Find a named argument e.g. @--name value@. Removes it from the
144 | -- argument list when it succeeds.
145 | arg :: Monad m
146 |     => Text -- ^ Name.
147 |     -> Text -- ^ Description.
148 |     -> Consumer [Text] (Option a) m Text
149 | arg name help =
150 |   consumer (return d)
151 |            (do s <- get
152 |                let indexedArgs =
153 |                      zip [0 :: Integer ..] s
154 |                case find ((== "--" <> name) . snd) indexedArgs of
155 |                  Nothing -> return (Failed d)
156 |                  Just (i,_) ->
157 |                    case lookup (i + 1) indexedArgs of
158 |                      Nothing -> return (Failed d)
159 |                      Just text ->
160 |                        do put (map snd (filter (\(j,_) -> j /= i && j /= i + 1) indexedArgs))
161 |                           return (Succeeded text))
162 |   where d = Unit (Arg name help)
163 | 
164 | -- | Make a text description of the command line options.
165 | textDescription :: Description (Option a) -> Text
166 | textDescription =
167 |   go False .
168 |   clean
169 |   where
170 |         go inor d =
171 |           case d of
172 |             Or None a -> "[" <> go inor a <> "]"
173 |             Or a None -> "[" <> go inor a <> "]"
174 |             Unit o -> textOpt o
175 |             Bounded min' _ d' ->
176 |               "[" <>
177 |               go inor d' <>
178 |               "]" <>
179 |               if min' == 0
180 |                  then "*"
181 |                  else "+"
182 |             And a b ->
183 |               go inor a <>
184 |               " " <>
185 |               go inor b
186 |             Or a b ->
187 |               (if inor
188 |                   then ""
189 |                   else "(") <>
190 |               go True a <>
191 |               "|" <>
192 |               go True b <>
193 |               (if inor
194 |                   then ""
195 |                   else ")")
196 |             Sequence xs ->
197 |               T.intercalate " "
198 |                             (map (go inor) xs)
199 |             Wrap o d' ->
200 |               textOpt o <>
201 |               (if T.null (textOpt o)
202 |                   then ""
203 |                   else " ") <>
204 |               go inor d'
205 |             None -> ""
206 | 
207 | -- | Clean up the condition tree for single-line presentation.
208 | clean :: Description a -> Description a
209 | clean (And None a) = clean a
210 | clean (And a None) = clean a
211 | clean (Or a (Or b None)) = Or (clean a) (clean b)
212 | clean (Or a (Or None b)) = Or (clean a) (clean b)
213 | clean (Or None (Or a b)) = Or (clean a) (clean b)
214 | clean (Or (Or a b) None) = Or (clean a) (clean b)
215 | clean (Or a None) = Or (clean a) None
216 | clean (Or None b) = Or None (clean b)
217 | clean (And a b) =
218 |   And (clean a)
219 |       (clean b)
220 | clean (Or a b) =
221 |   Or (clean a)
222 |      (clean b)
223 | clean a = a
224 | 
225 | -- | Make a text description of an option.
226 | textOpt :: (Option a) -> Text
227 | textOpt (AnyString t) = T.map toUpper t
228 | textOpt (Constant t _) = t
229 | textOpt (Flag t _) = "--" <> t
230 | textOpt (Arg t _) = "--" <> t <> " <...>"
231 | textOpt (Prefix t _) = "-" <> t <> "<...>"
232 | textOpt Stops = ""
233 | textOpt (Stopped _) = ""
234 | 


--------------------------------------------------------------------------------
/src/Main.hs:
--------------------------------------------------------------------------------
 1 | -- | Main entry point to descriptive.
 2 | --
 3 | -- Self-describing consumers/parsers
 4 | 
 5 | module Main where
 6 | 
 7 | -- | Main entry point.
 8 | main :: IO ()
 9 | main = return ()
10 | 


--------------------------------------------------------------------------------
/src/test/Main.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE FlexibleContexts #-}
  2 | {-# LANGUAGE ExtendedDefaultRules #-}
  3 | {-# LANGUAGE OverloadedStrings #-}
  4 | {-# OPTIONS_GHC -fno-warn-type-defaults #-}
  5 | 
  6 | -- | Test suite for ACE.
  7 | 
  8 | module Main where
  9 | 
 10 | import           Control.Applicative
 11 | import           Data.Aeson (Value(..),toJSON,object,(.=))
 12 | import qualified Data.Map.Strict as M
 13 | import           Data.Monoid
 14 | import           Data.Text (Text)
 15 | import           Descriptive
 16 | import qualified Descriptive.Char as Char
 17 | import qualified Descriptive.Form as Form
 18 | import qualified Descriptive.Formlet as Formlet
 19 | import qualified Descriptive.JSON as JSON
 20 | import qualified Descriptive.Options as Options
 21 | import           Test.Hspec (Spec,it,hspec)
 22 | import qualified Test.Hspec as Hspec
 23 | 
 24 | -- | Test suite entry point, returns exit failure if any test fails.
 25 | main :: IO ()
 26 | main = return () {-hspec spec-}
 27 | 
 28 | -- | Test suite.
 29 | spec :: Spec
 30 | spec = do
 31 |   Hspec.describe "Descriptive.Char" characters
 32 |   Hspec.describe "Descriptive.Form" form
 33 |   Hspec.describe "Descriptive.Formlet" formlet
 34 |   Hspec.describe "Descriptive.JSON" json
 35 |   Hspec.describe "Descriptive.Options" options
 36 | 
 37 | --------------------------------------------------------------------------------
 38 | -- Character parsing tests
 39 | 
 40 | characters :: Spec
 41 | characters =
 42 |   do it "describe"
 43 |         (describe (many (Char.char 'k') <>
 44 |                    Char.string "abc")
 45 |                   mempty ==
 46 |          And (Bounded 0 UnlimitedBound (Unit "k"))
 47 |              (Sequence [Unit "a",Unit "b",Unit "c",None]))
 48 |      it "consume"
 49 |         (consume (many (Char.char 'k') <>
 50 |                   Char.string "abc")
 51 |                  "kkkabc" ==
 52 |          (Succeeded "kkkabc"))
 53 |      it "fail generic"
 54 |         (consume (many (Char.char 'k') <>
 55 |                   Char.string "abc")
 56 |                  "kkkab" ==
 57 |          (Failed (Unit "a character")))
 58 |      it "fail specific"
 59 |         (consume (many (Char.char 'k') <>
 60 |                   Char.string "abc")
 61 |                  "kkkabj" ==
 62 |          (Failed (Unit "c")))
 63 | 
 64 | --------------------------------------------------------------------------------
 65 | -- Form tests
 66 | 
 67 | form :: Spec
 68 | form =
 69 |   do it "basic describe login"
 70 |         (describe ((,) <$>
 71 |                    Form.input "username" <*>
 72 |                    Form.input "password")
 73 |                   mempty ==
 74 |          (And (Unit (Form.Input "username"))
 75 |               (Unit (Form.Input "password"))))
 76 |      it "basic describe login"
 77 |         (consume ((,) <$>
 78 |                   Form.input "username" <*>
 79 |                   Form.input "password")
 80 |                  (M.fromList [("username","chrisdone"),("password","god")]) ==
 81 |          Succeeded ("chrisdone","god"))
 82 |      it "succeeding login"
 83 |         (consume login (M.fromList [("password2","gob"),("password","gob")]) ==
 84 |          Succeeded "gob")
 85 |      it "continuing login"
 86 |         (consume login (M.fromList [("password2","gob"),("password","go")]) ==
 87 |          Continued (And (Wrap (Form.Constraint "confirmed password (entered the same twice)")
 88 |                               (And (Unit (Form.Input "password"))
 89 |                                    (Unit (Form.Input "password2"))))
 90 |                         (Unit (Form.Input "token"))))
 91 |      it "succeeding disjunction"
 92 |         (consume login
 93 |                  (M.fromList
 94 |                     [("password2","gob"),("password","go"),("token","woot")]) ==
 95 |          Succeeded "woot")
 96 |   where login =
 97 |           Form.validate
 98 |                  "confirmed password (entered the same twice)"
 99 |                  (\(x,y) ->
100 |                     return (if x == y
101 |                                then Just y
102 |                                else Nothing))
103 |                  ((,) <$>
104 |                   Form.input "password" <*>
105 |                   Form.input "password2") <|>
106 |           Form.input "token"
107 | 
108 | --------------------------------------------------------------------------------
109 | -- Formlet tests
110 | 
111 | formlet :: Spec
112 | formlet =
113 |   do it "basic formlet"
114 |         (describe ((,) <$> Formlet.indexed <*> Formlet.indexed)
115 |                   (Formlet.FormletState mempty 0) ==
116 |          And (Unit (Formlet.Index 0))
117 |              (Unit (Formlet.Index 1)))
118 |      it "succeeding formlet"
119 |         (consume ((,) <$> Formlet.indexed <*> Formlet.indexed)
120 |                  (Formlet.FormletState (M.fromList [(0,"chrisdone"),(1,"god")])
121 |                                        0) ==
122 |          Succeeded ("chrisdone","god"))
123 |      it "succeeding formlet"
124 |         (consume ((,) <$> Formlet.indexed <*> Formlet.indexed)
125 |                  (Formlet.FormletState (M.fromList [(0,"chrisdone")])
126 |                                        0) ==
127 |          Failed (Unit (Formlet.Index 1)))
128 | 
129 | --------------------------------------------------------------------------------
130 | -- Options tests
131 | 
132 | options :: Spec
133 | options =
134 |   do it "describe options"
135 |         (describe server [] ==
136 |          And (And (And (Unit (Options.Constant "start" "cmd"))
137 |                        (Unit (Options.AnyString "SERVER_NAME")))
138 |                   (Or (Unit (Options.Flag "dev" "Enable dev mode?")) None))
139 |              (Unit (Options.Arg "port" "Port to listen on")))
140 |      it "succeeding options"
141 |         (consume server ["start","any","--port","1234","--dev"] ==
142 |          Succeeded ((),"any",True,"1234"))
143 |      it "succeeding omitting port options"
144 |         (consume server ["start","any","--port","1234"] ==
145 |          Succeeded ((),"any",False,"1234"))
146 |      it "failing options"
147 |         (consume server ["start","any"] ==
148 |          Failed (Unit (Options.Arg "port" "Port to listen on")))
149 |   where server =
150 |           ((,,,) <$>
151 |            Options.constant "start" "cmd" () <*>
152 |            Options.anyString "SERVER_NAME" <*>
153 |            Options.switch "dev" "Enable dev mode?" <*>
154 |            Options.arg "port" "Port to listen on")
155 | 
156 | --------------------------------------------------------------------------------
157 | -- JSON tests
158 | 
159 | -- | Submit a URL to reddit.
160 | data Submission =
161 |   Submission {submissionToken :: !Integer
162 |              ,submissionTitle :: !Text
163 |              ,submissionComment :: !Text
164 |              ,submissionSubreddit :: !Integer}
165 |   deriving (Show,Eq)
166 | 
167 | submission :: Monad m => Consumer Value (JSON.Doc Text) m Submission
168 | submission =
169 |   JSON.object "Submission"
170 |               (Submission
171 |                 <$> JSON.key "token" (JSON.integer "Submission token; see the API docs")
172 |                 <*> JSON.key "title" (JSON.string "Submission title")
173 |                 <*> JSON.key "comment" (JSON.string "Submission comment")
174 |                 <*> JSON.key "subreddit" (JSON.integer "The ID of the subreddit"))
175 | 
176 | sample :: Value
177 | sample =
178 |   toJSON (object
179 |             ["token" .= 123
180 |             ,"title" .= "Some title"
181 |             ,"comment" .= "This is good"
182 |             ,"subreddit" .= 234214])
183 | 
184 | badsample :: Value
185 | badsample =
186 |   toJSON (object
187 |             ["token" .= 123
188 |             ,"title" .= "Some title"
189 |             ,"comment" .= 123
190 |             ,"subreddit" .= 234214])
191 | 
192 | json :: Spec
193 | json =
194 |   do it "describe JSON"
195 |         (describe submission (toJSON ()) ==
196 |          Wrap (JSON.Object "Submission")
197 |               (And (And (And (Wrap (JSON.Key "token")
198 |                                    (Unit (JSON.Integer "Submission token; see the API docs")))
199 |                              (Wrap (JSON.Key "title")
200 |                                    (Unit (JSON.Text "Submission title"))))
201 |                         (Wrap (JSON.Key "comment")
202 |                               (Unit (JSON.Text "Submission comment"))))
203 |                    (Wrap (JSON.Key "subreddit")
204 |                          (Unit (JSON.Integer "The ID of the subreddit")))))
205 |      it "succeeding json"
206 |         (consume submission sample ==
207 |          Succeeded (Submission {submissionToken = 123
208 |                                ,submissionTitle = "Some title"
209 |                                ,submissionComment = "This is good"
210 |                                ,submissionSubreddit = 234214}))
211 |      it "failing json"
212 |         (consume submission badsample ==
213 |          Continued (Wrap (JSON.Object "Submission")
214 |                          (Wrap (JSON.Key "comment")
215 |                                (Unit (JSON.Text "Submission comment")))))
216 | 


--------------------------------------------------------------------------------
/stack.yaml:
--------------------------------------------------------------------------------
1 | #resolver: nightly-2018-04-01
2 | resolver: lts-11.3
3 | packages:
4 | - .
5 | 


--------------------------------------------------------------------------------