{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP          #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
module Staged.GHC.Generics.TH (
    deriveGeneric,
    deriveGeneric1,
) where

import Control.Monad ((>=>), unless, when, forM)

-- template-haskell
import Language.Haskell.TH
import Language.Haskell.TH.Syntax

-- names
import Staged.GHC.Generics.TH.Names
import Staged.GHC.Generics.Internal (sapply)

-- th-abstraction
import Language.Haskell.TH.Datatype

-- from generic-deriving
import Generics.Deriving.TH.Internal
import Generics.Deriving.TH.Post4_9
import Generics.Deriving.TH
       (KindSigOptions, Options (..), RepOptions (..), defaultOptions)

-- th-lift
import Language.Haskell.TH.Lift ()

import qualified Data.Map as Map (fromList)

-- | Derive 'Staged.GHC.Generics.Generic' using Template Haskell.
deriveGeneric :: Name -> Q [Dec]
deriveGeneric :: Name -> Q [Dec]
deriveGeneric Name
n = do
    Name
-> Name
-> GenericClass
-> Name
-> Name
-> Options
-> Name
-> Q [Dec]
deriveInstCommon Name
staged_genericTypeName  Name
staged_repTypeName  GenericClass
Generic  Name
staged_fromValName  Name
staged_toValName Options
defaultOptions Name
n

-- | Derive 'Staged.GHC.Generics.Generic1' using Template Haskell.
deriveGeneric1 :: Name -> Q [Dec]
deriveGeneric1 :: Name -> Q [Dec]
deriveGeneric1 Name
n = do
    Name
-> Name
-> GenericClass
-> Name
-> Name
-> Options
-> Name
-> Q [Dec]
deriveInstCommon Name
staged_generic1TypeName  Name
staged_rep1TypeName  GenericClass
Generic1  Name
staged_fromVal1Name  Name
staged_toVal1Name Options
defaultOptions Name
n

deriveInstCommon :: Name
                 -> Name
                 -> GenericClass
                 -> Name
                 -> Name
                 -> Options
                 -> Name
                 -> Q [Dec]
deriveInstCommon :: Name
-> Name
-> GenericClass
-> Name
-> Name
-> Options
-> Name
-> Q [Dec]
deriveInstCommon Name
genericName Name
repName GenericClass
gClass Name
fromName Name
toName Options
opts Name
n = do
  Either String (Name, [Type], [ConstructorInfo], DatatypeVariant_)
i <- Name
-> Q (Either
        String (Name, [Type], [ConstructorInfo], DatatypeVariant_))
reifyDataInfo Name
n

  let (Name
name, [Type]
instTys, [ConstructorInfo]
cons, DatatypeVariant_
dv) = (String -> (Name, [Type], [ConstructorInfo], DatatypeVariant_))
-> ((Name, [Type], [ConstructorInfo], DatatypeVariant_)
    -> (Name, [Type], [ConstructorInfo], DatatypeVariant_))
-> Either
     String (Name, [Type], [ConstructorInfo], DatatypeVariant_)
-> (Name, [Type], [ConstructorInfo], DatatypeVariant_)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> (Name, [Type], [ConstructorInfo], DatatypeVariant_)
forall a. HasCallStack => String -> a
error (Name, [Type], [ConstructorInfo], DatatypeVariant_)
-> (Name, [Type], [ConstructorInfo], DatatypeVariant_)
forall a. a -> a
id Either String (Name, [Type], [ConstructorInfo], DatatypeVariant_)
i
      useKindSigs :: KindSigOptions
useKindSigs = Options -> KindSigOptions
kindSigOptions Options
opts

  -- See Note [Forcing buildTypeInstance]
  !(Type
origTy, Type
origKind) <- GenericClass -> KindSigOptions -> Name -> [Type] -> Q (Type, Type)
buildTypeInstance GenericClass
gClass KindSigOptions
useKindSigs Name
name [Type]
instTys
  Type
tyInsRHS <- if Options -> RepOptions
repOptions Options
opts RepOptions -> RepOptions -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== RepOptions
InlineRep
                 then GenericClass
-> DatatypeVariant_
-> Name
-> [Type]
-> [ConstructorInfo]
-> Type
-> Q Type
makeRepInline   GenericClass
gClass DatatypeVariant_
dv Name
name [Type]
instTys [ConstructorInfo]
cons Type
origTy
                 else GenericClass -> DatatypeVariant_ -> Name -> Type -> Q Type
makeRepTySynApp GenericClass
gClass DatatypeVariant_
dv Name
name              Type
origTy

  let origSigTy :: Type
origSigTy = if KindSigOptions
useKindSigs
                     then Type -> Type -> Type
SigT Type
origTy Type
origKind
                     else Type
origTy
  Dec
tyIns <- Name -> Maybe [Q TyVarBndrUnit] -> [Q Type] -> Q Type -> DecQ
tySynInstDCompat Name
repName
                            Maybe [Q TyVarBndrUnit]
forall a. Maybe a
Nothing
                            [Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
origSigTy] (Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
tyInsRHS)

  let ecOptions :: KindSigOptions
ecOptions = Options -> KindSigOptions
emptyCaseOptions Options
opts
      mkBody :: (GenericClass
 -> KindSigOptions
 -> Int
 -> Int
 -> Name
 -> [Type]
 -> [ConstructorInfo]
 -> Q Match)
-> [Q Clause]
mkBody GenericClass
-> KindSigOptions
-> Int
-> Int
-> Name
-> [Type]
-> [ConstructorInfo]
-> Q Match
maker = [[Q Pat] -> Q Body -> [DecQ] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (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
$
        GenericClass
-> KindSigOptions
-> Name
-> [Type]
-> [ConstructorInfo]
-> (GenericClass
    -> KindSigOptions
    -> Int
    -> Int
    -> Name
    -> [Type]
    -> [ConstructorInfo]
    -> Q Match)
-> Q Exp
mkCaseExp GenericClass
gClass KindSigOptions
ecOptions Name
name [Type]
instTys [ConstructorInfo]
cons GenericClass
-> KindSigOptions
-> Int
-> Int
-> Name
-> [Type]
-> [ConstructorInfo]
-> Q Match
maker) []]
      tcs :: [Q Clause]
tcs = (GenericClass
 -> KindSigOptions
 -> Int
 -> Int
 -> Name
 -> [Type]
 -> [ConstructorInfo]
 -> Q Match)
-> [Q Clause]
mkBody GenericClass
-> KindSigOptions
-> Int
-> Int
-> Name
-> [Type]
-> [ConstructorInfo]
-> Q Match
mkTo

      fcs' :: Q Exp
fcs' = do
        Name
val <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"val"
        Name
k   <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"_kont" -- avoids unused warning
        [Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
val, Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
k] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
          [| unsafeCodeCoerce |] Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [| caseE |]
            [ [| unTypeCode |] 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
val
            , Q Exp
-> GenericClass
-> KindSigOptions
-> Int
-> Int
-> Name
-> [Type]
-> [ConstructorInfo]
-> Q Exp
mkFrom (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
k) GenericClass
gClass KindSigOptions
ecOptions Int
1 Int
1 Name
name [Type]
instTys [ConstructorInfo]
cons
            ]

      fcs :: [Q Clause]
fcs = [ [Q Pat] -> Q Body -> [DecQ] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
fcs') []]

  (Dec -> [Dec]) -> DecQ -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[]) (DecQ -> Q [Dec]) -> DecQ -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
    Q [Type] -> Q Type -> [DecQ] -> DecQ
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD ([Q Type] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt []) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
genericName Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
origSigTy)
                         [Dec -> DecQ
forall (m :: * -> *) a. Monad m => a -> m a
return Dec
tyIns, Name -> [Q Clause] -> DecQ
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
fromName [Q Clause]
fcs, Name -> [Q Clause] -> DecQ
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
toName [Q Clause]
tcs]

-------------------------------------------------------------------------------
-- Internal
-------------------------------------------------------------------------------

-- For the given Types, deduces the instance type (and kind) to use for a
-- Generic(1) instance. Coming up with the instance type isn't as simple as
-- dropping the last types, as you need to be wary of kinds being instantiated
-- with *.
-- See Note [Type inference in derived instances]
buildTypeInstance :: GenericClass
                  -- ^ Generic or Generic1
                  -> KindSigOptions
                  -- ^ Whether or not to use explicit kind signatures in the instance type
                  -> Name
                  -- ^ The type constructor or data family name
                  -> [Type]
                  -- ^ The types to instantiate the instance with
                  -> Q (Type, Kind)
buildTypeInstance :: GenericClass -> KindSigOptions -> Name -> [Type] -> Q (Type, Type)
buildTypeInstance GenericClass
gClass KindSigOptions
useKindSigs Name
tyConName [Type]
varTysOrig = do
    -- Make sure to expand through type/kind synonyms! Otherwise, the
    -- eta-reduction check might get tripped up over type variables in a
    -- synonym that are actually dropped.
    -- (See GHC Trac #11416 for a scenario where this actually happened.)
    [Type]
varTysExp <- (Type -> Q Type) -> [Type] -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q Type
resolveTypeSynonyms [Type]
varTysOrig

    let remainingLength :: Int
        remainingLength :: Int
remainingLength = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
varTysOrig Int -> Int -> Int
forall a. Num a => a -> a -> a
- GenericClass -> Int
forall a. Enum a => a -> Int
fromEnum GenericClass
gClass

        droppedTysExp :: [Type]
        droppedTysExp :: [Type]
droppedTysExp = Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
drop Int
remainingLength [Type]
varTysExp

        droppedStarKindStati :: [StarKindStatus]
        droppedStarKindStati :: [StarKindStatus]
droppedStarKindStati = (Type -> StarKindStatus) -> [Type] -> [StarKindStatus]
forall a b. (a -> b) -> [a] -> [b]
map Type -> StarKindStatus
canRealizeKindStar [Type]
droppedTysExp

    -- Check there are enough types to drop and that all of them are either of
    -- kind * or kind k (for some kind variable k). If not, throw an error.
    KindSigOptions -> Q () -> Q ()
forall (f :: * -> *).
Applicative f =>
KindSigOptions -> f () -> f ()
when (Int
remainingLength Int -> Int -> KindSigOptions
forall a. Ord a => a -> a -> KindSigOptions
< Int
0 KindSigOptions -> KindSigOptions -> KindSigOptions
|| (StarKindStatus -> KindSigOptions)
-> [StarKindStatus] -> KindSigOptions
forall (t :: * -> *) a.
Foldable t =>
(a -> KindSigOptions) -> t a -> KindSigOptions
any (StarKindStatus -> StarKindStatus -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== StarKindStatus
NotKindStar) [StarKindStatus]
droppedStarKindStati) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
      Name -> Q ()
forall a. Name -> Q a
derivingKindError Name
tyConName

        -- Substitute kind * for any dropped kind variables
    let varTysExpSubst :: [Type]
-- See Note [Generic1 is polykinded in base-4.10]
#if MIN_VERSION_base(4,10,0)
        varTysExpSubst :: [Type]
varTysExpSubst = [Type]
varTysExp
#else
        varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp

        droppedKindVarNames :: [Name]
        droppedKindVarNames = catKindVarNames droppedStarKindStati
#endif

    let remainingTysExpSubst, droppedTysExpSubst :: [Type]
        ([Type]
remainingTysExpSubst, [Type]
droppedTysExpSubst) =
          Int -> [Type] -> ([Type], [Type])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
remainingLength [Type]
varTysExpSubst

-- See Note [Generic1 is polykinded in base-4.10]
#if !(MIN_VERSION_base(4,10,0))
    -- If any of the dropped types were polykinded, ensure that there are of
    -- kind * after substituting * for the dropped kind variables. If not,
    -- throw an error.
    unless (all hasKindStar droppedTysExpSubst) $
      derivingKindError tyConName
#endif

        -- We now substitute all of the specialized-to-* kind variable names
        -- with *, but in the original types, not the synonym-expanded types. The reason
        -- we do this is a superficial one: we want the derived instance to resemble
        -- the datatype written in source code as closely as possible. For example,
        -- for the following data family instance:
        --
        --   data family Fam a
        --   newtype instance Fam String = Fam String
        --
        -- We'd want to generate the instance:
        --
        --   instance C (Fam String)
        --
        -- Not:
        --
        --   instance C (Fam [Char])
    let varTysOrigSubst :: [Type]
        varTysOrigSubst :: [Type]
varTysOrigSubst =
-- See Note [Generic1 is polykinded in base-4.10]
#if MIN_VERSION_base(4,10,0)
          [Type] -> [Type]
forall a. a -> a
id
#else
          map (substNamesWithKindStar droppedKindVarNames)
#endif
            ([Type] -> [Type]) -> [Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ [Type]
varTysOrig

        remainingTysOrigSubst, droppedTysOrigSubst :: [Type]
        ([Type]
remainingTysOrigSubst, [Type]
droppedTysOrigSubst) =
            Int -> [Type] -> ([Type], [Type])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
remainingLength [Type]
varTysOrigSubst

        remainingTysOrigSubst' :: [Type]
        -- See Note [Kind signatures in derived instances] for an explanation
        -- of the useKindSigs check.
        remainingTysOrigSubst' :: [Type]
remainingTysOrigSubst' =
          if KindSigOptions
useKindSigs
             then [Type]
remainingTysOrigSubst
             else (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
unSigT [Type]
remainingTysOrigSubst

        instanceType :: Type
        instanceType :: Type
instanceType = Type -> [Type] -> Type
applyTyToTys (Name -> Type
ConT Name
tyConName) [Type]
remainingTysOrigSubst'

        -- See Note [Kind signatures in derived instances]
        instanceKind :: Kind
        instanceKind :: Type
instanceKind = [Type] -> Type -> Type
makeFunKind ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
typeKind [Type]
droppedTysOrigSubst) Type
starK

    -- Ensure the dropped types can be safely eta-reduced. Otherwise,
    -- throw an error.
    KindSigOptions -> Q () -> Q ()
forall (f :: * -> *).
Applicative f =>
KindSigOptions -> f () -> f ()
unless ([Type] -> [Type] -> KindSigOptions
canEtaReduce [Type]
remainingTysExpSubst [Type]
droppedTysExpSubst) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
      Type -> Q ()
forall a. Type -> Q a
etaReductionError Type
instanceType
    (Type, Type) -> Q (Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
instanceType, Type
instanceKind)

makeRepInline :: GenericClass
              -> DatatypeVariant_
              -> Name
              -> [Type]
              -> [ConstructorInfo]
              -> Type
              -> Q Type
makeRepInline :: GenericClass
-> DatatypeVariant_
-> Name
-> [Type]
-> [ConstructorInfo]
-> Type
-> Q Type
makeRepInline GenericClass
gClass DatatypeVariant_
dv Name
name [Type]
instTys [ConstructorInfo]
cons Type
ty = do
  let instVars :: [TyVarBndrUnit]
instVars = [Type] -> [TyVarBndrUnit]
freeVariablesWellScoped [Type
ty]
      ([TyVarBndrUnit]
tySynVars, GenericKind
gk)  = GenericClass -> [Type] -> ([TyVarBndrUnit], GenericKind)
genericKind GenericClass
gClass [Type]
instTys

      typeSubst :: TypeSubst
      typeSubst :: TypeSubst
typeSubst = [(Name, Type)] -> TypeSubst
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, Type)] -> TypeSubst) -> [(Name, Type)] -> TypeSubst
forall a b. (a -> b) -> a -> b
$
        [Name] -> [Type] -> [(Name, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((TyVarBndrUnit -> Name) -> [TyVarBndrUnit] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrUnit -> Name
forall flag. TyVarBndr_ flag -> Name
tvName [TyVarBndrUnit]
tySynVars)
            ((TyVarBndrUnit -> Type) -> [TyVarBndrUnit] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Type
VarT (Name -> Type) -> (TyVarBndrUnit -> Name) -> TyVarBndrUnit -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndrUnit -> Name
forall flag. TyVarBndr_ flag -> Name
tvName) [TyVarBndrUnit]
instVars)

  GenericKind
-> DatatypeVariant_
-> Name
-> TypeSubst
-> [ConstructorInfo]
-> Q Type
repType GenericKind
gk DatatypeVariant_
dv Name
name TypeSubst
typeSubst [ConstructorInfo]
cons

genRepName :: GenericClass -> DatatypeVariant_
           -> Name -> Name
genRepName :: GenericClass -> DatatypeVariant_ -> Name -> Name
genRepName GenericClass
gClass DatatypeVariant_
dv Name
n
  = String -> Name
mkName
  (String -> Name) -> (String -> String) -> String -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DatatypeVariant_ -> String -> String
showsDatatypeVariant DatatypeVariant_
dv
  (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String
"Rep" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (GenericClass -> Int
forall a. Enum a => a -> Int
fromEnum GenericClass
gClass)) String -> String -> String
forall a. [a] -> [a] -> [a]
++)
  (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name -> String
showNameQual Name
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_") String -> String -> String
forall a. [a] -> [a] -> [a]
++)
  (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
sanitizeName
  (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
n

repType :: GenericKind
        -> DatatypeVariant_
        -> Name
        -> TypeSubst
        -> [ConstructorInfo]
        -> Q Type
repType :: GenericKind
-> DatatypeVariant_
-> Name
-> TypeSubst
-> [ConstructorInfo]
-> Q Type
repType GenericKind
gk DatatypeVariant_
dv Name
dt TypeSubst
typeSubst [ConstructorInfo]
cs =
    Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
d2TypeName Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` DatatypeVariant_ -> Name -> Q Type
mkMetaDataType DatatypeVariant_
dv Name
dt Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT`
      (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall a. (a -> a -> a) -> a -> [a] -> a
foldBal Q Type -> Q Type -> Q Type
sum' (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
v2TypeName) ((ConstructorInfo -> Q Type) -> [ConstructorInfo] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map (GenericKind
-> DatatypeVariant_
-> Name
-> TypeSubst
-> ConstructorInfo
-> Q Type
repCon GenericKind
gk DatatypeVariant_
dv Name
dt TypeSubst
typeSubst) [ConstructorInfo]
cs)
  where
    sum' :: Q Type -> Q Type -> Q Type
    sum' :: Q Type -> Q Type -> Q Type
sum' Q Type
a Q Type
b = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
staged_sumTypeName Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
a Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
b

repCon :: GenericKind
       -> DatatypeVariant_
       -> Name
       -> TypeSubst
       -> ConstructorInfo
       -> Q Type
repCon :: GenericKind
-> DatatypeVariant_
-> Name
-> TypeSubst
-> ConstructorInfo
-> Q Type
repCon GenericKind
gk DatatypeVariant_
dv Name
dt TypeSubst
typeSubst
  (ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName       = Name
n
                   , constructorVars :: ConstructorInfo -> [TyVarBndrUnit]
constructorVars       = [TyVarBndrUnit]
vars
                   , constructorContext :: ConstructorInfo -> [Type]
constructorContext    = [Type]
ctxt
                   , constructorStrictness :: ConstructorInfo -> [FieldStrictness]
constructorStrictness = [FieldStrictness]
bangs
                   , constructorFields :: ConstructorInfo -> [Type]
constructorFields     = [Type]
ts
                   , constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant    = ConstructorVariant
cv
                   }) = do
  Name -> [TyVarBndrUnit] -> [Type] -> Q ()
checkExistentialContext Name
n [TyVarBndrUnit]
vars [Type]
ctxt
  let mbSelNames :: Maybe [Name]
mbSelNames = case ConstructorVariant
cv of
                     ConstructorVariant
NormalConstructor          -> Maybe [Name]
forall a. Maybe a
Nothing
                     ConstructorVariant
InfixConstructor           -> Maybe [Name]
forall a. Maybe a
Nothing
                     RecordConstructor [Name]
selNames -> [Name] -> Maybe [Name]
forall a. a -> Maybe a
Just [Name]
selNames
      isRecord :: KindSigOptions
isRecord   = case ConstructorVariant
cv of
                     ConstructorVariant
NormalConstructor   -> KindSigOptions
False
                     ConstructorVariant
InfixConstructor    -> KindSigOptions
False
                     RecordConstructor [Name]
_ -> KindSigOptions
True
      isInfix :: KindSigOptions
isInfix    = case ConstructorVariant
cv of
                     ConstructorVariant
NormalConstructor   -> KindSigOptions
False
                     ConstructorVariant
InfixConstructor    -> KindSigOptions
True
                     RecordConstructor [Name]
_ -> KindSigOptions
False
  [SelStrictInfo]
ssis <- Name -> [FieldStrictness] -> Q [SelStrictInfo]
reifySelStrictInfo Name
n [FieldStrictness]
bangs
  GenericKind
-> DatatypeVariant_
-> Name
-> Name
-> TypeSubst
-> Maybe [Name]
-> [SelStrictInfo]
-> [Type]
-> KindSigOptions
-> KindSigOptions
-> Q Type
repConWith GenericKind
gk DatatypeVariant_
dv Name
dt Name
n TypeSubst
typeSubst Maybe [Name]
mbSelNames [SelStrictInfo]
ssis [Type]
ts KindSigOptions
isRecord KindSigOptions
isInfix

repConWith :: GenericKind
           -> DatatypeVariant_
           -> Name
           -> Name
           -> TypeSubst
           -> Maybe [Name]
           -> [SelStrictInfo]
           -> [Type]
           -> Bool
           -> Bool
           -> Q Type
repConWith :: GenericKind
-> DatatypeVariant_
-> Name
-> Name
-> TypeSubst
-> Maybe [Name]
-> [SelStrictInfo]
-> [Type]
-> KindSigOptions
-> KindSigOptions
-> Q Type
repConWith GenericKind
gk DatatypeVariant_
dv Name
dt Name
n TypeSubst
typeSubst Maybe [Name]
mbSelNames [SelStrictInfo]
ssis [Type]
ts KindSigOptions
isRecord KindSigOptions
isInfix = do
    let structureType :: Q Type
        structureType :: Q Type
structureType = (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall a. (a -> a -> a) -> a -> [a] -> a
foldBal Q Type -> Q Type -> Q Type
prodT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
u2TypeName) [Q Type]
f

        f :: [Q Type]
        f :: [Q Type]
f = case Maybe [Name]
mbSelNames of
                 Just [Name]
selNames -> (Name -> SelStrictInfo -> Type -> Q Type)
-> [Name] -> [SelStrictInfo] -> [Type] -> [Q Type]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 (GenericKind
-> DatatypeVariant_
-> Name
-> Name
-> TypeSubst
-> Maybe Name
-> SelStrictInfo
-> Type
-> Q Type
repField GenericKind
gk DatatypeVariant_
dv Name
dt Name
n TypeSubst
typeSubst (Maybe Name -> SelStrictInfo -> Type -> Q Type)
-> (Name -> Maybe Name) -> Name -> SelStrictInfo -> Type -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Maybe Name
forall a. a -> Maybe a
Just)
                                           [Name]
selNames [SelStrictInfo]
ssis [Type]
ts
                 Maybe [Name]
Nothing       -> (SelStrictInfo -> Type -> Q Type)
-> [SelStrictInfo] -> [Type] -> [Q Type]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith  (GenericKind
-> DatatypeVariant_
-> Name
-> Name
-> TypeSubst
-> Maybe Name
-> SelStrictInfo
-> Type
-> Q Type
repField GenericKind
gk DatatypeVariant_
dv Name
dt Name
n TypeSubst
typeSubst Maybe Name
forall a. Maybe a
Nothing)
                                           [SelStrictInfo]
ssis [Type]
ts

    Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
c2TypeName
      Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` DatatypeVariant_
-> Name -> Name -> KindSigOptions -> KindSigOptions -> Q Type
mkMetaConsType DatatypeVariant_
dv Name
dt Name
n KindSigOptions
isRecord KindSigOptions
isInfix
      Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
structureType

prodT :: Q Type -> Q Type -> Q Type
prodT :: Q Type -> Q Type -> Q Type
prodT Q Type
a Q Type
b = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
staged_productTypeName Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
a Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
b

repField :: GenericKind
         -> DatatypeVariant_
         -> Name
         -> Name
         -> TypeSubst
         -> Maybe Name
         -> SelStrictInfo
         -> Type
         -> Q Type
repField :: GenericKind
-> DatatypeVariant_
-> Name
-> Name
-> TypeSubst
-> Maybe Name
-> SelStrictInfo
-> Type
-> Q Type
repField GenericKind
gk DatatypeVariant_
dv Name
dt Name
ns TypeSubst
typeSubst Maybe Name
mbF SelStrictInfo
ssi Type
t =
           Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
s2TypeName
    Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` DatatypeVariant_
-> Name -> Name -> Maybe Name -> SelStrictInfo -> Q Type
mkMetaSelType DatatypeVariant_
dv Name
dt Name
ns Maybe Name
mbF SelStrictInfo
ssi
    Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` (GenericKind -> KindSigOptions -> Type -> Q Type
repFieldArg GenericKind
gk KindSigOptions
False (Type -> Q Type) -> Q Type -> Q Type
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> Q Type
resolveTypeSynonyms Type
t'')
  where
    -- See Note [Generic1 is polykinded in base-4.10]
    t', t'' :: Type
    t' :: Type
t' = case GenericKind
gk of
              Gen1 Name
_ (Just Name
_kvName) ->
#if MIN_VERSION_base(4,10,0)
                Type
t
#else
                substNameWithKind _kvName starK t
#endif
              GenericKind
_ -> Type
t
    t'' :: Type
t'' = TypeSubst -> Type -> Type
forall a. TypeSubstitution a => TypeSubst -> a -> a
applySubstitution TypeSubst
typeSubst Type
t'

repFieldArg :: GenericKind -> Bool -> Type -> Q Type
repFieldArg :: GenericKind -> KindSigOptions -> Type -> Q Type
repFieldArg GenericKind
_ KindSigOptions
_ ForallT{} = Q Type
forall a. a
rankNError
repFieldArg GenericKind
gk KindSigOptions
inPar (SigT Type
t Type
_) = GenericKind -> KindSigOptions -> Type -> Q Type
repFieldArg GenericKind
gk KindSigOptions
inPar Type
t
repFieldArg GenericKind
Gen0 KindSigOptions
_ Type
t = Type -> Q Type
boxT Type
t
repFieldArg (Gen1 Name
name Maybe Name
_) KindSigOptions
_ (VarT Name
t) | Name
t Name -> Name -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Name
name = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
par2TypeName
repFieldArg gk :: GenericKind
gk@(Gen1 Name
name Maybe Name
_) KindSigOptions
inPar Type
t = do
  let Type
tyHead:[Type]
tyArgs      = Type -> [Type]
unapplyTy Type
t
      numLastArgs :: Int
numLastArgs        = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
1 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tyArgs
      ([Type]
lhsArgs, [Type]
rhsArgs) = Int -> [Type] -> ([Type], [Type])
forall a. Int -> [a] -> ([a], [a])
splitAt ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tyArgs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numLastArgs) [Type]
tyArgs
      k2Type :: Q Type
k2Type             = Type -> Q Type
boxT Type
t
      phiType :: Q Type
phiType            = Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Type -> [Type] -> Type
applyTyToTys Type
tyHead [Type]
lhsArgs

  let inspectTy :: Type -> Q Type
      inspectTy :: Type -> Q Type
inspectTy (VarT Name
a)
        | Name
a Name -> Name -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Name
name
        = if KindSigOptions
inPar
          then Q Type
phiType
          else Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
staged_appTypeName Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
par2TypeName Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
phiType
      inspectTy (SigT Type
ty Type
_) = Type -> Q Type
inspectTy Type
ty
      inspectTy Type
beta
        | KindSigOptions -> KindSigOptions
not (Type -> Name -> KindSigOptions
ground Type
beta Name
name)
        = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
staged_appTypeName
          Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
staged_appTypeName Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
par2TypeName Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
phiType)
          Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` GenericKind -> KindSigOptions -> Type -> Q Type
repFieldArg GenericKind
gk KindSigOptions
True Type
beta
      inspectTy Type
_ = Q Type
k2Type

  KindSigOptions
itf <- Type -> Q KindSigOptions
isTyFamily Type
tyHead
  if (Type -> KindSigOptions) -> [Type] -> KindSigOptions
forall (t :: * -> *) a.
Foldable t =>
(a -> KindSigOptions) -> t a -> KindSigOptions
any (KindSigOptions -> KindSigOptions
not (KindSigOptions -> KindSigOptions)
-> (Type -> KindSigOptions) -> Type -> KindSigOptions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Name -> KindSigOptions
`ground` Name
name)) [Type]
lhsArgs
       KindSigOptions -> KindSigOptions -> KindSigOptions
