{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
module Property (
runProperty
, PropertyResult (..)
#ifdef TEST
, freeVariables
, parseNotInScope
#endif
) where
import Data.List
import Data.Maybe
import Data.Foldable
import Util
import Interpreter (Interpreter)
import qualified Interpreter
import Parse
data PropertyResult =
Success
| Failure String
| Error String
deriving (Eq, Show)
runProperty :: Interpreter -> Expression -> IO PropertyResult
runProperty repl expression = do
_ <- Interpreter.safeEval repl "import Test.QuickCheck ((==>))"
_ <- Interpreter.safeEval repl "import Test.QuickCheck.All (polyQuickCheck)"
_ <- Interpreter.safeEval repl "import Language.Haskell.TH (mkName)"
_ <- Interpreter.safeEval repl ":set -XTemplateHaskell"
r <- freeVariables repl expression >>=
(Interpreter.safeEval repl . quickCheck expression)
case r of
Left err -> do
return (Error err)
Right res
| "OK, passed" `isInfixOf` res -> return Success
| otherwise -> do
let msg = stripEnd (takeWhileEnd (/= '\b') res)
return (Failure msg)
where
quickCheck term vars =
"let doctest_prop " ++ unwords vars ++ " = " ++ term ++ "\n" ++
"$(polyQuickCheck (mkName \"doctest_prop\"))"
freeVariables :: Interpreter -> String -> IO [String]
freeVariables repl term = do
r <- Interpreter.safeEval repl (":type " ++ term)
return (either (const []) (nub . parseNotInScope) r)
parseNotInScope :: String -> [String]
parseNotInScope = nub . mapMaybe extractVariable . lines
where
extractVariable :: String -> Maybe String
extractVariable x
| "Not in scope: " `isInfixOf` x = Just . unquote . takeWhileEnd (/= ' ') $ x
| Just y <- (asum $ map (stripPrefix "Variable not in scope: ") (tails x)) = Just (takeWhile (/= ' ') y)
| otherwise = Nothing
unquote ('`':xs) = init xs
#if __GLASGOW_HASKELL__ >= 707
unquote ('\8216':xs) = init xs
#endif
unquote xs = xs