content: {-# LANGUAGE TemplateHaskell #-}
  
  -- | Generate 'HTraversable' and related instances via @TemplateHaskell@
  module Hyper.TH.Traversable
      ( makeHTraversable
      , makeHTraversableAndFoldable
      , makeHTraversableAndBases
      , makeHTraversableApplyAndBases
      ) where
  
  import qualified Control.Lens as Lens
  import Hyper.Class.Traversable (ContainedH (..), HTraversable (..))
  import Hyper.TH.Apply (makeHApplicativeBases)
  import Hyper.TH.Foldable (makeHFoldable)
  import Hyper.TH.Functor (makeHFunctor)
  import Hyper.TH.Internal.Utils
  import Hyper.TH.Nodes (makeHNodes)
  import Language.Haskell.TH
  import Language.Haskell.TH.Datatype (ConstructorVariant)
  
  import Hyper.Internal.Prelude
  
  -- | Generate 'HTraversable' and 'Hyper.Class.Apply.HApply' instances along with all of their base classes:
  -- 'Hyper.Class.Foldable.HFoldable', 'Hyper.Class.Functor.HFunctor',
  -- 'Hyper.Class.Pointed.HPointed', and 'Hyper.Class.Nodes.HNodes'.
  makeHTraversableApplyAndBases :: Name -> DecsQ
  makeHTraversableApplyAndBases x =
      sequenceA
          [ makeHApplicativeBases x
          , makeHTraversableAndFoldable x
          ]
          <&> concat
  
  -- | Generate a 'HTraversable' instance along with the instance of its base classes:
  -- 'Hyper.Class.Foldable.HFoldable', 'Hyper.Class.Functor.HFunctor', and 'Hyper.Class.Nodes.HNodes'.
  makeHTraversableAndBases :: Name -> DecsQ
  makeHTraversableAndBases x =
      sequenceA
          [ makeHNodes x
          , makeHFunctor x
          , makeHTraversableAndFoldable x
          ]
          <&> concat
  
  -- | Generate 'HTraversable' and 'Hyper.Class.Foldable.HFoldable' instances
  makeHTraversableAndFoldable :: Name -> DecsQ
  makeHTraversableAndFoldable x =
      sequenceA
          [ makeHFoldable x
          , makeHTraversable x
          ]
          <&> concat
  
  -- | Generate a 'HTraversable' instance
  makeHTraversable :: Name -> DecsQ
  makeHTraversable typeName = makeTypeInfo typeName >>= makeHTraversableForType
  
  makeHTraversableForType :: TypeInfo -> DecsQ
  makeHTraversableForType info =
      instanceD
          (makeContext info >>= simplifyContext)
          [t|HTraversable $(pure (tiInstance info))|]
          [ InlineP 'hsequence Inline FunLike AllPhases & PragmaD & pure
          , funD 'hsequence (tiConstructors info <&> makeCons)
          ]
          <&> (: [])
  
  makeContext :: TypeInfo -> Q [Pred]
  makeContext info =
      tiConstructors info ^.. traverse . Lens._3 . traverse . Lens._Right
          & traverse ctxForPat
          <&> mconcat
      where
          ctxForPat (InContainer t pat) = (:) <$> [t|Traversable $(pure t)|] <*> ctxForPat pat
          ctxForPat (GenEmbed t) = [t|HTraversable $(pure t)|] <&> (: [])
          ctxForPat (FlatEmbed t) = makeContext t
          ctxForPat _ = pure []
  
  makeCons ::
      (Name, ConstructorVariant, [Either Type CtrTypePattern]) -> ClauseQ
  makeCons (cName, _, cFields) =
      clause [consPat cName consVars] body []
      where
          body =
              consVars
                  <&> f
                  & applicativeStyle (conE cName)
                  & normalB
          consVars = makeConstructorVars "x" cFields
          f (pat, name) = bodyFor pat `appE` varE name
          bodyFor (Right x) = bodyForPat x
          bodyFor Left{} = [|pure|]
          bodyForPat Node{} = [|runContainedH|]
          bodyForPat FlatEmbed{} = [|hsequence|]
          bodyForPat GenEmbed{} = [|hsequence|]
          bodyForPat (InContainer _ pat) = [|traverse $(bodyForPat pat)|]
  