diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,54 @@ +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. +* Update bug report url in cabal file. + +2016-02-18 Facundo Domínguez 0.3.2.0 + +* Stop testing ghc-7.4 and test ghc-7.10. +* Add unsafeToDynamic. + +2016-01-25 Facundo Domínguez 0.3.1.1 + +* Push HUnit upper bound. + +2015-06-15 Facundo Domínguez 0.2.1.0 + +* Loosen upper bound of ghc-prim. + +2014-05-30 Tim Watson 0.2.0.0 + +* Fix funResultTy so @funResultTy ANY _ = ANY@ +* Ensure the result of funResultTy is consistent with unification +* Bump binary version to include 0.7.* + +2012-11-22 Edsko de Vries 0.1.0.2 + +* Relax package bounds to allow for Binary 0.6 + +2012-09-27 Edsko de Vries 0.1.0.1 + +* Relax lower bound of base to 4.4 (ghc 7.2) + +2012-08-10 Edsko de Vries 0.1.0.0 + +* Initial release. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,5 @@ Copyright (c) 2012, Edsko de Vries +Copyright (c) 2015, Tweag I/O Limited All rights reserved. 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,28 +1,56 @@ +cabal-version: 3.0 Name: rank1dynamic -Version: 0.1.0.2 +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. +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://github.com/haskell-distributed/distributed-process -License: BSD3 + support for rank-1 polymorphic types. +Homepage: http://haskell-distributed.github.com +License: BSD-3-Clause License-File: LICENSE Author: Edsko de Vries -Maintainer: edsko@well-typed.com -Copyright: Well-Typed LLP +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-doc-files: ChangeLog +source-repository head + Type: git + 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 && < 4.7, - ghc-prim >= 0.2 && < 0.4, - binary >= 0.5 && < 0.7 + 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.14 && < 5, + rank1dynamic, + tasty >= 1.5 && <1.6, + tasty-hunit >=0.10 && <0.11, + default-language: Haskell2010 + HS-Source-Dirs: tests diff --git a/src/Data/Rank1Dynamic.hs b/src/Data/Rank1Dynamic.hs --- a/src/Data/Rank1Dynamic.hs +++ b/src/Data/Rank1Dynamic.hs @@ -5,42 +5,42 @@ -- These examples correspond to the 'Data.Rank1Typeable.isInstanceOf' examples -- in "Data.Rank1Typeable". -- --- > > do f <- fromDynamic (toDynamic (even :: Int -> Bool)) ; return $ (f :: Int -> Int) 0 +-- > > do f <- fromDynamic (toDynamic (even :: Int -> Bool)) ; return $ (f :: Int -> Int) 0 -- > Left "Cannot unify Int and Bool" --- > +-- > -- > > do f <- fromDynamic (toDynamic (const 1 :: ANY -> Int)) ; return $ (f :: Int -> Int) 0 -- > Right 1 --- > +-- > -- > > do f <- fromDynamic (toDynamic (unsafeCoerce :: ANY1 -> ANY2)) ; return $ (f :: Int -> Int) 0 -- > Right 0 --- > +-- > -- > > do f <- fromDynamic (toDynamic (id :: ANY -> ANY)) ; return $ (f :: Int -> Bool) 0 -- > Left "Cannot unify Bool and Int" --- > +-- > -- > > do f <- fromDynamic (toDynamic (undefined :: ANY)) ; return $ (f :: Int -> Int) 0 -- > Right *** Exception: Prelude.undefined --- > +-- > -- > > do f <- fromDynamic (toDynamic (id :: ANY -> ANY)) ; return $ (f :: Int) -- > Left "Cannot unify Int and ->" -- -- [Examples of dynApply] --- +-- -- These examples correspond to the 'Data.Rank1Typeable.funResultTy' examples -- in "Data.Rank1Typeable". -- -- > > do app <- toDynamic (id :: ANY -> ANY) `dynApply` toDynamic True ; f <- fromDynamic app ; return $ (f :: Bool) -- > Right True --- > +-- > -- > > do app <- toDynamic (const :: ANY -> ANY1 -> ANY) `dynApply` toDynamic True ; f <- fromDynamic app ; return $ (f :: Int -> Bool) 0 -- > Right True --- > +-- > -- > > do app <- toDynamic (($ True) :: (Bool -> ANY) -> ANY) `dynApply` toDynamic (id :: ANY -> ANY) ; f <- fromDynamic app ; return (f :: Bool) -- > Right True --- > +-- > -- > > app <- toDynamic (const :: ANY -> ANY1 -> ANY) `dynApply` toDynamic (id :: ANY -> ANY) ; f <- fromDynamic app ; return $ (f :: Int -> Bool -> Bool) 0 True -- > Right True --- > --- > > do app <- toDynamic ((\f -> f . f) :: (ANY -> ANY) -> ANY -> ANY) `dynApply` toDynamic (even :: Int -> Bool) ; f <- fromDynamic app ; return (f :: ()) +-- > +-- > > do app <- toDynamic ((\f -> f . f) :: (ANY -> ANY) -> ANY -> ANY) `dynApply` toDynamic (even :: Int -> Bool) ; f <- fromDynamic app ; return (f :: ()) -- > Left "Cannot unify Int and Bool" -- -- [Using toDynamic] @@ -48,40 +48,41 @@ -- When using polymorphic values you need to give an explicit type annotation: -- -- > > toDynamic id --- > +-- > -- > :46:1: -- > Ambiguous type variable `a0' in the constraint: -- > (Typeable a0) arising from a use of `toDynamic' -- > Probable fix: add a type signature that fixes these type variable(s) -- > In the expression: toDynamic id -- > In an equation for `it': it = toDynamic id --- +-- -- versus -- -- > > toDynamic (id :: ANY -> ANY) -- > < ANY>> --- +-- -- Note that these type annotation are checked by ghc like any other: -- -- > > toDynamic (id :: ANY -> ANY1) --- > +-- > -- > :45:12: -- > Couldn't match expected type `V1' with actual type `V0' -- > Expected type: ANY -> ANY1 -- > Actual type: ANY -> ANY -- > In the first argument of `toDynamic', namely `(id :: ANY -> ANY1)' -- > In the expression: toDynamic (id :: ANY -> ANY1) -module Data.Rank1Dynamic +module Data.Rank1Dynamic ( Dynamic , toDynamic , fromDynamic , TypeError , dynTypeRep , dynApply + , unsafeToDynamic ) where -import qualified GHC.Prim as GHC (Any) -import Data.Rank1Typeable +import qualified GHC.Exts as GHC (Any) +import Data.Rank1Typeable ( Typeable , TypeRep , typeOf @@ -95,16 +96,25 @@ data Dynamic = Dynamic TypeRep GHC.Any instance Show Dynamic where - showsPrec _ (Dynamic t _) = showString "<<" . shows t . showString ">>" + showsPrec _ (Dynamic t _) = showString "<<" . shows t . showString ">>" --- | Introduce a dynamic value +-- | Introduce a dynamic value toDynamic :: Typeable a => a -> Dynamic toDynamic x = Dynamic (typeOf x) (unsafeCoerce x) +-- | Construct a dynamic value with a user-supplied type rep +-- +-- This function is unsafe because we have no way of verifying that the +-- provided type representation matches the value. +-- +-- Since 0.3.2.0. +unsafeToDynamic :: TypeRep -> a -> Dynamic +unsafeToDynamic typ x = Dynamic typ (unsafeCoerce x) + -- | Eliminate a dynamic value fromDynamic :: Typeable a => Dynamic -> Either TypeError a fromDynamic (Dynamic t v) = - case unsafeCoerce v of + case unsafeCoerce v of r -> case typeOf r `isInstanceOf` t of Left err -> Left err Right () -> Right r diff --git a/src/Data/Rank1Typeable.hs b/src/Data/Rank1Typeable.hs --- a/src/Data/Rank1Typeable.hs +++ b/src/Data/Rank1Typeable.hs @@ -1,7 +1,7 @@ -- | Runtime type representation of terms with support for rank-1 polymorphic -- types with type variables of kind *. -- --- The essence of this module is that we use the standard 'Typeable' +-- The essence of this module is that we use the standard 'Typeable' -- representation of "Data.Typeable" but we introduce a special (empty) data -- type 'TypVar' which represents type variables. 'TypVar' is indexed by an -- arbitrary other data type, giving you an unbounded number of type variables; @@ -12,23 +12,23 @@ -- > -- We CANNOT use a term of type 'Int -> Bool' as 'Int -> Int' -- > > typeOf (undefined :: Int -> Int) `isInstanceOf` typeOf (undefined :: Int -> Bool) -- > Left "Cannot unify Int and Bool" --- > +-- > -- > -- We CAN use a term of type 'forall a. a -> Int' as 'Int -> Int' -- > > typeOf (undefined :: Int -> Int) `isInstanceOf` typeOf (undefined :: ANY -> Int) -- > Right () --- > +-- > -- > -- We CAN use a term of type 'forall a b. a -> b' as 'forall a. a -> a' -- > > typeOf (undefined :: ANY -> ANY) `isInstanceOf` typeOf (undefined :: ANY -> ANY1) -- > Right () --- > +-- > -- > -- We CANNOT use a term of type 'forall a. a -> a' as 'forall a b. a -> b' -- > > typeOf (undefined :: ANY -> ANY1) `isInstanceOf` typeOf (undefined :: ANY -> ANY) -- > Left "Cannot unify Succ and Zero" --- > +-- > -- > -- We CAN use a term of type 'forall a. a' as 'forall a. a -> a' -- > > typeOf (undefined :: ANY -> ANY) `isInstanceOf` typeOf (undefined :: ANY) -- > Right () --- > +-- > -- > -- We CANNOT use a term of type 'forall a. a -> a' as 'forall a. a' -- > > typeOf (undefined :: ANY) `isInstanceOf` typeOf (undefined :: ANY -> ANY) -- > Left "Cannot unify Skolem and ->" @@ -37,14 +37,14 @@ -- -- [Examples of funResultTy] -- --- > -- Apply fn of type (forall a. a -> a) to arg of type Bool gives Bool +-- > -- Apply fn of type (forall a. a -> a) to arg of type Bool gives Bool -- > > funResultTy (typeOf (undefined :: ANY -> ANY)) (typeOf (undefined :: Bool)) -- > Right Bool --- > +-- > -- > -- Apply fn of type (forall a b. a -> b -> a) to arg of type Bool gives forall a. a -> Bool -- > > funResultTy (typeOf (undefined :: ANY -> ANY1 -> ANY)) (typeOf (undefined :: Bool)) -- > Right (ANY -> Bool) -- forall a. a -> Bool --- > +-- > -- > -- Apply fn of type (forall a. (Bool -> a) -> a) to argument of type (forall a. a -> a) gives Bool -- > > funResultTy (typeOf (undefined :: (Bool -> ANY) -> ANY)) (typeOf (undefined :: ANY -> ANY)) -- > Right Bool @@ -56,14 +56,14 @@ -- > -- 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" -module Data.Rank1Typeable - ( -- * Basic types +{-# LANGUAGE BangPatterns #-} +module Data.Rank1Typeable + ( -- * Basic types TypeRep , typeOf , splitTyConApp , mkTyConApp - , underlyingTypeRep - -- * Operations on type representations + -- * Operations on type representations , isInstanceOf , funResultTy , TypeError @@ -98,65 +98,86 @@ 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, mkTyCon3) -import Data.Typeable.Internal (listTc, funTc, TyCon(TyCon), tyConName) -import Data.Binary (Binary(get, put)) -import GHC.Fingerprint.Type (Fingerprint(..)) -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 +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 -> (TyCon (Fingerprint hi lo) package modul name, ts)) = do - put hi - put lo - put package - put modul - put name + put (splitTyConApp -> (tc, ts)) = do + put $ tyConPackage tc + put $ tyConModule tc + put $ tyConName tc put ts get = do - hi <- get - lo <- get package <- get modul <- get name <- get ts <- get - return $ mkTyConApp (TyCon (Fingerprint hi lo) package modul name) ts + return $ mkTyConApp (mkTyCon3 package modul name) ts -- | 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) -- -------------------------------------------------------------------------------- @@ -164,16 +185,16 @@ -- | 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 :: TypeRep -> Maybe Var isTypVar (splitTyConApp -> (c, [t])) | c == typVar = Just t isTypVar _ = Nothing @@ -190,7 +211,7 @@ -- Type variables -- -------------------------------------------------------------------------------- -data TypVar a deriving Typeable +data TypVar a deriving Typeable data Skolem a deriving Typeable data Zero deriving Typeable data Succ a deriving Typeable @@ -206,7 +227,7 @@ type V8 = Succ V7 type V9 = Succ V8 -type ANY = TypVar V0 +type ANY = TypVar V0 type ANY1 = TypVar V1 type ANY2 = TypVar V2 type ANY3 = TypVar V3 @@ -224,18 +245,17 @@ -- | If 'isInstanceOf' fails it returns a type error type TypeError = String --- | @t1 `isInstanceOf` t2@ checks if @t1@ is an instance of @t2@ -isInstanceOf :: TypeRep -> TypeRep -> Either TypeError () +-- | @t1 `isInstanceOf` t2@ checks if @t1@ is an instance of @t2@ +isInstanceOf :: TypeRep -> TypeRep -> Either TypeError () isInstanceOf t1 t2 = void (unify (skolemize t1) t2) -- | @funResultTy t1 t2@ is the type of the result when applying a function -- of type @t1@ to an argument of type @t2@ -funResultTy :: TypeRep -> TypeRep -> Either TypeError TypeRep -funResultTy (splitTyConApp -> (fc, [farg, fres])) x | fc == funTc = do - s <- unify (alphaRename "f" farg) (alphaRename "x" x) - return (normalize (subst s (alphaRename "f" fres))) -funResultTy f _ = - Left $ show f ++ " is not a function" +funResultTy :: TypeRep -> TypeRep -> Either TypeError TypeRep +funResultTy t1 t2 = do + let anyTy = mkTypVar $ typeOf (undefined :: V0) + s <- unify (alphaRename "f" t1) $ mkTyConApp tcFun [alphaRename "x" t2, anyTy] + return $ normalize $ subst s anyTy -------------------------------------------------------------------------------- -- Alpha-renaming and normalization -- @@ -251,7 +271,7 @@ tvars (isTypVar -> Just x) = [x] tvars (splitTyConApp -> (_, ts)) = concatMap tvars ts -normalize :: TypeRep -> TypeRep +normalize :: TypeRep -> TypeRep normalize t = subst (zip (tvars t) anys) t where anys :: [TypeRep] @@ -261,7 +281,7 @@ succ = mkTyConApp succTyCon . (:[]) zero :: TypeRep - zero = mkTyConApp zeroTyCon [] + zero = mkTyConApp zeroTyCon [] mkTyCon :: String -> TyCon mkTyCon = mkTyCon3 "rank1typeable" "Data.Rank1Typeable" @@ -281,38 +301,38 @@ type Var = TypeRep skolemize :: TypeRep -> TypeRep -skolemize (isTypVar -> Just x) = mkTyConApp skolem [x] +skolemize (isTypVar -> Just x) = mkTyConApp skolem [x] skolemize (splitTyConApp -> (c, ts)) = mkTyConApp c (map skolemize ts) occurs :: Var -> TypeRep -> Bool -occurs x (isTypVar -> Just x') = x == x' +occurs x (isTypVar -> Just x') = x == x' occurs x (splitTyConApp -> (_, ts)) = any (occurs x) ts subst :: Substitution -> TypeRep -> TypeRep subst s (isTypVar -> Just x) = fromMaybe (mkTypVar x) (lookup x s) subst s (splitTyConApp -> (c, ts)) = mkTyConApp c (map (subst s) ts) -unify :: TypeRep - -> TypeRep - -> Either TypeError Substitution +unify :: TypeRep + -> TypeRep + -> Either TypeError Substitution unify = \t1 t2 -> go [] [(t1, t2)] where - go :: Substitution - -> [Equation] - -> Either TypeError Substitution - go acc [] = + go :: Substitution + -> [Equation] + -> Either TypeError Substitution + go acc [] = return acc go acc ((t1, t2) : eqs) | t1 == t2 = -- Note: equality check is fast go acc eqs go acc ((isTypVar -> Just x, t) : eqs) = - if x `occurs` t + if x `occurs` t then Left "Occurs check" - else go ((x, t) : map (second $ subst [(x, t)]) acc) + else go ((x, t) : map (second $ subst [(x, t)]) acc) (map (subst [(x, t)] *** subst [(x, t)]) eqs) go acc ((t, isTypVar -> Just x) : eqs) = go acc ((mkTypVar x, t) : eqs) - go acc ((splitTyConApp -> (c1, ts1), splitTyConApp -> (c2, ts2)) : eqs) = - if c1 /= c2 + go acc ((splitTyConApp -> (c1, ts1), splitTyConApp -> (c2, ts2)) : eqs) = + if c1 /= c2 then Left $ "Cannot unify " ++ show c1 ++ " and " ++ show c2 else go acc (zip ts1 ts2 ++ eqs) @@ -320,18 +340,21 @@ -- Pretty-printing -- -------------------------------------------------------------------------------- +instance Show TyCon where + showsPrec _ c = showString (tyConName c) + instance Show TypeRep where showsPrec p (splitTyConApp -> (tycon, tys)) = case tys of [] -> showsPrec p tycon - [anyIdx -> Just i] | tycon == typVar -> showString "ANY" . showIdx i - [x] | tycon == listTc -> + [anyIdx -> Just i] | tycon == typVar -> showString "ANY" . showIdx i + [x] | tycon == tcList -> showChar '[' . shows x . showChar ']' - [a,r] | tycon == funTc -> - showParen (p > 8) $ showsPrec 9 a - . showString " -> " + [a,r] | tycon == tcFun -> + showParen (p > 8) $ showsPrec 9 a + . showString " -> " . showsPrec 8 r - xs | isTupleTyCon tycon -> + xs | isTupleTyCon tycon -> showTuple xs _ -> showParen (p > 9) $ showsPrec p tycon @@ -344,16 +367,16 @@ showArgs :: Show a => [a] -> ShowS showArgs [] = id showArgs [a] = showsPrec 10 a -showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as +showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as -anyIdx :: TypeRep -> Maybe Int +anyIdx :: TypeRep -> Maybe Int anyIdx (splitTyConApp -> (c, [])) | c == zeroTyCon = Just 0 anyIdx (splitTyConApp -> (c, [t])) | c == succTyCon = (+1) <$> anyIdx t anyIdx _ = Nothing showTuple :: [TypeRep] -> ShowS showTuple args = showChar '(' - . foldr (.) id ( intersperse (showChar ',') + . foldr (.) id ( intersperse (showChar ',') $ map (showsPrec 10) args ) . showChar ')' diff --git a/tests/test.hs b/tests/test.hs new file mode 100644 --- /dev/null +++ b/tests/test.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE CPP #-} +import Data.Rank1Dynamic +import Data.Rank1Typeable + +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 (testGroup "rank1dynamic" tests) + +tests :: [TestTree] +tests = + [ testGroup "Examples of isInstanceOf" + [ testCase "CANNOT use a term of type 'Int -> Bool' as 'Int -> Int'" $ + typeOf (undefined :: Int -> Int) `isInstanceOf` typeOf (undefined :: Int -> Bool) + @?= Left "Cannot unify Int and Bool" + + , testCase "CAN use a term of type 'forall a. a -> Int' as 'Int -> Int'" $ + typeOf (undefined :: Int -> Int) `isInstanceOf` typeOf (undefined :: ANY -> Int) + @?= Right () + + , testCase "CAN use a term of type 'forall a b. a -> b' as 'forall a. a -> a'" $ + typeOf (undefined :: ANY -> ANY) `isInstanceOf` typeOf (undefined :: ANY -> ANY1) + @?= Right () + + , testCase "CANNOT use a term of type 'forall a. a -> a' as 'forall a b. a -> b'" $ + typeOf (undefined :: ANY -> ANY1) `isInstanceOf` typeOf (undefined :: ANY -> ANY) + @?= Left "Cannot unify Succ and Zero" + + , testCase "CAN use a term of type 'forall a. a' as 'forall a. a -> a'" $ + typeOf (undefined :: ANY -> ANY) `isInstanceOf` typeOf (undefined :: ANY) + @?= Right () + + , testCase "CANNOT use a term of type 'forall a. a -> a' as 'forall a. a'" $ + typeOf (undefined :: ANY) `isInstanceOf` typeOf (undefined :: ANY -> ANY) + @?= Left ("Cannot unify Skolem and " ++ funKindStr) + ] + + , testGroup "Examples of funResultTy" + [ testCase "Apply fn of type (forall a. a -> a) to arg of type Bool gives Bool" $ + show (funResultTy (typeOf (undefined :: ANY -> ANY)) (typeOf (undefined :: Bool))) + @?= "Right Bool" + + , testCase "Apply fn of type (forall a b. a -> b -> a) to arg of type Bool gives forall a. a -> Bool" $ + show (funResultTy (typeOf (undefined :: ANY -> ANY1 -> ANY)) (typeOf (undefined :: Bool))) + @?= "Right (ANY -> Bool)" -- forall a. a -> Bool + + , testCase "Apply fn of type (forall a. (Bool -> a) -> a) to argument of type (forall a. a -> a) gives Bool" $ + show (funResultTy (typeOf (undefined :: (Bool -> ANY) -> ANY)) (typeOf (undefined :: ANY -> ANY))) + @?= "Right Bool" + + , testCase "Apply fn of type (forall a b. a -> b -> a) to arg of type (forall a. a -> a) gives (forall a b. a -> b -> b)" $ + show (funResultTy (typeOf (undefined :: ANY -> ANY1 -> ANY)) (typeOf (undefined :: ANY1 -> ANY1))) + @?= "Right (ANY -> ANY1 -> ANY1)" + + , testCase "Cannot apply function of type (forall a. (a -> a) -> a -> a) to arg of type (Int -> Bool)" $ + show (funResultTy (typeOf (undefined :: (ANY -> ANY) -> (ANY -> ANY))) (typeOf (undefined :: Int -> Bool))) + @?= "Left \"Cannot unify Int and Bool\"" + ] + + , testGroup "Examples of fromDynamic" + [ testCase "CANNOT use a term of type 'Int -> Bool' as 'Int -> Int'" $ + do f <- fromDynamic (toDynamic (even :: Int -> Bool)) + return $ (f :: Int -> Int) 0 + @?= Left "Cannot unify Int and Bool" + + , testCase "CAN use a term of type 'forall a. a -> Int' as 'Int -> Int'" $ + do f <- fromDynamic (toDynamic (const 1 :: ANY -> Int)) + return $ (f :: Int -> Int) 0 + @?= Right 1 + + , testCase "CAN use a term of type 'forall a b. a -> b' as 'forall a. a -> a'" $ + do f <- fromDynamic (toDynamic (unsafeCoerce :: ANY1 -> ANY2)) + return $ (f :: Int -> Int) 0 + @?= Right 0 + + , testCase "CANNOT use a term of type 'forall a. a -> a' as 'forall a b. a -> b'" $ + do f <- fromDynamic (toDynamic (id :: ANY -> ANY)) + return $ (f :: Int -> Bool) 0 + @?= Left "Cannot unify Bool and Int" + + , testCase "CAN use a term of type 'forall a. a' as 'forall a. a -> a'" $ + case do f <- fromDynamic (toDynamic (undefined :: ANY)) + return $ (f :: Int -> Int) 0 + of + Right _ -> return () + result -> assertFailure $ "Expected 'Right _' but got '" ++ show result ++ "'" + + , 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) + @?= Left ("Cannot unify Int and " ++ funKindStr) + ] + + , testGroup "Examples of dynApply" + [ testCase "Apply fn of type (forall a. a -> a) to arg of type Bool gives Bool" $ + do app <- toDynamic (id :: ANY -> ANY) `dynApply` toDynamic True + f <- fromDynamic app + return $ (f :: Bool) + @?= Right True + + , testCase "Apply fn of type (forall a b. a -> b -> a) to arg of type Bool gives forall a. a -> Bool" $ + do app <- toDynamic (const :: ANY -> ANY1 -> ANY) `dynApply` toDynamic True + f <- fromDynamic app + return $ (f :: Int -> Bool) 0 + @?= Right True + + , testCase "Apply fn of type (forall a. (Bool -> a) -> a) to argument of type (forall a. a -> a) gives Bool" $ + do app <- toDynamic (($ True) :: (Bool -> ANY) -> ANY) `dynApply` toDynamic (id :: ANY -> ANY) + f <- fromDynamic app + return (f :: Bool) + @?= Right True + + , testCase "Apply fn of type (forall a b. a -> b -> a) to arg of type (forall a. a -> a) gives (forall a b. a -> b -> b)" $ + do app <- toDynamic (const :: ANY -> ANY1 -> ANY) `dynApply` toDynamic (id :: ANY -> ANY) + f <- fromDynamic app ; return $ (f :: Int -> Bool -> Bool) 0 True + @?= Right True + + , testCase "Cannot apply function of type (forall a. (a -> a) -> a -> a) to arg of type (Int -> Bool)" $ + do app <- toDynamic ((\f -> f . f) :: (ANY -> ANY) -> ANY -> ANY) `dynApply` toDynamic (even :: Int -> Bool) ; f <- fromDynamic app ; return (f :: ()) + @?= Left "Cannot unify Int and Bool" + ] + ]