recover-rtti 0.3.0.0 → 0.4.0.0

raw patch · 27 files changed

+2698/−1904 lines, 27 filesdep +primitivedep ~aesondep ~unordered-containersdep ~vectorPVP ok

version bump matches the API change (PVP)

Dependencies added: primitive

Dependency ranges changed: aeson, unordered-containers, vector

API changes (from Hackage documentation)

Files

• CHANGELOG.md +12/−0
• recover-rtti.cabal +33/−18
• src/Debug/RecoverRTTI.hs +48/−11
• src/Debug/RecoverRTTI/CheckSame.hs +225/−0
• src/Debug/RecoverRTTI/Classifier.hs +179/−82
• src/Debug/RecoverRTTI/Classify.hs +216/−279
• src/Debug/RecoverRTTI/Constraint.hs +248/−0
• src/Debug/RecoverRTTI/Modules.hs +79/−29
• src/Debug/RecoverRTTI/Reclassify.hs +148/−0
• src/Debug/RecoverRTTI/Tuple.hs +30/−1
• src/Debug/RecoverRTTI/Util.hs +3/−26
• src/Debug/RecoverRTTI/Wrappers.hs +63/−0
• tests/Test/RecoverRTTI/Arbitrary.hs +0/−648
• tests/Test/RecoverRTTI/Classifier/Arbitrary.hs +259/−0
• tests/Test/RecoverRTTI/Classifier/Equality.hs +12/−0
• tests/Test/RecoverRTTI/Classifier/Size.hs +45/−0
• tests/Test/RecoverRTTI/Classify.hs +206/−134
• tests/Test/RecoverRTTI/ConcreteClassifier.hs +169/−376
• tests/Test/RecoverRTTI/Globals.hs +62/−0
• tests/Test/RecoverRTTI/Orphans.hs +0/−22
• tests/Test/RecoverRTTI/Prim.hs +292/−0
• tests/Test/RecoverRTTI/QuickCheck/DepGen.hs +163/−0
• tests/Test/RecoverRTTI/QuickCheck/Sized.hs +153/−0
• tests/Test/RecoverRTTI/Sanity.hs +8/−8
• tests/Test/RecoverRTTI/Show.hs +1/−2
• tests/Test/RecoverRTTI/Staged.hs +43/−267
• tests/Test/RecoverRTTI/UserDefined.hs +1/−1

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 =

@@ -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

@@ -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+    -- <https://github.com/haskell/cabal/blob/3f397c0c661facd0be9c5c67ad26f66a87725472/cabal-install/src/Distribution/Client/PackageHash.hs#L125-L157>+    stripVowels :: String -> String+    stripVowels = filter (`notElem` "aeoiu")

@@ -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

@@ -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

@@ -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

@@ -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 _ = "<Fun>"++instance Show SomePrimArrayM where+  show _ = "<Data.Primitive.Array.MutableArray>"++instance Show SomeStorableVector where+  show _ = "<Data.Vector.Storable.Vector>"++instance Show SomeStorableVectorM where+  show _ = "<Data.Vector.Storable.MVector>"++instance Show SomePrimitiveVector where+  show _ = "<Data.Vector.Primitive.Vector>"++instance Show SomePrimitiveVectorM where+  show _ = "<Data.Vector.Primitive.MVector>"

@@ -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 ())

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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")

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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

@@ -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 --

@@ -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