{-# LANGUAGE ScopedTypeVariables #-}

-----------------------------------------------------------------------------
-- |
-- 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 Name
_ [DTyVarBndrUnit]
_ [DCon]
cons) = do
  Bool -> DataDecl -> q ()
forall (q :: * -> *). DsMonad q => Bool -> DataDecl -> q ()
functorLikeValidityChecks Bool
False DataDecl
dd
  Name
f <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"_f"
  Name
z <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"_z"
  let ft_foldMap :: FFoldType (q DExp)
      ft_foldMap :: FFoldType (q DExp)
ft_foldMap = FT :: forall a.
a
-> a
-> (DType -> a -> a)
-> a
-> ([DTyVarBndrSpec] -> a -> a)
-> FFoldType a
FT { ft_triv :: q DExp
ft_triv = (DExp -> q DExp) -> q DExp
forall (q :: * -> *). Quasi q => (DExp -> q DExp) -> q DExp
mkSimpleLam ((DExp -> q DExp) -> q DExp) -> (DExp -> q DExp) -> q DExp
forall a b. (a -> b) -> a -> b
$ \DExp
_ -> DExp -> q DExp
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 (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 :: FFoldType (q DExp)
ft_foldr = FT :: forall a.
a
-> a
-> (DType -> a -> a)
-> a
-> ([DTyVarBndrSpec] -> a -> a)
-> FFoldType a
FT { ft_triv :: q DExp
ft_triv = (DExp -> DExp -> q DExp) -> q DExp
forall (q :: * -> *). Quasi q => (DExp -> DExp -> q DExp) -> q DExp
mkSimpleLam2 ((DExp -> DExp -> q DExp) -> q DExp)
-> (DExp -> DExp -> q DExp) -> q DExp
forall a b. (a -> b) -> a -> b
$ \DExp
_ DExp
z' -> DExp -> q DExp
forall (f :: * -> *) a. Applicative f => a -> f a
pure DExp
z'
                      -- foldr f = \x z -> z
                    , ft_var :: q DExp
ft_var  = DExp -> q DExp
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
                        DExp
gg <- q DExp
g
                        (DExp -> DExp -> q DExp) -> q DExp
forall (q :: * -> *). Quasi q => (DExp -> DExp -> q DExp) -> q DExp
mkSimpleLam2 ((DExp -> DExp -> q DExp) -> q DExp)
-> (DExp -> DExp -> q DExp) -> q DExp
forall a b. (a -> b) -> a -> b
$ \DExp
x DExp
z' -> DExp -> q DExp
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 :: [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 (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 :: [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 (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 -> q DClause
mk_foldMap_clause DCon
con = do
        [q DExp]
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
        [DPat] -> DCon -> [DExp] -> q DClause
clause_for_foldMap [Name -> DPat
DVarP Name
f] DCon
con ([DExp] -> q DClause) -> q [DExp] -> q DClause
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [q DExp] -> q [DExp]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [q DExp]
parts

      mk_foldr_clause :: DCon -> q DClause
      mk_foldr_clause :: DCon -> q DClause
mk_foldr_clause DCon
con = do
        [q DExp]
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
        [DPat] -> DCon -> [DExp] -> q DClause
clause_for_foldr [Name -> DPat
DVarP Name
f, Name -> DPat
DVarP Name
z] DCon
con ([DExp] -> q DClause) -> q [DExp] -> q DClause
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [q DExp] -> q [DExp]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [q DExp]
parts

      mk_foldMap :: q [DClause]
      mk_foldMap :: q [DClause]
mk_foldMap =
        case [DCon]
cons of
          [] -> [DClause] -> q [DClause]
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)
traverse DCon -> q DClause
mk_foldMap_clause [DCon]
cons

      mk_foldr :: q [DClause]
      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)
traverse DCon -> q DClause
mk_foldr_clause [DCon]
cons

  [DClause]
foldMap_clauses <- q [DClause]
mk_foldMap
  [DClause]
foldr_clauses   <- q [DClause]
mk_foldr
  let meths :: [(Name, LetDecRHS Unannotated)]
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)]
  DCxt
constraints <- Maybe DCxt -> DType -> DType -> [DCon] -> q DCxt
forall (q :: * -> *).
DsMonad q =>
Maybe DCxt -> DType -> DType -> [DCon] -> q DCxt
inferConstraintsDef Maybe DCxt
mb_ctxt (Name -> DType
DConT Name
foldableName) DType
ty [DCon]
cons
  UInstDecl -> q UInstDecl
forall (m :: * -> *) a. Monad m => a -> m a
return (UInstDecl -> q UInstDecl) -> UInstDecl -> q UInstDecl
forall a b. (a -> b) -> a -> b
$ InstDecl :: forall (ann :: AnnotationFlag).
DCxt
-> Name
-> DCxt
-> OMap Name DType
-> [(Name, LetDecRHS ann)]
-> InstDecl ann
InstDecl { id_cxt :: DCxt
id_cxt = DCxt
constraints
                    , id_name :: Name
id_name = Name
foldableName
                    , id_arg_tys :: DCxt
id_arg_tys = [DType
ty]
                    , id_sigs :: OMap Name DType
id_sigs  = OMap Name DType
forall a. Monoid a => a
mempty
                    , id_meths :: [(Name, LetDecRHS Unannotated)]
id_meths = [(Name, LetDecRHS Unannotated)]
meths }