inspection-testing 0.2.0.1 → 0.3
raw patch · 15 files changed
+327/−115 lines, 15 filesdep ~basedep ~ghcPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, ghc
API changes (from Hackage documentation)
- Test.Inspection: NoType :: Name -> Property
- Test.Inspection.Internal: KeepAlive :: KeepAlive
- Test.Inspection.Internal: data KeepAlive
- Test.Inspection.Internal: instance Data.Data.Data Test.Inspection.Internal.KeepAlive
+ Test.Inspection: NoTypeClasses :: [Name] -> Property
+ Test.Inspection: NoTypes :: [Name] -> Property
+ Test.Inspection: hasNoGenerics :: Name -> Obligation
+ Test.Inspection: hasNoTypeClasses :: Name -> Obligation
+ Test.Inspection: hasNoTypeClassesExcept :: Name -> [Name] -> Obligation
+ Test.Inspection.Core: doesNotContainTypeClasses :: Slice -> [Name] -> Maybe (Var, CoreExpr)
Files
- ChangeLog.md +10/−0
- README.md +9/−4
- Test/Inspection.hs +98/−50
- Test/Inspection/Core.hs +11/−2
- Test/Inspection/Internal.hs +0/−23
- Test/Inspection/Plugin.hs +38/−22
- Test/Inspection/TcPlugin.hs +62/−0
- examples/Dictionary.hs +37/−0
- examples/Fusion.hs +1/−1
- examples/Generics.hs +30/−0
- examples/NS_NP.hs +1/−1
- examples/Simple.hs +1/−1
- examples/SimpleTest.hs +1/−1
- examples/Text.hs +1/−1
- inspection-testing.cabal +27/−9
ChangeLog.md view
@@ -1,5 +1,15 @@ # Revision history for inspection-testing +## 0.3 -- UNRELEASED++* On GHC-8.5 or newer, use of `inspect` or `inspectTest` without actually+ loading the plugin will cause compilation to fail at type-checking time+ (thanks to @adamgundry for the idea)+* Support for `hasNoTypeClass` (thanks to @phadej)+* Support for `hasNoGenerics` (thanks to @isovector)+* No need to keep referenced variables alive using annotations:+ Simply mentioning them in a Template Haskell splice keeps them alive!+ ## 0.2.0.1 -- 2018-02-02 * Support GHC HEAD (8.5)
README.md view
@@ -75,10 +75,15 @@ Currently, inspection-testing supports - * checking two definitions to be equal (useful in the context of generic programming)- * checking the absence of a certain type (useful in the context of list or stream fusion)+ * checking two definitions to be equal (useful in the context of generic+ programming)+ * checking the absence of a certain type (useful in the context of list or+ stream fusion) * checking the absence of allocation (generally useful) +In general, the checks need to be placed in the same module as the+checked-definition.+ Possible further applications includes * checking that all recursive functions are (efficiently called) join-points@@ -87,8 +92,8 @@ Let me know if you need any of these, or have further ideas. -Help, I am drowining in Core!------------------------------+Help, I am drowning in Core!+---------------------------- inspection-testing prints the Core more or less like GHC would, and the same flags can be used to control the level of detail. In particular, you might want
Test/Inspection.hs view
@@ -11,6 +11,9 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE CPP #-} module Test.Inspection ( -- * Synopsis -- $synposis@@ -21,32 +24,33 @@ Result(..), -- * Defining obligations Obligation(..), mkObligation, Property(..),- (===), (==-), (=/=), hasNoType,+ -- * Convenience functions+ -- $convenience+ (===), (==-), (=/=), hasNoType, hasNoGenerics,+ hasNoTypeClasses, hasNoTypeClassesExcept, ) where -import Control.Monad import Language.Haskell.TH-import Language.Haskell.TH.Syntax (getQ, putQ, liftData, addTopDecls)+import Language.Haskell.TH.Syntax (Quasi(qNewName), liftData, addTopDecls)+#if MIN_VERSION_GLASGOW_HASKELL(8,5,0,0)+import Language.Haskell.TH.Syntax (getQ, putQ) -- only for needsPluginQ+#endif import Data.Data import GHC.Exts (lazy)--import Data.Maybe (fromMaybe)-import qualified Data.Set as S--import Test.Inspection.Internal+import GHC.Generics (V1(), U1(), M1(), K1(), (:+:), (:*:), (:.:), Rec1, Par1) {- $synposis To use inspection testing, you need to - 1. enable the @TemplateHaskell@ langauge extension+ 1. enable the @TemplateHaskell@ language extension 2. load the plugin using @-fplugin Test.Inspection.Plugin@ 3. declare your proof obligations using 'inspect' or 'inspectTest' An example module is @-{-\# LANGAUGE TemplateHaskell \#-}+{-\# LANGUAGE TemplateHaskell \#-} {-\# OPTIONS_GHC -O -fplugin Test.Inspection.Plugin \#-} module Simple where @@ -75,7 +79,7 @@ { target :: Name -- ^ The target of a test obligation; invariably the name of a local -- definition. To get the name of a function @foo@, write @'foo@. This requires- -- @{-\# LANGAUGE TemplateHaskell \#-}@.+ -- @{-\# LANGUAGE TemplateHaskell \#-}@. , property :: Property -- ^ The property of the target to be checked. , testName :: Maybe String@@ -100,23 +104,22 @@ -- @f = g@, or the definition of @g@ is @g = f@, or if the definitions are -- @f = e@ and @g = e@. --+ -- In general @f@ and @g@ need to be defined in this module, so that their+ -- actual defintions can be inspected.+ -- -- If the boolean flag is true, then ignore types during the comparison. = EqualTo Name Bool - -- | Does this type not occur anywhere in the definition of the function+ -- | Do none of these types anywhere in the definition of the function -- (neither locally bound nor passed as arguments)- | NoType Name+ | NoTypes [Name] -- | Does this function perform no heap allocations. | NoAllocation- deriving Data -allLocalNames :: Obligation -> [Name]-allLocalNames obl = target obl : goProp (property obl)- where- goProp :: Property -> [Name]- goProp (EqualTo n _) = [n]- goProp _ = []+ -- | Does this value contain dictionaries (/except/ of the listed classes).+ | NoTypeClasses [Name]+ deriving Data -- | Creates an inspection obligation for the given function name -- with default values for the optional fields.@@ -130,18 +133,23 @@ , storeResult = Nothing } --- | Convenience function to declare two functions to be equal+{- $convenience++These convenience functions create common test obligations directly.+-}++-- | Declare two functions to be equal (see 'EqualTo') (===) :: Name -> Name -> Obligation (===) = mkEquality False False infix 9 === --- | Convenience function to declare two functions to be equal, but ignoring--- type lambdas, type arguments and type casts+-- | Declare two functions to be equal, but ignoring+-- type lambdas, type arguments and type casts (see 'EqualTo') (==-) :: Name -> Name -> Obligation (==-) = mkEquality False True infix 9 ==- --- | Convenience function to declare two functions to be equal, but expect the test to fail+-- | Reclare two functions to be equal, but expect the test to fail (see 'EqualTo' and 'expectFail') -- (This is useful for documentation purposes, or as a TODO list.) (=/=) :: Name -> Name -> Obligation (=/=) = mkEquality True False@@ -152,21 +160,72 @@ (mkObligation n1 (EqualTo n2 ignore_types)) { expectFail = expectFail } --- | Convenience function to declare that a function’s implementation does not--- mention a type+-- | Declare that in a function’s implementation, the given type does not occur. ----- @inspect $ fusedFunction `hasNoType` ''[]@+-- More precisely: No locally bound variable (let-bound, lambda-bound or+-- pattern-bound) has a type that contains the given type constructor.+--+-- @'inspect' $ fusedFunction ``hasNoType`` ''[]@ hasNoType :: Name -> Name -> Obligation-hasNoType n tn = mkObligation n (NoType tn)+hasNoType n tn = mkObligation n (NoTypes [tn]) +-- | Declare that a function’s implementation does not contain any generic types.+-- This is just 'asNoType' applied to the usual type constructors used in+-- "GHC.Generics".+--+-- @inspect $ hasNoGenerics genericFunction@+hasNoGenerics :: Name -> Obligation+hasNoGenerics n =+ mkObligation n+ (NoTypes [ ''V1, ''U1, ''M1, ''K1, ''(:+:), ''(:*:), ''(:.:), ''Rec1+ , ''Par1+ ])++-- | Declare that a function's implementation does not include dictionaries.+--+-- More precisely: No locally bound variable (let-bound, lambda-bound or+-- pattern-bound) has a type that contains a type that mentions a type class.+--+-- @'inspect' $ 'hasNoTypeClasses' specializedFunction@+hasNoTypeClasses :: Name -> Obligation+hasNoTypeClasses n = hasNoTypeClassesExcept n []++-- | A variant of 'hasNoTypeClasses', which white-lists some type-classes.+--+-- @'inspect' $ fieldLens ``hasNoTypeClassesExcept`` [''Functor]@+hasNoTypeClassesExcept :: Name -> [Name] -> Obligation+hasNoTypeClassesExcept n tns = mkObligation n (NoTypeClasses tns)++-- | Internal class that prevents compilation when the plugin is not loaded+class PluginNotLoaded++_pretendItsUsed :: PluginNotLoaded => ()+_pretendItsUsed = ()++needsPluginQ :: Q [Dec]+#if MIN_VERSION_GLASGOW_HASKELL(8,5,0,0)+needsPluginQ = getQ >>= \case+ Just NeedsPluginInserted -> return []+ Nothing -> do+ putQ NeedsPluginInserted+ [d| needsTestInspectionPlugin :: ()+ needsTestInspectionPlugin = (() :: PluginNotLoaded => ())+ |]++-- | To ensure we insert needsPlugin only once+data NeedsPluginInserted = NeedsPluginInserted+#else+needsPluginQ = return []+#endif+ -- The exported TH functions inspectCommon :: AnnTarget -> Obligation -> Q [Dec] inspectCommon annTarget obl = do loc <- location annExpr <- liftData (obl { srcLoc = Just loc })- rememberDs <- concat <$> mapM rememberName (allLocalNames obl)- pure $ PragmaD (AnnP annTarget annExpr) : rememberDs+ np <- needsPluginQ+ pure $ np ++ [PragmaD (AnnP annTarget annExpr)] -- | As seen in the example above, the entry point to inspection testing is the -- 'inspect' function, to which you pass an 'Obligation'.@@ -192,7 +251,7 @@ inspectTest :: Obligation -> Q Exp inspectTest obl = do nameS <- genName- name <- newName nameS+ name <- newUniqueName nameS anns <- inspectCommon (ValueAnnotation name) obl addTopDecls $ [ SigD name (ConT ''Result)@@ -205,22 +264,11 @@ (r,c) <- loc_start <$> location return $ "inspect_" ++ show r ++ "_" ++ show c --- We need to ensure that names refernced in obligations are kept alive--- We do so by annotating them with 'KeepAlive'--newtype SeenNames = SeenNames (S.Set Name)---- Annotate each name only once-nameSeen :: Name -> Q Bool-nameSeen n = do- SeenNames s <- fromMaybe (SeenNames S.empty) <$> getQ- let seen = n `S.member` s- unless seen $ putQ $ SeenNames (S.insert n s)- pure seen--rememberName :: Name -> Q [Dec]-rememberName n = do- seen <- nameSeen n- if seen then return [] else do- kaExpr <- liftData KeepAlive- pure [ PragmaD (AnnP (ValueAnnotation n) kaExpr) ]+-- | 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
Test/Inspection/Core.hs view
@@ -8,6 +8,7 @@ , eqSlice , freeOfType , doesNotAllocate+ , doesNotContainTypeClasses ) where import CoreSyn@@ -22,6 +23,7 @@ import PprCore import Coercion import Util+import TyCon (TyCon, isClassTyCon) import qualified Data.Set as S import Control.Monad.State.Strict@@ -195,7 +197,10 @@ -- | Returns @True@ if the given core expression mentions no type constructor -- anywhere that has the given name. freeOfType :: Slice -> Name -> Maybe (Var, CoreExpr)-freeOfType slice tcN = listToMaybe [ (v,e) | (v,e) <- slice, not (go e) ]+freeOfType slice tcN = allTyCons (\tc -> getName tc /= tcN) slice++allTyCons :: (TyCon -> Bool) -> Slice -> Maybe (Var, CoreExpr)+allTyCons predicate slice = listToMaybe [ (v,e) | (v,e) <- slice, not (go e) ] where goV v = goT (varType v) @@ -216,7 +221,7 @@ goT (TyVarTy _) = True goT (AppTy t1 t2) = goT t1 && goT t2- goT (TyConApp tc ts) = getName tc /= tcN && all goT ts+ goT (TyConApp tc ts) = predicate tc && all goT ts -- ↑ This is the crucial bit goT (ForAllTy _ t) = goT t #if MIN_VERSION_GLASGOW_HASKELL(8,2,0,0)@@ -268,3 +273,7 @@ -- unlifted goA a (_,_, e) = go a e++doesNotContainTypeClasses :: Slice -> [Name] -> Maybe (Var, CoreExpr)+doesNotContainTypeClasses slice tcNs+ = allTyCons (\tc -> not (isClassTyCon tc) || any (getName tc ==) tcNs) slice
− Test/Inspection/Internal.hs
@@ -1,23 +0,0 @@--- |--- Description : Inspection testing--- Copyright : (c) Joachim Breitner, 2017--- License : MIT--- Maintainer : mail@joachim-breitner.de--- Portability : GHC specifc----{-# LANGUAGE DeriveDataTypeable #-}-module Test.Inspection.Internal- ( KeepAlive(..)- ) where--import Data.Data---- | An annotation to keep names alive-data KeepAlive = KeepAlive- deriving Data--{--keep_alive :: a-keep_alive = keep_alive-{-# NOINLINE keep_alive #-}--}
Test/Inspection/Plugin.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE LambdaCase #-} module Test.Inspection.Plugin (plugin) where import Control.Monad@@ -11,20 +12,22 @@ import Data.Either import Data.Maybe import Data.Bifunctor+import Data.List import qualified Data.Map.Strict as M import qualified Language.Haskell.TH.Syntax as TH import GhcPlugins hiding (SrcLoc) import Outputable -import Test.Inspection.Internal (KeepAlive(..)) import Test.Inspection (Obligation(..), Property(..), Result(..))+import Test.Inspection.TcPlugin (inspectionTcPlugin) import Test.Inspection.Core -- | The plugin. It supports the option @-fplugin-opt=Test.Inspection.Plugin:keep-going@ to -- ignore a failing build. plugin :: Plugin-plugin = defaultPlugin { installCoreToDos = install }+plugin = defaultPlugin { installCoreToDos = install+ , tcPlugin = const (Just inspectionTcPlugin) } data UponFailure = AbortCompilation | KeepGoing deriving Eq @@ -41,17 +44,9 @@ extractObligations :: ModGuts -> (ModGuts, [(ResultTarget, Obligation)]) extractObligations guts = (guts', obligations) where- (anns', obligations) = partitionMaybe findObligationAnn (mg_anns guts)- anns_clean = filter (not . isKeepAliveAnn) anns'+ (anns_clean, obligations) = partitionMaybe findObligationAnn (mg_anns guts) guts' = guts { mg_anns = anns_clean } -isKeepAliveAnn :: Annotation -> Bool-isKeepAliveAnn (Annotation (NamedTarget _) payload)- | Just KeepAlive <- fromSerialized deserializeWithData payload- = True-isKeepAliveAnn _- = False- findObligationAnn :: Annotation -> Maybe (ResultTarget, Obligation) findObligationAnn (Annotation (ModuleTarget _) payload) | Just obl <- fromSerialized deserializeWithData payload@@ -71,8 +66,11 @@ prettyProperty :: Module -> TH.Name -> Property -> String prettyProperty mod target (EqualTo n2 False) = showTHName mod target ++ " === " ++ showTHName mod n2 prettyProperty mod target (EqualTo n2 True) = showTHName mod target ++ " ==- " ++ showTHName mod n2-prettyProperty mod target (NoType t) = showTHName mod target ++ " `hasNoType` " ++ showTHName mod t+prettyProperty mod target (NoTypes [t]) = showTHName mod target ++ " `hasNoType` " ++ showTHName mod t+prettyProperty mod target (NoTypes ts) = showTHName mod target ++ " mentions none of " ++ intercalate ", " (map (showTHName mod) ts) prettyProperty mod target NoAllocation = showTHName mod target ++ " does not allocate"+prettyProperty mod target (NoTypeClasses []) = showTHName mod target ++ " does not contain dictionary values"+prettyProperty mod target (NoTypeClasses ts) = showTHName mod target ++ " does not contain dictionary values except of " ++ intercalate ", " (map (showTHName mod) ts) -- | Like show, but omit the module name if it is he current module showTHName :: Module -> TH.Name -> String@@ -150,8 +148,8 @@ checkProperty :: ModGuts -> TH.Name -> Property -> CoreM CheckResult checkProperty guts thn1 (EqualTo thn2 ignore_types) = do- Just n1 <- thNameToGhcName thn1- Just n2 <- thNameToGhcName thn2+ n1 <- fromTHName thn1+ n2 <- fromTHName thn2 let p1 = lookupNameInGuts guts n1 let p2 = lookupNameInGuts guts n2@@ -178,24 +176,24 @@ -> pure . Just $ ppr n1 <+> text " and " <+> ppr n2 <+> text "are different external names" | Nothing <- p1- -> pure . Just $ ppr n1 <+> text "is an external names"+ -> pure . Just $ ppr n1 <+> text "is an external name" | Nothing <- p2- -> pure . Just $ ppr n2 <+> text "is an external names"+ -> pure . Just $ ppr n2 <+> text "is an external name" where binds = flattenBinds (mg_binds guts) -checkProperty guts thn (NoType tht) = do- Just n <- thNameToGhcName thn- Just t <- thNameToGhcName tht+checkProperty guts thn (NoTypes thts) = do+ n <- fromTHName thn+ ts <- mapM fromTHName thts case lookupNameInGuts guts n of Nothing -> pure . Just $ ppr n <+> text "is not a local name"- Just (v, _) -> case freeOfType (slice binds v) t of+ Just (v, _) -> case msum $ map (freeOfType (slice binds v)) ts of Just _ -> pure . Just $ pprSlice (slice binds v) Nothing -> pure Nothing where binds = flattenBinds (mg_binds guts) checkProperty guts thn NoAllocation = do- Just n <- thNameToGhcName thn+ n <- fromTHName thn case lookupNameInGuts guts n of Nothing -> pure . Just $ ppr n <+> text "is not a local name" Just (v, _) -> case doesNotAllocate (slice binds v) of@@ -203,6 +201,24 @@ Nothing -> pure Nothing where binds = flattenBinds (mg_binds guts) +checkProperty guts thn (NoTypeClasses thts) = do+ n <- fromTHName thn+ ts <- mapM fromTHName thts+ case lookupNameInGuts guts n of+ Nothing -> pure . Just $ ppr n <+> text "is not a local name"+ Just (v, _) -> case doesNotContainTypeClasses (slice binds v) ts of+ Just (v',e') -> pure . Just $ nest 4 (ppr v' <+> text "=" <+> ppr e')+ Nothing -> pure Nothing+ where binds = flattenBinds (mg_binds guts)+ ++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 -> return n+ storeResults :: Updates -> ModGuts -> CoreM ModGuts storeResults = flip (foldM (flip (uncurry go))) where@@ -213,7 +229,7 @@ dcExpr :: TH.Name -> CoreM CoreExpr dcExpr thn = do- Just name <- thNameToGhcName thn+ name <- fromTHName thn dc <- lookupDataCon name pure $ Var (dataConWrapId dc)
+ Test/Inspection/TcPlugin.hs view
@@ -0,0 +1,62 @@+-- | See "Test.Inspection".+--+{-# LANGUAGE CPP #-}+module Test.Inspection.TcPlugin (inspectionTcPlugin) where++-- For the TC plugin+import Module (mkModuleName)+import OccName (mkTcOcc)+import TcEvidence+import TcPluginM+import TcRnTypes+import Class+#if MIN_VERSION_GLASGOW_HASKELL(8,5,0,0)+import MkCore+import TyCon+#endif+import Type++inspectionTcPlugin :: TcPlugin+inspectionTcPlugin =+ TcPlugin { tcPluginInit = lookupPNLTyCon+ , tcPluginSolve = solvePNL+ , tcPluginStop = const (return ())+ }++lookupPNLTyCon :: TcPluginM Class+lookupPNLTyCon = do+ Found _ md <- findImportedModule testInspectionModule Nothing+ pnlNm <- lookupOrig md (mkTcOcc "PluginNotLoaded")+ tcLookupClass pnlNm+ where+ testInspectionModule = mkModuleName "Test.Inspection"++#if MIN_VERSION_GLASGOW_HASKELL(8,5,0,0)+mkNullaryEv :: Class -> EvTerm+mkNullaryEv cls = EvExpr appDc+ where+ tyCon = classTyCon cls+ dc = tyConSingleDataCon tyCon+ appDc = mkCoreConApps dc []+# else+mkNullaryEv :: Class -> EvTerm+mkNullaryEv _ = error "Test.Inspection.TcPlugin needs GHC 8.6 or later"+#endif++findClassConstraint :: Class -> Ct -> Bool+findClassConstraint cls ct+ | Just (cls', []) <- getClassPredTys_maybe (ctPred ct)+ , cls' == cls+ = True+ | otherwise+ = False++solvePNL :: Class -- ^ PNL's TyCon+ -> [Ct] -- ^ [G]iven constraints+ -> [Ct] -- ^ [D]erived constraints+ -> [Ct] -- ^ [W]anted constraints+ -> TcPluginM TcPluginResult+solvePNL inspectionTcCls _ _ wanteds =+ return $ TcPluginOk [(mkNullaryEv inspectionTcCls, x)| x <- our_wanteds ] []+ where+ our_wanteds = filter (findClassConstraint inspectionTcCls) wanteds
+ examples/Dictionary.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-}+module Dictionary (main) where++import Test.Inspection+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad (replicateM_)+import Data.Traversable (foldMapDefault)+import Data.Semigroup (Semigroup)++putStrLn' :: MonadIO m => String -> m ()+putStrLn' = liftIO . putStrLn++action :: MonadIO m => m ()+action = replicateM_ 10 (putStrLn' "foo")++specialized :: IO ()+specialized = action++inspect $ hasNoTypeClasses 'specialized+inspect $ (hasNoTypeClasses 'action) { expectFail = True }++inspect $ hasNoTypeClassesExcept 'action [''MonadIO, ''Monad, ''Applicative, ''Functor]++listFoldMap :: Monoid m => (a -> m) -> [a] -> m+listFoldMap = foldMapDefault++#if __GLASGOW_HASKELL__ >= 802+inspect $ hasNoTypeClassesExcept 'listFoldMap [''Monoid, ''Semigroup]+#else+inspect $ (hasNoTypeClassesExcept 'listFoldMap [''Monoid, ''Semigroup]) { expectFail = True }+#endif+++main :: IO ()+main = return ()
examples/Fusion.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-}-module Fusion where+module Fusion (main) where import Test.Inspection import Data.List (foldl', sort)
+ examples/Generics.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE DeriveGeneric, TemplateHaskell #-}+{-# OPTIONS_GHC -fplugin=Test.Inspection.Plugin #-}+module Generics (main) where++import GHC.Generics+import Test.Inspection++data Record = MkRecord+ { fieldA :: Int+ , fieldB :: Bool+ } deriving Generic+++myRecord :: Record+myRecord = MkRecord 1 True++genericRep :: Rep Record x+genericRep = from myRecord+++roundTripRep :: Record+roundTripRep = to $ from myRecord++main :: IO ()+main = return ()++-- the check+inspect $ hasNoGenerics 'roundTripRep+inspect $ (hasNoGenerics 'genericRep) { expectFail = True }+
examples/NS_NP.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -O #-} {-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-}-module NS_NP where+module NS_NP (main) where import Test.Inspection
examples/Simple.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -O -fplugin Test.Inspection.Plugin #-}-module Simple where+module Simple (main) where import Test.Inspection import Data.Maybe
examples/SimpleTest.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -O -fplugin=Test.Inspection.Plugin #-}-module Main where+module Main (main) where import Test.Inspection import Data.Maybe
examples/Text.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-}-module Text where+module Text (main) where import Test.Inspection
inspection-testing.cabal view
@@ -1,5 +1,5 @@ name: inspection-testing-version: 0.2.0.1+version: 0.3 synopsis: GHC plugin to do inspection testing description: Some carefully crafted libraries make promises to their users beyond functionality and performance.@@ -43,9 +43,9 @@ library exposed-modules: Test.Inspection Test.Inspection.Plugin- Test.Inspection.Internal Test.Inspection.Core- build-depends: base >=4.9 && <4.12+ other-modules: Test.Inspection.TcPlugin+ build-depends: base >=4.9 && <4.13 build-depends: ghc >= 8.0.2 && <8.6 build-depends: template-haskell build-depends: containers@@ -59,7 +59,7 @@ hs-source-dirs: examples main-is: NS_NP.hs build-depends: inspection-testing- build-depends: base >=4.9 && <4.12+ build-depends: base >=4.9 && <4.13 default-language: Haskell2010 ghc-options: -main-is NS_NP @@ -69,7 +69,7 @@ hs-source-dirs: examples main-is: Simple.hs build-depends: inspection-testing- build-depends: base >=4.9 && <4.12+ build-depends: base >=4.9 && <4.13 default-language: Haskell2010 ghc-options: -main-is Simple @@ -78,7 +78,7 @@ hs-source-dirs: examples main-is: SimpleTest.hs build-depends: inspection-testing- build-depends: base >=4.9 && <4.12+ build-depends: base >=4.9 && <4.13 default-language: Haskell2010 test-suite fusion@@ -86,10 +86,28 @@ hs-source-dirs: examples main-is: Fusion.hs build-depends: inspection-testing- build-depends: base >=4.9 && <4.12+ build-depends: base >=4.9 && <4.13 default-language: Haskell2010 ghc-options: -main-is Fusion +test-suite generics+ type: exitcode-stdio-1.0+ hs-source-dirs: examples+ main-is: Generics.hs+ build-depends: inspection-testing+ build-depends: base >=4.9 && <4.13+ default-language: Haskell2010+ ghc-options: -main-is Generics++test-suite dictionary+ type: exitcode-stdio-1.0+ hs-source-dirs: examples+ main-is: Dictionary.hs+ build-depends: inspection-testing+ build-depends: base >=4.9 && <4.13+ default-language: Haskell2010+ ghc-options: -main-is Dictionary+ flag more-tests description: Run tests that pull in specific versions of other packages default: False@@ -100,7 +118,7 @@ main-is: Text.hs if flag(more-tests) build-depends: inspection-testing- build-depends: base >=4.9 && <4.12+ build-depends: base >=4.9 && <4.13 build-depends: text ==1.2.2.2 build-depends: bytestring else@@ -114,7 +132,7 @@ main-is: GenericLens.hs if flag(more-tests) build-depends: inspection-testing- build-depends: base >=4.9 && <4.12+ build-depends: base >=4.9 && <4.13 build-depends: generic-lens ==0.4.1.0 else buildable: False