{-# LANGUAGE ScopedTypeVariables #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Singletons.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.Deriving.Traversable where

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

mkTraversableInstance :: forall q. DsMonad q => DerivDesc q
mkTraversableInstance :: DerivDesc q
mkTraversableInstance Maybe DCxt
mb_ctxt DType
ty dd :: DataDecl
dd@(DataDecl Name
_ [DTyVarBndr]
_ [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"
  let ft_trav :: FFoldType (q DExp)
      ft_trav :: FFoldType (q DExp)
ft_trav = FT :: forall a.
a
-> a
-> (DType -> a -> a)
-> a
-> ([DTyVarBndr] -> a -> a)
-> FFoldType a
FT { ft_triv :: q DExp
ft_triv = 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
pureName
                     -- traverse f = pure x
                   , 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
                     -- 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 :: [DTyVarBndr] -> q DExp -> q DExp
ft_forall = \[DTyVarBndr]
_ 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 :: [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 (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 -> q DClause
mk_trav_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_trav DCon
con
        [DPat] -> DCon -> [DExp] -> q DClause
clause_for_con [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_trav :: q [DClause]
      mk_trav :: q [DClause]
mk_trav = case [DCon]
cons of
                  [] -> do Name
v <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"v"
                           [DClause] -> q [DClause]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[DPat] -> DExp -> DClause
DClause [DPat
DWildP, Name -> DPat
DVarP Name
v]
                                         (Name -> DExp
DVarE Name
pureName DExp -> DExp -> DExp
`DAppE` DExp -> [DMatch] -> DExp
DCaseE (Name -> DExp
DVarE Name
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)
traverse DCon -> q DClause
mk_trav_clause [DCon]
cons

  [DClause]
trav_clauses <- q [DClause]
mk_trav
  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
traversableName) 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
traversableName
                    , 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
traverseName, [DClause] -> LetDecRHS Unannotated
UFunction [DClause]
trav_clauses) ] }