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

module Data.Singletons.TH.Deriving.Traversable 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

mkTraversableInstance :: forall q. DsMonad q => DerivDesc q
mkTraversableInstance :: forall (q :: * -> *). DsMonad q => DerivDesc q
mkTraversableInstance 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"
  let ft_trav :: FFoldType (q DExp)
      ft_trav = FT { ft_triv :: q DExp
ft_triv = 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
pureName
                     -- traverse f = pure x
                   , 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
                     -- traverse f = f x
                   , ft_ty_app :: DType -> q DExp -> q DExp
ft_ty_app = \DType
_ q DExp
g -> DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE Name
traverseName) (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> q DExp
g
                     -- traverse f = traverse 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_trav"
                   }

      -- Con a1 a2 ... -> Con <$> g1 a1 <*> g2 a2 <*> ...
      clause_for_con :: [DPat] -> DCon -> [DExp] -> q DClause
      clause_for_con = (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
con_name -> DExp -> [DExp] -> DExp
mkApCon (Name -> DExp
DConE Name
con_name)
        where
          -- ((Con <$> x1) <*> x2) <*> ...
          mkApCon :: DExp -> [DExp] -> DExp
          mkApCon :: DExp -> [DExp] -> DExp
mkApCon DExp
con []  = Name -> DExp
DVarE Name
pureName DExp -> DExp -> DExp
`DAppE` DExp
con
          mkApCon DExp
con [DExp
x] = Name -> DExp
DVarE Name
fmapName DExp -> DExp -> DExp
`DAppE` DExp
con DExp -> DExp -> DExp
`DAppE` DExp
x
          mkApCon DExp
con (DExp
x1:DExp
x2:[DExp]
xs) =
              (DExp -> DExp -> DExp) -> DExp -> [DExp] -> DExp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DExp -> DExp -> DExp
appAp (Name -> DExp
DVarE Name
liftA2Name DExp -> DExp -> DExp
`DAppE` DExp
con DExp -> DExp -> DExp
`DAppE` DExp
x1 DExp -> DExp -> DExp
`DAppE` DExp
x2) [DExp]
xs
            where appAp :: DExp -> DExp -> DExp
appAp DExp
x DExp
y = Name -> DExp
DVarE Name
apName DExp -> DExp -> DExp
`DAppE` DExp
x DExp -> DExp -> DExp
`DAppE` DExp
y

      mk_trav_clause :: DCon -> q DClause
      mk_trav_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_trav DCon
con
        clause_for_con [DVarP f] con =<< sequence parts

      mk_trav :: q [DClause]
      mk_trav = case [DCon]
cons of
                  [] -> do v <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"v"
                           pure [DClause [DWildP, DVarP v]
                                         (DVarE pureName `DAppE` dCaseE (DVarE v) [])]
                  [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_trav_clause [DCon]
cons

  trav_clauses <- mk_trav
  constraints <- inferConstraintsDef mb_ctxt (DConT traversableName) ty cons
  return $ InstDecl { id_cxt = constraints
                    , id_name = traversableName
                    , id_arg_tys = [ty]
                    , id_sigs  = mempty
                    , id_meths = [ (traverseName, UFunction trav_clauses) ] }