{-# LANGUAGE CPP #-}
module Data.Comp.Derive.Utils where
import Control.Monad
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.ExpandSyns
#if __GLASGOW_HASKELL__ < 706
reportError :: String -> Q ()
reportError = report True
#endif
#if __GLASGOW_HASKELL__ < 800
data DataInfo = DataInfo Cxt Name [TyVarBndr] [Con] [Name]
#else
#if __GLASGOW_HASKELL__ < 802
data DataInfo = DataInfo Cxt Name [TyVarBndr] [Con] Cxt
#else
data DataInfo = DataInfo Cxt Name [TyVarBndr] [Con] [DerivClause]
#endif
#endif
abstractNewtypeQ :: Q Info -> Q (Maybe DataInfo)
abstractNewtypeQ :: Q Info -> Q (Maybe DataInfo)
abstractNewtypeQ = (Info -> Maybe DataInfo) -> Q Info -> Q (Maybe DataInfo)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Info -> Maybe DataInfo
abstractNewtype
abstractNewtype :: Info -> Maybe DataInfo
#if __GLASGOW_HASKELL__ < 800
abstractNewtype (TyConI (NewtypeD cxt name args constr derive))
= Just (DataInfo cxt name args [constr] derive)
abstractNewtype (TyConI (DataD cxt name args constrs derive))
= Just (DataInfo cxt name args constrs derive)
#else
abstractNewtype :: Info -> Maybe DataInfo
abstractNewtype (TyConI (NewtypeD Cxt
cxt Name
name [TyVarBndr]
args Maybe Kind
_ Con
constr [DerivClause]
derive))
= DataInfo -> Maybe DataInfo
forall a. a -> Maybe a
Just (Cxt -> Name -> [TyVarBndr] -> [Con] -> [DerivClause] -> DataInfo
DataInfo Cxt
cxt Name
name [TyVarBndr]
args [Con
constr] [DerivClause]
derive)
abstractNewtype (TyConI (DataD Cxt
cxt Name
name [TyVarBndr]
args Maybe Kind
_ [Con]
constrs [DerivClause]
derive))
= DataInfo -> Maybe DataInfo
forall a. a -> Maybe a
Just (Cxt -> Name -> [TyVarBndr] -> [Con] -> [DerivClause] -> DataInfo
DataInfo Cxt
cxt Name
name [TyVarBndr]
args [Con]
constrs [DerivClause]
derive)
#endif
abstractNewtype Info
_ = Maybe DataInfo
forall a. Maybe a
Nothing
normalCon :: Con -> (Name,[StrictType], Maybe Type)
normalCon :: Con -> (Name, [StrictType], Maybe Kind)
normalCon (NormalC Name
constr [StrictType]
args) = (Name
constr, [StrictType]
args, Maybe Kind
forall a. Maybe a
Nothing)
normalCon (RecC Name
constr [VarBangType]
args) = (Name
constr, (VarBangType -> StrictType) -> [VarBangType] -> [StrictType]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
_,Bang
s,Kind
t) -> (Bang
s,Kind
t)) [VarBangType]
args, Maybe Kind
forall a. Maybe a
Nothing)
normalCon (InfixC StrictType
a Name
constr StrictType
b) = (Name
constr, [StrictType
a,StrictType
b], Maybe Kind
forall a. Maybe a
Nothing)
normalCon (ForallC [TyVarBndr]
_ Cxt
_ Con
constr) = Con -> (Name, [StrictType], Maybe Kind)
normalCon Con
constr
#if __GLASGOW_HASKELL__ >= 800
normalCon (GadtC (Name
constr:[Name]
_) [StrictType]
args Kind
typ) = (Name
constr,[StrictType]
args,Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
typ)
#endif
normalCon Con
_ = [Char] -> (Name, [StrictType], Maybe Kind)
forall a. HasCallStack => [Char] -> a
error [Char]
"missing case for 'normalCon'"
normalCon' :: Con -> (Name,[Type], Maybe Type)
normalCon' :: Con -> (Name, Cxt, Maybe Kind)
normalCon' Con
con = (Name
n, (StrictType -> Kind) -> [StrictType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map StrictType -> Kind
forall a b. (a, b) -> b
snd [StrictType]
ts, Maybe Kind
t)
where (Name
n, [StrictType]
ts, Maybe Kind
t) = Con -> (Name, [StrictType], Maybe Kind)
normalCon Con
con
normalConExp :: Con -> Q (Name,[Type], Maybe Type)
normalConExp :: Con -> Q (Name, Cxt, Maybe Kind)
normalConExp Con
c = do
let (Name
n,Cxt
ts,Maybe Kind
t) = Con -> (Name, Cxt, Maybe Kind)
normalCon' Con
c
(Name, Cxt, Maybe Kind) -> Q (Name, Cxt, Maybe Kind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, Cxt
ts,Maybe Kind
t)
normalConStrExp :: Con -> Q (Name,[StrictType], Maybe Type)
normalConStrExp :: Con -> Q (Name, [StrictType], Maybe Kind)
normalConStrExp Con
c = do
let (Name
n,[StrictType]
ts,Maybe Kind
t) = Con -> (Name, [StrictType], Maybe Kind)
normalCon Con
c
[StrictType]
ts' <- (StrictType -> Q StrictType) -> [StrictType] -> Q [StrictType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ (Bang
st,Kind
ty) -> do Kind
ty' <- Kind -> Q Kind
expandSyns Kind
ty; StrictType -> Q StrictType
forall (m :: * -> *) a. Monad m => a -> m a
return (Bang
st,Kind
ty')) [StrictType]
ts
(Name, [StrictType], Maybe Kind)
-> Q (Name, [StrictType], Maybe Kind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, [StrictType]
ts',Maybe Kind
t)
getBinaryFArg :: Type -> Maybe Type -> Type
getBinaryFArg :: Kind -> Maybe Kind -> Kind
getBinaryFArg Kind
_ (Just (AppT (AppT Kind
_ Kind
t) Kind
_)) = Kind
t
getBinaryFArg Kind
def Maybe Kind
_ = Kind
def
getUnaryFArg :: Type -> Maybe Type -> Type
getUnaryFArg :: Kind -> Maybe Kind -> Kind
getUnaryFArg Kind
_ (Just (AppT Kind
_ Kind
t)) = Kind
t
getUnaryFArg Kind
def Maybe Kind
_ = Kind
def
abstractConType :: Con -> (Name,Int)
abstractConType :: Con -> (Name, Int)
abstractConType (NormalC Name
constr [StrictType]
args) = (Name
constr, [StrictType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [StrictType]
args)
abstractConType (RecC Name
constr [VarBangType]
args) = (Name
constr, [VarBangType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [VarBangType]
args)
abstractConType (InfixC StrictType
_ Name
constr StrictType
_) = (Name
constr, Int
2)
abstractConType (ForallC [TyVarBndr]
_ Cxt
_ Con
constr) = Con -> (Name, Int)
abstractConType Con
constr
#if __GLASGOW_HASKELL__ >= 800
abstractConType (GadtC (Name
constr:[Name]
_) [StrictType]
args Kind
_typ) = (Name
constr,[StrictType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [StrictType]
args)
#endif
abstractConType Con
_ = [Char] -> (Name, Int)
forall a. HasCallStack => [Char] -> a
error [Char]
"missing case for 'abstractConType'"
tyVarBndrName :: TyVarBndr -> Name
tyVarBndrName (PlainTV Name
n) = Name
n
tyVarBndrName (KindedTV Name
n Kind
_) = Name
n
containsType :: Type -> Type -> Bool
containsType :: Kind -> Kind -> Bool
containsType Kind
s Kind
t
| Kind
s Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
t = Bool
True
| Bool
otherwise = case Kind
s of
ForallT [TyVarBndr]
_ Cxt
_ Kind
s' -> Kind -> Kind -> Bool
containsType Kind
s' Kind
t
AppT Kind
s1 Kind
s2 -> Kind -> Kind -> Bool
containsType Kind
s1 Kind
t Bool -> Bool -> Bool
|| Kind -> Kind -> Bool
containsType Kind
s2 Kind
t
SigT Kind
s' Kind
_ -> Kind -> Kind -> Bool
containsType Kind
s' Kind
t
Kind
_ -> Bool
False
containsType' :: Type -> Type -> [Int]
containsType' :: Kind -> Kind -> [Int]
containsType' = Int -> Kind -> Kind -> [Int]
forall a. Num a => a -> Kind -> Kind -> [a]
run Int
0
where run :: a -> Kind -> Kind -> [a]
run a
n Kind
s Kind
t
| Kind
s Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
t = [a
n]
| Bool
otherwise = case Kind
s of
ForallT [TyVarBndr]
_ Cxt
_ Kind
s' -> a -> Kind -> Kind -> [a]
run a
n Kind
s' Kind
t
AppT Kind
s1 Kind
s2 -> a -> Kind -> Kind -> [a]
run a
n Kind
s1 Kind
t [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ a -> Kind -> Kind -> [a]
run (a
na -> a -> a
forall a. Num a => a -> a -> a
+a
1) Kind
s2 Kind
t
SigT Kind
s' Kind
_ -> a -> Kind -> Kind -> [a]
run a
n Kind
s' Kind
t
Kind
_ -> []
newNames :: Int -> String -> Q [Name]
newNames :: Int -> [Char] -> Q [Name]
newNames Int
n [Char]
name = Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n ([Char] -> Q Name
newName [Char]
name)
tupleTypes :: Int -> Int -> [Name]
tupleTypes Int
n Int
m = (Int -> Name) -> [Int] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Name
tupleTypeName [Int
n..Int
m]
derive :: [Name -> Q [Dec]] -> [Name] -> Q [Dec]
derive :: [Name -> Q [Dec]] -> [Name] -> Q [Dec]
derive [Name -> Q [Dec]]
ders [Name]
names = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Q [Dec]] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Name -> Q [Dec]
der Name
name | Name -> Q [Dec]
der <- [Name -> Q [Dec]]
ders, Name
name <- [Name]
names]
#if __GLASGOW_HASKELL__ < 710
mkClassP :: Name -> [Type] -> Pred
mkClassP = ClassP
#else
mkClassP :: Name -> [Type] -> Type
mkClassP :: Name -> Cxt -> Kind
mkClassP Name
name = (Kind -> Kind -> Kind) -> Kind -> Cxt -> Kind
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Kind -> Kind -> Kind
AppT (Name -> Kind
ConT Name
name)
#endif
#if __GLASGOW_HASKELL__ < 710
isEqualP :: Pred -> Maybe (Type, Type)
isEqualP (EqualP x y) = Just (x, y)
isEqualP _ = Nothing
#else
isEqualP :: Type -> Maybe (Type, Type)
isEqualP :: Kind -> Maybe (Kind, Kind)
isEqualP (AppT (AppT Kind
EqualityT Kind
x) Kind
y) = (Kind, Kind) -> Maybe (Kind, Kind)
forall a. a -> Maybe a
Just (Kind
x, Kind
y)
isEqualP Kind
_ = Maybe (Kind, Kind)
forall a. Maybe a
Nothing
#endif
mkInstanceD :: Cxt -> Type -> [Dec] -> Dec
#if __GLASGOW_HASKELL__ < 800
mkInstanceD cxt ty decs = InstanceD cxt ty decs
#else
mkInstanceD :: Cxt -> Kind -> [Dec] -> Dec
mkInstanceD Cxt
cxt Kind
ty [Dec]
decs = Maybe Overlap -> Cxt -> Kind -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing Cxt
cxt Kind
ty [Dec]
decs
#endif
liftSumGen :: Name -> Name -> Name -> Q [Dec]
liftSumGen :: Name -> Name -> Name -> Q [Dec]
liftSumGen Name
caseName Name
sumName Name
fname = do
ClassI (ClassD Cxt
_ Name
name [TyVarBndr]
targs_ [FunDep]
_ [Dec]
decs) [Dec]
_ <- Name -> Q Info
reify Name
fname
let targs :: [Name]
targs = (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
tyVarBndrName [TyVarBndr]
targs_
Maybe ([Name], [Name])
splitM <- [Name] -> [Dec] -> Q (Maybe ([Name], [Name]))
findSig [Name]
targs [Dec]
decs
case Maybe ([Name], [Name])
splitM of
Maybe ([Name], [Name])
Nothing -> do [Char] -> Q ()
reportError ([Char] -> Q ()) -> [Char] -> Q ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Class " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Show a => a -> [Char]
show Name
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" cannot be lifted to sums!"
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
Just ([Name]
ts1_, [Name]
ts2_) -> do
let f :: Kind
f = Name -> Kind
VarT (Name -> Kind) -> Name -> Kind
forall a b. (a -> b) -> a -> b
$ [Char] -> Name
mkName [Char]
"f"
let g :: Kind
g = Name -> Kind
VarT (Name -> Kind) -> Name -> Kind
forall a b. (a -> b) -> a -> b
$ [Char] -> Name
mkName [Char]
"g"
let ts1 :: Cxt
ts1 = (Name -> Kind) -> [Name] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> Kind
VarT [Name]
ts1_
let ts2 :: Cxt
ts2 = (Name -> Kind) -> [Name] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> Kind
VarT [Name]
ts2_
let cxt :: Cxt
cxt = [Name -> Cxt -> Kind
mkClassP Name
name (Cxt
ts1 Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ Kind
f Kind -> Cxt -> Cxt
forall a. a -> [a] -> [a]
: Cxt
ts2),
Name -> Cxt -> Kind
mkClassP Name
name (Cxt
ts1 Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ Kind
g Kind -> Cxt -> Cxt
forall a. a -> [a] -> [a]
: Cxt
ts2)]
let tp :: Kind
tp = ((Name -> Kind
ConT Name
sumName Kind -> Kind -> Kind
`AppT` Kind
f) Kind -> Kind -> Kind
`AppT` Kind
g)
let complType :: Kind
complType = (Kind -> Kind -> Kind) -> Kind -> Cxt -> Kind
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Kind -> Kind -> Kind
AppT ((Kind -> Kind -> Kind) -> Kind -> Cxt -> Kind
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Kind -> Kind -> Kind
AppT (Name -> Kind
ConT Name
name) Cxt
ts1 Kind -> Kind -> Kind
`AppT` Kind
tp) Cxt
ts2
[Dec]
decs' <- [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Q Dec] -> Q [Dec]) -> [Q Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (Dec -> [Q Dec]) -> [Dec] -> [Q Dec]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Dec -> [Q Dec]
decl [Dec]
decs
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Cxt -> Kind -> [Dec] -> Dec
mkInstanceD Cxt
cxt Kind
complType [Dec]
decs']
where decl :: Dec -> [DecQ]
decl :: Dec -> [Q Dec]
decl (SigD Name
f Kind
_) = [Name -> [ClauseQ] -> Q Dec
funD Name
f [Name -> ClauseQ
clause Name
f]]
decl Dec
_ = []
clause :: Name -> ClauseQ
clause :: Name -> ClauseQ
clause Name
f = do Name
x <- [Char] -> Q Name
newName [Char]
"x"
let b :: Body
b = Exp -> Body
NormalB (Name -> Exp
VarE Name
caseName Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
f Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
f Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
x)
Clause -> ClauseQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> ClauseQ) -> Clause -> ClauseQ
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
x] Body
b []
findSig :: [Name] -> [Dec] -> Q (Maybe ([Name],[Name]))
findSig :: [Name] -> [Dec] -> Q (Maybe ([Name], [Name]))
findSig [Name]
targs [Dec]
decs = case (Dec -> Q (Maybe Name)) -> [Dec] -> [Q (Maybe Name)]
forall a b. (a -> b) -> [a] -> [b]
map Dec -> Q (Maybe Name)
run [Dec]
decs of
[] -> Maybe ([Name], [Name]) -> Q (Maybe ([Name], [Name]))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ([Name], [Name])
forall a. Maybe a
Nothing
Q (Maybe Name)
mx:[Q (Maybe Name)]
_ -> do Maybe Name
x <- Q (Maybe Name)
mx
case Maybe Name
x of
Maybe Name
Nothing -> Maybe ([Name], [Name]) -> Q (Maybe ([Name], [Name]))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ([Name], [Name])
forall a. Maybe a
Nothing
Just Name
n -> Maybe ([Name], [Name]) -> Q (Maybe ([Name], [Name]))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ([Name], [Name]) -> Q (Maybe ([Name], [Name])))
-> Maybe ([Name], [Name]) -> Q (Maybe ([Name], [Name]))
forall a b. (a -> b) -> a -> b
$ Name -> [Name] -> Maybe ([Name], [Name])
forall a. Eq a => a -> [a] -> Maybe ([a], [a])
splitNames Name
n [Name]
targs
where run :: Dec -> Q (Maybe Name)
run :: Dec -> Q (Maybe Name)
run (SigD Name
_ Kind
ty) = do
Kind
ty' <- Kind -> Q Kind
expandSyns Kind
ty
Maybe Name -> Q (Maybe Name)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Name -> Q (Maybe Name)) -> Maybe Name -> Q (Maybe Name)
forall a b. (a -> b) -> a -> b
$ Bool -> Kind -> Maybe Name
getSig Bool
False Kind
ty'
run Dec
_ = Maybe Name -> Q (Maybe Name)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Name
forall a. Maybe a
Nothing
getSig :: Bool -> Kind -> Maybe Name
getSig Bool
t (ForallT [TyVarBndr]
_ Cxt
_ Kind
ty) = Bool -> Kind -> Maybe Name
getSig Bool
t Kind
ty
getSig Bool
False (AppT (AppT Kind
ArrowT Kind
ty) Kind
_) = Bool -> Kind -> Maybe Name
getSig Bool
True Kind
ty
getSig Bool
True (AppT Kind
ty Kind
_) = Bool -> Kind -> Maybe Name
getSig Bool
True Kind
ty
getSig Bool
True (VarT Name
n) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
getSig Bool
_ Kind
_ = Maybe Name
forall a. Maybe a
Nothing
splitNames :: a -> [a] -> Maybe ([a], [a])
splitNames a
y (a
x:[a]
xs)
| a
y a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x = ([a], [a]) -> Maybe ([a], [a])
forall a. a -> Maybe a
Just ([],[a]
xs)
| Bool
otherwise = do ([a]
xs1,[a]
xs2) <- a -> [a] -> Maybe ([a], [a])
splitNames a
y [a]
xs
([a], [a]) -> Maybe ([a], [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs1,[a]
xs2)
splitNames a
_ [] = Maybe ([a], [a])
forall a. Maybe a
Nothing