content: {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# OPTIONS_GHC -fno-warn-orphans #-}
  
  module Main where
  
  import Data.Monoid ((<>))
  import Data.SCargot
  import Data.SCargot.Comments
  import Data.SCargot.Repr
  import Data.Text (Text)
  import qualified Data.Text as T
  import Test.QuickCheck
  import Text.Parsec (char)
  
  instance Arbitrary a => Arbitrary (SExpr a) where
    arbitrary = sized $ \n ->
      if n <= 0
        then pure SNil
        else
          oneof
            [ SAtom <$> arbitrary,
              do
                k <- choose (0, n)
                elems <-
                  sequence
                    [ resize (n - k) arbitrary
                      | _ <- [0 .. k]
                    ]
                rest <-
                  oneof
                    [ SAtom <$> arbitrary,
                      pure SNil
                    ]
                pure (foldr SCons rest elems)
            ]
  
  instance Arbitrary a => Arbitrary (RichSExpr a) where
    arbitrary = toRich `fmap` arbitrary
  
  instance Arbitrary a => Arbitrary (WellFormedSExpr a) where
    arbitrary = sized $ \n ->
      oneof
        [ WFSAtom <$> arbitrary,
          do
            k <- choose (0, n)
            WFSList
              <$> sequence
                [ resize (n - k) arbitrary
                  | _ <- [0 .. k]
                ]
        ]
  
  data EncodedSExpr = EncodedSExpr
    { encoding :: Text,
      original :: SExpr ()
    }
    deriving (Eq, Show)
  
  instance Arbitrary EncodedSExpr where
    arbitrary = do
      sexpr :: SExpr () <- arbitrary
      let chunks = T.words (encodeOne printer sexpr)
      whitespace <- sequence [mkWs | _ <- chunks]
      pure
        ( EncodedSExpr
            { encoding = T.concat (zipWith (<>) chunks whitespace),
              original = sexpr
            }
        )
      where
        mkWs = do
          n :: Int <- choose (1, 10)
          T.pack
            <$> sequence
              [ elements " \t\r\n"
                | _ <- [0 .. n]
              ]
  
  parser :: SExprParser () (SExpr ())
  parser = mkParser (() <$ char 'X')
  
  printer :: SExprPrinter () (SExpr ())
  printer = flatPrint (const "X")
  
  prettyPrinter :: SExprPrinter () (SExpr ())
  prettyPrinter = basicPrint (const "X")
  
  widePrinter :: SExprPrinter () (SExpr ())
  widePrinter = unconstrainedPrint (const "X")
  
  richIso :: SExpr () -> Bool
  richIso s = fromRich (toRich s) == s
  
  richIsoBk :: RichSExpr () -> Bool
  richIsoBk s = toRich (fromRich s) == s
  
  wfIso :: SExpr () -> Bool
  wfIso s = case toWellFormed s of
    Left _ -> True
    Right y -> s == fromWellFormed y
  
  wfIsoBk :: WellFormedSExpr () -> Bool
  wfIsoBk s = toWellFormed (fromWellFormed s) == Right s
  
  encDec :: SExpr () -> Bool
  encDec s = decodeOne parser (encodeOne printer s) == Right s
  
  encDecPretty :: SExpr () -> Bool
  encDecPretty s = decodeOne parser (encodeOne prettyPrinter s) == Right s
  
  encDecWide :: SExpr () -> Bool
  encDecWide s = decodeOne parser (encodeOne widePrinter s) == Right s
  
  decEnc :: EncodedSExpr -> Bool
  decEnc s = decodeOne parser (encoding s) == Right (original s)
  
  encDecRich :: RichSExpr () -> Bool
  encDecRich s =
    decodeOne (asRich parser) (encodeOne printer (fromRich s))
      == Right s
  
  encDecRichPretty :: RichSExpr () -> Bool
  encDecRichPretty s =
    decodeOne
      (asRich parser)
      (encodeOne prettyPrinter (fromRich s))
      == Right s
  
  encDecRichWide :: RichSExpr () -> Bool
  encDecRichWide s =
    decodeOne
      (asRich parser)
      (encodeOne widePrinter (fromRich s))
      == Right s
  
  decEncRich :: EncodedSExpr -> Bool
  decEncRich s = decodeOne (asRich parser) (encoding s) == Right (toRich (original s))
  
  encDecWF :: WellFormedSExpr () -> Bool
  encDecWF s =
    decodeOne (asWellFormed parser) (encodeOne printer (fromWellFormed s))
      == Right s
  
  encDecWFPretty :: WellFormedSExpr () -> Bool
  encDecWFPretty s =
    decodeOne (asWellFormed parser) (encodeOne prettyPrinter (fromWellFormed s))
      == Right s
  
  encDecWFWide :: WellFormedSExpr () -> Bool
  encDecWFWide s =
    decodeOne (asWellFormed parser) (encodeOne widePrinter (fromWellFormed s))
      == Right s
  
  decEncWF :: EncodedSExpr -> Bool
  decEncWF s = decodeOne (asWellFormed parser) (encoding s) == toWellFormed (original s)
  
  insertComments :: Text -> Text -> Text -> Text
  insertComments lc rc sexpr =
    T.replace " " (" " <> lc <> "blahblahblah" <> rc <> " ") sexpr
  
  encDecLineComments :: SExpr () -> Bool
  encDecLineComments s =
    decodeOne
      (withLispComments parser)
      (insertComments ";" "\n" (encodeOne printer s))
      == Right s
  
  encDecBlockComments :: SExpr () -> Bool
  encDecBlockComments s =
    decodeOne
      (withHaskellBlockComments parser)
      (insertComments "{-" "-}" (encodeOne printer s))
      == Right s
  
  -- Sometimes we generate really huge test cases, which can take a really
  -- long time to process---especially when we're modifying the whitespace
  -- to produce weird anomalous S-expressions. So, we make the size parameter
  -- a bit smaller for good measure.
  reallyQuickCheck :: Testable prop => prop -> IO ()
  reallyQuickCheck = quickCheckWith stdArgs {maxSize = 25}
  
  main :: IO ()
  main = do
    putStrLn "The SExpr <--> Rich translation should be isomorphic"
    quickCheck richIso
    quickCheck richIsoBk
  
    putStrLn "The SExpr <--> WF translation should be near-isomorphic"
    quickCheck wfIso
    quickCheck wfIsoBk
  
    putStrLn "This should be true when parsing, as well"
    quickCheck encDec
    reallyQuickCheck decEnc
    quickCheck encDecRich
    reallyQuickCheck decEncRich
    quickCheck encDecWF
    reallyQuickCheck decEncWF
  
    putStrLn "And it should be true if pretty-printed"
    reallyQuickCheck encDecPretty
    reallyQuickCheck encDecRichPretty
    reallyQuickCheck encDecWFPretty
  
    putStrLn "And it should be true if pretty-printed using the wide-format printer"
    reallyQuickCheck encDecWide
    reallyQuickCheck encDecRichWide
    reallyQuickCheck encDecWFWide
  
    putStrLn "Comments should not affect parsing"
    reallyQuickCheck encDecLineComments
    reallyQuickCheck encDecBlockComments
  