{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
-- | Generate @generics-sop@ boilerplate instances using Template Haskell.
module Generics.SOP.TH
  ( deriveGeneric
  , deriveGenericOnly
  , deriveGenericSubst
  , deriveGenericOnlySubst
  , deriveGenericFunctions
  , deriveMetadataValue
  , deriveMetadataType
  ) where

import Control.Monad (join, replicateM, unless)
import Data.List (foldl')
import Data.Maybe (fromMaybe)
import Data.Proxy

-- importing in this order to avoid unused import warning
import Language.Haskell.TH.Datatype.TyVarBndr
import Language.Haskell.TH
import Language.Haskell.TH.Datatype as TH

import Generics.SOP.BasicFunctors
import qualified Generics.SOP.Metadata as SOP
import qualified Generics.SOP.Type.Metadata as SOP.T
import Generics.SOP.NP
import Generics.SOP.NS
import Generics.SOP.Universe

-- | Generate @generics-sop@ boilerplate for the given datatype.
--
-- This function takes the name of a datatype and generates:
--
--   * a 'Code' instance
--   * a 'Generic' instance
--   * a 'HasDatatypeInfo' instance
--
-- Note that the generated code will require the @TypeFamilies@ and
-- @DataKinds@ extensions to be enabled for the module.
--
-- /Example:/ If you have the datatype
--
-- > data Tree = Leaf Int | Node Tree Tree
--
-- and say
--
-- > deriveGeneric ''Tree
--
-- then you get code that is equivalent to:
--
-- > instance Generic Tree where
-- >
-- >   type Code Tree = '[ '[Int], '[Tree, Tree] ]
-- >
-- >   from (Leaf x)   = SOP (   Z (I x :* Nil))
-- >   from (Node l r) = SOP (S (Z (I l :* I r :* Nil)))
-- >
-- >   to (SOP    (Z (I x :* Nil)))         = Leaf x
-- >   to (SOP (S (Z (I l :* I r :* Nil)))) = Node l r
-- >   to (SOP (S (S x)))                   = x `seq` error "inaccessible"
-- >
-- > instance HasDatatypeInfo Tree where
-- >   type DatatypeInfoOf Tree =
-- >     T.ADT "Main" "Tree"
-- >       '[ T.Constructor "Leaf", T.Constructor "Node" ]
-- >
-- >   datatypeInfo _ =
-- >     T.demoteDatatypeInfo (Proxy :: Proxy (DatatypeInfoOf Tree))
--
-- /Limitations:/ Generation does not work for GADTs, for
-- datatypes that involve existential quantification, for
-- datatypes with unboxed fields.
--
deriveGeneric :: Name -> Q [Dec]
deriveGeneric :: Name -> Q [Dec]
deriveGeneric Name
n =
  Name -> (Name -> Q Type) -> Q [Dec]
deriveGenericSubst Name
n Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT

-- | Like 'deriveGeneric', but omit the 'HasDatatypeInfo' instance.
deriveGenericOnly :: Name -> Q [Dec]
deriveGenericOnly :: Name -> Q [Dec]
deriveGenericOnly Name
n =
  Name -> (Name -> Q Type) -> Q [Dec]
deriveGenericOnlySubst Name
n Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT

-- | Variant of 'deriveGeneric' that allows to restrict the type parameters.
--
-- Experimental function, exposed primarily for benchmarking.
--
deriveGenericSubst :: Name -> (Name -> Q Type) -> Q [Dec]
deriveGenericSubst :: Name -> (Name -> Q Type) -> Q [Dec]
deriveGenericSubst Name
n Name -> Q Type
f = do
  DatatypeInfo
dec <- Name -> Q DatatypeInfo
reifyDatatype Name
n
  [Dec]
ds1 <- DatatypeInfo
-> (DatatypeVariant
    -> Cxt
    -> Name
    -> [TyVarBndrUnit]
    -> Cxt
    -> [ConstructorInfo]
    -> Q [Dec])
-> Q [Dec]
forall a.
DatatypeInfo
-> (DatatypeVariant
    -> Cxt
    -> Name
    -> [TyVarBndrUnit]
    -> Cxt
    -> [ConstructorInfo]
    -> Q a)
-> Q a
withDataDec DatatypeInfo
dec ((Name -> Q Type)
-> DatatypeVariant
-> Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> [ConstructorInfo]
-> Q [Dec]
deriveGenericForDataDec  Name -> Q Type
f)
  [Dec]
ds2 <- DatatypeInfo
-> (DatatypeVariant
    -> Cxt
    -> Name
    -> [TyVarBndrUnit]
    -> Cxt
    -> [ConstructorInfo]
    -> Q [Dec])
-> Q [Dec]
forall a.
DatatypeInfo
-> (DatatypeVariant
    -> Cxt
    -> Name
    -> [TyVarBndrUnit]
    -> Cxt
    -> [ConstructorInfo]
    -> Q a)
-> Q a
withDataDec DatatypeInfo
dec ((Name -> Q Type)
-> DatatypeVariant
-> Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> [ConstructorInfo]
-> Q [Dec]
deriveMetadataForDataDec Name -> Q Type
f)
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec]
ds1 [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
ds2)

-- | Variant of 'deriveGenericOnly' that allows to restrict the type parameters.
--
-- Experimental function, exposed primarily for benchmarking.
--
deriveGenericOnlySubst :: Name -> (Name -> Q Type) -> Q [Dec]
deriveGenericOnlySubst :: Name -> (Name -> Q Type) -> Q [Dec]
deriveGenericOnlySubst Name
n Name -> Q Type
f = do
  DatatypeInfo
dec <- Name -> Q DatatypeInfo
reifyDatatype Name
n
  DatatypeInfo
-> (DatatypeVariant
    -> Cxt
    -> Name
    -> [TyVarBndrUnit]
    -> Cxt
    -> [ConstructorInfo]
    -> Q [Dec])
-> Q [Dec]
forall a.
DatatypeInfo
-> (DatatypeVariant
    -> Cxt
    -> Name
    -> [TyVarBndrUnit]
    -> Cxt
    -> [ConstructorInfo]
    -> Q a)
-> Q a
withDataDec DatatypeInfo
dec ((Name -> Q Type)
-> DatatypeVariant
-> Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> [ConstructorInfo]
-> Q [Dec]
deriveGenericForDataDec Name -> Q Type
f)

-- | Like 'deriveGenericOnly', but don't derive class instance, only functions.
--
-- /Example:/ If you say
--
-- > deriveGenericFunctions ''Tree "TreeCode" "fromTree" "toTree"
--
-- then you get code that is equivalent to:
--
-- > type TreeCode = '[ '[Int], '[Tree, Tree] ]
-- >
-- > fromTree :: Tree -> SOP I TreeCode
-- > fromTree (Leaf x)   = SOP (   Z (I x :* Nil))
-- > fromTree (Node l r) = SOP (S (Z (I l :* I r :* Nil)))
-- >
-- > toTree :: SOP I TreeCode -> Tree
-- > toTree (SOP    (Z (I x :* Nil)))         = Leaf x
-- > toTree (SOP (S (Z (I l :* I r :* Nil)))) = Node l r
-- > toTree (SOP (S (S x)))                   = x `seq` error "inaccessible"
--
-- @since 0.2
--
deriveGenericFunctions :: Name -> String -> String -> String -> Q [Dec]
deriveGenericFunctions :: Name -> String -> String -> String -> Q [Dec]
deriveGenericFunctions Name
n String
codeName String
fromName String
toName = do
  let codeName' :: Name
codeName' = String -> Name
mkName String
codeName
  let fromName' :: Name
fromName' = String -> Name
mkName String
fromName
  let toName' :: Name
toName'   = String -> Name
mkName String
toName
  DatatypeInfo
dec <- Name -> Q DatatypeInfo
reifyDatatype Name
n
  DatatypeInfo
-> (DatatypeVariant
    -> Cxt
    -> Name
    -> [TyVarBndrUnit]
    -> Cxt
    -> [ConstructorInfo]
    -> Q [Dec])
-> Q [Dec]
forall a.
DatatypeInfo
-> (DatatypeVariant
    -> Cxt
    -> Name
    -> [TyVarBndrUnit]
    -> Cxt
    -> [ConstructorInfo]
    -> Q a)
-> Q a
withDataDec DatatypeInfo
dec ((DatatypeVariant
  -> Cxt
  -> Name
  -> [TyVarBndrUnit]
  -> Cxt
  -> [ConstructorInfo]
  -> Q [Dec])
 -> Q [Dec])
-> (DatatypeVariant
    -> Cxt
    -> Name
    -> [TyVarBndrUnit]
    -> Cxt
    -> [ConstructorInfo]
    -> Q [Dec])
-> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \DatatypeVariant
_variant Cxt
_cxt Name
name [TyVarBndrUnit]
bndrs Cxt
instTys [ConstructorInfo]
cons -> do
    let codeType :: Q Type
codeType = (Name -> Q Type) -> [ConstructorInfo] -> Q Type
codeFor Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT [ConstructorInfo]
cons                     -- '[ '[Int], '[Tree, Tree] ]
    let origType :: Q Type
origType = (Name -> Q Type) -> Name -> Cxt -> Q Type
appTysSubst Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
name Cxt
instTys         -- Tree
    let repType :: Q Type
repType  = [t| SOP I $((Name -> Q Type) -> Name -> [TyVarBndrUnit] -> Q Type
appTyVars Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
codeName' [TyVarBndrUnit]
bndrs) |] -- SOP I TreeCode
    [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
      [ Name -> [TyVarBndrUnit] -> Q Type -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> [TyVarBndrUnit] -> m Type -> m Dec
tySynD Name
codeName' [TyVarBndrUnit]
bndrs Q Type
codeType                 -- type TreeCode = '[ '[Int], '[Tree, Tree] ]
      , Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
fromName' [t| $Q Type
origType -> $Q Type
repType |]     -- fromTree :: Tree -> SOP I TreeCode
      , Name -> [ConstructorInfo] -> Q Dec
embedding Name
fromName' [ConstructorInfo]
cons                        -- fromTree ... =
      , Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
toName' [t| $Q Type
repType -> $Q Type
origType |]       -- toTree :: SOP I TreeCode -> Tree
      , Name -> [ConstructorInfo] -> Q Dec
projection Name
toName' [ConstructorInfo]
cons                         -- toTree ... =
      ]

