-- | This module exports the templates for automatic instance deriving of "Transformation.Full" type classes. The most
-- common way to use it would be
--
-- > import qualified Transformation.Full.TH
-- > data MyDataType f' f = ...
-- > $(Transformation.Full.TH.deriveUpFunctor (conT ''MyTransformation) (conT ''MyDataType))
--

{-# Language TemplateHaskell #-}

module Transformation.Full.TH (deriveDownFunctor, deriveDownFoldable, deriveDownTraversable,
                               deriveUpFunctor, deriveUpFoldable, deriveUpTraversable)
where

import qualified Data.Traversable
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (BangType, VarBangType)

import qualified Transformation
import qualified Transformation.Deep
import qualified Transformation.Full

deriveDownFunctor :: Q Type -> Q Type -> Q [Dec]
deriveDownFunctor :: Q Type -> Q Type -> Q [Dec]
deriveDownFunctor Q Type
transformation Q Type
node = do
   let domain :: Q Type
domain = Name -> Q Type
conT ''Transformation.Domain Q Type -> Q Type -> Q Type
`appT` Q Type
transformation
       deepConstraint :: Q Type
deepConstraint = Name -> Q Type
conT ''Transformation.Deep.Functor Q Type -> Q Type -> Q Type
`appT` Q Type
transformation Q Type -> Q Type -> Q Type
`appT` Q Type
node
       fullConstraint :: Q Type
fullConstraint = Name -> Q Type
conT ''Transformation.Full.Functor Q Type -> Q Type -> Q Type
`appT` Q Type
transformation Q Type -> Q Type -> Q Type
`appT` Q Type
node
       shallowConstraint :: Q Type
shallowConstraint = Name -> Q Type
conT ''Transformation.At Q Type -> Q Type -> Q Type
`appT` Q Type
transformation Q Type -> Q Type -> Q Type
`appT` (Q Type
node Q Type -> Q Type -> Q Type
`appT` Q Type
domain Q Type -> Q Type -> Q Type
`appT` Q Type
domain)
   [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [CxtQ -> Q Type -> [Q Dec] -> Q Dec
instanceD ([Q Type] -> CxtQ
cxt [Q Type
deepConstraint, Q Type
shallowConstraint])
             Q Type
fullConstraint
             [Name -> [ClauseQ] -> Q Dec
funD '(Transformation.Full.<$>) [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE 'Transformation.Full.mapDownDefault) []]]]

deriveUpFunctor :: Q Type -> Q Type -> Q [Dec]
deriveUpFunctor :: Q Type -> Q Type -> Q [Dec]
deriveUpFunctor Q Type
transformation Q Type
node = do
   let codomain :: Q Type
codomain = Name -> Q Type
conT ''Transformation.Codomain Q Type -> Q Type -> Q Type
`appT` Q Type
transformation
       deepConstraint :: Q Type
deepConstraint = Name -> Q Type
conT ''Transformation.Deep.Functor Q Type -> Q Type -> Q Type
`appT` Q Type
transformation Q Type -> Q Type -> Q Type
`appT` Q Type
node
       fullConstraint :: Q Type
fullConstraint = Name -> Q Type
conT ''Transformation.Full.Functor Q Type -> Q Type -> Q Type
`appT` Q Type
transformation Q Type -> Q Type -> Q Type
`appT` Q Type
node
       shallowConstraint :: Q Type
shallowConstraint = Name -> Q Type
conT ''Transformation.At Q Type -> Q Type -> Q Type
`appT` Q Type
transformation Q Type -> Q Type -> Q Type
`appT` (Q Type
node Q Type -> Q Type -> Q Type
`appT` Q Type
codomain Q Type -> Q Type -> Q Type
`appT` Q Type
codomain)
   [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [CxtQ -> Q Type -> [Q Dec] -> Q Dec
instanceD ([Q Type] -> CxtQ
cxt [Q Type
deepConstraint, Q Type
shallowConstraint])
             Q Type
fullConstraint
             [Name -> [ClauseQ] -> Q Dec
funD '(Transformation.Full.<$>) [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE 'Transformation.Full.mapUpDefault) []]]]

deriveDownFoldable :: Q Type -> Q Type -> Q [Dec]
deriveDownFoldable :: Q Type -> Q Type -> Q [Dec]
deriveDownFoldable Q Type
transformation Q Type
node = do
   let domain :: Q Type
domain = Name -> Q Type
conT ''Transformation.Domain Q Type -> Q Type -> Q Type
`appT` Q Type
transformation
       deepConstraint :: Q Type
deepConstraint = Name -> Q Type
conT ''Transformation.Deep.Foldable Q Type -> Q Type -> Q Type
`appT` Q Type
transformation Q Type -> Q Type -> Q Type
`appT` Q Type
node
       fullConstraint :: Q Type
fullConstraint = Name -> Q Type
conT ''Transformation.Full.Foldable Q Type -> Q Type -> Q Type
`appT` Q Type
transformation Q Type -> Q Type -> Q Type
`appT` Q Type
node
       shallowConstraint :: Q Type
shallowConstraint = Name -> Q Type
conT ''Transformation.At Q Type -> Q Type -> Q Type
`appT` Q Type
transformation Q Type -> Q Type -> Q Type
`appT` (Q Type
node Q Type -> Q Type -> Q Type
`appT` Q Type
domain Q Type -> Q Type -> Q Type
`appT` Q Type
domain)
   [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [CxtQ -> Q Type -> [Q Dec] -> Q Dec
instanceD ([Q Type] -> CxtQ
cxt [Q Type
deepConstraint, Q Type
shallowConstraint])
             Q Type
fullConstraint
             [Name -> [ClauseQ] -> Q Dec
funD 'Transformation.Full.foldMap [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE 'Transformation.Full.foldMapDownDefault) []]]]

