{-# LANGUAGE CPP #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Generics.Deriving.TH
-- Copyright   :  (c) 2008--2009 Universiteit Utrecht
-- License     :  BSD3
--
-- Maintainer  :  generics@haskell.org
-- Stability   :  experimental
-- Portability :  non-portable
--
-- This module contains Template Haskell code that can be used to
-- automatically generate the boilerplate code for the generic deriving
-- library.
--
-- To use these functions, pass the name of a data type as an argument:
--
-- @
-- {-# LANGUAGE TemplateHaskell #-}
--
-- data Example a = Example Int Char a
-- $('deriveAll0'     ''Example) -- Derives Generic instance
-- $('deriveAll1'     ''Example) -- Derives Generic1 instance
-- $('deriveAll0And1' ''Example) -- Derives Generic and Generic1 instances
-- @
--
-- On GHC 7.4 or later, this code can also be used with data families. To derive
-- for a data family instance, pass the name of one of the instance's constructors:
--
-- @
-- {-# LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies #-}
--
-- data family Family a b
-- newtype instance Family Char b = FamilyChar Char
-- data    instance Family Bool b = FamilyTrue | FamilyFalse
--
-- $('deriveAll0' 'FamilyChar) -- instance Generic (Family Char b) where ...
-- $('deriveAll1' 'FamilyTrue) -- instance Generic1 (Family Bool) where ...
-- -- Alternatively, one could type $(deriveAll1 'FamilyFalse)
-- @
--
-- If you are deriving for data family instances, be aware of a bug on GHC
-- 7.8 (<https://ghc.haskell.org/trac/ghc/ticket/9692 Trac #9692>) which can
-- cause incorrectly derived 'Generic1' instances if a data family
-- declaration and one of its instances use different type variables:
--
-- @
-- data family Foo a b c
-- data instance Foo Int y z = Foo Int y z
-- $(deriveAll1 'Foo)
-- @
--
-- To avoid this issue, it is recommened that you use the same type variables
-- in the same positions in which they appeared in the data family declaration:
--
-- @
-- data family Foo a b c
-- data instance Foo Int b c = Foo Int b c
-- $(deriveAll1 'Foo)
-- @
-----------------------------------------------------------------------------

-- Adapted from Generics.Regular.TH
module Generics.Deriving.TH (

      deriveMeta
    , deriveData
    , deriveConstructors
    , deriveSelectors

    , deriveAll
    , deriveAll1
    , deriveAll0And1
    , deriveRepresentable0
    , deriveRepresentable1
    , deriveRep0
    , deriveRep1
    , simplInstance
     -- * @make@- functions
     -- $make
    , makeRep0
    , makeFrom
    , makeTo
    , makeRep1
    , makeFrom1
    , makeTo1
  ) where

import           Data.Char (isAlphaNum, ord)
import           Data.List
#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710
import qualified Data.Map as Map
import           Data.Map as Map (Map)
#endif
#if __GLASGOW_HASKELL__ >= 706 && __GLASGOW_HASKELL__ < 710
import qualified Data.Set as Set
import           Data.Set (Set)
#endif

import           Generics.Deriving.Base
import           Generics.Deriving.TH.Internal

import           Language.Haskell.TH.Lib
import           Language.Haskell.TH.Syntax (Name(..), NameFlavour(..), Lift(..),
                                            modString, pkgString)
import           Language.Haskell.TH hiding (Fixity())

-- | Given the names of a generic class, a type to instantiate, a function in
-- the class and the default implementation, generates the code for a basic
-- generic instance.
simplInstance :: Name -> Name -> Name -> Name -> Q [Dec]
simplInstance cl ty fn df = do
  x <- newName "x"
  let typ = ForallT [PlainTV x] []
        ((foldl (\a -> AppT a . VarT . tyVarBndrToName) (ConT (genRepName 0 DataPlain ty)) []) `AppT` (VarT x))
  fmap (: []) $ instanceD (cxt []) (conT cl `appT` conT ty)
    [funD fn [clause [] (normalB (varE df `appE`
      (sigE (varE undefinedValName) (return typ)))) []]]


-- | Given the type and the name (as string) for the type to derive,
-- generate the 'Data' instance, the 'Constructor' instances, the 'Selector'
-- instances, and the 'Representable0' instance.
deriveAll :: Name -> Q [Dec]
deriveAll n =
  do a <- deriveMeta n
     b <- deriveRepresentable0 n
     return (a ++ b)

-- | Given the type and the name (as string) for the type to derive,
-- generate the 'Data' instance, the 'Constructor' instances, the 'Selector'
-- instances, and the 'Representable1' instance.
deriveAll1 :: Name -> Q [Dec]
deriveAll1 n =
  do a <- deriveMeta n
     b <- deriveRepresentable1 n
     return (a ++ b)

-- | Given the type and the name (as string) for the type to derive,
-- generate the 'Data' instance, the 'Constructor' instances, the 'Selector'
-- instances, the 'Representable0' instance, and the 'Representable1' instance.
deriveAll0And1 :: Name -> Q [Dec]
deriveAll0And1 n =
  do a <- deriveMeta n
     b <- deriveRepresentable0 n
     c <- deriveRepresentable1 n
     return (a ++ b ++ c)

-- | Given the type and the name (as string) for the type to derive,
-- generate the 'Data' instance, the 'Constructor' instances, and the 'Selector'
-- instances.
deriveMeta :: Name -> Q [Dec]
deriveMeta n =
  do a <- deriveData n
     b <- deriveConstructors n
     c <- deriveSelectors n
     return (a ++ b ++ c)

-- | Given a datatype name, derive a datatype and instance of class 'Datatype'.
deriveData :: Name -> Q [Dec]
deriveData = dataInstance

-- | Given a datatype name, derive datatypes and
-- instances of class 'Constructor'.
deriveConstructors :: Name -> Q [Dec]
deriveConstructors = constrInstance

-- | Given a datatype name, derive datatypes and instances of class 'Selector'.
deriveSelectors :: Name -> Q [Dec]
deriveSelectors = selectInstance

-- | Given the type and the name (as string) for the Representable0 type
-- synonym to derive, generate the 'Representable0' instance.
deriveRepresentable0 :: Name -> Q [Dec]
deriveRepresentable0 n = do
    rep0 <- deriveRep0 n
    inst <- deriveInst n
    return $ rep0 ++ inst

-- | Given the type and the name (as string) for the Representable1 type
-- synonym to derive, generate the 'Representable1' instance.
deriveRepresentable1 :: Name -> Q [Dec]
deriveRepresentable1 n = do
    rep1  <- deriveRep1 n
    inst1 <- deriveInst1 n
    return $ rep1 ++ inst1

-- | Derive only the 'Rep0' type synonym. Not needed if 'deriveRepresentable0'
-- is used.
deriveRep0 :: Name -> Q [Dec]
deriveRep0 = deriveRepCommon 0

-- | Derive only the 'Rep1' type synonym. Not needed if 'deriveRepresentable1'
-- is used.
deriveRep1 :: Name -> Q [Dec]
deriveRep1 = deriveRepCommon 1

deriveRepCommon :: Int -> Name -> Q [Dec]
deriveRepCommon arity n = do
  i <- reifyDataInfo n
  let (name, _, allTvbs, cons, dv) = either error id i
      (tvbs, _, gk) = buildTypeInstance arity name allTvbs cons dv

  fmap (:[]) $ tySynD (genRepName arity dv name)
                      (map unKindedTV tvbs) -- The typechecker will infer the kinds of
                                            -- the TyVarBndrs in a type synonym
                                            -- declaration, so we don't need to
                                            -- splice them explicitly
                      (repType gk dv name cons)

deriveInst :: Name -> Q [Dec]
deriveInst = deriveInstCommon genericTypeName repTypeName 0 fromValName toValName

deriveInst1 :: Name -> Q [Dec]
deriveInst1 = deriveInstCommon generic1TypeName rep1TypeName 1 from1ValName to1ValName

deriveInstCommon :: Name -> Name -> Int -> Name -> Name -> Name -> Q [Dec]
deriveInstCommon genericName repName arity fromName toName n = do
  i <- reifyDataInfo n
  let (name, _, allTvbs, cons, dv) = either error id i
      (tvbs, origTy, gk) = buildTypeInstance arity name allTvbs cons dv
      repTy = applyTyToTvbs (genRepName arity dv name) tvbs
#if __GLASGOW_HASKELL__ >= 707
      tyIns = TySynInstD repName (TySynEqn [origTy] repTy)
#else
      tyIns = TySynInstD repName [origTy] repTy
#endif
      mkBody maker = [clause [] (normalB $ mkCaseExp gk name cons maker) []]
      fcs = mkBody mkFrom
      tcs = mkBody mkTo

  fmap (:[]) $
    instanceD (cxt []) (conT genericName `appT` return origTy)
                         [return tyIns, funD fromName fcs, funD toName tcs]

{- $make

There are some data types for which the Template Haskell deriver functions in
this module are not sophisticated enough to infer the correct 'Generic' or
'Generic1' instances. As an example, consider this data type:

@
data Fix f a = Fix (f (Fix f a))
@

A proper 'Generic1' instance would look like this:

@
instance Functor f => Generic1 (Fix f) where ...
@

Unfortunately, 'deriveRepresentable1' cannot infer the @Functor f@ constraint.
One can still define a 'Generic1' instance for @Fix@, however, by using the
functions in this module that are prefixed with @make@-. For example:

@
$('deriveMeta' ''Fix)
$('deriveRep1' ''Fix)
instance Functor f => Generic1 (Fix f) where
  type Rep1 (Fix f) = $('makeRep1' ''Fix) f
  from1 = $('makeFrom1' ''Fix)
  to1   = $('makeTo1'   ''Fix)
@

Note that due to the lack of type-level lambdas in Haskell, one must manually
apply @$('makeRep1' ''Fix)@ to the type parameters of @Fix@ (@f@ in the above
example).

-}

-- | Generates the 'Rep0' type synonym constructor (as opposed to 'deriveRep0',
-- which generates the type synonym declaration).
makeRep0 :: Name -> Q Type
makeRep0 = makeRepCommon 0

-- | Generates the 'Rep1' type synonym constructor (as opposed to 'deriveRep1',
-- which generates the type synonym declaration).
makeRep1 :: Name -> Q Type
makeRep1 = makeRepCommon 1

makeRepCommon :: Int -> Name -> Q Type
makeRepCommon arity n = do
  i <- reifyDataInfo n
  case i of
    Left msg               -> error msg
    Right (name, _, _, _, dv) -> conT $ genRepName arity dv name

-- | Generates a lambda expression which behaves like 'from'.
makeFrom :: Name -> Q Exp
makeFrom = makeFunCommon mkFrom 0

-- | Generates a lambda expression which behaves like 'to'.
makeTo :: Name -> Q Exp
makeTo = makeFunCommon mkTo 0

-- | Generates a lambda expression which behaves like 'from1'.
makeFrom1 :: Name -> Q Exp
makeFrom1 = makeFunCommon mkFrom 1

-- | Generates a lambda expression which behaves like 'to1'.
makeTo1 :: Name -> Q Exp
makeTo1 = makeFunCommon mkTo 1

makeFunCommon :: (GenericKind -> Int -> Int -> Name -> [Con] -> [Q Match])
              -> Int -> Name -> Q Exp
makeFunCommon maker arity n = do
  i <- reifyDataInfo n
  let (name, _, allTvbs, cons, dv) = either error id i
      (_, _, gk) = buildTypeInstance arity name allTvbs cons dv
  mkCaseExp gk name cons maker

dataInstance :: Name -> Q [Dec]
dataInstance n = do
  i <- reifyDataInfo n
  case i of
    Left  _                    -> return []
    Right (n', isNT, _, _, dv) -> mkInstance n' dv isNT
  where
    mkInstance n' dv isNT = do
      ds <- mkDataData dv n'
      is <- mkDataInstance dv n' isNT
      return $ [ds,is]

constrInstance :: Name -> Q [Dec]
constrInstance n = do
  i <- reifyDataInfo n
  case i of
    Left  _               -> return []
    Right (n', _, _, cs, dv) -> mkInstance n' cs dv
  where
    mkInstance n' cs dv = do
      ds <- mapM (mkConstrData dv n') cs
      is <- mapM (mkConstrInstance dv n') cs
      return $ ds ++ is

selectInstance :: Name -> Q [Dec]
selectInstance n = do
  i <- reifyDataInfo n
  case i of
    Left  _               -> return []
    Right (n', _, _, cs, dv) -> mkInstance n' cs dv
  where
    mkInstance n' cs dv = do
      ds <- mapM (mkSelectData dv n') cs
      is <- mapM (mkSelectInstance dv n') cs
      return $ concat (ds ++ is)

genName :: DataVariety -> [Name] -> Name
genName dv ns = mkName
              . showsDataVariety dv
              . intercalate "_"
              . consQualName
              $ map (sanitizeName . nameBase) ns
  where
    consQualName :: [String] -> [String]
    consQualName = case ns of
        []  -> id
        n:_ -> (showNameQual n :)

genRepName :: Int -> DataVariety -> Name -> Name
genRepName arity dv n = mkName
                      . showsDataVariety dv
                      . (("Rep" ++ show arity) ++)
                      . ((showNameQual n ++ "_") ++)
                      . sanitizeName
                      $ nameBase n

showsDataVariety :: DataVariety -> ShowS
showsDataVariety dv = (++ '_':label dv)
  where
    label DataPlain        = "Plain"
    label (DataFamily n _) = "Family_" ++ sanitizeName (nameBase n)

showNameQual :: Name -> String
showNameQual = sanitizeName . showQual
  where
    showQual (Name _ (NameQ m))       = modString m
    showQual (Name _ (NameG _ pkg m)) = pkgString pkg ++ ":" ++ modString m
    showQual _                        = ""

-- | Credit to Víctor López Juan for this trick
sanitizeName :: String -> String
sanitizeName nb = 'N':(
    nb >>= \x -> case x of
      c | isAlphaNum c || c == '\''-> [c]
      '_' -> "__"
      c   -> "_" ++ show (ord c))

mkDataData :: DataVariety -> Name -> Q Dec
mkDataData dv n = dataD (cxt []) (genName dv [n]) [] [] []

mkConstrData :: DataVariety -> Name -> Con -> Q Dec
mkConstrData dv dt (NormalC n _) =
  dataD (cxt []) (genName dv [dt, n]) [] [] []
mkConstrData dv dt r@(RecC _ _) =
  mkConstrData dv dt (stripRecordNames r)
mkConstrData dv dt (InfixC t1 n t2) =
  mkConstrData dv dt (NormalC n [t1,t2])
mkConstrData _ _ (ForallC _ _ con) = forallCError con

mkSelectData :: DataVariety -> Name -> Con -> Q [Dec]
mkSelectData dv dt (RecC n fs) = return (map one fs)
  where one (f, _, _) = DataD [] (genName dv [dt, n, f]) [] [] []
mkSelectData _ _ _ = return []


mkDataInstance :: DataVariety -> Name -> Bool -> Q Dec
mkDataInstance dv n _isNewtype =
  instanceD (cxt []) (appT (conT datatypeTypeName) (conT $ genName dv [n])) $
    [ funD datatypeNameValName [clause [wildP] (normalB (stringE (nameBase n))) []]
    , funD moduleNameValName   [clause [wildP] (normalB (stringE name)) []]
#if __GLASGOW_HASKELL__ >= 711
    , funD packageNameValName  [clause [wildP] (normalB (stringE pkgName)) []]
#endif
    ]
#if __GLASGOW_HASKELL__ >= 708
 ++ if _isNewtype
       then [funD isNewtypeValName [clause [wildP] (normalB (conE trueDataName)) []]]
       else []
#endif
  where
    name    = maybe (error "Cannot fetch module name!")  id (nameModule n)
#if __GLASGOW_HASKELL__ >= 711
    pkgName = maybe (error "Cannot fetch package name!") id (namePackage n)
#endif

liftFixity :: Fixity -> Q Exp
liftFixity Prefix      = conE prefixDataName
liftFixity (Infix a n) = conE infixDataName
    `appE` liftAssociativity a
    `appE` lift n

liftAssociativity :: Associativity -> Q Exp
liftAssociativity LeftAssociative  = conE leftAssociativeDataName
liftAssociativity RightAssociative = conE rightAssociativeDataName
liftAssociativity NotAssociative   = conE notAssociativeDataName

mkConstrInstance :: DataVariety -> Name -> Con -> Q Dec
mkConstrInstance dv dt (NormalC n _) = mkConstrInstanceWith dv dt n []
mkConstrInstance dv dt (RecC    n _) = mkConstrInstanceWith dv dt n
      [ funD conIsRecordValName [clause [wildP] (normalB (conE trueDataName)) []]]
mkConstrInstance dv dt (InfixC _ n _) =
    do
      i <- reify n
#if __GLASGOW_HASKELL__ >= 711
      fi <- case i of
                 DataConI{} -> fmap convertFixity $ reifyFixity n
                 _ -> return Prefix
#else
      let fi = case i of
                 DataConI _ _ _ f -> convertFixity f
                 _ -> Prefix
#endif
      instanceD (cxt []) (appT (conT constructorTypeName) (conT $ genName dv [dt, n]))
        [funD conNameValName   [clause [wildP] (normalB (stringE (nameBase n))) []],
         funD conFixityValName [clause [wildP] (normalB (liftFixity fi)) []]]
  where
    convertFixity (Fixity n' d) = Infix (convertDirection d) n'
    convertDirection InfixL = LeftAssociative
    convertDirection InfixR = RightAssociative
    convertDirection InfixN = NotAssociative
mkConstrInstance _ _ (ForallC _ _ con) = forallCError con

mkConstrInstanceWith :: DataVariety -> Name -> Name -> [Q Dec] -> Q Dec
mkConstrInstanceWith dv dt n extra =
  instanceD (cxt []) (appT (conT constructorTypeName) (conT $ genName dv [dt, n]))
    (funD conNameValName [clause [wildP] (normalB (stringE (nameBase n))) []] : extra)

mkSelectInstance :: DataVariety -> Name -> Con -> Q [Dec]
mkSelectInstance dv dt (RecC n fs) = return (map one fs) where
  one (f, _, _) =
    InstanceD ([]) (AppT (ConT selectorTypeName) (ConT $ genName dv [dt, n, f]))
      [FunD selNameValName [Clause [WildP]
        (NormalB (LitE (StringL (nameBase f)))) []]]
mkSelectInstance _ _ _ = return []

repType :: GenericKind -> DataVariety -> Name -> [Con] -> Q Type
repType gk dv dt cs =
    conT d1TypeName `appT` (conT $ genName dv [dt]) `appT`
      foldr1' sum' (conT v1TypeName)
        (map (repCon gk dv dt) cs)
  where
    sum' :: Q Type -> Q Type -> Q Type
    sum' a b = conT sumTypeName `appT` a `appT` b

repCon :: GenericKind -> DataVariety -> Name -> Con -> Q Type
repCon _ dv dt (NormalC n []) =
    conT c1TypeName `appT` (conT $ genName dv [dt, n]) `appT`
     (conT s1TypeName `appT` conT noSelectorTypeName `appT` conT u1TypeName)
repCon gk dv dt (NormalC n fs) =
    conT c1TypeName `appT` (conT $ genName dv [dt, n]) `appT`
     (foldr1 prod (map (repField gk . snd) fs)) where
    prod :: Q Type -> Q Type -> Q Type
    prod a b = conT productTypeName `appT` a `appT` b
repCon _ dv dt (RecC n []) =
    conT c1TypeName `appT` (conT $ genName dv [dt, n]) `appT` conT u1TypeName
repCon gk dv dt (RecC n fs) =
    conT c1TypeName `appT` (conT $ genName dv [dt, n]) `appT`
      (foldr1 prod (map (repField' gk dv dt n) fs)) where
    prod :: Q Type -> Q Type -> Q Type
    prod a b = conT productTypeName `appT` a `appT` b

repCon gk dv dt (InfixC t1 n t2) = repCon gk dv dt (NormalC n [t1,t2])
repCon _ _ _ (ForallC _ _ con) = forallCError con

--dataDeclToType :: (Name, [Name]) -> Type
--dataDeclToType (dt, vs) = foldl (\a b -> AppT a (VarT b)) (ConT dt) vs

repField :: GenericKind -> Type -> Q Type
--repField d t | t == dataDeclToType d = conT ''I
repField gk t = conT s1TypeName `appT` conT noSelectorTypeName `appT`
                   (repFieldArg gk =<< expandSyn t)

repField' :: GenericKind -> DataVariety -> Name -> Name -> (Name, Strict, Type) -> Q Type
--repField' d ns (_, _, t) | t == dataDeclToType d = conT ''I
repField' gk dv dt ns (f, _, t) = conT s1TypeName
    `appT` conT (genName dv [dt, ns, f])
    `appT` (repFieldArg gk =<< expandSyn t)
-- Note: we should generate Par0 too, at some point

repFieldArg :: GenericKind -> Type -> Q Type
repFieldArg _ ForallT{} = rankNError
repFieldArg gk (SigT t _) = repFieldArg gk t
repFieldArg Gen0 t = boxT t
repFieldArg (Gen1 nb) (VarT t) | NameBase t == nb = conT par1TypeName
repFieldArg gk@(Gen1 nb) t = do
  let tyHead:tyArgs      = unapplyTy t
      numLastArgs        = min 1 $ length tyArgs
      (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs
      rec0Type           = boxT t
      phiType            = return $ applyTyToTys tyHead lhsArgs

      inspectTy :: Type -> Q Type
      inspectTy (VarT a)
        | NameBase a == nb
        = conT rec1TypeName `appT` phiType
      inspectTy (SigT ty _) = inspectTy ty
      inspectTy beta
        | not (ground beta nb)
        = conT composeTypeName `appT` phiType
                               `appT` repFieldArg gk beta
      inspectTy _ = rec0Type

  itf <- isTyFamily tyHead
  if any (not . (`ground` nb)) lhsArgs
       || any (not . (`ground` nb)) tyArgs && itf
     then outOfPlaceTyVarError
     else case rhsArgs of
          []   -> rec0Type
          ty:_ -> inspectTy ty

boxT :: Type -> Q Type
boxT ty = case unboxedRepNames ty of
    Just (boxTyName, _, _) -> conT boxTyName
    Nothing                -> conT rec0TypeName `appT` return ty

mkCaseExp :: GenericKind -> Name -> [Con]
          -> (GenericKind -> Int -> Int -> Name -> [Con] -> [Q Match])
          -> Q Exp
mkCaseExp gk dt cs matchmaker = do
  val <- newName "val"
  lam1E (varP val) $ caseE (varE val) $ matchmaker gk 1 0 dt cs

mkFrom :: GenericKind -> Int -> Int -> Name -> [Con] -> [Q Match]
mkFrom _  _ _ dt [] = [errorFrom dt]
mkFrom gk m i _  cs = zipWith (fromCon gk wrapE (length cs)) [0..] cs
  where
    wrapE e = lrE m i e

errorFrom :: Name -> Q Match
errorFrom dt =
  match
    wildP
    (normalB $ appE (conE m1DataName) $ varE errorValName `appE` stringE
      ("No generic representation for empty datatype " ++ nameBase dt))
    []

errorTo :: Name -> Q Match
errorTo dt =
  match
    (conP m1DataName [wildP])
    (normalB $ varE errorValName `appE` stringE
      ("No values for empty datatype " ++ nameBase dt))
    []

mkTo :: GenericKind -> Int -> Int -> Name -> [Con] -> [Q Match]
mkTo _  _ _ dt [] = [errorTo dt]
mkTo gk m i _  cs = zipWith (toCon gk wrapP (length cs)) [0..] cs
  where
    wrapP p = lrP m i p

fromCon :: GenericKind -> (Q Exp -> Q Exp) -> Int -> Int -> Con -> Q Match
fromCon _ wrap m i (NormalC cn []) =
  match
    (conP cn [])
    (normalB $ appE (conE m1DataName) $ wrap $ lrE m i $ appE (conE m1DataName) $
      conE m1DataName `appE` (conE u1DataName)) []
fromCon gk wrap m i (NormalC cn fs) =
  -- runIO (putStrLn ("constructor " ++ show ix)) >>
  match
    (conP cn (map (varP . field) [0..length fs - 1]))
    (normalB $ appE (conE m1DataName) $ wrap $ lrE m i $ conE m1DataName `appE`
      foldr1 prod (zipWith (fromField gk) [0..] (map snd fs))) []
  where prod x y = conE productDataName `appE` x `appE` y
fromCon _ wrap m i (RecC cn []) =
  match
    (conP cn [])
    (normalB $ appE (conE m1DataName)
             $ wrap $ lrE m i $ conE m1DataName `appE` (conE u1DataName)) []
fromCon gk wrap m i (RecC cn fs) =
  match
    (conP cn (map (varP . field) [0..length fs - 1]))
    (normalB $ appE (conE m1DataName) $ wrap $ lrE m i $ conE m1DataName `appE`
      foldr1 prod (zipWith (fromField gk) [0..] (map trd fs))) []
  where prod x y = conE productDataName `appE` x `appE` y
fromCon gk wrap m i (InfixC t1 cn t2) =
  fromCon gk wrap m i (NormalC cn [t1,t2])
fromCon _ _ _ _ (ForallC _ _ con) = forallCError con

fromField :: GenericKind -> Int -> Type -> Q Exp
--fromField (dt, vs) nr t | t == dataDeclToType (dt, vs) = conE 'I `appE` varE (field nr)
fromField gk nr t = conE m1DataName `appE` (fromFieldWrap gk nr =<< expandSyn t)

fromFieldWrap :: GenericKind -> Int -> Type -> Q Exp
fromFieldWrap _         _  ForallT{}  = rankNError
fromFieldWrap gk        nr (SigT t _) = fromFieldWrap gk nr t
fromFieldWrap Gen0      nr t          = conE (boxRepName t) `appE` varE (field nr)
fromFieldWrap (Gen1 nb) nr t          = wC t nb             `appE` varE (field nr)

wC :: Type -> NameBase -> Q Exp
wC (VarT n) nb | NameBase n == nb = conE par1DataName
wC t nb
  | ground t nb = conE $ boxRepName t
  | otherwise = do
      let tyHead:tyArgs      = unapplyTy t
          numLastArgs        = min 1 $ length tyArgs
          (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs

          inspectTy :: Type -> Q Exp
          inspectTy ForallT{} = rankNError
          inspectTy (SigT ty _) = inspectTy ty
          inspectTy (VarT a)
            | NameBase a == nb
            = conE rec1DataName
          inspectTy beta = infixApp (conE comp1DataName)
                                    (varE composeValName)
                                    (varE fmapValName `appE` wC beta nb)

      itf <- isTyFamily tyHead
      if any (not . (`ground` nb)) lhsArgs
           || any (not . (`ground` nb)) tyArgs && itf
         then outOfPlaceTyVarError
         else case rhsArgs of
              []   -> conE $ boxRepName t
              ty:_ -> inspectTy ty

boxRepName :: Type -> Name
boxRepName = maybe k1DataName (\(_, boxName, _) -> boxName) . unboxedRepNames

toCon :: GenericKind -> (Q Pat -> Q Pat) -> Int -> Int -> Con -> Q Match
toCon _ wrap m i (NormalC cn []) =
    match
      (wrap $ conP m1DataName [lrP m i $ conP m1DataName
        [conP m1DataName [conP u1DataName []]]])
      (normalB $ conE cn) []
toCon gk wrap m i (NormalC cn fs) =
    -- runIO (putStrLn ("constructor " ++ show ix)) >>
    match
      (wrap $ conP m1DataName [lrP m i $ conP m1DataName
        [foldr1 prod (zipWith (\nr -> toField gk nr . snd) [0..] fs)]])
      (normalB $ foldl appE (conE cn) (zipWith (\nr t -> expandSyn t >>= toConUnwC gk nr)
                                      [0..] (map snd fs))) []
  where prod x y = conP productDataName [x,y]
toCon _ wrap m i (RecC cn []) =
    match
      (wrap $ conP m1DataName [lrP m i $ conP m1DataName [conP u1DataName []]])
      (normalB $ conE cn) []
toCon gk wrap m i (RecC cn fs) =
    match
      (wrap $ conP m1DataName [lrP m i $ conP m1DataName
        [foldr1 prod (zipWith (\nr (_, _, t) -> toField gk nr t) [0..] fs)]])
      (normalB $ foldl appE (conE cn) (zipWith (\nr t -> expandSyn t >>= toConUnwC gk nr)
                                               [0..] (map trd fs))) []
  where prod x y = conP productDataName [x,y]
toCon gk wrap m i (InfixC t1 cn t2) =
  toCon gk wrap m i (NormalC cn [t1,t2])
toCon _ _ _ _ (ForallC _ _ con) = forallCError con

toConUnwC :: GenericKind -> Int -> Type -> Q Exp
toConUnwC Gen0      nr _ = varE $ field nr
toConUnwC (Gen1 nb) nr t = unwC t nb `appE` varE (field nr)

toField :: GenericKind -> Int -> Type -> Q Pat
--toField (dt, vs) nr t | t == dataDeclToType (dt, vs) = conP 'I [varP (field nr)]
toField gk nr t = conP m1DataName [toFieldWrap gk nr t]

toFieldWrap :: GenericKind -> Int -> Type -> Q Pat
toFieldWrap Gen0     nr t = conP (boxRepName t) [varP (field nr)]
toFieldWrap (Gen1 _) nr _ = varP (field nr)

field :: Int -> Name
field n = mkName $ "f" ++ show n

unwC :: Type -> NameBase -> Q Exp
unwC (SigT t _) nb = unwC t nb
unwC (VarT n) nb | NameBase n == nb = varE unPar1ValName
unwC t nb
  | ground t nb = varE $ unboxRepName t
  | otherwise = do
      let tyHead:tyArgs      = unapplyTy t
          numLastArgs        = min 1 $ length tyArgs
          (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs

          inspectTy :: Type -> Q Exp
          inspectTy ForallT{} = rankNError
          inspectTy (SigT ty _) = inspectTy ty
          inspectTy (VarT a)
            | NameBase a == nb
            = varE unRec1ValName
          inspectTy beta = infixApp (varE fmapValName `appE` unwC beta nb)
                                    (varE composeValName)
                                    (varE unComp1ValName)

      itf <- isTyFamily tyHead
      if any (not . (`ground` nb)) lhsArgs
           || any (not . (`ground` nb)) tyArgs && itf
         then outOfPlaceTyVarError
         else case rhsArgs of
              []   -> varE $ unboxRepName t
              ty:_ -> inspectTy ty

unboxRepName :: Type -> Name
unboxRepName = maybe unK1ValName (\(_, _, unboxName) -> unboxName) . unboxedRepNames

lrP :: Int -> Int -> (Q Pat -> Q Pat)
lrP 1 0 p = p
lrP _ 0 p = conP l1DataName [p]
lrP m i p = conP r1DataName [lrP (m-1) (i-1) p]

lrE :: Int -> Int -> (Q Exp -> Q Exp)
lrE 1 0 e = e
lrE _ 0 e = conE l1DataName `appE` e
lrE m i e = conE r1DataName `appE` lrE (m-1) (i-1) e

unboxedRepNames :: Type -> Maybe (Name, Name, Name)
unboxedRepNames ty
  | ty == ConT addrHashTypeName   = Just (uAddrTypeName,   uAddrDataName,   uAddrHashValName)
  | ty == ConT charHashTypeName   = Just (uCharTypeName,   uCharDataName,   uCharHashValName)
  | ty == ConT doubleHashTypeName = Just (uDoubleTypeName, uDoubleDataName, uDoubleHashValName)
  | ty == ConT floatHashTypeName  = Just (uFloatTypeName,  uFloatDataName,  uFloatHashValName)
  | ty == ConT intHashTypeName    = Just (uIntTypeName,    uIntDataName,    uIntHashValName)
  | ty == ConT wordHashTypeName   = Just (uWordTypeName,   uWordDataName,   uWordHashValName)
  | otherwise                     = Nothing

-- | Boilerplate for top level splices.
--
-- The given Name must meet one of two criteria:
--
-- 1. It must be the name of a type constructor of a plain data type or newtype.
-- 2. It must be the name of a data family instance or newtype instance constructor.
--
-- Any other value will result in an exception.
reifyDataInfo :: Name
              -> Q (Either String (Name, Bool, [TyVarBndr], [Con], DataVariety))
reifyDataInfo name = do
  info <- reify name
  case info of
    TyConI dec ->
      return $ case dec of
        DataD    ctxt _ tvbs cons _ -> Right $
          checkDataContext name ctxt (name, False, tvbs, cons, DataPlain)
        NewtypeD ctxt _ tvbs con  _ -> Right $
          checkDataContext name ctxt (name, True, tvbs, [con], DataPlain)
        TySynD{} -> Left $ ns ++ "Type synonyms are not supported."
        _        -> Left $ ns ++ "Unsupported type: " ++ show dec
#if MIN_VERSION_template_haskell(2,7,0)
# if MIN_VERSION_template_haskell(2,11,0)
    DataConI _ _ parentName   -> do
# else
    DataConI _ _ parentName _ -> do
# endif
      parentInfo <- reify parentName
      return $ case parentInfo of
# if MIN_VERSION_template_haskell(2,11,0)
        FamilyI (DataFamilyD _ tvbs _) decs ->
# else
        FamilyI (FamilyD DataFam _ tvbs _) decs ->
# endif
          -- This isn't total, but the API requires that the data family instance have
          -- at least one constructor anyways, so this will always succeed.
          let instDec = flip find decs $ any ((name ==) . constructorName) . dataDecCons
           in case instDec of
                Just (DataInstD    ctxt _ instTys cons _) -> Right $
                  checkDataContext parentName ctxt
                    (parentName, False, tvbs, cons, DataFamily (constructorName $ head cons) instTys)
                Just (NewtypeInstD ctxt _ instTys con  _) -> Right $
                  checkDataContext parentName ctxt
                    (parentName, True, tvbs, [con], DataFamily (constructorName con) instTys)
                _ -> Left $ ns ++
                  "Could not find data or newtype instance constructor."
        _ -> Left $ ns ++ "Data constructor " ++ show name ++
          " is not from a data family instance constructor."
# if MIN_VERSION_template_haskell(2,11,0)
    FamilyI DataFamilyD{} _ ->
# else
    FamilyI (FamilyD DataFam _ _ _) _ ->
# endif
      return . Left $
        ns ++ "Cannot use a data family name. Use a data family instance constructor instead."
    _ -> return . Left $ ns ++ "The name must be of a plain data type constructor, "
                            ++ "or a data family instance constructor."
#else
    DataConI{} -> return . Left $ ns ++ "Cannot use a data constructor."
        ++ "\n\t(Note: if you are trying to derive for a data family instance, use GHC >= 7.4 instead.)"
    _          -> return . Left $ ns ++ "The name must be of a plain type constructor."
#endif
  where
    ns :: String
    ns = "Generics.Deriving.TH.reifyDataInfo: "

-- | Deduces the non-eta-reduced type variables, the instance type, the GenericKind
-- value to use for a Generic(1) instance.
buildTypeInstance :: Int
                  -- ^ Generic(0) or Generic1
                  -> Name
                  -- ^ The type constructor or data family name
                  -> [TyVarBndr]
                  -- ^ The type variables from the data type/data family declaration
                  -> [Con]
                  -- ^ The constructors of the data type/data family declaration
                  -> DataVariety
                  -- ^ If using a data family instance, provides the types used
                  -- to instantiate the instance
                  -> ([TyVarBndr], Type, GenericKind)
buildTypeInstance arity tyConName tvbs _ DataPlain
  | remainingLength < 0 || not (wellKinded droppedKinds) -- If we have enough well-kinded type variables
  = derivingKindError tyConName
  | otherwise = (remaining, instanceType, genericKindFromArity arity droppedNbs)
  where
    instanceType :: Type
    instanceType = applyTyToTvbs tyConName remaining

    remainingLength :: Int
    remainingLength = length tvbs - arity

    remaining, dropped :: [TyVarBndr]
    (remaining, dropped) = splitAt remainingLength tvbs

    droppedKinds :: [Kind]
    droppedKinds = map tyVarBndrToKind dropped

    droppedNbs :: [NameBase]
    droppedNbs = map tyVarBndrToNameBase dropped
buildTypeInstance arity parentName tvbs _cons (DataFamily _ instTysAndKinds)
  | remainingLength < 0 || not (wellKinded droppedKinds) -- If we have enough well-kinded type variables
  = derivingKindError parentName
  | canEtaReduce remaining dropped -- If it is safe to drop the type variables
  = (lhsTvbs, instanceType, genericKindFromArity arity droppedNbs)
  | otherwise = etaReductionError instanceType
  where
    -- We need to make sure that type variables in the instance head which have
    -- constraints aren't poly-kinded, e.g.,
    --
    -- @
    -- instance Generic (Foo (f :: k)) where
    -- @
    --
    -- To do this, we remove every kind ascription (i.e., strip off every 'SigT').
    instanceType :: Type
    instanceType = applyTyToTys (ConT parentName) $ map unSigT remaining

    remainingLength :: Int
    remainingLength = length tvbs - arity

    remaining, dropped :: [Type]
    (remaining, dropped) = splitAt remainingLength rhsTypes

    droppedKinds :: [Kind]
    droppedKinds = map tyVarBndrToKind . snd $ splitAt remainingLength tvbs

    droppedNbs :: [NameBase]
    droppedNbs = map varTToNameBase dropped

    -- We need to be mindful of an old GHC bug which causes kind variables to appear in
    -- @instTysAndKinds@ (as the name suggests) if
    --
    --   (1) @PolyKinds@ is enabled
    --   (2) either GHC 7.6 or 7.8 is being used (for more info, see Trac #9692).
    --
    -- Since Template Haskell doesn't seem to have a mechanism for detecting which
    -- language extensions are enabled, we do the next-best thing by counting
    -- the number of distinct kind variables in the data family declaration, and
    -- then dropping that number of entries from @instTysAndKinds@.
    instTypes :: [Type]
    instTypes =
#if __GLASGOW_HASKELL__ >= 710 || !(MIN_VERSION_template_haskell(2,8,0))
        instTysAndKinds
#else
        drop (Set.size . Set.unions $ map (distinctKindVars . tyVarBndrToKind) tvbs)
          instTysAndKinds
      where
        distinctKindVars :: Kind -> Set Name
# if MIN_VERSION_template_haskell(2,8,0)
        distinctKindVars (AppT k1 k2) = distinctKindVars k1 `Set.union` distinctKindVars k2
        distinctKindVars (SigT k _)   = distinctKindVars k
        distinctKindVars (VarT k)     = Set.singleton k
# endif
        distinctKindVars _            = Set.empty
#endif

    lhsTvbs :: [TyVarBndr]
    lhsTvbs = map (uncurry replaceTyVarName)
            . filter (isTyVar . snd)
            . take remainingLength
            $ zip tvbs rhsTypes

    -- In GHC 7.8, only the @Type@s up to the rightmost non-eta-reduced type variable
    -- in @instTypes@ are provided (as a result of a bug reported in Trac #9692). This
    -- is pretty inconvenient, as it makes it impossible to come up with the correct
    -- instance types in some cases. For example, consider the following code:
    --
    -- @
    -- data family Foo a b c
    -- data instance Foo Int y z = Foo Int y z
    -- $(deriveAll1 'Foo)
    -- @
    --
    -- Due to the aformentioned bug, Template Haskell doesn't tell us the names of
    -- either of type variables in the data instance (@y@ and @z@). As a result, we
    -- won't know to which fields of the 'Foo' constructor contain the rightmost type
    -- variable, which will result in an incorrect instance. Urgh.
    --
    -- A workaround is to ensure that you use the exact same type variables, in the
    -- exact same order, in the data family declaration and any data or newtype
    -- instances:
    --
    -- @
    -- data family Foo a b c
    -- data instance Foo Int b c = Foo Int b c
    -- $(deriveAll1 'Foo)
    -- @
    --
    -- Thankfully, other versions of GHC don't seem to have this bug.
    rhsTypes :: [Type]
    rhsTypes =
#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710
        instTypes ++ map tyVarBndrToType
                         (alignTyVarBndrs _cons $ drop (length instTypes) tvbs)
      where
        tyVarBndrToType :: TyVarBndr -> Type
        tyVarBndrToType (PlainTV n)    = VarT n
        tyVarBndrToType (KindedTV n k) = SigT (VarT n) k

        mapTyVarBndrName :: Name -> TyVarBndr -> TyVarBndr
        mapTyVarBndrName n PlainTV{}      = PlainTV n
        mapTyVarBndrName n (KindedTV _ k) = KindedTV n k

        -- To compensate for Trac #9692, we borrow some type variables from the data
        -- family declaration. However, the type variables used in a data family
        -- declaration are completely different from those used in a data family
        -- instance, even if their names appear to be the same. In particular,
        -- Template Haskell gives them different Name values.
        --
        -- We can account for this by walking through the constructors' type signatures
        -- to figure out what the correct Names should be, then replace the type
        -- variables from the data family declaration (which we borrow) with those
        -- from the constructors' type signatures.
        alignTyVarBndrs :: [Con] -> [TyVarBndr] -> [TyVarBndr]
        alignTyVarBndrs cons' tvbs' =
            let nbSet = Set.fromList $ map tyVarBndrToNameBase tvbs'
                nbMap = snd $ foldr alignCon (nbSet, Map.empty) cons'
            in map (\tvb -> mapTyVarBndrName (Map.findWithDefault
                                                (tyVarBndrToName     tvb)
                                                (tyVarBndrToNameBase tvb)
                                                nbMap
                                             ) tvb
                   ) tvbs'

        alignCon :: Con
                 -> (Set NameBase, Map NameBase Name)
                 -> (Set NameBase, Map NameBase Name)
        alignCon _ (nbs, m) | Set.null nbs = (nbs, m)
        alignCon (NormalC _ tys)    state = foldr alignTy state $ map snd tys
        alignCon (RecC    n tys)    state = alignCon (NormalC n $ map shrink tys) state
          where
            shrink (_, b, c) = (b, c)
        alignCon (InfixC ty1 n ty2) state = alignCon (NormalC n [ty1, ty2]) state
        alignCon (ForallC _ _ con)   _    = forallCError con

        alignTy :: Type
                -> (Set NameBase, Map NameBase Name)
                -> (Set NameBase, Map NameBase Name)
        alignTy _ (nbs, m) | Set.null nbs = (nbs, m)
        alignTy ForallT{}    _        = rankNError
        alignTy (AppT t1 t2) state    = alignTy t2 $ alignTy t1 state
        alignTy (SigT t _)   state    = alignTy t state
        alignTy (VarT n)     (nbs, m) =
            let nb = NameBase n
             in if nb `Set.member` nbs
                then let nbs' = nb `Set.delete` nbs
                         m'   = Map.insert nb n m
                      in (nbs', m')
                else (nbs, m)
        alignTy _            state    = state
#else
        instTypes
#endif

-- | True if the type does not mention the NameBase
ground :: Type -> NameBase -> Bool
ground (AppT t1 t2) nb = ground t1 nb && ground t2 nb
ground (SigT t _)   nb = ground t nb
ground (VarT n)     nb = NameBase n /= nb
ground ForallT{}    _  = rankNError
ground _            _  = True

-- | One of the last type variables cannot be eta-reduced (see the canEtaReduce
-- function for the criteria it would have to meet).
etaReductionError :: Type -> a
etaReductionError instanceType = error $
  "Cannot eta-reduce to an instance of form \n\tinstance (...) => "
  ++ pprint instanceType

-- | Either the given data type doesn't have enough type variables, or one of
-- the type variables to be eta-reduced cannot realize kind *.
derivingKindError :: Name -> a
derivingKindError tyConName = error
  . showString "Cannot derive well-kinded instance of form ‘Generic1 "
  . showParen True
    ( showString (nameBase tyConName)
    . showString " ..."
    )
  . showString "‘\n\tClass Generic1 expects an argument of kind * -> *"
  $ ""

outOfPlaceTyVarError :: a
outOfPlaceTyVarError = error $
    "Type applied to an argument involving the last parameter is not of kind * -> *"

-- | Deriving Generic(1) doesn't work with ExistentialQuantification
forallCError :: Con -> a
forallCError con = error $
  nameBase (constructorName con) ++ " must be a vanilla data constructor"

-- | Cannot have a constructor argument of form (forall a1 ... an. <type>)
-- when deriving Generic(1)
rankNError :: a
rankNError = error "Cannot have polymorphic arguments"

-- | One cannot derive Generic(1) instance for anything that uses DatatypeContexts,
-- so check to make sure the Cxt field of a datatype is null.
checkDataContext :: Name -> Cxt -> a -> a
checkDataContext _        [] x = x
checkDataContext dataName _  _ = error $
  nameBase dataName ++ " must not have a datatype context"

-- | Indicates whether Generic (Gen0) or Generic1 (Gen1) is being derived. Gen1
-- bundles the Name of the last type parameter.
data GenericKind = Gen0 | Gen1 NameBase

-- | Construct a GenericKind value from its arity.
genericKindFromArity :: Int -> [NameBase] -> GenericKind
genericKindFromArity 0 _   = Gen0
genericKindFromArity 1 nbs = Gen1 $ head nbs
genericKindFromArity _ _   = error "Invalid arity"

-- | Indicates whether Generic(1) is being derived for a plain data type (DataPlain)
-- or a data family instance (DataFamily). DataFamily bundles the Name of the data
-- family instance's first constructor (for Name-generation purposes) and the types
-- used to instantiate the instance.
data DataVariety = DataPlain | DataFamily Name [Type]