-- | Derive @DatatypeInfo@ value for the type.
--
-- /Example:/ If you say
--
-- > deriveMetadataValue ''Tree "TreeCode" "treeDatatypeInfo"
--
-- then you get code that is equivalent to:
--
-- > treeDatatypeInfo :: DatatypeInfo TreeCode
-- > treeDatatypeInfo = ADT "Main" "Tree"
-- >     (Constructor "Leaf" :* Constructor "Node" :* Nil)
--
-- /Note:/ CodeType needs to be derived with 'deriveGenericFunctions'.
--
-- @since 0.2
--
deriveMetadataValue :: Name -> String -> String -> Q [Dec]
deriveMetadataValue :: Name -> String -> String -> Q [Dec]
deriveMetadataValue Name
n String
codeName String
datatypeInfoName = do
  let codeName' :: Name
codeName'  = String -> Name
mkName String
codeName
  let datatypeInfoName' :: Name
datatypeInfoName' = String -> Name
mkName String
datatypeInfoName
  DatatypeInfo
dec <- Name -> Q DatatypeInfo
reifyDatatype Name
n
  DatatypeInfo
-> (DatatypeVariant
    -> Cxt
    -> Name
    -> [TyVarBndrUnit]
    -> Cxt
    -> [ConstructorInfo]
    -> Q [Dec])
-> Q [Dec]
forall a.
DatatypeInfo
-> (DatatypeVariant
    -> Cxt
    -> Name
    -> [TyVarBndrUnit]
    -> Cxt
    -> [ConstructorInfo]
    -> Q a)
-> Q a
withDataDec DatatypeInfo
dec ((DatatypeVariant
  -> Cxt
  -> Name
  -> [TyVarBndrUnit]
  -> Cxt
  -> [ConstructorInfo]
  -> Q [Dec])
 -> Q [Dec])
-> (DatatypeVariant
    -> Cxt
    -> Name
    -> [TyVarBndrUnit]
    -> Cxt
    -> [ConstructorInfo]
    -> Q [Dec])
-> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \DatatypeVariant
variant Cxt
_cxt Name
name [TyVarBndrUnit]
bndrs Cxt
_instTys [ConstructorInfo]
cons -> do
    [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
datatypeInfoName' [t| SOP.DatatypeInfo $((Name -> Q Type) -> Name -> [TyVarBndrUnit] -> Q Type
appTyVars Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
codeName' [TyVarBndrUnit]
bndrs) |] -- treeDatatypeInfo :: DatatypeInfo TreeCode
             , Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