|| (Type -> KindSigOptions) -> [Type] -> KindSigOptions
forall (t :: * -> *) a.
Foldable t =>
(a -> KindSigOptions) -> t a -> KindSigOptions
any (KindSigOptions -> KindSigOptions
not (KindSigOptions -> KindSigOptions)
-> (Type -> KindSigOptions) -> Type -> KindSigOptions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Name -> KindSigOptions
`ground` Name
name)) [Type]
tyArgs KindSigOptions -> KindSigOptions -> KindSigOptions
&& KindSigOptions
itf
     then Q Type
forall a. Q a
outOfPlaceTyVarError
     else case [Type]
rhsArgs of
          []   -> Q Type
k2Type
          Type
ty:[Type]
_ -> Type -> Q Type
inspectTy Type
ty

boxT :: Type -> Q Type
boxT :: Type -> Q Type
boxT Type
ty = case Type -> Maybe (Name, Name, Name)
unboxedRepNames Type
ty of
    Just (Name
boxTyName, Name
_, Name
_) -> Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
boxTyName
    Maybe (Name, Name, Name)
Nothing                -> Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
k2TypeName Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty

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

makeRepTySynApp :: GenericClass -> DatatypeVariant_ -> Name
                -> Type -> Q Type
makeRepTySynApp :: GenericClass -> DatatypeVariant_ -> Name -> Type -> Q Type
makeRepTySynApp GenericClass
gClass DatatypeVariant_
dv Name
name Type
ty =
  -- Here, we figure out the distinct type variables (in order from left-to-right)
  -- of the LHS of the Rep(1) instance. We call unKindedTV because the kind
  -- inferencer can figure out the kinds perfectly well, so we don't need to
  -- give anything here explicit kind signatures.
  let instTvbs :: [TyVarBndrUnit]
