master protect from lost imports of modules with defined CallSpecs

Author: yaitskov

quick-process.cabal

@@ -323,6 +323,7 @@ library
     System.Process.Quick.CallSpec.Subcases
     System.Process.Quick.CallSpec.Type
     System.Process.Quick.CallSpec.Verify
+    System.Process.Quick.CallSpec.Verify.ImportOverlook
     System.Process.Quick.CallSpec.Verify.Sandbox
     System.Process.Quick.CallSpec.Verify.TrailingHelp
     System.Process.Quick.CallSpec.Verify.Type

quick-process.cabal.template

@@ -112,6 +112,7 @@ library
     System.Process.Quick.CallSpec.Subcases
     System.Process.Quick.CallSpec.Type
     System.Process.Quick.CallSpec.Verify
+    System.Process.Quick.CallSpec.Verify.ImportOverlook
     System.Process.Quick.CallSpec.Verify.Sandbox
     System.Process.Quick.CallSpec.Verify.TrailingHelp
     System.Process.Quick.CallSpec.Verify.Type

src/System/Process/Quick/CallSpec.hs

@@ -15,9 +15,11 @@ import Language.Haskell.TH.Syntax qualified as THS
 import System.Directory
 import System.Process.Quick.CallArgument
 import System.Process.Quick.CallSpec.Type as E
+import System.Process.Quick.CallSpec.Verify.ImportOverlook
 import System.Process.Quick.Prelude
 import Text.Casing
 import Text.Regex
+import System.Process.Quick.Util
 
 type FoldrConstr l a = (HFoldr (Mapcar (Fun CallArgumentGen (QR a))) [QR a] l [QR a])
 
@@ -72,10 +74,13 @@ genCallSpec ::
   [VerificationMethod] -> String -> HList l -> Q [Dec]
 genCallSpec verMethods progName l = do
   runIO . whenNothingM_ (findExecutable progName) . fail $ "Program " <> show progName <> " is not found"
