diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,17 @@ # Revision history for recover-rtti +## 0.4 -- 2021-06-30 + +* Correctly set some required lower bounds. +* Add support for reclassification +* Add classification equality check +* Add support for primitive arrays and vectors +* Fix classification on OSX +* General internal cleanup of the library + +This release is backwards incompatible with 0.3, but users that simply use +`anythingToString` should be unaffected. + ## 0.3.0.0 -- 2021-03-17 * Fix bug that could cause `anythingToString` to fail on lists with an diff --git a/recover-rtti.cabal b/recover-rtti.cabal --- a/recover-rtti.cabal +++ b/recover-rtti.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: recover-rtti -version: 0.3.0.0 +version: 0.4.0.0 synopsis: Recover run-time type information from the GHC heap description: The main function in this package is 'classify', which looks at the GHC heap to recover type information about arbitrary @@ -24,31 +24,40 @@ library exposed-modules: Debug.RecoverRTTI - - - other-modules: Debug.RecoverRTTI.Classifier Debug.RecoverRTTI.Classify Debug.RecoverRTTI.ClosureTree + + other-modules: Debug.RecoverRTTI.CheckSame + Debug.RecoverRTTI.Classifier + Debug.RecoverRTTI.Constraint Debug.RecoverRTTI.FlatClosure Debug.RecoverRTTI.Modules Debug.RecoverRTTI.Nat + Debug.RecoverRTTI.Reclassify Debug.RecoverRTTI.Tuple Debug.RecoverRTTI.Tuple.Recursive Debug.RecoverRTTI.Tuple.Size Debug.RecoverRTTI.Util Debug.RecoverRTTI.Wrappers - build-depends: base >= 4.13 && < 4.16 - , aeson >= 1.5 && < 1.6 - , bytestring >= 0.10 && < 0.11 - , containers >= 0.6 && < 0.7 - , ghc-heap >= 8.8 && < 9.1 - , mtl >= 2.2 && < 2.3 - , sop-core >= 0.5 && < 0.6 - , stm >= 2.5 && < 2.6 - , text >= 1.2 && < 1.3 - , unordered-containers - , vector + build-depends: base >= 4.13 && < 4.16 + , aeson >= 1.4 && < 1.6 + , bytestring >= 0.10 && < 0.11 + , containers >= 0.6 && < 0.7 + , ghc-heap >= 8.8 && < 9.1 + , mtl >= 2.2 && < 2.3 + , sop-core >= 0.5 && < 0.6 + , stm >= 2.5 && < 2.6 + , text >= 1.2 && < 1.3 + -- 0.2.12 introduces Data.HashMap.Internal.Array + , unordered-containers >= 0.2.12 && < 0.3 + + -- THe oldest ghc we support is 8.8. + -- The dependencies below are the oldest versions of + -- these packages that compile with this ghc version. + , vector >= 0.12.1.2 && < 0.13 + , primitive >= 0.7 && < 0.8 + hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall @@ -59,12 +68,17 @@ type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: RecoverRttiTests.hs - other-modules: Test.RecoverRTTI.Arbitrary + other-modules: Test.RecoverRTTI.Classifier.Arbitrary + Test.RecoverRTTI.Classifier.Equality + Test.RecoverRTTI.Classifier.Size Test.RecoverRTTI.Classify Test.RecoverRTTI.ConcreteClassifier - Test.RecoverRTTI.Orphans - Test.RecoverRTTI.Show + Test.RecoverRTTI.Globals + Test.RecoverRTTI.Prim + Test.RecoverRTTI.QuickCheck.DepGen + Test.RecoverRTTI.QuickCheck.Sized Test.RecoverRTTI.Sanity + Test.RecoverRTTI.Show Test.RecoverRTTI.Staged Test.RecoverRTTI.UserDefined build-depends: base >= 4.13 @@ -76,6 +90,7 @@ , ghc-heap , ghc-prim , mtl + , primitive , QuickCheck , sop-core , stm diff --git a/src/Debug/RecoverRTTI.hs b/src/Debug/RecoverRTTI.hs --- a/src/Debug/RecoverRTTI.hs +++ b/src/Debug/RecoverRTTI.hs @@ -4,27 +4,57 @@ anythingToString -- * Recover type information , classify - , Classifier(..) - , Classifiers(..) - -- ** Pair value with its classifier - , Classified(..) - , classified + , Classifier + , PrimClassifier(..) + , IsUserDefined(..) + -- ** Generalizations + , Classifier_(..) -- ** Unknown or partially known type arguments - , MaybeF(..) - , EitherF(..) - , MaybePairF(..) + , Elem(..) + , Elems(..) -- ** Newtype wrappers for unshowable types , SomeSTRef(..) , SomeTVar(..) , SomeMVar(..) , SomeFun(..) + -- ** Mutable arrays + , SomePrimArrayM(..) + , SomeStorableVector(..) + , SomeStorableVectorM(..) + , SomePrimitiveVector(..) + , SomePrimitiveVectorM(..) + -- * Working with classifiers + -- ** Mapping + , mapClassifier + -- ** Equality + , samePrim + , sameClassifier_ + , sameElem + , sameElems -- * User-defined types , UserDefined -- opaque -- ** Classify constructor arguments + , Classified(..) , fromUserDefined - , Some(..) + -- * Recovering type class instances + -- ** Show + , canShowClassified + , canShowPrim + , canShowClassified_ + -- ** Generic + , PrimSatisfies + , primSatisfies + , ClassifiedSatisfies + , classifiedSatisfies + -- * Reclassification + , Reclassified(..) + , reclassify_ + , distribReclassified + , FromUsr(..) + , coerceFromUsr -- * Inductive tuples - , WrappedTuple(..) + , WrappedTuple(WrappedTuple, TNil, TCons) + , unwrapTuple , Tuple -- ** Translation to/from NP , tupleFromNP @@ -36,16 +66,23 @@ , smallerIsValid , toValidSize , liftValidSize - -- * Type-level naturals + -- * Util + -- ** Type-level naturals , Nat(..) , SNat(..) , KnownNat(..) , Length + -- ** Existentials + , Some(..) + , mapSome ) where +import Debug.RecoverRTTI.CheckSame import Debug.RecoverRTTI.Classifier import Debug.RecoverRTTI.Classify +import Debug.RecoverRTTI.Constraint import Debug.RecoverRTTI.Nat +import Debug.RecoverRTTI.Reclassify import Debug.RecoverRTTI.Tuple import Debug.RecoverRTTI.Util import Debug.RecoverRTTI.Wrappers diff --git a/src/Debug/RecoverRTTI/CheckSame.hs b/src/Debug/RecoverRTTI/CheckSame.hs new file mode 100644 --- /dev/null +++ b/src/Debug/RecoverRTTI/CheckSame.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Debug.RecoverRTTI.CheckSame ( + -- * Check if two classifiers are the same + samePrim + , sameClassifier_ + , sameElem + , sameElems + ) where + +import Data.SOP +import Data.Type.Equality + +import Debug.RecoverRTTI.Classifier + +{------------------------------------------------------------------------------- + Equality check +-------------------------------------------------------------------------------} + +samePrim :: PrimClassifier a -> PrimClassifier b -> Maybe (a :~: b) +samePrim = go + where + go :: PrimClassifier a -> PrimClassifier b -> Maybe (a :~: b) + + -- Primitive types + go C_Bool C_Bool = Just Refl + go C_Char C_Char = Just Refl + go C_Double C_Double = Just Refl + go C_Float C_Float = Just Refl + go C_Int C_Int = Just Refl + go C_Int8 C_Int8 = Just Refl + go C_Int16 C_Int16 = Just Refl + go C_Int32 C_Int32 = Just Refl + go C_Int64 C_Int64 = Just Refl + go C_Integer C_Integer = Just Refl + go C_Ordering C_Ordering = Just Refl + go C_Unit C_Unit = Just Refl + go C_Word C_Word = Just Refl + go C_Word8 C_Word8 = Just Refl + go C_Word16 C_Word16 = Just Refl + go C_Word32 C_Word32 = Just Refl + go C_Word64 C_Word64 = Just Refl + + -- String types + + go C_String C_String = Just Refl + go C_BS_Strict C_BS_Strict = Just Refl + go C_BS_Lazy C_BS_Lazy = Just Refl + go C_BS_Short C_BS_Short = Just Refl + go C_Text_Strict C_Text_Strict = Just Refl + go C_Text_Lazy C_Text_Lazy = Just Refl + + -- Aeson + + go C_Value C_Value = Just Refl + + -- Reference cells + + go C_STRef C_STRef = Just Refl + go C_TVar C_TVar = Just Refl + go C_MVar C_MVar = Just Refl + + -- Containers without type arguments + + go C_IntSet C_IntSet = Just Refl + go C_Prim_ArrayM C_Prim_ArrayM = Just Refl + go C_Vector_Storable C_Vector_Storable = Just Refl + go C_Vector_StorableM C_Vector_StorableM = Just Refl + go C_Vector_Primitive C_Vector_Primitive = Just Refl + go C_Vector_PrimitiveM C_Vector_PrimitiveM = Just Refl + + -- Functions + + go C_Fun C_Fun = Just Refl + + -- Not equal + go _ _ = Nothing + + _checkAllCases :: PrimClassifier a -> () + _checkAllCases = \case + -- Primitive types + + C_Bool -> () + C_Char -> () + C_Double -> () + C_Float -> () + C_Int -> () + C_Int8 -> () + C_Int16 -> () + C_Int32 -> () + C_Int64 -> () + C_Integer -> () + C_Ordering -> () + C_Unit -> () + C_Word -> () + C_Word8 -> () + C_Word16 -> () + C_Word32 -> () + C_Word64 -> () + + -- String types + + C_String -> () + C_BS_Strict -> () + C_BS_Lazy -> () + C_BS_Short -> () + C_Text_Strict -> () + C_Text_Lazy -> () + + -- Aeson + + C_Value -> () + + -- Reference cells + + C_STRef -> () + C_TVar -> () + C_MVar -> () + + -- Containers without type arguments + + C_IntSet -> () + C_Prim_ArrayM -> () + C_Vector_Storable -> () + C_Vector_StorableM -> () + C_Vector_Primitive -> () + C_Vector_PrimitiveM -> () + + -- Functions + + C_Fun -> () + +-- | Check that two classifiers are the same +-- +-- If they are the same, additionally return a proof that that means the +-- /types/ they classify must be equal (note that equality on the classifiers +-- is strictly stronger than equality on the types: for example, non-empty +-- and empty lists have different classifiers, but classify the same type). +-- +-- This is defined on the general type 'Classifier_' rather than on 'Classifier' +-- because different user-defined types may both be classified as @UserDefined@ +-- yet not be equal to each other +sameClassifier_ :: forall o. + (forall a b. o a -> o b -> Maybe (a :~: b)) + -> (forall a b. Classifier_ o a -> Classifier_ o b -> Maybe (a :~: b)) +sameClassifier_ sameOther = go + where + go :: Classifier_ o a -> Classifier_ o b -> Maybe (a :~: b) + + -- User-defined and primitive types + go (C_Prim c) (C_Prim c') = samePrim c c' + go (C_Other c) (C_Other c') = sameOther c c' + + -- Compound + go (C_Maybe c) (C_Maybe c') = sameElems sameOther c c' $ Refl + go (C_Either c) (C_Either c') = sameElems sameOther c c' $ Refl + go (C_List c) (C_List c') = sameElems sameOther c c' $ Refl + go (C_Ratio c) (C_Ratio c') = sameElems sameOther c c' $ Refl + go (C_Set c) (C_Set c') = sameElems sameOther c c' $ Refl + go (C_Map c) (C_Map c') = sameElems sameOther c c' $ Refl + go (C_IntMap c) (C_IntMap c') = sameElems sameOther c c' $ Refl + go (C_Sequence c) (C_Sequence c') = sameElems sameOther c c' $ Refl + go (C_Tree c) (C_Tree c') = sameElems sameOther c c' $ Refl + go (C_HashSet c) (C_HashSet c') = sameElems sameOther c c' $ Refl + go (C_HashMap c) (C_HashMap c') = sameElems sameOther c c' $ Refl + go (C_HM_Array c) (C_HM_Array c') = sameElems sameOther c c' $ Refl + go (C_Prim_Array c) (C_Prim_Array c') = sameElems sameOther c c' $ Refl + go (C_Vector_Boxed c) (C_Vector_Boxed c') = sameElems sameOther c c' $ Refl + go (C_Tuple c) (C_Tuple c') = sameElems sameOther c c' $ Refl + + -- No match + go _ _ = Nothing + where + _checkAllCases :: Classifier_ o a -> () + _checkAllCases = \case + -- Primitive and user-defined + C_Prim{} -> () + C_Other{} -> () + + -- Compound + C_Maybe{} -> () + C_Either{} -> () + C_List{} -> () + C_Ratio{} -> () + C_Set{} -> () + C_Map{} -> () + C_IntMap{} -> () + C_Sequence{} -> () + C_Tree{} -> () + C_HashSet{} -> () + C_HashMap{} -> () + C_HM_Array{} -> () + C_Prim_Array{} -> () + C_Vector_Boxed{} -> () + C_Tuple{} -> () + +sameElem :: forall o. + (forall a b. o a -> o b -> Maybe (a :~: b)) + -> (forall a b. Elem o a -> Elem o b -> Maybe (a :~: b)) +sameElem sameOther = go + where + go :: Elem o a -> Elem o b -> Maybe (a :~: b) + go NoElem NoElem = Just Refl + go NoElem (Elem _) = Nothing + go (Elem _) NoElem = Nothing + go (Elem ca) (Elem cb) = sameClassifier_ sameOther ca cb + +sameElems :: forall o r. + (forall a b. o a -> o b -> Maybe (a :~: b)) + -> (forall as bs. Elems o as -> Elems o bs -> (as ~ bs => r) -> Maybe r) +sameElems sameOther = go + where + go :: Elems o as -> Elems o bs -> (as ~ bs => r) -> Maybe r + go (Elems Nil) (Elems Nil) k = Just k + go (Elems Nil) (Elems (_ :* _)) _ = Nothing + go (Elems (_ :* _)) (Elems Nil) _ = Nothing + go (Elems (c :* cs)) (Elems (c' :* cs')) k = do + Refl <- sameElem sameOther c c' + go (Elems cs) (Elems cs') k diff --git a/src/Debug/RecoverRTTI/Classifier.hs b/src/Debug/RecoverRTTI/Classifier.hs --- a/src/Debug/RecoverRTTI/Classifier.hs +++ b/src/Debug/RecoverRTTI/Classifier.hs @@ -1,16 +1,25 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} module Debug.RecoverRTTI.Classifier ( - Classifier(..) - , Classifiers(..) - , Classified(..) - -- * Partial information - , MaybeF(..) - , EitherF(..) - , MaybePairF(..) + Classifier + , PrimClassifier(..) + , IsUserDefined(..) + -- * Generalizations + , Classifier_(..) + -- * Nested classification + , Elem(..) + , Elems(..) + -- * Mapping + , mapClassifier ) where import Data.Aeson (Value) @@ -25,6 +34,7 @@ import Data.Sequence (Seq) import Data.Set (Set) import Data.SOP +import Data.SOP.Dict import Data.Tree (Tree) import Data.Void import Data.Word @@ -33,6 +43,7 @@ import qualified Data.ByteString.Lazy as BS.Lazy import qualified Data.ByteString.Short as BS.Short import qualified Data.HashMap.Internal.Array as HashMap (Array) +import qualified Data.Primitive.Array as Prim (Array) import qualified Data.Text as Text.Strict import qualified Data.Text.Lazy as Text.Lazy import qualified Data.Vector as Vector.Boxed @@ -45,55 +56,44 @@ Classifier -------------------------------------------------------------------------------} --- | A value along with its classifier -data Classified a = Classified { - classifiedType :: Classifier a - , classifiedValue :: a - } - -- | Classifier -- -- Given a value of some unknown type @a@, a @Classifier a@ will tell you what -- the type of @a@ is. This is similar to a @TypeRep@, but since we recover -- this information from the heap, we have less accurate type information than -- @TypeRep@ does. -data Classifier (a :: Type) :: Type where - -- Primitive types - - C_Bool :: Classifier Bool - C_Char :: Classifier Char - C_Double :: Classifier Double - C_Float :: Classifier Float - C_Int :: Classifier Int - C_Int16 :: Classifier Int16 - C_Int8 :: Classifier Int8 - C_Int32 :: Classifier Int32 - C_Int64 :: Classifier Int64 - C_Integer :: Classifier Integer - C_Ordering :: Classifier Ordering - C_Unit :: Classifier () - C_Word :: Classifier Word - C_Word8 :: Classifier Word8 - C_Word16 :: Classifier Word16 - C_Word32 :: Classifier Word32 - C_Word64 :: Classifier Word64 +type Classifier = Classifier_ IsUserDefined - -- String types - -- - -- We list @String@ separately, so that we show them properly (rather than - -- as a list of characters). Of course, empty strings will be inferred as - -- empty lists instead. +-- | User-defined types +-- +-- If we classify a type as user-defined, we pair the classifier with the +-- original value. This means that a @Classifier@ is sufficient information +-- for staged inference by client code that may wish to further classify these +-- types given additional domain knowledge (see also 'reclassify_'). +data IsUserDefined a where + IsUserDefined :: UserDefined -> IsUserDefined UserDefined - C_String :: Classifier String - C_BS_Strict :: Classifier BS.Strict.ByteString - C_BS_Lazy :: Classifier BS.Lazy.ByteString - C_BS_Short :: Classifier BS.Short.ShortByteString - C_Text_Strict :: Classifier Text.Strict.Text - C_Text_Lazy :: Classifier Text.Lazy.Text +instance Show (IsUserDefined a) where + show (IsUserDefined _) = "IsUserDefined" - -- Aeson +{------------------------------------------------------------------------------- + Generalizations +-------------------------------------------------------------------------------} - C_Value :: Classifier Value +-- | Generalization of 'Classifier' +-- +-- Type arguments: +-- +-- * @o@: Classification of " other " types (not explicitly known to the lib) +-- +-- Normally we instantiate this to 'IsUserDefined', classifying all unknown +-- types as 'UserDefined'. +-- +-- * @a@: The type we're actually classifying +data Classifier_ (o :: Type -> Type) (a :: Type) :: Type where + -- Primitive and user-defined types + C_Prim :: PrimClassifier a -> Classifier_ o a + C_Other :: o a -> Classifier_ o a -- Compound -- @@ -103,53 +103,150 @@ -- as a 'HashSet'; however, we can only do this of course if we have at -- least one element. - C_Maybe :: MaybeF Classified a -> Classifier (Maybe a) - C_Either :: EitherF Classified a b -> Classifier (Either a b) - C_List :: MaybeF Classified a -> Classifier [a] - C_Ratio :: Classified a -> Classifier (Ratio a) - C_Set :: MaybeF Classified a -> Classifier (Set a) - C_Map :: MaybePairF Classified a b -> Classifier (Map a b) - C_IntSet :: Classifier IntSet - C_IntMap :: MaybeF Classified a -> Classifier (IntMap a) - C_Sequence :: MaybeF Classified a -> Classifier (Seq a) - C_Tree :: Classified a -> Classifier (Tree a) - C_HashSet :: Classified a -> Classifier (HashSet a) - C_HashMap :: MaybePairF Classified a b -> Classifier (HashMap a b) - C_HM_Array :: MaybeF Classified a -> Classifier (HashMap.Array a) - C_Vector_Boxed :: MaybeF Classified a -> Classifier (Vector.Boxed.Vector a) + C_Maybe :: Elems o '[a] -> Classifier_ o (Maybe a) + C_Either :: Elems o '[a, b] -> Classifier_ o (Either a b) + C_List :: Elems o '[a] -> Classifier_ o [a] + C_Ratio :: Elems o '[a] -> Classifier_ o (Ratio a) + C_Set :: Elems o '[a] -> Classifier_ o (Set a) + C_Map :: Elems o '[a, b] -> Classifier_ o (Map a b) + C_IntMap :: Elems o '[a] -> Classifier_ o (IntMap a) + C_Sequence :: Elems o '[a] -> Classifier_ o (Seq a) + C_Tree :: Elems o '[a] -> Classifier_ o (Tree a) + C_HashSet :: Elems o '[a] -> Classifier_ o (HashSet a) + C_HashMap :: Elems o '[a, b] -> Classifier_ o (HashMap a b) + C_HM_Array :: Elems o '[a] -> Classifier_ o (HashMap.Array a) + C_Prim_Array :: Elems o '[a] -> Classifier_ o (Prim.Array a) + C_Vector_Boxed :: Elems o '[a] -> Classifier_ o (Vector.Boxed.Vector a) C_Tuple :: (SListI xs, IsValidSize (Length xs)) - => Classifiers xs -> Classifier (WrappedTuple xs) + => Elems o xs -> Classifier_ o (WrappedTuple xs) +-- | Classifier for primitive types +data PrimClassifier (a :: Type) where + -- Primitive types + + C_Bool :: PrimClassifier Bool + C_Char :: PrimClassifier Char + C_Double :: PrimClassifier Double + C_Float :: PrimClassifier Float + C_Int :: PrimClassifier Int + C_Int16 :: PrimClassifier Int16 + C_Int8 :: PrimClassifier Int8 + C_Int32 :: PrimClassifier Int32 + C_Int64 :: PrimClassifier Int64 + C_Integer :: PrimClassifier Integer + C_Ordering :: PrimClassifier Ordering + C_Unit :: PrimClassifier () + C_Word :: PrimClassifier Word + C_Word8 :: PrimClassifier Word8 + C_Word16 :: PrimClassifier Word16 + C_Word32 :: PrimClassifier Word32 + C_Word64 :: PrimClassifier Word64 + + -- String types + -- + -- We list @String@ separately, so that we show them properly (rather than + -- as a list of characters). Of course, empty strings will be inferred as + -- empty lists instead. + + C_String :: PrimClassifier String + C_BS_Strict :: PrimClassifier BS.Strict.ByteString + C_BS_Lazy :: PrimClassifier BS.Lazy.ByteString + C_BS_Short :: PrimClassifier BS.Short.ShortByteString + C_Text_Strict :: PrimClassifier Text.Strict.Text + C_Text_Lazy :: PrimClassifier Text.Lazy.Text + + -- Aeson + + C_Value :: PrimClassifier Value + -- Reference cells - C_STRef :: Classifier SomeSTRef - C_TVar :: Classifier SomeTVar - C_MVar :: Classifier SomeMVar + C_STRef :: PrimClassifier SomeSTRef + C_TVar :: PrimClassifier SomeTVar + C_MVar :: PrimClassifier SomeMVar -- Functions - C_Fun :: Classifier SomeFun + C_Fun :: PrimClassifier SomeFun - -- User-defined + -- Containers with no type arguments + -- + -- We include mutable containers here, because we currently do not attempt + -- to peek inside them and hence cannot infer any types for their elements. - C_Custom :: Classifier UserDefined + C_IntSet :: PrimClassifier IntSet + C_Prim_ArrayM :: PrimClassifier SomePrimArrayM + C_Vector_Storable :: PrimClassifier SomeStorableVector + C_Vector_StorableM :: PrimClassifier SomeStorableVectorM + C_Vector_Primitive :: PrimClassifier SomePrimitiveVector + C_Vector_PrimitiveM :: PrimClassifier SomePrimitiveVectorM -newtype Classifiers xs = Classifiers (NP Classified xs) +{------------------------------------------------------------------------------- + Nested classification +-------------------------------------------------------------------------------} +data Elem o a where + Elem :: Classifier_ o a -> Elem o a + NoElem :: Elem o Void + +newtype Elems o xs = Elems (NP (Elem o) xs) + {------------------------------------------------------------------------------- - Partial information + Show -------------------------------------------------------------------------------} -data MaybeF f a where - FNothing :: MaybeF f Void - FJust :: f a -> MaybeF f a +deriving instance Show (PrimClassifier a) -data EitherF f a b where - FLeft :: f a -> EitherF f a Void - FRight :: f b -> EitherF f Void b +deriving instance (forall x. Show (o x)) => Show (Classifier_ o a) +deriving instance (forall x. Show (o x)) => Show (Elem o a) -data MaybePairF f a b where - FNothingPair :: MaybePairF f Void Void - FJustPair :: f a -> f b -> MaybePairF f a b +instance (forall a. Show (o a), SListI xs) => Show (Elems o xs) where + showsPrec p (Elems xs) = + case all_NP allShow of + Dict -> showsPrec p xs + where + allShow :: NP (Dict (Compose Show (Elem o))) xs + allShow = hpure Dict + +{------------------------------------------------------------------------------- + Map over classifiers +-------------------------------------------------------------------------------} + +mapClassifier :: forall m o o'. + Applicative m + => (forall a. o a -> m (o' a)) + -> (forall a. Classifier_ o a -> m (Classifier_ o' a)) +mapClassifier other = go + where + go :: forall a. Classifier_ o a -> m (Classifier_ o' a) + -- Primitive and user-defined types + + go (C_Prim c) = pure (C_Prim c) + go (C_Other c) = C_Other <$> other c + + -- Compound + + go (C_Maybe c) = C_Maybe <$> goElems c + go (C_Either c) = C_Either <$> goElems c + go (C_List c) = C_List <$> goElems c + go (C_Ratio c) = C_Ratio <$> goElems c + go (C_Set c) = C_Set <$> goElems c + go (C_Map c) = C_Map <$> goElems c + go (C_IntMap c) = C_IntMap <$> goElems c + go (C_Sequence c) = C_Sequence <$> goElems c + go (C_Tree c) = C_Tree <$> goElems c + go (C_HashSet c) = C_HashSet <$> goElems c + go (C_HashMap c) = C_HashMap <$> goElems c + go (C_HM_Array c) = C_HM_Array <$> goElems c + go (C_Prim_Array c) = C_Prim_Array <$> goElems c + go (C_Vector_Boxed c) = C_Vector_Boxed <$> goElems c + go (C_Tuple c) = C_Tuple <$> goElems c + + goElems :: SListI xs => Elems o xs -> m (Elems o' xs) + goElems (Elems cs) = Elems <$> htraverse' goElem cs + + goElem :: Elem o a -> m (Elem o' a) + goElem (Elem c) = Elem <$> go c + goElem NoElem = pure NoElem diff --git a/src/Debug/RecoverRTTI/Classify.hs b/src/Debug/RecoverRTTI/Classify.hs --- a/src/Debug/RecoverRTTI/Classify.hs +++ b/src/Debug/RecoverRTTI/Classify.hs @@ -1,8 +1,11 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} @@ -16,11 +19,21 @@ module Debug.RecoverRTTI.Classify ( -- * Classification classify - , classified + -- * User-defined types + , Classified(..) , fromUserDefined -- * Showing values , anythingToString + , canShowPrim , canShowClassified + , canShowClassified_ + -- * Patterns for common shapes of 'Elems' (exported for the tests) + , pattern ElemK + , pattern ElemU + , pattern ElemKK + , pattern ElemUU + , pattern ElemKU + , pattern ElemUK ) where import Control.Monad.Except @@ -32,22 +45,24 @@ import Data.SOP import Data.SOP.Dict import Data.Tree (Tree) +import Data.Void import GHC.Exts.Heap (Closure) import GHC.Real import System.IO.Unsafe (unsafePerformIO) import Unsafe.Coerce (unsafeCoerce) +import qualified Data.Foldable as Foldable import qualified Data.HashMap.Internal.Array as HashMap (Array) import qualified Data.HashMap.Internal.Array as HashMap.Array import qualified Data.HashMap.Lazy as HashMap -import qualified Data.IntMap as IntMap import qualified Data.Map as Map -import qualified Data.Sequence as Seq -import qualified Data.Set as Set +import qualified Data.Primitive.Array as Prim.Array +import qualified Data.Primitive.Array as Prim (Array) import qualified Data.Tree as Tree import qualified Data.Vector as Vector.Boxed import Debug.RecoverRTTI.Classifier +import Debug.RecoverRTTI.Constraint import Debug.RecoverRTTI.FlatClosure import Debug.RecoverRTTI.Modules import Debug.RecoverRTTI.Nat @@ -68,65 +83,65 @@ -- -- GHC.Types - (inKnownModule GhcTypes -> Just "True") -> return $ mustBe C_Bool - (inKnownModule GhcTypes -> Just "False") -> return $ mustBe C_Bool - (inKnownModule GhcTypes -> Just "C#") -> return $ mustBe C_Char - (inKnownModule GhcTypes -> Just "D#") -> return $ mustBe C_Double - (inKnownModule GhcTypes -> Just "F#") -> return $ mustBe C_Float - (inKnownModule GhcTypes -> Just "I#") -> return $ mustBe C_Int - (inKnownModule GhcTypes -> Just "LT") -> return $ mustBe C_Ordering - (inKnownModule GhcTypes -> Just "GT") -> return $ mustBe C_Ordering - (inKnownModule GhcTypes -> Just "EQ") -> return $ mustBe C_Ordering - (inKnownModule GhcTypes -> Just "W#") -> return $ mustBe C_Word + (inKnownModule GhcTypes -> Just "True") -> return $ mustBe $ C_Prim C_Bool + (inKnownModule GhcTypes -> Just "False") -> return $ mustBe $ C_Prim C_Bool + (inKnownModule GhcTypes -> Just "C#") -> return $ mustBe $ C_Prim C_Char + (inKnownModule GhcTypes -> Just "D#") -> return $ mustBe $ C_Prim C_Double + (inKnownModule GhcTypes -> Just "F#") -> return $ mustBe $ C_Prim C_Float + (inKnownModule GhcTypes -> Just "I#") -> return $ mustBe $ C_Prim C_Int + (inKnownModule GhcTypes -> Just "LT") -> return $ mustBe $ C_Prim C_Ordering + (inKnownModule GhcTypes -> Just "GT") -> return $ mustBe $ C_Prim C_Ordering + (inKnownModule GhcTypes -> Just "EQ") -> return $ mustBe $ C_Prim C_Ordering + (inKnownModule GhcTypes -> Just "W#") -> return $ mustBe $ C_Prim C_Word -- GHC.Tuple - (inKnownModule GhcTuple -> Just "()") -> return $ mustBe C_Unit + (inKnownModule GhcTuple -> Just "()") -> return $ mustBe $ C_Prim C_Unit -- GHC.Int - (inKnownModule GhcInt -> Just "I8#") -> return $ mustBe C_Int8 - (inKnownModule GhcInt -> Just "I16#") -> return $ mustBe C_Int16 - (inKnownModule GhcInt -> Just "I32#") -> return $ mustBe C_Int32 - (inKnownModule GhcInt -> Just "I64#") -> return $ mustBe C_Int64 + (inKnownModule GhcInt -> Just "I8#") -> return $ mustBe $ C_Prim C_Int8 + (inKnownModule GhcInt -> Just "I16#") -> return $ mustBe $ C_Prim C_Int16 + (inKnownModule GhcInt -> Just "I32#") -> return $ mustBe $ C_Prim C_Int32 + (inKnownModule GhcInt -> Just "I64#") -> return $ mustBe $ C_Prim C_Int64 -- GHC.Integer - (inKnownModule GhcIntegerType -> Just "S#") -> return $ mustBe C_Integer - (inKnownModule GhcIntegerType -> Just "Jp#") -> return $ mustBe C_Integer - (inKnownModule GhcIntegerType -> Just "Jn#") -> return $ mustBe C_Integer - (inKnownModule GhcNumInteger -> Just "IS") -> return $ mustBe C_Integer - (inKnownModule GhcNumInteger -> Just "IP") -> return $ mustBe C_Integer - (inKnownModule GhcNumInteger -> Just "IN") -> return $ mustBe C_Integer + (inKnownModule GhcIntegerType -> Just "S#") -> return $ mustBe $ C_Prim C_Integer + (inKnownModule GhcIntegerType -> Just "Jp#") -> return $ mustBe $ C_Prim C_Integer + (inKnownModule GhcIntegerType -> Just "Jn#") -> return $ mustBe $ C_Prim C_Integer + (inKnownModule GhcNumInteger -> Just "IS") -> return $ mustBe $ C_Prim C_Integer + (inKnownModule GhcNumInteger -> Just "IP") -> return $ mustBe $ C_Prim C_Integer + (inKnownModule GhcNumInteger -> Just "IN") -> return $ mustBe $ C_Prim C_Integer -- GHC.Word - (inKnownModule GhcWord -> Just "W8#") -> return $ mustBe C_Word8 - (inKnownModule GhcWord -> Just "W16#") -> return $ mustBe C_Word16 - (inKnownModule GhcWord -> Just "W32#") -> return $ mustBe C_Word32 - (inKnownModule GhcWord -> Just "W64#") -> return $ mustBe C_Word64 + (inKnownModule GhcWord -> Just "W8#") -> return $ mustBe $ C_Prim C_Word8 + (inKnownModule GhcWord -> Just "W16#") -> return $ mustBe $ C_Prim C_Word16 + (inKnownModule GhcWord -> Just "W32#") -> return $ mustBe $ C_Prim C_Word32 + (inKnownModule GhcWord -> Just "W64#") -> return $ mustBe $ C_Prim C_Word64 -- -- String types -- -- bytestring - (inKnownModule DataByteStringInternal -> Just "PS") -> return $ mustBe C_BS_Strict - (inKnownModule DataByteStringLazyInternal -> Just "Empty") -> return $ mustBe C_BS_Lazy - (inKnownModule DataByteStringLazyInternal -> Just "Chunk") -> return $ mustBe C_BS_Lazy - (inKnownModule DataByteStringShortInternal -> Just "SBS") -> return $ mustBe C_BS_Short + (inKnownModule DataByteStringInternal -> Just "PS") -> return $ mustBe $ C_Prim C_BS_Strict + (inKnownModule DataByteStringLazyInternal -> Just "Empty") -> return $ mustBe $ C_Prim C_BS_Lazy + (inKnownModule DataByteStringLazyInternal -> Just "Chunk") -> return $ mustBe $ C_Prim C_BS_Lazy + (inKnownModule DataByteStringShortInternal -> Just "SBS") -> return $ mustBe $ C_Prim C_BS_Short -- text - (inKnownModule DataTextInternal -> Just "Text") -> return $ mustBe C_Text_Strict - (inKnownModule DataTextInternalLazy -> Just "Chunk") -> return $ mustBe C_Text_Lazy - (inKnownModule DataTextInternalLazy -> Just "Empty") -> return $ mustBe C_Text_Lazy + (inKnownModule DataTextInternal -> Just "Text") -> return $ mustBe $ C_Prim C_Text_Strict + (inKnownModule DataTextInternalLazy -> Just "Chunk") -> return $ mustBe $ C_Prim C_Text_Lazy + (inKnownModule DataTextInternalLazy -> Just "Empty") -> return $ mustBe $ C_Prim C_Text_Lazy -- -- Aeson -- - (inKnownModule DataAesonTypesInternal -> Just "Object") -> return $ mustBe C_Value - (inKnownModule DataAesonTypesInternal -> Just "Array") -> return $ mustBe C_Value - (inKnownModule DataAesonTypesInternal -> Just "String") -> return $ mustBe C_Value - (inKnownModule DataAesonTypesInternal -> Just "Number") -> return $ mustBe C_Value - (inKnownModule DataAesonTypesInternal -> Just "Bool") -> return $ mustBe C_Value - (inKnownModule DataAesonTypesInternal -> Just "Null") -> return $ mustBe C_Value + (inKnownModule DataAesonTypesInternal -> Just "Object") -> return $ mustBe $ C_Prim C_Value + (inKnownModule DataAesonTypesInternal -> Just "Array") -> return $ mustBe $ C_Prim C_Value + (inKnownModule DataAesonTypesInternal -> Just "String") -> return $ mustBe $ C_Prim C_Value + (inKnownModule DataAesonTypesInternal -> Just "Number") -> return $ mustBe $ C_Prim C_Value + (inKnownModule DataAesonTypesInternal -> Just "Bool") -> return $ mustBe $ C_Prim C_Value + (inKnownModule DataAesonTypesInternal -> Just "Null") -> return $ mustBe $ C_Prim C_Value -- -- Compound (ghc-prim) @@ -168,11 +183,11 @@ -- IntSet (inKnownModule DataIntSetInternal -> Just "Bin") -> - return $ mustBe $ C_IntSet + return $ mustBe $ C_Prim C_IntSet (inKnownModule DataIntSetInternal -> Just "Tip") -> - return $ mustBe $ C_IntSet + return $ mustBe $ C_Prim C_IntSet (inKnownModule DataIntSetInternal -> Just "Nil") -> - return $ mustBe $ C_IntSet + return $ mustBe $ C_Prim C_IntSet -- IntMap (inKnownModule DataIntMapInternal -> Just "Nil") -> @@ -221,30 +236,48 @@ (inKnownModule DataHashMapInternalArray -> Just "Array") -> mustBe <$> classifyHMArray (unsafeCoerce x) + -- Arrays from @primitive@ + (inKnownModule DataPrimitiveArray -> Just "Array") -> + mustBe <$> classifyPrimArray (unsafeCoerce x) + (inKnownModule DataPrimitiveArray -> Just "MutableArray") -> + return $ mustBe $ C_Prim C_Prim_ArrayM + -- Boxed vectors (inKnownModule DataVector -> Just "Vector") -> mustBe <$> classifyVectorBoxed (unsafeCoerce x) + -- Storable vectors + (inKnownModule DataVectorStorable -> Just "Vector") -> + return $ mustBe $ C_Prim C_Vector_Storable + (inKnownModule DataVectorStorableMutable -> Just "MVector") -> + return $ mustBe $ C_Prim C_Vector_StorableM + + -- Primitive vectors + (inKnownModule DataVectorPrimitive -> Just "Vector") -> + return $ mustBe $ C_Prim C_Vector_Primitive + (inKnownModule DataVectorPrimitiveMutable -> Just "MVector") -> + return $ mustBe $ C_Prim C_Vector_PrimitiveM + -- -- Reference cells -- - (inKnownModule GhcSTRef -> Just "STRef") -> return $ mustBe C_STRef - (inKnownModule GhcMVar -> Just "MVar") -> return $ mustBe C_MVar - (inKnownModule GhcConcSync -> Just "TVar") -> return $ mustBe C_TVar + (inKnownModule GhcSTRef -> Just "STRef") -> return $ mustBe $ C_Prim C_STRef + (inKnownModule GhcMVar -> Just "MVar") -> return $ mustBe $ C_Prim C_MVar + (inKnownModule GhcConcSync -> Just "TVar") -> return $ mustBe $ C_Prim C_TVar -- -- Functions -- - FunClosure {} -> return $ mustBe C_Fun + FunClosure {} -> return $ mustBe $ C_Prim C_Fun -- -- User defined -- ConstrClosure {} -> - return $ mustBe C_Custom + return $ mustBe $ C_Other (IsUserDefined (unsafeCoerce x)) -- -- Classification failed @@ -252,7 +285,7 @@ OtherClosure other -> ExceptT $ return (Left other) -mustBe :: Classifier b -> Classifier a +mustBe :: Classifier_ o b -> Classifier_ o a mustBe = unsafeCoerce -- | Classify a value @@ -271,131 +304,78 @@ Classification for compound types -------------------------------------------------------------------------------} -classifyMaybe :: - Maybe a - -> ExceptT Closure IO (Classifier (Maybe a)) -classifyMaybe x = - case x of - Nothing -> return $ mustBe $ C_Maybe FNothing - Just x' -> do - cx <- classifyIO x' - return $ mustBe $ C_Maybe (FJust (Classified cx x')) +classifyMaybe :: Maybe a -> ExceptT Closure IO (Classifier (Maybe a)) +classifyMaybe = classifyFoldable C_Maybe classifyEither :: Either a b -> ExceptT Closure IO (Classifier (Either a b)) classifyEither x = case x of - Left x' -> do - cx <- classifyIO x' - return $ mustBe $ C_Either (FLeft (Classified cx x')) - Right y' -> do - cy <- classifyIO y' - return $ mustBe $ C_Either (FRight (Classified cy y')) + Left x' -> (mustBe . C_Either . ElemKU) <$> classifyIO x' + Right y' -> (mustBe . C_Either . ElemUK) <$> classifyIO y' -classifyList :: - [a] - -> ExceptT Closure IO (Classifier [a]) -classifyList x = - case x of - [] -> return $ mustBe $ C_List FNothing - x':_ -> do - cx <- classifyIO x' - return $ case cx of - C_Char -> mustBe $ C_String - _otherwise -> mustBe $ C_List (FJust (Classified cx x')) +classifyList :: [a] -> ExceptT Closure IO (Classifier [a]) +classifyList = classifyFoldable c_list + where + -- We special case for @String@, so that @show@ will use the (overlapped) + -- instance for @String@ instead of the general instance for @[a]@ + c_list :: Elems o '[x] -> Classifier_ o [x] + c_list (ElemK (C_Prim C_Char)) = C_Prim C_String + c_list c = C_List c -classifyRatio :: - Ratio a - -> ExceptT Closure IO (Classifier (Ratio a)) -classifyRatio (x' :% _) = do - cx <- classifyIO x' - return $ mustBe $ C_Ratio (Classified cx x') +classifyRatio :: Ratio a -> ExceptT Closure IO (Classifier (Ratio a)) +classifyRatio (x' :% _) = mustBe . C_Ratio . ElemK <$> classifyIO x' -classifySet :: - Set a - -> ExceptT Closure IO (Classifier (Set a)) -classifySet x = - case Set.lookupMin x of - Nothing -> return $ mustBe $ C_Set FNothing - Just x' -> do - cx <- classifyIO x' - return $ mustBe $ C_Set (FJust (Classified cx x')) +classifySet :: Set a -> ExceptT Closure IO (Classifier (Set a)) +classifySet = classifyFoldable C_Set -classifyMap :: - Map a b - -> ExceptT Closure IO (Classifier (Map a b)) -classifyMap x = - case Map.lookupMin x of - Nothing -> return $ mustBe $ C_Map FNothingPair - Just (x', y') -> do - cx <- classifyIO x' - cy <- classifyIO y' - return $ mustBe $ C_Map (FJustPair (Classified cx x') (Classified cy y')) +classifyMap :: Map a b -> ExceptT Closure IO (Classifier (Map a b)) +classifyMap = classifyFoldablePair C_Map Map.toList -classifyIntMap :: - IntMap a - -> ExceptT Closure IO (Classifier (IntMap a)) -classifyIntMap x = - case IntMap.minView x of - Nothing -> return $ mustBe $ C_IntMap FNothing - Just (x', _) -> do - cx <- classifyIO x' - return $ mustBe $ C_IntMap (FJust (Classified cx x')) +classifyIntMap :: IntMap a -> ExceptT Closure IO (Classifier (IntMap a)) +classifyIntMap = classifyFoldable C_IntMap -classifySequence :: - Seq a - -> ExceptT Closure IO (Classifier (Seq a)) -classifySequence x = - case Seq.viewl x of - Seq.EmptyL -> return $ mustBe $ C_Sequence FNothing - x' Seq.:< _ -> do - cx <- classifyIO x' - return $ mustBe $ C_Sequence (FJust (Classified cx x')) +classifySequence :: Seq a -> ExceptT Closure IO (Classifier (Seq a)) +classifySequence = classifyFoldable C_Sequence -classifyTree :: - Tree a - -> ExceptT Closure IO (Classifier (Tree a)) -classifyTree x = - case x of - Tree.Node x' _ -> do - cx <- classifyIO x' - return $ mustBe $ C_Tree (Classified cx x') +classifyTree :: Tree a -> ExceptT Closure IO (Classifier (Tree a)) +classifyTree (Tree.Node x' _) = mustBe . C_Tree . ElemK <$> classifyIO x' -classifyHashMap :: - HashMap a b - -> ExceptT Closure IO (Classifier (HashMap a b)) -classifyHashMap x = - case HashMap.toList x of - [] -> return $ mustBe $ C_HashMap FNothingPair - ((x', y'):_) -> do - cx <- classifyIO x' - cy <- classifyIO y' - return $ case cy of - C_Unit -> mustBe $ C_HashSet (Classified cx x') - _otherwise -> mustBe $ C_HashMap (FJustPair (Classified cx x') (Classified cy y')) +classifyHashMap :: HashMap a b -> ExceptT Closure IO (Classifier (HashMap a b)) +classifyHashMap = classifyFoldablePair c_hashmap HashMap.toList + where + -- HashSet is a newtype around HashMap + c_hashmap :: Elems o '[x, y] -> Classifier_ o (HashMap x y) + c_hashmap (ElemKK c (C_Prim C_Unit)) = mustBe $ C_HashSet (ElemK c) + c_hashmap c = C_HashMap c classifyHMArray :: HashMap.Array a - -> ExceptT Closure IO (Classifier (Tree a)) -classifyHMArray x = - if HashMap.Array.length x == 0 - then return $ mustBe $ C_HM_Array FNothing - else do - let x' = HashMap.Array.index x 0 - cx <- classifyIO x' - return $ mustBe $ C_HM_Array (FJust (Classified cx x')) + -> ExceptT Closure IO (Classifier (HashMap.Array a)) +classifyHMArray = + classifyArrayLike + C_HM_Array + HashMap.Array.length + (`HashMap.Array.index` 0) +classifyPrimArray :: + Prim.Array a + -> ExceptT Closure IO (Classifier (Prim.Array a)) +classifyPrimArray = + classifyArrayLike + C_Prim_Array + Prim.Array.sizeofArray + (`Prim.Array.indexArray` 0) + classifyVectorBoxed :: Vector.Boxed.Vector a -> ExceptT Closure IO (Classifier (Vector.Boxed.Vector a)) -classifyVectorBoxed x = - if Vector.Boxed.length x == 0 - then return $ mustBe $ C_Vector_Boxed FNothing - else do - let x' = Vector.Boxed.head x - cx <- classifyIO x' - return $ mustBe $ C_Vector_Boxed (FJust (Classified cx x')) +classifyVectorBoxed = + classifyArrayLike + C_Vector_Boxed + Vector.Boxed.length + Vector.Boxed.head classifyTuple :: (SListI xs, IsValidSize (Length xs)) @@ -403,14 +383,75 @@ -> ExceptT Closure IO (Classifier (WrappedTuple xs)) classifyTuple ptrs = do cs <- hsequence' (hmap aux ptrs) - return $ C_Tuple (Classifiers cs) + return $ C_Tuple (Elems (hmap Elem cs)) where - aux :: K Box a -> (ExceptT Closure IO :.: Classified) a - aux (K (Box x)) = Comp $ do - c <- classifyIO (unsafeCoerce x) - return $ Classified c (unsafeCoerce x) + aux :: K Box a -> (ExceptT Closure IO :.: Classifier) a + aux (K (Box x)) = Comp $ classifyIO (unsafeCoerce x) {------------------------------------------------------------------------------- + Helper functions for defining classifiers +-------------------------------------------------------------------------------} + +classifyFoldable :: + Foldable f + => (forall o x. Elems o '[x] -> Classifier_ o (f x)) + -> f a -> ExceptT Closure IO (Classifier (f a)) +classifyFoldable cc x = + case Foldable.toList x of + [] -> return $ mustBe $ cc ElemU + x':_ -> mustBe . cc . ElemK <$> classifyIO x' + +classifyFoldablePair :: + (forall o x y. Elems o '[x, y] -> Classifier_ o (f x y)) + -> (f a b -> [(a, b)]) + -> f a b -> ExceptT Closure IO (Classifier (f a b)) +classifyFoldablePair cc toList x = + case toList x of + [] -> return $ mustBe $ cc ElemUU + (x', y'):_ -> (\ca cb -> mustBe $ cc (ElemKK ca cb)) + <$> classifyIO x' + <*> classifyIO y' + +classifyArrayLike :: + (forall o x. Elems o '[x] -> Classifier_ o (f x)) + -> (f a -> Int) -- ^ Get the length of the array + -> (f a -> a) -- ^ Get the first element (provided the array is not empty) + -> f a -> ExceptT Closure IO (Classifier (f a)) +classifyArrayLike cc getLen getFirst x = + if getLen x == 0 + then return $ mustBe $ cc ElemU + else do + let x' = getFirst x + mustBe . cc . ElemK <$> classifyIO x' + +{------------------------------------------------------------------------------- + Patterns for common shapes of 'Elems' + + This is mostly useful internally; we export these only for the benefit of the + QuickCheck generator. Most other code can treat the all types uniformly. + + We distinguish between which elements are (K)nown and which (U)nknown +-------------------------------------------------------------------------------} + +pattern ElemK :: Classifier_ o a -> Elems o '[a] +pattern ElemK c = Elems (Elem c :* Nil) + +pattern ElemU :: Elems o '[Void] +pattern ElemU = Elems (NoElem :* Nil) + +pattern ElemKK :: Classifier_ o a -> Classifier_ o b -> Elems o '[a, b] +pattern ElemKK ca cb = Elems (Elem ca :* Elem cb :* Nil) + +pattern ElemUU :: Elems o '[Void, Void] +pattern ElemUU = Elems (NoElem :* NoElem :* Nil) + +pattern ElemKU :: Classifier_ o a -> Elems o '[a, Void] +pattern ElemKU c = Elems (Elem c :* NoElem :* Nil) + +pattern ElemUK :: Classifier_ o b -> Elems o '[Void, b] +pattern ElemUK c = Elems (NoElem :* Elem c :* Nil) + +{------------------------------------------------------------------------------- Recognizing tuples -------------------------------------------------------------------------------} @@ -421,16 +462,12 @@ toValidSize (length xs + 1) {------------------------------------------------------------------------------- - Classified values --------------------------------------------------------------------------------} - -classified :: a -> Either Closure (Classified a) -classified x = (\cx -> Classified cx x) <$> classify x - -{------------------------------------------------------------------------------- Classify constructor arguments -------------------------------------------------------------------------------} +-- | Bundle a value with its classifier +data Classified a = Classified (Classifier a) a + -- | Classify the arguments to the constructor -- -- Additionally returns the constructor name itself. @@ -478,14 +515,11 @@ -- If classification fails, we show the actual closure. anythingToString :: forall a. a -> String anythingToString x = - case classified x of - Right classifier -> showClassifiedValue 0 classifier "" + case classify x of Left closure -> show closure + Right classifier -> case canShowClassified classifier of + Dict -> show x -deriving instance Show (Classifier a) -deriving instance Show (MaybeF Classified a) -deriving instance Show (EitherF Classified a b) -deriving instance Show (MaybePairF Classified a b) deriving instance Show (Some Classified) instance Show (Classified a) where @@ -497,14 +531,6 @@ . showString " " . showsPrec 11 x -instance SListI xs => Show (Classifiers xs) where - show (Classifiers xs) = go (hpure Dict) - where - go :: NP (Dict (Compose Show Classified)) xs -> String - go dicts = - case all_NP dicts of - Dict -> "(" ++ show xs ++ ")" - -- | Show the classified value (without the classifier) showClassifiedValue :: Int -> Classified a -> ShowS showClassifiedValue p (Classified c x) = @@ -512,107 +538,18 @@ Dict -> showsPrec p x canShowClassified :: Classifier a -> Dict Show a -canShowClassified = go +canShowClassified = canShowClassified_ showOther where - go :: Classifier a -> Dict Show a - - -- - -- Simple cases - -- - - -- Primitive types - go C_Bool = Dict - go C_Char = Dict - go C_Double = Dict - go C_Float = Dict - go C_Int = Dict - go C_Int16 = Dict - go C_Int8 = Dict - go C_Int32 = Dict - go C_Int64 = Dict - go C_Integer = Dict - go C_Ordering = Dict - go C_Unit = Dict - go C_Word = Dict - go C_Word8 = Dict - go C_Word16 = Dict - go C_Word32 = Dict - go C_Word64 = Dict - - -- String types - go C_String = Dict - go C_BS_Strict = Dict - go C_BS_Lazy = Dict - go C_BS_Short = Dict - go C_Text_Strict = Dict - go C_Text_Lazy = Dict - - -- Aeson - go C_Value = Dict - - -- Reference cells - go C_STRef = Dict - go C_TVar = Dict - go C_MVar = Dict - - -- Functions - go C_Fun = Dict - - -- User-defined - go C_Custom = Dict - - -- - -- Compound - -- - - go (C_Maybe c) = goMaybeF c - go (C_Either c) = goEitherF c - go (C_List c) = goMaybeF c - go (C_Ratio c) = goF c - go (C_Set c) = goMaybeF c - go (C_Map c) = goMaybePairF c - go C_IntSet = Dict - go (C_IntMap c) = goMaybeF c - go (C_Sequence c) = goMaybeF c - go (C_Tree c) = goF c - go (C_HashSet c) = goF c - go (C_HashMap c) = goMaybePairF c - go (C_HM_Array c) = goMaybeF c - go (C_Vector_Boxed c) = goMaybeF c - - go (C_Tuple (Classifiers cs)) = - case all_NP (hmap (canShowClassified . classifiedType) cs) of - Dict -> Dict - - goMaybeF :: forall f a. - (forall x. Show x => Show (f x)) - => MaybeF Classified a -> Dict Show (f a) - goMaybeF FNothing = Dict - goMaybeF (FJust c) = case go (classifiedType c) of - Dict -> Dict - - goEitherF :: forall f a b. - (forall x y. (Show x, Show y) => Show (f x y)) - => EitherF Classified a b -> Dict Show (f a b) - goEitherF (FLeft c) = case go (classifiedType c) of - Dict -> Dict - goEitherF (FRight c) = case go (classifiedType c) of - Dict -> Dict + showOther :: IsUserDefined a -> Dict Show a + showOther (IsUserDefined _) = Dict - goF :: forall f a. - (forall x. Show x => Show (f x)) - => Classified a -> Dict Show (f a ) - goF c = case go (classifiedType c) of - Dict -> Dict +canShowPrim :: PrimClassifier a -> Dict Show a +canShowPrim = primSatisfies - goMaybePairF :: forall f a b. - (forall x y. (Show x, Show y) => Show (f x y)) - => MaybePairF Classified a b -> Dict Show (f a b) - goMaybePairF FNothingPair = Dict - goMaybePairF (FJustPair c c') = case ( go (classifiedType c) - , go (classifiedType c') - ) of - (Dict, Dict) -> Dict +canShowClassified_ :: forall o. + (forall a. o a -> Dict Show a) + -> (forall a. Classifier_ o a -> Dict Show a) +canShowClassified_ = classifiedSatisfies instance Show UserDefined where showsPrec p x = diff --git a/src/Debug/RecoverRTTI/Constraint.hs b/src/Debug/RecoverRTTI/Constraint.hs new file mode 100644 --- /dev/null +++ b/src/Debug/RecoverRTTI/Constraint.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +-- | Establish that a constraint holds for all classified types +module Debug.RecoverRTTI.Constraint ( + PrimSatisfies + , primSatisfies + , ClassifiedSatisfies + , classifiedSatisfies + ) where + +import Data.Aeson (Value) +import Data.HashMap.Lazy (HashMap) +import Data.HashSet (HashSet) +import Data.Int +import Data.IntMap (IntMap) +import Data.IntSet (IntSet) +import Data.Kind +import Data.Map (Map) +import Data.Ratio +import Data.Sequence (Seq) +import Data.Set (Set) +import Data.SOP +import Data.SOP.Dict +import Data.Tree (Tree) +import Data.Void +import Data.Word + +import qualified Data.ByteString as BS.Strict +import qualified Data.ByteString.Lazy as BS.Lazy +import qualified Data.ByteString.Short as BS.Short +import qualified Data.HashMap.Internal.Array as HashMap (Array) +import qualified Data.Primitive.Array as Prim (Array) +import qualified Data.Text as Text.Strict +import qualified Data.Text.Lazy as Text.Lazy +import qualified Data.Vector as Vector.Boxed + +import Debug.RecoverRTTI.Classifier +import Debug.RecoverRTTI.Nat +import Debug.RecoverRTTI.Tuple +import Debug.RecoverRTTI.Wrappers + +{------------------------------------------------------------------------------- + Primitives +-------------------------------------------------------------------------------} + +type PrimSatisfies (c :: Type -> Constraint) = ( + -- Primitive types + + c Bool + , c Char + , c Double + , c Float + , c Int + , c Int16 + , c Int8 + , c Int32 + , c Int64 + , c Integer + , c Ordering + , c () + , c Word + , c Word8 + , c Word16 + , c Word32 + , c Word64 + + -- String types + + , c String + , c BS.Strict.ByteString + , c BS.Lazy.ByteString + , c BS.Short.ShortByteString + , c Text.Strict.Text + , c Text.Lazy.Text + + -- Aeson + + , c Value + + -- Reference cells + + , c SomeSTRef + , c SomeTVar + , c SomeMVar + + -- Functions + + , c SomeFun + + -- Containers with no type arguments + + , c IntSet + , c SomePrimArrayM + , c SomeStorableVector + , c SomeStorableVectorM + , c SomePrimitiveVector + , c SomePrimitiveVectorM + ) + +primSatisfies :: forall c. + PrimSatisfies c + => (forall a. PrimClassifier a -> Dict c a) +primSatisfies = go + where + go :: PrimClassifier a -> Dict c a + + -- Primitive types + + go C_Bool = Dict + go C_Char = Dict + go C_Double = Dict + go C_Float = Dict + go C_Int = Dict + go C_Int16 = Dict + go C_Int8 = Dict + go C_Int32 = Dict + go C_Int64 = Dict + go C_Integer = Dict + go C_Ordering = Dict + go C_Unit = Dict + go C_Word = Dict + go C_Word8 = Dict + go C_Word16 = Dict + go C_Word32 = Dict + go C_Word64 = Dict + + -- String types + + go C_String = Dict + go C_BS_Strict = Dict + go C_BS_Lazy = Dict + go C_BS_Short = Dict + go C_Text_Strict = Dict + go C_Text_Lazy = Dict + + -- Aeson + + go C_Value = Dict + + -- Reference cells + + go C_STRef = Dict + go C_TVar = Dict + go C_MVar = Dict + + -- Functions + + go C_Fun = Dict + + -- Containers with no type arguments + + go C_IntSet = Dict + go C_Prim_ArrayM = Dict + go C_Vector_Storable = Dict + go C_Vector_StorableM = Dict + go C_Vector_Primitive = Dict + go C_Vector_PrimitiveM = Dict + +{------------------------------------------------------------------------------- + Compound + + We can't use a type alias for the constraint here as ghc doesn't like + quantified constraints in constraint type aliases. +-------------------------------------------------------------------------------} + +class ( + PrimSatisfies c + -- Compound + , forall a. (c a) => c (Maybe a) + , forall a b. (c a, c b) => c (Either a b) + , forall a. (c a) => c [a] + , forall a. (c a) => c (Ratio a) + , forall a. (c a) => c (Set a) + , forall a b. (c a, c b) => c (Map a b) + , forall a. (c a) => c (IntMap a) + , forall a. (c a) => c (Seq a) + , forall a. (c a) => c (Tree a) + , forall a. (c a) => c (HashSet a) + , forall a b. (c a, c b) => c (HashMap a b) + , forall a. (c a) => c (HashMap.Array a) + , forall a. (c a) => c (Prim.Array a) + , forall a. (c a) => c (Vector.Boxed.Vector a) + , forall xs. (All c xs, IsValidSize (Length xs)) => c (WrappedTuple xs) + ) => ClassifiedSatisfies (c :: Type -> Constraint) + +instance ( + PrimSatisfies c + -- Compound + , forall a. (c a) => c (Maybe a) + , forall a b. (c a, c b) => c (Either a b) + , forall a. (c a) => c [a] + , forall a. (c a) => c (Ratio a) + , forall a. (c a) => c (Set a) + , forall a b. (c a, c b) => c (Map a b) + , forall a. (c a) => c (IntMap a) + , forall a. (c a) => c (Seq a) + , forall a. (c a) => c (Tree a) + , forall a. (c a) => c (HashSet a) + , forall a b. (c a, c b) => c (HashMap a b) + , forall a. (c a) => c (HashMap.Array a) + , forall a. (c a) => c (Prim.Array a) + , forall a. (c a) => c (Vector.Boxed.Vector a) + , forall xs. (All c xs, IsValidSize (Length xs)) => c (WrappedTuple xs) + ) => ClassifiedSatisfies (c :: Type -> Constraint) + +classifiedSatisfies :: forall c o. + (ClassifiedSatisfies c, c Void) + => (forall a. o a -> Dict c a) + -> (forall a. Classifier_ o a -> Dict c a) +classifiedSatisfies otherSatisfies = go + where + go :: Classifier_ o a -> Dict c a + go (C_Prim c) = primSatisfies c + go (C_Other c) = otherSatisfies c + + -- Compound + go (C_Maybe c) = goElems c $ Dict + go (C_Either c) = goElems c $ Dict + go (C_List c) = goElems c $ Dict + go (C_Ratio c) = goElems c $ Dict + go (C_Set c) = goElems c $ Dict + go (C_Map c) = goElems c $ Dict + go (C_IntMap c) = goElems c $ Dict + go (C_Sequence c) = goElems c $ Dict + go (C_Tree c) = goElems c $ Dict + go (C_HashSet c) = goElems c $ Dict + go (C_HashMap c) = goElems c $ Dict + go (C_HM_Array c) = goElems c $ Dict + go (C_Prim_Array c) = goElems c $ Dict + go (C_Vector_Boxed c) = goElems c $ Dict + go (C_Tuple c) = goElems c $ Dict + + goElems :: SListI as => Elems o as -> (All c as => r) -> r + goElems (Elems cs) k = case all_NP (hmap goElem cs) of Dict -> k + + goElem :: Elem o a -> Dict c a + goElem (Elem c) = go c + goElem NoElem = Dict diff --git a/src/Debug/RecoverRTTI/Modules.hs b/src/Debug/RecoverRTTI/Modules.hs --- a/src/Debug/RecoverRTTI/Modules.hs +++ b/src/Debug/RecoverRTTI/Modules.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeFamilies #-} @@ -34,6 +35,7 @@ | PkgAeson | PkgUnorderedContainers | PkgVector + | PkgPrimitive data family KnownModule (pkg :: KnownPkg) @@ -52,6 +54,7 @@ SAeson :: SPkg 'PkgAeson SUnorderedContainers :: SPkg 'PkgUnorderedContainers SVector :: SPkg 'PkgVector + SPrimitive :: SPkg 'PkgPrimitive class IsKnownPkg pkg where singPkg :: SPkg pkg @@ -66,6 +69,7 @@ instance IsKnownPkg 'PkgAeson where singPkg = SAeson instance IsKnownPkg 'PkgUnorderedContainers where singPkg = SUnorderedContainers instance IsKnownPkg 'PkgVector where singPkg = SVector +instance IsKnownPkg 'PkgPrimitive where singPkg = SPrimitive {------------------------------------------------------------------------------- Modules in @ghc-pri@ @@ -152,9 +156,20 @@ -------------------------------------------------------------------------------} data instance KnownModule 'PkgVector = - DataVector + DataVector + | DataVectorStorable + | DataVectorStorableMutable + | DataVectorPrimitive + | DataVectorPrimitiveMutable {------------------------------------------------------------------------------- + Modules in @primitive@ +-------------------------------------------------------------------------------} + +data instance KnownModule 'PkgPrimitive = + DataPrimitiveArray + +{------------------------------------------------------------------------------- Matching -------------------------------------------------------------------------------} @@ -172,7 +187,8 @@ where go :: SPkg pkg -> KnownModule pkg -> FlatClosure -> Maybe (String, [Box]) go knownPkg knownModl ConstrClosure{pkg, modl, name, ptrArgs} = do - guard (namePkg knownPkg `isPrefixOf` pkg) -- ignore the version number + -- We ignore the package version for now + guard (stripVowels (namePkg knownPkg) `isPrefixOf` stripVowels pkg) guard (modl == nameModl knownPkg knownModl) return (name, ptrArgs) go _ _ _otherClosure = Nothing @@ -188,32 +204,66 @@ namePkg SAeson = "aeson" namePkg SUnorderedContainers = "unordered-containers" namePkg SVector = "vector" + namePkg SPrimitive = "primitive" nameModl :: SPkg pkg -> KnownModule pkg -> String - nameModl SGhcPrim GhcTypes = "GHC.Types" - nameModl SGhcPrim GhcTuple = "GHC.Tuple" - nameModl SBase GhcInt = "GHC.Int" - nameModl SBase GhcWord = "GHC.Word" - nameModl SBase GhcSTRef = "GHC.STRef" - nameModl SBase GhcMVar = "GHC.MVar" - nameModl SBase GhcConcSync = "GHC.Conc.Sync" - nameModl SBase GhcMaybe = "GHC.Maybe" - nameModl SBase GhcReal = "GHC.Real" - nameModl SBase DataEither = "Data.Either" - nameModl SByteString DataByteStringInternal = "Data.ByteString.Internal" - nameModl SByteString DataByteStringLazyInternal = "Data.ByteString.Lazy.Internal" - nameModl SByteString DataByteStringShortInternal = "Data.ByteString.Short.Internal" - nameModl SText DataTextInternal = "Data.Text.Internal" - nameModl SText DataTextInternalLazy = "Data.Text.Internal.Lazy" - nameModl SIntegerWiredIn GhcIntegerType = "GHC.Integer.Type" - nameModl SGhcBignum GhcNumInteger = "GHC.Num.Integer" - nameModl SContainers DataSetInternal = "Data.Set.Internal" - nameModl SContainers DataMapInternal = "Data.Map.Internal" - nameModl SContainers DataIntSetInternal = "Data.IntSet.Internal" - nameModl SContainers DataIntMapInternal = "Data.IntMap.Internal" - nameModl SContainers DataSequenceInternal = "Data.Sequence.Internal" - nameModl SContainers DataTree = "Data.Tree" - nameModl SAeson DataAesonTypesInternal = "Data.Aeson.Types.Internal" - nameModl SUnorderedContainers DataHashMapInternal = "Data.HashMap.Internal" - nameModl SUnorderedContainers DataHashMapInternalArray = "Data.HashMap.Internal.Array" - nameModl SVector DataVector = "Data.Vector" + nameModl = \case + SGhcPrim -> \case + GhcTypes -> "GHC.Types" + GhcTuple -> "GHC.Tuple" + + SBase -> \case + GhcInt -> "GHC.Int" + GhcWord -> "GHC.Word" + GhcSTRef -> "GHC.STRef" + GhcMVar -> "GHC.MVar" + GhcConcSync -> "GHC.Conc.Sync" + GhcMaybe -> "GHC.Maybe" + GhcReal -> "GHC.Real" + DataEither -> "Data.Either" + + SByteString -> \case + DataByteStringInternal -> "Data.ByteString.Internal" + DataByteStringLazyInternal -> "Data.ByteString.Lazy.Internal" + DataByteStringShortInternal -> "Data.ByteString.Short.Internal" + + SText -> \case + DataTextInternal -> "Data.Text.Internal" + DataTextInternalLazy -> "Data.Text.Internal.Lazy" + + SIntegerWiredIn -> \case + GhcIntegerType -> "GHC.Integer.Type" + + SGhcBignum -> \case + GhcNumInteger -> "GHC.Num.Integer" + + SContainers -> \case + DataSetInternal -> "Data.Set.Internal" + DataMapInternal -> "Data.Map.Internal" + DataIntSetInternal -> "Data.IntSet.Internal" + DataIntMapInternal -> "Data.IntMap.Internal" + DataSequenceInternal -> "Data.Sequence.Internal" + DataTree -> "Data.Tree" + + SAeson -> \case + DataAesonTypesInternal -> "Data.Aeson.Types.Internal" + + SUnorderedContainers -> \case + DataHashMapInternal -> "Data.HashMap.Internal" + DataHashMapInternalArray -> "Data.HashMap.Internal.Array" + + SVector -> \case + DataVector -> "Data.Vector" + DataVectorStorable -> "Data.Vector.Storable" + DataVectorStorableMutable -> "Data.Vector.Storable.Mutable" + DataVectorPrimitive -> "Data.Vector.Primitive" + DataVectorPrimitiveMutable -> "Data.Vector.Primitive.Mutable" + + SPrimitive -> \case + DataPrimitiveArray -> "Data.Primitive.Array" + + -- On OSX, cabal strips vowels from package IDs in order to work around + -- limitations around path lengths + -- + stripVowels :: String -> String + stripVowels = filter (`notElem` "aeoiu") diff --git a/src/Debug/RecoverRTTI/Reclassify.hs b/src/Debug/RecoverRTTI/Reclassify.hs new file mode 100644 --- /dev/null +++ b/src/Debug/RecoverRTTI/Reclassify.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Support for reclassification +module Debug.RecoverRTTI.Reclassify ( + Reclassified(..) + , reclassify_ + , distribReclassified + , FromUsr(..) + , coerceFromUsr + ) where + +import Data.Kind +import Data.SOP hiding (NS(..)) +import Data.Void +import Unsafe.Coerce (unsafeCoerce) + +import Debug.RecoverRTTI.Classifier +import Debug.RecoverRTTI.Tuple +import Debug.RecoverRTTI.Nat +import Debug.RecoverRTTI.Wrappers + +-- | Reclassified values +-- +-- Reclassification can be done by user code which want to take advantage of +-- the classification infrastructure for @recover-rtti@ but add some additional +-- classification for domain-specific types known only to that client code. +-- +-- When we reclassify a value, a value that might previously be classified as +-- @UserDefined@ may now be classified as some concrete type; therefore we +-- compute a classifier for a potentially /different/ type along with +-- evidence that we can coerce between the two. +data Reclassified o a where + Reclassified :: o b -> FromUsr a b -> Reclassified o a + +-- | Extension of 'Reclassified' to multiple elems +-- +-- This is used internally only. +data ReclassifiedElems o as where + RElems :: + (SListI bs, Length bs ~ Length as) + => Elems o bs -> PairWise FromUsr as bs -> ReclassifiedElems o as + +reclassify_ :: forall m o o'. Applicative m + => (forall a. o a -> m (Reclassified o' a)) + -> (forall a. Classifier_ o a -> m (Classifier_ (Reclassified o') a)) +reclassify_ = mapClassifier + +-- | Lift 'Reclassified' to the top-level +-- +-- Given a classifier with user-defined classifiers at the levels, along with +-- coercion functions, leave the user-defined classifiers in place but lift the +-- coercion function to the top-level. +distribReclassified :: forall o. + (forall a. Classifier_ (Reclassified o) a -> Reclassified (Classifier_ o) a) +distribReclassified = go + where + go :: forall a. Classifier_ (Reclassified o) a -> Reclassified (Classifier_ o) a + -- Primitive and user-defined + go (C_Prim c) = Reclassified (C_Prim c) Id + go (C_Other c) = case c of Reclassified c' f -> Reclassified (C_Other c') f + + -- Compound + go (C_Maybe c) = go1 C_Maybe c + go (C_Either c) = go2 C_Either c + go (C_List c) = go1 C_List c + go (C_Ratio c) = go1 C_Ratio c + go (C_Set c) = go1 C_Set c + go (C_Map c) = go2 C_Map c + go (C_IntMap c) = go1 C_IntMap c + go (C_Sequence c) = go1 C_Sequence c + go (C_Tree c) = go1 C_Tree c + go (C_HashSet c) = go1 C_HashSet c + go (C_HashMap c) = go2 C_HashMap c + go (C_HM_Array c) = go1 C_HM_Array c + go (C_Prim_Array c) = go1 C_Prim_Array c + go (C_Vector_Boxed c) = go1 C_Vector_Boxed c + go (C_Tuple c) = goN C_Tuple c + + go1 :: forall f a. + (forall a'. Elems o '[a'] -> Classifier_ o (f a')) + -> Elems (Reclassified o) '[a] + -> Reclassified (Classifier_ o) (f a) + go1 cf c = + case distribElems c of + RElems c' (PCons f PNil) -> Reclassified (cf c') (F1 f) + + go2 :: forall f a b. + (forall a' b'. Elems o '[a', b'] -> Classifier_ o (f a' b')) + -> Elems (Reclassified o) '[a, b] + -> Reclassified (Classifier_ o) (f a b) + go2 cf c = + case distribElems c of + RElems c' (PCons f (PCons f' PNil)) -> Reclassified (cf c') (F2 f f') + + goN :: forall f as. + SListI as + => (forall as'. + (SListI as', Length as' ~ Length as) + => Elems o as' -> Classifier_ o (f as')) + -> Elems (Reclassified o) as + -> Reclassified (Classifier_ o) (f as) + goN cf c = + case distribElems c of + RElems c' fs -> Reclassified (cf c') (FN fs) + +distribElem :: Elem (Reclassified o) a -> Reclassified (Elem o) a +distribElem = \case + NoElem -> Reclassified NoElem Absurd + Elem c -> case distribReclassified c of + Reclassified c' f -> Reclassified (Elem c') f + +distribElems :: + SListI xs + => Elems (Reclassified o) xs -> ReclassifiedElems o xs +distribElems = \(Elems cs) -> go $ hmap distribElem cs + where + go :: NP (Reclassified (Elem o)) xs -> ReclassifiedElems o xs + go Nil = RElems (Elems Nil) PNil + go (Reclassified c f :* cs) = case go cs of + RElems (Elems cs') fs' -> + RElems (Elems (c :* cs')) (PCons f fs') + +{------------------------------------------------------------------------------- + Evidence that we are only doing conversions from Any +-------------------------------------------------------------------------------} + +-- | Evidence that we can convert between two types +-- +-- The only actual conversion we ever do is from 'UserDefined' (aka 'Any') to +-- whatever type the reclassification gives. +data FromUsr :: Type -> Type -> Type where + Id :: FromUsr a a + Absurd :: FromUsr Void a + FromUsr :: FromUsr UserDefined a + F1 :: FromUsr a1 b1 -> FromUsr (f a1) (f b1) + F2 :: FromUsr a1 b1 -> FromUsr a2 b2 -> FromUsr (f a1 a2) (f b1 b2) + FN :: PairWise FromUsr as bs -> FromUsr (f as) (f bs) + Compose :: FromUsr b c -> FromUsr a b -> FromUsr a c + +-- | Coerce, given some evidence that the coercion is sound. +coerceFromUsr :: FromUsr a b -> a -> b +coerceFromUsr = unsafeCoerce diff --git a/src/Debug/RecoverRTTI/Tuple.hs b/src/Debug/RecoverRTTI/Tuple.hs --- a/src/Debug/RecoverRTTI/Tuple.hs +++ b/src/Debug/RecoverRTTI/Tuple.hs @@ -11,9 +11,13 @@ module Debug.RecoverRTTI.Tuple ( -- * Wrapped tuple WrappedTuple(WrappedTuple, TNil, TCons) + , unwrapTuple -- * Conversion between tuples and NP , tupleFromNP , tupleToNP + -- * Mapping + , PairWise(..) + , mapTuple -- * Re-exports , module Debug.RecoverRTTI.Tuple.Recursive , module Debug.RecoverRTTI.Tuple.Size @@ -38,7 +42,7 @@ -- Inductive view on tuples that can be constructed with or pattern matched on -- using 'TNil' and 'TCons'. The underlying representation is a /true/ tuple -- however; for example, @Tuple '[Int, Bool, Char] ~ (Int, Bool, Char)@. -newtype WrappedTuple xs = WrappedTuple (Tuple xs) +newtype WrappedTuple xs = WrappedTuple { unwrapTuple :: Tuple xs } pattern TNil :: forall xs. (SListI xs, IsValidSize (Length xs)) @@ -74,6 +78,31 @@ => WrappedTuple xs -> NP I xs tupleToNP TNil = Nil tupleToNP (TCons x xs) = I x :* tupleToNP xs + +{------------------------------------------------------------------------------- + Mapping +-------------------------------------------------------------------------------} + +data PairWise f xs ys where + PNil :: PairWise f '[] '[] + PCons :: f x y -> PairWise f xs ys -> PairWise f (x:xs) (y:ys) + +data SameListShape xs ys where + SameListShape :: (SListI ys, Length xs ~ Length ys) => SameListShape xs ys + +mapTuple' :: + (SListI xs, IsValidSize (Length xs)) + => PairWise (->) xs ys + -> WrappedTuple xs -> (SameListShape xs ys, WrappedTuple ys) +mapTuple' PNil TNil = (SameListShape, TNil) +mapTuple' (PCons f fs) (TCons x xs) = + case mapTuple' fs xs of + (SameListShape, ys) -> (SameListShape, TCons (f x) ys) + +mapTuple :: + (SListI xs, IsValidSize (Length xs)) + => PairWise (->) xs ys -> WrappedTuple xs -> WrappedTuple ys +mapTuple fs = snd . mapTuple' fs {------------------------------------------------------------------------------- Internal auxiliary functions for defining the pattern synonym diff --git a/src/Debug/RecoverRTTI/Util.hs b/src/Debug/RecoverRTTI/Util.hs --- a/src/Debug/RecoverRTTI/Util.hs +++ b/src/Debug/RecoverRTTI/Util.hs @@ -2,20 +2,15 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wno-redundant-constraints #-} - module Debug.RecoverRTTI.Util ( -- * Existentials Some(..) - , elimKnownSymbol - -- * Constraints - , keepRedundantConstraint + , mapSome -- * Lists , dropEnds -- * SOP @@ -24,9 +19,7 @@ ) where import Data.Kind -import Data.Proxy import Data.SOP -import GHC.TypeLits (KnownSymbol, SomeSymbol(..), someSymbolVal) import Debug.RecoverRTTI.Nat @@ -37,24 +30,8 @@ data Some (f :: k -> Type) where Some :: forall f a. f a -> Some f -elimKnownSymbol :: String -> (forall n. KnownSymbol n => Proxy n -> r) -> r -elimKnownSymbol s k = - case someSymbolVal s of - SomeSymbol p -> k p - -{------------------------------------------------------------------------------- - Constraints --------------------------------------------------------------------------------} - --- | Can be used to silence individual "redundant constraint" warnings --- --- > foo :: ConstraintUsefulForDebugging => ... --- > foo = --- > .. --- > where --- > _ = keepRedundantConstraint (Proxy @ConstraintUsefulForDebugging)) -keepRedundantConstraint :: c => proxy c -> () -keepRedundantConstraint _ = () +mapSome :: (forall x. f x -> g x) -> Some f -> Some g +mapSome f (Some x) = Some (f x) {------------------------------------------------------------------------------- Lists diff --git a/src/Debug/RecoverRTTI/Wrappers.hs b/src/Debug/RecoverRTTI/Wrappers.hs --- a/src/Debug/RecoverRTTI/Wrappers.hs +++ b/src/Debug/RecoverRTTI/Wrappers.hs @@ -20,6 +20,12 @@ , SomeSTRef(..) , SomeMVar(..) , SomeTVar(..) + -- * Arrays + , SomePrimArrayM(..) + , SomeStorableVector(..) + , SomeStorableVectorM(..) + , SomePrimitiveVector(..) + , SomePrimitiveVectorM(..) ) where import Control.Concurrent.MVar (MVar) @@ -27,6 +33,8 @@ import Data.STRef (STRef) import GHC.Exts +import qualified Data.Primitive.Array as Prim (MutableArray) + {------------------------------------------------------------------------------- User-defined types -------------------------------------------------------------------------------} @@ -64,10 +72,50 @@ deriving (Eq) {------------------------------------------------------------------------------- + Arrays + + For mutable arrays, we don't currently peek inside, and so we don't infer + the type of the elements. We /could/ (in principle this would be sound), + and we may wish to change this at some point. For the purposes of /show/, + however, having this type inferred it's particularly useful, unless we define + a `peekAnythingToString :: a -> IO String` function or something like that + which could look inside mutable structures (references, arrays, ..). +-------------------------------------------------------------------------------} + +newtype SomePrimArrayM = SomePrimArrayM (Prim.MutableArray RealWorld Any) + +-- | Storable vector ("Data.Vector.Storable") +-- +-- For storable arrays we have no hope of inferring the type of the elements: +-- the elements are not stored as pointers, but rather as " serialized " data +-- through the 'Storable' type class. In order to get at any element, we'd need +-- to have the corresponding 'Storable' instance, but of course we don't have it +-- if we don't have the type. +newtype SomeStorableVector = SomeStorableVector Any + +-- | Mutable storage vector ("Data.Vector.Storable") +-- +-- See 'SomeStorableVector' for some details on why we don't infer anything here. +newtype SomeStorableVectorM = SomeStorableVectorM Any + +-- | Primitive vector ("Data.Vector.Primitive") +-- +-- See 'SomeStorableVector' for why we can't classify elements of these vectors. +newtype SomePrimitiveVector = SomePrimitiveVector Any + +-- | Mutable primitive vector +newtype SomePrimitiveVectorM = SomePrimitiveVectorM Any + +{------------------------------------------------------------------------------- Show instances Unfortunately reference cells are moved by GC, so we can't do much here; showing the address of the variable isn't particularly helpful. + + We /could/ use @unsafePerformIO@ here to display the /contents/ of these + variables and mutable arrays, but that would not be referentially transparent; + unlike 'classify', that would not be morally pure. In principle we could offer + such a "display and peek inside mutable references" as a separate function. -------------------------------------------------------------------------------} instance Show SomeSTRef where @@ -81,3 +129,18 @@ instance Show SomeFun where show _ = "" + +instance Show SomePrimArrayM where + show _ = "" + +instance Show SomeStorableVector where + show _ = "" + +instance Show SomeStorableVectorM where + show _ = "" + +instance Show SomePrimitiveVector where + show _ = "" + +instance Show SomePrimitiveVectorM where + show _ = "" diff --git a/tests/Test/RecoverRTTI/Arbitrary.hs b/tests/Test/RecoverRTTI/Arbitrary.hs deleted file mode 100644 --- a/tests/Test/RecoverRTTI/Arbitrary.hs +++ /dev/null @@ -1,648 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Test.RecoverRTTI.Arbitrary ( - ClassifiedGen(..) - , arbitraryClassifiedGen - -- * Example values of reference cells - , exampleIORef - , exampleSTRef - , exampleMVar - , exampleTVar - ) where - -import Control.Concurrent.MVar (newEmptyMVar) -import Control.Concurrent.STM (newTVarIO) -import Control.Monad -import Control.Monad.ST.Unsafe (unsafeSTToIO) -import Data.Bifunctor -import Data.IORef (newIORef) -import Data.Maybe (catMaybes) -import Data.SOP -import Data.SOP.Dict -import Data.STRef (newSTRef) -import Data.Tree (Tree) -import Data.Void -import GHC.Real -import System.IO.Unsafe (unsafePerformIO) -import Unsafe.Coerce (unsafeCoerce) - -import qualified Data.Aeson as Aeson -import qualified Data.ByteString as BS.Strict -import qualified Data.ByteString.Lazy as BS.Lazy -import qualified Data.ByteString.Short as BS.Short -import qualified Data.HashMap.Internal.Array as HashMap.Array -import qualified Data.HashMap.Lazy as HashMap -import qualified Data.HashSet as HashSet -import qualified Data.IntMap as IntMap -import qualified Data.Map as Map -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Text as Text.Strict -import qualified Data.Text.Lazy as Text.Lazy -import qualified Data.Tree as Tree -import qualified Data.Vector as Vector.Boxed - -import Test.QuickCheck hiding (classify, NonEmpty) - -import Debug.RecoverRTTI - -import Test.RecoverRTTI.ConcreteClassifier -import Test.RecoverRTTI.Orphans () -import Test.RecoverRTTI.UserDefined - -{------------------------------------------------------------------------------- - Generic auxiliary --------------------------------------------------------------------------------} - -newtype SizedGen a = SizedGen (Int -> Gen a) - deriving (Functor) - -runSized :: Int -> SizedGen a -> Gen a -runSized n (SizedGen gen) = gen n - -ignoreSize :: Gen a -> SizedGen a -ignoreSize gen = SizedGen $ \_sz -> gen - -arbitrarySizedGen :: Arbitrary a => SizedGen a -arbitrarySizedGen = ignoreSize arbitrary - -{------------------------------------------------------------------------------- - Arbitrary instance --------------------------------------------------------------------------------} - --- | Quickcheck generator along with a classifier -data ClassifiedGen a where - ClassifiedGen :: - (Show a, Eq a) - => { -- | The classifier for the generator - genClassifier :: ConcreteClassifier a - - -- | The classified generator itself - -- - -- The size argument determines the maximum size of the /value/ - -- (as opposed to the maximum size of the /type/) - , classifiedGen :: SizedGen a - } - -> ClassifiedGen a - -canShowClassifiedGen :: ClassifiedGen a -> Dict Show a -canShowClassifiedGen ClassifiedGen{} = Dict - -canEqClassifiedGen :: ClassifiedGen a -> Dict Eq a -canEqClassifiedGen ClassifiedGen{} = Dict - -defaultClassifiedGen :: - (Arbitrary a, Show a, Eq a) - => ConcreteClassifier a - -> ClassifiedGen a -defaultClassifiedGen cc = ClassifiedGen cc $ ignoreSize arbitrary - --- | Generated arbitrary classifier along with a generator for that value --- --- NOTE: The @sz@ parameter limits the size of the /type tree/ (i.e., the number --- of recursive calls to arbitraryClassifiedGen), /not/ the size of the --- generated /values/. -arbitraryClassifiedGen :: Int -> Gen (Some ClassifiedGen) -arbitraryClassifiedGen typSz - | typSz < 0 = error "arbitraryClassifiedGen: uhoh.. bug" - | typSz == 0 = elements leaves - | otherwise = oneof (elements leaves : catMaybes compound) - where - -- Leaves of the tree (values with no recursion) - -- - -- Since there are the leaves, we don't need to check the size - leaves :: [Some ClassifiedGen] - leaves = concat [ - -- Primitive types - [ Some $ defaultClassifiedGen CC_Bool - , Some $ defaultClassifiedGen CC_Char - , Some $ defaultClassifiedGen CC_Double - , Some $ defaultClassifiedGen CC_Float - , Some $ defaultClassifiedGen CC_Int - , Some $ defaultClassifiedGen CC_Int16 - , Some $ defaultClassifiedGen CC_Int8 - , Some $ defaultClassifiedGen CC_Int32 - , Some $ defaultClassifiedGen CC_Int64 - , Some $ defaultClassifiedGen CC_Integer - , Some $ defaultClassifiedGen CC_Ordering - , Some $ defaultClassifiedGen CC_Unit - , Some $ defaultClassifiedGen CC_Word - , Some $ defaultClassifiedGen CC_Word8 - , Some $ defaultClassifiedGen CC_Word16 - , Some $ defaultClassifiedGen CC_Word32 - , Some $ defaultClassifiedGen CC_Word64 - ] - - -- Strings - -- - -- Avoid generating the empty string (recognized as @[Void]@) - , let mapList :: Arbitrary a => Int -> ([a] -> b) -> SizedGen b - mapList minSize f = SizedGen $ \valSz -> do - n <- choose (minSize, max minSize valSz) -- maybe valSz == 0 - f <$> vector n - in [ - Some $ ClassifiedGen CC_String (mapList 1 id) - , Some $ ClassifiedGen CC_BS_Strict (mapList 0 BS.Strict.pack) - , Some $ ClassifiedGen CC_BS_Lazy (mapList 0 BS.Lazy.pack) - , Some $ ClassifiedGen CC_BS_Short (mapList 0 BS.Short.pack) - , Some $ ClassifiedGen CC_Text_Strict (mapList 0 Text.Strict.pack) - , Some $ ClassifiedGen CC_Text_Lazy (mapList 0 Text.Lazy.pack) - ] - - -- Aeson - , [ Some $ ClassifiedGen CC_Value arbitraryAesonValue ] - - -- Reference cells - , [ Some $ ClassifiedGen CC_STRef (ignoreSize $ pure exampleSTRef) - , Some $ ClassifiedGen CC_STRef (ignoreSize $ pure exampleIORef) - , Some $ ClassifiedGen CC_MVar (ignoreSize $ pure exampleMVar) - , Some $ ClassifiedGen CC_TVar (ignoreSize $ pure exampleTVar) - ] - - -- Functions - -- - -- For functions we don't currently try to be clever and /generate/ - -- functions. Instead, we just try a few different categories. - , map (\f -> Some $ ClassifiedGen CC_Fun (ignoreSize $ pure f)) [ - -- Parametrically polymorphic function - unsafeCoerce (id :: Int -> Int) - , unsafeCoerce (const :: Int -> Bool -> Int) - -- Ad-hoc polymorphic function - , unsafeCoerce (negate :: Int -> Int) - , unsafeCoerce ((+) :: Int -> Int -> Int) - -- Partial application - , unsafeCoerce (const 1 :: Bool -> Int) - , unsafeCoerce ((+) 1 :: Int -> Int) - ] - ] - - -- Compound - -- - -- These are only used if @sz > 0@. - compound :: [Maybe (Gen (Some ClassifiedGen))] - compound = [ - -- Lists - -- - -- We have to be careful not to generate @[Char]@, because this is - -- inferred as @String@ - guard (typSz >= 1) >> (return $ do - Some a <- arbitraryClassifiedGen (typSz - 1) - genMaybeF - (\case FJust CC_Char -> CC_String - c -> CC_List c) - (return []) - (genListLike id) - a - ) - - -- Maybe - , guard (typSz >= 1) >> (return $ do - Some a <- arbitraryClassifiedGen (typSz - 1) - genMaybeF CC_Maybe (return Nothing) (fmap Just) a - ) - - -- Either - , guard (typSz >= 2) >> (return $ do - Some a <- arbitraryClassifiedGen (typSz `div` 2) - Some b <- arbitraryClassifiedGen (typSz `div` 2) - genEitherF CC_Either (fmap Left) (fmap Right) a b - ) - - -- Ratio - , guard (typSz >= 1) >> (return $ do - Some a <- arbitraryClassifiedGen (typSz `div` 2) - genF - CC_Ratio - (\(SizedGen gen) -> SizedGen $ \sz -> - (:%) <$> gen (sz `div` 2) <*> gen (sz `div` 2) - ) - a - ) - - -- Set - -- For set we must pick an ordered type, so we just pick Int - , return (do - genMaybeF - CC_Set - (return Set.empty) - (genListLike Set.fromList) - (defaultClassifiedGen CC_Int) - ) - - -- Map - -- Pick Int for the keys, but randomly for the values - , guard (typSz >= 1) >> (return $ do - Some b <- arbitraryClassifiedGen (typSz - 1) - genMaybePairF - CC_Map - (return Map.empty) - (genMapLike Map.fromList) - (defaultClassifiedGen CC_Int) - b - ) - - -- IntSet - , return $ return $ Some (defaultClassifiedGen CC_IntSet) - - -- IntMap - , guard (typSz >= 1) >> (return $ do - Some b <- arbitraryClassifiedGen (typSz - 1) - genMaybeF - CC_IntMap - (return IntMap.empty) - (genMapLike IntMap.fromList arbitrarySizedGen) - b - ) - - -- Sequence - , guard (typSz >= 1) >> (return $ do - Some a <- arbitraryClassifiedGen (typSz - 1) - genMaybeF - CC_Sequence - (return Seq.empty) - (genListLike Seq.fromList) - a - ) - - -- Tree - , guard (typSz >= 1) >> (return $ do - Some a <- arbitraryClassifiedGen (typSz - 1) - genF CC_Tree (genListLike mkSomeTree) a - ) - - -- HashSet - -- Like Set, we need an Ord instance on the elements, so we pick Int - -- genListLike never generates the empty list, which is important: - -- an empty 'HashSet' would be misclassified as a 'HashMap'. - , (return $ - genF - CC_HashSet - (genListLike HashSet.fromList) - (defaultClassifiedGen CC_Int) - ) - - -- HashMap - , guard (typSz >= 1) >> (return $ do - -- A map with @()@ values is classified as a @HashSet@ - let isUnit :: Some ClassifiedGen -> Bool - isUnit (Some (ClassifiedGen CC_Unit _)) = True - isUnit _otherwise = False - Some b <- arbitraryClassifiedGen (typSz - 1) `suchThat` (not . isUnit) - genMaybePairF - CC_HashMap - (return HashMap.empty) - (genMapLike HashMap.fromList) - (defaultClassifiedGen CC_Int) - b - ) - - -- HashMap's internal array type - , guard (typSz >= 1) >> (return $ do - let mkArray xs = HashMap.Array.fromList (length xs) xs - Some a <- arbitraryClassifiedGen (typSz - 1) - genMaybeF - CC_HM_Array - (return $ mkArray []) - (genListLike mkArray) - a - ) - - -- Boxed vectors - , guard (typSz >= 1) >> (return $ do - Some a <- arbitraryClassifiedGen (typSz - 1) - genMaybeF - CC_Vector_Boxed - (return Vector.Boxed.empty) - (genListLike Vector.Boxed.fromList) - a - ) - - -- - -- User-defined - -- - - -- SimpleType - , return $ return $ Some (defaultClassifiedGen CC_User_Simple) - - -- NonRecursive - , guard (typSz >= 1) >> (return $ do - Some a <- arbitraryClassifiedGen (typSz - 1) - genMaybeF - CC_User_NonRec - (NR1 <$> arbitrary) - (\gen -> SizedGen $ \valSz -> - NR2 <$> runSized valSz gen <*> arbitrary - ) - a - ) - - -- Recursive - , guard (typSz >= 1) >> (return $ do - Some a <- arbitraryClassifiedGen (typSz - 1) - genMaybeF - CC_User_Rec - (return RNil) - (genListLike recursiveFromList) - a - ) - - -- ContainsUnlifted - , return $ return $ Some (defaultClassifiedGen CC_User_Unlifted) - - -- - -- Tuples - -- - - , guard (typSz >= 2) >> (return $ - arbitraryTuple typSz $ \np -> - case ( all_NP (hmap canShowClassifiedGen np) - , all_NP (hmap canEqClassifiedGen np) - ) of - (Dict, Dict) -> - return . Some $ ClassifiedGen { - genClassifier = - CC_Tuple (ConcreteClassifiers (hmap genClassifier np)) - , classifiedGen = SizedGen $ \valSz -> do - let valSz' = valSz `div` lengthSList np - tupleFromNP <$> - hsequence(hmap (runSized valSz' . classifiedGen) np) - } - ) - ] - - -- We check that we cover all cases of 'Classifier' rather than - -- 'ConcreteClassifier': it is important that we generate test cases for - -- everything we classify in the main library. - _checkAllCases :: Classifier a -> () - _checkAllCases = \case - -- Primitive types - - C_Bool -> () - C_Char -> () - C_Double -> () - C_Float -> () - C_Int -> () - C_Int16 -> () - C_Int8 -> () - C_Int32 -> () - C_Int64 -> () - C_Integer -> () - C_Ordering -> () - C_Unit -> () - C_Word -> () - C_Word8 -> () - C_Word16 -> () - C_Word32 -> () - C_Word64 -> () - - -- String types - - C_String -> () - C_BS_Strict -> () - C_BS_Lazy -> () - C_BS_Short -> () - C_Text_Strict -> () - C_Text_Lazy -> () - - -- Aeson - - C_Value -> () - - -- Compound - - C_Maybe{} -> () - C_Either{} -> () - C_List{} -> () - C_Ratio{} -> () - C_Set{} -> () - C_Map{} -> () - C_IntSet{} -> () - C_IntMap{} -> () - C_Tuple{} -> () - C_Sequence{} -> () - C_Tree{} -> () - C_HashSet{} -> () - C_HashMap{} -> () - C_HM_Array{} -> () - C_Vector_Boxed{} -> () - - -- Reference cells - - C_STRef -> () - C_TVar -> () - C_MVar -> () - - -- Functions - - C_Fun -> () - - -- User-defined - - C_Custom{} -> () - --- | Generate arbitrary tuple size -arbitraryTuple :: forall r. - Int -- ^ Maximum type size (should be at least 2) - -> (forall xs. - (SListI xs, IsValidSize (Length xs)) - => NP ClassifiedGen xs -> Gen r - ) - -> Gen r -arbitraryTuple = \typSz k -> do - tupleSz <- choose (2, min typSz 62) - let typSz' = typSz `div` tupleSz - case toValidSize tupleSz of - Nothing -> - error "arbitraryTuple: impossible, this is a valid tuple size" - Just (Some valid@(ValidSize n _)) -> - go typSz' n $ \(np :: NP ClassifiedGen xs) -> - case liftValidSize (valid :: ValidSize (Length xs)) - of Dict -> k np - where - go :: Int - -> SNat n - -> (forall xs. - (SListI xs, Length xs ~ n) - => NP ClassifiedGen xs -> Gen r - ) - -> Gen r - go _ SZ k = k Nil - go typSz' (SS n) k = do - Some c <- arbitraryClassifiedGen typSz' - go typSz' n $ \cs -> k (c :* cs) - -instance Arbitrary (Some Value) where - arbitrary = sized $ \sz -> do - -- @sz@ will range from 0..100, but we don't want to generate types that - -- large - Some (ClassifiedGen cc gen) <- arbitraryClassifiedGen (sz `div` 10) - - -- For the values however we want to be able to generate larger trees - Some . Value cc <$> runSized sz gen - -{------------------------------------------------------------------------------- - Helpers --------------------------------------------------------------------------------} - -genListLike :: ([a] -> x) -> SizedGen a -> SizedGen x -genListLike f gen = SizedGen $ \valSz -> do - n <- choose (1, 5) - f <$> vectorOf n (runSized (valSz `div` n) gen) - -genMapLike :: ([(a, b)] -> x) -> SizedGen a -> SizedGen b -> SizedGen x -genMapLike f (SizedGen genX) (SizedGen genY) = SizedGen $ \valSz -> do - n <- choose (1, 5) - f <$> vectorOf n ( - (,) <$> genX (valSz `div` n `div` 2) - <*> genY (valSz `div` n `div` 2) - ) - -genMaybeF :: - ( forall x. Show x => Show (f x) - , forall x. Eq x => Eq (f x) - ) - => (forall x. MaybeF ConcreteClassifier x -> ConcreteClassifier (f x)) - -> Gen (f Void) - -> (SizedGen a -> SizedGen (f a)) - -> ClassifiedGen a -> Gen (Some ClassifiedGen) -genMaybeF cc genNothing genJust (ClassifiedGen cA genA) = - elements [ - Some $ ClassifiedGen (cc FNothing) (ignoreSize $ genNothing) - , Some $ ClassifiedGen (cc (FJust cA)) (genJust genA) - ] - -genEitherF :: - ( forall x y. (Show x, Show y) => Show (f x y) - , forall x y. (Eq x, Eq y) => Eq (f x y) - ) - => (forall x y. EitherF ConcreteClassifier x y -> ConcreteClassifier (f x y)) - -> (SizedGen a -> SizedGen (f a Void)) - -> (SizedGen b -> SizedGen (f Void b)) - -> ClassifiedGen a - -> ClassifiedGen b - -> Gen (Some ClassifiedGen) -genEitherF cc genLeft genRight (ClassifiedGen cA genA) (ClassifiedGen cB genB) = - elements [ - Some $ ClassifiedGen (cc (FLeft cA)) (genLeft genA) - , Some $ ClassifiedGen (cc (FRight cB)) (genRight genB) - ] - -genMaybePairF :: - ( forall x y. (Show x, Show y) => Show (f x y) - , forall x y. (Eq x, Eq y) => Eq (f x y) - ) - => (forall x y. MaybePairF ConcreteClassifier x y -> ConcreteClassifier (f x y)) - -> Gen (f Void Void) - -> (SizedGen a -> SizedGen b -> SizedGen (f a b)) - -> ClassifiedGen a -> ClassifiedGen b -> Gen (Some ClassifiedGen) -genMaybePairF cc genNothing genJust (ClassifiedGen cA genA) (ClassifiedGen cB genB) = - elements [ - Some $ ClassifiedGen (cc FNothingPair) (ignoreSize $ genNothing) - , Some $ ClassifiedGen (cc (FJustPair cA cB)) (genJust genA genB) - ] - -genF :: - ( forall x. Show x => Show (f x) - , forall x. Eq x => Eq (f x) - ) - => (forall x. ConcreteClassifier x -> ConcreteClassifier (f x)) - -> (SizedGen a -> SizedGen (f a)) - -> ClassifiedGen a -> Gen (Some ClassifiedGen) -genF cc gen (ClassifiedGen cA genA) = return $ - Some $ ClassifiedGen (cc cA) (gen genA) - -{------------------------------------------------------------------------------- - Auxiliary tree functions --------------------------------------------------------------------------------} - -mkSomeTree :: [a] -> Tree a -mkSomeTree [] = error "mkSomeTree: empty" -mkSomeTree [x] = Tree.Node x [] -mkSomeTree [x, y] = Tree.Node x [Tree.Node y []] -mkSomeTree (x : xs) = - let (left, right) = split xs - in Tree.Node x [mkSomeTree left, mkSomeTree right] - --- | Split list into halves --- --- If the input has at least two elements, neither list will be empty --- --- > split "abcde" == ("ace","bd") -split :: [a] -> ([a], [a]) -split [] = ([], []) -split (x:xs) = first (x:) $ splot xs - --- | Auxiliary to 'split' -splot :: [a] -> ([a], [a]) -splot [] = ([], []) -splot (x:xs) = second (x:) $ split xs - -{------------------------------------------------------------------------------- - Auxiliary Aeson --------------------------------------------------------------------------------} - -arbitraryAesonValue :: SizedGen Aeson.Value -arbitraryAesonValue = SizedGen $ go - where - go :: Int -> Gen Aeson.Value - go 0 = oneof nonRecursive - go sz = oneof (nonRecursive ++ recursive sz) - - nonRecursive :: [Gen Aeson.Value] - nonRecursive = [ - Aeson.String . Text.Strict.pack <$> arbitrary - , Aeson.Number . fromInteger <$> arbitrary - , Aeson.Bool <$> arbitrary - , return Aeson.Null - ] - - recursive :: Int -> [Gen Aeson.Value] - recursive sz = [ - do n <- choose (0, 5) - Aeson.Array . Vector.Boxed.fromList <$> replicateM n (go (sz `div` n)) - , do n <- choose (0, 5) - Aeson.object <$> replicateM n ( - (Aeson..=) - <$> fieldName - <*> go (sz `div` n) - ) - ] - - -- We're not interested in testing crazy values - fieldName :: Gen Text.Strict.Text - fieldName = elements ["a", "b", "c"] - -{------------------------------------------------------------------------------- - Some global variables, which we use only as input to the tests --------------------------------------------------------------------------------} - -exampleIORef :: SomeSTRef -{-# NOINLINE exampleIORef #-} -exampleIORef = unsafePerformIO $ - -- IORef is indistinguishable from STRef on the heap - unsafeCoerce <$> newIORef (unsafeCoerce ()) - -exampleSTRef :: SomeSTRef -exampleSTRef = unsafePerformIO $ unsafeSTToIO $ - unsafeCoerce <$> newSTRef (unsafeCoerce ()) - -exampleMVar :: SomeMVar -{-# NOINLINE exampleMVar #-} -exampleMVar = unsafePerformIO $ - SomeMVar <$> newEmptyMVar - -exampleTVar :: SomeTVar -{-# NOINLINE exampleTVar #-} -exampleTVar = unsafePerformIO $ - SomeTVar <$> newTVarIO (unsafeCoerce ()) diff --git a/tests/Test/RecoverRTTI/Classifier/Arbitrary.hs b/tests/Test/RecoverRTTI/Classifier/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/tests/Test/RecoverRTTI/Classifier/Arbitrary.hs @@ -0,0 +1,259 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.RecoverRTTI.Classifier.Arbitrary (arbitraryClassifier_) where + +import Data.Bifunctor +import Data.Kind +import Data.SOP +import Data.Tree (Tree) +import Data.Void +import GHC.Real (Ratio((:%))) + +import qualified Data.HashMap.Internal.Array as HashMap.Array +import qualified Data.HashMap.Lazy as HashMap +import qualified Data.HashSet as HashSet +import qualified Data.IntMap as IntMap +import qualified Data.Map as Map +import qualified Data.Primitive.Array as Prim.Array +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Tree as Tree +import qualified Data.Vector as Vector.Boxed + +import Debug.RecoverRTTI +import Debug.RecoverRTTI.Classify + +import Test.QuickCheck + +import Test.RecoverRTTI.Classifier.Equality () +import Test.RecoverRTTI.Prim +import Test.RecoverRTTI.QuickCheck.DepGen +import Test.RecoverRTTI.QuickCheck.Sized (SizedGen) + +import qualified Test.RecoverRTTI.QuickCheck.Sized as SG + +{------------------------------------------------------------------------------- + Generate arbitiary classifiers +-------------------------------------------------------------------------------} + +-- | Generated arbitrary classifier along with a generator for that value +-- +-- NOTE: The " size " here refers to the size of the /classifier/. Along with +-- the classifier we construct a generator for values of the corresponding +-- type; that generator in turn has its own (independent) size parameter. +arbitraryClassifier_ :: forall c o. + (c ~ Classifier_ o) + => SizedGen (Some (DepGen o)) -> SizedGen (Some (DepGen c)) +arbitraryClassifier_ genOther = go + where + go :: SizedGen (Some (DepGen c)) + go = SG.leafOrStep leaf compound + + -- Leaves of the tree (values with no recursion). + -- + -- We will fail to generate a leaf when the size reaches 0; this ensures + -- termination. + leaf :: Gen (Some (DepGen c)) + leaf = do + Some c <- arbitraryPrimClassifier + return $ Some $ primDepGen c + + -- Compound + -- + -- We deduct one from the size for the outer-most constructor + -- + -- For most types we generate arbitrary subtypes, but for some types we + -- must pick subtypes satisfying a certain constraint (e.g., @Ord@ for + -- @Set@); for such types we just pick a single example. + compound :: [SizedGen (Some (DepGen c))] + compound = [ + -- We include " other " in the compound list, so that we are sure + -- to subtract one from the size + (\(Some (DepGen c gen)) -> Some (DepGen (C_Other c) gen)) <$> genOther + + , go_U_K C_Maybe Nothing + (mapSome (GenK (fmap Just)) <$> go) + + , go_KU_UK C_Either + (mapSome (GenKU (fmap Left)) <$> go) + (mapSome (GenUK (fmap Right)) <$> go) + + -- @[Char]@ is classified as @String@ + , let notChar (Some (DepGen (C_Prim C_Char) _)) = False + notChar _otherwise = True in + go_U_K C_List [] + (mapSome (GenK (SG.genListLike id)) <$> (go `SG.suchThat` notChar)) + + , go_K C_Ratio $ pure . Some $ GenK { + justGen = \g -> uncurry (:%) <$> SG.divvyPair g g + , justElem = primDepGen C_Int + } + + , go_U_K C_Set Set.empty $ pure . Some $ GenK { + justGen = SG.genListLike Set.fromList + , justElem = primDepGen C_Int + } + + , go_UU_KK C_Map Map.empty + ((\(Some genElem) -> Some $ GenKK { + pairGen = SG.genMapLike Map.fromList + , pairFst = primDepGen C_Int + , pairSnd = genElem + }) <$> go) + + , go_U_K C_IntMap IntMap.empty + ((\(Some genElem) -> Some $ GenK { + justGen = SG.genMapLike IntMap.fromList SG.arbitrary + , justElem = genElem + }) <$> go) + + , go_U_K C_Sequence Seq.empty + (mapSome (GenK (SG.genListLike Seq.fromList)) <$> go) + + , go_K C_Tree + (mapSome (GenK (SG.genListLike mkSomeTree)) <$> go) + + , go_K C_HashSet $ pure . Some $ GenK { + justGen = SG.genListLike HashSet.fromList + , justElem = primDepGen C_Int + } + + -- @HashMap a ()@ is classified as a @HashSet@ instead + , let notUnit (Some (DepGen (C_Prim C_Unit) _)) = False + notUnit _otherwise = True in + go_UU_KK C_HashMap HashMap.empty + ((\(Some genElem) -> Some $ GenKK { + pairGen = SG.genMapLike HashMap.fromList + , pairFst = primDepGen C_Int + , pairSnd = genElem + }) <$> (go `SG.suchThat` notUnit)) + + , let mkArray xs = HashMap.Array.fromList (length xs) xs in + go_U_K C_HM_Array (mkArray []) + (mapSome (GenK (SG.genListLike mkArray)) <$> go) + + , go_U_K C_Prim_Array (Prim.Array.fromList []) + (mapSome (GenK (SG.genListLike Prim.Array.fromList)) <$> go) + + , go_U_K C_Vector_Boxed Vector.Boxed.empty + (mapSome (GenK (SG.genListLike Vector.Boxed.fromList)) <$> go) + + , goTuple + ] + + go_K :: forall f. + ( forall x. Show x => Show (f x) + , forall x. Eq x => Eq (f x) + ) + => (forall x. Elems o '[x] -> c (f x)) + -> SizedGen (Some (GenK c f)) + -> SizedGen (Some (DepGen c)) + go_K cf = fmap (\(Some a) -> Some (genJust (cf . ElemK) a)) + + go_U_K :: forall f. + ( forall x. Show x => Show (f x) + , forall x. Eq x => Eq (f x) + ) + => (forall x. Elems o '[x] -> c (f x)) + -> f Void + -> SizedGen (Some (GenK c f)) + -> SizedGen (Some (DepGen c)) + go_U_K cf nothing just = + SG.leafOrStep + (pure $ Some $ DepGen (cf ElemU) (pure nothing)) + [(\(Some a) -> Some (genJust (cf . ElemK) a)) <$> just] + + go_KU_UK :: forall f. + ( forall x y. (Show x, Show y) => Show (f x y) + , forall x y. (Eq x, Eq y) => Eq (f x y) + ) + => (forall x y. Elems o '[x, y] -> c (f x y)) + -> SizedGen (Some (GenKU c f)) + -> SizedGen (Some (GenUK c f)) + -> SizedGen (Some (DepGen c)) + go_KU_UK cf left right = + SG.oneofStepped [ + (\(Some a) -> Some (genLeft (cf . ElemKU) a)) <$> left + , (\(Some b) -> Some (genRight (cf . ElemUK) b)) <$> right + ] + + go_UU_KK :: forall (f :: Type -> Type -> Type). + ( forall x y. (Show x, Show y) => Show (f x y) + , forall x y. (Eq x, Eq y) => Eq (f x y) + ) + => (forall x y. Elems o '[x, y] -> c (f x y)) + -> f Void Void + -> SizedGen (Some (GenKK c f)) + -> SizedGen (Some (DepGen c)) + go_UU_KK cf nothing just = + SG.leafOrStep + (pure $ Some $ DepGen (cf ElemUU) (pure nothing)) + [(\(Some ab@GenKK{}) -> Some (genPair (cf . uncurry ElemKK) ab)) <$> just] + + goTuple :: SizedGen (Some (DepGen c)) + goTuple = + (\(Some (SG.ValidTuple t)) -> Some (lift t)) <$> SG.genTuple go + where + lift :: (SListI xs, IsValidSize (Length xs)) + => NP (DepGen (Classifier_ o)) xs + -> DepGen (Classifier_ o) (WrappedTuple xs) + lift t = genNP (C_Tuple . Elems . hmap Elem) $ GenNP { + npGen = fmap tupleFromNP . hsequence + , npElem = t + } + + _checkAllCases :: Classifier_ o a -> () + _checkAllCases = \case + -- Primitive and user-defined + C_Prim{} -> () + C_Other{} -> () + + -- Compound + C_Maybe{} -> () + C_Either{} -> () + C_List{} -> () + C_Ratio{} -> () + C_Set{} -> () + C_Map{} -> () + C_IntMap{} -> () + C_Sequence{} -> () + C_Tree{} -> () + C_HashSet{} -> () + C_HashMap{} -> () + C_HM_Array{} -> () + C_Prim_Array{} -> () + C_Vector_Boxed{} -> () + C_Tuple{} -> () + +{------------------------------------------------------------------------------- + Auxiliary tree functions +-------------------------------------------------------------------------------} + +mkSomeTree :: [a] -> Tree a +mkSomeTree [] = error "mkSomeTree: empty" +mkSomeTree [x] = Tree.Node x [] +mkSomeTree [x, y] = Tree.Node x [Tree.Node y []] +mkSomeTree (x : xs) = + let (left, right) = split xs + in Tree.Node x [mkSomeTree left, mkSomeTree right] + +-- | Split list into halves +-- +-- If the input has at least two elements, neither list will be empty +-- +-- > split "abcde" == ("ace","bd") +split :: [a] -> ([a], [a]) +split [] = ([], []) +split (x:xs) = first (x:) $ splot xs + +-- | Auxiliary to 'split' +splot :: [a] -> ([a], [a]) +splot [] = ([], []) +splot (x:xs) = second (x:) $ split xs diff --git a/tests/Test/RecoverRTTI/Classifier/Equality.hs b/tests/Test/RecoverRTTI/Classifier/Equality.hs new file mode 100644 --- /dev/null +++ b/tests/Test/RecoverRTTI/Classifier/Equality.hs @@ -0,0 +1,12 @@ +-- | Equality orphan instances +module Test.RecoverRTTI.Classifier.Equality () where + +import Data.Function (on) + +import qualified Data.HashMap.Internal.Array as HashMap (Array) +import qualified Data.HashMap.Internal.Array as HashMap.Array + +import Test.RecoverRTTI.Prim () + +instance Eq a => Eq (HashMap.Array a) where + (==) = (==) `on` HashMap.Array.toList diff --git a/tests/Test/RecoverRTTI/Classifier/Size.hs b/tests/Test/RecoverRTTI/Classifier/Size.hs new file mode 100644 --- /dev/null +++ b/tests/Test/RecoverRTTI/Classifier/Size.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.RecoverRTTI.Classifier.Size (classifierSize_) where + +import Data.SOP + +import Debug.RecoverRTTI + +{------------------------------------------------------------------------------- + Size +-------------------------------------------------------------------------------} + +classifierSize_ :: forall o. + (forall a. o a -> Int) + -> (forall a. Classifier_ o a -> Int) +classifierSize_ sizeOther = go + where + go :: Classifier_ o a -> Int + go (C_Prim _) = 1 + go (C_Other c) = sizeOther c + go (C_Maybe c) = 1 + goElems c + go (C_Either c) = 1 + goElems c + go (C_List c) = 1 + goElems c + go (C_Ratio c) = 1 + goElems c + go (C_Set c) = 1 + goElems c + go (C_Map c) = 1 + goElems c + go (C_IntMap c) = 1 + goElems c + go (C_Sequence c) = 1 + goElems c + go (C_Tree c) = 1 + goElems c + go (C_HashSet c) = 1 + goElems c + go (C_HashMap c) = 1 + goElems c + go (C_HM_Array c) = 1 + goElems c + go (C_Prim_Array c) = 1 + goElems c + go (C_Vector_Boxed c) = 1 + goElems c + go (C_Tuple c) = 1 + goElems c + + goElems :: SListI as => Elems o as -> Int + goElems (Elems cs) = sum . hcollapse $ hmap (K . goElem) cs + + goElem :: Elem o a -> Int + goElem NoElem = 0 + goElem (Elem c) = go c diff --git a/tests/Test/RecoverRTTI/Classify.hs b/tests/Test/RecoverRTTI/Classify.hs --- a/tests/Test/RecoverRTTI/Classify.hs +++ b/tests/Test/RecoverRTTI/Classify.hs @@ -11,6 +11,7 @@ import Data.Ratio import Data.SOP import Data.Type.Equality +import Unsafe.Coerce (unsafeCoerce) import qualified Data.Aeson as Aeson import qualified Data.HashMap.Internal.Array as HashMap.Array @@ -19,19 +20,22 @@ import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import qualified Data.Map as Map +import qualified Data.Primitive.Array as Prim.Array import qualified Data.Sequence as Seq import qualified Data.Set as Set import qualified Data.Tree as Tree import qualified Data.Vector as Vector.Boxed +import qualified Data.Vector.Storable as Vector.Storable +import qualified Data.Vector.Primitive as Vector.Primitive import Test.Tasty import Test.Tasty.QuickCheck hiding (classify, NonEmpty) import Debug.RecoverRTTI +import Debug.RecoverRTTI.Classify -import Test.RecoverRTTI.Arbitrary import Test.RecoverRTTI.ConcreteClassifier -import Test.RecoverRTTI.Orphans () +import Test.RecoverRTTI.Globals import Test.RecoverRTTI.Staged import Test.RecoverRTTI.UserDefined @@ -50,185 +54,253 @@ prop_constants = withMaxSuccess 1 $ conjoin [ -- Primitive types - compareClassifier $ Value CC_Bool True - , compareClassifier $ Value CC_Bool False - , compareClassifier $ Value CC_Char 'a' - , compareClassifier $ Value CC_Double 1.25 - , compareClassifier $ Value CC_Float 1.25 - , compareClassifier $ Value CC_Int 1234 - , compareClassifier $ Value CC_Int (-1234) - , compareClassifier $ Value CC_Int8 123 - , compareClassifier $ Value CC_Int16 1234 - , compareClassifier $ Value CC_Int32 1234 - , compareClassifier $ Value CC_Int64 1234 - , compareClassifier $ Value CC_Integer 1234 - , compareClassifier $ Value CC_Integer (succ (fromIntegral (maxBound :: Int))) - , compareClassifier $ Value CC_Integer (pred (fromIntegral (minBound :: Int))) - , compareClassifier $ Value CC_Ordering LT - , compareClassifier $ Value CC_Ordering GT - , compareClassifier $ Value CC_Ordering EQ - , compareClassifier $ Value CC_Unit () - , compareClassifier $ Value CC_Word 1234 - , compareClassifier $ Value CC_Word8 123 - , compareClassifier $ Value CC_Word16 134 - , compareClassifier $ Value CC_Word32 1234 - , compareClassifier $ Value CC_Word64 1234 + compareClassifier $ Value (C_Prim C_Bool) True + , compareClassifier $ Value (C_Prim C_Bool) False + , compareClassifier $ Value (C_Prim C_Char) 'a' + , compareClassifier $ Value (C_Prim C_Double) 1.25 + , compareClassifier $ Value (C_Prim C_Float) 1.25 + , compareClassifier $ Value (C_Prim C_Int) 1234 + , compareClassifier $ Value (C_Prim C_Int) (-1234) + , compareClassifier $ Value (C_Prim C_Int8) 123 + , compareClassifier $ Value (C_Prim C_Int16) 1234 + , compareClassifier $ Value (C_Prim C_Int32) 1234 + , compareClassifier $ Value (C_Prim C_Int64) 1234 + , compareClassifier $ Value (C_Prim C_Integer) 1234 + , compareClassifier $ Value (C_Prim C_Integer) (succ (fromIntegral (maxBound :: Int))) + , compareClassifier $ Value (C_Prim C_Integer) (pred (fromIntegral (minBound :: Int))) + , compareClassifier $ Value (C_Prim C_Ordering) LT + , compareClassifier $ Value (C_Prim C_Ordering) GT + , compareClassifier $ Value (C_Prim C_Ordering) EQ + , compareClassifier $ Value (C_Prim C_Unit) () + , compareClassifier $ Value (C_Prim C_Word) 1234 + , compareClassifier $ Value (C_Prim C_Word8) 123 + , compareClassifier $ Value (C_Prim C_Word16) 134 + , compareClassifier $ Value (C_Prim C_Word32) 1234 + , compareClassifier $ Value (C_Prim C_Word64) 1234 -- String types -- - -- We skip the empty string, because we infer that as @CC_List Empty@ + -- We skip the empty string, because we infer that as @C_List Empty@ - , compareClassifier $ Value CC_String "abcdefg" - , compareClassifier $ Value CC_BS_Strict "" - , compareClassifier $ Value CC_BS_Strict "abcdefg" - , compareClassifier $ Value CC_BS_Lazy "" - , compareClassifier $ Value CC_BS_Lazy "abcdefg" - , compareClassifier $ Value CC_BS_Short "" - , compareClassifier $ Value CC_BS_Short "abcdefg" - , compareClassifier $ Value CC_Text_Strict "" - , compareClassifier $ Value CC_Text_Strict "abcdefg" - , compareClassifier $ Value CC_Text_Lazy "" - , compareClassifier $ Value CC_Text_Lazy "abcdefg" + , compareClassifier $ Value (C_Prim C_String) "abcdefg" + , compareClassifier $ Value (C_Prim C_BS_Strict) "" + , compareClassifier $ Value (C_Prim C_BS_Strict) "abcdefg" + , compareClassifier $ Value (C_Prim C_BS_Lazy) "" + , compareClassifier $ Value (C_Prim C_BS_Lazy) "abcdefg" + , compareClassifier $ Value (C_Prim C_BS_Short) "" + , compareClassifier $ Value (C_Prim C_BS_Short) "abcdefg" + , compareClassifier $ Value (C_Prim C_Text_Strict) "" + , compareClassifier $ Value (C_Prim C_Text_Strict) "abcdefg" + , compareClassifier $ Value (C_Prim C_Text_Lazy) "" + , compareClassifier $ Value (C_Prim C_Text_Lazy) "abcdefg" -- Aeson - , compareClassifier $ Value CC_Value (Aeson.object [("x" Aeson..= True)]) + , compareClassifier $ Value (C_Prim C_Value) (Aeson.object [("x" Aeson..= True)]) - -- Compound + -- Reference cells - , compareClassifier $ Value (CC_Maybe FNothing) Nothing - , compareClassifier $ Value (CC_Maybe (FJust CC_Int)) (Just 3) + , compareClassifier $ Value (C_Prim C_STRef) exampleIORef + , compareClassifier $ Value (C_Prim C_STRef) exampleSTRef + , compareClassifier $ Value (C_Prim C_MVar) exampleMVar + , compareClassifier $ Value (C_Prim C_TVar) exampleTVar - , compareClassifier $ Value (CC_Either (FLeft CC_Int)) (Left 3) - , compareClassifier $ Value (CC_Either (FRight CC_Bool)) (Right True) + -- Functions - , compareClassifier $ Value (CC_List FNothing) [] - , compareClassifier $ Value (CC_List (FJust CC_Int)) [1, 2, 3] + , compareClassifier $ Value (C_Prim C_Fun) (SomeFun id) - , compareClassifier $ Value (CC_Tuple (ConcreteClassifiers (CC_Int :* CC_Char :* Nil))) (WrappedTuple (4, 'a')) - , compareClassifier $ Value (CC_Tuple (ConcreteClassifiers (CC_Int :* CC_Char :* CC_Bool :* Nil))) (WrappedTuple (4, 'a', True)) + -- Containers without type arguments - , compareClassifier $ Value (CC_Ratio CC_Integer) (1 % 2) + , compareClassifier $ Value (C_Prim C_IntSet) $ + IntSet.empty + , compareClassifier $ Value (C_Prim C_IntSet) $ + IntSet.fromList [1, 2, 3] - , compareClassifier $ Value (CC_Set FNothing) Set.empty - , compareClassifier $ Value (CC_Set (FJust CC_Int)) (Set.fromList [1, 2, 3] ) + , compareClassifier $ Value (C_Prim C_Prim_ArrayM) $ + examplePrimArrayM - , compareClassifier $ Value (CC_Map FNothingPair) Map.empty - , compareClassifier $ Value (CC_Map (FJustPair CC_Int CC_Char)) (Map.fromList [(1, 'a'), (2, 'b')]) + , compareClassifier $ Value (C_Prim C_Vector_Storable) $ + SomeStorableVector $ unsafeCoerce $ + Vector.Storable.fromList ([1, 2] :: [Double]) - , compareClassifier $ Value CC_IntSet IntSet.empty - , compareClassifier $ Value CC_IntSet (IntSet.fromList [1, 2, 3]) + , compareClassifier $ Value (C_Prim C_Vector_StorableM) $ + exampleStorableVectorM - , compareClassifier $ Value (CC_IntMap FNothing) IntMap.empty - , compareClassifier $ Value (CC_IntMap (FJust CC_Char)) (IntMap.fromList [(1, 'a'), (2, 'b')]) + , compareClassifier $ Value (C_Prim C_Vector_Primitive) $ + SomePrimitiveVector $ unsafeCoerce $ + Vector.Primitive.fromList ([1, 2] :: [Double]) - , compareClassifier $ Value (CC_Sequence FNothing) Seq.empty - , compareClassifier $ Value (CC_Sequence (FJust CC_Int)) (Seq.fromList [1, 2, 3]) + , compareClassifier $ Value (C_Prim C_Vector_PrimitiveM) $ + examplePrimitiveVectorM - , compareClassifier $ Value (CC_Tree CC_Int) (Tree.Node 1 []) + -- Compound - , compareClassifier $ Value (CC_HashSet CC_Int) (HashSet.fromList [1, 2, 3]) + , compareClassifier $ Value (C_Maybe ElemU) $ + Nothing + , compareClassifier $ Value (C_Maybe (ElemK (C_Prim C_Int))) $ + Just 3 - , compareClassifier $ Value (CC_HashMap FNothingPair) HashMap.empty - , compareClassifier $ Value (CC_HashMap (FJustPair CC_Int CC_Char)) (HashMap.fromList [(1, 'a'), (2, 'b')]) + , compareClassifier $ Value (C_Either (ElemKU (C_Prim C_Int))) $ + Left 3 + , compareClassifier $ Value (C_Either (ElemUK (C_Prim C_Bool))) $ + Right True - , compareClassifier $ Value (CC_HM_Array FNothing) (HashMap.Array.fromList 0 []) - , compareClassifier $ Value (CC_HM_Array (FJust CC_Int)) (HashMap.Array.fromList 2 [1, 2]) + , compareClassifier $ Value (C_List ElemU) $ + [] + , compareClassifier $ Value (C_List (ElemK (C_Prim C_Int))) $ + [1, 2, 3] - , compareClassifier $ Value (CC_Vector_Boxed FNothing) Vector.Boxed.empty - , compareClassifier $ Value (CC_Vector_Boxed (FJust CC_Int)) (Vector.Boxed.fromList [1, 2, 3]) + , compareClassifier $ Value (C_Tuple (Elems (Elem (C_Prim C_Int) :* Elem (C_Prim C_Char) :* Nil))) $ + WrappedTuple (4, 'a') + , compareClassifier $ Value (C_Tuple (Elems (Elem (C_Prim C_Int) :* Elem (C_Prim C_Char) :* Elem (C_Prim C_Bool) :* Nil))) $ + WrappedTuple (4, 'a', True) - -- Reference cells + , compareClassifier $ Value (C_Ratio (ElemK (C_Prim C_Integer))) $ + 1 % 2 - , compareClassifier $ Value CC_STRef exampleIORef - , compareClassifier $ Value CC_STRef exampleSTRef - , compareClassifier $ Value CC_MVar exampleMVar - , compareClassifier $ Value CC_TVar exampleTVar + , compareClassifier $ Value (C_Set ElemU) $ + Set.empty + , compareClassifier $ Value (C_Set (ElemK (C_Prim C_Int))) $ + Set.fromList [1, 2, 3] - -- Functions + , compareClassifier $ Value (C_Map ElemUU) $ + Map.empty + , compareClassifier $ Value (C_Map (ElemKK (C_Prim C_Int) (C_Prim C_Char))) $ + Map.fromList [(1, 'a'), (2, 'b')] - , compareClassifier $ Value CC_Fun (SomeFun id) + , compareClassifier $ Value (C_IntMap ElemU) $ + IntMap.empty + , compareClassifier $ Value (C_IntMap (ElemK (C_Prim C_Char))) $ + IntMap.fromList [(1, 'a'), (2, 'b')] + , compareClassifier $ Value (C_Sequence ElemU) $ + Seq.empty + , compareClassifier $ Value (C_Sequence (ElemK (C_Prim C_Int))) $ + Seq.fromList [1, 2, 3] + + , compareClassifier $ Value (C_Tree (ElemK (C_Prim C_Int))) $ + Tree.Node 1 [] + + , compareClassifier $ Value (C_HashSet (ElemK (C_Prim C_Int))) $ + HashSet.fromList [1, 2, 3] + + , compareClassifier $ Value (C_HashMap ElemUU) $ + HashMap.empty + , compareClassifier $ Value (C_HashMap (ElemKK (C_Prim C_Int) (C_Prim C_Char))) $ + HashMap.fromList [(1, 'a'), (2, 'b')] + + , compareClassifier $ Value (C_HM_Array ElemU) $ + HashMap.Array.fromList 0 [] + , compareClassifier $ Value (C_HM_Array (ElemK (C_Prim C_Int))) $ + HashMap.Array.fromList 2 [1, 2] + + , compareClassifier $ Value (C_Prim_Array ElemU) $ + Prim.Array.fromList [] + , compareClassifier $ Value (C_Prim_Array (ElemK (C_Prim C_Int))) $ + Prim.Array.fromList [1, 2, 3] + + , compareClassifier $ Value (C_Vector_Boxed ElemU) $ + Vector.Boxed.empty + , compareClassifier $ Value (C_Vector_Boxed (ElemK (C_Prim C_Int))) $ + Vector.Boxed.fromList [1, 2, 3] + -- User defined - , compareClassifier $ Value CC_User_Simple SimpleA - , compareClassifier $ Value CC_User_Simple SimpleB - , compareClassifier $ Value (CC_User_NonRec FNothing) (NR1 1234) - , compareClassifier $ Value (CC_User_NonRec (FJust CC_Char)) (NR2 'a' True) - , compareClassifier $ Value (CC_User_Rec FNothing) RNil - , compareClassifier $ Value (CC_User_Rec (FJust CC_Char)) (RCons 'a' RNil) - , compareClassifier $ Value CC_User_Unlifted exampleContainsUnlifted + , compareClassifier $ Value (C_Other C_Simple) $ + SimpleA + , compareClassifier $ Value (C_Other C_Simple) $ + SimpleB + + , compareClassifier $ Value (C_Other (C_NonRec ElemU)) $ + (NR1 1234) + , compareClassifier $ Value (C_Other (C_NonRec (ElemK (C_Prim C_Char)))) $ + (NR2 True 'a') + + , compareClassifier $ Value (C_Other (C_Rec ElemU)) $ + RNil + , compareClassifier $ Value (C_Other (C_Rec (ElemK (C_Prim C_Char)))) $ + (RCons 'a' RNil) + + , compareClassifier $ Value (C_Other C_Unlifted) $ + exampleContainsUnlifted ] where _checkAllCases :: ConcreteClassifier a -> () _checkAllCases = \case - -- Primitive types - - CC_Bool -> () - CC_Char -> () - CC_Double -> () - CC_Float -> () - CC_Int -> () - CC_Int8 -> () - CC_Int16 -> () - CC_Int32 -> () - CC_Int64 -> () - CC_Integer -> () - CC_Ordering -> () - CC_Unit -> () - CC_Word -> () - CC_Word8 -> () - CC_Word16 -> () - CC_Word32 -> () - CC_Word64 -> () + C_Prim C_Bool -> () + C_Prim C_Char -> () + C_Prim C_Double -> () + C_Prim C_Float -> () + C_Prim C_Int -> () + C_Prim C_Int8 -> () + C_Prim C_Int16 -> () + C_Prim C_Int32 -> () + C_Prim C_Int64 -> () + C_Prim C_Integer -> () + C_Prim C_Ordering -> () + C_Prim C_Unit -> () + C_Prim C_Word -> () + C_Prim C_Word8 -> () + C_Prim C_Word16 -> () + C_Prim C_Word32 -> () + C_Prim C_Word64 -> () -- String types - CC_String -> () - CC_BS_Strict -> () - CC_BS_Lazy -> () - CC_BS_Short -> () - CC_Text_Strict -> () - CC_Text_Lazy -> () + C_Prim C_String -> () + C_Prim C_BS_Strict -> () + C_Prim C_BS_Lazy -> () + C_Prim C_BS_Short -> () + C_Prim C_Text_Strict -> () + C_Prim C_Text_Lazy -> () -- Aeson - CC_Value -> () + C_Prim C_Value -> () - -- Compound + -- Containers without type arguments - CC_Maybe{} -> () - CC_Either{} -> () - CC_List{} -> () - CC_Ratio{} -> () - CC_Set{} -> () - CC_Map{} -> () - CC_IntSet{} -> () - CC_IntMap{} -> () - CC_Sequence{} -> () - CC_Tree{} -> () - CC_Tuple{} -> () - CC_HashSet{} -> () - CC_HashMap{} -> () - CC_HM_Array{} -> () - CC_Vector_Boxed{} -> () + C_Prim C_IntSet -> () + C_Prim C_Prim_ArrayM -> () + C_Prim C_Vector_Storable -> () + C_Prim C_Vector_StorableM -> () + C_Prim C_Vector_Primitive -> () + C_Prim C_Vector_PrimitiveM -> () -- Functions - CC_Fun{} -> () + C_Prim C_Fun -> () -- Reference cells - CC_STRef -> () - CC_TVar -> () - CC_MVar -> () + C_Prim C_STRef -> () + C_Prim C_TVar -> () + C_Prim C_MVar -> () + -- Compound + + C_Maybe{} -> () + C_Either{} -> () + C_List{} -> () + C_Ratio{} -> () + C_Set{} -> () + C_Map{} -> () + C_IntMap{} -> () + C_Sequence{} -> () + C_Tree{} -> () + C_Tuple{} -> () + C_HashSet{} -> () + C_HashMap{} -> () + C_HM_Array{} -> () + C_Prim_Array{} -> () + C_Vector_Boxed{} -> () + -- User-defined - CC_User_Simple{} -> () - CC_User_NonRec{} -> () - CC_User_Rec{} -> () - CC_User_Unlifted{} -> () + C_Other (C_Simple{}) -> () + C_Other (C_NonRec{}) -> () + C_Other (C_Rec{}) -> () + C_Other (C_Unlifted{}) -> () -- | Test using arbitrary values prop_arbitrary :: Some Value -> Property @@ -240,14 +312,14 @@ compareClassifier :: Value a -> Property compareClassifier = \(Value cc x) -> counterexample ("Generated classifier: " ++ show cc) - $ case runExcept $ classifyThenReclassify x of + $ case runExcept $ classifyConcrete x of Left err -> counterexample ("Failed to reclassify. Error: " ++ err) $ property False - Right (Reclassified cc' f) -> - case sameConcreteClassifier cc cc' of + Right (Reclassified cc' _pf) -> + case sameConcrete cc cc' of Nothing -> counterexample ("Inferred different classifier: " ++ show cc') $ property False Just Refl -> - x === f x + property True diff --git a/tests/Test/RecoverRTTI/ConcreteClassifier.hs b/tests/Test/RecoverRTTI/ConcreteClassifier.hs --- a/tests/Test/RecoverRTTI/ConcreteClassifier.hs +++ b/tests/Test/RecoverRTTI/ConcreteClassifier.hs @@ -1,52 +1,59 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} module Test.RecoverRTTI.ConcreteClassifier ( -- * Concrete classifier - ConcreteClassifier(..) - , sameConcreteClassifier - , ConcreteClassifiers(..) - , classifierSize + ConcreteClassifier + , ClassifyUser(..) -- * Values , Value(..) + -- * Constraints + , canShowConcrete + , canCompareConcrete + -- * Size + , sizeUser + , sizeConcrete + -- * Same classifier + , sameUser + , sameConcrete + -- * Equality + -- * Arbitrary + , arbitraryUser + , arbitraryConcrete ) where -import Data.HashMap.Lazy (HashMap) -import Data.HashSet (HashSet) -import Data.Int -import Data.IntMap (IntMap) -import Data.IntSet (IntSet) import Data.Kind -import Data.Map (Map) -import Data.Ratio -import Data.Sequence (Seq) -import Data.Set (Set) import Data.SOP import Data.SOP.Dict -import Data.Tree (Tree) import Data.Type.Equality -import Data.Word - -import qualified Data.Aeson as Aeson -import qualified Data.ByteString as BS.Strict -import qualified Data.ByteString.Lazy as BS.Lazy -import qualified Data.ByteString.Short as BS.Short -import qualified Data.HashMap.Internal.Array as HashMap (Array) -import qualified Data.Text as Text.Strict -import qualified Data.Text.Lazy as Text.Lazy -import qualified Data.Vector as Vector.Boxed +import Data.Void import Debug.RecoverRTTI +import Debug.RecoverRTTI.Classify +import Test.QuickCheck + +import Test.RecoverRTTI.Classifier.Arbitrary +import Test.RecoverRTTI.Classifier.Equality () +import Test.RecoverRTTI.Classifier.Size +import Test.RecoverRTTI.QuickCheck.DepGen +import Test.RecoverRTTI.QuickCheck.Sized (SizedGen) import Test.RecoverRTTI.UserDefined +import qualified Test.RecoverRTTI.QuickCheck.Sized as SG + {------------------------------------------------------------------------------- Concrete classifier @@ -60,180 +67,15 @@ information about which user-defined types we're interested in). -------------------------------------------------------------------------------} --- | Like 'Classifier', but with no guess-work and concrete types -data ConcreteClassifier (a :: Type) :: Type where - -- Primitive types - - CC_Bool :: ConcreteClassifier Bool - CC_Char :: ConcreteClassifier Char - CC_Double :: ConcreteClassifier Double - CC_Float :: ConcreteClassifier Float - CC_Int :: ConcreteClassifier Int - CC_Int8 :: ConcreteClassifier Int8 - CC_Int16 :: ConcreteClassifier Int16 - CC_Int32 :: ConcreteClassifier Int32 - CC_Int64 :: ConcreteClassifier Int64 - CC_Integer :: ConcreteClassifier Integer - CC_Ordering :: ConcreteClassifier Ordering - CC_Unit :: ConcreteClassifier () - CC_Word :: ConcreteClassifier Word - CC_Word8 :: ConcreteClassifier Word8 - CC_Word16 :: ConcreteClassifier Word16 - CC_Word32 :: ConcreteClassifier Word32 - CC_Word64 :: ConcreteClassifier Word64 - - -- Text types - - CC_String :: ConcreteClassifier String - CC_BS_Strict :: ConcreteClassifier BS.Strict.ByteString - CC_BS_Lazy :: ConcreteClassifier BS.Lazy.ByteString - CC_BS_Short :: ConcreteClassifier BS.Short.ShortByteString - CC_Text_Strict :: ConcreteClassifier Text.Strict.Text - CC_Text_Lazy :: ConcreteClassifier Text.Lazy.Text - - -- Aeson - - CC_Value :: ConcreteClassifier Aeson.Value - - -- Compound - - CC_Maybe :: MaybeF ConcreteClassifier a -> ConcreteClassifier (Maybe a) - CC_Either :: EitherF ConcreteClassifier a b -> ConcreteClassifier (Either a b) - CC_List :: MaybeF ConcreteClassifier a -> ConcreteClassifier [a] - CC_Ratio :: ConcreteClassifier a -> ConcreteClassifier (Ratio a) - CC_Set :: MaybeF ConcreteClassifier a -> ConcreteClassifier (Set a) - CC_Map :: MaybePairF ConcreteClassifier a b -> ConcreteClassifier (Map a b) - CC_IntSet :: ConcreteClassifier IntSet - CC_IntMap :: MaybeF ConcreteClassifier a -> ConcreteClassifier (IntMap a) - CC_Sequence :: MaybeF ConcreteClassifier a -> ConcreteClassifier (Seq a) - CC_Tree :: ConcreteClassifier a -> ConcreteClassifier (Tree a) - CC_HashSet :: ConcreteClassifier a -> ConcreteClassifier (HashSet a) - CC_HashMap :: MaybePairF ConcreteClassifier a b -> ConcreteClassifier (HashMap a b) - CC_HM_Array :: MaybeF ConcreteClassifier a -> ConcreteClassifier (HashMap.Array a) - CC_Vector_Boxed :: MaybeF ConcreteClassifier a -> ConcreteClassifier (Vector.Boxed.Vector a) - - CC_Tuple :: - (SListI xs, IsValidSize (Length xs)) - => ConcreteClassifiers xs -> ConcreteClassifier (WrappedTuple xs) - - -- Functions - - CC_Fun :: ConcreteClassifier SomeFun - - -- Reference cells - - CC_STRef :: ConcreteClassifier SomeSTRef - CC_TVar :: ConcreteClassifier SomeTVar - CC_MVar :: ConcreteClassifier SomeMVar - - -- User-defined - - CC_User_Simple :: ConcreteClassifier SimpleType - CC_User_NonRec :: MaybeF ConcreteClassifier a -> ConcreteClassifier (NonRecursive a) - CC_User_Rec :: MaybeF ConcreteClassifier a -> ConcreteClassifier (Recursive a) - CC_User_Unlifted :: ConcreteClassifier ContainsUnlifted - -newtype ConcreteClassifiers xs = ConcreteClassifiers (NP ConcreteClassifier xs) - -deriving instance Show (ConcreteClassifier a) -deriving instance Show (MaybeF ConcreteClassifier a) -deriving instance Show (EitherF ConcreteClassifier a b) -deriving instance Show (MaybePairF ConcreteClassifier a b) - -instance SListI xs => Show (ConcreteClassifiers xs) where - show (ConcreteClassifiers xs) = go (hpure Dict) - where - go :: NP (Dict (Compose Show ConcreteClassifier)) xs -> String - go dicts = - case all_NP dicts of - Dict -> "(" ++ show xs ++ ")" - -{------------------------------------------------------------------------------- - Size of the classifier - - Mostly used for sanity checking the generator --------------------------------------------------------------------------------} - -classifierSize :: ConcreteClassifier a -> Int -classifierSize = go - where - go :: ConcreteClassifier a -> Int - - -- Primitive types - go CC_Bool = 1 - go CC_Char = 1 - go CC_Double = 1 - go CC_Float = 1 - go CC_Int = 1 - go CC_Int8 = 1 - go CC_Int16 = 1 - go CC_Int32 = 1 - go CC_Int64 = 1 - go CC_Integer = 1 - go CC_Ordering = 1 - go CC_Unit = 1 - go CC_Word = 1 - go CC_Word8 = 1 - go CC_Word16 = 1 - go CC_Word32 = 1 - go CC_Word64 = 1 - - -- Text types - go CC_String = 1 - go CC_BS_Strict = 1 - go CC_BS_Lazy = 1 - go CC_BS_Short = 1 - go CC_Text_Strict = 1 - go CC_Text_Lazy = 1 - - -- Aeson - go CC_Value = 1 - - -- Compound - - go (CC_Maybe c) = 1 + goMaybeF c - go (CC_Either c) = 1 + goEitherF c - go (CC_List c) = 1 + goMaybeF c - go (CC_Ratio c) = 1 + go c - go (CC_Set c) = 1 + goMaybeF c - go (CC_Map c) = 1 + goMaybePairF c - go CC_IntSet = 1 - go (CC_IntMap c) = 1 + goMaybeF c - go (CC_Sequence c) = 1 + goMaybeF c - go (CC_Tree c) = 1 + go c - go (CC_HashSet c) = 1 + go c - go (CC_HashMap c) = 1 + goMaybePairF c - go (CC_HM_Array c) = 1 + goMaybeF c - go (CC_Vector_Boxed c) = 1 + goMaybeF c - - go (CC_Tuple (ConcreteClassifiers cs)) = - 1 + sum (hcollapse (hmap (K . go) cs)) - - -- Functions - go CC_Fun = 1 - - -- Reference cells - go CC_STRef = 1 - go CC_TVar = 1 - go CC_MVar = 1 - - -- User-defined - go CC_User_Simple = 1 - go (CC_User_NonRec c) = 1 + goMaybeF c - go (CC_User_Rec c) = 1 + goMaybeF c - go CC_User_Unlifted = 1 - - goMaybeF :: MaybeF ConcreteClassifier a -> Int - goMaybeF FNothing = 0 - goMaybeF (FJust c) = go c +type ConcreteClassifier = Classifier_ ClassifyUser - goEitherF :: EitherF ConcreteClassifier a b -> Int - goEitherF (FLeft c) = go c - goEitherF (FRight c) = go c +data ClassifyUser (a :: Type) where + C_Simple :: ClassifyUser SimpleType + C_NonRec :: Elems ClassifyUser '[a] -> ClassifyUser (NonRecursive a) + C_Rec :: Elems ClassifyUser '[a] -> ClassifyUser (Recursive a) + C_Unlifted :: ClassifyUser ContainsUnlifted - goMaybePairF :: MaybePairF ConcreteClassifier a b -> Int - goMaybePairF FNothingPair = 0 - goMaybePairF (FJustPair c c') = go c + go c' +deriving instance Show (ClassifyUser a) {------------------------------------------------------------------------------- Values @@ -249,202 +91,153 @@ deriving instance Show (Value a) deriving instance Show (Some Value) -{------------------------------------------------------------------------------- - Equality --------------------------------------------------------------------------------} - --- | Check that two classifiers are the same --- --- If they are the same, additionally return a proof that that means the --- /types/ they classify must be equal (note that equality on the classifiers --- is strictly stronger than equality on the types: for example, non-empty --- and empty lists have different classifiers, but classify the same type). -sameConcreteClassifier :: - ConcreteClassifier a - -> ConcreteClassifier b - -> Maybe (a :~: b) -sameConcreteClassifier = go - where - go :: ConcreteClassifier a -> ConcreteClassifier b -> Maybe (a :~: b) - go CC_Bool CC_Bool = Just Refl - go CC_Char CC_Char = Just Refl - go CC_Double CC_Double = Just Refl - go CC_Float CC_Float = Just Refl - go CC_Int CC_Int = Just Refl - go CC_Int8 CC_Int8 = Just Refl - go CC_Int16 CC_Int16 = Just Refl - go CC_Int32 CC_Int32 = Just Refl - go CC_Int64 CC_Int64 = Just Refl - go CC_Integer CC_Integer = Just Refl - go CC_Ordering CC_Ordering = Just Refl - go CC_Unit CC_Unit = Just Refl - go CC_Word CC_Word = Just Refl - go CC_Word8 CC_Word8 = Just Refl - go CC_Word16 CC_Word16 = Just Refl - go CC_Word32 CC_Word32 = Just Refl - go CC_Word64 CC_Word64 = Just Refl - - -- String types +instance Arbitrary (Some Value) where + arbitrary = do + -- We don't want to generate large classifiers + Some (DepGen cc gen) <- SG.run 10 arbitraryConcrete - go CC_String CC_String = Just Refl - go CC_BS_Strict CC_BS_Strict = Just Refl - go CC_BS_Lazy CC_BS_Lazy = Just Refl - go CC_BS_Short CC_BS_Short = Just Refl - go CC_Text_Strict CC_Text_Strict = Just Refl - go CC_Text_Lazy CC_Text_Lazy = Just Refl + -- For the values however we want to be able to generate larger trees + Some . Value cc <$> SG.run 1000 gen - -- Aeson +{------------------------------------------------------------------------------- + Constraints +-------------------------------------------------------------------------------} - go CC_Value CC_Value = Just Refl +class ( + c SimpleType + , forall a. c a => c (NonRecursive a) + , forall a. c a => c (Recursive a) + , c ContainsUnlifted + ) => UserSatisfies c - -- Compound +instance ( + c SimpleType + , forall a. c a => c (NonRecursive a) + , forall a. c a => c (Recursive a) + , c ContainsUnlifted + ) => UserSatisfies c - go (CC_Maybe c) (CC_Maybe c') = goMaybeF c c' - go (CC_Either c) (CC_Either c') = goEitherF c c' - go (CC_List c) (CC_List c') = goMaybeF c c' - go (CC_Ratio c) (CC_Ratio c') = goF c c' - go (CC_Set c) (CC_Set c') = goMaybeF c c' - go (CC_Map c) (CC_Map c') = goMaybePairF c c' - go CC_IntSet CC_IntSet = Just Refl - go (CC_IntMap c) (CC_IntMap c') = goMaybeF c c' - go (CC_Sequence c) (CC_Sequence c') = goMaybeF c c' - go (CC_Tree c) (CC_Tree c') = goF c c' - go (CC_HashSet c) (CC_HashSet c') = goF c c' - go (CC_HashMap c) (CC_HashMap c') = goMaybePairF c c' - go (CC_HM_Array c) (CC_HM_Array c') = goMaybeF c c' - go (CC_Vector_Boxed c) (CC_Vector_Boxed c') = goMaybeF c c' +userSatisfies :: forall c. + (ClassifiedSatisfies c, c Void, UserSatisfies c) + => (forall a. ClassifyUser a -> Dict c a) +userSatisfies = go + where + go :: ClassifyUser a -> Dict c a + go C_Simple = Dict + go (C_NonRec c) = goElems c $ Dict + go (C_Rec c) = goElems c $ Dict + go C_Unlifted = Dict - go (CC_Tuple (ConcreteClassifiers cs)) - (CC_Tuple (ConcreteClassifiers cs')) = (\Refl -> Refl) <$> goList cs cs' + goElems :: SListI as => Elems ClassifyUser as -> (All c as => r) -> r + goElems (Elems cs) k = case all_NP (hmap goElem cs) of Dict -> k - -- Reference cells + goElem :: Elem ClassifyUser a -> Dict c a + goElem (Elem c) = concreteSatisfies c + goElem NoElem = Dict - go CC_STRef CC_STRef = Just Refl - go CC_TVar CC_TVar = Just Refl - go CC_MVar CC_MVar = Just Refl +concreteSatisfies :: + (ClassifiedSatisfies c, c Void, UserSatisfies c) + => ConcreteClassifier a -> Dict c a +concreteSatisfies = classifiedSatisfies userSatisfies - -- Functions +canShowConcrete :: ConcreteClassifier a -> Dict Show a +canShowConcrete = concreteSatisfies - go CC_Fun CC_Fun = Just Refl +canCompareConcrete :: ConcreteClassifier a -> Dict Eq a +canCompareConcrete = concreteSatisfies - -- User-defined +{------------------------------------------------------------------------------- + Size of the classifier - go CC_User_Simple CC_User_Simple = Just Refl - go (CC_User_NonRec c) (CC_User_NonRec c') = goMaybeF c c' - go (CC_User_Rec c) (CC_User_Rec c') = goMaybeF c c' - go CC_User_Unlifted CC_User_Unlifted = Just Refl + Mostly used for sanity checking the generator +-------------------------------------------------------------------------------} - -- Otherwise, not equal +sizeUser :: ClassifyUser a -> Int +sizeUser = go + where + go :: ClassifyUser a -> Int + go C_Simple = 1 + go (C_NonRec c) = 1 + goElems c + go (C_Rec c) = 1 + goElems c + go C_Unlifted = 1 - go _ _ = Nothing + goElems :: SListI as => Elems ClassifyUser as -> Int + goElems (Elems cs) = sum . hcollapse $ hmap (K . goElem) cs - goMaybeF :: - MaybeF ConcreteClassifier x - -> MaybeF ConcreteClassifier x' - -> Maybe (f x :~: f x') - goMaybeF FNothing FNothing = Just Refl - goMaybeF (FJust x) (FJust x') = (\Refl -> Refl) <$> go x x' - goMaybeF _ _ = Nothing + goElem :: Elem ClassifyUser a -> Int + goElem NoElem = 0 + goElem (Elem c) = sizeConcrete c - goEitherF :: - EitherF ConcreteClassifier x y - -> EitherF ConcreteClassifier x' y' - -> Maybe (f x y :~: f x' y') - goEitherF (FLeft x) (FLeft x') = (\Refl -> Refl) <$> go x x' - goEitherF (FRight y) (FRight y') = (\Refl -> Refl) <$> go y y' - goEitherF (FLeft _) (FRight _ ) = Nothing - goEitherF (FRight _) (FLeft _ ) = Nothing +sizeConcrete :: ConcreteClassifier a -> Int +sizeConcrete = classifierSize_ sizeUser - goF :: - ConcreteClassifier x - -> ConcreteClassifier x' - -> Maybe (f x :~: f x') - goF x x' = (\Refl -> Refl) <$> go x x' +{------------------------------------------------------------------------------- + Same classifier +-------------------------------------------------------------------------------} - goMaybePairF :: - MaybePairF ConcreteClassifier x y - -> MaybePairF ConcreteClassifier x' y' - -> Maybe (f x y :~: f x' y') - goMaybePairF FNothingPair FNothingPair = Just Refl - goMaybePairF (FJustPair x y) (FJustPair x' y') = (\Refl Refl -> Refl) <$> go x x' <*> go y y' - goMaybePairF _ _ = Nothing +-- | Check that two classifiers are the same +sameConcrete :: + ConcreteClassifier a + -> ConcreteClassifier b + -> Maybe (a :~: b) +sameConcrete = sameClassifier_ sameUser - goList :: - NP ConcreteClassifier xs - -> NP ConcreteClassifier ys - -> Maybe (xs :~: ys) - goList Nil Nil = Just Refl - goList (x :* xs) (y :* ys) = (\Refl Refl -> Refl) <$> go x y <*> goList xs ys - goList Nil (_ :* _) = Nothing - goList (_ :* _) Nil = Nothing +sameUser :: ClassifyUser a -> ClassifyUser b -> Maybe (a :~: b) +sameUser = go + where + go :: ClassifyUser a -> ClassifyUser b -> Maybe (a :~: b) + go C_Simple C_Simple = Just Refl + go (C_NonRec c) (C_NonRec c') = sameElems sameUser c c' $ Refl + go (C_Rec c) (C_Rec c') = sameElems sameUser c c' $ Refl + go C_Unlifted C_Unlifted = Just Refl + go _ _ = Nothing - -- Make sure we get a warning if we add another constructor - _checkAllCases :: ConcreteClassifier a -> () + _checkAllCases :: ClassifyUser a -> () _checkAllCases = \case - -- Primitive types - - CC_Bool -> () - CC_Char -> () - CC_Double -> () - CC_Float -> () - CC_Int -> () - CC_Int8 -> () - CC_Int16 -> () - CC_Int32 -> () - CC_Int64 -> () - CC_Integer -> () - CC_Ordering -> () - CC_Unit -> () - CC_Word -> () - CC_Word8 -> () - CC_Word16 -> () - CC_Word32 -> () - CC_Word64 -> () - - -- String types - - CC_String -> () - CC_BS_Strict -> () - CC_BS_Lazy -> () - CC_BS_Short -> () - CC_Text_Strict -> () - CC_Text_Lazy -> () - - -- Aeson - - CC_Value -> () - - -- Compound + C_Simple{} -> () + C_NonRec{} -> () + C_Rec{} -> () + C_Unlifted{} -> () - CC_Maybe{} -> () - CC_Either{} -> () - CC_List{} -> () - CC_Ratio{} -> () - CC_Set{} -> () - CC_Map{} -> () - CC_IntSet{} -> () - CC_IntMap{} -> () - CC_Tuple{} -> () - CC_Sequence{} -> () - CC_Tree{} -> () - CC_HashSet{} -> () - CC_HashMap{} -> () - CC_HM_Array{} -> () - CC_Vector_Boxed{} -> () +{------------------------------------------------------------------------------- + Arbitrary +-------------------------------------------------------------------------------} - -- Reference cells +arbitraryUser :: SizedGen (Some (DepGen ClassifyUser)) +arbitraryUser = SG.leafOrStep leaf compound + where + leaf :: Gen (Some (DepGen ClassifyUser)) + leaf = oneof [ + -- SimpleType + pure . Some $ arbitraryDepGen C_Simple - CC_STRef -> () - CC_TVar -> () - CC_MVar -> () + -- ContainsUnlifted + , pure . Some $ arbitraryDepGen C_Unlifted + ] - -- Functions + compound :: [SizedGen (Some (DepGen ClassifyUser))] + compound = [ + -- NonRecursive + go_U_K C_NonRec (NR1 1234) + (mapSome (GenK (fmap (NR2 True))) <$> arbitraryConcrete) - CC_Fun -> () + -- Recursive + , go_U_K C_Rec RNil + (mapSome (GenK (SG.genListLike recursiveFromList)) <$> arbitraryConcrete) + ] - -- User-defined + go_U_K :: + ( forall x. Show x => Show (f x) + , forall x. Eq x => Eq (f x) + ) + => (forall a. Elems ClassifyUser '[a] -> ClassifyUser (f a)) + -> f Void + -> SizedGen (Some (GenK ConcreteClassifier f)) + -> SizedGen (Some (DepGen ClassifyUser)) + go_U_K cf nothing just = + SG.leafOrStep + (pure $ Some $ DepGen (cf ElemU) (pure nothing)) + [(\(Some a) -> Some (genJust (cf . ElemK) a)) <$> just] - CC_User_Simple{} -> () - CC_User_NonRec{} -> () - CC_User_Rec{} -> () - CC_User_Unlifted{} -> () +arbitraryConcrete :: SizedGen (Some (DepGen ConcreteClassifier)) +arbitraryConcrete = arbitraryClassifier_ arbitraryUser diff --git a/tests/Test/RecoverRTTI/Globals.hs b/tests/Test/RecoverRTTI/Globals.hs new file mode 100644 --- /dev/null +++ b/tests/Test/RecoverRTTI/Globals.hs @@ -0,0 +1,62 @@ +-- | Global mutable variables +-- +-- The tests are entirely pure, but occassionally needs examples of these +-- mutable structures. Having a single global example available is convenient. +module Test.RecoverRTTI.Globals ( + exampleIORef + , exampleSTRef + , exampleMVar + , exampleTVar + , examplePrimArrayM + , exampleStorableVectorM + , examplePrimitiveVectorM + ) where + +import Control.Concurrent.MVar (newEmptyMVar) +import Control.Concurrent.STM (newTVarIO) +import Control.Monad.ST.Unsafe (unsafeSTToIO) +import Data.IORef (newIORef) +import Data.STRef (newSTRef) +import System.IO.Unsafe (unsafePerformIO) +import Unsafe.Coerce (unsafeCoerce) + +import qualified Data.Primitive.Array as Prim.Array +import qualified Data.Vector.Primitive as Vector.Primitive +import qualified Data.Vector.Storable as Vector.Storable + +import Debug.RecoverRTTI + +exampleIORef :: SomeSTRef +{-# NOINLINE exampleIORef #-} +exampleIORef = unsafePerformIO $ + -- IORef is indistinguishable from STRef on the heap + unsafeCoerce <$> newIORef (unsafeCoerce ()) + +exampleSTRef :: SomeSTRef +exampleSTRef = unsafePerformIO $ unsafeSTToIO $ + unsafeCoerce <$> newSTRef (unsafeCoerce ()) + +exampleMVar :: SomeMVar +{-# NOINLINE exampleMVar #-} +exampleMVar = unsafePerformIO $ + SomeMVar <$> newEmptyMVar + +exampleTVar :: SomeTVar +{-# NOINLINE exampleTVar #-} +exampleTVar = unsafePerformIO $ + SomeTVar <$> newTVarIO (unsafeCoerce ()) + +examplePrimArrayM :: SomePrimArrayM +{-# NOINLINE examplePrimArrayM #-} +examplePrimArrayM = unsafePerformIO $ + unsafeCoerce <$> Prim.Array.newArray 0 (error "no elements") + +exampleStorableVectorM :: SomeStorableVectorM +{-# NOINLINE exampleStorableVectorM #-} +exampleStorableVectorM = unsafePerformIO $ + unsafeCoerce <$> Vector.Storable.thaw (Vector.Storable.fromList "abc") + +examplePrimitiveVectorM :: SomePrimitiveVectorM +{-# NOINLINE examplePrimitiveVectorM #-} +examplePrimitiveVectorM = unsafePerformIO $ + unsafeCoerce <$> Vector.Primitive.thaw (Vector.Primitive.fromList "abc") diff --git a/tests/Test/RecoverRTTI/Orphans.hs b/tests/Test/RecoverRTTI/Orphans.hs deleted file mode 100644 --- a/tests/Test/RecoverRTTI/Orphans.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Test.RecoverRTTI.Orphans () where - -import Data.Function (on) - -import qualified Data.HashMap.Internal.Array as HashMap (Array) -import qualified Data.HashMap.Internal.Array as HashMap.Array - -import Debug.RecoverRTTI - --- | Degenerate 'Eq' instance for functions that always says 'True' --- --- When we compare values up to the coercion returned by 'reclassify', we need --- an 'Eq' instance. We can't compare functions in any meaningful way though, --- and so we just return 'True' here no matter what. --- --- This is an orphan defined in the test suite only, so that users of the --- library don't have acccess to this (misleading) instance. -instance Eq SomeFun where - _ == _ = True - -instance Eq a => Eq (HashMap.Array a) where - (==) = (==) `on` HashMap.Array.toList diff --git a/tests/Test/RecoverRTTI/Prim.hs b/tests/Test/RecoverRTTI/Prim.hs new file mode 100644 --- /dev/null +++ b/tests/Test/RecoverRTTI/Prim.hs @@ -0,0 +1,292 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Test.RecoverRTTI.Prim ( + -- * Equality + canComparePrim + -- * Arbitrary + , primSatisfiesArbitrary + , arbitraryPrimClassifier + ) where + +import Control.Monad +import Data.SOP.Dict +import Unsafe.Coerce (unsafeCoerce) + +import qualified Data.Aeson as Aeson +import qualified Data.ByteString as BS.Strict +import qualified Data.ByteString.Lazy as BS.Lazy +import qualified Data.ByteString.Short as BS.Short +import qualified Data.Text as Text.Strict +import qualified Data.Text.Lazy as Text.Lazy +import qualified Data.Vector as Vector.Boxed +import qualified Data.Vector.Storable as Vector.Storable +import qualified Data.Vector.Primitive as Vector.Primitive + +import Debug.RecoverRTTI + +import Test.QuickCheck + +import Test.RecoverRTTI.Globals + +{------------------------------------------------------------------------------- + Equality +-------------------------------------------------------------------------------} + +canComparePrim :: PrimClassifier a -> Dict Eq a +canComparePrim = primSatisfies + +{------------------------------------------------------------------------------- + Arbitrary support for the primitive types +-------------------------------------------------------------------------------} + +primSatisfiesArbitrary :: PrimClassifier a -> Dict Arbitrary a +primSatisfiesArbitrary = primSatisfies + +arbitraryPrimClassifier :: Gen (Some PrimClassifier) +arbitraryPrimClassifier = elements [ + -- Primitive types + + Some C_Bool + , Some C_Char + , Some C_Double + , Some C_Float + , Some C_Int + , Some C_Int16 + , Some C_Int8 + , Some C_Int32 + , Some C_Int64 + , Some C_Integer + , Some C_Ordering + , Some C_Unit + , Some C_Word + , Some C_Word8 + , Some C_Word16 + , Some C_Word32 + , Some C_Word64 + + -- String types + + , Some C_String + , Some C_BS_Strict + , Some C_BS_Lazy + , Some C_BS_Short + , Some C_Text_Strict + , Some C_Text_Lazy + + -- Aeson + + , Some C_Value + + -- Reference cells + + , Some C_STRef + , Some C_TVar + , Some C_MVar + + -- Functions + + , Some C_Fun + + -- Containers with no type arguments + + , Some C_IntSet + , Some C_Prim_ArrayM + , Some C_Vector_Storable + , Some C_Vector_StorableM + , Some C_Vector_Primitive + , Some C_Vector_PrimitiveM + ] + where + _checkAllCases :: PrimClassifier a -> () + _checkAllCases = \case + -- Primitive types + + C_Bool -> () + C_Char -> () + C_Double -> () + C_Float -> () + C_Int -> () + C_Int16 -> () + C_Int8 -> () + C_Int32 -> () + C_Int64 -> () + C_Integer -> () + C_Ordering -> () + C_Unit -> () + C_Word -> () + C_Word8 -> () + C_Word16 -> () + C_Word32 -> () + C_Word64 -> () + + -- String types + + C_String -> () + C_BS_Strict -> () + C_BS_Lazy -> () + C_BS_Short -> () + C_Text_Strict -> () + C_Text_Lazy -> () + + -- Aeson + + C_Value -> () + + -- Reference cells + + C_STRef -> () + C_TVar -> () + C_MVar -> () + + -- Functions + + C_Fun -> () + + -- Containers with no type arguments + + C_IntSet -> () + C_Prim_ArrayM -> () + C_Vector_Storable -> () + C_Vector_StorableM -> () + C_Vector_Primitive -> () + C_Vector_PrimitiveM -> () + +{------------------------------------------------------------------------------- + Orphan instances +-------------------------------------------------------------------------------} + +instance Arbitrary BS.Strict.ByteString where + arbitrary = BS.Strict.pack <$> arbitrary + +instance Arbitrary BS.Lazy.ByteString where + arbitrary = BS.Lazy.pack <$> arbitrary + +instance Arbitrary BS.Short.ShortByteString where + arbitrary = BS.Short.pack <$> arbitrary + +instance Arbitrary Text.Strict.Text where + arbitrary = Text.Strict.pack <$> arbitrary + +instance Arbitrary Text.Lazy.Text where + arbitrary = Text.Lazy.pack <$> arbitrary + +instance Arbitrary Aeson.Value where + arbitrary = choose (0, 10) >>= go + where + go :: Int -> Gen Aeson.Value + go 0 = oneof nonRecursive + go sz = oneof (nonRecursive ++ recursive sz) + + nonRecursive :: [Gen Aeson.Value] + nonRecursive = [ + Aeson.String . Text.Strict.pack <$> arbitrary + , Aeson.Number . fromInteger <$> arbitrary + , Aeson.Bool <$> arbitrary + , return Aeson.Null + ] + + recursive :: Int -> [Gen Aeson.Value] + recursive sz = [ + do n <- choose (0, 5) + Aeson.Array . Vector.Boxed.fromList <$> replicateM n (go (sz `div` n)) + , do n <- choose (0, 5) + Aeson.object <$> replicateM n ( + (Aeson..=) + <$> fieldName + <*> go (sz `div` n) + ) + ] + + -- We're not interested in testing crazy values + fieldName :: Gen Text.Strict.Text + fieldName = elements ["a", "b", "c"] + +-- | Rather than trying to be clever here, we just generate a handful of +-- examples in different categories. +instance Arbitrary SomeFun where + arbitrary = elements [ + -- Parametrically polymorphic function + fun (id :: Int -> Int) + , fun (const :: Int -> Bool -> Int) + -- Ad-hoc polymorphic function + , fun (negate :: Int -> Int) + , fun ((+) :: Int -> Int -> Int) + -- Partial application + , fun (const 1 :: Bool -> Int) + , fun ((+) 1 :: Int -> Int) + ] + where + fun :: (a -> b) -> SomeFun + fun = unsafeCoerce + +instance Arbitrary SomeStorableVector where + arbitrary = elements [ + some $ Vector.Storable.fromList ([1, 2, 3] :: [Int]) + , some $ Vector.Storable.fromList ("abc" :: String) + ] + where + some :: Vector.Storable.Vector a -> SomeStorableVector + some = unsafeCoerce + +instance Arbitrary SomePrimitiveVector where + arbitrary = elements [ + some $ Vector.Primitive.fromList ([1, 2, 3] :: [Int]) + , some $ Vector.Primitive.fromList ("abc" :: String) + ] + where + some :: Vector.Primitive.Vector a -> SomePrimitiveVector + some = unsafeCoerce + +{------------------------------------------------------------------------------- + For the mutable variables, we just use the one global example +-------------------------------------------------------------------------------} + +instance Arbitrary SomeSTRef where + arbitrary = return exampleSTRef + +instance Arbitrary SomeTVar where + arbitrary = return exampleTVar + +instance Arbitrary SomeMVar where + arbitrary = return exampleMVar + +instance Arbitrary SomePrimArrayM where + arbitrary = return examplePrimArrayM + +instance Arbitrary SomeStorableVectorM where + arbitrary = return exampleStorableVectorM + +instance Arbitrary SomePrimitiveVectorM where + arbitrary = return examplePrimitiveVectorM + +{------------------------------------------------------------------------------- + Orphan equality instances +-------------------------------------------------------------------------------} + +-- | Degenerate 'Eq' instance for functions that always says 'True' +-- +-- When we compare values up to the coercion returned by 'reclassify', we need +-- an 'Eq' instance. We can't compare functions in any meaningful way though, +-- and so we just return 'True' here no matter what. +-- +-- This is an orphan defined in the test suite only, so that users of the +-- library don't have acccess to this (misleading) instance. +instance Eq SomeFun where + _ == _ = True + +instance Eq SomePrimArrayM where + _ == _ = True + +instance Eq SomeStorableVector where + _ == _ = True + +instance Eq SomeStorableVectorM where + _ == _ = True + +instance Eq SomePrimitiveVector where + _ == _ = True + +instance Eq SomePrimitiveVectorM where + _ == _ = True diff --git a/tests/Test/RecoverRTTI/QuickCheck/DepGen.hs b/tests/Test/RecoverRTTI/QuickCheck/DepGen.hs new file mode 100644 --- /dev/null +++ b/tests/Test/RecoverRTTI/QuickCheck/DepGen.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + +module Test.RecoverRTTI.QuickCheck.DepGen ( + -- * Dependent generator + DepGen(..) + , depClassifier + , depGen + -- * Creation + , arbitraryDepGen + , primDepGen + -- * Bundle a dependent generator with a lifting function + , GenK(..) + , GenKU(..) + , GenUK(..) + , GenKK(..) + , GenNP(..) + , genJust + , genLeft + , genRight + , genPair + , genNP + ) where + +import Data.Kind +import Data.SOP +import Data.SOP.Dict +import Data.Void + +import Debug.RecoverRTTI + +import Test.QuickCheck + +import Test.RecoverRTTI.Prim +import Test.RecoverRTTI.QuickCheck.Sized (SizedGen) + +import qualified Test.RecoverRTTI.QuickCheck.Sized as SG + +{------------------------------------------------------------------------------- + Dependent generator +-------------------------------------------------------------------------------} + +-- | Dependent generator +data DepGen c a where + DepGen :: (Show a, Eq a) => c a -> SizedGen a -> DepGen c a + +depClassifier :: DepGen c a -> c a +depClassifier (DepGen c _) = c + +depGen :: DepGen c a -> SizedGen a +depGen (DepGen _ gen) = gen + +{------------------------------------------------------------------------------- + Construction +-------------------------------------------------------------------------------} + +arbitraryDepGen :: (Arbitrary a, Show a, Eq a) => c a -> DepGen c a +arbitraryDepGen cc = DepGen cc $ SG.arbitrary + +primDepGen :: PrimClassifier a -> DepGen (Classifier_ o) a +primDepGen C_String = DepGen (C_Prim C_String) $ SG.lift $ + arbitrary `suchThat` (not . null) -- empty string classified as @[Void]@ +primDepGen c = + case (primSatisfiesArbitrary c, canShowPrim c, canComparePrim c) of + (Dict, Dict, Dict) -> arbitraryDepGen (C_Prim c) + +{------------------------------------------------------------------------------- + Bundle a dependent generator with a lifting function + + These are designed to work with 'MaybeF' and co. +-------------------------------------------------------------------------------} + +data GenK c (f :: Type -> Type) a = GenK { + justGen :: SizedGen a -> SizedGen (f a) + , justElem :: DepGen c a + } + +data GenKU c (f :: Type -> Type -> Type) a = GenKU { + leftGen :: SizedGen a -> SizedGen (f a Void) + , leftElem :: DepGen c a + } + +data GenUK c (f :: Type -> Type -> Type) b = GenUK { + rightGen :: SizedGen b -> SizedGen (f Void b) + , rightElem :: DepGen c b + } + +data GenKK c (f :: Type -> Type -> Type) (ab :: (Type, Type)) where + GenKK :: forall c f a b. { + pairGen :: SizedGen a -> SizedGen b -> SizedGen (f a b) + , pairFst :: DepGen c a + , pairSnd :: DepGen c b + } + -> GenKK c f '(a, b) + +data GenNP c f xs = GenNP { + npGen :: NP SizedGen xs -> SizedGen (f xs) + , npElem :: NP (DepGen c) xs + } + +genJust :: + ( forall x. Show x => Show (f x) + , forall x. Eq x => Eq (f x) + ) + => (c a -> c' (f a)) -> GenK c f a -> DepGen c' (f a) +genJust cf (GenK gen (DepGen cx gx)) = + DepGen (cf cx) (gen gx) + +genLeft :: + ( forall x y. (Show x, Show y) => Show (f x y) + , forall x y. (Eq x, Eq y) => Eq (f x y) + ) + => (c a -> c' (f a Void)) -> GenKU c f a -> DepGen c' (f a Void) +genLeft cf (GenKU gen (DepGen cx gx)) = + DepGen (cf cx) (gen gx) + +genRight :: + ( forall x y. (Show x, Show y) => Show (f x y) + , forall x y. (Eq x, Eq y) => Eq (f x y) + ) + => (c b -> c' (f Void b)) -> GenUK c f b -> DepGen c' (f Void b) +genRight cf (GenUK gen (DepGen cy gy)) = + DepGen (cf cy) (gen gy) + +genPair :: + ( forall x y. (Show x, Show y) => Show (f x y) + , forall x y. (Eq x, Eq y) => Eq (f x y) + ) + => ((c a, c b) -> c' (f a b)) -> GenKK c f '(a, b) -> DepGen c' (f a b) +genPair cf (GenKK gen (DepGen cx gx) (DepGen cy gy)) = + DepGen (cf (cx, cy)) $ + gen (SG.withSize (`div` 2) gx) + (SG.withSize (`div` 2) gy) + +genNP :: forall c c' f xs. + ( SListI xs + , All Show xs => Show (f xs ) + , All Eq xs => Eq (f xs) + ) + => (NP c xs -> c' (f xs)) -> GenNP c f xs -> DepGen c' (f xs) +genNP cf (GenNP gen elems) = + case (all_NP allShow, all_NP allEq) of + (Dict, Dict) -> + DepGen + (cf (hmap depClassifier elems)) + (gen (hmap (SG.withSize divSize . depGen) elems)) + where + divSize :: Int -> Int + divSize sz = (sz - 1) `div` lengthSList (Proxy @xs) + + allShow :: NP (Dict Show) xs + allShow = hmap (\DepGen{} -> Dict) elems + + allEq :: NP (Dict Eq) xs + allEq = hmap (\DepGen{} -> Dict) elems diff --git a/tests/Test/RecoverRTTI/QuickCheck/Sized.hs b/tests/Test/RecoverRTTI/QuickCheck/Sized.hs new file mode 100644 --- /dev/null +++ b/tests/Test/RecoverRTTI/QuickCheck/Sized.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +-- | Sized generators +-- +-- Intended for qualified import +-- +-- > import Test.RecoverRTTI.QuickCheck.Sized (SizedGen) +-- > import qualified Test.RecoverRTTI.QuickCheck.Sized as SG +module Test.RecoverRTTI.QuickCheck.Sized ( + -- * Sized generators + SizedGen(..) + , run + -- * Lifting @Gen@ into @SizedGen@ + , lift + , arbitrary + -- * Combinators + , suchThat + , withSize + , leafOrStep + , oneofStepped + , replicate + , divvy + , divvyPair + -- ** Derived + , genListLike + , genMapLike + -- ** Support for tuples + , ValidTuple(..) + , genTuple + ) where + +import Prelude hiding (replicate) + +import Data.Kind +import Data.SOP +import Data.SOP.Dict + +import Debug.RecoverRTTI + +import Test.QuickCheck (Arbitrary, Gen) + +import qualified Test.QuickCheck as QC + +{------------------------------------------------------------------------------- + Sized generators +-------------------------------------------------------------------------------} + +-- | Sized generators +-- +-- We thread the size all the way through the generating, to avoid generating +-- very big trees. This is nonetheless a naive approach; we might want to look +-- at papers such as "Feat: Functional Enumeration of Algebraic Types". +newtype SizedGen a = SizedGen { unSizedGen :: Int -> Gen a } + deriving (Functor) + +instance Applicative SizedGen where + pure x = SizedGen $ \_sz -> pure x + f <*> x = SizedGen $ \ sz -> unSizedGen f sz <*> unSizedGen x sz + +run :: Int -> SizedGen a -> Gen a +run n (SizedGen gen) = gen n + +{------------------------------------------------------------------------------- + Lifting @Gen@ into @SizedGen@ +-------------------------------------------------------------------------------} + +lift :: Gen a -> SizedGen a +lift gen = SizedGen $ \_ -> gen + +arbitrary :: Arbitrary a => SizedGen a +arbitrary = lift QC.arbitrary + +{------------------------------------------------------------------------------- + Combinators +-------------------------------------------------------------------------------} + +suchThat :: SizedGen a -> (a -> Bool) -> SizedGen a +gen `suchThat` p = SizedGen $ \sz -> unSizedGen gen sz `QC.suchThat` p + +withSize :: (Int -> Int) -> SizedGen a -> SizedGen a +withSize f gen = SizedGen $ unSizedGen gen . f + +leafOrStep :: Gen a -> [SizedGen a] -> SizedGen a +leafOrStep leaf nested = SizedGen $ \sz -> + if sz > 1 + then QC.oneof (map (run (sz - 1)) nested) + else leaf + +oneofStepped :: [SizedGen a] -> SizedGen a +oneofStepped gens = SizedGen $ \sz -> QC.oneof $ map (run (sz - 1)) gens + +replicate :: (Int, Int) -> SizedGen a -> SizedGen [a] +replicate (lo, hi) gen = SizedGen $ \sz -> do + n <- QC.choose (lo, max lo (min sz hi)) + let sz' = (sz - 1) `div` n + QC.vectorOf n $ run sz' gen + +divvy :: forall xs. SListI xs => NP SizedGen xs -> SizedGen (NP I xs) +divvy = hsequence . hmap (withSize (`div` n)) + where + n = lengthSList (Proxy @xs) + +divvyPair :: SizedGen a -> SizedGen b -> SizedGen (a, b) +divvyPair ga gb = unwrapTuple . tupleFromNP <$> divvy (ga :* gb :* Nil) + +{------------------------------------------------------------------------------- + Derived combinators +-------------------------------------------------------------------------------} + +genListLike :: ([a] -> x) -> SizedGen a -> SizedGen x +genListLike f = fmap f . replicate (1, 5) + +genMapLike :: ([(a, b)] -> x) -> SizedGen a -> SizedGen b -> SizedGen x +genMapLike f genA genB = fmap f $ replicate (1, 5) $ divvyPair genA genB + +{------------------------------------------------------------------------------- + Support for tuples +-------------------------------------------------------------------------------} + +data ValidTuple f (xs :: [Type]) where + ValidTuple :: (SListI xs, IsValidSize (Length xs)) => NP f xs -> ValidTuple f x + +-- | Generate arbitrary tuple +-- +-- Precondition: the generator must be able to generate values for @size >= 1@. +genTuple :: forall f. SizedGen (Some f) -> SizedGen (Some (ValidTuple f)) +genTuple gen = SizedGen $ \sz -> do + -- Pick no less than 2, and no more than 62 + n <- QC.choose (2, max 2 (min 62 sz)) + case toValidSize n of + Nothing -> error "impossible, we pick a valid tuple size" + Just (Some validSize@(ValidSize n' _)) -> + case liftValidSize validSize of + Dict -> go (sz `div` n) n' $ return . Some . ValidTuple + where + go :: Int + -> SNat n + -> (forall xs. (SListI xs, Length xs ~ n) => NP f xs -> Gen r) + -> Gen r + go _ SZ k = k Nil + go sz' (SS s) k = go sz' s $ \xs -> do + Some x <- run sz' gen + k $ (x :* xs) diff --git a/tests/Test/RecoverRTTI/Sanity.hs b/tests/Test/RecoverRTTI/Sanity.hs --- a/tests/Test/RecoverRTTI/Sanity.hs +++ b/tests/Test/RecoverRTTI/Sanity.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE NamedFieldPuns #-} - module Test.RecoverRTTI.Sanity (tests) where import Debug.RecoverRTTI @@ -7,9 +5,11 @@ import Test.Tasty import Test.Tasty.QuickCheck -import Test.RecoverRTTI.Arbitrary import Test.RecoverRTTI.ConcreteClassifier +import Test.RecoverRTTI.QuickCheck.DepGen +import qualified Test.RecoverRTTI.QuickCheck.Sized as SG + tests :: TestTree tests = testGroup "Test.RecoverRTTI.Sanity" [ testProperty "typeSize" prop_typeSize @@ -17,8 +17,8 @@ prop_typeSize :: Property prop_typeSize = - forAll (Blind <$> arbitraryClassifiedGen 10) $ - \(Blind (Some ClassifiedGen{genClassifier})) -> - counterexample ("classifier: " ++ show genClassifier) - $ counterexample ("size: " ++ show (classifierSize genClassifier)) - $ classifierSize genClassifier <= 100 + forAll (Blind <$> SG.run 10 arbitraryConcrete) $ + \(Blind (Some (DepGen classifier _))) -> + counterexample ("classifier: " ++ show classifier) + $ counterexample ("size: " ++ show (sizeConcrete classifier)) + $ sizeConcrete classifier <= 100 diff --git a/tests/Test/RecoverRTTI/Show.hs b/tests/Test/RecoverRTTI/Show.hs --- a/tests/Test/RecoverRTTI/Show.hs +++ b/tests/Test/RecoverRTTI/Show.hs @@ -8,7 +8,6 @@ import Debug.RecoverRTTI -import Test.RecoverRTTI.Arbitrary () import Test.RecoverRTTI.ConcreteClassifier tests :: TestTree @@ -29,5 +28,5 @@ prop_anythingToString :: Some Value -> Property prop_anythingToString (Some (Value _cc x)) = counterexample ("inferred: " ++ show (classify x)) - $ within 1_000_000 + $ within 2_000_000 $ show x === anythingToString x diff --git a/tests/Test/RecoverRTTI/Staged.hs b/tests/Test/RecoverRTTI/Staged.hs --- a/tests/Test/RecoverRTTI/Staged.hs +++ b/tests/Test/RecoverRTTI/Staged.hs @@ -1,13 +1,8 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -- | Staged inference -- @@ -28,29 +23,15 @@ -- In this module we do staged inference for the user-defined types used in the -- test suite. The primary purpose of this is to provide evidence that -- 'classify' gives us enough information to do so. -module Test.RecoverRTTI.Staged ( - Reclassified(..) - , reclassify - , classifyThenReclassify - ) where +module Test.RecoverRTTI.Staged (classifyConcrete, reclassify) where import Control.Monad.Except -import Data.Bifunctor -import Data.HashMap.Lazy (HashMap) -import Data.HashSet (HashSet) -import Data.Map (Map) -import Data.Set (Set) import Data.SOP hiding (NS(..)) import Data.Void -import GHC.Real import Unsafe.Coerce (unsafeCoerce) -import qualified Data.HashMap.Internal.Array as HashMap (Array) -import qualified Data.HashMap.Internal.Array as HashMap.Array -import qualified Data.Map as Map -import qualified Data.Set as Set - import Debug.RecoverRTTI +import Debug.RecoverRTTI.Classify import Test.RecoverRTTI.ConcreteClassifier import Test.RecoverRTTI.UserDefined @@ -59,26 +40,10 @@ Reclassified values -------------------------------------------------------------------------------} --- | Reclassified values --- --- We cannot go directly from a @Classifier a@ to a @ConcreteClassifier a@: --- in the case of a user-defined type, @a@ will be of the form --- --- > UserDefined c --- --- for some @c@, but we want to return classifier for a specific type, maybe --- --- > NonRecursive Char --- --- Therefore instead we return a classifier for some other type @b@, but along --- with a proof that we can /coerce/ from @a@ to @b@. -data Reclassified a where - Reclassified :: ConcreteClassifier b -> (a -> b) -> Reclassified a - -- | Classify, then reclassify -classifyThenReclassify :: a -> Except String (Reclassified a) -classifyThenReclassify x = - case classified x of +classifyConcrete :: a -> Except String (Reclassified ConcreteClassifier a) +classifyConcrete x = + case classify x of Left closure -> throwError $ "Failed to classify closure " ++ show closure Right classifier -> @@ -87,230 +52,52 @@ -- | Reclassify values -- -- See detailed description in 'Reclassified'. -reclassify :: Classified a -> Except String (Reclassified a) -reclassify = go +reclassify :: Classifier a -> Except String (Reclassified ConcreteClassifier a) +reclassify = fmap distribReclassified . reclassify_ go where - go :: Classified a -> Except String (Reclassified a) - go (Classified c x) = case c of - -- Primitive types - - C_Bool -> return $ Reclassified CC_Bool id - C_Char -> return $ Reclassified CC_Char id - C_Double -> return $ Reclassified CC_Double id - C_Float -> return $ Reclassified CC_Float id - C_Int -> return $ Reclassified CC_Int id - C_Int8 -> return $ Reclassified CC_Int8 id - C_Int16 -> return $ Reclassified CC_Int16 id - C_Int32 -> return $ Reclassified CC_Int32 id - C_Int64 -> return $ Reclassified CC_Int64 id - C_Integer -> return $ Reclassified CC_Integer id - C_Ordering -> return $ Reclassified CC_Ordering id - C_Unit -> return $ Reclassified CC_Unit id - C_Word -> return $ Reclassified CC_Word id - C_Word8 -> return $ Reclassified CC_Word8 id - C_Word16 -> return $ Reclassified CC_Word16 id - C_Word32 -> return $ Reclassified CC_Word32 id - C_Word64 -> return $ Reclassified CC_Word64 id - - -- String types - - C_String -> return $ Reclassified CC_String id - C_BS_Strict -> return $ Reclassified CC_BS_Strict id - C_BS_Lazy -> return $ Reclassified CC_BS_Lazy id - C_BS_Short -> return $ Reclassified CC_BS_Short id - C_Text_Strict -> return $ Reclassified CC_Text_Strict id - C_Text_Lazy -> return $ Reclassified CC_Text_Lazy id - - -- Aeson - - C_Value -> return $ Reclassified CC_Value id - - -- Compound - - C_Maybe c' -> goMaybeF fmap CC_Maybe c' - C_Either c' -> goEitherF bimap CC_Either c' - C_List c' -> goMaybeF fmap CC_List c' - C_Ratio c' -> goF coerceRatio CC_Ratio c' - C_Set c' -> goMaybeF coerceSet CC_Set c' - C_Map c' -> goMaybePairF coerceMap CC_Map c' - C_IntSet -> return $ Reclassified CC_IntSet id - C_IntMap c' -> goMaybeF fmap CC_IntMap c' - C_Sequence c' -> goMaybeF fmap CC_Sequence c' - C_Tree c' -> goF fmap CC_Tree c' - C_HashSet c' -> goF coerceHashSet CC_HashSet c' - C_HashMap c' -> goMaybePairF coerceHashMap CC_HashMap c' - C_HM_Array c' -> goMaybeF coerceHMArray CC_HM_Array c' - C_Vector_Boxed c' -> goMaybeF fmap CC_Vector_Boxed c' - - C_Tuple (Classifiers cs) -> - reclassifyTuple <$> (hsequence' (hmap (Comp . reclassify) cs)) - - -- Reference cells - - C_STRef -> return $ Reclassified CC_STRef id - C_TVar -> return $ Reclassified CC_TVar id - C_MVar -> return $ Reclassified CC_MVar id - - -- Functions - - C_Fun -> return $ Reclassified CC_Fun id - - -- User-defined - - C_Custom -> do - let (constr, _args) = fromUserDefined x + go :: IsUserDefined a -> Except String (Reclassified ClassifyUser a) + go (IsUserDefined x) = firstMatch ("Unknown constructor: " ++ constr) [ - reclassifySimple CC_User_Simple constr - , reclassifyTraversable CC_User_NonRec (constr, x) - , reclassifyTraversable CC_User_Rec (constr, x) - , reclassifySimple CC_User_Unlifted constr + goSimple C_Simple constr + , goTraversable C_NonRec (constr, x) + , goTraversable C_Rec (constr, x) + , goSimple C_Unlifted constr ] - - goMaybeF :: forall f a. - (forall x x'. (x -> x') -> f x -> f x') - -> (forall x. MaybeF ConcreteClassifier x -> ConcreteClassifier (f x)) - -> MaybeF Classified a - -> Except String (Reclassified (f a)) - goMaybeF _ cc FNothing = - return $ Reclassified (cc FNothing) id - goMaybeF coerce cc (FJust x') = - aux <$> reclassify x' where - aux :: Reclassified x -> Reclassified (f x) - aux (Reclassified c_x f_x) = - Reclassified (cc (FJust c_x)) (coerce f_x) - - goEitherF :: forall f a b. - (forall x x' y y'. (x -> x') -> (y -> y') -> f x y -> f x' y') - -> (forall x y. EitherF ConcreteClassifier x y -> ConcreteClassifier (f x y)) - -> EitherF Classified a b - -> Except String (Reclassified (f a b)) - goEitherF coerce cc (FLeft x') = - aux <$> reclassify x' - where - aux :: Reclassified x -> Reclassified (f x Void) - aux (Reclassified c_x f_x) = - Reclassified (cc (FLeft c_x)) (coerce f_x id) - goEitherF coerce cc (FRight y') = - aux <$> reclassify y' - where - aux :: Reclassified y -> Reclassified (f Void y) - aux (Reclassified c_y f_y) = - Reclassified (cc (FRight c_y)) (coerce id f_y) + (constr, _args) = fromUserDefined x - goMaybePairF :: forall f a b. - (forall x x' y y'. (x -> x') -> (y -> y') -> f x y -> f x' y') - -> (forall x y. MaybePairF ConcreteClassifier x y -> ConcreteClassifier (f x y)) - -> MaybePairF Classified a b - -> Except String (Reclassified (f a b)) - goMaybePairF _ cc FNothingPair = - return $ Reclassified (cc FNothingPair) id - goMaybePairF coerce cc (FJustPair x' y') = - aux <$> reclassify x' <*> reclassify y' - where - aux :: Reclassified x -> Reclassified y -> Reclassified (f x y) - aux (Reclassified c_x f_x) (Reclassified c_y f_y) = - Reclassified (cc (FJustPair c_x c_y)) (coerce f_x f_y) + -- Reclassification of user-defined types with no arguments + goSimple :: + forall a. ConstrsOf a + => ClassifyUser a + -> String + -> Except String (Maybe (Reclassified ClassifyUser UserDefined)) + goSimple c constr = + if constr `notElem` constrsOf (Proxy @a) + then return Nothing + else return . Just $ Reclassified c FromUsr - goF :: forall f a. - (forall x x'. (x -> x') -> f x -> f x') - -> (forall x. ConcreteClassifier x -> ConcreteClassifier (f x)) - -> Classified a - -> Except String (Reclassified (f a)) - goF coerce cc x' = - aux <$> reclassify x' + goTraversable :: + forall f. (Traversable f, ConstrsOf f) + => (forall a. Elems ClassifyUser '[a] -> ClassifyUser (f a)) + -> (String, UserDefined) + -> Except String (Maybe (Reclassified ClassifyUser UserDefined)) + goTraversable cc = \(constr, x) -> + if constr `notElem` constrsOf (Proxy @f) then + return Nothing + else + case checkEmptyTraversable (coerceToF x) of + Right _ -> return . Just $ Reclassified (cc ElemU) FromUsr + Left x' -> Just . aux <$> classifyConcrete x' where - aux :: Reclassified x -> Reclassified (f x) - aux (Reclassified c_x f_x) = - Reclassified (cc c_x) (coerce f_x) - -reclassifyTuple :: - (SListI xs, IsValidSize (Length xs)) - => NP Reclassified xs -> Reclassified (WrappedTuple xs) -reclassifyTuple = \cs -> - go cs $ \cs' f -> - Reclassified (CC_Tuple (ConcreteClassifiers cs')) f - where - go :: forall xs r. - (SListI xs, IsValidSize (Length xs)) - => NP Reclassified xs - -> (forall ys. - (SListI ys, Length ys ~ Length xs) - => NP ConcreteClassifier ys - -> (WrappedTuple xs -> WrappedTuple ys) - -> r - ) - -> r - go Nil k = k Nil id - go (x :* xs) k = smallerIsValid (Proxy @(Length xs)) $ - go xs $ \np f_np -> - case x of - Reclassified y f_y -> - k (y :* np) (bimapTuple f_y f_np) - -{------------------------------------------------------------------------------- - Lift coercions to non-functor types --------------------------------------------------------------------------------} - -coerceRatio :: (x -> x') -> Ratio x -> Ratio x' -coerceRatio f (x :% y) = f x :% f y - -coerceSet :: (x -> x') -> Set x -> Set x' -coerceSet f = Set.fromDistinctAscList . map f . Set.toAscList - -coerceMap :: (x -> x') -> (y -> y') -> Map x y -> Map x' y' -coerceMap f g = Map.fromDistinctAscList . map (bimap f g) . Map.toAscList - -coerceHMArray :: (x -> x') -> HashMap.Array x -> HashMap.Array x' -coerceHMArray f arr = - let xs = HashMap.Array.toList arr - in HashMap.Array.fromList (length xs) (map f xs) - --- Unfortunately, coercion on HashSet/HashMap is not expressible using its API -coerceHashSet :: (x -> x') -> HashSet x -> HashSet x' -coerceHashSet _ = unsafeCoerce - -coerceHashMap :: (x -> x') -> (y -> y') -> HashMap x y -> HashMap x' y' -coerceHashMap _ _ = unsafeCoerce - -{------------------------------------------------------------------------------- - When we reclassify values of user-defined types with type arguments, we need - to know that if @c@ is a value of, say, @T a@, it is also a value of @T b@, - for all @b@. This is what enables staged inference: we know it's a constructor - of @T x@ for /some/ @x@, and then as a second step figure out what @x@ is. --------------------------------------------------------------------------------} - --- | Reclassification of user-defined types with no arguments -reclassifySimple :: - forall a. ConstrsOf a - => ConcreteClassifier a - -> String - -> Except String (Maybe (Reclassified UserDefined)) -reclassifySimple cc constr = - if constr `notElem` constrsOf (Proxy @a) - then return Nothing - else return . Just $ Reclassified cc unsafeCoerce - --- | Reclassification of user-defined types with a single argument -reclassifyTraversable :: - forall f. (Traversable f, ConstrsOf f) - => (forall a. MaybeF ConcreteClassifier a -> ConcreteClassifier (f a)) - -> (String, UserDefined) - -> Except String (Maybe (Reclassified UserDefined)) -reclassifyTraversable cc = \(constr, x) -> - if constr `notElem` constrsOf (Proxy @f) - then return Nothing - else case checkEmptyTraversable (coerceToF x) of - Right _ -> return . Just $ Reclassified (cc FNothing) coerceToF - Left x' -> Just . aux <$> classifyThenReclassify x' - where - coerceToF :: forall a. UserDefined -> f a - coerceToF = unsafeCoerce + coerceToF :: forall a. UserDefined -> f a + coerceToF = unsafeCoerce - aux :: Reclassified a -- Classification of the elements - -> Reclassified UserDefined -- Classification of the container - aux (Reclassified c f) = - Reclassified (cc (FJust c)) (fmap f . coerceToF) + aux :: + Reclassified ConcreteClassifier a + -> Reclassified ClassifyUser UserDefined + aux (Reclassified c pf) = + Reclassified (cc (ElemK c)) (F1 pf `Compose` FromUsr) {------------------------------------------------------------------------------- Auxiliary @@ -322,17 +109,6 @@ go :: [Except e (Maybe a)] -> Except e a go [] = throwError err go (x:xs) = x >>= maybe (go xs) return - -bimapTuple :: - ( SListI xs - , SListI ys - , IsValidSize (Length (x ': xs)) - , Length xs ~ Length ys - ) - => (x -> y) - -> (WrappedTuple xs -> WrappedTuple ys) - -> WrappedTuple (x ': xs) -> WrappedTuple (y ': ys) -bimapTuple f g (TCons x xs) = TCons (f x) (g xs) -- | Check if a traversable data structure is empty -- diff --git a/tests/Test/RecoverRTTI/UserDefined.hs b/tests/Test/RecoverRTTI/UserDefined.hs --- a/tests/Test/RecoverRTTI/UserDefined.hs +++ b/tests/Test/RecoverRTTI/UserDefined.hs @@ -35,7 +35,7 @@ deriving (Show, Eq, Generic) -- | Example of a non-recursive user-defined type -data NonRecursive a = NR1 Int | NR2 a Bool +data NonRecursive a = NR1 Int | NR2 Bool a deriving (Show, Eq, Generic, Functor, Foldable, Traversable) -- | Example of a recursive user-defined type