    {-# LANGUAGE GeneralisedNewtypeDeriving #-}
    {-# LANGUAGE ViewPatterns #-}
    {-# LANGUAGE PatternSynonyms #-}

    -- | Types for the Constructed Product Result lattice.
    -- "GHC.Core.Opt.CprAnal" and "GHC.Core.Opt.WorkWrap.Utils"
    -- are its primary customers via 'GHC.Types.Id.idCprSig'.
    module GHC.Types.Cpr (
        Cpr (ConCpr), topCpr, botCpr, flatConCpr, asConCpr,
        CprType (..), topCprType, botCprType, flatConCprType,
        lubCprType, applyCprTy, abstractCprTy, trimCprTy,
        UnpackConFieldsResult (..), unpackConFieldsCpr,
        CprSig (..), topCprSig, isTopCprSig, mkCprSigForArity, mkCprSig,
        seqCprSig, prependArgsCprSig
      ) where

    import GHC.Prelude

    import GHC.Core.DataCon
    import GHC.Types.Basic
    import GHC.Utils.Binary
    import GHC.Utils.Misc
    import GHC.Utils.Outputable
    import GHC.Utils.Panic

    --
    -- * Cpr
    --

    data Cpr
      = BotCpr
      | ConCpr_ !ConTag ![Cpr]
      -- ^ The number of field Cprs equals 'dataConRepArity'.
      -- If all of them are top, better use 'FlatConCpr', as ensured by the pattern
      -- synonym 'ConCpr'.
      | FlatConCpr !ConTag
      -- ^ @FlatConCpr tag@ is an efficient encoding for @'ConCpr_' tag [TopCpr..]@.
      -- Purely for compiler perf. Can be constructed with 'ConCpr'.
      | TopCpr
      deriving Cpr -> Cpr -> Bool
    (Cpr -> Cpr -> Bool) -> (Cpr -> Cpr -> Bool) -> Eq Cpr
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: Cpr -> Cpr -> Bool
    == :: Cpr -> Cpr -> Bool
    $c/= :: Cpr -> Cpr -> Bool
    /= :: Cpr -> Cpr -> Bool
    Eq

    pattern ConCpr :: ConTag -> [Cpr] -> Cpr
    pattern $mConCpr :: forall {r}. Cpr -> (Arity -> [Cpr] -> r) -> ((# #) -> r) -> r
    $bConCpr :: Arity -> [Cpr] -> Cpr
    ConCpr t cs <- ConCpr_ t cs where
      ConCpr Arity
    t [Cpr]
    cs
        | (Cpr -> Bool) -> [Cpr] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all (Cpr -> Cpr -> Bool
    forall a. Eq a => a -> a -> Bool
    == Cpr
    TopCpr) [Cpr]
    cs = Arity -> Cpr
    FlatConCpr Arity
    t
        | Bool
    otherwise          = Arity -> [Cpr] -> Cpr
    ConCpr_ Arity
    t [Cpr]
    cs
    {-# COMPLETE BotCpr, TopCpr, FlatConCpr, ConCpr #-}

    viewConTag :: Cpr -> Maybe ConTag
    viewConTag :: Cpr -> Maybe Arity
    viewConTag (FlatConCpr Arity
    t) = Arity -> Maybe Arity
    forall a. a -> Maybe a
    Just Arity
    t
    viewConTag (ConCpr Arity
    t [Cpr]
    _)   = Arity -> Maybe Arity
    forall a. a -> Maybe a
    Just Arity
    t
    viewConTag Cpr
    _              = Maybe Arity
    forall a. Maybe a
    Nothing
    {-# INLINE viewConTag #-}

    lubCpr :: Cpr -> Cpr -> Cpr
    lubCpr :: Cpr -> Cpr -> Cpr
    lubCpr Cpr
    BotCpr      Cpr
    cpr     = Cpr
    cpr
    lubCpr Cpr
    cpr         Cpr
    BotCpr  = Cpr
    cpr
    lubCpr (FlatConCpr Arity
    t1) (Cpr -> Maybe Arity
    viewConTag -> Just Arity
    t2)
      | Arity
    t1 Arity -> Arity -> Bool
    forall a. Eq a => a -> a -> Bool
    == Arity
    t2 = Arity -> Cpr
    FlatConCpr Arity
    t1
    lubCpr (Cpr -> Maybe Arity
    viewConTag -> Just Arity
    t1) (FlatConCpr Arity
    t2)
      | Arity
    t1 Arity -> Arity -> Bool
    forall a. Eq a => a -> a -> Bool
    == Arity
    t2 = Arity -> Cpr
    FlatConCpr Arity
    t2
    lubCpr (ConCpr Arity
    t1 [Cpr]
    cs1) (ConCpr Arity
    t2 [Cpr]
    cs2)
      | Arity
    t1 Arity -> Arity -> Bool
    forall a. Eq a => a -> a -> Bool
    == Arity
    t2 = Arity -> [Cpr] -> Cpr
    ConCpr Arity
    t1 ([Cpr] -> [Cpr] -> [Cpr]
    lubFieldCprs [Cpr]
    cs1 [Cpr]
    cs2)
    lubCpr Cpr
    _           Cpr
    _       = Cpr
    TopCpr

    lubFieldCprs :: [Cpr] -> [Cpr] -> [Cpr]
    lubFieldCprs :: [Cpr] -> [Cpr] -> [Cpr]
    lubFieldCprs [Cpr]
    as [Cpr]
    bs
      | [Cpr]
    as [Cpr] -> [Cpr] -> Bool
    forall a b. [a] -> [b] -> Bool
    `equalLength` [Cpr]
    bs = (Cpr -> Cpr -> Cpr) -> [Cpr] -> [Cpr] -> [Cpr]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith Cpr -> Cpr -> Cpr
    lubCpr [Cpr]
    as [Cpr]
    bs
      | Bool
    otherwise           = []

    topCpr :: Cpr
    topCpr :: Cpr
    topCpr = Cpr
    TopCpr

    botCpr :: Cpr
    botCpr :: Cpr
    botCpr = Cpr
    BotCpr

    flatConCpr :: ConTag -> Cpr
    flatConCpr :: Arity -> Cpr
    flatConCpr Arity
    t = Arity -> Cpr
    FlatConCpr Arity
    t

    trimCpr :: Cpr -> Cpr
    trimCpr :: Cpr -> Cpr
    trimCpr Cpr
    BotCpr = Cpr
    botCpr
    trimCpr Cpr
    _      = Cpr
    topCpr

    asConCpr :: Cpr -> Maybe (ConTag, [Cpr])
    asConCpr :: Cpr -> Maybe (Arity, [Cpr])
    asConCpr (ConCpr Arity
    t [Cpr]
    cs)  = (Arity, [Cpr]) -> Maybe (Arity, [Cpr])
    forall a. a -> Maybe a
    Just (Arity
    t, [Cpr]
    cs)
    asConCpr (FlatConCpr Arity
    t) = (Arity, [Cpr]) -> Maybe (Arity, [Cpr])
    forall a. a -> Maybe a
    Just (Arity
    t, [])
    asConCpr Cpr
    TopCpr         = Maybe (Arity, [Cpr])
    forall a. Maybe a
    Nothing
    asConCpr Cpr
    BotCpr         = Maybe (Arity, [Cpr])
    forall a. Maybe a
    Nothing

    seqCpr :: Cpr -> ()
    seqCpr :: Cpr -> ()
    seqCpr (ConCpr Arity
    _ [Cpr]
    cs) = (Cpr -> () -> ()) -> () -> [Cpr] -> ()
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (() -> () -> ()
    forall a b. a -> b -> b
    seq (() -> () -> ()) -> (Cpr -> ()) -> Cpr -> () -> ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Cpr -> ()
    seqCpr) () [Cpr]
    cs
    seqCpr Cpr
    _             = ()

    --
    -- * CprType
    --

    -- | The abstract domain \(A_t\) from the original 'CPR for Haskell' paper.
    data CprType
      = CprType
      { CprType -> Arity
    ct_arty :: !Arity -- ^ Number of value arguments the denoted expression
                          --   eats before returning the 'ct_cpr'
      , CprType -> Cpr
    ct_cpr  :: !Cpr   -- ^ 'Cpr' eventually unleashed when applied to
                          --   'ct_arty' arguments
      }

    instance Eq CprType where
      CprType
    a == :: CprType -> CprType -> Bool
    == CprType
    b =  CprType -> Cpr
    ct_cpr CprType
    a Cpr -> Cpr -> Bool
    forall a. Eq a => a -> a -> Bool
    == CprType -> Cpr
    ct_cpr CprType
    b
             Bool -> Bool -> Bool
    && (CprType -> Arity
    ct_arty CprType
    a Arity -> Arity -> Bool
    forall a. Eq a => a -> a -> Bool
    == CprType -> Arity
    ct_arty CprType
    b Bool -> Bool -> Bool
    || CprType -> Cpr
    ct_cpr CprType
    a Cpr -> Cpr -> Bool
    forall a. Eq a => a -> a -> Bool
    == Cpr
    topCpr)

    topCprType :: CprType
    topCprType :: CprType
    topCprType = Arity -> Cpr -> CprType
    CprType Arity
    0 Cpr
    topCpr

    botCprType :: CprType
    botCprType :: CprType
    botCprType = Arity -> Cpr -> CprType
    CprType Arity
    0 Cpr
    botCpr

    flatConCprType :: ConTag -> CprType
    flatConCprType :: Arity -> CprType
    flatConCprType Arity
    con_tag = CprType { ct_arty :: Arity
    ct_arty = Arity
    0, ct_cpr :: Cpr
    ct_cpr = Arity -> Cpr
    flatConCpr Arity
    con_tag }

    lubCprType :: CprType -> CprType -> CprType
    lubCprType :: CprType -> CprType -> CprType
    lubCprType ty1 :: CprType
    ty1@(CprType Arity
    n1 Cpr
    cpr1) ty2 :: CprType
    ty2@(CprType Arity
    n2 Cpr
    cpr2)
      -- The arity of bottom CPR types can be extended arbitrarily.
      | Cpr
    cpr1 Cpr -> Cpr -> Bool
    forall a. Eq a => a -> a -> Bool
    == Cpr
    botCpr Bool -> Bool -> Bool
    && Arity
    n1 Arity -> Arity -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Arity
    n2 = CprType
    ty2
      | Cpr
    cpr2 Cpr -> Cpr -> Bool
    forall a. Eq a => a -> a -> Bool
    == Cpr
    botCpr Bool -> Bool -> Bool
    && Arity
    n2 Arity -> Arity -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Arity
    n1 = CprType
    ty1
      -- There might be non-bottom CPR types with mismatching arities.
      -- Consider test DmdAnalGADTs. We want to return top in these cases.
      | Arity
    n1 Arity -> Arity -> Bool
    forall a. Eq a => a -> a -> Bool
    == Arity
    n2                   = Arity -> Cpr -> CprType
    CprType Arity
    n1 (Cpr -> Cpr -> Cpr
    lubCpr Cpr
    cpr1 Cpr
    cpr2)
      | Bool
    otherwise                  = CprType
    topCprType

    applyCprTy :: CprType -> Arity -> CprType
    applyCprTy :: CprType -> Arity -> CprType
    applyCprTy (CprType Arity
    n Cpr
    res) Arity
    k
      | Arity
    n Arity -> Arity -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Arity
    k        = Arity -> Cpr -> CprType
    CprType (Arity
    nArity -> Arity -> Arity
    forall a. Num a => a -> a -> a
    -Arity
    k) Cpr
    res
      | Cpr
    res Cpr -> Cpr -> Bool
    forall a. Eq a => a -> a -> Bool
    == Cpr
    botCpr = CprType
    botCprType
      | Bool
    otherwise     = CprType
    topCprType

    abstractCprTy :: CprType -> CprType
    abstractCprTy :: CprType -> CprType
    abstractCprTy (CprType Arity
    n Cpr
    res)
      | Cpr
    res Cpr -> Cpr -> Bool
    forall a. Eq a => a -> a -> Bool
    == Cpr
    topCpr = CprType
    topCprType
      | Bool
    otherwise     = Arity -> Cpr -> CprType
    CprType (Arity
    nArity -> Arity -> Arity
    forall a. Num a => a -> a -> a
    +Arity
    1) Cpr
    res

    trimCprTy :: CprType -> CprType
    trimCprTy :: CprType -> CprType
    trimCprTy (CprType Arity
    arty Cpr
    res) = Arity -> Cpr -> CprType
    CprType Arity
    arty (Cpr -> Cpr
    trimCpr Cpr
    res)

    -- | The result of 'unpackConFieldsCpr'.
    data UnpackConFieldsResult
      = AllFieldsSame !Cpr
      | ForeachField ![Cpr]

    -- | Unpacks a 'ConCpr'-shaped 'Cpr' and returns the field 'Cpr's wrapped in a
    -- 'ForeachField'. Otherwise, it returns 'AllFieldsSame' with the appropriate
    -- 'Cpr' to assume for each field.
    --
    -- The use of 'UnpackConFieldsResult' allows O(1) space for the common,
    -- non-'ConCpr' case.
    unpackConFieldsCpr :: DataCon -> Cpr -> UnpackConFieldsResult
    unpackConFieldsCpr :: DataCon -> Cpr -> UnpackConFieldsResult
    unpackConFieldsCpr DataCon
    dc (ConCpr Arity
    t [Cpr]
    cs)
      | Arity
    t Arity -> Arity -> Bool
    forall a. Eq a => a -> a -> Bool
    == DataCon -> Arity
    dataConTag DataCon
    dc, [Cpr]
    cs [Cpr] -> Arity -> Bool
    forall a. [a] -> Arity -> Bool
    `lengthIs` DataCon -> Arity
    dataConRepArity DataCon
    dc
      = [Cpr] -> UnpackConFieldsResult
    ForeachField [Cpr]
    cs
    unpackConFieldsCpr DataCon
    _  Cpr
    BotCpr = Cpr -> UnpackConFieldsResult
    AllFieldsSame Cpr
    BotCpr
    unpackConFieldsCpr DataCon
    _  Cpr
    _      = Cpr -> UnpackConFieldsResult
    AllFieldsSame Cpr
    TopCpr
    {-# INLINE unpackConFieldsCpr #-}

    seqCprTy :: CprType -> ()
    seqCprTy :: CprType -> ()
    seqCprTy (CprType Arity
    _ Cpr
    cpr) = Cpr -> ()
    seqCpr Cpr
    cpr

    -- | The arity of the wrapped 'CprType' is the arity at which it is safe
    -- to unleash. See Note [Understanding DmdType and DmdSig] in "GHC.Types.Demand"
    newtype CprSig = CprSig { CprSig -> CprType
    getCprSig :: CprType }
      deriving (CprSig -> CprSig -> Bool
    (CprSig -> CprSig -> Bool)
    -> (CprSig -> CprSig -> Bool) -> Eq CprSig
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: CprSig -> CprSig -> Bool
    == :: CprSig -> CprSig -> Bool
    $c/= :: CprSig -> CprSig -> Bool
    /= :: CprSig -> CprSig -> Bool
    Eq, ReadBinHandle -> IO CprSig
    WriteBinHandle -> CprSig -> IO ()
    WriteBinHandle -> CprSig -> IO (Bin CprSig)
    (WriteBinHandle -> CprSig -> IO ())
    -> (WriteBinHandle -> CprSig -> IO (Bin CprSig))
    -> (ReadBinHandle -> IO CprSig)
    -> Binary CprSig
    forall a.
    (WriteBinHandle -> a -> IO ())
    -> (WriteBinHandle -> a -> IO (Bin a))
    -> (ReadBinHandle -> IO a)
    -> Binary a
    $cput_ :: WriteBinHandle -> CprSig -> IO ()
    put_ :: WriteBinHandle -> CprSig -> IO ()
    $cput :: WriteBinHandle -> CprSig -> IO (Bin CprSig)
    put :: WriteBinHandle -> CprSig -> IO (Bin CprSig)
    $cget :: ReadBinHandle -> IO CprSig
    get :: ReadBinHandle -> IO CprSig
    Binary)

    -- | Turns a 'CprType' computed for the particular 'Arity' into a 'CprSig'
    -- unleashable at that arity. See Note [Understanding DmdType and DmdSig] in
    -- "GHC.Types.Demand"
    mkCprSigForArity :: Arity -> CprType -> CprSig
    mkCprSigForArity :: Arity -> CprType -> CprSig
    mkCprSigForArity Arity
    arty ty :: CprType
    ty@(CprType Arity
    n Cpr
    _)
      | Arity
    arty Arity -> Arity -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Arity
    n = CprSig
    topCprSig -- Trim on arity mismatch
      | Bool
    otherwise = CprType -> CprSig
    CprSig CprType
    ty

    topCprSig :: CprSig
    topCprSig :: CprSig
    topCprSig = CprType -> CprSig
    CprSig CprType
    topCprType

    isTopCprSig :: CprSig -> Bool
    isTopCprSig :: CprSig -> Bool
    isTopCprSig (CprSig CprType
    ty) = CprType -> Cpr
    ct_cpr CprType
    ty Cpr -> Cpr -> Bool
    forall a. Eq a => a -> a -> Bool
    == Cpr
    topCpr

    mkCprSig :: Arity -> Cpr -> CprSig
    mkCprSig :: Arity -> Cpr -> CprSig
    mkCprSig Arity
    arty Cpr
    cpr = CprType -> CprSig
    CprSig (Arity -> Cpr -> CprType
    CprType Arity
    arty Cpr
    cpr)

    seqCprSig :: CprSig -> ()
    seqCprSig :: CprSig -> ()
    seqCprSig (CprSig CprType
    ty) = CprType -> ()
    seqCprTy CprType
    ty

    prependArgsCprSig :: Arity -> CprSig -> CprSig
    -- ^ Add extra value args to CprSig
    prependArgsCprSig :: Arity -> CprSig -> CprSig
    prependArgsCprSig Arity
    n_extra cpr_sig :: CprSig
    cpr_sig@(CprSig (CprType Arity
    arity Cpr
    cpr))
      | Arity
    n_extra Arity -> Arity -> Bool
    forall a. Eq a => a -> a -> Bool
    == Arity
    0 = CprSig
    cpr_sig
      | Bool
    otherwise    = Bool -> SDoc -> CprSig -> CprSig
    forall a. HasCallStack => Bool -> SDoc -> a -> a
    assertPpr (Arity
    n_extra Arity -> Arity -> Bool
    forall a. Ord a => a -> a -> Bool
    > Arity
    0) (Arity -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Arity
    n_extra) (CprSig -> CprSig) -> CprSig -> CprSig
    forall a b. (a -> b) -> a -> b
    $
                       CprType -> CprSig
    CprSig (Arity -> Cpr -> CprType
    CprType (Arity
    arity Arity -> Arity -> Arity
    forall a. Num a => a -> a -> a
    + Arity
    n_extra) Cpr
    cpr)

    -- | BNF:
    --
    -- > cpr ::= ''                               -- TopCpr
    -- >      |  n                                -- FlatConCpr n
    -- >      |  n '(' cpr1 ',' cpr2 ',' ... ')'  -- ConCpr n [cpr1,cpr2,...]
    -- >      |  'b'                              -- BotCpr
    --
    -- Examples:
    --   * `f x = f x` has result CPR `b`
    --   * `1(1,)` is a valid (nested) 'Cpr' denotation for `(I# 42#, f 42)`.
    instance Outputable Cpr where
      ppr :: Cpr -> SDoc
    ppr Cpr
    TopCpr         = SDoc
    forall doc. IsOutput doc => doc
    empty
      ppr (FlatConCpr Arity
    n) = Arity -> SDoc
    forall doc. IsLine doc => Arity -> doc
    int Arity
    n
      ppr (ConCpr Arity
    n [Cpr]
    cs)  = Arity -> SDoc
    forall doc. IsLine doc => Arity -> doc
    int Arity
    n SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    parens ((Cpr -> SDoc) -> [Cpr] -> SDoc
    forall a. (a -> SDoc) -> [a] -> SDoc
    pprWithCommas Cpr -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [Cpr]
    cs)
      ppr Cpr
    BotCpr         = Char -> SDoc
    forall doc. IsLine doc => Char -> doc
    char Char
    'b'

    -- | BNF:
    --
    -- > cpr_ty ::= cpr               -- short form if arty == 0
    -- >         |  '\' arty '.' cpr  -- if arty > 0
    --
    -- Examples:
    --   * `f x y z = f x y z` has denotation `\3.b`
    --   * `g !x = (x+1, x+2)` has denotation `\1.1(1,1)`.
    instance Outputable CprType where
      ppr :: CprType -> SDoc
    ppr (CprType Arity
    arty Cpr
    res)
        | Arity
    0 <- Arity
    arty = Cpr -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Cpr
    res
        | Bool
    otherwise = Char -> SDoc
    forall doc. IsLine doc => Char -> doc
    char Char
    '\\' SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> Arity -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Arity
    arty SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> Char -> SDoc
    forall doc. IsLine doc => Char -> doc
    char Char
    '.' SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> Cpr -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Cpr
    res

    -- | Only print the CPR result
    instance Outputable CprSig where
      ppr :: CprSig -> SDoc
    ppr (CprSig CprType
    ty) = Cpr -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (CprType -> Cpr
    ct_cpr CprType
    ty)

    instance Binary Cpr where
      put_ :: WriteBinHandle -> Cpr -> IO ()
    put_ WriteBinHandle
    bh Cpr
    TopCpr         = WriteBinHandle -> Word8 -> IO ()
    putByte WriteBinHandle
    bh Word8
    0
      put_ WriteBinHandle
    bh Cpr
    BotCpr         = WriteBinHandle -> Word8 -> IO ()
    putByte WriteBinHandle
    bh Word8
    1
      put_ WriteBinHandle
    bh (FlatConCpr Arity
    n) = WriteBinHandle -> Word8 -> IO ()
    putByte WriteBinHandle
    bh Word8
    2 IO () -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO b
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> WriteBinHandle -> Arity -> IO ()
    forall a. Binary a => WriteBinHandle -> a -> IO ()
    put_ WriteBinHandle
    bh Arity
    n
      put_ WriteBinHandle
    bh (ConCpr Arity
    n [Cpr]
    cs)  = WriteBinHandle -> Word8 -> IO ()
    putByte WriteBinHandle
    bh Word8
    3 IO () -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO b
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> WriteBinHandle -> Arity -> IO ()
    forall a. Binary a => WriteBinHandle -> a -> IO ()
    put_ WriteBinHandle
    bh Arity
    n IO () -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO b
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> WriteBinHandle -> [Cpr] -> IO ()
    forall a. Binary a => WriteBinHandle -> a -> IO ()
    put_ WriteBinHandle
    bh [Cpr]
    cs
      get :: ReadBinHandle -> IO Cpr
    get  ReadBinHandle
    bh = do
        h <- ReadBinHandle -> IO Word8
    getByte ReadBinHandle
    bh
        case h of
          Word8
    0 -> Cpr -> IO Cpr
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Cpr
    TopCpr
          Word8
    1 -> Cpr -> IO Cpr
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Cpr
    BotCpr
          Word8
    2 -> Arity -> Cpr
    FlatConCpr (Arity -> Cpr) -> IO Arity -> IO Cpr
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ReadBinHandle -> IO Arity
    forall a. Binary a => ReadBinHandle -> IO a
    get ReadBinHandle
    bh
          Word8
    3 -> Arity -> [Cpr] -> Cpr
    ConCpr (Arity -> [Cpr] -> Cpr) -> IO Arity -> IO ([Cpr] -> Cpr)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ReadBinHandle -> IO Arity
    forall a. Binary a => ReadBinHandle -> IO a
    get ReadBinHandle
    bh IO ([Cpr] -> Cpr) -> IO [Cpr] -> IO Cpr
    forall a b. IO (a -> b) -> IO a -> IO b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> ReadBinHandle -> IO [Cpr]
    forall a. Binary a => ReadBinHandle -> IO a
    get ReadBinHandle
    bh
          Word8
    _ -> String -> SDoc -> IO Cpr
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "Binary Cpr: Invalid tag" (Arity -> SDoc
    forall doc. IsLine doc => Arity -> doc
    int (Word8 -> Arity
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word8
    h))

    instance Binary CprType where
      put_ :: WriteBinHandle -> CprType -> IO ()
    put_ WriteBinHandle
    bh (CprType Arity
    arty Cpr
    cpr) = WriteBinHandle -> Arity -> IO ()
    forall a. Binary a => WriteBinHandle -> a -> IO ()
    put_ WriteBinHandle
    bh Arity
    arty IO () -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO b
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> WriteBinHandle -> Cpr -> IO ()
    forall a. Binary a => WriteBinHandle -> a -> IO ()
    put_ WriteBinHandle
    bh Cpr
    cpr
      get :: ReadBinHandle -> IO CprType
    get  ReadBinHandle
    bh                    = Arity -> Cpr -> CprType
    CprType (Arity -> Cpr -> CprType) -> IO Arity -> IO (Cpr -> CprType)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ReadBinHandle -> IO Arity
    forall a. Binary a => ReadBinHandle -> IO a
    get ReadBinHandle
    bh IO (Cpr -> CprType) -> IO Cpr -> IO CprType
    forall a b. IO (a -> b) -> IO a -> IO b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> ReadBinHandle -> IO Cpr
    forall a. Binary a => ReadBinHandle -> IO a
    get ReadBinHandle
    bh