{-# LANGUAGE TemplateHaskell, CPP #-}
module Test.FitSpec.Derive
( deriveMutable
, deriveMutableE
, deriveMutableCascading
, deriveMutableCascadingE
, module Test.FitSpec.Mutable
, module Test.FitSpec.ShowMutable
, module Test.LeanCheck
)
where
import Test.FitSpec.Mutable
import Test.FitSpec.ShowMutable
import Test.LeanCheck
import Test.LeanCheck.Derive (deriveListableIfNeeded)
import Language.Haskell.TH
import Control.Monad (when, unless, liftM, liftM2, filterM)
import Data.List (delete)
#if __GLASGOW_HASKELL__ < 706
reportWarning :: String -> Q ()
reportWarning = report False
#endif
deriveMutable :: Name -> DecsQ
deriveMutable :: Name -> DecsQ
deriveMutable = [Name] -> Name -> DecsQ
deriveMutableE []
deriveMutableCascading :: Name -> DecsQ
deriveMutableCascading :: Name -> DecsQ
deriveMutableCascading = [Name] -> Name -> DecsQ
deriveMutableCascadingE []
deriveMutableE :: [Name] -> Name -> DecsQ
deriveMutableE :: [Name] -> Name -> DecsQ
deriveMutableE = Bool -> [Name] -> Name -> DecsQ
deriveMutableEX Bool
False
deriveMutableCascadingE :: [Name] -> Name -> DecsQ
deriveMutableCascadingE :: [Name] -> Name -> DecsQ
deriveMutableCascadingE = Bool -> [Name] -> Name -> DecsQ
deriveMutableEX Bool
True
deriveMutableEX :: Bool -> [Name] -> Name -> DecsQ
deriveMutableEX :: Bool -> [Name] -> Name -> DecsQ
deriveMutableEX Bool
cascade [Name]
cs Name
t = do
Bool
is <- Name
t Name -> Name -> Q Bool
`isInstanceOf` ''Mutable
if Bool
is
then do
String -> Q ()
reportWarning (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"Instance Mutable " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
t
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" already exists, skipping derivation"
[Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return []
else do
Bool
isEq <- Name
t Name -> Name -> Q Bool
`isInstanceOf` ''Eq
Bool
isShow <- Name
t Name -> Name -> Q Bool
`isInstanceOf` ''Show
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isEq (String -> Q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"Unable to derive Mutable " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
t
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (missing Eq instance)")
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isShow (String -> Q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"Unable to derive Mutable " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
t
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (missing Show instance)")
if Bool
cascade
then ([Dec] -> [Dec] -> [Dec]) -> DecsQ -> DecsQ -> DecsQ
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
(++) (Name -> DecsQ
deriveListableCascading Name
t) ([Name] -> Name -> DecsQ
reallyDeriveMutableCascading [Name]
cs Name
t)
else ([Dec] -> [Dec] -> [Dec]) -> DecsQ -> DecsQ -> DecsQ
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
(++) (Name -> DecsQ
deriveListableIfNeeded Name
t) ([Name] -> Name -> DecsQ
reallyDeriveMutable [Name]
cs Name
t)
reallyDeriveMutable :: [Name] -> Name -> DecsQ
reallyDeriveMutable :: [Name] -> Name -> DecsQ
reallyDeriveMutable [Name]
cs Name
t = do
(Type
nt,[Type]
vs) <- Name -> Q (Type, [Type])
normalizeType Name
t
#if __GLASGOW_HASKELL__ >= 710
[Type]
cxt <- [Q Type] -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ [t| $(conT c) $(return v) |]
#else
cxt <- sequence [ classP c [return v]
#endif
| Type
v <- [Type]
vs, Name
c <- ''EqName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:''ListableName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:''ShowName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name]
cs ]
#if __GLASGOW_HASKELL__ >= 708
[Type]
cxt [Type] -> DecsQ -> DecsQ
|=>| [d| instance Mutable $(return nt)
where mutiers = mutiersEq
instance ShowMutable $(return nt)
where mutantS = mutantSEq |]
#else
return [ InstanceD
cxt
(AppT (ConT ''Mutable) nt)
[ValD (VarP 'mutiers) (NormalB (VarE 'mutiersEq)) []]
, InstanceD
cxt
(AppT (ConT ''ShowMutable) nt)
[ValD (VarP 'mutantS) (NormalB (VarE 'mutantSEq)) []]
]
#endif
reallyDeriveMutableCascading :: [Name] -> Name -> DecsQ
reallyDeriveMutableCascading :: [Name] -> Name -> DecsQ
reallyDeriveMutableCascading [Name]
cs Name
t = do
[Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> DecsQ) -> ([[Dec]] -> [Dec]) -> [[Dec]] -> DecsQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
([[Dec]] -> DecsQ) -> Q [[Dec]] -> DecsQ
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Name -> DecsQ) -> [Name] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Name] -> Name -> DecsQ
reallyDeriveMutable [Name]
cs)
([Name] -> Q [[Dec]]) -> Q [Name] -> Q [[Dec]]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Name -> Q Bool) -> [Name] -> Q [Name]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ((Bool -> Bool) -> Q Bool -> Q Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Bool -> Bool
not (Q Bool -> Q Bool) -> (Name -> Q Bool) -> Name -> Q Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Bool
isTypeSynonym)
([Name] -> Q [Name]) -> Q [Name] -> Q [Name]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Name] -> Q [Name]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name] -> Q [Name]) -> ([Name] -> [Name]) -> [Name] -> Q [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name
tName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:) ([Name] -> [Name]) -> ([Name] -> [Name]) -> [Name] -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Name] -> [Name]
forall a. Eq a => a -> [a] -> [a]
delete Name
t
([Name] -> Q [Name]) -> Q [Name] -> Q [Name]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Name
t Name -> (Name -> Q Bool) -> Q [Name]
`typeConCascadingArgsThat` (Name -> Name -> Q Bool
`isntInstanceOf` ''Mutable)
typeConArgs :: Name -> Q [Name]
typeConArgs :: Name -> Q [Name]
typeConArgs Name
t = do
Bool
is <- Name -> Q Bool
isTypeSynonym Name
t
if Bool
is
then (Type -> [Name]) -> Q Type -> Q [Name]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Type -> [Name]
typeConTs (Q Type -> Q [Name]) -> Q Type -> Q [Name]
forall a b. (a -> b) -> a -> b
$ Name -> Q Type
typeSynonymType Name
t
else ([(Name, [Type])] -> [Name]) -> Q [(Name, [Type])] -> Q [Name]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ([[Name]] -> [Name]
forall a. Ord a => [[a]] -> [a]
nubMerges ([[Name]] -> [Name])
-> ([(Name, [Type])] -> [[Name]]) -> [(Name, [Type])] -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> [Name]) -> [Type] -> [[Name]]
forall a b. (a -> b) -> [a] -> [b]
map Type -> [Name]
typeConTs ([Type] -> [[Name]])
-> ([(Name, [Type])] -> [Type]) -> [(Name, [Type])] -> [[Name]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Type]] -> [Type])
-> ([(Name, [Type])] -> [[Type]]) -> [(Name, [Type])] -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name, [Type]) -> [Type]) -> [(Name, [Type])] -> [[Type]]
forall a b. (a -> b) -> [a] -> [b]
map (Name, [Type]) -> [Type]
forall a b. (a, b) -> b
snd) (Q [(Name, [Type])] -> Q [Name]) -> Q [(Name, [Type])] -> Q [Name]
forall a b. (a -> b) -> a -> b
$ Name -> Q [(Name, [Type])]
typeConstructors Name
t
where
typeConTs :: Type -> [Name]
typeConTs :: Type -> [Name]
typeConTs (AppT Type
t1 Type
t2) = Type -> [Name]
typeConTs Type
t1 [Name] -> [Name] -> [Name]
forall a. Ord a => [a] -> [a] -> [a]
`nubMerge` Type -> [Name]
typeConTs Type
t2
typeConTs (SigT Type
t Type
_) = Type -> [Name]
typeConTs Type
t
typeConTs (VarT Name
_) = []
typeConTs (ConT Name
n) = [Name
n]
#if __GLASGOW_HASKELL__ >= 800
typeConTs (InfixT Type
t1 Name
n Type
t2) = Type -> [Name]
typeConTs Type
t1 [Name] -> [Name] -> [Name]
forall a. Ord a => [a] -> [a] -> [a]
`nubMerge` Type -> [Name]
typeConTs Type
t2
typeConTs (UInfixT Type
t1 Name
n Type
t2) = Type -> [Name]
typeConTs Type
t1 [Name] -> [Name] -> [Name]
forall a. Ord a => [a] -> [a] -> [a]
`nubMerge` Type -> [Name]
typeConTs Type
t2
typeConTs (ParensT Type
t) = Type -> [Name]
typeConTs Type
t
#endif
typeConTs Type
_ = []
typeConArgsThat :: Name -> (Name -> Q Bool) -> Q [Name]
typeConArgsThat :: Name -> (Name -> Q Bool) -> Q [Name]
typeConArgsThat Name
t Name -> Q Bool
p = do
[Name]
targs <- Name -> Q [Name]
typeConArgs Name
t
[(Name, Bool)]
tbs <- (Name -> Q (Name, Bool)) -> [Name] -> Q [(Name, Bool)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Name
t' -> do Bool
is <- Name -> Q Bool
p Name
t'; (Name, Bool) -> Q (Name, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
t',Bool
is)) [Name]
targs
[Name] -> Q [Name]
forall (m :: * -> *) a. Monad m => a -> m a
return [Name
t' | (Name
t',Bool
p) <- [(Name, Bool)]
tbs, Bool
p]
typeConCascadingArgsThat :: Name -> (Name -> Q Bool) -> Q [Name]
Name
t typeConCascadingArgsThat :: Name -> (Name -> Q Bool) -> Q [Name]
`typeConCascadingArgsThat` Name -> Q Bool
p = do
[Name]
ts <- Name
t Name -> (Name -> Q Bool) -> Q [Name]
`typeConArgsThat` Name -> Q Bool
p
let p' :: Name -> Q Bool
p' Name
t' = do Bool
is <- Name -> Q Bool
p Name
t'; Bool -> Q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Q Bool) -> Bool -> Q Bool
forall a b. (a -> b) -> a -> b
$ Name
t' Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (Name
tName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name]
ts) Bool -> Bool -> Bool
&& Bool
is
[[Name]]
tss <- (Name -> Q [Name]) -> [Name] -> Q [[Name]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> (Name -> Q Bool) -> Q [Name]
`typeConCascadingArgsThat` Name -> Q Bool
p') [Name]
ts
[Name] -> Q [Name]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name] -> Q [Name]) -> [Name] -> Q [Name]
forall a b. (a -> b) -> a -> b
$ [[Name]] -> [Name]
forall a. Ord a => [[a]] -> [a]
nubMerges ([Name]
ts[Name] -> [[Name]] -> [[Name]]
forall a. a -> [a] -> [a]
:[[Name]]
tss)
normalizeType :: Name -> Q (Type, [Type])
normalizeType :: Name -> Q (Type, [Type])
normalizeType Name
t = do
Int
ar <- Name -> Q Int
typeArity Name
t
[Type]
vs <- Int -> Q [Type]
newVarTs Int
ar
(Type, [Type]) -> Q (Type, [Type])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
t) [Type]
vs, [Type]
vs)
where
newNames :: [String] -> Q [Name]
newNames :: [String] -> Q [Name]
newNames = (String -> Q Name) -> [String] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> Q Name
newName
newVarTs :: Int -> Q [Type]
newVarTs :: Int -> Q [Type]
newVarTs Int
n = ([Name] -> [Type]) -> Q [Name] -> Q [Type]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT)
(Q [Name] -> Q [Type]) -> Q [Name] -> Q [Type]
forall a b. (a -> b) -> a -> b
$ [String] -> Q [Name]
newNames (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
n ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> String) -> String -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Char -> String -> String
forall a. a -> [a] -> [a]
:[]) (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
cycle [Char
'a'..Char
'z'])
normalizeTypeUnits :: Name -> Q Type
normalizeTypeUnits :: Name -> Q Type
normalizeTypeUnits Name
t = do
Int
ar <- Name -> Q Int
typeArity Name
t
Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return ((Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
t) (Int -> Type -> [Type]
forall a. Int -> a -> [a]
replicate Int
ar (Int -> Type
TupleT Int
0)))
isInstanceOf :: Name -> Name -> Q Bool
isInstanceOf :: Name -> Name -> Q Bool
isInstanceOf Name
tn Name
cl = do
Type
ty <- Name -> Q Type
normalizeTypeUnits Name
tn
Name -> [Type] -> Q Bool
isInstance Name
cl [Type
ty]
isntInstanceOf :: Name -> Name -> Q Bool
isntInstanceOf :: Name -> Name -> Q Bool
isntInstanceOf Name
tn Name
cl = (Bool -> Bool) -> Q Bool -> Q Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Bool -> Bool
not (Name -> Name -> Q Bool
isInstanceOf Name
tn Name
cl)
typeArity :: Name -> Q Int
typeArity :: Name -> Q Int
typeArity Name
t = do
Info
ti <- Name -> Q Info
reify Name
t
Int -> Q Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Q Int) -> ([TyVarBndr] -> Int) -> [TyVarBndr] -> Q Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TyVarBndr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([TyVarBndr] -> Q Int) -> [TyVarBndr] -> Q Int
forall a b. (a -> b) -> a -> b
$ case Info
ti of
#if __GLASGOW_HASKELL__ < 800
TyConI (DataD _ _ ks _ _) -> ks
TyConI (NewtypeD _ _ ks _ _) -> ks
#else
TyConI (DataD [Type]
_ Name
_ [TyVarBndr]
ks Maybe Type
_ [Con]
_ [DerivClause]
_) -> [TyVarBndr]
ks
TyConI (NewtypeD [Type]
_ Name
_ [TyVarBndr]
ks Maybe Type
_ Con
_ [DerivClause]
_) -> [TyVarBndr]
ks
#endif
TyConI (TySynD Name
_ [TyVarBndr]
ks Type
_) -> [TyVarBndr]
ks
Info
_ -> String -> [TyVarBndr]
forall a. HasCallStack => String -> a
error (String -> [TyVarBndr]) -> String -> [TyVarBndr]
forall a b. (a -> b) -> a -> b
$ String
"error (typeArity): symbol " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
t
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not a newtype, data or type synonym"
typeConstructors :: Name -> Q [(Name,[Type])]
typeConstructors :: Name -> Q [(Name, [Type])]
typeConstructors Name
t = do
Info
ti <- Name -> Q Info
reify Name
t
[(Name, [Type])] -> Q [(Name, [Type])]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, [Type])] -> Q [(Name, [Type])])
-> ([Con] -> [(Name, [Type])]) -> [Con] -> Q [(Name, [Type])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Con -> (Name, [Type])) -> [Con] -> [(Name, [Type])]
forall a b. (a -> b) -> [a] -> [b]
map Con -> (Name, [Type])
simplify ([Con] -> Q [(Name, [Type])]) -> [Con] -> Q [(Name, [Type])]
forall a b. (a -> b) -> a -> b
$ case Info
ti of
#if __GLASGOW_HASKELL__ < 800
TyConI (DataD _ _ _ cs _) -> cs
TyConI (NewtypeD _ _ _ c _) -> [c]
#else
TyConI (DataD [Type]
_ Name
_ [TyVarBndr]
_ Maybe Type
_ [Con]
cs [DerivClause]
_) -> [Con]
cs
TyConI (NewtypeD [Type]
_ Name
_ [TyVarBndr]
_ Maybe Type
_ Con
c [DerivClause]
_) -> [Con
c]
#endif
Info
_ -> String -> [Con]
forall a. HasCallStack => String -> a
error (String -> [Con]) -> String -> [Con]
forall a b. (a -> b) -> a -> b
$ String
"error (typeConstructors): symbol " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
t
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is neither newtype nor data"
where
simplify :: Con -> (Name, [Type])
simplify (NormalC Name
n [BangType]
ts) = (Name
n,(BangType -> Type) -> [BangType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Type
forall a b. (a, b) -> b
snd [BangType]
ts)
simplify (RecC Name
n [VarBangType]
ts) = (Name
n,(VarBangType -> Type) -> [VarBangType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Type
forall a b c. (a, b, c) -> c
trd [VarBangType]
ts)
simplify (InfixC BangType
t1 Name
n BangType
t2) = (Name
n,[BangType -> Type
forall a b. (a, b) -> b
snd BangType
t1,BangType -> Type
forall a b. (a, b) -> b
snd BangType
t2])
trd :: (a, b, c) -> c
trd (a
x,b
y,c
z) = c
z
isTypeSynonym :: Name -> Q Bool
isTypeSynonym :: Name -> Q Bool
isTypeSynonym Name
t = do
Info
ti <- Name -> Q Info
reify Name
t
Bool -> Q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Q Bool) -> Bool -> Q Bool
forall a b. (a -> b) -> a -> b
$ case Info
ti of
TyConI (TySynD Name
_ [TyVarBndr]
_ Type
_) -> Bool
True
Info
_ -> Bool
False
typeSynonymType :: Name -> Q Type
typeSynonymType :: Name -> Q Type
typeSynonymType Name
t = do
Info
ti <- Name -> Q Info
reify Name
t
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
$ case Info
ti of
TyConI (TySynD Name
_ [TyVarBndr]
_ Type
t') -> Type
t'
Info
_ -> String -> Type
forall a. HasCallStack => String -> a
error (String -> Type) -> String -> Type
forall a b. (a -> b) -> a -> b
$ String
"error (typeSynonymType): symbol " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
t
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not a type synonym"
(|=>|) :: Cxt -> DecsQ -> DecsQ
[Type]
c |=>| :: [Type] -> DecsQ -> DecsQ
|=>| DecsQ
qds = do [Dec]
ds <- DecsQ
qds
[Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> DecsQ) -> [Dec] -> DecsQ
forall a b. (a -> b) -> a -> b
$ (Dec -> Dec) -> [Dec] -> [Dec]
forall a b. (a -> b) -> [a] -> [b]
map (Dec -> [Type] -> Dec
`ac` [Type]
c) [Dec]
ds
#if __GLASGOW_HASKELL__ < 800
where ac (InstanceD c ts ds) c' = InstanceD (c++c') ts ds
ac d _ = d
#else
where ac :: Dec -> [Type] -> Dec
ac (InstanceD Maybe Overlap
o [Type]
c Type
ts [Dec]
ds) [Type]
c' = Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
o ([Type]
c[Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++[Type]
c') Type
ts [Dec]
ds
ac Dec
d [Type]
_ = Dec
d
#endif
nubMerge :: Ord a => [a] -> [a] -> [a]
nubMerge :: [a] -> [a] -> [a]
nubMerge [] [a]
ys = [a]
ys
nubMerge [a]
xs [] = [a]
xs
nubMerge (a
x:[a]
xs) (a
y:[a]
ys) | a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
y = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs [a] -> [a] -> [a]
forall a. Ord a => [a] -> [a] -> [a]
`nubMerge` (a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys)
| a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
y = a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs) [a] -> [a] -> [a]
forall a. Ord a => [a] -> [a] -> [a]
`nubMerge` [a]
ys
| Bool
otherwise = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs [a] -> [a] -> [a]
forall a. Ord a => [a] -> [a] -> [a]
`nubMerge` [a]
ys
nubMerges :: Ord a => [[a]] -> [a]
nubMerges :: [[a]] -> [a]
nubMerges = ([a] -> [a] -> [a]) -> [a] -> [[a]] -> [a]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr [a] -> [a] -> [a]
forall a. Ord a => [a] -> [a] -> [a]
nubMerge []