-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Singletons.TH.Deriving.Foldable
-- Copyright   :  (C) 2018 Ryan Scott
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  Ryan Scott
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Implements deriving of Foldable instances
--
----------------------------------------------------------------------------

module Data.Singletons.TH.Deriving.Foldable where

import Data.Singletons.TH.Deriving.Infer
import Data.Singletons.TH.Deriving.Util
import Data.Singletons.TH.Names
import Data.Singletons.TH.Syntax
import Language.Haskell.TH.Desugar

mkFoldableInstance :: forall q. DsMonad q => DerivDesc q
mkFoldableInstance :: forall (q :: * -> *). DsMonad q => DerivDesc q
mkFoldableInstance Maybe DCxt
mb_ctxt DType
ty dd :: DataDecl
dd@(DataDecl DataFlavor
_ Name
_ [DTyVarBndrVis]
_ [DCon]
cons) = do
  Bool -> DataDecl -> q ()
forall (q :: * -> *). DsMonad q => Bool -> DataDecl -> q ()
functorLikeValidityChecks Bool
False DataDecl
dd
  f <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"_f"
  z <- newUniqueName "_z"
  let ft_foldMap :: FFoldType (q DExp)
      ft_foldMap = FT { ft_triv :: q DExp
ft_triv = q DExp -> q DExp
forall (q :: * -> *). Quasi q => q DExp -> q DExp
mkSimpleWildLam (q DExp -> q DExp) -> q DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ DExp -> q DExp
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ Name -> DExp
DVarE Name
memptyName
                        -- foldMap f = \x -> mempty
                      , ft_var :: q DExp
ft_var = DExp -> q DExp
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ Name -> DExp
DVarE Name
f
                        -- foldMap f = f
                      , ft_ty_app :: DType -> q DExp -> q DExp
ft_ty_app = \DType
_ q DExp
g -> DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE Name
foldMapName) (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> q DExp
g
                        -- foldMap f = foldMap g
                      , ft_forall :: [DTyVarBndrSpec] -> q DExp -> q DExp
ft_forall  = \[DTyVarBndrSpec]
_ q DExp
g -> q DExp
g
                      , ft_bad_app :: q DExp
ft_bad_app = String -> q DExp
forall a. HasCallStack => String -> a
error String
"in other argument in ft_foldMap"
                      }

      ft_foldr :: FFoldType (q DExp)
      ft_foldr = FT { ft_triv :: q DExp
ft_triv = (DExp -> q DExp) -> q DExp
forall (q :: * -> *). Quasi q => (DExp -> q DExp) -> q DExp
mkSimpleWildLam2 DExp -> q DExp
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                      -- foldr f = \x z -> z
                    , ft_var :: q DExp
ft_var  = DExp -> q DExp
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ Name -> DExp
DVarE Name
f
                      -- foldr f = f
                    , ft_ty_app :: DType -> q DExp -> q DExp
ft_ty_app = \DType
_ q DExp
g -> do
                        gg <- q DExp
g
                        mkSimpleLam2 $ \DExp
x DExp
z' -> DExp -> q DExp
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$
                          Name -> DExp
DVarE Name
foldrName DExp -> DExp -> DExp
`DAppE` DExp
gg DExp -> DExp -> DExp
`DAppE` DExp
z' DExp -> DExp -> DExp
`DAppE` DExp
x
                      -- foldr f = (\x z -> foldr g z x)
                    , ft_forall :: [DTyVarBndrSpec] -> q DExp -> q DExp
ft_forall  = \[DTyVarBndrSpec]
_ q DExp
g -> q DExp
g
                    , ft_bad_app :: q DExp
ft_bad_app = String -> q DExp
forall a. HasCallStack => String -> a
error String
"in other argument in ft_foldr"
                    }

      clause_for_foldMap :: [DPat] -> DCon -> [DExp] -> q DClause
      clause_for_foldMap = (Name -> [DExp] -> DExp) -> [DPat] -> DCon -> [DExp] -> q DClause
