{-# LANGUAGE TemplateHaskell, CPP #-}

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 <- Name -> Q Info
reify Name
tyName
  internalDeriveSafeCopy' deriveType versionId kindName tyName 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 BndrVis]
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. HasCallStack => String -> Q a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
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 BndrVis] -> [(Integer, Con)] -> Q [Dec]
forall {s}. Cxt -> [TyVarBndr s] -> [(Integer, Con)] -> Q [Dec]
worker Cxt
context [TyVarBndr BndrVis]
tyvars ([Integer] -> [Con] -> [(Integer, Con)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0..] [Con]
cons)

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

    FamilyI Dec
_ [Dec]
insts -> do
      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 (ZonkAny 0)] -> [(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 (ZonkAny 1)] -> [(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. HasCallStack => String -> Q a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
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)
      return $ concat decs
    Info
_ -> String -> Q [Dec]
forall a. HasCallStack => String -> Q a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
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 <- Name -> Q Info
reify Name
tyName
  internalDeriveSafeCopyIndexedType' deriveType versionId kindName tyName tyIndex' 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
  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 of
    FamilyI Dec
_ [Dec]
insts -> do
      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 (ZonkAny 2)] -> [(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 (ZonkAny 3)] -> [(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. HasCallStack => String -> Q a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
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)
      return $ concat decs
    Info
_ -> String -> Q [Dec]
forall a. HasCallStack => String -> Q a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
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 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]
               (putFunsDecs, putFuns) <- case 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   = 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 = 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 [] ])
               clause [putClause] (normalB 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
                tagVar <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"tag"
                doE [ bindS (varP tagVar) (varE 'getWord8)
                    , noBindS $ caseE (varE tagVar) (
                        [ match (litP $ IntegerL i) (normalB $ mkGetBody con) [] | (i, con) <- cons ] ++
                        [ match wildP (normalB $ varE 'fail `appE` errorMsg tagVar) [] ]) ]
      mkGetBody :: Con -> Q Exp
mkGetBody Con
con
          = do (getFunsDecs, 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 -> 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 -> 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)
               doE (getFunsDecs ++ [noBindS 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
                                      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
                                      finish (zip origTypes realTypes) <$> foldM go ([], []) 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 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)
                               return ( bindS (varP funVar) (varE baseFun) : ds
                                      , (t, funVar) : 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 <- Name -> Q Info
reify Name
name
                                   return $ case info of
                                              TyVarI Name
_ Kind
ty            -> Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
ty
                                              TyConI (TySynD Name
_ [TyVarBndr BndrVis]
_ 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
"_"