datatypeInfoName' [[Q Pat] -> Q Body -> [Q Dec] -> 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
$ DatatypeVariant -> Name -> [ConstructorInfo] -> Q Exp
metadata' DatatypeVariant
variant Name
name [ConstructorInfo]
cons) []]    -- treeDatatypeInfo = ...
             ]
{-# DEPRECATED deriveMetadataValue "Use 'deriveMetadataType' and 'demoteDatatypeInfo' instead." #-}

-- | Derive @DatatypeInfo@ type for the type.
--
-- /Example:/ If you say
--
-- > deriveMetadataType ''Tree "TreeDatatypeInfo"
--
-- then you get code that is equivalent to:
--
-- > type TreeDatatypeInfo =
-- >   T.ADT "Main" "Tree"
-- >     [ T.Constructor "Leaf", T.Constructor "Node" ]
--
-- @since 0.3.0.0
--
deriveMetadataType :: Name -> String -> Q [Dec]
deriveMetadataType :: Name -> String -> Q [Dec]
deriveMetadataType Name
n String
datatypeInfoName = do
  let datatypeInfoName' :: Name
datatypeInfoName' = String -> Name
mkName String
datatypeInfoName
  DatatypeInfo
dec <- Name -> Q DatatypeInfo
reifyDatatype Name
n
  DatatypeInfo
-> (DatatypeVariant
    -> Cxt
    -> Name
    -> [TyVarBndrUnit]
    -> Cxt
    -> [ConstructorInfo]
    -> Q [Dec])
-> Q [Dec]
forall a.
DatatypeInfo
-> (DatatypeVariant
    -> Cxt
    -> Name
    -> [TyVarBndrUnit]
    -> Cxt
    -> [ConstructorInfo]
    -> Q a)
-> Q a
withDataDec DatatypeInfo
dec ((DatatypeVariant
  -> Cxt
  -> Name
  -> [TyVarBndrUnit]
  -> Cxt
  -> [ConstructorInfo]
  -> Q [Dec])
 -> Q [Dec])
-> (DatatypeVariant
    -> Cxt
    -> Name
    -> [TyVarBndrUnit]
    -> Cxt
    -> [ConstructorInfo]
    -> Q [Dec])
-> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \ DatatypeVariant
variant Cxt
_ctx Name
name [TyVarBndrUnit]
_bndrs Cxt
_instTys [ConstructorInfo]
cons ->
    [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
      [ Name -> [TyVarBndrUnit] -> Q Type -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> [TyVarBndrUnit] -> m Type -> m Dec
tySynD Name
datatypeInfoName' [] (DatatypeVariant -> Name -> [ConstructorInfo] -> Q Type
metadataType' DatatypeVariant
variant Name
name [ConstructorInfo]
cons) ]

deriveGenericForDataDec ::
  (Name -> Q Type) -> DatatypeVariant -> Cxt -> Name -> [TyVarBndrUnit] -> [Type] -> [TH.ConstructorInfo] -> Q [Dec]
deriveGenericForDataDec :: (Name -> Q Type)
-> DatatypeVariant
-> Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> [ConstructorInfo]
-> Q [Dec]
deriveGenericForDataDec Name -> Q Type
f DatatypeVariant
_variant Cxt
_cxt Name
name [TyVarBndrUnit]
_bndrs Cxt
instTys [ConstructorInfo]
cons = do
  let typ :: Q Type
typ = (Name -> Q Type) -> Name -> Cxt -> Q Type
appTysSubst Name -> Q Type
f Name
name Cxt
instTys
  (Name -> Q Type) -> Q Type -> [ConstructorInfo] -> Q [Dec]
deriveGenericForDataType Name -> Q Type
f Q Type
typ [ConstructorInfo]
cons

deriveGenericForDataType :: (Name -> Q Type) -> Q Type -> [TH.ConstructorInfo] -> Q [Dec]
deriveGenericForDataType :: (Name -> Q Type) -> Q Type -> [ConstructorInfo] -> Q [Dec]
deriveGenericForDataType Name -> Q Type
f Q Type
typ [ConstructorInfo]
cons = do
  let codeSyn :: Q Dec
codeSyn = Name -> Maybe [Q TyVarBndrUnit] -> [Q Type] -> Q Type -> Q Dec
tySynInstDCompat ''Generics.SOP.Universe.Code Maybe [Q TyVarBndrUnit]
forall a. Maybe a
Nothing [Q Type
typ] ((Name -> Q Type) -> [ConstructorInfo] -> Q Type
codeFor Name -> Q Type
f [ConstructorInfo]
cons)
  Dec
inst <- Q Cxt -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
            ([Q Type] -> Q Cxt
forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt [])
            [t| Generic $Q Type
typ |]
            [Q Dec
codeSyn, Name -> [ConstructorInfo] -> Q Dec
embedding 'from [ConstructorInfo]
cons, Name -> [ConstructorInfo] -> Q Dec
projection 'to [ConstructorInfo]
cons]
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
inst]

deriveMetadataForDataDec ::
  (Name -> Q Type) -> DatatypeVariant -> Cxt -> Name -> [TyVarBndrUnit] -> [Type] -> [TH.ConstructorInfo] -> Q [Dec]
deriveMetadataForDataDec :: (Name -> Q Type)
-> DatatypeVariant
-> Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> [ConstructorInfo]
-> Q [Dec]
deriveMetadataForDataDec Name -> Q Type
f DatatypeVariant
variant Cxt
_cxt Name
name [TyVarBndrUnit]
_bndrs Cxt
instTys [ConstructorInfo]
cons = do
  let typ :: Q Type
typ = (Name -> Q Type) -> Name -> Cxt -> Q Type
appTysSubst Name -> Q Type
f Name
name Cxt
instTys
  DatatypeVariant -> Name -> Q Type -> [ConstructorInfo] -> Q [Dec]
deriveMetadataForDataType DatatypeVariant
variant Name
name Q Type
typ [ConstructorInfo]
cons

deriveMetadataForDataType :: DatatypeVariant -> Name -> Q Type -> [TH.ConstructorInfo] -> Q [Dec]
deriveMetadataForDataType :: DatatypeVariant -> Name -> Q Type -> [ConstructorInfo] -> Q [Dec]
deriveMetadataForDataType DatatypeVariant
variant Name
name Q Type
typ [ConstructorInfo]
cons = do
  Dec
md   <- Q Cxt -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD ([Q Type] -> Q Cxt
forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt [])
            [t| HasDatatypeInfo $Q Type
typ |]
            [ Q Type -> DatatypeVariant -> Name -> [ConstructorInfo] -> Q Dec
metadataType Q Type
typ DatatypeVariant
variant Name
name [ConstructorInfo]
cons
            , Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'datatypeInfo
                [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP]
                  (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| SOP.T.demoteDatatypeInfo (Proxy :: Proxy (DatatypeInfoOf $Q Type
typ)) |])
                  []
                ]
            ]
            -- [metadata variant name cons]
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
md]

{-------------------------------------------------------------------------------
  Computing the code for a data type
-------------------------------------------------------------------------------}

codeFor :: (Name -> Q Type) -> [TH.ConstructorInfo] -> Q Type
codeFor :: (Name -> Q Type) -> [ConstructorInfo] -> Q Type
codeFor Name -> Q Type
f = [Q Type] -> Q Type
promotedTypeList ([Q Type] -> Q Type)
-> ([ConstructorInfo] -> [Q Type]) -> [ConstructorInfo] -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConstructorInfo -> Q Type) -> [ConstructorInfo] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map ConstructorInfo -> Q Type
go
  where
    go :: TH.ConstructorInfo -> Q Type
    go :: ConstructorInfo -> Q Type
go ConstructorInfo
c = do (Name
_, [Q Type]
ts) <- ConstructorInfo -> Q (Name, [Q Type])
conInfo ConstructorInfo
c
              (Name -> Q Type) -> [Q Type] -> Q Type
promotedTypeListSubst Name -> Q Type
f [Q Type]
ts

{-------------------------------------------------------------------------------
  Computing the embedding/projection pair
-------------------------------------------------------------------------------}

embedding :: Name -> [TH.ConstructorInfo] -> Q Dec
embedding :: Name -> [ConstructorInfo] -> Q Dec
embedding Name
fromName = Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
fromName ([Q Clause] -> Q Dec)
-> ([ConstructorInfo] -> [Q Clause]) -> [ConstructorInfo] -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Q Exp -> Q Exp) -> [ConstructorInfo] -> [Q Clause]
go' (\Q Exp
e -> [| Z $Q Exp
e |])
  where
    go' :: (Q Exp -> Q Exp) -> [TH.ConstructorInfo] -> [Q Clause]
    go' :: (Q Exp -> Q Exp) -> [ConstructorInfo] -> [Q Clause]
go' Q Exp -> Q Exp
_ [] = (Q Clause -> [Q Clause] -> [Q Clause]
forall a. a -> [a] -> [a]
:[]) (Q Clause -> [Q Clause]) -> Q Clause -> [Q Clause]
forall a b. (a -> b) -> a -> b
$ do
      Name
x <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
      [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (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
x) [])) []
    go' Q Exp -> Q Exp
br [ConstructorInfo]
cs = (Q Exp -> Q Exp) -> [ConstructorInfo] -> [Q Clause]
go Q Exp -> Q Exp
br [ConstructorInfo]
cs

    go :: (Q Exp -> Q Exp) -> [TH.ConstructorInfo] -> [Q Clause]
    go :: (Q Exp -> Q Exp) -> [ConstructorInfo] -> [Q Clause]
go Q Exp -> Q Exp
_  []     = []
    go Q Exp -> Q Exp
br (ConstructorInfo
c:[ConstructorInfo]
cs) = (Q Exp -> Q Exp) -> ConstructorInfo -> Q Clause
mkClause Q Exp -> Q Exp
br ConstructorInfo
c Q Clause -> [Q Clause] -> [Q Clause]
forall a. a -> [a] -> [a]
: (Q Exp -> Q Exp) -> [ConstructorInfo] -> [Q Clause]
go (\Q Exp
e -> [| S $(Q Exp -> Q Exp
br Q Exp
e) |]) [ConstructorInfo]
cs

    mkClause :: (Q Exp -> Q Exp) -> TH.ConstructorInfo -> Q Clause
    mkClause :: (Q Exp -> Q Exp) -> ConstructorInfo -> Q Clause
mkClause Q Exp -> Q Exp
br ConstructorInfo
c = do
      (Name
n, [Q Type]
ts) <- ConstructorInfo -> Q (Name, [Q Type])
conInfo ConstructorInfo
c
      [Name]
vars    <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([Q Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Q Type]
ts) (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x")
      [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
n ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
vars)]
             (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| SOP $(Q Exp -> Q Exp
br (Q Exp -> Q Exp) -> ([Name] -> Q Exp) -> [Name] -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Q Exp] -> Q Exp
npE ([Q Exp] -> Q Exp) -> ([Name] -> [Q Exp]) -> [Name] -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (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 'I) (Q Exp -> Q Exp) -> (Name -> Q Exp) -> Name -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE) ([Name] -> Q Exp) -> [Name] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Name]
vars) |])
             []

projection :: Name -> [TH.ConstructorInfo] -> Q Dec
projection :: Name -> [ConstructorInfo] -> Q Dec
projection Name
toName = Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
toName ([Q Clause] -> Q Dec)
-> ([ConstructorInfo] -> [Q Clause]) -> [ConstructorInfo] -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ConstructorInfo] -> [Q Clause]
go'
  where
    go' :: [TH.ConstructorInfo] -> [Q Clause]
    go' :: [ConstructorInfo] -> [Q Clause]
go' [] = (Q Clause -> [Q Clause] -> [Q Clause]
forall a. a -> [a] -> [a]
:[]) (Q Clause -> [Q Clause]) -> Q Clause -> [Q Clause]
forall a b. (a -> b) -> a -> b
$ do
      Name
x <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
      [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (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
x) [])) []
    go' [ConstructorInfo]
cs = (Q Pat -> Q Pat) -> [ConstructorInfo] -> [Q Clause]
go Q Pat -> Q Pat
forall a. a -> a
id [ConstructorInfo]
cs

    go :: (Q Pat -> Q Pat) -> [TH.ConstructorInfo] -> [Q Clause]
    go :: (Q Pat -> Q Pat) -> [ConstructorInfo] -> [Q Clause]
go Q Pat -> Q Pat
br [] = [(Q Pat -> Q Pat) -> Q Clause
mkUnreachableClause Q Pat -> Q Pat
br]
    go Q Pat -> Q Pat
br (ConstructorInfo
c:[ConstructorInfo]
cs) = (Q Pat -> Q Pat) -> ConstructorInfo -> Q Clause
mkClause Q Pat -> Q Pat
br ConstructorInfo
c Q Clause -> [Q Clause] -> [Q Clause]
forall a. a -> [a] -> [a]
: (Q Pat -> Q Pat) -> [ConstructorInfo] -> [Q Clause]
go (\Q Pat
p -> Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'S [Q Pat -> Q Pat
br Q Pat
p]) [ConstructorInfo]
cs

    -- Generates a final clause of the form:
    --
    --   to (S (... (S x))) = x `seq` error "inaccessible"
    --
    -- An equivalent way of achieving this would be:
    --
    --   to (S (... (S x))) = case x of {}
    --
    -- This, however, would require clients to enable the EmptyCase extension
    -- in their own code, which is something which we have not previously
    -- required. Therefore, we do not generate this code at the moment.
    mkUnreachableClause :: (Q Pat -> Q Pat) -> Q Clause
    mkUnreachableClause :: (Q Pat -> Q Pat) -> Q Clause
mkUnreachableClause Q Pat -> Q Pat
br = do
      Name
var <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
      [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'SOP [Q Pat -> Q Pat
br (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
var)]]
             (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
var) `seq` error "inaccessible" |])
             []

    mkClause :: (Q Pat -> Q Pat) -> TH.ConstructorInfo -> Q Clause
    mkClause :: (Q Pat -> Q Pat) -> ConstructorInfo -> Q Clause
mkClause Q Pat -> Q Pat
br ConstructorInfo
c = do
      (Name
n, [Q Type]
ts) <- ConstructorInfo -> Q (Name, [Q Type])
conInfo ConstructorInfo
c
      [Name]
vars    <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([Q Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Q Type]
ts) (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x")
      [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'SOP [Q Pat -> Q Pat
br (Q Pat -> Q Pat) -> ([Name] -> Q Pat) -> [Name] -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'Z ([Q Pat] -> Q Pat) -> ([Name] -> [Q Pat]) -> [Name] -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Q Pat -> [Q Pat] -> [Q Pat]
forall a. a -> [a] -> [a]
:[]) (Q Pat -> [Q Pat]) -> ([Name] -> Q Pat) -> [Name] -> [Q Pat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Q Pat] -> Q Pat
npP ([Q Pat] -> Q Pat) -> ([Name] -> [Q Pat]) -> [Name] -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
v -> Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'I [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
v]) ([Name] -> Q Pat) -> [Name] -> Q Pat
forall a b. (a -> b) -> a -> b
$ [Name]
vars]]
             (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Body
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE ([Q Exp] -> Q Body) -> [Q Exp] -> Q Body
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
n Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
vars)
             []

