GHC/Utils/Binary/Typeable.hs

    {-# LANGUAGE CPP #-}
    {-# LANGUAGE MultiWayIf #-}
    {-# LANGUAGE PolyKinds #-}
    {-# LANGUAGE GADTs #-}

    {-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
    {-# OPTIONS_GHC -Wno-orphans #-}
    #if MIN_VERSION_base(4,16,0)
    #define HAS_TYPELITCHAR
    #endif

    -- | Orphan Binary instances for Data.Typeable stuff
    module GHC.Utils.Binary.Typeable
       ( getSomeTypeRep
       )
    where

    #include "HsVersions.h"

    import GHC.Prelude

    import GHC.Utils.Binary

    import GHC.Exts (TYPE, RuntimeRep(..), VecCount(..), VecElem(..))
    #if __GLASGOW_HASKELL__ >= 901
    import GHC.Exts (Levity(Lifted, Unlifted))
    #endif
    import GHC.Serialized

    import Foreign
    import Type.Reflection
    import Type.Reflection.Unsafe
    import Data.Kind (Type)

    instance Binary TyCon where
        put_ bh tc = do
            put_ bh (tyConPackage tc)
            put_ bh (tyConModule tc)
            put_ bh (tyConName tc)
            put_ bh (tyConKindArgs tc)
            put_ bh (tyConKindRep tc)
        get bh =
            mkTyCon <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh

    getSomeTypeRep :: BinHandle -> IO SomeTypeRep
    getSomeTypeRep bh = do
        tag <- get bh :: IO Word8
        case tag of
            0 -> return $ SomeTypeRep (typeRep :: TypeRep Type)
            1 -> do con <- get bh :: IO TyCon
                    ks <- get bh :: IO [SomeTypeRep]
                    return $ SomeTypeRep $ mkTrCon con ks

            2 -> do SomeTypeRep f <- getSomeTypeRep bh
                    SomeTypeRep x <- getSomeTypeRep bh
                    case typeRepKind f of
                      Fun arg res ->
                          case arg `eqTypeRep` typeRepKind x of
                            Just HRefl ->
                                case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of
                                  Just HRefl -> return $ SomeTypeRep $ mkTrApp f x
                                  _ -> failure "Kind mismatch in type application" []
                            _ -> failure "Kind mismatch in type application"
                                 [ "    Found argument of kind: " ++ show (typeRepKind x)
                                 , "    Where the constructor:  " ++ show f
                                 , "    Expects kind:           " ++ show arg
                                 ]
                      _ -> failure "Applied non-arrow"
                           [ "    Applied type: " ++ show f
                           , "    To argument:  " ++ show x
                           ]
            3 -> do SomeTypeRep arg <- getSomeTypeRep bh
                    SomeTypeRep res <- getSomeTypeRep bh
                    if
                      | App argkcon _ <- typeRepKind arg
                      , App reskcon _ <- typeRepKind res
                      , Just HRefl <- argkcon `eqTypeRep` tYPErep
                      , Just HRefl <- reskcon `eqTypeRep` tYPErep
                      -> return $ SomeTypeRep $ Fun arg res
                      | otherwise -> failure "Kind mismatch" []
            _ -> failure "Invalid SomeTypeRep" []
      where
        tYPErep :: TypeRep TYPE
        tYPErep = typeRep

        failure description info =
            fail $ unlines $ [ "Binary.getSomeTypeRep: "++description ]
                          ++ map ("    "++) info

    instance Binary SomeTypeRep where
        put_ bh (SomeTypeRep rep) = putTypeRep bh rep
        get = getSomeTypeRep

    instance Typeable a => Binary (TypeRep (a :: k)) where
        put_ = putTypeRep
        get bh = do
            SomeTypeRep rep <- getSomeTypeRep bh
            case rep `eqTypeRep` expected of
                Just HRefl -> pure rep
                Nothing    -> fail $ unlines
                                   [ "Binary: Type mismatch"
                                   , "    Deserialized type: " ++ show rep
                                   , "    Expected type:     " ++ show expected
                                   ]
         where expected = typeRep :: TypeRep a

    instance Binary VecCount where
        put_ bh = putByte bh . fromIntegral . fromEnum
        get bh = toEnum . fromIntegral <$> getByte bh

    instance Binary VecElem where
        put_ bh = putByte bh . fromIntegral . fromEnum
        get bh = toEnum . fromIntegral <$> getByte bh

    instance Binary RuntimeRep where
        put_ bh (VecRep a b)    = putByte bh 0 >> put_ bh a >> put_ bh b
        put_ bh (TupleRep reps) = putByte bh 1 >> put_ bh reps
        put_ bh (SumRep reps)   = putByte bh 2 >> put_ bh reps
    #if __GLASGOW_HASKELL__ >= 901
        put_ bh (BoxedRep Lifted)   = putByte bh 3
        put_ bh (BoxedRep Unlifted) = putByte bh 4
    #else
        put_ bh LiftedRep       = putByte bh 3
        put_ bh UnliftedRep     = putByte bh 4
    #endif
        put_ bh IntRep          = putByte bh 5
        put_ bh WordRep         = putByte bh 6
        put_ bh Int64Rep        = putByte bh 7
        put_ bh Word64Rep       = putByte bh 8
        put_ bh AddrRep         = putByte bh 9
        put_ bh FloatRep        = putByte bh 10
        put_ bh DoubleRep       = putByte bh 11
        put_ bh Int8Rep         = putByte bh 12
        put_ bh Word8Rep        = putByte bh 13
        put_ bh Int16Rep        = putByte bh 14
        put_ bh Word16Rep       = putByte bh 15
        put_ bh Int32Rep        = putByte bh 16
        put_ bh Word32Rep       = putByte bh 17

        get bh = do
            tag <- getByte bh
            case tag of
              0  -> VecRep <$> get bh <*> get bh
              1  -> TupleRep <$> get bh
              2  -> SumRep <$> get bh
    #if __GLASGOW_HASKELL__ >= 901
              3  -> pure (BoxedRep Lifted)
              4  -> pure (BoxedRep Unlifted)
    #else
              3  -> pure LiftedRep
              4  -> pure UnliftedRep
    #endif
              5  -> pure IntRep
              6  -> pure WordRep
              7  -> pure Int64Rep
              8  -> pure Word64Rep
              9  -> pure AddrRep
              10 -> pure FloatRep
              11 -> pure DoubleRep
              12 -> pure Int8Rep
              13 -> pure Word8Rep
              14 -> pure Int16Rep
              15 -> pure Word16Rep
              16 -> pure Int32Rep
              17 -> pure Word32Rep
              _  -> fail "Binary.putRuntimeRep: invalid tag"

    instance Binary KindRep where
        put_ bh (KindRepTyConApp tc k) = putByte bh 0 >> put_ bh tc >> put_ bh k
        put_ bh (KindRepVar bndr) = putByte bh 1 >> put_ bh bndr
        put_ bh (KindRepApp a b) = putByte bh 2 >> put_ bh a >> put_ bh b
        put_ bh (KindRepFun a b) = putByte bh 3 >> put_ bh a >> put_ bh b
        put_ bh (KindRepTYPE r) = putByte bh 4 >> put_ bh r
        put_ bh (KindRepTypeLit sort r) = putByte bh 5 >> put_ bh sort >> put_ bh r

        get bh = do
            tag <- getByte bh
            case tag of
              0 -> KindRepTyConApp <$> get bh <*> get bh
              1 -> KindRepVar <$> get bh
              2 -> KindRepApp <$> get bh <*> get bh
              3 -> KindRepFun <$> get bh <*> get bh
              4 -> KindRepTYPE <$> get bh
              5 -> KindRepTypeLit <$> get bh <*> get bh
              _ -> fail "Binary.putKindRep: invalid tag"

    instance Binary TypeLitSort where
        put_ bh TypeLitSymbol = putByte bh 0
        put_ bh TypeLitNat = putByte bh 1
    #if defined(HAS_TYPELITCHAR)
        put_ bh TypeLitChar = putByte bh 2
    #endif
        get bh = do
            tag <- getByte bh
            case tag of
              0 -> pure TypeLitSymbol
              1 -> pure TypeLitNat
    #if defined(HAS_TYPELITCHAR)
              2 -> pure TypeLitChar
    #endif
              _ -> fail "Binary.putTypeLitSort: invalid tag"

    putTypeRep :: BinHandle -> TypeRep a -> IO ()
    -- Special handling for TYPE, (->), and RuntimeRep due to recursive kind
    -- relations.
    -- See Note [Mutually recursive representations of primitive types]
    putTypeRep bh rep
      | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type)
      = put_ bh (0 :: Word8)
    putTypeRep bh (Con' con ks) = do
        put_ bh (1 :: Word8)
        put_ bh con
        put_ bh ks
    putTypeRep bh (App f x) = do
        put_ bh (2 :: Word8)
        putTypeRep bh f
        putTypeRep bh x
    putTypeRep bh (Fun arg res) = do
        put_ bh (3 :: Word8)
        putTypeRep bh arg
        putTypeRep bh res

    instance Binary Serialized where
        put_ bh (Serialized the_type bytes) = do
            put_ bh the_type
            put_ bh bytes
        get bh = do
            the_type <- get bh
            bytes <- get bh
            return (Serialized the_type bytes)