never executed always true always false
    1 {-# LANGUAGE CPP #-}
    2 {-# LANGUAGE PolyKinds #-}
    3 {-# LANGUAGE GADTs #-}
    4 
    5 {-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
    6 {-# OPTIONS_GHC -Wno-orphans -Wincomplete-patterns #-}
    7 #if MIN_VERSION_base(4,16,0)
    8 #define HAS_TYPELITCHAR
    9 #endif
   10 
   11 -- | Orphan Binary instances for Data.Typeable stuff
   12 module GHC.Utils.Binary.Typeable
   13    ( getSomeTypeRep
   14    )
   15 where
   16 
   17 import GHC.Prelude
   18 
   19 import GHC.Utils.Binary
   20 
   21 import GHC.Exts (RuntimeRep(..), VecCount(..), VecElem(..))
   22 #if __GLASGOW_HASKELL__ >= 901
   23 import GHC.Exts (Levity(Lifted, Unlifted))
   24 #endif
   25 import GHC.Serialized
   26 
   27 import Foreign
   28 import Type.Reflection
   29 import Type.Reflection.Unsafe
   30 import Data.Kind (Type)
   31 
   32 
   33 instance Binary TyCon where
   34     put_ bh tc = do
   35         put_ bh (tyConPackage tc)
   36         put_ bh (tyConModule tc)
   37         put_ bh (tyConName tc)
   38         put_ bh (tyConKindArgs tc)
   39         put_ bh (tyConKindRep tc)
   40     get bh =
   41         mkTyCon <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh
   42 
   43 getSomeTypeRep :: BinHandle -> IO SomeTypeRep
   44 getSomeTypeRep bh = do
   45     tag <- get bh :: IO Word8
   46     case tag of
   47         0 -> return $ SomeTypeRep (typeRep :: TypeRep Type)
   48         1 -> do con <- get bh :: IO TyCon
   49                 ks <- get bh :: IO [SomeTypeRep]
   50                 return $ SomeTypeRep $ mkTrCon con ks
   51         2 -> do SomeTypeRep f <- getSomeTypeRep bh
   52                 SomeTypeRep x <- getSomeTypeRep bh
   53                 case typeRepKind f of
   54                   Fun arg res ->
   55                       case arg `eqTypeRep` typeRepKind x of
   56                         Just HRefl ->
   57                             case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of
   58                               Just HRefl -> return $ SomeTypeRep $ mkTrApp f x
   59                               _ -> failure "Kind mismatch in type application" []
   60                         _ -> failure "Kind mismatch in type application"
   61                              [ "    Found argument of kind: " ++ show (typeRepKind x)
   62                              , "    Where the constructor:  " ++ show f
   63                              , "    Expects kind:           " ++ show arg
   64                              ]
   65                   _ -> failure "Applied non-arrow"
   66                        [ "    Applied type: " ++ show f
   67                        , "    To argument:  " ++ show x
   68                        ]
   69         _ -> failure "Invalid SomeTypeRep" []
   70   where
   71     failure description info =
   72         fail $ unlines $ [ "Binary.getSomeTypeRep: "++description ]
   73                       ++ map ("    "++) info
   74 
   75 instance Binary SomeTypeRep where
   76     put_ bh (SomeTypeRep rep) = putTypeRep bh rep
   77     get = getSomeTypeRep
   78 
   79 instance Typeable a => Binary (TypeRep (a :: k)) where
   80     put_ = putTypeRep
   81     get bh = do
   82         SomeTypeRep rep <- getSomeTypeRep bh
   83         case rep `eqTypeRep` expected of
   84             Just HRefl -> pure rep
   85             Nothing    -> fail $ unlines
   86                                [ "Binary: Type mismatch"
   87                                , "    Deserialized type: " ++ show rep
   88                                , "    Expected type:     " ++ show expected
   89                                ]
   90      where expected = typeRep :: TypeRep a
   91 
   92 
   93 instance Binary VecCount where
   94     put_ bh = putByte bh . fromIntegral . fromEnum
   95     get bh = toEnum . fromIntegral <$> getByte bh
   96 
   97 instance Binary VecElem where
   98     put_ bh = putByte bh . fromIntegral . fromEnum
   99     get bh = toEnum . fromIntegral <$> getByte bh
  100 
  101 instance Binary RuntimeRep where
  102     put_ bh (VecRep a b)    = putByte bh 0 >> put_ bh a >> put_ bh b
  103     put_ bh (TupleRep reps) = putByte bh 1 >> put_ bh reps
  104     put_ bh (SumRep reps)   = putByte bh 2 >> put_ bh reps
  105 #if __GLASGOW_HASKELL__ >= 901
  106     put_ bh (BoxedRep Lifted)   = putByte bh 3
  107     put_ bh (BoxedRep Unlifted) = putByte bh 4
  108 #else
  109     put_ bh LiftedRep       = putByte bh 3
  110     put_ bh UnliftedRep     = putByte bh 4
  111 #endif
  112     put_ bh IntRep          = putByte bh 5
  113     put_ bh WordRep         = putByte bh 6
  114     put_ bh Int64Rep        = putByte bh 7
  115     put_ bh Word64Rep       = putByte bh 8
  116     put_ bh AddrRep         = putByte bh 9
  117     put_ bh FloatRep        = putByte bh 10
  118     put_ bh DoubleRep       = putByte bh 11
  119     put_ bh Int8Rep         = putByte bh 12
  120     put_ bh Word8Rep        = putByte bh 13
  121     put_ bh Int16Rep        = putByte bh 14
  122     put_ bh Word16Rep       = putByte bh 15
  123     put_ bh Int32Rep        = putByte bh 16
  124     put_ bh Word32Rep       = putByte bh 17
  125 
  126     get bh = do
  127         tag <- getByte bh
  128         case tag of
  129           0  -> VecRep <$> get bh <*> get bh
  130           1  -> TupleRep <$> get bh
  131           2  -> SumRep <$> get bh
  132 #if __GLASGOW_HASKELL__ >= 901
  133           3  -> pure (BoxedRep Lifted)
  134           4  -> pure (BoxedRep Unlifted)
  135 #else
  136           3  -> pure LiftedRep
  137           4  -> pure UnliftedRep
  138 #endif
  139           5  -> pure IntRep
  140           6  -> pure WordRep
  141           7  -> pure Int64Rep
  142           8  -> pure Word64Rep
  143           9  -> pure AddrRep
  144           10 -> pure FloatRep
  145           11 -> pure DoubleRep
  146           12 -> pure Int8Rep
  147           13 -> pure Word8Rep
  148           14 -> pure Int16Rep
  149           15 -> pure Word16Rep
  150           16 -> pure Int32Rep
  151           17 -> pure Word32Rep
  152           _  -> fail "Binary.putRuntimeRep: invalid tag"
  153 
  154 instance Binary KindRep where
  155     put_ bh (KindRepTyConApp tc k) = putByte bh 0 >> put_ bh tc >> put_ bh k
  156     put_ bh (KindRepVar bndr) = putByte bh 1 >> put_ bh bndr
  157     put_ bh (KindRepApp a b) = putByte bh 2 >> put_ bh a >> put_ bh b
  158     put_ bh (KindRepFun a b) = putByte bh 3 >> put_ bh a >> put_ bh b
  159     put_ bh (KindRepTYPE r) = putByte bh 4 >> put_ bh r
  160     put_ bh (KindRepTypeLit sort r) = putByte bh 5 >> put_ bh sort >> put_ bh r
  161 
  162     get bh = do
  163         tag <- getByte bh
  164         case tag of
  165           0 -> KindRepTyConApp <$> get bh <*> get bh
  166           1 -> KindRepVar <$> get bh
  167           2 -> KindRepApp <$> get bh <*> get bh
  168           3 -> KindRepFun <$> get bh <*> get bh
  169           4 -> KindRepTYPE <$> get bh
  170           5 -> KindRepTypeLit <$> get bh <*> get bh
  171           _ -> fail "Binary.putKindRep: invalid tag"
  172 
  173 instance Binary TypeLitSort where
  174     put_ bh TypeLitSymbol = putByte bh 0
  175     put_ bh TypeLitNat = putByte bh 1
  176 #if defined(HAS_TYPELITCHAR)
  177     put_ bh TypeLitChar = putByte bh 2
  178 #endif
  179     get bh = do
  180         tag <- getByte bh
  181         case tag of
  182           0 -> pure TypeLitSymbol
  183           1 -> pure TypeLitNat
  184 #if defined(HAS_TYPELITCHAR)
  185           2 -> pure TypeLitChar
  186 #endif
  187           _ -> fail "Binary.putTypeLitSort: invalid tag"
  188 
  189 putTypeRep :: BinHandle -> TypeRep a -> IO ()
  190 putTypeRep bh rep -- Handle Type specially since it's so common
  191   | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type)
  192   = put_ bh (0 :: Word8)
  193 putTypeRep bh (Con' con ks) = do
  194     put_ bh (1 :: Word8)
  195     put_ bh con
  196     put_ bh ks
  197 putTypeRep bh (App f x) = do
  198     put_ bh (2 :: Word8)
  199     putTypeRep bh f
  200     putTypeRep bh x
  201 putTypeRep bh (Fun arg res) = do
  202     put_ bh (3 :: Word8)
  203     putTypeRep bh arg
  204     putTypeRep bh res
  205 
  206 instance Binary Serialized where
  207     put_ bh (Serialized the_type bytes) = do
  208         put_ bh the_type
  209         put_ bh bytes
  210     get bh = do
  211         the_type <- get bh
  212         bytes <- get bh
  213         return (Serialized the_type bytes)