{-------------------------------------------------------------------------------
  Compute metadata
-------------------------------------------------------------------------------}

metadataType :: Q Type -> DatatypeVariant -> Name -> [TH.ConstructorInfo] -> Q Dec
metadataType :: Q Type -> DatatypeVariant -> Name -> [ConstructorInfo] -> Q Dec
metadataType Q Type
typ DatatypeVariant
variant Name
typeName [ConstructorInfo]
cs =
  Name -> Maybe [Q TyVarBndrUnit] -> [Q Type] -> Q Type -> Q Dec
tySynInstDCompat ''DatatypeInfoOf Maybe [Q TyVarBndrUnit]
forall a. Maybe a
Nothing [Q Type
typ] (DatatypeVariant -> Name -> [ConstructorInfo] -> Q Type
metadataType' DatatypeVariant
variant Name
typeName [ConstructorInfo]
cs)

-- | Derive term-level metadata.
metadata' :: DatatypeVariant -> Name -> [TH.ConstructorInfo] -> Q Exp
metadata' :: DatatypeVariant -> Name -> [ConstructorInfo] -> Q Exp
metadata' DatatypeVariant
dataVariant Name
typeName [ConstructorInfo]
cs = Q Exp
md
  where
    md :: Q Exp
    md :: Q Exp
md | DatatypeVariant -> Bool
isNewtypeVariant DatatypeVariant
dataVariant
       = [| SOP.Newtype $(String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (Name -> String
nameModule' Name
typeName))
                        $(String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (Name -> String
nameBase Name
typeName))
                        $(ConstructorInfo -> Q Exp
mdCon ([ConstructorInfo] -> ConstructorInfo
forall a. HasCallStack => [a] -> a
head [ConstructorInfo]
cs))
          |]

       | Bool
otherwise
       = [| SOP.ADT     $(String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (Name -> String
nameModule' Name
typeName))
                        $(String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (Name -> String
nameBase Name
typeName))
                        $([Q Exp] -> Q Exp
npE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (ConstructorInfo -> Q Exp) -> [ConstructorInfo] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map ConstructorInfo -> Q Exp
mdCon [ConstructorInfo]
cs)
                        $([Q [Q Exp]] -> Q Exp
popE ([Q [Q Exp]] -> Q Exp) -> [Q [Q Exp]] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (ConstructorInfo -> Q [Q Exp]) -> [ConstructorInfo] -> [Q [Q Exp]]
forall a b. (a -> b) -> [a] -> [b]
map ConstructorInfo -> Q [Q Exp]
mdStrictness [ConstructorInfo]
cs)
          |]

    mdStrictness :: TH.ConstructorInfo -> Q [Q Exp]
    mdStrictness :: ConstructorInfo -> Q [Q Exp]
mdStrictness ci :: ConstructorInfo
ci@(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName       = Name
n
                                     , constructorStrictness :: ConstructorInfo -> [FieldStrictness]
constructorStrictness = [FieldStrictness]
bs }) =
      ConstructorInfo -> Q [Q Exp] -> Q [Q Exp]
forall a. ConstructorInfo -> Q a -> Q a
checkForGADTs ConstructorInfo
ci (Q [Q Exp] -> Q [Q Exp]) -> Q [Q Exp] -> Q [Q Exp]
forall a b. (a -> b) -> a -> b
$ Name -> [FieldStrictness] -> Q [Q Exp]
mdConStrictness Name
n [FieldStrictness]
bs

    mdConStrictness :: Name -> [FieldStrictness] -> Q [Q Exp]
    mdConStrictness :: Name -> [FieldStrictness] -> Q [Q Exp]
mdConStrictness Name
n [FieldStrictness]
bs = do
      [DecidedStrictness]
dss <- Name -> Q [DecidedStrictness]
reifyConStrictness Name
n
      [Q Exp] -> Q [Q Exp]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ((FieldStrictness -> DecidedStrictness -> Q Exp)
-> [FieldStrictness] -> [DecidedStrictness] -> [Q Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ (FieldStrictness Unpackedness
su Strictness
ss) DecidedStrictness
ds ->
        [| SOP.StrictnessInfo
          $(Unpackedness -> Q Exp
mdTHUnpackedness     Unpackedness
su)
          $(Strictness -> Q Exp
mdTHStrictness       Strictness
ss)
          $(DecidedStrictness -> Q Exp
mdDecidedStrictness  DecidedStrictness
ds)
        |]) [FieldStrictness]
bs [DecidedStrictness]
dss)

    mdCon :: TH.ConstructorInfo -> Q Exp
    mdCon :: ConstructorInfo -> Q Exp
mdCon ci :: ConstructorInfo
ci@(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName    = Name
n
                              , constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = ConstructorVariant
conVariant }) =
      ConstructorInfo -> Q Exp -> Q Exp
