├── .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 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 " a a " == 307 | Succeeded (ComplVDisV (DistransitiveV "") 308 | (ComplNP (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing))) 309 | (ComplPP (PP (Preposition "") 310 | (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing))))) 311 | ``` 312 | 313 | Which I can then further parse with `descriptive` to yield 314 | descriptions like: 315 | 316 | [ ..] 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 | --------------------------------------------------------------------------------