forall (q :: * -> *).
Quasi q =>
(Name -> [DExp] -> DExp) -> [DPat] -> DCon -> [DExp] -> q DClause
mkSimpleConClause ((Name -> [DExp] -> DExp) -> [DPat] -> DCon -> [DExp] -> q DClause)
-> (Name -> [DExp] -> DExp)
-> [DPat]
-> DCon
-> [DExp]
-> q DClause
forall a b. (a -> b) -> a -> b
$ \Name
_ -> [DExp] -> DExp
mkFoldMap
        where
          -- mappend v1 (mappend v2 ..)
          mkFoldMap :: [DExp] -> DExp
          mkFoldMap :: [DExp] -> DExp
mkFoldMap [] = Name -> DExp
DVarE Name
memptyName
          mkFoldMap [DExp]
xs = (DExp -> DExp -> DExp) -> [DExp] -> DExp
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\DExp
x DExp
y -> Name -> DExp
DVarE Name
mappendName DExp -> DExp -> DExp
`DAppE` DExp
x DExp -> DExp -> DExp
`DAppE` DExp
y) [DExp]
xs

      clause_for_foldr :: [DPat] -> DCon -> [DExp] -> q DClause
      clause_for_foldr = (Name -> [DExp] -> DExp) -> [DPat] -> DCon -> [DExp] -> q DClause
forall (q :: * -> *).
Quasi q =>
(Name -> [DExp] -> DExp) -> [DPat] -> DCon -> [DExp] -> q DClause
mkSimpleConClause ((Name -> [DExp] -> DExp) -> [DPat] -> DCon -> [DExp] -> q DClause)
-> (Name -> [DExp] -> DExp)
-> [DPat]
-> DCon
-> [DExp]
-> q DClause
forall a b. (a -> b) -> a -> b
$ \Name
_ -> [DExp] -> DExp
mkFoldr
        where
          -- g1 v1 (g2 v2 (.. z))
          mkFoldr :: [DExp] -> DExp
          mkFoldr :: [DExp] -> DExp
mkFoldr = (DExp -> DExp -> DExp) -> DExp -> [DExp] -> DExp
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE Name
z)

      mk_foldMap_clause :: DCon -> q DClause
      mk_foldMap_clause DCon
con = do
        parts <- FFoldType (q DExp) -> DCon -> q [q DExp]
forall (q :: * -> *) a. DsMonad q => FFoldType a -> DCon -> q [a]
foldDataConArgs FFoldType (q DExp)
ft_foldMap DCon
con
        clause_for_foldMap [DVarP f] con =<< sequence parts

      mk_foldr_clause :: DCon -> q DClause
      mk_foldr_clause DCon
con = do
        parts <- FFoldType (q DExp) -> DCon -> q [q DExp]
forall (q :: * -> *) a. DsMonad q => FFoldType a -> DCon -> q [a]
foldDataConArgs FFoldType (q DExp)
ft_foldr DCon
con
        clause_for_foldr [DVarP f, DVarP z] con =<< sequence parts

      mk_foldMap :: q [DClause]
      mk_foldMap =
        case [DCon]
cons of
          [] -> [DClause] -> q [DClause]
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[DPat] -> DExp -> DClause
DClause [DPat
DWildP, DPat
DWildP] (Name -> DExp
DVarE Name
memptyName)]
          [DCon]
_  -> (DCon -> q DClause) -> [DCon] -> q [DClause]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse DCon -> q DClause
mk_foldMap_clause [DCon]
cons

      mk_foldr :: q [DClause]
      mk_foldr = (DCon -> q DClause) -> [DCon] -> q [DClause]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse DCon -> q DClause
mk_foldr_clause [DCon]
cons

  foldMap_clauses <- mk_foldMap
  foldr_clauses   <- mk_foldr
  let meths = (Name
foldMapName, [DClause] -> LetDecRHS Unannotated
UFunction [DClause]
foldMap_clauses)
              (Name, LetDecRHS Unannotated)
-> [(Name, LetDecRHS Unannotated)]
-> [(Name, LetDecRHS Unannotated)]
forall a. a -> [a] -> [a]
: case [DCon]
cons of
                  [] -> []
                  [DCon]
_  -> [(Name
foldrName, [DClause] -> LetDecRHS Unannotated
UFunction [DClause]
foldr_clauses)]
  constraints <- inferConstraintsDef mb_ctxt (DConT foldableName) ty cons
  return $ InstDecl { id_cxt = constraints
                    , id_name = foldableName
                    , id_arg_tys = [ty]
                    , id_sigs  = mempty
                    , id_meths = meths }