{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE PatternSynonyms       #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE StandaloneDeriving    #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}
{-# LANGUAGE ViewPatterns          #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

module Debug.RecoverRTTI.Classify (
    -- * Classification
    classify
    -- * 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
import Control.Monad.Except
import Data.HashMap.Lazy (HashMap)
import Data.IntMap (IntMap)
import Data.Map (Map)
import Data.Sequence (Seq)
import Data.Set (Set)
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)

#if MIN_VERSION_mtl(2,3,0)
import Control.Monad.Trans
#endif

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.Map                    as Map
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
import Debug.RecoverRTTI.Tuple
import Debug.RecoverRTTI.Util
import Debug.RecoverRTTI.Wrappers

{-------------------------------------------------------------------------------
  Classification
-------------------------------------------------------------------------------}

classifyIO :: a -> ExceptT Closure IO (Classifier a)
classifyIO :: forall a. a -> ExceptT Closure IO (Classifier a)
classifyIO a
x = do
    FlatClosure
closure <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Box -> IO FlatClosure
getBoxedClosureData (forall a. a -> Box
asBox a
x)
    case FlatClosure
closure of
      --
      -- Primitive (ghc-prim)
      --

      -- GHC.Types
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgGhcPrim
GhcTypes -> Just String
"True")  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier Bool
C_Bool
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgGhcPrim
GhcTypes -> Just String
"False") -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier Bool
C_Bool
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgGhcPrim
GhcTypes -> Just String
"C#")    -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier Char
C_Char
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgGhcPrim
GhcTypes -> Just String
"D#")    -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier Double
C_Double
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgGhcPrim
GhcTypes -> Just String
"F#")    -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier Float
C_Float
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgGhcPrim
GhcTypes -> Just String
"I#")    -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier Int
C_Int
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgGhcPrim
GhcTypes -> Just String
"LT")    -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier Ordering
C_Ordering
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgGhcPrim
GhcTypes -> Just String
"GT")    -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier Ordering
C_Ordering
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgGhcPrim
GhcTypes -> Just String
"EQ")    -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier Ordering
C_Ordering
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgGhcPrim
GhcTypes -> Just String
"W#")    -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier Word
C_Word

      -- GHC.Tuple
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgGhcPrim
GhcTuple -> Just String
"()") -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier ()
C_Unit

      -- GHC.Int
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgBase
GhcInt -> Just String
"I8#")  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier Int8
C_Int8
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgBase
GhcInt -> Just String
"I16#") -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier Int16
C_Int16
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgBase
GhcInt -> Just String
"I32#") -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier Int32
C_Int32
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgBase
GhcInt -> Just String
"I64#") -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier Int64
C_Int64

      -- GHC.Integer
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgIntegerWiredIn
GhcIntegerType -> Just String
"S#")  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier Integer
C_Integer
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgIntegerWiredIn
GhcIntegerType -> Just String
"Jp#") -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier Integer
C_Integer
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgIntegerWiredIn
GhcIntegerType -> Just String
"Jn#") -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier Integer
C_Integer
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgGhcBignum
GhcNumInteger  -> Just String
"IS")  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier Integer
C_Integer
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgGhcBignum
GhcNumInteger  -> Just String
"IP")  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier Integer
C_Integer
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgGhcBignum
GhcNumInteger  -> Just String
"IN")  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier Integer
C_Integer

      -- GHC.Word
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgBase
GhcWord -> Just String
"W8#")  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier Word8
C_Word8
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgBase
GhcWord -> Just String
"W16#") -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier Word16
C_Word16
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgBase
GhcWord -> Just String
"W32#") -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier Word32
C_Word32
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgBase
GhcWord -> Just String
"W64#") -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier Word64
C_Word64

      --
      -- String types
      --

      -- bytestring
      --
      -- bytestring changed from PS to BS in version 0.11
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgByteString
DataByteStringInternal      -> Just String
"PS")    -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier ByteString
C_BS_Strict
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgByteString
DataByteStringInternal      -> Just String
"BS")    -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier ByteString
C_BS_Strict
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgByteString
DataByteStringLazyInternal  -> Just String
"Empty") -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier ByteString
C_BS_Lazy
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgByteString
DataByteStringLazyInternal  -> Just String
"Chunk") -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier ByteString
C_BS_Lazy
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgByteString
DataByteStringShortInternal -> Just String
"SBS")   -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier ShortByteString
C_BS_Short

      -- text
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgText
DataTextInternal     -> Just String
"Text")  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier Text
C_Text_Strict
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgText
DataTextInternalLazy -> Just String
"Chunk") -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier Text
C_Text_Lazy
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgText
DataTextInternalLazy -> Just String
"Empty") -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier Text
C_Text_Lazy

      --
      -- Aeson
      --

      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgAeson
