{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GADTs #-}

-- This module is full of orphans, unfortunately
module GHCi.TH.Binary () where

import Prelude -- See note [Why do we import Prelude here?]
import Data.Binary
import qualified Data.ByteString as B
import qualified Data.ByteString.Internal as B
import GHC.Serialized
import qualified Language.Haskell.TH        as TH
import qualified Language.Haskell.TH.Syntax as TH
-- Put these in a separate module because they take ages to compile

instance Binary TH.Loc
instance Binary TH.Name
instance Binary TH.ModName
instance Binary TH.NameFlavour
instance Binary TH.PkgName
instance Binary TH.NameSpace
instance Binary TH.Module
instance Binary TH.Info
instance Binary TH.Type
instance Binary TH.TyLit
instance Binary TH.Specificity
instance Binary TH.BndrVis
instance Binary flag => Binary (TH.TyVarBndr flag)
instance Binary TH.Role
instance Binary TH.Lit
instance Binary TH.Range
instance Binary TH.Stmt
instance Binary TH.Pat
instance Binary TH.Exp
instance Binary TH.Dec
instance Binary TH.NamespaceSpecifier
instance Binary TH.Overlap
instance Binary TH.DerivClause
instance Binary TH.DerivStrategy
instance Binary TH.Guard
instance Binary TH.Body
instance Binary TH.Match
instance Binary TH.Fixity
instance Binary TH.TySynEqn
instance Binary TH.FunDep
instance Binary TH.AnnTarget
instance Binary TH.RuleBndr
instance Binary TH.Phases
instance Binary TH.RuleMatch
instance Binary TH.Inline
instance Binary TH.Pragma
instance Binary TH.Safety
instance Binary TH.Callconv
instance Binary TH.Foreign
instance Binary TH.Bang
instance Binary TH.SourceUnpackedness
instance Binary TH.SourceStrictness
instance Binary TH.DecidedStrictness
instance Binary TH.FixityDirection
instance Binary TH.OccName
instance Binary TH.Con
instance Binary TH.AnnLookup
instance Binary TH.ModuleInfo
instance Binary TH.Clause
instance Binary TH.InjectivityAnn
instance Binary TH.FamilyResultSig
instance Binary TH.TypeFamilyHead
instance Binary TH.PatSynDir
instance Binary TH.PatSynArgs
instance Binary TH.DocLoc

-- We need Binary TypeRep for serializing annotations

instance Binary Serialized where
    put :: Serialized -> Put
put (Serialized TypeRep
tyrep [Word8]
wds) = TypeRep -> Put
forall t. Binary t => t -> Put
put TypeRep
tyrep Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> Put
forall t. Binary t => t -> Put
put ([Word8] -> ByteString
B.pack [Word8]
wds)
    get :: Get Serialized
get = TypeRep -> [Word8] -> Serialized
Serialized (TypeRep -> [Word8] -> Serialized)
-> Get TypeRep -> Get ([Word8] -> Serialized)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get TypeRep
forall t. Binary t => Get t
get Get ([Word8] -> Serialized) -> Get [Word8] -> Get Serialized
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ByteString -> [Word8]
B.unpack (ByteString -> [Word8]) -> Get ByteString -> Get [Word8]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
forall t. Binary t => Get t
get)

instance Binary TH.Bytes where
   put :: Bytes -> Put
put (TH.Bytes ForeignPtr Word8
ptr Word
off Word
sz) = ByteString -> Put
forall t. Binary t => t -> Put
put ByteString
bs
      where bs :: ByteString
bs = ForeignPtr Word8 -> Int -> Int -> ByteString
B.PS ForeignPtr Word8
ptr (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
off) (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
sz)
   get :: Get Bytes
get = do
      B.PS ForeignPtr Word8
ptr Int
off Int
sz <- Get ByteString
forall t. Binary t => Get t
get
      Bytes -> Get Bytes
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignPtr Word8 -> Word -> Word -> Bytes
TH.Bytes ForeignPtr Word8
ptr (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off) (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz))