content: {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE FlexibleInstances #-}
  
  -- | Interface module.
  
  module Test.SmartCheck
    (
    -- ** Main SmartCheck interface.
      smartCheck
  
    -- ** User-suppplied counterexample interface.
    , smartCheckInput
  
    -- ** Run QuickCheck and get a result.
    , runQC
  
    -- ** Arguments
    , module Test.SmartCheck.Args
  
    -- ** Main type class based on Generics.
    , SubTypes(..)
  
    -- ** For constructing new instances of `SubTypes`
    , gst
    , grc
    , gtc
    , gsf
  --  , gsz
    ) where
  
  import Test.SmartCheck.Args
  import Test.SmartCheck.ConstructorGen
  import Test.SmartCheck.Extrapolate
  import Test.SmartCheck.Matches
  import Test.SmartCheck.Reduce
  import Test.SmartCheck.Render
  import Test.SmartCheck.Test
  import Test.SmartCheck.Types
  
  import qualified Test.QuickCheck as Q
  
  import Generics.Deriving
  import Control.Monad (when)
  
  --------------------------------------------------------------------------------
  
  -- | Main interface function.
  smartCheck ::
    ( SubTypes a
    , Generic a, ConNames (Rep a)
    , Q.Testable prop
    ) => ScArgs -> (a -> prop) -> IO ()
  smartCheck args scProp =
    smartCheckRun args =<< runQC (qcArgs args) scProp
  
  smartCheckInput :: forall a prop.
    ( SubTypes a
    , Generic a, ConNames (Rep a)
    , Q.Testable prop
    , Read a
    ) => ScArgs -> (a -> prop) -> IO ()
  smartCheckInput args scProp = do
    smartPrtLn "Input value to SmartCheck:"
    mcex <- fmap Just (readLn :: IO a)
    smartCheckRun args (mcex, Q.property . scProp)
  
  smartCheckRun :: forall a.
    ( SubTypes a
    , Generic a, ConNames (Rep a)
    ) => ScArgs -> (Maybe a, a -> Q.Property) -> IO ()
  smartCheckRun args (origMcex, origProp) = do
    putStrLn ""
    smartPrtLn $ "Analyzing the first argument of the property with SmartCheck..."
    smartPrtLn $ "(If any stage takes too long, modify SmartCheck's arguments.)"
    smartCheck' [] origMcex origProp
    where
    smartCheck' :: [(a, Replace Idx)]
                -> Maybe a
                -> (a -> Q.Property)
                -> IO ()
    smartCheck' ds mcex prop =
      maybe (maybeDoneMsg >> return ()) go mcex
      where
      go cex = do
          -- Run the smart reduction algorithm.
        d <- smartRun args cex prop
        -- If we asked to extrapolate values, do so.
        valIdxs <- forallExtrap args d origProp
        -- If we asked to extrapolate constructors, do so, again with the
        -- original property.
        csIdxs <- existsExtrap args d valIdxs origProp
  
        let replIdxs = Replace valIdxs csIdxs
        -- If either kind of extrapolation pass yielded fruit, prettyprint it.
        showExtrapOutput args valIdxs csIdxs replIdxs d
        -- Try again?
        runAgainMsg
  
        s <- getLine
        if s == ""
          -- If so, then loop, with the new prop.
          then do let oldVals  = (d,replIdxs):ds
                  let matchesProp a =
                              not (matchesShapes a oldVals)
                        Q.==> prop a
                  (mcex', _) <- runQC (qcArgs args) (Q.noShrinking . matchesProp)
                  smartCheck' oldVals mcex' matchesProp
          else smartPrtLn "Done."
  
    maybeDoneMsg = smartPrtLn "No value to smart-shrink; done."
  
  --------------------------------------------------------------------------------
  
  existsExtrap :: (Generic a, SubTypes a, ConNames (Rep a))
               => ScArgs -> a -> [Idx] -> (a -> Q.Property) -> IO [Idx]
  existsExtrap args d valIdxs origProp =
    if runExists args
      then constrsGen args d origProp valIdxs
      else return []
  
  --------------------------------------------------------------------------------
  
  forallExtrap :: SubTypes a => ScArgs -> a -> (a -> Q.Property) -> IO [Idx]
  forallExtrap args d origProp =
    if runForall args
      then -- Extrapolate with the original property to see if we
           -- get a previously-visited value back.
           extrapolate args d origProp
      else return []
  
  --------------------------------------------------------------------------------
  
  showExtrapOutput :: SubTypes a1
                   => ScArgs -> [a] -> [a] -> Replace Idx -> a1 -> IO ()
  showExtrapOutput args valIdxs csIdxs replIdxs d =
    when (runForall args || runExists args) $ do
      if null (valIdxs ++ csIdxs)
        then smartPrtLn "Could not extrapolate a new value."
        else output
    where
    output = do
      putStrLn ""
      smartPrtLn "Extrapolated value:"
      renderWithVars (format args) d replIdxs
  
  --------------------------------------------------------------------------------
  
  runAgainMsg :: IO ()
  runAgainMsg = putStrLn $
       "\nAttempt to find a new counterexample?\n"
    ++ "  ('Enter' to continue;"
    ++ " any character then 'Enter' to quit.)"
  
  --------------------------------------------------------------------------------
  
  -- | Run QuickCheck, to get a counterexamples for each argument, including the
  -- one we want to focus on for SmartCheck, which is the first argument.  That
  -- argument is never shrunk by QuickCheck, but others may be shrunk by
  -- QuickCheck.  Returns the value (if it exists) and a 'Property' (by applying
  -- the 'property' method to the 'Testable' value).  In each iteration of
  -- 'runQC', non-SmartCheck arguments are not necessarily held constant
  runQC :: forall a prop . (Show a, Q.Arbitrary a, Q.Testable prop)
            => Q.Args -> (a -> prop) -> IO (Maybe a, a -> Q.Property)
  runQC args scProp = do
    smartPrtLn "Finding a counterexample with QuickCheck..."
  --  smartPrtLn "
    (mCex, res) <- scQuickCheckWithResult args scProp
    return $ if failureRes res
               then (mCex,    Q.property . scProp)
               else (Nothing, Q.property . scProp)
  
  -- | Returns 'True' if a counterexample is returned and 'False' otherwise.
  failureRes :: Q.Result -> Bool
  failureRes res =
    case res of
      Q.Failure _ _ _ _ _ _ _ _ _ _ -> True
      _                             -> False
  
  --------------------------------------------------------------------------------
  
  