tasty-inspection-testing (empty) → 0.1
raw patch · 7 files changed
+378/−0 lines, 7 filesdep +basedep +ghcdep +inspection-testing
Dependencies added: base, ghc, inspection-testing, tasty, template-haskell
Files
- LICENSE +20/−0
- README.md +24/−0
- changelog.md +3/−0
- src/Test/Tasty/Inspection.hs +158/−0
- src/Test/Tasty/Inspection/Internal.hs +24/−0
- src/Test/Tasty/Inspection/Plugin.hs +113/−0
- tasty-inspection-testing.cabal +36/−0
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2017 Joachim Breitner, 2021 Andrew Lelechenko++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,24 @@+# tasty-inspection-tasting++Integrate [`inspection-testing`](http://hackage.haskell.org/package/inspection-testing)+into [`tasty`](http://hackage.haskell.org/package/tasty) test suites.++```haskell+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -O -dsuppress-all -dno-suppress-type-signatures -fplugin=Test.Tasty.Inspection.Plugin #-}++import Test.Tasty+import Test.Tasty.Inspection++lhs :: (a -> b) -> Maybe a -> Bool+lhs f x = case fmap f x of+ Nothing -> True+ Just{} -> False++rhs :: (a -> b) -> Maybe a -> Bool+rhs _ Nothing = True+rhs _ Just{} = False++main :: IO ()+main = defaultMain $(inspectTest $ 'lhs === 'rhs)+```
+ changelog.md view
@@ -0,0 +1,3 @@+# 0.1++* Initial release.
+ src/Test/Tasty/Inspection.hs view
@@ -0,0 +1,158 @@+-- |+-- Module: Test.Tasty.Inspection+-- Copyright: (c) 2017 Joachim Breitner, 2021 Andrew Lelechenko+-- Licence: MIT+-- Maintainer: andrew.lelechenko@gmail.com+--+-- Integrate @inspection-testing@ into @tasty@ test suites.+--++{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++module Test.Tasty.Inspection+ ( inspectTest+ , inspectObligations+ , inspectNames+ -- * Obligations+ -- | Mostly reexported from "Test.Inspection".+ , Obligation(testName)+ , mkObligation+ , Property(..)+ , (===)+ , (==-)+ , hasNoType+ , hasNoTypes+ , hasNoGenerics+ , hasNoTypeClasses+ , hasNoTypeClassesExcept+ , doesNotUse+ , doesNotUseAnyOf+ , coreOf+ ) where++import GHC.Exts (lazy)+import Language.Haskell.TH (Q, Dec(..), Exp(..), Lit(..), Phases(..), RuleMatch(..), Inline(..), Pragma(..), Body(..), Pat(..), Type(..), AnnTarget(..), Name, loc_start, location)+import Language.Haskell.TH.Syntax (Quasi(qNewName), liftData, addTopDecls, Name(..), occString)+#if MIN_VERSION_GLASGOW_HASKELL(8,4,0,0)+import Language.Haskell.TH.Syntax (addCorePlugin)+#endif++import Test.Tasty.Runners (TestTree(..))+import Test.Inspection (Obligation(..), testName, mkObligation, Property(..), (===), (==-), hasNoType, hasNoGenerics, hasNoTypeClasses, hasNoTypeClassesExcept, doesNotUse, coreOf)+import Test.Inspection.Plugin (prettyProperty)+import Test.Tasty.Inspection.Internal (CheckResult)++didNotRunPluginError :: a+didNotRunPluginError = lazy (error "Test.Tasty.Inspection.Plugin did not run")+{-# NOINLINE didNotRunPluginError #-}++-- | Create a @tasty@ 'TestTree' from an 'Obligation':+--+-- > {-# LANGUAGE TemplateHaskell #-}+-- > {-# OPTIONS_GHC -O -dsuppress-all -dno-suppress-type-signatures -fplugin=Test.Tasty.Inspection.Plugin #-}+-- >+-- > import Test.Tasty+-- > import Test.Tasty.Inspection+-- >+-- > lhs :: (a -> b) -> Maybe a -> Bool+-- > lhs f x = case fmap f x of+-- > Nothing -> True+-- > Just{} -> False+-- >+-- > rhs :: (a -> b) -> Maybe a -> Bool+-- > rhs _ Nothing = True+-- > rhs _ Just{} = False+-- >+-- > main :: IO ()+-- > main = defaultMain $(inspectTest $ 'lhs === 'rhs)+--+-- This is not the same function as 'Test.Inspection.inspectTest':+-- both return 'Q' 'Exp', but this one represents 'TestTree'+-- instead of 'Test.Inspection.Result'.+--+-- If you are unhappy with an autogenerated test name,+-- amend it using 'testName':+--+-- > inspectTest (obl { testName = Just "foo" })+--+-- To invert an obligation apply 'Test.Tasty.ExpectedFailure.expectFail'.+--+inspectTest :: Obligation -> Q Exp+inspectTest obl = do+#if MIN_VERSION_GLASGOW_HASKELL(8,4,0,0)+ addCorePlugin "Test.Tasty.Inspection.Plugin"+#endif+ nameS <- genName+ name <- newUniqueName nameS+ annExpr <- liftData obl+ addTopDecls $+ [ SigD name (ConT ''CheckResult)+ , ValD (VarP name) (NormalB (VarE 'didNotRunPluginError)) []+ , PragmaD (InlineP name NoInline FunLike AllPhases)+ , PragmaD (AnnP (ValueAnnotation name) annExpr)+ ]+ pure $+ AppE (AppE (ConE 'SingleTest) (LitE (StringL (prettyObligation obl)))) (VarE name)+ where+ genName = do+ (r, c) <- loc_start <$> location+ pure $ "inspect_" ++ show r ++ "_" ++ show c++prettyObligation :: Obligation -> String+prettyObligation Obligation{..} = case testName of+ Just n -> n+ Nothing -> prettyProperty showTHName target property++showTHName :: Name -> String+showTHName (Name occ _) = occString occ++-- | Like newName, but even more unique (unique across different splices),+-- and with unique @nameBase@s. Precondition: the string is a valid Haskell+-- alphanumeric identifier (could be upper- or lower-case).+newUniqueName :: Quasi q => String -> q Name+newUniqueName str = do+ n <- qNewName str+ qNewName $ show n+-- This is from https://ghc.haskell.org/trac/ghc/ticket/13054#comment:1++-- | Declare that given types do not occur in a function’s implementation.+hasNoTypes :: Name -> [Name] -> Obligation+hasNoTypes n ts = mkObligation n (NoTypes ts)++-- | Declare that given entities do not occur in a function’s implementation.+doesNotUseAnyOf :: Name -> [Name] -> Obligation+doesNotUseAnyOf n ns = mkObligation n (NoUseOf ns)++-- | Create a @tasty@ 'TestTree', which tests several 'Obligation's+-- for the same 'Name', generating a 'Test.Tasty.testGroup'.+inspectObligations :: [Name -> Obligation] -> Name -> Q Exp+inspectObligations obls name = do+ exps <- traverse (inspectTest . inscribeTestName . ($ name)) obls+ pure $ AppE (AppE (ConE 'TestGroup) (LitE (StringL (showTHName name)))) (ListE exps)+ where+ showTHName' n = if n == name then mempty else showTHName n+ inscribeTestName obl@Obligation{..} = case testName of+ Just{} -> obl+ Nothing -> obl { testName = Just $ dropWhile (== ' ') $+ prettyProperty showTHName' target property }++-- | Create a @tasty@ 'TestTree', which tests an 'Obligation'+-- for several 'Name's, generating a 'Test.Tasty.testGroup'.+inspectNames :: (Name -> Obligation) -> [Name] -> Q Exp+inspectNames _ [] =+ pure $ AppE (AppE (ConE 'TestGroup) (LitE (StringL "<empty>"))) (ListE [])+inspectNames obl names@(name : _) = do+ exps <- traverse (\n -> inspectTest $ forceTestName n $ obl n) names+ pure $ AppE (AppE (ConE 'TestGroup) (LitE (StringL groupName))) (ListE exps)+ where+ forceTestName n o = case testName o of+ Just{} -> o+ Nothing -> o { testName = Just $ showTHName n }+ showTHName' n = if n == name then mempty else showTHName n+ firstObl = obl name+ groupName = case testName firstObl of+ Just n -> n+ Nothing -> dropWhile (== ' ') $+ prettyProperty showTHName' (target firstObl) (property firstObl)
+ src/Test/Tasty/Inspection/Internal.hs view
@@ -0,0 +1,24 @@+-- |+-- Module: Test.Tasty.Inspection.Internal+-- Copyright: (c) 2017 Joachim Breitner, 2021 Andrew Lelechenko+-- Licence: MIT+-- Maintainer: andrew.lelechenko@gmail.com+--++{-# LANGUAGE LambdaCase #-}++module Test.Tasty.Inspection.Internal (CheckResult(..)) where++import Test.Tasty.Providers (IsTest(..), testPassed, testFailed)++data CheckResult+ = ResSuccess+ | ResSuccessWithMessage String+ | ResFailure String++instance IsTest CheckResult where+ run = const $ const . pure . \case+ ResSuccess -> testPassed ""+ ResSuccessWithMessage msg -> testPassed msg+ ResFailure msg -> testFailed msg+ testOptions = pure []
+ src/Test/Tasty/Inspection/Plugin.hs view
@@ -0,0 +1,113 @@+-- |+-- Module: Test.Tasty.Inspection.Plugin+-- Copyright: (c) 2017 Joachim Breitner, 2021 Andrew Lelechenko+-- Licence: MIT+-- Maintainer: andrew.lelechenko@gmail.com+--+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}++module Test.Tasty.Inspection.Plugin (plugin) where++import Control.Monad (when, foldM)+import qualified Language.Haskell.TH.Syntax as TH+import System.Exit (exitFailure)++#if MIN_VERSION_ghc(9,0,0)+import GHC.Plugins+#else+import GhcPlugins+#endif++#if MIN_VERSION_ghc(9,2,0)+import GHC.Types.TyThing+#endif++import Test.Inspection (Obligation(..))+import qualified Test.Inspection.Plugin as P (checkProperty, CheckResult(..))+import Test.Tasty.Inspection.Internal (CheckResult(..))++-- | The plugin for inspection testing.+-- You normally do not need to touch it yourself,+-- 'Test.Tasty.Inspection.inspectTest' will enable it automatically.+plugin :: Plugin+plugin = defaultPlugin+ { installCoreToDos = install+#if __GLASGOW_HASKELL__ >= 806+ , pluginRecompile = \_args -> pure NoForceRecompile+#endif+ }++install :: a -> [CoreToDo] -> CoreM [CoreToDo]+install = const $ \passes -> pure $ passes +++ [CoreDoPluginPass "Test.Tasty.Inspection.Plugin" proofPass]++extractObligations :: ModGuts -> (ModGuts, [(Name, Obligation)])+extractObligations guts = (guts { mg_anns = anns_clean }, obligations)+ where+ (anns_clean, obligations) = partitionMaybe findObligationAnn (mg_anns guts)++findObligationAnn :: Annotation -> Maybe (Name, Obligation)+findObligationAnn (Annotation (NamedTarget n) payload) =+ (n,) <$> fromSerialized deserializeWithData payload+findObligationAnn _ = Nothing++checkObligation :: ModGuts -> (Name, Obligation) -> CoreM ModGuts+checkObligation guts (name, obl) = do+ res <- P.checkProperty guts (target obl) (property obl)+ e <- resultToExpr res+ pure $ updateNameInGuts name e guts++updateNameInGuts :: Name -> CoreExpr -> ModGuts -> ModGuts+updateNameInGuts n expr guts =+ guts {mg_binds = map (updateNameInGut n expr) (mg_binds guts) }++updateNameInGut :: Name -> CoreExpr -> CoreBind -> CoreBind+updateNameInGut n e = \case+ NonRec v _+ | getName v == n -> NonRec v e+ bind -> bind++fromTHName :: TH.Name -> CoreM Name+fromTHName thn = thNameToGhcName thn >>= \case+ Nothing -> do+ errorMsg $ text "Could not resolve TH name" <+> text (show thn)+ liftIO $ exitFailure -- kill the compiler. Is there a nicer way?+ Just n -> pure n++dcExpr :: TH.Name -> CoreM CoreExpr+dcExpr thn = do+ name <- fromTHName thn+ dc <- lookupDataCon name+ pure $ Var (dataConWrapId dc)++resultToExpr :: P.CheckResult -> CoreM CoreExpr+resultToExpr P.ResSuccess =+ dcExpr 'ResSuccess+resultToExpr (P.ResSuccessWithMessage sdoc) = do+ dflags <- getDynFlags+ App <$> dcExpr 'ResSuccessWithMessage <*> mkStringExpr (showSDoc dflags sdoc)+resultToExpr (P.ResFailure sdoc) = do+ dflags <- getDynFlags+ App <$> dcExpr 'ResFailure <*> mkStringExpr (showSDoc dflags sdoc)++proofPass :: ModGuts -> CoreM ModGuts+proofPass guts = do+ dflags <- getDynFlags+ when (optLevel dflags < 1) $ warnMsg+#if MIN_VERSION_GLASGOW_HASKELL(8,9,0,0)+ NoReason+#endif+ $ fsep $ map text+ $ words "Test.Inspection: Compilation without -O detected. Expect optimizations to fail."+ uncurry (foldM checkObligation) (extractObligations guts)++partitionMaybe :: (a -> Maybe b) -> [a] -> ([a], [b])+partitionMaybe f = foldr go ([], [])+ where+ go a (l, r) = case f a of+ Nothing -> (a : l, r)+ Just b -> (l, b : r)
+ tasty-inspection-testing.cabal view
@@ -0,0 +1,36 @@+name: tasty-inspection-testing+version: 0.1+cabal-version: 1.18+build-type: Simple+license: MIT+license-file: LICENSE+copyright: 2017 Joachim Breitner, 2021 Andrew Lelechenko+maintainer: Andrew Lelechenko <andrew.lelechenko@gmail.com>+homepage: https://github.com/Bodigrim/tasty-inspection-testing+bug-reports: https://github.com/Bodigrim/tasty-inspection-testing/issues+category: Testing+synopsis: Inspection testing support for tasty+description: Integrate @inspection-testing@ into @tasty@ test suites.++extra-source-files:+ changelog.md+ README.md++tested-with: GHC==9.0.1, GHC==8.10.4, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2++source-repository head+ type: git+ location: https://github.com/Bodigrim/tasty-inspection-testing++library+ exposed-modules: Test.Tasty.Inspection+ Test.Tasty.Inspection.Plugin+ other-modules: Test.Tasty.Inspection.Internal+ build-depends: base < 5,+ ghc,+ inspection-testing >= 0.4.5 && < 0.5,+ tasty,+ template-haskell+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall