SCargotQC.hs 5.3 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175
  1. {-# LANGUAGE OverloadedStrings #-}
  2. {-# LANGUAGE ScopedTypeVariables #-}
  3. module Main where
  4. import Data.SCargot
  5. import Data.SCargot.Comments
  6. import Data.SCargot.Repr
  7. import Data.Monoid ((<>))
  8. import Data.Text (Text)
  9. import qualified Data.Text as T
  10. import Test.QuickCheck
  11. import Test.QuickCheck.Arbitrary
  12. import Text.Parsec (char)
  13. import Text.Parsec.Text (Parser)
  14. instance Arbitrary a => Arbitrary (SExpr a) where
  15. arbitrary = sized $ \n ->
  16. if n <= 0
  17. then pure SNil
  18. else oneof [ SAtom <$> arbitrary
  19. , do
  20. k <- choose (0, n)
  21. elems <- sequence [ resize (n-k) arbitrary
  22. | _ <- [0..k]
  23. ]
  24. tail <- oneof [ SAtom <$> arbitrary
  25. , pure SNil
  26. ]
  27. pure (foldr SCons tail elems)
  28. ]
  29. instance Arbitrary a => Arbitrary (RichSExpr a) where
  30. arbitrary = toRich `fmap` arbitrary
  31. instance Arbitrary a => Arbitrary (WellFormedSExpr a) where
  32. arbitrary = sized $ \n ->
  33. oneof [ WFSAtom <$> arbitrary
  34. , do
  35. k <- choose (0, n)
  36. WFSList <$> sequence
  37. [ resize (n-k) arbitrary
  38. | _ <- [0..k]
  39. ]
  40. ]
  41. data EncodedSExpr = EncodedSExpr
  42. { encoding :: Text
  43. , original :: SExpr ()
  44. } deriving (Eq, Show)
  45. instance Arbitrary EncodedSExpr where
  46. arbitrary = do
  47. sexpr :: SExpr () <- arbitrary
  48. let chunks = T.words (encodeOne printer sexpr)
  49. whitespace <- sequence [ mkWs | _ <- chunks ]
  50. pure (EncodedSExpr { encoding = T.concat (zipWith (<>) chunks whitespace)
  51. , original = sexpr
  52. })
  53. where mkWs = do
  54. n :: Int <- choose (1, 10)
  55. T.pack <$> sequence [ elements " \t\r\n"
  56. | _ <- [0..n]
  57. ]
  58. parser :: SExprParser () (SExpr ())
  59. parser = mkParser (() <$ char 'X')
  60. printer :: SExprPrinter () (SExpr ())
  61. printer = flatPrint (const "X")
  62. prettyPrinter :: SExprPrinter () (SExpr ())
  63. prettyPrinter = basicPrint (const "X")
  64. richIso :: SExpr () -> Bool
  65. richIso s = fromRich (toRich s) == s
  66. richIsoBk :: RichSExpr () -> Bool
  67. richIsoBk s = toRich (fromRich s) == s
  68. wfIso :: SExpr () -> Bool
  69. wfIso s = case toWellFormed s of
  70. Left _ -> True
  71. Right y -> s == fromWellFormed y
  72. wfIsoBk :: WellFormedSExpr () -> Bool
  73. wfIsoBk s = toWellFormed (fromWellFormed s) == Right s
  74. encDec :: SExpr () -> Bool
  75. encDec s = decodeOne parser (encodeOne printer s) == Right s
  76. encDecPretty :: SExpr () -> Bool
  77. encDecPretty s = decodeOne parser (encodeOne prettyPrinter s) == Right s
  78. decEnc :: EncodedSExpr -> Bool
  79. decEnc s = decodeOne parser (encoding s) == Right (original s)
  80. encDecRich :: RichSExpr () -> Bool
  81. encDecRich s = decodeOne (asRich parser) (encodeOne printer (fromRich s))
  82. == Right s
  83. encDecRichPretty :: RichSExpr () -> Bool
  84. encDecRichPretty s = decodeOne (asRich parser)
  85. (encodeOne prettyPrinter (fromRich s))
  86. == Right s
  87. decEncRich :: EncodedSExpr -> Bool
  88. decEncRich s = decodeOne (asRich parser) (encoding s) == Right (toRich (original s))
  89. encDecWF :: WellFormedSExpr () -> Bool
  90. encDecWF s = decodeOne (asWellFormed parser) (encodeOne printer (fromWellFormed s))
  91. == Right s
  92. encDecWFPretty :: WellFormedSExpr () -> Bool
  93. encDecWFPretty s =
  94. decodeOne (asWellFormed parser) (encodeOne prettyPrinter (fromWellFormed s))
  95. == Right s
  96. decEncWF :: EncodedSExpr -> Bool
  97. decEncWF s = decodeOne (asWellFormed parser) (encoding s) == toWellFormed (original s)
  98. insertComments :: Text -> Text -> Text -> Text
  99. insertComments lc rc sexpr =
  100. T.replace " " (" " <> lc <> "blahblahblah" <> rc <> " ") sexpr
  101. encDecLineComments :: SExpr () -> Bool
  102. encDecLineComments s =
  103. decodeOne (withLispComments parser)
  104. (insertComments ";" "\n" (encodeOne printer s)) == Right s
  105. encDecBlockComments :: SExpr () -> Bool
  106. encDecBlockComments s =
  107. decodeOne (withHaskellBlockComments parser)
  108. (insertComments "{-" "-}" (encodeOne printer s)) == Right s
  109. -- Sometimes we generate really huge test cases, which can take a really
  110. -- long time to process---especially when we're modifying the whitespace
  111. -- to produce weird anomalous S-expressions. So, we make the size parameter
  112. -- a bit smaller for good measure.
  113. reallyQuickCheck :: Testable prop => prop -> IO ()
  114. reallyQuickCheck = quickCheckWith stdArgs { maxSize = 25 }
  115. main :: IO ()
  116. main = do
  117. putStrLn "The SExpr <--> Rich translation should be isomorphic"
  118. quickCheck richIso
  119. quickCheck richIsoBk
  120. putStrLn "The SExpr <--> WF translation should be near-isomorphic"
  121. quickCheck wfIso
  122. quickCheck wfIsoBk
  123. putStrLn "This should be true when parsing, as well"
  124. quickCheck encDec
  125. reallyQuickCheck decEnc
  126. quickCheck encDecRich
  127. reallyQuickCheck decEncRich
  128. quickCheck encDecWF
  129. reallyQuickCheck decEncWF
  130. putStrLn "And it should be true if pretty-printed"
  131. reallyQuickCheck encDecPretty
  132. reallyQuickCheck encDecRichPretty
  133. reallyQuickCheck encDecWFPretty
  134. putStrLn "Comments should not affect parsing"
  135. reallyQuickCheck encDecLineComments
  136. reallyQuickCheck encDecBlockComments