{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}

module Test.DocTest.Internal.Property where

import           Data.List
import           Data.Maybe
import           Data.Foldable

import           Test.DocTest.Internal.Util
import           Test.DocTest.Internal.Interpreter (Interpreter)
import qualified Test.DocTest.Internal.Interpreter as Interpreter
import           Test.DocTest.Internal.Parse

-- | The result of evaluating an interaction.
data PropertyResult =
    Success
  | Failure String
  | Error String
  deriving (PropertyResult -> PropertyResult -> Bool
(PropertyResult -> PropertyResult -> Bool)
-> (PropertyResult -> PropertyResult -> Bool) -> Eq PropertyResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PropertyResult -> PropertyResult -> Bool
$c/= :: PropertyResult -> PropertyResult -> Bool
== :: PropertyResult -> PropertyResult -> Bool
$c== :: PropertyResult -> PropertyResult -> Bool
Eq, Int -> PropertyResult -> ShowS
[PropertyResult] -> ShowS
PropertyResult -> String
(Int -> PropertyResult -> ShowS)
-> (PropertyResult -> String)
-> ([PropertyResult] -> ShowS)
-> Show PropertyResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PropertyResult] -> ShowS
$cshowList :: [PropertyResult] -> ShowS
show :: PropertyResult -> String
$cshow :: PropertyResult -> String
showsPrec :: Int -> PropertyResult -> ShowS
$cshowsPrec :: Int -> PropertyResult -> ShowS
Show)

runProperty :: Interpreter -> Expression -> IO PropertyResult
runProperty :: Interpreter -> String -> IO PropertyResult
runProperty Interpreter
repl String
expression = do
  Either String String
_ <- Interpreter -> String -> IO (Either String String)
Interpreter.safeEval Interpreter
repl String
"import Test.QuickCheck ((==>))"
  Either String String
_ <- Interpreter -> String -> IO (Either String String)
Interpreter.safeEval Interpreter
repl String
"import Test.QuickCheck.All (polyQuickCheck)"
  Either String String
_ <- Interpreter -> String -> IO (Either String String)
Interpreter.safeEval Interpreter
repl String
"import Language.Haskell.TH (mkName)"
  Either String String
_ <- Interpreter -> String -> IO (Either String String)
Interpreter.safeEval Interpreter
repl String
":set -XTemplateHaskell"
  Either String String
r <- Interpreter -> String -> IO [String]
freeVariables Interpreter
repl String
expression IO [String]
-> ([String] -> IO (Either String String))
-> IO (Either String String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
       (Interpreter -> String -> IO (Either String String)
Interpreter.safeEval Interpreter
repl (String -> IO (Either String String))
-> ([String] -> String) -> [String] -> IO (Either String String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> String
quickCheck String
expression)
  case Either String String
r of
    Left String
err -> do
      PropertyResult -> IO PropertyResult
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> PropertyResult
Error String
err)
    Right String
res
      | String
"OK, passed" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
res -> PropertyResult -> IO PropertyResult
forall (m :: * -> *) a. Monad m => a -> m a
return PropertyResult
Success
      | Bool
otherwise -> do
          let msg :: String
msg =  ShowS
stripEnd ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\b') String
res)
          PropertyResult -> IO PropertyResult
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> PropertyResult
Failure String
msg)
  where
    quickCheck :: String -> [String] -> String
quickCheck String
term [String]
vars =
      String
"let doctest_prop " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
vars String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
term String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
      String
"$(polyQuickCheck (mkName \"doctest_prop\"))"

-- | Find all free variables in given term.
--
-- GHCi is used to detect free variables.
freeVariables :: Interpreter -> String -> IO [String]
freeVariables :: Interpreter -> String -> IO [String]
freeVariables Interpreter
repl String
term = do
  Either String String
r <- Interpreter -> String -> IO (Either String String)
Interpreter.safeEval Interpreter
repl (String
":type " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
term)
  [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ((String -> [String])
-> (String -> [String]) -> Either String String -> [String]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([String] -> String -> [String]
forall a b. a -> b -> a
const []) ([String] -> [String]
forall a. Eq a => [a] -> [a]
nub ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
parseNotInScope) Either String String
r)

-- | Parse and return all variables that are not in scope from a ghc error
-- message.
parseNotInScope :: String -> [String]
parseNotInScope :: String -> [String]
parseNotInScope = [String] -> [String]
forall a. Eq a => [a] -> [a]
nub ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Maybe String) -> [String] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe String
extractVariable ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
  where
    -- | Extract variable name from a "Not in scope"-error.
    extractVariable :: String -> Maybe String
    extractVariable :: String -> Maybe String
extractVariable String
x
      | String
"Not in scope: " String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
x = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> ShowS -> String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
unquote ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ') (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
x
      | Just String
y <- ([Maybe String] -> Maybe String
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum ([Maybe String] -> Maybe String) -> [Maybe String] -> Maybe String
forall a b. (a -> b) -> a -> b
$ (String -> Maybe String) -> [String] -> [Maybe String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"Variable not in scope: ") (String -> [String]
forall a. [a] -> [[a]]
tails String
x)) = String -> Maybe String
forall a. a -> Maybe a
Just ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ') String
y)
      | Bool
otherwise = Maybe String
forall a. Maybe a
Nothing

    -- | Remove quotes from given name, if any.
    unquote :: ShowS
unquote (Char
'`':String
xs)     = ShowS
forall a. [a] -> [a]
init String
xs
    unquote (Char
'\8216':String
xs) = ShowS
forall a. [a] -> [a]
init String
xs
    unquote String
xs           = String
xs