diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,3 @@ +0.1.0: + +* Change to Result type which supports Continued constructor. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -24,7 +24,7 @@ ``` haskell consumer :: (s -> (Description d,s)) - -> (s -> (Either (Description d) a,s)) + -> (s -> (Result (Description d) a,s)) -> Consumer s d a ``` @@ -37,8 +37,8 @@ To use a consumer or describe what it does, these are used: ``` haskell -consume :: Consumer s d a -> s -> (Either (Description d) a,s) -describe :: Consumer s d a -> s -> (Description d,s) +consume :: Consumer s d a -> s -> Result (Description d) a +describe :: Consumer s d a -> s -> Description d ``` A description is like this: @@ -61,9 +61,9 @@ parser, a text parsing grammar, etc. For example: ``` haskell -describeParser :: Consumer [Char] Text Demo -> Text -describeForm :: Consumer (Map Text Text) (Html ()) Login -> Html () -describeArgs :: Consumer [Text] CmdArgs MyApp -> CmdArgs +describeParser :: Description Text -> Text +describeForm :: Description (Html ()) -> Html () +describeArgs :: Description CmdArgs -> Text ``` See below for some examples of this library. @@ -78,11 +78,11 @@ (Sequence [Unit "a",Sequence [Unit "b",Sequence [Unit "c",Sequence []]]]) ,"") λ> consume (many (char 'k') <> string "abc") "kkkabc" -(Right "kkkabc","") +(Succeeded "kkkabc") λ> consume (many (char 'k') <> string "abc") "kkkab" -(Left (Unit "a character"),"") +(Failed (Unit "a character")) λ> consume (many (char 'k') <> string "abc") "kkkabj" -(Left (Unit "c"),"") +(Failed (Unit "c")) ``` ## Validating forms with named inputs @@ -97,32 +97,35 @@ input "username" <*> input "password") (M.fromList [("username","chrisdone"),("password","god")]) -(Right ("chrisdone","god") +(Succeeded ("chrisdone","god") ,fromList [("password","god"),("username","chrisdone")]) ``` Conditions on two inputs: ``` haskell -login = validate "confirmed password (entered the same twice)" - (\(x,y) -> - if x == y - then Just y - else Nothing) - ((,) <$> - input "password" <*> - input "password2") +login = + validate "confirmed password (entered the same twice)" + (\(x,y) -> + if x == y + then Just y + else Nothing) + ((,) <$> + input "password" <*> + input "password2") <|> + input "token" ``` ``` haskell -λ> describe login mempty -(Wrap (Constraint "confirmed password (entered the same twice)") - (And (Unit (Input "password")) - (Unit (Input "password2"))) -,fromList []) - λ> consume login (M.fromList [("password2","gob"),("password","gob")]) -(Right "gob",fromList [("password","gob"),("password2","gob")]) +Succeeded "gob" +λ> consume login (M.fromList [("password2","gob"),("password","go")]) +Continued (And (Wrap (Constraint "confirmed password (entered the same twice)") + (And (Unit (Input "password")) + (Unit (Input "password2")))) + (Unit (Input "token"))) +λ> consume login (M.fromList [("password2","gob"),("password","go"),("token","woot")]) +Succeeded "woot" ``` ## Validating forms with auto-generated input indexes @@ -132,22 +135,15 @@ ``` haskell λ> describe ((,) <$> indexed <*> indexed) (FormletState mempty 0) -(And (Unit (Index 0)) - (Unit (Index 1)) -,FormletState {formletMap = fromList [] +And (Unit (Index 0)) + (Unit (Index 1)) ,formletIndex = 2}) λ> consume ((,) <$> indexed <*> indexed) (FormletState (M.fromList [(0,"chrisdone"),(1,"god")]) 0) -(Right ("chrisdone","god") -,FormletState {formletMap = - fromList [(0,"chrisdone"),(1,"god")] - ,formletIndex = 2}) +Succeeded ("chrisdone","god") λ> consume ((,) <$> indexed <*> indexed) (FormletState (M.fromList [(0,"chrisdone")]) 0) -(Left (Unit (Index 1)) -,FormletState {formletMap = - fromList [(0,"chrisdone")] - ,formletIndex = 2}) +Failed (Unit (Index 1)) ``` ## Parsing command-line options @@ -165,17 +161,15 @@ ``` haskell λ> describe server [] -(And (And (And (Unit (Constant "start")) +And (And (And (Unit (Constant "start")) (Unit (AnyString "SERVER_NAME"))) (Unit (Flag "dev" "Enable dev mode?"))) (Unit (Arg "port" "Port to listen on")) -,[]) -λ> consume server ["start","any","--port","1234","-fdev"] -(Right ("start","any",True,"1234"),[]) +λ> consume server ["start","any","--port","1234","--dev"] +Succeeded ("start","any",True,"1234") λ> consume server ["start","any","--port","1234"] -(Right ("start","any",False,"1234"),[]) -λ> consume server ["start","any"] -(Left (Unit (Arg "port" "Port to listen on")),[]) +Succeeded ("start","any",False,"1234") +λ> ``` ## Self-documenting JSON parser @@ -219,7 +213,7 @@ ``` haskell λ> describe submission (toJSON ()) -(Wrap (Struct "Submission") +Wrap (Struct "Submission") (And (And (And (Wrap (Key "token") (Unit (Integer "Submission token; see the API docs"))) (Wrap (Key "title") @@ -228,26 +222,17 @@ (Unit (Text "Submission comment")))) (Wrap (Key "subreddit") (Unit (Integer "The ID of the subreddit")))) -,Array (fromList [])) + λ> consume submission sample -(Right (Submission {submissionToken = 123 +Succeeded (Submission {submissionToken = 123 ,submissionTitle = "Some title" ,submissionComment = "This is good" ,submissionSubreddit = 234214}) -,Object (fromList [("token",Number 123.0) - ,("subreddit",Number 234214.0) - ,("title",String "Some title") - ,("comment",String "This is good")])) - λ> consume submission badsample -(Left (Wrap (Struct "Submission") +Failed (Wrap (Struct "Submission") (Wrap (Key "comment") (Unit (Text "Submission comment")))) -,Object (fromList [("token",Number 123.0) - ,("subreddit",Number 234214.0) - ,("title",String "Some title") - ,("comment",Number 123.0)])) ``` The bad sample yields an informative message that: @@ -266,7 +251,7 @@ ``` haskell parsed complV " a a " == -Right (ComplVDisV (DistransitiveV "") +Succeeded (ComplVDisV (DistransitiveV "") (ComplNP (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing))) (ComplPP (PP (Preposition "") (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing))))) diff --git a/descriptive.cabal b/descriptive.cabal --- a/descriptive.cabal +++ b/descriptive.cabal @@ -1,5 +1,5 @@ name: descriptive -version: 0.0.2 +version: 0.1.0 synopsis: Self-describing consumers/parsers; forms, cmd-line args, JSON, etc. description: Self-describing consumers/parsers. See the README.md for more information. It is currently EXPERIMENTAL. stability: Experimental @@ -12,7 +12,7 @@ category: Parsing build-type: Simple cabal-version: >=1.8 -extra-source-files: README.md +extra-source-files: README.md, CHANGELOG library hs-source-dirs: src/ @@ -25,3 +25,12 @@ Descriptive.JSON build-depends: base >= 4 && <5, transformers, containers, text, mtl, aeson, bifunctors + +test-suite test + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: src/test + build-depends: base, + descriptive, transformers, containers, text, mtl, aeson, bifunctors, + HUnit, + hspec diff --git a/src/Descriptive.hs b/src/Descriptive.hs --- a/src/Descriptive.hs +++ b/src/Descriptive.hs @@ -18,6 +18,7 @@ ,Description(..) ,Bound(..) ,Consumer(..) + ,Result(..) -- * Combinators ,consumer ,wrap @@ -25,7 +26,7 @@ where import Control.Applicative -import Control.Arrow +import Data.Bifunctor import Data.Function import Data.Monoid @@ -35,7 +36,7 @@ -- | Run a consumer. consume :: Consumer s d a -- ^ The consumer to run. -> s -- ^ Initial state. - -> Either (Description d) a + -> Result (Description d) a consume (Consumer _ m) = fst . m -- | Describe a consumer. @@ -48,7 +49,7 @@ -- | Run a consumer. runConsumer :: Consumer s d a -- ^ The consumer to run. -> s -- ^ Initial state. - -> (Either (Description d) a,s) + -> (Result (Description d) a,s) runConsumer (Consumer _ m) = m -- | Describe a consumer. @@ -70,7 +71,7 @@ | Sequence [Description a] | Wrap a (Description a) | None - deriving (Show) + deriving (Show,Eq) instance Monoid (Description d) where mempty = None @@ -80,26 +81,46 @@ data Bound = NaturalBound !Integer | UnlimitedBound - deriving (Show) + deriving (Show,Eq) -- | A consumer. data Consumer s d a = Consumer {consumerDesc :: s -> (Description d,s) - ,consumerParse :: s -> (Either (Description d) a,s)} + ,consumerParse :: s -> (Result (Description d) a,s)} +-- | Some result. +data Result e a + = Failed e -- ^ The whole process failed. + | Succeeded a -- ^ The whole process succeeded. + | Continued e -- ^ There were errors but we continued to collect all the errors. + deriving (Show,Eq,Ord) + +instance Bifunctor Result where + second f r = + case r of + Succeeded a -> Succeeded (f a) + Failed e -> Failed e + Continued e -> Continued e + first f r = + case r of + Succeeded a -> Succeeded a + Failed e -> Failed (f e) + Continued e -> Continued (f e) + instance Functor (Consumer s d) where fmap f (Consumer d p) = Consumer d (\s -> case p s of - (Left e,s') -> (Left e,s') - (Right a,s') -> - (Right (f a),s')) + (Failed e,s') -> (Failed e,s') + (Continued e,s') -> (Continued e,s') + (Succeeded a,s') -> + (Succeeded (f a),s')) instance Applicative (Consumer s d) where pure a = consumer (\s -> (mempty,s)) - (\s -> (Right a,s)) + (\s -> (Succeeded a,s)) Consumer d pf <*> Consumer d' p' = consumer (\s -> let !(e,s') = d s @@ -109,17 +130,28 @@ let !(mf,s') = pf s !(ma,s'') = p' s' in case mf of - Left e -> (Left e,s') - Right f -> + Failed e -> (Failed e,s') + Continued e -> case ma of - Left e -> (Left e,s'') - Right a -> - (Right (f a),s'')) + Failed e' -> + (Failed e',s'') + Continued e' -> + (Continued (e <> e'),s'') + Succeeded _ -> + (Continued e,s'') + Succeeded f -> + case ma of + Continued e -> + (Continued e,s'') + Failed e -> + (Failed e,s'') + Succeeded a -> + (Succeeded (f a),s'')) instance Alternative (Consumer s d) where empty = Consumer (\s -> (mempty,s)) - (\s -> (Left mempty,s)) + (\s -> (Failed mempty,s)) a <|> b = Consumer (\s -> let !(d1,s') = consumerDesc a s @@ -127,13 +159,24 @@ in (Or d1 d2,s'')) (\s -> case consumerParse a s of - (Left e1,_) -> + (Continued e1,s') -> + case consumerParse b s' of + (Failed e2,s'') -> + (Failed e2,s'') + (Continued e2,s'') -> + (Continued (e1 <> e2),s'') + (Succeeded a',s'') -> + (Succeeded a',s'') + (Failed e1,_) -> case consumerParse b s of - (Left e2,s') -> - (Left (Or e1 e2),s') - (Right a2,s') -> - (Right a2,s') - (Right a1,s') -> (Right a1,s')) + (Failed e2,s') -> + (Failed (Or e1 e2),s') + (Continued e2,s'') -> + (Continued e2,s'') + (Succeeded a2,s') -> + (Succeeded a2,s') + (Succeeded a1,s') -> + (Succeeded a1,s')) some = sequenceHelper 1 many = sequenceHelper 0 @@ -145,30 +188,49 @@ (\s _ r -> fix (\go !i s' as -> case r s' of - (Right a,s'') -> + (Succeeded a,s'') -> go (i + 1) s'' (a : as) - (Left e,s'') + (Continued e,s'') -> + fix (\continue e' s''' -> + case r s''' of + (Continued e'',s'''') -> + continue (e' <> e'') s'''' + (Succeeded{},s'''') -> + continue e' s'''' + (Failed e'',s'''') + | i >= minb -> + (Continued e',s''') + | otherwise -> + (Failed (redescribe e''),s'''')) + e + s'' + (Failed e,s'') | i >= minb -> - (Right (reverse as),s') + (Succeeded (reverse as),s') | otherwise -> - (Left (redescribe e),s'')) + (Failed (redescribe e),s'')) 0 s []) - where redescribe = - Bounded minb UnlimitedBound + where redescribe = Bounded minb UnlimitedBound -instance (Monoid a) => Monoid (Either (Description d) a) where - mempty = Right mempty +instance (Monoid a) => Monoid (Result (Description d) a) where + mempty = Succeeded mempty mappend x y = case x of - Left e -> Left e - Right a -> + Failed e -> Failed e + Continued e -> case y of - Left e -> Left e - Right b -> Right (a <> b) + Failed e' -> Failed e' + Continued e' -> Continued (e <> e') + Succeeded _ -> Continued e + Succeeded a -> + case y of + Failed e -> Failed e + Continued e -> Continued e + Succeeded b -> Succeeded (a <> b) instance (Monoid a) => Monoid (Consumer s d a) where mempty = Consumer (\s -> (mempty,s)) (\s -> (mempty,s)) @@ -179,14 +241,14 @@ -- | Make a consumer. consumer :: (s -> (Description d,s)) -- ^ Produce description based on the state. - -> (s -> (Either (Description d) a,s)) -- ^ Parse the state and maybe transform it if desired. + -> (s -> (Result (Description d) a,s)) -- ^ Parse the state and maybe transform it if desired. -> Consumer s d a consumer d p = Consumer d p -- | Wrap a consumer with another consumer. wrap :: (s -> (t -> (Description d,t)) -> (Description d,s)) -- ^ Transformer the description. - -> (s -> (t -> (Description d,t)) -> (t -> (Either (Description d) a,t)) -> (Either (Description d) b,s)) -- ^ Transform the parser. Can re-run the parser if desired. + -> (s -> (t -> (Description d,t)) -> (t -> (Result (Description d) a,t)) -> (Result (Description d) b,s)) -- ^ Transform the parser. Can re-run the parser if desired. -> Consumer t d a -- ^ The consumer to transform. -> Consumer s d b -- ^ A new consumer with a potentially new state type. wrap redescribe reparse (Consumer d p) = diff --git a/src/Descriptive/Char.hs b/src/Descriptive/Char.hs --- a/src/Descriptive/Char.hs +++ b/src/Descriptive/Char.hs @@ -17,8 +17,8 @@ consumer (d,) (\s -> case s of - (c':cs') -> (Right c',cs') - [] -> (Left d,s)) + (c':cs') -> (Succeeded c',cs') + [] -> (Failed d,s)) where d = Unit "a character" -- | A character consumer. @@ -28,10 +28,11 @@ (d,)) (\s _ p -> case p s of - (Left e,s') -> (Left e,s') - (Right c',s') - | c' == c -> (Right c,s') - | otherwise -> (Left d,s')) + (Failed e,s') -> (Failed e,s') + (Continued e,s') -> (Continued e,s') + (Succeeded c',s') + | c' == c -> (Succeeded c,s') + | otherwise -> (Failed d,s')) anyChar where d = Unit (T.singleton c) diff --git a/src/Descriptive/Form.hs b/src/Descriptive/Form.hs --- a/src/Descriptive/Form.hs +++ b/src/Descriptive/Form.hs @@ -23,7 +23,7 @@ data Form = Input !Text | Constraint !Text - deriving (Show) + deriving (Show,Eq) -- | Consume any input value. input :: Text -> Consumer (Map Text Text) Form Text @@ -31,8 +31,8 @@ consumer (d,) (\s -> (case M.lookup name s of - Nothing -> Left d - Just a -> Right a + Nothing -> Continued d + Just a -> Succeeded a ,s)) where d = Unit (Input name) @@ -45,10 +45,12 @@ wrap (\s d -> redescribe (d s)) (\s d p -> case p s of - (Left e,s') -> (Left e,s') - (Right a,s') -> + (Failed e,s') -> (Failed e,s') + (Continued e,s') -> (Continued (wrapper e),s') + (Succeeded a,s') -> case check a of Nothing -> - (Left (fst (redescribe (d s))),s') - Just a' -> (Right a',s')) - where redescribe = first (Wrap (Constraint d')) + (Continued (fst (redescribe (d s))),s') + Just a' -> (Succeeded a',s')) + where redescribe = first wrapper + wrapper = Wrap (Constraint d') diff --git a/src/Descriptive/Formlet.hs b/src/Descriptive/Formlet.hs --- a/src/Descriptive/Formlet.hs +++ b/src/Descriptive/Formlet.hs @@ -21,13 +21,13 @@ data Formlet = Index !Integer | Constrained !Text - deriving (Show) + deriving (Show,Eq) -- | State used when running a formlet. data FormletState = FormletState {formletMap :: (Map Integer Text) ,formletIndex :: !Integer} - deriving (Show) + deriving (Show,Eq) -- | Consume any character. indexed :: Consumer FormletState Formlet Text @@ -35,8 +35,8 @@ consumer (\(nextIndex -> (i,s)) -> (d i,s)) (\(nextIndex -> (i,s)) -> case M.lookup i (formletMap s) of - Nothing -> (Left (d i),s) - Just a -> (Right a,s)) + Nothing -> (Failed (d i),s) + Just a -> (Succeeded a,s)) where d = Unit . Index nextIndex s = (formletIndex s,s {formletIndex = formletIndex s + 1}) diff --git a/src/Descriptive/JSON.hs b/src/Descriptive/JSON.hs --- a/src/Descriptive/JSON.hs +++ b/src/Descriptive/JSON.hs @@ -32,7 +32,7 @@ | Text !Text | Struct !Text | Key !Text - deriving (Show) + deriving (Show,Eq) -- | Consume an object. obj :: Text -- ^ Description of what the object is. @@ -42,11 +42,12 @@ wrap (\v d -> (Wrap doc (fst (d mempty)),v)) (\v _ p -> case fromJSON v of - Error{} -> (Left (Unit doc),v) + Error{} -> (Failed (Unit doc),v) Success o -> (case p o of - (Left e,_) -> Left (Wrap doc e) - (Right a,_) -> Right a + (Failed e,_) -> Failed (Wrap doc e) + (Continued e,_) -> Failed (Wrap doc e) + (Succeeded a,_) -> Succeeded a ,toJSON o)) where doc = Struct desc @@ -62,7 +63,7 @@ (\o _ p -> case parseMaybe (const (o .: k)) () of - Nothing -> (Left (Unit doc),o) + Nothing -> (Failed (Unit doc),o) Just (v :: Value) -> first (bimap (Wrap doc) id) (second (const o) @@ -76,8 +77,8 @@ consumer (d,) (\s -> case fromJSON s of - Error{} -> (Left d,s) - Success a -> (Right a,s)) + Error{} -> (Failed d,s) + Success a -> (Succeeded a,s)) where d = Unit (Text doc) -- | Consume an integer. @@ -87,6 +88,6 @@ consumer (d,) (\s -> case fromJSON s of - Error{} -> (Left d,s) - Success a -> (Right a,s)) + Error{} -> (Failed d,s) + Success a -> (Succeeded a,s)) where d = Unit (Integer doc) diff --git a/src/Descriptive/Options.hs b/src/Descriptive/Options.hs --- a/src/Descriptive/Options.hs +++ b/src/Descriptive/Options.hs @@ -33,7 +33,7 @@ | Flag !Text !Text | Arg !Text !Text | Prefix !Text !Text - deriving (Show) + deriving (Show,Eq) -- | Consume one argument from the argument list. anyString :: Text -> Consumer [Text] Option Text @@ -41,8 +41,8 @@ consumer (d,) (\s -> case s of - [] -> (Left d,s) - (x:s') -> (Right x,s')) + [] -> (Failed d,s) + (x:s') -> (Succeeded x,s')) where d = Unit (AnyString help) -- | Consume one argument from the argument list. @@ -52,8 +52,8 @@ (\s -> case s of (x:s') | x == x' -> - (Right x,s') - _ -> (Left d,s)) + (Succeeded x,s') + _ -> (Failed d,s)) where d = Unit (Constant x') -- | Find a short boolean flag. @@ -61,7 +61,7 @@ flag name help = consumer (d,) (\s -> - (Right (elem ("--" <> name) s),filter (/= "--" <> name) s)) + (Succeeded (elem ("--" <> name) s),filter (/= "--" <> name) s)) where d = Unit (Flag name help) -- | Find an argument prefixed by -X. @@ -70,8 +70,8 @@ consumer (d,) (\s -> case find (T.isPrefixOf ("-" <> pref)) s of - Nothing -> (Left d,s) - Just a -> (Right (T.drop (T.length pref + 1) a), delete a s)) + Nothing -> (Failed d,s) + Just a -> (Succeeded (T.drop (T.length pref + 1) a), delete a s)) where d = Unit (Prefix pref help) -- | Find a named argument. @@ -82,12 +82,12 @@ let indexedArgs = zip [0 :: Integer ..] s in case find ((== "--" <> name) . snd) indexedArgs of - Nothing -> (Left d,s) + Nothing -> (Failed d,s) Just (i,_) -> case lookup (i + 1) indexedArgs of - Nothing -> (Left d,s) + Nothing -> (Failed d,s) Just text -> - (Right text + (Succeeded text ,map snd (filter (\(j,_) -> j /= i && j /= i + 1) indexedArgs))) where d = Unit (Arg name help) diff --git a/src/test/Main.hs b/src/test/Main.hs new file mode 100644 --- /dev/null +++ b/src/test/Main.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +-- | Test suite for ACE. + +module Main where + +import Control.Applicative +import Data.Aeson (Value(..),toJSON,object,(.=)) +import qualified Data.Map.Strict as M +import Data.Monoid +import Data.Text (Text) +import Descriptive +import qualified Descriptive.Char as Char +import qualified Descriptive.Form as Form +import qualified Descriptive.Formlet as Formlet +import qualified Descriptive.JSON as JSON +import qualified Descriptive.Options as Options +import Test.HUnit +import Test.Hspec (Spec,it,hspec) +import qualified Test.Hspec as Hspec + +-- | Test suite entry point, returns exit failure if any test fails. +main :: IO () +main = hspec spec + +-- | Test suite. +spec :: Spec +spec = do + Hspec.describe "Descriptive.Char" characters + Hspec.describe "Descriptive.Form" form + Hspec.describe "Descriptive.Formlet" formlet + Hspec.describe "Descriptive.JSON" json + Hspec.describe "Descriptive.Options" options + +-------------------------------------------------------------------------------- +-- Character parsing tests + +characters :: Spec +characters = + do it "describe" + (describe (many (Char.char 'k') <> + Char.string "abc") + mempty == + And (Bounded 0 UnlimitedBound (Unit "k")) + (Sequence [Unit "a" + ,Sequence [Unit "b",Sequence [Unit "c",Sequence []]]])) + it "consume" + (consume (many (Char.char 'k') <> + Char.string "abc") + "kkkabc" == + (Succeeded "kkkabc")) + it "fail generic" + (consume (many (Char.char 'k') <> + Char.string "abc") + "kkkab" == + (Failed (Unit "a character"))) + it "fail specific" + (consume (many (Char.char 'k') <> + Char.string "abc") + "kkkabj" == + (Failed (Unit "c"))) + +-------------------------------------------------------------------------------- +-- Form tests + +form :: Spec +form = + do it "basic describe login" + (describe ((,) <$> + Form.input "username" <*> + Form.input "password") + mempty == + (And (Unit (Form.Input "username")) + (Unit (Form.Input "password")))) + it "basic describe login" + (consume ((,) <$> + Form.input "username" <*> + Form.input "password") + (M.fromList [("username","chrisdone"),("password","god")]) == + Succeeded ("chrisdone","god")) + it "succeeding login" + (consume login (M.fromList [("password2","gob"),("password","gob")]) == + Succeeded "gob") + it "continuing login" + (consume login (M.fromList [("password2","gob"),("password","go")]) == + Continued (And (Wrap (Form.Constraint "confirmed password (entered the same twice)") + (And (Unit (Form.Input "password")) + (Unit (Form.Input "password2")))) + (Unit (Form.Input "token")))) + it "succeeding disjunction" + (consume login + (M.fromList + [("password2","gob"),("password","go"),("token","woot")]) == + Succeeded "woot") + where login = + Form.validate + "confirmed password (entered the same twice)" + (\(x,y) -> + if x == y + then Just y + else Nothing) + ((,) <$> + Form.input "password" <*> + Form.input "password2") <|> + Form.input "token" + +-------------------------------------------------------------------------------- +-- Formlet tests + +formlet :: Spec +formlet = + do it "basic formlet" + (describe ((,) <$> Formlet.indexed <*> Formlet.indexed) + (Formlet.FormletState mempty 0) == + And (Unit (Formlet.Index 0)) + (Unit (Formlet.Index 1))) + it "succeeding formlet" + (consume ((,) <$> Formlet.indexed <*> Formlet.indexed) + (Formlet.FormletState (M.fromList [(0,"chrisdone"),(1,"god")]) + 0) == + Succeeded ("chrisdone","god")) + it "succeeding formlet" + (consume ((,) <$> Formlet.indexed <*> Formlet.indexed) + (Formlet.FormletState (M.fromList [(0,"chrisdone")]) + 0) == + Failed (Unit (Formlet.Index 1))) + +-------------------------------------------------------------------------------- +-- Options tests + +options :: Spec +options = + do it "describe options" + (describe server [] == + And (And (And (Unit (Options.Constant "start")) + (Unit (Options.AnyString "SERVER_NAME"))) + (Unit (Options.Flag "dev" "Enable dev mode?"))) + (Unit (Options.Arg "port" "Port to listen on"))) + it "succeeding options" + (consume server ["start","any","--port","1234","--dev"] == + Succeeded ("start","any",True,"1234")) + it "succeeding omitting port options" + (consume server ["start","any","--port","1234"] == + Succeeded ("start","any",False,"1234")) + it "failing options" + (consume server ["start","any"] == + Failed (Unit (Options.Arg "port" "Port to listen on"))) + where server = + ((,,,) <$> + Options.constant "start" <*> + Options.anyString "SERVER_NAME" <*> + Options.flag "dev" "Enable dev mode?" <*> + Options.arg "port" "Port to listen on") + +-------------------------------------------------------------------------------- +-- JSON tests + +-- | Submit a URL to reddit. +data Submission = + Submission {submissionToken :: !Integer + ,submissionTitle :: !Text + ,submissionComment :: !Text + ,submissionSubreddit :: !Integer} + deriving (Show,Eq) + +submission :: Consumer Value JSON.Doc Submission +submission = + JSON.obj "Submission" + (Submission + <$> JSON.key "token" (JSON.integer "Submission token; see the API docs") + <*> JSON.key "title" (JSON.string "Submission title") + <*> JSON.key "comment" (JSON.string "Submission comment") + <*> JSON.key "subreddit" (JSON.integer "The ID of the subreddit")) + +sample :: Value +sample = + toJSON (object + ["token" .= 123 + ,"title" .= "Some title" + ,"comment" .= "This is good" + ,"subreddit" .= 234214]) + +badsample :: Value +badsample = + toJSON (object + ["token" .= 123 + ,"title" .= "Some title" + ,"comment" .= 123 + ,"subreddit" .= 234214]) + +json :: Spec +json = + do it "describe JSON" + (describe submission (toJSON ()) == + Wrap (JSON.Struct "Submission") + (And (And (And (Wrap (JSON.Key "token") + (Unit (JSON.Integer "Submission token; see the API docs"))) + (Wrap (JSON.Key "title") + (Unit (JSON.Text "Submission title")))) + (Wrap (JSON.Key "comment") + (Unit (JSON.Text "Submission comment")))) + (Wrap (JSON.Key "subreddit") + (Unit (JSON.Integer "The ID of the subreddit"))))) + it "succeeding json" + (consume submission sample == + Succeeded (Submission {submissionToken = 123 + ,submissionTitle = "Some title" + ,submissionComment = "This is good" + ,submissionSubreddit = 234214})) + it "failing json" + (consume submission badsample == + Failed (Wrap (JSON.Struct "Submission") + (Wrap (JSON.Key "comment") + (Unit (JSON.Text "Submission comment")))))