QuickChecks.hs

{-# LANGUAGE Rank2Types, NoMonomorphismRestriction, ScopedTypeVariables #-}
module Database.Design.Ampersand.Test.Parser.QuickChecks (parserQuickChecks) where

import Database.Design.Ampersand.Test.Parser.ParserTest (parseReparse)
import Database.Design.Ampersand.Test.Parser.ArbitraryTree()
import Database.Design.Ampersand.ADL1.PrettyPrinters(prettyPrint)
import Database.Design.Ampersand.Core.ParseTree (P_Context)
import Database.Design.Ampersand.Input.ADL1.CtxError (Guarded(..))

import Test.QuickCheck(Args(..), quickCheckWithResult, Testable, Result(..))
import Debug.Trace

-- Tries to parse a string, and if successful, tests the result with the given function
testParse :: String -> (P_Context -> Bool) -> Bool
testParse text check = case parseReparse "File generated by QuickCheck. When you see it in an error, there is something wrong with the parser!" text of
            Checked a -> check a
            Errors e  -> trace (show e ++ "\n" ++ text) False
            -- TODO: Errors e  -> do { showErrors e; return False }

-- Tests whether the parsed context is equal to the original one
prop_pretty :: P_Context -> Bool
prop_pretty ctx = testParse prettyCtx eq
        where eq p = ctx == p || trace ("Printed versions are different: " ++ prettyCtx ++ "\n\n---------\n\n" ++ prettyPrint p) False
              prettyCtx = unlines . map includeLineNr . zip [1..] . lines $ prettyPrint ctx
              includeLineNr :: (Int,String) -> String
              includeLineNr (nr,str) = "{-"++take (4 - length (show nr)) (repeat '0')++show nr++"-} "++str

checkArgs :: Args
checkArgs = Args
  { replay          = Nothing
  , maxSuccess      = 64
  , maxDiscardRatio = 8
  , maxSize         = 8      -- otherwise there's nothing quick about it.
  , chatty          = False
  }

-- TODO: Improve the messages given here, remove all trace's
test :: Testable prop => prop -> IO (Bool, String)
test p = do res <- quickCheckWithResult checkArgs p
            case res of
                Success {} -> return (True, "")
                _          -> return (False, show res )

parserQuickChecks :: IO (Bool,String)
parserQuickChecks = test prop_pretty