instTvbs = (TyVarBndrUnit -> TyVarBndrUnit)
-> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrUnit -> TyVarBndrUnit
unKindedTV ([TyVarBndrUnit] -> [TyVarBndrUnit])
-> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a b. (a -> b) -> a -> b
$ [Type] -> [TyVarBndrUnit]
freeVariablesWellScoped [Type
ty]
  in Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> [TyVarBndrUnit] -> Type
forall spec. Name -> [TyVarBndr_ spec] -> Type
applyTyToTvbs (GenericClass -> DatatypeVariant_ -> Name -> Name
genRepName GenericClass
gClass DatatypeVariant_
dv Name
name) [TyVarBndrUnit]
instTvbs

mkCaseExp
  :: GenericClass -> EmptyCaseOptions -> Name -> [Type] -> [ConstructorInfo]
  -> (GenericClass -> EmptyCaseOptions -> Int -> Int -> Name -> [Type]
                   -> [ConstructorInfo] -> Q Match)
  -> Q Exp
mkCaseExp :: GenericClass
-> KindSigOptions
-> Name
-> [Type]
-> [ConstructorInfo]
-> (GenericClass
    -> KindSigOptions
    -> Int
    -> Int
    -> Name
    -> [Type]
    -> [ConstructorInfo]
    -> Q Match)
