-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Derive.TopDown.Instance
-- Copyright   :  (c) Song Zhang
-- License     :  BSD-style (see the LICENSE file)
-- 
-- Maintainer  :  haskell.zhang.song `at` hotmail.com
-- Stability   :  experimental
-- Portability :  non-portable
--
-----------------------------------------------------------------------------

module Data.Derive.TopDown.Instance
  ( instance_
  , instance_with_breaks
  , instances
  , instancess
  , instance_with
  ) where

import           Control.Monad
import           Control.Monad.State
import           Data.Derive.TopDown.CxtGen     ( genInferredContext )
import           Data.Derive.TopDown.IsInstance
import           Data.Derive.TopDown.Lib
import           Data.List                      ( foldl1' )
import           Language.Haskell.TH

gen_instance_decl
  :: ClassName
  -> TypeName
  -> [TypeName]  -- ^ a list of types that breaks the generation process
  -> Maybe Overlap
  -> ContextGenderator -- ^ a context generator
  -> StateT [Type] Q [Dec]
gen_instance_decl :: TypeName
-> TypeName
-> [TypeName]
-> Maybe Overlap
-> ContextGenderator
-> StateT [Type] Q [Dec]
gen_instance_decl TypeName
cn TypeName
tn [TypeName]
breaks Maybe Overlap
mo ContextGenderator
cg = do
  ([TyVarBndr ()]
tvbs, [Con]
cons) <- Q ([TyVarBndr ()], [Con])
-> StateT [Type] Q ([TyVarBndr ()], [Con])
forall (m :: * -> *) a. Monad m => m a -> StateT [Type] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q ([TyVarBndr ()], [Con])
 -> StateT [Type] Q ([TyVarBndr ()], [Con]))
-> Q ([TyVarBndr ()], [Con])
-> StateT [Type] Q ([TyVarBndr ()], [Con])
forall a b. (a -> b) -> a -> b
$ TypeName -> Q ([TyVarBndr ()], [Con])
getTyVarCons TypeName
tn
  let typeNames :: [TypeName]
typeNames = (TyVarBndr () -> TypeName) -> [TyVarBndr ()] -> [TypeName]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr () -> TypeName
forall a. TyVarBndr a -> TypeName
getTVBName [TyVarBndr ()]
tvbs
  Bool
isCnHighOrderClass <- Q Bool -> StateT [Type] Q Bool
forall (m :: * -> *) a. Monad m => m a -> StateT [Type] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Bool -> StateT [Type] Q Bool) -> Q Bool -> StateT [Type] Q Bool
forall a b. (a -> b) -> a -> b
$ TypeName -> Q Bool
isHigherOrderClass TypeName
cn
  -- prevent calling isInstance class with * -> * and type with *
  if Bool
isCnHighOrderClass Bool -> Bool -> Bool
&& [TypeName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TypeName]
typeNames
    then [Dec] -> StateT [Type] Q [Dec]
forall a. a -> StateT [Type] Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    else do
      Type
saturatedType <- Q Type -> StateT [Type] Q Type
forall (m :: * -> *) a. Monad m => m a -> StateT [Type] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Type -> StateT [Type] Q Type) -> Q Type -> StateT [Type] Q Type
forall a b. (a -> b) -> a -> b
$ (Q Type -> Q Type -> Q Type) -> [Q Type] -> Q Type
forall a. HasCallStack => (a -> a -> a) -> [a] -> a
foldl1' Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (TypeName -> Q Type
forall (m :: * -> *). Quote m => TypeName -> m Type
conT TypeName
tn Q Type -> [Q Type] -> [Q Type]
forall a. a -> [a] -> [a]
: (TypeName -> Q Type) -> [TypeName] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map TypeName -> Q Type
forall (m :: * -> *). Quote m => TypeName -> m Type
varT [TypeName]
typeNames)
      Type