forall a. ConstructorInfo -> Q a -> Q a
checkForGADTs ConstructorInfo
ci (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
      case ConstructorVariant
conVariant of
        ConstructorVariant
NormalConstructor    -> [| SOP.Constructor $(String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (Name -> String
nameBase Name
n)) |]
        RecordConstructor [Name]
ts -> [| SOP.Record      $(String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (Name -> String
nameBase Name
n))
                                                   $([Q Exp] -> Q Exp
npE ((Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
mdField [Name]
ts))
                                 |]
        ConstructorVariant
InfixConstructor     -> do
          Maybe Fixity
fixity <- Name -> Q (Maybe Fixity)
reifyFixity Name
n
          case Fixity -> Maybe Fixity -> Fixity
forall a. a -> Maybe a -> a
fromMaybe Fixity
defaultFixity Maybe Fixity
fixity of
            Fixity Int
f FixityDirection
a ->       [| SOP.Infix       $(String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (Name -> String
nameBase Name
n))
                                                   $(FixityDirection -> Q Exp
mdAssociativity FixityDirection
a)
                                                   f
                                 |]


    mdField :: Name -> Q Exp
    mdField :: Name -> Q Exp
mdField Name
n = [| SOP.FieldInfo $(String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (Name -> String
nameBase Name
n)) |]

    mdTHUnpackedness :: TH.Unpackedness -> Q Exp
    mdTHUnpackedness :: Unpackedness -> Q Exp
mdTHUnpackedness Unpackedness
UnspecifiedUnpackedness = [| SOP.NoSourceUnpackedness |]
    mdTHUnpackedness Unpackedness
NoUnpack                = [| SOP.SourceNoUnpack       |]
    mdTHUnpackedness Unpackedness
Unpack                  = [| SOP.SourceUnpack         |]

    mdTHStrictness :: TH.Strictness -> Q Exp
    mdTHStrictness :: Strictness -> Q Exp
mdTHStrictness Strictness
UnspecifiedStrictness = [| SOP.NoSourceStrictness |]
    mdTHStrictness Strictness
Lazy                  = [| SOP.SourceLazy         |]
    mdTHStrictness Strictness
TH.Strict             = [| SOP.SourceStrict       |]

    mdDecidedStrictness :: DecidedStrictness -> Q Exp
    mdDecidedStrictness :: DecidedStrictness -> Q Exp
mdDecidedStrictness DecidedStrictness
DecidedLazy   = [| SOP.DecidedLazy   |]
    mdDecidedStrictness DecidedStrictness
DecidedStrict = [| SOP.DecidedStrict |]
    mdDecidedStrictness DecidedStrictness
DecidedUnpack = [| SOP.DecidedUnpack |]

    mdAssociativity :: FixityDirection -> Q Exp
    mdAssociativity :: FixityDirection -> Q Exp
mdAssociativity FixityDirection
InfixL = [| SOP.LeftAssociative  |]
    mdAssociativity FixityDirection
InfixR = [| SOP.RightAssociative |]
    mdAssociativity FixityDirection
InfixN = [| SOP.NotAssociative   |]

-- | Derive type-level metadata.
metadataType' :: DatatypeVariant -> Name -> [TH.ConstructorInfo] -> Q Type
metadataType' :: DatatypeVariant -> Name -> [ConstructorInfo] -> Q Type
metadataType' DatatypeVariant
dataVariant Name
typeName [ConstructorInfo]
cs = Q Type
md
  where
    md :: Q Type
    md :: Q Type
md | DatatypeVariant -> Bool
isNewtypeVariant DatatypeVariant
dataVariant
       = [t| 'SOP.T.Newtype $(String -> Q Type
stringT (Name -> String
nameModule' Name
typeName))
                            $(String -> Q Type
stringT (Name -> String
nameBase Name
typeName))
                            $(ConstructorInfo -> Q Type
mdCon ([ConstructorInfo] -> ConstructorInfo
forall a. HasCallStack => [a] -> a
head [ConstructorInfo]
cs))
           |]

       | Bool
otherwise
       = [t| 'SOP.T.ADT     $(String -> Q Type
stringT (Name -> String
nameModule' Name
typeName))
                            $(String -> Q Type
stringT (Name -> String
nameBase Name
typeName))
                            $([Q Type] -> Q Type
promotedTypeList ([Q Type] -> Q Type) -> [Q Type] -> Q Type
forall a b. (a -> b) -> a -> b
$ (ConstructorInfo -> Q Type) -> [ConstructorInfo] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map ConstructorInfo -> Q Type
mdCon [ConstructorInfo]
cs)
                            $([Q [Q Type]] -> Q Type
promotedTypeListOfList ([Q [Q Type]] -> Q Type) -> [Q [Q Type]] -> Q Type
forall a b. (a -> b) -> a -> b
$ (ConstructorInfo -> Q [Q Type])
-> [ConstructorInfo] -> [Q [Q Type]]
forall a b. (a -> b) -> [a] -> [b]
map ConstructorInfo -> Q [Q Type]
mdStrictness [ConstructorInfo]
cs)
           |]

    mdStrictness :: TH.ConstructorInfo -> Q [Q Type]
    mdStrictness :: ConstructorInfo -> Q [Q Type]
mdStrictness ci :: ConstructorInfo
ci@(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName       = Name
n
                                     , constructorStrictness :: ConstructorInfo -> [FieldStrictness]
constructorStrictness = [FieldStrictness]
bs }) =
      ConstructorInfo -> Q [Q Type] -> Q [Q Type]
forall a. ConstructorInfo -> Q a -> Q a
checkForGADTs ConstructorInfo
ci (Q [Q Type] -> Q [Q Type]) -> Q [Q Type] -> Q [Q Type]
forall a b. (a -> b) -> a -> b
$ Name -> [FieldStrictness] -> Q [Q Type]
mdConStrictness Name
n [FieldStrictness]
bs

    mdConStrictness :: Name -> [FieldStrictness] -> Q [Q Type]
    mdConStrictness :: Name -> [FieldStrictness] -> Q [Q Type]
mdConStrictness Name
n [FieldStrictness]
bs = do
      [DecidedStrictness]
dss <- Name -> Q [DecidedStrictness]
reifyConStrictness Name
n
      [Q Type] -> Q [Q Type]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ((FieldStrictness -> DecidedStrictness -> Q Type)
-> [FieldStrictness] -> [DecidedStrictness] -> [Q Type]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ (FieldStrictness Unpackedness
su Strictness
ss) DecidedStrictness
ds ->
        [t| 'SOP.T.StrictnessInfo
          $(Unpackedness -> Q Type
mdTHUnpackedness     Unpackedness
su)
          $(Strictness -> Q Type
mdTHStrictness       Strictness
ss)
          $(DecidedStrictness -> Q Type
mdDecidedStrictness  DecidedStrictness
ds)
        |]) [FieldStrictness]
bs [DecidedStrictness]
dss)

    mdCon :: TH.ConstructorInfo -> Q Type
    mdCon :: ConstructorInfo -> Q Type
mdCon ci :: ConstructorInfo
ci@(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName    = Name
n
                              , constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = ConstructorVariant
conVariant }) =
      ConstructorInfo -> Q Type -> Q Type
forall a. ConstructorInfo -> Q a -> Q a
checkForGADTs ConstructorInfo
ci (Q Type -> Q Type) -> Q Type -> Q Type
forall a b. (a -> b) -> a -> b
$
      case ConstructorVariant
conVariant of
        ConstructorVariant
NormalConstructor    -> [t| 'SOP.T.Constructor $(String -> Q Type
stringT (Name -> String
nameBase Name
n)) |]
        RecordConstructor [Name]
ts -> [t| 'SOP.T.Record      $(String -> Q Type
stringT (Name -> String
nameBase Name
n))
                                                       $([Q Type] -> Q Type
promotedTypeList ((Name -> Q Type) -> [Name] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Type
mdField [Name]
ts))
                                  |]
        ConstructorVariant
InfixConstructor     -> do
          Maybe Fixity
fixity <- Name -> Q (Maybe Fixity)
reifyFixity Name
n
          case Fixity -> Maybe Fixity -> Fixity
forall a. a -> Maybe a -> a
fromMaybe Fixity
defaultFixity Maybe Fixity
fixity of
            Fixity Int
f FixityDirection
a ->       [t| 'SOP.T.Infix       $(String -> Q Type
stringT (Name -> String
nameBase Name
n))
                                                       $(FixityDirection -> Q Type
mdAssociativity FixityDirection
a)
                                                       $(Int -> Q Type
natT Int
f)
                                  |]

    mdField :: Name -> Q Type
    mdField :: Name -> Q Type
mdField Name
n = [t| 'SOP.T.FieldInfo $(String -> Q Type
stringT (Name -> String
nameBase Name
n)) |]

    mdTHUnpackedness :: TH.Unpackedness -> Q Type
    mdTHUnpackedness :: Unpackedness -> Q Type