-> Q Exp
mkCaseExp GenericClass
gClass KindSigOptions
ecOptions Name
dt [Type]
instTys [ConstructorInfo]
cs GenericClass
-> KindSigOptions
-> Int
-> Int
-> Name
-> [Type]
-> [ConstructorInfo]
-> Q Match
matchmaker = do
  Name
val <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"val"
  Q Pat -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Exp
lam1E (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
val) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
val) [GenericClass
-> KindSigOptions
-> Int
-> Int
-> Name
-> [Type]
-> [ConstructorInfo]
-> Q Match
matchmaker GenericClass
gClass KindSigOptions
ecOptions Int
1 Int
1 Name
dt [Type]
instTys [ConstructorInfo]
cs]

-- | 'True' if generated code for empty data types should use the @EmptyCase@
-- extension, 'False' otherwise. This has no effect on GHCs before 7.8, since
-- @EmptyCase@ is only available in 7.8 or later.
type EmptyCaseOptions = Bool

-------------------------------------------------------------------------------
-- mkTo
-------------------------------------------------------------------------------

mkTo :: GenericClass -> EmptyCaseOptions -> Int -> Int -> Name -> [Type]
     -> [ConstructorInfo] -> Q Match
mkTo :: GenericClass
-> KindSigOptions
-> Int
-> Int
-> Name
-> [Type]
-> [ConstructorInfo]
-> Q Match
mkTo GenericClass
gClass KindSigOptions
ecOptions Int
m Int
i Name
dt [Type]
instTys [ConstructorInfo]
cs = do
    Name
y <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"y"
    Q Pat -> Q Body -> [DecQ] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
m2DataName [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
y])
          (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
$ Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
y) [Q Match]
cases)
          []
  where
    cases :: [Q Match]
cases = case [ConstructorInfo]
cs of
              [] -> KindSigOptions -> Name -> [Q Match]
errorTo KindSigOptions
ecOptions Name
dt
              [ConstructorInfo]
_  -> (Int -> ConstructorInfo -> Q Match)
-> [Int] -> [ConstructorInfo] -> [Q Match]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (GenericKind
-> (Q Pat -> Q Pat) -> Int -> Int -> ConstructorInfo -> Q Match
toCon GenericKind
gk Q Pat -> Q Pat
wrapP ([ConstructorInfo] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
cs)) [Int
1..] [ConstructorInfo]
cs
    wrapP :: Q Pat -> Q Pat
wrapP Q Pat
p = Int -> Int -> Q Pat -> Q Pat
lrP Int
i Int
m Q Pat
p
    ([TyVarBndrUnit]
_, GenericKind
gk) = GenericClass -> [Type] -> ([TyVarBndrUnit], GenericKind)
genericKind GenericClass
gClass [Type]
instTys


toCon :: GenericKind -> (Q Pat -> Q Pat) -> Int -> Int
      -> ConstructorInfo -> Q Match
