    {-# LANGUAGE TemplateHaskell, CPP #-}

    -- Hack for bug in older Cabal versions
    #ifndef MIN_VERSION_template_haskell
    #define MIN_VERSION_template_haskell(x,y,z) 1
    #endif

    module Data.SafeCopy.Derive where

    import Data.Serialize (getWord8, putWord8, label)
    import Data.SafeCopy.SafeCopy

    import Language.Haskell.TH hiding (Kind)
    import Control.Monad
    import Data.Maybe (fromMaybe)
    #ifdef __HADDOCK__
    import Data.Word (Word8) -- Haddock
    #endif

    -- | Derive an instance of 'SafeCopy'.
    --
    --   When serializing, we put a 'Word8' describing the
    --   constructor (if the data type has more than one
    --   constructor).  For each type used in the constructor, we
    --   call 'getSafePut' (which immediately serializes the version
    --   of the type).  Then, for each field in the constructor, we
    --   use one of the put functions obtained in the last step.
    --
    --   For example, given the data type and the declaration below
    --
    --   @
    --data T0 b = T0 b Int
    --deriveSafeCopy 1 'base ''T0
    --   @
    --
    --   we generate
    --
    --   @
    --instance (SafeCopy a, SafeCopy b) =>
    --         SafeCopy (T0 b) where
    --    putCopy (T0 arg1 arg2) = contain $ do put_b   <- getSafePut
    --                                          put_Int <- getSafePut
    --                                          put_b   arg1
    --                                          put_Int arg2
    --                                          return ()
    --    getCopy = contain $ do get_b   <- getSafeGet
    --                           get_Int <- getSafeGet
    --                           return T0 \<*\> get_b \<*\> get_Int
    --    version = 1
    --    kind = base
    --   @
    --
    --   And, should we create another data type as a newer version of @T0@, such as
    --
    --   @
    --data T a b = C a a | D b Int
    --deriveSafeCopy 2 'extension ''T
    --
    --instance SafeCopy b => Migrate (T a b) where
    --  type MigrateFrom (T a b) = T0 b
    --  migrate (T0 b i) = D b i
    --   @
    --
    --   we generate
    --
    --   @
    --instance (SafeCopy a, SafeCopy b) =>
    --         SafeCopy (T a b) where
    --    putCopy (C arg1 arg2) = contain $ do putWord8 0
    --                                         put_a <- getSafePut
    --                                         put_a arg1
    --                                         put_a arg2
    --                                         return ()
    --    putCopy (D arg1 arg2) = contain $ do putWord8 1
    --                                         put_b   <- getSafePut
    --                                         put_Int <- getSafePut
    --                                         put_b   arg1
    --                                         put_Int arg2
    --                                         return ()
    --    getCopy = contain $ do tag <- getWord8
    --                           case tag of
    --                             0 -> do get_a <- getSafeGet
    --                                     return C \<*\> get_a \<*\> get_a
    --                             1 -> do get_b   <- getSafeGet
    --                                     get_Int <- getSafeGet
    --                                     return D \<*\> get_b \<*\> get_Int
    --                             _ -> fail $ \"Could not identify tag \\\"\" ++
    --                                         show tag ++ \"\\\" for type Main.T \" ++
    --                                         \"that has only 2 constructors.  \" ++
    --                                         \"Maybe your data is corrupted?\"
    --    version = 2
    --    kind = extension
    --   @
    --
    --   Note that by using getSafePut, we saved 4 bytes in the case
    --   of the @C@ constructor.  For @D@ and @T0@, we didn't save
    --   anything.  The instance derived by this function always use
    --   at most the same space as those generated by
    --   'deriveSafeCopySimple', but never more (as we don't call
    --   'getSafePut'/'getSafeGet' for types that aren't needed).
    --
    --   Note that you may use 'deriveSafeCopySimple' with one
    --   version of your data type and 'deriveSafeCopy' in another
    --   version without any problems.
    deriveSafeCopy :: Version a -> Name -> Name -> Q [Dec]
    deriveSafeCopy :: forall a. Version a -> Name -> Name -> Q [Dec]
    deriveSafeCopy = DeriveType -> Version a -> Name -> Name -> Q [Dec]
    forall a. DeriveType -> Version a -> Name -> Name -> Q [Dec]
    internalDeriveSafeCopy DeriveType
    Normal

    deriveSafeCopyIndexedType :: Version a -> Name -> Name -> [Name] -> Q [Dec]
    deriveSafeCopyIndexedType :: forall a. Version a -> Name -> Name -> [Name] -> Q [Dec]
    deriveSafeCopyIndexedType = DeriveType -> Version a -> Name -> Name -> [Name] -> Q [Dec]
    forall a.
    DeriveType -> Version a -> Name -> Name -> [Name] -> Q [Dec]
    internalDeriveSafeCopyIndexedType DeriveType
    Normal

    -- | Derive an instance of 'SafeCopy'.  The instance derived by
    --   this function is simpler than the one derived by
    --   'deriveSafeCopy' in that we always use 'safePut' and
    --   'safeGet' (instead of 'getSafePut' and 'getSafeGet').
    --
    --   When serializing, we put a 'Word8' describing the
    --   constructor (if the data type has more than one constructor)
    --   and, for each field of the constructor, we use 'safePut'.
    --
    --   For example, given the data type and the declaration below
    --
    --   @
    --data T a b = C a a | D b Int
    --deriveSafeCopySimple 1 'base ''T
    --   @
    --
    --   we generate
    --
    --   @
    --instance (SafeCopy a, SafeCopy b) =>
    --         SafeCopy (T a b) where
    --    putCopy (C arg1 arg2) = contain $ do putWord8 0
    --                                         safePut arg1
    --                                         safePut arg2
    --                                         return ()
    --    putCopy (D arg1 arg2) = contain $ do putWord8 1
    --                                         safePut arg1
    --                                         safePut arg2
    --                                         return ()
    --    getCopy = contain $ do tag <- getWord8
    --                           case tag of
    --                             0 -> do return C \<*\> safeGet \<*\> safeGet
    --                             1 -> do return D \<*\> safeGet \<*\> safeGet
    --                             _ -> fail $ \"Could not identify tag \\\"\" ++
    --                                         show tag ++ \"\\\" for type Main.T \" ++
    --                                         \"that has only 2 constructors.  \" ++
    --                                         \"Maybe your data is corrupted?\"
    --    version = 1
    --    kind = base
    --   @
    --
    --   Using this simpler instance means that you may spend more
    --   bytes when serializing data.  On the other hand, it is more
    --   straightforward and may match any other format you used in
    --   the past.
    --
    --   Note that you may use 'deriveSafeCopy' with one version of
    --   your data type and 'deriveSafeCopySimple' in another version
    --   without any problems.
    deriveSafeCopySimple :: Version a -> Name -> Name -> Q [Dec]
    deriveSafeCopySimple :: forall a. Version a -> Name -> Name -> Q [Dec]
    deriveSafeCopySimple = DeriveType -> Version a -> Name -> Name -> Q [Dec]
    forall a. DeriveType -> Version a -> Name -> Name -> Q [Dec]
    internalDeriveSafeCopy DeriveType
    Simple

    deriveSafeCopySimpleIndexedType :: Version a -> Name -> Name -> [Name] -> Q [Dec]
    deriveSafeCopySimpleIndexedType :: forall a. Version a -> Name -> Name -> [Name] -> Q [Dec]
    deriveSafeCopySimpleIndexedType = DeriveType -> Version a -> Name -> Name -> [Name] -> Q [Dec]
    forall a.
    DeriveType -> Version a -> Name -> Name -> [Name] -> Q [Dec]
    internalDeriveSafeCopyIndexedType DeriveType
    Simple

    -- | Derive an instance of 'SafeCopy'.  The instance derived by
    --   this function should be compatible with the instance derived
    --   by the module @Happstack.Data.SerializeTH@ of the
    --   @happstack-data@ package.  The instances use only 'safePut'
    --   and 'safeGet' (as do the instances created by
    --   'deriveSafeCopySimple'), but we also always write a 'Word8'
    --   tag, even if the data type isn't a sum type.
    --
    --   For example, given the data type and the declaration below
    --
    --   @
    --data T0 b = T0 b Int
    --deriveSafeCopy 1 'base ''T0
    --   @
    --
    --   we generate
    --
    --   @
    --instance (SafeCopy a, SafeCopy b) =>
    --         SafeCopy (T0 b) where
    --    putCopy (T0 arg1 arg2) = contain $ do putWord8 0
    --                                          safePut arg1
    --                                          safePut arg2
    --                                          return ()
    --    getCopy = contain $ do tag <- getWord8
    --                           case tag of
    --                             0 -> do return T0 \<*\> safeGet \<*\> safeGet
    --                             _ -> fail $ \"Could not identify tag \\\"\" ++
    --                                         show tag ++ \"\\\" for type Main.T0 \" ++
    --                                         \"that has only 1 constructors.  \" ++
    --                                         \"Maybe your data is corrupted?\"
    --    version = 1
    --    kind = base
    --   @
    --
    --   This instance always consumes at least the same space as
    --   'deriveSafeCopy' or 'deriveSafeCopySimple', but may use more
    --   because of the useless tag.  So we recomend using it only if
    --   you really need to read a previous version in this format,
    --   and not for newer versions.
    --
    --   Note that you may use 'deriveSafeCopy' with one version of
    --   your data type and 'deriveSafeCopyHappstackData' in another version
    --   without any problems.
    deriveSafeCopyHappstackData :: Version a -> Name -> Name -> Q [Dec]
    deriveSafeCopyHappstackData :: forall a. Version a -> Name -> Name -> Q [Dec]
    deriveSafeCopyHappstackData = DeriveType -> Version a -> Name -> Name -> Q [Dec]
    forall a. DeriveType -> Version a -> Name -> Name -> Q [Dec]
    internalDeriveSafeCopy DeriveType
    HappstackData

    deriveSafeCopyHappstackDataIndexedType :: Version a -> Name -> Name -> [Name] -> Q [Dec]
    deriveSafeCopyHappstackDataIndexedType :: forall a. Version a -> Name -> Name -> [Name] -> Q [Dec]
    deriveSafeCopyHappstackDataIndexedType = DeriveType -> Version a -> Name -> Name -> [Name] -> Q [Dec]
    forall a.
    DeriveType -> Version a -> Name -> Name -> [Name] -> Q [Dec]
    internalDeriveSafeCopyIndexedType DeriveType
    HappstackData

    data DeriveType = Normal | Simple | HappstackData

    forceTag :: DeriveType -> Bool
    forceTag :: DeriveType -> Bool
    forceTag DeriveType
    HappstackData = Bool
    True
    forceTag DeriveType
    _             = Bool
    False

    #if MIN_VERSION_template_haskell(2,17,0)
    tyVarName :: TyVarBndr s -> Name
    tyVarName :: forall s. TyVarBndr s -> Name
    tyVarName (PlainTV Name
    n s
    _) = Name
    n
    tyVarName (KindedTV Name
    n s
    _ Kind
    _) = Name
    n
    #else
    tyVarName :: TyVarBndr -> Name
    tyVarName (PlainTV n) = n
    tyVarName (KindedTV n _) = n
    #endif

    internalDeriveSafeCopy :: DeriveType -> Version a -> Name -> Name -> Q [Dec]
    internalDeriveSafeCopy :: forall a. DeriveType -> Version a -> Name -> Name -> Q [Dec]
    internalDeriveSafeCopy DeriveType
    deriveType Version a
    versionId Name
    kindName Name
    tyName = do
      Info
    info <- Name -> Q Info
    reify Name
    tyName
      DeriveType -> Version a -> Name -> Name -> Info -> Q [Dec]
    forall a.
    DeriveType -> Version a -> Name -> Name -> Info -> Q [Dec]
    internalDeriveSafeCopy' DeriveType
    deriveType Version a
    versionId Name
    kindName Name
    tyName Info
    info

    internalDeriveSafeCopy' :: DeriveType -> Version a -> Name -> Name -> Info -> Q [Dec]
    internalDeriveSafeCopy' :: forall a.
    DeriveType -> Version a -> Name -> Name -> Info -> Q [Dec]
    internalDeriveSafeCopy' DeriveType
    deriveType Version a
    versionId Name
    kindName Name
    tyName Info
    info = do
      case Info
    info of
        TyConI (DataD Cxt
    context Name
    _name [TyVarBndr ()]
    tyvars Maybe Kind
    _kind [Con]
    cons [DerivClause]
    _derivs)
          | [Con] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Con]
    cons Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    255 -> String -> Q [Dec]
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Q [Dec]) -> String -> Q [Dec]
    forall a b. (a -> b) -> a -> b
    $ String
    "Can't derive SafeCopy instance for: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Name -> String
    forall a. Show a => a -> String
    show Name
    tyName String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                                        String
    ". The datatype must have less than 256 constructors."
          | Bool
    otherwise         -> Cxt -> [TyVarBndr ()] -> [(Integer, Con)] -> Q [Dec]
    forall {s}. Cxt -> [TyVarBndr s] -> [(Integer, Con)] -> Q [Dec]
    worker Cxt
    context [TyVarBndr ()]
    tyvars ([Integer] -> [Con] -> [(Integer, Con)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Integer
    0..] [Con]
    cons)

        TyConI (NewtypeD Cxt
    context Name
    _name [TyVarBndr ()]
    tyvars Maybe Kind
    _kind Con
    con [DerivClause]
    _derivs) ->
          Cxt -> [TyVarBndr ()] -> [(Integer, Con)] -> Q [Dec]
    forall {s}. Cxt -> [TyVarBndr s] -> [(Integer, Con)] -> Q [Dec]
    worker Cxt
    context [TyVarBndr ()]
    tyvars [(Integer
    0, Con
    con)]

        FamilyI Dec
    _ [Dec]
    insts -> do
          [[Dec]]
    decs <- [Dec] -> (Dec -> Q [Dec]) -> Q [[Dec]]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    t a -> (a -> m b) -> m (t b)
    forM [Dec]
    insts ((Dec -> Q [Dec]) -> Q [[Dec]]) -> (Dec -> Q [Dec]) -> Q [[Dec]]
    forall a b. (a -> b) -> a -> b
    $ \Dec
    inst ->
            case Dec
    inst of
    #if MIN_VERSION_template_haskell(2,15,0)
              DataInstD Cxt
    context Maybe [TyVarBndr ()]
    _ Kind
    nty Maybe Kind
    _kind [Con]
    cons [DerivClause]
    _derivs ->
                  Q Kind -> Cxt -> [TyVarBndr Any] -> [(Integer, Con)] -> Q [Dec]
    forall {s}.
    Q Kind -> Cxt -> [TyVarBndr s] -> [(Integer, Con)] -> Q [Dec]
    worker' (Kind -> Q Kind
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Kind
    nty) Cxt
    context [] ([Integer] -> [Con] -> [(Integer, Con)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Integer
    0..] [Con]
    cons)

              NewtypeInstD Cxt
    context Maybe [TyVarBndr ()]
    _ Kind
    nty Maybe Kind
    _kind Con
    con [DerivClause]
    _derivs ->
                  Q Kind -> Cxt -> [TyVarBndr Any] -> [(Integer, Con)] -> Q [Dec]
    forall {s}.
    Q Kind -> Cxt -> [TyVarBndr s] -> [(Integer, Con)] -> Q [Dec]
    worker' (Kind -> Q Kind
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Kind
    nty) Cxt
    context [] [(Integer
    0, Con
    con)]
    #else
              DataInstD context _name ty _kind cons _derivs ->
                  worker' (foldl appT (conT tyName) (map return ty)) context [] (zip [0..] cons)

              NewtypeInstD context _name ty _kind con _derivs ->
                  worker' (foldl appT (conT tyName) (map return ty)) context [] [(0, con)]
    #endif
              Dec
    _ -> String -> Q [Dec]
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Q [Dec]) -> String -> Q [Dec]
    forall a b. (a -> b) -> a -> b
    $ String
    "Can't derive SafeCopy instance for: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ (Name, Dec) -> String
    forall a. Show a => a -> String
    show (Name
    tyName, Dec
    inst)
          [Dec] -> Q [Dec]
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
    forall a b. (a -> b) -> a -> b
    $ [[Dec]] -> [Dec]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [[Dec]]
    decs
        Info
    _ -> String -> Q [Dec]
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Q [Dec]) -> String -> Q [Dec]
    forall a b. (a -> b) -> a -> b
    $ String
    "Can't derive SafeCopy instance for: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ (Name, Info) -> String
    forall a. Show a => a -> String
    show (Name
    tyName, Info
    info)
      where
        worker :: Cxt -> [TyVarBndr s] -> [(Integer, Con)] -> Q [Dec]
    worker = Q Kind -> Cxt -> [TyVarBndr s] -> [(Integer, Con)] -> Q [Dec]
    forall {s}.
    Q Kind -> Cxt -> [TyVarBndr s] -> [(Integer, Con)] -> Q [Dec]
    worker' (Name -> Q Kind
    forall (m :: * -> *). Quote m => Name -> m Kind
    conT Name
    tyName)
        worker' :: Q Kind -> Cxt -> [TyVarBndr s] -> [(Integer, Con)] -> Q [Dec]
    worker' Q Kind
    tyBase Cxt
    context [TyVarBndr s]
    tyvars [(Integer, Con)]
    cons =
          let ty :: Q Kind
    ty = (Q Kind -> Q Kind -> Q Kind) -> Q Kind -> [Q Kind] -> Q Kind
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl Q Kind -> Q Kind -> Q Kind
    forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
    appT Q Kind
    tyBase [ Name -> Q Kind
    forall (m :: * -> *). Quote m => Name -> m Kind
    varT (Name -> Q Kind) -> Name -> Q Kind
    forall a b. (a -> b) -> a -> b
    $ TyVarBndr s -> Name
    forall s. TyVarBndr s -> Name
    tyVarName TyVarBndr s
    var | TyVarBndr s
    var <- [TyVarBndr s]
    tyvars ]
              safeCopyClass :: t (m Kind) -> m Kind
    safeCopyClass t (m Kind)
    args = (m Kind -> m Kind -> m Kind) -> m Kind -> t (m Kind) -> m Kind
    forall b a. (b -> a -> b) -> b -> t a -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl m Kind -> m Kind -> m Kind
    forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
    appT (Name -> m Kind
    forall (m :: * -> *). Quote m => Name -> m Kind
    conT ''SafeCopy) t (m Kind)
    args
          in (Dec -> [Dec] -> [Dec]
    forall a. a -> [a] -> [a]
    :[]) (Dec -> [Dec]) -> Q Dec -> Q [Dec]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Q Cxt -> Q Kind -> [Q Dec] -> Q Dec
    forall (m :: * -> *).
    Quote m =>
    m Cxt -> m Kind -> [m Dec] -> m Dec
    instanceD ([Q Kind] -> Q Cxt
    forall (m :: * -> *). Quote m => [m Kind] -> m Cxt
    cxt ([Q Kind] -> Q Cxt) -> [Q Kind] -> Q Cxt
    forall a b. (a -> b) -> a -> b
    $ [[Q Kind] -> Q Kind
    forall {t :: * -> *} {m :: * -> *}.
    (Foldable t, Quote m) =>
    t (m Kind) -> m Kind
    safeCopyClass [Name -> Q Kind
    forall (m :: * -> *). Quote m => Name -> m Kind
    varT (Name -> Q Kind) -> Name -> Q Kind
    forall a b. (a -> b) -> a -> b
    $ TyVarBndr s -> Name
    forall s. TyVarBndr s -> Name
    tyVarName TyVarBndr s
    var] | TyVarBndr s
    var <- [TyVarBndr s]
    tyvars] [Q Kind] -> [Q Kind] -> [Q Kind]
    forall a. [a] -> [a] -> [a]
    ++ (Kind -> Q Kind) -> Cxt -> [Q Kind]
    forall a b. (a -> b) -> [a] -> [b]
    map Kind -> Q Kind
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Cxt
    context)
                                           (Name -> Q Kind
    forall (m :: * -> *). Quote m => Name -> m Kind
    conT ''SafeCopy Q Kind -> Q Kind -> Q Kind
    forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
    `appT` Q Kind
    ty)
                                           [ DeriveType -> [(Integer, Con)] -> Q Dec
    mkPutCopy DeriveType
    deriveType [(Integer, Con)]
    cons
                                           , DeriveType -> String -> [(Integer, Con)] -> Q Dec
    mkGetCopy DeriveType
    deriveType (Name -> String
    forall a. Show a => a -> String
    show Name
    tyName) [(Integer, Con)]
    cons
                                           , Q Pat -> Q Body -> [Q Dec] -> Q Dec
    forall (m :: * -> *).
    Quote m =>
    m Pat -> m Body -> [m Dec] -> m Dec
    valD (Name -> Q Pat
    forall (m :: * -> *). Quote m => Name -> m Pat
    varP 'version) (Q Exp -> Q Body
    forall (m :: * -> *). Quote m => m Exp -> m Body
    normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
    forall a b. (a -> b) -> a -> b
    $ Lit -> Q Exp
    forall (m :: * -> *). Quote m => Lit -> m Exp
    litE (Lit -> Q Exp) -> Lit -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Integer -> Lit
    integerL (Integer -> Lit) -> Integer -> Lit
    forall a b. (a -> b) -> a -> b
    $ Int32 -> Integer
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Int32 -> Integer) -> Int32 -> Integer
    forall a b. (a -> b) -> a -> b
    $ Version a -> Int32
    forall a. Version a -> Int32
    unVersion Version a
    versionId) []
                                           , Q Pat -> Q Body -> [Q Dec] -> Q Dec
    forall (m :: * -> *).
    Quote m =>
    m Pat -> m Body -> [m Dec] -> m Dec
    valD (Name -> Q Pat
    forall (m :: * -> *). Quote m => Name -> m Pat
    varP 'kind) (Q Exp -> Q Body
    forall (m :: * -> *). Quote m => m Exp -> m Body
    normalB (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    kindName)) []
                                           , Name -> [Q Clause] -> Q Dec
    forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
    funD 'errorTypeName [[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
    forall (m :: * -> *).
    Quote m =>
    [m Pat] -> m Body -> [m Dec] -> m Clause
    clause [Q Pat
    forall (m :: * -> *). Quote m => m Pat
    wildP] (Q Exp -> Q Body
    forall (m :: * -> *). Quote m => m Exp -> m Body
    normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
    forall a b. (a -> b) -> a -> b
    $ Lit -> Q Exp
    forall (m :: * -> *). Quote m => Lit -> m Exp
    litE (Lit -> Q Exp) -> Lit -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ String -> Lit
    StringL (Name -> String
    forall a. Show a => a -> String
    show Name
    tyName)) []]
                                           ]

    internalDeriveSafeCopyIndexedType :: DeriveType -> Version a -> Name -> Name -> [Name] -> Q [Dec]
    internalDeriveSafeCopyIndexedType :: forall a.
    DeriveType -> Version a -> Name -> Name -> [Name] -> Q [Dec]
    internalDeriveSafeCopyIndexedType DeriveType
    deriveType Version a
    versionId Name
    kindName Name
    tyName [Name]
    tyIndex' = do
      Info
    info <- Name -> Q Info
    reify Name
    tyName
      DeriveType
    -> Version a -> Name -> Name -> [Name] -> Info -> Q [Dec]
    forall a.
    DeriveType
    -> Version a -> Name -> Name -> [Name] -> Info -> Q [Dec]
    internalDeriveSafeCopyIndexedType' DeriveType
    deriveType Version a
    versionId Name
    kindName Name
    tyName [Name]
    tyIndex' Info
    info

    internalDeriveSafeCopyIndexedType' :: DeriveType -> Version a -> Name -> Name -> [Name] -> Info -> Q [Dec]
    internalDeriveSafeCopyIndexedType' :: forall a.
    DeriveType
    -> Version a -> Name -> Name -> [Name] -> Info -> Q [Dec]
    internalDeriveSafeCopyIndexedType' DeriveType
    deriveType Version a
    versionId Name
    kindName Name
    tyName [Name]
    tyIndex' Info
    info = do
      Cxt
    tyIndex <- (Name -> Q Kind) -> [Name] -> Q Cxt
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM Name -> Q Kind
    forall (m :: * -> *). Quote m => Name -> m Kind
    conT [Name]
    tyIndex'
      case Info
    info of
        FamilyI Dec
    _ [Dec]
    insts -> do
          [[Dec]]
    decs <- [Dec] -> (Dec -> Q [Dec]) -> Q [[Dec]]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    t a -> (a -> m b) -> m (t b)
    forM [Dec]
    insts ((Dec -> Q [Dec]) -> Q [[Dec]]) -> (Dec -> Q [Dec]) -> Q [[Dec]]
    forall a b. (a -> b) -> a -> b
    $ \Dec
    inst ->
            case Dec
    inst of
    #if MIN_VERSION_template_haskell(2,15,0)
              DataInstD Cxt
    context Maybe [TyVarBndr ()]
    _ Kind
    nty Maybe Kind
    _kind [Con]
    cons [DerivClause]
    _derivs
                | Kind
    nty Kind -> Kind -> Bool
    forall a. Eq a => a -> a -> Bool
    == (Kind -> Kind -> Kind) -> Kind -> Cxt -> Kind
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl Kind -> Kind -> Kind
    AppT (Name -> Kind
    ConT Name
    tyName) Cxt
    tyIndex ->
                  Q Kind -> Cxt -> [TyVarBndr Any] -> [(Integer, Con)] -> Q [Dec]
    forall {s}.
    Q Kind -> Cxt -> [TyVarBndr s] -> [(Integer, Con)] -> Q [Dec]
    worker' (Kind -> Q Kind
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Kind
    nty) Cxt
    context [] ([Integer] -> [Con] -> [(Integer, Con)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Integer
    0..] [Con]
    cons)
    #else
              DataInstD context _name ty _kind cons _derivs
                | ty == tyIndex ->
                  worker' (foldl appT (conT tyName) (map return ty)) context [] (zip [0..] cons)
    #endif
                | Bool
    otherwise ->
                  [Dec] -> Q [Dec]
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []

    #if MIN_VERSION_template_haskell(2,15,0)
              NewtypeInstD Cxt
    context Maybe [TyVarBndr ()]
    _ Kind
    nty Maybe Kind
    _kind Con
    con [DerivClause]
    _derivs
                | Kind
    nty Kind -> Kind -> Bool
    forall a. Eq a => a -> a -> Bool
    == (Kind -> Kind -> Kind) -> Kind -> Cxt -> Kind
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl Kind -> Kind -> Kind
    AppT (Name -> Kind
    ConT Name
    tyName) Cxt
    tyIndex ->
                  Q Kind -> Cxt -> [TyVarBndr Any] -> [(Integer, Con)] -> Q [Dec]
    forall {s}.
    Q Kind -> Cxt -> [TyVarBndr s] -> [(Integer, Con)] -> Q [Dec]
    worker' (Kind -> Q Kind
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Kind
    nty) Cxt
    context [] [(Integer
    0, Con
    con)]
    #else
              NewtypeInstD context _name ty _kind con _derivs
                | ty == tyIndex ->
                  worker' (foldl appT (conT tyName) (map return ty)) context [] [(0, con)]
    #endif
                | Bool
    otherwise ->
                  [Dec] -> Q [Dec]
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
              Dec
    _ -> String -> Q [Dec]
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Q [Dec]) -> String -> Q [Dec]
    forall a b. (a -> b) -> a -> b
    $ String
    "Can't derive SafeCopy instance for: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ (Name, Dec) -> String
    forall a. Show a => a -> String
    show (Name
    tyName, Dec
    inst)
          [Dec] -> Q [Dec]
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
    forall a b. (a -> b) -> a -> b
    $ [[Dec]] -> [Dec]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [[Dec]]
    decs
        Info
    _ -> String -> Q [Dec]
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Q [Dec]) -> String -> Q [Dec]
    forall a b. (a -> b) -> a -> b
    $ String
    "Can't derive SafeCopy instance for: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ (Name, Info) -> String
    forall a. Show a => a -> String
    show (Name
    tyName, Info
    info)
      where
        typeNameStr :: String
    typeNameStr = [String] -> String
    unwords ([String] -> String) -> [String] -> String
    forall a b. (a -> b) -> a -> b
    $ (Name -> String) -> [Name] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> String
    forall a. Show a => a -> String
    show (Name
    tyNameName -> [Name] -> [Name]
    forall a. a -> [a] -> [a]
    :[Name]
    tyIndex')
        worker' :: Q Kind -> Cxt -> [TyVarBndr s] -> [(Integer, Con)] -> Q [Dec]
    worker' Q Kind
    tyBase Cxt
    context [TyVarBndr s]
    tyvars [(Integer, Con)]
    cons =
          let ty :: Q Kind
    ty = (Q Kind -> Q Kind -> Q Kind) -> Q Kind -> [Q Kind] -> Q Kind
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl Q Kind -> Q Kind -> Q Kind
    forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
    appT Q Kind
    tyBase [ Name -> Q Kind
    forall (m :: * -> *). Quote m => Name -> m Kind
    varT (Name -> Q Kind) -> Name -> Q Kind
    forall a b. (a -> b) -> a -> b
    $ TyVarBndr s -> Name
    forall s. TyVarBndr s -> Name
    tyVarName TyVarBndr s
    var | TyVarBndr s
    var <- [TyVarBndr s]
    tyvars ]
              safeCopyClass :: t (m Kind) -> m Kind
    safeCopyClass t (m Kind)
    args = (m Kind -> m Kind -> m Kind) -> m Kind -> t (m Kind) -> m Kind
    forall b a. (b -> a -> b) -> b -> t a -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl m Kind -> m Kind -> m Kind
    forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
    appT (Name -> m Kind
    forall (m :: * -> *). Quote m => Name -> m Kind
    conT ''SafeCopy) t (m Kind)
    args
          in (Dec -> [Dec] -> [Dec]
    forall a. a -> [a] -> [a]
    :[]) (Dec -> [Dec]) -> Q Dec -> Q [Dec]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Q Cxt -> Q Kind -> [Q Dec] -> Q Dec
    forall (m :: * -> *).
    Quote m =>
    m Cxt -> m Kind -> [m Dec] -> m Dec
    instanceD ([Q Kind] -> Q Cxt
    forall (m :: * -> *). Quote m => [m Kind] -> m Cxt
    cxt ([Q Kind] -> Q Cxt) -> [Q Kind] -> Q Cxt
    forall a b. (a -> b) -> a -> b
    $ [[Q Kind] -> Q Kind
    forall {t :: * -> *} {m :: * -> *}.
    (Foldable t, Quote m) =>
    t (m Kind) -> m Kind
    safeCopyClass [Name -> Q Kind
    forall (m :: * -> *). Quote m => Name -> m Kind
    varT (Name -> Q Kind) -> Name -> Q Kind
    forall a b. (a -> b) -> a -> b
    $ TyVarBndr s -> Name
    forall s. TyVarBndr s -> Name
    tyVarName TyVarBndr s
    var] | TyVarBndr s
    var <- [TyVarBndr s]
    tyvars] [Q Kind] -> [Q Kind] -> [Q Kind]
    forall a. [a] -> [a] -> [a]
    ++ (Kind -> Q Kind) -> Cxt -> [Q Kind]
    forall a b. (a -> b) -> [a] -> [b]
    map Kind -> Q Kind
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Cxt
    context)
                                           (Name -> Q Kind
    forall (m :: * -> *). Quote m => Name -> m Kind
    conT ''SafeCopy Q Kind -> Q Kind -> Q Kind
    forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
    `appT` Q Kind
    ty)
                                           [ DeriveType -> [(Integer, Con)] -> Q Dec
    mkPutCopy DeriveType
    deriveType [(Integer, Con)]
    cons
                                           , DeriveType -> String -> [(Integer, Con)] -> Q Dec
    mkGetCopy DeriveType
    deriveType String
    typeNameStr [(Integer, Con)]
    cons
                                           , Q Pat -> Q Body -> [Q Dec] -> Q Dec
    forall (m :: * -> *).
    Quote m =>
    m Pat -> m Body -> [m Dec] -> m Dec
    valD (Name -> Q Pat
    forall (m :: * -> *). Quote m => Name -> m Pat
    varP 'version) (Q Exp -> Q Body
    forall (m :: * -> *). Quote m => m Exp -> m Body
    normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
    forall a b. (a -> b) -> a -> b
    $ Lit -> Q Exp
    forall (m :: * -> *). Quote m => Lit -> m Exp
    litE (Lit -> Q Exp) -> Lit -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Integer -> Lit
    integerL (Integer -> Lit) -> Integer -> Lit
    forall a b. (a -> b) -> a -> b
    $ Int32 -> Integer
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Int32 -> Integer) -> Int32 -> Integer
    forall a b. (a -> b) -> a -> b
    $ Version a -> Int32
    forall a. Version a -> Int32
    unVersion Version a
    versionId) []
                                           , Q Pat -> Q Body -> [Q Dec] -> Q Dec
    forall (m :: * -> *).
    Quote m =>
    m Pat -> m Body -> [m Dec] -> m Dec
    valD (Name -> Q Pat
    forall (m :: * -> *). Quote m => Name -> m Pat
    varP 'kind) (Q Exp -> Q Body
    forall (m :: * -> *). Quote m => m Exp -> m Body
    normalB (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    kindName)) []
                                           , Name -> [Q Clause] -> Q Dec
    forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
    funD 'errorTypeName [[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
    forall (m :: * -> *).
    Quote m =>
    [m Pat] -> m Body -> [m Dec] -> m Clause
    clause [Q Pat
    forall (m :: * -> *). Quote m => m Pat
    wildP] (Q Exp -> Q Body
    forall (m :: * -> *). Quote m => m Exp -> m Body
    normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
    forall a b. (a -> b) -> a -> b
    $ Lit -> Q Exp
    forall (m :: * -> *). Quote m => Lit -> m Exp
    litE (Lit -> Q Exp) -> Lit -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ String -> Lit
    StringL String
    typeNameStr) []]
                                           ]

    mkPutCopy :: DeriveType -> [(Integer, Con)] -> DecQ
    mkPutCopy :: DeriveType -> [(Integer, Con)] -> Q Dec
    mkPutCopy DeriveType
    deriveType [(Integer, Con)]
    cons = Name -> [Q Clause] -> Q Dec
    forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
    funD 'putCopy ([Q Clause] -> Q Dec) -> [Q Clause] -> Q Dec
    forall a b. (a -> b) -> a -> b
    $ ((Integer, Con) -> Q Clause) -> [(Integer, Con)] -> [Q Clause]
    forall a b. (a -> b) -> [a] -> [b]
    map (Integer, Con) -> Q Clause
    mkPutClause [(Integer, Con)]
    cons
        where
          manyConstructors :: Bool
    manyConstructors = [(Integer, Con)] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [(Integer, Con)]
    cons Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    1 Bool -> Bool -> Bool
    || DeriveType -> Bool
    forceTag DeriveType
    deriveType
          mkPutClause :: (Integer, Con) -> Q Clause
    mkPutClause (Integer
    conNumber, Con
    con)
              = do [Name]
    putVars <- (Int -> Q Name) -> [Int] -> Q [Name]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM (\Int
    n -> String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName (String
    "a" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    n)) [Int
    1..Con -> Int
    conSize Con
    con]
                   ([StmtQ]
    putFunsDecs, Kind -> Name
    putFuns) <- case DeriveType
    deriveType of
                                               DeriveType
    Normal -> String -> Name -> Con -> Q ([StmtQ], Kind -> Name)
    mkSafeFunctions String
    "safePut_" 'getSafePut Con
    con
                                               DeriveType
    _      -> ([StmtQ], Kind -> Name) -> Q ([StmtQ], Kind -> Name)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([], Name -> Kind -> Name
    forall a b. a -> b -> a
    const 'safePut)
                   let putClause :: Q Pat
    putClause   = Name -> [Q Pat] -> Q Pat
    forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
    conP (Con -> Name
    conName Con
    con) ((Name -> Q Pat) -> [Name] -> [Q Pat]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Q Pat
    forall (m :: * -> *). Quote m => Name -> m Pat
    varP [Name]
    putVars)
                       putCopyBody :: Q Exp
    putCopyBody = Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE 'contain Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE` [StmtQ] -> Q Exp
    forall (m :: * -> *). Quote m => [m Stmt] -> m Exp
    doE (
                                       [ Q Exp -> StmtQ
    forall (m :: * -> *). Quote m => m Exp -> m Stmt
    noBindS (Q Exp -> StmtQ) -> Q Exp -> StmtQ
    forall a b. (a -> b) -> a -> b
    $ Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE 'putWord8 Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE` Lit -> Q Exp
    forall (m :: * -> *). Quote m => Lit -> m Exp
    litE (Integer -> Lit
    IntegerL Integer
    conNumber) | Bool
    manyConstructors ] [StmtQ] -> [StmtQ] -> [StmtQ]
    forall a. [a] -> [a] -> [a]
    ++
                                       [StmtQ]
    putFunsDecs [StmtQ] -> [StmtQ] -> [StmtQ]
    forall a. [a] -> [a] -> [a]
    ++
                                       [ Q Exp -> StmtQ
    forall (m :: * -> *). Quote m => m Exp -> m Stmt
    noBindS (Q Exp -> StmtQ) -> Q Exp -> StmtQ
    forall a b. (a -> b) -> a -> b
    $ Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE (Kind -> Name
    putFuns Kind
    typ) Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE` Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    var | (Kind
    typ, Name
    var) <- Cxt -> [Name] -> [(Kind, Name)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip (Con -> Cxt
    conTypes Con
    con) [Name]
    putVars ] [StmtQ] -> [StmtQ] -> [StmtQ]
    forall a. [a] -> [a] -> [a]
    ++
                                       [ Q Exp -> StmtQ
    forall (m :: * -> *). Quote m => m Exp -> m Stmt
    noBindS (Q Exp -> StmtQ) -> Q Exp -> StmtQ
    forall a b. (a -> b) -> a -> b
    $ Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE 'return Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE` [Q Exp] -> Q Exp
    forall (m :: * -> *). Quote m => [m Exp] -> m Exp
    tupE [] ])
                   [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
    forall (m :: * -> *).
    Quote m =>
    [m Pat] -> m Body -> [m Dec] -> m Clause
    clause [Q Pat
    putClause] (Q Exp -> Q Body
    forall (m :: * -> *). Quote m => m Exp -> m Body
    normalB Q Exp
    putCopyBody) []

    mkGetCopy :: DeriveType -> String -> [(Integer, Con)] -> DecQ
    mkGetCopy :: DeriveType -> String -> [(Integer, Con)] -> Q Dec
    mkGetCopy DeriveType
    deriveType String
    tyName [(Integer, Con)]
    cons = Q Pat -> Q Body -> [Q Dec] -> Q Dec
    forall (m :: * -> *).
    Quote m =>
    m Pat -> m Body -> [m Dec] -> m Dec
    valD (Name -> Q Pat
    forall (m :: * -> *). Quote m => Name -> m Pat
    varP 'getCopy) (Q Exp -> Q Body
    forall (m :: * -> *). Quote m => m Exp -> m Body
    normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
    forall a b. (a -> b) -> a -> b
    $ Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE 'contain Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE` Q Exp
    mkLabel) []
        where
          mkLabel :: Q Exp
    mkLabel = Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE 'label Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE` Lit -> Q Exp
    forall (m :: * -> *). Quote m => Lit -> m Exp
    litE (String -> Lit
    stringL String
    labelString) Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE` Q Exp
    getCopyBody
          labelString :: String
    labelString = String
    tyName String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ":"
          getCopyBody :: Q Exp
    getCopyBody
              = case [(Integer, Con)]
    cons of
                  [(Integer
    _, Con
    con)] | Bool -> Bool
    not (DeriveType -> Bool
    forceTag DeriveType
    deriveType) -> Con -> Q Exp
    mkGetBody Con
    con
                  [(Integer, Con)]
    _ -> do
                    Name
    tagVar <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "tag"
                    [StmtQ] -> Q Exp
    forall (m :: * -> *). Quote m => [m Stmt] -> m Exp
    doE [ Q Pat -> Q Exp -> StmtQ
    forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Stmt
    bindS (Name -> Q Pat
    forall (m :: * -> *). Quote m => Name -> m Pat
    varP Name
    tagVar) (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE 'getWord8)
                        , Q Exp -> StmtQ
    forall (m :: * -> *). Quote m => m Exp -> m Stmt
    noBindS (Q Exp -> StmtQ) -> Q Exp -> StmtQ
    forall a b. (a -> b) -> a -> b
    $ Q Exp -> [Q Match] -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
    caseE (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    tagVar) (
                            [ Q Pat -> Q Body -> [Q Dec] -> Q Match
    forall (m :: * -> *).
    Quote m =>
    m Pat -> m Body -> [m Dec] -> m Match
    match (Lit -> Q Pat
    forall (m :: * -> *). Quote m => Lit -> m Pat
    litP (Lit -> Q Pat) -> Lit -> Q Pat
    forall a b. (a -> b) -> a -> b
    $ Integer -> Lit
    IntegerL Integer
    i) (Q Exp -> Q Body
    forall (m :: * -> *). Quote m => m Exp -> m Body
    normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
    forall a b. (a -> b) -> a -> b
    $ Con -> Q Exp
    mkGetBody Con
    con) [] | (Integer
    i, Con
    con) <- [(Integer, Con)]
    cons ] [Q Match] -> [Q Match] -> [Q Match]
    forall a. [a] -> [a] -> [a]
    ++
                            [ Q Pat -> Q Body -> [Q Dec] -> Q Match
    forall (m :: * -> *).
    Quote m =>
    m Pat -> m Body -> [m Dec] -> m Match
    match Q Pat
    forall (m :: * -> *). Quote m => m Pat
    wildP (Q Exp -> Q Body
    forall (m :: * -> *). Quote m => m Exp -> m Body
    normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
    forall a b. (a -> b) -> a -> b
    $ Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE 'fail Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE` Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    errorMsg Name
    tagVar) [] ]) ]
          mkGetBody :: Con -> Q Exp
    mkGetBody Con
    con
              = do ([StmtQ]
    getFunsDecs, Kind -> Name
    getFuns) <- case DeriveType
    deriveType of
                                               DeriveType
    Normal -> String -> Name -> Con -> Q ([StmtQ], Kind -> Name)
    mkSafeFunctions String
    "safeGet_" 'getSafeGet Con
    con
                                               DeriveType
    _      -> ([StmtQ], Kind -> Name) -> Q ([StmtQ], Kind -> Name)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([], Name -> Kind -> Name
    forall a b. a -> b -> a
    const 'safeGet)
                   let getBase :: Q Exp
    getBase = Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    appE (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE 'return) (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    conE (Con -> Name
    conName Con
    con))
                       getArgs :: Q Exp
    getArgs = (Q Exp -> Kind -> Q Exp) -> Q Exp -> Cxt -> Q Exp
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl (\Q Exp
    a Kind
    t -> Maybe (Q Exp) -> Q Exp -> Maybe (Q Exp) -> Q Exp
    forall (m :: * -> *).
    Quote m =>
    Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
    infixE (Q Exp -> Maybe (Q Exp)
    forall a. a -> Maybe a
    Just Q Exp
    a) (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE '(<*>)) (Q Exp -> Maybe (Q Exp)
    forall a. a -> Maybe a
    Just (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE (Kind -> Name
    getFuns Kind
    t)))) Q Exp
    getBase (Con -> Cxt
    conTypes Con
    con)
                   [StmtQ] -> Q Exp
    forall (m :: * -> *). Quote m => [m Stmt] -> m Exp
    doE ([StmtQ]
    getFunsDecs [StmtQ] -> [StmtQ] -> [StmtQ]
    forall a. [a] -> [a] -> [a]
    ++ [Q Exp -> StmtQ
    forall (m :: * -> *). Quote m => m Exp -> m Stmt
    noBindS Q Exp
    getArgs])
          errorMsg :: Name -> m Exp
    errorMsg Name
    tagVar = Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
    forall (m :: * -> *).
    Quote m =>
    Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
    infixE (m Exp -> Maybe (m Exp)
    forall a. a -> Maybe a
    Just (m Exp -> Maybe (m Exp)) -> m Exp -> Maybe (m Exp)
    forall a b. (a -> b) -> a -> b
    $ String -> m Exp
    strE String
    str1) (Name -> m Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE '(++)) (Maybe (m Exp) -> m Exp) -> Maybe (m Exp) -> m Exp
    forall a b. (a -> b) -> a -> b
    $ m Exp -> Maybe (m Exp)
    forall a. a -> Maybe a
    Just (m Exp -> Maybe (m Exp)) -> m Exp -> Maybe (m Exp)
    forall a b. (a -> b) -> a -> b
    $
                            Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
    forall (m :: * -> *).
    Quote m =>
    Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
    infixE (m Exp -> Maybe (m Exp)
    forall a. a -> Maybe a
    Just m Exp
    tagStr) (Name -> m Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE '(++)) (m Exp -> Maybe (m Exp)
    forall a. a -> Maybe a
    Just (m Exp -> Maybe (m Exp)) -> m Exp -> Maybe (m Exp)
    forall a b. (a -> b) -> a -> b
    $ String -> m Exp
    strE String
    str2)
              where
                strE :: String -> m Exp
    strE = Lit -> m Exp
    forall (m :: * -> *). Quote m => Lit -> m Exp
    litE (Lit -> m Exp) -> (String -> Lit) -> String -> m Exp
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Lit
    StringL
                tagStr :: m Exp
    tagStr = Name -> m Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE 'show m Exp -> m Exp -> m Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE` Name -> m Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    tagVar
                str1 :: String
    str1 = String
    "Could not identify tag \""
                str2 :: String
    str2 = [String] -> String
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [ String
    "\" for type "
                              , String -> String
    forall a. Show a => a -> String
    show String
    tyName
                              , String
    " that has only "
                              , Int -> String
    forall a. Show a => a -> String
    show ([(Integer, Con)] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [(Integer, Con)]
    cons)
                              , String
    " constructors.  Maybe your data is corrupted?" ]

    mkSafeFunctions :: String -> Name -> Con -> Q ([StmtQ], Type -> Name)
    mkSafeFunctions :: String -> Name -> Con -> Q ([StmtQ], Kind -> Name)
    mkSafeFunctions String
    name Name
    baseFun Con
    con = do let origTypes :: Cxt
    origTypes = Con -> Cxt
    conTypes Con
    con
                                          Cxt
    realTypes <- (Kind -> Q Kind) -> Cxt -> Q Cxt
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM Kind -> Q Kind
    followSynonyms Cxt
    origTypes
                                          [(Kind, Kind)]
    -> ([StmtQ], [(Kind, Name)]) -> ([StmtQ], Kind -> Name)
    finish (Cxt -> Cxt -> [(Kind, Kind)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip Cxt
    origTypes Cxt
    realTypes) (([StmtQ], [(Kind, Name)]) -> ([StmtQ], Kind -> Name))
    -> Q ([StmtQ], [(Kind, Name)]) -> Q ([StmtQ], Kind -> Name)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (([StmtQ], [(Kind, Name)]) -> Kind -> Q ([StmtQ], [(Kind, Name)]))
    -> ([StmtQ], [(Kind, Name)]) -> Cxt -> Q ([StmtQ], [(Kind, Name)])
    forall (t :: * -> *) (m :: * -> *) b a.
    (Foldable t, Monad m) =>
    (b -> a -> m b) -> b -> t a -> m b
    foldM ([StmtQ], [(Kind, Name)]) -> Kind -> Q ([StmtQ], [(Kind, Name)])
    forall {m :: * -> *} {m :: * -> *}.
    (Quote m, Quote m) =>
    ([m Stmt], [(Kind, Name)]) -> Kind -> m ([m Stmt], [(Kind, Name)])
    go ([], []) Cxt
    realTypes
        where go :: ([m Stmt], [(Kind, Name)]) -> Kind -> m ([m Stmt], [(Kind, Name)])
    go ([m Stmt]
    ds, [(Kind, Name)]
    fs) Kind
    t
                  | Bool
    found     = ([m Stmt], [(Kind, Name)]) -> m ([m Stmt], [(Kind, Name)])
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([m Stmt]
    ds, [(Kind, Name)]
    fs)
                  | Bool
    otherwise = do Name
    funVar <- String -> m Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName (String
    name String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Kind -> String
    typeName Kind
    t)
                                   ([m Stmt], [(Kind, Name)]) -> m ([m Stmt], [(Kind, Name)])
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ( m Pat -> m Exp -> m Stmt
    forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Stmt
    bindS (Name -> m Pat
    forall (m :: * -> *). Quote m => Name -> m Pat
    varP Name
    funVar) (Name -> m Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    baseFun) m Stmt -> [m Stmt] -> [m Stmt]
    forall a. a -> [a] -> [a]
    : [m Stmt]
    ds
                                          , (Kind
    t, Name
    funVar) (Kind, Name) -> [(Kind, Name)] -> [(Kind, Name)]
    forall a. a -> [a] -> [a]
    : [(Kind, Name)]
    fs )
                  where found :: Bool
    found = ((Kind, Name) -> Bool) -> [(Kind, Name)] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any ((Kind -> Kind -> Bool
    forall a. Eq a => a -> a -> Bool
    == Kind
    t) (Kind -> Bool) -> ((Kind, Name) -> Kind) -> (Kind, Name) -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Kind, Name) -> Kind
    forall a b. (a, b) -> a
    fst) [(Kind, Name)]
    fs
              finish
                :: [(Type, Type)]            -- "dictionary" from synonyms(or not) to real types
                -> ([StmtQ], [(Type, Name)]) -- statements
                -> ([StmtQ], Type -> Name)   -- function body and name-generator
              finish :: [(Kind, Kind)]
    -> ([StmtQ], [(Kind, Name)]) -> ([StmtQ], Kind -> Name)
    finish [(Kind, Kind)]
    typeList ([StmtQ]
    ds, [(Kind, Name)]
    fs) = ([StmtQ] -> [StmtQ]
    forall a. [a] -> [a]
    reverse [StmtQ]
    ds, Kind -> Name
    getName)
                  where getName :: Kind -> Name
    getName Kind
    typ = Name -> Maybe Name -> Name
    forall a. a -> Maybe a -> a
    fromMaybe Name
    forall {a}. a
    err (Maybe Name -> Name) -> Maybe Name -> Name
    forall a b. (a -> b) -> a -> b
    $ Kind -> [(Kind, Kind)] -> Maybe Kind
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup Kind
    typ [(Kind, Kind)]
    typeList Maybe Kind -> (Kind -> Maybe Name) -> Maybe Name
    forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= (Kind -> [(Kind, Name)] -> Maybe Name)
    -> [(Kind, Name)] -> Kind -> Maybe Name
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip Kind -> [(Kind, Name)] -> Maybe Name
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup [(Kind, Name)]
    fs
                        err :: a
    err = String -> a
    forall a. HasCallStack => String -> a
    error String
    "mkSafeFunctions: never here"

    -- | Follow type synonyms.  This allows us to see, for example,
    -- that @[Char]@ and @String@ are the same type and we just need
    -- to call 'getSafePut' or 'getSafeGet' once for both.
    followSynonyms :: Type -> Q Type
    followSynonyms :: Kind -> Q Kind
    followSynonyms t :: Kind
    t@(ConT Name
    name)
        = Q Kind -> (Kind -> Q Kind) -> Maybe Kind -> Q Kind
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe (Kind -> Q Kind
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Kind
    t) Kind -> Q Kind
    followSynonyms (Maybe Kind -> Q Kind) -> Q (Maybe Kind) -> Q Kind
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<<
          Q (Maybe Kind) -> Q (Maybe Kind) -> Q (Maybe Kind)
    forall a. Q a -> Q a -> Q a
    recover (Maybe Kind -> Q (Maybe Kind)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe Kind
    forall a. Maybe a
    Nothing) (do Info
    info <- Name -> Q Info
    reify Name
    name
                                       Maybe Kind -> Q (Maybe Kind)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe Kind -> Q (Maybe Kind)) -> Maybe Kind -> Q (Maybe Kind)
    forall a b. (a -> b) -> a -> b
    $ case Info
    info of
                                                  TyVarI Name
    _ Kind
    ty            -> Kind -> Maybe Kind
    forall a. a -> Maybe a
    Just Kind
    ty
                                                  TyConI (TySynD Name
    _ [TyVarBndr ()]
    _ Kind
    ty) -> Kind -> Maybe Kind
    forall a. a -> Maybe a
    Just Kind
    ty
                                                  Info
    _                      -> Maybe Kind
    forall a. Maybe a
    Nothing)
    followSynonyms (AppT Kind
    ty1 Kind
    ty2) = (Kind -> Kind -> Kind) -> Q Kind -> Q Kind -> Q Kind
    forall (m :: * -> *) a1 a2 r.
    Monad m =>
    (a1 -> a2 -> r) -> m a1 -> m a2 -> m r
    liftM2 Kind -> Kind -> Kind
    AppT (Kind -> Q Kind
    followSynonyms Kind
    ty1) (Kind -> Q Kind
    followSynonyms Kind
    ty2)
    followSynonyms (SigT Kind
    ty Kind
    k)    = (Kind -> Kind) -> Q Kind -> Q Kind
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    liftM ((Kind -> Kind -> Kind) -> Kind -> Kind -> Kind
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip Kind -> Kind -> Kind
    SigT Kind
    k) (Kind -> Q Kind
    followSynonyms Kind
    ty)
    followSynonyms Kind
    t              = Kind -> Q Kind
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Kind
    t

    conSize :: Con -> Int
    conSize :: Con -> Int
    conSize (NormalC Name
    _name [BangType]
    args) = [BangType] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [BangType]
    args
    conSize (RecC Name
    _name [VarBangType]
    recs)    = [VarBangType] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [VarBangType]
    recs
    conSize InfixC{}             = Int
    2
    conSize ForallC{}            = String -> Int
    forall a. HasCallStack => String -> a
    error String
    "Found constructor with existentially quantified binder. Cannot derive SafeCopy for it."
    conSize GadtC{}              = String -> Int
    forall a. HasCallStack => String -> a
    error String
    "Found GADT constructor. Cannot derive SafeCopy for it."
    conSize RecGadtC{}           = String -> Int
    forall a. HasCallStack => String -> a
    error String
    "Found GADT constructor. Cannot derive SafeCopy for it."

    conName :: Con -> Name
    conName :: Con -> Name
    conName (NormalC Name
    name [BangType]
    _args) = Name
    name
    conName (RecC Name
    name [VarBangType]
    _recs)    = Name
    name
    conName (InfixC BangType
    _ Name
    name BangType
    _)    = Name
    name
    conName Con
    _                    = String -> Name
    forall a. HasCallStack => String -> a
    error String
    "conName: never here"

    conTypes :: Con -> [Type]
    conTypes :: Con -> Cxt
    conTypes (NormalC Name
    _name [BangType]
    args)       = [Kind
    t | (Bang
    _, Kind
    t)    <- [BangType]
    args]
    conTypes (RecC Name
    _name [VarBangType]
    args)          = [Kind
    t | (Name
    _, Bang
    _, Kind
    t) <- [VarBangType]
    args]
    conTypes (InfixC (Bang
    _, Kind
    t1) Name
    _ (Bang
    _, Kind
    t2)) = [Kind
    t1, Kind
    t2]
    conTypes Con
    _                          = String -> Cxt
    forall a. HasCallStack => String -> a
    error String
    "conName: never here"

    typeName :: Type -> String
    typeName :: Kind -> String
    typeName (VarT Name
    name) = Name -> String
    nameBase Name
    name
    typeName (ConT Name
    name) = Name -> String
    nameBase Name
    name
    typeName (TupleT Int
    n)  = String
    "Tuple" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    n
    typeName Kind
    ArrowT      = String
    "Arrow"
    typeName Kind
    ListT       = String
    "List"
    typeName (AppT Kind
    t Kind
    u)  = Kind -> String
    typeName Kind
    t String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Kind -> String
    typeName Kind
    u
    typeName (SigT Kind
    t Kind
    _k) = Kind -> String
    typeName Kind
    t
    typeName Kind
    _           = String
    "_"