gdritter repos s-cargot / 8a28adf
Added some more quickcheck tests Getty Ritter 8 years ago
1 changed file(s) with 98 addition(s) and 24 deletion(s). Collapse all Expand all
+98
-24
test/SCargotQC.hs less more
11 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE ScopedTypeVariables #-}
23
3 module Data.SCargot.ReprQC (reprQC) where
4 module Main where
45
5 import Data.SCargot ( SExprParser
6 , SExprPrinter
7 , mkParser
8 , flatPrint
9 , encodeOne
10 , decodeOne
11 , asRich
12 , asWellFormed
13 )
14 import Data.SCargot.Repr ( SExpr(..)
15 , RichSExpr
16 , fromRich
17 , toRich
18 , WellFormedSExpr(..)
19 , fromWellFormed
20 , toWellFormed
21 )
22 import Test.QuickCheck
23 import Test.QuickCheck.Arbitrary
24 import Text.Parsec (char)
25 import Text.Parsec.Text (Parser)
6 import Data.SCargot
7 import Data.SCargot.Comments
8 import Data.SCargot.Repr
9
10 import Data.Monoid ((<>))
11 import Data.Text (Text)
12 import qualified Data.Text as T
13 import Test.QuickCheck
14 import Test.QuickCheck.Arbitrary
15 import Text.Parsec (char)
16 import Text.Parsec.Text (Parser)
2617
2718 instance Arbitrary a => Arbitrary (SExpr a) where
2819 arbitrary = sized $ \n ->
5445 ]
5546 ]
5647
48 data EncodedSExpr = EncodedSExpr
49 { encoding :: Text
50 , original :: SExpr ()
51 } deriving (Eq, Show)
52
53 instance Arbitrary EncodedSExpr where
54 arbitrary = do
55 sexpr :: SExpr () <- arbitrary
56 let chunks = T.words (encodeOne printer sexpr)
57 whitespace <- sequence [ mkWs | _ <- chunks ]
58 pure (EncodedSExpr { encoding = T.concat (zipWith (<>) chunks whitespace)
59 , original = sexpr
60 })
61 where mkWs = do
62 n :: Int <- choose (1, 10)
63 T.pack <$> sequence [ elements " \t\r\n"
64 | _ <- [0..n]
65 ]
66
5767 parser :: SExprParser () (SExpr ())
5868 parser = mkParser (() <$ char 'X')
5969
6070 printer :: SExprPrinter () (SExpr ())
6171 printer = flatPrint (const "X")
72
73 prettyPrinter :: SExprPrinter () (SExpr ())
74 prettyPrinter = basicPrint (const "X")
75
6276
6377 richIso :: SExpr () -> Bool
6478 richIso s = fromRich (toRich s) == s
7993 encDec :: SExpr () -> Bool
8094 encDec s = decodeOne parser (encodeOne printer s) == Right s
8195
96 encDecPretty :: SExpr () -> Bool
97 encDecPretty s = decodeOne parser (encodeOne prettyPrinter s) == Right s
98
99 decEnc :: EncodedSExpr -> Bool
100 decEnc s = decodeOne parser (encoding s) == Right (original s)
101
102
82103 encDecRich :: RichSExpr () -> Bool
83104 encDecRich s = decodeOne (asRich parser) (encodeOne printer (fromRich s))
84105 == Right s
106
107 encDecRichPretty :: RichSExpr () -> Bool
108 encDecRichPretty s = decodeOne (asRich parser)
109 (encodeOne prettyPrinter (fromRich s))
110 == Right s
111
112 decEncRich :: EncodedSExpr -> Bool
113 decEncRich s = decodeOne (asRich parser) (encoding s) == Right (toRich (original s))
114
85115
86116 encDecWF :: WellFormedSExpr () -> Bool
87117 encDecWF s = decodeOne (asWellFormed parser) (encodeOne printer (fromWellFormed s))
88118 == Right s
89119
90 reprQC :: IO ()
91 reprQC = do
120 encDecWFPretty :: WellFormedSExpr () -> Bool
121 encDecWFPretty s =
122 decodeOne (asWellFormed parser) (encodeOne prettyPrinter (fromWellFormed s))
123 == Right s
124
125 decEncWF :: EncodedSExpr -> Bool
126 decEncWF s = decodeOne (asWellFormed parser) (encoding s) == toWellFormed (original s)
127
128
129 insertComments :: Text -> Text -> Text -> Text
130 insertComments lc rc sexpr =
131 T.replace " " (" " <> lc <> "blahblahblah" <> rc <> " ") sexpr
132
133 encDecLineComments :: SExpr () -> Bool
134 encDecLineComments s =
135 decodeOne (withLispComments parser)
136 (insertComments ";" "\n" (encodeOne printer s)) == Right s
137
138 encDecBlockComments :: SExpr () -> Bool
139 encDecBlockComments s =
140 decodeOne (withHaskellBlockComments parser)
141 (insertComments "{-" "-}" (encodeOne printer s)) == Right s
142
143 -- Sometimes we generate really huge test cases, which can take a really
144 -- long time to process---especially when we're modifying the whitespace
145 -- to produce weird anomalous S-expressions. So, we make the size parameter
146 -- a bit smaller for good measure.
147 reallyQuickCheck :: Testable prop => prop -> IO ()
148 reallyQuickCheck = quickCheckWith stdArgs { maxSize = 25 }
149
150 main :: IO ()
151 main = do
92152 putStrLn "The SExpr <--> Rich translation should be isomorphic"
93153 quickCheck richIso
94154 quickCheck richIsoBk
155
95156 putStrLn "The SExpr <--> WF translation should be near-isomorphic"
96157 quickCheck wfIso
97158 quickCheck wfIsoBk
159
98160 putStrLn "This should be true when parsing, as well"
99161 quickCheck encDec
162 reallyQuickCheck decEnc
100163 quickCheck encDecRich
164 reallyQuickCheck decEncRich
101165 quickCheck encDecWF
166 reallyQuickCheck decEncWF
167
168 putStrLn "And it should be true if pretty-printed"
169 reallyQuickCheck encDecPretty
170 reallyQuickCheck encDecRichPretty
171 reallyQuickCheck encDecWFPretty
172
173 putStrLn "Comments should not affect parsing"
174 reallyQuickCheck encDecLineComments
175 reallyQuickCheck encDecBlockComments