DataAesonTypesInternal -> Just String
"Object") -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier Value
C_Value
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgAeson
DataAesonTypesInternal -> Just String
"Array")  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier Value
C_Value
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgAeson
DataAesonTypesInternal -> Just String
"String") -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier Value
C_Value
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgAeson
DataAesonTypesInternal -> Just String
"Number") -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier Value
C_Value
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgAeson
DataAesonTypesInternal -> Just String
"Bool")   -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier Value
C_Value
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgAeson
DataAesonTypesInternal -> Just String
"Null")   -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier Value
C_Value

      --
      -- Compound (ghc-prim)
      --

      -- Maybe
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgBase
GhcMaybe -> Just String
"Nothing") ->
        forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Maybe a -> ExceptT Closure IO (Classifier (Maybe a))
classifyMaybe (forall a b. a -> b
unsafeCoerce a
x)
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgBase
GhcMaybe -> Just String
"Just") ->
        forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Maybe a -> ExceptT Closure IO (Classifier (Maybe a))
classifyMaybe (forall a b. a -> b
unsafeCoerce a
x)

      -- Either
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgBase
DataEither -> Just String
"Left") ->
        forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b.
Either a b -> ExceptT Closure IO (Classifier (Either a b))
classifyEither (forall a b. a -> b
unsafeCoerce a
x)
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgBase
DataEither -> Just String
"Right") ->
        forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b.
Either a b -> ExceptT Closure IO (Classifier (Either a b))
classifyEither (forall a b. a -> b
unsafeCoerce a
x)

      -- Lists (this includes the 'String' case)
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgGhcPrim
GhcTypes -> Just String
"[]") ->
        forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> ExceptT Closure IO (Classifier [a])
classifyList (forall a b. a -> b
unsafeCoerce a
x)
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgGhcPrim
GhcTypes -> Just String
":") ->
        forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> ExceptT Closure IO (Classifier [a])
classifyList (forall a b. a -> b
unsafeCoerce a
x)

      -- Ratio
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgBase
GhcReal -> Just String
":%") ->
        forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Ratio a -> ExceptT Closure IO (Classifier (Ratio a))
classifyRatio (forall a b. a -> b
unsafeCoerce a
x)

      -- Set
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgContainers
DataSetInternal -> Just String
"Tip") ->
        forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Set a -> ExceptT Closure IO (Classifier (Set a))
classifySet (forall a b. a -> b
unsafeCoerce a
x)
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgContainers
DataSetInternal -> Just String
"Bin") ->
        forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Set a -> ExceptT Closure IO (Classifier (Set a))
classifySet (forall a b. a -> b
unsafeCoerce a
x)

      -- Map
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgContainers
DataMapInternal -> Just String
"Tip") ->
        forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. Map a b -> ExceptT Closure IO (Classifier (Map a b))
classifyMap (forall a b. a -> b
unsafeCoerce a
x)
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgContainers
DataMapInternal -> Just String
"Bin") ->
        forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. Map a b -> ExceptT Closure IO (Classifier (Map a b))
classifyMap (forall a b. a -> b
unsafeCoerce a
x)

      -- IntSet
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgContainers
DataIntSetInternal -> Just String
"Bin") ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier IntSet
C_IntSet
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgContainers
DataIntSetInternal -> Just String
"Tip") ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier IntSet
C_IntSet
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgContainers
DataIntSetInternal -> Just String
"Nil") ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier IntSet
C_IntSet

      -- IntMap
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgContainers
DataIntMapInternal -> Just String
"Nil") ->
        forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IntMap a -> ExceptT Closure IO (Classifier (IntMap a))
classifyIntMap (forall a b. a -> b
unsafeCoerce a
x)
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgContainers
DataIntMapInternal -> Just String
"Tip") ->
        forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IntMap a -> ExceptT Closure IO (Classifier (IntMap a))
classifyIntMap (forall a b. a -> b
unsafeCoerce a
x)
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgContainers
DataIntMapInternal -> Just String
"Bin") ->
        forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IntMap a -> ExceptT Closure IO (Classifier (IntMap a))
classifyIntMap (forall a b. a -> b
unsafeCoerce a
x)

      -- Sequence
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgContainers
DataSequenceInternal -> Just String
"EmptyT") ->
        forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Seq a -> ExceptT Closure IO (Classifier (Seq a))
classifySequence (forall a b. a -> b
unsafeCoerce a
x)
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgContainers
DataSequenceInternal -> Just String
"Single") ->
        forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Seq a -> ExceptT Closure IO (Classifier (Seq a))
classifySequence (forall a b. a -> b
unsafeCoerce a
x)
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgContainers
DataSequenceInternal -> Just String
"Deep") ->
        forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Seq a -> ExceptT Closure IO (Classifier (Seq a))
classifySequence (forall a b. a -> b
unsafeCoerce a
x)

      -- Tree
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgContainers
DataTree -> Just String
"Node") ->
        forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Tree a -> ExceptT Closure IO (Classifier (Tree a))