-  maybe err (g . mkName') (programNameToHsIdentifier progName)
+  pkgName <- loc_module <$> location
+  addCompiledCallSpec (ConT . mkName . joinNe pkgName '.' $ toList csBaseName)
+  go $ mkName' csBaseName
   where
-    err = fail $ "Call spec name is bad: " <> show progName <> " " <> show l
-    g recName = do
+    csBaseName = maybe err id (programNameToHsIdentifier progName)
+    err = error $ "Call spec name is bad: " <> show progName <> " " <> show l
+    go recName = do
       (a, w) <- runWriterT . unQR $ sequence
         [ genCallArgsRecord recName l
         , genCallSpecInstance verMethods recName progName l

src/System/Process/Quick/CallSpec/Verify.hs

@@ -5,7 +5,7 @@ import Data.Map qualified as M
 import Data.Multimap.Table (row, rowKeys, rowKeysSet)
 import Data.Set (findMin)
 import Data.Text.Lazy qualified as LT
-import Data.Typeable ( TypeRep )
+import System.Process.Quick.CallSpec.Verify.ImportOverlook
 import Language.Haskell.TH.Syntax
 import System.Process.Quick.CallSpec
 import System.Process.Quick.CallSpec.Verify.Sandbox
@@ -115,7 +115,10 @@ discoverAndVerifyCallSpecs activeVerMethods iterations = do
   outArgLocators <- extractInstanceType <$> reifyInstances ''RefinedOutArgLocator [VarT (mkName "c")]
   when (outArgLocators == []) $ putStrLn "Discovered 0 OutArg locators!!!"
   ts <- extractInstanceType <$> reifyInstances ''CallSpec [VarT (mkName "a")]
-  when (ts == []) $ putStrLn "Discovered 0 types with CallSpec instance!!!"
+  when (ts == []) $ fail "Discovered 0 types with CallSpec instance!!!"
+  overlookedCss <- verifyFoundCsCoverCompiledOnes ts
+  when (overlookedCss /= mempty) . fail . toString . displayT . renderOneLine $
+    "Overlooked CallSpecs: " <> pretty overlookedCss
   !r <- [| void $ runStateT (
              fmap concat
                (sequence $(ListE <$> (mapM (genCsVerification

src/System/Process/Quick/CallSpec/Verify/ImportOverlook.hs

@@ -0,0 +1,29 @@
+module System.Process.Quick.CallSpec.Verify.ImportOverlook
+  ( addCompiledCallSpec
+  , verifyFoundCsCoverCompiledOnes
+  ) where
+
+import Data.Set ( (\\), insert )
+import Language.Haskell.TH ( Type, Name, nameModule, nameBase, mkName )
+import System.Process.Quick.Prelude hiding (Type)
+import System.Process.Quick.Util
+
+erasePackage :: Type -> Type
+erasePackage t = gmapT go t
+  where
+    go :: forall x. (Data x) => x -> x
+    go x | Just Refl <- eqT @x @Name =
+             mkName $ joinNe (fromMaybe "" $ nameModule x) '.' (nameBase x)
+         | otherwise = x
+
+compiledCallSpecs :: IORef (Set Type)
+compiledCallSpecs = unsafePerformIO $ newIORef mempty
+
+addCompiledCallSpec :: MonadIO m => Type -> m ()
+addCompiledCallSpec xt = atomicModifyIORef'_ compiledCallSpecs $ $(tw "/") . insert (erasePackage xt)
+
+verifyFoundCsCoverCompiledOnes :: MonadIO m => [Type] -> m (Set Type)
+verifyFoundCsCoverCompiledOnes found =
+  (\\ fromList found') <$> readIORef compiledCallSpecs
+  where
+    found' =  erasePackage <$> found

src/System/Process/Quick/CallSpec/Verify/Sandbox.hs

@@ -1,6 +1,5 @@
 module System.Process.Quick.CallSpec.Verify.Sandbox where
 
-import Control.Monad.Writer.Strict (execWriterT, WriterT)
 import Data.Conduit (runConduitRes, (.|))
 import Data.Conduit.Find as F
 import Data.Conduit.List qualified as DCL

src/System/Process/Quick/CallSpec/Verify/Type.hs

@@ -2,7 +2,6 @@
 module System.Process.Quick.CallSpec.Verify.Type where
 
 import Data.Multimap.Table ( Table )
-import Data.Typeable ( TypeRep )
 import Generic.Data ( gmappend, gmempty )
 import Prelude (show)
 import System.Process.Quick.CallEffect (CallEffect)

src/System/Process/Quick/Predicate/InDir.hs

@@ -5,7 +5,6 @@ import System.Process.Quick.Predicate
 import System.Process.Quick.Predicate.InFile ( genFilePathBy )
 import System.Process.Quick.Prelude
 import Text.Regex.TDFA ((=~))
-import Type.Reflection ((:~:)(Refl))
 
 data InDir deriving (Data, Show, Eq, Generic)
 

src/System/Process/Quick/Predicate/InFile.hs

@@ -1,14 +1,12 @@
 module System.Process.Quick.Predicate.InFile where
 
-import Control.Monad.Writer.Strict
 import System.Process.Quick.Predicate
 import System.Process.Quick.Prelude
 import System.Process.Quick.TdfaToSbvRegex as P
 import System.Process.Quick.Sbv.Arbitrary
 import System.Process.Quick.CallArgument (NeList)
 import Text.Regex.TDFA ((=~))
 import Type.Reflection qualified as R
-import Type.Reflection ((:~:)(Refl))
 
 
 data InFile (ext :: Symbol) deriving (Data, Show, Eq, Generic)

src/System/Process/Quick/Prelude.hs

@@ -1,24 +1,26 @@
 {-# OPTIONS_HADDOCK hide #-}
 module System.Process.Quick.Prelude (module M, liftIO1) where
 
+import Control.Monad.Writer.Strict as M (MonadWriter (tell), WriterT, execWriterT)
 import Control.Exception.Safe as M (MonadMask, MonadCatch, bracket, tryIO, try, tryAny, throw)
 import Control.Lens as M (Lens', at, (^.), (.~), (%~), _1, _2)
 import Control.Monad.Time as M (MonadTime(..))
 import Data.Char as M (isAlphaNum, isAlpha, isLetter, isLower, toLower)
-import Data.Data as M (Data, gmapM)
+import Data.Data as M (Data, gmapM, gmapT)
 import Data.Generics.Labels as M ()
 import Data.HList as M (typeRep)
 import Data.List as M (isSuffixOf)
 import Data.Set as M (member)
 import Data.Time.Clock as M (NominalDiffTime, diffUTCTime)
-import Data.Typeable as M (eqT)
+import Data.Typeable as M (TypeRep, eqT, (:~:) (Refl))
 import Debug.TraceEmbrace as M (tr, tw)
 import Generic.Random as M (genericArbitraryU)
 import GHC.TypeLits as M (Symbol, KnownSymbol (..), symbolVal)
 import Refined as M (Refined, unrefine, refine, Predicate (..), throwRefineOtherException)
 import Relude as M hiding (Predicate)
 import Relude.Extra as M (toPairs)
 import System.Exit as M (ExitCode (..))
+import System.IO.Unsafe as M (unsafePerformIO)
 import System.Process as M (ProcessHandle, CreateProcess (..), readCreateProcess, readCreateProcessWithExitCode)
 import System.Process.Quick.Pretty as M
 import Test.QuickCheck as M (Gen, Arbitrary (..), generate, chooseInt, sized, elements, listOf)