toCon :: GenericKind
-> (Q Pat -> Q Pat) -> Int -> Int -> ConstructorInfo -> Q Match
toCon GenericKind
gk Q Pat -> Q Pat
wrap Int
m Int
i
  (ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName    = Name
cn
                   , constructorVars :: ConstructorInfo -> [TyVarBndrUnit]
constructorVars    = [TyVarBndrUnit]
vars
                   , constructorContext :: ConstructorInfo -> [Type]
constructorContext = [Type]
ctxt
                   , constructorFields :: ConstructorInfo -> [Type]
constructorFields  = [Type]
ts
                   }) = do
  Name -> [TyVarBndrUnit] -> [Type] -> Q ()
checkExistentialContext Name
cn [TyVarBndrUnit]
vars [Type]
ctxt
  [Name]
fNames <- String -> Int -> Q [Name]
newNameList String
"f" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ts
  Q Pat -> Q Body -> [DecQ] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Q Pat -> Q Pat
wrap (Q Pat -> Q Pat) -> Q Pat -> Q Pat
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Q Pat -> Q Pat
lrP Int
i Int
m (Q Pat -> Q Pat) -> Q Pat -> Q Pat
forall a b. (a -> b) -> a -> b
$ Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
m2DataName
          [(Q Pat -> Q Pat -> Q Pat) -> Q Pat -> [Q Pat] -> Q Pat
forall a. (a -> a -> a) -> a -> [a] -> a
foldBal Q Pat -> Q Pat -> Q Pat
forall {m :: * -> *}. Quote m => m Pat -> m Pat -> m Pat
prod (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
u2DataName []) ((Name -> Type -> Q Pat) -> [Name] -> [Type] -> [Q Pat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (GenericKind -> Name -> Type -> Q Pat
toField GenericKind
gk) [Name]
fNames [Type]
ts)])
        (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
$ (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
          (\Q Exp
f Q Exp
x -> [| sapply $f $x |])
          ([| unsafeCodeCoerce |] Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ([| conE |] Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift Name
cn))
          ((Name -> Type -> Q Exp) -> [Name] -> [Type] -> [Q Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Name
nr -> Type -> Q Type
resolveTypeSynonyms (Type -> Q Type) -> (Type -> Q Exp) -> Type -> Q Exp
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> GenericKind -> Name -> Type -> Q Exp
toConUnwC GenericKind
gk Name
nr)
          [Name]
fNames [Type]
ts)) []
  where prod :: m Pat -> m Pat -> m Pat
prod m Pat
x m Pat
y = Name -> [m Pat] -> m Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
staged_productDataName [m Pat
x,m Pat
y]

toConUnwC :: GenericKind -> Name -> Type -> Q Exp
toConUnwC :: GenericKind -> Name -> Type -> Q Exp
toConUnwC GenericKind
Gen0          Name
nr Type
_ = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
nr
toConUnwC (Gen1 Name
name Maybe Name
_) Name
nr Type
t = Type -> KindSigOptions -> Name -> Name -> Q Exp
unwC Type
t KindSigOptions
False Name
name Name
nr

toField :: GenericKind -> Name -> Type -> Q Pat
toField :: GenericKind -> Name -> Type -> Q Pat
toField GenericKind
gk Name
nr Type
t = Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
m2DataName [GenericKind -> Name -> Type -> Q Pat
toFieldWrap GenericKind
gk Name
nr Type
t]

toFieldWrap :: GenericKind -> Name -> Type -> Q Pat
toFieldWrap :: GenericKind -> Name -> Type -> Q Pat
toFieldWrap GenericKind
Gen0   Name
nr Type
t = Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (Type -> Name
boxRepName Type
t) [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
nr]
toFieldWrap Gen1{} Name
nr Type
_ = Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
nr

unwC :: Type -> Bool -> Name -> Name -> Q Exp
unwC :: Type -> KindSigOptions -> Name -> Name -> Q Exp
unwC (SigT Type
t Type
_)  KindSigOptions
inPar Name
name Name
nr             = Type -> KindSigOptions -> Name -> Name -> Q Exp
unwC Type
t KindSigOptions
inPar Name
name Name
nr
unwC (VarT Name
t)   KindSigOptions
_inPar Name
name Name
nr | Name
t Name -> Name -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Name
name = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
unPar2ValName 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
nr
unwC Type
t           KindSigOptions
inPar Name
name Name
nr
  | Type -> Name -> KindSigOptions
ground Type
t Name
name = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Type -> Name
unboxRepName Type
t) 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
nr
  | KindSigOptions
otherwise = do
      let Type
tyHead:[Type]
tyArgs      = Type -> [Type]
unapplyTy Type
t
          numLastArgs :: Int
numLastArgs        = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
1 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tyArgs
          ([Type]
lhsArgs, [Type]
rhsArgs) = Int -> [Type] -> ([Type], [Type])
forall a. Int -> [a] -> ([a], [a])
splitAt ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tyArgs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numLastArgs) [Type]
tyArgs

          inspectTy :: Type -> Q Exp
          inspectTy :: Type -> Q Exp
inspectTy ForallT{} = Q Exp
forall a. a
rankNError
          inspectTy (SigT Type
ty Type
_) = Type -> Q Exp
inspectTy Type
ty
          inspectTy (VarT Name
a)
            | Name
a Name -> Name -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Name
name
            = if KindSigOptions
inPar
              then Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
unAppValName 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
nr
              else Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
unPar2ValName 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
unAppValName 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
nr)
          inspectTy Type
beta
            = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
unPar2ValName 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
unAppValName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Type -> KindSigOptions -> Name -> Name -> Q Exp
unwC Type
beta KindSigOptions
True Name
name Name
nr)

      KindSigOptions
itf <- Type -> Q KindSigOptions
isTyFamily Type
tyHead
      if (Type -> KindSigOptions) -> [Type] -> KindSigOptions
forall (t :: * -> *) a.
Foldable t =>
(a -> KindSigOptions) -> t a -> KindSigOptions
any (KindSigOptions -> KindSigOptions
not (KindSigOptions -> KindSigOptions)
-> (Type -> KindSigOptions) -> Type -> KindSigOptions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Name -> KindSigOptions
`ground` Name
name)) [Type]
lhsArgs
           KindSigOptions -> KindSigOptions -> KindSigOptions
|| (Type -> KindSigOptions) -> [Type] -> KindSigOptions
forall (t :: * -> *) a.
Foldable t =>
(a -> KindSigOptions) -> t a -> KindSigOptions
any (KindSigOptions -> KindSigOptions
not (KindSigOptions -> KindSigOptions)
-> (Type -> KindSigOptions) -> Type -> KindSigOptions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Name -> KindSigOptions
`ground` Name
name)) [Type]
tyArgs KindSigOptions -> KindSigOptions -> KindSigOptions
&& KindSigOptions
itf
         then Q Exp
forall a. Q a
outOfPlaceTyVarError
         else case [Type]
rhsArgs of
              []   -> Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Type -> Name
unboxRepName Type
t) 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
nr
              Type
ty:[Type]
_ -> Type -> Q Exp
inspectTy Type
ty

