rank1dynamic 0.3.3.0 → 0.4.0

raw patch · 4 files changed

+69/−63 lines, 4 filesdep ~HUnitdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: HUnit, base

API changes (from Hackage documentation)

Files

• ChangeLog +5/−0
• rank1dynamic.cabal +5/−6
• src/Data/Rank1Typeable.hs +59/−48
• tests/test.hs +0/−9

@@ -1,3 +1,8 @@+2017-08-22  Facundo Domínguez  <facundo.dominguez@tweag.io>  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  <facundo.dominguez@tweag.io>  0.3.3.0  * Add compatibility with ghc-8.

@@ -1,5 +1,5 @@ Name:                rank1dynamic-Version:             0.3.3.0+Version:             0.4.0 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@@ -23,20 +23,19 @@ Library   Exposed-Modules:     Data.Rank1Dynamic,                        Data.Rank1Typeable-  Build-Depends:       base >= 4.4 && < 5,+  Build-Depends:       base >= 4.6 && < 5,                        binary >= 0.5 && < 0.9   HS-Source-Dirs:      src   GHC-Options:         -Wall   Extensions:          EmptyDataDecls,                        DeriveDataTypeable,-                       ViewPatterns,-                       CPP+                       ViewPatterns  Test-Suite TestRank1Dynamic   Type:              exitcode-stdio-1.0   Main-Is:           test.hs-  Build-Depends:     base >= 4.4 && < 5,-                     HUnit >= 1.2 && < 1.4,+  Build-Depends:     base >= 4.6 && < 5,+                     HUnit >= 1.2 && < 1.7,                      rank1dynamic,                      test-framework >= 0.6 && < 0.9,                      test-framework-hunit >= 0.2.0 && < 0.4

@@ -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@@ -99,61 +99,47 @@ 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--- (<http://hackage.haskell.org/trac/ghc/ticket/5962>)+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 +155,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 +186,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 +340,9 @@ -------------------------------------------------------------------------------- -- Pretty-printing                                                            -- --------------------------------------------------------------------------------++instance Show TyCon where+  showsPrec _ c = showString (tyConName c)  instance Show TypeRep where   showsPrec p (splitTyConApp -> (tycon, tys)) =

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} import Data.Rank1Typeable import Data.Rank1Dynamic @@ -36,11 +35,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        ]    , testGroup "Examples of funResultTy"@@ -95,11 +90,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       ]    , testGroup "Examples of dynApply"