{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PolyKinds #-}
-- | Shared functions for dependent-sum-template
module Data.Dependent.Sum.TH.Internal where

import Control.Monad
import Language.Haskell.TH
import Language.Haskell.TH.Extras
import Language.Haskell.TH.Datatype.TyVarBndr

classHeadToParams :: Type -> (Name, [Type])
classHeadToParams :: Type -> (Name, [Type])
classHeadToParams Type
t = (Name
h, [Type] -> [Type]
forall a. [a] -> [a]
reverse [Type]
reversedParams)
  where (Name
h, [Type]
reversedParams) = Type -> (Name, [Type])
go Type
t
        go :: Type -> (Name, [Type])
        go :: Type -> (Name, [Type])
go Type
t = case Type
t of
          AppT Type
f Type
x ->
            let (Name
h, [Type]
reversedParams) = Type -> (Name, [Type])
classHeadToParams Type
f
            in (Name
h, Type
x Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
reversedParams)
          Type
_ -> (Type -> Name
headOfType Type
t, [])

-- Invoke the deriver for the given class instance.  We assume that the type
-- we're deriving for is always the first typeclass parameter, if there are
-- multiple.
deriveForDec :: Name -> (Q Type -> Q Type) -> ([TyVarBndrSpec] -> [Con] -> Q Dec) -> Dec -> Q [Dec]
deriveForDec :: Name
-> (Q Type -> Q Type)
-> ([TyVarBndrSpec] -> [Con] -> Q Dec)
-> Dec
-> Q [Dec]
deriveForDec Name
className Q Type -> Q Type
makeClassHead [TyVarBndrSpec] -> [Con] -> Q Dec
f Dec
dec = Name
-> (Q Type -> Q Type)
-> ([TyVarBndrSpec] -> [Con] -> Q Dec)
-> Dec
-> Q [Dec]
deriveForDec' Name
className Q Type -> Q Type
makeClassHead ([TyVarBndrSpec] -> [Con] -> Q Dec
f ([TyVarBndrSpec] -> [Con] -> Q Dec)
-> ([TyVarBndrSpec] -> [TyVarBndrSpec])
-> [TyVarBndrSpec]
-> [Con]
-> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Specificity -> [TyVarBndrSpec] -> [TyVarBndrSpec]
forall newFlag oldFlag.
newFlag -> [TyVarBndrSpec] -> [TyVarBndrSpec]
changeTVFlags Specificity
specifiedSpec) Dec
dec

deriveForDec' :: Name -> (Q Type -> Q Type) -> ([TyVarBndrUnit] -> [Con] -> Q Dec) -> Dec -> Q [Dec]
deriveForDec' :: Name
-> (Q Type -> Q Type)
-> ([TyVarBndrSpec] -> [Con] -> Q Dec)
-> Dec
-> Q [Dec]
deriveForDec' Name
className Q Type -> Q Type
_ [TyVarBndrSpec] -> [Con] -> Q Dec
f (InstanceD Maybe Overlap
overlaps [Type]
cxt Type
classHead [Dec]
decs) = do
    let (Name
givenClassName, Type
firstParam : [Type]
_) = Type -> (Name, [Type])
classHeadToParams Type
classHead
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
givenClassName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
className) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
      String -> Q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"while deriving " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
className String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": wrong class name in prototype declaration: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
givenClassName
    let dataTypeName :: Name
dataTypeName = Type -> Name
headOfType Type
firstParam
    Info
dataTypeInfo <- Name -> Q Info
reify Name
dataTypeName
    case Info
dataTypeInfo of
        TyConI (DataD [Type]
dataCxt Name
name [TyVarBndrSpec]
bndrs Maybe Type
_ [Con]
cons [DerivClause]
_) -> do
            Dec
dec <- [TyVarBndrSpec] -> [Con] -> Q Dec
f [TyVarBndrSpec]
bndrs [Con]
cons
            [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
overlaps [Type]
cxt Type
classHead [Dec
dec]]
        Info
_ -> String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q [Dec]) -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ String
"while deriving " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
className String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": the name of an algebraic data type constructor is required"
deriveForDec' Name
className Q Type -> Q Type
makeClassHead [TyVarBndrSpec] -> [Con] -> Q Dec
f (DataD [Type]
dataCxt Name
name [TyVarBndrSpec]
bndrs Maybe Type
_ [Con]
cons [DerivClause]
_) = Dec -> [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Dec
inst
    where
        inst :: Q Dec
inst = CxtQ -> Q Type -> [Q Dec] -> Q Dec
instanceD ([Q Type] -> CxtQ
cxt ((Type -> Q Type) -> [Type] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return [Type]
dataCxt)) (Q Type -> Q Type
makeClassHead (Q Type -> Q Type) -> Q Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Q Type
conT Name
name) [Q Dec
dec]
        dec :: Q Dec
dec = [TyVarBndrSpec] -> [Con] -> Q Dec
f [TyVarBndrSpec]
bndrs [Con]
cons
#if __GLASGOW_HASKELL__ >= 808
deriveForDec' Name
className Q Type -> Q Type
makeClassHead [TyVarBndrSpec] -> [Con] -> Q Dec
f (DataInstD [Type]
dataCxt Maybe [TyVarBndrSpec]
tvBndrs Type
ty Maybe Type
_ [Con]
cons [DerivClause]
_) = Dec -> [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Dec
inst
#else
deriveForDec' className makeClassHead f (DataInstD dataCxt name tyArgs _ cons _) = return <$> inst
#endif
    where
        inst :: Q Dec
inst = CxtQ -> Q Type -> [Q Dec] -> Q Dec
instanceD ([Q Type] -> CxtQ
cxt ((Type -> Q Type) -> [Type] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return [Type]
dataCxt)) Q Type
clhead [Q Dec
dec]
#if __GLASGOW_HASKELL__ >= 808
        clhead :: Q Type
clhead = Q Type -> Q Type
makeClassHead (Q Type -> Q Type) -> Q Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
initTy Type
ty
#if __GLASGOW_HASKELL__ >= 900
        bndrs = [PlainTV v x | PlainTV v x <- maybe [] id tvBndrs]
#else
        bndrs :: [TyVarBndrSpec]
bndrs = [Name -> TyVarBndrSpec
PlainTV Name
v | PlainTV Name
v <- [TyVarBndrSpec]
-> ([TyVarBndrSpec] -> [TyVarBndrSpec])
-> Maybe [TyVarBndrSpec]
-> [TyVarBndrSpec]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [TyVarBndrSpec] -> [TyVarBndrSpec]
forall a. a -> a
id Maybe [TyVarBndrSpec]
tvBndrs]
#endif
        initTy :: Type -> Type
initTy (AppT Type
ty Type
_) = Type
ty
#else
        clhead = makeClassHead $ foldl1 appT (map return $ (ConT name : init tyArgs))
        -- TODO: figure out proper number of family parameters vs instance parameters
        bndrs = [PlainTV v | VarT v <- tail tyArgs ]
#endif
        dec :: Q Dec
dec = [TyVarBndrSpec] -> [Con] -> Q Dec
f [TyVarBndrSpec]
bndrs [Con]
cons