Cabal-tests/tests/NoThunks.hs

   1 {-# LANGUAGE CPP                 #-}
   2 #if !(__GLASGOW_HASKELL__ >= 806 && defined(MIN_VERSION_nothunks))
   3 module Main (main) where
   4 main :: IO ()
   5 main = putStrLn "Old GHC, no nothunks"
   6 #else
   7
   8 {-# LANGUAGE DerivingVia         #-}
   9 {-# LANGUAGE LambdaCase          #-}
  10 {-# LANGUAGE ScopedTypeVariables #-}
  11 {-# LANGUAGE StandaloneDeriving  #-}
  12 {-# OPTIONS_GHC -Wno-orphans #-}
  13 module Main (main) where
  14
  15 import Control.Applicative                    ((<|>))
  16 import Data.Foldable                          (toList)
  17 import Data.Proxy                             (Proxy (..))
  18 import Data.Typeable                          (Typeable, typeRep)
  19 import Distribution.CabalSpecVersion          (CabalSpecVersion)
  20 import Distribution.Compat.NonEmptySet        (NonEmptySet)
  21 import Distribution.Compiler                  (CompilerFlavor, PerCompilerFlavor)
  22 import Distribution.Fields                    (runParseResult)
  23 import Distribution.ModuleName                (ModuleName)
  24 import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)
  25 import Distribution.SPDX                      (License, LicenseExceptionId, LicenseExpression, LicenseId, LicenseRef, SimpleLicenseExpression)
  26 import Distribution.System                    (Arch, OS)
  27 import Distribution.Utils.Path                (SymbolicPathX)
  28 import Distribution.Utils.ShortText           (ShortText)
  29 import Distribution.Version                   (Version, VersionRange)
  30 import Language.Haskell.Extension             (Extension, KnownExtension, Language)
  31 import NoThunks.Class                         (NoThunks (..), OnlyCheckWhnf (..), noThunksInValues)
  32 import Test.Tasty                             (defaultMain, testGroup)
  33 import Test.Tasty.HUnit                       (assertFailure, testCase)
  34
  35 import Distribution.PackageDescription
  36
  37 import qualified Data.ByteString      as BS
  38 import qualified Distribution.License as License
  39
  40 main :: IO ()
  41 main = defaultMain $ testGroup "nothunks"
  42     [ testCase "parsing Cabal.cabal" noThunksParse
  43     ]
  44
  45 noThunksParse :: IO ()
  46 noThunksParse = do
  47     bs <- BS.readFile "Cabal/Cabal.cabal" <|> BS.readFile "../Cabal/Cabal.cabal"
  48     let res = parseGenericPackageDescription bs
  49     gpd <- either (assertFailure . show) return $ snd $
  50         runParseResult res
  51
  52     noThunks [] gpd >>= \case
  53         -- ok
  54         Nothing -> return ()
  55
  56         -- found thunk
  57         Just info -> assertFailure $ "Thunk in " ++ show info
  58
  59 -------------------------------------------------------------------------------
  60 -- NoThunks instances
  61 -------------------------------------------------------------------------------
  62
  63 instance NoThunks Arch
  64 instance NoThunks Benchmark
  65 instance NoThunks BenchmarkInterface
  66 instance NoThunks BenchmarkType
  67 instance NoThunks BuildInfo
  68 instance NoThunks BuildType
  69 instance NoThunks CabalSpecVersion
  70 instance NoThunks CompilerFlavor
  71 instance NoThunks ConfVar
  72 instance NoThunks Dependency
  73 instance NoThunks Executable
  74 instance NoThunks ExecutableScope
  75 instance NoThunks FlagName
  76 instance NoThunks ForeignLib
  77 instance NoThunks ForeignLibOption
  78 instance NoThunks ModuleReexport
  79 instance NoThunks LibraryVisibility
  80 instance NoThunks ForeignLibType
  81 instance NoThunks GenericPackageDescription
  82 instance NoThunks KnownRepoType
  83 instance NoThunks Library
  84 instance NoThunks LibraryName
  85 instance NoThunks Mixin
  86 instance NoThunks License
  87 instance NoThunks License.License
  88 instance NoThunks LicenseExpression
  89 instance NoThunks LicenseRef
  90 instance NoThunks ModuleName
  91 instance NoThunks OS
  92 instance NoThunks PackageDescription
  93 instance NoThunks PackageFlag
  94 instance NoThunks PackageIdentifier
  95 instance NoThunks PackageName
  96 instance NoThunks LegacyExeDependency
  97 instance NoThunks ExeDependency
  98 instance NoThunks PkgconfigName
  99 instance NoThunks PkgconfigDependency
 100 instance NoThunks PkgconfigVersion
 101 instance NoThunks PkgconfigVersionRange
 102 instance NoThunks LibVersionInfo
 103 instance NoThunks RepoKind
 104 instance NoThunks RepoType
 105 instance NoThunks Extension
 106 instance NoThunks Language
 107 instance NoThunks SetupBuildInfo
 108 instance NoThunks SimpleLicenseExpression
 109 instance NoThunks KnownExtension
 110 instance NoThunks SourceRepo
 111 instance NoThunks IncludeRenaming
 112 instance NoThunks ModuleRenaming
 113 instance NoThunks TestSuite
 114 instance NoThunks TestSuiteInterface
 115 instance NoThunks TestType
 116 instance NoThunks UnqualComponentName
 117 instance NoThunks Version
 118 instance NoThunks VersionRange
 119
 120 instance NoThunks ShortText where
 121
 122 instance NoThunks a => NoThunks (PerCompilerFlavor a)
 123
 124 instance (Typeable allowAbs, Typeable from, Typeable to)
 125        => NoThunks (SymbolicPathX allowAbs from to)
 126
 127 deriving via (OnlyCheckWhnf LicenseId) instance NoThunks LicenseId
 128 deriving via (OnlyCheckWhnf LicenseExceptionId) instance NoThunks LicenseExceptionId
 129 deriving via (CheckFoldableNamed NonEmptySet a) instance NoThunks a => NoThunks (NonEmptySet a)
 130
 131 instance (NoThunks v, NoThunks c, NoThunks a) => NoThunks (CondTree v c a)
 132 instance (NoThunks v, NoThunks c, NoThunks a) => NoThunks (CondBranch v c a)
 133 instance (NoThunks c) => NoThunks (Condition c)
 134
 135 -------------------------------------------------------------------------------
 136 -- NoThunks helpers
 137 -------------------------------------------------------------------------------
 138
 139 newtype CheckFoldableNamed f a = CheckFoldableNamed (f a)
 140
 141 instance (NoThunks a, Foldable f, Typeable f) => NoThunks (CheckFoldableNamed f a) where
 142     showTypeOf _ = show (typeRep (Proxy :: Proxy f))
 143     wNoThunks ctxt (CheckFoldableNamed xs) = noThunksInValues ctxt (toList xs)
 144
 145 #endif