classifyTree (forall a b. a -> b
unsafeCoerce a
x)

      -- Tuples (of size 2..62)
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe (String, [Box])
inKnownModuleNested KnownModule 'PkgGhcPrim
GhcTuple -> Just (
            String -> Maybe (Some ValidSize)
isTuple       -> Just (Some validSize :: ValidSize a
validSize@(ValidSize SNat a
sz forall r. TooBig a -> r
_))
          , forall (n :: Nat) a. SNat n -> [a] -> Maybe (VerifiedSize n a)
verifySize SNat a
sz -> Just (VerifiedSize NP (K Box) xs
ptrs)
          )) ->
        case forall (n :: Nat). ValidSize n -> Dict IsValidSize n
liftValidSize ValidSize a
validSize of
          Dict IsValidSize a
Dict -> forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (xs :: [*]).
(SListI xs, IsValidSize (Length xs)) =>
NP (K Box) xs -> ExceptT Closure IO (Classifier (WrappedTuple xs))
classifyTuple NP (K Box) xs
ptrs

      -- HashMap
      --
      -- This could also be a HashSet, which is a newtype around a HashMap;
      -- we distinguish in 'classifyHashMap'.
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgUnorderedContainers
DataHashMapInternal -> Just String
"Empty") ->
        forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b.
HashMap a b -> ExceptT Closure IO (Classifier (HashMap a b))
classifyHashMap (forall a b. a -> b
unsafeCoerce a
x)
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgUnorderedContainers
DataHashMapInternal -> Just String
"BitmapIndexed") ->
        forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b.
HashMap a b -> ExceptT Closure IO (Classifier (HashMap a b))
classifyHashMap (forall a b. a -> b
unsafeCoerce a
x)
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgUnorderedContainers
DataHashMapInternal -> Just String
"Leaf") ->
        forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b.
HashMap a b -> ExceptT Closure IO (Classifier (HashMap a b))
classifyHashMap (forall a b. a -> b
unsafeCoerce a
x)
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgUnorderedContainers
DataHashMapInternal -> Just String
"Full") ->
        forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b.
HashMap a b -> ExceptT Closure IO (Classifier (HashMap a b))
classifyHashMap (forall a b. a -> b
unsafeCoerce a
x)
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgUnorderedContainers
DataHashMapInternal -> Just String
"Collision") ->
        forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b.
HashMap a b -> ExceptT Closure IO (Classifier (HashMap a b))
classifyHashMap (forall a b. a -> b
unsafeCoerce a
x)

      -- HashMap's internal Array type
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgUnorderedContainers
DataHashMapInternalArray -> Just String
"Array") ->
        forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Array a -> ExceptT Closure IO (Classifier (Array a))
classifyHMArray (forall a b. a -> b
unsafeCoerce a
x)

      -- Arrays from @primitive@
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgPrimitive
DataPrimitiveArray -> Just String
"Array") ->
        forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Array a -> ExceptT Closure IO (Classifier (Array a))
classifyPrimArray (forall a b. a -> b
unsafeCoerce a
x)
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgPrimitive
DataPrimitiveArray -> Just String
"MutableArray") ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier SomePrimArrayM
C_Prim_ArrayM

      -- Boxed vectors
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgVector
DataVector -> Just String
"Vector") ->
        forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Vector a -> ExceptT Closure IO (Classifier (Vector a))
classifyVectorBoxed (forall a b. a -> b
unsafeCoerce a
x)

      -- Storable vectors
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgVector
DataVectorStorable -> Just String
"Vector") ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier SomeStorableVector
C_Vector_Storable
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgVector
DataVectorStorableMutable -> Just String
"MVector") ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier SomeStorableVectorM
C_Vector_StorableM

      -- Primitive vectors
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgVector
DataVectorPrimitive -> Just String
"Vector") ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier SomePrimitiveVector
C_Vector_Primitive
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgVector
DataVectorPrimitiveMutable -> Just String
"MVector") ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier SomePrimitiveVectorM
C_Vector_PrimitiveM

      --
      -- Reference cells
      --

      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgBase
GhcSTRef    -> Just String
"STRef") -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier SomeSTRef
C_STRef
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgBase
GhcMVar     -> Just String
"MVar")  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier SomeMVar
C_MVar
      (forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule 'PkgBase
GhcConcSync -> Just String
"TVar")  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier SomeTVar
C_TVar

      --
      -- Functions
      --

      FunClosure {} -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier SomeFun
C_Fun

      --
      -- User defined
      --

      ConstrClosure {} ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) a. o a -> Classifier_ o a
C_Other (UserDefined -> IsUserDefined UserDefined
IsUserDefined (forall a b. a -> b
unsafeCoerce a
x))

      --
      -- Classification failed
      --

      OtherClosure Closure
other -> forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left Closure
other)

mustBe :: Classifier_ o b -> Classifier_ o a
mustBe :: forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe = forall a b. a -> b
unsafeCoerce