unboxRepName :: Type -> Name
unboxRepName :: Type -> Name
unboxRepName = Name
-> ((Name, Name, Name) -> Name) -> Maybe (Name, Name, Name) -> Name
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Name
unK2ValName (Name, Name, Name) -> Name
forall a b c. (a, b, c) -> c
trd3 (Maybe (Name, Name, Name) -> Name)
-> (Type -> Maybe (Name, Name, Name)) -> Type -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Maybe (Name, Name, Name)
unboxedRepNames

boxRepName :: Type -> Name
boxRepName :: Type -> Name
boxRepName = Name
-> ((Name, Name, Name) -> Name) -> Maybe (Name, Name, Name) -> Name
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Name
k2DataName (Name, Name, Name) -> Name
forall a b c. (a, b, c) -> b
snd3 (Maybe (Name, Name, Name) -> Name)
-> (Type -> Maybe (Name, Name, Name)) -> Type -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Maybe (Name, Name, Name)
unboxedRepNames

-------------------------------------------------------------------------------
-- mkFrom
-------------------------------------------------------------------------------

mkFrom :: Q Exp
       -> GenericClass -> EmptyCaseOptions -> Int -> Int -> Name -> [Type]
       -> [ConstructorInfo] -> Q Exp
mkFrom :: Q Exp
-> GenericClass
-> KindSigOptions
-> Int
-> Int
-> Name
-> [Type]
-> [ConstructorInfo]
-> Q Exp
mkFrom Q Exp
kont GenericClass
gClass KindSigOptions
ecOptions Int
m Int
i Name
dt [Type]
instTys [ConstructorInfo]
cs = do
    -- y <- newName "y"
    [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE [Q Exp]
cases
    -- match (varP y)
    --       (normalB $ conE m2DataName `appE` caseE (varE y) cases)
    --       []
  where
    cases :: [ExpQ]
    cases :: [Q Exp]
cases = case [ConstructorInfo]
cs of
              [] -> KindSigOptions -> Name -> [Q Exp]
errorFrom KindSigOptions
ecOptions Name
dt
              [ConstructorInfo]
_  -> (Int -> ConstructorInfo -> Q Exp)
-> [Int] -> [ConstructorInfo] -> [Q Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Q Exp
-> GenericKind
-> (Q Exp -> Q Exp)
-> Int
-> Int
-> ConstructorInfo
-> Q Exp
fromCon Q Exp
kont GenericKind
gk Q Exp -> Q Exp
wrapE ([ConstructorInfo] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
cs)) [Int
1..] [ConstructorInfo]
cs
    wrapE :: Q Exp -> Q Exp
wrapE Q Exp
e = Int -> Int -> Q Exp -> Q Exp
lrE Int
i Int
m Q Exp
e
    ([TyVarBndrUnit]
_, GenericKind
gk) = GenericClass -> [Type] -> ([TyVarBndrUnit], GenericKind)
genericKind GenericClass
gClass [Type]
instTys

errorFrom :: EmptyCaseOptions -> Name -> [ExpQ]
errorFrom :: KindSigOptions -> Name -> [Q Exp]
errorFrom KindSigOptions
_useEmptyCase Name
_dt = []
{- TODO:
  | useEmptyCase && ghc7'8OrLater
  = []
  | otherwise
  = [do z <- newName "z"
        match
          (varP z)
          (normalB $
            appE (varE seqValName) (varE z) `appE`
            appE (varE errorValName)
                 (stringE $ "No generic representation for empty datatype "
                          ++ nameBase dt))
          []]
-}

fromCon :: Q Exp
        -> GenericKind -> (Q Exp -> Q Exp) -> Int -> Int
        -> ConstructorInfo -> Q Exp
fromCon :: Q Exp
-> GenericKind
-> (Q Exp -> Q Exp)
-> Int
-> Int
-> ConstructorInfo
-> Q Exp
fromCon Q Exp
kont GenericKind
gk Q Exp -> Q Exp
wrap Int
m Int
i
  (ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName    = Name
cn
                   , constructorVars :: ConstructorInfo -> [TyVarBndrUnit]
constructorVars    = [TyVarBndrUnit]
vars
                   , constructorContext :: ConstructorInfo -> [Type]
constructorContext = [Type]
ctxt
                   , constructorFields :: ConstructorInfo -> [Type]
constructorFields  = [Type]
ts
                   }) = do
  Name -> [TyVarBndrUnit] -> [Type] -> Q ()
checkExistentialContext Name
cn [TyVarBndrUnit]
vars [Type]
ctxt
  [(Name, String)]