mdTHUnpackedness Unpackedness
UnspecifiedUnpackedness = [t| 'SOP.NoSourceUnpackedness |]
    mdTHUnpackedness Unpackedness
NoUnpack                = [t| 'SOP.SourceNoUnpack       |]
    mdTHUnpackedness Unpackedness
Unpack                  = [t| 'SOP.SourceUnpack         |]

    mdTHStrictness :: TH.Strictness -> Q Type
    mdTHStrictness :: Strictness -> Q Type
mdTHStrictness Strictness
UnspecifiedStrictness = [t| 'SOP.NoSourceStrictness |]
    mdTHStrictness Strictness
Lazy                  = [t| 'SOP.SourceLazy         |]
    mdTHStrictness Strictness
TH.Strict             = [t| 'SOP.SourceStrict       |]

    mdDecidedStrictness :: DecidedStrictness -> Q Type
    mdDecidedStrictness :: DecidedStrictness -> Q Type
mdDecidedStrictness DecidedStrictness
DecidedLazy   = [t| 'SOP.DecidedLazy   |]
    mdDecidedStrictness DecidedStrictness
DecidedStrict = [t| 'SOP.DecidedStrict |]
    mdDecidedStrictness DecidedStrictness
DecidedUnpack = [t| 'SOP.DecidedUnpack |]

    mdAssociativity :: FixityDirection -> Q Type
    mdAssociativity :: FixityDirection -> Q Type
mdAssociativity FixityDirection
InfixL = [t| 'SOP.T.LeftAssociative  |]
    mdAssociativity FixityDirection
InfixR = [t| 'SOP.T.RightAssociative |]
    mdAssociativity FixityDirection
InfixN = [t| 'SOP.T.NotAssociative   |]

nameModule' :: Name -> String
nameModule' :: Name -> String
nameModule' = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String)
-> (Name -> Maybe String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Maybe String
nameModule

{-------------------------------------------------------------------------------
  Constructing n-ary pairs
-------------------------------------------------------------------------------}

-- Given
--
-- > [a, b, c]
--
-- Construct
--
-- > a :* b :* c :* Nil
npE :: [Q Exp] -> Q Exp
npE :: [Q Exp] -> Q Exp
npE []     = [| Nil |]
npE (Q Exp
e:[Q Exp]
es) = [| $Q Exp
e :* $([Q Exp] -> Q Exp
npE [Q Exp]
es) |]

-- Construct a POP.
popE :: [Q [Q Exp]] -> Q Exp
popE :: [Q [Q Exp]] -> Q Exp
popE [Q [Q Exp]]
ess =
  [| POP $([Q Exp] -> Q Exp
npE ((Q [Q Exp] -> Q Exp) -> [Q [Q Exp]] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Q (Q Exp) -> Q Exp
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Q (Q Exp) -> Q Exp)
-> (Q [Q Exp] -> Q (Q Exp)) -> Q [Q Exp] -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Q Exp] -> Q Exp) -> Q [Q Exp] -> Q (Q Exp)
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Q Exp] -> Q Exp
npE) [Q [Q Exp]]
ess)) |]

-- Like npE, but construct a pattern instead
npP :: [Q Pat] -> Q Pat
npP :: [Q Pat] -> Q Pat
npP []     = Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'Nil []
npP (Q Pat
p:[Q Pat]
ps) = Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP '(:*) [Q Pat
p, [Q Pat] -> Q Pat
npP [Q Pat]
ps]

{-------------------------------------------------------------------------------
  Some auxiliary definitions for working with TH
-------------------------------------------------------------------------------}

conInfo :: TH.ConstructorInfo -> Q (Name, [Q Type])
conInfo :: ConstructorInfo -> Q (Name, [Q Type])
conInfo ci :: ConstructorInfo
ci@(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName    = Name
n
                            , constructorFields :: ConstructorInfo -> Cxt
constructorFields  = Cxt
ts }) =
  ConstructorInfo -> Q (Name, [Q Type]) -> Q (Name, [Q Type])
forall a. ConstructorInfo -> Q a -> Q a
checkForGADTs ConstructorInfo
ci (Q (Name, [Q Type]) -> Q (Name, [Q Type]))
-> Q (Name, [Q Type]) -> Q (Name, [Q Type])
forall a b. (a -> b) -> a -> b
$ (Name, [Q Type]) -> Q (Name, [Q Type])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, (Type -> Q Type) -> Cxt -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
ts)

stringT :: String -> Q Type
stringT :: String -> Q Type
stringT = Q TyLit -> Q Type
forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (Q TyLit -> Q Type) -> (String -> Q TyLit) -> String -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q TyLit
forall (m :: * -> *). Quote m => String -> m TyLit
strTyLit

natT :: Int -> Q Type
natT :: Int -> Q Type
natT = Q TyLit -> Q Type
forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (Q TyLit -> Q Type) -> (Int -> Q TyLit) -> Int -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Q TyLit
forall (m :: * -> *). Quote m => Integer -> m TyLit
numTyLit (Integer -> Q TyLit) -> (Int -> Integer) -> Int -> Q TyLit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral

promotedTypeList :: [Q Type] -> Q Type
promotedTypeList :: [Q Type] -> Q Type
promotedTypeList []     = Q Type
forall (m :: * -> *). Quote m => m Type
promotedNilT
promotedTypeList (Q Type
t:[Q Type]
ts) = [t| $Q Type
forall (m :: * -> *). Quote m => m Type
promotedConsT $Q Type
t $([Q Type] -> Q Type
promotedTypeList [Q Type]
ts) |]

promotedTypeListOfList :: [Q [Q Type]] -> Q Type
promotedTypeListOfList :: [Q [Q Type]] -> Q Type
promotedTypeListOfList =
  [Q Type] -> Q Type
promotedTypeList ([Q Type] -> Q Type)
-> ([Q [Q Type]] -> [Q Type]) -> [Q [Q Type]] -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Q [Q Type] -> Q Type) -> [Q [Q Type]] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map (Q (Q Type) -> Q Type
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Q (Q Type) -> Q Type)
-> (Q [Q Type] -> Q (Q Type)) -> Q [Q Type] -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Q Type] -> Q Type) -> Q [Q Type] -> Q (Q Type)
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Q Type] -> Q Type
promotedTypeList)

promotedTypeListSubst :: (Name -> Q Type) -> [Q Type] -> Q Type
promotedTypeListSubst :: (Name -> Q Type) -> [Q Type] -> Q Type
promotedTypeListSubst Name -> Q Type
_ []     = Q Type
forall (m :: * -> *). Quote m => m Type
promotedNilT
promotedTypeListSubst Name -> Q Type
f (Q Type
t:[Q Type]
ts) = [t| $Q Type
forall (m :: * -> *). Quote m => m Type
promotedConsT $(Q Type
t Q Type -> (Type -> Q Type) -> Q Type
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Name -> Q Type) -> Type -> Q Type
substType Name -> Q Type
f) $((Name -> Q Type) -> [Q Type] -> Q Type
promotedTypeListSubst Name -> Q Type
f [Q Type]
ts) |]

appsT :: Name -> [Q Type] -> Q Type
appsT :: Name -> [Q Type] -> Q Type
appsT Name
n = (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' 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
n)

