{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, PatternGuards, CPP, DoAndIfThenElse #-}
module Data.Generics.Geniplate(
genUniverseBi, genUniverseBi', genUniverseBiT, genUniverseBiT',
genTransformBi, genTransformBi', genTransformBiT, genTransformBiT',
genTransformBiM, genTransformBiM', genTransformBiMT, genTransformBiMT',
UniverseBi(..), universe, instanceUniverseBi, instanceUniverseBiT,
TransformBi(..), transform, instanceTransformBi, instanceTransformBiT,
TransformBiM(..), transformM, instanceTransformBiM, instanceTransformBiMT,
DescendBiM(..), instanceDescendBiM, instanceDescendBiMT,
DescendM(..), descend, instanceDescendM, instanceDescendMT,
) where
import Control.Monad
import Control.Exception(assert)
import Control.Monad.State.Strict
import Control.Monad.Identity
import Data.Maybe
import Language.Haskell.TH hiding (conP)
import Language.Haskell.TH.Syntax hiding (lift)
conP :: Name -> [Pat] -> Pat
#if MIN_VERSION_template_haskell(2,18,0)
conP :: Name -> [Pat] -> Pat
conP Name
c = Name -> [Type] -> [Pat] -> Pat
ConP Name
c []
#else
conP c = ConP c
#endif
class UniverseBi s t where
universeBi :: s -> [t]
class TransformBi s t where
transformBi :: (s -> s) -> t -> t
class TransformBiM m s t where
transformBiM :: (s -> m s) -> t -> m t
class DescendBiM m s t where
descendBiM :: (s -> m s) -> t -> m t
class DescendM m t where
descendM :: (t -> m t) -> t -> m t
universe :: (UniverseBi a a) => a -> [a]
universe :: forall a. UniverseBi a a => a -> [a]
universe = forall s t. UniverseBi s t => s -> [t]
universeBi
transform :: (TransformBi a a) => (a -> a) -> a -> a
transform :: forall a. TransformBi a a => (a -> a) -> a -> a
transform = forall s t. TransformBi s t => (s -> s) -> t -> t
transformBi
transformM :: (TransformBiM m a a) => (a -> m a) -> a -> m a
transformM :: forall (m :: * -> *) a.
TransformBiM m a a =>
(a -> m a) -> a -> m a
transformM = forall (m :: * -> *) s t.
TransformBiM m s t =>
(s -> m s) -> t -> m t
transformBiM
descend :: (DescendM Identity a) => (a -> a) -> (a -> a)
descend :: forall a. DescendM Identity a => (a -> a) -> a -> a
descend a -> a
f = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) t. DescendM m t => (t -> m t) -> t -> m t
descendM (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
f)
instanceUniverseBi :: TypeQ
-> Q [Dec]
instanceUniverseBi :: TypeQ -> Q [Dec]
instanceUniverseBi = [TypeQ] -> TypeQ -> Q [Dec]
instanceUniverseBiT []
instanceUniverseBiT :: [TypeQ]
-> TypeQ
-> Q [Dec]
instanceUniverseBiT :: [TypeQ] -> TypeQ -> Q [Dec]
instanceUniverseBiT [TypeQ]
stops TypeQ
ty = [TypeQ] -> Type -> Q [Dec]
instanceUniverseBiT' [TypeQ]
stops forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TypeQ
ty
instanceUniverseBiT' :: [TypeQ] -> Type -> Q [Dec]
instanceUniverseBiT' :: [TypeQ] -> Type -> Q [Dec]
instanceUniverseBiT' [TypeQ]
stops (ForallT [TyVarBndr Specificity]
_ [Type]
_ Type
t) = [TypeQ] -> Type -> Q [Dec]
instanceUniverseBiT' [TypeQ]
stops Type
t
instanceUniverseBiT' [TypeQ]
stops Type
ty | (TupleT Int
_, [Type
from, Type
to]) <- Type -> (Type, [Type])
splitTypeApp Type
ty = do
([Dec]
ds, Exp
f) <- [TypeQ] -> Type -> Type -> Q ([Dec], Exp)
uniBiQ [TypeQ]
stops Type
from Type
to
Name
x <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"_x"
let e :: Exp
e = [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
x] forall a b. (a -> b) -> a -> b
$ [Dec] -> Exp -> Exp
LetE [Dec]
ds forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE Exp
f (Name -> Exp
VarE Name
x)) ([Exp] -> Exp
ListE [])
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> [Type] -> Name -> Exp -> [Dec]
instDef ''UniverseBi [Type
from, Type
to] 'universeBi Exp
e
instanceUniverseBiT' [TypeQ]
_ Type
t = forall a. String -> a
genError String
"instanceUniverseBi: the argument should be of the form [t| (S, T) |]"
funDef :: Name -> Exp -> [Dec]
funDef :: Name -> Exp -> [Dec]
funDef Name
f Exp
e = [Name -> [Clause] -> Dec
FunD Name
f [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
e) []]]
instDef :: Name -> [Type] -> Name -> Exp -> [Dec]
#if MIN_VERSION_template_haskell(2,11,0)
instDef :: Name -> [Type] -> Name -> Exp -> [Dec]
instDef Name
cls [Type]
ts Name
met Exp
e = [Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD forall a. Maybe a
Nothing [] (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
cls) [Type]
ts) (Name -> Exp -> [Dec]
funDef Name
met Exp
e)]
#else
instDef cls ts met e = [InstanceD [] (foldl AppT (ConT cls) ts) (funDef met e)]
#endif
instanceTransformBi :: TypeQ
-> Q [Dec]
instanceTransformBi :: TypeQ -> Q [Dec]
instanceTransformBi = [TypeQ] -> TypeQ -> Q [Dec]
instanceTransformBiT []
instanceTransformBiT :: [TypeQ]
-> TypeQ
-> Q [Dec]
instanceTransformBiT :: [TypeQ] -> TypeQ -> Q [Dec]
instanceTransformBiT [TypeQ]
stops TypeQ
ty = Mode -> [TypeQ] -> Type -> Q [Dec]
instanceTransformBiT' Mode
MTransformBi [TypeQ]
stops forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TypeQ
ty
data Mode = MTransformBi | MDescendBi | MDescend
deriving (Mode -> Mode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Mode -> Mode -> Bool
$c/= :: Mode -> Mode -> Bool
== :: Mode -> Mode -> Bool
$c== :: Mode -> Mode -> Bool
Eq, Eq Mode
Mode -> Mode -> Bool
Mode -> Mode -> Ordering
Mode -> Mode -> Mode
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Mode -> Mode -> Mode
$cmin :: Mode -> Mode -> Mode
max :: Mode -> Mode -> Mode
$cmax :: Mode -> Mode -> Mode
>= :: Mode -> Mode -> Bool
$c>= :: Mode -> Mode -> Bool
> :: Mode -> Mode -> Bool
$c> :: Mode -> Mode -> Bool
<= :: Mode -> Mode -> Bool
$c<= :: Mode -> Mode -> Bool
< :: Mode -> Mode -> Bool
$c< :: Mode -> Mode -> Bool
compare :: Mode -> Mode -> Ordering
$ccompare :: Mode -> Mode -> Ordering
Ord, Int -> Mode -> ShowS
[Mode] -> ShowS
Mode -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Mode] -> ShowS
$cshowList :: [Mode] -> ShowS
show :: Mode -> String
$cshow :: Mode -> String
showsPrec :: Int -> Mode -> ShowS
$cshowsPrec :: Int -> Mode -> ShowS
Show)
instanceTransformBiT' :: Mode -> [TypeQ] -> Type -> Q [Dec]
instanceTransformBiT' :: Mode -> [TypeQ] -> Type -> Q [Dec]
instanceTransformBiT' Mode
doDescend [TypeQ]
stops (ForallT [TyVarBndr Specificity]
_ [Type]
_ Type
t) = Mode -> [TypeQ] -> Type -> Q [Dec]
instanceTransformBiT' Mode
doDescend [TypeQ]
stops Type
t
instanceTransformBiT' Mode
doDescend [TypeQ]
stops Type
ty | (TupleT Int
_, [Type
ft, Type
st]) <- Type -> (Type, [Type])
splitTypeApp Type
ty = do
Name
f <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"_f"
Name
x <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"_x"
([Dec]
ds, Exp
tr) <- Mode -> RetAp -> [TypeQ] -> Name -> Type -> Type -> Q ([Dec], Exp)
trBiQ Mode
doDescend RetAp
raNormal [TypeQ]
stops Name
f Type
ft Type
st
let e :: Exp
e = [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
f, Name -> Pat
VarP Name
x] forall a b. (a -> b) -> a -> b
$ [Dec] -> Exp -> Exp
LetE [Dec]
ds forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE Exp
tr (Name -> Exp
VarE Name
x)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> [Type] -> Name -> Exp -> [Dec]
instDef ''TransformBi [Type
ft, Type
st] 'transformBi Exp
e
instanceTransformBiT' Mode
_ [TypeQ]
_ Type
t = forall a. String -> a
genError String
"instanceTransformBiT: the argument should be of the form [t| (S, T) |]"
instanceDescendM :: TypeQ
-> TypeQ
-> Q [Dec]
instanceDescendM :: TypeQ -> TypeQ -> Q [Dec]
instanceDescendM = [TypeQ] -> TypeQ -> TypeQ -> Q [Dec]
instanceDescendMT []
instanceDescendMT :: [TypeQ]
-> TypeQ
-> TypeQ
-> Q [Dec]
instanceDescendMT :: [TypeQ] -> TypeQ -> TypeQ -> Q [Dec]
instanceDescendMT [TypeQ]
stops TypeQ
mndq TypeQ
ty = Mode -> [TypeQ] -> TypeQ -> Type -> Q [Dec]
instanceTransformBiMT' Mode
MDescend [TypeQ]
stops TypeQ
mndq forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TypeQ
ty
instanceDescendBiM :: TypeQ
-> TypeQ
-> Q [Dec]
instanceDescendBiM :: TypeQ -> TypeQ -> Q [Dec]
instanceDescendBiM = [TypeQ] -> TypeQ -> TypeQ -> Q [Dec]
instanceDescendBiMT []
instanceDescendBiMT :: [TypeQ]
-> TypeQ
-> TypeQ
-> Q [Dec]
instanceDescendBiMT :: [TypeQ] -> TypeQ -> TypeQ -> Q [Dec]
instanceDescendBiMT [TypeQ]
stops TypeQ
mndq TypeQ
ty = Mode -> [TypeQ] -> TypeQ -> Type -> Q [Dec]
instanceTransformBiMT' Mode
MDescendBi [TypeQ]
stops TypeQ
mndq forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TypeQ
ty
instanceTransformBiM :: TypeQ
-> TypeQ
-> Q [Dec]
instanceTransformBiM :: TypeQ -> TypeQ -> Q [Dec]
instanceTransformBiM = [TypeQ] -> TypeQ -> TypeQ -> Q [Dec]
instanceTransformBiMT []
instanceTransformBiMT :: [TypeQ]
-> TypeQ
-> TypeQ
-> Q [Dec]
instanceTransformBiMT :: [TypeQ] -> TypeQ -> TypeQ -> Q [Dec]
instanceTransformBiMT [TypeQ]
stops TypeQ
mndq TypeQ
ty = Mode -> [TypeQ] -> TypeQ -> Type -> Q [Dec]
instanceTransformBiMT' Mode
MTransformBi [TypeQ]
stops TypeQ
mndq forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TypeQ
ty
instanceTransformBiMT' :: Mode -> [TypeQ] -> TypeQ -> Type -> Q [Dec]
instanceTransformBiMT' :: Mode -> [TypeQ] -> TypeQ -> Type -> Q [Dec]
instanceTransformBiMT' Mode
doDescend [TypeQ]
stops TypeQ
mndq (ForallT [TyVarBndr Specificity]
_ [Type]
_ Type
t) = Mode -> [TypeQ] -> TypeQ -> Type -> Q [Dec]
instanceTransformBiMT' Mode
doDescend [TypeQ]
stops TypeQ
mndq Type
t
instanceTransformBiMT' Mode
MDescend [TypeQ]
stops TypeQ
mndq Type
ty = do
Type
mnd <- TypeQ
mndq
Name
f <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"_f"
Name
x <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"_x"
([Dec]
ds, Exp
tr) <- Mode -> RetAp -> [TypeQ] -> Name -> Type -> Type -> Q ([Dec], Exp)
trBiQ Mode
MDescend RetAp
raMonad [TypeQ]
stops Name
f Type
ty Type
ty
let e :: Exp
e = [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
f, Name -> Pat
VarP Name
x] forall a b. (a -> b) -> a -> b
$ [Dec] -> Exp -> Exp
LetE [Dec]
ds forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE Exp
tr (Name -> Exp
VarE Name
x)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> [Type] -> Name -> Exp -> [Dec]
instDef ''DescendM [Type
mnd, Type
ty] 'descendM Exp
e
instanceTransformBiMT' Mode
doDescend [TypeQ]
stops TypeQ
mndq Type
ty | (TupleT Int
_, [Type
ft, Type
st]) <- Type -> (Type, [Type])
splitTypeApp Type
ty = do
Type
mnd <- TypeQ
mndq
Name
f <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"_f"
Name
x <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"_x"
([Dec]
ds, Exp
tr) <- Mode -> RetAp -> [TypeQ] -> Name -> Type -> Type -> Q ([Dec], Exp)
trBiQ Mode
doDescend RetAp
raMonad [TypeQ]
stops Name
f Type
ft Type
st
let e :: Exp
e = [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
f, Name -> Pat
VarP Name
x] forall a b. (a -> b) -> a -> b
$ [Dec] -> Exp -> Exp
LetE [Dec]
ds forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE Exp
tr (Name -> Exp
VarE Name
x)
cls :: Name
cls = case Mode
doDescend of Mode
MTransformBi -> ''TransformBiM; Mode
MDescendBi -> ''DescendBiM
met :: Name
met = case Mode
doDescend of Mode
MTransformBi -> 'transformBiM; Mode
MDescendBi -> 'descendBiM
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> [Type] -> Name -> Exp -> [Dec]
instDef Name
cls [Type
mnd, Type
ft, Type
st] Name
met Exp
e
instanceTransformBiMT' Mode
_ [TypeQ]
_ TypeQ
_ Type
t = forall a. String -> a
genError String
"instanceTransformBiMT: the argument should be of the form [t| (S, T) |]"
genUniverseBi :: Name
-> Q Exp
genUniverseBi :: Name -> Q Exp
genUniverseBi = [TypeQ] -> Name -> Q Exp
genUniverseBiT []
genUniverseBi' :: TypeQ -> Q Exp
genUniverseBi' :: TypeQ -> Q Exp
genUniverseBi' = [TypeQ] -> TypeQ -> Q Exp
genUniverseBiT' []
genUniverseBiT :: [TypeQ]
-> Name
-> Q Exp
genUniverseBiT :: [TypeQ] -> Name -> Q Exp
genUniverseBiT [TypeQ]
stops = forall (q :: * -> *).
Quasi q =>
Name -> q ([TyVarBndr Specificity], Type, Type)
getNameType forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall a. [TypeQ] -> ([TyVarBndr a], Type, Type) -> Q Exp
genUniverseBiTsplit [TypeQ]
stops
genUniverseBiT' :: [TypeQ] -> TypeQ -> Q Exp
genUniverseBiT' :: [TypeQ] -> TypeQ -> Q Exp
genUniverseBiT' [TypeQ]
stops TypeQ
q = TypeQ
q forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (q :: * -> *).
Quasi q =>
Type -> q ([TyVarBndr Specificity], Type, Type)
splitType forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. [TypeQ] -> ([TyVarBndr a], Type, Type) -> Q Exp
genUniverseBiTsplit [TypeQ]
stops
#if MIN_VERSION_template_haskell(2,17,0)
genUniverseBiTsplit :: [TypeQ] -> ([TyVarBndr a], Type, Type) -> Q Exp
#else
genUniverseBiTsplit :: [TypeQ] -> ([TyVarBndr], Type, Type) -> Q Exp
#endif
genUniverseBiTsplit :: forall a. [TypeQ] -> ([TyVarBndr a], Type, Type) -> Q Exp
genUniverseBiTsplit [TypeQ]
stops ([TyVarBndr a]
_tvs,Type
from,Type
tos) = do
let to :: Type
to = Type -> Type
unList Type
tos
([Dec]
ds, Exp
f) <- [TypeQ] -> Type -> Type -> Q ([Dec], Exp)
uniBiQ [TypeQ]
stops Type
from Type
to
Name
x <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"_x"
let e :: Exp
e = [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
x] forall a b. (a -> b) -> a -> b
$ [Dec] -> Exp -> Exp
LetE [Dec]
ds forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE Exp
f (Name -> Exp
VarE Name
x)) ([Exp] -> Exp
ListE [])
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
e
type U = StateT (Map Type Dec, Map Type Bool) Q
instance Quasi U where
qNewName :: String -> U Name
qNewName = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quasi m => String -> m Name
qNewName
qReport :: Bool -> String -> U ()
qReport Bool
b = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
b
qRecover :: forall a. U a -> U a -> U a
qRecover = forall a. HasCallStack => String -> a
error String
"Data.Generics.Geniplate: qRecover not implemented"
qReify :: Name -> U Info
qReify = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quasi m => Name -> m Info
qReify
#if MIN_VERSION_template_haskell(2,7,0)
qReifyInstances :: Name -> [Type] -> U [Dec]
qReifyInstances Name
n = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quasi m => Name -> [Type] -> m [Dec]
qReifyInstances Name
n
#elif MIN_VERSION_template_haskell(2,5,0)
qClassInstances n = lift . qClassInstances n
#endif
qLocation :: U Loc
qLocation = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). Quasi m => m Loc
qLocation
qRunIO :: forall a. IO a -> U a
qRunIO = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO
#if MIN_VERSION_template_haskell(2,14,0)
qAddForeignFilePath :: ForeignSrcLang -> String -> U ()
qAddForeignFilePath ForeignSrcLang
l = forall a. HasCallStack => a
undefined
#elif MIN_VERSION_template_haskell(2,12,0)
qAddForeignFile l = undefined
#endif
#if MIN_VERSION_template_haskell(2,7,0)
qLookupName :: Bool -> String -> U (Maybe Name)
qLookupName Bool
ns = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quasi m => Bool -> String -> m (Maybe Name)
qLookupName Bool
ns
qAddDependentFile :: String -> U ()
qAddDependentFile = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quasi m => String -> m ()
qAddDependentFile
#if MIN_VERSION_template_haskell(2,9,0)
qReifyRoles :: Name -> U [Role]
qReifyRoles = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quasi m => Name -> m [Role]
qReifyRoles
qReifyAnnotations :: forall a. Data a => AnnLookup -> U [a]
qReifyAnnotations = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. (Quasi m, Data a) => AnnLookup -> m [a]
qReifyAnnotations
qReifyModule :: Module -> U ModuleInfo
qReifyModule = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quasi m => Module -> m ModuleInfo
qReifyModule
qAddTopDecls :: [Dec] -> U ()
qAddTopDecls = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quasi m => [Dec] -> m ()
qAddTopDecls
qAddModFinalizer :: Q () -> U ()
qAddModFinalizer = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quasi m => Q () -> m ()
qAddModFinalizer
qGetQ :: forall a. Typeable a => U (Maybe a)
qGetQ = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *) a. (Quasi m, Typeable a) => m (Maybe a)
qGetQ
qPutQ :: forall a. Typeable a => a -> U ()
qPutQ = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. (Quasi m, Typeable a) => a -> m ()
qPutQ
#if MIN_VERSION_template_haskell(2,11,0)
qReifyFixity :: Name -> U (Maybe Fixity)
qReifyFixity = forall a. HasCallStack => a
undefined
qReifyConStrictness :: Name -> U [DecidedStrictness]
qReifyConStrictness = forall a. HasCallStack => a
undefined
qIsExtEnabled :: Extension -> U Bool
qIsExtEnabled = forall a. HasCallStack => a
undefined
qExtsEnabled :: U [Extension]
qExtsEnabled = forall a. HasCallStack => a
undefined
#if MIN_VERSION_template_haskell(2,13,0)
qAddCorePlugin :: String -> U ()
qAddCorePlugin = forall a. HasCallStack => a
undefined
#if MIN_VERSION_template_haskell(2,14,0)
qAddTempFile :: String -> U String
qAddTempFile = forall a. HasCallStack => a
undefined
#if MIN_VERSION_template_haskell(2,16,0)
qReifyType :: Name -> U Type
qReifyType = forall a. HasCallStack => a
undefined
#endif
#endif
#endif
#endif
#endif
#endif
uniBiQ :: [TypeQ] -> Type -> Type -> Q ([Dec], Exp)
uniBiQ :: [TypeQ] -> Type -> Type -> Q ([Dec], Exp)
uniBiQ [TypeQ]
stops Type
from Type
ato = do
[Type]
ss <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [TypeQ]
stops
Type
to <- forall (q :: * -> *). Quasi q => Type -> q Type
expandSyn Type
ato
(Exp
f, (Map Type Dec
m, Map Type Bool
_)) <- forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Type -> Type -> U Exp
uniBi Type
from Type
to) (forall a b. Map a b
mEmpty, forall a b. [(a, b)] -> Map a b
mFromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
ss (forall a. a -> [a]
repeat Bool
False))
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. Map a b -> [b]
mElems Map Type Dec
m, Exp
f)
uniBi :: Type -> Type -> U Exp
uniBi :: Type -> Type -> U Exp
uniBi Type
afrom Type
to = do
(Map Type Dec
m, Map Type Bool
c) <- forall s (m :: * -> *). MonadState s m => m s
get
Type
from <- forall (q :: * -> *). Quasi q => Type -> q Type
expandSyn Type
afrom
case forall a b. Eq a => a -> Map a b -> Maybe b
mLookup Type
from Map Type Dec
m of
Just (FunD Name
n [Clause]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
n
Maybe Dec
_ -> do
Name
f <- forall (m :: * -> *). Quasi m => String -> m Name
qNewName String
"_f"
let mkRec :: StateT (Map Type Dec, Map Type Bool) Q [Clause]
mkRec = do
forall s (m :: * -> *). MonadState s m => s -> m ()
put (forall a b. Eq a => a -> b -> Map a b -> Map a b
mInsert Type
from (Name -> [Clause] -> Dec
FunD Name
f [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB forall a b. (a -> b) -> a -> b
$ [Maybe Exp] -> Exp
TupE []) []]) Map Type Dec
m, Map Type Bool
c)
Type -> Type -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
uniBiCase Type
from Type
to
[Clause]
cs <- if Type
from forall a. Eq a => a -> a -> Bool
== Type
to then do
Bool
b <- Type -> Type -> U Bool
contains' Type
to Type
from
if Bool
b then do
Name
g <- forall (m :: * -> *). Quasi m => String -> m Name
qNewName String
"_g"
[Clause]
gcs <- StateT (Map Type Dec, Map Type Bool) Q [Clause]
mkRec
let dg :: Dec
dg = Name -> [Clause] -> Dec
FunD Name
g [Clause]
gcs
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \ (Map Type Dec
m', Map Type Bool
c') -> (forall a b. Eq a => a -> b -> Map a b -> Map a b
mInsert (Name -> Type
ConT Name
g) Dec
dg Map Type Dec
m', Map Type Bool
c')
Q [Dec] -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
unFun [d| f _x _r = _x : $(return (VarE g)) _x _r |]
else
Q [Dec] -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
unFun [d| f _x _r = _x : _r |]
else do
Bool
b <- Type -> Type -> U Bool
contains Type
to Type
from
if Bool
b then do
StateT (Map Type Dec, Map Type Bool) Q [Clause]
mkRec
else
Q [Dec] -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
unFun [d| f _ _r = _r |]
let d :: Dec
d = Name -> [Clause] -> Dec
FunD Name
f [Clause]
cs
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \ (Map Type Dec
m', Map Type Bool
c') -> (forall a b. Eq a => a -> b -> Map a b -> Map a b
mInsert Type
from Dec
d Map Type Dec
m', Map Type Bool
c')
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
f
contains :: Type -> Type -> U Bool
contains :: Type -> Type -> U Bool
contains Type
to Type
afrom = do
Type
from <- forall (q :: * -> *). Quasi q => Type -> q Type
expandSyn Type
afrom
if Type
from forall a. Eq a => a -> a -> Bool
== Type
to then
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else do
Map Type Bool
c <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a, b) -> b
snd
case forall a. Type -> Map Type a -> Maybe a
mLookupSplits Type
from Map Type Bool
c of
Just Bool
b -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
b
Maybe Bool
Nothing -> Type -> Type -> U Bool
contains' Type
to Type
from
mLookupSplits :: Type -> Map Type a -> Maybe a
mLookupSplits :: forall a. Type -> Map Type a -> Maybe a
mLookupSplits Type
ty Map Type a
m = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [ forall a b. Eq a => a -> Map a b -> Maybe b
mLookup Type
ty' Map Type a
m | Type
ty' <- Type -> [Type]
splits Type
ty ]
where
splits :: Type -> [Type]
splits t :: Type
t@(AppT Type
u Type
_) = Type
tforall a. a -> [a] -> [a]
:Type -> [Type]
splits Type
u
splits Type
t = [Type
t]
contains' :: Type -> Type -> U Bool
contains' :: Type -> Type -> U Bool
contains' Type
to Type
from = do
let (Type
con, [Type]
ts) = Type -> (Type, [Type])
splitTypeApp Type
from
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \ (Map Type Dec
m, Map Type Bool
c) -> (Map Type Dec
m, forall a b. Eq a => a -> b -> Map a b -> Map a b
mInsert Type
from Bool
False Map Type Bool
c)
Bool
b <- case Type
con of
ConT Name
n -> Name -> Type -> [Type] -> U Bool
containsCon Name
n Type
to [Type]
ts
TupleT Int
_ -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *). Foldable t => t Bool -> Bool
or forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type -> Type -> U Bool
contains Type
to) [Type]
ts
Type
ArrowT -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Type
ListT -> if Type
to forall a. Eq a => a -> a -> Bool
== Type
from then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True else Type -> Type -> U Bool
contains Type
to (forall a. [a] -> a
head [Type]
ts)
VarT Name
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Type
t -> forall a. String -> a
genError forall a b. (a -> b) -> a -> b
$ String
"contains: unexpected type: " forall a. [a] -> [a] -> [a]
++ forall a. Ppr a => a -> String
pprint Type
from forall a. [a] -> [a] -> [a]
++ String
" (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Type
t forall a. [a] -> [a] -> [a]
++ String
")"
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \ (Map Type Dec
m, Map Type Bool
c) -> (Map Type Dec
m, forall a b. Eq a => a -> b -> Map a b -> Map a b
mInsert Type
from Bool
b Map Type Bool
c)
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
b
containsCon :: Name -> Type -> [Type] -> U Bool
containsCon :: Name -> Type -> [Type] -> U Bool
containsCon Name
con Type
to [Type]
ts = do
([TyVarBndr ()]
tvs, [Con]
cons) <- forall (q :: * -> *). Quasi q => Name -> q ([TyVarBndr ()], [Con])
getTyConInfo Name
con
let conCon :: Con -> U Bool
conCon (NormalC Name
_ [BangType]
xs) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *). Foldable t => t Bool -> Bool
or forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type -> U Bool
field forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [BangType]
xs
conCon (InfixC BangType
x1 Name
_ BangType
x2) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *). Foldable t => t Bool -> Bool
or forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> U Bool
field [forall a b. (a, b) -> b
snd BangType
x1, forall a b. (a, b) -> b
snd BangType
x2]
conCon (RecC Name
_ [VarBangType]
xs) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *). Foldable t => t Bool -> Bool
or forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> U Bool
field [ Type
t | (Name
_,Bang
_,Type
t) <- [VarBangType]
xs ]
conCon Con
c = forall a. String -> a
genError forall a b. (a -> b) -> a -> b
$ String
"containsCon: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Con
c
s :: Subst
s = forall a. [TyVarBndr a] -> [Type] -> Subst
mkSubst [TyVarBndr ()]
tvs [Type]
ts
field :: Type -> U Bool
field Type
t = Type -> Type -> U Bool
contains Type
to (Subst -> Type -> Type
subst Subst
s Type
t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *). Foldable t => t Bool -> Bool
or forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Con -> U Bool
conCon [Con]
cons
unFunD :: [Dec] -> [Clause]
unFunD :: [Dec] -> [Clause]
unFunD [FunD Name
_ [Clause]
cs] = [Clause]
cs
unFunD [Dec]
_ = forall a. String -> a
genError forall a b. (a -> b) -> a -> b
$ String
"unFunD"
unFun :: Q [Dec] -> U [Clause]
unFun :: Q [Dec] -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
unFun = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Dec] -> [Clause]
unFunD
uniBiCase :: Type -> Type -> U [Clause]
uniBiCase :: Type -> Type -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
uniBiCase Type
from Type
to = do
let (Type
con, [Type]
ts) = Type -> (Type, [Type])
splitTypeApp Type
from
case Type
con of
ConT Name
n -> Name
-> [Type]
-> Type
-> StateT (Map Type Dec, Map Type Bool) Q [Clause]
uniBiCon Name
n [Type]
ts Type
to
TupleT Int
_ -> [Type] -> Type -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
uniBiTuple [Type]
ts Type
to
Type
ListT -> Type -> Type -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
uniBiList (forall a. [a] -> a
head [Type]
ts) Type
to
Type
t -> forall a. String -> a
genError forall a b. (a -> b) -> a -> b
$ String
"uniBiCase: unexpected type: " forall a. [a] -> [a] -> [a]
++ forall a. Ppr a => a -> String
pprint Type
from forall a. [a] -> [a] -> [a]
++ String
" (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Type
t forall a. [a] -> [a] -> [a]
++ String
")"
uniBiList :: Type -> Type -> U [Clause]
uniBiList :: Type -> Type -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
uniBiList Type
t Type
to = do
Exp
uni <- Type -> Type -> U Exp
uniBi Type
t Type
to
Exp
rec <- Type -> Type -> U Exp
uniBi (Type -> Type -> Type
AppT Type
ListT Type
t) Type
to
Q [Dec] -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
unFun [d| f [] _r = _r; f (_x:_xs) _r = $(return uni) _x ($(return rec) _xs _r) |]
uniBiTuple :: [Type] -> Type -> U [Clause]
uniBiTuple :: [Type] -> Type -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
uniBiTuple [Type]
ts Type
to = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> [a] -> [a]
:[]) forall a b. (a -> b) -> a -> b
$ Type -> Subst -> ([Pat] -> Pat) -> [Type] -> U Clause
mkArm Type
to [] [Pat] -> Pat
TupP [Type]
ts
uniBiCon :: Name -> [Type] -> Type -> U [Clause]
uniBiCon :: Name
-> [Type]
-> Type
-> StateT (Map Type Dec, Map Type Bool) Q [Clause]
uniBiCon Name
con [Type]
ts Type
to = do
([TyVarBndr ()]
tvs, [Con]
cons) <- forall (q :: * -> *). Quasi q => Name -> q ([TyVarBndr ()], [Con])
getTyConInfo Name
con
let genArm :: Con -> U Clause
genArm (NormalC Name
c [BangType]
xs) = forall {a}. ([Pat] -> Pat) -> [(a, Type)] -> U Clause
arm (Name -> [Pat] -> Pat
conP Name
c) [BangType]
xs
genArm (InfixC BangType
x1 Name
c BangType
x2) = forall {a}. ([Pat] -> Pat) -> [(a, Type)] -> U Clause
arm (\ [Pat
p1, Pat
p2] -> Pat -> Name -> Pat -> Pat
InfixP Pat
p1 Name
c Pat
p2) [BangType
x1, BangType
x2]
genArm (RecC Name
c [VarBangType]
xs) = forall {a}. ([Pat] -> Pat) -> [(a, Type)] -> U Clause
arm (Name -> [Pat] -> Pat
conP Name
c) [ (Bang
b,Type
t) | (Name
_,Bang
b,Type
t) <- [VarBangType]
xs ]
genArm Con
c = forall a. String -> a
genError forall a b. (a -> b) -> a -> b
$ String
"uniBiCon: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Con
c
s :: Subst
s = forall a. [TyVarBndr a] -> [Type] -> Subst
mkSubst [TyVarBndr ()]
tvs [Type]
ts
arm :: ([Pat] -> Pat) -> [(a, Type)] -> U Clause
arm [Pat] -> Pat
c [(a, Type)]
xs = Type -> Subst -> ([Pat] -> Pat) -> [Type] -> U Clause
mkArm Type
to Subst
s [Pat] -> Pat
c forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(a, Type)]
xs
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Con]
cons then
Q [Dec] -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
unFun [d| f _ _r = _r |]
else
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Con -> U Clause
genArm [Con]
cons
mkArm :: Type -> Subst -> ([Pat] -> Pat) -> [Type] -> U Clause
mkArm :: Type -> Subst -> ([Pat] -> Pat) -> [Type] -> U Clause
mkArm Type
to Subst
s [Pat] -> Pat
c [Type]
ts = do
Name
r <- forall (m :: * -> *). Quasi m => String -> m Name
qNewName String
"_r"
[Name]
vs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quasi m => String -> m Name
qNewName String
"_x") [Type]
ts
let sub :: Name -> Type -> StateT (Map Type Dec, Map Type Bool) Q (Exp -> Exp)
sub Name
v Type
t = do
let t' :: Type
t' = Subst -> Type -> Type
subst Subst
s Type
t
Exp
uni <- Type -> Type -> U Exp
uniBi Type
t' Type
to
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE Exp
uni (Name -> Exp
VarE Name
v))
[Exp -> Exp]
es <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Name -> Type -> StateT (Map Type Dec, Map Type Bool) Q (Exp -> Exp)
sub [Name]
vs [Type]
ts
let body :: Exp
body = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a b. (a -> b) -> a -> b
($) (Name -> Exp
VarE Name
r) [Exp -> Exp]
es
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [[Pat] -> Pat
c (forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
vs), Name -> Pat
VarP Name
r] (Exp -> Body
NormalB Exp
body) []
type Subst = [(Name, Type)]
#if MIN_VERSION_template_haskell(2,17,0)
mkSubst :: [TyVarBndr a] -> [Type] -> Subst
#else
mkSubst :: [TyVarBndr] -> [Type] -> Subst
#endif
mkSubst :: forall a. [TyVarBndr a] -> [Type] -> Subst
mkSubst [TyVarBndr a]
vs [Type]
ts =
let vs' :: [Name]
vs' = forall a b. (a -> b) -> [a] -> [b]
map forall {flag}. TyVarBndr flag -> Name
un [TyVarBndr a]
vs
#if MIN_VERSION_template_haskell(2,17,0)
un :: TyVarBndr flag -> Name
un (PlainTV Name
v flag
_) = Name
v
un (KindedTV Name
v flag
_ Type
_) = Name
v
#else
un (PlainTV v) = v
un (KindedTV v _) = v
#endif
in forall a. HasCallStack => Bool -> a -> a
assert (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
vs' forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ts) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
vs' [Type]
ts
subst :: Subst -> Type -> Type
subst :: Subst -> Type -> Type
subst Subst
s (ForallT [TyVarBndr Specificity]
v [Type]
c Type
t) = [TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT [TyVarBndr Specificity]
v [Type]
c forall a b. (a -> b) -> a -> b
$ Subst -> Type -> Type
subst Subst
s Type
t
subst Subst
s t :: Type
t@(VarT Name
n) = forall a. a -> Maybe a -> a
fromMaybe Type
t forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
n Subst
s
subst Subst
s (AppT Type
t1 Type
t2) = Type -> Type -> Type
AppT (Subst -> Type -> Type
subst Subst
s Type
t1) (Subst -> Type -> Type
subst Subst
s Type
t2)
subst Subst
s (SigT Type
t Type
k) = Type -> Type -> Type
SigT (Subst -> Type -> Type
subst Subst
s Type
t) Type
k
subst Subst
_ Type
t = Type
t
#if MIN_VERSION_template_haskell(2,17,0)
getTyConInfo :: (Quasi q) => Name -> q ([TyVarBndr ()], [Con])
#else
getTyConInfo :: (Quasi q) => Name -> q ([TyVarBndr], [Con])
#endif
getTyConInfo :: forall (q :: * -> *). Quasi q => Name -> q ([TyVarBndr ()], [Con])
getTyConInfo Name
con = do
Info
info <- forall (m :: * -> *). Quasi m => Name -> m Info
qReify Name
con
case Info
info of
#if MIN_VERSION_template_haskell(2,11,0)
TyConI (DataD [Type]
_ Name
_ [TyVarBndr ()]
tvs Maybe Type
_ [Con]
cs [DerivClause]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVarBndr ()]
tvs, [Con]
cs)
TyConI (NewtypeD [Type]
_ Name
_ [TyVarBndr ()]
tvs Maybe Type
_ Con
c [DerivClause]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVarBndr ()]
tvs, [Con
c])
#else
TyConI (DataD _ _ tvs cs _) -> return (tvs, cs)
TyConI (NewtypeD _ _ tvs c _) -> return (tvs, [c])
#endif
PrimTyConI{} -> forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
Info
i -> forall a. String -> a
genError forall a b. (a -> b) -> a -> b
$ String
"unexpected TyCon: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Info
i
#if MIN_VERSION_template_haskell(2,17,0)
splitType :: (Quasi q) => Type -> q ([TyVarBndr Specificity], Type, Type)
#else
splitType :: (Quasi q) => Type -> q ([TyVarBndr], Type, Type)
#endif
splitType :: forall (q :: * -> *).
Quasi q =>
Type -> q ([TyVarBndr Specificity], Type, Type)
splitType Type
t =
case Type
t of
(ForallT [TyVarBndr Specificity]
tvs [Type]
_ Type
t) -> do
([TyVarBndr Specificity]
tvs', Type
from, Type
to) <- forall (q :: * -> *).
Quasi q =>
Type -> q ([TyVarBndr Specificity], Type, Type)
splitType Type
t
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVarBndr Specificity]
tvs forall a. [a] -> [a] -> [a]
++ [TyVarBndr Specificity]
tvs', Type
from, Type
to)
(AppT (AppT Type
ArrowT Type
from) Type
to) -> forall (m :: * -> *) a. Monad m => a -> m a
return ([], Type
from, Type
to)
Type
_ -> forall a. String -> a
genError forall a b. (a -> b) -> a -> b
$ String
"Type is not an arrow: " forall a. [a] -> [a] -> [a]
++ forall a. Ppr a => a -> String
pprint Type
t
#if MIN_VERSION_template_haskell(2,17,0)
getNameType :: (Quasi q) => Name -> q ([TyVarBndr Specificity], Type, Type)
#else
getNameType :: (Quasi q) => Name -> q ([TyVarBndr], Type, Type)
#endif
getNameType :: forall (q :: * -> *).
Quasi q =>
Name -> q ([TyVarBndr Specificity], Type, Type)
getNameType Name
name = do
Info
info <- forall (m :: * -> *). Quasi m => Name -> m Info
qReify Name
name
case Info
info of
#if MIN_VERSION_template_haskell(2,11,0)
VarI Name
_ Type
t Maybe Dec
_ -> forall (q :: * -> *).
Quasi q =>
Type -> q ([TyVarBndr Specificity], Type, Type)
splitType Type
t
#else
VarI _ t _ _ -> splitType t
#endif
Info
_ -> forall a. String -> a
genError forall a b. (a -> b) -> a -> b
$ String
"Name is not variable: " forall a. [a] -> [a] -> [a]
++ forall a. Ppr a => a -> String
pprint Name
name
unList :: Type -> Type
unList :: Type -> Type
unList (AppT (ConT Name
n) Type
t) | Name
n forall a. Eq a => a -> a -> Bool
== ''[] = Type
t
unList (AppT Type
ListT Type
t) = Type
t
unList Type
t = forall a. String -> a
genError forall a b. (a -> b) -> a -> b
$ String
"universeBi: Type is not a list: " forall a. [a] -> [a] -> [a]
++ forall a. Ppr a => a -> String
pprint Type
t
splitTypeApp :: Type -> (Type, [Type])
splitTypeApp :: Type -> (Type, [Type])
splitTypeApp (AppT Type
a Type
r) = (Type
c, [Type]
rs forall a. [a] -> [a] -> [a]
++ [Type
r]) where (Type
c, [Type]
rs) = Type -> (Type, [Type])
splitTypeApp Type
a
splitTypeApp Type
t = (Type
t, [])
expandSyn :: (Quasi q) => Type -> q Type
expandSyn :: forall (q :: * -> *). Quasi q => Type -> q Type
expandSyn (ForallT [TyVarBndr Specificity]
tvs [Type]
ctx Type
t) = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ([TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT [TyVarBndr Specificity]
tvs [Type]
ctx) forall a b. (a -> b) -> a -> b
$ forall (q :: * -> *). Quasi q => Type -> q Type
expandSyn Type
t
expandSyn t :: Type
t@AppT{} = forall (q :: * -> *). Quasi q => Type -> [Type] -> q Type
expandSynApp Type
t []
expandSyn t :: Type
t@ConT{} = forall (q :: * -> *). Quasi q => Type -> [Type] -> q Type
expandSynApp Type
t []
expandSyn (SigT Type
t Type
k) = forall (q :: * -> *). Quasi q => Type -> q Type
expandSyn Type
t
expandSyn Type
t = forall (m :: * -> *) a. Monad m => a -> m a
return Type
t
expandSynApp :: (Quasi q) => Type -> [Type] -> q Type
expandSynApp :: forall (q :: * -> *). Quasi q => Type -> [Type] -> q Type
expandSynApp (AppT Type
t1 Type
t2) [Type]
ts = do Type
t2' <- forall (q :: * -> *). Quasi q => Type -> q Type
expandSyn Type
t2; forall (q :: * -> *). Quasi q => Type -> [Type] -> q Type
expandSynApp Type
t1 (Type
t2'forall a. a -> [a] -> [a]
:[Type]
ts)
expandSynApp (ConT Name
n) [Type]
ts | Name -> String
nameBase Name
n forall a. Eq a => a -> a -> Bool
== String
"[]" = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT Type
ListT [Type]
ts
expandSynApp t :: Type
t@(ConT Name
n) [Type]
ts = do
Info
info <- forall (m :: * -> *). Quasi m => Name -> m Info
qReify Name
n
case Info
info of
TyConI (TySynD Name
_ [TyVarBndr ()]
tvs Type
rhs) ->
let ([Type]
ts', [Type]
ts'') = forall a. Int -> [a] -> ([a], [a])
splitAt (forall (t :: * -> *) a. Foldable t => t a -> Int
length [TyVarBndr ()]
tvs) [Type]
ts
s :: Subst
s = forall a. [TyVarBndr a] -> [Type] -> Subst
mkSubst [TyVarBndr ()]
tvs [Type]
ts'
rhs' :: Type
rhs' = Subst -> Type -> Type
subst Subst
s Type
rhs
in forall (q :: * -> *). Quasi q => Type -> [Type] -> q Type
expandSynApp Type
rhs' [Type]
ts''
Info
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT Type
t [Type]
ts
expandSynApp Type
t [Type]
ts = do Type
t' <- forall (q :: * -> *). Quasi q => Type -> q Type
expandSyn Type
t; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT Type
t' [Type]
ts
genError :: String -> a
genError :: forall a. String -> a
genError String
msg = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Data.Generics.Geniplate: " forall a. [a] -> [a] -> [a]
++ String
msg
genTransformBi :: Name
-> Q Exp
genTransformBi :: Name -> Q Exp
genTransformBi = [TypeQ] -> Name -> Q Exp
genTransformBiT []
genTransformBi' :: TypeQ -> Q Exp
genTransformBi' :: TypeQ -> Q Exp
genTransformBi' = [TypeQ] -> TypeQ -> Q Exp
genTransformBiT' []
genTransformBiT :: [TypeQ] -> Name -> Q Exp
genTransformBiT :: [TypeQ] -> Name -> Q Exp
genTransformBiT = RetAp -> [TypeQ] -> Name -> Q Exp
transformBiG RetAp
raNormal
genTransformBiT' :: [TypeQ] -> TypeQ -> Q Exp
genTransformBiT' :: [TypeQ] -> TypeQ -> Q Exp
genTransformBiT' = RetAp -> [TypeQ] -> TypeQ -> Q Exp
transformBiG' RetAp
raNormal
raNormal :: RetAp
raNormal :: RetAp
raNormal = (forall a. a -> a
id, Exp -> Exp -> Exp
AppE, Exp -> Exp -> Exp
AppE)
genTransformBiM :: Name -> Q Exp
genTransformBiM :: Name -> Q Exp
genTransformBiM = [TypeQ] -> Name -> Q Exp
genTransformBiMT []
genTransformBiM' :: TypeQ -> Q Exp
genTransformBiM' :: TypeQ -> Q Exp
genTransformBiM' = [TypeQ] -> TypeQ -> Q Exp
genTransformBiMT' []
genTransformBiMT :: [TypeQ] -> Name -> Q Exp
genTransformBiMT :: [TypeQ] -> Name -> Q Exp
genTransformBiMT = RetAp -> [TypeQ] -> Name -> Q Exp
transformBiG RetAp
raMonad
genTransformBiMT' :: [TypeQ] -> TypeQ -> Q Exp
genTransformBiMT' :: [TypeQ] -> TypeQ -> Q Exp
genTransformBiMT' = RetAp -> [TypeQ] -> TypeQ -> Q Exp
transformBiG' RetAp
raMonad
raMonad :: RetAp
raMonad :: RetAp
raMonad = (Exp -> Exp
eret, Exp -> Exp -> Exp
eap, Exp -> Exp -> Exp
emap)
where eret :: Exp -> Exp
eret Exp
e = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Control.Monad.return) Exp
e
eap :: Exp -> Exp -> Exp
eap Exp
f Exp
a = Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Control.Monad.ap) Exp
f) Exp
a
emap :: Exp -> Exp -> Exp
emap Exp
f Exp
a = Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE '(Control.Monad.=<<)) Exp
f) Exp
a
type RetAp = (Exp -> Exp, Exp -> Exp -> Exp, Exp -> Exp -> Exp)
transformBiG :: RetAp -> [TypeQ] -> Name -> Q Exp
transformBiG :: RetAp -> [TypeQ] -> Name -> Q Exp
transformBiG RetAp
ra [TypeQ]
stops = forall (q :: * -> *).
Quasi q =>
Name -> q ([TyVarBndr Specificity], Type, Type)
getNameType forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall t. Mode -> RetAp -> [TypeQ] -> (t, Type, Type) -> Q Exp
transformBiGsplit Mode
MTransformBi RetAp
ra [TypeQ]
stops
transformBiG' :: RetAp -> [TypeQ] -> TypeQ -> Q Exp
transformBiG' :: RetAp -> [TypeQ] -> TypeQ -> Q Exp
transformBiG' RetAp
ra [TypeQ]
stops TypeQ
q = TypeQ
q forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (q :: * -> *).
Quasi q =>
Type -> q ([TyVarBndr Specificity], Type, Type)
splitType forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall t. Mode -> RetAp -> [TypeQ] -> (t, Type, Type) -> Q Exp
transformBiGsplit Mode
MTransformBi RetAp
ra [TypeQ]
stops
transformBiGsplit :: Mode -> RetAp -> [TypeQ] -> (t, Type, Type) -> Q Exp
transformBiGsplit :: forall t. Mode -> RetAp -> [TypeQ] -> (t, Type, Type) -> Q Exp
transformBiGsplit Mode
doDescend RetAp
ra [TypeQ]
stops (t
_tvs,Type
fcn,Type
res) = do
Name
f <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"_f"
Name
x <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"_x"
([Dec]
ds, Exp
tr) <-
case (Type
fcn, Type
res) of
(AppT (AppT Type
ArrowT Type
s) Type
s', AppT (AppT Type
ArrowT Type
t) Type
t') | Type
s forall a. Eq a => a -> a -> Bool
== Type
s' Bool -> Bool -> Bool
&& Type
t forall a. Eq a => a -> a -> Bool
== Type
t' -> Mode -> RetAp -> [TypeQ] -> Name -> Type -> Type -> Q ([Dec], Exp)
trBiQ Mode
doDescend RetAp
ra [TypeQ]
stops Name
f Type
s Type
t
(AppT (AppT Type
ArrowT Type
s) (AppT Type
m Type
s'), AppT (AppT Type
ArrowT Type
t) (AppT Type
m' Type
t')) | Type
s forall a. Eq a => a -> a -> Bool
== Type
s' Bool -> Bool -> Bool
&& Type
t forall a. Eq a => a -> a -> Bool
== Type
t' Bool -> Bool -> Bool
&& Type
m forall a. Eq a => a -> a -> Bool
== Type
m' -> Mode -> RetAp -> [TypeQ] -> Name -> Type -> Type -> Q ([Dec], Exp)
trBiQ Mode
doDescend RetAp
ra [TypeQ]
stops Name
f Type
s Type
t
(Type, Type)
_ -> forall a. String -> a
genError forall a b. (a -> b) -> a -> b
$ String
"transformBi: malformed type: " forall a. [a] -> [a] -> [a]
++ forall a. Ppr a => a -> String
pprint (Type -> Type -> Type
AppT (Type -> Type -> Type
AppT Type
ArrowT Type
fcn) Type
res) forall a. [a] -> [a] -> [a]
++ String
", should have form (S->S) -> (T->T)"
let e :: Exp
e = [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
f, Name -> Pat
VarP Name
x] forall a b. (a -> b) -> a -> b
$ [Dec] -> Exp -> Exp
LetE [Dec]
ds forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE Exp
tr (Name -> Exp
VarE Name
x)
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
e
trBiQ :: Mode -> RetAp -> [TypeQ] -> Name -> Type -> Type -> Q ([Dec], Exp)
trBiQ :: Mode -> RetAp -> [TypeQ] -> Name -> Type -> Type -> Q ([Dec], Exp)
trBiQ Mode
doDescend RetAp
ra [TypeQ]
stops Name
f Type
aft Type
st = do
[Type]
ss <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [TypeQ]
stops
Type
ft <- forall (q :: * -> *). Quasi q => Type -> q Type
expandSyn Type
aft
(Exp
tr, (Map Type Dec
m, Map Type Bool
_)) <- forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Bool -> Mode -> RetAp -> Exp -> Type -> Type -> U Exp
trBi Bool
False Mode
doDescend RetAp
ra (Name -> Exp
VarE Name
f) Type
ft Type
st) (forall a b. Map a b
mEmpty, forall a b. [(a, b)] -> Map a b
mFromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
ss (forall a. a -> [a]
repeat Bool
False))
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. Map a b -> [b]
mElems Map Type Dec
m, Exp
tr)
trBi :: Bool -> Mode -> RetAp -> Exp -> Type -> Type -> U Exp
trBi :: Bool -> Mode -> RetAp -> Exp -> Type -> Type -> U Exp
trBi Bool
seenStop Mode
doDescend ra :: RetAp
ra@(Exp -> Exp
ret, Exp -> Exp -> Exp
_, Exp -> Exp -> Exp
rbind) Exp
f Type
ft Type
ast = do
(Map Type Dec
m, Map Type Bool
c) <- forall s (m :: * -> *). MonadState s m => m s
get
Type
st <- forall (q :: * -> *). Quasi q => Type -> q Type
expandSyn Type
ast
case forall a b. Eq a => a -> Map a b -> Maybe b
mLookup Type
st Map Type Dec
m of
Just (FunD Name
n [Clause]
_) -> do
if Mode
doDescend forall a. Eq a => a -> a -> Bool
== Mode
MDescend Bool -> Bool -> Bool
&& Type
ft forall a. Eq a => a -> a -> Bool
== Type
st then
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
f
else
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
n
Maybe Dec
_ -> do
Name
tr <- forall (m :: * -> *). Quasi m => String -> m Name
qNewName String
"_tr"
let mkRec :: Bool -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
mkRec Bool
same = do
forall s (m :: * -> *). MonadState s m => s -> m ()
put (forall a b. Eq a => a -> b -> Map a b -> Map a b
mInsert Type
st (Name -> [Clause] -> Dec
FunD Name
tr [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB forall a b. (a -> b) -> a -> b
$ [Maybe Exp] -> Exp
TupE []) []]) Map Type Dec
m, Map Type Bool
c)
Bool
-> Mode
-> RetAp
-> Exp
-> Type
-> Type
-> StateT (Map Type Dec, Map Type Bool) Q [Clause]
trBiCase Bool
same Mode
doDescend RetAp
ra Exp
f Type
ft Type
st
[Clause]
cs <- if Type
ft forall a. Eq a => a -> a -> Bool
== Type
st then do
Bool
b <- Type -> Type -> U Bool
contains' Type
ft Type
st
if Bool
b then do
Name
g <- forall (m :: * -> *). Quasi m => String -> m Name
qNewName String
"_g"
[Clause]
gcs <- Bool -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
mkRec Bool
True
let dg :: Dec
dg = Name -> [Clause] -> Dec
FunD Name
g [Clause]
gcs
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \ (Map Type Dec
m', Map Type Bool
c') -> (forall a b. Eq a => a -> b -> Map a b -> Map a b
mInsert (Name -> Type
ConT Name
g) Dec
dg Map Type Dec
m', Map Type Bool
c')
Name
x <- forall (m :: * -> *). Quasi m => String -> m Name
qNewName String
"_x"
let f' :: Exp -> Exp
f' = if Mode
doDescend forall a. Eq a => a -> a -> Bool
== Mode
MDescend then forall a. a -> a
id else Exp -> Exp -> Exp
rbind Exp
f
forall (m :: * -> *) a. Monad m => a -> m a
return [[Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
x] (Exp -> Body
NormalB forall a b. (a -> b) -> a -> b
$ Exp -> Exp
f' (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
g) (Name -> Exp
VarE Name
x))) []]
else do
Name
x <- forall (m :: * -> *). Quasi m => String -> m Name
qNewName String
"_x"
forall (m :: * -> *) a. Monad m => a -> m a
return [[Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
x] (Exp -> Body
NormalB forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE Exp
f (Name -> Exp
VarE Name
x)) []]
else do
Bool
b <- Type -> Type -> U Bool
contains Type
ft Type
st
if Bool
b then do
Bool -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
mkRec Bool
False
else do
Name
x <- forall (m :: * -> *). Quasi m => String -> m Name
qNewName String
"_x"
forall (m :: * -> *) a. Monad m => a -> m a
return [[Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
x] (Exp -> Body
NormalB forall a b. (a -> b) -> a -> b
$ Exp -> Exp
ret forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
x) []]
let d :: Dec
d = Name -> [Clause] -> Dec
FunD Name
tr [Clause]
cs
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \ (Map Type Dec
m', Map Type Bool
c') -> (forall a b. Eq a => a -> b -> Map a b -> Map a b
mInsert Type
st Dec
d Map Type Dec
m', Map Type Bool
c')
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
tr
trBiCase :: Bool -> Mode -> RetAp -> Exp -> Type -> Type -> U [Clause]
trBiCase :: Bool
-> Mode
-> RetAp
-> Exp
-> Type
-> Type
-> StateT (Map Type Dec, Map Type Bool) Q [Clause]
trBiCase Bool
seenStop Mode
doDescend RetAp
ra Exp
f Type
ft Type
st = do
let (Type
con, [Type]
ts) = Type -> (Type, [Type])
splitTypeApp Type
st
case Type
con of
ConT Name
n -> Bool
-> Mode
-> RetAp
-> Exp
-> Name
-> Type
-> Type
-> [Type]
-> StateT (Map Type Dec, Map Type Bool) Q [Clause]
trBiCon Bool
seenStop Mode
doDescend RetAp
ra Exp
f Name
n Type
ft Type
st [Type]
ts
TupleT Int
_ -> Bool
-> Mode
-> RetAp
-> Exp
-> Type
-> Type
-> [Type]
-> StateT (Map Type Dec, Map Type Bool) Q [Clause]
trBiTuple Bool
seenStop Mode
doDescend RetAp
ra Exp
f Type
ft Type
st [Type]
ts
Type
ListT -> Bool
-> Mode
-> RetAp
-> Exp
-> Type
-> Type
-> Type
-> StateT (Map Type Dec, Map Type Bool) Q [Clause]
trBiList Bool
seenStop Mode
doDescend RetAp
ra Exp
f Type
ft Type
st (forall a. [a] -> a
head [Type]
ts)
Type
_ -> forall a. String -> a
genError forall a b. (a -> b) -> a -> b
$ String
"trBiCase: unexpected type: " forall a. [a] -> [a] -> [a]
++ forall a. Ppr a => a -> String
pprint Type
st forall a. [a] -> [a] -> [a]
++ String
" (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Type
st forall a. [a] -> [a] -> [a]
++ String
")"
trBiList :: Bool -> Mode -> RetAp -> Exp -> Type -> Type -> Type -> U [Clause]
trBiList :: Bool
-> Mode
-> RetAp
-> Exp
-> Type
-> Type
-> Type
-> StateT (Map Type Dec, Map Type Bool) Q [Clause]
trBiList Bool
seenStop Mode
doDescend RetAp
ra Exp
f Type
ft Type
st Type
et = do
Clause
nil <- Bool
-> Mode
-> RetAp
-> Exp
-> Type
-> Type
-> Subst
-> ([Pat] -> Pat)
-> Exp
-> [Type]
-> U Clause
trMkArm Bool
seenStop Mode
doDescend RetAp
ra Exp
f Type
ft Type
st [] (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ [Pat] -> Pat
ListP []) ([Exp] -> Exp
ListE []) []
Clause
cons <- Bool
-> Mode
-> RetAp
-> Exp
-> Type
-> Type
-> Subst
-> ([Pat] -> Pat)
-> Exp
-> [Type]
-> U Clause
trMkArm Bool
seenStop Mode
doDescend RetAp
ra Exp
f Type
ft Type
st [] (Name -> [Pat] -> Pat
conP '(:)) (Name -> Exp
ConE '(:)) [Type
et, Type
st]
forall (m :: * -> *) a. Monad m => a -> m a
return [Clause
nil, Clause
cons]
trBiTuple :: Bool -> Mode -> RetAp -> Exp -> Type -> Type -> [Type] -> U [Clause]
trBiTuple :: Bool
-> Mode
-> RetAp
-> Exp
-> Type
-> Type
-> [Type]
-> StateT (Map Type Dec, Map Type Bool) Q [Clause]
trBiTuple Bool
seenStop Mode
doDescend RetAp
ra Exp
f Type
ft Type
st [Type]
ts = do
[Name]
vs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quasi m => String -> m Name
qNewName String
"_t") [Type]
ts
#if MIN_VERSION_template_haskell(2,16,0)
let tupE :: Exp
tupE = [Pat] -> Exp -> Exp
LamE (forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
vs) forall a b. (a -> b) -> a -> b
$ [Maybe Exp] -> Exp
TupE (forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE) [Name]
vs)
#else
let tupE = LamE (map VarP vs) $ TupE (map VarE vs)
#endif
Clause
c <- Bool
-> Mode
-> RetAp
-> Exp
-> Type
-> Type
-> Subst
-> ([Pat] -> Pat)
-> Exp
-> [Type]
-> U Clause
trMkArm Bool
seenStop Mode
doDescend RetAp
ra Exp
f Type
ft Type
st [] [Pat] -> Pat
TupP Exp
tupE [Type]
ts
forall (m :: * -> *) a. Monad m => a -> m a
return [Clause
c]
trBiCon :: Bool -> Mode -> RetAp -> Exp -> Name -> Type -> Type -> [Type] -> U [Clause]
trBiCon :: Bool
-> Mode
-> RetAp
-> Exp
-> Name
-> Type
-> Type
-> [Type]
-> StateT (Map Type Dec, Map Type Bool) Q [Clause]
trBiCon Bool
seenStop Mode
doDescend RetAp
ra Exp
f Name
con Type
ft Type
st [Type]
ts = do
([TyVarBndr ()]
tvs, [Con]
cons) <- forall (q :: * -> *). Quasi q => Name -> q ([TyVarBndr ()], [Con])
getTyConInfo Name
con
let genArm :: Con -> U Clause
genArm (NormalC Name
c [BangType]
xs) = forall {a}. ([Pat] -> Pat) -> Exp -> [(a, Type)] -> U Clause
arm (Name -> [Pat] -> Pat
conP Name
c) (Name -> Exp
ConE Name
c) [BangType]
xs
genArm (InfixC BangType
x1 Name
c BangType
x2) = forall {a}. ([Pat] -> Pat) -> Exp -> [(a, Type)] -> U Clause
arm (\ [Pat
p1, Pat
p2] -> Pat -> Name -> Pat -> Pat
InfixP Pat
p1 Name
c Pat
p2) (Name -> Exp
ConE Name
c) [BangType
x1, BangType
x2]
genArm (RecC Name
c [VarBangType]
xs) = forall {a}. ([Pat] -> Pat) -> Exp -> [(a, Type)] -> U Clause
arm (Name -> [Pat] -> Pat
conP Name
c) (Name -> Exp
ConE Name
c) [ (Bang
b,Type
t) | (Name
_,Bang
b,Type
t) <- [VarBangType]
xs ]
genArm Con
c = forall a. String -> a
genError forall a b. (a -> b) -> a -> b
$ String
"trBiCon: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Con
c
s :: Subst
s = forall a. [TyVarBndr a] -> [Type] -> Subst
mkSubst [TyVarBndr ()]
tvs [Type]
ts
arm :: ([Pat] -> Pat) -> Exp -> [(a, Type)] -> U Clause
arm [Pat] -> Pat
c Exp
ec [(a, Type)]
xs = Bool
-> Mode
-> RetAp
-> Exp
-> Type
-> Type
-> Subst
-> ([Pat] -> Pat)
-> Exp
-> [Type]
-> U Clause
trMkArm Bool
seenStop Mode
doDescend RetAp
ra Exp
f Type
ft Type
st Subst
s [Pat] -> Pat
c Exp
ec forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(a, Type)]
xs
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Con -> U Clause
genArm [Con]
cons
trMkArm :: Bool -> Mode -> RetAp -> Exp -> Type -> Type -> Subst -> ([Pat] -> Pat) -> Exp -> [Type] -> U Clause
trMkArm :: Bool
-> Mode
-> RetAp
-> Exp
-> Type
-> Type
-> Subst
-> ([Pat] -> Pat)
-> Exp
-> [Type]
-> U Clause
trMkArm Bool
seenStop Mode
doDescend ra :: RetAp
ra@(Exp -> Exp
ret, Exp -> Exp -> Exp
apl, Exp -> Exp -> Exp
_) Exp
f Type
ft Type
st Subst
s [Pat] -> Pat
c Exp
ec [Type]
ts = do
[Name]
vs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quasi m => String -> m Name
qNewName String
"_x") [Type]
ts
let sub :: Name -> Type -> U Exp
sub Name
v Type
t = do
if Bool
seenStop Bool -> Bool -> Bool
&& Mode
doDescend forall a. Eq a => a -> a -> Bool
== Mode
MDescendBi then do
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exp -> Exp
ret (Name -> Exp
VarE Name
v)
else do
let t' :: Type
t' = Subst -> Type -> Type
subst Subst
s Type
t
Exp
tr <- Bool -> Mode -> RetAp -> Exp -> Type -> Type -> U Exp
trBi Bool
seenStop Mode
doDescend RetAp
ra Exp
f Type
ft Type
t'
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE Exp
tr (Name -> Exp
VarE Name
v)
[Exp]
es <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Name -> Type -> U Exp
sub [Name]
vs [Type]
ts
let body :: Exp
body = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
apl (Exp -> Exp
ret Exp
ec) [Exp]
es
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [[Pat] -> Pat
c (forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
vs)] (Exp -> Body
NormalB Exp
body) []
newtype Map a b = Map [(a, b)]
mEmpty :: Map a b
mEmpty :: forall a b. Map a b
mEmpty = forall a b. [(a, b)] -> Map a b
Map []
mLookup :: (Eq a) => a -> Map a b -> Maybe b
mLookup :: forall a b. Eq a => a -> Map a b -> Maybe b
mLookup a
a (Map [(a, b)]
xys) = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
a [(a, b)]
xys
mInsert :: (Eq a) => a -> b -> Map a b -> Map a b
mInsert :: forall a b. Eq a => a -> b -> Map a b -> Map a b
mInsert a
a b
b (Map [(a, b)]
xys) = forall a b. [(a, b)] -> Map a b
Map forall a b. (a -> b) -> a -> b
$ (a
a, b
b) forall a. a -> [a] -> [a]
: forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
/= a
a) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(a, b)]
xys
mElems :: Map a b -> [b]
mElems :: forall a b. Map a b -> [b]
mElems (Map [(a, b)]
xys) = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(a, b)]
xys
mFromList :: [(a, b)] -> Map a b
mFromList :: forall a b. [(a, b)] -> Map a b
mFromList [(a, b)]
xys = forall a b. [(a, b)] -> Map a b
Map [(a, b)]
xys