{-# 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 :: 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 :: 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 :: 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 :: 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 :: 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 :: 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 (PlainTV n _) = n
tyVarName (KindedTV n _ _) = n
#else
tyVarName :: TyVarBndr -> Name
tyVarName :: TyVarBndr -> Name
tyVarName (PlainTV Name
n) = Name
n
tyVarName (KindedTV Name
n Kind
_) = Name
n
#endif

internalDeriveSafeCopy :: DeriveType -> Version a -> Name -> Name -> Q [Dec]
internalDeriveSafeCopy :: 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' :: 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 (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 (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]
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]
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] -> [(Integer, Con)] -> Q [Dec]
worker' (Kind -> Q Kind
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] -> [(Integer, Con)] -> Q [Dec]
worker' (Kind -> Q Kind
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 (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 (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 (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] -> [(Integer, Con)] -> Q [Dec]
worker = Q Kind -> Cxt -> [TyVarBndr] -> [(Integer, Con)] -> Q [Dec]
worker' (Name -> Q Kind
conT Name
tyName)
    worker' :: Q Kind -> Cxt -> [TyVarBndr] -> [(Integer, Con)] -> Q [Dec]
worker' Q Kind
tyBase Cxt
context [TyVarBndr]
tyvars [(Integer, Con)]
cons =
      let ty :: Q Kind
ty = (Q Kind -> Q Kind -> Q Kind) -> Q Kind -> [Q Kind] -> Q Kind
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Kind -> Q Kind -> Q Kind
appT Q Kind
tyBase [ Name -> Q Kind
varT (Name -> Q Kind) -> Name -> Q Kind
forall a b. (a -> b) -> a -> b
$ TyVarBndr -> Name
tyVarName TyVarBndr
var | TyVarBndr
var <- [TyVarBndr]
tyvars ]
          safeCopyClass :: t (Q Kind) -> Q Kind
safeCopyClass t (Q Kind)
args = (Q Kind -> Q Kind -> Q Kind) -> Q Kind -> t (Q Kind) -> Q Kind
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Kind -> Q Kind -> Q Kind
appT (Name -> Q Kind
conT ''SafeCopy) t (Q 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
<$> CxtQ -> Q Kind -> [Q Dec] -> Q Dec
instanceD ([Q Kind] -> CxtQ
cxt ([Q Kind] -> CxtQ) -> [Q Kind] -> CxtQ
forall a b. (a -> b) -> a -> b
$ [[Q Kind] -> Q Kind
forall (t :: * -> *). Foldable t => t (Q Kind) -> Q Kind
safeCopyClass [Name -> Q Kind
varT (Name -> Q Kind) -> Name -> Q Kind
forall a b. (a -> b) -> a -> b
$ TyVarBndr -> Name
tyVarName TyVarBndr
var] | TyVarBndr
var <- [TyVarBndr]
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 (m :: * -> *) a. Monad m => a -> m a
return Cxt
context)
                                       (Name -> Q Kind
conT ''SafeCopy Q Kind -> Q Kind -> Q 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
                                       , PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP 'version) (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Lit -> ExpQ
litE (Lit -> ExpQ) -> Lit -> ExpQ
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) []
                                       , PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP 'kind) (ExpQ -> BodyQ
normalB (Name -> ExpQ
varE Name
kindName)) []
                                       , Name -> [ClauseQ] -> Q Dec
funD 'errorTypeName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
wildP] (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Lit -> ExpQ
litE (Lit -> ExpQ) -> Lit -> ExpQ
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 :: 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' :: 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] -> CxtQ
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> Q 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 (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] -> [(Integer, Con)] -> Q [Dec]
worker' (Kind -> Q Kind
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 (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 (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] -> [(Integer, Con)] -> Q [Dec]
worker' (Kind -> Q Kind
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 (m :: * -> *) a. Monad m => a -> m a
return []
          Dec
_ -> String -> Q [Dec]
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 (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 (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] -> [(Integer, Con)] -> Q [Dec]
worker' Q Kind
tyBase Cxt
context [TyVarBndr]
tyvars [(Integer, Con)]
cons =
      let ty :: Q Kind
ty = (Q Kind -> Q Kind -> Q Kind) -> Q Kind -> [Q Kind] -> Q Kind
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Kind -> Q Kind -> Q Kind
appT Q Kind
tyBase [ Name -> Q Kind
varT (Name -> Q Kind) -> Name -> Q Kind
forall a b. (a -> b) -> a -> b
$ TyVarBndr -> Name
tyVarName TyVarBndr
var | TyVarBndr
var <- [TyVarBndr]
tyvars ]
          safeCopyClass :: t (Q Kind) -> Q Kind
safeCopyClass t (Q Kind)
args = (Q Kind -> Q Kind -> Q Kind) -> Q Kind -> t (Q Kind) -> Q Kind
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Kind -> Q Kind -> Q Kind
appT (Name -> Q Kind
conT ''SafeCopy) t (Q 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
<$> CxtQ -> Q Kind -> [Q Dec] -> Q Dec
instanceD ([Q Kind] -> CxtQ
cxt ([Q Kind] -> CxtQ) -> [Q Kind] -> CxtQ
forall a b. (a -> b) -> a -> b
$ [[Q Kind] -> Q Kind
forall (t :: * -> *). Foldable t => t (Q Kind) -> Q Kind
safeCopyClass [Name -> Q Kind
varT (Name -> Q Kind) -> Name -> Q Kind
forall a b. (a -> b) -> a -> b
$ TyVarBndr -> Name
tyVarName TyVarBndr
var] | TyVarBndr
var <- [TyVarBndr]
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 (m :: * -> *) a. Monad m => a -> m a
return Cxt
context)
                                       (Name -> Q Kind
conT ''SafeCopy Q Kind -> Q Kind -> Q 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
                                       , PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP 'version) (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Lit -> ExpQ
litE (Lit -> ExpQ) -> Lit -> ExpQ
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) []
                                       , PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP 'kind) (ExpQ -> BodyQ
normalB (Name -> ExpQ
varE Name
kindName)) []
                                       , Name -> [ClauseQ] -> Q Dec
funD 'errorTypeName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
wildP] (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Lit -> ExpQ
litE (Lit -> ExpQ) -> Lit -> ExpQ
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 -> [ClauseQ] -> Q Dec
funD 'putCopy ([ClauseQ] -> Q Dec) -> [ClauseQ] -> Q Dec
forall a b. (a -> b) -> a -> b
$ ((Integer, Con) -> ClauseQ) -> [(Integer, Con)] -> [ClauseQ]
forall a b. (a -> b) -> [a] -> [b]
map (Integer, Con) -> ClauseQ
mkPutClause [(Integer, Con)]
cons
    where
      manyConstructors :: Bool
manyConstructors = [(Integer, Con)] -> 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) -> ClauseQ
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)
mapM (\Int
n -> String -> Q 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 (m :: * -> *) a. Monad m => a -> m a
return ([], Name -> Kind -> Name
forall a b. a -> b -> a
const 'safePut)
               let putClause :: PatQ
putClause   = Name -> [PatQ] -> PatQ
conP (Con -> Name
conName Con
con) ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
putVars)
                   putCopyBody :: ExpQ
putCopyBody = Name -> ExpQ
varE 'contain ExpQ -> ExpQ -> ExpQ
`appE` [StmtQ] -> ExpQ
doE (
                                   [ ExpQ -> StmtQ
noBindS (ExpQ -> StmtQ) -> ExpQ -> StmtQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE 'putWord8 ExpQ -> ExpQ -> ExpQ
`appE` Lit -> ExpQ
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]
++
                                   [ ExpQ -> StmtQ
noBindS (ExpQ -> StmtQ) -> ExpQ -> StmtQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE (Kind -> Name
putFuns Kind
typ) ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
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]
++
                                   [ ExpQ -> StmtQ
noBindS (ExpQ -> StmtQ) -> ExpQ -> StmtQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE 'return ExpQ -> ExpQ -> ExpQ
`appE` [ExpQ] -> ExpQ
tupE [] ])
               [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
putClause] (ExpQ -> BodyQ
normalB ExpQ
putCopyBody) []

mkGetCopy :: DeriveType -> String -> [(Integer, Con)] -> DecQ
mkGetCopy :: DeriveType -> String -> [(Integer, Con)] -> Q Dec
mkGetCopy DeriveType
deriveType String
tyName [(Integer, Con)]
cons = PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP 'getCopy) (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE 'contain ExpQ -> ExpQ -> ExpQ
`appE` ExpQ
mkLabel) []
    where
      mkLabel :: ExpQ
mkLabel = Name -> ExpQ
varE 'label ExpQ -> ExpQ -> ExpQ
`appE` Lit -> ExpQ
litE (String -> Lit
stringL String
labelString) ExpQ -> ExpQ -> ExpQ
`appE` ExpQ
getCopyBody
      labelString :: String
labelString = String
tyName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":"
      getCopyBody :: ExpQ
getCopyBody
          = case [(Integer, Con)]
cons of
              [(Integer
_, Con
con)] | Bool -> Bool
not (DeriveType -> Bool
forceTag DeriveType
deriveType) -> Con -> ExpQ
mkGetBody Con
con
              [(Integer, Con)]
_ -> do
                Name
tagVar <- String -> Q Name
newName String
"tag"
                [StmtQ] -> ExpQ
doE [ PatQ -> ExpQ -> StmtQ
bindS (Name -> PatQ
varP Name
tagVar) (Name -> ExpQ
varE 'getWord8)
                    , ExpQ -> StmtQ
noBindS (ExpQ -> StmtQ) -> ExpQ -> StmtQ
forall a b. (a -> b) -> a -> b
$ ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
tagVar) (
                        [ PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (Lit -> PatQ
litP (Lit -> PatQ) -> Lit -> PatQ
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
IntegerL Integer
i) (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Con -> ExpQ
mkGetBody Con
con) [] | (Integer
i, Con
con) <- [(Integer, Con)]
cons ] [MatchQ] -> [MatchQ] -> [MatchQ]
forall a. [a] -> [a] -> [a]
++
                        [ PatQ -> BodyQ -> [Q Dec] -> MatchQ
match PatQ
wildP (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE 'fail ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
errorMsg Name
tagVar) [] ]) ]
      mkGetBody :: Con -> ExpQ
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 (m :: * -> *) a. Monad m => a -> m a
return ([], Name -> Kind -> Name
forall a b. a -> b -> a
const 'safeGet)
               let getBase :: ExpQ
getBase = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'return) (Name -> ExpQ
conE (Con -> Name
conName Con
con))
                   getArgs :: ExpQ
getArgs = (ExpQ -> Kind -> ExpQ) -> ExpQ -> Cxt -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ExpQ
a Kind
t -> Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
infixE (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just ExpQ
a) (Name -> ExpQ
varE '(<*>)) (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just (Name -> ExpQ
varE (Kind -> Name
getFuns Kind
t)))) ExpQ
getBase (Con -> Cxt
conTypes Con
con)
               [StmtQ] -> ExpQ
doE ([StmtQ]
getFunsDecs [StmtQ] -> [StmtQ] -> [StmtQ]
forall a. [a] -> [a] -> [a]
++ [ExpQ -> StmtQ
noBindS ExpQ
getArgs])
      errorMsg :: Name -> ExpQ
errorMsg Name
tagVar = Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
infixE (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just (ExpQ -> Maybe ExpQ) -> ExpQ -> Maybe ExpQ
forall a b. (a -> b) -> a -> b
$ String -> ExpQ
strE String
str1) (Name -> ExpQ
varE '(++)) (Maybe ExpQ -> ExpQ) -> Maybe ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just (ExpQ -> Maybe ExpQ) -> ExpQ -> Maybe ExpQ
forall a b. (a -> b) -> a -> b
$
                        Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
infixE (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just ExpQ
tagStr) (Name -> ExpQ
varE '(++)) (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just (ExpQ -> Maybe ExpQ) -> ExpQ -> Maybe ExpQ
forall a b. (a -> b) -> a -> b
$ String -> ExpQ
strE String
str2)
          where
            strE :: String -> ExpQ
strE = Lit -> ExpQ
litE (Lit -> ExpQ) -> (String -> Lit) -> String -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL
            tagStr :: ExpQ
tagStr = Name -> ExpQ
varE 'show ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
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 (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 -> CxtQ
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t 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)])
go ([], []) Cxt
realTypes
    where go :: ([StmtQ], [(Kind, Name)]) -> Kind -> Q ([StmtQ], [(Kind, Name)])
go ([StmtQ]
ds, [(Kind, Name)]
fs) Kind
t
              | Bool
found     = ([StmtQ], [(Kind, Name)]) -> Q ([StmtQ], [(Kind, Name)])
forall (m :: * -> *) a. Monad m => a -> m a
return ([StmtQ]
ds, [(Kind, Name)]
fs)
              | Bool
otherwise = do Name
funVar <- String -> Q Name
newName (String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ Kind -> String
typeName Kind
t)
                               ([StmtQ], [(Kind, Name)]) -> Q ([StmtQ], [(Kind, Name)])
forall (m :: * -> *) a. Monad m => a -> m a
return ( PatQ -> ExpQ -> StmtQ
bindS (Name -> PatQ
varP Name
funVar) (Name -> ExpQ
varE Name
baseFun) StmtQ -> [StmtQ] -> [StmtQ]
forall a. a -> [a] -> [a]
: [StmtQ]
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 (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 (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 (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 (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 (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 (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
args
conSize (RecC Name
_name [VarBangType]
recs)    = [VarBangType] -> 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
"_"