appTyVars :: (Name -> Q Type) -> Name -> [TyVarBndrUnit] -> Q Type
appTyVars :: (Name -> Q Type) -> Name -> [TyVarBndrUnit] -> Q Type
appTyVars Name -> Q Type
f Name
n [TyVarBndrUnit]
bndrs =
  Name -> [Q Type] -> Q Type
appsT Name
n ((TyVarBndrUnit -> Q Type) -> [TyVarBndrUnit] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Q Type
f (Name -> Q Type)
-> (TyVarBndrUnit -> Name) -> TyVarBndrUnit -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndrUnit -> Name
forall flag. TyVarBndr_ flag -> Name
tvName) [TyVarBndrUnit]
bndrs)

appTysSubst :: (Name -> Q Type) -> Name -> [Type] -> Q Type
appTysSubst :: (Name -> Q Type) -> Name -> Cxt -> Q Type
appTysSubst Name -> Q Type
f Name
n Cxt
args =
  Name -> [Q Type] -> Q Type
appsT Name
n ((Type -> Q Type) -> Cxt -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map ((Name -> Q Type) -> Type -> Q Type
substType Name -> Q Type
f (Type -> Q Type) -> (Type -> Type) -> Type -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
unSigType) Cxt
args)

unSigType :: Type -> Type
unSigType :: Type -> Type
unSigType (SigT Type
t Type
_) = Type
t
unSigType Type
t          = Type
t

substType :: (Name -> Q Type) -> Type -> Q Type
substType :: (Name -> Q Type) -> Type -> Q Type
substType Name -> Q Type
f = Type -> Q Type
go
  where
    go :: Type -> Q Type
go (VarT Name
n)     = Name -> Q Type
f Name
n
    go (AppT Type
t1 Type
t2) = Type -> Type -> Type
AppT (Type -> Type -> Type) -> Q Type -> Q (Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Q Type
go Type
t1 Q (Type -> Type) -> Q Type -> Q Type
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Q Type
go Type
t2
    go Type
ListT        = Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ListT
    go (ConT Name
n)     = Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type
ConT Name
n)
    go Type
ArrowT       = Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ArrowT
    go (TupleT Int
i)   = Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Type
TupleT Int
i)
    go Type
t            = Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t -- error (show t)
      -- TODO: This is incorrect, but we only need substitution to work
      -- in simple cases for now. The reason is that substitution is normally
      -- the identity, except if we use TH derivation for the tagged datatypes
      -- in the benchmarking suite. So we can fall back on identity in all
      -- but the cases we need for the benchmarking suite.

-- Process a DatatypeInfo using continuation-passing style.
withDataDec :: TH.DatatypeInfo
            -> (DatatypeVariant
                   -- The variety of data type
                   -- (@data@, @newtype@, @data instance@, or @newtype instance@)
                -> Cxt
                   -- The datatype context
                -> Name
                   -- The data type's name
                -> [TyVarBndrUnit]
                   -- The datatype's type variable binders, both implicit and explicit.
                   -- Examples:
                   --
                   -- - For `data Maybe a = Nothing | Just a`, the binders are
                   --   [PlainTV a]
                   -- - For `data Proxy (a :: k) = Proxy`, the binders are
                   --   [PlainTV k, KindedTV a (VarT k)]
                   -- - For `data instance DF Int (Maybe b) = DF b`, the binders are
                   --   [PlainTV b]
                -> [Type]
                   -- For vanilla data types, these are the explicitly bound
                   -- type variable binders, but in Type form.
                   -- For data family instances, these are the type arguments.
                   -- Examples:
                   --
                   -- - For `data Maybe a = Nothing | Just a`, the types are
                   --   [VarT a]
                   -- - For `data Proxy (a :: k) = Proxy`, the types are
                   --   [SigT (VarT a) (VarT k)]
                   -- - For `data instance DF Int (Maybe b) = DF b`, the binders are
                   --   [ConT ''Int, ConT ''Maybe `AppT` VarT b]
                -> [TH.ConstructorInfo]
                   -- The data type's constructors
                -> Q a)
            -> Q a
withDataDec :: forall a.
DatatypeInfo
-> (DatatypeVariant
    -> Cxt
    -> Name
    -> [TyVarBndrUnit]
    -> Cxt
    -> [ConstructorInfo]
    -> Q a)
-> Q a
withDataDec (TH.DatatypeInfo { datatypeContext :: DatatypeInfo -> Cxt
datatypeContext   = Cxt
ctxt
                             , datatypeName :: DatatypeInfo -> Name
datatypeName      = Name
name
                             , datatypeVars :: DatatypeInfo -> [TyVarBndrUnit]
datatypeVars      = [TyVarBndrUnit]
bndrs
                             , datatypeInstTypes :: DatatypeInfo -> Cxt
datatypeInstTypes = Cxt
instTypes
                             , datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant   = DatatypeVariant
variant
                             , datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons      = [ConstructorInfo]
cons }) DatatypeVariant
-> Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> [ConstructorInfo]
-> Q a
f =
  DatatypeVariant -> Q a -> Q a
forall a. DatatypeVariant -> Q a -> Q a
checkForTypeData DatatypeVariant
variant (Q a -> Q a) -> Q a -> Q a
forall a b. (a -> b) -> a -> b
$
  DatatypeVariant
-> Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> [ConstructorInfo]
-> Q a
f DatatypeVariant
variant Cxt
ctxt Name
name [TyVarBndrUnit]
bndrs Cxt
instTypes [ConstructorInfo]
cons

checkForTypeData :: DatatypeVariant -> Q a -> Q a
checkForTypeData :: forall a. DatatypeVariant -> Q a -> Q a
checkForTypeData DatatypeVariant
variant Q a
q = do
  case DatatypeVariant
variant of
#if MIN_VERSION_th_abstraction(0,5,0)
    DatatypeVariant
TH.TypeData -> String -> Q ()
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"`type data` declarations not supported"
#endif
    DatatypeVariant
_ -> () -> Q ()
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Q a
q

checkForGADTs :: TH.ConstructorInfo -> Q a -> Q a
checkForGADTs :: forall a. ConstructorInfo -> Q a -> Q a
checkForGADTs (ConstructorInfo { constructorVars :: ConstructorInfo -> [TyVarBndrUnit]
constructorVars    = [TyVarBndrUnit]
exVars
                               , constructorContext :: ConstructorInfo -> Cxt
constructorContext = Cxt
exCxt }) Q a
q = do
  Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([TyVarBndrUnit] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndrUnit]
exVars) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> Q ()
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Existentials not supported"
  Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Cxt -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Cxt
exCxt)  (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> Q ()
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"GADTs not supported"
  Q a
q

isNewtypeVariant :: DatatypeVariant -> Bool
isNewtypeVariant :: DatatypeVariant -> Bool
isNewtypeVariant DatatypeVariant
Datatype        = Bool
False
isNewtypeVariant DatatypeVariant
DataInstance    = Bool
False
isNewtypeVariant DatatypeVariant
Newtype         = Bool
True
isNewtypeVariant DatatypeVariant
NewtypeInstance = Bool
True
#if MIN_VERSION_th_abstraction(0,5,0)
isNewtypeVariant DatatypeVariant
TH.TypeData     = Bool
False
#endif