instanceType  <- if Bool
isCnHighOrderClass Bool -> Bool -> Bool
&& (Bool -> Bool
not (Bool -> Bool) -> ([TypeName] -> Bool) -> [TypeName] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TypeName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [TypeName]
typeNames
        then
          let pns :: [TypeName]
pns = [TypeName] -> [TypeName]
forall a. HasCallStack => [a] -> [a]
init [TypeName]
typeNames
          in  if [TypeName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TypeName]
pns
                then Q Type -> StateT [Type] Q Type
forall (m :: * -> *) a. Monad m => m a -> StateT [Type] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Type -> StateT [Type] Q Type) -> Q Type -> StateT [Type] Q Type
forall a b. (a -> b) -> a -> b
$ TypeName -> Q Type
forall (m :: * -> *). Quote m => TypeName -> m Type
conT TypeName
tn
                else Q Type -> StateT [Type] Q Type
forall (m :: * -> *) a. Monad m => m a -> StateT [Type] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Type -> StateT [Type] Q Type) -> Q Type -> StateT [Type] Q Type
forall a b. (a -> b) -> a -> b
$ (Q Type -> Q Type -> Q Type) -> [Q Type] -> Q Type
forall a. HasCallStack => (a -> a -> a) -> [a] -> a
foldl1' Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (TypeName -> Q Type
forall (m :: * -> *). Quote m => TypeName -> m Type
conT TypeName
tn Q Type -> [Q Type] -> [Q Type]
forall a. a -> [a] -> [a]
: ((TypeName -> Q Type) -> [TypeName] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map TypeName -> Q Type
forall (m :: * -> *). Quote m => TypeName -> m Type
varT [TypeName]
pns))
        else Type -> StateT [Type] Q Type
forall a. a -> StateT [Type] Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
saturatedType
      Bool
isMember <- Q Bool -> StateT [Type] Q Bool
forall (m :: * -> *) a. Monad m => m a -> StateT [Type] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Bool -> StateT [Type] Q Bool) -> Q Bool -> StateT [Type] Q Bool
forall a b. (a -> b) -> a -> b
$ TypeName -> [Type] -> Q Bool
isInstance' TypeName
cn [Type
instanceType]
      [Type]
table    <- StateT [Type] Q [Type]
forall s (m :: * -> *). MonadState s m => m s
get
      if Bool
isMember Bool -> Bool -> Bool
|| Type -> [Type] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Type
instanceType [Type]
table Bool -> Bool -> Bool
|| TypeName -> [TypeName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem TypeName
tn [TypeName]
breaks
         -- normally empty instance will not be used to derive Generic
         -- so I do not check Generic and Generic1
        then [Dec] -> StateT [Type] Q [Dec]
forall a. a -> StateT [Type] Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
        else do
          [Type]
classContext <- if Bool
isCnHighOrderClass
            then [Type] -> StateT [Type] Q [Type]
forall a. a -> StateT [Type] Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
            else Q [Type] -> StateT [Type] Q [Type]
forall (m :: * -> *) a. Monad m => m a -> StateT [Type] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q [Type] -> StateT [Type] Q [Type])
-> Q [Type] -> StateT [Type] Q [Type]
forall a b. (a -> b) -> a -> b
$ ContextGenderator
cg TypeName
cn TypeName
tn
          let decl :: [Dec]
decl =
                [Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
mo [Type]
classContext (Type -> Type -> Type
AppT (TypeName -> Type
ConT TypeName
cn) Type
instanceType) []]
          ([Type] -> [Type]) -> StateT [Type] Q ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Type
instanceType Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:)
          [TypeName]
names  <- Q [TypeName] -> StateT [Type] Q [TypeName]
forall (m :: * -> *) a. Monad m => m a -> StateT [Type] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q [TypeName] -> StateT [Type] Q [TypeName])
-> Q [TypeName] -> StateT [Type] Q [TypeName]
forall a b. (a -> b) -> a -> b
$ ([[TypeName]] -> [TypeName]) -> Q [[TypeName]] -> Q [TypeName]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[TypeName]] -> [TypeName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[TypeName]] -> Q [TypeName]) -> Q [[TypeName]] -> Q [TypeName]
forall a b. (a -> b) -> a -> b
$ (Con -> Q [TypeName]) -> [Con] -> Q [[TypeName]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Con -> Q [TypeName]
getCompositeTypeNames [Con]
cons
          [TypeName]
names' <- Q [TypeName] -> StateT [Type] Q [TypeName]
forall (m :: * -> *) a. Monad m => m a -> StateT [Type] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
            (Q [TypeName] -> StateT [Type] Q [TypeName])
-> Q [TypeName] -> StateT [Type] Q [TypeName]
forall a b. (a -> b) -> a -> b
$ (TypeName -> Q Bool) -> [TypeName] -> Q [TypeName]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (\TypeName
x -> TypeName -> Q Bool
isTypeFamily TypeName
x Q Bool -> (Bool -> Q Bool) -> Q Bool
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b -> Bool -> Q Bool
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Q Bool) -> Bool -> Q Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
b) [TypeName]
names
          [[Dec]]