-- | Classify a value
--
-- Given a value of some unknown type @a@ and a classifier @Classifier a@,
-- it should be sound to coerce the value to the type indicated by the
-- classifier.
--
-- This is also the reason not all values can be classified; in particular,
-- we cannot classify values of unlifted types, as for these types coercion
-- does not work (this would result in a ghc runtime crash).
classify :: a -> Either Closure (Classifier a)
classify :: forall a. a -> Either Closure (Classifier a)
classify = forall a. IO a -> a
unsafePerformIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> ExceptT Closure IO (Classifier a)
classifyIO

{-------------------------------------------------------------------------------
  Classification for compound types
-------------------------------------------------------------------------------}

classifyMaybe :: Maybe a -> ExceptT Closure IO (Classifier (Maybe a))
classifyMaybe :: forall a. Maybe a -> ExceptT Closure IO (Classifier (Maybe a))
classifyMaybe = forall (f :: * -> *) a.
Foldable f =>
(forall (o :: * -> *) x. Elems o '[x] -> Classifier_ o (f x))
-> f a -> ExceptT Closure IO (Classifier (f a))
classifyFoldable forall (o :: * -> *) a. Elems o '[a] -> Classifier_ o (Maybe a)
C_Maybe

classifyEither ::
     Either a b
  -> ExceptT Closure IO (Classifier (Either a b))
classifyEither :: forall a b.
Either a b -> ExceptT Closure IO (Classifier (Either a b))
classifyEither Either a b
x =
    case Either a b
x of
      Left  a
x' -> (forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (o :: * -> *) a b.
Elems o '[a, b] -> Classifier_ o (Either a b)
C_Either forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (o :: * -> *) a. Classifier_ o a -> Elems o '[a, Void]
ElemKU)  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> ExceptT Closure IO (Classifier a)
classifyIO a
x'
      Right b
y' -> (forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (o :: * -> *) a b.
Elems o '[a, b] -> Classifier_ o (Either a b)
C_Either forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (o :: * -> *) b. Classifier_ o b -> Elems o '[Void, b]
ElemUK) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> ExceptT Closure IO (Classifier a)
classifyIO b
y'