fNames <- String -> Int -> Q [(Name, String)]
newNameList' String
"f" (Int -> Q [(Name, String)]) -> Int -> Q [(Name, String)]
forall a b. (a -> b) -> a -> b
$ [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ts

  let fNameExps :: [ExpQ]
      fNameExps :: [Q Exp]
fNameExps =
          [ [| unsafeCodeCoerce (varE $(varE fName)) |]
          | (Name
fName, String
_) <- [(Name, String)]
fNames
          ]

  let kontArg :: ExpQ
      kontArg :: Q Exp
kontArg = Q Exp -> Q Exp
wrap (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Q Exp -> Q Exp
lrE Int
i Int
m (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
m2DataName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
         (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall a. (a -> a -> a) -> a -> [a] -> a
foldBal Q Exp -> Q Exp -> Q Exp
prodE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
u2DataName) ((Q Exp -> Type -> Q Exp) -> [Q Exp] -> [Type] -> [Q Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (GenericKind -> Q Exp -> Type -> Q Exp
fromField GenericKind
gk) [Q Exp]
fNameExps [Type]
ts)

  -- we create a do block which makes new variables.
  let bindNewNames :: [Q Stmt]
bindNewNames = [ Q Pat -> Q Exp -> Q Stmt
forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Stmt
bindS (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
v) [| newName $(stringE s) |] | (Name
v, String
s) <- [(Name, String)]
fNames ]

  [Q Stmt] -> Q Exp
forall (m :: * -> *). Quote m => [m Stmt] -> m Exp
doE ([Q Stmt] -> Q Exp) -> [Q Stmt] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Q Stmt]
bindNewNames [Q Stmt] -> [Q Stmt] -> [Q Stmt]
forall a. [a] -> [a] -> [a]
++

      -- match (conP cn (map varP fNames))
      --       (normalB $ wrap $ lrE i m $ conE m2DataName `appE`
      --         foldBal prodE (conE u2DataName) (zipWith (fromField gk) fNames ts)) []
      [ Q Exp -> Q Stmt
forall (m :: * -> *). Quote m => m Exp -> m Stmt
noBindS (Q Exp -> Q Stmt) -> Q Exp -> Q Stmt
forall a b. (a -> b) -> a -> b
$ (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [| match |]
          [ (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [| conP |]
              [ Name -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift Name
cn
              , [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE  [ [| varP |] 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
fName | (Name
fName, String
_) <- [(Name, String)]
fNames ]
              ]
          , [| normalB (unTypeCode ($kont $(conE m2DataName `appE` kontArg))) |]
          , [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE []
          ]
      ]

newNameList' :: String -> Int -> Q [(Name, String)]
newNameList' :: String -> Int -> Q [(Name, String)]
newNameList' String
prefix Int
n = [Int] -> (Int -> Q (Name, String)) -> Q [(Name, String)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
1..Int
n] ((Int -> Q (Name, String)) -> Q [(Name, String)])
-> (Int -> Q (Name, String)) -> Q [(Name, String)]
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
    let s :: String
s = String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
    Name
n' <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
s
    (Name, String) -> Q (Name, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n', String
s)

prodE :: Q Exp -> Q Exp -> Q Exp
prodE :: Q Exp -> Q Exp -> Q Exp
prodE Q Exp
x Q Exp
y = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
staged_productDataName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
x Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
y

fromField :: GenericKind -> Q Exp -> Type -> Q Exp
fromField :: GenericKind -> Q Exp -> Type -> Q Exp
fromField GenericKind
gk Q Exp
nr Type
t = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
m2DataName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (GenericKind -> Q Exp -> Type -> Q Exp
fromFieldWrap GenericKind
gk Q Exp
nr (Type -> Q Exp) -> Q Type -> Q Exp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> Q Type
resolveTypeSynonyms Type
t)

fromFieldWrap :: GenericKind -> Q Exp -> Type -> Q Exp
fromFieldWrap :: GenericKind -> Q Exp -> Type -> Q Exp
fromFieldWrap GenericKind
_             Q Exp
_  ForallT{}  = Q Exp
forall a. a
rankNError
fromFieldWrap GenericKind
gk            Q Exp
nr (SigT Type
t Type
_) = GenericKind -> Q Exp -> Type -> Q Exp
fromFieldWrap GenericKind
gk Q Exp
nr Type
t
fromFieldWrap GenericKind
Gen0          Q Exp
nr Type
t          = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE (Type -> Name
boxRepName Type
t) Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
nr
fromFieldWrap (Gen1 Name
name Maybe Name
_) Q Exp
nr Type
t          = Type -> Name -> Q Exp -> Q Exp
wC Type
t Name
name Q Exp
nr

wC :: Type -> Name -> Q Exp -> Q Exp
wC :: Type -> Name -> Q Exp -> Q Exp
wC (VarT Name
t) Name
name Q Exp
nr | Name
t Name -> Name -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Name
name = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
par2DataName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
nr
wC Type
t        Name
name Q Exp
nr
  | Type -> Name -> KindSigOptions
ground Type
t Name
name = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE (Type -> Name
boxRepName Type
t) Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
nr
  | KindSigOptions
otherwise = do
      let Type
tyHead:[Type]
tyArgs      = Type -> [Type]
unapplyTy Type
t
          numLastArgs :: Int
numLastArgs        = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
1 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tyArgs
          ([Type]
lhsArgs, [Type]
rhsArgs) = Int -> [Type] -> ([Type], [Type])
forall a. Int -> [a] -> ([a], [a])
splitAt ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tyArgs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numLastArgs) [Type]
tyArgs

          inspectTy :: Type -> Q Exp
          inspectTy :: Type -> Q Exp
inspectTy ForallT{} = Q Exp
forall a. a
rankNError
          inspectTy (SigT Type
ty Type
_) = Type -> Q Exp
inspectTy Type
ty
          inspectTy (VarT Name
a)
            | Name
a Name -> Name -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Name
name
            = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
appDataName 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
conE Name
par2DataName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
nr)
          inspectTy Type
beta =
              Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
appDataName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Type -> Name -> Q Exp -> Q Exp
wC Type
beta Name
name Q Exp
nr

      KindSigOptions
itf <- Type -> Q KindSigOptions
isTyFamily Type
tyHead
      if (Type -> KindSigOptions) -> [Type] -> KindSigOptions
forall (t :: * -> *) a.
Foldable t =>
(a -> KindSigOptions) -> t a -> KindSigOptions
any (KindSigOptions -> KindSigOptions
not (KindSigOptions -> KindSigOptions)
-> (Type -> KindSigOptions) -> Type -> KindSigOptions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Name -> KindSigOptions
`ground` Name
name)) [Type]
lhsArgs
           KindSigOptions -> KindSigOptions -> KindSigOptions
|| (Type -> KindSigOptions) -> [Type] -> KindSigOptions
forall (t :: * -> *) a.
Foldable t =>
(a -> KindSigOptions) -> t a -> KindSigOptions
any (KindSigOptions -> KindSigOptions
not (KindSigOptions -> KindSigOptions)
-> (Type -> KindSigOptions) -> Type -> KindSigOptions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Name -> KindSigOptions
`ground` Name
name)) [Type]
tyArgs KindSigOptions -> KindSigOptions -> KindSigOptions
&& KindSigOptions
itf
         then Q Exp
forall a. Q a
outOfPlaceTyVarError
         else case [Type]
rhsArgs of
              []   -> Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE (Type -> Name
boxRepName Type
t) Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
nr
              Type
ty:[Type]
_ -> Type -> Q Exp
inspectTy Type
ty

-------------------------------------------------------------------------------
-- Utilities
-------------------------------------------------------------------------------

errorTo :: EmptyCaseOptions -> Name -> [Q Match]
errorTo :: KindSigOptions -> Name -> [Q Match]
errorTo KindSigOptions
useEmptyCase Name
dt
  | KindSigOptions
useEmptyCase
  = []
  | KindSigOptions
otherwise
  = [do Name
z <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"z"
        Q Pat -> Q Body -> [DecQ] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match
          (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
z)
          (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
$
            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
seqValName) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
z) Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
            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
errorValName)
                 (String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"No values for empty datatype " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
dt))
          []]

lrP :: Int -> Int -> (Q Pat -> Q Pat)
lrP :: Int -> Int -> Q Pat -> Q Pat
lrP Int
i Int
n Q Pat
p
  | Int
n Int -> Int -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Int
0       = String -> Q Pat
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"lrP: impossible"
  | Int
n Int -> Int -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Int
1       = Q Pat
p
  | Int
i Int -> Int -> KindSigOptions
forall a. Ord a => a -> a -> KindSigOptions
<= Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
n Int
2 = Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
l2DataName [Int -> Int -> Q Pat -> Q Pat
lrP Int
i     (Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
n Int
2) Q Pat
p]
  | KindSigOptions
otherwise    = Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
r2DataName [Int -> Int -> Q Pat -> Q Pat
lrP (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
m) (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
m)     Q Pat
p]
                     where m :: Int
m = Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
n Int
2

lrE :: Int -> Int -> (Q Exp -> Q Exp)
lrE :: Int -> Int -> Q Exp -> Q Exp
lrE Int
i Int
n Q Exp
e
  | Int
n Int -> Int -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Int
0       = String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"lrE: impossible"
  | Int
n Int -> Int -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Int
1       = Q Exp
e
  | Int
i Int -> Int -> KindSigOptions
forall a. Ord a => a -> a -> KindSigOptions
<= Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
n Int
2 = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
l2DataName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Int -> Int -> Q Exp -> Q Exp
lrE Int
i     (Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
n Int
2) Q Exp
e
  | KindSigOptions
otherwise    = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
r2DataName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Int -> Int -> Q Exp -> Q Exp
lrE (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
m) (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
m)     Q Exp
e
                     where m :: Int
m = Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
n Int
2