{-# 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 (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 $(appTyVars varT codeName' bndrs) |] -- SOP I TreeCode
    [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t 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| $origType -> $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| $repType -> $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)
sequence [ Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
datatypeInfoName' [t| SOP.DatatypeInfo $(appTyVars varT codeName' 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 <