diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,22 @@ +2025-02-04 Laurent P. René de Cotret 0.4.3 + +* Ported test suite to use `tasty` rather than `test-framework`. +* Removed unused test dependencies (#467) + +2024-09-03 Laurent P. René de Cotret 0.4.2 + +* Bumped dependency bounds to support GHC 8.10.7 - GHC 9.10.1 +* Updated links to point to Distributed Haskell monorepo + +2020-10-24 Facundo Domínguez 0.4.1 + +* Support ghc-8.6.5 and ghc-8.8.4 + +2017-08-22 Facundo Domínguez 0.4.0 + +* Add compatibility with ghc-8.2.1. +* Drop support for ghc-7.6 and ghc-7.8. + 2016-05-31 Facundo Domínguez 0.3.3.0 * Add compatibility with ghc-8. diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/rank1dynamic.cabal b/rank1dynamic.cabal --- a/rank1dynamic.cabal +++ b/rank1dynamic.cabal @@ -1,44 +1,56 @@ +cabal-version: 3.0 Name: rank1dynamic -Version: 0.3.3.0 +Version: 0.4.3 Synopsis: Like Data.Dynamic/Data.Typeable but with support for rank-1 polymorphic types Description: "Data.Typeable" and "Data.Dynamic" only support monomorphic types. In this package we provide similar functionality but with support for rank-1 polymorphic types. Homepage: http://haskell-distributed.github.com -License: BSD3 +License: BSD-3-Clause License-File: LICENSE Author: Edsko de Vries -Maintainer: Facundo Domínguez -Bug-Reports: https://github.com/haskell-distributed/rank1dynamic/issues +maintainer: The Distributed Haskell team +Bug-Reports: https://github.com/haskell-distributed/distributed-process/issues Copyright: Well-Typed LLP, Tweag I/O Limited Category: Data Build-Type: Simple -Cabal-Version: >=1.8 -extra-source-files: ChangeLog +extra-doc-files: ChangeLog -Source-Repository head +source-repository head Type: git - Location: https://github.com/haskell-distributed/rank1dynamic + Location: https://github.com/haskell-distributed/distributed-process + SubDir: packages/rank1dynamic +common warnings + ghc-options: -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wredundant-constraints + -fhide-source-paths + -Wpartial-fields + -Wunused-packages + Library + import: warnings Exposed-Modules: Data.Rank1Dynamic, Data.Rank1Typeable - Build-Depends: base >= 4.4 && < 5, - binary >= 0.5 && < 0.9 + Build-Depends: base >= 4.14 && < 5, + binary >= 0.8 && < 0.9 HS-Source-Dirs: src - GHC-Options: -Wall - Extensions: EmptyDataDecls, + default-language: Haskell2010 + Default-Extensions: EmptyDataDecls, DeriveDataTypeable, - ViewPatterns, - CPP + ViewPatterns Test-Suite TestRank1Dynamic + import: warnings Type: exitcode-stdio-1.0 Main-Is: test.hs - Build-Depends: base >= 4.4 && < 5, - HUnit >= 1.2 && < 1.4, + Build-Depends: base >= 4.14 && < 5, rank1dynamic, - test-framework >= 0.6 && < 0.9, - test-framework-hunit >= 0.2.0 && < 0.4 - ghc-options: -Wall + tasty >= 1.5 && <1.6, + tasty-hunit >=0.10 && <0.11, + default-language: Haskell2010 HS-Source-Dirs: tests diff --git a/src/Data/Rank1Typeable.hs b/src/Data/Rank1Typeable.hs --- a/src/Data/Rank1Typeable.hs +++ b/src/Data/Rank1Typeable.hs @@ -56,13 +56,13 @@ -- > -- Cannot apply function of type (forall a. (a -> a) -> a -> a) to arg of type (Int -> Bool) -- > > funResultTy (typeOf (undefined :: (ANY -> ANY) -> (ANY -> ANY))) (typeOf (undefined :: Int -> Bool)) -- > Left "Cannot unify Int and Bool" +{-# LANGUAGE BangPatterns #-} module Data.Rank1Typeable ( -- * Basic types TypeRep , typeOf , splitTyConApp , mkTyConApp - , underlyingTypeRep -- * Operations on type representations , isInstanceOf , funResultTy @@ -98,62 +98,47 @@ import Prelude hiding (succ) import Control.Arrow ((***), second) import Control.Monad (void) -import Control.Applicative ((<$>)) +import Data.Binary +import Data.Function (on) import Data.List (intersperse, isPrefixOf) import Data.Maybe (fromMaybe) -import Data.Typeable - ( Typeable - , TyCon - , mkTyCon3 - , tyConPackage - , tyConModule - , tyConName - ) -#if MIN_VERSION_base(4,7,0) -import Data.Proxy (Proxy(Proxy)) -#endif -import qualified Data.Typeable.Internal as T -import Data.Binary (Binary(get, put)) -import qualified Data.Typeable as Typeable - ( TypeRep - , typeOf - , splitTyConApp - , mkTyConApp - ) +import Data.Typeable ( Typeable ) +import qualified Data.Typeable as T +import GHC.Fingerprint tcList, tcFun :: TyCon -#if MIN_VERSION_base(4,7,0) -tcList = T.typeRepTyCon (T.typeOf [()]) -tcFun = T.typeRepTyCon (T.typeRep (Proxy :: Proxy (->))) -#else -tcList = T.listTc -tcFun = T.funTc -#endif +tcList = fst $ splitTyConApp $ typeOf [()] +tcFun = fst $ splitTyConApp $ typeOf (\() -> ()) -------------------------------------------------------------------------------- -- The basic type -- -------------------------------------------------------------------------------- -- | Dynamic type representation with support for rank-1 types -newtype TypeRep = TypeRep { - -- | Return the underlying standard ("Data.Typeable") type representation - underlyingTypeRep :: Typeable.TypeRep - } +data TypeRep + = TRCon TyCon + | TRApp {-# UNPACK #-} !Fingerprint TypeRep TypeRep +data TyCon = TyCon + { tyConFingerprint :: {-# UNPACK #-} !Fingerprint + , tyConPackage :: String + , tyConModule :: String + , tyConName :: String + } + +-- | The fingerprint of a TypeRep +typeRepFingerprint :: TypeRep -> Fingerprint +typeRepFingerprint (TRCon c) = tyConFingerprint c +typeRepFingerprint (TRApp fp _ _) = fp + -- | Compare two type representations --- --- For base >= 4.6 this compares fingerprints, but older versions of base --- have a bug in the fingerprint construction --- () +instance Eq TyCon where + (==) = (==) `on` tyConFingerprint + instance Eq TypeRep where -#if ! MIN_VERSION_base(4,6,0) - (splitTyConApp -> (c1, ts1)) == (splitTyConApp -> (c2, ts2)) = - c1 == c2 && all (uncurry (==)) (zip ts1 ts2) -#else - t1 == t2 = underlyingTypeRep t1 == underlyingTypeRep t2 -#endif + (==) = (==) `on` typeRepFingerprint --- Binary instance for 'TypeRep', avoiding orphan instances +--- Binary instance for 'TypeRep', avoiding orphan instances instance Binary TypeRep where put (splitTyConApp -> (tc, ts)) = do put $ tyConPackage tc @@ -169,8 +154,30 @@ -- | The type representation of any 'Typeable' term typeOf :: Typeable a => a -> TypeRep -typeOf = TypeRep . Typeable.typeOf +typeOf = trTypeOf . T.typeOf +-- | Conversion from Data.Typeable.TypeRep to Data.Rank1Typeable.TypeRep +trTypeOf :: T.TypeRep -> TypeRep +trTypeOf t = let (c, ts) = T.splitTyConApp t + in foldl mkTRApp (TRCon $ fromTypeableTyCon c) $ map trTypeOf ts + where + fromTypeableTyCon c = + TyCon (T.tyConFingerprint c) + (T.tyConPackage c) + (T.tyConModule c) + (T.tyConName c) + +-- | Applies a TypeRep to another. +mkTRApp :: TypeRep -> TypeRep -> TypeRep +mkTRApp t0 t1 = TRApp fp t0 t1 + where + fp = fingerprintFingerprints [typeRepFingerprint t0, typeRepFingerprint t1] + +mkTyCon3 :: String -> String -> String -> TyCon +mkTyCon3 pkg m name = TyCon fp pkg m name + where + fp = fingerprintFingerprints [ fingerprintString s | s <- [pkg, m, name] ] + -------------------------------------------------------------------------------- -- Constructors/destructors (views) -- -------------------------------------------------------------------------------- @@ -178,14 +185,14 @@ -- | Split a type representation into the application of -- a type constructor and its argument splitTyConApp :: TypeRep -> (TyCon, [TypeRep]) -splitTyConApp t = - let (c, ts) = Typeable.splitTyConApp (underlyingTypeRep t) - in (c, map TypeRep ts) +splitTyConApp = go [] + where + go xs (TRCon c) = (c, xs) + go xs (TRApp _ t0 t1) = go (t1 : xs) t0 -- | Inverse of 'splitTyConApp' mkTyConApp :: TyCon -> [TypeRep] -> TypeRep -mkTyConApp c ts - = TypeRep (Typeable.mkTyConApp c (map underlyingTypeRep ts)) +mkTyConApp c = foldl mkTRApp (TRCon c) isTypVar :: TypeRep -> Maybe Var isTypVar (splitTyConApp -> (c, [t])) | c == typVar = Just t @@ -332,6 +339,9 @@ -------------------------------------------------------------------------------- -- Pretty-printing -- -------------------------------------------------------------------------------- + +instance Show TyCon where + showsPrec _ c = showString (tyConName c) instance Show TypeRep where showsPrec p (splitTyConApp -> (tycon, tys)) = diff --git a/tests/test.hs b/tests/test.hs --- a/tests/test.hs +++ b/tests/test.hs @@ -1,17 +1,25 @@ {-# LANGUAGE CPP #-} -import Data.Rank1Typeable -import Data.Rank1Dynamic +import Data.Rank1Dynamic +import Data.Rank1Typeable -import Test.HUnit hiding (Test) -import Test.Framework -import Test.Framework.Providers.HUnit -import Unsafe.Coerce +import Test.Tasty +import Test.Tasty.HUnit +import Unsafe.Coerce +funKindStr :: String +#if defined(MIN_VERSION_GLASGOW_HASKELL) && MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) +funKindStr = "FUN" +#elif __GLASGOW_HASKELL__ >= 804 +funKindStr = "->" +#else +funKindStr = "(->)" +#endif + main :: IO () -main = defaultMain tests +main = defaultMain (testGroup "rank1dynamic" tests) -tests :: [Test] +tests :: [TestTree] tests = [ testGroup "Examples of isInstanceOf" [ testCase "CANNOT use a term of type 'Int -> Bool' as 'Int -> Int'" $ @@ -36,11 +44,7 @@ , testCase "CANNOT use a term of type 'forall a. a -> a' as 'forall a. a'" $ typeOf (undefined :: ANY) `isInstanceOf` typeOf (undefined :: ANY -> ANY) -#if MIN_VERSION_base(4,7,0) - @?= Left "Cannot unify Skolem and (->)" -#else - @?= Left "Cannot unify Skolem and ->" -#endif + @?= Left ("Cannot unify Skolem and " ++ funKindStr) ] , testGroup "Examples of funResultTy" @@ -95,11 +99,7 @@ , testCase "CANNOT use a term of type 'forall a. a -> a' as 'forall a. a'" $ do f <- fromDynamic (toDynamic (id :: ANY -> ANY)) ; return $ (f :: Int) -#if MIN_VERSION_base(4,7,0) - @?= Left "Cannot unify Int and (->)" -#else - @?= Left "Cannot unify Int and ->" -#endif + @?= Left ("Cannot unify Int and " ++ funKindStr) ] , testGroup "Examples of dynApply"