diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/Test/Inspection.hs b/Test/Inspection.hs --- a/Test/Inspection.hs +++ b/Test/Inspection.hs @@ -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 diff --git a/Test/Inspection/Core.hs b/Test/Inspection/Core.hs --- a/Test/Inspection/Core.hs +++ b/Test/Inspection/Core.hs @@ -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 diff --git a/Test/Inspection/Internal.hs b/Test/Inspection/Internal.hs deleted file mode 100644 --- a/Test/Inspection/Internal.hs +++ /dev/null @@ -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 #-} --} diff --git a/Test/Inspection/Plugin.hs b/Test/Inspection/Plugin.hs --- a/Test/Inspection/Plugin.hs +++ b/Test/Inspection/Plugin.hs @@ -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) diff --git a/Test/Inspection/TcPlugin.hs b/Test/Inspection/TcPlugin.hs new file mode 100644 --- /dev/null +++ b/Test/Inspection/TcPlugin.hs @@ -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 diff --git a/examples/Dictionary.hs b/examples/Dictionary.hs new file mode 100644 --- /dev/null +++ b/examples/Dictionary.hs @@ -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 () diff --git a/examples/Fusion.hs b/examples/Fusion.hs --- a/examples/Fusion.hs +++ b/examples/Fusion.hs @@ -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) diff --git a/examples/Generics.hs b/examples/Generics.hs new file mode 100644 --- /dev/null +++ b/examples/Generics.hs @@ -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 } + diff --git a/examples/NS_NP.hs b/examples/NS_NP.hs --- a/examples/NS_NP.hs +++ b/examples/NS_NP.hs @@ -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 diff --git a/examples/Simple.hs b/examples/Simple.hs --- a/examples/Simple.hs +++ b/examples/Simple.hs @@ -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 diff --git a/examples/SimpleTest.hs b/examples/SimpleTest.hs --- a/examples/SimpleTest.hs +++ b/examples/SimpleTest.hs @@ -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 diff --git a/examples/Text.hs b/examples/Text.hs --- a/examples/Text.hs +++ b/examples/Text.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-} -module Text where +module Text (main) where import Test.Inspection diff --git a/inspection-testing.cabal b/inspection-testing.cabal --- a/inspection-testing.cabal +++ b/inspection-testing.cabal @@ -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