deriveUpFoldable :: Q Type -> Q Type -> Q [Dec]
deriveUpFoldable :: Q Type -> Q Type -> Q [Dec]
deriveUpFoldable Q Type
transformation Q Type
node = do
   let codomain :: Q Type
codomain = Name -> Q Type
conT ''Transformation.Codomain Q Type -> Q Type -> Q Type
`appT` Q Type
transformation
       deepConstraint :: Q Type
deepConstraint = Name -> Q Type
conT ''Transformation.Deep.Foldable Q Type -> Q Type -> Q Type
`appT` Q Type
transformation Q Type -> Q Type -> Q Type
`appT` Q Type
node
       fullConstraint :: Q Type
fullConstraint = Name -> Q Type
conT ''Transformation.Full.Foldable Q Type -> Q Type -> Q Type
`appT` Q Type
transformation Q Type -> Q Type -> Q Type
`appT` Q Type
node
       shallowConstraint :: Q Type
shallowConstraint = Name -> Q Type
conT ''Transformation.At Q Type -> Q Type -> Q Type
`appT` Q Type
transformation Q Type -> Q Type -> Q Type
`appT` (Q Type
node Q Type -> Q Type -> Q Type
`appT` Q Type
codomain Q Type -> Q Type -> Q Type
`appT` Q Type
codomain)
   [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [CxtQ -> Q Type -> [Q Dec] -> Q Dec
instanceD ([Q Type] -> CxtQ
cxt [Q Type
deepConstraint, Q Type
shallowConstraint])
             Q Type
fullConstraint
             [Name -> [ClauseQ] -> Q Dec
funD 'Transformation.Full.foldMap [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE 'Transformation.Full.foldMapUpDefault) []]]]

deriveDownTraversable :: Q Type -> Q Type -> Q [Dec]
deriveDownTraversable :: Q Type -> Q Type -> Q [Dec]
deriveDownTraversable Q Type
transformation Q Type
node = do
   let domain :: Q Type
domain = Name -> Q Type
conT ''Transformation.Domain Q Type -> Q Type -> Q Type
`appT` Q Type
transformation
       deepConstraint :: Q Type
deepConstraint = Name -> Q Type
conT ''Transformation.Deep.Traversable Q Type -> Q Type -> Q Type
`appT` Q Type
transformation Q Type -> Q Type -> Q Type
`appT` Q Type
node
       fullConstraint :: Q Type
fullConstraint = Name -> Q Type
conT ''Transformation.Full.Traversable Q Type -> Q Type -> Q Type
`appT` Q Type
transformation Q Type -> Q Type -> Q Type
`appT` Q Type
node
       shallowConstraint :: Q Type
shallowConstraint = Name -> Q Type
conT ''Transformation.At Q Type -> Q Type -> Q Type
`appT` Q Type
transformation Q Type -> Q Type -> Q Type
`appT` (Q Type
node Q Type -> Q Type -> Q Type
`appT` Q Type
domain Q Type -> Q Type -> Q Type
`appT` Q Type
domain)
   [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [CxtQ -> Q Type -> [Q Dec] -> Q Dec
instanceD ([Q Type] -> CxtQ
cxt [Q Type
deepConstraint, Q Type
shallowConstraint])
             Q Type
fullConstraint
             [Name -> [ClauseQ] -> Q Dec
funD 'Transformation.Full.traverse [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE 'Transformation.Full.traverseDownDefault) []]]]

deriveUpTraversable :: Q Type -> Q Type -> Q [Dec]
deriveUpTraversable :: Q Type -> Q Type -> Q [Dec]
deriveUpTraversable Q Type
transformation Q Type
node = do
   let codomain :: Q Type
codomain = Name -> Q Type
conT ''Transformation.Codomain Q Type -> Q Type -> Q Type
`appT` Q Type
transformation
       deepConstraint :: Q Type
deepConstraint = Name -> Q Type
conT ''Transformation.Deep.Traversable Q Type -> Q Type -> Q Type
`appT` Q Type
transformation Q Type -> Q Type -> Q Type
`appT` Q Type
node
       fullConstraint :: Q Type
fullConstraint = Name -> Q Type
conT ''Transformation.Full.Traversable Q Type -> Q Type -> Q Type
`appT` Q Type
transformation Q Type -> Q Type -> Q Type
`appT` Q Type
node
       shallowConstraint :: Q Type
shallowConstraint = Name -> Q Type
conT ''Transformation.At Q Type -> Q Type -> Q Type
`appT` Q Type
transformation Q Type -> Q Type -> Q Type
`appT` (Q Type
node Q Type -> Q Type -> Q Type
`appT` Q Type
codomain Q Type -> Q Type -> Q Type
`appT` Q Type
codomain)
   [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [CxtQ -> Q Type -> [Q Dec] -> Q Dec
instanceD ([Q Type] -> CxtQ
cxt [Q Type
deepConstraint, Q Type
shallowConstraint])
             Q Type
fullConstraint
             [Name -> [ClauseQ] -> Q Dec
funD 'Transformation.Full.traverse [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE 'Transformation.Full.traverseUpDefault) []]]]