classifyList :: [a] -> ExceptT Closure IO (Classifier [a])
classifyList :: forall a. [a] -> ExceptT Closure IO (Classifier [a])
classifyList = forall (f :: * -> *) a.
Foldable f =>
(forall (o :: * -> *) x. Elems o '[x] -> Classifier_ o (f x))
-> f a -> ExceptT Closure IO (Classifier (f a))
classifyFoldable forall (o :: * -> *) x. Elems o '[x] -> Classifier_ o [x]
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 :: forall (o :: * -> *) x. Elems o '[x] -> Classifier_ o [x]
c_list (ElemK (C_Prim PrimClassifier x
C_Char)) = forall a (o :: * -> *). PrimClassifier a -> Classifier_ o a
C_Prim PrimClassifier String
C_String
    c_list Elems o '[x]
c = forall (o :: * -> *) x. Elems o '[x] -> Classifier_ o [x]
C_List Elems o '[x]
c

classifyRatio :: Ratio a -> ExceptT Closure IO (Classifier (Ratio a))
classifyRatio :: forall a. Ratio a -> ExceptT Closure IO (Classifier (Ratio a))
classifyRatio (a
x' :% a
_) = forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (o :: * -> *) a. Elems o '[a] -> Classifier_ o (Ratio a)
C_Ratio forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (o :: * -> *) a. Classifier_ o a -> Elems o '[a]
ElemK forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> ExceptT Closure IO (Classifier a)
classifyIO a
x'

classifySet :: Set a -> ExceptT Closure IO (Classifier (Set a))
classifySet :: forall a. Set a -> ExceptT Closure IO (Classifier (Set a))
classifySet = forall (f :: * -> *) a.
Foldable f =>
(forall (o :: * -> *) x. Elems o '[x] -> Classifier_ o (f x))
-> f a -> ExceptT Closure IO (Classifier (f a))
classifyFoldable forall (o :: * -> *) a. Elems o '[a] -> Classifier_ o (Set a)
C_Set

classifyMap :: Map a b -> ExceptT Closure IO (Classifier (Map a b))
classifyMap :: forall a b. Map a b -> ExceptT Closure IO (Classifier (Map a b))
classifyMap = forall (f :: * -> * -> *) a b.
(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 forall (o :: * -> *) a b.
Elems o '[a, b] -> Classifier_ o (Map a b)
C_Map forall k a. Map k a -> [(k, a)]
Map.toList

classifyIntMap :: IntMap a -> ExceptT Closure IO (Classifier (IntMap a))
classifyIntMap :: forall a. IntMap a -> ExceptT Closure IO (Classifier (IntMap a))
classifyIntMap = forall (f :: * -> *) a.
Foldable f =>
(forall (o :: * -> *) x. Elems o '[x] -> Classifier_ o (f x))
-> f a -> ExceptT Closure IO (Classifier (f a))
classifyFoldable forall (o :: * -> *) a. Elems o '[a] -> Classifier_ o (IntMap a)
C_IntMap

classifySequence :: Seq a -> ExceptT Closure IO (Classifier (Seq a))
classifySequence :: forall a. Seq a -> ExceptT Closure IO (Classifier (Seq a))
classifySequence = forall (f :: * -> *) a.
Foldable f =>
(forall (o :: * -> *) x. Elems o '[x] -> Classifier_ o (f x))
-> f a -> ExceptT Closure IO (Classifier (f a))
classifyFoldable forall (o :: * -> *) a. Elems o '[a] -> Classifier_ o (Seq a)
C_Sequence

classifyTree :: Tree a -> ExceptT Closure IO (Classifier (Tree a))
classifyTree :: forall a. Tree a -> ExceptT Closure IO (Classifier (Tree a))
classifyTree (Tree.Node a
x' [Tree a]
_) = forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (o :: * -> *) a. Elems o '[a] -> Classifier_ o (Tree a)
C_Tree forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (o :: * -> *) a. Classifier_ o a -> Elems o '[a]
ElemK forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> ExceptT Closure IO (Classifier a)
classifyIO a
x'

classifyHashMap :: HashMap a b -> ExceptT Closure IO (Classifier (HashMap a b))
classifyHashMap :: forall a b.
HashMap a b -> ExceptT Closure IO (Classifier (HashMap a b))
classifyHashMap = forall (f :: * -> * -> *) a b.
(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 forall (o :: * -> *) x y.
Elems o '[x, y] -> Classifier_ o (HashMap x y)
c_hashmap forall k v. HashMap k v -> [(k, v)]
HashMap.toList
  where
    -- HashSet is a newtype around HashMap
    c_hashmap :: Elems o '[x, y] -> Classifier_ o (HashMap x y)
    c_hashmap :: forall (o :: * -> *) x y.
Elems o '[x, y] -> Classifier_ o (HashMap x y)
c_hashmap (ElemKK Classifier_ o x
c (C_Prim PrimClassifier y
C_Unit)) = forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) a. Elems o '[a] -> Classifier_ o (HashSet a)
C_HashSet (forall (o :: * -> *) a. Classifier_ o a -> Elems o '[a]
ElemK Classifier_ o x
c)
    c_hashmap Elems o '[x, y]
c = forall (o :: * -> *) x y.
Elems o '[x, y] -> Classifier_ o (HashMap x y)
C_HashMap Elems o '[x, y]
c

classifyHMArray ::
     HashMap.Array a
  -> ExceptT Closure IO (Classifier (HashMap.Array a))
classifyHMArray :: forall a. Array a -> ExceptT Closure IO (Classifier (Array a))
classifyHMArray =
    forall (f :: * -> *) a.
(forall (o :: * -> *) x. Elems o '[x] -> Classifier_ o (f x))
-> (f a -> Int)
-> (f a -> a)
-> f a
-> ExceptT Closure IO (Classifier (f a))
classifyArrayLike
      forall (o :: * -> *) a. Elems o '[a] -> Classifier_ o (Array a)
C_HM_Array
      forall a. Array a -> Int
HashMap.Array.length
      (forall a. Array a -> Int -> a
`HashMap.Array.index` Int
0)

classifyPrimArray ::
     Prim.Array a
  -> ExceptT Closure IO (Classifier (Prim.Array a))
classifyPrimArray :: forall a. Array a -> ExceptT Closure IO (Classifier (Array a))
classifyPrimArray =
    forall (f :: * -> *) a.
(forall (o :: * -> *) x. Elems o '[x] -> Classifier_ o (f x))
-> (f a -> Int)
-> (f a -> a)
-> f a
-> ExceptT Closure IO (Classifier (f a))
classifyArrayLike
      forall (o :: * -> *) a. Elems o '[a] -> Classifier_ o (Array a)
C_Prim_Array
      forall a. Array a -> Int
Prim.Array.sizeofArray
      (forall a. Array a -> Int -> a
`Prim.Array.indexArray` Int
0)

classifyVectorBoxed ::
     Vector.Boxed.Vector a
  -> ExceptT Closure IO (Classifier (Vector.Boxed.Vector a))
classifyVectorBoxed :: forall a. Vector a -> ExceptT Closure IO (Classifier (Vector a))
classifyVectorBoxed =
    forall (f :: * -> *) a.
(forall (o :: * -> *) x. Elems o '[x] -> Classifier_ o (f x))
-> (f a -> Int)
-> (f a -> a)
-> f a
-> ExceptT Closure IO (Classifier (f a))
classifyArrayLike
      forall (o :: * -> *) a. Elems o '[a] -> Classifier_ o (Vector a)
C_Vector_Boxed
      forall a. Vector a -> Int
Vector.Boxed.length
      forall a. Vector a -> a
Vector.Boxed.head

classifyTuple ::
     (SListI xs, IsValidSize (Length xs))
  => NP (K Box) xs
  -> ExceptT Closure IO (Classifier (WrappedTuple xs))
classifyTuple :: forall (xs :: [*]).
(SListI xs, IsValidSize (Length xs)) =>
NP (K Box) xs -> ExceptT Closure IO (Classifier (WrappedTuple xs))
classifyTuple NP (K Box) xs
ptrs = do
    NP Classifier xs
cs <- forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: * -> *)
       (g :: k -> *).
(HSequence h, SListIN h xs, Applicative f) =>
h (f :.: g) xs -> f (h g xs)
hsequence' (forall {k} {l} (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
       (f' :: k -> *).
(SListIN (Prod h) xs, HAp h) =>
(forall (a :: k). f a -> f' a) -> h f xs -> h f' xs
hmap forall a. K Box a -> (:.:) (ExceptT Closure IO) Classifier a
aux NP (K Box) xs
ptrs)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (a :: [*]) (o :: * -> *).
(SListI a, IsValidSize (Length a)) =>
Elems o a -> Classifier_ o (WrappedTuple a)
C_Tuple (forall (o :: * -> *) (xs :: [*]). NP (Elem o) xs -> Elems o xs
Elems (forall {k} {l} (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
       (f' :: k -> *).
(SListIN (Prod h) xs, HAp h) =>
(forall (a :: k). f a -> f' a) -> h f xs -> h f' xs
hmap forall (o :: * -> *) a. Classifier_ o a -> Elem o a
Elem NP Classifier xs
cs))
  where
    aux :: K Box a -> (ExceptT Closure IO :.: Classifier) a
    aux :: forall a. K Box a -> (:.:) (ExceptT Closure IO) Classifier a
aux (K (Box Any
x)) = forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
Comp forall a b. (a -> b) -> a -> b
$ forall a. a -> ExceptT Closure IO (Classifier a)
classifyIO (forall a b. a -> b
unsafeCoerce Any
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 :: forall (f :: * -> *) a.
Foldable f =>
(forall (o :: * -> *) x. Elems o '[x] -> Classifier_ o (f x))
-> f a -> ExceptT Closure IO (Classifier (f a))
classifyFoldable forall (o :: * -> *) x. Elems o '[x] -> Classifier_ o (f x)
cc f a
x =
    case forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList f a
x of
      []   -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) x. Elems o '[x] -> Classifier_ o (f x)
cc forall (o :: * -> *). Elems o '[Void]
ElemU
      a
x':[a]
_ -> forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (o :: * -> *) x. Elems o '[x] -> Classifier_ o (f x)
cc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (o :: * -> *) a. Classifier_ o a -> Elems o '[a]
ElemK forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> ExceptT Closure IO (Classifier a)
classifyIO a
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 :: forall (f :: * -> * -> *) a b.
(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 forall (o :: * -> *) x y. Elems o '[x, y] -> Classifier_ o (f x y)
cc f a b -> [(a, b)]
toList f a b
x =
    case f a b -> [(a, b)]
toList f a b
x of
      []         -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) x y. Elems o '[x, y] -> Classifier_ o (f x y)
cc forall (o :: * -> *). Elems o '[Void, Void]
ElemUU
      (a
x', b
y'):[(a, b)]
_ -> (\Classifier_ IsUserDefined a
ca Classifier_ IsUserDefined b
cb -> forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) x y. Elems o '[x, y] -> Classifier_ o (f x y)
cc (forall (o :: * -> *) a b.
Classifier_ o a -> Classifier_ o b -> Elems o '[a, b]
ElemKK Classifier_ IsUserDefined a
ca Classifier_ IsUserDefined b
cb))
                       forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> ExceptT Closure IO (Classifier a)
classifyIO a
x'
                       forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> ExceptT Closure IO (Classifier a)
classifyIO b
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 :: forall (f :: * -> *) a.
(forall (o :: * -> *) x. Elems o '[x] -> Classifier_ o (f x))
-> (f a -> Int)
-> (f a -> a)
-> f a
-> ExceptT Closure IO (Classifier (f a))
classifyArrayLike forall (o :: * -> *) x. Elems o '[x] -> Classifier_ o (f x)
cc f a -> Int
getLen f a -> a
getFirst f a
x =
    if f a -> Int
getLen f a
x forall a. Eq a => a -> a -> Bool
== Int
0
      then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) x. Elems o '[x] -> Classifier_ o (f x)
cc forall (o :: * -> *). Elems o '[Void]
ElemU
      else do
        let x' :: a
x' = f a -> a
getFirst f a
x
        forall (o :: * -> *) b a. Classifier_ o b -> Classifier_ o a
mustBe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (o :: * -> *) x. Elems o '[x] -> Classifier_ o (f x)
cc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (o :: * -> *) a. Classifier_ o a -> Elems o '[a]
ElemK forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> ExceptT Closure IO (Classifier a)
classifyIO a
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 $bElemK :: forall (o :: * -> *) a. Classifier_ o a -> Elems o '[a]
$mElemK :: forall {r} {o :: * -> *} {a}.
Elems o '[a] -> (Classifier_ o a -> r) -> ((# #) -> r) -> r
ElemK c = Elems (Elem c :* Nil)

pattern ElemU :: Elems o '[Void]
pattern $bElemU :: forall (o :: * -> *). Elems o '[Void]
$mElemU :: forall {r} {o :: * -> *}.
Elems o '[Void] -> ((# #) -> r) -> ((# #) -> r) -> r
ElemU = Elems (NoElem :* Nil)

pattern ElemKK :: Classifier_ o a -> Classifier_ o b -> Elems o '[a, b]
pattern $bElemKK :: forall (o :: * -> *) a b.
Classifier_ o a -> Classifier_ o b -> Elems o '[a, b]
$mElemKK :: forall {r} {o :: * -> *} {a} {b}.
Elems o '[a, b]
-> (Classifier_ o a -> Classifier_ o b -> r) -> ((# #) -> r) -> r
ElemKK ca cb = Elems (Elem ca :* Elem cb :* Nil)

pattern ElemUU :: Elems o '[Void, Void]
pattern $bElemUU :: forall (o :: * -> *). Elems o '[Void, Void]
$mElemUU :: forall {r} {o :: * -> *}.
Elems o '[Void, Void] -> ((# #) -> r) -> ((# #) -> r) -> r
ElemUU = Elems (NoElem :* NoElem :* Nil)

pattern ElemKU :: Classifier_ o a -> Elems o '[a, Void]
pattern $bElemKU :: forall (o :: * -> *) a. Classifier_ o a -> Elems o '[a, Void]
$mElemKU :: forall {r} {o :: * -> *} {a}.
Elems o '[a, Void] -> (Classifier_ o a -> r) -> ((# #) -> r) -> r
ElemKU c = Elems (Elem c :* NoElem :* Nil)

pattern ElemUK :: Classifier_ o b -> Elems o '[Void, b]
pattern $bElemUK :: forall (o :: * -> *) b. Classifier_ o b -> Elems o '[Void, b]
$mElemUK :: forall {r} {o :: * -> *} {b}.
Elems o '[Void, b] -> (Classifier_ o b -> r) -> ((# #) -> r) -> r
ElemUK c = Elems (NoElem :* Elem c :* Nil)

{-------------------------------------------------------------------------------
  Recognizing tuples
-------------------------------------------------------------------------------}

isTuple :: String -> Maybe (Some ValidSize)
isTuple :: String -> Maybe (Some ValidSize)
isTuple String
typ = do
    (Char
a, String
xs, Char
z) <- forall a. [a] -> Maybe (a, [a], a)
dropEnds String
typ
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Char
a forall a. Eq a => a -> a -> Bool
== Char
'(' Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
== Char
',') String
xs Bool -> Bool -> Bool
&& Char
z forall a. Eq a => a -> a -> Bool
== Char
')'
    Int -> Maybe (Some ValidSize)
toValidSize (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
xs forall a. Num a => a -> a -> a
+ Int
1)

{-------------------------------------------------------------------------------
  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.
fromUserDefined :: UserDefined -> (String, [Some Classified])
fromUserDefined :: UserDefined -> (String, [Some Classified])
fromUserDefined = \(UserDefined Any
x) -> forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall x. x -> IO (String, [Some Classified])
go Any
x
  where
    go :: x -> IO (String, [Some Classified])
    go :: forall x. x -> IO (String, [Some Classified])
go x
x = do
        FlatClosure
closure <- Box -> IO FlatClosure
getBoxedClosureData (forall a. a -> Box
asBox x
x)
        case FlatClosure
closure of
          ConstrClosure {String
name :: FlatClosure -> String
name :: String
name, [Box]
ptrArgs :: FlatClosure -> [Box]
ptrArgs :: [Box]
ptrArgs} ->
            (String
name,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Some Classified] -> [Box] -> IO [Some Classified]
goArgs [] [Box]
ptrArgs
          FlatClosure
_otherwise ->
            forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"elimUserDefined: unexpected closure: "
                 forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show FlatClosure
closure

    goArgs :: [Some Classified] -> [Box] -> IO [Some Classified]
    goArgs :: [Some Classified] -> [Box] -> IO [Some Classified]
goArgs [Some Classified]
acc []         = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> [a]
reverse [Some Classified]
acc)
    goArgs [Some Classified]
acc (Box Any
b:[Box]
bs) = do
        Either Closure (Classifier Any)
mc <- forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ forall a. a -> ExceptT Closure IO (Classifier a)
classifyIO Any
b
        case Either Closure (Classifier Any)
mc of
          Right Classifier Any
c -> [Some Classified] -> [Box] -> IO [Some Classified]
goArgs (forall {k} (f :: k -> *) (a :: k). f a -> Some f
Some (forall a. Classifier a -> a -> Classified a
Classified Classifier Any
c (forall a b. a -> b
unsafeCoerce Any
b)) forall a. a -> [a] -> [a]
: [Some Classified]
acc) [Box]
bs
          Left  Closure
_ -> [Some Classified] -> [Box] -> IO [Some Classified]
goArgs                                         [Some Classified]
acc  [Box]
bs

{-------------------------------------------------------------------------------
  Show

  Showing values is mutually recursive with classification: when we show a
  value classified as @UserDefined@, we recursively classify the nested values
  /when/ we show the value.
-------------------------------------------------------------------------------}

-- | Show any value
--
-- This shows any value, as long as it's not unlifted. The result should be
-- equal to show instances, with the following caveats:
--
-- * User-defined types (types not explicitly known to this library) with a
--   /custom/ Show instance will still be showable, but the result will be
--   what the /derived/ show instance would have done.
-- * Record field names are not known at runtime, so they are not shown.
-- * UNPACKed data is not visible to this library (if you compile with @-O0@
--   @ghc@ will not unpack data, so that might be a workaround if necessary).
--
-- If classification fails, we show the actual closure.
anythingToString :: forall a. a -> String
anythingToString :: forall a. a -> String
anythingToString a
x =
    case forall a. a -> Either Closure (Classifier a)
classify a
x of
      Left  Closure
closure    -> forall a. Show a => a -> String
show Closure
closure
      Right Classifier a
classifier -> case forall a. Classifier a -> Dict Show a
canShowClassified Classifier a
classifier of
                            Dict Show a
Dict -> forall a. Show a => a -> String
show a
x

deriving instance Show (Some Classified)

instance Show (Classified a) where
  showsPrec :: Int -> Classified a -> ShowS
showsPrec Int
p (Classified Classifier a
c a
x) = Bool -> ShowS -> ShowS
showParen (Int
p forall a. Ord a => a -> a -> Bool
>= Int
11) forall a b. (a -> b) -> a -> b
$
      case forall a. Classifier a -> Dict Show a
canShowClassified Classifier a
c of
        Dict Show a
Dict ->
            String -> ShowS
showString String
"Classified "
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Classifier a
c
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" "
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 a
x

-- | Show the classified value (without the classifier)
showClassifiedValue :: Int -> Classified a -> ShowS
showClassifiedValue :: forall a. Int -> Classified a -> ShowS
showClassifiedValue Int
p (Classified Classifier a
c a
x) =
    case forall a. Classifier a -> Dict Show a
canShowClassified Classifier a
c of
      Dict Show a
Dict -> forall a. Show a => Int -> a -> ShowS
showsPrec Int
p a
x

canShowClassified :: Classifier a -> Dict Show a
canShowClassified :: forall a. Classifier a -> Dict Show a
canShowClassified = forall (o :: * -> *).
(forall a. o a -> Dict Show a)
-> forall a. Classifier_ o a -> Dict Show a
canShowClassified_ forall a. IsUserDefined a -> Dict Show a
showOther
  where
    showOther :: IsUserDefined a -> Dict Show a
    showOther :: forall a. IsUserDefined a -> Dict Show a
showOther (IsUserDefined UserDefined
_) = forall {k} (c :: k -> Constraint) (a :: k). c a => Dict c a
Dict

canShowPrim :: PrimClassifier a -> Dict Show a
canShowPrim :: forall a. PrimClassifier a -> Dict Show a
canShowPrim = forall (c :: * -> Constraint) a.
PrimSatisfies c =>
PrimClassifier a -> Dict c a
primSatisfies

canShowClassified_ :: forall o.
     (forall a. o a -> Dict Show a)
  -> (forall a. Classifier_ o a -> Dict Show a)
canShowClassified_ :: forall (o :: * -> *).
(forall a. o a -> Dict Show a)
-> forall a. Classifier_ o a -> Dict Show a
canShowClassified_ = forall (c :: * -> Constraint) (o :: * -> *).
(ClassifiedSatisfies c, c Void) =>
(forall a. o a -> Dict c a)
-> forall a. Classifier_ o a -> Dict c a
classifiedSatisfies

instance Show UserDefined where
  showsPrec :: Int -> UserDefined -> ShowS
showsPrec Int
p UserDefined
x =
      case [Some Classified]
args of
        [] -> String -> ShowS
showString String
constrName
        [Some Classified]
xs -> Bool -> ShowS -> ShowS
showParen (Int
p forall a. Ord a => a -> a -> Bool
>= Int
11)
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> ShowS
showString String
constrName forall b c a. (b -> c) -> (a -> b) -> a -> c
.)
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\(Some Classified a
x') -> String -> ShowS
showString String
" " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> Classified a -> ShowS
showClassifiedValue Int
11 Classified a
x')
            forall a b. (a -> b) -> a -> b
$ [Some Classified]
xs
    where
      (String
constrName, [Some Classified]
args) = UserDefined -> (String, [Some Classified])
fromUserDefined UserDefined
x