xs <- (TypeName -> StateT [Type] Q [Dec])
-> [TypeName] -> StateT [Type] Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\TypeName
n -> TypeName
-> TypeName
-> [TypeName]
-> Maybe Overlap
-> ContextGenderator
-> StateT [Type] Q [Dec]
gen_instance_decl TypeName
cn TypeName
n [TypeName]
breaks Maybe Overlap
mo ContextGenderator
cg) [TypeName]
names'
          [Dec] -> StateT [Type] Q [Dec]
forall a. a -> StateT [Type] Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> StateT [Type] Q [Dec]) -> [Dec] -> StateT [Type] Q [Dec]
forall a b. (a -> b) -> a -> b
$ [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
xs [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
decl

instance_
  :: Name -- ^ class name
  -> Name -- ^ type name
  -> Q [Dec]
instance_ :: TypeName -> TypeName -> Q [Dec]
instance_ TypeName
cn TypeName
tn =
  StateT [Type] Q [Dec] -> [Type] -> Q [Dec]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (TypeName
-> TypeName
-> [TypeName]
-> Maybe Overlap
-> ContextGenderator
-> StateT [Type] Q [Dec]
gen_instance_decl TypeName
cn TypeName
tn [] Maybe Overlap
forall a. Maybe a
Nothing ContextGenderator
genInferredContext) []

instance_with_breaks
  :: Name -- ^ class name
  -> Name -- ^ type name
  -> [Name] -- ^ type names that stop the deriving process
  -> Q [Dec]
instance_with_breaks :: TypeName -> TypeName -> [TypeName] -> Q [Dec]
instance_with_breaks TypeName
cn TypeName
tn [TypeName]
bs =
  StateT [Type] Q [Dec] -> [Type] -> Q [Dec]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (TypeName
-> TypeName
-> [TypeName]
-> Maybe Overlap
-> ContextGenderator
-> StateT [Type] Q [Dec]
gen_instance_decl TypeName
cn TypeName
tn [TypeName]
bs Maybe Overlap
forall a. Maybe a
Nothing ContextGenderator
genInferredContext) []

instances
  :: [Name] -- ^ class names
  -> Name   -- ^ type name
  -> Q [Dec]
instances :: [TypeName] -> TypeName -> Q [Dec]
instances [TypeName]
cns TypeName
tn = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((TypeName -> Q [Dec]) -> [TypeName] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\TypeName
x -> TypeName -> TypeName -> Q [Dec]
instance_ TypeName
x TypeName
tn) [TypeName]
cns)

instancess
  :: [Name] -- ^ class names
  -> [Name] -- ^ type names
  -> Q [Dec]
instancess :: [TypeName] -> [TypeName] -> Q [Dec]
instancess [TypeName]
cns [TypeName]
tns = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((TypeName -> Q [Dec]) -> [TypeName] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\TypeName
x -> [TypeName] -> TypeName -> Q [Dec]
instances [TypeName]
cns TypeName
x) [TypeName]
tns)

instance_with
  :: ClassName
  -> TypeName
  -> [TypeName]        -- ^ a list of types that breaks the generation process
  -> Maybe Overlap
  -> ContextGenderator -- ^ a context generator
  -> Q [Dec]
instance_with :: TypeName
-> TypeName
-> [TypeName]
-> Maybe Overlap
-> ContextGenderator
-> Q [Dec]
instance_with TypeName
cn TypeName
tn [TypeName]
bs Maybe Overlap
mo ContextGenderator
cg = StateT [Type] Q [Dec] -> [Type] -> Q [Dec]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (TypeName
-> TypeName
-> [TypeName]
-> Maybe Overlap
-> ContextGenderator
-> StateT [Type] Q [Dec]
gen_instance_decl TypeName
cn TypeName
tn [TypeName]
bs Maybe Overlap
mo ContextGenderator
cg) []